Merge pull request #726 from DavisVaughan/tbl-new-data-frame

- `new_tibble()` uses `vctrs::new_data_frame()` internally (#726, @DavisVaughan).

Author: krlmlr

NAMESPACE

@@ -86,6 +86,7 @@ importFrom(pillar,type_sum)
 importFrom(pkgconfig,set_config)
 importFrom(utils,head)
 importFrom(utils,tail)
+importFrom(vctrs,new_data_frame)
 importFrom(vctrs,new_rcrd)
 importFrom(vctrs,num_as_location)
 importFrom(vctrs,unspecified)

R/new.R

@@ -44,9 +44,6 @@ new_tibble <- function(x, ..., nrow, class = NULL, subclass = NULL) {
     cnd_signal(error_new_tibble_must_be_list())
   }
 
-  #' The `...` argument allows adding more attributes to the subclass.
-  x <- update_tibble_attrs(x, ...)
-
   #' An `nrow` argument is required.
   if (missing(nrow)) {
     cnd <- error_new_tibble_needs_nrow()
@@ -63,22 +60,54 @@ new_tibble <- function(x, ..., nrow, class = NULL, subclass = NULL) {
   #' equal to this value.
   #' (But this is not checked by the constructor).
   #' This takes the place of the "row.names" attribute in a data frame.
-  if (!is_integerish(nrow, 1)) {
+  if (is_integerish(nrow, 1)) {
+    nrow <- as.integer(nrow)
+  } else {
     cnd_signal(error_new_tibble_needs_nrow())
   }
 
+  args <- attributes(x)
+
+  if (is.null(args)) {
+    args <- list()
+  }
+
+  new_attrs <- pairlist2(...)
+  nms <- names(new_attrs)
+
+  for (i in seq_along(nms)) {
+    nm <- nms[[i]]
+
+    if (nm == "") {
+      next
+    }
+
+    args[[nm]] <- new_attrs[[i]]
+  }
+
   #' `x` must have names (or be empty),
   #' but the names are not checked for correctness.
   if (length(x) == 0) {
     # Leaving this because creating a named list of length zero seems difficult
-    names(x) <- character()
-  } else if (is.null(names(x))) {
+    args[["names"]] <- character()
+  } else if (is.null(args[["names"]])) {
     cnd_signal(error_names_must_be_non_null())
   }
 
-  attr(x, "row.names") <- .set_row_names(nrow)
-  class(x) <- c(class[!class %in% tibble_class], tibble_class)
-  x
+  if (is.null(class)) {
+    class <- tibble_class_no_data_frame
+  } else {
+    class <- c(class[!class %in% tibble_class], tibble_class_no_data_frame)
+  }
+
+  slots <- c("x", "n", "class")
+  args[slots] <- list(x, nrow, class)
+
+  # `new_data_frame()` restores compact row names
+  args[["row.names"]] <- NULL
+
+  # do.call() is faster than exec() in this case
+  do.call(new_data_frame, args)
 }
 
 #' @description
@@ -131,11 +160,8 @@ validate_nrow <- function(names, lengths, nrow) {
   }
 }
 
-update_tibble_attrs <- function(x, ...) {
-  .Call(`tibble_update_attrs`, x, pairlist2(...))
-}
-
 tibble_class <- c("tbl_df", "tbl", "data.frame")
+tibble_class_no_data_frame <- c("tbl_df", "tbl")
 
 # Errors ------------------------------------------------------------------
 

R/tibble-package.R

@@ -9,6 +9,7 @@
 #' @importFrom vctrs unspecified vec_as_subscript2 num_as_location vec_ptype_abbr
 #' @importFrom vctrs vec_names vec_names2 vec_set_names
 #' @importFrom vctrs new_rcrd
+#' @importFrom vctrs new_data_frame
 #' @aliases NULL tibble-package
 #' @details
 #' `r lifecycle::badge("stable")`

man/new_tibble.Rd

@@ -1,19 +1,5 @@
 #include "tibble.h"
 
-SEXP tibble_update_attrs(SEXP x, SEXP dots) {
-  x = PROTECT(Rf_shallow_duplicate(x));
-
-  while(dots != R_NilValue) {
-    SEXP tag = TAG(dots);
-    if (tag != R_NilValue) {
-      Rf_setAttrib(x, tag, CAR(dots));
-    }
-    dots = CDR(dots);
-  }
-  UNPROTECT(1);
-  return x;
-}
-
 SEXP tibble_restore_impl(SEXP xo, SEXP x) {
   xo = PROTECT(Rf_shallow_duplicate(xo));
 

src/attributes.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_update_attrs", (DL_FUNC) &tibble_update_attrs, 2},
   {"tibble_restore_impl", (DL_FUNC) &tibble_restore_impl, 2},
   {"tibble_need_coerce", (DL_FUNC) &tibble_need_coerce, 1},
 

src/init.c

@@ -58,6 +58,32 @@ test_that("new_tibble() with additional attributes", {
   expect_identical(tbl_df, tbl_foo)
 })
 
+test_that("new_tibble() can add attributes on zero column tibbles with no attributes", {
+  expect_identical(
+    attr(new_tibble(list(), nrow = 0L, foo = 10), "foo"),
+    10
+  )
+})
+
+test_that("new_tibble() ignores unnamed additional attributes", {
+  expect_identical(
+    new_tibble(list(x = 1), "foo", nrow = 1),
+    new_tibble(list(x = 1), nrow = 1)
+  )
+
+  expect_identical(
+    new_tibble(list(x = 1), "foo", bar = "bar", nrow = 1),
+    new_tibble(list(x = 1), bar = "bar", nrow = 1)
+  )
+})
+
+test_that("new_tibble() allows setting names through `...`", {
+  expect_identical(
+    new_tibble(list(1), names = "x", nrow = 1),
+    new_tibble(list(x = 1), nrow = 1)
+  )
+})
+
 test_that("new_tibble checks", {
   scoped_lifecycle_errors()