Use check_name() in all steps that produces new columns

NEWS.md

@@ -8,6 +8,8 @@
 
 * Steps with tunable arguments now have those arguments listed in the documentation.
 
+* All steps that add new columns will now informatively error if name collision occurs. (#983)
+
 # recipes 1.0.5
 
 * Added `outside` argument to `step_percentile()` to determine different ways of handling values outside the range of the training data.

R/bs.R

@@ -183,7 +183,10 @@ bake.step_bs <- function(object, new_data, ...) {
     strt <- max(cols) + 1
     new_data[, orig_var] <- NULL
   }
-  new_data <- bind_cols(new_data, as_tibble(bs_values))
+  bs_values <- as_tibble(bs_values)
+  bs_values <- check_name(bs_values, new_data, object, names(bs_values))
+
+  new_data <- bind_cols(new_data, bs_values)
   new_data
 }
 

R/date.R

@@ -286,6 +286,8 @@ bake.step_date <- function(object, new_data, ...) {
 
   names(date_values) <- new_names
 
+  date_values <- check_name(date_values, new_data, object, names(date_values))
+
   new_data <- bind_cols(new_data, date_values)
   keep_original_cols <- get_keep_original_cols(object)
   if (!keep_original_cols) {

R/dummy.R

@@ -331,7 +331,10 @@ bake.step_dummy <- function(object, new_data, ...) {
     ## use backticks for nonstandard factor levels here
     used_lvl <- gsub(paste0("^\\`?", col_names[i], "\\`?"), "", colnames(indicators))
     colnames(indicators) <- object$naming(col_names[i], used_lvl, fac_type == "ordered")
-    new_data <- bind_cols(new_data, as_tibble(indicators))
+    indicators <- as_tibble(indicators)
+    indicators <- check_name(indicators, new_data, object, names(indicators))
+
+    new_data <- bind_cols(new_data, indicators)
     if (any(!object$preserve, !keep_original_cols)) {
       new_data[, col_names[i]] <- NULL
     }

R/dummy_multi_choice.R

@@ -176,8 +176,11 @@ bake.step_dummy_multi_choice <- function(object, new_data, ...) {
 
   used_lvl <- gsub(paste0("^", prefix), "", colnames(indicators))
   colnames(indicators) <- object$naming(prefix, used_lvl)
+  indicators <- as_tibble(indicators)
 
-  new_data <- bind_cols(new_data, as_tibble(indicators))
+  indicators <- check_name(indicators, new_data, object, names(indicators))
+
+  new_data <- bind_cols(new_data, indicators)
   keep_original_cols <- get_keep_original_cols(object)
 
   if (!keep_original_cols) {

R/extract.R

@@ -246,6 +246,8 @@ bake.step_dummy_extract <- function(object, new_data, ...) {
     used_lvl <- gsub(paste0("^", col_names[i]), "", colnames(indicators))
     colnames(indicators) <- object$naming(col_names[i], used_lvl)
 
+    indicators <- check_name(indicators, new_data, object, names(indicators))
+
     new_data <- bind_cols(new_data, indicators)
 
     if (!keep_original_cols) {

R/geodist.R

@@ -157,11 +157,6 @@ prep.step_geodist <- function(x, training, info = NULL, ...) {
   }
   check_type(training[, lat_name], types = c("double", "integer"))
 
-
-  if (any(names(training) == x$name)) {
-    rlang::abort("'", x$name, "' is already used in the data.")
-  }
-
   step_geodist_new(
     lon = x$lon,
     lat = x$lat,
@@ -238,11 +233,16 @@ bake.step_geodist <- function(object, new_data, ...) {
   }
 
   if (object$log) {
-    new_data[, object$name] <- log(dist_vals)
-  } else {
-    new_data[, object$name] <- dist_vals
+    dist_vals <- log(dist_vals)
   }
 
+  geo_data <- tibble(dist_vals)
+  names(geo_data) <- object$name
+
+  geo_data <- check_name(geo_data, new_data, object, newname = object$name)
+
+  new_data <- bind_cols(new_data, geo_data)
+
   new_data
 }
 

R/harmonic.R

@@ -312,6 +312,9 @@ bake.step_harmonic <- function(object, new_data, ...) {
       seq_len(n_frequency)
     )
     res <- as_tibble(res)
+
+    res <- check_name(res, new_data, object, names(res))
+
     new_data <- bind_cols(new_data, res)
   }
 

R/holiday.R

@@ -141,6 +141,7 @@ bake.step_holiday <- function(object, new_data, ...) {
     names(tmp) <- paste(object$columns[i], names(tmp), sep = "_")
     tmp <- purrr::map_dfc(tmp, vec_cast, integer())
 
+    tmp <- check_name(tmp, new_data, object, names(tmp))
     new_data <- bind_cols(new_data, tmp)
   }
 

R/ica.R

@@ -199,7 +199,9 @@ bake.step_ica <- function(object, new_data, ...) {
     comps <- comps %*% object$res$K %*% object$res$W
     comps <- comps[, seq_len(object$num_comp), drop = FALSE]
     colnames(comps) <- names0(ncol(comps), object$prefix)
-    new_data <- bind_cols(new_data, as_tibble(comps))
+    comps <- as_tibble(comps)
+    comps <- check_name(comps, new_data, object)
+    new_data <- bind_cols(new_data, comps)
     keep_original_cols <- get_keep_original_cols(object)
 
     if (!keep_original_cols) {

R/interactions.R

@@ -232,7 +232,9 @@ bake.step_interact <- function(object, new_data, ...) {
   }
   colnames(out) <-
     gsub(":", object$sep, unlist(lapply(res, colnames)))
-  new_data <- bind_cols(new_data, as_tibble(out))
+  out <- as_tibble(out)
+  out <- check_name(out, new_data, object, names(out))
+  new_data <- bind_cols(new_data, out)
   new_data
 }
 

R/intercept.R

@@ -92,7 +92,10 @@ prep.step_intercept <- function(x, training, info = NULL, ...) {
 
 #' @export
 bake.step_intercept <- function(object, new_data, ...) {
-  tibble::add_column(new_data, !!object$name := object$value, .before = TRUE)
+  intercept <- tibble(!!object$name := rep(object$value, nrow(new_data)))
+  intercept <- check_name(intercept, new_data, object, names(intercept))
+  new_data <- bind_cols(intercept, new_data)
+  new_data
 }
 
 print.step_intercept <-

R/isomap.R

@@ -204,8 +204,9 @@ bake.step_isomap <- function(object, new_data, ...) {
       )@data
     })
     comps <- comps[, seq_len(object$num_terms), drop = FALSE]
+    comps <- as_tibble(comps)
     comps <- check_name(comps, new_data, object)
-    new_data <- bind_cols(new_data, as_tibble(comps))
+    new_data <- bind_cols(new_data, comps)
     keep_original_cols <- get_keep_original_cols(object)
     if (!keep_original_cols) {
       new_data <- new_data[, !(colnames(new_data) %in% isomap_vars), drop = FALSE]

R/kpca.R

@@ -166,8 +166,9 @@ bake.step_kpca <- function(object, new_data, ...) {
     comps <- rlang::eval_tidy(cl)
     comps <- comps[, seq_len(object$num_comp), drop = FALSE]
     colnames(comps) <- names0(ncol(comps), object$prefix)
+    comps <- as_tibble(comps)
     comps <- check_name(comps, new_data, object)
-    new_data <- bind_cols(new_data, as_tibble(comps))
+    new_data <- bind_cols(new_data, comps)
     keep_original_cols <- get_keep_original_cols(object)
 
     if (!keep_original_cols) {

R/kpca_poly.R

@@ -172,8 +172,9 @@ bake.step_kpca_poly <- function(object, new_data, ...) {
     comps <- rlang::eval_tidy(cl)
     comps <- comps[, seq_len(object$num_comp), drop = FALSE]
     colnames(comps) <- names0(ncol(comps), object$prefix)
+    comps <- as_tibble(comps)
     comps <- check_name(comps, new_data, object)
-    new_data <- bind_cols(new_data, as_tibble(comps))
+    new_data <- bind_cols(new_data, comps)
     keep_original_cols <- get_keep_original_cols(object)
 
     if (!keep_original_cols) {

R/kpca_rbf.R

@@ -160,8 +160,9 @@ bake.step_kpca_rbf <- function(object, new_data, ...) {
     comps <- rlang::eval_tidy(cl)
     comps <- comps[, seq_len(object$num_comp), drop = FALSE]
     colnames(comps) <- names0(ncol(comps), object$prefix)
+    comps <- as_tibble(comps)
     comps <- check_name(comps, new_data, object)
-    new_data <- bind_cols(new_data, as_tibble(comps))
+    new_data <- bind_cols(new_data, comps)
     keep_original_cols <- get_keep_original_cols(object)
 
     if (!keep_original_cols) {

R/misc.R

@@ -500,24 +500,27 @@ simple_terms <- function(x, ...) {
 #'   in the trained object.
 #' @param names A logical determining if the names should be set using
 #' the names function (TRUE) or colnames function (FALSE).
+#' @param call The execution environment of a currently running function, e.g.
+#'   `caller_env()`. The function will be mentioned in error messages as the
+#'   source of the error. See the call argument of [rlang::abort()] for more
+#'   information.
 #' @export
 #' @keywords internal
-check_name <- function(res, new_data, object, newname = NULL, names = FALSE) {
+check_name <- function(res, new_data, object, newname = NULL, names = FALSE,
+                       call = caller_env()) {
   if (is.null(newname)) {
     newname <- names0(ncol(res), object$prefix)
   }
   new_data_names <- colnames(new_data)
   intersection <- new_data_names %in% newname
   if (any(intersection)) {
-    rlang::abort(
-      paste0(
-        "Name collision occured in `",
-        class(object)[1],
-        "`. The following variable names already exists: ",
-        paste0(new_data_names[intersection], collapse = ", "),
-        "."
-      )
+    nms <- new_data_names[intersection]
+    cli::cli_abort(
+      c("Name collision occured. The following variable names already exists:",
+        i = " {nms}"),
+      call = call
     )
+
   }
   if (names) {
     names(res) <- newname

R/naindicate.R

@@ -111,7 +111,9 @@ bake.step_indicate_na <- function(object, new_data, ...) {
   cols <- tibble::new_tibble(cols, nrow = nrow(new_data))
   cols <- dplyr::rename_with(cols, ~ vec_paste0(object$prefix, "_", .x))
 
-  new_data <- dplyr::bind_cols(new_data, cols)
+  cols <- check_name(cols, new_data, object, names(cols))
+
+  new_data <- bind_cols(new_data, cols)
   new_data
 }
 

R/nnmf.R

@@ -188,7 +188,9 @@ bake.step_nnmf <- function(object, new_data, ...) {
       object$res@apply(dimred_data(new_data[, nnmf_vars, drop = FALSE]))@data
     comps <- comps[, seq_len(object$num_comp), drop = FALSE]
     colnames(comps) <- names0(ncol(comps), object$prefix)
-    new_data <- bind_cols(new_data, as_tibble(comps))
+    comps <- as_tibble(comps)
+    comps <- check_name(comps, new_data, object)
+    new_data <- bind_cols(new_data, comps)
     keep_original_cols <- get_keep_original_cols(object)
 
     if (!keep_original_cols) {

R/nnmf_sparse.R

@@ -198,7 +198,9 @@ bake.step_nnmf_sparse <- function(object, new_data, ...) {
     proj_data <- as.matrix(new_data[, object$res$x_vars, drop = FALSE])
     proj_data <- proj_data %*% object$res$w
     colnames(proj_data) <- names0(ncol(proj_data), object$prefix)
-    new_data <- bind_cols(new_data, as_tibble(proj_data))
+    proj_data <- as_tibble(proj_data)
+    proj_data <- check_name(proj_data, new_data, object)
+    new_data <- bind_cols(new_data, proj_data)
     keep_original_cols <- get_keep_original_cols(object)
 
     if (!keep_original_cols) {

R/ns.R

@@ -173,7 +173,9 @@ bake.step_ns <- function(object, new_data, ...) {
     strt <- max(cols) + 1
     new_data[, orig_var] <- NULL
   }
-  new_data <- bind_cols(new_data, as_tibble(ns_values))
+  ns_values <- as_tibble(ns_values)
+  ns_values <- check_name(ns_values, new_data, object, names(ns_values))
+  new_data <- bind_cols(new_data, ns_values)
   new_data
 }
 

R/pls.R

@@ -381,9 +381,10 @@ bake.step_pls <- function(object, new_data, ...) {
     }
 
     names(comps) <- names0(ncol(comps), object$prefix)
+    comps <- as_tibble(comps)
     comps <- check_name(comps, new_data, object)
 
-    new_data <- bind_cols(new_data, as_tibble(comps))
+    new_data <- bind_cols(new_data, comps)
     keep_original_cols <- get_keep_original_cols(object)
 
     # Old pls never preserved original columns,

R/poly.R

@@ -171,7 +171,8 @@ bake.step_poly <- function(object, new_data, ...) {
     new_tbl[i_new_names] <- new_cols
   }
 
-  new_data <- dplyr::bind_cols(new_data, new_tbl)
+  new_tbl <- check_name(new_tbl, new_data, object, names(new_tbl))
+  new_data <- bind_cols(new_data, new_tbl)
   new_data <- dplyr::select(new_data, -dplyr::all_of(col_names))
   new_data
 }

R/poly_bernstein.R

@@ -151,6 +151,7 @@ bake.step_poly_bernstein <- function(object, new_data, ...) {
   orig_names <- names(object$results)
   if (length(orig_names) > 0) {
     new_cols <- purrr::map2_dfc(object$results, new_data[, orig_names], spline2_apply)
+    new_cols <- check_name(new_cols, new_data, object, names(new_cols))
     new_data <- bind_cols(new_data, new_cols)
     keep_original_cols <- get_keep_original_cols(object)
     if (!keep_original_cols) {

R/ratio.R

@@ -159,9 +159,10 @@ bake.step_ratio <- function(object, new_data, ...) {
 
   res <- tibble::new_tibble(res, nrow = nrow(new_data))
 
-  keep_original_cols <- get_keep_original_cols(object)
+  res <- check_name(res, new_data, object, names(res))
   new_data <- bind_cols(new_data, res)
 
+  keep_original_cols <- get_keep_original_cols(object)
   if (!keep_original_cols) {
     union_cols <- union(object$columns$top, object$columns$bottom)
     new_data <- new_data[, !(colnames(new_data) %in% union_cols), drop = FALSE]

R/spline_b.R

@@ -168,6 +168,7 @@ bake.step_spline_b <- function(object, new_data, ...) {
   orig_names <- names(object$results)
   if (length(orig_names) > 0) {
     new_cols <- purrr::map2_dfc(object$results, new_data[, orig_names], spline2_apply)
+    new_cols <- check_name(new_cols, new_data, object, names(new_cols))
     new_data <- bind_cols(new_data, new_cols)
     keep_original_cols <- get_keep_original_cols(object)
     if (!keep_original_cols) {

R/spline_convex.R

@@ -159,6 +159,7 @@ bake.step_spline_convex <- function(object, new_data, ...) {
   orig_names <- names(object$results)
   if (length(orig_names) > 0) {
     new_cols <- purrr::map2_dfc(object$results, new_data[, orig_names], spline2_apply)
+    new_cols <- check_name(new_cols, new_data, object, names(new_cols))
     new_data <- bind_cols(new_data, new_cols)
     keep_original_cols <- get_keep_original_cols(object)
     if (!keep_original_cols) {

R/spline_monotone.R

@@ -160,6 +160,7 @@ bake.step_spline_monotone <- function(object, new_data, ...) {
   orig_names <- names(object$results)
   if (length(orig_names) > 0) {
     new_cols <- purrr::map2_dfc(object$results, new_data[, orig_names], spline2_apply)
+    new_cols <- check_name(new_cols, new_data, object, names(new_cols))
     new_data <- bind_cols(new_data, new_cols)
     keep_original_cols <- get_keep_original_cols(object)
     if (!keep_original_cols) {

R/spline_natural.R

@@ -151,6 +151,7 @@ bake.step_spline_natural <- function(object, new_data, ...) {
   orig_names <- names(object$results)
   if (length(orig_names) > 0) {
     new_cols <- purrr::map2_dfc(object$results, new_data[, orig_names], spline2_apply)
+    new_cols <- check_name(new_cols, new_data, object, names(new_cols))
     new_data <- bind_cols(new_data, new_cols)
     keep_original_cols <- get_keep_original_cols(object)
     if (!keep_original_cols) {

R/spline_nonnegative.R

@@ -171,6 +171,7 @@ bake.step_spline_nonnegative <- function(object, new_data, ...) {
   orig_names <- names(object$results)
   if (length(orig_names) > 0) {
     new_cols <- purrr::map2_dfc(object$results, new_data[, orig_names], spline2_apply)
+    new_cols <- check_name(new_cols, new_data, object, names(new_cols))
     new_data <- bind_cols(new_data, new_cols)
     keep_original_cols <- get_keep_original_cols(object)
     if (!keep_original_cols) {

R/time.R

@@ -143,6 +143,7 @@ bake.step_time <- function(object, new_data, ...) {
     )
 
     names(time_values) <- glue("{column}_{names(time_values)}")
+    time_values <- check_name(time_values, new_data, object, names(time_values))
     new_data <- bind_cols(new_data, time_values)
   }