diff --git a/DESCRIPTION b/DESCRIPTION index e6cf8a5eb..efa394a84 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -59,5 +59,6 @@ Collate: 'qenv-get_warnings.R' 'qenv-join.R' 'qenv-show.R' + 'qenv-within.R' 'teal.code-package.R' 'utils.R' diff --git a/NAMESPACE b/NAMESPACE index aa2789359..d7211a97c 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -1,6 +1,7 @@ # Generated by roxygen2: do not edit by hand S3method("[[",qenv.error) +S3method(within,qenv) export(concat) export(dev_suppress) export(eval_code) diff --git a/NEWS.md b/NEWS.md index 66b29f0c3..4bd5f8211 100644 --- a/NEWS.md +++ b/NEWS.md @@ -7,6 +7,7 @@ * Updated usage and installation instructions in `README`. * Updated phrasing of the `qenv` vignette. * Specified minimal version of package dependencies. +* Added `within` method for `qenv` for convenient passing of inline code to `eval_code`. # teal.code 0.4.0 diff --git a/R/qenv-within.R b/R/qenv-within.R new file mode 100644 index 000000000..a6413568e --- /dev/null +++ b/R/qenv-within.R @@ -0,0 +1,75 @@ +#' Evaluate expression in `qenv` object. +#' +#' Convenience function for evaluating inline code inside the environment of a `qenv`. +#' +#' This is a wrapper for `eval_code` that provides a simplified way of passing code for evaluation. +#' It accepts only inline expressions (both simple and compound) and allows for injecting values into `expr` +#' through the `...` argument: as `name:value` pairs are passed to `...`, +#' `name` in `expr` will be replaced with `value`. +#' +#' @section Using language objects: +#' Passing language objects to `expr` is generally not intended but can be achieved with `do.call`. +#' Only single `expression`s will work and substitution is not available. See examples. +#' +#' @param data `qenv` object +#' @param expr `expression` to evaluate +#' @param ... `name:value` pairs to inject values into `expr` +#' +#' @return +#' Returns a `qenv` object with `expr` evaluated. If evaluation raises an error, a `qenv.error` is returned. +#' +#' @seealso [`eval_code`], [`base::within`] +#' +#' @export +#' +#' @rdname within +#' +#' @examples +#' +#' q <- new_qenv() +#' +#' # execute code +#' q <- within(q, { +#' i <- iris +#' }) +#' q <- within(q, { +#' m <- mtcars +#' f <- faithful +#' }) +#' q +#' get_code(q) +#' +#' # inject values into code +#' q <- new_qenv() +#' q <- within(q, i <- iris) +#' within(q, print(dim(subset(i, Species == "virginica")))) +#' within(q, print(dim(subset(i, Species == species)))) # fails +#' within(q, print(dim(subset(i, Species == species))), species = "versicolor") +#' species_external <- "versicolor" +#' within(q, print(dim(subset(i, Species == species))), species = species_external) +#' +#' # pass language objects +#' expr <- expression(i <- iris, m <- mtcars) +#' within(q, expr) # fails +#' do.call(within, list(q, expr)) +#' +#' exprlist <- list(expression(i <- iris), expression(m <- mtcars)) +#' within(q, exprlist) # fails +#' do.call(within, list(q, do.call(c, exprlist))) +#' +within.qenv <- function(data, expr, ...) { + expr <- substitute(expr) + extras <- list(...) + + # Add braces for consistency. + if (!identical(as.list(expr)[[1L]], as.symbol("{"))) { + expr <- call("{", expr) + } + + calls <- as.list(expr)[-1] + + # Inject extra values into expressions. + calls <- lapply(calls, function(x) do.call(substitute, list(x, env = extras))) + + eval_code(object = data, code = as.expression(calls)) +} diff --git a/_pkgdown.yml b/_pkgdown.yml index 19958db9c..46dfe638a 100644 --- a/_pkgdown.yml +++ b/_pkgdown.yml @@ -33,3 +33,4 @@ reference: - join - new_qenv - show,qenv-method + - within.qenv diff --git a/man/within.Rd b/man/within.Rd new file mode 100644 index 000000000..bb8cc449f --- /dev/null +++ b/man/within.Rd @@ -0,0 +1,70 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/qenv-within.R +\name{within.qenv} +\alias{within.qenv} +\title{Evaluate expression in \code{qenv} object.} +\usage{ +\method{within}{qenv}(data, expr, ...) +} +\arguments{ +\item{data}{\code{qenv} object} + +\item{expr}{\code{expression} to evaluate} + +\item{...}{\code{name:value} pairs to inject values into \code{expr}} +} +\value{ +Returns a \code{qenv} object with \code{expr} evaluated. If evaluation raises an error, a \code{qenv.error} is returned. +} +\description{ +Convenience function for evaluating inline code inside the environment of a \code{qenv}. +} +\details{ +This is a wrapper for \code{eval_code} that provides a simplified way of passing code for evaluation. +It accepts only inline expressions (both simple and compound) and allows for injecting values into \code{expr} +through the \code{...} argument: as \code{name:value} pairs are passed to \code{...}, +\code{name} in \code{expr} will be replaced with \code{value}. +} +\section{Using language objects}{ + +Passing language objects to \code{expr} is generally not intended but can be achieved with \code{do.call}. +Only single \code{expression}s will work and substitution is not available. See examples. +} + +\examples{ + +q <- new_qenv() + +# execute code +q <- within(q, { + i <- iris +}) +q <- within(q, { + m <- mtcars + f <- faithful +}) +q +get_code(q) + +# inject values into code +q <- new_qenv() +q <- within(q, i <- iris) +within(q, print(dim(subset(i, Species == "virginica")))) +within(q, print(dim(subset(i, Species == species)))) # fails +within(q, print(dim(subset(i, Species == species))), species = "versicolor") +species_external <- "versicolor" +within(q, print(dim(subset(i, Species == species))), species = species_external) + +# pass language objects +expr <- expression(i <- iris, m <- mtcars) +within(q, expr) # fails +do.call(within, list(q, expr)) + +exprlist <- list(expression(i <- iris), expression(m <- mtcars)) +within(q, exprlist) # fails +do.call(within, list(q, do.call(c, exprlist))) + +} +\seealso{ +\code{\link{eval_code}}, \code{\link[base:with]{base::within}} +} diff --git a/tests/testthat/test-qenv-within.R b/tests/testthat/test-qenv-within.R new file mode 100644 index 000000000..05ab6c1fa --- /dev/null +++ b/tests/testthat/test-qenv-within.R @@ -0,0 +1,107 @@ +# styler: off +# nolint start + +# code acceptance ---- +testthat::test_that("simple and compound expressions are evaluated", { + q <- new_qenv() + testthat::expect_no_error( + within(q, 1 + 1) + ) + testthat::expect_no_error( + within(q, { + 1 + 1 + }) + ) +}) + +# code identity ---- +testthat::test_that("styling of input code does not impact evaluation results", { + q <- new_qenv() + q <- within(q, 1 + 1) + q <- within(q, {1 + 1}) + q <- within(q, { + 1 + 1 + }) + q <- within(q, { + 1 + + 1 + }) + all_code <- get_code(q) + testthat::expect_identical( + all_code, + rep("1 + 1", 4L) + ) + + q <- new_qenv() + q <- within(q, {1 + 1; 2 + 2}) + q <- within(q, { + 1 + 1; 2 + 2 + }) + q <- within(q, { + 1 + 1 + 2 + 2 + }) + q <- within(q, { + 1 + 1; + 2 + 2 + }) + all_code <- get_code(q) + testthat::expect_identical( + all_code, + rep(c("1 + 1", "2 + 2"), 4L) + ) +}) + + +# return value ---- +testthat::test_that("within.qenv renturns a deep copy of `data`", { + q <- new_qenv() + q <- within(new_qenv(), i <- iris) + qq <- within(q, {}) + testthat::expect_equal(q, qq) + testthat::expect_false(identical(q, qq)) +}) + +testthat::test_that("within.qenv renturns qenv.error even if evaluation raises error", { + q <- new_qenv() + q <- within(q, i <- iris) + qq <- within(q, stop("right there")) + testthat::expect_true( + exists("qq", inherits = FALSE) + ) + testthat::expect_s3_class(qq, "qenv.error") +}) + + +# injecting values ---- +testthat::test_that("external values can be injected into expressions through `...`", { + q <- new_qenv() + + external_value <- "virginica" + q <- within(q, { + i <- subset(iris, Species == species) + }, + species = external_value) + + testthat::expect_identical(get_code(q), "i <- subset(iris, Species == \"virginica\")") +}) + +testthat::test_that("external values are not taken from calling frame", { + q <- new_qenv() + species <- "setosa" + qq <- within(q, { + i <- subset(iris, Species == species) + }) + testthat::expect_s3_class(qq, "qenv.error") + testthat::expect_error(get_code(qq), "object 'species' not found") + + qq <- within(q, { + i <- subset(iris, Species == species) + }, + species = species) + testthat::expect_s4_class(qq, "qenv") + testthat::expect_identical(get_code(qq), "i <- subset(iris, Species == \"setosa\")") +}) + +# nolint end +# styler: on diff --git a/vignettes/qenv.Rmd b/vignettes/qenv.Rmd index bb2d985c2..5b0a8c73e 100644 --- a/vignettes/qenv.Rmd +++ b/vignettes/qenv.Rmd @@ -1,5 +1,5 @@ --- -title: "`qenv`" +title: "qenv" author: "NEST coreDev" output: rmarkdown::html_vignette vignette: > @@ -53,6 +53,44 @@ print(q2[["y"]]) cat(paste(get_code(q2), collapse = "\n")) ``` + +### Substitutions +In some cases one may want to substitute some elements of the code before evaluation. +Consider a case when a subset of `iris` defined by an input value. +```{r} +q <- new_qenv() +q <- eval_code(q, quote(i <- subset(iris, Species == "setosa"))) +q <- eval_code(q, substitute( + ii <- subset(iris, Species == species), + env = list(species = "versicolor") +)) +input_value <- "virginica" +q <- eval_code(q, substitute( + iii <- subset(iris, Species == species), + env = list(species = input_value) +)) + +summary(q[["i"]]$Species) +summary(q[["ii"]]$Species) +summary(q[["iii"]]$Species) +``` + +A more convenient way to pass code with substitution is to use the `within` method. +```{r} +qq <- new_qenv() +qq <- within(qq, i <- subset(iris, Species == "setosa")) +qq <- within(qq, ii <- subset(iris, Species == species), species = "versicolor") +input_value <- "virginica" +qq <- within(qq, iii <- subset(iris, Species == species), species = input_value) + +summary(qq[["i"]]$Species) +summary(qq[["ii"]]$Species) +summary(qq[["iii"]]$Species) +``` + +See `?within.qenv` for more details. + + ### Combining `qenv` objects Given a pair of `qenv` objects, you may be able to "join" them, creating a new `qenv` object encompassing the union of both environments, along with the requisite code for reproduction: