diff --git a/DESCRIPTION b/DESCRIPTION index 9880837..01d1c95 100644 --- a/DESCRIPTION +++ b/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 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 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/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/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/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 ------- 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}} +} + 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) + +}) +