From e1ece68d9b2211e16301ae233f3af1a8b6846472 Mon Sep 17 00:00:00 2001
From: Hadley Wickham <h.wickham@gmail.com>
Date: Tue, 18 Jun 2024 17:07:08 +0100
Subject: [PATCH 1/3] Create one test for all warning options (#134)

* Set options using withr
* Also test `warn = 2` since testthat bug has long been fixed
---
 tests/testthat/test-evaluate.R | 27 +++++++++++++++------------
 1 file changed, 15 insertions(+), 12 deletions(-)

diff --git a/tests/testthat/test-evaluate.R b/tests/testthat/test-evaluate.R
index 8d186e1..857c297 100644
--- a/tests/testthat/test-evaluate.R
+++ b/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_("

From ec159c035aee39783e8e652b3023434baecf56b6 Mon Sep 17 00:00:00 2001
From: Hadley Wickham <h.wickham@gmail.com>
Date: Tue, 18 Jun 2024 17:08:02 +0100
Subject: [PATCH 2/3] Refactor plot_snapshot (#138)

The logic should be identical, but hopefully it's now a bit easier to understand what's going on.
---
 R/graphics.R | 105 +++++++++++++++++++++++++++++----------------------
 1 file changed, 59 insertions(+), 46 deletions(-)

diff --git a/R/graphics.R b/R/graphics.R
index 0a05483..a1a8734 100644
--- a/R/graphics.R
+++ b/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"
+)

From 7f8d7d567200dbca472d28d1d264333ec576c625 Mon Sep 17 00:00:00 2001
From: Hadley Wickham <h.wickham@gmail.com>
Date: Tue, 18 Jun 2024 17:08:49 +0100
Subject: [PATCH 3/3] Move flush_console() to its own file (#141)

* Make it more self-contained
* Add a test
* Polish docs
---
 R/eval.R                            |  5 +----
 R/flush-console.R                   | 35 +++++++++++++++++++++++++++++
 R/utils.R                           |  4 ++++
 R/watcher.R                         | 17 --------------
 man/flush_console.Rd                |  7 +++---
 tests/testthat/test-flush-console.R | 27 ++++++++++++++++++++++
 6 files changed, 70 insertions(+), 25 deletions(-)
 create mode 100644 R/flush-console.R
 create mode 100644 R/utils.R
 create mode 100644 tests/testthat/test-flush-console.R

diff --git a/R/eval.R b/R/eval.R
index af1703a..fe994ea 100644
--- a/R/eval.R
+++ b/R/eval.R
@@ -165,10 +165,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() {
diff --git a/R/flush-console.R b/R/flush-console.R
new file mode 100644
index 0000000..22290df
--- /dev/null
+++ b/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()
+}
diff --git a/R/utils.R b/R/utils.R
new file mode 100644
index 0000000..c46dda2
--- /dev/null
+++ b/R/utils.R
@@ -0,0 +1,4 @@
+defer <- function(expr, frame = parent.frame(), after = FALSE) {
+  thunk <- as.call(list(function() expr))
+  do.call(on.exit, list(thunk, TRUE, after), envir = frame)
+}
diff --git a/R/watcher.R b/R/watcher.R
index 1864f62..cb37379 100644
--- a/R/watcher.R
+++ b/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()
diff --git a/man/flush_console.Rd b/man/flush_console.Rd
index 85e362d..7ae3176 100644
--- a/man/flush_console.Rd
+++ b/man/flush_console.Rd
@@ -1,8 +1,8 @@
 % Generated by roxygen2: do not edit by hand
-% Please edit documentation in R/watcher.R
+% Please edit documentation in R/flush-console.R
 \name{flush_console}
 \alias{flush_console}
-\title{An emulation of flush.console() in evaluate()}
+\title{An emulation of \code{flush.console()} in \code{evaluate()}}
 \usage{
 flush_console()
 }
@@ -14,8 +14,7 @@ be immediately written out, and more importantly, the \code{text} handler
 (specified in the \code{output_handler} argument of \code{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 \code{evaluate()} (e.g.
 either a direct \code{evaluate()} call or in \pkg{knitr} code chunks).
 }
diff --git a/tests/testthat/test-flush-console.R b/tests/testthat/test-flush-console.R
new file mode 100644
index 0000000..f2ac526
--- /dev/null
+++ b/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")
+})