Pass calls for improved error messages (#1340)

R/chop.R

@@ -141,17 +141,17 @@ unchop <- function(data, cols, keep_empty = FALSE, ptype = NULL) {
 #   used to slice the data frame `x` was subset from to align it with `val`.
 # - `val` the unchopped data frame.
 
-df_unchop <- function(x, ..., ptype = NULL, keep_empty = FALSE) {
+df_unchop <- function(x, ..., ptype = NULL, keep_empty = FALSE, error_call = caller_env()) {
   check_dots_empty()
 
   if (!is.data.frame(x)) {
-    abort("`x` must be a data frame.")
+    abort("`x` must be a data frame.", call = error_call)
   }
   if (!is_bool(keep_empty)) {
-    abort("`keep_empty` must be a single `TRUE` or `FALSE`.")
+    abort("`keep_empty` must be a single `TRUE` or `FALSE`.", call = error_call)
   }
 
-  ptype <- check_list_of_ptypes(ptype, names = names(x), arg = "ptype")
+  ptype <- check_list_of_ptypes(ptype, names = names(x), arg = "ptype", call = error_call)
 
   size <- vec_size(x)
 
@@ -201,7 +201,7 @@ df_unchop <- function(x, ..., ptype = NULL, keep_empty = FALSE) {
     x_nulls[[i]] <- info$null
   }
 
-  sizes <- reduce(x_sizes, unchop_sizes2)
+  sizes <- reduce(x_sizes, unchop_sizes2, error_call = error_call)
 
   info <- unchop_finalize(x, sizes, x_nulls, keep_empty)
   x <- info$x
@@ -221,7 +221,7 @@ df_unchop <- function(x, ..., ptype = NULL, keep_empty = FALSE) {
 
     if (!col_is_list) {
       if (!is_null(col_ptype)) {
-        col <- vec_cast(col, col_ptype, x_arg = col_name)
+        col <- vec_cast(col, col_ptype, x_arg = col_name, call = error_call)
       }
       out_cols[[i]] <- vec_slice(col, out_loc)
       next
@@ -237,7 +237,7 @@ df_unchop <- function(x, ..., ptype = NULL, keep_empty = FALSE) {
 
     col_sizes <- x_sizes[[i]]
     row_recycle <- col_sizes != sizes
-    col[row_recycle] <- map2(col[row_recycle], sizes[row_recycle], vec_recycle)
+    col[row_recycle] <- map2(col[row_recycle], sizes[row_recycle], vec_recycle, call = error_call)
 
     col <- list_unchop(col, ptype = col_ptype)
 
@@ -264,7 +264,7 @@ df_unchop <- function(x, ..., ptype = NULL, keep_empty = FALSE) {
   out
 }
 
-unchop_sizes2 <- function(x, y) {
+unchop_sizes2 <- function(x, y, error_call) {
   # Standard tidyverse recycling rules, just vectorized.
 
   # Recycle `x` values with `y`
@@ -286,7 +286,7 @@ unchop_sizes2 <- function(x, y) {
     row <- which(incompatible)[[1]]
     x <- x[[row]]
     y <- y[[row]]
-    abort(glue("In row {row}, can't recycle input of size {x} to size {y}."))
+    abort(glue("In row {row}, can't recycle input of size {x} to size {y}."), call = error_call)
   }
 
   x

R/expand.R

@@ -194,7 +194,7 @@ expand_grid <- function(..., .name_repair = "check_unique") {
   }
 
   # Flattens unnamed data frames after grid expansion
-  out <- df_list(!!!out, .name_repair = .name_repair)
+  out <- df_list(!!!out, .name_repair = .name_repair, .error_call = current_env())
   out <- tibble::new_tibble(out, nrow = size)
 
   out
@@ -228,7 +228,7 @@ fct_unique <- function(x) {
   factor(out, levels = levels, exclude = NULL, ordered = is.ordered(x))
 }
 
-grid_dots <- function(..., `_data` = NULL) {
+grid_dots <- function(..., `_data` = NULL, .error_call = caller_env()) {
   dots <- enquos(...)
   n_dots <- length(dots)
 
@@ -277,7 +277,7 @@ grid_dots <- function(..., `_data` = NULL) {
     }
 
     arg <- paste0("..", i)
-    vec_assert(dot, arg = arg)
+    vec_assert(dot, arg = arg, call = .error_call)
 
     out[[i]] <- dot
 

R/extract.R

@@ -50,8 +50,8 @@ extract.data.frame <- function(data, col, into, regex = "([[:alnum:]]+)",
   reconstruct_tibble(data, out, if (remove) var else chr())
 }
 
-str_extract <- function(x, into, regex, convert = FALSE) {
-  check_not_stringr_pattern(regex, "regex")
+str_extract <- function(x, into, regex, convert = FALSE, error_call = caller_env()) {
+  check_not_stringr_pattern(regex, "regex", call = error_call)
 
   stopifnot(
     is_string(regex),
@@ -60,9 +60,9 @@ str_extract <- function(x, into, regex, convert = FALSE) {
 
   out <- str_match_first(x, regex)
   if (length(out) != length(into)) {
-    stop(
-      "`regex` should define ", length(into), " groups; ", length(out), " found.",
-      call. = FALSE
+    abort(
+      glue("`regex` should define {length(into)} groups; {length(out)} found."),
+      call = error_call
     )
   }
 

R/hoist.R

@@ -133,7 +133,7 @@ hoist <- function(.data,
   out
 }
 
-check_pluckers <- function(...) {
+check_pluckers <- function(..., .call = caller_env()) {
   pluckers <- list2(...)
 
   is_string <- map_lgl(pluckers, ~ is.character(.x) && length(.x) == 1)
@@ -144,11 +144,11 @@ check_pluckers <- function(...) {
   }
 
   if (length(pluckers) > 0 && !is_named(pluckers)) {
-    abort("All elements of `...` must be named.")
+    abort("All elements of `...` must be named.", call = .call)
   }
 
   if (vec_duplicate_any(names(pluckers))) {
-    abort("The names of `...` must be unique.")
+    abort("The names of `...` must be unique.", call = .call)
   }
 
   # Standardize all pluckers to lists for splicing into `pluck()`

R/pivot-long.R

@@ -321,7 +321,8 @@ pivot_longer_spec <- function(data,
     data_cols,
     keys,
     vals,
-    .name_repair = names_repair
+    .name_repair = names_repair,
+    .error_call = current_env()
   ))
 
   if (values_drop_na) {

R/pivot-wide.R

@@ -444,7 +444,8 @@ pivot_wider_spec <- function(data,
     rows,
     values,
     unused,
-    .name_repair = names_repair
+    .name_repair = names_repair,
+    .error_call = current_env()
   ))
 
   reconstruct_tibble(input, out)
@@ -525,17 +526,19 @@ build_wider_spec <- function(data,
 build_wider_id_cols_expr <- function(data,
                                      id_cols = NULL,
                                      names_from = name,
-                                     values_from = value) {
+                                     values_from = value,
+                                     error_call = caller_env()) {
   # TODO: Use `allow_rename = FALSE`.
   # Requires https://github.com/r-lib/tidyselect/issues/225.
-  names_from_cols <- names(tidyselect::eval_select(enquo(names_from), data))
-  values_from_cols <- names(tidyselect::eval_select(enquo(values_from), data))
+  names_from_cols <- names(tidyselect::eval_select(enquo(names_from), data, error_call = error_call))
+  values_from_cols <- names(tidyselect::eval_select(enquo(values_from), data, error_call = error_call))
 
   out <- select_wider_id_cols(
     data = data,
     id_cols = {{ id_cols }},
     names_from_cols = names_from_cols,
-    values_from_cols = values_from_cols
+    values_from_cols = values_from_cols,
+    error_call = error_call
   )
 
   expr(c(!!!out))
@@ -544,7 +547,8 @@ build_wider_id_cols_expr <- function(data,
 select_wider_id_cols <- function(data,
                                  id_cols = NULL,
                                  names_from_cols = character(),
-                                 values_from_cols = character()) {
+                                 values_from_cols = character(),
+                                 error_call = caller_env()) {
   id_cols <- enquo(id_cols)
 
   # Remove known non-id-cols so they are never selected
@@ -558,43 +562,43 @@ select_wider_id_cols <- function(data,
   try_fetch(
     # TODO: Use `allow_rename = FALSE`.
     # Requires https://github.com/r-lib/tidyselect/issues/225.
-    id_cols <- tidyselect::eval_select(enquo(id_cols), data),
+    id_cols <- tidyselect::eval_select(enquo(id_cols), data, error_call = error_call),
     vctrs_error_subscript_oob = function(cnd) {
-      rethrow_id_cols_oob(cnd, names_from_cols, values_from_cols)
+      rethrow_id_cols_oob(cnd, names_from_cols, values_from_cols, error_call)
     }
   )
 
   names(id_cols)
 }
 
-rethrow_id_cols_oob <- function(cnd, names_from_cols, values_from_cols) {
+rethrow_id_cols_oob <- function(cnd, names_from_cols, values_from_cols, call) {
   i <- cnd[["i"]]
 
   if (!is_string(i)) {
     abort("`i` is expected to be a string.", .internal = TRUE)
   }
 
   if (i %in% names_from_cols) {
-    stop_id_cols_oob(i, "names_from")
+    stop_id_cols_oob(i, "names_from", call = call)
   } else if (i %in% values_from_cols) {
-    stop_id_cols_oob(i, "values_from")
+    stop_id_cols_oob(i, "values_from", call = call)
   } else {
     # Zap this special handler, throw the normal condition
     zap()
   }
 }
 
-stop_id_cols_oob <- function(i, arg) {
+stop_id_cols_oob <- function(i, arg, call) {
   message <- c(
     glue("`id_cols` can't select a column already selected by `{arg}`."),
     i = glue("Column `{i}` has already been selected.")
   )
-  abort(message, parent = NA)
+  abort(message, parent = NA, call = call)
 }
 
 # Helpers -----------------------------------------------------------------
 
-value_summarize <- function(value, value_locs, value_name, fn, fn_name) {
+value_summarize <- function(value, value_locs, value_name, fn, fn_name, error_call = caller_env()) {
   value <- vec_chop(value, value_locs)
 
   if (identical(fn, list)) {
@@ -618,7 +622,7 @@ value_summarize <- function(value, value_locs, value_name, fn, fn_name) {
       x = glue("Applying `{fn_name}` resulted in a value with length {size}.")
     )
 
-    abort(c(header, bullet))
+    abort(c(header, bullet), call = error_call)
   }
 
   value <- vec_c(!!!value)

R/pivot.R

@@ -29,24 +29,24 @@
 #' # `.name` and `.value` are forced to be the first two columns
 #' spec <- tibble(foo = 1, .value = "b", .name = "a")
 #' check_pivot_spec(spec)
-check_pivot_spec <- function(spec) {
+check_pivot_spec <- function(spec, error_call = caller_env()) {
   if (!is.data.frame(spec)) {
-    abort("`spec` must be a data frame.")
+    abort("`spec` must be a data frame.", call = error_call)
   }
 
   if (!has_name(spec, ".name") || !has_name(spec, ".value")) {
-    abort("`spec` must have `.name` and `.value` columns.")
+    abort("`spec` must have `.name` and `.value` columns.", call = error_call)
   }
 
   if (!is.character(spec$.name)) {
-    abort("The `.name` column of `spec` must be a character vector.")
+    abort("The `.name` column of `spec` must be a character vector.", call = error_call)
   }
   if (vec_duplicate_any(spec$.name)) {
-    abort("The `.name` column of `spec` must be unique.")
+    abort("The `.name` column of `spec` must be unique.", call = error_call)
   }
 
   if (!is.character(spec$.value)) {
-    abort("The `.value` column of `spec` must be a character vector.")
+    abort("The `.value` column of `spec` must be a character vector.", call = error_call)
   }
 
   # Ensure `.name` and `.value` come first, in that order

R/replace_na.R

@@ -77,10 +77,10 @@ replace_na.data.frame <- function(data, replace = list(), ...) {
   data
 }
 
-check_replacement <- function(x, var) {
+check_replacement <- function(x, var, call = caller_env()) {
   n <- vec_size(x)
 
   if (n != 1) {
-    abort(glue("Replacement for `{var}` is length {n}, not length 1."))
+    abort(glue("Replacement for `{var}` is length {n}, not length 1."), call = call)
   }
 }

R/separate.R

@@ -86,19 +86,19 @@ separate.data.frame <- function(data, col, into, sep = "[^[:alnum:]]+",
   reconstruct_tibble(data, out, if (remove) var else NULL)
 }
 
-str_separate <- function(x, into, sep, convert = FALSE, extra = "warn", fill = "warn") {
-  check_not_stringr_pattern(sep, "sep")
+str_separate <- function(x, into, sep, convert = FALSE, extra = "warn", fill = "warn", error_call = caller_env()) {
+  check_not_stringr_pattern(sep, "sep", call = error_call)
 
   if (!is.character(into)) {
-    abort("`into` must be a character vector")
+    abort("`into` must be a character vector.", call = error_call)
   }
 
   if (is.numeric(sep)) {
     out <- strsep(x, sep)
   } else if (is_character(sep)) {
     out <- str_split_fixed(x, sep, length(into), extra = extra, fill = fill)
   } else {
-    abort("`sep` must be either numeric or character")
+    abort("`sep` must be either numeric or character.", call = error_call)
   }
 
   names(out) <- as_utf8_character(into)
@@ -186,9 +186,9 @@ list_indices <- function(x, max = 20) {
   paste(x, collapse = ", ")
 }
 
-check_not_stringr_pattern <- function(x, arg) {
+check_not_stringr_pattern <- function(x, arg, call = caller_env()) {
   if (inherits_any(x, c("pattern", "stringr_pattern"))) {
-    abort(glue("`{arg}` can't use modifiers from stringr."))
+    abort(glue("`{arg}` can't use modifiers from stringr."), call = call)
   }
 
   invisible(x)