diff --git a/NEWS.md b/NEWS.md index 4069366..ac9f429 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,5 +1,6 @@ # evaluate (development version) +* The `source` output handler can now take two arguments (the unparsed `src` and the parsed `call`) and choose to affect the displayed source. # Version 0.23 diff --git a/R/eval.R b/R/eval.R index 3c51da3..3f12487 100644 --- a/R/eval.R +++ b/R/eval.R @@ -58,8 +58,7 @@ evaluate <- function(input, parsed <- parse_all(input, filename, stop_on_error != 2L) if (inherits(err <- attr(parsed, 'PARSE_ERROR'), 'error')) { - source <- new_source(parsed$src) - output_handler$source(source) + source <- new_source(parsed$src, call[[1]], output_handler$source) output_handler$error(err) err$call <- NULL # the call is unlikely to be useful return(list(source, err)) @@ -124,6 +123,9 @@ evaluate <- function(input, } } + is_empty <- vapply(out, identical, list(NULL), FUN.VALUE = logical(1)) + out <- out[!is_empty] + unlist(out, recursive = FALSE, use.names = FALSE) } @@ -143,8 +145,7 @@ evaluate_call <- function(call, if (debug) message(src) if (is.null(call) && !last) { - source <- new_source(src) - output_handler$source(source) + source <- new_source(src, call[[1]], output_handler$source) return(list(source)) } stopifnot(is.call(call) || is.language(call) || is.atomic(call) || is.null(call)) @@ -161,8 +162,7 @@ evaluate_call <- function(call, cat(src, "\n", sep = "", file = stderr()) } - source <- new_source(src) - output_handler$source(source) + source <- new_source(src, call[[1]], output_handler$source) output <- list(source) dev <- dev.cur() diff --git a/R/output.R b/R/output.R index 347378a..740cdb1 100644 --- a/R/output.R +++ b/R/output.R @@ -19,8 +19,23 @@ new_value <- function(value, visible = TRUE) { structure(list(value = value, visible = visible), class = "value") } -new_source <- function(src) { - structure(list(src = src), class = "source") +new_source <- function(src, call, handler = NULL) { + src <- structure(list(src = src), class = "source") + if (is.null(handler)) { + return(src) + } + + n_args <- length(formals(handler)) + if (n_args == 1) { + # Old format only called for side effects + handler(src) + src + } else if (n_args == 2) { + # New format can influence result + handler(src, call) + } else { + stop("Source output handler must have one or two arguments") + } } classes <- function(x) vapply(x, function(x) class(x)[1], character(1)) @@ -45,6 +60,11 @@ render <- function(x) if (isS4(x)) methods::show(x) else print(x) #' printing, then the `text` or `graphics` handlers may be called. #' #' @param source Function to handle the echoed source code under evaluation. +#' This function should take two arguments (`src` and `call`), and return +#' an object that will be inserted into the evaluate outputs. +#' +#' Return `src` for the default evaluate behaviour. Return `NULL` to +#' drop the source from the output. #' @param text Function to handle any textual console output. #' @param graphics Function to handle graphics, as returned by #' [recordPlot()]. diff --git a/man/new_output_handler.Rd b/man/new_output_handler.Rd index 700f8c4..1733f1e 100644 --- a/man/new_output_handler.Rd +++ b/man/new_output_handler.Rd @@ -17,7 +17,12 @@ new_output_handler( ) } \arguments{ -\item{source}{Function to handle the echoed source code under evaluation.} +\item{source}{Function to handle the echoed source code under evaluation. +This function should take two arguments (\code{src} and \code{call}), and return +an object that will be inserted into the evaluate outputs. + +Return \code{src} for the default evaluate behaviour. Return \code{NULL} to +drop the source from the output.} \item{text}{Function to handle any textual console output.} diff --git a/tests/testthat/_snaps/eval.md b/tests/testthat/_snaps/eval.md index cc394bd..902c8cc 100644 --- a/tests/testthat/_snaps/eval.md +++ b/tests/testthat/_snaps/eval.md @@ -25,3 +25,11 @@ Warning: This is a warning +# can conditionally omit output with output handler + + Code + replay(out) + Output + > x + [1] 1 + diff --git a/tests/testthat/_snaps/output.md b/tests/testthat/_snaps/output.md new file mode 100644 index 0000000..537ed9d --- /dev/null +++ b/tests/testthat/_snaps/output.md @@ -0,0 +1,8 @@ +# handles various numbers of arguments + + Code + new_source("x", quote(x), f3) + Condition + Error in `new_source()`: + ! Source output handler must have one or two arguments + diff --git a/tests/testthat/test-eval.R b/tests/testthat/test-eval.R index 10a522d..c3a589d 100644 --- a/tests/testthat/test-eval.R +++ b/tests/testthat/test-eval.R @@ -43,3 +43,19 @@ test_that("show_warning handles different types of warning", { }) }) + +test_that("can conditionally omit output with output handler", { + hide_source <- function(src, call) { + if (is.call(call) && identical(call[[1]], quote(hide))) { + NULL + } else { + src + } + } + handler <- new_output_handler(source = hide_source) + hide <- function(x) invisible(x) + + out <- evaluate("hide(x <- 1)\nx", output_handler = handler) + expect_length(out, 2) + expect_snapshot(replay(out)) +}) diff --git a/tests/testthat/test-output.R b/tests/testthat/test-output.R index edd431d..a7bc251 100644 --- a/tests/testthat/test-output.R +++ b/tests/testthat/test-output.R @@ -4,3 +4,29 @@ test_that("open plot windows maintained", { expect_length(dev.list(), n) }) + +# new_source ------------------------------------------------------------------- + +test_that("handles various numbers of arguments", { + signal_condition <- function(class) { + signalCondition(structure(list(), class = c(class, "condition"))) + } + expected <- structure(list(src = "x"), class = "source") + + # No handler + expect_equal(new_source("x", quote(x)), expected) + + # One argument + f1 <- function(src) signal_condition("handler_called") + expect_condition(out <- new_source("x", quote(x), f1), class = "handler_called") + expect_equal(out, expected) + + # Two arguments + f2 <- function(src, call) {signal_condition("handler_called"); NULL} + expect_condition(out <- new_source("x", quote(x), f2), class = "handler_called") + expect_equal(out, NULL) + + # Three arguments + f3 <- function(a, b, c) NULL + expect_snapshot(new_source("x", quote(x), f3), error = TRUE) +})