Evaluate print in evaluation environment

DESCRIPTION

@@ -36,4 +36,4 @@ Config/Needs/website: tidyverse/tidytemplate
 Config/testthat/edition: 3
 Encoding: UTF-8
 Roxygen: list(markdown = TRUE)
-RoxygenNote: 7.3.1
+RoxygenNote: 7.3.2

NEWS.md

@@ -1,5 +1,6 @@
 # evaluate (development version)
 
+* The default `value` handler now evaluates print in a child environment of the evaluation environment. This largely makes evaluate easier to test, but should make defining S3 methods for print a little easier (#192).
 * `parse_all()` adds a `\n` to the end of every line, even the last one if it didn't have one in the input.
 * Setting `ACTIONS_STEP_DEBUG=1` (as in a failing GHA workflow) will automatically set `log_echo` and `log_warning` to `TRUE` (#175).
 * New `local_reproducible_output()` helper that sets various options and env vars to help ensure consistency of output across environments.

R/evaluate.R

@@ -94,7 +94,7 @@ evaluate <- function(input,
   on_message <- check_keep(keep_message, "keep_message")
   on_warning <- check_keep(keep_warning, "keep_warning", log_warning)
 
-  output_handler <- output_handler %||% default_output_handler
+  output_handler <- output_handler %||% evaluate_default_output_handler
 
   if (isTRUE(include_timing)) {
     warning("`evaluate(include_timing)` is deprecated")
@@ -144,9 +144,9 @@ evaluate <- function(input,
       with_handlers(
         {
           for (expr in tle$exprs) {
-          ev <- withVisible(eval(expr, envir))
-          watcher$capture_plot_and_output()
-            watcher$print_value(ev$value, ev$visible)
+            ev <- withVisible(eval(expr, envir))
+            watcher$capture_plot_and_output()
+            watcher$print_value(ev$value, ev$visible, envir)
           }
           TRUE
         },

R/output-handler.R

@@ -34,6 +34,9 @@
 #'   * If it has one argument, it called on visible values.
 #'   * If it has two arguments, it handles all values, with the second
 #'     argument indicating whether or not the value is visible.
+#'   * If it has three arguments, it will be called on all values, with the
+#'     the third argument given the evaluation environment which is needed
+#'     to look up print methods for S3 objects.
 #' @param calling_handlers List of [calling handlers][withCallingHandlers].
 #'   These handlers have precedence over the exiting handler installed
 #'   by [evaluate()] when `stop_on_error` is set to 0.

R/output.R

@@ -23,15 +23,31 @@ show_value <- function(handler, visible) {
   visible || length(formals(handler$value)) > 1
 }
 
-handle_value <- function(handler, value, visible) {
+handle_value <- function(handler, value, visible, envir = parent.frame()) {
   n_args <- length(formals(handler$value))
   if (n_args == 1) {
     handler$value(value)
   } else if (n_args == 2) {
     handler$value(value, visible)
+  } else if (n_args == 3) {
+    handler$value(value, visible, envir)
   } else {
     stop("Value output handler must have one or two arguments")
   }
 }
 
-render <- function(x) if (isS4(x)) methods::show(x) else print(x)
+render <- function(value, visible, envir) {
+  if (!visible) {
+    return(invisible())
+  }
+
+  if (isS4(value)) {
+    methods::show(value)
+  } else {
+    # We need to evaluate the print() generic in a child environment of the 
+    # evaluation frame in order to find any methods registered there
+    print_env <- new.env(parent = envir) 
+    print_env$value <- value
+    evalq(print(value), envir = print_env)
+  }
+}

R/replay.R

@@ -33,7 +33,7 @@ replay.list <- function(x) {
 
 #' @export
 replay.default <- function(x) {
-  render(x)
+  render(x, TRUE, parent.frame())
 }
 
 #' @export

R/watchout.R

@@ -80,15 +80,11 @@ watchout <- function(handler = new_output_handler(),
     capture_output()
   }
 
-  print_value <- function(value, visible) {
+  print_value <- function(value, visible, envir) {
     if (!show_value(handler, visible)) 
       return()
 
-    # Ideally we'd evaluate the print() generic in envir in order to find
-    # any methods registered in that environment. That, however, is 
-    # challenging and only makes a few tests a little simpler so we don't
-    # bother.
-    pv <- withVisible(handle_value(handler, value, visible))
+    pv <- withVisible(handle_value(handler, value, visible, envir))
     capture_plot_and_output()
     # If the return value is visible, save the value to the output
     if (pv$visible) {

R/zzz.R

@@ -1,6 +1,13 @@
-# used by knitr to avoid overheard of calling new_output_handler() repeatedly
+# used evaluate() to avoid overhead of calling new_output_handler() repeatedly
+evaluate_default_output_handler <- NULL
+# used by knitr, as above, but also for value handler
 default_output_handler <- NULL
 
 .onLoad <- function(...) {
+  evaluate_default_output_handler <<- new_output_handler()
   default_output_handler <<- new_output_handler()
+  # Match knitr's expectations
+  default_output_handler$value <<- function(x) {
+    render(x, visible = TRUE, envir = parent.frame())
+  }
 }

tests/testthat/test-graphics.R

@@ -43,33 +43,34 @@ test_that("base plots in a single expression are captured", {
 
 test_that("captures ggplots", {
   skip_if_not_installed("ggplot2")
+  library(ggplot2)
+
   ev <- evaluate(
-    "ggplot2::ggplot(mtcars, ggplot2::aes(mpg, wt)) + ggplot2::geom_point()"
+    "ggplot(mtcars, aes(mpg, wt)) + geom_point()"
   )
   expect_output_types(ev, c("source", "plot"))
 
   ev <- evaluate(function() {
     for (j in 1:2) {
-      print(ggplot2::ggplot(mtcars, ggplot2::aes(mpg, wt)) + ggplot2::geom_point())
+      print(ggplot(mtcars, aes(mpg, wt)) + geom_point())
     }
   })
   expect_output_types(ev, c("source", "plot", "plot"))
 })
 
 test_that("erroring ggplots should not be recorded", {
   skip_if_not_installed("ggplot2")
-
+  library(ggplot2)
+
   # error in aesthetics
   ev <- evaluate(function() {
-    ggplot2::ggplot(iris, ggplot2::aes(XXXXXXXXXX, Sepal.Length)) + 
-      ggplot2::geom_boxplot()
+    ggplot(iris, aes(XXXXXXXXXX, Sepal.Length)) + geom_boxplot()
   })
   expect_output_types(ev, c("source", "error"))
 
   # error in geom
   ev <- evaluate(function() {
-    ggplot2::ggplot(iris, ggplot2::aes(Species, Sepal.Length)) + 
-      ggplot2::geom_bar()
+    ggplot(iris, aes(Species, Sepal.Length)) + geom_bar()
   })
   expect_output_types(ev, c("source", "error"))
 })

tests/testthat/test-replay.R

@@ -1,11 +1,7 @@
 test_that("replay() should work when print() returns visible NULLs", {
-  old <- options(prompt = "> ")
-  on.exit(options(old), add = TRUE)
-
-  # need to put S3 method in global namespace otherwise it isn't found
-  assign("print.FOO_BAR", function(x, ...) NULL, envir = globalenv())
-  on.exit(rm(print.FOO_BAR, envir = globalenv()), add = TRUE)
+  withr::local_options(prompt = "> ")
 
+  print.FOO_BAR <- function(x, ...) NULL
   ret <- evaluate('structure(1, class = "FOO_BAR")')
   expect_snapshot(replay(ret))
 })