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..80ce22f 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 (#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. diff --git a/R/evaluate.R b/R/evaluate.R index f541e8a..da62161 100644 --- a/R/evaluate.R +++ b/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 }, 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..7a65f8c 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 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) + } +} 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/R/zzz.R b/R/zzz.R index ccc8811..0b3778a 100644 --- a/R/zzz.R +++ b/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()) + } } 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)) })