Improve rmarkdown error forwarding (r-lib#2438)

Fixes r-lib#2433
SebKrantz · Jun 1, 2024 · 1b7e2f2 · 1b7e2f2
1 parent 6d94bc1
commit 1b7e2f2
Show file tree

Hide file tree

Showing 7 changed files with 132 additions and 50 deletions.
diff --git a/NEWS.md b/NEWS.md
@@ -1,5 +1,6 @@
 # pkgdown (development version)
 
+* `build_article()` gains a new `new_process` argument which allows to build a vignette in the current process for debugging purposes. We've also improved the error messages and tracebacks if an article fails to build, hopefully also making debugging easier (#2438).
 * Preview links now work once again (#2435).
 * `build_home()` no longer renders Github issue and pull request templates (@hsloot, #2362)
 * It is now easier to preview parts of the website locally interactively. `build_reference_index()` and friends will call `init_site()` internally instead of erroring (@olivroy, #2329).

diff --git a/R/build-articles.R b/R/build-articles.R
@@ -200,11 +200,15 @@ build_articles <- function(pkg = ".",
 #' @param name Name of article to render. This should be either a path
 #'   relative to `vignettes/` without extension, or `index` or `README`.
 #' @param data Additional data to pass on to template.
+#' @param new_process Build the article in a clean R process? The default,
+#'   `TRUE`, ensures that every article is build in a fresh environment, but
+#'   you may want to set it to `FALSE` to make debugging easier.
 build_article <- function(name,
                           pkg = ".",
                           data = list(),
                           lazy = FALSE,
                           seed = 1014L,
+                          new_process = TRUE,
                           quiet = TRUE) {
 
   pkg <- as_pkgdown(pkg)
@@ -293,6 +297,7 @@ build_article <- function(name,
     output_format = format,
     output_options = options,
     seed = seed,
+    new_process = new_process,
     quiet = quiet
   )
 }

diff --git a/R/rmarkdown.R b/R/rmarkdown.R
@@ -1,7 +1,7 @@
 #' Render RMarkdown document in a fresh session
 #'
 #' @noRd
-render_rmarkdown <- function(pkg, input, output, ..., seed = NULL, copy_images = TRUE, quiet = TRUE) {
+render_rmarkdown <- function(pkg, input, output, ..., seed = NULL, copy_images = TRUE, new_process = TRUE, quiet = TRUE, call = caller_env()) {
 
   input_path <- path_abs(input, pkg$src_path)
   output_path <- path_abs(output, pkg$dst_path)
@@ -19,48 +19,39 @@ render_rmarkdown <- function(pkg, input, output, ..., seed = NULL, copy_images =
     output_dir = path_dir(output_path),
     intermediates_dir = tempdir(),
     encoding = "UTF-8",
-    envir = globalenv(),
     seed = seed,
     ...,
     quiet = quiet
   )
 
-  path <- tryCatch(
-    callr::r_safe(
-      function(seed, envir, ...) {
-        if (!is.null(seed)) {
-          # since envir is copied from the parent fn into callr::r_safe(),
-          # set.seed() sets the seed in the wrong global env and we have to
-          # manually copy it over
-          set.seed(seed)
-          envir$.Random.seed <- .GlobalEnv$.Random.seed
-          if (requireNamespace("htmlwidgets", quietly = TRUE)) {
-            htmlwidgets::setWidgetIdSeed(seed)
-          }
-        }
-        rmarkdown::render(envir = envir, ...)
-      },
-      args = args,
-      show = !quiet,
-      env = c(
-        callr::rcmd_safe_env(),
-        BSTINPUTS = bst_paths(input_path),
-        TEXINPUTS = tex_paths(input_path),
-        BIBINPUTS = bib_paths(input_path),
-        R_CLI_NUM_COLORS = 256
-      )
-    ),
-    error = function(cnd) {
-      cli::cli_abort(
-        c(
-          "Failed to render RMarkdown document.",
-          x = gsub("\r", "", cnd$stderr, fixed = TRUE)
-        ),
-        parent = cnd
-      )
-    }
+  withr::local_envvar(
+    callr::rcmd_safe_env(),
+    BSTINPUTS = bst_paths(input_path),
+    TEXINPUTS = tex_paths(input_path),
+    BIBINPUTS = bib_paths(input_path),
+    R_CLI_NUM_COLORS = 256
   )
 
+  if (new_process) {
+    path <- withCallingHandlers(
+      callr::r_safe(rmarkdown_render_with_seed, args = args, show = !quiet),
+      error = function(cnd) {
+        lines <- strsplit(cnd$stderr, "\r?\n")[[1]]
+        cli::cli_abort(
+          c(
+            x = "Failed to render RMarkdown document.",
+            set_names(lines, " ")
+          ),
+          parent = cnd$parent %||% cnd,
+          trace = cnd$parent$trace,
+          call = call
+        )
+      }
+    )
+  } else {
+    path <- inject(rmarkdown_render_with_seed(!!!args))
+  }
+
   if (identical(path_ext(path)[[1]], "html")) {
     update_html(
       path,
@@ -102,6 +93,25 @@ render_rmarkdown <- function(pkg, input, output, ..., seed = NULL, copy_images =
   invisible(path)
 }
 
+
+rmarkdown_render_with_seed <- function(..., seed = NULL) {
+  if (!is.null(seed)) {
+    set.seed(seed)
+    if (requireNamespace("htmlwidgets", quietly = TRUE)) {
+      htmlwidgets::setWidgetIdSeed(seed)
+    }
+
+    # since envir is copied from the parent fn into callr::r_safe(),
+    # set.seed() sets the seed in the wrong global env and we have to
+    # manually copy it over
+    # if (!identical(envir, globalenv())) {
+    #   envir$.Random.seed <- .GlobalEnv$.Random.seed
+    # }
+  }
+
+  rmarkdown::render(envir = globalenv(), ...)
+}
+
 # adapted from tools::texi2dvi
 bst_paths <- function(path) {
   paths <- c(
@@ -125,5 +135,4 @@ bib_paths <- function(path) {
     tex_paths(path)
   )
   paste(paths, collapse = .Platform$path.sep)
-
 }
diff --git a/man/build_articles.Rd b/man/build_articles.Rd
diff --git a/tests/testthat/_snaps/rmarkdown.md b/tests/testthat/_snaps/rmarkdown.md
@@ -6,22 +6,50 @@
       Reading assets/vignette-with-img.Rmd
       Writing `test.html`
 
-# render_rmarkdown yields useful error
+# render_rmarkdown yields useful error if pandoc fails
 
     Code
-      render_rmarkdown(pkg, "assets/pandoc-fail.Rmd", "test.html", output_format = rmarkdown::html_document(
-        pandoc_args = "--fail-if-warnings"))
+      render_rmarkdown(pkg, "assets/pandoc-fail.Rmd", "test.html", output_format = format)
     Message
       Reading assets/pandoc-fail.Rmd
     Condition
-      Error in `render_rmarkdown()`:
-      ! Failed to render RMarkdown document.
-      x [WARNING] Could not fetch resource path-to-image.png Failing because there were warnings.
-      Caused by error:
-      ! in callr subprocess.
+      Error:
+      x Failed to render RMarkdown document.
+        [WARNING] Could not fetch resource path-to-image.png
+        Failing because there were warnings.
       Caused by error:
       ! pandoc document conversion failed with error 3
 
+# render_rmarkdown yields useful error if R fails
+
+    Code
+      # Test traceback
+      summary(expect_error(render_rmarkdown(pkg, "assets/r-fail.Rmd", "test.html")))
+    Message
+      Reading assets/r-fail.Rmd
+    Output
+      <error/rlang_error>
+      Error:
+      x Failed to render RMarkdown document.
+        
+        Quitting from lines 6-13 [unnamed-chunk-1] (r-fail.Rmd)
+      Caused by error:
+      ! Error!
+      ---
+      Backtrace:
+          x
+       1. \-global f()
+       2.   \-global g()
+       3.     \-global h()
+    Code
+      # Just test that it works; needed for browser() etc
+      expect_error(render_rmarkdown(pkg, "assets/r-fail.Rmd", "test.html",
+        new_process = FALSE))
+    Message
+      Reading assets/r-fail.Rmd
+      
+      Quitting from lines 6-13 [unnamed-chunk-1] (r-fail.Rmd)
+
 # render_rmarkdown styles ANSI escapes
 
     Code

diff --git a/tests/testthat/assets/r-fail.Rmd b/tests/testthat/assets/r-fail.Rmd
@@ -0,0 +1,13 @@
+---
+title: "r-fail"
+---
+
+```{r}
+f <- function() g()
+g <- function() h()
+h <- function() {
+  rlang::abort("Error!")
+}
+
+f()
+```
diff --git a/tests/testthat/test-rmarkdown.R b/tests/testthat/test-rmarkdown.R
@@ -13,18 +13,39 @@ test_that("render_rmarkdown copies image files in subdirectories", {
   )
 })
 
-test_that("render_rmarkdown yields useful error", {
+test_that("render_rmarkdown yields useful error if pandoc fails", {
   local_edition(3)
   skip_on_cran() # fragile due to pandoc dependency
   skip_if_no_pandoc("2.18")
 
   tmp <- dir_create(file_temp())
   pkg <- list(src_path = test_path("."), dst_path = tmp, bs_version = 3)
 
-  expect_snapshot(error = TRUE, {
-    render_rmarkdown(pkg, "assets/pandoc-fail.Rmd", "test.html",
-        output_format = rmarkdown::html_document(pandoc_args = "--fail-if-warnings"))
-  })
+  format <- rmarkdown::html_document(pandoc_args = "--fail-if-warnings")
+  expect_snapshot(
+    render_rmarkdown(pkg, "assets/pandoc-fail.Rmd", "test.html", output_format = format),
+    error = TRUE
+  )
+})
+
+test_that("render_rmarkdown yields useful error if R fails", {
+  local_edition(3)
+  skip_if_no_pandoc()
+
+  tmp <- dir_create(file_temp())
+  pkg <- list(src_path = test_path("."), dst_path = tmp, bs_version = 3)
+
+  expect_snapshot(
+    {
+      "Test traceback"
+      summary(expect_error(render_rmarkdown(pkg, "assets/r-fail.Rmd", "test.html")))
+
+      "Just test that it works; needed for browser() etc"
+      expect_error(render_rmarkdown(pkg, "assets/r-fail.Rmd", "test.html", new_process = FALSE))
+    },
+    # work around xfun bug
+    transform = function(x) gsub("lines  ?at lines", "lines", x)
+  )
 })
 
 test_that("render_rmarkdown styles ANSI escapes", {