evaluate caches outputs

Author: gogonzo

.lintr

@@ -1,5 +1,4 @@
 linters: linters_with_defaults(
   line_length_linter = line_length_linter(120),
-  cyclocomp_linter = NULL,
   object_usage_linter = NULL
   )

DESCRIPTION

@@ -29,6 +29,7 @@ Depends:
 Imports:
     checkmate (>= 2.1.0),
     cli (>= 3.4.0),
+    evaluate (>= 1.0.0),
     grDevices,
     lifecycle (>= 0.2.0),
     rlang (>= 1.1.0),

NEWS.md

@@ -6,6 +6,7 @@
 
 ### Miscellaneous
 
+* `eval_code` uses `evaluate::evaluate` and stores returned outputs in the code's attribute.
 * Refactor `eval_code` method signature to allow for more flexibility when extending the `eval_code`/`within` functions.
 
 # teal.code 0.6.1

R/qenv-eval_code.R

@@ -53,48 +53,44 @@ setMethod("eval_code", signature = c(object = "qenv.error"), function(object, co
     return(object)
   }
   code_split <- split_code(paste(code, collapse = "\n"))
+
   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)
-          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)
-            parent.env(object@.xData) <- parent.env(.GlobalEnv)
-          }
-          NULL
-        },
-        error = function(e) {
-          errorCondition(
-            message = sprintf(
-              "%s \n when evaluating qenv code:\n%s",
-              cli::ansi_strip(conditionMessage(e)),
-              current_code
-            ),
-            class = c("qenv.error", "try-error", "simpleError"),
-            trace = unlist(c(object@code, list(current_code)))
-          )
-        }
-      ),
-      warning = function(w) {
-        attr(current_code, "warning") <<- cli::ansi_strip(sprintf("> %s\n", conditionMessage(w)))
-        invokeRestart("muffleWarning")
-      },
-      message = function(m) {
-        attr(current_code, "message") <<- cli::ansi_strip(sprintf("> %s", conditionMessage(m)))
-        invokeRestart("muffleMessage")
-      }
+    x <- evaluate::evaluate(
+      current_code,
+      envir = object@.xData,
+      stop_on_error = 1,
+      output_handler = evaluate::new_output_handler(value = identity)
     )
 
-    if (!is.null(x)) {
-      return(x)
+    e <- Filter(function(e) inherits(e, "error"), x)
+    if (length(e)) {
+      return(
+        errorCondition(
+          message = sprintf(
+            "%s \n when evaluating qenv code:\n%s",
+            cli::ansi_strip(conditionMessage(e[[1]])),
+            current_code
+          ),
+          class = c("qenv.error", "try-error", "simpleError"),
+          trace = unlist(c(object@code, list(current_code)))
+        )
+      )
+    }
+    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)
+      parent.env(object@.xData) <- parent.env(.GlobalEnv)
     }
-    attr(current_code, "dependency") <- extract_dependency(current_call)
+
+    attributes(current_code) <- Filter(
+      length,
+      list(
+        dependency = extract_dependency(current_call),
+        outputs = x[-1]
+      )
+    )
     object@code <- c(object@code, stats::setNames(list(current_code), sample.int(.Machine$integer.max, size = 1)))
   }
 

R/utils.R

