Enhance formula processing in ard_survival_survfit() (#226)

**What changes are proposed in this pull request?**
* Implemented `summary(extend=TRUE)` in `ard_survival_survfit()` to
return results for time points out of bounds.
* Added a `data.frame` method to `ard_survival_survfit()`.
* Added a warning for incorrect formula type to
`ard_survival_survfit()`.

Closes #223 and #224 


--------------------------------------------------------------------------------

Pre-review Checklist (if item does not apply, mark is as complete)
- [ ] **All** GitHub Action workflows pass with a ✅
- [ ] 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")` 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""))`
- [ ] 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 ✅
- [ ] Approve Pull Request
- [ ] Merge the PR. Please use "Squash and merge" or "Rebase and merge".

---------

Co-authored-by: Daniel Sjoberg <[email protected]>

NAMESPACE

@@ -12,6 +12,8 @@ S3method(ard_missing,survey.design)
 S3method(ard_regression,default)
 S3method(ard_stats_anova,anova)
 S3method(ard_stats_anova,data.frame)
+S3method(ard_survival_survfit,data.frame)
+S3method(ard_survival_survfit,survfit)
 S3method(ard_total_n,survey.design)
 S3method(construct_model,data.frame)
 S3method(construct_model,survey.design)

NEWS.md

@@ -1,5 +1,11 @@
 # cardx 0.2.1.9008
 
+* Implemented `summary(extend=TRUE)` in `ard_survival_survfit()` to return results for time points out of bounds. (#224)
+
+* Added a `data.frame` method to `ard_survival_survfit()`.
+
+* Added a warning for incorrect formula type to `ard_survival_survfit()`. (#223)
+
 # cardx 0.2.1
 
 ## New Features and Updates

R/ard_survival_survfit.R

@@ -4,8 +4,8 @@
 #' Analysis results data for survival quantiles and x-year survival estimates, extracted
 #' from a [survival::survfit()] model.
 #'
-#' @param x ([survival::survfit()])\cr
-#'   a [survival::survfit()] object. See below for details.
+#' @param x (`survfit` or `data.frame`)\cr
+#'   an object of class `survfit` created with [survival::survfit()] or a data frame. See below for details.
 #' @param times (`numeric`)\cr
 #'   a vector of times for which to return survival probabilities.
 #' @param probs (`numeric`)\cr
@@ -23,6 +23,34 @@
 #'   ) %>%
 #'   knitr::kable()
 #'   ```
+#' @param y (`Surv` or `string`)\cr
+#'   an object of class `Surv` created using [survival::Surv()]. This object will be passed as the left-hand side of
+#'   the formula constructed and passed to [survival::survfit()]. This object can also be passed as a string.
+#' @param variables (`character`)\cr
+#'   stratification variables to be passed as the right-hand side of the formula constructed and passed to
+#'   [survival::survfit()].
+#' @param method.args (named `list`)\cr
+#'   named list of arguments that will be passed to [survival::survfit()].
+#' @inheritParams rlang::args_dots_empty
+#'
+#' @section Formula Specification:
+#' When passing a [`survival::survfit()`] object to `ard_survival_survfit()`,
+#' the `survfit()` call must use an evaluated formula and not a stored formula.
+#' Including a proper formula in the call allows the function to accurately
+#' identify all variables included in the estimation. See below for examples:
+#'
+#' ```r
+#' library(cardx)
+#' library(survival)
+#'
+#' # include formula in `survfit()` call
+#' survfit(Surv(time, status) ~ sex, lung) |> ard_survival_survfit(time = 500)
+#'
+#' # you can also pass a data frame to `ard_survival_survfit()` as well.
+#' lung |>
+#'   ard_survival_survfit(y = Surv(time, status), variables = "sex", time = 500)
+#' ```
+#' You **cannot**, however, pass a stored formula, e.g. `survfit(my_formula, lung)`
 #'
 #' @return an ARD data frame of class 'card'
 #' @name ard_survival_survfit
@@ -42,6 +70,9 @@
 #' survfit(Surv_CNSR(AVAL, CNSR) ~ TRTA, data = cards::ADTTE, conf.int = 0.90) |>
 #'   ard_survival_survfit(probs = c(0.25, 0.5, 0.75))
 #'
+#' cards::ADTTE |>
+#'   ard_survival_survfit(y = Surv_CNSR(AVAL, CNSR), variables = c("TRTA", "SEX"), times = 90)
+#'
 #' # Competing Risks Example ---------------------------
 #' set.seed(1)
 #' ADTTE_MS <- cards::ADTTE %>%
@@ -59,15 +90,31 @@ NULL
 
 #' @rdname ard_survival_survfit
 #' @export
-ard_survival_survfit <- function(x, times = NULL, probs = NULL, type = NULL) {
+ard_survival_survfit <- function(x, ...) {
+  set_cli_abort_call()
+
+  check_not_missing(x)
+  UseMethod("ard_survival_survfit")
+}
+
+#' @rdname ard_survival_survfit
+#' @export
+ard_survival_survfit.survfit <- function(x, times = NULL, probs = NULL, type = NULL, ...) {
   set_cli_abort_call()
 
   # check installed packages ---------------------------------------------------
   check_pkg_installed(c("survival", "broom"))
 
   # check/process inputs -------------------------------------------------------
-  check_not_missing(x)
-  check_class(x, cls = "survfit")
+  if (is.name(x$call$formula)) {
+    cli::cli_abort(
+      message = paste(
+        "The call in the survfit object {.arg x} must be an evaluated formula.",
+        "Please see the function documentation for details on properly specifying formulas."
+      ),
+      call = get_cli_abort_call()
+    )
+  }
   if (inherits(x, "survfitcox")) {
     cli::cli_abort("Argument {.arg x} cannot be class {.cls survfitcox}.",
       call = get_cli_abort_call()
@@ -107,6 +154,34 @@ ard_survival_survfit <- function(x, times = NULL, probs = NULL, type = NULL) {
   .format_survfit_results(tidy_survfit)
 }
 
+#' @rdname ard_survival_survfit
+#' @export
+ard_survival_survfit.data.frame <- function(x, y, variables,
+                                            times = NULL, probs = NULL, type = NULL,
+                                            method.args = list(conf.int = 0.95), ...) {
+  set_cli_abort_call()
+
+  # check/process inputs -------------------------------------------------------
+  check_class(variables, "character")
+
+  # process outcome as string --------------------------------------------------
+  y <- enquo(y)
+  # if a character was passed, return it as is
+  if (tryCatch(is.character(eval_tidy(y)), error = \(e) FALSE)) y <- eval_tidy(y) # styler: off
+  # otherwise, convert expr to string
+  else y <- expr_deparse(quo_get_expr(y))  # styler: off
+
+  # build model ----------------------------------------------------------------
+  construct_model(
+    data = x,
+    formula = stats::reformulate(termlabels = bt(variables), response = y),
+    method = "survfit",
+    package = "survival",
+    method.args = {{ method.args }}
+  ) |>
+    ard_survival_survfit(times = times, probs = probs, type = type)
+}
+
 #' Process Survival Fit For Time Estimates
 #'
 #' @inheritParams cards::tidy_as_ard
@@ -134,7 +209,7 @@ ard_survival_survfit <- function(x, times = NULL, probs = NULL, type = NULL) {
     start.time <- 0
   }
   x <- survival::survfit0(x, start.time) %>%
-    summary(times)
+    summary(times, extend = TRUE)
 
   # process competing risks/multi-state models
   multi_state <- inherits(x, "summary.survfitms")

tests/testthat/_snaps/ard_survival_survfit.md

@@ -265,13 +265,38 @@
     Message
       i 4 more variables: context, fmt_fn, warning, error
 
+---
+
+    Code
+      survival::survfit(survival::Surv(AVAL, CNSR) ~ TRTA, data = ADTTE_MS) %>%
+        ard_survival_survfit(times = c(60, 180), type = "risk")
+    Condition
+      Error in `ard_survival_survfit()`:
+      ! Cannot use `type` argument with `survfit` models with class <survfitms/survfitcoxms>.
+
 # ard_survival_survfit() errors are properly handled
 
     Code
-      ard_survival_survfit("not_survfit")
+      ard_survival_survfit(x, times = 25)
     Condition
       Error in `ard_survival_survfit()`:
-      ! The `x` argument must be class <survfit>, not a string.
+      ! The call in the survfit object `x` must be an evaluated formula. Please see the function documentation for details on properly specifying formulas.
+
+---
+
+    Code
+      ard_survival_survfit(times = 25)
+    Condition
+      Error in `ard_survival_survfit()`:
+      ! The `x` argument cannot be missing.
+
+---
+
+    Code
+      ard_survival_survfit("not_survfit")
+    Condition
+      Error in `UseMethod()`:
+      ! no applicable method for 'ard_survival_survfit' applied to an object of class "character"
 
 ---
 
@@ -282,6 +307,15 @@
       Error in `ard_survival_survfit()`:
       ! `type` must be one of "survival", "risk", or "cumhaz", not "notatype".
 
+---
+
+    Code
+      ard_survival_survfit(survival::survfit(survival::Surv(AVAL, CNSR) ~ TRTA,
+      cards::ADTTE), probs = c(0.25, 0.75), type = "risk")
+    Condition
+      Error in `ard_survival_survfit()`:
+      ! Cannot use `type` argument when `probs` argument specifed.
+
 ---
 
     Code
@@ -300,3 +334,54 @@
       Error in `ard_survival_survfit()`:
       ! Argument `x` cannot be class <survfitcox>.
 
+# ard_survival_survfit() extends to times outside range
+
+    Code
+      print(ard_survival_survfit(survival::survfit(survival::Surv(AVAL, CNSR) ~ TRTA,
+      cards::ADTTE), times = 200), n = Inf)
+    Message
+      {cards} data frame: 15 x 11
+    Output
+         group1 group1_level variable variable_level stat_name stat_label stat
+      1    TRTA      Placebo     time            200    n.risk  Number o…    0
+      2    TRTA      Placebo     time            200  estimate  Survival…    0
+      3    TRTA      Placebo     time            200 std.error  Standard…  NaN
+      4    TRTA      Placebo     time            200 conf.high  CI Upper…   NA
+      5    TRTA      Placebo     time            200  conf.low  CI Lower…   NA
+      6    TRTA    Xanomeli…     time            200    n.risk  Number o…    0
+      7    TRTA    Xanomeli…     time            200  estimate  Survival…    0
+      8    TRTA    Xanomeli…     time            200 std.error  Standard…  NaN
+      9    TRTA    Xanomeli…     time            200 conf.high  CI Upper…   NA
+      10   TRTA    Xanomeli…     time            200  conf.low  CI Lower…   NA
+      11   TRTA    Xanomeli…     time            200    n.risk  Number o…    0
+      12   TRTA    Xanomeli…     time            200  estimate  Survival…    0
+      13   TRTA    Xanomeli…     time            200 std.error  Standard…  NaN
+      14   TRTA    Xanomeli…     time            200 conf.high  CI Upper…   NA
+      15   TRTA    Xanomeli…     time            200  conf.low  CI Lower…   NA
+    Message
+      i 4 more variables: context, fmt_fn, warning, error
+
+# ard_survival_survfit.data.frame() works as expected
+
+    Code
+      res_quo <- print(dplyr::mutate(ard_survival_survfit.data.frame(x = mtcars, y = "survival::Surv(mpg, am)",
+        variables = "vs", times = 20, method.args = list(start.time = 0, id = cyl)),
+      stat = lapply(stat, function(x) ifelse(is.numeric(x), cards::round5(x, 3), x))),
+      n = Inf)
+    Message
+      {cards} data frame: 10 x 11
+    Output
+         group1 group1_level variable variable_level stat_name stat_label  stat
+      1      vs            0     time             20    n.risk  Number o…     3
+      2      vs            0     time             20  estimate  Survival… 0.615
+      3      vs            0     time             20 std.error  Standard… 0.082
+      4      vs            0     time             20 conf.high  CI Upper…   0.8
+      5      vs            0     time             20  conf.low  CI Lower… 0.474
+      6      vs            1     time             20    n.risk  Number o…    11
+      7      vs            1     time             20  estimate  Survival…     1
+      8      vs            1     time             20 std.error  Standard…     0
+      9      vs            1     time             20 conf.high  CI Upper…     1
+      10     vs            1     time             20  conf.low  CI Lower…     1
+    Message
+      i 4 more variables: context, fmt_fn, warning, error
+