Pass calls for improved error messages

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, 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 = 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 = call)
   }
 
-  ptype <- check_list_of_ptypes(ptype, names = names(x), arg = "ptype")
+  ptype <- check_list_of_ptypes(ptype, names = names(x), arg = "ptype", call = 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, call = 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 = 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 = 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, 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 = 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
@@ -277,7 +277,7 @@ grid_dots <- function(..., `_data` = NULL) {
     }
 
     arg <- paste0("..", i)
-    vec_assert(dot, arg = arg)
+    vec_assert(dot, arg = arg, call = caller_env())
 
     out[[i]] <- dot
 

R/extract.R

@@ -50,7 +50,7 @@ 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) {
+str_extract <- function(x, into, regex, convert = FALSE, call = caller_env()) {
   check_not_stringr_pattern(regex, "regex")
 
   stopifnot(
@@ -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 = 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,
+                                     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 = call))
+  values_from_cols <- names(tidyselect::eval_select(enquo(values_from), data, error_call = 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,
+    call = caller_env()
   )
 
   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(),
+                                 call = caller_env()) {
   id_cols <- enquo(id_cols)
 
   # Remove known non-id-cols so they are never selected
@@ -558,38 +562,38 @@ 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 = 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, 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 -----------------------------------------------------------------
@@ -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 = caller_env())
   }
 
   value <- vec_c(!!!value)

R/pivot.R

@@ -31,22 +31,22 @@
 #' check_pivot_spec(spec)
 check_pivot_spec <- function(spec) {
   if (!is.data.frame(spec)) {
-    abort("`spec` must be a data frame.")
+    abort("`spec` must be a data frame.", call = caller_env())
   }
 
   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 = caller_env())
   }
 
   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 = caller_env())
   }
   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 = caller_env())
   }
 
   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 = caller_env())
   }
 
   # Ensure `.name` and `.value` come first, in that order

R/replace_na.R

@@ -81,6 +81,6 @@ check_replacement <- function(x, var) {
   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 = caller_env())
   }
 }

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", call = caller_env()) {
+  check_not_stringr_pattern(sep, "sep", call = call)
 
   if (!is.character(into)) {
-    abort("`into` must be a character vector")
+    abort("`into` must be a character vector.", call = 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 = 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)

R/unnest-helper.R

@@ -5,11 +5,12 @@ df_simplify <- function(x,
                         ...,
                         ptype = NULL,
                         transform = NULL,
-                        simplify = TRUE) {
+                        simplify = TRUE,
+                        call = caller_env()) {
   check_dots_empty()
 
-  ptype <- check_list_of_ptypes(ptype, names(x), "ptype")
-  transform <- check_list_of_functions(transform, names(x), "transform")
+  ptype <- check_list_of_ptypes(ptype, names(x), "ptype", call = call)
+  transform <- check_list_of_functions(transform, names(x), "transform", call = call)
 
   if (is_bool(simplify)) {
     simplify_default <- simplify
@@ -19,13 +20,13 @@ df_simplify <- function(x,
   }
 
   if (!vec_is_list(simplify)) {
-    abort("`simplify` must be a list or a single `TRUE` or `FALSE`.")
+    abort("`simplify` must be a list or a single `TRUE` or `FALSE`.", call = call)
   }
   if (length(simplify) > 0L && !is_named(simplify)) {
-    abort("All elements of `simplify` must be named.")
+    abort("All elements of `simplify` must be named.", call = call)
   }
   if (vec_duplicate_any(names(simplify))) {
-    abort("The names of `simplify` must be unique.")
+    abort("The names of `simplify` must be unique.", call = call)
   }
 
   x_n <- length(x)
@@ -47,7 +48,8 @@ df_simplify <- function(x,
       x = col,
       ptype = col_ptype,
       transform = col_transform,
-      simplify = col_simplify
+      simplify = col_simplify,
+      call = call
     )
   }
 
@@ -58,7 +60,8 @@ col_simplify <- function(x,
                          ...,
                          ptype = NULL,
                          transform = NULL,
-                         simplify = TRUE) {
+                         simplify = TRUE,
+                         call = caller_env()) {
   check_dots_empty()
 
   if (!is.null(transform)) {
@@ -70,7 +73,7 @@ col_simplify <- function(x,
       x <- transform(x)
     }
     if (!is.null(ptype)) {
-      x <- vec_cast(x, ptype)
+      x <- vec_cast(x, ptype, call = call)
     }
     return(x)
   }
@@ -82,7 +85,7 @@ col_simplify <- function(x,
   }
   if (!is.null(ptype)) {
     x <- tidyr_new_list(x)
-    x <- vec_cast_common(!!!x, .to = ptype)
+    x <- vec_cast_common(!!!x, .to = ptype, .call = call)
     x <- new_list_of(x, ptype = ptype)
   }