add disposables

DESCRIPTION

@@ -1,9 +1,10 @@
 Package: testthatsomemore
 Title: A mocking, stubbing, and file testing framework extending testthat
-Version: 0.2.4
+Version: 0.2.5
 Maintainer: Robert Krzyzanowski <technoguyrob@gmail.com>
 Authors@R: c(person("Robert", "Krzyzanowski",
-    email = "technoguyrob@gmail.com", role = c("aut", "cre")))
+    email = "technoguyrob@gmail.com", role = c("aut", "cre")),
+    person("Gabor", "Csardi", email = "csardi.gabor@gmail.com", role = "ctb"))
 Description: This package intends to go above and beyond the features
     provided by the testthat package. Namely, stubbing of functions and methods
     is provided as well as the ability to architect mock structured hierarchies
@@ -12,7 +13,8 @@ Description: This package intends to go above and beyond the features
     raise the caliber of R testing frameworks to that of famous libraries
     like JUnit and RSpec.
 Depends:
-    R (>= 3.0.0)
+    R (>= 3.0.0),
+    methods
 Imports:
     testthat,
     crayon

NAMESPACE

@@ -3,13 +3,17 @@
 export("stub<-")
 export(assert)
 export(create_file_structure)
+export(dispose_packages)
 export(expect_is_directory)
 export(expect_is_file)
 export(is.directory)
+export(make_packages)
 export(package_stub)
 export(pending)
 export(pretend_now_is)
 export(touch)
 export(within_file_structure)
 import(testthat)
 importFrom(crayon,yellow)
+importFrom(methods,reconcilePropertiesAndPrototype)
+importFrom(utils,package.skeleton)

NEWS.md

