|
| 1 | +#' ARD for Difference in Survival |
| 2 | +#' |
| 3 | +#' @description |
| 4 | +#' Analysis results data for comparison of survival using [survival::survdiff()]. |
| 5 | +#' |
| 6 | +#' @param formula (`formula`)\cr |
| 7 | +#' a formula |
| 8 | +#' @param data (`data.frame`)\cr |
| 9 | +#' a data frame |
| 10 | +#' @param rho (`scalar numeric`)\cr |
| 11 | +#' numeric scalar passed to `survival::survdiff(rho)`. Default is `rho=0`. |
| 12 | +#' @param ... additional arguments passed to `survival::survdiff()` |
| 13 | +#' |
| 14 | +#' @return an ARD data frame of class 'card' |
| 15 | +#' @export |
| 16 | +#' |
| 17 | +#' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = c("survival", "broom", "ggsurvfit"), reference_pkg = "cardx")) |
| 18 | +#' library(survival) |
| 19 | +#' library(ggsurvfit) |
| 20 | +#' |
| 21 | +#' ard_survival_survdiff(Surv_CNSR(AVAL, CNSR) ~ TRTA, data = cards::ADTTE) |
| 22 | +ard_survival_survdiff <- function(formula, data, rho = 0, ...) { |
| 23 | + set_cli_abort_call() |
| 24 | + |
| 25 | + # check installed packages --------------------------------------------------- |
| 26 | + check_pkg_installed(c("survival", "broom"), reference_pkg = "cardx") |
| 27 | + |
| 28 | + # check/process inputs ------------------------------------------------------- |
| 29 | + check_not_missing(formula) |
| 30 | + check_class(formula, cls = "formula") |
| 31 | + if (!missing(data)) check_class(data, cls = "data.frame") |
| 32 | + check_scalar(rho) |
| 33 | + check_class(rho, cls = "numeric") |
| 34 | + |
| 35 | + # assign method |
| 36 | + method <- dplyr::case_when( |
| 37 | + rho == 0 ~ "Log-rank test", |
| 38 | + rho == 1.5 ~ "Tarone-Ware test", |
| 39 | + rho == 1 ~ "Peto & Peto modification of Gehan-Wilcoxon test", |
| 40 | + .default = glue::glue("G-rho test (\U03C1 = {rho})") |
| 41 | + ) |> |
| 42 | + as.character() |
| 43 | + |
| 44 | + # calculate survdiff() results ----------------------------------------------- |
| 45 | + lst_glance <- |
| 46 | + cards::eval_capture_conditions( |
| 47 | + survival::survdiff(formula = formula, data = data, rho = rho, ...) |> |
| 48 | + broom::glance() |> |
| 49 | + dplyr::mutate(method = .env$method) |
| 50 | + ) |
| 51 | + |
| 52 | + # tidy results up in an ARD format ------------------------------------------- |
| 53 | + # extract variable names from formula |
| 54 | + variables <- stats::terms(formula) |> |
| 55 | + attr("term.labels") |> |
| 56 | + .strip_backticks() |
| 57 | + |
| 58 | + # if there was an error, return results early |
| 59 | + if (is.null(lst_glance[["result"]])) { |
| 60 | + # if no variables in formula, then return an error |
| 61 | + # otherwise, if we do have variable names, then we can construct an empty ARD which will be done below |
| 62 | + if (is_empty(variables)) { |
| 63 | + cli::cli_abort( |
| 64 | + message = |
| 65 | + c("There was an error in {.fun survival::survdiff}. See below:", |
| 66 | + "x" = lst_glance[["error"]] |
| 67 | + ), |
| 68 | + call = get_cli_abort_call() |
| 69 | + ) |
| 70 | + } |
| 71 | + } |
| 72 | + |
| 73 | + .variables_to_survdiff_ard( |
| 74 | + variables = variables, |
| 75 | + method = method, |
| 76 | + # styler: off |
| 77 | + stat_names = |
| 78 | + if (!is.null(lst_glance[["result"]])) names(lst_glance[["result"]]) |
| 79 | + else c("statistic", "df", "p.value", "method"), |
| 80 | + stats = |
| 81 | + if (!is.null(lst_glance[["result"]])) unname(as.list(lst_glance[["result"]])) |
| 82 | + else rep_along(c("statistic", "df", "p.value"), list(NULL)) |> c(list(method = method)) |
| 83 | + # styler: on |
| 84 | + ) |> |
| 85 | + .add_survdiff_stat_labels() |> |
| 86 | + dplyr::mutate( |
| 87 | + context = "survival_survdiff", |
| 88 | + warning = lst_glance["warning"], |
| 89 | + error = lst_glance["error"], |
| 90 | + fmt_fn = map( |
| 91 | + .data$stat, |
| 92 | + function(x) { |
| 93 | + if (is.numeric(x)) return(1L) # styler: off |
| 94 | + NULL |
| 95 | + } |
| 96 | + ) |
| 97 | + ) |> |
| 98 | + cards::tidy_ard_column_order() %>% |
| 99 | + {structure(., class = c("card", class(.)))} # styler: off |
| 100 | +} |
| 101 | + |
| 102 | +.variables_to_survdiff_ard <- function(variables, |
| 103 | + method, |
| 104 | + stat_names, |
| 105 | + stats) { |
| 106 | + len <- length(variables) |
| 107 | + |
| 108 | + df_vars <- dplyr::tibble(!!!rev(variables)) |> |
| 109 | + set_names( |
| 110 | + ifelse( |
| 111 | + len > 1L, |
| 112 | + c(paste0("group_", rev(seq_len(len - 1L))), "variable"), |
| 113 | + "variable" |
| 114 | + ) |
| 115 | + ) |
| 116 | + |
| 117 | + dplyr::bind_cols( |
| 118 | + df_vars, |
| 119 | + dplyr::tibble( |
| 120 | + stat_name = .env$stat_names, |
| 121 | + stat = .env$stats |
| 122 | + ) |
| 123 | + ) |
| 124 | +} |
| 125 | + |
| 126 | +.add_survdiff_stat_labels <- function(x) { |
| 127 | + x |> |
| 128 | + dplyr::left_join( |
| 129 | + dplyr::tribble( |
| 130 | + ~stat_name, ~stat_label, |
| 131 | + "statistic", "X^2 Statistic", |
| 132 | + "df", "Degrees of Freedom", |
| 133 | + "p.value", "p-value" |
| 134 | + ), |
| 135 | + by = "stat_name" |
| 136 | + ) |> |
| 137 | + dplyr::mutate(stat_label = dplyr::coalesce(.data$stat_label, .data$stat_name)) |
| 138 | +} |
| 139 | + |
| 140 | +.strip_backticks <- function(x) { |
| 141 | + ifelse( |
| 142 | + str_detect(x, "^`.*`$"), |
| 143 | + substr(x, 2, nchar(x) - 1), |
| 144 | + x |
| 145 | + ) |
| 146 | +} |
0 commit comments