adapt errors to next rlang

NAMESPACE

@@ -59,6 +59,9 @@ S3method(filter,data.frame)
 S3method(filter,ts)
 S3method(filter_,data.frame)
 S3method(filter_,tbl_df)
+S3method(filter_bullets,"dplyr:::filter_incompatible_size")
+S3method(filter_bullets,"dplyr:::filter_incompatible_type")
+S3method(filter_bullets,default)
 S3method(format,src_local)
 S3method(full_join,data.frame)
 S3method(group_by,data.frame)
@@ -94,6 +97,10 @@ S3method(left_join,data.frame)
 S3method(mutate,data.frame)
 S3method(mutate_,data.frame)
 S3method(mutate_,tbl_df)
+S3method(mutate_bullets,"dplyr:::mutate_incompatible_size")
+S3method(mutate_bullets,"dplyr:::mutate_mixed_null")
+S3method(mutate_bullets,"dplyr:::mutate_not_vector")
+S3method(mutate_bullets,default)
 S3method(n_groups,data.frame)
 S3method(nest_by,data.frame)
 S3method(nest_by,grouped_df)
@@ -137,6 +144,7 @@ S3method(setequal,data.frame)
 S3method(slice,data.frame)
 S3method(slice_,data.frame)
 S3method(slice_,tbl_df)
+S3method(slice_bullets,default)
 S3method(slice_head,data.frame)
 S3method(slice_max,data.frame)
 S3method(slice_min,data.frame)
@@ -148,6 +156,11 @@ S3method(summarise,grouped_df)
 S3method(summarise,rowwise_df)
 S3method(summarise_,data.frame)
 S3method(summarise_,tbl_df)
+S3method(summarise_bullets,"dplyr:::error_summarise_incompatible_combine")
+S3method(summarise_bullets,"dplyr:::summarise_incompatible_size")
+S3method(summarise_bullets,"dplyr:::summarise_mixed_null")
+S3method(summarise_bullets,"dplyr:::summarise_unsupported_type")
+S3method(summarise_bullets,default)
 S3method(tally,data.frame)
 S3method(tbl,DBIConnection)
 S3method(tbl,src_local)

R/across.R

