Updating deprecation message for modify_*() functions (#1802)

* progress * updates * Update test-modify_header.R
ddsjoberg · Jul 6, 2024 · 990a396 · 990a396
1 parent e9af78a
commit 990a396
Show file tree

Hide file tree

Showing 7 changed files with 45 additions and 6 deletions.
diff --git a/R/add_difference.R b/R/add_difference.R
@@ -37,7 +37,7 @@ add_difference <- function(x, ...) {
 #'   Default is
 #'   `list(c(all_continuous(), all_categorical(FALSE)) ~ label_style_sigfig(), all_categorical() ~ \(x) paste0(style_sigfig(x, scale = 100), "%"))`
 #' @param conf.level (`numeric`)\cr
-#'  a scalar in `⁠(0, 1`)⁠ indicating the confidence level. Default is 0.95
+#'   a scalar in the interval `(0, 1)` indicating the confidence level. Default is 0.95
 #' @inheritParams  add_p.tbl_summary
 #'
 #' @export

diff --git a/R/add_difference.tbl_svysummary.R b/R/add_difference.tbl_svysummary.R
@@ -18,7 +18,7 @@
 #'   Default is
 #'   `list(c(all_continuous(), all_categorical(FALSE)) ~ label_style_sigfig(), all_categorical() ~ \(x) paste0(style_sigfig(x, scale = 100), "%"))`
 #' @param conf.level (`numeric`)\cr
-#'  a scalar in `⁠(0, 1`)⁠ indicating the confidence level. Default is 0.95
+#'   a scalar in the interval `(0, 1)` indicating the confidence level. Default is 0.95
 #' @inheritParams  add_p.tbl_summary
 #'
 #' @export

diff --git a/R/modify.R b/R/modify.R
@@ -301,15 +301,19 @@ show_header_names <- function(x = NULL, include_example = TRUE, quiet = NULL) {
 
 .deprecate_modify_update_and_quiet_args <- function(dots, update, quiet, calling_fun) {
   # deprecated arguments
-  if (!missing(update)) {
+  if (!missing(update) || (!is_empty(dots) && is.list(dots[[1]]))) {
     lifecycle::deprecate_warn(
       "2.0.0", glue("gtsummary::{calling_fun}(update=)"),
       details =
         glue("Use `{calling_fun}(...)` input instead.
             Dynamic dots allow for syntax like `{calling_fun}(!!!list(...))`."),
       env = get_cli_abort_call()
     )
-    dots <- c(dots, update)
+
+    if (!is_empty(dots) && is.list(dots[[1]])) dots <- c(dots[-1], dots[[1]]) # styler: off
+    if (!missing(update)) dots <- c(dots, update) # styler: off
+
+    dots
   }
   if (!missing(quiet)) {
     lifecycle::deprecate_warn(

diff --git a/man/add_difference.tbl_summary.Rd b/man/add_difference.tbl_summary.Rd
diff --git a/man/add_difference.tbl_svysummary.Rd b/man/add_difference.tbl_svysummary.Rd
diff --git a/tests/testthat/test-modify_header.R b/tests/testthat/test-modify_header.R
@@ -1,16 +1,49 @@
 
 # first, testing deprecation
 test_that("modify_header(update,quiet) are deprecated", {
+  lifecycle::expect_deprecated(
+    tbl_summary(trial, include = marker) |>
+      modify_header(list(label = "Variable"))
+  )
+
+  # THIS ONE FAILS LOCALLY UNLESS I RUN ALL THE TESTS WITH THE 'Test' BUTTON
   lifecycle::expect_deprecated(
     tbl_summary(trial, include = marker) |>
       modify_header(update = list(label = "Variable"))
   )
+
   lifecycle::expect_deprecated(
     tbl_summary(trial, include = marker) |>
       modify_header(quiet = FALSE)
   )
 })
 
+
+test_that("modify_header(update) are deprecated and still work", {
+  withr::local_options(lifecycle_verbosity = "quiet")
+  expect_equal(
+    tbl_summary(trial, include = marker) |>
+      modify_header(list(label = "Variable")) |>
+      getElement("table_styling") |>
+      getElement("header"),
+    tbl_summary(trial, include = marker) |>
+      modify_header(label = "Variable") |>
+      getElement("table_styling") |>
+      getElement("header")
+  )
+
+  expect_equal(
+    tbl_summary(trial, include = marker) |>
+      modify_header(update = list(label = "Variable")) |>
+      getElement("table_styling") |>
+      getElement("header"),
+    tbl_summary(trial, include = marker) |>
+      modify_header(label = "Variable") |>
+      getElement("table_styling") |>
+      getElement("header")
+  )
+})
+
 test_that("modify_header(update) deprecated argument still works", {
   withr::local_options(lifecycle_verbosity = "quiet")
   expect_equal(

diff --git a/tests/testthat/test-show_header_names.R b/tests/testthat/test-show_header_names.R
@@ -1,3 +1,5 @@
+skip_on_os("windows")
+
 test_that("show_header_names() works", {
   expect_snapshot(
     tbl_summary(trial, include = age, by = trt, missing = "no") |>