# printing ---------------------------------------------------------------- test_that("data frames print nicely", { expect_equal(vec_ptype_abbr(mtcars), "df[,11]") expect_snapshot(vec_ptype_show(mtcars)) expect_snapshot(vec_ptype_show(iris)) }) test_that("embedded data frames print nicely", { df <- data.frame(x = 1:3) df$a <- data.frame(a = 1:3, b = letters[1:3]) df$b <- list_of(1, 2, 3) df$c <- as_list_of(split(data.frame(x = 1:3, y = letters[1:3]), 1:3)) expect_snapshot(vec_ptype_show(df)) }) # coercing ---------------------------------------------------------------- test_that("data frame only combines with other data frames or NULL", { dt <- data.frame(x = 1) expect_equal(vec_ptype_common(dt, NULL), vec_ptype(dt)) expect_error(vec_ptype_common(dt, 1:10), class = "vctrs_error_incompatible_type") }) test_that("data frame takes max of individual variables", { dt1 <- data.frame(x = FALSE, y = 1L) dt2 <- data.frame(x = 1.5, y = 1.5) expect_equal(vec_ptype_common(dt1, dt2), vec_ptype_common(dt2)) }) test_that("data frame combines variables", { dt1 <- data.frame(x = 1) dt2 <- data.frame(y = 1) dt3 <- max(dt1, dt2) expect_equal( vec_ptype_common(dt1, dt2), vec_ptype_common(data.frame(x = double(), y = double())) ) }) test_that("empty data frame still has names", { df <- data.frame() out <- vec_ptype_common(df, df) expect_equal(names(out), character()) }) test_that("combining data frames with foreign classes uses fallback", { foo <- foobar(data.frame()) df <- data.frame() expect_identical(vec_ptype_common(foo, foo, foo), foo) expect_identical(vec_ptype_common(foo, foo, df, foo), df) expect_identical(vec_ptype2(foo, df), data.frame()) expect_identical(vec_ptype2(df, foo), data.frame()) expect_identical(vec_ptype_common(foo, df), df) expect_identical(vec_ptype_common(df, foo), df) cnds <- list() withCallingHandlers( warning = function(cnd) { cnds <<- append(cnds, list(cnd)) invokeRestart("muffleWarning") }, expect_identical( vec_ptype_common(foo, df, foo, foo), df ) ) # There are no longer any warnings expect_length(cnds, 0) expect_equal( vec_cbind(foobar(data.frame(x = 1)), data.frame(y = 2)), data.frame(x = 1, y = 2) ) expect_equal( vec_rbind(foo, data.frame(), foo), df ) }) # casting ----------------------------------------------------------------- test_that("safe casts work as expected", { df <- data.frame(x = 1, y = 0) expect_equal(vec_cast(NULL, df), NULL) expect_equal(vec_cast(df, df), df) expect_equal(vec_cast(data.frame(x = TRUE, y = FALSE), df), df) }) test_that("warn about lossy coercions", { df1 <- data.frame(x = factor("foo"), y = 1) df2 <- data.frame(x = factor("bar")) expect_lossy(vec_cast(df1, df1[1]), df1[1], x = df1, to = df1[1]) expect_lossy( vec_cast(df1[1], df2), data.frame(x = factor(NA, levels = "bar")), x = factor("foo"), to = factor("bar") ) out <- allow_lossy_cast( allow_lossy_cast( vec_cast(df1, df2), factor("foo"), factor("bar") ), df1, df2 ) expect_identical(out, data.frame(x = factor(NA, levels = "bar"))) }) test_that("invalid cast generates error", { expect_error(vec_cast(1L, data.frame()), class = "vctrs_error_incompatible_type") }) test_that("column order matches type", { df1 <- data.frame(x = 1, y = "a") df2 <- data.frame(x = TRUE, z = 3) df3 <- vec_cast(df2, vec_ptype_common(df1, df2)) expect_named(df3, c("x", "y", "z")) }) test_that("restore generates correct row/col names", { df1 <- data.frame(x = NA, y = 1:4, z = 1:4) df1$x <- data.frame(a = 1:4, b = 1:4) df2 <- vec_restore(lapply(df1[1:3], vec_slice, 1:2), df1) expect_named(df2, c("x", "y", "z")) expect_equal(.row_names_info(df2), -2) }) test_that("restore keeps automatic row/col names", { df1 <- data.frame(x = NA, y = 1:4, z = 1:4) df1$x <- data.frame(a = 1:4, b = 1:4) df2 <- vec_restore(df1, df1) expect_named(df2, c("x", "y", "z")) expect_equal(.row_names_info(df2), -4) }) test_that("cast to empty data frame preserves number of rows", { out <- vec_cast(new_data_frame(n = 10L), new_data_frame()) expect_equal(nrow(out), 10L) }) test_that("can cast unspecified to data frame", { df <- data.frame(x = 1, y = 2L) expect_identical(vec_cast(unspecified(3), df), vec_init(df, 3)) }) test_that("cannot cast list to data frame", { df <- data.frame(x = 1, y = 2L) expect_error(vec_cast(list(df, df), df), class = "vctrs_error_incompatible_type") }) test_that("can restore lists with empty names", { expect_identical(vec_restore(list(), data.frame()), data.frame()) }) test_that("can restore subclasses of data frames", { expect_identical(vec_restore(list(), subclass(data.frame())), subclass(data.frame())) local_methods( vec_restore.vctrs_foobar = function(x, to, ..., i) "dispatched" ) expect_identical(vec_restore(list(), subclass(data.frame())), "dispatched") }) test_that("df_cast() checks for names", { x <- new_data_frame(list(1)) y <- new_data_frame(list(2)) expect_error(vec_cast_common(x, y), "must have names") }) test_that("casting to and from data frame preserves row names", { out <- vec_cast(mtcars, unrownames(mtcars)) expect_identical(row.names(out), row.names(mtcars)) out <- vec_cast(out, unrownames(mtcars)) expect_identical(row.names(out), row.names(mtcars)) }) test_that("df_cast() evaluates arg lazily", { expect_silent(df_cast(data_frame(), data_frame(), x_arg = print("oof"))) expect_silent(df_cast(data_frame(), data_frame(), to_arg = print("oof"))) }) # df_ptype2 --------------------------------------------------------------- test_that("df_ptype2() evaluates arg lazily", { expect_silent(df_ptype2(data_frame(), data_frame(), x_arg = print("oof"))) expect_silent(df_ptype2(data_frame(), data_frame(), y_arg = print("oof"))) }) # new_data_frame ---------------------------------------------------------- test_that("can construct an empty data frame", { expect_identical(new_data_frame(), data.frame()) }) test_that("can validly set the number of rows when there are no columns", { expect <- structure( list(), class = "data.frame", row.names = .set_row_names(2L), names = character() ) expect_identical(new_data_frame(n = 2L), expect) }) test_that("can add additional classes", { expect_s3_class(new_data_frame(class = "foobar"), "foobar") expect_s3_class(new_data_frame(class = c("foo", "bar")), c("foo", "bar")) }) test_that("can add additional attributes", { expect <- data.frame() attr(expect, "foo") <- "bar" attr(expect, "a") <- "b" expect_identical(new_data_frame(foo = "bar", a = "b"), expect) }) test_that("size is pulled from first column if not supplied", { x <- new_data_frame(list(x = 1:5, y = 1:6)) expect_identical(.row_names_info(x, type = 1), -5L) }) test_that("can construct a data frame without column names", { expect_named(new_data_frame(list(1, 2)), NULL) }) test_that("the names on an empty data frame are an empty character vector", { expect_identical(names(new_data_frame()), character()) }) test_that("class attribute", { expect_identical( class(new_data_frame(list(a = 1))), "data.frame" ) expect_identical( class(new_data_frame(list(a = 1), class = "tbl_df")), c("tbl_df", "data.frame") ) expect_identical( class(new_data_frame(list(a = 1), class = c("tbl_df", "tbl", "data.frame"))), c("tbl_df", "tbl", "data.frame", "data.frame") ) expect_identical( class(new_data_frame(list(a = 1), class = "foo_frame")), c("foo_frame", "data.frame") ) expect_identical( class(exec(new_data_frame, list(a = 1), !!!attributes(new_data_frame(list(), class = "tbl_df")))), c("tbl_df", "data.frame", "data.frame") ) expect_identical( class(exec(new_data_frame, list(a = 1), !!!attributes(new_data_frame(list(b = 1), class = "tbl_df")))), c("tbl_df", "data.frame", "data.frame") ) }) test_that("attributes with special names are merged", { expect_identical( names(new_data_frame(list(a = 1))), "a" ) expect_identical( names(new_data_frame(list(a = 1), names = "name")), "name" ) expect_identical( names(new_data_frame(list(1), names = "name")), "name" ) expect_identical( attr(new_data_frame(list()), "row.names"), integer() ) expect_identical( .row_names_info(new_data_frame(list(), n = 3L)), -3L ) expect_error(new_data_frame(list(), n = 1L, row.names = 1:3), ".") expect_identical( .row_names_info(new_data_frame(list(), n = 3L, row.names = 1:3)), 3L ) expect_identical( .row_names_info(new_data_frame(list(), n = 3L, row.names = c(NA, -3L))), -3L ) expect_identical( attr(new_data_frame(list(), n = 1L, row.names = "rowname"), "row.names"), "rowname" ) }) test_that("n and row.names (#894)", { # Can omit n if row.names attribute is given expect_identical( row.names(new_data_frame(list(), row.names = "rowname")), "rowname" ) expect_identical( attr(new_data_frame(list(), row.names = 2L), "row.names"), 2L ) expect_identical( row.names(new_data_frame(list(), row.names = chr())), chr() ) }) test_that("`x` must be a list", { expect_snapshot((expect_error( new_data_frame(1), "`x` must be a list" ))) }) test_that("if supplied, `n` must be an integer of size 1", { expect_snapshot({ (expect_error(new_data_frame(n = c(1L, 2L)), "must be an integer of size 1")) (expect_error(new_data_frame(n = "x"), "must be an integer of size 1")) }) }) test_that("if supplied, `n` can't be negative or missing (#1477)", { expect_snapshot({ (expect_error(new_data_frame(n = -1L))) (expect_error(new_data_frame(n = NA_integer_))) }) }) test_that("`class` must be a character vector", { expect_snapshot((expect_error( new_data_frame(class = 1), "must be NULL or a character vector" ))) }) test_that("flatten info is computed", { df_flatten_info <- function(x) { .Call(ffi_df_flatten_info, x) } expect_identical(df_flatten_info(mtcars), list(FALSE, ncol(mtcars))) df <- tibble(x = 1, y = tibble(x = 2, y = tibble(x = 3), z = 4), z = 5) expect_identical(df_flatten_info(df), list(TRUE, 5L)) }) test_that("can flatten data frames", { df_flatten <- function(x) { .Call(ffi_df_flatten, x) } expect_identical(df_flatten(mtcars), mtcars) df <- tibble(x = 1, y = tibble(x = 2, y = tibble(x = 3), z = 4), z = 5) expect_identical(df_flatten(df), new_data_frame(list(x = 1, x = 2, x = 3, z = 4, z = 5))) }) test_that("can flatten data frames with rcrd columns (#1318)", { col <- new_rcrd(list(a = 1)) df <- data_frame(col = col, y = 1) expect_identical(vec_proxy_equal(df), data_frame(col = 1, y = 1)) col <- new_rcrd(list(a = 1, b = 2)) df <- data_frame(col = col, y = 1) expect_identical(vec_proxy_equal(df), data_frame(a = 1, b = 2, y = 1)) }) test_that("new_data_frame() zaps existing attributes", { struct <- structure(list(), foo = 1) expect_identical( attributes(new_data_frame(struct)), attributes(new_data_frame(list())), ) expect_identical( attributes(new_data_frame(struct, bar = 2)), attributes(new_data_frame(list(), bar = 2)), ) }) # data_frame -------------------------------------------------------------- test_that("data_frame() and df_list() report error context", { expect_snapshot({ (expect_error(data_frame(a = 1, a = 1))) (expect_error(data_frame(a = 1, a = 1, .error_call = call("foo")))) (expect_error(data_frame(a = 1:2, b = int()))) (expect_error(data_frame(a = 1:2, b = int(), .error_call = call("foo")))) (expect_error(df_list(a = 1, a = 1))) (expect_error(df_list(a = 1, a = 1, .error_call = call("foo")))) (expect_error(df_list(a = 1:2, b = int()))) (expect_error(df_list(a = 1:2, b = int(), .error_call = call("foo")))) }) }) test_that("can construct data frames with empty input", { expect_identical(data_frame(), new_data_frame()) expect_named(data_frame(), character()) }) test_that("input is tidy recycled", { expect_identical( data_frame(x = 1, y = 1:3), data_frame(x = c(1, 1, 1), y = 1:3) ) expect_identical( data_frame(x = 1, y = integer()), data_frame(x = double(), y = integer()) ) expect_snapshot({ expect_error(data_frame(1:2, 1:3), class = "vctrs_error_incompatible_size") }) }) test_that("dots are dynamic", { list_2_data_frame <- function(x) data_frame(!!!x) expect_identical( list_2_data_frame(list(x = 1, y = 2)), data_frame(x = 1, y = 2) ) }) test_that("unnamed input is auto named with empty strings", { expect_named(data_frame(1, 2, .name_repair = "minimal"), c("", "")) }) test_that("unnamed data frames are auto unpacked", { expect_identical( data_frame(w = 1, data_frame(x = 2, y = 3), z = 4), data_frame(w = 1, x = 2, y = 3, z = 4) ) }) test_that("named data frames are not unpacked", { df_col <- data_frame(x = 2, y = 3) df <- data_frame(w = 1, col = data_frame(x = 2, y = 3), z = 4) expect_identical(df$col, df_col) }) test_that("unpacked data frames without names are caught", { df_col <- new_data_frame(list(1)) expect_error(data_frame(df_col), "corrupt data frame") }) test_that("unpacking in `df_list()` can be disabled with `.unpack = FALSE`", { out <- df_list( w = 1, data_frame(x = 2, y = 3), z = 4, .unpack = FALSE, .name_repair = "minimal" ) expect <- list( w = 1, data_frame(x = 2, y = 3), z = 4 ) expect_identical(out, expect) }) test_that("`.unpack` is validated", { expect_snapshot(error = TRUE, { df_list(.unpack = 1) }) expect_snapshot(error = TRUE, { df_list(.unpack = c(TRUE, FALSE)) }) }) test_that("`NULL` inputs are dropped", { expect_identical(data_frame(NULL, x = 1, NULL), data_frame(x = 1)) }) test_that("`NULL` inputs are dropped before name repair", { expect_identical( data_frame(x = NULL, x = 1, .name_repair = "check_unique"), data_frame(x = 1) ) }) test_that("`.size` can force a desired size", { df <- data_frame(x = 1, .size = 5) expect_identical(df$x, rep(1, 5)) expect_size(data_frame(.size = 5), 5L) }) test_that("`.name_repair` repairs names", { expect_message(res <- data_frame(x = 1, x = 1, .name_repair = "unique")) expect_named(res, c("x...1", "x...2")) }) test_that("`.name_repair` happens after auto-naming with empty strings", { expect_message(res <- data_frame(1, 2, .name_repair = "unique")) expect_named(res, c("...1", "...2")) }) test_that("`.name_repair` happens after splicing", { expect_message(res <- data_frame(x = 1, data_frame(x = 2), .name_repair = "unique")) expect_named(res, c("x...1", "x...2")) }) test_that("`.name_repair` can be quiet", { local_name_repair_verbose() expect_snapshot({ dfl_unique <- df_list(1, 2, .name_repair = "unique_quiet") dfl_universal <- df_list("if" = 1, "in" = 2, .name_repair = "universal_quiet") df_unique <- data_frame(1, 2, .name_repair = "unique_quiet") df_universal <- data_frame("if" = 1, "in" = 2, .name_repair = "universal_quiet") }) expect_named(dfl_unique, c("...1", "...2")) expect_named(dfl_universal, c(".if", ".in")) expect_named(df_unique, c("...1", "...2")) expect_named(df_universal, c(".if", ".in")) }) # fallback ---------------------------------------------------------------- test_that("data frame fallback handles column types (#999)", { df1 <- foobar(data.frame(x = 1)) df2 <- foobar(data.frame(x = 1, y = 2)) df3 <- foobar(data.frame(x = "", y = 2)) common <- foobar(data.frame(x = dbl(), y = dbl())) expect_identical(vec_ptype2(df1, df2), common) expect_identical(vec_ptype2(df2, df1), common) exp <- foobar(data_frame(x = 1, y = na_dbl)) expect_identical(vec_cast(df1, df2), exp) expect_identical(vec_cast(set_tibble(df1), set_tibble(df2)), set_tibble(exp)) expect_snapshot({ local_error_call(call("my_function")) (expect_error( vec_ptype2(df1, df3), class = "vctrs_error_incompatible_type" )) (expect_error( vec_ptype2(df3, df1), class = "vctrs_error_incompatible_type" )) (expect_error( vec_cast(df2, df1), class = "vctrs_error_incompatible_type" )) }) expect_identical( vec_rbind(df1, df2), foobar(data.frame(x = c(1, 1), y = c(NA, 2))) ) # Attributes are not restored df1_attrib <- foobar(df1, foo = "foo") df2_attrib <- foobar(df2, bar = "bar") exp <- data.frame(x = c(1, 1), y = c(NA, 2)) expect_equal( vec_rbind(df1_attrib, df2_attrib), exp ) out <- with_methods( `[.vctrs_foobar` = function(x, i, ...) { new_data_frame( NextMethod(), dispatched = TRUE, class = "vctrs_foobar" ) }, vec_rbind(df1_attrib, df2_attrib) ) expect_identical(out, exp) }) test_that("falls back to tibble for tibble subclasses (#1025)", { foo <- foobar(tibble::as_tibble(mtcars)) expect_s3_class(vec_rbind(foo, mtcars), "tbl_df") expect_s3_class(vec_rbind(foo, mtcars, mtcars), "tbl_df") expect_s3_class(vec_rbind(foo, mtcars, foobar(mtcars)), "tbl_df") }) test_that("fallback is recursive", { df <- mtcars[1:3, 1, drop = FALSE] foo <- new_data_frame(list(x = foobar(df, foo = TRUE))) bar <- new_data_frame(list(x = foobar(df, bar = TRUE))) baz <- new_data_frame(list(y = 1:3, x = foobar(df, bar = TRUE))) exp <- new_data_frame(list(x = vec_rbind(df, df))) expect_equal(vec_rbind(foo, bar), exp) exp <- new_data_frame(list(x = vec_rbind(df, df), y = c(NA, NA, NA, 1:3))) expect_equal(vec_rbind(foo, baz), exp) })
Generated by dwww version 1.15 on Thu May 23 02:12:40 CEST 2024.