From ea1b2684af736ff9961feff554f1439678fcfe41 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Kirill=20M=C3=BCller?= Date: Tue, 20 Jul 2021 10:01:09 +0200 Subject: [PATCH 1/4] Draft: as_tibble_row() for arbitrary vectors, doesn't unwrap lists yet --- R/as_tibble.R | 23 +++++++++---------- man/as_tibble.Rd | 4 +--- tests/testthat/_snaps/msg.md | 6 ++--- tests/testthat/test-as_tibble.R | 39 ++++++++++++++++++++++++++------- tests/testthat/test-msg.R | 2 +- 5 files changed, 48 insertions(+), 26 deletions(-) diff --git a/R/as_tibble.R b/R/as_tibble.R index 98d52613c..2119a5e77 100644 --- a/R/as_tibble.R +++ b/R/as_tibble.R @@ -270,9 +270,7 @@ as_tibble.default <- function(x, ...) { #' @description #' `as_tibble_row()` converts a vector to a tibble with one row. -#' The input must be a bare vector, e.g. vectors of dates are not -#' supported yet. -#' If the input is a list, all elements must have length one. +#' If the input is a list, all elements must have size one. #' #' @rdname as_tibble #' @export @@ -284,15 +282,18 @@ as_tibble.default <- function(x, ...) { as_tibble_row <- function(x, .name_repair = c("check_unique", "unique", "universal", "minimal")) { - if (!is_bare_vector(x)) { - # FIXME: Remove entry from help once fixed (#797) - cnd_signal(error_as_tibble_row_bare(x)) + if (!vec_is(x)) { + cnd_signal(error_as_tibble_row_vector(x)) } - x <- set_repaired_names(x, repair_hint = TRUE, .name_repair) + names <- vec_names2(x, repair = .name_repair) + x <- vec_set_names(x, NULL) + slices <- lapply(seq_len(vec_size(x)), vec_slice, x = x) + names(slices) <- names + + check_all_lengths_one(slices) - check_all_lengths_one(x) - new_tibble(as.list(x), nrow = 1) + new_tibble(slices, nrow = 1) } check_all_lengths_one <- function(x) { @@ -346,9 +347,9 @@ error_column_scalar_type <- function(names, positions, classes) { ) } -error_as_tibble_row_bare <- function(x) { +error_as_tibble_row_vector <- function(x) { tibble_error(paste0( - "`x` must be a bare vector in `as_tibble_row()`, not ", class(x)[[1]], "." + "`x` must be a vector in `as_tibble_row()`, not ", class(x)[[1]], "." )) } diff --git a/man/as_tibble.Rd b/man/as_tibble.Rd index 5caad9d4f..66a363eeb 100644 --- a/man/as_tibble.Rd +++ b/man/as_tibble.Rd @@ -111,9 +111,7 @@ that implements tibble's treatment of \link{rownames}. } \code{as_tibble_row()} converts a vector to a tibble with one row. -The input must be a bare vector, e.g. vectors of dates are not -supported yet. -If the input is a list, all elements must have length one. +If the input is a list, all elements must have size one. \code{as_tibble_col()} converts a vector to a tibble with one column. } diff --git a/tests/testthat/_snaps/msg.md b/tests/testthat/_snaps/msg.md index 703bed590..dee121ef3 100644 --- a/tests/testthat/_snaps/msg.md +++ b/tests/testthat/_snaps/msg.md @@ -90,10 +90,10 @@ x Column `C` is c. x ... and 23 more problems. Code - error_as_tibble_row_bare(new_environment()) + error_as_tibble_row_vector(new_environment()) Output - - `x` must be a bare vector in `as_tibble_row()`, not environment. + + `x` must be a vector in `as_tibble_row()`, not environment. Code error_as_tibble_row_size_one(3, "foo", 7) Output diff --git a/tests/testthat/test-as_tibble.R b/tests/testthat/test-as_tibble.R index fbc6f3748..e4c165095 100644 --- a/tests/testthat/test-as_tibble.R +++ b/tests/testthat/test-as_tibble.R @@ -416,18 +416,41 @@ test_that("as_tibble_row() can convert named bare vectors to data frame", { ) }) -test_that("as_tibbe_row() fails with non-bare vectors (#739)", { +test_that("as_tibble_row() works with non-bare vectors (#797)", { expect_tibble_error( - as_tibble_row(Sys.time()), - error_as_tibble_row_bare(Sys.time()) + as_tibble_row(new_environment()), + error_as_tibble_row_vector(new_environment()) ) - expect_tibble_error( - as_tibble_row(iris), - error_as_tibble_row_bare(iris) + + time <- vec_slice(Sys.time(), 1) + expect_identical( + as_tibble_row(time, .name_repair = "unique"), + tibble(...1 = time) ) - expect_tibble_error( + expect_identical( + as_tibble_row(trees[1:3, ], .name_repair = "unique"), + tibble( + ...1 = remove_rownames(trees[1, ]), + ...2 = remove_rownames(trees[2, ]), + ...3 = remove_rownames(trees[3, ]) + ) + ) + + remove_first_dimname <- function(x) { + dn <- dimnames(x) + dn[1] <- list(NULL) + dimnames(x) <- dn + x + } + + expect_identical( as_tibble_row(Titanic), - error_as_tibble_row_bare(Titanic) + tibble( + "1st" = remove_first_dimname(Titanic[1,,,, drop = FALSE]), + "2nd" = remove_first_dimname(Titanic[2,,,, drop = FALSE]), + "3rd" = remove_first_dimname(Titanic[3,,,, drop = FALSE]), + Crew = remove_first_dimname(Titanic[4,,,, drop = FALSE]) + ) ) }) diff --git a/tests/testthat/test-msg.R b/tests/testthat/test-msg.R index bddb59800..926db50e0 100644 --- a/tests/testthat/test-msg.R +++ b/tests/testthat/test-msg.R @@ -30,7 +30,7 @@ test_that("output test", { error_column_scalar_type(letters[2:3], 3:4, c("name", "NULL")) error_column_scalar_type(c("", "", LETTERS), 1:28, c("QQ", "VV", letters)) - error_as_tibble_row_bare(new_environment()) + error_as_tibble_row_vector(new_environment()) error_as_tibble_row_size_one(3, "foo", 7) "# class-tbl_df" From 37ebd88d5bdd6193a721dd8a51ac72dc2e2c0746 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Kirill=20M=C3=BCller?= Date: Tue, 20 Jul 2021 10:16:04 +0200 Subject: [PATCH 2/4] vectbl_names2() --- R/as_tibble.R | 2 +- R/names.R | 8 ++++++++ 2 files changed, 9 insertions(+), 1 deletion(-) diff --git a/R/as_tibble.R b/R/as_tibble.R index 2119a5e77..2d03dfff4 100644 --- a/R/as_tibble.R +++ b/R/as_tibble.R @@ -286,7 +286,7 @@ as_tibble_row <- function(x, cnd_signal(error_as_tibble_row_vector(x)) } - names <- vec_names2(x, repair = .name_repair) + names <- vectbl_names2(x, .name_repair = .name_repair) x <- vec_set_names(x, NULL) slices <- lapply(seq_len(vec_size(x)), vec_slice, x = x) names(slices) <- names diff --git a/R/names.R b/R/names.R index 5eb3bf889..00482bba6 100644 --- a/R/names.R +++ b/R/names.R @@ -1,3 +1,11 @@ +vectbl_names2 <- function(x, + .name_repair = c("check_unique", "unique", "universal", "minimal"), + quiet = FALSE) { + + name <- vec_names2(x, repair = "minimal", quiet = quiet) + repaired_names(name, repair_hint = TRUE, .name_repair = .name_repair, quiet = quiet) +} + set_repaired_names <- function(x, repair_hint, .name_repair = c("check_unique", "unique", "universal", "minimal"), From 67cfe58792f5aaad994bb904b59b061f29ccc6ae Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Kirill=20M=C3=BCller?= Date: Tue, 20 Jul 2021 10:22:38 +0200 Subject: [PATCH 3/4] Special-case bare lists --- R/as_tibble.R | 11 ++++++++--- 1 file changed, 8 insertions(+), 3 deletions(-) diff --git a/R/as_tibble.R b/R/as_tibble.R index 2d03dfff4..6e0aad0ba 100644 --- a/R/as_tibble.R +++ b/R/as_tibble.R @@ -287,9 +287,14 @@ as_tibble_row <- function(x, } names <- vectbl_names2(x, .name_repair = .name_repair) - x <- vec_set_names(x, NULL) - slices <- lapply(seq_len(vec_size(x)), vec_slice, x = x) - names(slices) <- names + + if (is_bare_list(x)) { + slices <- x + } else { + x <- vec_set_names(x, NULL) + slices <- lapply(seq_len(vec_size(x)), vec_slice, x = x) + names(slices) <- names + } check_all_lengths_one(slices) From 6cc3b57487ee0e267b62e806310c5ad1e6f09896 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Kirill=20M=C3=BCller?= Date: Wed, 21 Jul 2021 05:41:54 +0200 Subject: [PATCH 4/4] FIXME --- R/as_tibble.R | 1 + 1 file changed, 1 insertion(+) diff --git a/R/as_tibble.R b/R/as_tibble.R index 6e0aad0ba..e3e95fe4a 100644 --- a/R/as_tibble.R +++ b/R/as_tibble.R @@ -288,6 +288,7 @@ as_tibble_row <- function(x, names <- vectbl_names2(x, .name_repair = .name_repair) + # FIXME: Use vec_chop2() when https://github.com/r-lib/vctrs/pull/1226 is in if (is_bare_list(x)) { slices <- x } else {