Allow table1 objects in new_tab_list()

DESCRIPTION

@@ -13,12 +13,13 @@ RoxygenNote: 7.3.2
 Imports: 
     knitr,
     vctrs
-Suggests: 
+Suggests:
     dplyr,
     glue,
     pander,
     rmarkdown,
     spelling,
+    table1,
     testthat (>= 3.0.0),
     tibble,
     tidyr

R/objects.R

@@ -19,10 +19,11 @@ new_tab_list <- function(x) {
   if (!inherits(x, "list")) {
     stop("`x` must be a list")
   }
-  x_null <- vapply(X = x, FUN = is.null, FUN.VALUE = TRUE)
-  x_df <- vapply(X = x, FUN = inherits, "data.frame", FUN.VALUE = TRUE)
-  if (!all(x_null | x_df)) {
-    stop("The contents of 'x' must be NULL or a 'data.frame'-like object")
+  x_null   <- vapply(X = x, FUN = is.null,  FUN.VALUE = TRUE)
+  x_df     <- vapply(X = x, FUN = inherits, "data.frame", FUN.VALUE = TRUE)
+  x_table1 <- vapply(X = x, FUN = inherits, "table1",     FUN.VALUE = TRUE)
+  if (!all(x_null | x_df | x_table1)) {
+    stop("The contents of 'x' must be NULL, a 'data.frame'-like object, or a 'table1' object")
   }
   vctrs::new_vctr(x, class = "tab_list")
 }

tests/testthat/test-objects.R

@@ -15,10 +15,24 @@ test_that("new_tab_list", {
   )
   expect_error(
     new_tab_list(list("A")),
-    regexp = "The contents of 'x' must be NULL or a 'data.frame'-like object"
+    regexp = "The contents of 'x' must be NULL, a 'data.frame'-like object, or a 'table1' object"
   )
 })
 
+test_that("new_tab_list accepts table1 objects", {
+  skip_if_not_installed("table1")
+  d  <- data.frame(x = c(1, 2, 3), g = c("a", "a", "b"))
+  t1 <- table1::table1(~ x | g, data = d)
+  expect_s3_class(t1, "table1")
+
+  new_tl <- new_tab_list(list(t1))
+  expect_s3_class(new_tl, "tab_list")
+
+  new_tt <- new_tab_tibble(tibble::tibble(table = list(t1), caption = "Test table1"))
+  expect_s3_class(new_tt, "tab_tibble")
+  expect_s3_class(new_tt$table, "tab_list")
+})
+
 test_that("vctrs methods", {
   d_tab_prep <- tidyr::nest(mtcars, table = !"cyl")
   d_tab_prep <- dplyr::mutate(d_tab_prep, caption = glue::glue("Cars with {cyl} cylinders"))