tidyverse · krlmlr · Jul 31, 2021 · Jul 31, 2021 · Jul 31, 2021 · Jul 31, 2021
diff --git a/NAMESPACE b/NAMESPACE
@@ -97,12 +97,14 @@ importFrom(vctrs,vec_as_names_legacy)
 importFrom(vctrs,vec_as_subscript2)
 importFrom(vctrs,vec_assign)
 importFrom(vctrs,vec_c)
+importFrom(vctrs,vec_data)
 importFrom(vctrs,vec_is)
 importFrom(vctrs,vec_names)
 importFrom(vctrs,vec_names2)
 importFrom(vctrs,vec_ptype_abbr)
 importFrom(vctrs,vec_rbind)
 importFrom(vctrs,vec_recycle)
+importFrom(vctrs,vec_recycle_common)
 importFrom(vctrs,vec_set_names)
 importFrom(vctrs,vec_size)
 importFrom(vctrs,vec_slice)

diff --git a/R/add.R b/R/add.R
@@ -63,7 +63,7 @@ add_row <- function(.data, ..., .before = NULL, .after = NULL) {
   pos <- pos_from_before_after(.before, .after, nrow(.data))
   out <- rbind_at(.data, df, pos)
 
-  vectbl_restore(out, .data)
+  tibble_reconstruct(out, .data)
 }
 
 #' @export
@@ -95,6 +95,8 @@ rbind_at <- function(old, new, pos) {
     seq2(pos + 1L, nrow(old))
   )
   vec_slice(out, idx)
+
+  # tibble_reconstruct
 }
 
 #' Add columns to a data frame
@@ -166,7 +168,7 @@ add_column <- function(.data, ..., .before = NULL, .after = NULL,
   out <- new_data[indexes]
 
   out <- set_repaired_names(out, repair_hint = TRUE, .name_repair)
-  vectbl_restore(out, .data)
+  tibble_reconstruct(out, .data)
 }
 
 

diff --git a/R/reconstruct.R b/R/reconstruct.R
@@ -0,0 +1,77 @@
+# Keep in sync with generics.R in dplyr
+# Imported from 3de24a738243a3d07c87b3f4e4afa5f6b02ff561
+
+tibble_row_slice <- function(data, i, ...) {
+  if (!is.numeric(i) && !is.logical(i)) {
+    abort("`i` must be a numeric or logical vector.")
+  }
+
+  tibble_reconstruct(vec_slice(remove_rownames(data), i), data)
+}
+
+tibble_col_modify <- function(data, cols) {
+  # Must be implemented from first principles to avoiding edge cases in
+  # [.data.frame and [.tibble (2.1.3 and earlier).
+
+  # Apply tidyverse recycling rules
+  cols <- vec_recycle_common(!!!cols, .size = nrow(data))
+
+  # Transform to list to avoid stripping inner names with `[[<-`
+  out <- as.list(dplyr_vec_data(data))
+
+  nms <- as_utf8_character(names2(cols))
+  names(out) <- as_utf8_character(names2(out))
+
+  for (i in seq_along(cols)) {
+    nm <- nms[[i]]
+    out[[nm]] <- cols[[i]]
+  }
+
+  # Transform back to data frame before reconstruction
+  row_names <- .row_names_info(data, type = 0L)
+  out <- new_data_frame(out, n = nrow(data), row.names = row_names)
+
+  tibble_reconstruct(out, data)
+}
+
+tibble_reconstruct <- function(data, template) {
+  # Strip attributes before dispatch to make it easier to implement
+  # methods and prevent unexpected leaking of irrelevant attributes.
+  data <- dplyr_new_data_frame(data)
+
+  attrs <- attributes(template)
+  attrs$names <- names(data)
+  attrs$row.names <- .row_names_info(data, type = 0L)
+
+  attributes(data) <- attrs
+  data
+}
+
+# Until fixed upstream. `vec_data()` should not return lists from data
+# frames.
+dplyr_vec_data <- function(x) {
+  out <- vec_data(x)
+
+  if (is.data.frame(x)) {
+    new_data_frame(out, n = nrow(x))
+  } else {
+    out
+  }
+}
+
+# Until vctrs::new_data_frame() forwards row names automatically
+dplyr_new_data_frame <- function(x = data.frame(),
+                                 n = NULL,
+                                 ...,
+                                 row.names = NULL,
+                                 class = NULL) {
+  row.names <- row.names %||% .row_names_info(x, type = 0L)
+
+  new_data_frame(
+    x,
+    n = n,
+    ...,
+    row.names = row.names,
+    class = class
+  )
+}
diff --git a/R/subsetting.R b/R/subsetting.R
@@ -256,7 +256,7 @@ NULL
   if (drop && length(xo) == 1L) {
     tbl_subset2(xo, 1L, j_arg)
   } else {
-    vectbl_restore(xo, x)
+    tibble_reconstruct(xo, x)
   }
 }
 
