{teal} module returns a teal_report object that extends from teal_data

R/qenv-eval_code.R

@@ -9,6 +9,9 @@
 #' @param code (`character`, `language` or `expression`) code to evaluate.
 #' It is possible to preserve original formatting of the `code` by providing a `character` or an
 #' `expression` being a result of `parse(keep.source = TRUE)`.
+#' @param keep_output (`logical(1)`) whether to keep the output of the code evaluation.
+#'
+#' @param ... ([`dots`]) additional arguments passed to future methods.
 #'
 #' @return
 #' `qenv` environment with `code/expr` evaluated or `qenv.error` if evaluation fails.
@@ -21,15 +24,28 @@
 #' q <- eval_code(q, quote(library(checkmate)))
 #' q <- eval_code(q, expression(assert_number(a)))
 #'
-#' @aliases eval_code,qenv,character-method
-#' @aliases eval_code,qenv,language-method
-#' @aliases eval_code,qenv,expression-method
-#' @aliases eval_code,qenv.error,ANY-method
+#' @aliases eval_code,qenv-method
+#' @aliases eval_code,qenv.error-method
 #'
 #' @export
-setGeneric("eval_code", function(object, code) standardGeneric("eval_code"))
+setGeneric("eval_code", function(object, code, keep_output = FALSE, ...) standardGeneric("eval_code"))
+
+setMethod("eval_code", signature = c(object = "qenv"), function(object, code, keep_output = FALSE, ...) {
+  if (!is.language(code) && !is.character(code)) {
+    stop("eval_code accepts code being language or character")
+  }
+  code <- .preprocess_code(code)
+  # preprocess code to ensure it is a character vector
+  .eval_code(object = object, code = code, keep_output = keep_output, ...)
+})
+
+setMethod("eval_code", signature = c(object = "qenv.error"), function(object, code, keep_output = FALSE, ...) object)
 
-setMethod("eval_code", signature = c("qenv", "character"), function(object, code) {
+#' @keywords internal
+.eval_code <- function(object, code, keep_output = FALSE, ...) {
+  if (identical(code, "")) {
+    return(object)
+  }
   parsed_code <- parse(text = code, keep.source = TRUE)
   object@.xData <- rlang::env_clone(object@.xData, parent = parent.env(.GlobalEnv))
   if (length(parsed_code) == 0) {
@@ -42,13 +58,15 @@ setMethod("eval_code", signature = c("qenv", "character"), function(object, code
   for (i in seq_along(code_split)) {
     current_code <- code_split[[i]]
     current_call <- parse(text = current_code, keep.source = TRUE)
-
     # Using withCallingHandlers to capture warnings and messages.
     # Using tryCatch to capture the error and abort further evaluation.
     x <- withCallingHandlers(
       tryCatch(
         {
-          eval(current_call, envir = object@.xData)
+          out <- eval(current_call, envir = object@.xData)
+          if (keep_output && i == length(code_split)) {
+            attr(current_code, "output") <- out
+          }
           if (!identical(parent.env(object@.xData), parent.env(.GlobalEnv))) {
             # needed to make sure that @.xData is always a sibling of .GlobalEnv
             # could be changed when any new package is added to search path (through library or require call)
@@ -60,7 +78,7 @@ setMethod("eval_code", signature = c("qenv", "character"), function(object, code
           errorCondition(
             message = sprintf(
               "%s \n when evaluating qenv code:\n%s",
-              .ansi_strip(conditionMessage(e)),
+              cli::ansi_strip(conditionMessage(e)),
               current_code
             ),
             class = c("qenv.error", "try-error", "simpleError"),
@@ -69,11 +87,11 @@ setMethod("eval_code", signature = c("qenv", "character"), function(object, code
         }
       ),
       warning = function(w) {
-        attr(current_code, "warning") <<- .ansi_strip(sprintf("> %s\n", conditionMessage(w)))
+        attr(current_code, "warning") <<- cli::ansi_strip(sprintf("> %s\n", conditionMessage(w)))
         invokeRestart("muffleWarning")
       },
       message = function(m) {
-        attr(current_code, "message") <<- .ansi_strip(sprintf("> %s", conditionMessage(m)))
+        attr(current_code, "message") <<- cli::ansi_strip(sprintf("> %s", conditionMessage(m)))
         invokeRestart("muffleMessage")
       }
     )
@@ -87,42 +105,17 @@ setMethod("eval_code", signature = c("qenv", "character"), function(object, code
 
   lockEnvironment(object@.xData, bindings = TRUE)
   object
-})
-
-setMethod("eval_code", signature = c("qenv", "language"), function(object, code) {
-  eval_code(object, code = paste(vapply(lang2calls(code), deparse1, collapse = "\n", character(1L)), collapse = "\n"))
-})
+}
 
-setMethod("eval_code", signature = c("qenv", "expression"), function(object, code) {
-  srcref <- attr(code, "wholeSrcref")
-  if (length(srcref)) {
-    eval_code(object, code = paste(attr(code, "wholeSrcref"), collapse = "\n"))
+setGeneric(".preprocess_code", function(code) standardGeneric(".preprocess_code"))
+setMethod(".preprocess_code", signature = c("character"), function(code) paste(code, collapse = "\n"))
+setMethod(".preprocess_code", signature = c("ANY"), function(code) {
+  if (is.expression(code) && length(attr(code, "wholeSrcref"))) {
+    paste(attr(code, "wholeSrcref"), collapse = "\n")
   } else {
-    Reduce(function(u, v) {
-      if (inherits(v, "=") && identical(typeof(v), "language")) {
-        # typeof(`=`) is language, but it doesn't dispatch on it, so we need to
-        # explicitly pass it as first class of the object
-        class(v) <- unique(c("language", class(v)))
-      }
-      eval_code(u, v)
-    }, init = object, x = code)
+    paste(
+      vapply(lang2calls(code), deparse1, collapse = "\n", character(1L)),
+      collapse = "\n"
+    )
   }
 })
-
-setMethod("eval_code", signature = c("qenv.error", "ANY"), function(object, code) {
-  object
-})
-
-# if cli is installed rlang adds terminal printing characters
-# which need to be removed
-.ansi_strip <- function(chr) {
-  if (requireNamespace("cli", quietly = TRUE)) {
-    cli::ansi_strip(chr)
-  } else {
-    chr
-  }
-}
-
-get_code_attr <- function(qenv, attr) {
-  unlist(lapply(qenv@code, function(x) attr(x, attr)))
-}

R/qenv-within.R

@@ -9,6 +9,7 @@
 #'
 #' @param data (`qenv`)
 #' @param expr (`expression`) to evaluate. Must be inline code, see `Using language objects...`
+#' @param keep_output (`logical(1)`) whether to keep the output of the code evaluation.
 #' @param ... named argument value will substitute a symbol in the `expr` matched by the name.
 #' For practical usage see Examples section below.
 #'
@@ -47,27 +48,22 @@
 #'
 #' @export
 #'
-within.qenv <- function(data, expr, ...) {
-  expr <- substitute(expr)
+within.qenv <- function(data, expr, keep_output = FALSE, ...) {
+  expr <- as.expression(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))
+  calls <- lapply(expr, function(x) do.call(substitute, list(x, env = extras)))
+  do.call(
+    eval_code,
+    utils::modifyList(extras, list(object = data, code = as.expression(calls), keep_output = keep_output))
+  )
 }
 
 
 #' @keywords internal
 #'
 #' @export
-within.qenv.error <- function(data, expr, ...) {
+within.qenv.error <- function(data, expr, keep_output = FALSE, ...) {
   data
 }

tests/testthat/test-qenv_eval_code.R

@@ -45,6 +45,11 @@ testthat::test_that("eval_code works with expression", {
   testthat::expect_equal(q1, list2env(list(a = 1, b = 2)))
 })
 
+testthat::test_that("eval_code ignores empty code", {
+  q <- qenv()
+  testthat::expect_identical(q, eval_code(q, ""))
+})
+
 testthat::test_that("eval_code preserves original formatting when `srcref` is present in the expression", {
   code <- "# comment
   a <- 1L"
@@ -77,12 +82,11 @@ testthat::test_that("eval_code works with quoted code block", {
   testthat::expect_equal(q1, list2env(list(a = 1, b = 2)))
 })
 
-testthat::test_that("eval_code fails with unquoted expression", {
-  b <- 3
-  testthat::expect_error(
-    eval_code(qenv(), a <- b),
-    "unable to find an inherited method for function .eval_code. for signature"
-  )
+testthat::test_that("eval_code fails with code not being language nor character", {
+  msg <- "eval_code accepts code being language or character"
+  testthat::expect_error(eval_code(qenv(), NULL), msg)
+  testthat::expect_error(eval_code(qenv(), 1), msg)
+  testthat::expect_error(eval_code(qenv(), list()), msg)
 })
 
 testthat::test_that("an error when calling eval_code returns a qenv.error object which has message and trace", {
@@ -183,7 +187,9 @@ testthat::test_that("comments passed alone to eval_code that contain @linksto ta
   )
 })
 
-testthat::test_that("Code executed with integer shorthand (1L) is the same as original", {
-  q <- within(qenv(), a <- 1L)
-  testthat::expect_identical(get_code(q), "a <- 1L")
+testthat::test_that("keep_output stores the last output of the `code` evaluation in its 'output' attribute", {
+  q <- eval_code(qenv(), "a <- 1L;b <-2L;c<- 3L", keep_output = TRUE)
+  testthat::expect_identical(attr(q@code[[1]], "output"), NULL)
+  testthat::expect_identical(attr(q@code[[2]], "output"), NULL)
+  testthat::expect_identical(attr(q@code[[3]], "output"), 3L)
 })

tests/testthat/test-qenv_join.R

@@ -131,7 +131,7 @@ testthat::test_that("Joining two independent qenvs with warnings results in obje
   q <- c(q1, q2)
 
   testthat::expect_equal(
-    unname(get_code_attr(q, "warning")),
+    vapply(q@code, attr, which = "warning", character(1L), USE.NAMES = FALSE),
     c(
       "> This is warning 1\n",
       "> This is warning 2\n"
@@ -146,7 +146,7 @@ testthat::test_that("Joining two independent qenvs with messages results in obje
   q <- c(q1, q2)
 
   testthat::expect_equal(
-    unname(get_code_attr(q, "message")),
+    vapply(q@code, attr, which = "message", character(1L), USE.NAMES = FALSE),
     c(
       "> This is message 1\n",
       "> This is message 2\n"

tests/testthat/test-qenv_within.R

@@ -149,3 +149,22 @@ testthat::describe("within run with `=`", {
     testthat::expect_equal(q$i, 1)
   })
 })
+
+testthat::test_that("Code executed with integer shorthand (1L) is the same as original", {
+  q <- within(qenv(), a <- 1L)
+  testthat::expect_identical(get_code(q), "a <- 1L")
+})
+
+testthat::test_that("keep_output stores the last output of the `code` evaluation in its 'output' attribute", {
+  q <- within(qenv(),
+    {
+      a <- 1L
+      b <- 2L
+      c <- 3L
+    },
+    keep_output = TRUE
+  )
+  testthat::expect_identical(attr(q@code[[1]], "output"), NULL)
+  testthat::expect_identical(attr(q@code[[2]], "output"), NULL)
+  testthat::expect_identical(attr(q@code[[3]], "output"), 3L)
+})