From 41bdebfac1c1f437f189456eec66d135ec665a31 Mon Sep 17 00:00:00 2001 From: Emily de la Rua <59304861+edelarua@users.noreply.github.com> Date: Thu, 9 Jan 2025 18:05:21 -0500 Subject: [PATCH] Fix bug in `ard_survival_survfit()` when "=" is in strata variable labels (#253) **What changes are proposed in this pull request?** * Fixed a bug in `ard_survival_survfit()` causing an error when "=" character is present in stratification variable level labels. (#252) Closes #252 -------------------------------------------------------------------------------- Pre-review Checklist (if item does not apply, mark is as complete) - [x] **All** GitHub Action workflows pass with a :white_check_mark: - [x] PR branch has pulled the most recent updates from master branch: `usethis::pr_merge_main()` - [x] If a bug was fixed, a unit test was added. - [x] If a new `ard_*()` function was added, it passes the ARD structural checks from `cards::check_ard_structure()`. - [x] If a new `ard_*()` function was added, `set_cli_abort_call()` has been set. - [x] If a new `ard_*()` function was added and it depends on another package (such as, `broom`), `is_pkg_installed("broom")` 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""))` - [x] 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) - [ ] If a bug was fixed, a unit test was added. - [ ] Code coverage is suitable for any new functions/features: `devtools::test_coverage()` When the branch is ready to be merged: - [ ] Update `NEWS.md` with the changes from this pull request under the heading "`# cardx (development version)`". If there is an issue associated with the pull request, reference it in parentheses at the end update (see `NEWS.md` for examples). - [ ] **All** GitHub Action workflows pass with a :white_check_mark: - [ ] Approve Pull Request - [ ] Merge the PR. Please use "Squash and merge" or "Rebase and merge". --------- Co-authored-by: Daniel Sjoberg --- NEWS.md | 2 ++ R/ard_survival_survfit.R | 13 ++++------- tests/testthat/_snaps/ard_survival_survfit.md | 22 +++++++++++++++++++ tests/testthat/test-ard_survival_survfit.R | 9 ++++++++ 4 files changed, 37 insertions(+), 9 deletions(-) diff --git a/NEWS.md b/NEWS.md index d4634fe6..f4abfade 100644 --- a/NEWS.md +++ b/NEWS.md @@ -4,6 +4,8 @@ * Update in `ard_missing.survey.design()` where we can now tabulate the missing rate of design variables, such as the weights. +* Fixed a bug in `ard_survival_survfit()` causing an error when "=" character is present in stratification variable level labels. (#252) + # cardx 0.2.2 * Added a `data.frame` method to `ard_survival_survfit()`. diff --git a/R/ard_survival_survfit.R b/R/ard_survival_survfit.R index 05f836dc..772f4a27 100644 --- a/R/ard_survival_survfit.R +++ b/R/ard_survival_survfit.R @@ -284,7 +284,7 @@ ard_survival_survfit.data.frame <- function(x, y, variables, dplyr::rename(conf.low = "conf.high", conf.high = "conf.low") } - df_stat <- extract_multi_strata(x, df_stat) + df_stat <- extract_strata(x, df_stat) df_stat } @@ -320,13 +320,13 @@ ard_survival_survfit.data.frame <- function(x, y, variables, if (length(x$n) == 1) df_stat <- df_stat %>% dplyr::select(-"strata") - df_stat <- extract_multi_strata(x, df_stat) + df_stat <- extract_strata(x, df_stat) df_stat } -# process multiple stratifying variables -extract_multi_strata <- function(x, df_stat) { +# process stratifying variables +extract_strata <- function(x, df_stat) { x_terms <- attr(stats::terms(stats::as.formula(x$call$formula)), "term.labels") x_terms <- gsub(".*\\(", "", gsub("\\)", "", x_terms)) if (length(x_terms) > 0L) { @@ -380,11 +380,6 @@ extract_multi_strata <- function(x, df_stat) { ) %>% dplyr::select(-all_of(est)) - if ("strata" %in% names(ret)) { - ret <- ret %>% - tidyr::separate_wider_delim("strata", "=", names = c("group1", "group1_level")) - } - ret %>% dplyr::left_join( .df_survfit_stat_labels(), diff --git a/tests/testthat/_snaps/ard_survival_survfit.md b/tests/testthat/_snaps/ard_survival_survfit.md index 1e440730..9cd90560 100644 --- a/tests/testthat/_snaps/ard_survival_survfit.md +++ b/tests/testthat/_snaps/ard_survival_survfit.md @@ -334,6 +334,28 @@ Error in `ard_survival_survfit()`: ! Argument `x` cannot be class . +# ard_survival_survfit() works with '=' in strata variable level labels + + Code + ard_survival_survfit(survival::survfit(survival::Surv(time, status) ~ age_bin, + data = lung2), times = 100) + Message + {cards} data frame: 10 x 11 + Output + group1 group1_level variable variable_level stat_name stat_label stat + 1 age_bin <60 time 100 n.risk Number o… 77 + 2 age_bin <60 time 100 estimate Survival… 0.928 + 3 age_bin <60 time 100 std.error Standard… 0.028 + 4 age_bin <60 time 100 conf.high CI Upper… 0.985 + 5 age_bin <60 time 100 conf.low CI Lower… 0.874 + 6 age_bin >=60 time 100 n.risk Number o… 119 + 7 age_bin >=60 time 100 estimate Survival… 0.827 + 8 age_bin >=60 time 100 std.error Standard… 0.031 + 9 age_bin >=60 time 100 conf.high CI Upper… 0.891 + 10 age_bin >=60 time 100 conf.low CI Lower… 0.768 + Message + i 4 more variables: context, fmt_fn, warning, error + # ard_survival_survfit() extends to times outside range Code diff --git a/tests/testthat/test-ard_survival_survfit.R b/tests/testthat/test-ard_survival_survfit.R index a3cd76db..5ccc63a1 100644 --- a/tests/testthat/test-ard_survival_survfit.R +++ b/tests/testthat/test-ard_survival_survfit.R @@ -167,6 +167,15 @@ test_that("ard_survival_survfit() errors with stratified Cox model", { ) }) +test_that("ard_survival_survfit() works with '=' in strata variable level labels", { + lung2 <- survival::lung %>% + dplyr::mutate(age_bin = factor(ifelse(age < 60, "<60", ">=60"))) + + expect_snapshot( + survival::survfit(survival::Surv(time, status) ~ age_bin, data = lung2) |> + ard_survival_survfit(times = 100) + ) +}) test_that("ard_survival_survfit() follows ard structure", { expect_silent(