Preserve the call stack on error

Closes #5308

NEWS.md

@@ -4,6 +4,10 @@
 
 * cummean() no longer has off-by-one indexing problem (#5287).
 
+* The call stack is preserved on error. This makes it possible to `recover()`
+  into problematic code called from dplyr verbs (#5308).
+
+
 # dplyr 1.0.0
 
 ## Breaking changes

R/arrange.R

@@ -113,7 +113,7 @@ arrange_rows <- function(.data, dots) {
   #
   #       revisit when we have something like mutate_one() to
   #       evaluate one quosure in the data mask
-  data <- tryCatch({
+  data <- withCallingHandlers({
     transmute(new_data_frame(.data), !!!quosures)
   }, error = function(cnd) {
     stop_arrange_transmute(cnd)

R/filter.R

@@ -120,7 +120,7 @@ filter_rows <- function(.data, ...) {
   mask <- DataMask$new(.data, caller_env())
 
   env_filter <- env()
-  tryCatch(
+  withCallingHandlers(
     mask$eval_all_filter(dots, env_filter),
     simpleError = function(e) {
       stop_dplyr(env_filter$current_expression, dots, fn = "filter", problem = conditionMessage(e))

R/mutate.R

@@ -229,7 +229,7 @@ mutate_cols <- function(.data, ...) {
 
   new_columns <- list()
 
-  tryCatch({
+  withCallingHandlers({
     for (i in seq_along(dots)) {
       not_named <- (is.null(dots_names) || dots_names[i] == "")
 
@@ -287,7 +287,7 @@ mutate_cols <- function(.data, ...) {
 
       # only unchop if needed
       if (is.null(result)) {
-        result <- tryCatch(
+        result <- withCallingHandlers(
           vec_unchop(chunks, rows),
           vctrs_error_incompatible_type = function(cnd) {
             abort(class = "dplyr:::error_mutate_incompatible_combine", parent = cnd)

R/summarise.R

@@ -213,8 +213,7 @@ summarise_cols <- function(.data, ...) {
   chunks <- vector("list", length(dots))
   types <- vector("list", length(dots))
 
-  tryCatch({
-
+  withCallingHandlers({
     # generate all chunks and monitor the sizes
     for (i in seq_along(dots)) {
       quo <- dots[[i]]
@@ -227,7 +226,7 @@ summarise_cols <- function(.data, ...) {
 
       mask$across_cache_reset()
 
-      result_type <- types[[i]] <- tryCatch(
+      result_type <- types[[i]] <- withCallingHandlers(
         vec_ptype_common(!!!chunks[[i]]),
         vctrs_error_incompatible_type = function(cnd) {
           abort(class = "dplyr:::error_summarise_incompatible_combine", parent = cnd)

tests/testthat/test-arrange.r

@@ -163,3 +163,17 @@ test_that("can arrange() with unruly class", {
     quux(data.frame(x = 3:1, dispatched = TRUE))
   )
 })
+
+test_that("arrange() preserves the call stack on error (#5308)", {
+  foobar <- function() stop("foo")
+
+  stack <- NULL
+  expect_error(
+    withCallingHandlers(
+      error = function(...) stack <<- sys.calls(),
+      arrange(mtcars, foobar())
+    )
+  )
+
+  expect_true(some(stack, is_call, "foobar"))
+})

tests/testthat/test-filter.r

@@ -497,3 +497,17 @@ test_that("can filter() with unruly class", {
     quux(data.frame(x = 1:2, dispatched = TRUE))
   )
 })
+
+test_that("filter() preserves the call stack on error (#5308)", {
+  foobar <- function() stop("foo")
+
+  stack <- NULL
+  expect_error(
+    withCallingHandlers(
+      error = function(...) stack <<- sys.calls(),
+      filter(mtcars, foobar())
+    )
+  )
+
+  expect_true(some(stack, is_call, "foobar"))
+})

tests/testthat/test-mutate.r

@@ -344,6 +344,20 @@ test_that("can use .before and .after to control column position", {
   expect_named(mutate(df, x = 1, .after = y), c("x", "y"))
 })
 
+test_that("mutate() preserves the call stack on error (#5308)", {
+  foobar <- function() stop("foo")
+
+  stack <- NULL
+  expect_error(
+    withCallingHandlers(
+      error = function(...) stack <<- sys.calls(),
+      mutate(mtcars, foobar())
+    )
+  )
+
+  expect_true(some(stack, is_call, "foobar"))
+})
+
 # Error messages ----------------------------------------------------------
 
 test_that("mutate() give meaningful errors", {

tests/testthat/test-summarise.r

@@ -202,6 +202,20 @@ test_that("summarise(.groups=)", {
 
 # errors -------------------------------------------------------------------
 
+test_that("summarise() preserves the call stack on error (#5308)", {
+  foobar <- function() stop("foo")
+
+  stack <- NULL
+  expect_error(
+    withCallingHandlers(
+      error = function(...) stack <<- sys.calls(),
+      summarise(mtcars, foobar())
+    )
+  )
+
+  expect_true(some(stack, is_call, "foobar"))
+})
+
 test_that("summarise() gives meaningful errors", {
   verify_output(env = env(global_env()), test_path("test-summarise-errors.txt"), {
     "# Messages about .groups="