@@ -410,8 +410,7 @@ tbl_subset2 <- function(x, j, j_arg) {
 tbl_subset_row <- function(x, i, i_arg) {
   if (is.null(i)) return(x)
   i <- vectbl_as_row_index(i, x, i_arg)
-  xo <- lapply(unclass(x), vec_slice, i = i)
-  set_tibble_class(xo, nrow = length(i))
+  tibble_row_slice(x, i)
 }
 
 tbl_subassign <- function(x, i, j, value, i_arg, j_arg, value_arg) {
@@ -462,7 +461,7 @@ tbl_subassign <- function(x, i, j, value, i_arg, j_arg, value_arg) {
     }
   }
 
-  vectbl_restore(xo, x)
+  tibble_reconstruct(xo, x)
 }
 
 vectbl_as_new_row_index <- function(i, x, i_arg) {
@@ -611,30 +610,42 @@ is_tight_sequence_at_end <- function(i_new, n) {
 }
 
 tbl_subassign_col <- function(x, j, value) {
-  is_data <- !vapply(value, is.null, NA)
-  nrow <- fast_nrow(x)
+  # Fix order
+  order_j <- order(j)
+  value <- value[order_j]
+  j <- j[order_j]
 
-  x <- unclass(x)
+  # tibble_col_modify
 
-  # Grow, assign new names
-  new <- which(j > length(x))
-  if (has_length(new)) {
-    length(x) <- max(j[new])
-    names(x)[ j[new] ] <- names2(j)[new]
-  }
+  # Adapt to interface
+  names(value) <- names(j)
+
+  # New names
+  tweak_names <- (j > length(x))
+  need_tweak_names <- any(tweak_names)
 
-  # Update
-  for (jj in which(is_data)) {
-    ji <- j[[jj]]
-    x[[ji]] <- value[[jj]]
+  if (need_tweak_names) {
+    new_names <- names(x)
+    new_names[ j[tweak_names] ] <- names(j)[tweak_names]
+
+    # New names ("" means appending at end)
+    names(value)[tweak_names] <- ""
+
+    # Removed names, use vapply() for speed
+    col_is_null <- vapply(value, is.null, NA)
+    if (any(col_is_null)) {
+      new_names <- new_names[ -j[col_is_null] ]
+    }
   }
 
-  # Remove
-  j_remove <- j[!is_data & !is.na(j)]
-  if (has_length(j_remove)) x <- x[-j_remove]
+  out <- tibble_col_modify(x, value)
 
-  # Restore
-  set_tibble_class(x, nrow)
+  # This calls `names<-()` for the tibble class
+  if (need_tweak_names) {
+    names(out) <- new_names
+  }
+
+  return(out)
 }
 
 tbl_expand_to_nrow <- function(x, i) {
@@ -649,7 +660,7 @@ tbl_expand_to_nrow <- function(x, i) {
   if (new_nrow != nrow) {
     # FIXME: vec_expand()?
     i_expand <- c(seq_len(nrow), rep(NA_integer_, new_nrow - nrow))
-    x <- vec_slice(x, i_expand)
+    x <- tibble_row_slice(x, i_expand)
   }
 
   x
@@ -776,12 +787,6 @@ set_tibble_class <- function(x, nrow) {
   x
 }
 
-# External ----------------------------------------------------------------
-
-vectbl_restore <- function(xo, x) {
-  .Call(`tibble_restore_impl`, xo, x)
-}
-
 # Errors ------------------------------------------------------------------
 
 error_need_rhs_vector <- function(value_arg) {

diff --git a/R/tibble-package.R b/R/tibble-package.R
@@ -10,6 +10,7 @@
 #' @importFrom vctrs vec_names vec_names2 vec_set_names
 #' @importFrom vctrs new_rcrd
 #' @importFrom vctrs new_data_frame
+#' @importFrom vctrs vec_recycle_common vec_data
 #' @aliases NULL tibble-package
 #' @details
 #' `r lifecycle::badge("stable")`

diff --git a/src/attributes.c b/src/attributes.c
diff --git a/src/init.c b/src/init.c
@@ -7,7 +7,6 @@
 static const R_CallMethodDef CallEntries[] = {
   {"tibble_matrixToDataFrame", (DL_FUNC) &tibble_matrixToDataFrame, 1},
   {"tibble_string_to_indices", (DL_FUNC) &tibble_string_to_indices, 1},
-  {"tibble_restore_impl", (DL_FUNC) &tibble_restore_impl, 2},
   {"tibble_need_coerce", (DL_FUNC) &tibble_need_coerce, 1},
 
   {NULL, NULL, 0}

diff --git a/src/tibble.h b/src/tibble.h
@@ -7,7 +7,5 @@
 SEXP tibble_matrixToDataFrame(SEXP xSEXP);
 SEXP tibble_string_to_indices(SEXP x);
 SEXP tibble_need_coerce(SEXP x);
-SEXP tibble_update_attrs(SEXP x, SEXP dots);
-SEXP tibble_restore_impl(SEXP xo, SEXP x);
 
 #endif /* TIBBLE_H */
diff --git a/tests/testthat/test-subsetting.R b/tests/testthat/test-subsetting.R
@@ -16,6 +16,15 @@ test_that("[ retains class", {
  expect_identical(class(mtcars2), class(mtcars2[1:5, 1:5]))
 })
 
+test_that("[ removes row names", {
+  tbl <- tibble(a = 1:3)
+  expect_warning(rownames(tbl) <- letters[1:3], "deprecated")
+
+  expect_equal(rownames(tbl), letters[1:3])
+  expect_equal(rownames(tbl[1, ]), "1")
+  expect_equal(rownames(tbl["a"]), as.character(1:3))
+})
+
 test_that("[ and as_tibble commute", {
   mtcars2 <- as_tibble(mtcars)
   expect_identical(mtcars2, as_tibble(mtcars))