Use evaluate

.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),
@@ -64,6 +65,7 @@ Collate:
     'qenv-get_code.R'
     'qenv-get_env.R'
     'qenv-get_messages.r'
+    'qenv-get_outputs.R'
     'qenv-get_var.R'
     'qenv-get_warnings.R'
     'qenv-join.R'

NAMESPACE

@@ -17,6 +17,7 @@ export(eval_code)
 export(get_code)
 export(get_env)
 export(get_messages)
+export(get_outputs)
 export(get_var)
 export(get_warnings)
 export(join)

NEWS.md

@@ -1,11 +1,16 @@
 # teal.code 0.6.1.9003
 
+### Enhancements
+
+* Introduced `get_outputs` function to fetch objects which have been printed or plotted in the `qenv` code. 
+
 ### Bug fixes
 
 * Fix a problem detecting co-occurrences when expression has multiple lines.
 
 ### 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 = [email protected])
-          if (!identical(parent.env([email protected]), 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([email protected]) <- 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 = [email protected],
+      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([email protected]), 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([email protected]) <- 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/qenv-get_outputs.R

@@ -0,0 +1,34 @@
+#' Get outputs
+#'
+#' @description
+#' `eval_code` evaluates code silently so plots and prints don't show up in the console or graphic devices.
+#' If one wants to use an output outside of the `qenv` (e.g. use a graph in `renderPlot`) then use `get_outputs`.
+#' @param object (`qenv`)
+#' @return list of outputs generated in a `qenv``
+#' @examples
+#' q <- eval_code(
+#'   qenv(),
+#'   quote({
+#'     a <- 1
+#'     print("I'm an output")
+#'     plot(1)
+#'   })
+#' )
+#' get_outputs(q)
+#'
+#' @aliases get_outputs,qenv-method
+#'
+#' @export
+setGeneric("get_outputs", function(object) standardGeneric("get_outputs"))
+
+
+
+setMethod("get_outputs", signature = "qenv", function(object) {
+  Reduce(
+    function(x, y) {
+      c(x, attr(y, "outputs"))
+    },
+    init = list(),
+    x = object@code
+  )
+})

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

_pkgdown.yml

@@ -31,6 +31,7 @@ reference:
       - eval_code
       - get_code
       - get_env
+      - get_outputs
       - get_var
       - get_messages
       - get_warnings

tests/testthat/test-get_outputs.R

@@ -0,0 +1,40 @@
+testthat::describe("get_output", {
+  testthat::it("returns an empty list if nothing is printed", {
+    q <- qenv()
+    q1 <- eval_code(q, expression(a <- 1L, b <- 2L))
+    testthat::expect_identical(get_outputs(q1), list())
+  })
+
+  testthat::it("implicitly printed objects are returned asis in a list", {
+    q <- qenv()
+    q1 <- eval_code(q, expression(a <- 1L, a, b <- 2L, b))
+    testthat::expect_identical(get_outputs(q1), list(1L, 2L))
+  })
+
+  testthat::it("explicitly printed objects are returned as console-output-string in a list", {
+    q <- qenv()
+    q1 <- eval_code(q, expression(a <- 1L, print(a), b <- 2L, print(b)))
+    testthat::expect_identical(get_outputs(q1), list("[1] 1\n", "[1] 2\n"))
+  })
+
+  testthat::it("printed plots are returned as recordedplot in a list", {
+    q <- qenv()
+    q1 <- eval_code(q, expression(a <- 1L, plot(a)))
+    testthat::expect_true(inherits(get_outputs(q1)[[1]], "recordedplot"))
+  })
+
+  testthat::it("warnings are returned asis in a list", {
+    q <- qenv()
+    q1 <- eval_code(q, expression(warning("test")))
+    expected <- simpleWarning("test")
+    expected["call"] <- NULL
+    testthat::expect_identical(get_outputs(q1), list(expected))
+  })
+
+  testthat::it("messages are returned asis in a list", {
+    q <- qenv()
+    q1 <- eval_code(q, expression(message("test")))
+    expected <- simpleMessage("test\n", call = quote(message("test")))
+    testthat::expect_identical(get_outputs(q1), list(expected))
+  })
+})

tests/testthat/test-qenv_concat.R

@@ -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_eval_code.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")
+})