@@ -172,18 +172,25 @@ across <- function(.cols = everything(), .fns = NULL, ..., .names = NULL) {
 
   # Loop in such an order that all functions are applied
   # to a single column before moving on to the next column
-  for (i in seq_n_cols) {
-    var <- vars[[i]]
-    col <- data[[i]]
-
-    context_poke("column", var)
-
-    for (j in seq_fns) {
-      fn <- fns[[j]]
-      out[[k]] <- fn(col, ...)
-      k <- k + 1L
+  withCallingHandlers(
+    for (i in seq_n_cols) {
+      var <- vars[[i]]
+      col <- data[[i]]
+
+      context_poke("column", var)
+
+      for (j in seq_fns) {
+        fn <- fns[[j]]
+        out[[k]] <- fn(col, ...)
+        k <- k + 1L
+      }
+    }, error = function(cnd) {
+      bullets <- c(
+        glue("Problem while computing column `{names[k]}`.")
+      )
+      abort(bullets, call = call(setup$across_if_fn), parent = cnd)
     }
-  }
+  )
 
   size <- vec_size_common(!!!out)
   out <- vec_recycle_common(!!!out, .size = size)
@@ -247,7 +254,7 @@ c_across <- function(cols = everything()) {
   cols <- enquo(cols)
   vars <- c_across_setup(!!cols)
 
-  mask <- peek_mask("c_across()")
+  mask <- peek_mask("c_across")
 
   cols <- mask$current_cols(vars)
   vec_c(!!!cols, .name_spec = zap())
@@ -266,35 +273,43 @@ across_setup <- function(cols,
                          fns,
                          names,
                          .caller_env,
-                         mask = peek_mask("across()"),
+                         mask = peek_mask("across"),
                          inline = FALSE) {
   cols <- enquo(cols)
 
   # `across()` is evaluated in a data mask so we need to remove the
   # mask layer from the quosure environment (#5460)
   cols <- quo_set_env(cols, data_mask_top(quo_get_env(cols), recursive = FALSE, inherit = FALSE))
 
+  across_if_fn <- context_peek_bare("across_if_fn") %||% "across"
+
   # TODO: call eval_select with a calling handler to intercept
   #       classed error, after https://github.com/r-lib/tidyselect/issues/233
   if (is.null(fns) && quo_is_call(cols, "~")) {
-    if_fn <- context_peek_bare("across_if_fn") %||% "across"
-    abort(c(
-      "Predicate used in lieu of column selection.",
-      i = glue("You most likely meant: `{if_fn}(everything(), {as_label(cols)})`."),
+    bullets <- c(
+      "Must supply a column selection.",
+      i = glue("You most likely meant: `{across_if_fn}(everything(), {as_label(cols)})`."),
       i = "The first argument `.cols` selects a set of columns.",
       i = "The second argument `.fns` operates on each selected columns."
-    ))
+    )
+    abort(bullets, call = call(across_if_fn))
   }
   across_cols <- mask$across_cols()
 
-  vars <- tidyselect::eval_select(cols, data = across_cols)
+  vars <- fix_call(
+    tidyselect::eval_select(cols, data = across_cols),
+    call = call(across_if_fn)
+  )
   names_vars <- names(vars)
   vars <- names(across_cols)[vars]
 
   if (is.null(fns)) {
     if (!is.null(names)) {
       glue_mask <- across_glue_mask(.caller_env, .col = names_vars, .fn = "1")
-      names <- vec_as_names(glue(names, .envir = glue_mask), repair = "check_unique")
+      names <- fix_call(
+        vec_as_names(glue(names, .envir = glue_mask), repair = "check_unique"),
+        call = call(across_if_fn)
+      )
     } else {
       names <- names_vars
     }
@@ -312,9 +327,8 @@ across_setup <- function(cols,
   }
 
   if (!is.list(fns)) {
-    abort(c("Problem with `across()` input `.fns`.",
-      i = "`.fns` must be NULL, a function, a formula, or a list of functions/formulas."
-    ))
+    msg <- c("`.fns` must be NULL, a function, a formula, or a list of functions/formulas.")
+    abort(msg, call = call(across_if_fn))
   }
 
   # make sure fns has names, use number to replace unnamed
@@ -328,17 +342,20 @@ across_setup <- function(cols,
     }
   }
 
-  glue_mask <- glue_mask <- across_glue_mask(.caller_env,
+  glue_mask <- across_glue_mask(.caller_env,
     .col = rep(names_vars, each = length(fns)),
     .fn  = rep(names_fns , length(vars))
   )
-  names <- vec_as_names(glue(names, .envir = glue_mask), repair = "check_unique")
+  names <- fix_call(
+    vec_as_names(glue(names, .envir = glue_mask), repair = "check_unique"),
+    call = call(across_if_fn)
+  )
 
   if (!inline) {
     fns <- map(fns, as_function)
   }
 
-  list(vars = vars, fns = fns, names = names)
+  list(vars = vars, fns = fns, names = names, across_if_fn = across_if_fn)
 }
 
 # FIXME: This pattern should be encapsulated by rlang
@@ -354,7 +371,7 @@ data_mask_top <- function(env, recursive = FALSE, inherit = FALSE) {
 }
 
 c_across_setup <- function(cols) {
-  mask <- peek_mask("c_across()")
+  mask <- peek_mask("c_across")
 
   cols <- enquo(cols)
   across_cols <- mask$across_cols()
@@ -528,7 +545,7 @@ expand_across <- function(quo) {
   seq_vars <- seq_len(n_vars)
   seq_fns  <- seq_len(n_fns)
 
-  expressions <- vector(mode = "list", n_vars * n_fns)
+  expressions <- structure(vector(mode = "list", n_vars * n_fns), class = "dplyr_expanded_quosures")
   columns <- character(n_vars * n_fns)
 
   k <- 1L

R/all-equal.r

@@ -34,7 +34,6 @@
 #' all_equal(df1, df2, convert = TRUE)
 all_equal <- function(target, current, ignore_col_order = TRUE,
                       ignore_row_order = TRUE, convert = FALSE, ...) {
-
   equal_data_frame(target, current,
     ignore_col_order = ignore_col_order,
     ignore_row_order = ignore_row_order,
@@ -45,13 +44,14 @@ all_equal <- function(target, current, ignore_col_order = TRUE,
 equal_data_frame <- function(x, y, ignore_col_order = TRUE, ignore_row_order = TRUE, convert = FALSE) {
   compat <- is_compatible_data_frame(x, y, ignore_col_order = ignore_col_order, convert = convert)
   if (!isTRUE(compat)) {
-    return(compat)
+    # revert the bulleting from is_compatible_data_frame()
+    return(glue_collapse(compat, sep = "\n"))
   }
 
   nrows_x <- nrow(x)
   nrows_y <- nrow(y)
   if (nrows_x != nrows_y) {
-    return("Different number of rows")
+    return("Different number of rows.")
   }
 
   if (ncol(x) == 0L) {

R/arrange.R

@@ -83,7 +83,7 @@ arrange.data.frame <- function(.data, ..., .by_group = FALSE) {
 
 # Helpers -----------------------------------------------------------------
 
-arrange_rows <- function(.data, dots) {
+arrange_rows <- function(.data, dots, error_call = caller_env()) {
   if (length(dots) == 0L) {
     out <- seq_len(nrow(.data))
     return(out)
@@ -97,7 +97,7 @@ arrange_rows <- function(.data, dots) {
     if (quo_is_call(quosure, "desc", ns = c("", "dplyr"))) {
       expr <- quo_get_expr(quosure)
       if (!has_length(expr, 2L)) {
-        abort("`desc()` expects exactly one argument.")
+        abort("`desc()` must be called with exactly one argument.", call = error_call)
       }
 
       quosure <- new_quosure(node_cadr(expr), quo_get_env(quosure))
@@ -126,14 +126,20 @@ arrange_rows <- function(.data, dots) {
       names <- names2(bullets)
       names[names == ""] <- "x"
       bullets <- set_names(bullets, names)
+
+      # skip the parent as this has reworked the bullets
+      # and this would be confusing to have them
+      parent <- cnd$parent
     } else {
-      bullets <- c(x = conditionMessage(cnd))
+      parent <- cnd
+      bullets <- c()
     }
 
-    abort(c(
-      "arrange() failed at implicit mutate() step. ",
+    bullets <- c(
+      "Problem with the implicit `mutate()` step. ",
       bullets
-    ), class = "dplyr_error")
+    )
+    abort(bullets, call = error_call, parent = parent)
 
   })
 

R/bind.r

@@ -101,19 +101,20 @@ bind_rows <- function(..., .id = NULL) {
   for (i in seq_along(dots)) {
     .x <- dots[[i]]
     if (!is.data.frame(.x) && !vec_is(.x)) {
-      abort(glue("Argument {i} must be a data frame or a named atomic vector."))
+      msg <- glue("Argument {i} must be a data frame or a named atomic vector.")
+      abort(msg)
     }
 
     if (is.null(names(.x))) {
-      abort(glue("Argument {i} must have names."))
+      msg <- glue("Argument {i} must have names.")
+      abort(msg)
     }
   }
 
   if (!is_null(.id)) {
     if (!is_string(.id)) {
-      bad_args(".id", "must be a scalar string, ",
-        "not {friendly_type_of(.id)} of length {length(.id)}."
-      )
+      msg <- glue("`.id` must be a scalar string, not {friendly_type_of(.id)} of length {length(.id)}.")
+      abort(msg)
     }
     if (!is_named(dots)) {
       names(dots) <- seq_along(dots)
@@ -135,7 +136,7 @@ bind_rows <- function(..., .id = NULL) {
   if (is.null(.id)) {
     names(dots) <- NULL
   }
-  out <- vec_rbind(!!!dots, .names_to = .id)
+  out <- fix_call(vec_rbind(!!!dots, .names_to = .id))
   if (length(dots)) {
     if (is.data.frame(first)) {
       out <- dplyr_reconstruct(out, first)
@@ -159,7 +160,7 @@ bind_cols <- function(..., .name_repair = c("unique", "universal", "check_unique
   names[map_lgl(dots, is.data.frame)] <- ""
   names(dots) <- names
 
-  out <- vec_cbind(!!!dots, .name_repair = .name_repair)
+  out <- fix_call(vec_cbind(!!!dots, .name_repair = .name_repair))
   if (!any(map_lgl(dots, is.data.frame))) {
     out <- as_tibble(out)
   }