diff --git a/NAMESPACE b/NAMESPACE index c983431e9..bf301774b 100644 --- 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 index 369842471..d34bebfb0 100644 --- 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 new file mode 100644 index 000000000..d427610be --- /dev/null +++ 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 index e81a5f780..7994e8bad 100644 --- 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 index ffcac0f11..6310aa705 100644 --- 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 deleted file mode 100644 index 7770b41d9..000000000 --- a/src/attributes.c +++ /dev/null @@ -1,18 +0,0 @@ -#include "tibble.h" - -SEXP tibble_restore_impl(SEXP xo, SEXP x) { - xo = PROTECT(Rf_shallow_duplicate(xo)); - - // copy over all attributes except `names` and `row.names` - SEXP attr_x = ATTRIB(x); - while(attr_x != R_NilValue) { - SEXP tag = TAG(attr_x); - if (tag != R_NamesSymbol && tag != R_RowNamesSymbol) { - Rf_setAttrib(xo, tag, CAR(attr_x)); - } - attr_x = CDR(attr_x); - } - - UNPROTECT(1); - return xo; -} diff --git a/src/init.c b/src/init.c index 4588296a2..34a41b670 100644 --- 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 index b1c762fb2..6902a0b9f 100644 --- 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 index b496cfa83..4c0559231 100644 --- 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))