Use evaluate (#258)

`eval_code` caches now outputs of the code in the `attr(<code line>,
"outputs")`. See the tests of `get_outputs` to see how it works.

---------

Signed-off-by: Dawid Kałędkowski <[email protected]>
Co-authored-by: André Veríssimo <[email protected]>
Co-authored-by: github-actions <41898282+github-actions[bot]@users.noreply.github.com>

Author: 3 people

.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-class.R

@@ -31,11 +31,12 @@ setMethod(
   "initialize",
   "qenv",
   function(.Object, .xData, code = list(), ...) { # nolint: object_name.
+    parent <- parent.env(.GlobalEnv)
     new_xdata <- if (rlang::is_missing(.xData)) {
-      new.env(parent = parent.env(.GlobalEnv))
+      new.env(parent = parent)
     } else {
       checkmate::assert_environment(.xData)
-      rlang::env_clone(.xData, parent = parent.env(.GlobalEnv))
+      rlang::env_clone(.xData, parent = parent)
     }
     lockEnvironment(new_xdata, bindings = TRUE)
 

R/qenv-eval_code.R

@@ -44,60 +44,57 @@ setMethod("eval_code", signature = c(object = "qenv.error"), function(object, co
   if (identical(trimws(code), "") || length(code) == 0) {
     return(object)
   }
+  code <- paste(split_code(code), collapse = "\n")
+
+  object@.xData <- rlang::env_clone(object@.xData, parent = parent.env(object@.xData))
   parsed_code <- parse(text = code, keep.source = TRUE)
-  object@.xData <- rlang::env_clone(object@.xData, parent = parent.env(.GlobalEnv))
-  if (length(parsed_code) == 0) {
-    # empty code, or just comments
-    attr(code, "dependency") <- extract_dependency(parsed_code) # in case comment contains @linksto tag
-    object@code <- c(object@code, stats::setNames(list(code), sample.int(.Machine$integer.max, size = 1)))
-    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) {
+
+  old <- evaluate::inject_funs(
+    library = function(...) {
+      x <- library(...)
+      if (!identical(parent.env(object@.xData), parent.env(.GlobalEnv))) {
+        parent.env(object@.xData) <- parent.env(.GlobalEnv)
+      }
+      invisible(x)
+    }
+  )
+  out <- evaluate::evaluate(
+    code,
+    envir = object@.xData,
+    stop_on_error = 1,
+    output_handler = evaluate::new_output_handler(value = identity)
+  )
+  out <- evaluate::trim_intermediate_plots(out)
+
+  evaluate::inject_funs(old) # remove library() override
+
+  new_code <- list()
+  for (this in out) {
+    if (inherits(this, "source")) {
+      this_code <- gsub("\n$", "", this$src)
+      attr(this_code, "dependency") <- extract_dependency(parse(text = this_code, keep.source = TRUE))
+      new_code <- c(new_code, stats::setNames(list(this_code), sample.int(.Machine$integer.max, size = 1)))
+    } else {
+      last_code <- new_code[[length(new_code)]]
+      if (inherits(this, "error")) {
+        return(
           errorCondition(
             message = sprintf(
               "%s \n when evaluating qenv code:\n%s",
-              cli::ansi_strip(conditionMessage(e)),
-              current_code
+              cli::ansi_strip(conditionMessage(this)),
+              last_code
             ),
             class = c("qenv.error", "try-error", "simpleError"),
-            trace = unlist(c(object@code, list(current_code)))
+            trace = unlist(c(object@code, list(new_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")
+        )
       }
-    )
-
-    if (!is.null(x)) {
-      return(x)
+      attr(last_code, "outputs") <- c(attr(last_code, "outputs"), list(this))
+      new_code[[length(new_code)]] <- last_code
     }
-    attr(current_code, "dependency") <- extract_dependency(current_call)
-    object@code <- c(object@code, stats::setNames(list(current_code), sample.int(.Machine$integer.max, size = 1)))
   }
 
+  object@code <- c(object@code, new_code)
   lockEnvironment(object@.xData, bindings = TRUE)
   object
 }

R/qenv-get_outputs.R

@@ -0,0 +1,30 @@
+#' 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-get_code_dependency.R

@@ -521,6 +521,9 @@ get_call_breaks <- function(code) {
     }
   ))
   call_breaks <- call_breaks[-nrow(call_breaks), , drop = FALSE] # breaks in between needed only
+  if (nrow(call_breaks) == 0L) {
+    call_breaks <- matrix(numeric(0), ncol = 2)
+  }
   colnames(call_breaks) <- c("line", "col")
   call_breaks
 }

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