Merge branch 'main' into the

NEWS.md

@@ -1,5 +1,7 @@
 # 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.
 * `evaluate()` now correctly captures plots created before messages/warnings/errors (#28).

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(),
@@ -50,12 +47,18 @@ evaluate <- function(input,
                      log_echo = FALSE,
                      log_warning = FALSE,
                      new_device = TRUE,
-                     output_handler = default_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")
+  }
+
   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 +94,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 +122,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)
@@ -147,37 +148,42 @@ 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)) {
+      cnd <- reset_call(cnd)
+      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) {
+      cnd <- reset_call(cnd)
+      output <<- c(output, list(cnd))
+      output_handler$error(cnd)
     }
   }
 
@@ -190,30 +196,20 @@ 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)
   # The user's condition handlers have priority over ours
   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
@@ -250,6 +246,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"))

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

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)

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)

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

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

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")
 })

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")
@@ -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)
+})

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"
-  )
-})