Ensuring tbl_ard_*() function can ingest ARDs from their tbl_*() …

…counterparts (#1996)

* updates

* Update DESCRIPTION

DESCRIPTION

@@ -46,14 +46,14 @@ Depends:
     R (>= 4.2)
 Imports: 
     cards (>= 0.2.2.9009),
-    cli (>= 3.6.1),
+    cli (>= 3.6.3),
     dplyr (>= 1.1.3),
     glue (>= 1.6.2),
     gt (>= 0.10.0),
     lifecycle (>= 1.0.3),
     rlang (>= 1.1.1),
     tidyr (>= 1.3.0),
-    vctrs
+    vctrs (>= 0.6.4)
 Suggests: 
     aod (>= 1.3.3),
     broom (>= 1.0.5),

R/tbl_continuous.R

@@ -223,6 +223,11 @@ tbl_continuous <- function(data,
 
 
 .add_gts_column_to_cards_continuous <- function(cards, variables, by) {
+  if ("gts_column" %in% names(cards)) {
+    cli::cli_inform("The {.val gts_column} column is alread present. Defining the column has been skipped.")
+    return(cards)
+  }
+
   # adding the name of the column the stats will populate
   if (is_empty(by)) {
     cards$gts_column <-

R/tbl_summary.R

@@ -427,6 +427,11 @@ tbl_summary <- function(data,
 }
 
 .add_gts_column_to_cards_summary <- function(cards, variables, by) {
+  if ("gts_column" %in% names(cards)) {
+    cli::cli_inform("The {.val gts_column} column is alread present. Defining the column has been skipped.")
+    return(cards)
+  }
+
   # adding the name of the column the stats will populate
   if (is_empty(by)) {
     cards$gts_column <-

tests/testthat/test-tbl_ard_continuous.R

@@ -136,3 +136,25 @@ test_that("tbl_ard_continuous(value) messaging", {
       tbl_ard_continuous(by = "trt", variable = "age", include = "grade", value = grade ~ letters)
   )
 })
+
+test_that("tbl_ard_continuous() existing 'gts_column'", {
+  # test there is no error when passing an ARD with an existing 'gts_column'
+  tbl <-
+    tbl_continuous(
+      data = trial,
+      variable = age,
+      by = trt,
+      include = grade
+    )
+  expect_equal(
+    tbl_ard_continuous(
+      cards = tbl$cards[[1]],
+      variable = age,
+      by = trt,
+      include = grade
+    ) |>
+      modify_header(all_stat_cols() ~ "**{level}**  \nN = {n}") |>
+      as.data.frame(),
+    as.data.frame(tbl)
+  )
+})

tests/testthat/test-tbl_ard_summary.R

@@ -106,7 +106,7 @@ test_that("tbl_ard_summary(by) messaging", {
       tbl_ard_summary(by = trt)
   )
 
-    # when ARD is stratified, but `by` arg not specified
+  # when ARD is stratified, but `by` arg not specified
   expect_snapshot(
     error = TRUE,
     cards::ard_stack(
@@ -281,3 +281,19 @@ test_that("tbl_ard_summary(overall)", {
   )
 })
 
+test_that("tbl_ard_summary() existing 'gts_column'", {
+  # test there is no error when passing an ARD with an existing 'gts_column'
+  tbl <- tbl_summary(trial, by = trt, include = c(age, grade, response))
+  expect_equal(
+    tbl_ard_summary(
+      cards = tbl$cards[[1]],
+      include = c(age, grade, response),
+      by = trt,
+      missing = "ifany"
+    ) |>
+      modify_header(all_stat_cols() ~ "**{level}**  \nN = {n}") |>
+      as.data.frame(),
+    as.data.frame(tbl)
+  )
+})
+

tests/testthat/test-tbl_ard_wide_summary.R

@@ -91,3 +91,19 @@ test_that("tbl_ard_summary(label) argument works", {
     "Updated AGE!"
   )
 })
+
+test_that("tbl_ard_wide_summary() existing 'gts_column'", {
+  # test there is no error when passing an ARD with an existing 'gts_column'
+  tbl <-
+    trial |>
+    tbl_wide_summary(include = c(response, grade))
+  expect_equal(
+    tbl_ard_wide_summary(
+      cards = tbl$cards[[1]],
+      include = c(response, grade)
+    ) |>
+      as.data.frame(),
+    as.data.frame(tbl)
+  )
+})
+