@@ -57,12 +57,25 @@ lang2calls <- function(x) {
 #' Obtain warnings or messages from code slot
 #'
 #' @param object (`qenv`)
-#' @param what (`"warning"` or `"message"`)
+#' @param what (`warning` or `message`)
 #' @return `character(1)` containing combined message or `NULL` when no warnings/messages
 #' @keywords internal
 get_warn_message_util <- function(object, what) {
   checkmate::matchArg(what, choices = c("warning", "message"))
-  messages <- lapply(object@code, "attr", what)
+  messages <- lapply(
+    object@code,
+    function(x) {
+      unlist(lapply(
+        attr(x, "outputs"),
+        function(el) {
+          if (inherits(el, what)) {
+            sprintf("> %s", conditionMessage(el))
+          }
+        }
+      ))
+    }
+  )
+
   idx_warn <- which(sapply(messages, function(x) !is.null(x) && !identical(x, "")))
   if (!any(idx_warn)) {
     return(NULL)
@@ -74,7 +87,7 @@ get_warn_message_util <- function(object, what) {
     warn = messages,
     expr = code,
     function(warn, expr) {
-      sprintf("%swhen running code:\n%s", warn, expr)
+      sprintf("%s\nwhen running code:\n%s", trimws(warn), trimws(expr))
     }
   )
 

man/get_warn_message_util.Rd

@@ -50,11 +50,20 @@ testthat::test_that("Concatenate two independent qenvs with warnings results in
 
   q12 <- concat(q1, q2)
 
-  testthat::expect_equal(
-    unlist(lapply(q12@code, attr, "warning"), use.names = FALSE),
-    c(
-      "> This is warning 1\n",
-      "> This is warning 2\n"
+  testthat::expect_identical(
+    get_warnings(q12),
+    paste(
+      "~~~ Warnings ~~~",
+      "\n> This is warning 1",
+      "when running code:",
+      "warning('This is warning 1')",
+      "\n> This is warning 2",
+      "when running code:",
+      "warning('This is warning 2')",
+      "\n~~~ Trace ~~~\n",
+      "warning('This is warning 1')",
+      "warning('This is warning 2')",
+      sep = "\n"
     )
   )
 })
@@ -65,11 +74,20 @@ testthat::test_that("Concatenate two independent qenvs with messages results in
 
   q12 <- concat(q1, q2)
 
-  testthat::expect_equal(
-    unlist(lapply(q12@code, attr, "message"), use.names = FALSE),
-    c(
-      "> This is message 1\n",
-      "> This is message 2\n"
+  testthat::expect_identical(
+    get_messages(q12),
+    paste(
+      "~~~ Messages ~~~",
+      "\n> This is message 1",
+      "when running code:",
+      "message('This is message 1')",
+      "\n> This is message 2",
+      "when running code:",
+      "message('This is message 2')",
+      "\n~~~ Trace ~~~\n",
+      "message('This is message 1')",
+      "message('This is message 2')",
+      sep = "\n"
     )
   )
 })

tests/testthat/test-qenv_concat.R

@@ -186,3 +186,18 @@ testthat::test_that("comments passed alone to eval_code that contain @linksto ta
     "x"
   )
 })
+
+testthat::test_that("object printed (explicitly) is stored as string in the 'outputs' attribute of a code element", {
+  q <- eval_code(qenv(), "print('whatever')")
+  testthat::expect_identical(attr(q@code[[1]], "outputs")[[1]], '[1] "whatever"\n')
+})
+
+testthat::test_that("object printed (implicitly) is stored asis in the 'outputs' attribute of a code element", {
+  q <- eval_code(qenv(), "head(letters)")
+  testthat::expect_identical(attr(q@code[[1]], "outputs")[[1]], head(letters))
+})
+
+testthat::test_that("plot output is stored as recordedplot in the 'outputs' attribute of a code element", {
+  q <- eval_code(qenv(), "plot(1)")
+  testthat::expect_s3_class(attr(q@code[[1]], "outputs")[[1]], "recordedplot")
+})

tests/testthat/test-qenv_eval_code.R

@@ -130,11 +130,20 @@ testthat::test_that("Joining two independent qenvs with warnings results in obje
 
   q <- c(q1, q2)
 
-  testthat::expect_equal(
-    vapply(q@code, attr, which = "warning", character(1L), USE.NAMES = FALSE),
-    c(
-      "> This is warning 1\n",
-      "> This is warning 2\n"
+  testthat::expect_identical(
+    get_warnings(q),
+    paste(
+      "~~~ Warnings ~~~",
+      "\n> This is warning 1",
+      "when running code:",
+      "warning('This is warning 1')",
+      "\n> This is warning 2",
+      "when running code:",
+      "warning('This is warning 2')",
+      "\n~~~ Trace ~~~\n",
+      "warning('This is warning 1')",
+      "warning('This is warning 2')",
+      sep = "\n"
     )
   )
 })
@@ -145,11 +154,20 @@ testthat::test_that("Joining two independent qenvs with messages results in obje
 
   q <- c(q1, q2)
 
-  testthat::expect_equal(
-    vapply(q@code, attr, which = "message", character(1L), USE.NAMES = FALSE),
-    c(
-      "> This is message 1\n",
-      "> This is message 2\n"
+  testthat::expect_identical(
+    get_messages(q),
+    paste(
+      "~~~ Messages ~~~",
+      "\n> This is message 1",
+      "when running code:",
+      "message('This is message 1')",
+      "\n> This is message 2",
+      "when running code:",
+      "message('This is message 2')",
+      "\n~~~ Trace ~~~\n",
+      "message('This is message 1')",
+      "message('This is message 2')",
+      sep = "\n"
     )
   )
 })