Merge commit '31521799a4256e8570c703756eca3350d973fc10'

DESCRIPTION

@@ -28,7 +28,7 @@ Imports:
     methods
 Suggests:
     covr,
-    ggplot2,
+    ggplot2 (>= 3.3.6),
     lattice,
     rlang,
     testthat (>= 3.0.0),

NEWS.md

@@ -1,5 +1,7 @@
 # evaluate (development version)
 
+* `evaluate()` now correctly captures plots created before messages/warnings/errors (#28).
+
 # evaluate 0.24.0
 
 * The `source` output handler can now take two arguments (the unparsed `src` 

R/eval.R

@@ -64,15 +64,14 @@ evaluate <- function(input,
     return(list(source, err))
   }
 
-  if (is.null(enclos)) {
-    enclos <- if (is.list(envir) || is.pairlist(envir)) parent.frame() else baseenv()
+  if (is.list(envir)) {
+    envir <- list2env(envir, parent = enclos %||% parent.frame())
   }
 
   if (new_device) {
-    # Start new graphics device and clean up afterwards
-    if (identical(grDevices::pdf, getOption("device"))) {
-      dev.new(file = NULL)
-    } else dev.new()
+    # Ensure we have a graphics device available for recording, but choose
+    # one that's available on all platforms and doesn't write to disk
+    pdf(file = NULL)
     dev.control(displaylist = "enable")
     dev <- dev.cur()
     on.exit(dev.off(dev))
@@ -103,15 +102,11 @@ evaluate <- function(input,
     if (length(dev.list()) < devn) dev.set(dev)
     devn <- length(dev.list())
 
-    expr <- parsed$expr[[i]]
-    if (!is.null(expr))
-      expr <- as.expression(expr)
-    out[[i]] <- evaluate_call(
-      expr,
-      parsed$src[[i]],
+    out[[i]] <- evaluate_top_level_expression(
+      exprs = parsed$expr[[i]],
+      src = parsed$src[[i]],
       watcher = watcher,
       envir = envir,
-      enclos = enclos,
       last = i == length(out),
       use_try = stop_on_error != 2L,
       keep_warning = keep_warning,
@@ -136,62 +131,46 @@ evaluate <- function(input,
   unlist(out, recursive = FALSE, use.names = FALSE)
 }
 
-evaluate_call <- function(call,
-                          src,
-                          watcher,
-                          envir = parent.frame(),
-                          enclos = NULL,
-                          last = FALSE,
-                          use_try = FALSE,
-                          keep_warning = TRUE,
-                          keep_message = TRUE,
-                          log_echo = FALSE,
-                          log_warning = FALSE,
-                          output_handler = new_output_handler(),
-                          include_timing = FALSE) {
-  if (is.null(call) && !last) {
-    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))
+evaluate_top_level_expression <- function(exprs,
+                                          src,
+                                          watcher,
+                                          envir = parent.frame(),
+                                          last = FALSE,
+                                          use_try = FALSE,
+                                          keep_warning = TRUE,
+                                          keep_message = TRUE,
+                                          log_echo = FALSE,
+                                          log_warning = FALSE,
+                                          output_handler = new_output_handler(),
+                                          include_timing = FALSE) {
+  stopifnot(is.expression(exprs))
 
   if (log_echo && !is.null(src)) {
     cat(src, "\n", sep = "", file = stderr())
   }
 
-  source <- new_source(src, call[[1]], output_handler$source)
+  source <- new_source(src, exprs[[1]], output_handler$source)
   output <- list(source)
 
   dev <- dev.cur()
-  handle_output <- function(plot = FALSE, incomplete_plots = FALSE) {
+  handle_output <- function(plot = TRUE, incomplete_plots = FALSE) {
     # if dev.cur() has changed, we should not record plots any more
     plot <- plot && identical(dev, dev.cur())
     out <- watcher(plot, incomplete_plots)
     output <<- c(output, out)
   }
 
-  flush_old <- .env$flush_console; on.exit({
-    .env$flush_console <- flush_old
-  }, add = TRUE)
-  .env$flush_console <- function() handle_output(FALSE)
+  local_output_handler(function() handle_output(FALSE))
 
   # Hooks to capture plot creation
-  capture_plot <- function() {
-    handle_output(TRUE)
-  }
   hook_list <- list(
-    persp = capture_plot,
-    before.plot.new = capture_plot,
-    before.grid.newpage = capture_plot
+    persp = handle_output,
+    before.plot.new = handle_output,
+    before.grid.newpage = handle_output
   )
   set_hooks(hook_list)
   on.exit(remove_hooks(hook_list), add = TRUE)
 
-  handle_condition <- function(cond) {
-    handle_output()
-    output <<- c(output, list(cond))
-  }
-
   # Handlers for warnings, errors and messages
   wHandler <- function(wn) {
     if (log_warning) {
@@ -203,21 +182,28 @@ evaluate_call <- function(call,
     if (getOption("warn") >= 2) return()
 
     if (keep_warning && getOption("warn") >= 0) {
-      handle_condition(wn)
+      handle_output()
+      output <<- c(output, list(wn))
       output_handler$warning(wn)
     }
     invokeRestart("muffleWarning")
   }
-  eHandler <- if (use_try) function(e) {
-    handle_condition(e)
-    output_handler$error(e)
-  } else identity
-  mHandler <- if (is.na(keep_message)) identity else function(m) {
-    if (keep_message) {
-      handle_condition(m)
+  eHandler <- function(e) {
+    handle_output()
+    if (use_try) {
+      output <<- c(output, list(e))
+      output_handler$error(e)
+    }
+  }
+  mHandler <- function(m) {
+    handle_output()
+    if (isTRUE(keep_message)) {
+      output <<- c(output, list(m))
       output_handler$message(m)
+      invokeRestart("muffleMessage")
+    } else if (isFALSE(keep_message)) {
+      invokeRestart("muffleMessage")
     }
-    invokeRestart("muffleMessage")
   }
 
   ev <- list(value = NULL, visible = FALSE)
@@ -227,7 +213,6 @@ evaluate_call <- function(call,
   } else {
     handle <- force
   }
-  value_handler <- output_handler$value
   if (include_timing) {
     timing_fn <- function(x) system.time(x)[1:3]
   } else {
@@ -245,12 +230,11 @@ evaluate_call <- function(call,
 
   user_handlers <- output_handler$calling_handlers
 
-  multi_args <- length(formals(value_handler)) > 1
-  for (expr in call) {
+  for (expr in exprs) {
     srcindex <- length(output)
     time <- timing_fn(handle(
       ev <- withCallingHandlers(
-        withVisible(eval_with_user_handlers(expr, envir, enclos, user_handlers)),
+        withVisible(eval_with_user_handlers(expr, envir, user_handlers)),
         warning = wHandler,
         error = eHandler,
         message = mHandler
@@ -260,14 +244,10 @@ evaluate_call <- function(call,
     if (!is.null(time))
       attr(output[[srcindex]]$src, 'timing') <- time
 
-    # If visible or the value handler has multi args, process and capture output
-    if (ev$visible || multi_args) {
+    if (show_value(output_handler, ev$visible)) {
       pv <- list(value = NULL, visible = FALSE)
-      value_fun <- if (multi_args) value_handler else {
-        function(x, visible) value_handler(x)
-      }
       handle(pv <- withCallingHandlers(withVisible(
-        value_fun(ev$value, ev$visible)
+        handle_value(output_handler, ev$value, ev$visible)
       ), warning = wHandler, error = eHandler, message = mHandler))
       handle_output(TRUE)
       # If the return value is visible, save the value to the output
@@ -282,9 +262,9 @@ evaluate_call <- function(call,
   output
 }
 
-eval_with_user_handlers <- function(expr, envir, enclos, calling_handlers) {
+eval_with_user_handlers <- function(expr, envir, calling_handlers) {
   if (!length(calling_handlers)) {
-    return(eval(expr, envir, enclos))
+    return(eval(expr, envir))
   }
 
   if (!is.list(calling_handlers)) {
@@ -293,7 +273,7 @@ eval_with_user_handlers <- function(expr, envir, enclos, calling_handlers) {
 
   call <- as.call(c(
     quote(withCallingHandlers),
-    quote(eval(expr, envir, enclos)),
+    quote(eval(expr, envir)),
     calling_handlers
   ))
 

R/evaluate-package.R

@@ -0,0 +1,6 @@
+#' @keywords internal
+"_PACKAGE"
+
+## usethis namespace: start
+## usethis namespace: end
+NULL

R/flush-console.R

@@ -0,0 +1,35 @@
+#' An emulation of `flush.console()` in `evaluate()`
+#'
+#' @description
+#' When [evaluate()] is evaluating code, the text output is diverted into
+#' an internal connection, and there is no way to flush that connection. This
+#' function provides a way to "flush" the connection so that any text output can
+#' be immediately written out, and more importantly, the `text` handler
+#' (specified in the `output_handler` argument of `evaluate()`) will
+#' be called, which makes it possible for users to know it when the code
+#' produces text output using the handler.
+#' 
+#' This function is supposed to be called inside `evaluate()` (e.g.
+#' either a direct `evaluate()` call or in \pkg{knitr} code chunks).
+#' @export
+flush_console = function() {
+  if (!is.null(.env$output_handler)) {
+    .env$output_handler()
+  }
+  invisible()
+}
+
+.env = new.env()
+.env$output_handler <- NULL
+
+set_output_handler <- function(handler) {
+  old <- .env$output_handler
+  .env$output_handler <- handler
+  invisible(old)
+} 
+
+local_output_handler <- function(handler, frame = parent.frame()) {
+  old <- set_output_handler(handler)
+  defer(set_output_handler(old), frame)
+  invisible()
+}