diff --git a/NEWS.md b/NEWS.md index 8b38842e..03792504 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,5 +1,6 @@ # evaluate (development version) +* `evaluate()` no longer incorrectly prints the return value of print methods. * `evaluate()` automatically strips calls from conditions emitted by top-level code (these incorrectly get calls because they're wrapped inside `eval()`) (#150). * `evalute(include_timing)` has been deprecated. I can't find any use of it on GitHub, and it adds substantial code complexity for little gain. * `watchout()` is no longer exported; it's really an implementation detail that should never have been leaked to the public interface. diff --git a/R/eval.R b/R/eval.R index 9c97a0b0..f8b98081 100644 --- a/R/eval.R +++ b/R/eval.R @@ -187,14 +187,12 @@ evaluate_top_level_expression <- function(exprs, } } - if (use_try) { - handle <- function(code) { - tryCatch(code, error = function(err) { - list(value = NULL, visible = FALSE) - }) + handle_error <- function(code) { + if (use_try) { + tryCatch(code, error = function(err) NULL) + } else { + code } - } else { - handle <- force } user_handlers <- output_handler$calling_handlers @@ -203,30 +201,27 @@ evaluate_top_level_expression <- function(exprs, handlers <- c(user_handlers, evaluate_handlers) for (expr in exprs) { - ev <- handle( + ev <- handle_error( with_handlers( withVisible(eval(expr, envir)), handlers ) ) + handle_output(TRUE) - if (show_value(output_handler, ev$visible)) { + if (!is.null(ev) && show_value(output_handler, ev$visible)) { # 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 <- handle( + handle_error( with_handlers( - withVisible( - handle_value(output_handler, ev$value, ev$visible) - ), + handle_value(output_handler, ev$value, ev$visible), handlers ) ) handle_output(TRUE) - # If the return value is visible, save the value to the output - if (pv$visible) output <- c(output, list(pv$value)) } } # Always capture last plot, even if incomplete diff --git a/R/output.R b/R/output.R index 4c091e50..949e86eb 100644 --- a/R/output.R +++ b/R/output.R @@ -97,6 +97,9 @@ render <- function(x) if (isS4(x)) methods::show(x) else print(x) #' * 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. +#' +#' The return value of the handler is ignored; its job is to print +#' output to the screen. #' @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/man/new_output_handler.Rd b/man/new_output_handler.Rd index d11e58d6..39e88328 100644 --- a/man/new_output_handler.Rd +++ b/man/new_output_handler.Rd @@ -42,7 +42,10 @@ 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. -}} +} + +The return value of the handler is ignored; its job is to print +output to the screen.} \item{calling_handlers}{List of \link[=withCallingHandlers]{calling handlers}. These handlers have precedence over the exiting handler installed diff --git a/tests/testthat/_snaps/replay.md b/tests/testthat/_snaps/replay.md index 65bf18b3..53f222e2 100644 --- a/tests/testthat/_snaps/replay.md +++ b/tests/testthat/_snaps/replay.md @@ -1,11 +1,3 @@ -# replay() should work when print() returns visible NULLs - - Code - replay(ret) - Output - > structure(1, class = "FOO_BAR") - NULL - # format_condition handles different types of warning Code diff --git a/tests/testthat/test-eval.R b/tests/testthat/test-eval.R index 992033b3..9b8c03c0 100644 --- a/tests/testthat/test-eval.R +++ b/tests/testthat/test-eval.R @@ -120,6 +120,15 @@ test_that("source handled called correctly when src is unparseable", { expect_equal(call, expression()) }) +test_that("visible print() values are not printed", { + # need to put S3 method in global namespace otherwise it isn't found + assign("print.FOO_BAR", function(x, ...) NULL, envir = globalenv()) + defer(rm(print.FOO_BAR, envir = globalenv())) + + ev <- evaluate('structure(1, class = "FOO_BAR")') + expect_output_types(ev, "source") +}) + test_that("has a reasonable print method", { f <- function() { print("1") diff --git a/tests/testthat/test-evaluate.R b/tests/testthat/test-evaluate.R index 8fff0d42..d833f713 100644 --- a/tests/testthat/test-evaluate.R +++ b/tests/testthat/test-evaluate.R @@ -86,27 +86,24 @@ test_that("output and plots interleaved correctly", { expect_output_types(ev, c("source", "plot", "text", "plot", "text")) }) -test_that("return value of value handler inserted directly in output list", { - skip_if_not_installed("ggplot2") - - ev <- evaluate_(' - rnorm(10) - x <- list("I\'m a list!") - suppressPackageStartupMessages(library(ggplot2)) - ggplot(mtcars, aes(mpg, wt)) + geom_point() - ', output_handler = new_output_handler(value = identity) - ) - expect_output_types(ev, c("source", "numeric", "source", "source", "source", "gg")) +test_that("return value of value handler is ignored", { + handler <- new_output_handler(value = identity) + ev <- evaluate_(output_handler = handler, ' + 1 + invisible(1) + ') + expect_output_types(ev, c("source", "source")) }) test_that("invisible values can also be saved if value handler has two arguments", { - handler <- new_output_handler(value = function(x, visible) { - x # always returns a visible value - }) + handler <- new_output_handler(value = function(x, visible) cat(x)) expect_true(show_value(handler, FALSE)) - ev <- evaluate("x<-1:10", output_handler = handler) - expect_output_types(ev, c("source", "integer")) + ev <- evaluate_(output_handler = handler, ' + 1 + invisible(1) + ') + expect_output_types(ev, c("source", "text", "source", "text")) }) test_that("multiple expressions on one line can get printed as expected", { diff --git a/tests/testthat/test-replay.R b/tests/testthat/test-replay.R index 33524169..98e8e19a 100644 --- a/tests/testthat/test-replay.R +++ b/tests/testthat/test-replay.R @@ -1,15 +1,3 @@ -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) - - ret <- evaluate('structure(1, class = "FOO_BAR")') - expect_snapshot(replay(ret)) -}) - test_that("format_condition handles different types of warning", { expect_snapshot({ w1 <- simpleWarning("This is a warning")