Merge branch 'main' into 116-check-for-other-package-messaging

.github/PULL_REQUEST_TEMPLATE.md

@@ -13,6 +13,8 @@ Pre-review Checklist (if item does not apply, mark is as complete)
 - [ ] PR branch has pulled the most recent updates from master branch: `usethis::pr_merge_main()`
 - [ ] If a bug was fixed, a unit test was added.
 - [ ] If a new `ard_*()` function was added, it passes the ARD structural checks from `cards::check_ard_structure()`.
+- [ ] If a new `ard_*()` function was added, `set_cli_abort_call()` has been set.
+- [ ] If a new `ard_*()` function was added and it depends on another package (such as, `broom`), `is_pkg_installed("broom", reference_pkg = "cardx")` has been set in the function call and the following added to the roxygen comments: `@examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = "broom"", reference_pkg = "cardx"))`
 - [ ] Code coverage is suitable for any new functions/features (generally, 100% coverage for new code): `devtools::test_coverage()`
 
 Reviewer Checklist (if item does not apply, mark is as complete)

DESCRIPTION

@@ -1,6 +1,6 @@
 Package: cardx
 Title: Extra Analysis Results Data Utilities
-Version: 0.1.0.9017
+Version: 0.1.0.9021
 Authors@R: c(
     person("Daniel", "Sjoberg", , "[email protected]", role = c("aut", "cre")),
     person("Abinaya", "Yogasekaram", , "[email protected]", role = "aut"),
@@ -27,10 +27,11 @@ Imports:
 Suggests:
     aod (>= 1.3.3),
     broom (>= 1.0.5),
-    broom.helpers (>= 1.13.0),
+    broom.helpers (>= 1.15.0),
     car (>= 3.0-11),
     effectsize (>= 0.6.0),
     geepack (>= 1.3.2),
+    ggsurvfit (>= 1.0.0),
     lme4 (>= 1.1-31),
     parameters (>= 0.20.2),
     smd (>= 0.6.6),

NAMESPACE

@@ -34,6 +34,7 @@ export(ard_survey_svychisq)
 export(ard_survey_svycontinuous)
 export(ard_survey_svyranktest)
 export(ard_survey_svyttest)
+export(ard_survival_survdiff)
 export(ard_survival_survfit)
 export(contains)
 export(ends_with)

NEWS.md

@@ -1,4 +1,4 @@
-# cardx 0.1.0.9017
+# cardx 0.1.0.9021
 
 ### Breaking Changes
 
@@ -39,8 +39,9 @@ ard_moodtest()          -> ard_stats_mood_test()
 
 * Updated `ard_stats_t_test()` and `ard_stats_wilcox_test()` to no longer require the `by` argument, which yields central estimates with their confidence intervals. (#82)
 
-* Import cli call environment functions from `https://github.com/ddsjoberg/standalone/blob/main/R/standalone-cli_call_env.R` and implement `set_cli_abort_call` in user-facing functions. (#111, @edelarua)
+* Imported cli call environment functions from `https://github.com/ddsjoberg/standalone/blob/main/R/standalone-cli_call_env.R` and implemented `set_cli_abort_call` in user-facing functions. (#111)
 
+* Added `ard_survival_survdiff()` for creating results from `survival::survdiff()`. (#113)
 
 # cardx 0.1.0
 

R/ard_car_vif.R

@@ -73,7 +73,7 @@ ard_car_vif <- function(x, ...) {
       values_to = "stat"
     ) |>
     dplyr::mutate(
-      context = "vif",
+      context = "car_vif",
       stat_label = ifelse(
         .data$stat_name == "aGVIF",
         "Adjusted GVIF",

R/ard_effectsize_cohens_d.R

@@ -181,7 +181,7 @@ ard_effectsize_paired_cohens_d <- function(data, by, variables, id, ...) {
       fun_args_to_record = c("mu", "paired", "pooled_sd", "alternative"),
       formals = formals(asNamespace("effectsize")[["cohens_d"]]),
       passed_args = c(list(paired = paired), dots_list(...)),
-      lst_ard_columns = list(group1 = by, variable = variable, context = "cohens_d")
+      lst_ard_columns = list(group1 = by, variable = variable, context = "effectsize_cohens_d")
     )
 
   # add the stat label ---------------------------------------------------------

R/ard_effectsize_hedges_g.R

@@ -173,7 +173,7 @@ ard_effectsize_paired_hedges_g <- function(data, by, variables, id, ...) {
       fun_args_to_record = c("mu", "paired", "pooled_sd", "alternative"),
       formals = formals(asNamespace("effectsize")[["hedges_g"]]),
       passed_args = c(list(paired = paired), dots_list(...)),
-      lst_ard_columns = list(group1 = by, variable = variable, context = "hedges_g")
+      lst_ard_columns = list(group1 = by, variable = variable, context = "effectsize_hedges_g")
     )
 
   # add the stat label ---------------------------------------------------------

R/ard_smd_smd.R

@@ -81,7 +81,7 @@ ard_smd_smd <- function(data, by, variables, ...) {
       formals = formals(smd::smd)["gref"],
       # removing the `std.error` ARGUMENT (not the result)
       passed_args = dots_list(...) |> utils::modifyList(list(std.error = NULL)),
-      lst_ard_columns = list(group1 = by, variable = variable, context = "smd")
+      lst_ard_columns = list(group1 = by, variable = variable, context = "smd_smd")
     )
 
   # add the stat label ---------------------------------------------------------

R/ard_stats_aov.R

@@ -49,7 +49,7 @@ ard_stats_aov <- function(formula, data, ...) {
           .data$stat_name %in% "meansq" ~ "Mean of Sum of Squares",
           TRUE ~ .data$stat_name
         ),
-      context = "aov",
+      context = "stats_aov",
       warning = aov["warning"],
       error = aov["error"]
     ) |>

R/ard_stats_chisq_test.R

@@ -53,7 +53,7 @@ ard_stats_chisq_test <- function(data, by, variables, ...) {
           c("correct", "p", "rescale.p", "simulate.p.value", "B"),
         formals = formals(stats::chisq.test),
         passed_args = dots_list(...),
-        lst_ard_columns = list(group1 = by, variable = variable, context = "chisqtest")
+        lst_ard_columns = list(group1 = by, variable = variable, context = "stats_chisq_test")
       ) |>
         dplyr::mutate(
           .after = "stat_name",

R/ard_stats_fisher_test.R

@@ -57,7 +57,7 @@ ard_stats_fisher_test <- function(data, by, variables, ...) {
           ),
         formals = formals(stats::fisher.test),
         passed_args = dots_list(...),
-        lst_ard_columns = list(group1 = by, variable = variable, context = "fishertest")
+        lst_ard_columns = list(group1 = by, variable = variable, context = "stats_fisher_test")
       ) |>
         dplyr::mutate(
           .after = "stat_name",

R/ard_stats_kruskal_test.R

@@ -48,7 +48,7 @@ ard_stats_kruskal_test <- function(data, by, variables) {
               broom::tidy()
           ),
         tidy_result_names = c("statistic", "p.value", "parameter", "method"),
-        lst_ard_columns = list(group1 = by, variable = variable, context = "kruskaltest")
+        lst_ard_columns = list(group1 = by, variable = variable, context = "stats_kruskal_test")
       ) |>
         dplyr::mutate(
           .after = "stat_name",

R/ard_stats_mcnemar_test.R

@@ -92,7 +92,7 @@ ard_stats_mcnemar_test <- function(data, by, variables, ...) {
       fun_args_to_record = c("correct"),
       formals = formals(asNamespace("stats")[["mcnemar.test"]]),
       passed_args = dots_list(...),
-      lst_ard_columns = list(group1 = by, variable = variable, context = "mcnemartest")
+      lst_ard_columns = list(group1 = by, variable = variable, context = "stats_mcnemar_test")
     )
 
   # add the stat label ---------------------------------------------------------

R/ard_stats_mood_test.R

@@ -91,7 +91,7 @@ ard_stats_mood_test <- function(data, by, variables, ...) {
       tidy_result_names = c("statistic", "p.value", "method", "alternative"),
       formals = formals(asNamespace("stats")[["mood.test.default"]]),
       passed_args = c(dots_list(...)),
-      lst_ard_columns = list(group1 = by, variable = variable, context = "moodtest")
+      lst_ard_columns = list(group1 = by, variable = variable, context = "stats_mood_test")
     )
 
   # add the stat label ---------------------------------------------------------

R/ard_stats_oneway_test.R

@@ -37,7 +37,7 @@ ard_stats_oneway_test <- function(formula, data, ...) {
       c("var.equal"),
     formals = formals(stats::oneway.test),
     passed_args = dots_list(...),
-    lst_ard_columns = list(context = "oneway.test")
+    lst_ard_columns = list(context = "stats_oneway_test")
   ) |>
     dplyr::mutate(
       .after = "stat_name",

R/ard_stats_prop_test.R

@@ -108,7 +108,7 @@ ard_stats_prop_test <- function(data, by, variables, ...) {
       fun_args_to_record = c("p", "conf.level", "correct"),
       formals = formals(stats::prop.test),
       passed_args = dots_list(...),
-      lst_ard_columns = list(group1 = by, variable = variable, context = "proptest")
+      lst_ard_columns = list(group1 = by, variable = variable, context = "stats_prop_test")
     )
 
   # add the stat label ---------------------------------------------------------

R/ard_stats_t_test.R

@@ -168,7 +168,7 @@ ard_stats_paired_t_test <- function(data, by, variables, id, ...) {
       fun_args_to_record = c("mu", "paired", "var.equal", "conf.level"),
       formals = formals(asNamespace("stats")[["t.test.default"]]),
       passed_args = c(list(paired = paired), dots_list(...)),
-      lst_ard_columns = list(variable = variable, context = "ttest")
+      lst_ard_columns = list(variable = variable, context = "stats_t_test")
     )
 
   if (!is_empty(by)) {

R/ard_stats_wilcox_test.R

@@ -178,7 +178,7 @@ ard_stats_paired_wilcox_test <- function(data, by, variables, id, ...) {
       ),
       formals = formals(asNamespace("stats")[["wilcox.test.default"]]),
       passed_args = c(list(paired = paired), dots_list(...)),
-      lst_ard_columns = list(variable = variable, context = "wilcoxtest")
+      lst_ard_columns = list(variable = variable, context = "stats_wilcox_test")
     )
 
   if (!is_empty(by)) {

R/ard_survey_svychisq.R

@@ -55,7 +55,7 @@ ard_survey_svychisq <- function(data, by, variables, statistic = "F", ...) {
           ),
         tidy_result_names = c("statistic", "p.value", "ndf", "ddf", "method"),
         passed_args = dots_list(...),
-        lst_ard_columns = list(group1 = by, variable = variable, context = "svychisq")
+        lst_ard_columns = list(group1 = by, variable = variable, context = "survey_svychisq")
       ) |>
         dplyr::mutate(
           .after = "stat_name",

R/ard_survey_svycontinuous.R

@@ -138,7 +138,7 @@ ard_survey_svycontinuous <- function(data, variables, by = NULL,
 
   # add class and return ARD object --------------------------------------------
   df_stats |>
-    dplyr::mutate(context = "continuous") |>
+    dplyr::mutate(context = "survey_svycontinuous") |>
     cards::tidy_ard_column_order() %>%
     {structure(., class = c("card", class(.)))} # styler: off
 }

R/ard_survey_svyranktest.R

@@ -68,7 +68,7 @@ ard_survey_svyranktest <- function(data, by, variables, test, ...) {
         "method", "alternative"
       ),
       passed_args = dots_list(...),
-      lst_ard_columns = list(group1 = by, variable = variable, context = "svyranktest")
+      lst_ard_columns = list(group1 = by, variable = variable, context = "survey_svyranktest")
     )
 
   # add the stat label ---------------------------------------------------------

R/ard_survey_svyttest.R

@@ -75,7 +75,7 @@ ard_survey_svyttest <- function(data, by, variables, conf.level = 0.95, ...) {
         "conf.level", "method", "alternative"
       ),
       passed_args = dots_list(...),
-      lst_ard_columns = list(group1 = by, variable = variable, context = "svyttest")
+      lst_ard_columns = list(group1 = by, variable = variable, context = "survey_svyttest")
     )
 
   # add the stat label ---------------------------------------------------------

R/ard_survival_survdiff.R

@@ -0,0 +1,146 @@
+#' ARD for Difference in Survival
+#'
+#' @description
+#' Analysis results data for comparison of survival using [survival::survdiff()].
+#'
+#' @param formula (`formula`)\cr
+#'   a formula
+#' @param data (`data.frame`)\cr
+#'  a data frame
+#' @param rho (`scalar numeric`)\cr
+#'   numeric scalar passed to `survival::survdiff(rho)`. Default is `rho=0`.
+#' @param ... additional arguments passed to `survival::survdiff()`
+#'
+#' @return an ARD data frame of class 'card'
+#' @export
+#'
+#' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = c("survival", "broom", "ggsurvfit"), reference_pkg = "cardx"))
+#' library(survival)
+#' library(ggsurvfit)
+#'
+#' ard_survival_survdiff(Surv_CNSR(AVAL, CNSR) ~ TRTA, data = cards::ADTTE)
+ard_survival_survdiff <- function(formula, data, rho = 0, ...) {
+  set_cli_abort_call()
+
+  # check installed packages ---------------------------------------------------
+  check_pkg_installed(c("survival", "broom"), reference_pkg = "cardx")
+
+  # check/process inputs -------------------------------------------------------
+  check_not_missing(formula)
+  check_class(formula, cls = "formula")
+  if (!missing(data)) check_class(data, cls = "data.frame")
+  check_scalar(rho)
+  check_class(rho, cls = "numeric")
+
+  # assign method
+  method <- dplyr::case_when(
+    rho == 0 ~ "Log-rank test",
+    rho == 1.5 ~ "Tarone-Ware test",
+    rho == 1 ~ "Peto & Peto modification of Gehan-Wilcoxon test",
+    .default = glue::glue("G-rho test (\U03C1 = {rho})")
+  ) |>
+    as.character()
+
+  # calculate survdiff() results -----------------------------------------------
+  lst_glance <-
+    cards::eval_capture_conditions(
+      survival::survdiff(formula = formula, data = data, rho = rho, ...) |>
+        broom::glance() |>
+        dplyr::mutate(method = .env$method)
+    )
+
+  # tidy results up in an ARD format -------------------------------------------
+  # extract variable names from formula
+  variables <- stats::terms(formula) |>
+    attr("term.labels") |>
+    .strip_backticks()
+
+  # if there was an error, return results early
+  if (is.null(lst_glance[["result"]])) {
+    # if no variables in formula, then return an error
+    # otherwise, if we do have variable names, then we can construct an empty ARD which will be done below
+    if (is_empty(variables)) {
+      cli::cli_abort(
+        message =
+          c("There was an error in {.fun survival::survdiff}. See below:",
+            "x" = lst_glance[["error"]]
+          ),
+        call = get_cli_abort_call()
+      )
+    }
+  }
+
+  .variables_to_survdiff_ard(
+    variables = variables,
+    method = method,
+    # styler: off
+    stat_names =
+      if (!is.null(lst_glance[["result"]])) names(lst_glance[["result"]])
+      else c("statistic", "df", "p.value", "method"),
+    stats =
+      if (!is.null(lst_glance[["result"]])) unname(as.list(lst_glance[["result"]]))
+      else rep_along(c("statistic", "df", "p.value"), list(NULL)) |> c(list(method = method))
+    # styler: on
+  ) |>
+    .add_survdiff_stat_labels() |>
+    dplyr::mutate(
+      context = "survival_survdiff",
+      warning = lst_glance["warning"],
+      error = lst_glance["error"],
+      fmt_fn = map(
+        .data$stat,
+        function(x) {
+          if (is.numeric(x)) return(1L) # styler: off
+          NULL
+        }
+      )
+    ) |>
+    cards::tidy_ard_column_order() %>%
+    {structure(., class = c("card", class(.)))} # styler: off
+}
+
+.variables_to_survdiff_ard <- function(variables,
+                                       method,
+                                       stat_names,
+                                       stats) {
+  len <- length(variables)
+
+  df_vars <- dplyr::tibble(!!!rev(variables)) |>
+    set_names(
+      ifelse(
+        len > 1L,
+        c(paste0("group_", rev(seq_len(len - 1L))), "variable"),
+        "variable"
+      )
+    )
+
+  dplyr::bind_cols(
+    df_vars,
+    dplyr::tibble(
+      stat_name = .env$stat_names,
+      stat = .env$stats
+    )
+  )
+}
+
+.add_survdiff_stat_labels <- function(x) {
+  x |>
+    dplyr::left_join(
+      dplyr::tribble(
+        ~stat_name, ~stat_label,
+        "statistic", "X^2 Statistic",
+        "df", "Degrees of Freedom",
+        "p.value", "p-value"
+      ),
+      by = "stat_name"
+    ) |>
+    dplyr::mutate(stat_label = dplyr::coalesce(.data$stat_label, .data$stat_name))
+}
+
+.strip_backticks <- function(x) {
+  ifelse(
+    str_detect(x, "^`.*`$"),
+    substr(x, 2, nchar(x) - 1),
+    x
+  )
+}

R/ard_survival_survfit.R

@@ -32,13 +32,14 @@
 #' * Times should be provided using the same scale as the time variable used to fit the provided
 #'   survival fit model.
 #'
-#' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = c("survival", "broom"), reference_pkg = "cardx"))
+#' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = c("survival", "broom", "ggsurvfit"), reference_pkg = "cardx"))
 #' library(survival)
+#' library(ggsurvfit)
 #'
-#' survfit(Surv(AVAL, CNSR) ~ TRTA, cards::ADTTE) |>
+#' survfit(Surv_CNSR(AVAL, CNSR) ~ TRTA, cards::ADTTE) |>
 #'   ard_survival_survfit(times = c(60, 180))
 #'
-#' survfit(Surv(AVAL, CNSR) ~ TRTA, cards::ADTTE) |>
+#' survfit(Surv_CNSR(AVAL, CNSR) ~ TRTA, cards::ADTTE) |>
 #'   ard_survival_survfit(probs = c(0.25, 0.5, 0.75))
 #'
 #' # Competing Risks Example ---------------------------
@@ -240,7 +241,7 @@ ard_survival_survfit <- function(x, times = NULL, probs = NULL, type = NULL) {
   ) %>%
     dplyr::bind_rows() %>%
     `rownames<-`(NULL) %>%
-    dplyr::mutate(context = "survival") %>%
+    dplyr::mutate(context = "survival_survfit") %>%
     dplyr::as_tibble()
 
   if (length(x$n) == 1) df_stat <- df_stat %>% dplyr::select(-"strata")

_pkgdown.yml

@@ -40,6 +40,7 @@ reference:
       - ard_survey_svychisq
       - ard_survey_svyranktest
       - ard_survey_svyttest
+      - ard_survival_survdiff
 
   - subtitle: "Estimation"
   - contents: