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

NEWS.md

@@ -4,6 +4,10 @@
 
 * Fix a problem detecting co-occurrences when expression has multiple lines.
 
+### Miscellaneous
+
+* Refactor `eval_code` method signature to allow for more flexibility when extending the `eval_code`/`within` functions.
+
 # teal.code 0.6.1
 
 ### Bug fixes

R/qenv-eval_code.R

@@ -9,6 +9,7 @@
 #' @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 ... ([`dots`]) additional arguments passed to future methods.
 #'
 #' @return
 #' `qenv` environment with `code/expr` evaluated or `qenv.error` if evaluation fails.
@@ -21,15 +22,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
+#' @seealso [within.qenv]
 #' @export
-setGeneric("eval_code", function(object, code) standardGeneric("eval_code"))
+setGeneric("eval_code", function(object, code, ...) standardGeneric("eval_code"))
+
+setMethod("eval_code", signature = c(object = "qenv"), function(object, code, ...) {
+  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, ...)
+})
+
+setMethod("eval_code", signature = c(object = "qenv.error"), function(object, code, ...) object)
 
-setMethod("eval_code", signature = c("qenv", "character"), function(object, code) {
+#' @keywords internal
+.eval_code <- function(object, code, ...) {
+  if (identical(trimws(code), "") || length(code) == 0) {
+    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,7 +56,6 @@ 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(
@@ -60,7 +73,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 +82,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 +100,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

@@ -1,3 +1,4 @@
+#' Evaluate code in `qenv`
 #' @details
 #' `within()` is a convenience method that wraps `eval_code` to provide a simplified way of passing expression.
 #' `within` accepts only inline expressions (both simple and compound) and allows to substitute `expr`
@@ -43,25 +44,18 @@
 #' within(q, exprlist) # fails
 #' do.call(within, list(q, do.call(c, exprlist)))
 #'
-#' @rdname eval_code
-#'
 #' @export
 #'
 within.qenv <- function(data, expr, ...) {
-  expr <- substitute(expr)
+  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)))
+  )
 }
 
 

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", {
@@ -182,8 +186,3 @@ testthat::test_that("comments passed alone to eval_code that contain @linksto ta
     "x"
   )
 })
-
-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")
-})

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,8 @@ 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")
+})