From 1178ea92e3b6fe17224ad34b0e0e5d992669a81f Mon Sep 17 00:00:00 2001 From: Hadley Wickham Date: Wed, 3 Jul 2024 15:31:03 -0500 Subject: [PATCH] Evaluate print in evaluation environment Fixes #192 --- DESCRIPTION | 2 +- NEWS.md | 1 + R/evaluate.R | 2 +- R/output-handler.R | 3 +++ R/output.R | 20 ++++++++++++++++++-- R/replay.R | 2 +- R/watchout.R | 8 ++------ man/new_output_handler.Rd | 3 +++ tests/testthat/test-graphics.R | 15 ++++++++------- tests/testthat/test-replay.R | 8 ++------ 10 files changed, 40 insertions(+), 24 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index b0cdfc7..b7b60f9 100644 --- a/DESCRIPTION +++ b/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 diff --git a/NEWS.md b/NEWS.md index 2a52938..6617888 100644 --- a/NEWS.md +++ b/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 (@) * `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. diff --git a/R/evaluate.R b/R/evaluate.R index f541e8a..53d4645 100644 --- a/R/evaluate.R +++ b/R/evaluate.R @@ -146,7 +146,7 @@ evaluate <- function(input, for (expr in tle$exprs) { ev <- withVisible(eval(expr, envir)) watcher$capture_plot_and_output() - watcher$print_value(ev$value, ev$visible) + watcher$print_value(ev$value, ev$visible, envir) } TRUE }, diff --git a/R/output-handler.R b/R/output-handler.R index 59d099a..1c1ad45 100644 --- a/R/output-handler.R +++ b/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. diff --git a/R/output.R b/R/output.R index fa3b261..19c504e 100644 --- a/R/output.R +++ b/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 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) + } +} diff --git a/R/replay.R b/R/replay.R index e1a0d1f..c797dd6 100644 --- a/R/replay.R +++ b/R/replay.R @@ -33,7 +33,7 @@ replay.list <- function(x) { #' @export replay.default <- function(x) { - render(x) + render(x, TRUE, parent.frame()) } #' @export diff --git a/R/watchout.R b/R/watchout.R index 8b916c9..abe46b4 100644 --- a/R/watchout.R +++ b/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) { diff --git a/man/new_output_handler.Rd b/man/new_output_handler.Rd index de20549..6e37230 100644 --- a/man/new_output_handler.Rd +++ b/man/new_output_handler.Rd @@ -43,6 +43,9 @@ drop the source from the output.} \item If it has one argument, it called on visible values. \item If it has two arguments, it handles all values, with the second argument indicating whether or not the value is visible. +\item 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. }} \item{calling_handlers}{List of \link[=withCallingHandlers]{calling handlers}. diff --git a/tests/testthat/test-graphics.R b/tests/testthat/test-graphics.R index 872a6fa..618a4a3 100644 --- a/tests/testthat/test-graphics.R +++ b/tests/testthat/test-graphics.R @@ -43,14 +43,16 @@ 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")) @@ -58,18 +60,17 @@ test_that("captures ggplots", { 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")) }) diff --git a/tests/testthat/test-replay.R b/tests/testthat/test-replay.R index 651d518..f587248 100644 --- a/tests/testthat/test-replay.R +++ b/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)) })