127 introduce within.qenv

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'

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)

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
 

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))
+}

_pkgdown.yml

@@ -33,3 +33,4 @@ reference:
       - join
       - new_qenv
       - show,qenv-method
+      - within.qenv

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

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: