Merge commit '7f8d7d567200dbca472d28d1d264333ec576c625'

R/eval.R

@@ -163,10 +163,7 @@ evaluate_top_level_expression <- function(exprs,
     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() {

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()
+}

R/graphics.R

@@ -10,65 +10,78 @@ plot_snapshot <- local({
   last_plot <- NULL
 
   function(incomplete = FALSE) {
-    # to record a plot, at least one device must be open; the list of devices
-    # must not have changed since evaluate() started
-    if (is.null(devs <- dev.list()) || !identical(devs, .env$dev_list)) return(NULL)
-    if (!incomplete && !par('page')) return(NULL)  # current page not complete
+    devs <- dev.list()
+    # No graphics devices 
+    if (is.null(devs)) {
+      return()
+    }
+
+    # Current graphics device changed since evaluate started
+    if (!identical(devs, .env$dev_list)) {
+      return()
+    }
+
+    # current page is incomplete
+    if (!par("page") && !incomplete) {
+      return()
+    }
 
     plot <- recordPlot()
-    if (identical(last_plot, plot) || is_par_change(last_plot, plot)) {
-      return(NULL)
+    if (!makes_visual_change(plot[[1]])) {
+      return()
+    }
+
+    if (!looks_different(last_plot[[1]], plot[[1]])) {
+      return()
     }
 
-    if (is.empty(plot)) return(NULL)
     last_plot <<- plot
     plot
   }
 })
 
-is_par_change <- function(p1, p2) {
-  calls1 <- plot_calls(p1)
-  calls2 <- plot_calls(p2)
-
-  n1 <- length(calls1)
-  n2 <- length(calls2)
+looks_different <- function(old_dl, new_dl) {
+  if (identical(old_dl, new_dl)) {
+    return(FALSE)
+  }
 
-  if (n2 <= n1) return(FALSE)
-  i1 <- seq_len(n1)
-  if (!identical(calls1, calls2[i1])) return(FALSE)
-  # also check if the content of the display list is still the same (note we
-  # need p1[[1]][] as well because [] turns a dotted pair list into a list)
-  if (!identical(p1[[1]][i1], p2[[1]][i1])) return(FALSE)
+  # If the new plot has fewer calls, it must be a visual change
+  if (length(new_dl) < length(old_dl)) {
+    return(TRUE)
+  }
+
+  # If the initial calls are different, it must be a visual change
+  if (!identical(old_dl[], new_dl[seq_along(old_dl)])) {
+    return(TRUE)
+  }
 
-  last <- calls2[(n1 + 1):n2]
-  all(last %in% empty_calls)
+  # If the last calls involve visual changes then it's a visual change
+  added_dl <- new_dl[-seq_along(old_dl)]
+  makes_visual_change(added_dl)
 }
 
-# if all calls are in these elements, the plot is basically empty
-empty_calls <- c("layout", "par", "clip")
-empty_calls <- c(
-  "palette", "palette2",
-  sprintf("C_%s", c(empty_calls, "strWidth", "strHeight", "plot_window"))
-)
-
-is.empty <- function(x) {
-  if (is.null(x)) return(TRUE)
-
-  pc <- plot_calls(x)
-  if (length(pc) == 0) return(TRUE)
+makes_visual_change <- function(plot) {
+  xs <- lapply(plot, function(x) x[[2]][[1]])
 
-  all(pc %in% empty_calls)
+  for (x in xs) {
+    if (hasName(x, "name")) { # base graphics
+      if (!x$name %in% non_visual_calls) {
+        return(TRUE)
+      }
+    } else if (is.call(x)) { # grid graphics
+      if (as.character(x[[1]]) != "requireNamespace") {
+        return(TRUE)
+      }
+    }
+  }
+  FALSE
 }
 
-plot_calls <- function(plot) {
-  el <- lapply(plot[[1]], "[[", 2)
-  if (length(el) == 0) return()
-  unlist(lapply(el, function(x) {
-    # grid graphics do not have x[[1]]$name
-    if (!is.null(nm <- x[[1]][["name"]])) return(nm)
-    nm <- deparse(x[[1]])
-    # the plot element should not be empty, and ignore calls that are simply
-    # requireNamespace()
-    if (length(x[[2]]) > 0 || !all(grepl("^requireNamespace\\(", nm))) nm
-  }))
-}
+non_visual_calls <- c(
+  "C_clip", 
+  "C_layout", 
+  "C_par", 
+  "C_plot_window", 
+  "C_strHeight", "C_strWidth", 
+  "palette", "palette2"
+)

R/utils.R

@@ -1 +1,6 @@
+defer <- function(expr, frame = parent.frame(), after = FALSE) {
+  thunk <- as.call(list(function() expr))
+  do.call(on.exit, list(thunk, TRUE, after), envir = frame)
+}
+
 `%||%` <- function(a, b) if (is.null(a)) b else a

R/watcher.R

@@ -58,20 +58,3 @@ test_con = function(con, test) {
 con_error = function(x) stop(
   x, '... Please make sure not to call closeAllConnections().', call. = FALSE
 )
-
-.env = new.env()
-.env$flush_console = function() {}
-
-#' An emulation of flush.console() in evaluate()
-#'
-#' 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.
-#' @note 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() .env$flush_console()

tests/testthat/test-evaluate.R

@@ -48,24 +48,27 @@ test_that("errors during printing visible values are captured", {
   expect_s3_class(ev[[2]], "error")
 })
 
-test_that("options(warn = -1) suppresses warnings", {
-  ev <- evaluate("op = options(warn = -1); warning('hi'); options(op)")
+test_that("respects warn options", {
+  # suppress warnings
+  withr::local_options(warn = -1)
+  ev <- evaluate("warning('hi')")
   expect_equal(classes(ev), "source")
-})
 
-test_that("options(warn = 0) and options(warn = 1) produces warnings", {
-  ev <- evaluate("op = options(warn = 0); warning('hi'); options(op)")
+  # delayed warnings are always immediate in knitr
+  withr::local_options(warn = 0)
+  ev <- evaluate("warning('hi')")
   expect_equal(classes(ev), c("source", "simpleWarning"))
 
-  ev <- evaluate("op = options(warn = 1); warning('hi'); options(op)")
+  # immediate warnings
+  withr::local_options(warn = 1)
+  ev <- evaluate("warning('hi')")
   expect_equal(classes(ev), c("source", "simpleWarning"))
-})
 
-# See https://github.com/r-lib/evaluate/pull/81#issuecomment-367685196
-# test_that("options(warn = 2) produces errors instead of warnings", {
-#   ev_warn_2 <- evaluate("op = options(warn = 2); warning('hi'); options(op)")
-#   expect_equal(classes(ev_warn_2), c("source", "simpleError"))
-# })
+  # warnings become errors
+  withr::local_options(warn = 2)
+  ev <- evaluate("warning('hi')")
+  expect_equal(classes(ev), c("source", "simpleError"))
+})
 
 test_that("output and plots interleaved correctly", {
   ev <- evaluate_("

tests/testthat/test-flush-console.R

@@ -0,0 +1,27 @@
+
+
+test_that("flush_console() is a null op by default", {
+  expect_no_error(flush_console())
+})
+
+test_that("can set and restore output handler", {
+  f <- function() message("Hi")
+  old <- set_output_handler(function() message("Hi"))
+  expect_equal(.env$output_handler, f)
+  expect_equal(old, NULL)
+
+  expect_message(flush_console(), "Hi")
+  old2 <- set_output_handler(old)
+  expect_equal(old2, f)
+})
+
+test_that("can use flush_console() inside evaluate", {
+  test <- function() {
+    cat("hi")
+    flush_console()
+    cat("bye")
+  }
+  ev <- evaluate("test()")
+  expect_equal(ev[[2]], "hi")
+  expect_equal(ev[[3]], "bye")
+})