diff --git a/DESCRIPTION b/DESCRIPTION index 1e5ce4c..114dff1 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -25,11 +25,14 @@ BugReports: https://github.com/r-lib/evaluate/issues Depends: R (>= 3.6.0) Suggests: + callr, covr, ggplot2 (>= 3.3.6), lattice, methods, + pkgload, rlang, + knitr, testthat (>= 3.0.0), withr Config/Needs/website: tidyverse/tidytemplate diff --git a/R/conditions.R b/R/conditions.R index 9825553..099536e 100644 --- a/R/conditions.R +++ b/R/conditions.R @@ -34,7 +34,8 @@ condition_handlers <- function(watcher, on_error, on_warning, on_message) { switch(on_error, continue = invokeRestart("eval_continue"), stop = invokeRestart("eval_stop"), - error = invokeRestart("eval_error", cnd) + # No need to invoke a restart as we want the error to be thrown in this case. + error = NULL ) } ) diff --git a/R/evaluate.R b/R/evaluate.R index 4444c63..c23817e 100644 --- a/R/evaluate.R +++ b/R/evaluate.R @@ -121,6 +121,11 @@ evaluate <- function(input, } local_inject_funs(envir) + if (is.null(getOption("rlang_trace_top_env"))) { + # If not already set, indicate the top environment to trim traceback + options(rlang_trace_top_env = envir) + } + # Handlers for warnings, errors and messages user_handlers <- output_handler$calling_handlers evaluate_handlers <- condition_handlers( @@ -151,8 +156,7 @@ evaluate <- function(input, handlers ), eval_continue = function() TRUE, - eval_stop = function() FALSE, - eval_error = function(cnd) {signalCondition(cnd); stop(cnd)} + eval_stop = function() FALSE ) watcher$check_devices() diff --git a/tests/testthat/_snaps/conditions.md b/tests/testthat/_snaps/conditions.md index 1bad37f..aaa62a6 100644 --- a/tests/testthat/_snaps/conditions.md +++ b/tests/testthat/_snaps/conditions.md @@ -6,10 +6,10 @@ Warning in `f()`: Hi! -# all three starts of stop_on_error work as expected +# all three values of stop_on_error work as expected Code - evaluate("stop(\"1\")\n2", stop_on_error = 2L) + ev <- evaluate("stop(\"1\")\n2", stop_on_error = 2L) Condition Error: ! 1 diff --git a/tests/testthat/_snaps/conditions/abort-error.txt b/tests/testthat/_snaps/conditions/abort-error.txt new file mode 100644 index 0000000..9796662 --- /dev/null +++ b/tests/testthat/_snaps/conditions/abort-error.txt @@ -0,0 +1,10 @@ +Error in `h()`: +! ! +Backtrace: + x + 1. \-global f() + 2. \-global g() + 3. \-global h() + 4. \-rlang::abort("!") +Execution halted +Ran 8/8 deferred expressions diff --git a/tests/testthat/_snaps/conditions/rmd-abort-error.md b/tests/testthat/_snaps/conditions/rmd-abort-error.md new file mode 100644 index 0000000..0fa32f4 --- /dev/null +++ b/tests/testthat/_snaps/conditions/rmd-abort-error.md @@ -0,0 +1,22 @@ +--- +title: document with error +--- + + +``` r +f <- function() g() +g <- function() h() +h <- function() rlang::abort("!") +f() +``` + +``` +## Error in `h()`: +## ! ! +## Backtrace: +## x +## 1. \-evaluate (local) f() +## 2. \-evaluate (local) g() +## 3. \-evaluate (local) h() +## 4. \-rlang::abort("!") +``` diff --git a/tests/testthat/_snaps/conditions/rmd-abort-error.txt b/tests/testthat/_snaps/conditions/rmd-abort-error.txt new file mode 100644 index 0000000..114acb6 --- /dev/null +++ b/tests/testthat/_snaps/conditions/rmd-abort-error.txt @@ -0,0 +1,12 @@ + + +processing file: ressources/with-abort-error.Rmd +Error in `h()`: +! ! +Backtrace: + 1. global f() + 2. global g() + 3. global h() + +Quitting from lines 6-10 [unnamed-chunk-1] (ressources/with-abort-error.Rmd) +Execution halted diff --git a/tests/testthat/_snaps/conditions/rmd-stop-error-auto-entrace.txt b/tests/testthat/_snaps/conditions/rmd-stop-error-auto-entrace.txt new file mode 100644 index 0000000..c2ea7b0 --- /dev/null +++ b/tests/testthat/_snaps/conditions/rmd-stop-error-auto-entrace.txt @@ -0,0 +1,12 @@ + + +processing file: ressources/with-stop-error-auto-entrace.Rmd +Error in `h()`: +! ! +Backtrace: + 1. global f() + 2. global g() + 3. global h() + +Quitting from lines 6-10 [unnamed-chunk-1] (ressources/with-stop-error-auto-entrace.Rmd) +Execution halted diff --git a/tests/testthat/_snaps/conditions/rmd-stop-error-entrace-sewed.md b/tests/testthat/_snaps/conditions/rmd-stop-error-entrace-sewed.md new file mode 100644 index 0000000..a7f1e5e --- /dev/null +++ b/tests/testthat/_snaps/conditions/rmd-stop-error-entrace-sewed.md @@ -0,0 +1,27 @@ +--- +title: document with error +--- + + +``` r +rlang::global_entrace() +options(rlang_backtrace_on_error_report = "full") +``` + + +``` r +f <- function() g() +g <- function() h() +h <- function() stop("!") +f() +``` + +``` +## Error in `h()`: +## ! ! +## Backtrace: +## x +## 1. \-evaluate (local) f() +## 2. \-evaluate (local) g() +## 3. \-evaluate (local) h() +``` diff --git a/tests/testthat/_snaps/conditions/rmd-stop-error.md b/tests/testthat/_snaps/conditions/rmd-stop-error.md new file mode 100644 index 0000000..78ea215 --- /dev/null +++ b/tests/testthat/_snaps/conditions/rmd-stop-error.md @@ -0,0 +1,15 @@ +--- +title: document with error +--- + + +``` r +f <- function() g() +g <- function() h() +h <- function() stop("!") +f() +``` + +``` +## Error in h(): ! +``` diff --git a/tests/testthat/_snaps/conditions/stop-error-no-trace.txt b/tests/testthat/_snaps/conditions/stop-error-no-trace.txt new file mode 100644 index 0000000..66f5c0e --- /dev/null +++ b/tests/testthat/_snaps/conditions/stop-error-no-trace.txt @@ -0,0 +1,4 @@ +Error in h() : ! +Calls: ... withCallingHandlers -> withVisible -> eval -> eval -> f -> g -> h +Execution halted +Ran 8/8 deferred expressions diff --git a/tests/testthat/_snaps/conditions/stop-error-trace-calling-handler.txt b/tests/testthat/_snaps/conditions/stop-error-trace-calling-handler.txt new file mode 100644 index 0000000..fd142af --- /dev/null +++ b/tests/testthat/_snaps/conditions/stop-error-trace-calling-handler.txt @@ -0,0 +1,9 @@ +Error in `h()`: +! ! +Backtrace: + x + 1. \-global f() + 2. \-global g() + 3. \-global h() +Execution halted +Ran 8/8 deferred expressions diff --git a/tests/testthat/_snaps/conditions/stop-error-trace-trimmed.txt b/tests/testthat/_snaps/conditions/stop-error-trace-trimmed.txt new file mode 100644 index 0000000..fd142af --- /dev/null +++ b/tests/testthat/_snaps/conditions/stop-error-trace-trimmed.txt @@ -0,0 +1,9 @@ +Error in `h()`: +! ! +Backtrace: + x + 1. \-global f() + 2. \-global g() + 3. \-global h() +Execution halted +Ran 8/8 deferred expressions diff --git a/tests/testthat/_snaps/conditions/stop-error-trace-wch.txt b/tests/testthat/_snaps/conditions/stop-error-trace-wch.txt new file mode 100644 index 0000000..fd142af --- /dev/null +++ b/tests/testthat/_snaps/conditions/stop-error-trace-wch.txt @@ -0,0 +1,9 @@ +Error in `h()`: +! ! +Backtrace: + x + 1. \-global f() + 2. \-global g() + 3. \-global h() +Execution halted +Ran 8/8 deferred expressions diff --git a/tests/testthat/helper.R b/tests/testthat/helper.R index 7a22266..3ded4e2 100644 --- a/tests/testthat/helper.R +++ b/tests/testthat/helper.R @@ -2,3 +2,20 @@ expect_output_types <- function(x, types) { output_types <- vapply(x, output_type, character(1)) expect_equal(output_types, types) } + +quick_install <- function(package, lib, quiet = TRUE) { + opts <- c( + "--data-compress=none", + "--no-byte-compile", + "--no-data", + "--no-demo", + "--no-docs", + "--no-help", + "--no-html", + "--no-libs", + "--use-vanilla", + sprintf("--library=%s", lib), + package + ) + invisible(callr::rcmd("INSTALL", opts, show = !quiet, fail_on_status = TRUE)) +} diff --git a/tests/testthat/ressources/with-abort-error.R b/tests/testthat/ressources/with-abort-error.R new file mode 100644 index 0000000..fe6a15a --- /dev/null +++ b/tests/testthat/ressources/with-abort-error.R @@ -0,0 +1,7 @@ +testthat::local_reproducible_output() +evaluate::evaluate(function() { + f <- function() g() + g <- function() h() + h <- function() rlang::abort("!") + f() +}, stop_on_error = 2L) diff --git a/tests/testthat/ressources/with-abort-error.Rmd b/tests/testthat/ressources/with-abort-error.Rmd new file mode 100644 index 0000000..b7262fb --- /dev/null +++ b/tests/testthat/ressources/with-abort-error.Rmd @@ -0,0 +1,10 @@ +--- +title: document with error +--- + +```{r} +f <- function() g() +g <- function() h() +h <- function() rlang::abort("!") +f() +``` diff --git a/tests/testthat/ressources/with-stop-error-auto-entrace.Rmd b/tests/testthat/ressources/with-stop-error-auto-entrace.Rmd new file mode 100644 index 0000000..ae2d717 --- /dev/null +++ b/tests/testthat/ressources/with-stop-error-auto-entrace.Rmd @@ -0,0 +1,10 @@ +--- +title: document with error +--- + +```{r} +f <- function() g() +g <- function() h() +h <- function() stop("!") +f() +``` diff --git a/tests/testthat/ressources/with-stop-error-no-trace.R b/tests/testthat/ressources/with-stop-error-no-trace.R new file mode 100644 index 0000000..2dc76d5 --- /dev/null +++ b/tests/testthat/ressources/with-stop-error-no-trace.R @@ -0,0 +1,7 @@ +testthat::local_reproducible_output() +evaluate::evaluate(function() { + f <- function() g() + g <- function() h() + h <- function() stop("!") + f() +}, stop_on_error = 2L) diff --git a/tests/testthat/ressources/with-stop-error-sewed.Rmd b/tests/testthat/ressources/with-stop-error-sewed.Rmd new file mode 100644 index 0000000..2d9b679 --- /dev/null +++ b/tests/testthat/ressources/with-stop-error-sewed.Rmd @@ -0,0 +1,15 @@ +--- +title: document with error +--- + +```{r} +rlang::global_entrace() +options(rlang_backtrace_on_error_report = "full") +``` + +```{r} +f <- function() g() +g <- function() h() +h <- function() stop("!") +f() +``` diff --git a/tests/testthat/ressources/with-stop-error-trace-trimmed.R b/tests/testthat/ressources/with-stop-error-trace-trimmed.R new file mode 100644 index 0000000..05fc9e7 --- /dev/null +++ b/tests/testthat/ressources/with-stop-error-trace-trimmed.R @@ -0,0 +1,11 @@ +testthat::local_reproducible_output() +handlers <- evaluate::new_output_handler( + calling_handlers = list(error = function(cnd) rlang::entrace(cnd)) +) +options(rlang_trace_top_env = parent.frame()) +evaluate::evaluate(function() { + f <- function() g() + g <- function() h() + h <- function() stop("!") + f() +}, stop_on_error = 2L, output_handler = handlers) diff --git a/tests/testthat/ressources/with-stop-error-trace.R b/tests/testthat/ressources/with-stop-error-trace.R new file mode 100644 index 0000000..32a69b2 --- /dev/null +++ b/tests/testthat/ressources/with-stop-error-trace.R @@ -0,0 +1,10 @@ +testthat::local_reproducible_output() +handlers <- evaluate::new_output_handler( + calling_handlers = list(error = function(cnd) rlang::entrace(cnd)) +) +evaluate::evaluate(function() { + f <- function() g() + g <- function() h() + h <- function() stop("!") + f() +}, stop_on_error = 2L, output_handler = handlers) diff --git a/tests/testthat/ressources/with-stop-error-wch.R b/tests/testthat/ressources/with-stop-error-wch.R new file mode 100644 index 0000000..1d7aee6 --- /dev/null +++ b/tests/testthat/ressources/with-stop-error-wch.R @@ -0,0 +1,10 @@ +testthat::local_reproducible_output() +withCallingHandlers( + error = function(cnd) rlang::entrace(cnd), + evaluate::evaluate(function() { + f <- function() g() + g <- function() h() + h <- function() stop("!") + f() + }, stop_on_error = 2L) +) diff --git a/tests/testthat/test-conditions.R b/tests/testthat/test-conditions.R index 218cd09..4beb6f2 100644 --- a/tests/testthat/test-conditions.R +++ b/tests/testthat/test-conditions.R @@ -118,14 +118,14 @@ test_that("an error terminates evaluation of multi-expression input", { expect_output_types(ev, c("source", "error")) }) -test_that("all three starts of stop_on_error work as expected", { +test_that("all three values of stop_on_error work as expected", { ev <- evaluate('stop("1")\n2', stop_on_error = 0L) expect_output_types(ev, c("source", "error", "source", "text")) ev <- evaluate('stop("1")\n2', stop_on_error = 1L) expect_output_types(ev, c("source", "error")) - expect_snapshot(evaluate('stop("1")\n2', stop_on_error = 2L), error = TRUE) + expect_snapshot(ev <- evaluate("stop(\"1\")\n2", stop_on_error = 2L), error = TRUE) }) test_that("errors during printing are captured", { @@ -136,3 +136,64 @@ test_that("errors during printing are captured", { ev <- evaluate("a") expect_output_types(ev, c("source", "error")) }) + +test_that("Error can be entraced and correctly handled in outputs", { + skip_if_not_installed("rlang") + skip_if_not_installed("knitr") + skip_if_not_installed("callr") + skip_on_cran() + # install dev version of package in temp directory + withr::local_temp_libpaths() + quick_install(pkgload::pkg_path("."), lib = .libPaths()[1]) + + out <- withr::local_tempfile(fileext = ".txt") + + # Checking different way to entrace with evaluate + callr::rscript(test_path("ressources/with-stop-error-no-trace.R"), fail_on_status = FALSE, show = FALSE, stderr = out) + expect_snapshot_file(out, name = 'stop-error-no-trace.txt') + + callr::rscript(test_path("ressources/with-stop-error-trace.R"), fail_on_status = FALSE, show = FALSE, stderr = out) + expect_snapshot_file(out, name = 'stop-error-trace-calling-handler.txt') + + callr::rscript(test_path("ressources/with-stop-error-wch.R"), fail_on_status = FALSE, show = FALSE, stderr = out) + expect_snapshot_file(out, name = 'stop-error-trace-wch.txt') + + callr::rscript(test_path("ressources/with-stop-error-trace-trimmed.R"), fail_on_status = FALSE, show = FALSE, stderr = out) + expect_snapshot_file(out, name = 'stop-error-trace-trimmed.txt') + + callr::rscript(test_path("ressources/with-abort-error.R"), fail_on_status = FALSE, show = FALSE, stderr = out) + expect_snapshot_file(out, name = 'abort-error.txt') + + # Checking error thrown when in rmarkdown and knitr context + rscript <- withr::local_tempfile(fileext = ".R") + out2 <- normalizePath(withr::local_tempfile(fileext = ".md"), winslash = "/", mustWork = FALSE) + writeLines(c( + "options(knitr.chunk.error = FALSE)", + sprintf('knitr::knit("%s", output = "%s")', test_path("ressources/with-stop-error-auto-entrace.Rmd"), out2) + ), con = rscript) + callr::rscript(rscript, fail_on_status = FALSE, show = FALSE, stderr = out) + expect_snapshot_file(out, name = 'rmd-stop-error-auto-entrace.txt') + + writeLines(c( + "options(knitr.chunk.error = FALSE)", + sprintf('res <- knitr::knit("%s", output = "%s")', test_path("ressources/with-abort-error.Rmd"), out2) + ), con = rscript) + callr::rscript(rscript, fail_on_status = FALSE, show = FALSE, stderr = out) + expect_snapshot_file(out, name = 'rmd-abort-error.txt') + + # Checking error captured in cell output in rmarkdown and knitr context + withr::with_options(list(options(knitr.chunk.error = TRUE)), { + expect_snapshot_file( + knitr::knit(test_path("ressources/with-stop-error-auto-entrace.Rmd"), output = out, quiet = TRUE), + name = "rmd-stop-error.md" + ) + expect_snapshot_file( + knitr::knit(test_path("ressources/with-stop-error-sewed.Rmd"), output = out, quiet = TRUE), + name = "rmd-stop-error-entrace-sewed.md" + ) + expect_snapshot_file( + knitr::knit(test_path("ressources/with-abort-error.Rmd"), output = out, quiet = TRUE), + name = "rmd-abort-error.md" + ) + }) +})