strip colon from error messages (tidyverse#2731)

R/case_when.R

@@ -70,15 +70,15 @@ case_when <- function(...) {
     f <- formulas[[i]]
     if (!inherits(f, "formula") || length(f) != 3) {
       non_formula_arg <- substitute(list(...))[[i + 1]]
-      header <- glue("Case {i} ({deparsed})", deparsed = deparse_trunc(non_formula_arg))
-      glubort(header, "must be a two-sided formula, not {type_of(f)}")
+      header <- glue("Case {i} ({deparsed})", deparsed = fmt_obj1(deparse_trunc(non_formula_arg)))
+      glubort(header, "must be a two-sided formula, not a {type_of(f)}")
     }
 
     env <- environment(f)
 
     query[[i]] <- eval_bare(f[[2]], env)
     if (!is.logical(query[[i]])) {
-      header <- glue("LHS of case {i} ({deparsed})", deparsed = deparse_trunc(f_lhs(f)))
+      header <- glue("LHS of case {i} ({deparsed})", deparsed = fmt_obj1(deparse_trunc(f_lhs(f))))
       glubort(header, "must be a logical, not {type_of(query[[i]])}")
     }
 
@@ -92,7 +92,7 @@ case_when <- function(...) {
   for (i in seq_len(n)) {
     check_length(
       query[[i]], out,
-      paste0("LHS of case ", i, " (", deparse_trunc(f_lhs(formulas[[i]])), ")"),
+      paste0("LHS of case ", i, " (", fmt_obj1(deparse_trunc(f_lhs(formulas[[i]]))), ")"),
       "the longest input"
     )
 

R/colwise-filter.R

@@ -53,7 +53,7 @@ filter_at <- function(.tbl, .vars, .vars_predicate) {
 
 apply_filter_syms <- function(pred, syms, tbl) {
   if (is_empty(syms)) {
-    abort("`.predicate`: no matching columns")
+    bad_args(".predicate", "has no matching columns")
   }
 
   if (inherits(pred, "all_vars")) {

R/colwise-select.R

@@ -89,7 +89,7 @@ vars_select_syms <- function(vars, funs, tbl, strict = FALSE) {
   } else if (!strict) {
     syms <- syms(vars)
   } else {
-    bad_args(".funs", "no renaming function supplied")
+    bad_args(".funs", "must specify a renaming function")
   }
 
   group_syms <- base::setdiff(syms(group_vars(tbl)), syms)

R/copy-to.r

@@ -38,7 +38,7 @@ auto_copy <- function(x, y, copy = FALSE, ...) {
   if (same_src(x, y)) return(y)
 
   if (!copy) {
-    bad_args(c("x", "y", "copy"), "must share the same src, ",
+    glubort(NULL, "`x` and `y` must share the same src, ",
       "set `copy` = TRUE (may be slow)"
     )
   }

R/error.R

@@ -32,6 +32,10 @@ bad_named_calls <- function(named_calls, ..., .envir = parent.frame()) {
   glubort(fmt_named_calls(named_calls), ..., .envir = .envir)
 }
 
+bad_eq_ops <- function(named_calls, ..., .envir = parent.frame()) {
+  glubort(fmt_wrong_eq_ops(named_calls), ..., .envir = .envir)
+}
+
 bad_cols <- function(cols, ..., .envir = parent.frame()) {
   glubort(fmt_cols(cols), ..., .envir = .envir)
 }
@@ -42,7 +46,7 @@ bad_measures <- function(measures, ..., .envir = parent.frame()) {
 
 glubort <- function(header, ..., .envir = parent.frame(), .abort = abort) {
   text <- glue(..., .envir = .envir)
-  if (!is_null(header)) text <- paste0(header, ": ", text)
+  if (!is_null(header)) text <- paste0(header, " ", text)
   .abort(text)
 }
 
@@ -58,14 +62,21 @@ fmt_pos_args <- function(x) {
 
 fmt_calls <- function(...) {
   x <- parse_named_call(...)
-  fmt_comma(x)
+  fmt_obj(x)
 }
 
 fmt_named_calls <- function(...) {
   x <- parse_named_call(...)
   fmt_named(x)
 }
 
+fmt_wrong_eq_ops <- function(...) {
+  x <- parse_named_call(...)
+  fmt_comma(
+    paste0(fmt_obj1(names2(x)), " (", fmt_obj1(paste0(names2(x), " = ", x)), ")")
+  )
+}
+
 fmt_cols <- function(x) {
   cols <- ntext(length(x), "Column", "Columns")
   glue("{cols} {fmt_obj(x)}")

R/grouped-df.r

@@ -290,8 +290,8 @@ sample_frac.grouped_df <- function(tbl, size = 1, replace = FALSE,
     warn("`.env` is deprecated and no longer has any effect")
   }
   if (size > 1 && !replace) {
-    bad_args(c("size", "replace"), "sampled fraction must be less or equal to one, ",
-      "set `replace` = TRUE for sampling with replacement"
+    bad_args("size", "of sampled fraction must be less or equal to one, ",
+      "set `replace` = TRUE to use sampling with replacement"
     )
   }
   weight <- enquo(weight)

R/join.r

@@ -145,14 +145,14 @@ common_by_from_vector <- function(by) {
 common_by.list <- function(by, x, y) {
   x_vars <- tbl_vars(x)
   if (!all(by$x %in% x_vars)) {
-    bad_args("by", "join column {missing} not found in lhs",
+    bad_args("by", "can't contain join column {missing} which is missing from LHS",
       missing = fmt_obj(setdiff(by$x, x_vars))
     )
   }
 
   y_vars <- tbl_vars(y)
   if (!all(by$y %in% y_vars)) {
-    bad_args("by", "join column {missing} not found in rhs",
+    bad_args("by", "can't contain join column {missing} which is missing from RHS",
       missing = fmt_obj(setdiff(by$y, y_vars))
     )
   }

R/lead-lag.R

@@ -62,7 +62,7 @@ lag <- function(x, n = 1L, default = NA, order_by = NULL, ...) {
   }
 
   if (inherits(x, "ts")) {
-    bad_args("x", "must be a vector, not ts object, do you want `stats::lag()`?")
+    bad_args("x", "must be a vector, not a ts object, do you want `stats::lag()`?")
   }
 
   if (length(n) != 1 || !is.numeric(n) || n < 0) {

R/recode.R

@@ -144,7 +144,7 @@ recode.factor <- function(.x, ..., .default = NULL, .missing = NULL) {
     bad_pos_args(bad, "must be named, not unnamed")
   }
   if (!is.null(.missing)) {
-    bad_args(".missing", "not supported for factors")
+    bad_args(".missing", "is not supported for factors")
   }
 
   n <- length(levels(.x))

R/sample.R

@@ -103,15 +103,15 @@ check_weight <- function(x, n) {
 check_size <- function(size, n, replace = FALSE) {
   if (size <= n || replace) return()
 
-  bad_args(c("size", "replace"), "must be less or equal than {n} (size of data), ",
-    "set `replace` = TRUE for sampling with replacement"
+  bad_args("size", "must be less or equal than {n} (size of data), ",
+    "set `replace` = TRUE to use sampling with replacement"
   )
 }
 
 check_frac <- function(size, replace = FALSE) {
   if (size <= 1 || replace) return()
 
-  bad_args(c("size", "replace"), "sampled fraction must be less or equal to one, ",
-    "set `replace` = TRUE for sampling with replacement"
+  bad_args("size", "of sampled fraction must be less or equal to one, ",
+    "set `replace` = TRUE to use sampling with replacement"
   )
 }

R/select-vars.R

@@ -151,7 +151,7 @@ rename_vars <- function(vars, ..., strict = TRUE) {
 
   unknown_vars <- setdiff(old_vars, vars)
   if (strict && length(unknown_vars) > 0) {
-    bad_args(unknown_vars, "unknown variables")
+    bad_args(unknown_vars, "contains unknown variables")
   }
 
   select <- set_names(vars, vars)

R/src-local.r

@@ -17,7 +17,7 @@
 #' }
 src_local <- function(tbl, pkg = NULL, env = NULL) {
   if (!xor(is.null(pkg), is.null(env))) {
-    bad_args(c("pkg", "env"), "exactly one must be non-NULL, ",
+    glubort(NULL, "Exactly one of `pkg` and `env` must be non-NULL, ",
       "not {(!is.null(pkg)) + (!is.null(env))}"
     )
   }
@@ -57,8 +57,8 @@ copy_to.src_local <- function(dest, df, name = deparse(substitute(df)),
                               overwrite = FALSE, ...) {
 
   if (!overwrite && exists(name, envir = dest$env, inherits = FALSE)) {
-    bad_args(c("name", "overwrite"), "object with name {fmt_obj(name)} already exists, ",
-      "set `overwrite` = TRUE"
+    glubort(NULL, "object with `name` = {fmt_obj(name)} must not already exist, ",
+      "unless `overwrite` = TRUE"
     )
   }
 

R/src_dbi.R

@@ -143,7 +143,7 @@ src_sqlite <- function(path, create = FALSE) {
   check_dbplyr()
 
   if (!create && !file.exists(path)) {
-    bad_args(c("path", "create"), "path does not exist, set `create` = TRUE")
+    bad_args("path", "must not already exist, unless `create` = TRUE")
   }
 
   con <- DBI::dbConnect(RSQLite::SQLite(), path)

R/tbl-cube.r

@@ -106,7 +106,7 @@ tbl_cube <- function(dimensions, measures) {
   )
   if (any(!dims_ok)) {
     bad <- names(measures)[!dims_ok]
-    bad_measures(bad, "need dimensions {fmt_dims(dims)}, not {bad_dim}",
+    bad_measures(bad, "needs dimensions {fmt_dims(dims)}, not {bad_dim}",
       bad_dim = fmt_dims(dim(measures[!dims_ok][[1L]]))
     )
   }
@@ -274,7 +274,7 @@ as.tbl_cube.data.frame <- function(x, dim_names = NULL, met_name = guess_met(x),
     dupe_row <- anyDuplicated(all[dim_names])
     dupe <- unlist(all[dupe_row, dim_names])
 
-    bad_args("x", "all combinations of dimension variables must be unique, ",
+    bad_args("x", "must be unique in all combinations of dimension variables, ",
       'duplicates: {fmt_named(dupe)}'
     )
   }

R/tbl-df.r

@@ -56,7 +56,7 @@ filter.tbl_df <- function(.data, ...) {
   dots <- quos(...)
   if (any(have_name(dots))) {
     bad <- dots[have_name(dots)]
-    bad_named_calls(bad, "must not be named, do you need `==`?")
+    bad_eq_ops(bad, "must not be named, do you need `==`?")
   } else if (is_empty(dots)) {
     return(.data)
   }

R/ts.R

@@ -1,4 +1,4 @@
 #' @export
 filter.ts <- function(.data, ...) {
-  bad_args(".data", "must be a data source, not ts object, do you want `stats::filter()`?")
+  bad_args(".data", "must be a data source, not a ts object, do you want `stats::filter()`?")
 }

R/utils-replace-with.R

@@ -20,11 +20,11 @@ check_length <- function(x, template, header, reason = NULL) {
   check_length_val(length(x), length(template), header, reason)
 }
 
-check_length_col <- function(length_x, n, name, reason = NULL) {
-  check_length_val(length_x, n, fmt_cols(name), reason)
+check_length_col <- function(length_x, n, name, reason = NULL, .abort = abort) {
+  check_length_val(length_x, n, fmt_cols(name), reason, .abort = .abort)
 }
 
-check_length_val <- function(length_x, n, header, reason = NULL) {
+check_length_val <- function(length_x, n, header, reason = NULL, .abort = abort) {
   if (length_x == n) {
     return()
   }
@@ -37,9 +37,9 @@ check_length_val <- function(length_x, n, header, reason = NULL) {
   else reason <- glue(" ({reason})")
 
   if (n == 1) {
-    glubort(header, "must be length one{reason}, not {length_x}")
+    glubort(header, "must be length 1{reason}, not {length_x}", .abort = .abort)
   } else {
-    glubort(header, "must be length {n}{reason} or one, not {length_x}")
+    glubort(header, "must be length {n}{reason} or one, not {length_x}", .abort = .abort)
   }
 }
 

inst/include/dplyr/Collecter.h

@@ -625,7 +625,7 @@ inline Collecter* collecter(SEXP model, int n) {
     break;
   }
 
-  stop("unsupported vector type %s", Rf_type2char(TYPEOF(model)));
+  stop("is of unsupported type %s", Rf_type2char(TYPEOF(model)));
 }
 
 inline Collecter* promote_collecter(SEXP model, int n, Collecter* previous) {
@@ -667,7 +667,7 @@ inline Collecter* promote_collecter(SEXP model, int n, Collecter* previous) {
   default:
     break;
   }
-  stop("unsupported vector type %s", Rf_type2char(TYPEOF(model)));
+  stop("is of unsupported type %s", Rf_type2char(TYPEOF(model)));
 }
 
 }

inst/include/dplyr/DataFrameSubsetVisitors.h

@@ -50,7 +50,7 @@ class DataFrameSubsetVisitors {
 
       int pos = indx[i];
       if (pos == NA_INTEGER) {
-        bad_col(names[i], "unknown");
+        bad_col(names[i], "is unknown");
       }
 
       SubsetVectorVisitor* v = subset_visitor(data[pos - 1], data_names[pos - 1]);

inst/include/dplyr/Gatherer.h

@@ -96,7 +96,7 @@ class GathererImpl : public Gatherer {
       delete coll;
       coll = new_collecter;
     } else {
-      bad_col(name, "can't convert {source_type} to {target_type}",
+      bad_col(name, "can't be converted from {source_type} to {target_type}",
               _["source_type"] = coll->describe(), _["target_type"] = get_single_class(subset));
     }
   }
@@ -221,7 +221,7 @@ class ConstantGathererImpl : public Gatherer {
 
 inline Gatherer* constant_gatherer(SEXP x, int n, const SymbolString& name) {
   if (Rf_inherits(x, "POSIXlt")) {
-    bad_col(name, "POSIXlt results not supported");
+    bad_col(name, "is of unsupported class POSIXlt");
   }
   switch (TYPEOF(x)) {
   case INTSXP:
@@ -239,7 +239,7 @@ inline Gatherer* constant_gatherer(SEXP x, int n, const SymbolString& name) {
   default:
     break;
   }
-  bad_col(name, "unsupported vector type {type}", _["type"] = Rf_type2char(TYPEOF(x)));
+  bad_col(name, "is of unsupported type {type}", _["type"] = Rf_type2char(TYPEOF(x)));
 }
 
 template <typename Data, typename Subsets>
@@ -249,7 +249,7 @@ inline Gatherer* gatherer(GroupedCallProxy<Data, Subsets>& proxy, const Data& gd
   RObject first(proxy.get(indices));
 
   if (Rf_inherits(first, "POSIXlt")) {
-    bad_col(name, "POSIXlt results not supported");
+    bad_col(name, "is of unsupported class POSIXlt");
   }
 
   check_supported_type(first, name);

inst/include/dplyr/GroupedDataFrame.h

@@ -78,7 +78,7 @@ class GroupedDataFrame {
       // check consistency of the groups
       int rows_in_groups = sum(group_sizes);
       if (data_.nrows() != rows_in_groups) {
-        bad_arg(".data", "corrupt grouped_df, contains {rows} rows, and {group_rows} rows in groups",
+        bad_arg(".data", "is a corrupt grouped_df, contains {rows} rows, and {group_rows} rows in groups",
                 _["rows"] = data_.nrows(), _["group_rows"] = rows_in_groups);
       }
     }

inst/include/dplyr/OrderVisitorImpl.h

@@ -273,7 +273,7 @@ inline OrderVisitor* order_visitor_asc_vector(SEXP vec) {
     break;
   }
 
-  stop("unsupported vector type %s", Rf_type2char(TYPEOF(vec)));
+  stop("is of unsupported type %s", Rf_type2char(TYPEOF(vec)));
 }
 }
 

inst/include/dplyr/Replicator.h

@@ -54,7 +54,7 @@ inline Replicator* replicator(SEXP v, const Data& gdf) {
     break;
   }
 
-  stop("unsupported vector type %s", Rf_type2char(TYPEOF(v)));
+  stop("is of unsupported type %s", Rf_type2char(TYPEOF(v)));
 }
 
 } // namespace dplyr

inst/include/dplyr/Result/GroupedSubset.h

@@ -76,7 +76,7 @@ inline GroupedSubset* grouped_subset(SEXP x, int max_size) {
   default:
     break;
   }
-  stop("unsupported vector type %s", Rf_type2char(TYPEOF(x)));
+  stop("is of unsupported type %s", Rf_type2char(TYPEOF(x)));
 }
 
 
@@ -129,7 +129,7 @@ inline GroupedSubset* summarised_subset(SummarisedVariable x) {
   default:
     break;
   }
-  stop("unsupported vector type %s", Rf_type2char(TYPEOF(x)));
+  stop("is of unsupported type %s", Rf_type2char(TYPEOF(x)));
 }
 }
 

inst/include/dplyr/checks.h

@@ -71,9 +71,9 @@ inline SupportedType check_supported_type(SEXP x, const SymbolString& name = Str
     return DPLYR_VECSXP;
   default:
     if (name.is_empty()) {
-      Rcpp::stop("unsupported type %s", type_name(x));
+      Rcpp::stop("is of unsupported type %s", type_name(x));
     } else {
-      bad_col(name, "must be a vector, not {type}",
+      bad_col(name, "is of unsupported type {type}",
               _["type"] = type_name(x));
     }
   }
@@ -82,8 +82,11 @@ inline SupportedType check_supported_type(SEXP x, const SymbolString& name = Str
 inline void check_length(const int actual, const int expected, const char* comment, const SymbolString& name) {
   if (actual == expected || actual == 1) return;
 
-  Function check_length_col("check_length_col", Environment::namespace_env("dplyr"));
-  check_length_col(actual, expected, CharacterVector::create(name.get_sexp()), std::string(comment));
+  static Function check_length_col("check_length_col", Environment::namespace_env("dplyr"));
+  static Function identity("identity", Environment::base_env());
+  String message = check_length_col(actual, expected, CharacterVector::create(name.get_sexp()), std::string(comment), _[".abort"] = identity);
+  message.set_encoding(CE_UTF8);
+  stop(message.get_cstring());
 }
 
 }