@@ -1,3 +1,7 @@
+# Version 0.2.5
+
+  * Added `make_packages` and `dispose_packages` thanks to [gaborcsardi's disposables](https://github.com/gaborcsardi/disposables).
+
 # Version 0.2.2
 
   * Added the `pretend_now_is` time-stubbing helper.

R/disposables.R

@@ -0,0 +1,230 @@
+# Copied with gracious permission from gaborcsardi: https://github.com/gaborcsardi/disposables/issues/1
+
+#' @importFrom methods reconcilePropertiesAndPrototype
+NULL
+
+install_quietly <- TRUE
+
+with_wd <- function(dir, expr) {
+  wd <- getwd()
+  on.exit(setwd(wd))
+  setwd(dir)
+  eval(substitute(expr), envir = parent.frame())
+}
+
+build_pkg <- function(path, pkg_file = NULL) {
+  if (!file.exists(path)) stop("path does not exist")
+  pkg_name <- basename(path)
+  if (is.null(pkg_file)) {
+    pkg_file <- file.path(dirname(path), paste0(pkg_name, "_1.0.tar.gz"))
+  }
+  with_wd(dirname(path),
+          tar(basename(pkg_file), pkg_name, compression = "gzip"))
+  pkg_file
+}
+
+#' @importFrom utils package.skeleton
+
+install_tmp_pkg <- function(..., pkg_name, lib_dir, imports = character()) {
+  if (!file.exists(lib_dir)) stop("lib_dir does not exist")
+  if (!is.character(pkg_name) || length(pkg_name) != 1) {
+    stop("pkg_name is not a string")
+  }
+
+  ## Create a directory that will contain the source package
+  src_dir <- tempfile()
+  on.exit(try(unlink(src_dir, recursive = TRUE), silent = TRUE), add = TRUE)
+  dir.create(src_dir)
+
+  ## Create source package, need a non-empty environment,
+  ## otherwise package.skeleton fails
+  tmp_env <- new.env()
+  assign("f", function(x) x, envir = tmp_env)
+  suppressMessages(package.skeleton(pkg_name, path = src_dir,
+                                    environment = tmp_env))
+  pkg_dir <- file.path(src_dir, pkg_name)
+
+  ## Make it installable: remove man, add imports
+  unlink(file.path(pkg_dir, "man"), recursive = TRUE)
+  if (length(imports) != 0) {
+    cat("Imports: ", paste(imports, collapse = ", "), "\n",
+        file = file.path(pkg_dir, "DESCRIPTION"), append = TRUE)
+    cat(paste0("import(", imports, ")"), sep="\n",
+        file = file.path(pkg_dir, "NAMESPACE"), append = TRUE)
+  }
+
+  ## Put the code in it, dput is noisy, so we need to redirect it to
+  ## temporary file
+  exprs <- list(...)
+  unlink(file.path(pkg_dir, "R"), recursive = TRUE)
+  dir.create(file.path(pkg_dir, "R"))
+  code_file <- file.path(pkg_dir, "R", "code.R")
+  tmp_file <- tempfile()
+  on.exit(try(unlink(tmp_file), silent = TRUE), add = TRUE)
+  sapply(exprs, function(x)
+         cat(deparse(dput(x, file = tmp_file)),
+             file = code_file, append = TRUE, "\n", sep="\n"))
+
+  ## Build it
+  pkg_file <- build_pkg(pkg_dir)
+
+  ## Install it into the supplied lib_dir
+  install.packages(pkg_file, lib = lib_dir, repos = NULL, type = "source",
+                   quiet = install_quietly)
+}
+
+with_libpath <- function(lib_path, ...) {
+  cur_lib_path <- .libPaths()
+  on.exit(.libPaths(cur_lib_path), add = TRUE)
+  .libPaths(c(lib_path, cur_lib_path))
+  exprs <- c(as.list(match.call(expand.dots = FALSE)$...))
+  sapply(exprs, eval, envir = parent.frame())
+}
+
+#' Create, install, load and attach multiple disposable packages
+#'
+#' If a package with the same name as a disposable one, is
+#' loaded, then it will be unloaded. If a package with same name
+#' as a disposable on is installed in \code{lib_dir}, then
+#' it will be overwritten. (\code{lib_dir} is usually a temporary
+#' directory, so this is not a big problem.)
+#'
+#' @details
+#' Note that if you specify \code{lib_dir} and it points to an
+#' existing directory, \code{make_package} overwrites the packages
+#' there. If an error happens during installation or loading of
+#' the disposables packages, then it will \emph{not} restore the
+#' original contents of \code{lib_dir}, but it will remove
+#' all newly installed disposable packages, even the ones
+#' that were installed cleanly.
+#'
+#' @param ... Named expressions.
+#'   A separate package with the given name is created for each.
+#' @param lib_dir Directory to install the package to.
+#'   Defaults to a temporary directory that is
+#'   deleted once the R session is over.
+#' @param imports The 'Imports' field in the DESCRIPTION file,
+#'   the packages to import in each disposable package.
+#' @return A named list with entries: \itemize{
+#'     \item \code{lib_dir} The directory in which the packages are
+#'       installed.
+#'     \item \code{package} The named of the packages.
+#'   }
+#'
+#' @export
+#' @seealso \code{\link{dispose_packages}}
+#' @examples
+#' \donttest{
+#' pkg <- make_packages(
+#'   foo1 = { f <- function() print("hello!") ; d <- 1:10 },
+#'   foo2 = { f <- function() print("hello again!") ; d <- 11:20 }
+#' )
+#' foo1::f()
+#' foo2::f()
+#' foo1::d
+#' foo2::d
+#' dispose_packages(pkg)
+#' }
+
+make_packages <- function(..., lib_dir = tempfile(),
+                          imports = character()) {
+
+  remove_lib_dir <- !file.exists(lib_dir)
+  if (remove_lib_dir) dir.create(lib_dir)
+  exprs <- c(as.list(match.call(expand.dots = FALSE)$...))
+
+  pkgs <- list(lib_dir = lib_dir, packages = names(exprs))
+
+  ## Start clean
+  dispose_packages(pkgs, delete_lib_dir = FALSE)
+
+  ## Clean up on error
+  on.exit(dispose_packages(pkgs, delete_lib_dir = remove_lib_dir))
+
+  for (i in seq_along(exprs)) {
+    expr <- exprs[[i]]
+    name <- names(exprs)[i]
+    install_tmp_pkg(expr, pkg_name = name,
+                     lib_dir = lib_dir, imports = imports)
+    with_libpath(lib_dir, suppressMessages(library(name, quietly = TRUE,
+                                                   character.only = TRUE)))
+  }
+
+  on.exit()
+  pkgs
+}
+
+#' Get rid of temporary packages
+#'
+#' @param packages A list returned by \code{\link{make_packages}}.
+#' @param unattach Whether to unattach the packages.
+#' @param unload Whether to unload the packages. It is not possible to
+#'   unload without unattaching.
+#' @param delete Whether to delete the installed packages from the
+#'   \code{lib_dir}. If \code{delete_lib_dir} is \code{TRUE}, then
+#'   this should be \code{TRUE} as well.
+#' @param delete_lib_dir Whether to delete the the whole \code{lib_dir}.
+#'
+#' @export
+#' @examples
+#' \donttest{
+#' pkg <- make_packages(
+#'   foo1 = { f <- function() print("hello!") ; d <- 1:10 },
+#'   foo2 = { f <- function() print("hello again!") ; d <- 11:20 }
+#' )
+#'
+#' foo1::f()
+#' foo2::f()
+#' foo1::d
+#' foo2::d
+#'
+#' ## Unattach only
+#' dispose_packages(pkg, unload = FALSE, delete = FALSE)
+#' "package:foo1" %in% search()
+#' "foo1" %in% loadedNamespaces()
+#' dir(pkg$lib_dir)
+#'
+#' ## Unload
+#' dispose_packages(pkg, delete = FALSE)
+#' "package:foo1" %in% search()
+#' "foo1" %in% loadedNamespaces()
+#' dir(pkg$lib_dir)
+#'
+#' ## Delete completely
+#' dispose_packages(pkg)
+#' "package:foo1" %in% search()
+#' "foo1" %in% loadedNamespaces()
+#' file.exists(pkg$lib_dir)
+#' }
+
+dispose_packages <- function(packages, unattach = TRUE, unload = unattach,
+                             delete = TRUE, delete_lib_dir = delete) {
+
+  if (!unattach && unload) stop("Cannot unload without unattaching")
+  if (!delete && delete_lib_dir) {
+    stop("Cannot delete lib_dir without deleting packages")
+  }
+
+  if (unattach) {
+    for (n in packages$packages) {
+      pn <- paste0("package:", n)
+      if (pn %in% search()) detach(pn, character.only = TRUE)
+    }
+  }
+
+  if (unload) {
+    for (n in packages$packages) {
+      if (n %in% loadedNamespaces()) unloadNamespace(n)
+    }
+  }
+
+  if (delete_lib_dir) {
+    unlink(packages$lib_dir, recursive = TRUE)
+  } else if (delete) {
+    for (n in packages$packages) {
+      unlink(file.path(packages$lib_dir, n), recursive = TRUE)
+    }
+  }
+
+  invisible()
+}

README.md

@@ -7,6 +7,7 @@ in the R-sphere, but there are still some features lacking. `testthatsomemore` p
   * The ability to mock and stub functions and closures, including those in packages.
   * Creation of hierarchical file structures for testing of IO-related functions.
   * Pretending now is some other time, like Ruby's [Timecop gem](https://github.com/travisjeffery/timecop).
+  * Creating full directory mocks of R packages, thanks to [gaborcsardi](https://github.com/gaborcsardi/disposables).
   * Indicating that some tests are pending.
 
 To use, simply run:
@@ -112,6 +113,54 @@ pretend_now_is("2 months from now", {
 })
 ```
 
+Mocks of R packages
+------------------
+
+When developing R packages perform operations on other R packages, writing tests
+can be difficult since you have to simulate your functions on another package.
+
+Thanks to [gaborcsardi's disposables](https://github.com/gaborcsardi/disposables), 
+this is possible with `make_packages` and `dispose_packages`.
+
+```R
+test_that("inheritance works across packages", {
+
+  pkgs <- make_packages(
+    imports = "R6",
+
+    ## Code to put in package 'R6testA'
+    R6testA = {
+      AC <- R6Class(
+        public = list(
+          x = 1
+        )
+      )
+    },
+
+    ## Code to put in package 'R6testB'
+    R6testB = {
+      BC <- R6Class(
+        inherit = R6testA::AC,
+        public = list(
+          y = 2
+        )
+      )
+    }
+
+  )
+
+  ## In case of an error below
+  on.exit(try(dispose_packages(pkgs), silent = TRUE), add = TRUE)
+
+  ## Now ready for the tests
+  B <- BC$new()
+  expect_equal(B$x, 1)
+  expect_equal(B$y, 2)
+
+})
+```
+add README example
+
 Pending
 -------