Merge pull request #332 from tidyverse/f-new-tibble-responsibilities

- Cleanly define responsibilities of `new_tibble()` (#332).

R/as_tibble.R

@@ -69,41 +69,40 @@ as_tibble.tbl_df <- function(x, ..., validate = FALSE, rownames = NULL) {
 #' @export
 #' @rdname as_tibble
 as_tibble.data.frame <- function(x, validate = TRUE, ..., rownames = NA) {
-  result <- list_to_tibble(x, validate, raw_rownames(x))
+  old_rownames <- raw_rownames(x)
+  result <- list_to_tibble(x, validate)
   if (is.null(rownames)) {
-    remove_rownames(result)
+    result
   } else if (is.na(rownames)) {
+    attr(result, "row.names") <- old_rownames
     result
   } else {
-    rownames_to_column(result, var = rownames)
+    add_column(result, !! rownames := old_rownames, .before = 1L)
   }
 }
 
 #' @export
 #' @rdname as_tibble
 as_tibble.list <- function(x, validate = TRUE, ...) {
   if (length(x) == 0) {
-    list_to_tibble(repair_names(list()), validate = FALSE, .set_row_names(0L))
+    list_to_tibble(repair_names(list()), validate = FALSE)
   } else {
     list_to_tibble(x, validate)
   }
 }
 
-list_to_tibble <- function(x, validate, rownames = NULL) {
+list_to_tibble <- function(x, validate) {
   # this is to avoid any method dispatch that may happen when processing x
   x <- unclass(x)
 
   if (validate) {
     x <- check_tibble(x)
+  } else if (has_null_names(x)) {
+    x <- set_names(x, rep_along(x, ""))
   }
   x <- recycle_columns(x)
 
-  if (is.null(rownames)) {
-    rownames <- .set_row_names(NROW(x[[1L]]))
-  }
-
-  attr(x, "row.names") <- rownames
-  set_tibble_class(x)
+  new_tibble(x)
 }
 
 #' @export

R/new.R

@@ -1,14 +1,59 @@
 #' Constructor
 #'
 #' Creates a subclass of a tibble.
+#' This function is mostly useful for package authors that implement subclasses
+#' of a tibble, like \pkg{sf} or \pkg{tibbletime}.
 #'
 #' @param x A tibble-like object
 #' @param ... Passed on to [structure()]
+#' @param nrow The number of rows, guessed from the data by default
 #' @param subclass Subclasses to assign to the new object, default: none
 #' @export
-new_tibble <- function(x, ..., subclass = NULL) {
+#' @examples
+#' new_tibble(list(a = 1:3, b = 4:6))
+#'
+#' # One particular situation where the nrow argument is essential:
+#' new_tibble(list(), nrow = 150, subclass = "my_tibble")
+#'
+#' # It's safest to always pass it along:
+#' new_tibble(list(a = 1:3, b = 4:6), nrow = 3)
+#'
+#' \dontrun{
+#' # All columns must be the same length:
+#' new_tibble(list(a = 1:3, b = 4.6))
+#'
+#' # The length must be consistent with the nrow argument if available:
+#' new_tibble(list(a = 1:3, b = 4:6), nrow = 2)
+#' }
+new_tibble <- function(x, ..., nrow = NULL, subclass = NULL) {
+  #' @details
+  #' `x` must be a named (or empty) list, but the names are not currently
+  #' checked for correctness.
+  stopifnot(is.list(x))
+  if (length(x) == 0) names(x) <- character()
+  stopifnot(has_nonnull_names(x))
+
+  #' @details
+  #' The `...` argument allows adding more attributes to the subclass.
   x <- update_tibble_attrs(x, ...)
-  x <- set_tibble_class(x, subclass = subclass)
+
+  #' @details
+  #' The `row.names` attribute will be computed from the `nrow` argument,
+  #' overriding any existing attribute of this name in `x` or in the `...`
+  #' arguments.
+  #' If `nrow` is `NULL`, the number of rows will be guessed from the data.
+  if (is.null(nrow)) nrow <- guess_nrow(x)
+  attr(x, "row.names") <- .set_row_names(nrow)
+  #' The `new_tibble()` constructor makes sure that the `row.names` attribute
+  #' is consistent with the data before returning.
+  validate_nrow(x)
+
+  #' @details
+  #' The `class` attribute of the returned object always consists of
+  #' `c("tbl_df", "tbl", "data.frame")`. If the `subclass` argument is set,
+  #' it will be prepended to that list of classes.
+  class(x) <- c(subclass, "tbl_df", "tbl", "data.frame")
+
   x
 }
 
@@ -32,7 +77,23 @@ update_tibble_attrs <- function(x, ...) {
   x
 }
 
-set_tibble_class <- function(x, subclass = NULL) {
-  class(x) <- c(subclass, "tbl_df", "tbl", "data.frame")
-  x
+guess_nrow <- function(x) {
+  if (!is.null(.row_names_info(x, 0L))) .row_names_info(x, 2L)
+  else if (length(x) == 0) 0L
+  else NROW(x[[1L]])
+}
+
+validate_nrow <- function(x) {
+  # Validate column lengths, don't recycle
+  lengths <- map_int(x, NROW)
+  first <- .row_names_info(x, 2L)
+
+  bad_len <- lengths != first
+  if (any(bad_len)) {
+    invalid_df_msg(
+      paste0("must be length ", first, ", not "), x, bad_len, lengths[bad_len]
+    )
+  }
+
+  invisible(x)
 }

R/tibble.R

@@ -118,7 +118,7 @@ recycle_columns <- function(x) {
     return(x)
   }
 
-  # Validate column lengths
+  # Validate column lengths, allow recycling
   lengths <- map_int(x, NROW)
   max <- max(c(lengths[lengths != 1L], 0L))
 

R/utils.r

@@ -1,12 +1,20 @@
 
 has_dim <- function(x) {
-  length(dim(x)) > 0L || is_named(x)
+  length(dim(x)) > 0L || has_nonnull_names(x)
 }
 
 needs_dim <- function(x) {
   length(dim(x)) > 1L
 }
 
+has_null_names <- function(x) {
+  is.null(names(x))
+}
+
+has_nonnull_names <- function(x) {
+  !has_null_names(x)
+}
+
 set_class <- `class<-`
 
 is_1d <- function(x) {

tests/testthat/test-data-frame.R

@@ -228,6 +228,14 @@ test_that("as_tibble() can validate (#278)", {
 })
 
 
+test_that("as_tibble() adds empty names if not validating", {
+  invalid_df <- as_tibble(list(3, 4, 5), validate = FALSE)
+  expect_equal(length(invalid_df), 3)
+  expect_equal(nrow(invalid_df), 1)
+  expect_equal(names(invalid_df), rep("", 3))
+})
+
+
 test_that("as_tibble() can convert row names", {
   df <- data.frame(a = 1:3, b = 2:4, row.names = letters[5:7])
   expect_identical(

tests/testthat/test-tbl-df.R

@@ -300,9 +300,9 @@ test_that("is_tibble", {
 
 test_that("new_tibble", {
   tbl <- new_tibble(
-    data.frame(a = 1),
-    attr1 = "val1",
-    attr2 = "val2",
+    data.frame(a = 1:3),
+    attr1 = "value1",
+    attr2 = 2,
     subclass = "nt"
   )
 
@@ -311,11 +311,25 @@ test_that("new_tibble", {
   expect_equal(
     unclass(tbl),
     structure(
-      list(a = 1),
+      list(a = 1:3),
+      attr1 = "value1",
+      attr2 = 2,
       .Names = "a",
-      row.names = c(NA, -1L),
-      attr1 = "val1",
-      attr2 = "val2"
+      row.names = .set_row_names(3L)
     )
   )
 })
+
+test_that("new_tibble checks", {
+  expect_identical(new_tibble(list()), tibble())
+  expect_identical(new_tibble(list(a = 1:3, b = 4:6)), tibble(a = 1:3, b = 4:6))
+  expect_error(new_tibble(list(1)), "names", fixed = TRUE)
+  expect_error(new_tibble(list(a = 1, b = 2:3)), "length", fixed = TRUE)
+  expect_error(
+    new_tibble(
+      structure(list(a = 1, b = 2), row.names = .set_row_names(2))
+    ),
+    "length",
+    fixed = TRUE
+  )
+})