From 08994d424eb3a849054593c336720cfe7c9530be Mon Sep 17 00:00:00 2001 From: RobertZK Date: Sat, 18 Apr 2015 16:38:34 -0500 Subject: [PATCH 1/4] add disposables --- DESCRIPTION | 3 +- R/disposables.R | 230 ++++++++++++++++++++++++++++++ tests/testthat/test-disposables.R | 127 +++++++++++++++++ 3 files changed, 359 insertions(+), 1 deletion(-) create mode 100644 R/disposables.R create mode 100644 tests/testthat/test-disposables.R diff --git a/DESCRIPTION b/DESCRIPTION index 9880837..d2121c7 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -3,7 +3,8 @@ Title: A mocking, stubbing, and file testing framework extending testthat Version: 0.2.4 Maintainer: Robert Krzyzanowski 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 diff --git a/R/disposables.R b/R/disposables.R new file mode 100644 index 0000000..4367888 --- /dev/null +++ b/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() +} diff --git a/tests/testthat/test-disposables.R b/tests/testthat/test-disposables.R new file mode 100644 index 0000000..1581ae1 --- /dev/null +++ b/tests/testthat/test-disposables.R @@ -0,0 +1,127 @@ +context("Cleaning up on error") + +test_that("We clean up if a package cannot be installed", { + + lib_dir <- tempfile() + try( + silent = TRUE, + suppressWarnings( + pkgs <- make_packages( + lib_dir = lib_dir, + foo1 = { f <- function() print("hello!") ; d <- 1:10 }, + foo2 = { "syntax error" + 10 + "here" } + ) + ) + ) + + expect_false("package:foo1" %in% search()) + expect_false("package:foo2" %in% search()) + expect_false(file.exists(lib_dir)) + +}) + +test_that("We clean up if a package cannot be loaded", { + + lib_dir <- tempfile() + try( + silent = TRUE, + suppressWarnings( + pkgs <- make_packages( + lib_dir = lib_dir, + foo1 = { f <- function() print("hello!") ; d <- 1:10 }, + foo2 = { .onLoad <- function() { "syntax error" + 10 + "here" } } + ) + ) + ) + + expect_false("package:foo1" %in% search()) + expect_false("package:foo2" %in% search()) + expect_false(file.exists(lib_dir)) + +}) + +context("Disposable packages") + +test_that("We can create and load them", { + + on.exit(dispose_packages(pkgs)) + pkgs <- make_packages( + foo1 = { f <- function() print("hello!") ; d <- 1:10 }, + foo2 = { f <- function() print("hello again!") ; d <- 11:20 } + ) + + expect_output(foo1::f(), "hello!", fixed = TRUE) + expect_output(foo2::f(), "hello again!", fixed = TRUE) + expect_equal(foo1::d, 1:10) + expect_equal(foo2::d, 11:20) + +}) + +test_that("We can dispose packages", { + + on.exit(dispose_packages(pkgs)) + pkgs <- make_packages( + foo1 = { f <- function() print("hello!") ; d <- 1:10 }, + foo2 = { f <- function() print("hello again!") ; d <- 11:20 } + ) + + ## Do nothing + dispose_packages(pkgs, unattach = FALSE, delete = FALSE) + expect_true("package:foo1" %in% search()) + expect_true("package:foo2" %in% search()) + expect_true("foo1" %in% loadedNamespaces()) + expect_true("foo2" %in% loadedNamespaces()) + expect_true("foo1" %in% dir(pkgs$lib_dir)) + expect_true("foo2" %in% dir(pkgs$lib_dir)) + + ## Unattach + dispose_packages(pkgs, unload = FALSE, delete = FALSE) + expect_false("package:foo1" %in% search()) + expect_false("package:foo2" %in% search()) + expect_true("foo1" %in% loadedNamespaces()) + expect_true("foo2" %in% loadedNamespaces()) + expect_true("foo1" %in% dir(pkgs$lib_dir)) + expect_true("foo2" %in% dir(pkgs$lib_dir)) + + ## Unload + dispose_packages(pkgs, delete = FALSE) + expect_false("package:foo1" %in% search()) + expect_false("package:foo2" %in% search()) + expect_false("foo1" %in% loadedNamespaces()) + expect_false("foo2" %in% loadedNamespaces()) + expect_true("foo1" %in% dir(pkgs$lib_dir)) + expect_true("foo2" %in% dir(pkgs$lib_dir)) + + ## Delete + dispose_packages(pkgs, delete_lib_dir = FALSE) + expect_false("foo1" %in% dir(pkgs$lib_dir)) + expect_false("foo2" %in% dir(pkgs$lib_dir)) + expect_true(file.exists(pkgs$lib_dir)) + + ## Clean up completely + dispose_packages(pkgs) + expect_false(file.exists(pkgs$lib_dir)) + +}) + +test_that("We unload a package if it is already loaded", { + + on.exit(dispose_packages(pkgs), add = TRUE) + pkgs <- make_packages( + foo1 = { f <- function() print("hello!") ; d <- 1:10 }, + foo2 = { f <- function() print("hello again!") ; d <- 11:20 } + ) + + on.exit(dispose_packages(pkgs2), add = TRUE) + pkgs2 <- make_packages( + foo1 = { f <- function() print("hello two!") ; d <- 1:100 }, + foo2 = { f <- function() print("hello two again!") ; d <- 11:200 } + ) + + expect_output(foo1::f(), "hello two!", fixed = TRUE) + expect_output(foo2::f(), "hello two again!", fixed = TRUE) + expect_equal(foo1::d, 1:100) + expect_equal(foo2::d, 11:200) + +}) + From 47f3bec3030a2c822d2c94870588461663d9897e Mon Sep 17 00:00:00 2001 From: RobertZK Date: Sat, 18 Apr 2015 16:39:23 -0500 Subject: [PATCH 2/4] update docs --- NAMESPACE | 4 +++ man/dispose_packages.Rd | 58 ++++++++++++++++++++++++++++++++++++++++ man/make_packages.Rd | 59 +++++++++++++++++++++++++++++++++++++++++ 3 files changed, 121 insertions(+) create mode 100644 man/dispose_packages.Rd create mode 100644 man/make_packages.Rd diff --git a/NAMESPACE b/NAMESPACE index 6ae752f..c95fdb7 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -3,9 +3,11 @@ 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) @@ -13,3 +15,5 @@ export(touch) export(within_file_structure) import(testthat) importFrom(crayon,yellow) +importFrom(methods,reconcilePropertiesAndPrototype) +importFrom(utils,package.skeleton) diff --git a/man/dispose_packages.Rd b/man/dispose_packages.Rd new file mode 100644 index 0000000..f543abf --- /dev/null +++ b/man/dispose_packages.Rd @@ -0,0 +1,58 @@ +% Generated by roxygen2 (4.1.0): do not edit by hand +% Please edit documentation in R/disposables.R +\name{dispose_packages} +\alias{dispose_packages} +\title{Get rid of temporary packages} +\usage{ +dispose_packages(packages, unattach = TRUE, unload = unattach, + delete = TRUE, delete_lib_dir = delete) +} +\arguments{ +\item{packages}{A list returned by \code{\link{make_packages}}.} + +\item{unattach}{Whether to unattach the packages.} + +\item{unload}{Whether to unload the packages. It is not possible to +unload without unattaching.} + +\item{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.} + +\item{delete_lib_dir}{Whether to delete the the whole \code{lib_dir}.} +} +\description{ +Get rid of temporary 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 + +## 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) +} +} + diff --git a/man/make_packages.Rd b/man/make_packages.Rd new file mode 100644 index 0000000..0472733 --- /dev/null +++ b/man/make_packages.Rd @@ -0,0 +1,59 @@ +% Generated by roxygen2 (4.1.0): do not edit by hand +% Please edit documentation in R/disposables.R +\name{make_packages} +\alias{make_packages} +\title{Create, install, load and attach multiple disposable packages} +\usage{ +make_packages(..., lib_dir = tempfile(), imports = character()) +} +\arguments{ +\item{...}{Named expressions. +A separate package with the given name is created for each.} + +\item{lib_dir}{Directory to install the package to. +Defaults to a temporary directory that is +deleted once the R session is over.} + +\item{imports}{The 'Imports' field in the DESCRIPTION file, +the packages to import in each disposable package.} +} +\value{ +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. + } +} +\description{ +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. +} +\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) +} +} +\seealso{ +\code{\link{dispose_packages}} +} + From 96706c99cddbeb940e55896880d6ebe867b5bd3a Mon Sep 17 00:00:00 2001 From: RobertZK Date: Sat, 18 Apr 2015 16:42:51 -0500 Subject: [PATCH 3/4] update NEWS README and DESCRIPTION --- DESCRIPTION | 2 +- NEWS.md | 4 ++++ README.md | 49 +++++++++++++++++++++++++++++++++++++++++++++++++ 3 files changed, 54 insertions(+), 1 deletion(-) diff --git a/DESCRIPTION b/DESCRIPTION index d2121c7..4cafae4 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,6 +1,6 @@ Package: testthatsomemore Title: A mocking, stubbing, and file testing framework extending testthat -Version: 0.2.4 +Version: 0.2.5 Maintainer: Robert Krzyzanowski Authors@R: c(person("Robert", "Krzyzanowski", email = "technoguyrob@gmail.com", role = c("aut", "cre")), diff --git a/NEWS.md b/NEWS.md index 994a778..ff7b9cf 100644 --- a/NEWS.md +++ b/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. diff --git a/README.md b/README.md index fab6697..6709a19 100644 --- a/README.md +++ b/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 ------- From 3ed2335321034c27d58a422264552cd0c9a3a0c1 Mon Sep 17 00:00:00 2001 From: RobertZK Date: Sat, 18 Apr 2015 16:43:36 -0500 Subject: [PATCH 4/4] add methods to Depends --- DESCRIPTION | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/DESCRIPTION b/DESCRIPTION index 4cafae4..01d1c95 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -13,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