From ab6b58c7b47f564a79e67d1f591f2638d21313f6 Mon Sep 17 00:00:00 2001
From: Hadley Wickham <h.wickham@gmail.com>
Date: Wed, 19 Jun 2024 14:50:01 +0100
Subject: [PATCH 1/5] Minor test/doc/code refactoring (#158)

---
 R/eval.R                        |  2 +-
 R/output.R                      | 28 +++++++++++++++++++---------
 R/utils.R                       |  1 +
 man/evaluate.Rd                 |  2 +-
 tests/testthat/_snaps/output.md | 23 +++++++++++++++++++++++
 tests/testthat/test-errors.R    | 13 ++++++-------
 tests/testthat/test-eval.R      |  2 +-
 tests/testthat/test-evaluate.R  | 19 -------------------
 tests/testthat/test-output.R    | 12 +++++++-----
 9 files changed, 59 insertions(+), 43 deletions(-)

diff --git a/R/eval.R b/R/eval.R
index a2c5ac6..e3f1ef0 100644
--- a/R/eval.R
+++ b/R/eval.R
@@ -50,7 +50,7 @@ evaluate <- function(input,
                      log_echo = FALSE,
                      log_warning = FALSE,
                      new_device = TRUE,
-                     output_handler = default_output_handler,
+                     output_handler = new_output_handler(),
                      filename = NULL,
                      include_timing = FALSE) {
   stop_on_error <- as.integer(stop_on_error)
diff --git a/R/output.R b/R/output.R
index fd594ed..4c091e5 100644
--- a/R/output.R
+++ b/R/output.R
@@ -104,9 +104,12 @@ render <- function(x) if (isS4(x)) methods::show(x) else print(x)
 #' @aliases output_handler
 #' @export
 new_output_handler <- function(source = identity,
-                               text = identity, graphics = identity,
-                               message = identity, warning = identity,
-                               error = identity, value = render,
+                               text = identity,
+                               graphics = identity,
+                               message = identity,
+                               warning = identity,
+                               error = identity,
+                               value = render,
                                calling_handlers = list()) {
   source <- match.fun(source)
   stopifnot(length(formals(source)) >= 1)
@@ -125,10 +128,19 @@ new_output_handler <- function(source = identity,
 
   check_handlers(calling_handlers)
 
-  structure(list(source = source, text = text, graphics = graphics,
-                 message = message, warning = warning, error = error,
-                 value = value, calling_handlers = calling_handlers),
-            class = "output_handler")
+  structure(
+    list(
+      source = source,
+      text = text,
+      graphics = graphics,
+      message = message,
+      warning = warning,
+      error = error,
+      value = value,
+      calling_handlers = calling_handlers
+    ),
+    class = "output_handler"
+  )
 }
 
 check_handlers <- function(x) {
@@ -157,5 +169,3 @@ stop_bad_handlers <- function() {
     call = call("new_output_handler")
   ))
 }
-
-default_output_handler <- new_output_handler()
diff --git a/R/utils.R b/R/utils.R
index e01f97b..36e65c8 100644
--- a/R/utils.R
+++ b/R/utils.R
@@ -8,6 +8,7 @@ indent <- function(x, by = "  ", drop_trailing_nl = TRUE) {
   }
   paste0(by, gsub("\n", paste0("\n", by), x))
 }
+
 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/man/evaluate.Rd b/man/evaluate.Rd
index 49a3691..ba35886 100644
--- a/man/evaluate.Rd
+++ b/man/evaluate.Rd
@@ -15,7 +15,7 @@ evaluate(
   log_echo = FALSE,
   log_warning = FALSE,
   new_device = TRUE,
-  output_handler = default_output_handler,
+  output_handler = new_output_handler(),
   filename = NULL,
   include_timing = FALSE
 )
diff --git a/tests/testthat/_snaps/output.md b/tests/testthat/_snaps/output.md
index 537ed9d..6066f6c 100644
--- a/tests/testthat/_snaps/output.md
+++ b/tests/testthat/_snaps/output.md
@@ -1,3 +1,26 @@
+# calling handlers are checked
+
+    Code
+      check_handlers(list(condition = 1))
+    Condition
+      Error in `new_output_handler()`:
+      ! `calling_handlers` must be a named list of functions.
+    Code
+      check_handlers(list(function(...) NULL))
+    Condition
+      Error in `new_output_handler()`:
+      ! `calling_handlers` must be a named list of functions.
+    Code
+      check_handlers(stats::setNames(list(function(...) NULL), NA))
+    Condition
+      Error in `new_output_handler()`:
+      ! `calling_handlers` must be a named list of functions.
+    Code
+      check_handlers(stats::setNames(list(function(...) NULL), ""))
+    Condition
+      Error in `new_output_handler()`:
+      ! `calling_handlers` must be a named list of functions.
+
 # handles various numbers of arguments
 
     Code
diff --git a/tests/testthat/test-errors.R b/tests/testthat/test-errors.R
index 66df94b..d655b0d 100644
--- a/tests/testthat/test-errors.R
+++ b/tests/testthat/test-errors.R
@@ -32,11 +32,10 @@ test_that("traceback useful if stop_on_error == 2L", {
 })
 
 test_that("capture messages in try() (#88)", {
-  ev <- evaluate_('
-    g <- function() f("error")
-    f <- function(x) stop(paste0("Obscure ", x))
-    
-    try(g())
-  ')  
-  expect_match(ev[[length(ev)]], "Obscure error")
+  f <- function(x) stop(paste0("Obscure ", x))
+  g <- function() f("error")
+
+  ev <- evaluate_('try(g())')
+  expect_output_types(ev, c("source", "text"))
+  expect_match(ev[[2]], "Obscure error")
 })
diff --git a/tests/testthat/test-eval.R b/tests/testthat/test-eval.R
index 65170a9..3c78fee 100644
--- a/tests/testthat/test-eval.R
+++ b/tests/testthat/test-eval.R
@@ -1,5 +1,5 @@
 test_that("all condition handlers first capture output", {
-  test <- function(){
+  test <- function() {
     plot(1, main = "one")
     message("this is an message!")
     plot(2, main = "two")
diff --git a/tests/testthat/test-evaluate.R b/tests/testthat/test-evaluate.R
index 097ddb9..8fff0d4 100644
--- a/tests/testthat/test-evaluate.R
+++ b/tests/testthat/test-evaluate.R
@@ -136,22 +136,3 @@ test_that("user can register calling handlers", {
   evaluate("stop('tilt')", stop_on_error = 0, output_handler = out_hnd)
   expect_s3_class(handled, "error")
 })
-
-test_that("calling handlers are checked", {
-  expect_error(
-    new_output_handler(calling_handlers = list(condition = 1)),
-    "must be"
-  )
-  expect_error(
-    new_output_handler(calling_handlers = list(function(...) NULL)),
-    "must be"
-  )
-  expect_error(
-    new_output_handler(calling_handlers = stats::setNames(list(function(...) NULL), NA)),
-    "must be"
-  )
-  expect_error(
-    new_output_handler(calling_handlers = stats::setNames(list(function(...) NULL), "")),
-    "must be"
-  )
-})
diff --git a/tests/testthat/test-output.R b/tests/testthat/test-output.R
index ffe52da..0222d7f 100644
--- a/tests/testthat/test-output.R
+++ b/tests/testthat/test-output.R
@@ -1,10 +1,12 @@
-test_that("open plot windows maintained", {
-  n <- length(dev.list())
-  evaluate("plot(1)")
-  expect_length(dev.list(), n)
+test_that("calling handlers are checked", {
+  expect_snapshot(error = TRUE, {
+    check_handlers(list(condition = 1))
+    check_handlers(list(function(...) NULL))
+    check_handlers(stats::setNames(list(function(...) NULL), NA))
+    check_handlers(stats::setNames(list(function(...) NULL), ""))
+  })
 })
 
-
 # new_source -------------------------------------------------------------------
 
 test_that("handles various numbers of arguments", {

From 7a68cb9ffd39b3d67a2e07caef45b9a9c6d3ed01 Mon Sep 17 00:00:00 2001
From: Hadley Wickham <h.wickham@gmail.com>
Date: Thu, 20 Jun 2024 13:14:15 +0100
Subject: [PATCH 2/5] Deprecate include_timing (#159)

I can't find any evidence of use of GitHub, it was never tested, and it adds a substantial amount of complexity to the code.
---
 NEWS.md         |  1 +
 R/eval.R        | 33 +++++++++++----------------------
 R/replay.R      | 35 +----------------------------------
 man/evaluate.Rd |  5 +----
 4 files changed, 14 insertions(+), 60 deletions(-)

diff --git a/NEWS.md b/NEWS.md
index aceb1f5..d65af17 100644
--- a/NEWS.md
+++ b/NEWS.md
@@ -1,5 +1,6 @@
 # evaluate (development version)
 
+* `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.
 * `evaluate()` gains an output class (`evaluate_evaluation`/`list`) and a basic print method.
 * `evaluate()` now correctly captures plots created before messages/warnings/errors (#28).
diff --git a/R/eval.R b/R/eval.R
index e3f1ef0..1c6321a 100644
--- a/R/eval.R
+++ b/R/eval.R
@@ -35,10 +35,7 @@
 #'   processes the output from the evaluation. The default simply prints the
 #'   visible return values.
 #' @param filename string overrriding the [base::srcfile()] filename.
-#' @param include_timing if `TRUE`, evaluate will wrap each input
-#'   expression in `system.time()`, which will be accessed by following
-#'   `replay()` call to produce timing information for each evaluated
-#'   command.
+#' @param include_timing Deprecated. 
 #' @import graphics grDevices utils
 evaluate <- function(input,
                      envir = parent.frame(),
@@ -56,6 +53,10 @@ evaluate <- function(input,
   stop_on_error <- as.integer(stop_on_error)
   stopifnot(length(stop_on_error) == 1)
 
+  if (isTRUE(include_timing)) {
+    warning("`evaluate(include_timing)` is deprecated")
+  }
+
   parsed <- parse_all(input, filename, stop_on_error != 2L)
   if (inherits(err <- attr(parsed, 'PARSE_ERROR'), 'error')) {
     source <- new_source(parsed$src, expression(), output_handler$source)
@@ -91,8 +92,7 @@ evaluate <- function(input,
       keep_warning = keep_warning,
       keep_message = keep_message,
       log_warning = log_warning,
-      output_handler = output_handler,
-      include_timing = include_timing
+      output_handler = output_handler
     )
     watcher$check_devices()
 
@@ -120,8 +120,7 @@ evaluate_top_level_expression <- function(exprs,
                                           keep_warning = TRUE,
                                           keep_message = TRUE,
                                           log_warning = FALSE,
-                                          output_handler = new_output_handler(),
-                                          include_timing = FALSE) {
+                                          output_handler = new_output_handler()) {
   stopifnot(is.expression(exprs))
 
   source <- new_source(src, exprs[[1]], output_handler$source)
@@ -190,11 +189,6 @@ evaluate_top_level_expression <- function(exprs,
   } else {
     handle <- force
   }
-  if (include_timing) {
-    timing_fn <- function(x) system.time(x)[1:3]
-  } else {
-    timing_fn <- function(x) {x; NULL}
-  }
 
   user_handlers <- output_handler$calling_handlers
   evaluate_handlers <- list(error = eHandler, warning = wHandler, message = mHandler)
@@ -202,18 +196,13 @@ evaluate_top_level_expression <- function(exprs,
   handlers <- c(user_handlers, evaluate_handlers)
 
   for (expr in exprs) {
-    srcindex <- length(output)
-    time <- timing_fn(
-      ev <- handle(
-        with_handlers(
-          withVisible(eval(expr, envir)),
-          handlers
-        )
+    ev <- handle(
+      with_handlers(
+        withVisible(eval(expr, envir)),
+        handlers
       )
     )
     handle_output(TRUE)
-    if (!is.null(time))
-      attr(output[[srcindex]]$src, 'timing') <- time
 
     if (show_value(output_handler, ev$visible)) {
       # Ideally we'd evaluate the print() generic in envir in order to find
diff --git a/R/replay.R b/R/replay.R
index d431e61..a22e265 100644
--- a/R/replay.R
+++ b/R/replay.R
@@ -41,8 +41,7 @@ replay.character <- function(x) {
 
 #' @export
 replay.source <- function(x) {
-  s <- if (is.null(attr(x$src,'timing'))) '' else render_timing(attr(x$src, 'timing'))
-  cat(paste0(s, line_prompt(x$src)))
+  cat(line_prompt(x$src))
 }
 
 #' @export
@@ -70,38 +69,6 @@ replay.recordedplot <- function(x) {
   print(x)
 }
 
-render_timing <- function(t) {
-  if (max(t) < 0.5) '' else paste0(
-    '[', render_sec(t[[1]] + t[[2]]), # User time + Kernel time
-    ',', render_sec(t[[3]]), # Wall time
-    ']'
-  )
-}
-
-render_sec <- function(s) {
-  if (s < 0.005) return('<5ms')
-  if (s < 1) return(paste0(round(s,2), 's'))
-  if (s < 10) return(paste0(round(s,1), 's'))
-  sec <- round(s,0)
-  if (sec < 120) return(paste0(sec, 's'))
-  min <- floor(sec/60)
-  sec <- sec - min*60
-  if (min < 10) return(paste0(
-    min, 'm', formatC(sec, digits = 0, width = 2, format = "f", flag = "0"), 's'
-  ))
-  min <- min + round(sec/60, 0)
-  if (min < 120) return(paste0(min, 'm'))
-  h <- floor(min/60)
-  min <- min - h * 60
-  if (h < 48) return(paste0(
-    h, 'h', formatC(min, digits = 0, width = 2, format = "f", flag = "0"), 'm'
-  ))
-  d <- floor(h/24)
-  h <- h - d*24
-  return(paste0(d, 'd', h, 'h'))
-}
-
-
 format_condition <- function(x) {
   if (inherits(x, "rlang_warning") || inherits(x, "rlang_error")) {
     format(x)
diff --git a/man/evaluate.Rd b/man/evaluate.Rd
index ba35886..9093d1a 100644
--- a/man/evaluate.Rd
+++ b/man/evaluate.Rd
@@ -58,10 +58,7 @@ visible return values.}
 
 \item{filename}{string overrriding the \code{\link[base:srcfile]{base::srcfile()}} filename.}
 
-\item{include_timing}{if \code{TRUE}, evaluate will wrap each input
-expression in \code{system.time()}, which will be accessed by following
-\code{replay()} call to produce timing information for each evaluated
-command.}
+\item{include_timing}{Deprecated.}
 }
 \description{
 Compare to \code{\link[=eval]{eval()}}, \code{evaluate} captures all of the

From ac267336fb5c9be88bf6995fc880ff8bd3bacc23 Mon Sep 17 00:00:00 2001
From: Hadley Wickham <h.wickham@gmail.com>
Date: Thu, 20 Jun 2024 13:51:40 +0100
Subject: [PATCH 3/5] Tidy up condition handlers (#160)

* Call the condition `cnd`
* Define in "usual" order (message, warning, error)
* Refactoring warning handler to make logic clearer
---
 R/eval.R | 49 ++++++++++++++++++++++++++-----------------------
 1 file changed, 26 insertions(+), 23 deletions(-)

diff --git a/R/eval.R b/R/eval.R
index 1c6321a..4d06cbc 100644
--- a/R/eval.R
+++ b/R/eval.R
@@ -146,37 +146,40 @@ evaluate_top_level_expression <- function(exprs,
   on.exit(remove_hooks(hook_list), add = TRUE)
 
   # Handlers for warnings, errors and messages
-  wHandler <- function(wn) {
-    if (log_warning) {
-      cat(format_condition(wn), "\n", sep = "", file = stderr())
+  mHandler <- function(cnd) {
+    handle_output()
+    if (isTRUE(keep_message)) {
+      output <<- c(output, list(cnd))
+      output_handler$message(cnd)
+      invokeRestart("muffleMessage")
+    } else if (isFALSE(keep_message)) {
+      invokeRestart("muffleMessage")
     }
-    if (is.na(keep_warning)) return()
-
-    # do not handle the warning as it will be raised as error after
+  }
+  wHandler <- function(cnd) {
+    # do not handle warnings that shortly become errors
     if (getOption("warn") >= 2) return()
+    # do not handle warnings that have been completely silenced
+    if (getOption("warn") < 0) return()
 
-    if (keep_warning && getOption("warn") >= 0) {
-      handle_output()
-      output <<- c(output, list(wn))
-      output_handler$warning(wn)
+    if (log_warning) {
+      cat_line(format_condition(cnd), file = stderr())
     }
-    invokeRestart("muffleWarning")
-  }
-  eHandler <- function(e) {
+
     handle_output()
-    if (use_try) {
-      output <<- c(output, list(e))
-      output_handler$error(e)
+    if (isTRUE(keep_warning)) {
+      output <<- c(output, list(cnd))
+      output_handler$warning(cnd)
+      invokeRestart("muffleWarning")
+    } else if (isFALSE(keep_warning)) {
+      invokeRestart("muffleWarning")
     }
   }
-  mHandler <- function(m) {
+  eHandler <- function(cnd) {
     handle_output()
-    if (isTRUE(keep_message)) {
-      output <<- c(output, list(m))
-      output_handler$message(m)
-      invokeRestart("muffleMessage")
-    } else if (isFALSE(keep_message)) {
-      invokeRestart("muffleMessage")
+    if (use_try) {
+      output <<- c(output, list(cnd))
+      output_handler$error(cnd)
     }
   }
 

From 82bb9722c5381087eb10e723193f5b5041e0f3b7 Mon Sep 17 00:00:00 2001
From: Hadley Wickham <h.wickham@gmail.com>
Date: Thu, 20 Jun 2024 15:43:59 +0100
Subject: [PATCH 4/5] Strip calls from top-level conditions (#157)

Fixes #150
---
 NEWS.md                    | 1 +
 R/eval.R                   | 9 +++++++++
 tests/testthat/test-eval.R | 5 +++++
 3 files changed, 15 insertions(+)

diff --git a/NEWS.md b/NEWS.md
index d65af17..8b38842 100644
--- a/NEWS.md
+++ b/NEWS.md
@@ -1,5 +1,6 @@
 # evaluate (development version)
 
+* `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.
 * `evaluate()` gains an output class (`evaluate_evaluation`/`list`) and a basic print method.
diff --git a/R/eval.R b/R/eval.R
index 4d06cbc..7711afd 100644
--- a/R/eval.R
+++ b/R/eval.R
@@ -168,6 +168,7 @@ evaluate_top_level_expression <- function(exprs,
 
     handle_output()
     if (isTRUE(keep_warning)) {
+      cnd <- reset_call(cnd)
       output <<- c(output, list(cnd))
       output_handler$warning(cnd)
       invokeRestart("muffleWarning")
@@ -178,6 +179,7 @@ evaluate_top_level_expression <- function(exprs,
   eHandler <- function(cnd) {
     handle_output()
     if (use_try) {
+      cnd <- reset_call(cnd)
       output <<- c(output, list(cnd))
       output_handler$error(cnd)
     }
@@ -242,6 +244,13 @@ with_handlers <- function(code, handlers) {
   eval(call)
 }
 
+reset_call <- function(cnd) {
+  if (identical(cnd$call, quote(eval(expr, envir)))) {
+    cnd$call <- NULL
+  }
+  cnd
+}
+
 new_evaluation <- function(x) {
   # Needs explicit list for backwards compatibility
   structure(x, class = c("evaluate_evaluation", "list"))
diff --git a/tests/testthat/test-eval.R b/tests/testthat/test-eval.R
index 3c78fee..992033b 100644
--- a/tests/testthat/test-eval.R
+++ b/tests/testthat/test-eval.R
@@ -133,3 +133,8 @@ test_that("has a reasonable print method", {
     evaluate("plot(1:3)")
   })  
 })
+
+test_that("conditions get calls stripped", {
+  expect_equal(evaluate("warning('x')")[[2]]$call, NULL)
+  expect_equal(evaluate("stop('x')")[[2]]$call, NULL)
+})

From 14c96090102be7dfd48c7811f85895d1f848b0d1 Mon Sep 17 00:00:00 2001
From: Hadley Wickham <h.wickham@gmail.com>
Date: Thu, 20 Jun 2024 16:02:03 +0100
Subject: [PATCH 5/5] Restore object that knitr uses (#162)

* Restore object that knitr uses

* Re-document
---
 R/eval.R        | 4 +++-
 R/zzz.R         | 6 ++++++
 man/evaluate.Rd | 2 +-
 3 files changed, 10 insertions(+), 2 deletions(-)
 create mode 100644 R/zzz.R

diff --git a/R/eval.R b/R/eval.R
index 7711afd..9c97a0b 100644
--- a/R/eval.R
+++ b/R/eval.R
@@ -47,12 +47,14 @@ evaluate <- function(input,
                      log_echo = FALSE,
                      log_warning = FALSE,
                      new_device = TRUE,
-                     output_handler = new_output_handler(),
+                     output_handler = NULL,
                      filename = NULL,
                      include_timing = FALSE) {
   stop_on_error <- as.integer(stop_on_error)
   stopifnot(length(stop_on_error) == 1)
 
+  output_handler <- output_handler %||% default_output_handler
+
   if (isTRUE(include_timing)) {
     warning("`evaluate(include_timing)` is deprecated")
   }
diff --git a/R/zzz.R b/R/zzz.R
new file mode 100644
index 0000000..ccc8811
--- /dev/null
+++ b/R/zzz.R
@@ -0,0 +1,6 @@
+# used by knitr to avoid overheard of calling new_output_handler() repeatedly
+default_output_handler <- NULL
+
+.onLoad <- function(...) {
+  default_output_handler <<- new_output_handler()
+}
diff --git a/man/evaluate.Rd b/man/evaluate.Rd
index 9093d1a..d76f7ba 100644
--- a/man/evaluate.Rd
+++ b/man/evaluate.Rd
@@ -15,7 +15,7 @@ evaluate(
   log_echo = FALSE,
   log_warning = FALSE,
   new_device = TRUE,
-  output_handler = new_output_handler(),
+  output_handler = NULL,
   filename = NULL,
   include_timing = FALSE
 )