Merge pull request #1114 from r-lib/f-rbind

Prefer vctrs functions over slower base R equivalents

Author: lorenzwalthert

NAMESPACE

@@ -52,3 +52,6 @@ importFrom(rlang,is_installed)
 importFrom(rlang,seq2)
 importFrom(rlang,set_names)
 importFrom(rlang,warn)
+importFrom(vctrs,vec_rbind)
+importFrom(vctrs,vec_slice)
+importFrom(vctrs,vec_split)

R/compat-dplyr.R

@@ -13,41 +13,17 @@ lead <- function(x, n = 1L, default = NA) {
 
 arrange <- function(.data, ...) {
   ord <- eval(substitute(order(...)), .data, parent.frame())
-  .data[ord, , drop = FALSE]
+  vec_slice(.data, ord)
 }
 
 arrange_pos_id <- function(data) {
   pos_id <- data$pos_id
   if (is.unsorted(pos_id)) {
-    data <- data[order(pos_id), , drop = FALSE]
+    data <- vec_slice(data, order(pos_id))
   }
   data
 }
 
-bind_rows <- function(x, y = NULL, ...) {
-  if (is.null(x) && is.null(y)) {
-    return(new_styler_df(list()))
-  }
-  if (is.null(x)) {
-    if (inherits(y, "data.frame")) {
-      return(y)
-    }
-    return(do.call(rbind.data.frame, x))
-  }
-  if (is.null(y)) {
-    if (inherits(x, "data.frame")) {
-      return(x)
-    }
-    return(do.call(rbind.data.frame, x))
-  }
-  if (NCOL(x) != NCOL(y)) {
-    for (nme in setdiff(names(x), names(y))) {
-      y[[nme]] <- NA
-    }
-  }
-  bind_rows(rbind.data.frame(x, y), ...)
-}
-
 filter <- function(.data, ...) {
   subset(.data, ...)
 }
@@ -76,13 +52,8 @@ last <- function(x) {
   x[[length(x)]]
 }
 
-slice <- function(.data, ...) {
-  .data[c(...), , drop = FALSE]
-}
-
-# TODO: Use `purrr::map_dfr()` when it stops implicitly relying on `{dplyr}`
-map_dfr <- function(.x, .f, ..., .id = NULL) {
+map_dfr <- function(.x, .f, ...) {
   .f <- purrr::as_mapper(.f, ...)
   res <- map(.x, .f, ...)
-  bind_rows(res, .id = .id)
+  vec_rbind(!!!res)
 }

R/compat-tidyr.R

@@ -3,8 +3,8 @@ nest_ <- function(data, key_col, nest_cols = character()) {
   key_data <- data[[key_column]]
   key_levels <- unique(key_data)
   key_factor <- factor(key_data, levels = key_levels)
-  res <- list()
-  res[[key_column]] <- key_levels
-  res[[key_col]] <- split(data[, nest_cols], key_factor)
-  new_styler_df(res)
+
+  res <- vec_split(data[, nest_cols], key_factor)
+  names(res) <- c(key_column, key_col)
+  res
 }

R/detect-alignment-utils.R

@@ -15,7 +15,7 @@ alignment_ensure_no_closing_brace <- function(pd_by_line,
     pd_by_line[-length(pd_by_line)]
   } else {
     # only drop last elment of last line
-    pd_by_line[[length(pd_by_line)]] <- last[seq2(1L, nrow(last) - 1L), ]
+    pd_by_line[[length(pd_by_line)]] <- vec_slice(last, seq2(1L, nrow(last) - 1L))
     pd_by_line
   }
 }
@@ -29,7 +29,7 @@ alignment_ensure_no_closing_brace <- function(pd_by_line,
 #' @keywords internal
 alignment_drop_comments <- function(pd_by_line) {
   map(pd_by_line, function(x) {
-    out <- x[x$token != "COMMENT", ]
+    out <- vec_slice(x, x$token != "COMMENT")
     if (nrow(out) < 1L) {
       return(NULL)
     } else {
@@ -62,7 +62,7 @@ alignment_drop_last_expr <- function(pds_by_line) {
   pd_last_line <- pds_by_line[[length(pds_by_line)]]
   last_two_lines <- pd_last_line$token[c(nrow(pd_last_line) - 1L, nrow(pd_last_line))]
   if (identical(last_two_lines, c("')'", "expr"))) {
-    pd_last_line <- pd_last_line[-nrow(pd_last_line), ]
+    pd_last_line <- vec_slice(pd_last_line, -nrow(pd_last_line))
   }
   pds_by_line[[length(pds_by_line)]] <- pd_last_line
   pds_by_line
@@ -141,7 +141,7 @@ alignment_serialize_line <- function(relevant_pd_by_line, column) {
     return(NULL)
   }
   between_commas <- seq2(max(1L, comma_idx[column - 1L]), comma_idx[column])
-  relevant_pd_by_line <- relevant_pd_by_line[between_commas, ]
+  relevant_pd_by_line <- vec_slice(relevant_pd_by_line, between_commas)
   alignment_serialize(relevant_pd_by_line)
 }
 

R/detect-alignment.R

@@ -46,7 +46,12 @@ token_is_on_aligned_line <- function(pd_flat) {
   # pos_id too expensive to construct in alignment_ensure_trailing_comma()
   pd_flat$lag_newlines <- pd_flat$pos_id <- NULL
   pd_flat$.lag_spaces <- lag(pd_flat$spaces)
-  pd_by_line <- split(pd_flat, line_idx)
+  pd_by_line_split <- vec_split(pd_flat, line_idx)
+
+  # FIXME: Why are we using names here?
+  pd_by_line <- pd_by_line_split[[2L]]
+  names(pd_by_line) <- as.character(pd_by_line_split[[1L]])
+
   pd_by_line[purrr::map_lgl(pd_by_line, ~ any(.x$stylerignore))] <- NULL
   if (length(pd_by_line) < 1L) {
     return(TRUE)

R/indent.R

@@ -179,7 +179,7 @@ needs_indention_one <- function(pd,
     potential_trigger_pos, before_first_break
   )
   multi_line_token <- pd_is_multi_line(
-    pd[row_idx_between_trigger_and_line_break, ]
+    vec_slice(pd, row_idx_between_trigger_and_line_break)
   )
   remaining_row_idx_between_trigger_and_line_break <- setdiff(
     row_idx_between_trigger_and_line_break,

R/nest.R

@@ -99,12 +99,12 @@ add_cache_block <- function(pd_nested) {
 shallowify <- function(pd) {
   if (cache_is_activated()) {
     order <- order(pd$line1, pd$col1, -pd$line2, -pd$col2, as.integer(pd$terminal))
-    pd_parent_first <- pd[order, ]
-    pos_ids_to_keep <- pd_parent_first %>%
-      split(cumsum(pd_parent_first$parent == 0L)) %>%
+    pd_parent_first <- vec_slice(pd, order)
+    pd_parent_first_split <- vec_split(pd_parent_first, cumsum(pd_parent_first$parent == 0L))
+    pos_ids_to_keep <- pd_parent_first_split[[2L]] %>%
       map(find_pos_id_to_keep) %>%
       unlist(use.names = FALSE)
-    shallow <- pd[pd$pos_id %in% pos_ids_to_keep, ]
+    shallow <- vec_slice(pd, pd$pos_id %in% pos_ids_to_keep)
     shallow$terminal[shallow$is_cached] <- TRUE
     # all cached expressions need to be marked as terminals because to
     # [apply_stylerignore()], we rely on terminals only.
@@ -335,10 +335,9 @@ nest_parse_data <- function(pd_flat) {
       return(pd_flat)
     }
     pd_flat$internal <- with(pd_flat, (id %in% parent) | (parent <= 0L))
-    split_data <- split(pd_flat, pd_flat$internal)
 
-    child <- split_data$`FALSE`
-    internal <- split_data$`TRUE`
+    child <- vec_slice(pd_flat, !pd_flat$internal)
+    internal <- vec_slice(pd_flat, pd_flat$internal)
 
     internal$internal_child <- internal$child
     internal$child <- NULL
@@ -367,14 +366,14 @@ nest_parse_data <- function(pd_flat) {
 #' the correct order.
 #' @param child A parse table or `NULL`.
 #' @param internal_child A parse table or `NULL`.
-#' @details Essentially, this is a wrapper around [dplyr::bind_rows()], but
-#'   returns `NULL` if the result of [dplyr::bind_rows()] is a data frame with
+#' @details Essentially, this is a wrapper around vctrs::vec_rbind()], but
+#'   returns `NULL` if the result of vctrs::vec_rbind()] is a data frame with
 #'   zero rows.
 #' @keywords internal
 combine_children <- function(child, internal_child) {
-  bound <- bind_rows(child, internal_child)
+  bound <- vec_rbind(child, internal_child)
   if (nrow(bound) == 0L) {
     return(NULL)
   }
-  bound[order(bound$pos_id), ]
+  vec_slice(bound, order(bound$pos_id))
 }

R/parse.R

@@ -137,7 +137,7 @@ ensure_correct_txt <- function(pd, text) {
   if (!any(is_problematic_text)) {
     return(pd)
   }
-  problematic_text <- pd[is_problematic_text, ]
+  problematic_text <- vec_slice(pd, is_problematic_text)
   is_parent_of_problematic_string <- pd$id %in% problematic_text$parent
 
   is_unaffected_token <- !magrittr::or(
@@ -167,10 +167,10 @@ ensure_correct_txt <- function(pd, text) {
     names(new_text),
     paste0(line_col_names(), "parent")
   )
-  bind_rows(
+  vec_rbind(
     new_text[, names_to_keep],
-    pd[is_unaffected_token, ],
-    pd[is_parent_of_problematic_string, ]
+    vec_slice(pd, is_unaffected_token),
+    vec_slice(pd, is_parent_of_problematic_string)
   ) %>%
     arrange_pos_id()
 }

R/reindent.R

@@ -96,8 +96,8 @@ set_regex_indention <- function(flattened_pd,
     if (length(cond) < 1L) {
       return(flattened_pd)
     }
-    to_check <- flattened_pd[cond, ]
-    not_to_check <- flattened_pd[-cond, ]
+    to_check <- vec_slice(flattened_pd, cond)
+    not_to_check <- vec_slice(flattened_pd, -cond)
   } else {
     to_check <- flattened_pd
     not_to_check <- NULL
@@ -108,6 +108,6 @@ set_regex_indention <- function(flattened_pd,
     flatten_int()
 
   to_check$lag_spaces[indices_to_force] <- target_indention
-  bind_rows(to_check, not_to_check) %>%
+  vec_rbind(to_check, not_to_check) %>%
     arrange_pos_id()
 }

R/relevel.R

@@ -85,8 +85,8 @@ flatten_pd <- function(pd_nested, token, child_token = token, left = TRUE) {
 #' @keywords internal
 bind_with_child <- function(pd_nested, pos) {
   pd_nested %>%
-    slice(-pos) %>%
-    bind_rows(pd_nested$child[[pos]]) %>%
+    vec_slice(-pos) %>%
+    vec_rbind(pd_nested$child[[pos]]) %>%
     arrange_pos_id()
 }
 
@@ -178,8 +178,8 @@ relocate_eq_assign_nest <- function(pd) {
   idx_eq_assign <- which(pd$token == "EQ_ASSIGN")
   if (length(idx_eq_assign) > 0L) {
     block_id <- find_block_id(pd)
-    blocks <- split(pd, block_id)
-    pd <- map_dfr(blocks, relocate_eq_assign_one)
+    blocks <- vec_split(pd, block_id)
+    pd <- map_dfr(blocks[[2L]], relocate_eq_assign_one)
   }
   pd
 }
@@ -217,7 +217,7 @@ relocate_eq_assign_one <- function(pd) {
   eq_ind <- seq2(idx_eq_assign[1L] - 1L, last(idx_eq_assign) + 1L)
   # initialize because wrap_expr_in_expr -> create_tokens -> requires it
   pd$indent <- 0L
-  eq_expr <- pd[eq_ind, ] %>%
+  eq_expr <- vec_slice(pd, eq_ind) %>%
     wrap_expr_in_expr() %>%
     add_line_col_to_wrapped_expr() %>%
     remove_attributes(c(
@@ -227,8 +227,8 @@ relocate_eq_assign_one <- function(pd) {
   eq_expr$id <- NA
   eq_expr$parent <- NA
   pd$indent <- NULL
-  non_eq_expr <- pd[-eq_ind, ]
-  pd <- bind_rows(eq_expr, non_eq_expr) %>%
+  non_eq_expr <- vec_slice(pd, -eq_ind)
+  pd <- vec_rbind(eq_expr, non_eq_expr) %>%
     arrange_pos_id()
   pd
 }