test_that("base coercions are symmetric and unchanging", { types <- list( logical(), integer(), double(), character(), raw(), list() ) mat <- maxtype_mat(types) expect_true(isSymmetric(mat)) expect_snapshot(mat) }) test_that("new classes are uncoercible by default", { x <- structure(1:10, class = "vctrs_nonexistant") expect_error(vec_ptype2(1, x), class = "vctrs_error_incompatible_type") expect_error(vec_ptype2(x, 1), class = "vctrs_error_incompatible_type") }) test_that("vec_typeof2() returns common type", { nms <- names(base_empty_types) for (i in seq_along(base_empty_types)) { this <- nms[[i]] for (j in seq_along(base_empty_types)) { that <- nms[[j]] if (i <= j) { exp <- paste0("VCTRS_TYPE2_", this, "_", that) } else { exp <- paste0("VCTRS_TYPE2_", that, "_", this) } out <- vec_typeof2(base_empty_types[[this]], base_empty_types[[that]]) expect_identical(out, exp) } } }) test_that("vec_typeof2_s3() returns common type", { all_base_empty_types <- c(base_empty_types, base_s3_empty_types) nms_s3 <- names(base_s3_empty_types) nms <- names(all_base_empty_types) for (i in seq_along(all_base_empty_types)) { this <- nms[[i]] for (j in seq_along(all_base_empty_types)) { that <- nms[[j]] # Skip when we have two non s3 objects if (!(this %in% nms_s3) & !(that %in% nms_s3)) { next } if (i <= j) { exp <- paste0("VCTRS_TYPE2_S3_", this, "_", that) } else { exp <- paste0("VCTRS_TYPE2_S3_", that, "_", this) } out <- vec_typeof2_s3(all_base_empty_types[[this]], all_base_empty_types[[that]]) expect_identical(out, exp) } } }) test_that("vec_ptype2() dispatches when inputs have shape", { expect_identical(dim(vec_ptype2(int(), matrix(nrow = 3, ncol = 4))), c(0L, 4L)) expect_identical(dim(vec_ptype2(matrix("", nrow = 3), c("", "", ""))), c(0L, 1L)) }) test_that("vec_ptype2() requires vectors", { expect_error(vec_ptype2(NULL, quote(name)), class = "vctrs_error_scalar_type") expect_error(vec_ptype2(NA, quote(name)), class = "vctrs_error_scalar_type") expect_error(vec_ptype2(list(), quote(name)), class = "vctrs_error_scalar_type") expect_error(vec_ptype2(quote(name), NULL), class = "vctrs_error_scalar_type") expect_error(vec_ptype2(quote(name), NA), class = "vctrs_error_scalar_type") expect_error(vec_ptype2(quote(name), list()), class = "vctrs_error_scalar_type") expect_error(vec_ptype2(quote(name), quote(name)), class = "vctrs_error_scalar_type") }) test_that("vec_ptype2() with unspecified requires vectors", { expect_error(vec_ptype2(unspecified(), quote(name)), class = "vctrs_error_scalar_type") expect_error(vec_ptype2(quote(name), unspecified()), class = "vctrs_error_scalar_type") }) test_that("vec_ptype2() forwards argument tag", { expect_error(vec_ptype2(quote(name), list(), x_arg = "foo"), "`foo`", class = "vctrs_error_scalar_type") expect_error(vec_ptype2(list(), quote(name), y_arg = "foo"), "`foo`", class = "vctrs_error_scalar_type") }) test_that("stop_incompatible_type() checks for scalars", { expect_error(stop_incompatible_type(NA, foobar(), x_arg = "x", y_arg = "y"), class = "vctrs_error_scalar_type") expect_error(vec_ptype_common(NA, foobar()), class = "vctrs_error_scalar_type") expect_error(vec_ptype_common(foobar(), list()), class = "vctrs_error_scalar_type") }) test_that("vec_ptype2() methods forward args to stop_incompatible_type()", { expect_args(new_hidden(), lgl(), x_arg = "foo", y_arg = "bar") expect_args(lgl(), new_hidden(), x_arg = "foo", y_arg = "bar") expect_args(int(), new_hidden(), x_arg = "foo", y_arg = "bar") expect_args(dbl(), new_hidden(), x_arg = "foo", y_arg = "bar") expect_args(chr(), new_hidden(), x_arg = "foo", y_arg = "bar") expect_args(list(), new_hidden(), x_arg = "foo", y_arg = "bar") expect_args(new_rcrd(list(x = NA)), new_hidden(), x_arg = "foo", y_arg = "bar") expect_args(data.frame(), new_hidden(), x_arg = "foo", y_arg = "bar") expect_args(Sys.Date(), new_hidden(), x_arg = "foo", y_arg = "bar") expect_args(as.difftime(1, units = "hours"), new_hidden(), x_arg = "foo", y_arg = "bar") expect_args(factor(), new_hidden(), x_arg = "foo", y_arg = "bar") expect_args(ordered(""), new_hidden(), x_arg = "foo", y_arg = "bar") expect_args(ordered(""), factor(), x_arg = "foo", y_arg = "bar") expect_args(bit64::as.integer64(1), new_hidden(), x_arg = "foo", y_arg = "bar") }) test_that("vec_ptype2() data frame methods builds argument tags", { # Bare objects expect_snapshot(error = TRUE, { vec_ptype2("foo", 10) }) # Nested dataframes expect_snapshot(error = TRUE, { df1 <- tibble(x = tibble(y = tibble(z = 1))) df2 <- tibble(x = tibble(y = tibble(z = "a"))) vec_ptype2(df1, df2) }) }) test_that("stop_incompatible_type() can be called without argument tags", { expect_error(stop_incompatible_type(1, 2, x_arg = "", y_arg = ""), "<double> and <double>", class = "vctrs_error_incompatible_type") }) test_that("vec_ptype2() returns empty prototype when other input is NULL", { expect_identical(vec_ptype2(1:5, NULL), int()) expect_identical(vec_ptype2(NULL, 1:5), int()) }) test_that("Subclasses of data.frame dispatch to `vec_ptype2()` methods", { local_methods( vec_ptype2.quuxframe = function(x, y, ...) UseMethod("vec_ptype2.quuxframe"), vec_ptype2.quuxframe.data.frame = function(x, y, ...) "dispatched!", vec_ptype2.data.frame.quuxframe = function(x, y, ...) "dispatched!" ) quux <- structure(data.frame(), class = c("quuxframe", "data.frame")) expect_identical(vec_ptype2(quux, mtcars), "dispatched!") expect_identical(vec_ptype2(mtcars, quux), "dispatched!") quux <- structure(data.frame(), class = c("quuxframe", "tbl_df", "data.frame")) expect_identical(vec_ptype2(quux, mtcars), "dispatched!") expect_identical(vec_ptype2(mtcars, quux), "dispatched!") }) test_that("Subclasses of `tbl_df` have `tbl_df` common type (#481)", { quux <- foobar(tibble()) expect_identical( vec_ptype_common(quux, tibble()), tibble() ) expect_identical( vec_ptype_common(tibble(), quux), tibble() ) }) test_that("Column name encodings are handled correctly in the common type (#553)", { encs <- encodings() data <- list(chr()) df_utf8 <- tibble::as_tibble(set_names(data, encs$utf8)) df_unknown <- tibble::as_tibble(set_names(data, encs$unknown)) expect_identical(vec_ptype2(df_utf8, df_unknown), df_utf8) }) test_that("vec_is_subtype() determines subtyping relationship", { expect_true(vec_is_subtype(lgl(), int())) expect_false(vec_is_subtype(int(), lgl())) expect_false(vec_is_subtype(lgl(), chr())) expect_false(vec_is_subtype(chr(), lgl())) local_methods( vec_ptype2.vctrs_foobar = function(x, y, ...) UseMethod("vec_ptype2.vctrs_foobar"), vec_ptype2.vctrs_foobar.logical = function(x, y, ...) logical(), vec_ptype2.logical.vctrs_foobar = function(x, y, ...) logical() ) expect_true(vec_is_subtype(foobar(TRUE), lgl())) expect_false(vec_is_subtype(lgl(), foobar(TRUE))) }) test_that("can override scalar vector error message for base scalar types", { expect_snapshot({ (expect_error(vec_ptype2(NULL, quote(x), y_arg = "foo"), class = "vctrs_error_scalar_type")) (expect_error(vec_ptype2(quote(x), NULL, x_arg = "foo"), class = "vctrs_error_scalar_type")) }) }) test_that("can override scalar vector error message for S3 types", { expect_snapshot({ (expect_error(vec_ptype2(NULL, foobar(), y_arg = "foo"), class = "vctrs_error_scalar_type")) (expect_error(vec_ptype2(foobar(), NULL, x_arg = "foo"), class = "vctrs_error_scalar_type")) }) }) test_that("ptype2 and cast errors when same class fallback is impossible are informative", { expect_snapshot({ (expect_error( vec_cast(foobar(1, bar = TRUE), foobar(2, baz = TRUE)), class = "vctrs_error_incompatible_type" )) (expect_error( vec_ptype2(foobar(1, bar = TRUE), foobar(2, baz = TRUE)), class = "vctrs_error_incompatible_type" )) }) }) test_that("Incompatible attributes bullets are not show when methods are implemented", { expect_snapshot({ with_foobar_cast <- function(expr ) { with_methods( vec_cast.vctrs_foobar = function(...) NULL, vec_cast.vctrs_foobar.vctrs_foobar = function(x, to, ...) vec_default_cast(x, to, ...), expr ) } with_foobar_ptype2 <- function(expr ) { with_methods( vec_ptype2.vctrs_foobar = function(...) NULL, vec_ptype2.vctrs_foobar.vctrs_foobar = function(x, y, ...) vec_default_ptype2(x, y, ...), expr ) } (expect_error( with_foobar_cast(vec_cast(foobar(1, bar = TRUE), foobar(2, baz = TRUE))), class = "vctrs_error_incompatible_type" )) (expect_error( with_foobar_ptype2(vec_ptype2(foobar(1, bar = TRUE), foobar(2, baz = TRUE))), class = "vctrs_error_incompatible_type" )) }) }) test_that("attributes no longer play a role in bare data frame fallback", { foobar_bud <- foobar(mtcars, bud = TRUE) foobar_boo <- foobar(mtcars, boo = TRUE) expect_equal( vec_ptype2(foobar_bud, foobar_boo), vec_slice(unrownames(mtcars), 0) ) expect_equal( vec_ptype2(foobar(mtcars), foobaz(mtcars)), vec_slice(unrownames(mtcars), 0) ) }) test_that("vec_ptype2() methods get prototypes", { x <- NULL y <- NULL local_methods(vec_ptype2.vctrs_foobar.vctrs_foobar = function(x, y, ...) { x <<- x y <<- y NULL }) vec_ptype2(foobar(1:3), foobar(letters)) expect_identical(x, foobar(int())) expect_identical(y, foobar(chr())) vec_ptype2(foobar(mtcars), foobar(iris)) expect_identical(x, foobar(mtcars[0, , drop = FALSE])) expect_identical(y, foobar(iris[0, , drop = FALSE])) }) test_that("vec_ptype2() allows vec_ptype() to return another type", { out <- with_methods( vec_restore.vctrs_foobar = function(x, to, ...) unstructure(x), vec_ptype2(foobar(1), foobar(2)) ) expect_identical(out, dbl()) }) test_that("vec_ptype2() evaluates x_arg and y_arg lazily", { expect_silent(vec_ptype2(1L, 1L, x_arg = print("oof"))) expect_silent(vec_ptype2(1L, 1L, y_arg = print("oof"))) }) test_that("can restart ptype2 errors", { x <- data_frame(x = ordered(c("a", "b", "c"))) y <- data_frame(x = ordered(c("A", "B", "C"))) exp <- c("a", "b", "c", "A", "B", "C") exp <- factor(exp, exp) expect_error(vec_rbind(x, y), class = "vctrs_error_incompatible_type") expect_equal( with_ordered_restart(vec_rbind(x, y)), data_frame(x = exp) ) z <- data_frame(x = chr()) expect_equal( with_ordered_restart(vec_ptype_common(x, y)), data_frame(x = exp[0]) ) expect_equal( with_ordered_restart(vec_ptype_common(x, y, z)), data_frame(x = chr()) ) expect_equal( with_ordered_restart(vec_cast_common(x, y)), list( data_frame(x = factor(c("a", "b", "c"), levels(exp))), data_frame(x = factor(c("A", "B", "C"), levels(exp))) ) ) expect_equal( with_ordered_restart(vec_cast_common(x, y, z)), list( data_frame(x = c("a", "b", "c")), data_frame(x = c("A", "B", "C")), data_frame(x = chr()) ) ) # Factor case y <- data_frame(x = factor(c("A", "B", "C"))) expect_equal( with_ordered_restart(vec_rbind(x, y)), data_frame(x = exp) ) }) test_that("subclasses of tibble are compatible", { tib <- foobar(tibble(x = 1)) ptype <- foobar(tibble(x = dbl())) expect_equal(vec_ptype_common(tib), ptype) expect_equal(vec_ptype_common(tib, tib), ptype) })
Generated by dwww version 1.15 on Fri Jun 21 07:55:18 CEST 2024.