Merge pull request #1215 from lionel-/fix-last-error-knitr

Register an `rlang_error` method for `knitr::sew()` to handle backtraces in error messages

NEWS.md

@@ -1,5 +1,23 @@
 # rlang (development version)
 
+* A `knitr::sew()` method is registered for `rlang_error`. This makes
+  it possible to consult `last_error()` (the call must occur in a
+  different chunk than the error) and to set
+  `rlang_backtrace_on_error` global options in knitr to display a
+  backtrace on error.
+
+  If you show rlang backtraces in a knitted document, also set this in
+  a hidden chunk to trim the knitr context from the backtraces:
+
+  ```
+  options(
+    rlang_trace_top_env = environment()
+  )
+  ```
+
+  This change replaces an ad hoc mechanism that caused bugs in corner
+  cases (#1205).
+
 * Internal errors now include a winch backtrace if installed. The user
   is invited to install it if not installed.
 

R/cnd-abort.R

@@ -56,6 +56,26 @@
 #' When set to quiet, the message is not displayed and the condition
 #' is not signalled.
 #'
+#' @details
+#'
+#' - An `rlang_error` method for the `knitr::sew()` generic is
+#'   registered to make it possible to display backtraces with
+#'   captured errors (`error = TRUE` chunks).
+#'
+#'   In `error = TRUE` chunks, the default value for
+#'   `rlang_backtrace_on_error` is `"none"`. You can override it by
+#'   setting this option in your document, e.g. to `"reminder"` or
+#'   `"full"`.
+#'
+#'   If you display rlang backtraces in a knitted document, you will
+#'   probably want to trim the knitr context from the backtrace by
+#'   setting this option in a hidden chunk:
+#'
+#'     ```
+#'     options(
+#'       rlang_trace_top_env = environment()
+#'     )
+#'     ```
 #'
 #' @inheritParams cnd
 #' @param message The message to display. Character vectors are
@@ -177,7 +197,7 @@ abort <- function(message = NULL,
 }
 
 signal_abort <- function(cnd) {
-  if (is_true(peek_option("rlang:::force_unhandled_error"))) {
+  if (is_true(peek_option("rlang::::force_unhandled_error"))) {
     # Fall back with the full rlang error
     fallback <- cnd
   } else {
@@ -197,21 +217,17 @@ signal_abort <- function(cnd) {
 
   if (is_interactive()) {
     # Generate the error message, possibly with a backtrace or reminder
-    fallback$message <- paste_line(
-      conditionMessage(cnd),
-      format_onerror_backtrace(cnd)
-    )
+    fallback$message <- cnd_unhandled_message(cnd)
     fallback$rlang_entraced <- TRUE
   } else {
     file <- peek_option("rlang:::error_pipe") %||% stderr()
-    msg <- conditionMessage(cnd)
-    fallback$message <- msg
+    fallback$message <- conditionMessage(cnd)
 
-    cat("Error: ", msg, "\n", sep = "", file = file)
+    msg <- cnd_unhandled_message(cnd)
 
     # Print the backtrace eagerly in non-interactive sessions because
     # the length of error messages is limited (#856)
-    cat(format_onerror_backtrace(cnd), "\n", sep = "", file = file)
+    cat("Error: ", msg, "\n", sep = "", file = file)
 
     # Turn off the regular error printing to avoid printing the error
     # twice
@@ -220,6 +236,36 @@ signal_abort <- function(cnd) {
 
   stop(fallback)
 }
+cnd_unhandled_message <- function(cnd) {
+  paste_line(
+    conditionMessage(cnd),
+    format_onerror_backtrace(cnd)
+  )
+}
+
+on_load({
+  s3_register("knitr::sew", "rlang_error", function(x, options, ...) {
+    # Simulate interactive session to prevent full backtrace from
+    # being included in error message
+    local_interactive()
+
+    # Save the unhandled error for `rlang::last_error()`.
+    last_error_env$cnd <- x
+
+    # By default, we display no reminder or backtrace for errors
+    # captured by knitr. This default can be overridden.
+    opt <- peek_option("rlang_backtrace_on_error") %||% "none"
+    local_options(rlang_backtrace_on_error = opt)
+
+    msg <- cnd_unhandled_message(x)
+
+    # Create bare error and sew it to delegate finalisation to parent
+    # method since there is no simple way to generically modify the
+    # condition and then call `NextMethod()` (a `conditionMessage()`
+    # method might conflict, etc).
+    knitr::sew(simpleError(msg), options, ...)
+  })
+})
 
 trace_trim_context <- function(trace, idx) {
   if (!is_scalar_integerish(idx)) {
@@ -410,7 +456,8 @@ show_trace_p <- function() {
 #' @export
 last_error <- function() {
   if (is_null(last_error_env$cnd)) {
-    abort("Can't show last error because no error was recorded yet")
+    local_options(rlang_backtrace_on_error = "none")
+    stop("Can't show last error because no error was recorded yet", call. = FALSE)
   }
 
   cnd <- last_error_env$cnd

tests/testthat/_snaps/cnd-abort.md

@@ -22,7 +22,6 @@
       cat_line(reminder)
     Output
       Error: Error message
-      
       Execution halted
     Code
       cat_line(branch)
@@ -85,13 +84,11 @@
       cat_line(branch_depth_0)
     Output
       Error: foo
-      
       Execution halted
     Code
       cat_line(full_depth_0)
     Output
       Error: foo
-      
       Execution halted
     Code
       cat_line(branch_depth_1)

tests/testthat/_snaps/trace.md

@@ -937,3 +937,56 @@
           x
        1. \-rlang:::f(3) test-trace.R:488:2
 
+# caught error does not display backtrace in knitted files
+
+    Code
+      cat_line(render_md("test-trace-full.Rmd"))
+    Output
+          options(rlang_trace_top_env = environment())
+      
+          f <- function() g()
+          g <- function() h()
+          h <- function() rlang::abort("foo")
+      
+          f()
+      
+          ## Error: foo
+      
+      Currently needs to be in a different chunk:
+      
+          last_error()
+      
+          ## <error/rlang_error>
+          ## foo
+          ## Backtrace:
+          ##  1. global::f()
+          ##  2. global::g()
+          ##  3. global::h()
+          ## Run `rlang::last_trace()` to see the full context.
+      
+          last_trace()
+      
+          ## <error/rlang_error>
+          ## foo
+          ## Backtrace:
+          ##     x
+          ##  1. \-global::f()
+          ##  2.   \-global::g()
+          ##  3.     \-global::h()
+      
+          options(rlang_backtrace_on_error = "reminder")
+          f()
+      
+          ## Error: foo
+          ## Run `rlang::last_error()` to see where the error occurred.
+      
+          options(rlang_backtrace_on_error = "full")
+          f()
+      
+          ## Error: foo
+          ## Backtrace:
+          ##     x
+          ##  1. \-global::f()
+          ##  2.   \-global::g()
+          ##  3.     \-global::h()
+

tests/testthat/test-cnd-abort.R

@@ -20,7 +20,7 @@ test_that("errors are saved", {
   # Verbose try() triggers conditionMessage() and thus saves the error.
   # This simulates an unhandled error.
   local_options(
-    `rlang:::force_unhandled_error` = TRUE,
+    `rlang::::force_unhandled_error` = TRUE,
     `rlang:::error_pipe` = tempfile()
   )
 
@@ -42,7 +42,7 @@ test_that("No backtrace is displayed with top-level active bindings", {
 
 test_that("Invalid on_error option resets itself", {
   with_options(
-    `rlang:::force_unhandled_error` = TRUE,
+    `rlang::::force_unhandled_error` = TRUE,
     `rlang:::error_pipe` = tempfile(),
     rlang_backtrace_on_error = NA,
     {

tests/testthat/test-cnd-error.R

@@ -72,7 +72,7 @@ test_that("error is printed with parent backtrace", {
 
   err_force <- with_options(
     catch_error(a()),
-    `rlang:::force_unhandled_error` = TRUE,
+    `rlang::::force_unhandled_error` = TRUE,
     `rlang:::error_pipe` = tempfile()
   )
 

tests/testthat/test-trace-full.Rmd

@@ -0,0 +1,28 @@
+```{r}
+options(rlang_trace_top_env = environment())
+
+f <- function() g()
+g <- function() h()
+h <- function() rlang::abort("foo")
+```
+
+```{r, error = TRUE}
+f()
+```
+
+Currently needs to be in a different chunk:
+
+```{r}
+last_error()
+last_trace()
+```
+
+```{r, error = TRUE}
+options(rlang_backtrace_on_error = "reminder")
+f()
+```
+
+```{r, error = TRUE}
+options(rlang_backtrace_on_error = "full")
+f()
+```

tests/testthat/test-trace.R

@@ -600,9 +600,14 @@ test_that("caught error does not display backtrace in knitted files", {
     rlang_backtrace_on_error = NULL,
     rlang_interactive = FALSE
   )
+
   lines <- render_md("test-trace.Rmd")
   error_line <- lines[[length(lines)]]
   expect_match(error_line, "foo$")
+
+  expect_snapshot({
+    cat_line(render_md("test-trace-full.Rmd"))
+  })
 })
 
 test_that("empty backtraces are dealt with", {

tests/testthat/test-trace.Rmd

@@ -1,11 +1,11 @@
-
 ```{r}
-getOption("rlang_backtrace_on_error")
-```
+options(rlang_trace_top_env = environment())
 
-```{r, error = TRUE}
 f <- function() g()
 g <- function() h()
 h <- function() rlang::abort("foo")
+```
+
+```{r, error = TRUE}
 f()
 ```