| 1 |
- #' Functions for Calculating Proportion Confidence Intervals+ #' ARD Survey t-test |
||
| 3 |
- #' Functions to calculate different proportion confidence intervals for use in `ard_proportion()`.+ #' @description |
||
| 4 |
- #'+ #' Analysis results data for survey t-test using [`survey::svyttest()`]. |
||
| 5 |
- #' @inheritParams ard_proportion_ci+ #' |
||
| 6 |
- #' @param x vector of a binary values, i.e. a logical vector, or numeric with values `c(0, 1)`+ #' @param data (`survey.design`)\cr |
||
| 7 |
- #' @return Confidence interval of a proportion.+ #' a survey design object often created with [`survey::svydesign()`] |
||
| 8 |
- #'+ #' @param by ([`tidy-select`][dplyr::dplyr_tidy_select])\cr |
||
| 9 |
- #' @name proportion_ci+ #' column name to compare by |
||
| 10 |
- #' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = "broom", reference_pkg = "cardx"))
+ #' @param variables ([`tidy-select`][dplyr::dplyr_tidy_select])\cr |
||
| 11 |
- #' x <- c(+ #' column names to be compared. Independent tests will be run for each variable. |
||
| 12 |
- #' TRUE, TRUE, TRUE, TRUE, TRUE,+ #' @param conf.level (`double`)\cr |
||
| 13 |
- #' FALSE, FALSE, FALSE, FALSE, FALSE+ #' confidence level of the returned confidence interval. Must be between `c(0, 1)`. |
||
| 14 |
- #' )+ #' Default is `0.95` |
||
| 15 |
- #'+ #' @param ... arguments passed to [`survey::svyttest()`] |
||
| 16 |
- #' proportion_ci_wald(x, conf.level = 0.9)+ #' |
||
| 17 |
- #' proportion_ci_wilson(x, correct = TRUE)+ #' @return ARD data frame |
||
| 18 |
- #' proportion_ci_clopper_pearson(x)+ #' @export |
||
| 19 |
- #' proportion_ci_agresti_coull(x)+ #' |
||
| 20 |
- #' proportion_ci_jeffreys(x)+ #' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = c("survey", "broom"), reference_pkg = "cardx"))
|
||
| 21 |
- NULL+ #' data(api, package = "survey") |
||
| 22 |
-
+ #' dclus2 <- survey::svydesign(id = ~ dnum + snum, fpc = ~ fpc1 + fpc2, data = apiclus2) |
||
| 23 |
- #' @describeIn proportion_ci Calculates the Wald interval by following the usual textbook definition+ #' |
||
| 24 |
- #' for a single proportion confidence interval using the normal approximation.+ #' ard_survey_svyttest(dclus2, variables = enroll, by = comp.imp, conf.level = 0.9) |
||
| 25 |
- #'+ ard_survey_svyttest <- function(data, by, variables, conf.level = 0.95, ...) {
|
||
| 26 | -+ | 4x |
- #' \deqn{\hat{p} \pm z_{\alpha/2} \sqrt{\frac{\hat{p}(1 - \hat{p})}{n}}}
+ set_cli_abort_call() |
| 27 |
- #'+ |
||
| 28 |
- #' @param correct (`logical`)\cr apply continuity correction.+ # check installed packages --------------------------------------------------- |
||
| 29 | -+ | 4x |
- #'+ check_pkg_installed(c("survey", "broom"), reference_pkg = "cardx")
|
| 30 |
- #' @export+ |
||
| 31 |
- proportion_ci_wald <- function(x, conf.level = 0.95, correct = FALSE) {
+ # check/process inputs ------------------------------------------------------- |
||
| 32 | -15x | +4x |
- set_cli_abort_call()+ check_not_missing(data) |
| 33 | -+ | 4x |
-
+ check_not_missing(variables) |
| 34 | -+ | 4x |
- # check inputs ---------------------------------------------------------------+ check_not_missing(by) |
| 35 | -15x | +4x |
- check_not_missing(x)+ check_range(conf.level, range = c(0, 1)) |
| 36 | -15x | +4x |
- check_binary(x)+ check_class(data, cls = "survey.design") |
| 37 | -15x | +4x |
- check_range(conf.level, range = c(0, 1), include_bounds = c(FALSE, FALSE))+ cards::process_selectors(data[["variables"]], by = {{ by }}, variables = {{ variables }})
|
| 38 | -15x | +4x |
- check_scalar(conf.level)+ check_scalar(by) |
| 39 | -15x | +
- check_class(x = correct, "logical")+ |
|
| 40 | -15x | +
- check_scalar(correct)+ # build ARD ------------------------------------------------------------------ |
|
| 41 | -+ | 4x |
-
+ lapply( |
| 42 | -15x | +4x |
- x <- stats::na.omit(x)+ variables, |
| 43 | -+ | 4x |
-
+ function(variable) {
|
| 44 | -15x | +5x |
- n <- length(x)+ .format_svyttest_results( |
| 45 | -15x | +5x |
- p_hat <- mean(x)+ by = by, |
| 46 | -15x | +5x |
- z <- stats::qnorm((1 + conf.level) / 2)+ variable = variable, |
| 47 | -15x | +5x |
- q_hat <- 1 - p_hat+ lst_tidy = |
| 48 | -15x | +5x |
- correction_factor <- ifelse(correct, 1 / (2 * n), 0)+ cards::eval_capture_conditions( |
| 49 | -+ | 5x |
-
+ survey::svyttest(reformulate2(termlabels = by, response = variable), design = data, ...) %>% |
| 50 | -15x | +
- err <- z * sqrt(p_hat * q_hat) / sqrt(n) + correction_factor+ # a slightly enhanced tidier that allows us to specify the conf.level |
|
| 51 | -15x | +
- l_ci <- max(0, p_hat - err)+ {
|
|
| 52 | -15x | +4x |
- u_ci <- min(1, p_hat + err)+ dplyr::bind_cols( |
| 53 | -+ | 4x |
-
+ broom::tidy(.) |> dplyr::select(-c("conf.low", "conf.high")),
|
| 54 | -15x | +4x |
- list(+ dplyr::tibble(!!!stats::confint(., level = conf.level) |> set_names(c("conf.low", "conf.high"))) |>
|
| 55 | -15x | +4x |
- N = n,+ dplyr::mutate(conf.level = conf.level) |
| 56 | -15x | +
- estimate = p_hat,+ ) |
|
| 57 | -15x | +
- conf.low = l_ci,+ } |
|
| 58 | -15x | +
- conf.high = u_ci,+ ), |
|
| 59 | -15x | +
- conf.level = conf.level,+ ... |
|
| 60 | -15x | +
- method =+ ) |
|
| 61 | -15x | +
- glue::glue("Wald Confidence Interval {ifelse(correct, 'with', 'without')} continuity correction")
+ } |
|
| 62 |
- )+ ) |> |
||
| 63 | -+ | 4x |
- }+ dplyr::bind_rows() |
| 64 |
-
+ } |
||
| 66 |
- #' @describeIn proportion_ci Calculates the Wilson interval by calling [stats::prop.test()].+ .format_svyttest_results <- function(by, variable, lst_tidy, ...) {
|
||
| 67 |
- #' Also referred to as Wilson score interval.+ # build ARD ------------------------------------------------------------------ |
||
| 68 | -+ | 5x |
- #'+ ret <- |
| 69 | -+ | 5x |
- #' \deqn{\frac{\hat{p} +
+ cards::tidy_as_ard( |
| 70 | -+ | 5x |
- #' \frac{z^2_{\alpha/2}}{2n} \pm z_{\alpha/2} \sqrt{\frac{\hat{p}(1 - \hat{p})}{n} +
+ lst_tidy = lst_tidy, |
| 71 | -+ | 5x |
- #' \frac{z^2_{\alpha/2}}{4n^2}}}{1 + \frac{z^2_{\alpha/2}}{n}}}
+ tidy_result_names = c( |
| 72 | -+ | 5x |
- #'+ "estimate", "statistic", |
| 73 | -+ | 5x |
- #' @export+ "p.value", "parameter", |
| 74 | -+ | 5x |
- proportion_ci_wilson <- function(x, conf.level = 0.95, correct = FALSE) {
+ "conf.low", "conf.high", |
| 75 | 5x |
- set_cli_abort_call()+ "conf.level", "method", "alternative" |
|
| 76 |
-
+ ), |
||
| 77 | -+ | 5x |
- # check installed packages ---------------------------------------------------+ passed_args = dots_list(...), |
| 78 | 5x |
- check_pkg_installed(pkg = "broom", reference_pkg = "cardx")+ lst_ard_columns = list(group1 = by, variable = variable, context = "survey_svyttest") |
|
| 79 |
-
+ ) |
||
| 80 |
- # check inputs ---------------------------------------------------------------+ |
||
| 81 | -5x | +
- check_not_missing(x)+ # add the stat label --------------------------------------------------------- |
|
| 82 | 5x |
- check_binary(x)+ ret |> |
|
| 83 | 5x |
- check_class(x = correct, "logical")+ dplyr::left_join( |
|
| 84 | 5x |
- check_scalar(correct)+ .df_ttest_stat_labels(), |
|
| 85 | 5x |
- check_range(conf.level, range = c(0, 1), include_bounds = c(FALSE, FALSE))+ by = "stat_name" |
|
| 86 | -5x | +
- check_scalar(conf.level)+ ) |> |
|
| 87 | -+ | 5x |
-
+ dplyr::mutate(stat_label = dplyr::coalesce(.data$stat_label, .data$stat_name)) |> |
| 88 | 5x |
- x <- stats::na.omit(x)+ cards::tidy_ard_column_order() |
|
| 89 |
-
+ } |
||
| 90 | -5x | +
| 1 | +
- n <- length(x)+ #' ARD ANOVA |
|||
| 91 | -5x | +|||
| 2 | +
- y <- stats::prop.test(x = sum(x), n = n, correct = correct, conf.level = conf.level)+ #' |
|||
| 92 | +3 |
-
+ #' Prepare ANOVA results from the `stats::anova()` function. |
||
| 93 | -5x | +|||
| 4 | +
- list(N = n, conf.level = conf.level) |>+ #' Users may pass a pre-calculated `stats::anova()` object or a list of |
|||
| 94 | -5x | +|||
| 5 | +
- utils::modifyList(val = broom::tidy(y) |> as.list()) |>+ #' formulas. In the latter case, the models will be constructed using the |
|||
| 95 | -5x | +|||
| 6 | +
- utils::modifyList(+ #' information passed and models will be passed to `stats::anova()`. |
|||
| 96 | -5x | +|||
| 7 | +
- list(+ #' |
|||
| 97 | -5x | +|||
| 8 | +
- method =+ #' @param x (`anova` or `data.frame`)\cr |
|||
| 98 | -5x | +|||
| 9 | +
- glue::glue("Wilson Confidence Interval {ifelse(correct, 'with', 'without')} continuity correction")
+ #' an object of class `'anova'` created with `stats::anova()` or |
|||
| 99 | +10 |
- )+ #' a data frame |
||
| 100 | +11 |
- )+ #' @param formulas (`list`)\cr |
||
| 101 | +12 |
- }+ #' a list of formulas |
||
| 102 | +13 |
-
+ #' @param method_text (`string`)\cr |
||
| 103 | +14 |
- #' @describeIn proportion_ci Calculates the Clopper-Pearson interval by calling [stats::binom.test()].+ #' string of the method used. Default is `"ANOVA results from `stats::anova()`"`. |
||
| 104 | +15 |
- #' Also referred to as the `exact` method.+ #' We provide the option to change this as `stats::anova()` can produce |
||
| 105 | +16 |
- #'+ #' results from many types of models that may warrant a more precise |
||
| 106 | +17 |
- #' \deqn{
+ #' description. |
||
| 107 | +18 |
- #' \left( \frac{k}{n} \pm z_{\alpha/2} \sqrt{\frac{\frac{k}{n}(1-\frac{k}{n})}{n} +
+ #' @inheritParams rlang::args_dots_empty |
||
| 108 | +19 |
- #' \frac{z^2_{\alpha/2}}{4n^2}} \right)
+ #' @inheritParams construction_helpers |
||
| 109 | +20 |
- #' / \left( 1 + \frac{z^2_{\alpha/2}}{n} \right)}
+ #' |
||
| 110 | +21 |
- #'+ #' @details |
||
| 111 | +22 |
- #' @export+ #' When a list of formulas is supplied to `ard_stats_anova()`, these formulas |
||
| 112 | +23 |
- proportion_ci_clopper_pearson <- function(x, conf.level = 0.95) {
+ #' along with information from other arguments, are used to construct models |
||
| 113 | -2x | +|||
| 24 | +
- set_cli_abort_call()+ #' and pass those models to `stats::anova()`. |
|||
| 114 | +25 |
-
+ #' |
||
| 115 | +26 |
- # check installed packages ---------------------------------------------------+ #' The models are constructed using `rlang::exec()`, which is similar to `do.call()`. |
||
| 116 | -2x | +|||
| 27 | +
- check_pkg_installed(pkg = "broom", reference_pkg = "cardx")+ #' |
|||
| 117 | +28 |
-
+ #' ```r |
||
| 118 | +29 |
- # check inputs ---------------------------------------------------------------+ #' rlang::exec(.fn = method, formula = formula, data = data, !!!method.args) |
||
| 119 | -2x | +|||
| 30 | +
- check_not_missing(x)+ #' ``` |
|||
| 120 | -2x | +|||
| 31 | +
- check_binary(x)+ #' |
|||
| 121 | -2x | +|||
| 32 | +
- check_range(conf.level, range = c(0, 1), include_bounds = c(FALSE, FALSE))+ #' The above function is executed in `withr::with_namespace(package)`, which |
|||
| 122 | -2x | +|||
| 33 | +
- check_scalar(conf.level)+ #' allows for the use of `ard_stats_anova(method)` from packages, |
|||
| 123 | +34 |
-
+ #' e.g. `package = 'lme4'` must be specified when `method = 'glmer'`. |
||
| 124 | -2x | +|||
| 35 | +
- x <- stats::na.omit(x)+ #' See example below. |
|||
| 125 | -2x | +|||
| 36 | +
- n <- length(x)+ #' |
|||
| 126 | +37 |
-
+ #' @return ARD data frame |
||
| 127 | -2x | +|||
| 38 | +
- y <- stats::binom.test(x = sum(x), n = n, conf.level = conf.level)+ #' @name ard_stats_anova |
|||
| 128 | +39 |
-
+ #' |
||
| 129 | -2x | +|||
| 40 | +
- list(N = n, conf.level = conf.level) |>+ #' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = c("broom", "withr", "lme4"), reference_pkg = "cardx"))
|
|||
| 130 | -2x | +|||
| 41 | +
- utils::modifyList(val = broom::tidy(y) |> as.list()) |>+ #' anova( |
|||
| 131 | -2x | +|||
| 42 | +
- utils::modifyList(list(method = "Clopper-Pearson Confidence Interval"))+ #' lm(mpg ~ am, mtcars), |
|||
| 132 | +43 |
- }+ #' lm(mpg ~ am + hp, mtcars) |
||
| 133 | +44 |
-
+ #' ) |> |
||
| 134 | +45 |
- #' @describeIn proportion_ci Calculates the `Agresti-Coull` interval (created by `Alan Agresti` and `Brent Coull`) by+ #' ard_stats_anova() |
||
| 135 | +46 |
- #' (for 95% CI) adding two successes and two failures to the data and then using the Wald formula to construct a CI.+ #' |
||
| 136 | +47 |
- #'+ #' ard_stats_anova( |
||
| 137 | +48 |
- #' \deqn{
+ #' x = mtcars, |
||
| 138 | +49 |
- #' \left( \frac{\tilde{p} + z^2_{\alpha/2}/2}{n + z^2_{\alpha/2}} \pm
+ #' formulas = list(am ~ mpg, am ~ mpg + hp), |
||
| 139 | +50 |
- #' z_{\alpha/2} \sqrt{\frac{\tilde{p}(1 - \tilde{p})}{n} +
+ #' method = "glm", |
||
| 140 | +51 |
- #' \frac{z^2_{\alpha/2}}{4n^2}} \right)}
+ #' method.args = list(family = binomial) |
||
| 141 | +52 |
- #'+ #' ) |
||
| 142 | +53 |
- #' @export+ #' |
||
| 143 | +54 |
- proportion_ci_agresti_coull <- function(x, conf.level = 0.95) {
+ #' ard_stats_anova( |
||
| 144 | -2x | +|||
| 55 | +
- set_cli_abort_call()+ #' x = mtcars, |
|||
| 145 | +56 |
-
+ #' formulas = list(am ~ 1 + (1 | vs), am ~ mpg + (1 | vs)), |
||
| 146 | +57 |
- # check inputs ---------------------------------------------------------------+ #' method = "glmer", |
||
| 147 | -2x | +|||
| 58 | +
- check_not_missing(x)+ #' method.args = list(family = binomial), |
|||
| 148 | -2x | +|||
| 59 | +
- check_binary(x)+ #' package = "lme4" |
|||
| 149 | -2x | +|||
| 60 | +
- check_range(conf.level, range = c(0, 1), include_bounds = c(FALSE, FALSE))+ #' ) |
|||
| 150 | -2x | +|||
| 61 | +
- check_scalar(conf.level)+ NULL |
|||
| 151 | +62 | |||
| 152 | -2x | +|||
| 63 | +
- x <- stats::na.omit(x)+ #' @rdname ard_stats_anova |
|||
| 153 | +64 |
-
+ #' @export |
||
| 154 | -2x | +|||
| 65 | +
- n <- length(x)+ ard_stats_anova <- function(x, ...) {
|
|||
| 155 | -2x | +66 | +8x |
- x_sum <- sum(x)+ UseMethod("ard_stats_anova")
|
| 156 | -2x | +|||
| 67 | +
- z <- stats::qnorm((1 + conf.level) / 2)+ } |
|||
| 157 | +68 | |||
| 158 | +69 |
- # Add here both z^2 / 2 successes and failures.+ #' @rdname ard_stats_anova |
||
| 159 | -2x | +|||
| 70 | +
- x_sum_tilde <- x_sum + z^2 / 2+ #' @export+ |
+ |||
| 71 | ++ |
+ ard_stats_anova.anova <- function(x, method_text = "ANOVA results from `stats::anova()`", ...) {
|
||
| 160 | +72 | 2x |
- n_tilde <- n + z^2+ set_cli_abort_call() |
|
| 161 | +73 | |||
| 162 | +74 |
- # Then proceed as with the Wald interval.- |
- ||
| 163 | -2x | -
- p_tilde <- x_sum_tilde / n_tilde+ # check inputs --------------------------------------------------------------- |
||
| 164 | +75 | 2x |
- q_tilde <- 1 - p_tilde+ check_dots_empty() |
|
| 165 | +76 | 2x |
- err <- z * sqrt(p_tilde * q_tilde) / sqrt(n_tilde)+ check_pkg_installed("broom", reference_pkg = "cardx")
|
|
| 166 | +77 | 2x |
- l_ci <- max(0, p_tilde - err)+ check_string(method_text) |
|
| 167 | -2x | +|||
| 78 | +
- u_ci <- min(1, p_tilde + err)+ |
|||
| 168 | +79 |
-
+ # return df in cards formats ------------------------------------------------- |
||
| 169 | +80 | 2x |
- list(+ lst_results <- |
|
| 170 | +81 | 2x |
- N = n,+ cards::eval_capture_conditions( |
|
| 171 | +82 | 2x |
- estimate = mean(x),+ .anova_tidy_and_reshape(x, method_text = method_text) |
|
| 172 | -2x | +|||
| 83 | +
- conf.low = l_ci,+ ) |
|||
| 173 | -2x | +|||
| 84 | +
- conf.high = u_ci,+ |
|||
| 174 | -2x | +|||
| 85 | +
- conf.level = conf.level,+ # final tidying up of cards data frame --------------------------------------- |
|||
| 175 | +86 | 2x |
- method = "Agresti-Coull Confidence Interval"+ .anova_final_ard_prep(lst_results, method_text = method_text) |
|
| 176 | +87 |
- )+ } |
||
| 177 | +88 |
- }+ |
||
| 178 | +89 | |||
| 179 | +90 |
- #' @describeIn proportion_ci Calculates the Jeffreys interval, an equal-tailed interval based on the+ #' @rdname ard_stats_anova |
||
| 180 | +91 |
- #' non-informative Jeffreys prior for a binomial proportion.+ #' @export |
||
| 181 | +92 |
- #'+ ard_stats_anova.data.frame <- function(x, |
||
| 182 | +93 |
- #' \deqn{\left( \text{Beta}\left(\frac{k}{2} + \frac{1}{2}, \frac{n - k}{2} + \frac{1}{2}\right)_\alpha,
+ formulas, |
||
| 183 | +94 |
- #' \text{Beta}\left(\frac{k}{2} + \frac{1}{2}, \frac{n - k}{2} + \frac{1}{2}\right)_{1-\alpha} \right)}
+ method, |
||
| 184 | +95 |
- #'+ method.args = list(), |
||
| 185 | +96 |
- #' @export+ package = "base", |
||
| 186 | +97 |
- proportion_ci_jeffreys <- function(x, conf.level = 0.95) {
+ method_text = "ANOVA results from `stats::anova()`",+ |
+ ||
| 98 | ++ |
+ ...) {
|
||
| 187 | -3x | +99 | +6x |
set_cli_abort_call() |
| 188 | +100 | |||
| 189 | +101 |
# check inputs --------------------------------------------------------------- |
||
| 190 | -3x | +102 | +6x |
- check_not_missing(x)+ check_dots_empty() |
| 191 | -3x | +103 | +6x |
- check_binary(x)+ check_pkg_installed(c("broom", "withr", package), reference_pkg = "cardx")
|
| 192 | -3x | +104 | +6x |
- check_range(conf.level, range = c(0, 1), include_bounds = c(FALSE, FALSE))+ check_not_missing(formulas) |
| 193 | -3x | +105 | +6x |
- check_scalar(conf.level)+ check_class(formulas, cls = "list") |
| 194 | -3x | -
- x <- stats::na.omit(x)- |
- ||
| 195 | -+ | 106 | +6x |
-
+ walk( |
| 196 | -3x | +107 | +6x |
- n <- length(x)+ formulas, |
| 197 | -3x | -
- x_sum <- sum(x)- |
- ||
| 198 | -+ | 108 | +6x |
-
+ ~ check_class( |
| 199 | -3x | +109 | +6x |
- alpha <- 1 - conf.level+ .x, |
| 200 | -3x | +110 | +6x |
- l_ci <- ifelse(+ cls = "formula", |
| 201 | -3x | +111 | +6x |
- x_sum == 0,+ arg_name = "formulas", |
| 202 | -3x | +112 | +6x |
- 0,+ message = "Each element of {.arg formulas} must be class {.cls formula}"
|
| 203 | -3x | +|||
| 113 | +
- stats::qbeta(alpha / 2, x_sum + 0.5, n - x_sum + 0.5)+ ) |
|||
| 204 | +114 |
) |
||
| 205 | +115 | |||
| 206 | -3x | +|||
| 116 | +
- u_ci <- ifelse(+ # calculate results and return df in cards formats --------------------------- |
|||
| 207 | -3x | +|||
| 117 | +
- x_sum == n,+ # create models |
|||
| 208 | -3x | +118 | +6x |
- 1,+ lst_results <- |
| 209 | -3x | -
- stats::qbeta(1 - alpha / 2, x_sum + 0.5, n - x_sum + 0.5)- |
- ||
| 210 | -+ | 119 | +6x |
- )+ cards::eval_capture_conditions({
|
| 211 | +120 |
-
+ # first build the models |
||
| 212 | -3x | +121 | +6x |
- list(+ models <- |
| 213 | -3x | +122 | +6x |
- N = n,+ lapply( |
| 214 | -3x | +123 | +6x |
- estimate = mean(x),+ formulas, |
| 215 | -3x | +124 | +6x |
- conf.low = l_ci,+ function(formula) {
|
| 216 | -3x | -
- conf.high = u_ci,- |
- ||
| 217 | -3x | -
- conf.level = conf.level,- |
- ||
| 218 | -3x | -
- method = glue::glue("Jeffreys Interval")
- |
- ||
| 219 | -+ | 125 | +11x |
- )+ construct_model(data = x, formula = formula, method = method, method.args = {{ method.args }}, package = package)
|
| 220 | +126 |
- }+ } |
||
| 221 | +127 |
-
+ ) |
||
| 222 | +128 | |||
| 223 | -- |
- #' @describeIn proportion_ci Calculates the stratified Wilson confidence- |
- ||
| 224 | +129 |
- #' interval for unequal proportions as described in+ # now calculate `stats::anova()` and reshape results |
||
| 225 | -+ | |||
| 130 | +5x |
- #' Xin YA, Su XG. Stratified Wilson and Newcombe confidence intervals+ rlang::inject(stats::anova(!!!models)) |> |
||
| 226 | -+ | |||
| 131 | +5x |
- #' for multiple binomial proportions. _Statistics in Biopharmaceutical Research_. 2010;2(3).+ .anova_tidy_and_reshape(method_text = method_text) |
||
| 227 | +132 |
- #'+ }) |
||
| 228 | +133 |
- #' \deqn{\frac{\hat{p}_j + \frac{z^2_{\alpha/2}}{2n_j} \pm
+
|
||
| 229 | +134 |
- #' z_{\alpha/2} \sqrt{\frac{\hat{p}_j(1 - \hat{p}_j)}{n_j} +
+ # final tidying up of cards data frame --------------------------------------- |
||
| 230 | -+ | |||
| 135 | +6x |
- #' \frac{z^2_{\alpha/2}}{4n_j^2}}}{1 + \frac{z^2_{\alpha/2}}{n_j}}}
+ .anova_final_ard_prep(lst_results, method_text = method_text) |
||
| 231 | +136 |
- #'+ } |
||
| 232 | +137 |
- #'+ |
||
| 233 | +138 |
- #' @param strata (`factor`)\cr variable with one level per stratum and same length as `x`.+ .anova_tidy_and_reshape <- function(x, method_text) {
|
||
| 234 | -+ | |||
| 139 | +7x |
- #' @param weights (`numeric` or `NULL`)\cr weights for each level of the strata. If `NULL`, they are+ broom::tidy(x) |> |
||
| 235 | -+ | |||
| 140 | +7x |
- #' estimated using the iterative algorithm that+ dplyr::mutate( |
||
| 236 | -+ | |||
| 141 | +7x |
- #' minimizes the weighted squared length of the confidence interval.+ across(everything(), as.list), |
||
| 237 | -+ | |||
| 142 | +7x |
- #' @param max.iterations (`count`)\cr maximum number of iterations for the iterative procedure used+ variable = paste0("model_", dplyr::row_number())
|
||
| 238 | +143 |
- #' to find estimates of optimal weights.+ ) |> |
||
| 239 | -+ | |||
| 144 | +7x |
- #' @param correct (`flag`)\cr include the continuity correction. For further information, see for example+ tidyr::pivot_longer( |
||
| 240 | -+ | |||
| 145 | +7x |
- #' [stats::prop.test()].+ cols = -"variable", |
||
| 241 | -+ | |||
| 146 | +7x |
- #'+ names_to = "stat_name", |
||
| 242 | -+ | |||
| 147 | +7x |
- #' @examples+ values_to = "stat" |
||
| 243 | +148 |
- #' # Stratified Wilson confidence interval with unequal probabilities+ ) |> |
||
| 244 | -+ | |||
| 149 | +7x |
- #'+ dplyr::filter(!is.na(.data$stat)) %>% |
||
| 245 | +150 |
- #' set.seed(1)+ # add one more row with the method |
||
| 246 | +151 |
- #' rsp <- sample(c(TRUE, FALSE), 100, TRUE)+ {
|
||
| 247 | -+ | |||
| 152 | +7x |
- #' strata_data <- data.frame(+ dplyr::bind_rows( |
||
| 248 | +153 |
- #' "f1" = sample(c("a", "b"), 100, TRUE),
+ ., |
||
| 249 | -+ | |||
| 154 | +7x |
- #' "f2" = sample(c("x", "y", "z"), 100, TRUE),
+ dplyr::filter(., dplyr::n() == dplyr::row_number()) |> |
||
| 250 | -+ | |||
| 155 | +7x |
- #' stringsAsFactors = TRUE+ dplyr::mutate( |
||
| 251 | -+ | |||
| 156 | +7x |
- #' )+ stat_name = "method", |
||
| 252 | -+ | |||
| 157 | +7x |
- #' strata <- interaction(strata_data)+ stat = list(.env$method_text) |
||
| 253 | +158 |
- #' n_strata <- ncol(table(rsp, strata)) # Number of strata+ ) |
||
| 254 | +159 |
- #'+ ) |
||
| 255 | +160 |
- #' proportion_ci_strat_wilson(+ } |
||
| 256 | +161 |
- #' x = rsp, strata = strata,+ } |
||
| 257 | +162 |
- #' conf.level = 0.90+ |
||
| 258 | +163 |
- #' )+ .anova_final_ard_prep <- function(lst_results, method_text) {
|
||
| 259 | +164 |
- #'+ # saving the results in data frame ------------------------------------------- |
||
| 260 | -+ | |||
| 165 | +8x |
- #' # Not automatic setting of weights+ df_card <- |
||
| 261 | -+ | |||
| 166 | +8x |
- #' proportion_ci_strat_wilson(+ if (!is.null(lst_results[["result"]])) {
|
||
| 262 | -+ | |||
| 167 | +7x |
- #' x = rsp, strata = strata,+ lst_results[["result"]] |
||
| 263 | -+ | |||
| 168 | +8x |
- #' weights = rep(1 / n_strata, n_strata),+ } else { # if there was an error return a shell of an ARD data frame
|
||
| 264 | -+ | |||
| 169 | +1x |
- #' conf.level = 0.90+ dplyr::tibble( |
||
| 265 | -+ | |||
| 170 | +1x |
- #' )+ variable = "model_1", |
||
| 266 | -+ | |||
| 171 | +1x |
- #'+ stat_name = c("p.value", "method"),
|
||
| 267 | -+ | |||
| 172 | +1x |
- #' @export+ stat = list(NULL, method_text) |
||
| 268 | +173 |
- proportion_ci_strat_wilson <- function(x,+ ) |
||
| 269 | +174 |
- strata,+ } |
||
| 270 | +175 |
- weights = NULL,+ |
||
| 271 | +176 |
- conf.level = 0.95,+ # final tidying up of cards data frame --------------------------------------- |
||
| 272 | -+ | |||
| 177 | +8x |
- max.iterations = 10L,+ df_card |> |
||
| 273 | -+ | |||
| 178 | +8x |
- correct = FALSE) {
+ dplyr::mutate( |
||
| 274 | -2x | +179 | +8x |
- set_cli_abort_call()+ warning = lst_results["warning"], |
| 275 | -+ | |||
| 180 | +8x |
-
+ error = lst_results["error"], |
||
| 276 | -+ | |||
| 181 | +8x |
- # check inputs ---------------------------------------------------------------+ context = "stats_anova", |
||
| 277 | -2x | +182 | +8x |
- check_not_missing(x)+ fmt_fn = lapply( |
| 278 | -2x | +183 | +8x |
- check_not_missing(strata)+ .data$stat, |
| 279 | -2x | +184 | +8x |
- check_binary(x)+ function(x) {
|
| 280 | -2x | +185 | +77x |
- check_class(correct, "logical")+ switch(is.integer(x), |
| 281 | -2x | +186 | +77x |
- check_scalar(correct)+ 0L |
| 282 | -2x | +187 | +77x |
- check_class(strata, "factor")+ ) %||% switch(is.numeric(x), |
| 283 | -2x | +188 | +77x |
- check_range(conf.level, range = c(0, 1), include_bounds = c(FALSE, FALSE))+ 1L |
| 284 | -2x | +|||
| 189 | +
- check_scalar(conf.level)+ ) |
|||
| 285 | +190 |
-
+ } |
||
| 286 | +191 |
- # remove missing values from x and strata+ ), |
||
| 287 | -2x | +192 | +8x |
- is_na <- is.na(x) | is.na(strata)+ stat_label = |
| 288 | -2x | +193 | +8x |
- x <- x[!is_na]+ dplyr::case_when( |
| 289 | -2x | +194 | +8x |
- strata <- strata[!is_na]+ .data$stat_name %in% "p.value" ~ "p-value", |
| 290 | -! | +|||
| 195 | +8x |
- if (!inherits(x, "logical")) x <- as.logical(x)+ .data$stat_name %in% "sumsq" ~ "Sum of Squares", |
||
| 291 | -+ | |||
| 196 | +8x |
- # check all TRUE/FALSE, if so, not calculable+ .data$stat_name %in% "rss" ~ "Residual Sum of Squares", |
||
| 292 | -2x | +197 | +8x |
- if (all(x) || all(!x)) {
+ .data$stat_name %in% "df" ~ "Degrees of Freedom", |
| 293 | -! | +|||
| 198 | +8x |
- cli::cli_abort("All values in {.arg x} argument are either {.code TRUE} or {.code FALSE} and CI is not estimable.")
+ .data$stat_name %in% "df.residual" ~ "df for residuals",+ |
+ ||
| 199 | +8x | +
+ .default = .data$stat_name |
||
| 294 | +200 |
- }+ ) |
||
| 295 | +201 |
-
+ ) |> |
||
| 296 | -2x | +202 | +8x |
- tbl <- table(factor(x, levels = c(FALSE, TRUE)), strata, useNA = "no")+ cards::tidy_ard_column_order() %>% |
| 297 | -2x | +203 | +8x |
- n_strata <- length(unique(strata))+ {structure(., class = c("card", class(.)))} # styler: off
|
| 298 | +204 |
-
+ } |
||
| 299 | +
| 1 |
- # Checking the weights and maximum number of iterations.- |
- |||
| 300 | -2x | -
- do_iter <- FALSE+ #' ARD Proportion Confidence Intervals |
||
| 301 | -2x | +|||
| 2 | +
- if (is.null(weights)) {
+ #' |
|||
| 302 | -! | +|||
| 3 | +
- weights <- rep(1 / n_strata, n_strata) # Initialization for iterative procedure+ #' `r lifecycle::badge('experimental')`\cr
|
|||
| 303 | -! | +|||
| 4 | +
- do_iter <- TRUE+ #' Calculate confidence intervals for proportions. |
|||
| 304 | +5 |
-
+ #' |
||
| 305 | +6 |
- # Iteration parameters+ #' @inheritParams cards::ard_categorical |
||
| 306 | -! | +|||
| 7 | +
- if (!is_scalar_integerish(max.iterations) || max.iterations < 1) {
+ #' @param variables ([`tidy-select`][dplyr::dplyr_tidy_select])\cr |
|||
| 307 | -! | +|||
| 8 | +
- cli::cli_abort("Argument {.arg max.iterations} must be a positive integer.")
+ #' columns to include in summaries. Columns must be class `<logical>` |
|||
| 308 | +9 |
- }+ #' or `<numeric>` values coded as `c(0, 1)`. |
||
| 309 | +10 |
- }+ #' @param by ([`tidy-select`][dplyr::dplyr_tidy_select])\cr |
||
| 310 | -2x | +|||
| 11 | +
- check_range(weights, range = c(0, 1), include_bounds = c(TRUE, TRUE))+ #' columns to stratify calculations by |
|||
| 311 | -2x | +|||
| 12 | +
- sum_weights <- sum(weights) |>+ #' @param conf.level (`numeric`)\cr |
|||
| 312 | -2x | +|||
| 13 | +
- round() |>+ #' a scalar in `(0, 1)` indicating the confidence level. |
|||
| 313 | -2x | +|||
| 14 | +
- as.integer()+ #' Default is `0.95` |
|||
| 314 | -2x | +|||
| 15 | +
- if (sum_weights != 1L || abs(sum_weights - sum(weights)) > sqrt(.Machine$double.eps)) {
+ #' @param method (`string`)\cr |
|||
| 315 | -! | +|||
| 16 | +
- cli::cli_abort("The sum of the {.arg weights} argument must be {.val {1L}}")
+ #' string indicating the type of confidence interval to calculate. |
|||
| 316 | +17 |
- }+ #' Must be one of `r formals(ard_proportion_ci)[["method"]] |> eval() |> shQuote("sh")`.
|
||
| 317 | +18 |
-
+ #' See `?proportion_ci` for details. |
||
| 318 | -2x | +|||
| 19 | +
- xs <- tbl["TRUE", ]+ #' @param strata,weights,max.iterations arguments passed to `proportion_ci_strat_wilson()`, |
|||
| 319 | -2x | +|||
| 20 | +
- ns <- colSums(tbl)+ #' when `method='strat_wilson'` |
|||
| 320 | -2x | +|||
| 21 | +
- use_stratum <- (ns > 0)+ #' @param value ([`formula-list-selector`][syntax])\cr |
|||
| 321 | -2x | +|||
| 22 | +
- ns <- ns[use_stratum]+ #' function will calculate the CIs for all levels of the variables specified. |
|||
| 322 | -2x | +|||
| 23 | +
- xs <- xs[use_stratum]+ #' Use this argument to instead request only a single level by summarized. |
|||
| 323 | -2x | +|||
| 24 | +
- ests <- xs / ns+ #' Default is `list(where(is_binary) ~ 1L, where(is.logical) ~ TRUE)`, where |
|||
| 324 | -2x | +|||
| 25 | +
- vars <- ests * (1 - ests) / ns+ #' columns coded as `0`/`1` and `TRUE`/`FALSE` will summarize the `1` and `TRUE` levels. |
|||
| 325 | +26 |
-
+ #' |
||
| 326 | -2x | +|||
| 27 | +
- strata_qnorm <- .strata_normal_quantile(vars, weights, conf.level)+ #' @return an ARD data frame |
|||
| 327 | +28 |
-
+ #' @export |
||
| 328 | +29 |
- # Iterative setting of weights if they were not passed in `weights` argument+ #' |
||
| 329 | -2x | +|||
| 30 | +
- weights_new <- if (do_iter) {
+ #' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = "broom", reference_pkg = "cardx"))
|
|||
| 330 | -! | +|||
| 31 | +
- .update_weights_strat_wilson(vars, strata_qnorm, weights, ns, max.iterations, conf.level)$weights+ #' # compute CI for binary variables |
|||
| 331 | +32 |
- } else {
+ #' ard_proportion_ci(mtcars, variables = c(vs, am), method = "wilson") |
||
| 332 | -2x | +|||
| 33 | +
- weights+ #' |
|||
| 333 | +34 |
- }+ #' # compute CIs for each level of a categorical variable |
||
| 334 | +35 |
-
+ #' ard_proportion_ci(mtcars, variables = cyl, method = "jeffreys") |
||
| 335 | -2x | +|||
| 36 | +
- strata_conf.level <- 2 * stats::pnorm(strata_qnorm) - 1+ ard_proportion_ci <- function(data, |
|||
| 336 | +37 |
-
+ variables, |
||
| 337 | -2x | +|||
| 38 | +
- ci_by_strata <- Map(+ by = dplyr::group_vars(data), |
|||
| 338 | -2x | +|||
| 39 | +
- function(x, n) {
+ method = c( |
|||
| 339 | +40 |
- # Classic Wilson's confidence interval+ "waldcc", "wald", "clopper-pearson", |
||
| 340 | -12x | +|||
| 41 | +
- suppressWarnings(stats::prop.test(x, n, correct = correct, conf.level = strata_conf.level)$conf.int)+ "wilson", "wilsoncc", |
|||
| 341 | +42 |
- },+ "strat_wilson", "strat_wilsoncc", |
||
| 342 | -2x | +|||
| 43 | +
- x = xs,+ "agresti-coull", "jeffreys" |
|||
| 343 | -2x | +|||
| 44 | +
- n = ns+ ), |
|||
| 344 | +45 |
- )+ conf.level = 0.95, |
||
| 345 | -2x | +|||
| 46 | +
- lower_by_strata <- sapply(ci_by_strata, "[", 1L)+ value = list(where(is_binary) ~ 1L, where(is.logical) ~ TRUE), |
|||
| 346 | -2x | +|||
| 47 | +
- upper_by_strata <- sapply(ci_by_strata, "[", 2L)+ strata = NULL, |
|||
| 347 | +48 |
-
+ weights = NULL, |
||
| 348 | -2x | +|||
| 49 | +
- lower <- sum(weights_new * lower_by_strata)+ max.iterations = 10) {
|
|||
| 349 | -2x | +50 | +10x |
- upper <- sum(weights_new * upper_by_strata)+ set_cli_abort_call() |
| 350 | +51 | |||
| 351 | +52 |
- # Return values+ # check installed packages --------------------------------------------------- |
||
| 352 | -2x | +53 | +10x |
- list(+ check_pkg_installed(pkg = "broom", reference_pkg = "cardx") |
| 353 | -2x | +|||
| 54 | +
- N = length(x),+ |
|||
| 354 | -2x | +|||
| 55 | +
- estimate = mean(x),+ # process inputs ------------------------------------------------------------- |
|||
| 355 | -2x | +56 | +10x |
- conf.low = lower,+ cards::process_selectors(data, variables = {{ variables }}, by = {{ by }})
|
| 356 | -2x | +57 | +10x |
- conf.high = upper,+ method <- arg_match(method) |
| 357 | -2x | +58 | +10x |
- conf.level = conf.level,+ if (method %in% c("strat_wilson", "strat_wilsoncc")) {
|
| 358 | -2x | +59 | +1x |
- weights = if (do_iter) weights_new else NULL,+ cards::process_selectors(data, strata = strata) |
| 359 | -2x | +60 | +1x |
- method =+ check_scalar(strata) |
| 360 | -2x | +|||
| 61 | +
- glue::glue("Stratified Wilson Confidence Interval {ifelse(correct, 'with', 'without')} continuity correction")
+ } |
|||
| 361 | -+ | |||
| 62 | +10x |
- ) |>+ cards::process_formula_selectors( |
||
| 362 | -2x | +63 | +10x |
- compact()+ data[variables], |
| 363 | -+ | |||
| 64 | +10x |
- }+ value = value |
||
| 364 | +65 |
-
+ ) |
||
| 365 | +66 |
- #' @describeIn proportion_ci Helper to determine if vector is binary (logical or 0/1)+ |
||
| 366 | +67 |
- #'+ # calculate confidence intervals --------------------------------------------- |
||
| 367 | -+ | |||
| 68 | +10x |
- #' @export+ map( |
||
| 368 | -+ | |||
| 69 | +10x |
- is_binary <- function(x) {
+ variables, |
||
| 369 | -16x | +70 | +10x |
- is.logical(x) || (is_integerish(x) && is_empty(setdiff(x, c(0, 1, NA))))+ function(variable) {
|
| 370 | -+ | |||
| 71 | +17x |
- }+ levels <- .unique_values_sort(data, variable = variable, value = value[[variable]]) |
||
| 371 | +72 | |||
| 372 | -+ | |||
| 73 | +17x |
- #' Helper Function for the Estimation of Stratified Quantiles+ .calculate_ard_proportion( |
||
| 373 | -+ | |||
| 74 | +17x |
- #'+ data = .as_dummy(data, variable = variable, levels = levels, by = by, strata = strata), |
||
| 374 | -+ | |||
| 75 | +17x |
- #' This function wraps the estimation of stratified percentiles when we assume+ variables = c(everything(), -all_of(c(by, strata))), |
||
| 375 | -+ | |||
| 76 | +17x |
- #' the approximation for large numbers. This is necessary only in the case+ by = all_of(by), |
||
| 376 | -+ | |||
| 77 | +17x |
- #' proportions for each strata are unequal.+ method = method, |
||
| 377 | -+ | |||
| 78 | +17x |
- #'+ conf.level = conf.level, |
||
| 378 | -+ | |||
| 79 | +17x |
- #' @inheritParams proportion_ci_strat_wilson+ strata = strata, |
||
| 379 | -+ | |||
| 80 | +17x |
- #'+ weights = weights, |
||
| 380 | -+ | |||
| 81 | +17x |
- #' @return Stratified quantile.+ max.iterations = max.iterations |
||
| 381 | +82 |
- #'+ ) %>% |
||
| 382 | +83 |
- #' @seealso [proportion_ci_strat_wilson()]+ # merge in the variable levels |
||
| 383 | -+ | |||
| 84 | +17x |
- #'+ dplyr::left_join( |
||
| 384 | -+ | |||
| 85 | +17x |
- #' @keywords internal+ dplyr::select(., "variable") |> |
||
| 385 | -+ | |||
| 86 | +17x |
- #'+ dplyr::distinct() |> |
||
| 386 | -+ | |||
| 87 | +17x |
- #' @examples+ dplyr::mutate(variable_level = as.list(.env$levels)), |
||
| 387 | -+ | |||
| 88 | +17x |
- #' strata_data <- table(data.frame(+ by = "variable" |
||
| 388 | +89 |
- #' "f1" = sample(c(TRUE, FALSE), 100, TRUE),+ ) |> |
||
| 389 | +90 |
- #' "f2" = sample(c("x", "y", "z"), 100, TRUE),
+ # rename variable column |
||
| 390 | -+ | |||
| 91 | +17x |
- #' stringsAsFactors = TRUE+ dplyr::mutate(variable = .env$variable) |> |
||
| 391 | -+ | |||
| 92 | +17x |
- #' ))+ dplyr::relocate("variable_level", .after = "variable")
|
||
| 392 | +93 |
- #' ns <- colSums(strata_data)+ } |
||
| 393 | +94 |
- #' ests <- strata_data["TRUE", ] / ns+ ) |> |
||
| 394 | -+ | |||
| 95 | +10x |
- #' vars <- ests * (1 - ests) / ns+ dplyr::bind_rows() |
||
| 395 | +96 |
- #' weights <- rep(1 / length(ns), length(ns))+ } |
||
| 396 | +97 |
- #'+ |
||
| 397 | +98 |
- #' cardx:::.strata_normal_quantile(vars, weights, 0.95)+ .calculate_ard_proportion <- function(data, variables, by, method, conf.level, strata, weights, max.iterations) {
|
||
| 398 | -+ | |||
| 99 | +17x |
- .strata_normal_quantile <- function(vars, weights, conf.level) {
+ cards::ard_complex( |
||
| 399 | -2x | +100 | +17x |
- summands <- weights^2 * vars+ data = data, |
| 400 | -+ | |||
| 101 | +17x |
- # Stratified quantile+ variables = {{ variables }},
|
||
| 401 | -2x | +102 | +17x |
- sqrt(sum(summands)) / sum(sqrt(summands)) * stats::qnorm((1 + conf.level) / 2)+ by = {{ by }},
|
| 402 | -+ | |||
| 103 | +17x |
- }+ statistic = |
||
| 403 | -+ | |||
| 104 | +17x |
-
+ ~ list( |
||
| 404 | -+ | |||
| 105 | +17x |
- #' Helper Function for the Estimation of Weights for `proportion_ci_strat_wilson()`+ prop_ci = |
||
| 405 | -+ | |||
| 106 | +17x |
- #'+ switch(method, |
||
| 406 | -+ | |||
| 107 | +17x |
- #' This function wraps the iteration procedure that allows you to estimate+ "waldcc" = \(x, ...) proportion_ci_wald(x, conf.level = conf.level, correct = TRUE), |
||
| 407 | -+ | |||
| 108 | +17x |
- #' the weights for each proportional strata. This assumes to minimize the+ "wald" = \(x, ...) proportion_ci_wald(x, conf.level = conf.level, correct = FALSE), |
||
| 408 | -+ | |||
| 109 | +17x |
- #' weighted squared length of the confidence interval.+ "wilsoncc" = \(x, ...) proportion_ci_wilson(x, conf.level = conf.level, correct = TRUE), |
||
| 409 | -+ | |||
| 110 | +17x |
- #'+ "wilson" = \(x, ...) proportion_ci_wilson(x, conf.level = conf.level, correct = FALSE), |
||
| 410 | -+ | |||
| 111 | +17x |
- #' @keywords internal+ "clopper-pearson" = \(x, ...) proportion_ci_clopper_pearson(x, conf.level = conf.level), |
||
| 411 | -+ | |||
| 112 | +17x |
- #' @inheritParams proportion_ci_strat_wilson+ "agresti-coull" = \(x, ...) proportion_ci_agresti_coull(x, conf.level = conf.level), |
||
| 412 | -+ | |||
| 113 | +17x |
- #' @param vars (`numeric`)\cr normalized proportions for each strata.+ "jeffreys" = \(x, ...) proportion_ci_jeffreys(x, conf.level = conf.level), |
||
| 413 | -+ | |||
| 114 | +17x |
- #' @param strata_qnorm (`numeric`)\cr initial estimation with identical weights of the quantiles.+ "strat_wilsoncc" = \(x, data, ...) {
|
||
| 414 | -+ | |||
| 115 | +! |
- #' @param initial_weights (`numeric`)\cr initial weights used to calculate `strata_qnorm`. This can+ proportion_ci_strat_wilson(x, |
||
| 415 | -+ | |||
| 116 | +! |
- #' be optimized in the future if we need to estimate better initial weights.+ strata = data[[strata]], weights = weights, |
||
| 416 | -+ | |||
| 117 | +! |
- #' @param n_per_strata (`numeric`)\cr number of elements in each strata.+ max.iterations = max.iterations, |
||
| 417 | -+ | |||
| 118 | +! |
- #' @param max.iterations (`count`)\cr maximum number of iterations to be tried. Convergence is always checked.+ conf.level = conf.level, correct = TRUE |
||
| 418 | +119 |
- #' @param tol (`number`)\cr tolerance threshold for convergence.+ ) |
||
| 419 | +120 |
- #'+ }, |
||
| 420 | -+ | |||
| 121 | +17x |
- #' @return A `list` of 3 elements: `n_it`, `weights`, and `diff_v`.+ "strat_wilson" = \(x, data, ...) {
|
||
| 421 | -+ | |||
| 122 | +1x |
- #'+ proportion_ci_strat_wilson(x, |
||
| 422 | -+ | |||
| 123 | +1x |
- #' @seealso For references and details see [`proportion_ci_strat_wilson()`].+ strata = data[[strata]], weights = weights, |
||
| 423 | -+ | |||
| 124 | +1x |
- #'+ max.iterations = max.iterations, |
||
| 424 | -+ | |||
| 125 | +1x |
- #' @examples+ conf.level = conf.level, correct = FALSE |
||
| 425 | +126 |
- #' vs <- c(0.011, 0.013, 0.012, 0.014, 0.017, 0.018)+ ) |
||
| 426 | +127 |
- #' sq <- 0.674+ } |
||
| 427 | +128 |
- #' ws <- rep(1 / length(vs), length(vs))+ ) |
||
| 428 | +129 |
- #' ns <- c(22, 18, 17, 17, 14, 12)+ ) |
||
| 429 | +130 |
- #'+ ) |> |
||
| 430 | -+ | |||
| 131 | +17x |
- #' cardx:::.update_weights_strat_wilson(vs, sq, ws, ns, 100, 0.95, 0.001)+ dplyr::mutate( |
||
| 431 | -+ | |||
| 132 | +17x |
- .update_weights_strat_wilson <- function(vars,+ context = "proportion_ci" |
||
| 432 | +133 |
- strata_qnorm,+ ) |
||
| 433 | +134 |
- initial_weights,+ } |
||
| 434 | +135 |
- n_per_strata,+ |
||
| 435 | +136 |
- max.iterations = 50,+ .unique_values_sort <- function(data, variable, value = NULL) {
|
||
| 436 | -+ | |||
| 137 | +177x |
- conf.level = 0.95,+ unique_levels <- |
||
| 437 | +138 |
- tol = 0.001) {
- |
- ||
| 438 | -! | -
- it <- 0+ # styler: off |
||
| 439 | -! | +|||
| 139 | +177x |
- diff_v <- NULL+ if (is.logical(data[[variable]])) c(TRUE, FALSE) |
||
| 440 | -+ | |||
| 140 | +177x |
-
+ else if (is.factor(data[[variable]])) factor(levels(data[[variable]]), levels = levels(data[[variable]])) |
||
| 441 | -! | +|||
| 141 | +177x |
- while (it < max.iterations) {
+ else unique(data[[variable]]) |> sort() |
||
| 442 | -! | +|||
| 142 | +
- it <- it + 1+ # styler: on |
|||
| 443 | -! | +|||
| 143 | +
- weights_new_t <- (1 + strata_qnorm^2 / n_per_strata)^2+ |
|||
| 444 | -! | +|||
| 144 | +177x |
- weights_new_b <- (vars + strata_qnorm^2 / (4 * n_per_strata^2))+ if (!is_empty(value) && !value %in% unique_levels) {
|
||
| 445 | -! | +|||
| 145 | +1x |
- weights_new <- weights_new_t / weights_new_b+ cli::cli_warn( |
||
| 446 | -! | +|||
| 146 | +1x |
- weights_new <- weights_new / sum(weights_new)+ c("A value of {.code value={.val {value}}} for variable {.val {variable}}
|
||
| 447 | -! | +|||
| 147 | +1x |
- strata_qnorm <- .strata_normal_quantile(vars, weights_new, conf.level)+ was passed, but is not one of the observed levels: {.val {unique_levels}}.",
|
||
| 448 | -! | +|||
| 148 | +1x |
- diff_v <- c(diff_v, sum(abs(weights_new - initial_weights)))+ i = "This may be an error.", |
||
| 449 | -! | +|||
| 149 | +1x |
- if (diff_v[length(diff_v)] < tol) break+ i = "If value is a valid, convert variable to factor with all levels specified to avoid this message." |
||
| 450 | -! | +|||
| 150 | +
- initial_weights <- weights_new+ ) |
|||
| 451 | +151 |
- }+ ) |
||
| 452 | +152 |
-
+ } |
||
| 453 | -! | +|||
| 153 | +177x |
- if (it == max.iterations) {
+ if (!is_empty(value)) {
|
||
| 454 | -! | +|||
| 154 | +16x |
- warning("The heuristic to find weights did not converge with max.iterations = ", max.iterations)
+ unique_levels <- value |
||
| 455 | +155 |
} |
||
| 456 | +156 | |||
| 457 | -! | +|||
| 157 | +177x |
- list(+ unique_levels |
||
| 458 | -! | +|||
| 158 | +
- "n_it" = it,+ } |
|||
| 459 | -! | +|||
| 159 | +
- "weights" = weights_new,+ |
|||
| 460 | -! | +|||
| 160 | +
- "diff_v" = diff_v+ .as_dummy <- function(data, variable, levels, by, strata) {
|
|||
| 461 | +161 |
- )+ # define dummy variables and return tibble+ |
+ ||
| 162 | +17x | +
+ map(levels, ~ data[[variable]] == .x) |>+ |
+ ||
| 163 | +17x | +
+ set_names(paste0("this_is_not_a_column_name_anyone_would_choose_", variable, "_", levels, "...")) %>%
+ |
+ ||
| 164 | +17x | +
+ {dplyr::tibble(!!!.)} |> # styler: off
+ |
+ ||
| 165 | +17x | +
+ dplyr::bind_cols(data[c(by, strata)]) |
||
| 462 | +166 |
}@@ -5136,14 +5127,14 @@ cardx coverage - 95.32% |
| 1 |
- #' ARD Hedge's G Test+ #' Regression VIF ARD |
||
| 4 |
- #' Analysis results data for paired and non-paired Hedge's G Effect Size Test+ #' Function takes a regression model object and returns the variance inflation factor (VIF) |
||
| 5 |
- #' using [`effectsize::hedges_g()`].+ #' using [`car::vif()`] and converts it to a ARD structure |
||
| 7 |
- #' @param data (`data.frame`)\cr+ #' @param x regression model object |
||
| 8 |
- #' a data frame. See below for details.+ #' See car::vif() for details |
||
| 9 |
- #' @param by ([`tidy-select`][dplyr::dplyr_tidy_select])\cr+ #' |
||
| 10 |
- #' column name to compare by. Must be a categorical variable with exactly two levels.+ #' @param ... arguments passed to `car::vif(...)` |
||
| 11 |
- #' @param variables ([`tidy-select`][dplyr::dplyr_tidy_select])\cr+ #' |
||
| 12 |
- #' column names to be compared. Must be a continuous variable. Independent+ #' @return data frame |
||
| 13 |
- #' tests will be run for each variable+ #' @name ard_car_vif |
||
| 14 |
- #' @param id ([`tidy-select`][dplyr::dplyr_tidy_select])\cr+ #' @rdname ard_car_vif |
||
| 15 |
- #' column name of the subject or participant ID+ #' @export |
||
| 16 |
- #' @param conf.level (scalar `numeric`)\cr+ #' |
||
| 17 |
- #' confidence level for confidence interval. Default is `0.95`.+ #' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = "car", reference_pkg = "cardx"))
|
||
| 18 |
- #' @param ... arguments passed to `effectsize::hedges_g(...)`+ #' lm(AGE ~ ARM + SEX, data = cards::ADSL) |> |
||
| 19 |
- #'+ #' ard_car_vif() |
||
| 20 |
- #' @return ARD data frame+ ard_car_vif <- function(x, ...) {
|
||
| 21 | -+ | 3x |
- #' @name ard_effectsize_hedges_g+ set_cli_abort_call() |
| 22 |
- #'+ |
||
| 23 |
- #' @details+ # check installed packages --------------------------------------------------- |
||
| 24 | -+ | 3x |
- #' For the `ard_effectsize_hedges_g()` function, the data is expected to be one row per subject.+ check_pkg_installed("car", reference_pkg = "cardx")
|
| 25 |
- #' The data is passed as `effectsize::hedges_g(data[[variable]]~data[[by]], data, paired = FALSE, ...)`.+ |
||
| 26 |
- #'+ # check inputs --------------------------------------------------------------- |
||
| 27 | -+ | 3x |
- #' For the `ard_effectsize_paired_hedges_g()` function, the data is expected to be one row+ check_not_missing(x) |
| 28 |
- #' per subject per by level. Before the effect size is calculated, the data are+ |
||
| 29 | -+ | 3x |
- #' reshaped to a wide format to be one row per subject.+ vif <- cards::eval_capture_conditions(car::vif(x, ...)) |
| 30 |
- #' The data are then passed as+ |
||
| 31 |
- #' `effectsize::hedges_g(x = data_wide[[<by level 1>]], y = data_wide[[<by level 2>]], paired = TRUE, ...)`.+ # if vif failed, set result as NULL, error will be kept through eval_capture_conditions() |
||
| 32 | -+ | 3x |
- #'+ if (is.null(vif$result)) {
|
| 33 |
- #' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = c("effectsize", "parameters"), reference_pkg = "cardx"))
+ # try to capture variable names from `terms()` |
||
| 34 | -+ | 2x |
- #' cards::ADSL |>+ lst_terms <- cards::eval_capture_conditions(attr(stats::terms(x), "term.labels")) |
| 35 |
- #' dplyr::filter(ARM %in% c("Placebo", "Xanomeline High Dose")) |>
+ # we cannot get variable names, error out |
||
| 36 | -+ | 2x |
- #' ard_effectsize_hedges_g(by = ARM, variables = AGE)+ if (!is.null(lst_terms[["error"]])) {
|
| 37 | -+ | 1x |
- #'+ cli::cli_abort( |
| 38 | -+ | 1x |
- #' # constructing a paired data set,+ c("There was an error running {.fun car::vif}. See below.", x = vif[["error"]]),
|
| 39 | -+ | 1x |
- #' # where patients receive both treatments+ call = get_cli_abort_call() |
| 40 |
- #' cards::ADSL[c("ARM", "AGE")] |>
+ ) |
||
| 41 |
- #' dplyr::filter(ARM %in% c("Placebo", "Xanomeline High Dose")) |>
+ } |
||
| 42 | -+ | 1x |
- #' dplyr::mutate(.by = ARM, USUBJID = dplyr::row_number()) |>+ vif$result <- dplyr::tibble( |
| 43 | -+ | 1x |
- #' dplyr::arrange(USUBJID, ARM) |>+ variable = lst_terms[["result"]], |
| 44 | -+ | 1x |
- #' dplyr::group_by(USUBJID) |>+ VIF = list(NULL), |
| 45 | -+ | 1x |
- #' dplyr::filter(dplyr::n() > 1) |>+ GVIF = list(NULL), |
| 46 | -+ | 1x |
- #' ard_effectsize_paired_hedges_g(by = ARM, variables = AGE, id = USUBJID)+ aGVIF = list(NULL), |
| 47 | -+ | 1x |
- NULL+ df = list(NULL) |
| 48 |
-
+ ) |
||
| 49 |
- #' @rdname ard_effectsize_hedges_g+ } |
||
| 50 |
- #' @export+ # if VIF is returned |
||
| 51 | -+ | 1x |
- ard_effectsize_hedges_g <- function(data, by, variables, conf.level = 0.95, ...) {
+ else if (!is.matrix(vif$result)) {
|
| 52 | -3x | +! |
- set_cli_abort_call()+ vif$result <- dplyr::tibble(variable = names(vif$result), VIF = vif$result) |
| 53 |
-
+ } |
||
| 54 |
- # check installed packages ---------------------------------------------------+ # if Generalized VIF is returned |
||
| 55 | -3x | +1x |
- check_pkg_installed(c("effectsize", "parameters"), reference_pkg = "cardx")
+ else if (is.matrix(vif$result)) {
|
| 56 | -+ | 1x |
-
+ vif$result <- |
| 57 | -+ | 1x |
- # check/process inputs -------------------------------------------------------+ vif$result |> |
| 58 | -3x | +1x |
- check_not_missing(data)+ as.data.frame() %>% |
| 59 | -3x | +1x |
- check_not_missing(variables)+ dplyr::mutate(., variable = rownames(.), .before = 1L) |> |
| 60 | -3x | +1x |
- check_data_frame(data)+ dplyr::rename( |
| 61 | -3x | +1x |
- data <- dplyr::ungroup(data)+ aGVIF = "GVIF^(1/(2*Df))", |
| 62 | -3x | +1x |
- cards::process_selectors(data, by = {{ by }}, variables = {{ variables }})
+ df = "Df" |
| 63 | -3x | +
- check_scalar(by)+ ) |> |
|
| 64 | -3x | +1x |
- check_range(conf.level, range = c(0, 1))+ dplyr::tibble() |
| 65 |
-
+ } |
||
| 66 |
- # if no variables selected, return empty tibble ------------------------------+ |
||
| 67 | -3x | +
- if (is_empty(variables)) {
+ # Clean-up the result to fit the ard structure through pivot |
|
| 68 | -! | +2x |
- return(dplyr::tibble())+ vif$result <- |
| 69 | -+ | 2x |
- }+ vif$result |> |
| 70 | -+ | 2x |
-
+ tidyr::pivot_longer( |
| 71 | -+ | 2x |
- # build ARD ------------------------------------------------------------------+ cols = -c("variable"),
|
| 72 | -3x | +2x |
- lapply(+ names_to = "stat_name", |
| 73 | -3x | +2x |
- variables,+ values_to = "stat" |
| 74 | -3x | +
- function(variable) {
+ ) |> |
|
| 75 | -4x | +2x |
- .format_hedges_g_results(+ dplyr::mutate( |
| 76 | -4x | +2x |
- by = by,+ context = "car_vif", |
| 77 | -4x | +2x |
- variable = variable,+ stat_label = ifelse( |
| 78 | -4x | +2x |
- lst_tidy =+ .data$stat_name == "aGVIF", |
| 79 | -4x | +2x |
- cards::eval_capture_conditions(+ "Adjusted GVIF", |
| 80 | -4x | +2x |
- effectsize::hedges_g(+ .data$stat_name |
| 81 | -4x | +
- reformulate2(by, response = variable),+ ), |
|
| 82 | -4x | +2x |
- data = data |> tidyr::drop_na(all_of(c(by, variable))),+ fmt_fn = map( |
| 83 | -4x | +2x |
- paired = FALSE,+ .data$stat, |
| 84 | -4x | +2x |
- ci = conf.level,+ function(.x) {
|
| 85 |
- ...+ # styler: off |
||
| 86 | -+ | ! |
- ) |>+ if (is.integer(.x)) return(0L) |
| 87 | -4x | +6x |
- parameters::standardize_names(style = "broom") |>+ if (is.numeric(.x)) return(1L) |
| 88 | -4x | +
- dplyr::mutate(method = "Hedge's G")+ # styler: on |
|
| 89 | -+ | 4x |
- ),+ NULL |
| 90 | -4x | +
- paired = FALSE,+ } |
|
| 91 |
- ...+ ) |
||
| 92 |
- )+ ) |
||
| 93 |
- }+ |
||
| 94 |
- ) |>+ # Bind the results and possible warning/errors together |
||
| 95 | -3x | +2x |
- dplyr::bind_rows()+ vif_return <- dplyr::tibble( |
| 96 | -+ | 2x |
- }+ vif$result, |
| 97 | -+ | 2x |
-
+ warning = vif["warning"], |
| 98 | -+ | 2x |
- #' @rdname ard_effectsize_hedges_g+ error = vif["error"] |
| 99 |
- #' @export+ ) |
||
| 100 |
- ard_effectsize_paired_hedges_g <- function(data, by, variables, id, conf.level = 0.95, ...) {
+
|
||
| 101 | -2x | +
- set_cli_abort_call()+ # Clean up return object |
|
| 102 | -+ | 2x |
-
+ vif_return |> |
| 103 | -+ | 2x |
- # check installed packages ---------------------------------------------------+ cards::tidy_ard_column_order() %>% |
| 104 | 2x |
- check_pkg_installed(c("effectsize", "parameters"), reference_pkg = "cardx")
+ {structure(., class = c("card", class(.)))} # styler: off
|
|
| 105 |
-
+ } |
| 106 | +1 |
- # check/process inputs -------------------------------------------------------+ #' ARD Categorical Survey Statistics |
||
| 107 | -2x | +|||
| 2 | +
- check_not_missing(data)+ #' |
|||
| 108 | -2x | +|||
| 3 | +
- check_not_missing(variables)+ #' @description |
|||
| 109 | -2x | -
- check_not_missing(by)- |
- ||
| 110 | -2x | -
- check_not_missing(id)- |
- ||
| 111 | -2x | -
- check_data_frame(data)- |
- ||
| 112 | -2x | -
- data <- dplyr::ungroup(data)- |
- ||
| 113 | -2x | +|||
| 4 | +
- cards::process_selectors(data, by = {{ by }}, variables = {{ variables }}, id = {{ id }})
+ #' Compute tabulations on survey-weighted data. |
|||
| 114 | -2x | +|||
| 5 | +
- check_scalar(by)+ #' |
|||
| 115 | -2x | +|||
| 6 | +
- check_scalar(id)+ #' The counts and proportion (`"N"`, `"n"`, `"p"`) are calculated using `survey::svytable()`, |
|||
| 116 | -2x | +|||
| 7 | +
- check_range(conf.level, range = c(0, 1))+ #' and the standard errors and design effect (`"p.std.error"`, `"deff"`) are |
|||
| 117 | +8 |
-
+ #' calculated using `survey::svymean()`. |
||
| 118 | +9 |
- # if no variables selected, return empty tibble ------------------------------+ #' |
||
| 119 | -2x | +|||
| 10 | +
- if (is_empty(variables)) {
+ #' The unweighted statistics are calculated with `cards::ard_categorical.data.frame()`. |
|||
| 120 | -! | +|||
| 11 | +
- return(dplyr::tibble())+ #' |
|||
| 121 | +12 |
- }+ #' @param data (`survey.design`)\cr |
||
| 122 | +13 |
- # build ARD ------------------------------------------------------------------+ #' a design object often created with [`survey::svydesign()`]. |
||
| 123 | +14 |
-
+ #' @param variables ([`tidy-select`][dplyr::dplyr_tidy_select])\cr |
||
| 124 | -2x | +|||
| 15 | +
- lapply(+ #' columns to include in summaries. |
|||
| 125 | -2x | +|||
| 16 | +
- variables,+ #' @param by ([`tidy-select`][dplyr::dplyr_tidy_select])\cr |
|||
| 126 | -2x | +|||
| 17 | +
- function(variable) {
+ #' results are calculated for **all combinations** of the column specified |
|||
| 127 | -2x | +|||
| 18 | +
- .format_hedges_g_results(+ #' and the variables. A single column may be specified. |
|||
| 128 | -2x | +|||
| 19 | +
- by = by,+ #' @param denominator (`string`)\cr |
|||
| 129 | -2x | +|||
| 20 | +
- variable = variable,+ #' a string indicating the type proportions to calculate. Must be one of |
|||
| 130 | -2x | +|||
| 21 | +
- lst_tidy =+ #' `"column"` (the default), `"row"`, and `"cell"`. |
|||
| 131 | -2x | +|||
| 22 | +
- cards::eval_capture_conditions({
+ #' @param statistic ([`formula-list-selector`][syntax])\cr |
|||
| 132 | +23 |
- # adding this reshape inside the eval, so if there is an error it's captured in the ARD object+ #' a named list, a list of formulas, |
||
| 133 | -2x | +|||
| 24 | +
- data_wide <-+ #' or a single formula where the list element is a character vector of |
|||
| 134 | -2x | +|||
| 25 | +
- data |>+ #' statistic names to include. See default value for options. |
|||
| 135 | -2x | +|||
| 26 | +
- tidyr::drop_na(all_of(c(id, by, variable))) |>+ #' @param fmt_fn ([`formula-list-selector`][syntax])\cr |
|||
| 136 | -2x | +|||
| 27 | +
- .paired_data_pivot_wider(by = by, variable = variable, id = id) |>+ #' a named list, a list of formulas, |
|||
| 137 | -2x | +|||
| 28 | +
- tidyr::drop_na(any_of(c("by1", "by2")))
+ #' or a single formula where the list element is a named list of functions |
|||
| 138 | +29 |
- # perform paired cohen's d test+ #' (or the RHS of a formula), |
||
| 139 | -1x | +|||
| 30 | +
- effectsize::hedges_g(x = data_wide[["by1"]], y = data_wide[["by2"]], paired = TRUE, ci = conf.level, ...) |>+ #' e.g. `list(mpg = list(mean = \(x) round(x, digits = 2) |> as.character))`. |
|||
| 140 | -1x | +|||
| 31 | +
- parameters::standardize_names(style = "broom") |>+ #' @param stat_label ([`formula-list-selector`][syntax])\cr |
|||
| 141 | -1x | +|||
| 32 | +
- dplyr::mutate(method = "Paired Hedge's G")+ #' a named list, a list of formulas, or a single formula where |
|||
| 142 | +33 |
- }),+ #' the list element is either a named list or a list of formulas defining the |
||
| 143 | -2x | +|||
| 34 | +
- paired = TRUE,+ #' statistic labels, e.g. `everything() ~ list(mean = "Mean", sd = "SD")` or |
|||
| 144 | +35 |
- ...+ #' `everything() ~ list(mean ~ "Mean", sd ~ "SD")`. |
||
| 145 | +36 |
- )+ #' @inheritParams rlang::args_dots_empty |
||
| 146 | +37 |
- }+ #' |
||
| 147 | +38 |
- ) |>+ #' @return an ARD data frame of class 'card' |
||
| 148 | -2x | +|||
| 39 | +
- dplyr::bind_rows()+ #' @export |
|||
| 149 | +40 |
- }+ #' |
||
| 150 | +41 |
-
+ #' @examplesIf cardx:::is_pkg_installed("survey", reference_pkg = "cardx")
|
||
| 151 | +42 |
- #' Convert Hedge's G Test to ARD+ #' svy_titanic <- survey::svydesign(~1, data = as.data.frame(Titanic), weights = ~Freq) |
||
| 152 | +43 |
#' |
||
| 153 | +44 |
- #' @inheritParams cards::tidy_as_ard+ #' ard_categorical(svy_titanic, variables = c(Class, Age), by = Survived) |
||
| 154 | +45 |
- #' @inheritParams effectsize::hedges_g+ ard_categorical.survey.design <- function(data, |
||
| 155 | +46 |
- #' @param by (`string`)\cr by column name+ variables, |
||
| 156 | +47 |
- #' @param variable (`string`)\cr variable column name+ by = NULL, |
||
| 157 | +48 |
- #' @param ... passed to `hedges_g(...)`+ statistic = everything() ~ c("n", "N", "p", "p.std.error", "deff", "n_unweighted", "N_unweighted", "p_unweighted"),
|
||
| 158 | +49 |
- #'+ denominator = c("column", "row", "cell"),
|
||
| 159 | +50 |
- #' @return ARD data frame+ fmt_fn = NULL, |
||
| 160 | +51 |
- #' @keywords internal+ stat_label = everything() ~ list( |
||
| 161 | +52 |
- #' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = c("effectsize", "parameters"), reference_pkg = "cardx"))
+ p = "%", |
||
| 162 | +53 |
- #' cardx:::.format_hedges_g_results(+ p.std.error = "SE(%)", |
||
| 163 | +54 |
- #' by = "ARM",+ deff = "Design Effect", |
||
| 164 | +55 |
- #' variable = "AGE",+ "n_unweighted" = "Unweighted n", |
||
| 165 | +56 |
- #' paired = FALSE,+ "N_unweighted" = "Unweighted N", |
||
| 166 | +57 |
- #' lst_tidy =+ "p_unweighted" = "Unweighted %" |
||
| 167 | +58 |
- #' cards::eval_capture_conditions(+ ), |
||
| 168 | +59 |
- #' effectsize::hedges_g(data[[variable]] ~ data[[by]], paired = FALSE) |>+ ...) {
|
||
| 169 | -+ | |||
| 60 | +50x |
- #' parameters::standardize_names(style = "broom")+ set_cli_abort_call() |
||
| 170 | -+ | |||
| 61 | +50x |
- #' )+ check_pkg_installed(pkg = "survey", reference_pkg = "cardx") |
||
| 171 | -+ | |||
| 62 | +50x |
- #' )+ check_dots_empty()+ |
+ ||
| 63 | +50x | +
+ deff <- TRUE # we may update in the future to make this an argument for users |
||
| 172 | +64 |
- .format_hedges_g_results <- function(by, variable, lst_tidy, paired, ...) {
+
|
||
| 173 | +65 |
- # build ARD ------------------------------------------------------------------+ # process arguments ---------------------------------------------------------- |
||
| 174 | -6x | +66 | +50x |
- ret <-+ check_not_missing(variables) |
| 175 | -6x | +67 | +50x |
- cards::tidy_as_ard(+ cards::process_selectors( |
| 176 | -6x | +68 | +50x |
- lst_tidy = lst_tidy,+ data = data$variables, |
| 177 | -6x | +69 | +50x |
- tidy_result_names = c(+ variables = {{ variables }},
|
| 178 | -6x | +70 | +50x |
- "estimate", "conf.level", "conf.low", "conf.high"+ by = {{ by }}
|
| 179 | +71 |
- ),+ ) |
||
| 180 | -6x | +72 | +50x |
- fun_args_to_record = c("mu", "paired", "pooled_sd", "alternative"),
+ variables <- setdiff(variables, by) |
| 181 | -6x | +73 | +50x |
- formals = formals(asNamespace("effectsize")[["hedges_g"]]),
+ check_scalar(by, allow_empty = TRUE) |
| 182 | -6x | +|||
| 74 | +
- passed_args = c(list(paired = paired), dots_list(...)),+ |
|||
| 183 | -6x | +|||
| 75 | +
- lst_ard_columns = list(group1 = by, variable = variable, context = "effectsize_hedges_g")+ # if no variables selected, return empty data frame |
|||
| 184 | -+ | |||
| 76 | +! |
- )+ if (is_empty(variables)) return(dplyr::tibble()) # styler: off |
||
| 185 | +77 | |||
| 78 | +50x | +
+ check_na_factor_levels(data$variables, c(by, variables))+ |
+ ||
| 186 | +79 |
- # add the stat label ---------------------------------------------------------+ |
||
| 187 | -6x | +80 | +50x |
- ret |>+ cards::process_formula_selectors( |
| 188 | -6x | +81 | +50x |
- dplyr::left_join(+ data = data$variables[variables], |
| 189 | -6x | +82 | +50x |
- .df_effectsize_stat_labels(),+ statistic = statistic, |
| 190 | -6x | +83 | +50x |
- by = "stat_name"+ fmt_fn = fmt_fn,+ |
+
| 84 | +50x | +
+ stat_label = stat_label |
||
| 191 | +85 |
- ) |>+ ) |
||
| 192 | -6x | +86 | +50x |
- dplyr::mutate(stat_label = dplyr::coalesce(.data$stat_label, .data$stat_name)) |>+ cards::fill_formula_selectors( |
| 193 | -6x | +87 | +50x |
- cards::tidy_ard_column_order()+ data = data$variables[variables], |
| 194 | -+ | |||
| 88 | +50x |
- }+ statistic = formals(asNamespace("cardx")[["ard_categorical.survey.design"]])[["statistic"]] |> eval(),
|
| 1 | +89 |
- #' ARD Chi-squared Test+ ) |
||
| 2 | -+ | |||
| 90 | +50x |
- #'+ accepted_svy_stats <- c("n", "N", "p", "p.std.error", "deff", "n_unweighted", "N_unweighted", "p_unweighted")
|
||
| 3 | -+ | |||
| 91 | +50x |
- #' @description+ cards::check_list_elements( |
||
| 4 | -+ | |||
| 92 | +50x |
- #' Analysis results data for Pearson's Chi-squared Test.+ x = statistic, |
||
| 5 | -+ | |||
| 93 | +50x |
- #' Calculated with `chisq.test(x = data[[variable]], y = data[[by]], ...)`+ predicate = \(x) all(x %in% accepted_svy_stats), |
||
| 6 | -+ | |||
| 94 | +50x |
- #'+ error_msg = c("Error in the values of the {.arg statistic} argument.",
|
||
| 7 | -+ | |||
| 95 | +50x |
- #'+ i = "Values must be in {.val {accepted_svy_stats}}"
|
||
| 8 | +96 |
- #' @param data (`data.frame`)\cr+ ) |
||
| 9 | +97 |
- #' a data frame.+ ) |
||
| 10 | -+ | |||
| 98 | +50x |
- #' @param by ([`tidy-select`][dplyr::dplyr_tidy_select])\cr+ denominator <- arg_match(denominator) |
||
| 11 | +99 |
- #' column name to compare by.+ |
||
| 12 | +100 |
- #' @param variables ([`tidy-select`][dplyr::dplyr_tidy_select])\cr+ # return empty tibble if no variables selected -------------------------------+ |
+ ||
| 101 | +50x | +
+ if (is_empty(variables)) {
+ |
+ ||
| 102 | +! | +
+ return(dplyr::tibble()) |
||
| 13 | +103 |
- #' column names to be compared. Independent tests will be computed for+ } |
||
| 14 | +104 |
- #' each variable.+ |
||
| 15 | +105 |
- #' @param ... additional arguments passed to `chisq.test(...)`+ # check the missingness+ |
+ ||
| 106 | +50x | +
+ walk(+ |
+ ||
| 107 | +50x | +
+ variables,+ |
+ ||
| 108 | +50x | +
+ \(.x) {
+ |
+ ||
| 109 | +97x | +
+ if (all(is.na(data$variables[[.x]])) && !inherits(.x, c("logical", "factor"))) {
+ |
+ ||
| 110 | +1x | +
+ cli::cli_abort(+ |
+ ||
| 111 | +1x | +
+ c("Column {.val {.x}} is all missing and cannot be tabulated.",
+ |
+ ||
| 112 | +1x | +
+ i = "Only columns of class {.cls logical} and {.cls factor} can be tabulated when all values are missing."
|
||
| 16 | +113 |
- #'+ ),+ |
+ ||
| 114 | +1x | +
+ call = get_cli_abort_call() |
||
| 17 | +115 |
- #' @return ARD data frame+ ) |
||
| 18 | +116 |
- #' @export+ } |
||
| 19 | +117 |
- #'+ } |
||
| 20 | +118 |
- #' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = "broom", reference_pkg = "cardx"))
+ ) |
||
| 21 | +119 |
- #' cards::ADSL |>+ |
||
| 22 | +120 |
- #' ard_stats_chisq_test(by = "ARM", variables = "AGEGR1")+ # calculate counts ----------------------------------------------------------- |
||
| 23 | +121 |
- ard_stats_chisq_test <- function(data, by, variables, ...) {
+ # this tabulation accounts for unobserved combinations |
||
| 24 | -5x | +122 | +49x |
- set_cli_abort_call()+ svytable_counts <- .svytable_counts(data, variables, by, denominator) |
| 25 | +123 | |||
| 26 | +124 |
- # check installed packages ---------------------------------------------------+ # calculate rate SE and DEFF ------------------------------------------------- |
||
| 27 | -5x | +125 | +49x |
- check_pkg_installed("broom", reference_pkg = "cardx")
+ svytable_rates <- .svytable_rate_stats(data, variables, by, denominator, deff) |
| 28 | +126 | |||
| 29 | +127 |
- # check/process inputs -------------------------------------------------------+ # convert results into a proper ARD object ----------------------------------- |
||
| 30 | -5x | +128 | +49x |
- check_not_missing(data)+ cards <- |
| 31 | -5x | +129 | +49x |
- check_not_missing(variables)+ svytable_counts |> |
| 32 | -5x | +|||
| 130 | +
- check_not_missing(by)+ # merge in the SE(p) and DEFF |
|||
| 33 | -5x | +131 | +49x |
- check_data_frame(data)+ dplyr::left_join( |
| 34 | -5x | +132 | +49x |
- cards::process_selectors(data, by = {{ by }}, variables = {{ variables }})
+ svytable_rates |> dplyr::select(-"p"), |
| 35 | -5x | +133 | +49x |
- check_scalar(by)+ by = intersect(c("group1", "group1_level", "variable", "variable_level"), names(svytable_counts))
|
| 36 | +134 |
-
+ ) |> |
||
| 37 | +135 |
- # if no variables selected, return empty tibble ------------------------------+ # make columns list columns |
||
| 38 | -5x | +136 | +49x |
- if (is_empty(variables)) {
+ dplyr::mutate(across(-any_of(c("group1", "variable")), as.list)) |>
|
| 39 | -! | +|||
| 137 | +49x |
- return(dplyr::tibble())+ tidyr::pivot_longer( |
||
| 40 | -+ | |||
| 138 | +49x |
- }+ cols = -c(cards::all_ard_groups(), cards::all_ard_variables()), |
||
| 41 | -+ | |||
| 139 | +49x |
- # build ARD ------------------------------------------------------------------+ names_to = "stat_name", |
||
| 42 | -5x | +140 | +49x |
- lapply(+ values_to = "stat" |
| 43 | -5x | +|||
| 141 | +
- variables,+ ) |> |
|||
| 44 | -5x | +|||
| 142 | +
- function(variable) {
+ # keep statistics requested by user |
|||
| 45 | -6x | +143 | +49x |
- cards::tidy_as_ard(+ dplyr::inner_join( |
| 46 | -6x | +144 | +49x |
- lst_tidy =+ statistic |> enframe("variable", "stat_name") |> tidyr::unnest(cols = "stat_name"),
|
| 47 | -6x | +145 | +49x |
- cards::eval_capture_conditions(+ by = c("variable", "stat_name")
|
| 48 | -6x | +|||
| 146 | +
- stats::chisq.test(x = data[[variable]], y = data[[by]], ...) |>+ ) |
|||
| 49 | -6x | +|||
| 147 | +
- broom::tidy()+ |
|||
| 50 | +148 |
- ),+ # add unweighted statistics -------------------------------------------------- |
||
| 51 | -6x | +149 | +49x |
- tidy_result_names = c("statistic", "p.value", "parameter", "method"),
+ cards_unweighted <- |
| 52 | -6x | +150 | +49x |
- fun_args_to_record =+ ard_categorical( |
| 53 | -6x | +151 | +49x |
- c("correct", "p", "rescale.p", "simulate.p.value", "B"),
+ data = data[["variables"]], |
| 54 | -6x | +152 | +49x |
- formals = formals(stats::chisq.test),+ variables = all_of(variables), |
| 55 | -6x | +153 | +49x |
- passed_args = dots_list(...),+ by = any_of(by), |
| 56 | -6x | +154 | +49x |
- lst_ard_columns = list(group1 = by, variable = variable, context = "stats_chisq_test")+ denominator = denominator |
| 57 | +155 |
- ) |>+ ) |> |
||
| 58 | -6x | +|||
| 156 | +
- dplyr::mutate(+ # all the survey levels are reported as character, so we do the same here. |
|||
| 59 | -6x | +157 | +49x |
- .after = "stat_name",+ dplyr::mutate( |
| 60 | -6x | +158 | +49x |
- stat_label =+ across( |
| 61 | -6x | +159 | +49x |
- dplyr::case_when(+ c(cards::all_ard_groups("levels"), cards::all_ard_variables("levels")),
|
| 62 | -6x | +160 | +49x |
- .data$stat_name %in% "statistic" ~ "X-squared Statistic",+ ~ map(.x, as.character) |
| 63 | -6x | +|||
| 161 | +
- .data$stat_name %in% "p.value" ~ "p-value",+ ) |
|||
| 64 | -6x | +|||
| 162 | +
- .data$stat_name %in% "parameter" ~ "Degrees of Freedom",+ ) |> |
|||
| 65 | -6x | +163 | +49x |
- TRUE ~ .data$stat_name,+ dplyr::select(-c("stat_label", "fmt_fn", "warning", "error")) |>
|
| 66 | -+ | |||
| 164 | +49x |
- )+ dplyr::mutate( |
||
| 67 | -+ | |||
| 165 | +49x |
- )+ stat_name = |
||
| 68 | -+ | |||
| 166 | +49x |
- }+ dplyr::case_match(.data$stat_name, "n" ~ "n_unweighted", "N" ~ "N_unweighted", "p" ~ "p_unweighted") |
||
| 69 | +167 |
- ) |>+ ) |
||
| 70 | -5x | +168 | +49x |
- dplyr::bind_rows()+ cards <- cards |> dplyr::bind_rows(cards_unweighted) # styler: off |
| 71 | +169 |
- }+ |
| 1 | +170 |
- #' ARD one-sample t-test+ # final processing of fmt_fn ------------------------------------------------- |
||
| 2 | -+ | |||
| 171 | +49x |
- #'+ cards <- cards |> |
||
| 3 | -+ | |||
| 172 | +49x |
- #' @description+ .process_nested_list_as_df( |
||
| 4 | -+ | |||
| 173 | +49x |
- #' Analysis results data for one-sample t-tests.+ arg = fmt_fn, |
||
| 5 | -+ | |||
| 174 | +49x |
- #' Result may be stratified by including the `by` argument.+ new_column = "fmt_fn" |
||
| 6 | +175 |
- #'+ ) |> |
||
| 7 | -+ | |||
| 176 | +49x |
- #' @param data (`data.frame`)\cr+ .default_svy_cat_fmt_fn() |
||
| 8 | +177 |
- #' a data frame. See below for details.+ |
||
| 9 | +178 |
- #' @param variables ([`tidy-select`][dplyr::dplyr_tidy_select])\cr+ # merge in statistic labels -------------------------------------------------- |
||
| 10 | -+ | |||
| 179 | +49x |
- #' column names to be analyzed. Independent t-tests will be computed for+ cards <- cards |> |
||
| 11 | -+ | |||
| 180 | +49x |
- #' each variable.+ .process_nested_list_as_df( |
||
| 12 | -+ | |||
| 181 | +49x |
- #' @param by ([`tidy-select`][dplyr::dplyr_tidy_select])\cr+ arg = stat_label, |
||
| 13 | -+ | |||
| 182 | +49x |
- #' optional column name to stratify results by.+ new_column = "stat_label", |
||
| 14 | -+ | |||
| 183 | +49x |
- #' @inheritParams ard_stats_t_test+ unlist = TRUE |
||
| 15 | +184 |
- #'+ ) |> |
||
| 16 | -+ | |||
| 185 | +49x |
- #' @return ARD data frame+ dplyr::mutate(stat_label = dplyr::coalesce(.data$stat_label, .data$stat_name)) |
||
| 17 | +186 |
- #' @export+ |
||
| 18 | +187 |
- #'+ # return final object -------------------------------------------------------- |
||
| 19 | -+ | |||
| 188 | +49x |
- #' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = "broom", reference_pkg = "cardx"))
+ cards |> |
||
| 20 | -+ | |||
| 189 | +49x |
- #' cards::ADSL |>+ dplyr::mutate( |
||
| 21 | -+ | |||
| 190 | +49x |
- #' ard_stats_t_test_onesample(by = ARM, variables = AGE)+ context = "categorical", |
||
| 22 | -+ | |||
| 191 | +49x |
- ard_stats_t_test_onesample <- function(data, variables, by = dplyr::group_vars(data), conf.level = 0.95, ...) {
+ warning = list(NULL), |
||
| 23 | -2x | +192 | +49x |
- set_cli_abort_call()+ error = list(NULL), |
| 24 | +193 |
-
+ ) |> |
||
| 25 | -+ | |||
| 194 | +49x |
- # check installed packages ---------------------------------------------------+ cards::tidy_ard_column_order() %>% |
||
| 26 | -2x | +195 | +49x |
- check_pkg_installed("broom", reference_pkg = "cardx")
+ {structure(., class = c("card", class(.)))} |> # styler: off
+ |
+
| 196 | +49x | +
+ cards::tidy_ard_row_order() |
||
| 27 | +197 | ++ |
+ }+ |
+ |
| 198 | ||||
| 28 | +199 |
- # check/process inputs -------------------------------------------------------+ # check for functions with NA factor levels (these are not allowed) |
||
| 29 | -2x | +|||
| 200 | +
- check_not_missing(data)+ check_na_factor_levels <- function(data, variables) {
|
|||
| 30 | -2x | +201 | +60x |
- check_not_missing(variables)+ walk( |
| 31 | -2x | +202 | +60x |
- check_data_frame(data)+ variables, |
| 32 | -2x | +203 | +60x |
- data <- dplyr::ungroup(data)+ \(variable) {
|
| 33 | -2x | +204 | +137x |
- cards::process_selectors(data, by = {{ by }}, variables = {{ variables }})
+ if (is.factor(data[[variable]]) && any(is.na(levels(data[[variable]])))) {
|
| 34 | -2x | +|||
| 205 | +! |
- check_scalar_range(conf.level, range = c(0, 1))+ cli::cli_abort(+ |
+ ||
| 206 | +! | +
+ "Column {.val {variable}} is a factor with {.val {NA}} levels, which are not allowed.",
+ |
+ ||
| 207 | +! | +
+ call = get_cli_abort_call() |
||
| 35 | +208 |
-
+ ) |
||
| 36 | +209 |
- # if no variables selected, return empty tibble ------------------------------+ } |
||
| 37 | -2x | +|||
| 210 | +
- if (is_empty(variables)) {
+ } |
|||
| 38 | -1x | +|||
| 211 | +
- return(dplyr::tibble())+ ) |
|||
| 39 | +212 |
- }+ } |
||
| 40 | +213 | |||
| 41 | -1x | +|||
| 214 | +
- cards::ard_continuous(+ # this function returns a tibble with the SE(p) and DEFF |
|||
| 42 | -1x | +|||
| 215 | +
- data = data,+ .svytable_rate_stats <- function(data, variables, by, denominator, deff) {
|
|||
| 43 | -1x | +216 | +32x |
- variables = all_of(variables),+ if (!is_empty(by)) by_lvls <- .unique_values_sort(data$variables, by) # styler: off |
| 44 | -1x | +217 | +49x |
- by = all_of(by),+ if (!is_empty(by) && length(by_lvls) == 1L) {
|
| 45 | -1x | -
- statistic = all_of(variables) ~ list(t_test_onesample = \(x) stats::t.test(x = x, conf.level = conf.level, ...) |> broom::tidy())- |
- ||
| 46 | -+ | 218 | +6x |
- ) |>+ data$variables[[by]] <- |
| 47 | -1x | +219 | +6x |
- cards::bind_ard(+ case_switch( |
| 48 | -1x | +220 | +6x |
- cards::ard_continuous(+ inherits(data$variables[[by]], "factor") ~ fct_expand(data$variables[[by]], paste("not", by_lvls)),
|
| 49 | -1x | +221 | +6x |
- data = data,+ .default = factor(data$variables[[by]], levels = c(by_lvls, paste("not", by_lvls)))
|
| 50 | -1x | +|||
| 222 | +
- variables = all_of(variables),+ ) |
|||
| 51 | -1x | +|||
| 223 | +
- by = all_of(by),+ } |
|||
| 52 | -1x | +224 | +49x |
- statistic =+ if (!is_empty(by) && inherits(data$variables[[by]], "logical")) {
|
| 53 | -1x | +225 | +9x |
- all_of(variables) ~+ data$variables[[by]] <- factor(data$variables[[by]], levels = c(TRUE, FALSE)) |
| 54 | -1x | +|||
| 226 | +
- list(conf.level = \(x) {
+ } |
|||
| 55 | -3x | +227 | +49x |
- formals(asNamespace("stats")[["t.test.default"]])["mu"] |>
+ if (!is_empty(by) && !inherits(data$variables[[by]], "factor")) {
|
| 56 | +228 | 3x |
- utils::modifyList(list(conf.level = conf.level, ...))+ data$variables[[by]] <- factor(data$variables[[by]]) |
|
| 57 | +229 |
- })+ } |
||
| 58 | +230 |
- )+ |
||
| 59 | -+ | |||
| 231 | +49x |
- ) |>+ lapply( |
||
| 60 | -1x | +232 | +49x |
- dplyr::select(-"stat_label") |>+ variables, |
| 61 | -1x | +233 | +49x |
- dplyr::left_join(+ \(variable) {
+ |
+
| 234 | ++ |
+ # convert the variable to a factor if not already one or a lgl, so we get the correct rate stats from svymean |
||
| 62 | -1x | +235 | +96x |
- .df_ttest_stat_labels(by = NULL),+ if (!inherits(data$variables[[variable]], c("factor", "logical"))) {
|
| 63 | -1x | +236 | +6x |
- by = "stat_name"+ data$variables[[variable]] <- factor(data$variables[[variable]]) |
| 64 | +237 |
- ) |>+ } |
||
| 65 | -1x | +|||
| 238 | +
- dplyr::mutate(+ |
|||
| 66 | -1x | +|||
| 239 | +
- stat_label = dplyr::coalesce(.data$stat_label, .data$stat_name),+ # there are issues with svymean() when a variable has only one level. adding a second as needed |
|||
| 67 | -1x | +240 | +96x |
- context = "stats_t_test_onesample",+ variable_lvls <- .unique_values_sort(data$variables, variable) |
| 68 | -+ | |||
| 241 | +96x |
- ) |>+ if (length(variable_lvls) == 1L) {
|
||
| 69 | -1x | +242 | +6x |
- cards::tidy_ard_row_order() |>+ data$variables[[variable]] <- |
| 70 | -1x | +243 | +6x |
- cards::tidy_ard_column_order()+ case_switch( |
| 71 | -+ | |||
| 244 | +6x |
- }+ inherits(data$variables[[variable]], "factor") ~ fct_expand(data$variables[[variable]], paste("not", variable_lvls)),
|
| 1 | -+ | |||
| 245 | +6x |
- #' ARD Standardized Mean Difference+ .default = factor(data$variables[[variable]], levels = c(variable_lvls, paste("not", variable_lvls)))
|
||
| 2 | +246 |
- #'+ ) |
||
| 3 | +247 |
- #' @description+ } |
||
| 4 | -+ | |||
| 248 | +96x |
- #' Standardized mean difference calculated via [`smd::smd()`] with `na.rm = TRUE`.+ if (inherits(data$variables[[variable]], "logical")) {
|
||
| 5 | -+ | |||
| 249 | +18x |
- #' Additionally, this function add a confidence interval to the SMD when+ data$variables[[variable]] <- factor(data$variables[[variable]], levels = c(TRUE, FALSE)) |
||
| 6 | +250 |
- #' `std.error=TRUE`, which the original `smd::smd()` does not include.+ } |
||
| 7 | -+ | |||
| 251 | +96x |
- #'+ if (!inherits(data$variables[[variable]], "factor")) {
|
||
| 8 | -+ | |||
| 252 | +! |
- #' @param data (`data.frame`/`survey.design`)\cr+ data$variables[[variable]] <- factor(data$variables[[variable]]) |
||
| 9 | +253 |
- #' a data frame or object of class 'survey.design'+ } |
||
| 10 | +254 |
- #' (typically created with [`survey::svydesign()`]).+ |
||
| 11 | +255 |
- #' @param by ([`tidy-select`][dplyr::dplyr_tidy_select])\cr+ # each combination of denominator and whether there is a by variable is handled separately |
||
| 12 | -+ | |||
| 256 | +96x |
- #' column name to compare by.+ result <- |
||
| 13 | -+ | |||
| 257 | +96x |
- #' @param variables ([`tidy-select`][dplyr::dplyr_tidy_select])\cr+ case_switch( |
||
| 14 | +258 |
- #' column names to be compared. Independent tests will be computed for+ # by variable and column percentages |
||
| 15 | -+ | |||
| 259 | +96x |
- #' each variable.+ !is_empty(by) && denominator == "column" ~ |
||
| 16 | -+ | |||
| 260 | +96x |
- #' @param conf.level (scalar `numeric`)\cr+ .one_svytable_rates_by_column(data, variable, by, deff), |
||
| 17 | +261 |
- #' confidence level for confidence interval. Default is `0.95`.+ # by variable and row percentages |
||
| 18 | -+ | |||
| 262 | +96x |
- #' @param std.error (scalar `logical`)\cr+ !is_empty(by) && denominator == "row" ~ |
||
| 19 | -+ | |||
| 263 | +96x |
- #' Logical indicator for computing standard errors using `smd::compute_smd_var()`.+ .one_svytable_rates_by_row(data, variable, by, deff), |
||
| 20 | +264 |
- #' Default is `TRUE`.+ # by variable and cell percentages |
||
| 21 | -+ | |||
| 265 | +96x |
- #' @param ... arguments passed to `smd::smd()`+ !is_empty(by) && denominator == "cell" ~ |
||
| 22 | -+ | |||
| 266 | +96x |
- #'+ .one_svytable_rates_by_cell(data, variable, by, deff), |
||
| 23 | +267 |
- #' @return ARD data frame+ # no by variable and column/cell percentages |
||
| 24 | -+ | |||
| 268 | +96x |
- #' @export+ denominator %in% c("column", "cell") ~
|
||
| 25 | -+ | |||
| 269 | +96x |
- #'+ .one_svytable_rates_no_by_column_and_cell(data, variable, deff), |
||
| 26 | +270 |
- #' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = "smd", reference_pkg = "cardx"))
+ # no by variable and row percentages+ |
+ ||
| 271 | +96x | +
+ denominator == "row" ~+ |
+ ||
| 272 | +96x | +
+ .one_svytable_rates_no_by_row(data, variable, deff) |
||
| 27 | +273 |
- #' ard_smd_smd(cards::ADSL, by = SEX, variables = AGE)+ ) |
||
| 28 | +274 |
- #' ard_smd_smd(cards::ADSL, by = SEX, variables = AGEGR1)+ |
||
| 29 | +275 |
- ard_smd_smd <- function(data, by, variables, std.error = TRUE, conf.level = 0.95, ...) {
+ # if a level was added, remove the fake level |
||
| 30 | -5x | +276 | +96x |
- set_cli_abort_call()+ if (length(variable_lvls) == 1L) {
|
| 31 | -+ | |||
| 277 | +6x |
-
+ result <- result |> dplyr::filter(.data$variable_level %in% variable_lvls) |
||
| 32 | +278 |
- # check installed packages ---------------------------------------------------+ } |
||
| 33 | -5x | +279 | +96x |
- check_pkg_installed("smd", reference_pkg = "cardx")
+ if (!is_empty(by) && length(by_lvls) == 1L) {
+ |
+
| 280 | +12x | +
+ result <- result |> dplyr::filter(.data$group1_level %in% by_lvls) |
||
| 34 | +281 |
-
+ } |
||
| 35 | +282 |
- # check/process inputs -------------------------------------------------------+ |
||
| 36 | -5x | +283 | +96x |
- check_not_missing(data)+ result |
| 37 | -5x | +|||
| 284 | +
- check_not_missing(variables)+ }+ |
+ |||
| 285 | ++ |
+ ) |> |
||
| 38 | -5x | +286 | +49x |
- check_not_missing(by)+ dplyr::bind_rows() |
| 39 | +287 | ++ |
+ }+ |
+ |
| 288 | ||||
| 40 | +289 |
- # grab design object if from `survey` ----------------------------------------+ .one_svytable_rates_no_by_row <- function(data, variable, deff) {
|
||
| 41 | -5x | +290 | +10x |
- is_survey <- inherits(data, "survey.design")+ dplyr::tibble( |
| 42 | -5x | +291 | +10x |
- if (is_survey) {
+ variable = .env$variable, |
| 43 | -1x | +292 | +10x |
- design <- data+ variable_level = unique(data$variables[[variable]]) |> sort() |> as.character(), |
| 44 | -1x | +293 | +10x |
- data <- design$variables+ p = 1,+ |
+
| 294 | +10x | +
+ p.std.error = 0,+ |
+ ||
| 295 | +10x | +
+ deff = NaN |
||
| 45 | +296 |
- }+ ) |
||
| 46 | +297 |
-
+ } |
||
| 47 | +298 | |||
| 48 | +299 |
- # continue check/process inputs ----------------------------------------------+ .one_svytable_rates_no_by_column_and_cell <- function(data, variable, deff) {
|
||
| 49 | -5x | +300 | +23x |
- check_data_frame(data)+ survey::svymean(reformulate2(variable), design = data, na.rm = TRUE, deff = deff) |> |
| 50 | -5x | +301 | +23x |
- data <- dplyr::ungroup(data)+ dplyr::as_tibble(rownames = "var_level") |> |
| 51 | -5x | +302 | +23x |
- cards::process_selectors(data, by = {{ by }}, variables = {{ variables }})
+ dplyr::mutate( |
| 52 | -5x | -
- check_scalar(by)- |
- ||
| 53 | -+ | 303 | +23x |
- # This check can be relaxed, but would require some changes to handle multi-row outputs+ variable_level = str_remove(.data$var_level, pattern = paste0("^", .env$variable)),
|
| 54 | -5x | -
- check_n_levels(data[[by]], 2L, message = "The {.arg by} column must have {.val {length}} levels.")
- |
- ||
| 55 | -+ | 304 | +23x |
-
+ variable = .env$variable |
| 56 | +305 |
- # if no variables selected, return empty tibble ------------------------------+ ) |> |
||
| 57 | -5x | -
- if (is_empty(variables)) {
- |
- ||
| 58 | -! | +306 | +23x |
- return(dplyr::tibble())+ dplyr::select("variable", "variable_level", p = "mean", p.std.error = "SE", any_of("deff"))
|
| 59 | +307 |
- }+ } |
||
| 60 | +308 | |||
| 61 | +309 |
- # build ARD ------------------------------------------------------------------+ .one_svytable_rates_by_cell <- function(data, variable, by, deff) {
|
||
| 62 | -5x | +310 | +20x |
- lapply(+ df_interaction_id <- |
| 63 | -5x | +311 | +20x |
- variables,+ .df_all_combos(data, variable, by) |> |
| 64 | -5x | +312 | +20x |
- function(variable) {
+ dplyr::mutate( |
| 65 | -6x | +313 | +20x |
- .format_smd_results(+ var_level = |
| 66 | -6x | +314 | +20x |
- by = by,+ glue::glue("interaction({.env$by}, {.env$variable}){.data$group1_level}.{.data$variable_level}")
|
| 67 | -6x | +|||
| 315 | +
- variable = variable,+ ) |
|||
| 68 | -6x | +|||
| 316 | +
- lst_tidy =+ |
|||
| 69 | -6x | +317 | +20x |
- cards::eval_capture_conditions(+ survey::svymean( |
| 70 | -6x | +318 | +20x |
- switch(as.character(is_survey),+ x = inject(~ interaction(!!sym(bt(by)), !!sym(bt(variable)))), |
| 71 | -6x | +319 | +20x |
- "TRUE" = smd::smd(x = data[[variable]], g = data[[by]], w = stats::weights(design), na.rm = TRUE, std.error = std.error, ...),+ design = data, |
| 72 | -6x | -
- "FALSE" = smd::smd(x = data[[variable]], g = data[[by]], na.rm = TRUE, std.error = std.error, ...)- |
- ||
| 73 | -+ | 320 | +20x |
- ) |>+ na.rm = TRUE, |
| 74 | -6x | +321 | +20x |
- dplyr::select(-any_of("term")) %>%
+ deff = deff |
| 75 | +322 |
- # styler: off+ ) |> |
||
| 76 | -5x | +323 | +20x |
- {if (isTRUE(std.error))
+ dplyr::as_tibble(rownames = "var_level") |> |
| 77 | -5x | -
- dplyr::mutate(- |
- ||
| 78 | -+ | 324 | +20x |
- .,+ dplyr::left_join(df_interaction_id, by = "var_level") |> |
| 79 | -5x | +325 | +20x |
- conf.low = .data$estimate + stats::qnorm((1 - .env$conf.level) / 2) * .data$std.error,+ dplyr::select( |
| 80 | -5x | +326 | +20x |
- conf.high = .data$estimate - stats::qnorm((1 - .env$conf.level) / 2) * .data$std.error,+ cards::all_ard_groups(), cards::all_ard_variables(), |
| 81 | -5x | +327 | +20x |
- method = "Standardized Mean Difference"+ p = "mean", p.std.error = "SE", any_of("deff")
|
| 82 | +328 |
- )+ ) |
||
| 83 | +329 |
- else+ } |
||
| 84 | -! | +|||
| 330 | +
- dplyr::mutate(+ |
|||
| 85 | +331 |
- .,+ .one_svytable_rates_by_row <- function(data, variable, by, deff) {
|
||
| 86 | -! | +|||
| 332 | +20x |
- method = "Standardized Mean Difference"- |
- ||
| 87 | -- |
- )}- |
- ||
| 88 | -- |
- # styler: on- |
- ||
| 89 | -- |
- ),- |
- ||
| 90 | -- |
- ...- |
- ||
| 91 | -- |
- )- |
- ||
| 92 | -- |
- }- |
- ||
| 93 | -- |
- ) |>- |
- ||
| 94 | -5x | -
- dplyr::bind_rows()- |
- ||
| 95 | -- |
- }- |
- ||
| 96 | -- | - - | -||
| 97 | -- | - - | -||
| 98 | -- |
- .format_smd_results <- function(by, variable, lst_tidy, ...) {
- |
- ||
| 99 | -- |
- # build ARD ------------------------------------------------------------------- |
- ||
| 100 | -6x | -
- ret <-- |
- ||
| 101 | -6x | -
- cards::tidy_as_ard(- |
- ||
| 102 | -6x | -
- lst_tidy = lst_tidy,- |
- ||
| 103 | -6x | -
- tidy_result_names = c("estimate", "std.error"),
- |
- ||
| 104 | -6x | -
- fun_args_to_record = c("gref"),
- |
- ||
| 105 | -6x | -
- formals = formals(smd::smd)[c("gref")],
- |
- ||
| 106 | -- |
- # removing the `std.error` ARGUMENT (not the result)- |
- ||
| 107 | -6x | -
- passed_args = dots_list(...) |> utils::modifyList(list(std.error = NULL)),- |
- ||
| 108 | -6x | -
- lst_ard_columns = list(group1 = by, variable = variable, context = "smd_smd")- |
- ||
| 109 | -- |
- )- |
- ||
| 110 | -- | - - | -||
| 111 | -- |
- # add the stat label ---------------------------------------------------------- |
- ||
| 112 | -6x | -
- ret |>- |
- ||
| 113 | -6x | -
- dplyr::left_join(- |
- ||
| 114 | -6x | -
- dplyr::tribble(- |
- ||
| 115 | -6x | -
- ~stat_name, ~stat_label,- |
- ||
| 116 | -6x | -
- "estimate", "Standardized Mean Difference",- |
- ||
| 117 | -6x | -
- "std.error", "Standard Error",- |
- ||
| 118 | -6x | -
- "gref", "Integer Reference Group Level"- |
- ||
| 119 | -- |
- ),- |
- ||
| 120 | -6x | -
- by = "stat_name"- |
- ||
| 121 | -- |
- ) |>- |
- ||
| 122 | -6x | -
- dplyr::mutate(stat_label = dplyr::coalesce(.data$stat_label, .data$stat_name)) |>- |
- ||
| 123 | -6x | -
- cards::tidy_ard_column_order()- |
- ||
| 124 | -- |
- }- |
-
| 1 | -- |
- #' ARD Wilcoxon Rank-Sum Test- |
- ||
| 2 | -- |
- #'- |
- ||
| 3 | -- |
- #' @description- |
- ||
| 4 | -- |
- #' Analysis results data for paired and non-paired Wilcoxon Rank-Sum tests.- |
- ||
| 5 | -- |
- #'- |
- ||
| 6 | -- |
- #' @param data (`data.frame`)\cr- |
- ||
| 7 | -- |
- #' a data frame. See below for details.- |
- ||
| 8 | -- |
- #' @param by ([`tidy-select`][dplyr::dplyr_tidy_select])\cr- |
- ||
| 9 | -- |
- #' optional column name to compare by.- |
- ||
| 10 | -- |
- #' @param variables ([`tidy-select`][dplyr::dplyr_tidy_select])\cr- |
- ||
| 11 | -- |
- #' column names to be compared. Independent tests will be computed for- |
- ||
| 12 | -- |
- #' each variable.- |
- ||
| 13 | -- |
- #' @param id ([`tidy-select`][dplyr::dplyr_tidy_select])\cr- |
- ||
| 14 | -- |
- #' column name of the subject or participant ID.- |
- ||
| 15 | -- |
- #' @param conf.level (scalar `numeric`)\cr- |
- ||
| 16 | -- |
- #' confidence level for confidence interval. Default is `0.95`.- |
- ||
| 17 | -- |
- #' @param ... arguments passed to `wilcox.test(...)`- |
- ||
| 18 | -- |
- #'- |
- ||
| 19 | -- |
- #' @return ARD data frame- |
- ||
| 20 | -- |
- #' @name ard_stats_wilcox_test- |
- ||
| 21 | -- |
- #'- |
- ||
| 22 | -- |
- #' @details- |
- ||
| 23 | -- |
- #' For the `ard_stats_wilcox_test()` function, the data is expected to be one row per subject.- |
- ||
| 24 | -- |
- #' The data is passed as `wilcox.test(data[[variable]] ~ data[[by]], paired = FALSE, ...)`.- |
- ||
| 25 | -- |
- #'- |
- ||
| 26 | -- |
- #' For the `ard_stats_paired_wilcox_test()` function, the data is expected to be one row- |
- ||
| 27 | -- |
- #' per subject per by level. Before the test is calculated, the data are- |
- ||
| 28 | -- |
- #' reshaped to a wide format to be one row per subject.- |
- ||
| 29 | -- |
- #' The data are then passed as- |
- ||
| 30 | -- |
- #' `wilcox.test(x = data_wide[[<by level 1>]], y = data_wide[[<by level 2>]], paired = TRUE, ...)`.- |
- ||
| 31 | -- |
- #'- |
- ||
| 32 | -- |
- #' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = "broom", reference_pkg = "cardx"))
- |
- ||
| 33 | -- |
- #' cards::ADSL |>- |
- ||
| 34 | -- |
- #' dplyr::filter(ARM %in% c("Placebo", "Xanomeline High Dose")) |>
- |
- ||
| 35 | -- |
- #' ard_stats_wilcox_test(by = "ARM", variables = "AGE")- |
- ||
| 36 | -- |
- #'- |
- ||
| 37 | -- |
- #' # constructing a paired data set,- |
- ||
| 38 | -- |
- #' # where patients receive both treatments- |
- ||
| 39 | -- |
- #' cards::ADSL[c("ARM", "AGE")] |>
- |
- ||
| 40 | -- |
- #' dplyr::filter(ARM %in% c("Placebo", "Xanomeline High Dose")) |>
- |
- ||
| 41 | -- |
- #' dplyr::mutate(.by = ARM, USUBJID = dplyr::row_number()) |>- |
- ||
| 42 | -- |
- #' dplyr::arrange(USUBJID, ARM) |>- |
- ||
| 43 | -- |
- #' ard_stats_paired_wilcox_test(by = ARM, variables = AGE, id = USUBJID)- |
- ||
| 44 | -- |
- NULL- |
- ||
| 45 | -- | - - | -||
| 46 | -- |
- #' @rdname ard_stats_wilcox_test- |
- ||
| 47 | -- |
- #' @export- |
- ||
| 48 | -- |
- ard_stats_wilcox_test <- function(data, variables, by = NULL, conf.level = 0.95, ...) {
- |
- ||
| 49 | -5x | -
- set_cli_abort_call()- |
- ||
| 50 | -- | - - | -||
| 51 | -- |
- # check installed packages ---------------------------------------------------- |
- ||
| 52 | -5x | -
- check_pkg_installed("broom", reference_pkg = "cardx")
- |
- ||
| 53 | -- | - - | -||
| 54 | -- |
- # check/process inputs -------------------------------------------------------- |
- ||
| 55 | -5x | -
- check_not_missing(data)- |
- ||
| 56 | -5x | -
- check_not_missing(variables)- |
- ||
| 57 | -5x | -
- check_data_frame(data)- |
- ||
| 58 | -5x | -
- data <- dplyr::ungroup(data)- |
- ||
| 59 | -5x | -
- cards::process_selectors(data, by = {{ by }}, variables = {{ variables }})
- |
- ||
| 60 | -5x | -
- check_scalar(by, allow_empty = TRUE)- |
- ||
| 61 | -5x | -
- check_range(conf.level, range = c(0, 1))- |
- ||
| 62 | -- | - - | -||
| 63 | -- |
- # if no variables selected, return empty tibble ------------------------------- |
- ||
| 64 | -5x | -
- if (is_empty(variables)) {
- |
- ||
| 65 | -! | -
- return(dplyr::tibble())- |
- ||
| 66 | -- |
- }- |
- ||
| 67 | -- | - - | -||
| 68 | -- |
- # build ARD ------------------------------------------------------------------- |
- ||
| 69 | -5x | -
- lapply(- |
- ||
| 70 | -5x | -
- variables,- |
- ||
| 71 | -5x | -
- function(variable) {
- |
- ||
| 72 | -6x | -
- .format_wilcoxtest_results(- |
- ||
| 73 | -6x | -
- by = by,- |
- ||
| 74 | -6x | -
- variable = variable,- |
- ||
| 75 | -6x | -
- lst_tidy =- |
- ||
| 76 | -- |
- # styler: off- |
- ||
| 77 | -6x | -
- cards::eval_capture_conditions(- |
- ||
| 78 | -6x | -
- if (!is_empty(by)) {
- |
- ||
| 79 | -5x | -
- stats::wilcox.test(data[[variable]] ~ data[[by]], conf.level = conf.level, ...) |>- |
- ||
| 80 | -5x | -
- broom::tidy()- |
- ||
| 81 | -- |
- }- |
- ||
| 82 | -- |
- else {
- |
- ||
| 83 | -1x | -
- stats::wilcox.test(data[[variable]], ...) |>- |
- ||
| 84 | -1x | -
- broom::tidy()- |
- ||
| 85 | -- |
- }- |
- ||
| 86 | -- |
- ),- |
- ||
| 87 | -- |
- # styler: on- |
- ||
| 88 | -6x | -
- paired = FALSE,- |
- ||
| 89 | -- |
- ...- |
- ||
| 90 | -- |
- )- |
- ||
| 91 | -- |
- }- |
- ||
| 92 | -- |
- ) |>- |
- ||
| 93 | -5x | -
- dplyr::bind_rows()- |
- ||
| 94 | -- |
- }- |
- ||
| 95 | -- | - - | -||
| 96 | -- |
- #' @rdname ard_stats_wilcox_test- |
- ||
| 97 | -- |
- #' @export- |
- ||
| 98 | -- |
- ard_stats_paired_wilcox_test <- function(data, by, variables, id, conf.level = 0.95, ...) {
- |
- ||
| 99 | -2x | -
- set_cli_abort_call()- |
- ||
| 100 | -- | - - | -||
| 101 | -- |
- # check installed packages ---------------------------------------------------- |
- ||
| 102 | -2x | -
- check_pkg_installed("broom", reference_pkg = "cardx")
- |
- ||
| 103 | -- | - - | -||
| 104 | -- |
- # check/process inputs -------------------------------------------------------- |
- ||
| 105 | -2x | -
- check_not_missing(data)- |
- ||
| 106 | -2x | -
- check_not_missing(variables)- |
- ||
| 107 | -2x | -
- check_not_missing(by)- |
- ||
| 108 | -2x | -
- check_not_missing(id)- |
- ||
| 109 | -2x | -
- check_data_frame(data)- |
- ||
| 110 | -2x | -
- data <- dplyr::ungroup(data)- |
- ||
| 111 | -2x | -
- cards::process_selectors(data, by = {{ by }}, variables = {{ variables }}, id = {{ id }})
- |
- ||
| 112 | -2x | -
- check_scalar(by)- |
- ||
| 113 | -2x | -
- check_scalar(id)- |
- ||
| 114 | -- | - - | -||
| 115 | -- |
- # if no variables selected, return empty tibble ------------------------------- |
- ||
| 116 | -2x | -
- if (is_empty(variables)) {
- |
- ||
| 117 | -! | -
- return(dplyr::tibble())- |
- ||
| 118 | -- |
- }- |
- ||
| 119 | -- | - - | -||
| 120 | -- |
- # build ARD ------------------------------------------------------------------- |
- ||
| 121 | -2x | -
- lapply(- |
- ||
| 122 | -2x | -
- variables,- |
- ||
| 123 | -2x | -
- function(variable) {
- |
- ||
| 124 | -2x | -
- .format_wilcoxtest_results(- |
- ||
| 125 | -2x | -
- by = by,+ survey::svyby( |
||
| 126 | -2x | -
- variable = variable,- |
- ||
| 127 | -2x | +333 | +20x |
- lst_tidy =+ formula = reformulate2(by), |
| 128 | -2x | -
- cards::eval_capture_conditions({
- |
- ||
| 129 | -+ | 334 | +20x |
- # adding this reshape inside the eval, so if there is an error it's captured in the ARD object+ by = reformulate2(variable), |
| 130 | -2x | -
- data_wide <- .paired_data_pivot_wider(data, by = by, variable = variable, id = id)- |
- ||
| 131 | -+ | 335 | +20x |
- # perform paired wilcox test+ design = data, |
| 132 | -1x | +336 | +20x |
- stats::wilcox.test(x = data_wide[["by1"]], y = data_wide[["by2"]], paired = TRUE, conf.level = conf.level, ...) |>+ FUN = survey::svymean, |
| 133 | -1x | -
- broom::tidy()- |
- ||
| 134 | -+ | 337 | +20x |
- }),+ na.rm = TRUE, |
| 135 | -2x | -
- paired = TRUE,- |
- ||
| 136 | -- |
- ...- |
- ||
| 137 | -- |
- )- |
- ||
| 138 | -+ | 338 | +20x |
- }+ deff = deff |
| 139 | +339 |
) |> |
||
| 140 | -2x | -
- dplyr::bind_rows()- |
- ||
| 141 | -- |
- }- |
- ||
| 142 | -- | - - | -||
| 143 | -- | - - | -||
| 144 | -- |
- #' Convert Wilcoxon test to ARD- |
- ||
| 145 | -- |
- #'- |
- ||
| 146 | -- |
- #' @inheritParams cards::tidy_as_ard- |
- ||
| 147 | -- |
- #' @inheritParams stats::wilcox.test- |
- ||
| 148 | -- |
- #' @param by (`string`)\cr by column name- |
- ||
| 149 | -- |
- #' @param variable (`string`)\cr variable column name- |
- ||
| 150 | -- |
- #' @param ... passed to `stats::wilcox.test(...)`- |
- ||
| 151 | -- |
- #'- |
- ||
| 152 | -- |
- #' @return ARD data frame- |
- ||
| 153 | -- |
- #'- |
- ||
| 154 | -- |
- #' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = "broom", reference_pkg = "cardx"))
- |
- ||
| 155 | -- |
- #' # Pre-processing ADSL to have grouping factor (ARM here) with 2 levels- |
- ||
| 156 | -- |
- #' ADSL <- cards::ADSL |>- |
- ||
| 157 | -- |
- #' dplyr::filter(ARM %in% c("Placebo", "Xanomeline High Dose")) |>
- |
- ||
| 158 | -- |
- #' ard_stats_wilcox_test(by = "ARM", variables = "AGE")- |
- ||
| 159 | -- |
- #'- |
- ||
| 160 | -- |
- #' cardx:::.format_wilcoxtest_results(- |
- ||
| 161 | -- |
- #' by = "ARM",- |
- ||
| 162 | -- |
- #' variable = "AGE",- |
- ||
| 163 | -- |
- #' paired = FALSE,- |
- ||
| 164 | -- |
- #' lst_tidy =- |
- ||
| 165 | -- |
- #' cards::eval_capture_conditions(- |
- ||
| 166 | -- |
- #' stats::wilcox.test(ADSL[["AGE"]] ~ ADSL[["ARM"]], paired = FALSE) |>- |
- ||
| 167 | -- |
- #' broom::tidy()- |
- ||
| 168 | -- |
- #' )- |
- ||
| 169 | -- |
- #' )- |
- ||
| 170 | -- |
- #'- |
- ||
| 171 | -- |
- #' @keywords internal- |
- ||
| 172 | -- |
- .format_wilcoxtest_results <- function(by = NULL, variable, lst_tidy, paired, ...) {
- |
- ||
| 173 | -+ | 340 | +20x |
- # build ARD ------------------------------------------------------------------+ dplyr::as_tibble() |> |
| 174 | -8x | +341 | +20x |
- ret <-+ tidyr::pivot_longer(-all_of(variable)) |> |
| 175 | -8x | +342 | +20x |
- cards::tidy_as_ard(+ dplyr::mutate( |
| 176 | -8x | +343 | +20x |
- lst_tidy = lst_tidy,+ stat = |
| 177 | -8x | +344 | +20x |
- tidy_result_names = c("statistic", "p.value", "method", "alternative"),
+ dplyr::case_when( |
| 178 | -8x | +345 | +20x |
- fun_args_to_record = c(+ startsWith(.data$name, paste0("se.", by)) | startsWith(.data$name, paste0("se.`", by, "`")) ~ "p.std.error",
|
| 179 | -8x | +346 | +20x |
- "mu", "paired", "exact", "correct", "conf.int",+ startsWith(.data$name, paste0("DEff.", by)) | startsWith(.data$name, paste0("DEff.`", by, "`")) ~ "deff",
|
| 180 | -8x | +347 | +20x |
- "conf.level", "tol.root", "digits.rank"+ TRUE ~ "p" |
| 181 | +348 |
- ),- |
- ||
| 182 | -8x | -
- formals = formals(asNamespace("stats")[["wilcox.test.default"]]),
+ ), |
||
| 183 | -8x | +349 | +20x |
- passed_args = c(list(paired = paired), dots_list(...)),+ name = |
| 184 | -8x | -
- lst_ard_columns = list(variable = variable, context = "stats_wilcox_test")- |
- ||
| 185 | -- |
- )- |
- ||
| 186 | -+ | 350 | +20x |
-
+ str_remove_all(.data$name, "se\\.") %>% |
| 187 | -8x | +351 | +20x |
- if (!is_empty(by)) {
+ str_remove_all("DEff\\.") %>%
|
| 188 | -7x | +352 | +20x |
- ret <- ret |>+ str_remove_all(by) %>% |
| 189 | -7x | -
- dplyr::mutate(group1 = by)- |
- ||
| 190 | -- |
- }- |
- ||
| 191 | -+ | 353 | +20x |
-
+ str_remove_all("`")
|
| 192 | +354 |
- # add the stat label ---------------------------------------------------------+ ) |> |
||
| 193 | -8x | +355 | +20x |
- ret |>+ tidyr::pivot_wider(names_from = "stat", values_from = "value") |> |
| 194 | -8x | +356 | +20x |
- dplyr::left_join(+ set_names(c("variable_level", "group1_level", "p", "p.std.error", "deff")) |>
|
| 195 | -8x | +357 | +20x |
- .df_wilcoxtest_stat_labels(by),+ dplyr::mutate( |
| 196 | -8x | -
- by = "stat_name"- |
- ||
| 197 | -+ | 358 | +20x |
- ) |>+ group1 = .env$by, |
| 198 | -8x | +359 | +20x |
- dplyr::mutate(stat_label = dplyr::coalesce(.data$stat_label, .data$stat_name)) |>+ variable = .env$variable, |
| 199 | -8x | +360 | +20x |
- cards::tidy_ard_column_order()+ across(c("group1_level", "variable_level"), as.character)
|
| 200 | +361 |
- }+ ) |
||
| 201 | +362 |
-
+ } |
||
| 202 | +363 | |||
| 203 | +364 |
- .df_wilcoxtest_stat_labels <- function(by = NULL) {
+ .one_svytable_rates_by_column <- function(data, variable, by, deff) {
|
||
| 204 | -8x | +365 | +23x |
- dplyr::tribble(+ survey::svyby( |
| 205 | -8x | +366 | +23x |
- ~stat_name, ~stat_label,+ formula = reformulate2(variable), |
| 206 | -8x | +367 | +23x |
- "statistic", ifelse(is.null(by), "V Statistic", "X-squared Statistic"),+ by = reformulate2(by), |
| 207 | -8x | +368 | +23x |
- "parameter", "Degrees of Freedom",+ design = data, |
| 208 | -8x | +369 | +23x |
- "estimate", "Median of the Difference",+ FUN = survey::svymean, |
| 209 | -8x | +370 | +23x |
- "p.value", "p-value",+ na.rm = TRUE, |
| 210 | -8x | +371 | +23x |
- "conf.low", "CI Lower Bound",+ deff = deff |
| 211 | -8x | +|||
| 372 | +
- "conf.high", "CI Upper Bound",+ ) |> |
|||
| 212 | -8x | +373 | +23x |
- "paired", "Paired test",+ dplyr::as_tibble() |> |
| 213 | -8x | -
- "conf.level", "CI Confidence Level",- |
- ||
| 214 | -+ | 374 | +23x |
- )+ tidyr::pivot_longer(-all_of(by)) |> |
| 215 | -+ | |||
| 375 | +23x |
- }+ dplyr::mutate( |
| 1 | -+ | |||
| 376 | +23x |
- #' Regression VIF ARD+ stat = |
||
| 2 | -+ | |||
| 377 | +23x |
- #'+ dplyr::case_when( |
||
| 3 | -+ | |||
| 378 | +23x |
- #' @description+ startsWith(.data$name, paste0("se.", variable)) | startsWith(.data$name, paste0("se.`", variable, "`")) ~ "p.std.error",
|
||
| 4 | -+ | |||
| 379 | +23x |
- #' Function takes a regression model object and returns the variance inflation factor (VIF)+ startsWith(.data$name, paste0("DEff.", variable)) | startsWith(.data$name, paste0("DEff.`", variable, "`")) ~ "deff",
|
||
| 5 | -+ | |||
| 380 | +23x |
- #' using [`car::vif()`] and converts it to a ARD structure+ TRUE ~ "p" |
||
| 6 | +381 |
- #'+ ), |
||
| 7 | -+ | |||
| 382 | +23x |
- #' @param x regression model object+ name = |
||
| 8 | -+ | |||
| 383 | +23x |
- #' See car::vif() for details+ str_remove_all(.data$name, "se\\.") %>% |
||
| 9 | -+ | |||
| 384 | +23x |
- #'+ str_remove_all("DEff\\.") %>%
|
||
| 10 | -+ | |||
| 385 | +23x |
- #' @param ... arguments passed to `car::vif(...)`+ str_remove_all(variable) %>% |
||
| 11 | -+ | |||
| 386 | +23x |
- #'+ str_remove_all("`")
|
||
| 12 | +387 |
- #' @return data frame+ ) |> |
||
| 13 | -+ | |||
| 388 | +23x |
- #' @name ard_car_vif+ tidyr::pivot_wider(names_from = "stat", values_from = "value") |> |
||
| 14 | -+ | |||
| 389 | +23x |
- #' @rdname ard_car_vif+ set_names(c("group1_level", "variable_level", "p", "p.std.error", "deff")) |>
|
||
| 15 | -+ | |||
| 390 | +23x |
- #' @export+ dplyr::mutate( |
||
| 16 | -+ | |||
| 391 | +23x |
- #'+ group1 = .env$by, |
||
| 17 | -+ | |||
| 392 | +23x |
- #' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = "car", reference_pkg = "cardx"))
+ variable = .env$variable, |
||
| 18 | -+ | |||
| 393 | +23x |
- #' lm(AGE ~ ARM + SEX, data = cards::ADSL) |>+ across(c("group1_level", "variable_level"), as.character)
|
||
| 19 | +394 |
- #' ard_car_vif()+ ) |
||
| 20 | +395 |
- ard_car_vif <- function(x, ...) {
- |
- ||
| 21 | -3x | -
- set_cli_abort_call()+ } |
||
| 22 | +396 | |||
| 23 | +397 |
- # check installed packages ---------------------------------------------------+ .svytable_counts <- function(data, variables, by, denominator) {
|
||
| 24 | -3x | +398 | +49x |
- check_pkg_installed("car", reference_pkg = "cardx")
+ df_counts <- |
| 25 | -+ | |||
| 399 | +49x |
-
+ lapply( |
||
| 26 | -+ | |||
| 400 | +49x |
- # check inputs ---------------------------------------------------------------+ variables, |
||
| 27 | -3x | +401 | +49x |
- check_not_missing(x)+ \(variable) {
|
| 28 | +402 |
-
+ # perform weighted tabulation |
||
| 29 | -3x | +403 | +96x |
- vif <- cards::eval_capture_conditions(car::vif(x, ...))+ df_count <- |
| 30 | -+ | |||
| 404 | +96x |
-
+ survey::svytable(formula = reformulate2(c(by, variable)), design = data) |> |
||
| 31 | -+ | |||
| 405 | +96x |
- # if vif failed, set result as NULL, error will be kept through eval_capture_conditions()+ dplyr::as_tibble() |
||
| 32 | -3x | +406 | +96x |
- if (is.null(vif$result)) {
+ if (is_empty(by)) {
|
| 33 | -+ | |||
| 407 | +33x |
- # try to capture variable names from `terms()`+ names(df_count) <- c("variable_level", "n")
|
||
| 34 | -2x | +408 | +33x |
- lst_terms <- cards::eval_capture_conditions(attr(stats::terms(x), "term.labels"))+ df_count$variable <- variable |
| 35 | +409 |
- # we cannot get variable names, error out+ } else {
|
||
| 36 | -2x | +410 | +63x |
- if (!is.null(lst_terms[["error"]])) {
+ names(df_count) <- c("group1_level", "variable_level", "n")
|
| 37 | -1x | +411 | +63x |
- cli::cli_abort(+ df_count$variable <- variable |
| 38 | -1x | +412 | +63x |
- c("There was an error running {.fun car::vif}. See below.", x = vif[["error"]]),
+ df_count$group1 <- by |
| 39 | -1x | +|||
| 413 | +
- call = get_cli_abort_call()+ } |
|||
| 40 | +414 |
- )+ |
||
| 41 | +415 |
- }+ # adding unobserved levels |
||
| 42 | -1x | +416 | +96x |
- vif$result <- dplyr::tibble(+ .df_all_combos(data, variable, by) %>% |
| 43 | -1x | +417 | +96x |
- variable = lst_terms[["result"]],+ dplyr::left_join( |
| 44 | -1x | +418 | +96x |
- VIF = list(NULL),+ df_count, |
| 45 | -1x | +419 | +96x |
- GVIF = list(NULL),+ by = names(.) |
| 46 | -1x | +|||
| 420 | +
- aGVIF = list(NULL),+ ) |> |
|||
| 47 | -1x | -
- df = list(NULL)- |
- ||
| 48 | -+ | 421 | +96x |
- )+ tidyr::replace_na(list(n = 0)) # unobserved levels assigned zero count |
| 49 | +422 |
- }+ } |
||
| 50 | +423 |
- # if VIF is returned+ ) |> |
||
| 51 | -1x | -
- else if (!is.matrix(vif$result)) {
- |
- ||
| 52 | -! | +424 | +49x |
- vif$result <- dplyr::tibble(variable = names(vif$result), VIF = vif$result)+ dplyr::bind_rows() |
| 53 | +425 |
- }+ |
||
| 54 | +426 |
- # if Generalized VIF is returned- |
- ||
| 55 | -1x | -
- else if (is.matrix(vif$result)) {
- |
- ||
| 56 | -1x | -
- vif$result <-+ # add big N and p, then return data frame of results |
||
| 57 | -1x | +427 | +49x |
- vif$result |>+ switch(denominator, |
| 58 | -1x | +|||
| 428 | +
- as.data.frame() %>%+ "column" = |
|||
| 59 | -1x | +429 | +19x |
- dplyr::mutate(., variable = rownames(.), .before = 1L) |>+ df_counts |> |
| 60 | -1x | +430 | +19x |
- dplyr::rename(+ dplyr::mutate( |
| 61 | -1x | +431 | +19x |
- aGVIF = "GVIF^(1/(2*Df))",+ .by = c(cards::all_ard_groups(), cards::all_ard_variables("names")),
|
| 62 | -1x | -
- df = "Df"- |
- ||
| 63 | -+ | 432 | +19x |
- ) |>+ N = sum(.data$n), |
| 64 | -1x | -
- dplyr::tibble()- |
- ||
| 65 | -+ | 433 | +19x |
- }+ p = .data$n / .data$N |
| 66 | +434 |
-
+ ), |
||
| 67 | +435 |
- # Clean-up the result to fit the ard structure through pivot- |
- ||
| 68 | -2x | -
- vif$result <-+ "row" = |
||
| 69 | -2x | +436 | +15x |
- vif$result |>+ df_counts |> |
| 70 | -2x | +437 | +15x |
- tidyr::pivot_longer(+ dplyr::mutate( |
| 71 | -2x | +438 | +15x |
- cols = -c("variable"),
+ .by = cards::all_ard_variables(), |
| 72 | -2x | +439 | +15x |
- names_to = "stat_name",+ N = sum(.data$n), |
| 73 | -2x | +440 | +15x |
- values_to = "stat"+ p = .data$n / .data$N |
| 74 | +441 |
- ) |>+ ), |
||
| 75 | -2x | +|||
| 442 | +
- dplyr::mutate(+ "cell" = |
|||
| 76 | -2x | +443 | +15x |
- context = "car_vif",+ df_counts |> |
| 77 | -2x | +444 | +15x |
- stat_label = ifelse(+ dplyr::mutate( |
| 78 | -2x | +445 | +15x |
- .data$stat_name == "aGVIF",+ .by = c(cards::all_ard_groups("names"), cards::all_ard_variables("names")),
|
| 79 | -2x | +446 | +15x |
- "Adjusted GVIF",+ N = sum(.data$n), |
| 80 | -2x | +447 | +15x |
- .data$stat_name+ p = .data$n / .data$N |
| 81 | +448 |
- ),- |
- ||
| 82 | -2x | -
- fmt_fn = map(+ ) |
||
| 83 | -2x | +|||
| 449 | +
- .data$stat,+ ) |
|||
| 84 | -2x | +|||
| 450 | +
- function(.x) {
+ } |
|||
| 85 | +451 |
- # styler: off+ |
||
| 86 | -! | +|||
| 452 | +
- if (is.integer(.x)) return(0L)+ .df_all_combos <- function(data, variable, by) {
|
|||
| 87 | -6x | +453 | +116x |
- if (is.numeric(.x)) return(1L)+ df <- cards::nest_for_ard( |
| 88 | -+ | |||
| 454 | +116x |
- # styler: on+ data = data$variables, |
||
| 89 | -4x | +455 | +116x |
- NULL+ by = c(by, variable), |
| 90 | -+ | |||
| 456 | +116x |
- }+ list_columns = FALSE, |
||
| 91 | -+ | |||
| 457 | +116x |
- )+ include_data = FALSE |
||
| 92 | +458 |
- )+ ) |
||
| 93 | +459 | |||
| 94 | +460 |
- # Bind the results and possible warning/errors together+ # renaming with variable colnames |
||
| 95 | -2x | +461 | +116x |
- vif_return <- dplyr::tibble(+ if (!is_empty(by)) {
|
| 96 | -2x | +462 | +83x |
- vif$result,+ df <- dplyr::rename(df, variable = "group2", variable_level = "group2_level") |
| 97 | -2x | +|||
| 463 | +
- warning = vif["warning"],+ } else {
|
|||
| 98 | -2x | +464 | +33x |
- error = vif["error"]+ df <- dplyr::rename(df, variable = "group1", variable_level = "group1_level") |
| 99 | +465 |
- )+ } |
||
| 100 | +466 | |||
| 101 | +467 |
- # Clean up return object+ # convert levels to character for merging later |
||
| 102 | -2x | +468 | +116x |
- vif_return |>+ df |> |
| 103 | -2x | +469 | +116x |
- cards::tidy_ard_column_order() %>%+ dplyr::mutate( |
| 104 | -2x | +470 | +116x |
- {structure(., class = c("card", class(.)))} # styler: off
+ across( |
| 105 | -+ | |||
| 471 | +116x |
- }+ c(cards::all_ard_groups("levels"), cards::all_ard_variables("levels")),
|
| 1 | -+ | |||
| 472 | +116x |
- #' ARD Cohen's D Test+ as.character |
||
| 2 | +473 |
- #'+ ) |
||
| 3 | +474 |
- #' @description+ ) |
||
| 4 | +475 |
- #' Analysis results data for paired and non-paired Cohen's D Effect Size Test+ } |
||
| 5 | +476 |
- #' using [`effectsize::cohens_d()`].+ |
||
| 6 | +477 |
- #'+ case_switch <- function(..., .default = NULL) {
|
||
| 7 | +478 |
- #' @param data (`data.frame`)\cr+ dots <- dots_list(...) |
||
| 8 | +479 |
- #' a data frame. See below for details.+ |
||
| 9 | +480 |
- #' @param by ([`tidy-select`][dplyr::dplyr_tidy_select])\cr+ for (f in dots) {
|
||
| 10 | +481 |
- #' column name to compare by. Must be a categorical variable with exactly two levels.+ if (isTRUE(eval(f_lhs(f), envir = attr(f, ".Environment")))) {
|
||
| 11 | +482 |
- #' @param variables ([`tidy-select`][dplyr::dplyr_tidy_select])\cr+ return(eval(f_rhs(f), envir = attr(f, ".Environment"))) |
||
| 12 | +483 |
- #' column names to be compared. Must be a continuous variables.+ } |
||
| 13 | +484 |
- #' Independent tests will be run for each variable.+ } |
||
| 14 | +485 |
- #' @param id ([`tidy-select`][dplyr::dplyr_tidy_select])\cr+ |
||
| 15 | +486 |
- #' column name of the subject or participant ID+ return(.default) |
||
| 16 | +487 |
- #' @param conf.level (scalar `numeric`)\cr+ } |
||
| 17 | +488 |
- #' confidence level for confidence interval. Default is `0.95`.+ |
||
| 18 | +489 |
- #' @param ... arguments passed to `effectsize::cohens_d(...)`+ .default_svy_cat_fmt_fn <- function(x) {
|
||
| 19 | -+ | |||
| 490 | +53x |
- #'+ x |> |
||
| 20 | -+ | |||
| 491 | +53x |
- #' @return ARD data frame+ dplyr::mutate( |
||
| 21 | -+ | |||
| 492 | +53x |
- #' @name ard_effectsize_cohens_d+ fmt_fn = |
||
| 22 | -+ | |||
| 493 | +53x |
- #'+ pmap( |
||
| 23 | -+ | |||
| 494 | +53x |
- #' @details+ list(.data$stat_name, .data$stat, .data$fmt_fn), |
||
| 24 | -+ | |||
| 495 | +53x |
- #' For the `ard_effectsize_cohens_d()` function, the data is expected to be one row per subject.+ function(stat_name, stat, fmt_fn) {
|
||
| 25 | -+ | |||
| 496 | +3438x |
- #' The data is passed as `effectsize::cohens_d(data[[variable]]~data[[by]], data, paired = FALSE, ...)`.+ if (!is_empty(fmt_fn)) {
|
||
| 26 | -+ | |||
| 497 | +! |
- #'+ return(fmt_fn) |
||
| 27 | +498 |
- #' For the `ard_effectsize_paired_cohens_d()` function, the data is expected to be one row+ } |
||
| 28 | -+ | |||
| 499 | +3438x |
- #' per subject per by level. Before the effect size is calculated, the data are+ if (stat_name %in% c("p", "p_miss", "p_nonmiss", "p_unweighted")) {
|
||
| 29 | -+ | |||
| 500 | +864x |
- #' reshaped to a wide format to be one row per subject.+ return(cards::label_cards(digits = 1, scale = 100)) |
||
| 30 | +501 |
- #' The data are then passed as+ } |
||
| 31 | -+ | |||
| 502 | +2574x |
- #' `effectsize::cohens_d(x = data_wide[[<by level 1>]], y = data_wide[[<by level 2>]], paired = TRUE, ...)`.+ if (stat_name %in% c("n", "N", "N_miss", "N_nonmiss", "N_obs", "n_unweighted", "N_unweighted")) {
|
||
| 32 | -+ | |||
| 503 | +1719x |
- #'+ return(cards::label_cards(digits = 0)) |
||
| 33 | +504 |
- #' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = c("effectsize", "parameters"), reference_pkg = "cardx"))
+ } |
||
| 34 | -+ | |||
| 505 | +855x |
- #' cards::ADSL |>+ if (is.integer(stat)) {
|
||
| 35 | -+ | |||
| 506 | +27x |
- #' dplyr::filter(ARM %in% c("Placebo", "Xanomeline High Dose")) |>
+ return(0L) |
||
| 36 | +507 |
- #' ard_effectsize_cohens_d(by = ARM, variables = AGE)+ } |
||
| 37 | -+ | |||
| 508 | +828x |
- #'+ if (is.numeric(stat)) {
+ |
+ ||
| 509 | +828x | +
+ return(1L) |
||
| 38 | +510 |
- #' # constructing a paired data set,+ }+ |
+ ||
| 511 | +! | +
+ return(as.character) |
||
| 39 | +512 |
- #' # where patients receive both treatments+ } |
||
| 40 | +513 |
- #' cards::ADSL[c("ARM", "AGE")] |>
+ ) |
||
| 41 | +514 |
- #' dplyr::filter(ARM %in% c("Placebo", "Xanomeline High Dose")) |>
+ ) |
||
| 42 | +515 |
- #' dplyr::mutate(.by = ARM, USUBJID = dplyr::row_number()) |>+ } |
||
| 43 | +516 |
- #' dplyr::arrange(USUBJID, ARM) |>+ |
||
| 44 | +517 |
- #' dplyr::group_by(USUBJID) |>+ #' Convert Nested Lists to Column |
||
| 45 | +518 |
- #' dplyr::filter(dplyr::n() > 1) |>+ #' |
||
| 46 | +519 |
- #' ard_effectsize_paired_cohens_d(by = ARM, variables = AGE, id = USUBJID)+ #' Some arguments, such as `stat_label`, are passed as nested lists. This |
||
| 47 | +520 |
- NULL+ #' function properly unnests these lists and adds them to the results data frame. |
||
| 48 | +521 |
-
+ #' |
||
| 49 | +522 |
- #' @rdname ard_effectsize_cohens_d+ #' @param x (`data.frame`)\cr |
||
| 50 | +523 |
- #' @export+ #' result data frame |
||
| 51 | +524 |
- ard_effectsize_cohens_d <- function(data, by, variables, conf.level = 0.95, ...) {
+ #' @param arg (`list`)\cr |
||
| 52 | -3x | +|||
| 525 | +
- set_cli_abort_call()+ #' the nested list |
|||
| 53 | +526 |
-
+ #' @param new_column (`string`)\cr |
||
| 54 | +527 |
- # check installed packages ---------------------------------------------------+ #' new column name |
||
| 55 | -3x | +|||
| 528 | +
- check_pkg_installed(c("effectsize", "parameters"), reference_pkg = "cardx")
+ #' @param unlist (`logical`)\cr |
|||
| 56 | +529 |
-
+ #' whether to fully unlist final results |
||
| 57 | +530 |
- # check/process inputs -------------------------------------------------------+ #' |
||
| 58 | -3x | +|||
| 531 | +
- check_not_missing(data)+ #' @return a data frame |
|||
| 59 | -3x | +|||
| 532 | +
- check_not_missing(variables)+ #' @keywords internal |
|||
| 60 | -3x | +|||
| 533 | +
- check_not_missing(by)+ #' |
|||
| 61 | -3x | +|||
| 534 | +
- check_data_frame(data)+ #' @examples |
|||
| 62 | -3x | +|||
| 535 | +
- data <- dplyr::ungroup(data)+ #' ard <- ard_categorical(cards::ADSL, by = "ARM", variables = "AGEGR1") |
|||
| 63 | -3x | +|||
| 536 | +
- cards::process_selectors(data, by = {{ by }}, variables = {{ variables }})
+ #' |
|||
| 64 | -3x | +|||
| 537 | +
- check_scalar(by)+ #' cardx:::.process_nested_list_as_df(ard, NULL, "new_col") |
|||
| 65 | -3x | +|||
| 538 | +
- check_range(conf.level, range = c(0, 1))+ .process_nested_list_as_df <- function(x, arg, new_column, unlist = FALSE) {
|
|||
| 66 | +539 |
- # if no variables selected, return empty tibble ------------------------------+ # add fmt_fn column if not already present |
||
| 67 | -3x | +540 | +106x |
- if (is_empty(variables)) {
+ if (!new_column %in% names(x)) {
|
| 68 | -! | +|||
| 541 | +106x |
- return(dplyr::tibble())+ x[[new_column]] <- list(NULL) |
||
| 69 | +542 |
} |
||
| 70 | +543 | |||
| 71 | +544 |
- # build ARD ------------------------------------------------------------------+ # process argument if not NULL, and update new column |
||
| 72 | -3x | +545 | +106x |
- lapply(+ if (!is_empty(arg)) {
|
| 73 | -3x | +546 | +53x |
- variables,+ df_argument <- |
| 74 | -3x | +547 | +53x |
- function(variable) {
+ imap( |
| 75 | -4x | +548 | +53x |
- .format_cohens_d_results(+ arg, |
| 76 | -4x | +549 | +53x |
- by = by,+ function(enlst_arg, variable) {
|
| 77 | -4x | +550 | +102x |
- variable = variable,+ lst_stat_names <- |
| 78 | -4x | +551 | +102x |
- lst_tidy =+ x[c("variable", "stat_name")] |>
|
| 79 | -4x | +552 | +102x |
- cards::eval_capture_conditions(+ dplyr::filter(.data$variable %in% .env$variable) |> |
| 80 | -4x | +553 | +102x |
- effectsize::cohens_d(+ unique() %>% |
| 81 | -4x | +554 | +102x |
- reformulate2(by, response = variable),+ {stats::setNames(as.list(.[["stat_name"]]), .[["stat_name"]])} # styler: off
+ |
+
| 555 | ++ | + | ||
| 82 | -4x | +556 | +102x |
- data = data |> tidyr::drop_na(all_of(c(by, variable))),+ cards::compute_formula_selector( |
| 83 | -4x | +557 | +102x |
- paired = FALSE,+ data = lst_stat_names, |
| 84 | -4x | +558 | +102x |
- ci = conf.level,+ x = enlst_arg |
| 85 | +559 |
- ...+ ) %>% |
||
| 86 | +560 |
- ) |>+ # styler: off |
||
| 87 | -4x | +561 | +102x |
- parameters::standardize_names(style = "broom") |>+ {dplyr::tibble(
|
| 88 | -4x | +562 | +102x |
- dplyr::mutate(method = "Cohen's D")+ variable = variable, |
| 89 | -+ | |||
| 563 | +102x |
- ),+ stat_name = names(.), |
||
| 90 | -4x | +564 | +102x |
- paired = FALSE,+ "{new_column}" := unname(.)
|
| 91 | +565 |
- ...+ )} |
||
| 92 | +566 |
- )+ # styler: on |
||
| 93 | +567 |
- }+ } |
||
| 94 | +568 |
- ) |>+ ) |> |
||
| 95 | -3x | +569 | +53x |
- dplyr::bind_rows()+ dplyr::bind_rows() |
| 96 | +570 |
- }+ + |
+ ||
| 571 | +53x | +
+ x <- x |> dplyr::rows_update(df_argument, by = c("variable", "stat_name"), unmatched = "ignore")
|
||
| 97 | +572 |
-
+ } |
||
| 98 | +573 | |||
| 99 | -+ | |||
| 574 | +106x |
- #' @rdname ard_effectsize_cohens_d+ if (isTRUE(unlist)) {
+ |
+ ||
| 575 | +53x | +
+ x[[new_column]] <- lapply(x[[new_column]], function(x) x %||% NA) |> unlist() |
||
| 100 | +576 |
- #' @export+ } |
||
| 101 | +577 |
- ard_effectsize_paired_cohens_d <- function(data, by, variables, id, conf.level = 0.95, ...) {
+
|
||
| 102 | -2x | +578 | +106x |
- set_cli_abort_call()+ x |
| 103 | +579 |
-
+ } |
| 104 | +1 |
- # check installed packages ---------------------------------------------------+ #' ARD Mood Test |
||
| 105 | -2x | +|||
| 2 | +
- check_pkg_installed(c("effectsize", "parameters"), reference_pkg = "cardx")
+ #' |
|||
| 106 | +3 |
-
+ #' @description |
||
| 107 | +4 |
- # check/process inputs -------------------------------------------------------+ #' Analysis results data for Mood two sample test of scale. Note this not to be confused with |
||
| 108 | -2x | +|||
| 5 | +
- check_not_missing(data)+ #' the Brown-Mood test of medians. |
|||
| 109 | -2x | +|||
| 6 | +
- check_not_missing(variables)+ #' |
|||
| 110 | -2x | +|||
| 7 | +
- check_not_missing(by)+ #' @param data (`data.frame`)\cr |
|||
| 111 | -2x | +|||
| 8 | +
- check_not_missing(id)+ #' a data frame. See below for details. |
|||
| 112 | -2x | +|||
| 9 | +
- check_data_frame(data)+ #' @param by ([`tidy-select`][dplyr::dplyr_tidy_select])\cr |
|||
| 113 | -2x | +|||
| 10 | +
- data <- dplyr::ungroup(data)+ #' column name to compare by. |
|||
| 114 | -2x | +|||
| 11 | +
- cards::process_selectors(data, by = {{ by }}, variables = {{ variables }}, id = {{ id }})
+ #' @param variables ([`tidy-select`][dplyr::dplyr_tidy_select])\cr |
|||
| 115 | -2x | +|||
| 12 | +
- check_scalar(by)+ #' column name to be compared. Independent tests will |
|||
| 116 | -2x | +|||
| 13 | +
- check_scalar(id)+ #' be run for each variable. |
|||
| 117 | -2x | +|||
| 14 | +
- check_range(conf.level, range = c(0, 1))+ #' @param ... arguments passed to `mood.test(...)` |
|||
| 118 | +15 |
-
+ #' |
||
| 119 | +16 |
- # if no variables selected, return empty tibble ------------------------------+ #' @return ARD data frame |
||
| 120 | -2x | +|||
| 17 | +
- if (is_empty(variables)) {
+ #' @name ard_stats_mood_test |
|||
| 121 | -! | +|||
| 18 | +
- return(dplyr::tibble())+ #' |
|||
| 122 | +19 |
- }+ #' @details |
||
| 123 | +20 |
-
+ #' For the `ard_stats_mood_test()` function, the data is expected to be one row per subject. |
||
| 124 | +21 |
- # build ARD ------------------------------------------------------------------+ #' The data is passed as `mood.test(data[[variable]] ~ data[[by]], ...)`. |
||
| 125 | -2x | +|||
| 22 | +
- lapply(+ #' @rdname ard_stats_mood_test |
|||
| 126 | -2x | +|||
| 23 | +
- variables,+ #' @export |
|||
| 127 | -2x | +|||
| 24 | +
- function(variable) {
+ #' |
|||
| 128 | -2x | +|||
| 25 | +
- .format_cohens_d_results(+ #' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = "broom", reference_pkg = "cardx"))
|
|||
| 129 | -2x | +|||
| 26 | ++ |
+ #' cards::ADSL |>+ |
+ ||
| 27 | +
- by = by,+ #' ard_stats_mood_test(by = "SEX", variables = "AGE") |
|||
| 130 | -2x | +|||
| 28 | +
- variable = variable,+ ard_stats_mood_test <- function(data, by, variables, ...) {
|
|||
| 131 | +29 | 2x |
- lst_tidy =+ set_cli_abort_call() |
|
| 132 | -2x | +|||
| 30 | +
- cards::eval_capture_conditions({
+
|
|||
| 133 | +31 |
- # adding this reshape inside the eval, so if there is an error it's captured in the ARD object+ # check installed packages --------------------------------------------------- |
||
| 134 | +32 | 2x |
- data_wide <-+ check_pkg_installed("broom", reference_pkg = "cardx")
|
|
| 135 | -2x | +|||
| 33 | +
- data |>+ |
|||
| 136 | -2x | +|||
| 34 | +
- tidyr::drop_na(all_of(c(id, by, variable))) |>+ # check/process inputs ------------------------------------------------------- |
|||
| 137 | +35 | 2x |
- .paired_data_pivot_wider(by = by, variable = variable, id = id) |>+ check_not_missing(data) |
|
| 138 | +36 | 2x |
- tidyr::drop_na(any_of(c("by1", "by2")))
- |
- |
| 139 | -- |
- # perform paired cohen's d test+ check_not_missing(variables) |
||
| 140 | -1x | +37 | +2x |
- effectsize::cohens_d(x = data_wide[["by1"]], y = data_wide[["by2"]], paired = TRUE, ci = conf.level, ...) |>+ check_not_missing(by) |
| 141 | -1x | +38 | +2x |
- parameters::standardize_names(style = "broom") |>+ check_data_frame(data) |
| 142 | -1x | -
- dplyr::mutate(method = "Paired Cohen's D")- |
- ||
| 143 | -+ | 39 | +2x |
- }),+ data <- dplyr::ungroup(data) |
| 144 | +40 | 2x |
- paired = TRUE,+ cards::process_selectors(data, by = {{ by }}, variables = {{ variables }})
|
|
| 145 | -+ | |||
| 41 | +2x |
- ...+ check_scalar(by) |
||
| 146 | +42 |
- )+ |
||
| 147 | +43 |
- }+ |
||
| 148 | +44 |
- ) |>+ # if no variables selected, return empty tibble ------------------------------ |
||
| 149 | +45 | 2x |
- dplyr::bind_rows()+ if (is_empty(variables)) {
|
|
| 150 | -+ | |||
| 46 | +! |
- }+ return(dplyr::tibble()) |
||
| 151 | +47 |
-
+ } |
||
| 152 | +48 |
- .df_effectsize_stat_labels <- function() {
+ # build ARD ------------------------------------------------------------------ |
||
| 153 | -12x | +49 | +2x |
- dplyr::tribble(+ lapply( |
| 154 | -12x | +50 | +2x |
- ~stat_name, ~stat_label,+ variables, |
| 155 | -12x | +51 | +2x |
- "estimate", "Effect Size Estimate",+ function(variable) {
|
| 156 | -12x | +52 | +2x |
- "conf.low", "CI Lower Bound",+ .format_moodtest_results( |
| 157 | -12x | +53 | +2x |
- "conf.high", "CI Upper Bound",+ by = by, |
| 158 | -12x | +54 | +2x |
- "conf.level", "CI Confidence Level",+ variable = variable, |
| 159 | -12x | +55 | +2x |
- "mu", "H0 Mean",+ lst_tidy = |
| 160 | -12x | +56 | +2x |
- "paired", "Paired test",+ cards::eval_capture_conditions( |
| 161 | -12x | +57 | +2x |
- "pooled_sd", "Pooled Standard Deviation",+ stats::mood.test(data[[variable]] ~ data[[by]], ...) |> |
| 162 | -12x | +58 | +2x |
- "alternative", "Alternative Hypothesis"+ broom::tidy() |
| 163 | +59 |
- )+ ), |
||
| 164 | +60 |
- }+ ... |
||
| 165 | +61 |
-
+ ) |
||
| 166 | +62 |
-
+ } |
||
| 167 | +63 |
- #' Convert Cohen's D Test to ARD+ ) |>+ |
+ ||
| 64 | +2x | +
+ dplyr::bind_rows() |
||
| 168 | +65 | ++ |
+ }+ |
+ |
| 66 | ++ |
+ #' Convert mood test results to ARD+ |
+ ||
| 67 |
#' |
|||
| 169 | +68 |
#' @inheritParams cards::tidy_as_ard |
||
| 170 | +69 |
- #' @inheritParams effectsize::cohens_d+ #' @inheritParams stats::mood.test |
||
| 171 | +70 |
#' @param by (`string`)\cr by column name |
||
| 172 | +71 |
#' @param variable (`string`)\cr variable column name |
||
| 173 | +72 |
- #' @param ... passed to `cohens_d(...)`+ #' @param ... passed to `mood.test(...)` |
||
| 174 | +73 |
#' |
||
| 175 | +74 |
#' @return ARD data frame |
||
| 176 | +75 |
#' @keywords internal |
||
| 177 | +76 |
- #' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = c("effectsize", "parameters"), reference_pkg = "cardx"))
+ #' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = "broom", reference_pkg = "cardx"))
|
||
| 178 | +77 |
- #' cardx:::.format_cohens_d_results(+ #' cardx:::.format_moodtest_results( |
||
| 179 | +78 |
- #' by = "ARM",+ #' by = "SEX", |
||
| 180 | +79 |
#' variable = "AGE", |
||
| 181 | -- |
- #' paired = FALSE,- |
- ||
| 182 | +80 |
#' lst_tidy = |
||
| 183 | +81 |
#' cards::eval_capture_conditions( |
||
| 184 | +82 |
- #' effectsize::hedges_g(data[[variable]] ~ data[[by]], paired = FALSE) |>+ #' stats::mood.test(ADSL[["AGE"]] ~ ADSL[["SEX"]]) |> |
||
| 185 | +83 |
- #' parameters::standardize_names(style = "broom")+ #' broom::tidy() |
||
| 186 | +84 |
#' ) |
||
| 187 | +85 |
#' ) |
||
| 188 | +86 |
- .format_cohens_d_results <- function(by, variable, lst_tidy, paired, ...) {
+ .format_moodtest_results <- function(by, variable, lst_tidy, ...) {
|
||
| 189 | +87 |
# build ARD ------------------------------------------------------------------ |
||
| 190 | -6x | +88 | +2x |
ret <- |
| 191 | -6x | +89 | +2x |
cards::tidy_as_ard( |
| 192 | -6x | +90 | +2x |
lst_tidy = lst_tidy, |
| 193 | -6x | -
- tidy_result_names = c(- |
- ||
| 194 | -6x | -
- "estimate", "conf.level", "conf.low", "conf.high"- |
- ||
| 195 | -- |
- ),- |
- ||
| 196 | -6x | +91 | +2x |
- fun_args_to_record = c("mu", "paired", "pooled_sd", "alternative"),
+ tidy_result_names = c("statistic", "p.value", "method", "alternative"),
|
| 197 | -6x | +92 | +2x |
- formals = formals(asNamespace("effectsize")[["cohens_d"]]),
+ formals = formals(asNamespace("stats")[["mood.test.default"]]),
|
| 198 | -6x | +93 | +2x |
- passed_args = c(list(paired = paired), dots_list(...)),+ passed_args = c(dots_list(...)), |
| 199 | -6x | +94 | +2x |
- lst_ard_columns = list(group1 = by, variable = variable, context = "effectsize_cohens_d")+ lst_ard_columns = list(group1 = by, variable = variable, context = "stats_mood_test") |
| 200 | +95 |
) |
||
| 201 | +96 | |||
| 202 | +97 |
# add the stat label --------------------------------------------------------- |
||
| 203 | -6x | +98 | +2x |
ret |> |
| 204 | -6x | +99 | +2x |
dplyr::left_join( |
| 205 | -6x | +100 | +2x |
- .df_effectsize_stat_labels(),+ .df_moodtest_stat_labels(), |
| 206 | -6x | +101 | +2x |
by = "stat_name" |
| 207 | +102 |
) |> |
||
| 208 | -6x | +103 | +2x |
dplyr::mutate(stat_label = dplyr::coalesce(.data$stat_label, .data$stat_name)) |> |
| 209 | -6x | +104 | +2x |
cards::tidy_ard_column_order() |
| 210 | +105 | ++ |
+ }+ |
+ |
| 106 | ++ | + + | +||
| 107 | ++ |
+ .df_moodtest_stat_labels <- function() {
+ |
+ ||
| 108 | +2x | +
+ dplyr::tribble(+ |
+ ||
| 109 | +2x | +
+ ~stat_name, ~stat_label,+ |
+ ||
| 110 | +2x | +
+ "statistic", "Z-Statistic",+ |
+ ||
| 111 | +2x | +
+ "p.value", "p-value",+ |
+ ||
| 112 | +2x | +
+ "alternative", "Alternative Hypothesis"+ |
+ ||
| 113 | ++ |
+ )+ |
+ ||
| 114 |
}@@ -12108,14 +10731,14 @@ cardx coverage - 95.32% |
| 1 |
- #' ARD Categorical Survey Statistics+ #' ARD Wilcoxon Rank-Sum Test |
||
| 4 |
- #' Compute tabulations on survey-weighted data.+ #' Analysis results data for paired and non-paired Wilcoxon Rank-Sum tests. |
||
| 6 |
- #' The counts and proportion (`"N"`, `"n"`, `"p"`) are calculated using `survey::svytable()`,+ #' @param data (`data.frame`)\cr |
||
| 7 |
- #' and the standard errors and design effect (`"p.std.error"`, `"deff"`) are+ #' a data frame. See below for details. |
||
| 8 |
- #' calculated using `survey::svymean()`.+ #' @param by ([`tidy-select`][dplyr::dplyr_tidy_select])\cr |
||
| 9 |
- #'+ #' optional column name to compare by. |
||
| 10 |
- #' The unweighted statistics are calculated with `cards::ard_categorical.data.frame()`.+ #' @param variables ([`tidy-select`][dplyr::dplyr_tidy_select])\cr |
||
| 11 |
- #'+ #' column names to be compared. Independent tests will be computed for |
||
| 12 |
- #' @param data (`survey.design`)\cr+ #' each variable. |
||
| 13 |
- #' a design object often created with [`survey::svydesign()`].+ #' @param id ([`tidy-select`][dplyr::dplyr_tidy_select])\cr |
||
| 14 |
- #' @param variables ([`tidy-select`][dplyr::dplyr_tidy_select])\cr+ #' column name of the subject or participant ID. |
||
| 15 |
- #' columns to include in summaries.+ #' @param conf.level (scalar `numeric`)\cr |
||
| 16 |
- #' @param by ([`tidy-select`][dplyr::dplyr_tidy_select])\cr+ #' confidence level for confidence interval. Default is `0.95`. |
||
| 17 |
- #' results are calculated for **all combinations** of the column specified+ #' @param ... arguments passed to `wilcox.test(...)` |
||
| 18 |
- #' and the variables. A single column may be specified.+ #' |
||
| 19 |
- #' @param denominator (`string`)\cr+ #' @return ARD data frame |
||
| 20 |
- #' a string indicating the type proportions to calculate. Must be one of+ #' @name ard_stats_wilcox_test |
||
| 21 |
- #' `"column"` (the default), `"row"`, and `"cell"`.+ #' |
||
| 22 |
- #' @param statistic ([`formula-list-selector`][syntax])\cr+ #' @details |
||
| 23 |
- #' a named list, a list of formulas,+ #' For the `ard_stats_wilcox_test()` function, the data is expected to be one row per subject. |
||
| 24 |
- #' or a single formula where the list element is a character vector of+ #' The data is passed as `wilcox.test(data[[variable]] ~ data[[by]], paired = FALSE, ...)`. |
||
| 25 |
- #' statistic names to include. See default value for options.+ #' |
||
| 26 |
- #' @param fmt_fn ([`formula-list-selector`][syntax])\cr+ #' For the `ard_stats_paired_wilcox_test()` function, the data is expected to be one row |
||
| 27 |
- #' a named list, a list of formulas,+ #' per subject per by level. Before the test is calculated, the data are |
||
| 28 |
- #' or a single formula where the list element is a named list of functions+ #' reshaped to a wide format to be one row per subject. |
||
| 29 |
- #' (or the RHS of a formula),+ #' The data are then passed as |
||
| 30 |
- #' e.g. `list(mpg = list(mean = \(x) round(x, digits = 2) |> as.character))`.+ #' `wilcox.test(x = data_wide[[<by level 1>]], y = data_wide[[<by level 2>]], paired = TRUE, ...)`. |
||
| 31 |
- #' @param stat_label ([`formula-list-selector`][syntax])\cr+ #' |
||
| 32 |
- #' a named list, a list of formulas, or a single formula where+ #' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = "broom", reference_pkg = "cardx"))
|
||
| 33 |
- #' the list element is either a named list or a list of formulas defining the+ #' cards::ADSL |> |
||
| 34 |
- #' statistic labels, e.g. `everything() ~ list(mean = "Mean", sd = "SD")` or+ #' dplyr::filter(ARM %in% c("Placebo", "Xanomeline High Dose")) |>
|
||
| 35 |
- #' `everything() ~ list(mean ~ "Mean", sd ~ "SD")`.+ #' ard_stats_wilcox_test(by = "ARM", variables = "AGE") |
||
| 36 |
- #' @inheritParams rlang::args_dots_empty+ #' |
||
| 37 |
- #'+ #' # constructing a paired data set, |
||
| 38 |
- #' @return an ARD data frame of class 'card'+ #' # where patients receive both treatments |
||
| 39 |
- #' @export+ #' cards::ADSL[c("ARM", "AGE")] |>
|
||
| 40 |
- #'+ #' dplyr::filter(ARM %in% c("Placebo", "Xanomeline High Dose")) |>
|
||
| 41 |
- #' @examplesIf cardx:::is_pkg_installed("survey", reference_pkg = "cardx")
+ #' dplyr::mutate(.by = ARM, USUBJID = dplyr::row_number()) |> |
||
| 42 |
- #' svy_titanic <- survey::svydesign(~1, data = as.data.frame(Titanic), weights = ~Freq)+ #' dplyr::arrange(USUBJID, ARM) |> |
||
| 43 |
- #'+ #' ard_stats_paired_wilcox_test(by = ARM, variables = AGE, id = USUBJID) |
||
| 44 |
- #' ard_categorical(svy_titanic, variables = c(Class, Age), by = Survived)+ NULL |
||
| 45 |
- ard_categorical.survey.design <- function(data,+ |
||
| 46 |
- variables,+ #' @rdname ard_stats_wilcox_test |
||
| 47 |
- by = NULL,+ #' @export |
||
| 48 |
- statistic = everything() ~ c("n", "N", "p", "p.std.error", "deff", "n_unweighted", "N_unweighted", "p_unweighted"),
+ ard_stats_wilcox_test <- function(data, variables, by = NULL, conf.level = 0.95, ...) {
|
||
| 49 | -+ | 5x |
- denominator = c("column", "row", "cell"),
+ set_cli_abort_call() |
| 50 |
- fmt_fn = NULL,+ |
||
| 51 |
- stat_label = everything() ~ list(+ # check installed packages --------------------------------------------------- |
||
| 52 | -+ | 5x |
- p = "%",+ check_pkg_installed("broom", reference_pkg = "cardx")
|
| 53 |
- p.std.error = "SE(%)",+ |
||
| 54 |
- deff = "Design Effect",+ # check/process inputs ------------------------------------------------------- |
||
| 55 | -+ | 5x |
- "n_unweighted" = "Unweighted n",+ check_not_missing(data) |
| 56 | -+ | 5x |
- "N_unweighted" = "Unweighted N",+ check_not_missing(variables) |
| 57 | -+ | 5x |
- "p_unweighted" = "Unweighted %"+ check_data_frame(data) |
| 58 | -+ | 5x |
- ),+ data <- dplyr::ungroup(data) |
| 59 | -+ | 5x |
- ...) {
+ cards::process_selectors(data, by = {{ by }}, variables = {{ variables }})
|
| 60 | -50x | +5x |
- set_cli_abort_call()+ check_scalar(by, allow_empty = TRUE) |
| 61 | -50x | +5x |
- check_pkg_installed(pkg = "survey", reference_pkg = "cardx")+ check_range(conf.level, range = c(0, 1)) |
| 62 | -50x | +
- check_dots_empty()+ |
|
| 63 | -50x | +
- deff <- TRUE # we may update in the future to make this an argument for users+ # if no variables selected, return empty tibble ------------------------------ |
|
| 64 | -+ | 5x |
-
+ if (is_empty(variables)) {
|
| 65 | -+ | ! |
- # process arguments ----------------------------------------------------------+ return(dplyr::tibble()) |
| 66 | -50x | +
- check_not_missing(variables)+ } |
|
| 67 | -50x | +
- cards::process_selectors(+ |
|
| 68 | -50x | +
- data = data$variables,+ # build ARD ------------------------------------------------------------------ |
|
| 69 | -50x | +5x |
- variables = {{ variables }},
+ lapply( |
| 70 | -50x | +5x |
- by = {{ by }}
+ variables, |
| 71 | -+ | 5x |
- )+ function(variable) {
|
| 72 | -50x | +6x |
- variables <- setdiff(variables, by)+ .format_wilcoxtest_results( |
| 73 | -50x | +6x |
- check_scalar(by, allow_empty = TRUE)+ by = by, |
| 74 | -+ | 6x |
-
+ variable = variable, |
| 75 | -+ | 6x |
- # if no variables selected, return empty data frame+ lst_tidy = |
| 76 | -! | +
- if (is_empty(variables)) return(dplyr::tibble()) # styler: off+ # styler: off |
|
| 77 | -+ | 6x |
-
+ cards::eval_capture_conditions( |
| 78 | -50x | +6x |
- check_na_factor_levels(data$variables, c(by, variables))+ if (!is_empty(by)) {
|
| 79 | -+ | 5x |
-
+ stats::wilcox.test(data[[variable]] ~ data[[by]], conf.level = conf.level, ...) |> |
| 80 | -50x | +5x |
- cards::process_formula_selectors(+ broom::tidy() |
| 81 | -50x | +
- data = data$variables[variables],+ } |
|
| 82 | -50x | +
- statistic = statistic,+ else {
|
|
| 83 | -50x | +1x |
- fmt_fn = fmt_fn,+ stats::wilcox.test(data[[variable]], ...) |> |
| 84 | -50x | +1x |
- stat_label = stat_label+ broom::tidy() |
| 85 |
- )+ } |
||
| 86 | -50x | +
- cards::fill_formula_selectors(+ ), |
|
| 87 | -50x | +
- data = data$variables[variables],+ # styler: on |
|
| 88 | -50x | +6x |
- statistic = formals(asNamespace("cardx")[["ard_categorical.survey.design"]])[["statistic"]] |> eval(),
+ paired = FALSE, |
| 89 |
- )+ ... |
||
| 90 | -50x | +
- accepted_svy_stats <- c("n", "N", "p", "p.std.error", "deff", "n_unweighted", "N_unweighted", "p_unweighted")
+ ) |
|
| 91 | -50x | +
- cards::check_list_elements(+ } |
|
| 92 | -50x | +
- x = statistic,+ ) |> |
|
| 93 | -50x | +5x |
- predicate = \(x) all(x %in% accepted_svy_stats),+ dplyr::bind_rows() |
| 94 | -50x | +
- error_msg = c("Error in the values of the {.arg statistic} argument.",
+ } |
|
| 95 | -50x | +
- i = "Values must be in {.val {accepted_svy_stats}}"
+
|
|
| 96 |
- )+ #' @rdname ard_stats_wilcox_test |
||
| 97 |
- )+ #' @export |
||
| 98 | -50x | +
- denominator <- arg_match(denominator)+ ard_stats_paired_wilcox_test <- function(data, by, variables, id, conf.level = 0.95, ...) {
|
|
| 99 | -+ | 2x |
-
+ set_cli_abort_call() |
| 100 |
- # return empty tibble if no variables selected -------------------------------+ |
||
| 101 | -50x | +
- if (is_empty(variables)) {
+ # check installed packages --------------------------------------------------- |
|
| 102 | -! | +2x |
- return(dplyr::tibble())+ check_pkg_installed("broom", reference_pkg = "cardx")
|
| 103 |
- }+ |
||
| 104 |
-
+ # check/process inputs ------------------------------------------------------- |
||
| 105 | -+ | 2x |
- # check the missingness+ check_not_missing(data) |
| 106 | -50x | +2x |
- walk(+ check_not_missing(variables) |
| 107 | -50x | +2x |
- variables,+ check_not_missing(by) |
| 108 | -50x | +2x |
- \(.x) {
+ check_not_missing(id) |
| 109 | -97x | +2x |
- if (all(is.na(data$variables[[.x]])) && !inherits(.x, c("logical", "factor"))) {
+ check_data_frame(data) |
| 110 | -1x | +2x |
- cli::cli_abort(+ data <- dplyr::ungroup(data) |
| 111 | -1x | +2x |
- c("Column {.val {.x}} is all missing and cannot be tabulated.",
+ cards::process_selectors(data, by = {{ by }}, variables = {{ variables }}, id = {{ id }})
|
| 112 | -1x | +2x |
- i = "Only columns of class {.cls logical} and {.cls factor} can be tabulated when all values are missing."
+ check_scalar(by) |
| 113 | -+ | 2x |
- ),+ check_scalar(id) |
| 114 | -1x | +
- call = get_cli_abort_call()+ |
|
| 115 |
- )+ # if no variables selected, return empty tibble ------------------------------ |
||
| 116 | -+ | 2x |
- }+ if (is_empty(variables)) {
|
| 117 | -+ | ! |
- }+ return(dplyr::tibble()) |
| 118 |
- )+ } |
||
| 120 |
- # calculate counts -----------------------------------------------------------+ # build ARD ------------------------------------------------------------------ |
||
| 121 | -+ | 2x |
- # this tabulation accounts for unobserved combinations+ lapply( |
| 122 | -49x | +2x |
- svytable_counts <- .svytable_counts(data, variables, by, denominator)+ variables, |
| 123 | -+ | 2x |
-
+ function(variable) {
|
| 124 | -+ | 2x |
- # calculate rate SE and DEFF -------------------------------------------------+ .format_wilcoxtest_results( |
| 125 | -49x | +2x |
- svytable_rates <- .svytable_rate_stats(data, variables, by, denominator, deff)+ by = by, |
| 126 | -+ | 2x |
-
+ variable = variable, |
| 127 | -+ | 2x |
- # convert results into a proper ARD object -----------------------------------+ lst_tidy = |
| 128 | -49x | +2x |
- cards <-+ cards::eval_capture_conditions({
|
| 129 | -49x | +
- svytable_counts |>+ # adding this reshape inside the eval, so if there is an error it's captured in the ARD object |
|
| 130 | -+ | 2x |
- # merge in the SE(p) and DEFF+ data_wide <- .paired_data_pivot_wider(data, by = by, variable = variable, id = id) |
| 131 | -49x | +
- dplyr::left_join(+ # perform paired wilcox test |
|
| 132 | -49x | +1x |
- svytable_rates |> dplyr::select(-"p"),+ stats::wilcox.test(x = data_wide[["by1"]], y = data_wide[["by2"]], paired = TRUE, conf.level = conf.level, ...) |> |
| 133 | -49x | +1x |
- by = intersect(c("group1", "group1_level", "variable", "variable_level"), names(svytable_counts))
+ broom::tidy() |
| 134 |
- ) |>+ }), |
||
| 135 | -+ | 2x |
- # make columns list columns+ paired = TRUE, |
| 136 | -49x | +
- dplyr::mutate(across(-any_of(c("group1", "variable")), as.list)) |>
+ ... |
|
| 137 | -49x | +
- tidyr::pivot_longer(+ ) |
|
| 138 | -49x | +
- cols = -c(cards::all_ard_groups(), cards::all_ard_variables()),+ } |
|
| 139 | -49x | +
- names_to = "stat_name",+ ) |> |
|
| 140 | -49x | +2x |
- values_to = "stat"+ dplyr::bind_rows() |
| 141 |
- ) |>+ } |
||
| 142 |
- # keep statistics requested by user+ |
||
| 143 | -49x | +
- dplyr::inner_join(+ |
|
| 144 | -49x | +
- statistic |> enframe("variable", "stat_name") |> tidyr::unnest(cols = "stat_name"),
+ #' Convert Wilcoxon test to ARD |
|
| 145 | -49x | +
- by = c("variable", "stat_name")
+ #' |
|
| 146 |
- )+ #' @inheritParams cards::tidy_as_ard |
||
| 147 |
-
+ #' @inheritParams stats::wilcox.test |
||
| 148 |
- # add unweighted statistics --------------------------------------------------+ #' @param by (`string`)\cr by column name |
||
| 149 | -49x | +
- cards_unweighted <-+ #' @param variable (`string`)\cr variable column name |
|
| 150 | -49x | +
- ard_categorical(+ #' @param ... passed to `stats::wilcox.test(...)` |
|
| 151 | -49x | +
- data = data[["variables"]],+ #' |
|
| 152 | -49x | +
- variables = all_of(variables),+ #' @return ARD data frame |
|
| 153 | -49x | +
- by = any_of(by),+ #' |
|
| 154 | -49x | +
- denominator = denominator+ #' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = "broom", reference_pkg = "cardx"))
|
|
| 155 |
- ) |>+ #' # Pre-processing ADSL to have grouping factor (ARM here) with 2 levels |
||
| 156 |
- # all the survey levels are reported as character, so we do the same here.+ #' ADSL <- cards::ADSL |> |
||
| 157 | -49x | +
- dplyr::mutate(+ #' dplyr::filter(ARM %in% c("Placebo", "Xanomeline High Dose")) |>
|
|
| 158 | -49x | +
- across(+ #' ard_stats_wilcox_test(by = "ARM", variables = "AGE") |
|
| 159 | -49x | +
- c(cards::all_ard_groups("levels"), cards::all_ard_variables("levels")),
+ #' |
|
| 160 | -49x | +
- ~ map(.x, as.character)+ #' cardx:::.format_wilcoxtest_results( |
|
| 161 |
- )+ #' by = "ARM", |
||
| 162 |
- ) |>+ #' variable = "AGE", |
||
| 163 | -49x | +
- dplyr::select(-c("stat_label", "fmt_fn", "warning", "error")) |>
+ #' paired = FALSE, |
|
| 164 | -49x | +
- dplyr::mutate(+ #' lst_tidy = |
|
| 165 | -49x | +
- stat_name =+ #' cards::eval_capture_conditions( |
|
| 166 | -49x | +
- dplyr::case_match(.data$stat_name, "n" ~ "n_unweighted", "N" ~ "N_unweighted", "p" ~ "p_unweighted")+ #' stats::wilcox.test(ADSL[["AGE"]] ~ ADSL[["ARM"]], paired = FALSE) |> |
|
| 167 |
- )+ #' broom::tidy() |
||
| 168 | -49x | +
- cards <- cards |> dplyr::bind_rows(cards_unweighted) # styler: off+ #' ) |
|
| 169 |
-
+ #' ) |
||
| 170 |
- # final processing of fmt_fn -------------------------------------------------+ #' |
||
| 171 | -49x | +
- cards <- cards |>+ #' @keywords internal |
|
| 172 | -49x | +
- .process_nested_list_as_df(+ .format_wilcoxtest_results <- function(by = NULL, variable, lst_tidy, paired, ...) {
|
|
| 173 | -49x | +
- arg = fmt_fn,+ # build ARD ------------------------------------------------------------------ |
|
| 174 | -49x | +8x |
- new_column = "fmt_fn"+ ret <- |
| 175 | -+ | 8x |
- ) |>+ cards::tidy_as_ard( |
| 176 | -49x | +8x |
- .default_svy_cat_fmt_fn()+ lst_tidy = lst_tidy, |
| 177 | -+ | 8x |
-
+ tidy_result_names = c("statistic", "p.value", "method", "alternative"),
|
| 178 | -+ | 8x |
- # merge in statistic labels --------------------------------------------------+ fun_args_to_record = c( |
| 179 | -49x | +8x |
- cards <- cards |>+ "mu", "paired", "exact", "correct", "conf.int", |
| 180 | -49x | +8x |
- .process_nested_list_as_df(+ "conf.level", "tol.root", "digits.rank" |
| 181 | -49x | +
- arg = stat_label,+ ), |
|
| 182 | -49x | +8x |
- new_column = "stat_label",+ formals = formals(asNamespace("stats")[["wilcox.test.default"]]),
|
| 183 | -49x | +8x |
- unlist = TRUE+ passed_args = c(list(paired = paired), dots_list(...)), |
| 184 | -+ | 8x |
- ) |>+ lst_ard_columns = list(variable = variable, context = "stats_wilcox_test") |
| 185 | -49x | +
- dplyr::mutate(stat_label = dplyr::coalesce(.data$stat_label, .data$stat_name))+ ) |
|
| 187 | -+ | 8x |
- # return final object --------------------------------------------------------+ if (!is_empty(by)) {
|
| 188 | -49x | +7x |
- cards |>+ ret <- ret |> |
| 189 | -49x | +7x |
- dplyr::mutate(+ dplyr::mutate(group1 = by) |
| 190 | -49x | +
- context = "categorical",+ } |
|
| 191 | -49x | +
- warning = list(NULL),+ |
|
| 192 | -49x | +
- error = list(NULL),+ # add the stat label --------------------------------------------------------- |
|
| 193 | -+ | 8x |
- ) |>+ ret |> |
| 194 | -49x | +8x |
- cards::tidy_ard_column_order() %>%+ dplyr::left_join( |
| 195 | -49x | +8x |
- {structure(., class = c("card", class(.)))} |> # styler: off
+ .df_wilcoxtest_stat_labels(by), |
| 196 | -49x | +8x |
- cards::tidy_ard_row_order()+ by = "stat_name" |
| 197 |
- }+ ) |> |
||
| 198 | -+ | 8x |
-
+ dplyr::mutate(stat_label = dplyr::coalesce(.data$stat_label, .data$stat_name)) |> |
| 199 | -+ | 8x |
- # check for functions with NA factor levels (these are not allowed)+ cards::tidy_ard_column_order() |
| 200 |
- check_na_factor_levels <- function(data, variables) {
+ } |
||
| 201 | -60x | +
- walk(+ |
|
| 202 | -60x | +
- variables,+ |
|
| 203 | -60x | +
- \(variable) {
+ .df_wilcoxtest_stat_labels <- function(by = NULL) {
|
|
| 204 | -137x | +8x |
- if (is.factor(data[[variable]]) && any(is.na(levels(data[[variable]])))) {
+ dplyr::tribble( |
| 205 | -! | +8x |
- cli::cli_abort(+ ~stat_name, ~stat_label, |
| 206 | -! | +8x |
- "Column {.val {variable}} is a factor with {.val {NA}} levels, which are not allowed.",
+ "statistic", ifelse(is.null(by), "V Statistic", "X-squared Statistic"), |
| 207 | -! | +8x |
- call = get_cli_abort_call()+ "parameter", "Degrees of Freedom", |
| 208 | -+ | 8x |
- )+ "estimate", "Median of the Difference", |
| 209 | -+ | 8x |
- }+ "p.value", "p-value", |
| 210 | -+ | 8x |
- }+ "conf.low", "CI Lower Bound", |
| 211 | -+ | 8x |
- )+ "conf.high", "CI Upper Bound", |
| 212 | -+ | 8x |
- }+ "paired", "Paired test", |
| 213 | -+ | 8x |
-
+ "conf.level", "CI Confidence Level", |
| 214 |
- # this function returns a tibble with the SE(p) and DEFF+ ) |
||
| 215 |
- .svytable_rate_stats <- function(data, variables, by, denominator, deff) {
- |
- ||
| 216 | -32x | -
- if (!is_empty(by)) by_lvls <- .unique_values_sort(data$variables, by) # styler: off+ } |
|
| 217 | -49x | +
| 1 | +
- if (!is_empty(by) && length(by_lvls) == 1L) {
+ #' Functions for Calculating Proportion Confidence Intervals |
|||
| 218 | -6x | +|||
| 2 | +
- data$variables[[by]] <-+ #' |
|||
| 219 | -6x | +|||
| 3 | +
- case_switch(+ #' Functions to calculate different proportion confidence intervals for use in `ard_proportion()`. |
|||
| 220 | -6x | +|||
| 4 | +
- inherits(data$variables[[by]], "factor") ~ fct_expand(data$variables[[by]], paste("not", by_lvls)),
+ #' |
|||
| 221 | -6x | +|||
| 5 | +
- .default = factor(data$variables[[by]], levels = c(by_lvls, paste("not", by_lvls)))
+ #' @inheritParams ard_proportion_ci |
|||
| 222 | +6 |
- )+ #' @param x vector of a binary values, i.e. a logical vector, or numeric with values `c(0, 1)` |
||
| 223 | +7 |
- }+ #' @return Confidence interval of a proportion. |
||
| 224 | -49x | +|||
| 8 | +
- if (!is_empty(by) && inherits(data$variables[[by]], "logical")) {
+ #' |
|||
| 225 | -9x | +|||
| 9 | +
- data$variables[[by]] <- factor(data$variables[[by]], levels = c(TRUE, FALSE))+ #' @name proportion_ci |
|||
| 226 | +10 |
- }+ #' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = "broom", reference_pkg = "cardx"))
|
||
| 227 | -49x | +|||
| 11 | +
- if (!is_empty(by) && !inherits(data$variables[[by]], "factor")) {
+ #' x <- c( |
|||
| 228 | -3x | +|||
| 12 | +
- data$variables[[by]] <- factor(data$variables[[by]])+ #' TRUE, TRUE, TRUE, TRUE, TRUE, |
|||
| 229 | +13 |
- }+ #' FALSE, FALSE, FALSE, FALSE, FALSE |
||
| 230 | +14 |
-
+ #' ) |
||
| 231 | -49x | +|||
| 15 | +
- lapply(+ #' |
|||
| 232 | -49x | +|||
| 16 | +
- variables,+ #' proportion_ci_wald(x, conf.level = 0.9) |
|||
| 233 | -49x | +|||
| 17 | +
- \(variable) {
+ #' proportion_ci_wilson(x, correct = TRUE) |
|||
| 234 | +18 |
- # convert the variable to a factor if not already one or a lgl, so we get the correct rate stats from svymean+ #' proportion_ci_clopper_pearson(x) |
||
| 235 | -96x | +|||
| 19 | +
- if (!inherits(data$variables[[variable]], c("factor", "logical"))) {
+ #' proportion_ci_agresti_coull(x) |
|||
| 236 | -6x | +|||
| 20 | +
- data$variables[[variable]] <- factor(data$variables[[variable]])+ #' proportion_ci_jeffreys(x) |
|||
| 237 | +21 |
- }+ NULL |
||
| 238 | +22 | |||
| 239 | +23 |
- # there are issues with svymean() when a variable has only one level. adding a second as needed- |
- ||
| 240 | -96x | -
- variable_lvls <- .unique_values_sort(data$variables, variable)- |
- ||
| 241 | -96x | -
- if (length(variable_lvls) == 1L) {
- |
- ||
| 242 | -6x | -
- data$variables[[variable]] <-- |
- ||
| 243 | -6x | -
- case_switch(- |
- ||
| 244 | -6x | -
- inherits(data$variables[[variable]], "factor") ~ fct_expand(data$variables[[variable]], paste("not", variable_lvls)),
- |
- ||
| 245 | -6x | -
- .default = factor(data$variables[[variable]], levels = c(variable_lvls, paste("not", variable_lvls)))
+ #' @describeIn proportion_ci Calculates the Wald interval by following the usual textbook definition |
||
| 246 | +24 |
- )+ #' for a single proportion confidence interval using the normal approximation. |
||
| 247 | +25 |
- }+ #' |
||
| 248 | -96x | +|||
| 26 | +
- if (inherits(data$variables[[variable]], "logical")) {
+ #' \deqn{\hat{p} \pm z_{\alpha/2} \sqrt{\frac{\hat{p}(1 - \hat{p})}{n}}}
|
|||
| 249 | -18x | +|||
| 27 | +
- data$variables[[variable]] <- factor(data$variables[[variable]], levels = c(TRUE, FALSE))+ #' |
|||
| 250 | +28 |
- }+ #' @param correct (`logical`)\cr apply continuity correction. |
||
| 251 | -96x | +|||
| 29 | +
- if (!inherits(data$variables[[variable]], "factor")) {
+ #' |
|||
| 252 | -! | +|||
| 30 | +
- data$variables[[variable]] <- factor(data$variables[[variable]])+ #' @export |
|||
| 253 | +31 |
- }+ proportion_ci_wald <- function(x, conf.level = 0.95, correct = FALSE) {
+ |
+ ||
| 32 | +15x | +
+ set_cli_abort_call() |
||
| 254 | +33 | |||
| 255 | +34 |
- # each combination of denominator and whether there is a by variable is handled separately+ # check inputs --------------------------------------------------------------- |
||
| 256 | -96x | +35 | +15x |
- result <-+ check_not_missing(x) |
| 257 | -96x | +36 | +15x |
- case_switch(+ check_binary(x) |
| 258 | -+ | |||
| 37 | +15x |
- # by variable and column percentages+ check_range(conf.level, range = c(0, 1), include_bounds = c(FALSE, FALSE)) |
||
| 259 | -96x | +38 | +15x |
- !is_empty(by) && denominator == "column" ~+ check_scalar(conf.level) |
| 260 | -96x | +39 | +15x |
- .one_svytable_rates_by_column(data, variable, by, deff),+ check_class(x = correct, "logical") |
| 261 | -+ | |||
| 40 | +15x |
- # by variable and row percentages+ check_scalar(correct) |
||
| 262 | -96x | +|||
| 41 | +
- !is_empty(by) && denominator == "row" ~+ |
|||
| 263 | -96x | +42 | +15x |
- .one_svytable_rates_by_row(data, variable, by, deff),+ x <- stats::na.omit(x) |
| 264 | +43 |
- # by variable and cell percentages+ |
||
| 265 | -96x | +44 | +15x |
- !is_empty(by) && denominator == "cell" ~+ n <- length(x) |
| 266 | -96x | +45 | +15x |
- .one_svytable_rates_by_cell(data, variable, by, deff),+ p_hat <- mean(x) |
| 267 | -+ | |||
| 46 | +15x |
- # no by variable and column/cell percentages+ z <- stats::qnorm((1 + conf.level) / 2) |
||
| 268 | -96x | +47 | +15x |
- denominator %in% c("column", "cell") ~
+ q_hat <- 1 - p_hat |
| 269 | -96x | +48 | +15x |
- .one_svytable_rates_no_by_column_and_cell(data, variable, deff),+ correction_factor <- ifelse(correct, 1 / (2 * n), 0) |
| 270 | +49 |
- # no by variable and row percentages+ |
||
| 271 | -96x | +50 | +15x |
- denominator == "row" ~+ err <- z * sqrt(p_hat * q_hat) / sqrt(n) + correction_factor |
| 272 | -96x | +51 | +15x |
- .one_svytable_rates_no_by_row(data, variable, deff)+ l_ci <- max(0, p_hat - err) |
| 273 | -+ | |||
| 52 | +15x |
- )+ u_ci <- min(1, p_hat + err) |
||
| 274 | +53 | |||
| 275 | -+ | |||
| 54 | +15x |
- # if a level was added, remove the fake level+ list( |
||
| 276 | -96x | +55 | +15x |
- if (length(variable_lvls) == 1L) {
+ N = n, |
| 277 | -6x | +56 | +15x |
- result <- result |> dplyr::filter(.data$variable_level %in% variable_lvls)+ estimate = p_hat, |
| 278 | -+ | |||
| 57 | +15x |
- }+ conf.low = l_ci, |
||
| 279 | -96x | +58 | +15x |
- if (!is_empty(by) && length(by_lvls) == 1L) {
+ conf.high = u_ci, |
| 280 | -12x | +59 | +15x |
- result <- result |> dplyr::filter(.data$group1_level %in% by_lvls)+ conf.level = conf.level, |
| 281 | -+ | |||
| 60 | +15x |
- }+ method =+ |
+ ||
| 61 | +15x | +
+ glue::glue("Wald Confidence Interval {ifelse(correct, 'with', 'without')} continuity correction")
|
||
| 282 | +62 |
-
+ ) |
||
| 283 | -96x | +|||
| 63 | +
- result+ } |
|||
| 284 | +64 |
- }+ |
||
| 285 | +65 |
- ) |>+ |
||
| 286 | -49x | +|||
| 66 | +
- dplyr::bind_rows()+ #' @describeIn proportion_ci Calculates the Wilson interval by calling [stats::prop.test()]. |
|||
| 287 | +67 |
- }+ #' Also referred to as Wilson score interval. |
||
| 288 | +68 |
-
+ #' |
||
| 289 | +69 |
- .one_svytable_rates_no_by_row <- function(data, variable, deff) {
+ #' \deqn{\frac{\hat{p} +
|
||
| 290 | -10x | +|||
| 70 | +
- dplyr::tibble(+ #' \frac{z^2_{\alpha/2}}{2n} \pm z_{\alpha/2} \sqrt{\frac{\hat{p}(1 - \hat{p})}{n} +
|
|||
| 291 | -10x | +|||
| 71 | +
- variable = .env$variable,+ #' \frac{z^2_{\alpha/2}}{4n^2}}}{1 + \frac{z^2_{\alpha/2}}{n}}}
|
|||
| 292 | -10x | +|||
| 72 | +
- variable_level = unique(data$variables[[variable]]) |> sort() |> as.character(),+ #' |
|||
| 293 | -10x | +|||
| 73 | +
- p = 1,+ #' @export |
|||
| 294 | -10x | +|||
| 74 | +
- p.std.error = 0,+ proportion_ci_wilson <- function(x, conf.level = 0.95, correct = FALSE) {
|
|||
| 295 | -10x | +75 | +5x |
- deff = NaN+ set_cli_abort_call() |
| 296 | +76 |
- )+ |
||
| 297 | +77 |
- }+ # check installed packages ---------------------------------------------------+ |
+ ||
| 78 | +5x | +
+ check_pkg_installed(pkg = "broom", reference_pkg = "cardx") |
||
| 298 | +79 | |||
| 299 | +80 |
- .one_svytable_rates_no_by_column_and_cell <- function(data, variable, deff) {
+ # check inputs --------------------------------------------------------------- |
||
| 300 | -23x | +81 | +5x |
- survey::svymean(reformulate2(variable), design = data, na.rm = TRUE, deff = deff) |>+ check_not_missing(x) |
| 301 | -23x | +82 | +5x |
- dplyr::as_tibble(rownames = "var_level") |>+ check_binary(x) |
| 302 | -23x | +83 | +5x |
- dplyr::mutate(+ check_class(x = correct, "logical") |
| 303 | -23x | +84 | +5x |
- variable_level = str_remove(.data$var_level, pattern = paste0("^", .env$variable)),
+ check_scalar(correct) |
| 304 | -23x | -
- variable = .env$variable- |
- ||
| 305 | -+ | 85 | +5x |
- ) |>+ check_range(conf.level, range = c(0, 1), include_bounds = c(FALSE, FALSE)) |
| 306 | -23x | +86 | +5x |
- dplyr::select("variable", "variable_level", p = "mean", p.std.error = "SE", any_of("deff"))
+ check_scalar(conf.level) |
| 307 | +87 |
- }+ |
||
| 308 | -+ | |||
| 88 | +5x |
-
+ x <- stats::na.omit(x) |
||
| 309 | +89 |
- .one_svytable_rates_by_cell <- function(data, variable, by, deff) {
+
|
||
| 310 | -20x | +90 | +5x |
- df_interaction_id <-+ n <- length(x) |
| 311 | -20x | +91 | +5x |
- .df_all_combos(data, variable, by) |>+ y <- stats::prop.test(x = sum(x), n = n, correct = correct, conf.level = conf.level) |
| 312 | -20x | +|||
| 92 | +
- dplyr::mutate(+ |
|||
| 313 | -20x | +93 | +5x |
- var_level =+ list(N = n, conf.level = conf.level) |> |
| 314 | -20x | -
- glue::glue("interaction({.env$by}, {.env$variable}){.data$group1_level}.{.data$variable_level}")
- |
- ||
| 315 | -- |
- )- |
- ||
| 316 | -+ | 94 | +5x |
-
+ utils::modifyList(val = broom::tidy(y) |> as.list()) |> |
| 317 | -20x | +95 | +5x |
- survey::svymean(+ utils::modifyList( |
| 318 | -20x | +96 | +5x |
- x = inject(~ interaction(!!sym(bt(by)), !!sym(bt(variable)))),+ list( |
| 319 | -20x | +97 | +5x |
- design = data,+ method = |
| 320 | -20x | +98 | +5x |
- na.rm = TRUE,+ glue::glue("Wilson Confidence Interval {ifelse(correct, 'with', 'without')} continuity correction")
|
| 321 | -20x | +|||
| 99 | +
- deff = deff+ ) |
|||
| 322 | +100 |
- ) |>+ ) |
||
| 323 | -20x | +|||
| 101 | +
- dplyr::as_tibble(rownames = "var_level") |>+ } |
|||
| 324 | -20x | +|||
| 102 | +
- dplyr::left_join(df_interaction_id, by = "var_level") |>+ |
|||
| 325 | -20x | +|||
| 103 | +
- dplyr::select(+ #' @describeIn proportion_ci Calculates the Clopper-Pearson interval by calling [stats::binom.test()]. |
|||
| 326 | -20x | +|||
| 104 | +
- cards::all_ard_groups(), cards::all_ard_variables(),+ #' Also referred to as the `exact` method. |
|||
| 327 | -20x | +|||
| 105 | +
- p = "mean", p.std.error = "SE", any_of("deff")
+ #' |
|||
| 328 | +106 |
- )+ #' \deqn{
|
||
| 329 | +107 |
- }+ #' \left( \frac{k}{n} \pm z_{\alpha/2} \sqrt{\frac{\frac{k}{n}(1-\frac{k}{n})}{n} +
|
||
| 330 | +108 |
-
+ #' \frac{z^2_{\alpha/2}}{4n^2}} \right)
|
||
| 331 | +109 |
- .one_svytable_rates_by_row <- function(data, variable, by, deff) {
+ #' / \left( 1 + \frac{z^2_{\alpha/2}}{n} \right)}
|
||
| 332 | -20x | +|||
| 110 | +
- survey::svyby(+ #' |
|||
| 333 | -20x | +|||
| 111 | +
- formula = reformulate2(by),+ #' @export |
|||
| 334 | -20x | +|||
| 112 | +
- by = reformulate2(variable),+ proportion_ci_clopper_pearson <- function(x, conf.level = 0.95) {
|
|||
| 335 | -20x | +113 | +2x |
- design = data,+ set_cli_abort_call() |
| 336 | -20x | +|||
| 114 | +
- FUN = survey::svymean,+ |
|||
| 337 | -20x | +|||
| 115 | +
- na.rm = TRUE,+ # check installed packages --------------------------------------------------- |
|||
| 338 | -20x | +116 | +2x |
- deff = deff+ check_pkg_installed(pkg = "broom", reference_pkg = "cardx") |
| 339 | +117 |
- ) |>+ |
||
| 340 | -20x | +|||
| 118 | +
- dplyr::as_tibble() |>+ # check inputs --------------------------------------------------------------- |
|||
| 341 | -20x | +119 | +2x |
- tidyr::pivot_longer(-all_of(variable)) |>+ check_not_missing(x) |
| 342 | -20x | +120 | +2x |
- dplyr::mutate(+ check_binary(x) |
| 343 | -20x | +121 | +2x |
- stat =+ check_range(conf.level, range = c(0, 1), include_bounds = c(FALSE, FALSE)) |
| 344 | -20x | +122 | +2x |
- dplyr::case_when(+ check_scalar(conf.level) |
| 345 | -20x | +|||
| 123 | +
- startsWith(.data$name, paste0("se.", by)) | startsWith(.data$name, paste0("se.`", by, "`")) ~ "p.std.error",
+
|
|||
| 346 | -20x | +124 | +2x |
- startsWith(.data$name, paste0("DEff.", by)) | startsWith(.data$name, paste0("DEff.`", by, "`")) ~ "deff",
+ x <- stats::na.omit(x) |
| 347 | -20x | +125 | +2x |
- TRUE ~ "p"+ n <- length(x) |
| 348 | +126 |
- ),+ |
||
| 349 | -20x | +127 | +2x |
- name =+ y <- stats::binom.test(x = sum(x), n = n, conf.level = conf.level) |
| 350 | -20x | +|||
| 128 | +
- str_remove_all(.data$name, "se\\.") %>%+ |
|||
| 351 | -20x | +129 | +2x |
- str_remove_all("DEff\\.") %>%
+ list(N = n, conf.level = conf.level) |> |
| 352 | -20x | +130 | +2x |
- str_remove_all(by) %>%+ utils::modifyList(val = broom::tidy(y) |> as.list()) |> |
| 353 | -20x | +131 | +2x |
- str_remove_all("`")
+ utils::modifyList(list(method = "Clopper-Pearson Confidence Interval")) |
| 354 | +132 |
- ) |>+ } |
||
| 355 | -20x | +|||
| 133 | +
- tidyr::pivot_wider(names_from = "stat", values_from = "value") |>+ |
|||
| 356 | -20x | +|||
| 134 | +
- set_names(c("variable_level", "group1_level", "p", "p.std.error", "deff")) |>
+ #' @describeIn proportion_ci Calculates the `Agresti-Coull` interval (created by `Alan Agresti` and `Brent Coull`) by |
|||
| 357 | -20x | +|||
| 135 | +
- dplyr::mutate(+ #' (for 95% CI) adding two successes and two failures to the data and then using the Wald formula to construct a CI. |
|||
| 358 | -20x | +|||
| 136 | +
- group1 = .env$by,+ #' |
|||
| 359 | -20x | +|||
| 137 | +
- variable = .env$variable,+ #' \deqn{
|
|||
| 360 | -20x | +|||
| 138 | +
- across(c("group1_level", "variable_level"), as.character)
+ #' \left( \frac{\tilde{p} + z^2_{\alpha/2}/2}{n + z^2_{\alpha/2}} \pm
|
|||
| 361 | +139 |
- )+ #' z_{\alpha/2} \sqrt{\frac{\tilde{p}(1 - \tilde{p})}{n} +
|
||
| 362 | +140 |
- }+ #' \frac{z^2_{\alpha/2}}{4n^2}} \right)}
|
||
| 363 | +141 |
-
+ #' |
||
| 364 | +142 |
- .one_svytable_rates_by_column <- function(data, variable, by, deff) {
+ #' @export |
||
| 365 | -23x | +|||
| 143 | +
- survey::svyby(+ proportion_ci_agresti_coull <- function(x, conf.level = 0.95) {
|
|||
| 366 | -23x | +144 | +2x |
- formula = reformulate2(variable),+ set_cli_abort_call() |
| 367 | -23x | +|||
| 145 | +
- by = reformulate2(by),+ + |
+ |||
| 146 | ++ |
+ # check inputs --------------------------------------------------------------- |
||
| 368 | -23x | +147 | +2x |
- design = data,+ check_not_missing(x) |
| 369 | -23x | +148 | +2x |
- FUN = survey::svymean,+ check_binary(x) |
| 370 | -23x | +149 | +2x |
- na.rm = TRUE,+ check_range(conf.level, range = c(0, 1), include_bounds = c(FALSE, FALSE)) |
| 371 | -23x | +150 | +2x |
- deff = deff+ check_scalar(conf.level) |
| 372 | +151 |
- ) |>+ |
||
| 373 | -23x | +152 | +2x |
- dplyr::as_tibble() |>+ x <- stats::na.omit(x) |
| 374 | -23x | +|||
| 153 | +
- tidyr::pivot_longer(-all_of(by)) |>+ |
|||
| 375 | -23x | +154 | +2x |
- dplyr::mutate(+ n <- length(x) |
| 376 | -23x | +155 | +2x |
- stat =+ x_sum <- sum(x) |
| 377 | -23x | +156 | +2x |
- dplyr::case_when(+ z <- stats::qnorm((1 + conf.level) / 2) |
| 378 | -23x | +|||
| 157 | +
- startsWith(.data$name, paste0("se.", variable)) | startsWith(.data$name, paste0("se.`", variable, "`")) ~ "p.std.error",
+
+ |
+ |||
| 158 | ++ |
+ # Add here both z^2 / 2 successes and failures. |
||
| 379 | -23x | +159 | +2x |
- startsWith(.data$name, paste0("DEff.", variable)) | startsWith(.data$name, paste0("DEff.`", variable, "`")) ~ "deff",
+ x_sum_tilde <- x_sum + z^2 / 2 |
| 380 | -23x | +160 | +2x |
- TRUE ~ "p"+ n_tilde <- n + z^2 |
| 381 | +161 |
- ),+ + |
+ ||
| 162 | ++ |
+ # Then proceed as with the Wald interval. |
||
| 382 | -23x | +163 | +2x |
- name =+ p_tilde <- x_sum_tilde / n_tilde |
| 383 | -23x | +164 | +2x |
- str_remove_all(.data$name, "se\\.") %>%+ q_tilde <- 1 - p_tilde |
| 384 | -23x | +165 | +2x |
- str_remove_all("DEff\\.") %>%
+ err <- z * sqrt(p_tilde * q_tilde) / sqrt(n_tilde) |
| 385 | -23x | +166 | +2x |
- str_remove_all(variable) %>%+ l_ci <- max(0, p_tilde - err) |
| 386 | -23x | +167 | +2x |
- str_remove_all("`")
+ u_ci <- min(1, p_tilde + err) |
| 387 | +168 |
- ) |>+ |
||
| 388 | -23x | +169 | +2x |
- tidyr::pivot_wider(names_from = "stat", values_from = "value") |>+ list( |
| 389 | -23x | +170 | +2x |
- set_names(c("group1_level", "variable_level", "p", "p.std.error", "deff")) |>
+ N = n, |
| 390 | -23x | +171 | +2x |
- dplyr::mutate(+ estimate = mean(x), |
| 391 | -23x | +172 | +2x |
- group1 = .env$by,+ conf.low = l_ci, |
| 392 | -23x | +173 | +2x |
- variable = .env$variable,+ conf.high = u_ci, |
| 393 | -23x | +174 | +2x |
- across(c("group1_level", "variable_level"), as.character)
+ conf.level = conf.level,+ |
+
| 175 | +2x | +
+ method = "Agresti-Coull Confidence Interval" |
||
| 394 | +176 |
- )+ ) |
||
| 395 | +177 |
} |
||
| 396 | +178 | |||
| 397 | +179 |
- .svytable_counts <- function(data, variables, by, denominator) {
+ #' @describeIn proportion_ci Calculates the Jeffreys interval, an equal-tailed interval based on the |
||
| 398 | -49x | +|||
| 180 | +
- df_counts <-+ #' non-informative Jeffreys prior for a binomial proportion. |
|||
| 399 | -49x | +|||
| 181 | +
- lapply(+ #' |
|||
| 400 | -49x | +|||
| 182 | +
- variables,+ #' \deqn{\left( \text{Beta}\left(\frac{k}{2} + \frac{1}{2}, \frac{n - k}{2} + \frac{1}{2}\right)_\alpha,
+ |
+ |||
| 183 | ++ |
+ #' \text{Beta}\left(\frac{k}{2} + \frac{1}{2}, \frac{n - k}{2} + \frac{1}{2}\right)_{1-\alpha} \right)}
+ |
+ ||
| 184 | ++ |
+ #'+ |
+ ||
| 185 | ++ |
+ #' @export+ |
+ ||
| 186 | ++ |
+ proportion_ci_jeffreys <- function(x, conf.level = 0.95) {
|
||
| 401 | -49x | +187 | +3x |
- \(variable) {
+ set_cli_abort_call() |
| 402 | +188 |
- # perform weighted tabulation+ |
||
| 403 | -96x | +|||
| 189 | +
- df_count <-+ # check inputs --------------------------------------------------------------- |
|||
| 404 | -96x | +190 | +3x |
- survey::svytable(formula = reformulate2(c(by, variable)), design = data) |>+ check_not_missing(x) |
| 405 | -96x | +191 | +3x |
- dplyr::as_tibble()+ check_binary(x) |
| 406 | -96x | +192 | +3x |
- if (is_empty(by)) {
+ check_range(conf.level, range = c(0, 1), include_bounds = c(FALSE, FALSE)) |
| 407 | -33x | +193 | +3x |
- names(df_count) <- c("variable_level", "n")
+ check_scalar(conf.level) |
| 408 | -33x | +194 | +3x |
- df_count$variable <- variable+ x <- stats::na.omit(x) |
| 409 | +195 |
- } else {
- |
- ||
| 410 | -63x | -
- names(df_count) <- c("group1_level", "variable_level", "n")
+
|
||
| 411 | -63x | +196 | +3x |
- df_count$variable <- variable+ n <- length(x) |
| 412 | -63x | +197 | +3x |
- df_count$group1 <- by+ x_sum <- sum(x) |
| 413 | +198 |
- }+ |
||
| 414 | -+ | |||
| 199 | +3x |
-
+ alpha <- 1 - conf.level |
||
| 415 | -+ | |||
| 200 | +3x |
- # adding unobserved levels+ l_ci <- ifelse( |
||
| 416 | -96x | +201 | +3x |
- .df_all_combos(data, variable, by) %>%+ x_sum == 0, |
| 417 | -96x | +202 | +3x |
- dplyr::left_join(+ 0, |
| 418 | -96x | +203 | +3x |
- df_count,+ stats::qbeta(alpha / 2, x_sum + 0.5, n - x_sum + 0.5) |
| 419 | -96x | +|||
| 204 | +
- by = names(.)+ ) |
|||
| 420 | +205 |
- ) |>+ |
||
| 421 | -96x | +206 | +3x |
- tidyr::replace_na(list(n = 0)) # unobserved levels assigned zero count+ u_ci <- ifelse( |
| 422 | -+ | |||
| 207 | +3x |
- }+ x_sum == n, |
||
| 423 | -+ | |||
| 208 | +3x |
- ) |>+ 1, |
||
| 424 | -49x | +209 | +3x |
- dplyr::bind_rows()+ stats::qbeta(1 - alpha / 2, x_sum + 0.5, n - x_sum + 0.5) |
| 425 | +210 |
-
+ ) |
||
| 426 | +211 |
- # add big N and p, then return data frame of results+ |
||
| 427 | -49x | +212 | +3x |
- switch(denominator,+ list( |
| 428 | -+ | |||
| 213 | +3x |
- "column" =+ N = n, |
||
| 429 | -19x | +214 | +3x |
- df_counts |>+ estimate = mean(x), |
| 430 | -19x | +215 | +3x |
- dplyr::mutate(+ conf.low = l_ci, |
| 431 | -19x | +216 | +3x |
- .by = c(cards::all_ard_groups(), cards::all_ard_variables("names")),
+ conf.high = u_ci, |
| 432 | -19x | +217 | +3x |
- N = sum(.data$n),+ conf.level = conf.level, |
| 433 | -19x | +218 | +3x |
- p = .data$n / .data$N+ method = glue::glue("Jeffreys Interval")
|
| 434 | +219 |
- ),+ ) |
||
| 435 | +220 |
- "row" =+ } |
||
| 436 | -15x | +|||
| 221 | +
- df_counts |>+ |
|||
| 437 | -15x | +|||
| 222 | +
- dplyr::mutate(+ |
|||
| 438 | -15x | +|||
| 223 | +
- .by = cards::all_ard_variables(),+ #' @describeIn proportion_ci Calculates the stratified Wilson confidence |
|||
| 439 | -15x | +|||
| 224 | +
- N = sum(.data$n),+ #' interval for unequal proportions as described in |
|||
| 440 | -15x | +|||
| 225 | +
- p = .data$n / .data$N+ #' Xin YA, Su XG. Stratified Wilson and Newcombe confidence intervals |
|||
| 441 | +226 |
- ),+ #' for multiple binomial proportions. _Statistics in Biopharmaceutical Research_. 2010;2(3). |
||
| 442 | +227 |
- "cell" =+ #' |
||
| 443 | -15x | +|||
| 228 | +
- df_counts |>+ #' \deqn{\frac{\hat{p}_j + \frac{z^2_{\alpha/2}}{2n_j} \pm
|
|||
| 444 | -15x | +|||
| 229 | +
- dplyr::mutate(+ #' z_{\alpha/2} \sqrt{\frac{\hat{p}_j(1 - \hat{p}_j)}{n_j} +
|
|||
| 445 | -15x | +|||
| 230 | +
- .by = c(cards::all_ard_groups("names"), cards::all_ard_variables("names")),
+ #' \frac{z^2_{\alpha/2}}{4n_j^2}}}{1 + \frac{z^2_{\alpha/2}}{n_j}}}
|
|||
| 446 | -15x | +|||
| 231 | +
- N = sum(.data$n),+ #' |
|||
| 447 | -15x | +|||
| 232 | +
- p = .data$n / .data$N+ #' |
|||
| 448 | +233 |
- )+ #' @param strata (`factor`)\cr variable with one level per stratum and same length as `x`. |
||
| 449 | +234 |
- )+ #' @param weights (`numeric` or `NULL`)\cr weights for each level of the strata. If `NULL`, they are |
||
| 450 | +235 |
- }+ #' estimated using the iterative algorithm that |
||
| 451 | +236 |
-
+ #' minimizes the weighted squared length of the confidence interval. |
||
| 452 | +237 |
- .df_all_combos <- function(data, variable, by) {
+ #' @param max.iterations (`count`)\cr maximum number of iterations for the iterative procedure used |
||
| 453 | -116x | +|||
| 238 | +
- df <- cards::nest_for_ard(+ #' to find estimates of optimal weights. |
|||
| 454 | -116x | +|||
| 239 | +
- data = data$variables,+ #' @param correct (`flag`)\cr include the continuity correction. For further information, see for example |
|||
| 455 | -116x | +|||
| 240 | +
- by = c(by, variable),+ #' [stats::prop.test()]. |
|||
| 456 | -116x | +|||
| 241 | +
- list_columns = FALSE,+ #' |
|||
| 457 | -116x | +|||
| 242 | +
- include_data = FALSE+ #' @examples |
|||
| 458 | +243 |
- )+ #' # Stratified Wilson confidence interval with unequal probabilities |
||
| 459 | +244 |
-
+ #' |
||
| 460 | +245 |
- # renaming with variable colnames+ #' set.seed(1) |
||
| 461 | -116x | +|||
| 246 | +
- if (!is_empty(by)) {
+ #' rsp <- sample(c(TRUE, FALSE), 100, TRUE) |
|||
| 462 | -83x | +|||
| 247 | +
- df <- dplyr::rename(df, variable = "group2", variable_level = "group2_level")+ #' strata_data <- data.frame( |
|||
| 463 | +248 |
- } else {
+ #' "f1" = sample(c("a", "b"), 100, TRUE),
|
||
| 464 | -33x | +|||
| 249 | +
- df <- dplyr::rename(df, variable = "group1", variable_level = "group1_level")+ #' "f2" = sample(c("x", "y", "z"), 100, TRUE),
|
|||
| 465 | +250 |
- }+ #' stringsAsFactors = TRUE |
||
| 466 | +251 |
-
+ #' ) |
||
| 467 | +252 |
- # convert levels to character for merging later+ #' strata <- interaction(strata_data) |
||
| 468 | -116x | +|||
| 253 | +
- df |>+ #' n_strata <- ncol(table(rsp, strata)) # Number of strata |
|||
| 469 | -116x | +|||
| 254 | +
- dplyr::mutate(+ #' |
|||
| 470 | -116x | +|||
| 255 | +
- across(+ #' proportion_ci_strat_wilson( |
|||
| 471 | -116x | +|||
| 256 | +
- c(cards::all_ard_groups("levels"), cards::all_ard_variables("levels")),
+ #' x = rsp, strata = strata, |
|||
| 472 | -116x | +|||
| 257 | +
- as.character+ #' conf.level = 0.90 |
|||
| 473 | +258 |
- )+ #' ) |
||
| 474 | +259 |
- )+ #' |
||
| 475 | +260 |
- }+ #' # Not automatic setting of weights |
||
| 476 | +261 |
-
+ #' proportion_ci_strat_wilson( |
||
| 477 | +262 |
- case_switch <- function(..., .default = NULL) {
+ #' x = rsp, strata = strata, |
||
| 478 | +263 |
- dots <- dots_list(...)+ #' weights = rep(1 / n_strata, n_strata), |
||
| 479 | +264 |
-
+ #' conf.level = 0.90 |
||
| 480 | +265 |
- for (f in dots) {
+ #' ) |
||
| 481 | +266 |
- if (isTRUE(eval(f_lhs(f), envir = attr(f, ".Environment")))) {
+ #' |
||
| 482 | +267 |
- return(eval(f_rhs(f), envir = attr(f, ".Environment")))+ #' @export |
||
| 483 | +268 |
- }+ proportion_ci_strat_wilson <- function(x, |
||
| 484 | +269 |
- }+ strata, |
||
| 485 | +270 |
-
+ weights = NULL, |
||
| 486 | +271 |
- return(.default)+ conf.level = 0.95, |
||
| 487 | +272 | ++ |
+ max.iterations = 10L,+ |
+ |
| 273 |
- }+ correct = FALSE) {
+ |
+ |||
| 274 | +2x | +
+ set_cli_abort_call() |
||
| 488 | +275 | |||
| 489 | +276 |
- .default_svy_cat_fmt_fn <- function(x) {
+ # check inputs --------------------------------------------------------------- |
||
| 490 | -53x | +277 | +2x |
- x |>+ check_not_missing(x) |
| 491 | -53x | +278 | +2x |
- dplyr::mutate(+ check_not_missing(strata) |
| 492 | -53x | +279 | +2x |
- fmt_fn =+ check_binary(x) |
| 493 | -53x | +280 | +2x |
- pmap(+ check_class(correct, "logical") |
| 494 | -53x | +281 | +2x |
- list(.data$stat_name, .data$stat, .data$fmt_fn),+ check_scalar(correct) |
| 495 | -53x | +282 | +2x |
- function(stat_name, stat, fmt_fn) {
+ check_class(strata, "factor") |
| 496 | -3438x | +283 | +2x |
- if (!is_empty(fmt_fn)) {
+ check_range(conf.level, range = c(0, 1), include_bounds = c(FALSE, FALSE)) |
| 497 | -! | +|||
| 284 | +2x |
- return(fmt_fn)+ check_scalar(conf.level) |
||
| 498 | +285 |
- }- |
- ||
| 499 | -3438x | -
- if (stat_name %in% c("p", "p_miss", "p_nonmiss", "p_unweighted")) {
- |
- ||
| 500 | -864x | -
- return(cards::label_cards(digits = 1, scale = 100))+ |
||
| 501 | +286 |
- }+ # remove missing values from x and strata |
||
| 502 | -2574x | +287 | +2x |
- if (stat_name %in% c("n", "N", "N_miss", "N_nonmiss", "N_obs", "n_unweighted", "N_unweighted")) {
+ is_na <- is.na(x) | is.na(strata) |
| 503 | -1719x | -
- return(cards::label_cards(digits = 0))- |
- ||
| 504 | -+ | 288 | +2x |
- }+ x <- x[!is_na] |
| 505 | -855x | +289 | +2x |
- if (is.integer(stat)) {
+ strata <- strata[!is_na] |
| 506 | -27x | +|||
| 290 | +! |
- return(0L)+ if (!inherits(x, "logical")) x <- as.logical(x) |
||
| 507 | +291 |
- }- |
- ||
| 508 | -828x | -
- if (is.numeric(stat)) {
+ # check all TRUE/FALSE, if so, not calculable |
||
| 509 | -828x | -
- return(1L)- |
- ||
| 510 | -+ | 292 | +2x |
- }+ if (all(x) || all(!x)) {
|
| 511 | +293 | ! |
- return(as.character)+ cli::cli_abort("All values in {.arg x} argument are either {.code TRUE} or {.code FALSE} and CI is not estimable.")
|
|
| 512 | +294 |
- }+ } |
||
| 513 | +295 |
- )+ |
||
| 514 | -+ | |||
| 296 | +2x |
- )+ tbl <- table(factor(x, levels = c(FALSE, TRUE)), strata, useNA = "no") |
||
| 515 | -+ | |||
| 297 | +2x |
- }+ n_strata <- length(unique(strata)) |
||
| 516 | +298 | |||
| 517 | +299 |
- #' Convert Nested Lists to Column+ # Checking the weights and maximum number of iterations. |
||
| 518 | -+ | |||
| 300 | +2x |
- #'+ do_iter <- FALSE |
||
| 519 | -+ | |||
| 301 | +2x |
- #' Some arguments, such as `stat_label`, are passed as nested lists. This+ if (is.null(weights)) {
|
||
| 520 | -+ | |||
| 302 | +! |
- #' function properly unnests these lists and adds them to the results data frame.+ weights <- rep(1 / n_strata, n_strata) # Initialization for iterative procedure |
||
| 521 | -+ | |||
| 303 | +! |
- #'+ do_iter <- TRUE |
||
| 522 | +304 |
- #' @param x (`data.frame`)\cr+ |
||
| 523 | +305 |
- #' result data frame+ # Iteration parameters |
||
| 524 | -+ | |||
| 306 | +! |
- #' @param arg (`list`)\cr+ if (!is_scalar_integerish(max.iterations) || max.iterations < 1) {
|
||
| 525 | -+ | |||
| 307 | +! |
- #' the nested list+ cli::cli_abort("Argument {.arg max.iterations} must be a positive integer.")
|
||
| 526 | +308 |
- #' @param new_column (`string`)\cr+ } |
||
| 527 | +309 |
- #' new column name+ } |
||
| 528 | -+ | |||
| 310 | +2x |
- #' @param unlist (`logical`)\cr+ check_range(weights, range = c(0, 1), include_bounds = c(TRUE, TRUE)) |
||
| 529 | -+ | |||
| 311 | +2x |
- #' whether to fully unlist final results+ sum_weights <- sum(weights) |> |
||
| 530 | -+ | |||
| 312 | +2x |
- #'+ round() |> |
||
| 531 | -+ | |||
| 313 | +2x |
- #' @return a data frame+ as.integer() |
||
| 532 | -+ | |||
| 314 | +2x |
- #' @keywords internal+ if (sum_weights != 1L || abs(sum_weights - sum(weights)) > sqrt(.Machine$double.eps)) {
|
||
| 533 | -+ | |||
| 315 | +! |
- #'+ cli::cli_abort("The sum of the {.arg weights} argument must be {.val {1L}}")
|
||
| 534 | +316 |
- #' @examples+ } |
||
| 535 | +317 |
- #' ard <- ard_categorical(cards::ADSL, by = "ARM", variables = "AGEGR1")+ |
||
| 536 | -+ | |||
| 318 | +2x |
- #'+ xs <- tbl["TRUE", ] |
||
| 537 | -+ | |||
| 319 | +2x |
- #' cardx:::.process_nested_list_as_df(ard, NULL, "new_col")+ ns <- colSums(tbl) |
||
| 538 | -+ | |||
| 320 | +2x |
- .process_nested_list_as_df <- function(x, arg, new_column, unlist = FALSE) {
+ use_stratum <- (ns > 0) |
||
| 539 | -+ | |||
| 321 | +2x |
- # add fmt_fn column if not already present+ ns <- ns[use_stratum] |
||
| 540 | -106x | +322 | +2x |
- if (!new_column %in% names(x)) {
+ xs <- xs[use_stratum] |
| 541 | -106x | +323 | +2x |
- x[[new_column]] <- list(NULL)+ ests <- xs / ns+ |
+
| 324 | +2x | +
+ vars <- ests * (1 - ests) / ns |
||
| 542 | +325 |
- }+ + |
+ ||
| 326 | +2x | +
+ strata_qnorm <- .strata_normal_quantile(vars, weights, conf.level) |
||
| 543 | +327 | |||
| 544 | +328 |
- # process argument if not NULL, and update new column+ # Iterative setting of weights if they were not passed in `weights` argument |
||
| 545 | -106x | +329 | +2x |
- if (!is_empty(arg)) {
+ weights_new <- if (do_iter) {
|
| 546 | -53x | +|||
| 330 | +! |
- df_argument <-+ .update_weights_strat_wilson(vars, strata_qnorm, weights, ns, max.iterations, conf.level)$weights |
||
| 547 | -53x | +|||
| 331 | +
- imap(+ } else {
|
|||
| 548 | -53x | +332 | +2x |
- arg,+ weights |
| 549 | -53x | +|||
| 333 | +
- function(enlst_arg, variable) {
+ } |
|||
| 550 | -102x | +|||
| 334 | +
- lst_stat_names <-+ |
|||
| 551 | -102x | +335 | +2x |
- x[c("variable", "stat_name")] |>
+ strata_conf.level <- 2 * stats::pnorm(strata_qnorm) - 1 |
| 552 | -102x | +|||
| 336 | +
- dplyr::filter(.data$variable %in% .env$variable) |>+ |
|||
| 553 | -102x | +337 | +2x |
- unique() %>%+ ci_by_strata <- Map( |
| 554 | -102x | +338 | +2x |
- {stats::setNames(as.list(.[["stat_name"]]), .[["stat_name"]])} # styler: off
+ function(x, n) {
|
| 555 | +339 |
-
+ # Classic Wilson's confidence interval |
||
| 556 | -102x | +340 | +12x |
- cards::compute_formula_selector(+ suppressWarnings(stats::prop.test(x, n, correct = correct, conf.level = strata_conf.level)$conf.int) |
| 557 | -102x | +|||
| 341 | +
- data = lst_stat_names,+ }, |
|||
| 558 | -102x | +342 | +2x |
- x = enlst_arg+ x = xs, |
| 559 | -+ | |||
| 343 | +2x |
- ) %>%+ n = ns |
||
| 560 | +344 |
- # styler: off+ ) |
||
| 561 | -102x | +345 | +2x |
- {dplyr::tibble(
+ lower_by_strata <- sapply(ci_by_strata, "[", 1L) |
| 562 | -102x | +346 | +2x |
- variable = variable,+ upper_by_strata <- sapply(ci_by_strata, "[", 2L) |
| 563 | -102x | +|||
| 347 | +
- stat_name = names(.),+ |
|||
| 564 | -102x | +348 | +2x |
- "{new_column}" := unname(.)
+ lower <- sum(weights_new * lower_by_strata) |
| 565 | -+ | |||
| 349 | +2x |
- )}+ upper <- sum(weights_new * upper_by_strata) |
||
| 566 | +350 |
- # styler: on+ |
||
| 567 | +351 |
- }+ # Return values |
||
| 568 | -+ | |||
| 352 | +2x |
- ) |>+ list( |
||
| 569 | -53x | +353 | +2x |
- dplyr::bind_rows()+ N = length(x), |
| 570 | -+ | |||
| 354 | +2x |
-
+ estimate = mean(x), |
||
| 571 | -53x | +355 | +2x |
- x <- x |> dplyr::rows_update(df_argument, by = c("variable", "stat_name"), unmatched = "ignore")
+ conf.low = lower, |
| 572 | -+ | |||
| 356 | +2x |
- }+ conf.high = upper, |
||
| 573 | -+ | |||
| 357 | +2x |
-
+ conf.level = conf.level, |
||
| 574 | -106x | +358 | +2x |
- if (isTRUE(unlist)) {
+ weights = if (do_iter) weights_new else NULL, |
| 575 | -53x | +359 | +2x |
- x[[new_column]] <- lapply(x[[new_column]], function(x) x %||% NA) |> unlist()+ method = |
| 576 | -+ | |||
| 360 | +2x |
- }+ glue::glue("Stratified Wilson Confidence Interval {ifelse(correct, 'with', 'without')} continuity correction")
|
||
| 577 | +361 |
-
+ ) |> |
||
| 578 | -106x | +362 | +2x |
- x+ compact() |
| 579 | +363 |
} |
| 1 | +364 |
- #' ARD Survival Differences+ |
|
| 2 | +365 |
- #'+ #' @describeIn proportion_ci Helper to determine if vector is binary (logical or 0/1) |
|
| 3 | +366 |
- #' Calculate differences in the Kaplan-Meier estimator of survival using the+ #' |
|
| 4 | +367 |
- #' results from [`survival::survfit()`].+ #' @export |
|
| 5 | +368 |
- #'+ is_binary <- function(x) {
|
|
| 6 | -+ | ||
| 369 | +16x |
- #' @param x (`survift`)\cr+ is.logical(x) || (is_integerish(x) && is_empty(setdiff(x, c(0, 1, NA)))) |
|
| 7 | +370 |
- #' object of class `'survfit'` typically created with [`survival::survfit()`]+ } |
|
| 8 | +371 |
- #' @param conf.level (scalar `numeric`)\cr+ |
|
| 9 | +372 |
- #' confidence level for confidence interval. Default is `0.95`.+ #' Helper Function for the Estimation of Stratified Quantiles |
|
| 10 | +373 |
- #' @inheritParams ard_survival_survfit+ #' |
|
| 11 | +374 |
- #'+ #' This function wraps the estimation of stratified percentiles when we assume |
|
| 12 | +375 |
- #' @return an ARD data frame of class 'card'+ #' the approximation for large numbers. This is necessary only in the case |
|
| 13 | +376 |
- #' @export+ #' proportions for each strata are unequal. |
|
| 14 | +377 |
#' |
|
| 15 | +378 |
- #' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = c("survival", "ggsurvfit"), reference_pkg = "cardx"))
+ #' @inheritParams proportion_ci_strat_wilson |
|
| 16 | +379 |
- #' library(ggsurvfit)+ #' |
|
| 17 | +380 |
- #' library(survival)+ #' @return Stratified quantile. |
|
| 18 | +381 |
#' |
|
| 19 | +382 |
- #' survfit(Surv_CNSR() ~ TRTA, data = cards::ADTTE) |>+ #' @seealso [proportion_ci_strat_wilson()] |
|
| 20 | +383 |
- #' ard_survival_survfit_diff(times = c(25, 50))+ #' |
|
| 21 | +384 |
- ard_survival_survfit_diff <- function(x, times, conf.level = 0.95) {
- |
- |
| 22 | -2x | -
- set_cli_abort_call()+ #' @keywords internal |
|
| 23 | +385 |
-
+ #' |
|
| 24 | +386 |
- # check installed packages ---------------------------------------------------- |
- |
| 25 | -2x | -
- check_pkg_installed(c("survival", "broom"), reference_pkg = "cardx")
+ #' @examples |
|
| 26 | -2x | +||
| 387 | +
- check_not_missing(x)+ #' strata_data <- table(data.frame( |
||
| 27 | -2x | +||
| 388 | +
- check_not_missing(times)+ #' "f1" = sample(c(TRUE, FALSE), 100, TRUE), |
||
| 28 | -2x | +||
| 389 | +
- check_class(x, "survfit")+ #' "f2" = sample(c("x", "y", "z"), 100, TRUE),
|
||
| 29 | +390 |
-
+ #' stringsAsFactors = TRUE |
|
| 30 | -2x | +||
| 391 | +
- if (inherits(x, c("survfitms", "survfitcox"))) {
+ #' )) |
||
| 31 | -! | +||
| 392 | +
- cli::cli_abort(+ #' ns <- colSums(strata_data) |
||
| 32 | -! | +||
| 393 | +
- "Argument {.arg x} cannot be class {.cls {c('survfitms', 'survfitcox')}}.",
+ #' ests <- strata_data["TRUE", ] / ns |
||
| 33 | -! | +||
| 394 | +
- call = get_cli_abort_call()+ #' vars <- ests * (1 - ests) / ns |
||
| 34 | +395 |
- )+ #' weights <- rep(1 / length(ns), length(ns)) |
|
| 35 | +396 |
- }+ #' |
|
| 36 | -2x | +||
| 397 | +
- check_scalar_range(conf.level, range = c(0, 1))+ #' cardx:::.strata_normal_quantile(vars, weights, 0.95) |
||
| 37 | -2x | +||
| 398 | +
- check_length(+ .strata_normal_quantile <- function(vars, weights, conf.level) {
|
||
| 38 | +399 | 2x |
- as.list(x$call)[["formula"]] |> stats::as.formula() |> stats::terms() |> attr("term.labels"),
+ summands <- weights^2 * vars |
| 39 | -2x | +||
| 400 | +
- length = 1L,+ # Stratified quantile |
||
| 40 | +401 | 2x |
- message = "The {.cls survfit} object passed in argument {.arg x} must be stratified by a single variable."
+ sqrt(sum(summands)) / sum(sqrt(summands)) * stats::qnorm((1 + conf.level) / 2) |
| 41 | +402 |
- )- |
- |
| 42 | -1x | -
- if (length(x$strata) < 2) {
- |
- |
| 43 | -! | -
- cli::cli_abort(- |
- |
| 44 | -! | -
- "The {.cls survfit} object's stratifying variable must have 2 or more levels.",
- |
- |
| 45 | -! | -
- call = get_cli_abort_call()+ } |
|
| 46 | +403 |
- )+ |
|
| 47 | +404 |
- }+ #' Helper Function for the Estimation of Weights for `proportion_ci_strat_wilson()` |
|
| 48 | +405 |
-
+ #' |
|
| 49 | +406 |
- # calculate the survival at the specified times- |
- |
| 50 | -1x | -
- ard_survival_survfit <-- |
- |
| 51 | -1x | -
- ard_survival_survfit(x = x, times = times) |>- |
- |
| 52 | -1x | -
- dplyr::filter(.data$stat_name %in% c("estimate", "std.error")) |>
- |
- |
| 53 | -1x | -
- dplyr::select(-c("stat_label", "context", "fmt_fn"))
+ #' This function wraps the iteration procedure that allows you to estimate |
|
| 54 | +407 |
-
+ #' the weights for each proportional strata. This assumes to minimize the |
|
| 55 | +408 |
- # transform the survival ARD into a cards object with the survival difference- |
- |
| 56 | -1x | -
- card <-- |
- |
| 57 | -1x | -
- ard_survival_survfit %>%- |
- |
| 58 | -1x | -
- {dplyr::left_join( # styler: off
+ #' weighted squared length of the confidence interval. |
|
| 59 | +409 |
- # remove the first group from the data frame (this is our reference group)- |
- |
| 60 | -1x | -
- dplyr::filter(., .by = cards::all_ard_groups(), dplyr::cur_group_id() > 1L) |>- |
- |
| 61 | -1x | -
- dplyr::rename(stat1 = "stat"),+ #' |
|
| 62 | +410 |
- # merge the reference group data- |
- |
| 63 | -1x | -
- dplyr::filter(., .by = cards::all_ard_groups(), dplyr::cur_group_id() == 1L) |>- |
- |
| 64 | -1x | -
- dplyr::select(stat0 = "stat", everything(), -c("group1_level", "error", "warning")),
- |
- |
| 65 | -1x | -
- by = c("group1", "variable", "variable_level", "stat_name")
- |
- |
| 66 | -1x | -
- )} |> # styler: off+ #' @keywords internal |
|
| 67 | +411 |
- # reshape to put the stats that need to be combined on the same row- |
- |
| 68 | -1x | -
- tidyr::pivot_wider(- |
- |
| 69 | -1x | -
- id_cols = c("group1", "group1_level", "variable", "variable_level"),
- |
- |
| 70 | -1x | -
- names_from = "stat_name",- |
- |
| 71 | -1x | -
- values_from = c("stat0", "stat1"),
+ #' @inheritParams proportion_ci_strat_wilson |
|
| 72 | -1x | +||
| 412 | +
- values_fn = unlist+ #' @param vars (`numeric`)\cr normalized proportions for each strata. |
||
| 73 | +413 |
- ) |>+ #' @param strata_qnorm (`numeric`)\cr initial estimation with identical weights of the quantiles. |
|
| 74 | +414 |
- # calcualte the primary statistics to return+ #' @param initial_weights (`numeric`)\cr initial weights used to calculate `strata_qnorm`. This can |
|
| 75 | -1x | +||
| 415 | +
- dplyr::mutate(+ #' be optimized in the future if we need to estimate better initial weights. |
||
| 76 | +416 |
- # reference level+ #' @param n_per_strata (`numeric`)\cr number of elements in each strata. |
|
| 77 | -1x | +||
| 417 | +
- reference_level = ard_survival_survfit[["group1_level"]][1],+ #' @param max.iterations (`count`)\cr maximum number of iterations to be tried. Convergence is always checked. |
||
| 78 | +418 |
- # short description of method+ #' @param tol (`number`)\cr tolerance threshold for convergence. |
|
| 79 | -1x | +||
| 419 | +
- method = "Survival Difference (Z-test)",+ #' |
||
| 80 | +420 |
- # survival difference+ #' @return A `list` of 3 elements: `n_it`, `weights`, and `diff_v`. |
|
| 81 | -1x | +||
| 421 | +
- estimate = .data$stat0_estimate - .data$stat1_estimate,+ #' |
||
| 82 | +422 |
- # survival difference standard error+ #' @seealso For references and details see [`proportion_ci_strat_wilson()`]. |
|
| 83 | -1x | +||
| 423 | +
- std.error = sqrt(.data$stat0_std.error^2 + .data$stat1_std.error^2),+ #' |
||
| 84 | +424 |
- # Z test statistic+ #' @examples |
|
| 85 | -1x | +||
| 425 | +
- statistic = .data$estimate / .data$std.error,+ #' vs <- c(0.011, 0.013, 0.012, 0.014, 0.017, 0.018) |
||
| 86 | +426 |
- # confidence limits of the survival difference+ #' sq <- 0.674 |
|
| 87 | -1x | +||
| 427 | +
- conf.low = .data$estimate - .data$std.error * stats::qnorm(1 - (1 - .env$conf.level) / 2),+ #' ws <- rep(1 / length(vs), length(vs)) |
||
| 88 | -1x | +||
| 428 | +
- conf.high = .data$estimate + .data$std.error * stats::qnorm(1 - (1 - .env$conf.level) / 2),+ #' ns <- c(22, 18, 17, 17, 14, 12) |
||
| 89 | +429 |
- # p-value for test where H0: no difference+ #' |
|
| 90 | -1x | +||
| 430 | +
- p.value = 2 * (1 - stats::pnorm(abs(.data$statistic))),+ #' cardx:::.update_weights_strat_wilson(vs, sq, ws, ns, 100, 0.95, 0.001) |
||
| 91 | -1x | +||
| 431 | +
- across(c("reference_level", "estimate", "std.error", "statistic", "conf.low", "conf.high", "p.value", "method"), as.list)
+ .update_weights_strat_wilson <- function(vars, |
||
| 92 | +432 |
- ) |>+ strata_qnorm, |
|
| 93 | +433 |
- # reshape into the cards structure+ initial_weights, |
|
| 94 | -1x | +||
| 434 | +
- dplyr::select(-starts_with("stat0_"), -starts_with("stat1_")) |>
+ n_per_strata, |
||
| 95 | -1x | +||
| 435 | +
- tidyr::pivot_longer(+ max.iterations = 50, |
||
| 96 | -1x | +||
| 436 | +
- cols = -c(cards::all_ard_groups(), cards::all_ard_variables()),+ conf.level = 0.95, |
||
| 97 | -1x | +||
| 437 | +
- names_to = "stat_name",+ tol = 0.001) {
|
||
| 98 | -1x | +||
| 438 | +! |
- values_to = "stat"+ it <- 0 |
|
| 99 | -+ | ||
| 439 | +! |
- )+ diff_v <- NULL |
|
| 100 | +440 | ||
| 101 | -+ | ||
| 441 | +! |
- # final prepping of the cards object -----------------------------------------+ while (it < max.iterations) {
|
|
| 102 | -1x | +||
| 442 | +! |
- card |>+ it <- it + 1 |
|
| 103 | -1x | +||
| 443 | +! |
- dplyr::mutate(+ weights_new_t <- (1 + strata_qnorm^2 / n_per_strata)^2 |
|
| 104 | -1x | +||
| 444 | +! |
- warning = ard_survival_survfit[["warning"]][1],+ weights_new_b <- (vars + strata_qnorm^2 / (4 * n_per_strata^2)) |
|
| 105 | -1x | +||
| 445 | +! |
- error = ard_survival_survfit[["error"]][1],+ weights_new <- weights_new_t / weights_new_b |
|
| 106 | -1x | +||
| 446 | +! |
- fmt_fn = list(1L),+ weights_new <- weights_new / sum(weights_new) |
|
| 107 | -1x | +||
| 447 | +! |
- stat_label =+ strata_qnorm <- .strata_normal_quantile(vars, weights_new, conf.level) |
|
| 108 | -1x | +||
| 448 | +! |
- dplyr::case_when(+ diff_v <- c(diff_v, sum(abs(weights_new - initial_weights))) |
|
| 109 | -1x | +||
| 449 | +! |
- .data$stat_name %in% "estimate" ~ "Survival Difference",+ if (diff_v[length(diff_v)] < tol) break |
|
| 110 | -1x | +||
| 450 | +! |
- .data$stat_name %in% "std.error" ~ "Survival Difference Standard Error",+ initial_weights <- weights_new |
|
| 111 | -1x | +||
| 451 | +
- .data$stat_name %in% "conf.low" ~ "CI Lower Bound",+ } |
||
| 112 | -1x | +||
| 452 | +
- .data$stat_name %in% "conf.high" ~ "CI Upper Bound",+ |
||
| 113 | -1x | +||
| 453 | +! |
- .data$stat_name %in% "statistic" ~ "z statistic",+ if (it == max.iterations) {
|
|
| 114 | -1x | +||
| 454 | +! |
- .data$stat_name %in% "p.value" ~ "p-value",+ warning("The heuristic to find weights did not converge with max.iterations = ", max.iterations)
|
|
| 115 | -1x | +||
| 455 | +
- .default = .data$stat_name+ } |
||
| 116 | +456 |
- ),+ |
|
| 117 | -1x | +||
| 457 | +! |
- context = "survival_survfit_diff",+ list( |
|
| 118 | -+ | ||
| 458 | +! |
- ) |>+ "n_it" = it, |
|
| 119 | -1x | +||
| 459 | +! |
- cards::tidy_ard_column_order() %>%+ "weights" = weights_new, |
|
| 120 | -1x | +||
| 460 | +! |
- structure(., class = c("card", class(.)))
+ "diff_v" = diff_v |
|
| 121 | +461 | ++ |
+ )+ |
+
| 462 |
}@@ -17020,14 +15482,14 @@ cardx coverage - 95.32% |
| 1 |
- #' ARD Survival Estimates+ #' ARD survey categorical CIs |
|||
| 3 |
- #' @description+ #' One-sample confidence intervals for continuous variables' means and medians. |
|||
| 4 |
- #' Analysis results data for survival quantiles and x-year survival estimates, extracted+ #' Confidence limits are calculated with `survey::svymean()` and `survey::svyquantile()`. |
|||
| 5 |
- #' from a [survival::survfit()] model.+ #' |
|||
| 7 |
- #' @param x ([survival::survfit()])\cr+ #' @inheritParams ard_continuous.survey.design |
|||
| 8 |
- #' a [survival::survfit()] object. See below for details.+ #' @param method (`string`)\cr |
|||
| 9 |
- #' @param times (`numeric`)\cr+ #' Method for confidence interval calculation. |
|||
| 10 |
- #' a vector of times for which to return survival probabilities.+ #' When `"svymean"`, the calculation is computed via `survey::svymean()`. |
|||
| 11 |
- #' @param probs (`numeric`)\cr+ #' Otherwise, it is calculated via`survey::svyquantile(interval.type=method)` |
|||
| 12 |
- #' a vector of probabilities with values in (0,1) specifying the survival quantiles to return.+ #' @param conf.level (scalar `numeric`)\cr |
|||
| 13 |
- #' @param type (`string` or `NULL`)\cr+ #' confidence level for confidence interval. Default is `0.95`. |
|||
| 14 |
- #' type of statistic to report. Available for Kaplan-Meier time estimates only, otherwise `type`+ #' @param df (`numeric`)\cr |
|||
| 15 |
- #' is ignored. Default is `NULL`.+ #' denominator degrees of freedom, passed to `survey::confint(df)`. |
|||
| 16 |
- #' Must be one of the following:+ #' Default is `survey::degf(data)`. |
|||
| 17 |
- #' ```{r, echo = FALSE}
+ #' @param ... arguments passed to `survey::confint()` |
|||
| 18 |
- #' dplyr::tribble(+ #' |
|||
| 19 |
- #' ~type, ~transformation,+ #' @return ARD data frame |
|||
| 20 |
- #' '`"survival"`', '`x`',+ #' @export |
|||
| 21 |
- #' '`"risk"`', '`1 - x`',+ #' |
|||
| 22 |
- #' '`"cumhaz"`', '`-log(x)`',+ #' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = "survey", reference_pkg = "cardx"))
|
|||
| 23 |
- #' ) %>%+ #' data(api, package = "survey") |
|||
| 24 |
- #' knitr::kable()+ #' dclus1 <- survey::svydesign(id = ~dnum, weights = ~pw, data = apiclus1, fpc = ~fpc) |
|||
| 25 |
- #' ```+ #' |
|||
| 26 |
- #'+ #' ard_survey_continuous_ci(dclus1, variables = api00) |
|||
| 27 |
- #' @return an ARD data frame of class 'card'+ #' ard_survey_continuous_ci(dclus1, variables = api00, method = "xlogit") |
|||
| 28 |
- #' @name ard_survival_survfit+ ard_survey_continuous_ci <- function(data, |
|||
| 29 |
- #'+ variables, |
|||
| 30 |
- #' @details+ by = NULL, |
|||
| 31 |
- #' * Only one of either the `times` or `probs` parameters can be specified.+ method = c("svymean", "mean", "beta", "xlogit", "asin", "score"),
|
|||
| 32 |
- #' * Times should be provided using the same scale as the time variable used to fit the provided+ conf.level = 0.95, |
|||
| 33 |
- #' survival fit model.+ df = survey::degf(data), |
|||
| 34 |
- #'+ ...) {
|
|||
| 35 | -+ | 14x |
- #' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = c("survival", "broom", "ggsurvfit"), reference_pkg = "cardx"))
+ set_cli_abort_call() |
|
| 36 |
- #' library(survival)+ |
|||
| 37 |
- #' library(ggsurvfit)+ # check inputs --------------------------------------------------------------- |
|||
| 38 | -+ | 14x |
- #'+ check_not_missing(data) |
|
| 39 | -+ | 14x |
- #' survfit(Surv_CNSR(AVAL, CNSR) ~ TRTA, cards::ADTTE) |>+ check_class(data, "survey.design") |
|
| 40 | -+ | 14x |
- #' ard_survival_survfit(times = c(60, 180))+ check_not_missing(variables) |
|
| 41 |
- #'+ |
|||
| 42 | -+ | 14x |
- #' survfit(Surv_CNSR(AVAL, CNSR) ~ TRTA, cards::ADTTE) |>+ cards::process_selectors( |
|
| 43 | -+ | 14x |
- #' ard_survival_survfit(probs = c(0.25, 0.5, 0.75))+ data = data$variables, |
|
| 44 | -+ | 14x |
- #'+ variables = {{ variables }},
|
|
| 45 | -+ | 14x |
- #' # Competing Risks Example ---------------------------+ by = {{ by }}
|
|
| 46 |
- #' set.seed(1)+ ) |
|||
| 47 | -+ | 14x |
- #' ADTTE_MS <- cards::ADTTE %>%+ check_scalar(by, allow_empty = TRUE) |
|
| 48 | -+ | 14x |
- #' dplyr::mutate(+ check_scalar_range(conf.level, range = c(0, 1)) |
|
| 49 | -+ | 14x |
- #' CNSR = dplyr::case_when(+ method <- arg_match(method) |
|
| 50 |
- #' CNSR == 0 ~ "censor",+ |
|||
| 51 | -+ | 14x |
- #' runif(dplyr::n()) < 0.5 ~ "death from cancer",+ walk( |
|
| 52 | -+ | 14x |
- #' TRUE ~ "death other causes"+ variables, |
|
| 53 | -+ | 14x |
- #' ) %>% factor()+ \(variable) {
|
|
| 54 | -+ | 24x |
- #' )+ if (!is.numeric(data$variables[[variable]])) {
|
|
| 55 | -+ | ! |
- #'+ cli::cli_inform( |
|
| 56 | -+ | ! |
- #' survfit(Surv(AVAL, CNSR) ~ TRTA, data = ADTTE_MS) %>%+ "Column {.val {variable}} is not {.cls numeric} and results may be an unexpected format."
|
|
| 57 |
- #' ard_survival_survfit(times = c(60, 180))+ ) |
|||
| 58 |
- NULL+ } |
|||
| 59 |
-
+ } |
|||
| 60 |
- #' @rdname ard_survival_survfit+ ) |
|||
| 61 |
- #' @export+ |
|||
| 62 |
- ard_survival_survfit <- function(x, times = NULL, probs = NULL, type = NULL) {
+ # calculate and return ARD of one sample CI ---------------------------------- |
|||
| 63 | -11x | +14x |
- set_cli_abort_call()+ .calculate_ard_continuous_survey_ci( |
|
| 64 | -+ | 14x |
-
+ FUN = ifelse(method == "svymean", .svymean_confint_wrapper, .svyquantile_confint_wrapper), |
|
| 65 | -+ | 14x |
- # check installed packages ---------------------------------------------------+ data = data, |
|
| 66 | -11x | +14x |
- check_pkg_installed(c("survival", "broom"), reference_pkg = "cardx")
+ variables = variables, |
|
| 67 | -+ | 14x |
-
+ by = by, |
|
| 68 | -+ | 14x |
- # check/process inputs -------------------------------------------------------+ conf.level = conf.level, |
|
| 69 | -11x | +14x |
- check_not_missing(x)+ method = method, |
|
| 70 | -11x | +14x |
- check_class(x, cls = "survfit")+ df = df, |
|
| 71 | -10x | +
- if (inherits(x, "survfitcox")) {
+ ... |
||
| 72 | -1x | +
- cli::cli_abort("Argument {.arg x} cannot be class {.cls survfitcox}.",
+ ) |
||
| 73 | -1x | +
- call = get_cli_abort_call()+ } |
||
| 74 |
- )+ |
|||
| 75 |
- }+ .calculate_ard_continuous_survey_ci <- function(FUN, data, variables, by, conf.level, ...) {
|
|||
| 76 |
-
+ # return empty data frame if no variables to process ------------------------- |
|||
| 77 | -+ | 1x |
- # competing risks models cannot use the type argument+ if (is_empty(variables)) return(dplyr::tibble()) # styler: off |
|
| 78 | -9x | +
- if (inherits(x, c("survfitms", "survfitcoxms")) && !is.null(type)) {
+
|
||
| 79 | -! | +
- cli::cli_abort("Cannot use {.arg type} argument with {.code survfit} models with class {.cls {c('survfitms', 'survfitcoxms')}}.",
+ # calculate results ---------------------------------------------------------- |
||
| 80 | -! | +13x |
- call = get_cli_abort_call()+ map( |
|
| 81 | -+ | 13x |
- )+ variables, |
|
| 82 | -+ | 13x |
- }+ function(variable) {
|
|
| 83 | -1x | +24x |
- if (!is.null(probs)) check_range(probs, c(0, 1))+ .calculate_one_ard_continuous_survey_ci( |
|
| 84 | -9x | +24x |
- if (sum(is.null(times), is.null(probs)) != 1) {
+ FUN = FUN, |
|
| 85 | -! | +24x |
- cli::cli_abort("One and only one of {.arg times} and {.arg probs} must be specified.")
+ data = data, |
|
| 86 | -+ | 24x |
- }+ variable = variable, |
|
| 87 | -+ | 24x |
-
+ by = by, |
|
| 88 | -+ | 24x |
- # for regular KM estimators, we allow the type argument+ conf.level = conf.level, |
|
| 89 | -9x | +
- if (!inherits(x, "survfitms") && !is.null(type)) {
+ ... |
||
| 90 | -1x | +
- type <- arg_match(type, values = c("survival", "risk", "cumhaz"))
+ ) |
||
| 91 |
- }+ } |
|||
| 92 |
-
+ ) |> |
|||
| 93 | -+ | 13x |
- # cannot specify type arg when probs supplied+ dplyr::bind_rows() |
|
| 94 | -9x | +
- if (!is.null(probs) && !is.null(type)) {
+ } |
||
| 95 | -! | +
- cli::cli_abort("Cannot use {.arg type} argument when {.arg probs} argument specifed.",
+
|
||
| 96 | -! | +
- call = get_cli_abort_call()+ .calculate_one_ard_continuous_survey_ci <- function(FUN, data, variable, by, conf.level, ...) {
|
||
| 97 | -+ | 24x |
- )+ if (!is_empty(by)) {
|
|
| 98 | -+ | 8x |
- }+ by_levels <- .unique_values_sort(data$variables, variable = by) |
|
| 99 | -+ | 8x |
-
+ lst_data <- |
|
| 100 | -+ | 8x |
- # build ARD ------------------------------------------------------------------+ map( |
|
| 101 | -9x | +8x |
- est_type <- ifelse(is.null(probs), "times", "probs")+ by_levels, |
|
| 102 | -9x | +8x |
- tidy_survfit <- switch(est_type,+ ~ call2("subset", expr(data), expr(!!sym(by) == !!.x)) |> eval()
|
|
| 103 | -9x | +
- "times" = .process_survfit_time(x, times, type %||% "survival"),+ ) |> |
||
| 104 | -9x | +8x |
- "probs" = .process_survfit_probs(x, probs)+ set_names(as.character(by_levels)) |
|
| 105 |
- )+ } |
|||
| 107 | -9x | +24x |
- .format_survfit_results(tidy_survfit)+ df_full <- |
|
| 108 | -+ | 24x |
- }+ case_switch( |
|
| 109 | -+ | 24x |
-
+ !is_empty(by) ~ |
|
| 110 | -+ | 24x |
- #' Process Survival Fit For Time Estimates+ tidyr::expand_grid( |
|
| 111 | -+ | 24x |
- #'+ group1_level = as.character(by_levels) |> as.list() |
|
| 112 |
- #' @inheritParams cards::tidy_as_ard+ ) |> |
|||
| 113 | -+ | 24x |
- #' @inheritParams ard_survival_survfit+ dplyr::mutate(group1 = .env$by, variable = .env$variable), |
|
| 114 | -+ | 24x |
- #' @param start.time (`numeric`)\cr+ .default = |
|
| 115 | -+ | 24x |
- #' default starting time. See [survival::survfit0()] for more details.+ dplyr::tibble(variable = .env$variable) |
|
| 116 |
- #'+ ) |> |
|||
| 117 | -+ | 24x |
- #' @return a `tibble`+ dplyr::rowwise() |> |
|
| 118 | -+ | 24x |
- #'+ dplyr::mutate( |
|
| 119 | -+ | 24x |
- #' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = c("survival", "broom"), reference_pkg = "cardx"))
+ lst_result = |
|
| 120 | -+ | 24x |
- #' survival::survfit(survival::Surv(AVAL, CNSR) ~ TRTA, cards::ADTTE) |>+ FUN( |
|
| 121 | -+ | 24x |
- #' cardx:::.process_survfit_time(times = c(60, 180), type = "risk")+ data = |
|
| 122 | -+ | 24x |
- #'+ case_switch( |
|
| 123 | -+ | 24x |
- #' @keywords internal+ is_empty(.env$by) ~ data, |
|
| 124 | -+ | 24x |
- .process_survfit_time <- function(x, times, type, start.time = NULL) {
+ .default = lst_data[[.data$group1_level]] |
|
| 125 |
- # add start time+ ), |
|||
| 126 | -8x | +24x |
- min_time <- min(x$time)+ variable = .data$variable, |
|
| 127 | -8x | +24x |
- if (is.null(start.time) && min_time < 0) {
+ conf.level = .env$conf.level, |
|
| 128 | -! | +
- cli::cli_inform(paste(+ ... |
||
| 129 | -! | +
- "The {.arg start.time} argument has not been set and negative times have been observed. Please set start",
+ ) |> |
||
| 130 | -! | +24x |
- "time via the {.arg start.time} argument, otherwise the minimum observed time will be used by default."
+ list(), |
|
| 131 | -+ | 24x |
- ))+ result = |
|
| 132 | -! | +24x |
- start.time <- min_time+ .data$lst_result[["result"]] |> |
|
| 133 | -8x | +24x |
- } else if (is.null(start.time)) {
+ enframe("stat_name", "stat") |>
|
|
| 134 | -8x | +24x |
- start.time <- 0+ list(), |
|
| 135 | -+ | 24x |
- }+ warning = .data$lst_result["warning"] |> unname(), |
|
| 136 | -8x | +24x |
- x <- survival::survfit0(x, start.time) %>%+ error = .data$lst_result["error"] |> unname(), |
|
| 137 | -8x | +24x |
- summary(times)+ context = "survey_continuous_ci" |
|
| 138 | + |
+ ) |>+ |
+ ||
| 139 | +24x | +
+ dplyr::select(-"lst_result") |>+ |
+ ||
| 140 | +24x | +
+ dplyr::ungroup() |>+ |
+ ||
| 141 | +24x | +
+ tidyr::unnest("result") |>
+ |
+ ||
| 142 | +24x | +
+ dplyr::mutate(+ |
+ ||
| 143 | +24x | +
+ stat_label = .data$stat_name,+ |
+ ||
| 144 | +24x | +
+ fmt_fn = map(.data$stat, ~ case_switch(is.numeric(.x) ~ 2L, .default = as.character))+ |
+ ||
| 145 | ++ |
+ ) |>+ |
+ ||
| 146 | +24x | +
+ cards::tidy_ard_column_order() %>%+ |
+ ||
| 147 | +24x | +
+ structure(., class = c("card", class(.)))
+ |
+ ||
| 148 | ++ |
+ }+ |
+ ||
| 149 | +||||
| 139 | +150 |
- # process competing risks/multi-state models+ .svymean_confint_wrapper <- function(data, variable, conf.level, df, ...) {
+ |
+ ||
| 151 | +24x | +
+ lst_results <-+ |
+ ||
| 152 | +24x | +
+ cards::eval_capture_conditions({
+ |
+ ||
| 153 | +24x | +
+ svymean <-+ |
+ ||
| 154 | +24x | +
+ survey::svymean(x = reformulate2(variable), design = data, na.rm = TRUE)+ |
+ ||
| 155 | ++ | + + | +||
| 156 | +24x | +
+ lst_svymean <- as.data.frame(svymean) |>+ |
+ ||
| 157 | +24x | +
+ as.list() |>+ |
+ ||
| 158 | +24x | +
+ set_names(c("estimate", "std.error"))
+ |
+ ||
| 159 | ++ | + + | +||
| 160 | +24x | +
+ lst_confint <- stats::confint(svymean, level = conf.level, df = df, ...) |> |
||
| 140 | -8x | +161 | +24x |
- multi_state <- inherits(x, "summary.survfitms")+ as.data.frame() |> |
| 141 | -+ | |||
| 162 | +24x |
-
+ as.list() |> |
||
| 142 | -8x | +163 | +24x |
- if (multi_state) {
+ set_names(c("conf.low", "conf.high"))
|
| 143 | +164 |
- # selecting state to show- |
- ||
| 144 | -1x | -
- state <- setdiff(unique(x$states), "(s0)")[[1]]+ |
||
| 145 | -1x | +165 | +22x |
- cli::cli_inform("Multi-state model detected. Showing probabilities into state '{state}'.")
+ c(lst_svymean, lst_confint) |
| 146 | -1x | +|||
| 166 | +
- x$n.risk <- x$n.risk[, 1]+ }) |
|||
| 147 | -1x | +|||
| 167 | +
- ms_cols <- c("pstate", "std.err", "upper", "lower")
+
|
|||
| 148 | -1x | +|||
| 168 | +
- state_col <- which(colnames(x$pstate) == state)+ # add NULL results if error |
|||
| 149 | -1x | +169 | +24x |
- x[ms_cols] <- lapply(x[ms_cols], function(m) m[, state_col])+ if (is_empty(lst_results[["result"]])) {
|
| 150 | -1x | +170 | +2x |
- x$surv <- x$pstate+ lst_results[["result"]] <- rep_named(c("estimate", "std.error", "conf.low", "conf.high"), list(NULL))
|
| 151 | +171 |
} |
||
| 152 | +172 | |||
| 153 | +173 |
- # tidy survfit results- |
- ||
| 154 | -8x | -
- x_cols <- intersect(names(x), c("time", "n.risk", "surv", "std.err", "upper", "lower", "strata"))
+ # add other args |
||
| 155 | -8x | +174 | +24x |
- tidy_x <- data.frame(x[x_cols]) %>%+ lst_results[["result"]] <- lst_results[["result"]] |> append(list(conf.level = conf.level)) |
| 156 | -8x | +|||
| 175 | +
- dplyr::rename(estimate = "surv", std.error = "std.err", conf.high = "upper", conf.low = "lower")+ |
|||
| 157 | +176 |
-
+ # return list result |
||
| 158 | -8x | +177 | +24x |
- strat <- "strata" %in% names(tidy_x)+ lst_results |
| 159 | +178 | ++ |
+ }+ |
+ |
| 179 | ||||
| 160 | +180 |
- # get requested estimates+ .svyquantile_confint_wrapper <- function(data, variable, conf.level, method, df, ...) {
|
||
| 161 | +181 | 8x |
- df_stat <- tidy_x %>%+ lst_results <- |
|
| 162 | -+ | |||
| 182 | +8x |
- # find max time+ cards::eval_capture_conditions({
|
||
| 163 | +183 | 8x |
- dplyr::group_by_at(., dplyr::vars(dplyr::any_of("strata"))) %>%
+ svyquantile <- |
|
| 164 | +184 | 8x |
- dplyr::mutate(time_max = max(.data$time)) %>%+ survey::svyquantile( |
|
| 165 | +185 | 8x |
- dplyr::ungroup() %>%+ x = reformulate2(variable), design = data, quantiles = 0.5,+ |
+ |
| 186 | +8x | +
+ na.rm = TRUE, interval.type = method |
||
| 166 | +187 |
- # add requested timepoints+ ) |
||
| 167 | -8x | +|||
| 188 | +
- dplyr::full_join(+ |
|||
| 168 | +189 | 8x |
- tidy_x %>%+ lst_svyquantile <- svyquantile |> |
|
| 169 | +190 | 8x |
- dplyr::select(any_of("strata")) %>%
+ getElement(1L) |> |
|
| 170 | +191 | 8x |
- dplyr::distinct() %>%+ as.data.frame() |> |
|
| 171 | +192 | 8x |
- dplyr::mutate(+ dplyr::select(1L, last_col()) |> |
|
| 172 | +193 | 8x |
- time = list(.env$times),+ as.list() |> |
|
| 173 | +194 | 8x |
- col_name = list(paste("stat", seq_len(length(.env$times)), sep = "_"))
+ set_names(c("estimate", "std.error"))
|
|
| 174 | +195 |
- ) %>%+ |
||
| 175 | +196 | 8x |
- tidyr::unnest(cols = c("time", "col_name")),
+ lst_confint <- stats::confint(svyquantile, level = conf.level, df = df, ...) |> |
|
| 176 | +197 | 8x |
- by = unlist(intersect(c("strata", "time"), names(tidy_x)))
+ as.data.frame() |> |
|
| 177 | -+ | |||
| 198 | +8x |
- )+ as.list() |>+ |
+ ||
| 199 | +8x | +
+ set_names(c("conf.low", "conf.high"))
|
||
| 178 | +200 | |||
| 179 | +201 | 8x |
- if (strat) {
+ c(lst_svyquantile, lst_confint) |
|
| 180 | -7x | +|||
| 202 | +
- df_stat <- df_stat %>% dplyr::arrange(.data$strata)+ }) |
|||
| 181 | +203 |
- }+ |
||
| 182 | +204 |
-
+ # add NULL results if error |
||
| 183 | +205 | 8x |
- df_stat <- df_stat %>%+ if (is_empty(lst_results[["result"]])) {
|
|
| 184 | -8x | +|||
| 206 | +! |
- dplyr::arrange(.data$time) %>%+ lst_results[["result"]] <- rep_named(c("estimate", "std.error", "conf.low", "conf.high"), list(NULL))
|
||
| 185 | +207 |
- # if user-specified time is after max time, make estimate NA+ } |
||
| 186 | -8x | +|||
| 208 | +
- dplyr::mutate_at(+ |
|||
| 187 | -8x | +|||
| 209 | +
- dplyr::vars("estimate", "conf.high", "conf.low"),
+ # add other args |
|||
| 188 | +210 | 8x |
- ~ ifelse(.data$time > .data$time_max, NA_real_, .)+ lst_results[["result"]] <- lst_results[["result"]] |> append(list(conf.level = conf.level)) |
|
| 189 | +211 |
- ) %>%+ |
||
| 190 | -8x | +|||
| 212 | +
- dplyr::mutate(context = type) %>%+ # return list result |
|||
| 191 | +213 | 8x |
- dplyr::select(!dplyr::any_of(c("time_max", "col_name")))
+ lst_results |
|
| 192 | +214 |
-
+ } |
| 193 | +1 |
- # convert estimates to requested type- |
- ||
| 194 | -8x | -
- if (type != "survival") {
+ #' ARD for Difference in Survival |
||
| 195 | -1x | +|||
| 2 | +
- df_stat <- df_stat %>%+ #' |
|||
| 196 | -1x | +|||
| 3 | +
- dplyr::mutate(dplyr::across(+ #' @description |
|||
| 197 | -1x | +|||
| 4 | +
- any_of(c("estimate", "conf.low", "conf.high")),
+ #' Analysis results data for comparison of survival using [survival::survdiff()]. |
|||
| 198 | -1x | +|||
| 5 | +
- if (type == "cumhaz") ~ -log(.x) else ~ 1 - .x+ #' |
|||
| 199 | +6 |
- )) %>%+ #' @param formula (`formula`)\cr |
||
| 200 | -1x | +|||
| 7 | +
- dplyr::rename(conf.low = "conf.high", conf.high = "conf.low")+ #' a formula |
|||
| 201 | +8 |
- }+ #' @param data (`data.frame`)\cr |
||
| 202 | +9 |
-
+ #' a data frame |
||
| 203 | -8x | +|||
| 10 | +
- df_stat <- extract_multi_strata(x, df_stat)+ #' @param rho (`scalar numeric`)\cr |
|||
| 204 | +11 |
-
+ #' numeric scalar passed to `survival::survdiff(rho)`. Default is `rho=0`. |
||
| 205 | -8x | +|||
| 12 | +
- df_stat+ #' @param ... additional arguments passed to `survival::survdiff()` |
|||
| 206 | +13 |
- }+ #' |
||
| 207 | +14 |
-
+ #' @return an ARD data frame of class 'card' |
||
| 208 | +15 |
- #' Process Survival Fit For Quantile Estimates+ #' @export |
||
| 209 | +16 |
#' |
||
| 210 | +17 |
- #' @inheritParams cards::tidy_as_ard+ #' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = c("survival", "broom", "ggsurvfit"), reference_pkg = "cardx"))
|
||
| 211 | +18 |
- #' @inheritParams ard_survival_survfit+ #' library(survival) |
||
| 212 | +19 |
- #'+ #' library(ggsurvfit) |
||
| 213 | +20 |
- #' @return a `tibble`+ #' |
||
| 214 | +21 |
- #'+ #' ard_survival_survdiff(Surv_CNSR(AVAL, CNSR) ~ TRTA, data = cards::ADTTE) |
||
| 215 | +22 |
- #' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = "survival", reference_pkg = "cardx"))
+ ard_survival_survdiff <- function(formula, data, rho = 0, ...) {
|
||
| 216 | -+ | |||
| 23 | +4x |
- #' survival::survfit(survival::Surv(AVAL, CNSR) ~ TRTA, cards::ADTTE) |>+ set_cli_abort_call() |
||
| 217 | +24 |
- #' cardx:::.process_survfit_probs(probs = c(0.25, 0.75))+ |
||
| 218 | +25 |
- #'+ # check installed packages --------------------------------------------------- |
||
| 219 | -+ | |||
| 26 | +4x |
- #' @keywords internal+ check_pkg_installed(c("survival", "broom"), reference_pkg = "cardx")
|
||
| 220 | +27 |
- .process_survfit_probs <- function(x, probs) {
+
|
||
| 221 | +28 |
- # calculate survival quantiles and add estimates to df+ # check/process inputs ------------------------------------------------------- |
||
| 222 | -1x | +29 | +4x |
- df_stat <- map2(+ check_not_missing(formula) |
| 223 | -1x | +30 | +4x |
- probs,+ check_class(formula, cls = "formula") |
| 224 | -1x | +31 | +4x |
- seq_along(probs),+ if (!missing(data)) check_class(data, cls = "data.frame") |
| 225 | -1x | +32 | +4x |
- ~ stats::quantile(x, probs = .x) %>%+ check_scalar(rho) |
| 226 | -1x | +33 | +4x |
- as.data.frame() %>%+ check_class(rho, cls = "numeric") |
| 227 | -1x | +|||
| 34 | +
- set_names(c("estimate", "conf.low", "conf.high")) %>%
+
+ |
+ |||
| 35 | ++ |
+ # assign method |
||
| 228 | -1x | +36 | +4x |
- dplyr::mutate(strata = row.names(.)) %>%+ method <- dplyr::case_when( |
| 229 | -1x | +37 | +4x |
- dplyr::select(dplyr::any_of(c("n.risk", "strata", "estimate", "std.error", "conf.low", "conf.high"))) %>%
+ rho == 0 ~ "Log-rank test", |
| 230 | -1x | +38 | +4x |
- dplyr::mutate(prob = .x)+ rho == 1.5 ~ "Tarone-Ware test", |
| 231 | -+ | |||
| 39 | +4x |
- ) %>%+ rho == 1 ~ "Peto & Peto modification of Gehan-Wilcoxon test", |
||
| 232 | -1x | +40 | +4x |
- dplyr::bind_rows() %>%+ .default = glue::glue("G-rho test (\U03C1 = {rho})")
|
| 233 | -1x | +|||
| 41 | +
- `rownames<-`(NULL) %>%+ ) |> |
|||
| 234 | -1x | +42 | +4x |
- dplyr::mutate(context = "survival_survfit") %>%+ as.character() |
| 235 | -1x | +|||
| 43 | +
- dplyr::as_tibble()+ |
|||
| 236 | +44 |
-
+ # calculate survdiff() results ----------------------------------------------- |
||
| 237 | -! | +|||
| 45 | +4x |
- if (length(x$n) == 1) df_stat <- df_stat %>% dplyr::select(-"strata")+ lst_glance <- |
||
| 238 | -+ | |||
| 46 | +4x |
-
+ cards::eval_capture_conditions( |
||
| 239 | -1x | +47 | +4x |
- df_stat <- extract_multi_strata(x, df_stat)+ survival::survdiff(formula = formula, data = data, rho = rho, ...) |> |
| 240 | -+ | |||
| 48 | +4x |
-
+ broom::glance() |> |
||
| 241 | -1x | +49 | +4x |
- df_stat+ dplyr::mutate(method = .env$method) |
| 242 | +50 |
- }+ ) |
||
| 243 | +51 | |||
| 244 | +52 |
- # process multiple stratifying variables+ # tidy results up in an ARD format ------------------------------------------- |
||
| 245 | +53 |
- extract_multi_strata <- function(x, df_stat) {
- |
- ||
| 246 | -9x | -
- x_terms <- attr(stats::terms(stats::as.formula(x$call$formula)), "term.labels")+ # extract variable names from formula |
||
| 247 | -9x | +54 | +4x |
- x_terms <- gsub(".*\\(", "", gsub("\\)", "", x_terms))
+ variables <- stats::terms(formula) |> |
| 248 | -9x | +55 | +4x |
- if (length(x_terms) > 1) {
+ attr("term.labels") |>
|
| 249 | -3x | +56 | +4x |
- strata_lvls <- data.frame()+ .strip_backticks() |
| 250 | +57 | |||
| 251 | -3x | +|||
| 58 | +
- for (i in df_stat[["strata"]]) {
+ # if there was an error, return results early |
|||
| 252 | -42x | +59 | +4x |
- i <- gsub(".*\\(", "", gsub("\\)", "", i))
+ if (is.null(lst_glance[["result"]])) {
|
| 253 | -42x | +|||
| 60 | +
- terms_str <- strsplit(i, paste(c(paste0(x_terms, "="), paste0(", ", x_terms, "=")), collapse = "|"))[[1]]
+ # if no variables in formula, then return an error |
|||
| 254 | -42x | +|||
| 61 | +
- s_lvl <- terms_str[nchar(terms_str) > 0]+ # otherwise, if we do have variable names, then we can construct an empty ARD which will be done below |
|||
| 255 | -42x | -
- strata_lvls <- rbind(strata_lvls, s_lvl)- |
- ||
| 256 | -+ | 62 | +2x |
- }+ if (is_empty(variables)) {
|
| 257 | -3x | +63 | +1x |
- if (nrow(strata_lvls) > 0) {
+ cli::cli_abort( |
| 258 | -3x | +64 | +1x |
- strata_lvls <- cbind(strata_lvls, t(x_terms))+ message = |
| 259 | -3x | +65 | +1x |
- names(strata_lvls) <- c(+ c("There was an error in {.fun survival::survdiff}. See below:",
|
| 260 | -3x | +66 | +1x |
- t(sapply(seq_along(x_terms), function(i) c(paste0("group", i, "_level"), paste0("group", i))))
+ "x" = lst_glance[["error"]] |
| 261 | +67 |
- )- |
- ||
| 262 | -3x | -
- df_stat <- cbind(df_stat, strata_lvls) %>%+ ), |
||
| 263 | -3x | +68 | +1x |
- dplyr::select(-"strata")+ call = get_cli_abort_call() |
| 264 | +69 |
- }+ ) |
||
| 265 | +70 |
- }- |
- ||
| 266 | -9x | -
- df_stat+ } |
||
| 267 | +71 |
- }+ } |
||
| 268 | +72 | |||
| 269 | -+ | |||
| 73 | +3x |
- #' Convert Tidied Survival Fit to ARD+ .variables_to_survdiff_ard( |
||
| 270 | -+ | |||
| 74 | +3x |
- #'+ variables = variables, |
||
| 271 | -+ | |||
| 75 | +3x |
- #' @inheritParams cards::tidy_as_ard+ method = method, |
||
| 272 | +76 |
- #'+ # styler: off |
||
| 273 | -+ | |||
| 77 | +3x |
- #' @return an ARD data frame of class 'card'+ stat_names = |
||
| 274 | -+ | |||
| 78 | +3x |
- #'+ if (!is.null(lst_glance[["result"]])) names(lst_glance[["result"]]) |
||
| 275 | -+ | |||
| 79 | +3x |
- #' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = c("survival", "broom"), reference_pkg = "cardx"))
+ else c("statistic", "df", "p.value", "method"),
|
||
| 276 | -+ | |||
| 80 | +3x |
- #' cardx:::.format_survfit_results(+ stats = |
||
| 277 | -+ | |||
| 81 | +3x |
- #' broom::tidy(survival::survfit(survival::Surv(AVAL, CNSR) ~ TRTA, cards::ADTTE))+ if (!is.null(lst_glance[["result"]])) unname(as.list(lst_glance[["result"]])) |
||
| 278 | -+ | |||
| 82 | +3x |
- #' )+ else rep_along(c("statistic", "df", "p.value"), list(NULL)) |> c(list(method = method))
|
||
| 279 | +83 |
- #'+ # styler: on |
||
| 280 | +84 |
- #' @keywords internal+ ) |> |
||
| 281 | -+ | |||
| 85 | +3x |
- .format_survfit_results <- function(tidy_survfit) {
+ .add_survdiff_stat_labels() |> |
||
| 282 | -9x | +86 | +3x |
- est <- if ("time" %in% names(tidy_survfit)) "time" else "prob"
+ dplyr::mutate( |
| 283 | -+ | |||
| 87 | +3x |
-
+ context = "survival_survdiff", |
||
| 284 | -9x | +88 | +3x |
- ret <- tidy_survfit %>%+ warning = lst_glance["warning"], |
| 285 | -9x | +89 | +3x |
- dplyr::mutate(dplyr::across(+ error = lst_glance["error"], |
| 286 | -9x | +90 | +3x |
- dplyr::any_of(c("n.risk", "estimate", "std.error", "conf.high", "conf.low", "time", "prob")), ~ as.list(.)
+ fmt_fn = map( |
| 287 | -+ | |||
| 91 | +3x |
- )) %>%+ .data$stat, |
||
| 288 | -9x | +92 | +3x |
- tidyr::pivot_longer(+ function(x) {
|
| 289 | -9x | +93 | +6x |
- cols = dplyr::any_of(c("n.risk", "estimate", "std.error", "conf.high", "conf.low")),
+ if (is.numeric(x)) return(1L) # styler: off |
| 290 | -9x | +94 | +6x |
- names_to = "stat_name",+ NULL |
| 291 | -9x | +|||
| 95 | +
- values_to = "stat"+ } |
|||
| 292 | +96 |
- ) %>%+ ) |
||
| 293 | -9x | +|||
| 97 | +
- dplyr::mutate(+ ) |> |
|||
| 294 | -9x | +98 | +3x |
- variable = est,+ cards::tidy_ard_column_order() %>% |
| 295 | -9x | +99 | +3x |
- variable_level = .data[[est]]+ {structure(., class = c("card", class(.)))} # styler: off
|
| 296 | +100 |
- ) %>%- |
- ||
| 297 | -9x | -
- dplyr::select(-all_of(est))+ } |
||
| 298 | +101 | |||
| 299 | -9x | +|||
| 102 | +
- if ("strata" %in% names(ret)) {
+ .variables_to_survdiff_ard <- function(variables, |
|||
| 300 | -5x | +|||
| 103 | +
- ret <- ret %>%+ method, |
|||
| 301 | -5x | +|||
| 104 | +
- tidyr::separate_wider_delim("strata", "=", names = c("group1", "group1_level"))
+ stat_names, |
|||
| 302 | +105 |
- }+ stats) {
+ |
+ ||
| 106 | +3x | +
+ len <- length(variables) |
||
| 303 | +107 | |||
| 304 | -9x | +108 | +3x |
- ret %>%+ df_vars <- dplyr::tibble(!!!rev(variables)) |> |
| 305 | -9x | +109 | +3x |
- dplyr::left_join(+ set_names( |
| 306 | -9x | +110 | +3x |
- .df_survfit_stat_labels(),+ ifelse( |
| 307 | -9x | +111 | +3x |
- by = "stat_name"+ len > 1L, |
| 308 | -+ | |||
| 112 | +3x |
- ) %>%+ c(paste0("group_", rev(seq_len(len - 1L))), "variable"),
|
||
| 309 | -9x | +113 | +3x |
- dplyr::mutate(+ "variable" |
| 310 | -9x | +|||
| 114 | ++ |
+ )+ |
+ ||
| 115 | +
- fmt_fn = lapply(+ ) |
|||
| 311 | -9x | +|||
| 116 | +
- .data$stat,+ |
|||
| 312 | -9x | +117 | +3x |
- function(x) {
+ dplyr::bind_cols( |
| 313 | -348x | +118 | +3x |
- switch(is.integer(x),+ df_vars, |
| 314 | -348x | +119 | +3x |
- 0L+ dplyr::tibble( |
| 315 | -348x | +120 | +3x |
- ) %||% switch(is.numeric(x),+ stat_name = .env$stat_names, |
| 316 | -348x | +121 | +3x |
- 1L+ stat = .env$stats |
| 317 | +122 |
- )+ ) |
||
| 318 | +123 |
- }+ ) |
||
| 319 | +124 |
- ),+ } |
||
| 320 | -9x | +|||
| 125 | +
- stat_label = dplyr::coalesce(.data$stat_label, .data$stat_name)+ |
|||
| 321 | +126 |
- ) %>%+ .add_survdiff_stat_labels <- function(x) {
|
||
| 322 | -9x | +127 | +3x |
- dplyr::mutate(dplyr::across(matches("group[0-9]*_level"), ~ as.list(as.factor(.x)))) %>%
+ x |> |
| 323 | -9x | +128 | +3x |
- dplyr::mutate(+ dplyr::left_join( |
| 324 | -9x | +129 | +3x |
- warning = list(NULL),+ dplyr::tribble( |
| 325 | -9x | -
- error = list(NULL)- |
- ||
| 326 | -+ | 130 | +3x |
- ) %>%+ ~stat_name, ~stat_label, |
| 327 | -9x | +131 | +3x |
- structure(., class = c("card", class(.))) %>%
+ "statistic", "X^2 Statistic", |
| 328 | -9x | +132 | +3x |
- cards::tidy_ard_column_order() %>%+ "df", "Degrees of Freedom", |
| 329 | -9x | +133 | +3x |
- cards::tidy_ard_row_order()+ "p.value", "p-value" |
| 330 | +134 |
- }+ ), |
||
| 331 | -+ | |||
| 135 | +3x |
-
+ by = "stat_name" |
||
| 332 | +136 |
- .df_survfit_stat_labels <- function() {
- |
- ||
| 333 | -9x | -
- dplyr::tribble(- |
- ||
| 334 | -9x | -
- ~stat_name, ~stat_label,+ ) |> |
||
| 335 | -9x | +137 | +3x |
- "n.risk", "Number of Subjects at Risk",+ dplyr::mutate(stat_label = dplyr::coalesce(.data$stat_label, .data$stat_name)) |
| 336 | -9x | +|||
| 138 | +
- "estimate", "Survival Probability",+ } |
|||
| 337 | -9x | +|||
| 139 | +
- "std.error", "Standard Error (untransformed)",+ |
|||
| 338 | -9x | +|||
| 140 | +
- "conf.low", "CI Lower Bound",+ .strip_backticks <- function(x) {
|
|||
| 339 | -9x | +141 | +4x |
- "conf.high", "CI Upper Bound",+ ifelse( |
| 340 | -9x | +142 | +4x |
- "conf.level", "CI Confidence Level",+ str_detect(x, "^`.*`$"), |
| 341 | -9x | +143 | +4x |
- "prob", "Quantile",+ substr(x, 2, nchar(x) - 1), |
| 342 | -9x | +144 | +4x |
- "time", "Time"+ x |
| 343 | +145 |
) |
||
| 344 | +146 |
}@@ -19434,14 +18014,14 @@ cardx coverage - 95.32% |
| 1 |
- #' ARD Survey Chi-Square Test+ #' ARD Survival Estimates |
||
| 4 |
- #' Analysis results data for survey Chi-Square test using [`survey::svychisq()`].+ #' Analysis results data for survival quantiles and x-year survival estimates, extracted |
||
| 5 |
- #' Only two-way comparisons are supported.+ #' from a [survival::survfit()] model. |
||
| 7 |
- #' @param data (`survey.design`)\cr+ #' @param x ([survival::survfit()])\cr |
||
| 8 |
- #' a survey design object often created with the \{survey\} package
+ #' a [survival::survfit()] object. See below for details. |
||
| 9 |
- #' @param by ([`tidy-select`][dplyr::dplyr_tidy_select])\cr+ #' @param times (`numeric`)\cr |
||
| 10 |
- #' column name to compare by.+ #' a vector of times for which to return survival probabilities. |
||
| 11 |
- #' @param variables ([`tidy-select`][dplyr::dplyr_tidy_select])\cr+ #' @param probs (`numeric`)\cr |
||
| 12 |
- #' column names to be compared. Independent tests will be computed for+ #' a vector of probabilities with values in (0,1) specifying the survival quantiles to return. |
||
| 13 |
- #' each variable.+ #' @param type (`string` or `NULL`)\cr |
||
| 14 |
- #' @param statistic (`character`)\cr+ #' type of statistic to report. Available for Kaplan-Meier time estimates only, otherwise `type` |
||
| 15 |
- #' statistic used to estimate Chisq p-value.+ #' is ignored. Default is `NULL`. |
||
| 16 |
- #' Default is the Rao-Scott second-order correction ("F"). See [`survey::svychisq`]
+ #' Must be one of the following: |
||
| 17 |
- #' for available statistics options.+ #' ```{r, echo = FALSE}
|
||
| 18 |
- #' @param ... arguments passed to [`survey::svychisq()`].+ #' dplyr::tribble( |
||
| 19 |
- #'+ #' ~type, ~transformation, |
||
| 20 |
- #' @return ARD data frame+ #' '`"survival"`', '`x`', |
||
| 21 |
- #' @export+ #' '`"risk"`', '`1 - x`', |
||
| 22 |
- #'+ #' '`"cumhaz"`', '`-log(x)`', |
||
| 23 |
- #' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = c("survey", "broom"), reference_pkg = "cardx"))
+ #' ) %>% |
||
| 24 |
- #' data(api, package = "survey")+ #' knitr::kable() |
||
| 25 |
- #' dclus1 <- survey::svydesign(id = ~dnum, weights = ~pw, data = apiclus1, fpc = ~fpc)+ #' ``` |
||
| 27 |
- #' ard_survey_svychisq(dclus1, variables = sch.wide, by = comp.imp, statistic = "F")+ #' @return an ARD data frame of class 'card' |
||
| 28 |
- ard_survey_svychisq <- function(data, by, variables, statistic = "F", ...) {
+ #' @name ard_survival_survfit |
||
| 29 | -2x | +
- set_cli_abort_call()+ #' |
|
| 30 |
-
+ #' @details |
||
| 31 |
- # check installed packages ---------------------------------------------------+ #' * Only one of either the `times` or `probs` parameters can be specified. |
||
| 32 | -2x | +
- check_pkg_installed(c("survey", "broom"), reference_pkg = "cardx")
+ #' * Times should be provided using the same scale as the time variable used to fit the provided |
|
| 33 |
-
+ #' survival fit model. |
||
| 34 |
- # check/process inputs -------------------------------------------------------+ #' |
||
| 35 | -2x | +
- check_not_missing(data)+ #' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = c("survival", "broom", "ggsurvfit"), reference_pkg = "cardx"))
|
|
| 36 | -2x | +
- check_not_missing(variables)+ #' library(survival) |
|
| 37 | -2x | +
- check_not_missing(by)+ #' library(ggsurvfit) |
|
| 38 | -2x | +
- check_class(data, cls = "survey.design")+ #' |
|
| 39 | -2x | +
- cards::process_selectors(data[["variables"]], by = {{ by }}, variables = {{ variables }})
+ #' survfit(Surv_CNSR(AVAL, CNSR) ~ TRTA, cards::ADTTE) |> |
|
| 40 | -2x | +
- check_scalar(by)+ #' ard_survival_survfit(times = c(60, 180)) |
|
| 41 |
-
+ #' |
||
| 42 |
- # if no variables selected, return empty tibble ------------------------------+ #' survfit(Surv_CNSR(AVAL, CNSR) ~ TRTA, cards::ADTTE) |> |
||
| 43 | -2x | +
- if (is_empty(variables)) {
+ #' ard_survival_survfit(probs = c(0.25, 0.5, 0.75)) |
|
| 44 | -! | +
- return(dplyr::tibble())+ #' |
|
| 45 |
- }+ #' # Competing Risks Example --------------------------- |
||
| 46 |
- # build ARD ------------------------------------------------------------------+ #' set.seed(1) |
||
| 47 | -2x | +
- lapply(+ #' ADTTE_MS <- cards::ADTTE %>% |
|
| 48 | -2x | +
- variables,+ #' dplyr::mutate( |
|
| 49 | -2x | +
- function(variable) {
+ #' CNSR = dplyr::case_when( |
|
| 50 | -3x | +
- cards::tidy_as_ard(+ #' CNSR == 0 ~ "censor", |
|
| 51 | -3x | +
- lst_tidy =+ #' runif(dplyr::n()) < 0.5 ~ "death from cancer", |
|
| 52 | -3x | +
- cards::eval_capture_conditions(+ #' TRUE ~ "death other causes" |
|
| 53 | -3x | +
- survey::svychisq(reformulate2(termlabels = c(variable, by)), design = data, statistic = statistic, ...) |>+ #' ) %>% factor() |
|
| 54 | -3x | +
- broom::tidy()+ #' ) |
|
| 55 |
- ),+ #' |
||
| 56 | -3x | +
- tidy_result_names = c("statistic", "p.value", "ndf", "ddf", "method"),
+ #' survfit(Surv(AVAL, CNSR) ~ TRTA, data = ADTTE_MS) %>% |
|
| 57 | -3x | +
- passed_args = dots_list(...),+ #' ard_survival_survfit(times = c(60, 180)) |
|
| 58 | -3x | +
- lst_ard_columns = list(group1 = by, variable = variable, context = "survey_svychisq")+ NULL |
|
| 59 |
- ) |>+ |
||
| 60 | -3x | +
- dplyr::mutate(+ #' @rdname ard_survival_survfit |
|
| 61 | -3x | +
- .after = "stat_name",+ #' @export |
|
| 62 | -3x | +
- stat_label =+ ard_survival_survfit <- function(x, times = NULL, probs = NULL, type = NULL) {
|
|
| 63 | -3x | +11x |
- dplyr::case_when(+ set_cli_abort_call() |
| 64 | -3x | +
- .data$stat_name %in% "statistic" ~ "Statistic",+ |
|
| 65 | -3x | +
- .data$stat_name %in% "p.value" ~ "p-value",+ # check installed packages --------------------------------------------------- |
|
| 66 | -3x | +11x |
- .data$stat_name %in% "ndf" ~ "Nominator Degrees of Freedom",+ check_pkg_installed(c("survival", "broom"), reference_pkg = "cardx")
|
| 67 | -3x | +
- .data$stat_name %in% "ddf" ~ "Denominator Degrees of Freedom",+ |
|
| 68 | -3x | +
- TRUE ~ .data$stat_name,+ # check/process inputs ------------------------------------------------------- |
|
| 69 | -+ | 11x |
- )+ check_not_missing(x) |
| 70 | -+ | 11x |
- )+ check_class(x, cls = "survfit") |
| 71 | -- |
- }- |
- |
| 72 | -+ | 10x |
- ) |>+ if (inherits(x, "survfitcox")) {
|
| 73 | -2x | -
- dplyr::bind_rows()- |
- |
| 74 | -- |
- }- |
-
| 1 | -- |
- #' ARD Fisher's Exact Test- |
- ||
| 2 | -- |
- #'- |
- ||
| 3 | -+ | 72 | +1x |
- #' @description+ cli::cli_abort("Argument {.arg x} cannot be class {.cls survfitcox}.",
|
| 4 | -+ | |||
| 73 | +1x |
- #' Analysis results data for Fisher's Exact Test.+ call = get_cli_abort_call() |
||
| 5 | +74 |
- #' Calculated with `fisher.test(x = data[[variable]], y = data[[by]], ...)`+ ) |
||
| 6 | +75 |
- #'+ } |
||
| 7 | +76 |
- #'+ |
||
| 8 | +77 |
- #' @param data (`data.frame`)\cr+ # competing risks models cannot use the type argument |
||
| 9 | -+ | |||
| 78 | +9x |
- #' a data frame.+ if (inherits(x, c("survfitms", "survfitcoxms")) && !is.null(type)) {
|
||
| 10 | -+ | |||
| 79 | +! |
- #' @param by ([`tidy-select`][dplyr::dplyr_tidy_select])\cr+ cli::cli_abort("Cannot use {.arg type} argument with {.code survfit} models with class {.cls {c('survfitms', 'survfitcoxms')}}.",
|
||
| 11 | -+ | |||
| 80 | +! |
- #' column name to compare by+ call = get_cli_abort_call() |
||
| 12 | +81 |
- #' @param variables ([`tidy-select`][dplyr::dplyr_tidy_select])\cr+ ) |
||
| 13 | +82 |
- #' column names to be compared. Independent tests will be computed for+ } |
||
| 14 | -+ | |||
| 83 | +1x |
- #' each variable.+ if (!is.null(probs)) check_range(probs, c(0, 1)) |
||
| 15 | -+ | |||
| 84 | +9x |
- #' @param conf.level (scalar `numeric`)\cr+ if (sum(is.null(times), is.null(probs)) != 1) {
|
||
| 16 | -+ | |||
| 85 | +! |
- #' confidence level for confidence interval. Default is `0.95`.+ cli::cli_abort("One and only one of {.arg times} and {.arg probs} must be specified.")
|
||
| 17 | +86 |
- #' @param ... additional arguments passed to `fisher.test(...)`+ } |
||
| 18 | +87 |
- #'+ |
||
| 19 | +88 |
- #' @return ARD data frame+ # for regular KM estimators, we allow the type argument |
||
| 20 | -+ | |||
| 89 | +9x |
- #' @export+ if (!inherits(x, "survfitms") && !is.null(type)) {
|
||
| 21 | -+ | |||
| 90 | +1x |
- #'+ type <- arg_match(type, values = c("survival", "risk", "cumhaz"))
|
||
| 22 | +91 |
- #' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = "broom", reference_pkg = "cardx"))
+ } |
||
| 23 | +92 |
- #' cards::ADSL[1:30, ] |>+ |
||
| 24 | +93 |
- #' ard_stats_fisher_test(by = "ARM", variables = "AGEGR1")+ # cannot specify type arg when probs supplied |
||
| 25 | -+ | |||
| 94 | +9x |
- ard_stats_fisher_test <- function(data, by, variables, conf.level = 0.95, ...) {
+ if (!is.null(probs) && !is.null(type)) {
|
||
| 26 | -3x | +|||
| 95 | +! |
- set_cli_abort_call()+ cli::cli_abort("Cannot use {.arg type} argument when {.arg probs} argument specifed.",
|
||
| 27 | -+ | |||
| 96 | +! |
-
+ call = get_cli_abort_call() |
||
| 28 | +97 |
- # check installed packages ---------------------------------------------------+ ) |
||
| 29 | -3x | +|||
| 98 | +
- check_pkg_installed("broom", reference_pkg = "cardx")
+ } |
|||
| 30 | +99 | |||
| 31 | +100 |
- # check/process inputs -------------------------------------------------------+ # build ARD ------------------------------------------------------------------ |
||
| 32 | -3x | +101 | +9x |
- check_not_missing(data)+ est_type <- ifelse(is.null(probs), "times", "probs") |
| 33 | -3x | +102 | +9x |
- check_not_missing(variables)+ tidy_survfit <- switch(est_type, |
| 34 | -3x | +103 | +9x |
- check_not_missing(by)+ "times" = .process_survfit_time(x, times, type %||% "survival"), |
| 35 | -3x | +104 | +9x |
- check_data_frame(data)+ "probs" = .process_survfit_probs(x, probs) |
| 36 | -3x | +|||
| 105 | +
- cards::process_selectors(data, by = {{ by }}, variables = {{ variables }})
+ ) |
|||
| 37 | -3x | +|||
| 106 | +
- check_scalar(by)+ |
|||
| 38 | -3x | +107 | +9x |
- check_range(conf.level, range = c(0, 1))+ .format_survfit_results(tidy_survfit) |
| 39 | +108 |
-
+ } |
||
| 40 | +109 |
- # if no variables selected, return empty tibble ------------------------------- |
- ||
| 41 | -3x | -
- if (is_empty(variables)) {
+
|
||
| 42 | -! | +|||
| 110 | +
- return(dplyr::tibble())+ #' Process Survival Fit For Time Estimates |
|||
| 43 | +111 |
- }+ #' |
||
| 44 | +112 |
- # build ARD ------------------------------------------------------------------+ #' @inheritParams cards::tidy_as_ard |
||
| 45 | -3x | +|||
| 113 | +
- lapply(+ #' @inheritParams ard_survival_survfit |
|||
| 46 | -3x | +|||
| 114 | +
- variables,+ #' @param start.time (`numeric`)\cr |
|||
| 47 | -3x | +|||
| 115 | +
- function(variable) {
+ #' default starting time. See [survival::survfit0()] for more details. |
|||
| 48 | -4x | +|||
| 116 | +
- cards::tidy_as_ard(+ #' |
|||
| 49 | -4x | +|||
| 117 | +
- lst_tidy =+ #' @return a `tibble` |
|||
| 50 | -4x | +|||
| 118 | +
- cards::eval_capture_conditions(+ #' |
|||
| 51 | -4x | +|||
| 119 | +
- stats::fisher.test(x = data[[variable]], y = data[[by]], conf.level = conf.level, ...) |>+ #' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = c("survival", "broom"), reference_pkg = "cardx"))
|
|||
| 52 | -4x | +|||
| 120 | +
- broom::tidy()+ #' survival::survfit(survival::Surv(AVAL, CNSR) ~ TRTA, cards::ADTTE) |> |
|||
| 53 | +121 |
- ),+ #' cardx:::.process_survfit_time(times = c(60, 180), type = "risk") |
||
| 54 | -4x | +|||
| 122 | +
- tidy_result_names =+ #' |
|||
| 55 | -4x | +|||
| 123 | +
- c("estimate", "p.value", "conf.low", "conf.high", "method", "alternative"),
+ #' @keywords internal |
|||
| 56 | -4x | +|||
| 124 | +
- fun_args_to_record =+ .process_survfit_time <- function(x, times, type, start.time = NULL) {
|
|||
| 57 | -4x | +|||
| 125 | +
- c(+ # add start time |
|||
| 58 | -4x | +126 | +8x |
- "workspace", "hybrid", "hybridPars", "control", "or",+ min_time <- min(x$time) |
| 59 | -4x | -
- "conf.int", "conf.level", "simulate.p.value", "B"- |
- ||
| 60 | -+ | 127 | +8x |
- ),+ if (is.null(start.time) && min_time < 0) {
|
| 61 | -4x | +|||
| 128 | +! |
- formals = formals(stats::fisher.test),+ cli::cli_inform(paste( |
||
| 62 | -4x | +|||
| 129 | +! |
- passed_args = dots_list(...),+ "The {.arg start.time} argument has not been set and negative times have been observed. Please set start",
|
||
| 63 | -4x | +|||
| 130 | +! |
- lst_ard_columns = list(group1 = by, variable = variable, context = "stats_fisher_test")+ "time via the {.arg start.time} argument, otherwise the minimum observed time will be used by default."
|
||
| 64 | +131 |
- ) |>+ )) |
||
| 65 | -4x | +|||
| 132 | +! |
- dplyr::mutate(+ start.time <- min_time |
||
| 66 | -4x | +133 | +8x |
- .after = "stat_name",+ } else if (is.null(start.time)) {
|
| 67 | -4x | +134 | +8x |
- stat_label =+ start.time <- 0 |
| 68 | -4x | +|||
| 135 | +
- dplyr::case_when(+ } |
|||
| 69 | -4x | +136 | +8x |
- .data$stat_name %in% "p.value" ~ "p-value",+ x <- survival::survfit0(x, start.time) %>% |
| 70 | -4x | -
- TRUE ~ .data$stat_name,- |
- ||
| 71 | -- |
- )- |
- ||
| 72 | -+ | 137 | +8x |
- )+ summary(times) |
| 73 | +138 |
- }+ |
||
| 74 | +139 |
- ) |>+ # process competing risks/multi-state models |
||
| 75 | -3x | +140 | +8x |
- dplyr::bind_rows()+ multi_state <- inherits(x, "summary.survfitms") |
| 76 | +141 |
- }+ |
| 1 | -+ | |||
| 142 | +8x |
- #' ARD McNemar's Test+ if (multi_state) {
|
||
| 2 | +143 |
- #'+ # selecting state to show |
||
| 3 | -+ | |||
| 144 | +1x |
- #' @description+ state <- setdiff(unique(x$states), "(s0)")[[1]] |
||
| 4 | -+ | |||
| 145 | +1x |
- #' Analysis results data for McNemar's statistical test.+ cli::cli_inform("Multi-state model detected. Showing probabilities into state '{state}'.")
|
||
| 5 | -+ | |||
| 146 | +1x |
- #' We have two functions depending on the structure of the data.+ x$n.risk <- x$n.risk[, 1] |
||
| 6 | -+ | |||
| 147 | +1x |
- #' - `ard_stats_mcnemar_test()` is the structure expected by [`stats::mcnemar.test()`]+ ms_cols <- c("pstate", "std.err", "upper", "lower")
|
- ||
| 7 | -+ | |||
| 148 | +1x |
- #' - `ard_stats_mcnemar_test_long()` is one row per ID per group+ state_col <- which(colnames(x$pstate) == state) |
||
| 8 | -+ | |||
| 149 | +1x |
- #'+ x[ms_cols] <- lapply(x[ms_cols], function(m) m[, state_col]) |
||
| 9 | -+ | |||
| 150 | +1x |
- #' @param data (`data.frame`)\cr+ x$surv <- x$pstate |
||
| 10 | +151 |
- #' a data frame. See below for details.+ } |
||
| 11 | +152 |
- #' @param by ([`tidy-select`][dplyr::dplyr_tidy_select])\cr+ |
||
| 12 | +153 |
- #' column name to compare by.+ # tidy survfit results |
||
| 13 | -+ | |||
| 154 | +8x |
- #' @param variables ([`tidy-select`][dplyr::dplyr_tidy_select])\cr+ x_cols <- intersect(names(x), c("time", "n.risk", "surv", "std.err", "upper", "lower", "strata"))
|
||
| 14 | -+ | |||
| 155 | +8x |
- #' column names to be compared. Independent tests will+ tidy_x <- data.frame(x[x_cols]) %>% |
||
| 15 | -+ | |||
| 156 | +8x |
- #' be computed for each variable.+ dplyr::rename(estimate = "surv", std.error = "std.err", conf.high = "upper", conf.low = "lower") |
||
| 16 | +157 |
- #' @param ... arguments passed to `stats::mcnemar.test(...)`+ |
||
| 17 | -+ | |||
| 158 | +8x |
- #' @param id ([`tidy-select`][dplyr::dplyr_tidy_select])\cr+ strat <- "strata" %in% names(tidy_x) |
||
| 18 | +159 |
- #' column name of the subject or participant ID+ |
||
| 19 | +160 |
- #'+ # get requested estimates |
||
| 20 | -+ | |||
| 161 | +8x |
- #' @return ARD data frame+ df_stat <- tidy_x %>% |
||
| 21 | +162 |
- #' @name ard_stats_mcnemar_test+ # find max time |
||
| 22 | -+ | |||
| 163 | +8x |
- #'+ dplyr::group_by_at(., dplyr::vars(dplyr::any_of("strata"))) %>%
|
||
| 23 | -+ | |||
| 164 | +8x |
- #' @details+ dplyr::mutate(time_max = max(.data$time)) %>% |
||
| 24 | -+ | |||
| 165 | +8x |
- #' For the `ard_stats_mcnemar_test()` function, the data is expected to be one row per subject.+ dplyr::ungroup() %>% |
||
| 25 | +166 |
- #' The data is passed as `stats::mcnemar.test(x = data[[variable]], y = data[[by]], ...)`.+ # add requested timepoints |
||
| 26 | -+ | |||
| 167 | +8x |
- #' Please use `table(x = data[[variable]], y = data[[by]])` to check the contingency table.+ dplyr::full_join( |
||
| 27 | -+ | |||
| 168 | +8x |
- #'+ tidy_x %>% |
||
| 28 | -+ | |||
| 169 | +8x |
- #' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = "broom", reference_pkg = "cardx"))
+ dplyr::select(any_of("strata")) %>%
|
||
| 29 | -+ | |||
| 170 | +8x |
- #' cards::ADSL |>+ dplyr::distinct() %>% |
||
| 30 | -+ | |||
| 171 | +8x |
- #' ard_stats_mcnemar_test(by = "SEX", variables = "EFFFL")+ dplyr::mutate( |
||
| 31 | -+ | |||
| 172 | +8x |
- #'+ time = list(.env$times), |
||
| 32 | -+ | |||
| 173 | +8x |
- #' set.seed(1234)+ col_name = list(paste("stat", seq_len(length(.env$times)), sep = "_"))
|
||
| 33 | +174 |
- #' cards::ADSL[c("USUBJID", "TRT01P")] |>
+ ) %>% |
||
| 34 | -+ | |||
| 175 | +8x |
- #' dplyr::mutate(TYPE = "PLANNED") |>+ tidyr::unnest(cols = c("time", "col_name")),
|
||
| 35 | -+ | |||
| 176 | +8x |
- #' dplyr::rename(TRT01 = TRT01P) %>%+ by = unlist(intersect(c("strata", "time"), names(tidy_x)))
|
||
| 36 | +177 |
- #' dplyr::bind_rows(dplyr::mutate(., TYPE = "ACTUAL", TRT01 = sample(TRT01))) |>+ ) |
||
| 37 | +178 |
- #' ard_stats_mcnemar_test_long(+ |
||
| 38 | -+ | |||
| 179 | +8x |
- #' by = TYPE,+ if (strat) {
|
||
| 39 | -+ | |||
| 180 | +7x |
- #' variable = TRT01,+ df_stat <- df_stat %>% dplyr::arrange(.data$strata) |
||
| 40 | +181 |
- #' id = USUBJID+ } |
||
| 41 | +182 |
- #' )+ |
||
| 42 | -+ | |||
| 183 | +8x |
- NULL+ df_stat <- df_stat %>% |
||
| 43 | -+ | |||
| 184 | +8x |
-
+ dplyr::arrange(.data$time) %>% |
||
| 44 | +185 |
- #' @rdname ard_stats_mcnemar_test+ # if user-specified time is after max time, make estimate NA |
||
| 45 | -+ | |||
| 186 | +8x |
- #' @export+ dplyr::mutate_at( |
||
| 46 | -+ | |||
| 187 | +8x |
- ard_stats_mcnemar_test <- function(data, by, variables, ...) {
+ dplyr::vars("estimate", "conf.high", "conf.low"),
|
||
| 47 | -6x | +188 | +8x |
- set_cli_abort_call()+ ~ ifelse(.data$time > .data$time_max, NA_real_, .) |
| 48 | +189 |
-
+ ) %>% |
||
| 49 | -+ | |||
| 190 | +8x |
- # check installed packages ---------------------------------------------------+ dplyr::mutate(context = type) %>% |
||
| 50 | -6x | +191 | +8x |
- check_pkg_installed("broom", reference_pkg = "cardx")
+ dplyr::select(!dplyr::any_of(c("time_max", "col_name")))
|
| 51 | +192 | |||
| 52 | +193 |
- # check/process inputs -------------------------------------------------------- |
- ||
| 53 | -6x | -
- check_not_missing(data)- |
- ||
| 54 | -6x | -
- check_not_missing(variables)+ # convert estimates to requested type |
||
| 55 | -6x | +194 | +8x |
- check_not_missing(by)+ if (type != "survival") {
|
| 56 | -6x | +195 | +1x |
- check_data_frame(data)+ df_stat <- df_stat %>% |
| 57 | -6x | +196 | +1x |
- data <- dplyr::ungroup(data)+ dplyr::mutate(dplyr::across( |
| 58 | -6x | +197 | +1x |
- cards::process_selectors(data, by = {{ by }}, variables = {{ variables }})
+ any_of(c("estimate", "conf.low", "conf.high")),
|
| 59 | -6x | -
- check_scalar(by)- |
- ||
| 60 | -+ | 198 | +1x |
-
+ if (type == "cumhaz") ~ -log(.x) else ~ 1 - .x |
| 61 | +199 |
- # if no variables selected, return empty tibble ------------------------------+ )) %>% |
||
| 62 | -6x | -
- if (is_empty(variables)) {
- |
- ||
| 63 | -! | +200 | +1x |
- return(dplyr::tibble())+ dplyr::rename(conf.low = "conf.high", conf.high = "conf.low") |
| 64 | +201 |
} |
||
| 65 | +202 |
- # build ARD ------------------------------------------------------------------- |
- ||
| 66 | -6x | -
- lapply(+ |
||
| 67 | -6x | +203 | +8x |
- variables,+ df_stat <- extract_multi_strata(x, df_stat) |
| 68 | -6x | +|||
| 204 | +
- function(variable) {
+
|
|||
| 69 | -7x | +205 | +8x |
- .format_mcnemartest_results(+ df_stat |
| 70 | -7x | +|||
| 206 | +
- by = by,+ } |
|||
| 71 | -7x | +|||
| 207 | +
- variable = variable,+ |
|||
| 72 | -7x | +|||
| 208 | +
- lst_tidy =+ #' Process Survival Fit For Quantile Estimates |
|||
| 73 | -7x | +|||
| 209 | +
- cards::eval_capture_conditions(+ #' |
|||
| 74 | -7x | +|||
| 210 | +
- stats::mcnemar.test(x = data[[variable]], y = data[[by]], ...) |>+ #' @inheritParams cards::tidy_as_ard |
|||
| 75 | -7x | +|||
| 211 | +
- broom::tidy()+ #' @inheritParams ard_survival_survfit |
|||
| 76 | +212 |
- ),+ #' |
||
| 77 | +213 |
- ...+ #' @return a `tibble` |
||
| 78 | +214 |
- )+ #' |
||
| 79 | +215 |
- }+ #' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = "survival", reference_pkg = "cardx"))
|
||
| 80 | +216 |
- ) |>+ #' survival::survfit(survival::Surv(AVAL, CNSR) ~ TRTA, cards::ADTTE) |> |
||
| 81 | -6x | +|||
| 217 | +
- dplyr::bind_rows()+ #' cardx:::.process_survfit_probs(probs = c(0.25, 0.75)) |
|||
| 82 | +218 |
- }+ #' |
||
| 83 | +219 |
-
+ #' @keywords internal |
||
| 84 | +220 |
- #' @rdname ard_stats_mcnemar_test+ .process_survfit_probs <- function(x, probs) {
|
||
| 85 | +221 |
- #' @export+ # calculate survival quantiles and add estimates to df |
||
| 86 | -+ | |||
| 222 | +1x |
- ard_stats_mcnemar_test_long <- function(data, by, variables, id, ...) {
+ df_stat <- map2( |
||
| 87 | +223 | 1x |
- set_cli_abort_call()+ probs, |
|
| 88 | -+ | |||
| 224 | +1x |
-
+ seq_along(probs), |
||
| 89 | -+ | |||
| 225 | +1x |
- # check installed packages ---------------------------------------------------+ ~ stats::quantile(x, probs = .x) %>% |
||
| 90 | +226 | 1x |
- check_pkg_installed("broom", reference_pkg = "cardx")
+ as.data.frame() %>% |
|
| 91 | -+ | |||
| 227 | +1x |
-
+ set_names(c("estimate", "conf.low", "conf.high")) %>%
|
||
| 92 | -+ | |||
| 228 | +1x |
- # check/process inputs -------------------------------------------------------+ dplyr::mutate(strata = row.names(.)) %>% |
||
| 93 | +229 | 1x |
- check_not_missing(data)+ dplyr::select(dplyr::any_of(c("n.risk", "strata", "estimate", "std.error", "conf.low", "conf.high"))) %>%
|
|
| 94 | +230 | 1x |
- check_not_missing(variables)+ dplyr::mutate(prob = .x) |
|
| 95 | -1x | +|||
| 231 | +
- check_not_missing(by)+ ) %>% |
|||
| 96 | +232 | 1x |
- check_not_missing(id)+ dplyr::bind_rows() %>% |
|
| 97 | +233 | 1x |
- check_data_frame(data)+ `rownames<-`(NULL) %>% |
|
| 98 | +234 | 1x |
- data <- dplyr::ungroup(data)+ dplyr::mutate(context = "survival_survfit") %>% |
|
| 99 | +235 | 1x |
- cards::process_selectors(data, by = {{ by }}, variables = {{ variables }}, id = {{ id }})
+ dplyr::as_tibble() |
|
| 100 | -1x | +|||
| 236 | +
- check_scalar(by)+ |
|||
| 101 | -1x | +|||
| 237 | +! |
- check_scalar(id)+ if (length(x$n) == 1) df_stat <- df_stat %>% dplyr::select(-"strata") |
||
| 102 | +238 | |||
| 239 | +1x | +
+ df_stat <- extract_multi_strata(x, df_stat)+ |
+ ||
| 103 | +240 |
- # if no variables selected, return empty tibble ------------------------------+ |
||
| 104 | +241 | 1x |
- if (is_empty(variables)) {
+ df_stat |
|
| 105 | -! | +|||
| 242 | +
- return(dplyr::tibble())+ } |
|||
| 106 | +243 |
- }+ |
||
| 107 | +244 |
- # build ARD ------------------------------------------------------------------+ # process multiple stratifying variables |
||
| 108 | -1x | +|||
| 245 | +
- lapply(+ extract_multi_strata <- function(x, df_stat) {
|
|||
| 109 | -1x | +246 | +9x |
- variables,+ x_terms <- attr(stats::terms(stats::as.formula(x$call$formula)), "term.labels") |
| 110 | -1x | +247 | +9x |
- function(variable) {
+ x_terms <- gsub(".*\\(", "", gsub("\\)", "", x_terms))
|
| 111 | -1x | +248 | +9x |
- .format_mcnemartest_results(+ if (length(x_terms) > 1) {
|
| 112 | -1x | +249 | +3x |
- by = by,+ strata_lvls <- data.frame()+ |
+
| 250 | ++ | + | ||
| 113 | -1x | +251 | +3x |
- variable = variable,+ for (i in df_stat[["strata"]]) {
|
| 114 | -1x | +252 | +42x |
- lst_tidy =+ i <- gsub(".*\\(", "", gsub("\\)", "", i))
|
| 115 | -1x | +253 | +42x |
- cards::eval_capture_conditions({
+ terms_str <- strsplit(i, paste(c(paste0(x_terms, "="), paste0(", ", x_terms, "=")), collapse = "|"))[[1]]
|
| 116 | -+ | |||
| 254 | +42x |
- # adding this reshape inside the eval, so if there is an error it's captured in the ARD object+ s_lvl <- terms_str[nchar(terms_str) > 0] |
||
| 117 | -1x | +255 | +42x |
- data_wide <- .paired_data_pivot_wider(data, by = by, variable = variable, id = id)+ strata_lvls <- rbind(strata_lvls, s_lvl) |
| 118 | +256 |
- # performing McNemars test+ } |
||
| 119 | -1x | +257 | +3x |
- stats::mcnemar.test(x = data_wide[["by1"]], y = data_wide[["by2"]], ...) |>+ if (nrow(strata_lvls) > 0) {
|
| 120 | -1x | +258 | +3x |
- broom::tidy()+ strata_lvls <- cbind(strata_lvls, t(x_terms)) |
| 121 | -+ | |||
| 259 | +3x |
- }),+ names(strata_lvls) <- c( |
||
| 122 | -+ | |||
| 260 | +3x |
- ...+ t(sapply(seq_along(x_terms), function(i) c(paste0("group", i, "_level"), paste0("group", i))))
|
||
| 123 | +261 |
) |
||
| 262 | +3x | +
+ df_stat <- cbind(df_stat, strata_lvls) %>%+ |
+ ||
| 263 | +3x | +
+ dplyr::select(-"strata")+ |
+ ||
| 124 | +264 |
} |
||
| 125 | +265 |
- ) |>+ } |
||
| 126 | -1x | +266 | +9x |
- dplyr::bind_rows()+ df_stat |
| 127 | +267 |
} |
||
| 128 | +268 | |||
| 129 | +269 |
- #' Convert McNemar's test to ARD+ #' Convert Tidied Survival Fit to ARD |
||
| 130 | +270 |
#' |
||
| 131 | +271 |
#' @inheritParams cards::tidy_as_ard |
||
| 132 | +272 |
- #' @inheritParams stats::mcnemar.test+ #' |
||
| 133 | +273 |
- #' @param by (`string`)\cr by column name+ #' @return an ARD data frame of class 'card' |
||
| 134 | +274 |
- #' @param variable (`string`)\cr variable column name+ #' |
||
| 135 | +275 |
- #' @param ... passed to `stats::mcnemar.test(...)`+ #' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = c("survival", "broom"), reference_pkg = "cardx"))
|
||
| 136 | +276 |
- #'+ #' cardx:::.format_survfit_results( |
||
| 137 | +277 |
- #' @return ARD data frame+ #' broom::tidy(survival::survfit(survival::Surv(AVAL, CNSR) ~ TRTA, cards::ADTTE)) |
||
| 138 | +278 |
- #'+ #' ) |
||
| 139 | +279 |
- #' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = "broom", reference_pkg = "cardx"))
+ #' |
||
| 140 | +280 |
- #' cardx:::.format_mcnemartest_results(+ #' @keywords internal |
||
| 141 | +281 |
- #' by = "ARM",+ .format_survfit_results <- function(tidy_survfit) {
|
||
| 142 | -+ | |||
| 282 | +9x |
- #' variable = "AGE",+ est <- if ("time" %in% names(tidy_survfit)) "time" else "prob"
|
||
| 143 | +283 |
- #' lst_tidy =+ |
||
| 144 | -+ | |||
| 284 | +9x |
- #' cards::eval_capture_conditions(+ ret <- tidy_survfit %>% |
||
| 145 | -+ | |||
| 285 | +9x |
- #' stats::mcnemar.test(cards::ADSL[["SEX"]], cards::ADSL[["EFFFL"]]) |>+ dplyr::mutate(dplyr::across(+ |
+ ||
| 286 | +9x | +
+ dplyr::any_of(c("n.risk", "estimate", "std.error", "conf.high", "conf.low", "time", "prob")), ~ as.list(.)
|
||
| 146 | +287 |
- #' broom::tidy()+ )) %>%+ |
+ ||
| 288 | +9x | +
+ tidyr::pivot_longer(+ |
+ ||
| 289 | +9x | +
+ cols = dplyr::any_of(c("n.risk", "estimate", "std.error", "conf.high", "conf.low")),
+ |
+ ||
| 290 | +9x | +
+ names_to = "stat_name",+ |
+ ||
| 291 | +9x | +
+ values_to = "stat" |
||
| 147 | +292 |
- #' )+ ) %>%+ |
+ ||
| 293 | +9x | +
+ dplyr::mutate(+ |
+ ||
| 294 | +9x | +
+ variable = est,+ |
+ ||
| 295 | +9x | +
+ variable_level = .data[[est]] |
||
| 148 | +296 |
- #' )+ ) %>%+ |
+ ||
| 297 | +9x | +
+ dplyr::select(-all_of(est)) |
||
| 149 | +298 |
- #'+ + |
+ ||
| 299 | +9x | +
+ if ("strata" %in% names(ret)) {
+ |
+ ||
| 300 | +5x | +
+ ret <- ret %>%+ |
+ ||
| 301 | +5x | +
+ tidyr::separate_wider_delim("strata", "=", names = c("group1", "group1_level"))
|
||
| 150 | +302 |
- #' @keywords internal+ } |
||
| 151 | +303 |
- .format_mcnemartest_results <- function(by, variable, lst_tidy, ...) {
+
+ |
+ ||
| 304 | +9x | +
+ ret %>%+ |
+ ||
| 305 | +9x | +
+ dplyr::left_join(+ |
+ ||
| 306 | +9x | +
+ .df_survfit_stat_labels(),+ |
+ ||
| 307 | +9x | +
+ by = "stat_name" |
||
| 152 | +308 |
- # build ARD ------------------------------------------------------------------+ ) %>% |
||
| 153 | -8x | +309 | +9x |
- ret <-+ dplyr::mutate( |
| 154 | -8x | +310 | +9x |
- cards::tidy_as_ard(+ fmt_fn = lapply( |
| 155 | -8x | +311 | +9x |
- lst_tidy = lst_tidy,+ .data$stat, |
| 156 | -8x | +312 | +9x |
- tidy_result_names = c("statistic", "p.value", "method"),
+ function(x) {
|
| 157 | -8x | +313 | +348x |
- fun_args_to_record = c("correct"),
+ switch(is.integer(x), |
| 158 | -8x | +314 | +348x |
- formals = formals(asNamespace("stats")[["mcnemar.test"]]),
+ 0L |
| 159 | -8x | +315 | +348x |
- passed_args = dots_list(...),+ ) %||% switch(is.numeric(x), |
| 160 | -8x | +316 | +348x |
- lst_ard_columns = list(group1 = by, variable = variable, context = "stats_mcnemar_test")+ 1L |
| 161 | +317 |
- )+ )+ |
+ ||
| 318 | ++ |
+ } |
||
| 162 | +319 |
-
+ ),+ |
+ ||
| 320 | +9x | +
+ stat_label = dplyr::coalesce(.data$stat_label, .data$stat_name) |
||
| 163 | +321 |
- # add the stat label ---------------------------------------------------------+ ) %>% |
||
| 164 | -8x | +322 | +9x |
- ret |>+ dplyr::mutate(dplyr::across(matches("group[0-9]*_level"), ~ as.list(as.factor(.x)))) %>%
|
| 165 | -8x | +323 | +9x |
- dplyr::left_join(+ dplyr::mutate( |
| 166 | -8x | +324 | +9x |
- .df_mcnemar_stat_labels(),+ warning = list(NULL), |
| 167 | -8x | +325 | +9x |
- by = "stat_name"+ error = list(NULL) |
| 168 | +326 |
- ) |>+ ) %>% |
||
| 169 | -8x | +327 | +9x |
- dplyr::mutate(stat_label = dplyr::coalesce(.data$stat_label, .data$stat_name)) |>+ structure(., class = c("card", class(.))) %>%
|
| 170 | -8x | +328 | +9x |
- cards::tidy_ard_column_order()+ cards::tidy_ard_column_order() %>%+ |
+
| 329 | +9x | +
+ cards::tidy_ard_row_order() |
||
| 171 | +330 |
} |
||
| 172 | +331 | |||
| 173 | +332 |
- .df_mcnemar_stat_labels <- function() {
+ .df_survfit_stat_labels <- function() {
|
||
| 174 | -8x | +333 | +9x |
dplyr::tribble( |
| 175 | -8x | +334 | +9x |
~stat_name, ~stat_label, |
| 176 | -8x | +335 | +9x |
- "statistic", "X-squared Statistic",+ "n.risk", "Number of Subjects at Risk", |
| 177 | -8x | +336 | +9x |
- "parameter", "Degrees of Freedom",+ "estimate", "Survival Probability", |
| 178 | -8x | +337 | +9x |
- "p.value", "p-value",+ "std.error", "Standard Error (untransformed)",+ |
+
| 338 | +9x | +
+ "conf.low", "CI Lower Bound",+ |
+ ||
| 339 | +9x | +
+ "conf.high", "CI Upper Bound",+ |
+ ||
| 340 | +9x | +
+ "conf.level", "CI Confidence Level",+ |
+ ||
| 341 | +9x | +
+ "prob", "Quantile",+ |
+ ||
| 342 | +9x | +
+ "time", "Time" |
||
| 179 | +343 |
) |
||
| 180 | +344 |
}@@ -21762,14 +20428,14 @@ cardx coverage - 95.32% |
| 1 |
- #' ARD Survey rank test+ #' ARD t-test |
||
| 4 |
- #' Analysis results data for survey wilcox test using [`survey::svyranktest()`].+ #' Analysis results data for paired and non-paired t-tests. |
||
| 6 |
- #' @param data (`survey.design`)\cr+ #' @param data (`data.frame`)\cr |
||
| 7 |
- #' a survey design object often created with [`survey::svydesign()`]+ #' a data frame. See below for details. |
||
| 9 |
- #' column name to compare by+ #' optional column name to compare by. |
||
| 11 |
- #' column names to be compared. Independent tests will be run for each variable.+ #' column names to be compared. Independent t-tests will be computed for |
||
| 12 |
- #' @param test (`string`)\cr+ #' each variable. |
||
| 13 |
- #' a string to denote which rank test to use:+ #' @param id ([`tidy-select`][dplyr::dplyr_tidy_select])\cr |
||
| 14 |
- #' `"wilcoxon"`, `"vanderWaerden"`, `"median"`, `"KruskalWallis"`+ #' column name of the subject or participant ID |
||
| 15 |
- #' @param ... arguments passed to [`survey::svyranktest()`]+ #' @param conf.level (scalar `numeric`)\cr |
||
| 16 |
- #'+ #' confidence level for confidence interval. Default is `0.95`. |
||
| 17 |
- #' @return ARD data frame+ #' @param ... arguments passed to `t.test(...)` |
||
| 18 |
- #' @export+ #' |
||
| 19 |
- #'+ #' @return ARD data frame |
||
| 20 |
- #' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = c("survey", "broom"), reference_pkg = "cardx"))
+ #' @name ard_stats_t_test |
||
| 21 |
- #' data(api, package = "survey")+ #' |
||
| 22 |
- #' dclus2 <- survey::svydesign(id = ~ dnum + snum, fpc = ~ fpc1 + fpc2, data = apiclus2)+ #' @details |
||
| 23 |
- #'+ #' For the `ard_stats_t_test()` function, the data is expected to be one row per subject. |
||
| 24 |
- #' ard_survey_svyranktest(dclus2, variables = enroll, by = comp.imp, test = "wilcoxon")+ #' The data is passed as `t.test(data[[variable]] ~ data[[by]], paired = FALSE, ...)`. |
||
| 25 |
- #' ard_survey_svyranktest(dclus2, variables = enroll, by = comp.imp, test = "vanderWaerden")+ #' |
||
| 26 |
- #' ard_survey_svyranktest(dclus2, variables = enroll, by = comp.imp, test = "median")+ #' For the `ard_stats_paired_t_test()` function, the data is expected to be one row |
||
| 27 |
- #' ard_survey_svyranktest(dclus2, variables = enroll, by = comp.imp, test = "KruskalWallis")+ #' per subject per by level. Before the t-test is calculated, the data are |
||
| 28 |
- ard_survey_svyranktest <- function(data, by, variables, test, ...) {
+ #' reshaped to a wide format to be one row per subject. |
||
| 29 | -5x | +
- set_cli_abort_call()+ #' The data are then passed as |
|
| 30 |
-
+ #' `t.test(x = data_wide[[<by level 1>]], y = data_wide[[<by level 2>]], paired = TRUE, ...)`. |
||
| 31 |
- # check installed packages ---------------------------------------------------+ #' |
||
| 32 | -5x | +
- check_pkg_installed(c("survey", "broom"), reference_pkg = "cardx")
+ #' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = "broom", reference_pkg = "cardx"))
|
|
| 33 |
-
+ #' cards::ADSL |> |
||
| 34 |
- # check/process inputs -------------------------------------------------------+ #' dplyr::filter(ARM %in% c("Placebo", "Xanomeline High Dose")) |>
|
||
| 35 | -5x | +
- check_not_missing(data)+ #' ard_stats_t_test(by = ARM, variables = c(AGE, BMIBL)) |
|
| 36 | -5x | +
- check_not_missing(variables)+ #' |
|
| 37 | -5x | -
- check_not_missing(by)- |
- |
| 38 | -5x | -
- check_class(data, cls = "survey.design")- |
- |
| 39 | -5x | -
- cards::process_selectors(data[["variables"]], by = {{ by }}, variables = {{ variables }})
- |
- |
| 40 | -5x | +
- check_scalar(by)+ #' # constructing a paired data set, |
|
| 41 | +38 |
-
+ #' # where patients receive both treatments |
|
| 42 | +39 |
- # build ARD ------------------------------------------------------------------- |
- |
| 43 | -5x | -
- lapply(- |
- |
| 44 | -5x | -
- variables,- |
- |
| 45 | -5x | -
- function(variable) {
- |
- |
| 46 | -5x | -
- .format_svyranktest_results(- |
- |
| 47 | -5x | -
- by = by,- |
- |
| 48 | -5x | -
- variable = variable,- |
- |
| 49 | -5x | -
- lst_tidy =- |
- |
| 50 | -5x | -
- cards::eval_capture_conditions(- |
- |
| 51 | -5x | -
- survey::svyranktest(reformulate2(termlabels = by, response = variable), design = data, test = test, ...) |>- |
- |
| 52 | -5x | -
- broom::tidy()+ #' cards::ADSL[c("ARM", "AGE")] |>
|
|
| 53 | +40 |
- )+ #' dplyr::filter(ARM %in% c("Placebo", "Xanomeline High Dose")) |>
|
|
| 54 | +41 |
- )+ #' dplyr::mutate(.by = ARM, USUBJID = dplyr::row_number()) |> |
|
| 55 | +42 |
- }+ #' dplyr::arrange(USUBJID, ARM) |> |
|
| 56 | +43 |
- ) |>- |
- |
| 57 | -5x | -
- dplyr::bind_rows()+ #' ard_stats_paired_t_test(by = ARM, variables = AGE, id = USUBJID) |
|
| 58 | +44 |
- }+ NULL |
|
| 59 | +45 | ||
| 60 | +46 |
- .format_svyranktest_results <- function(by, variable, lst_tidy, ...) {
+ #' @rdname ard_stats_t_test |
|
| 61 | +47 |
- # build ARD ------------------------------------------------------------------- |
- |
| 62 | -5x | -
- ret <-- |
- |
| 63 | -5x | -
- cards::tidy_as_ard(- |
- |
| 64 | -5x | -
- lst_tidy = lst_tidy,- |
- |
| 65 | -5x | -
- tidy_result_names = c(- |
- |
| 66 | -5x | -
- "estimate", "statistic",- |
- |
| 67 | -5x | -
- "p.value", "parameter",- |
- |
| 68 | -5x | -
- "method", "alternative"+ #' @export |
|
| 69 | +48 |
- ),- |
- |
| 70 | -5x | -
- passed_args = dots_list(...),+ ard_stats_t_test <- function(data, variables, by = NULL, conf.level = 0.95, ...) {
|
|
| 71 | +49 | 5x |
- lst_ard_columns = list(group1 = by, variable = variable, context = "survey_svyranktest")- |
-
| 72 | -- |
- )+ set_cli_abort_call() |
|
| 73 | +50 | ||
| 74 | -- |
- # add the stat label ---------------------------------------------------------- |
- |
| 75 | -5x | -
- ret |>- |
- |
| 76 | -5x | -
- dplyr::left_join(- |
- |
| 77 | -5x | -
- .df_surveyrank_stat_labels(),- |
- |
| 78 | -5x | -
- by = "stat_name"- |
- |
| 79 | +51 |
- ) |>- |
- |
| 80 | -5x | -
- dplyr::mutate(stat_label = dplyr::coalesce(.data$stat_label, .data$stat_name)) |>+ # check installed packages --------------------------------------------------- |
|
| 81 | +52 | 5x |
- cards::tidy_ard_column_order()- |
-
| 82 | -- |
- }- |
- |
| 83 | -- |
-
+ check_pkg_installed("broom", reference_pkg = "cardx")
|
|
| 84 | +53 | ||
| 85 | +54 |
- .df_surveyrank_stat_labels <- function() {
- |
- |
| 86 | -5x | -
- dplyr::tribble(- |
- |
| 87 | -5x | -
- ~stat_name, ~stat_label,+ # check/process inputs ------------------------------------------------------- |
|
| 88 | +55 | 5x |
- "statistic", "Statistic",+ check_not_missing(data) |
| 89 | +56 | 5x |
- "parameter", "Degrees of Freedom",+ check_not_missing(variables) |
| 90 | +57 | 5x |
- "estimate", "Median of the Difference",+ check_data_frame(data) |
| 91 | +58 | 5x |
- "null.value", "Null Value",+ data <- dplyr::ungroup(data) |
| 92 | +59 | 5x |
- "alternative", "Alternative Hypothesis",+ cards::process_selectors(data, by = {{ by }}, variables = {{ variables }})
|
| 93 | +60 | 5x |
- "data.name", "Data Name",+ check_scalar(by, allow_empty = TRUE) |
| 94 | +61 | 5x |
- "p.value", "p-value"+ check_range(conf.level, range = c(0, 1)) |
| 95 | +62 |
- )+ |
|
| 96 | +63 |
- }+ # if no variables selected, return empty tibble ------------------------------ |
| 1 | -+ | |||
| 64 | +5x |
- #' ARD Mood Test+ if (is_empty(variables)) {
|
||
| 2 | -+ | |||
| 65 | +! |
- #'+ return(dplyr::tibble()) |
||
| 3 | +66 |
- #' @description+ } |
||
| 4 | +67 |
- #' Analysis results data for Mood two sample test of scale. Note this not to be confused with+ |
||
| 5 | +68 |
- #' the Brown-Mood test of medians.+ # build ARD ------------------------------------------------------------------ |
||
| 6 | -+ | |||
| 69 | +5x |
- #'+ lapply( |
||
| 7 | -+ | |||
| 70 | +5x |
- #' @param data (`data.frame`)\cr+ variables, |
||
| 8 | -+ | |||
| 71 | +5x |
- #' a data frame. See below for details.+ function(variable) {
|
||
| 9 | -+ | |||
| 72 | +6x |
- #' @param by ([`tidy-select`][dplyr::dplyr_tidy_select])\cr+ .format_ttest_results( |
||
| 10 | -+ | |||
| 73 | +6x |
- #' column name to compare by.+ by = by, |
||
| 11 | -+ | |||
| 74 | +6x |
- #' @param variables ([`tidy-select`][dplyr::dplyr_tidy_select])\cr+ variable = variable, |
||
| 12 | -+ | |||
| 75 | +6x |
- #' column name to be compared. Independent tests will+ lst_tidy = |
||
| 13 | +76 |
- #' be run for each variable.+ # styler: off |
||
| 14 | -+ | |||
| 77 | +6x |
- #' @param ... arguments passed to `mood.test(...)`+ cards::eval_capture_conditions( |
||
| 15 | -+ | |||
| 78 | +6x |
- #'+ if (!is_empty(by)) stats::t.test(data[[variable]] ~ data[[by]], conf.level = conf.level, ...) |> broom::tidy() |
||
| 16 | -+ | |||
| 79 | +6x |
- #' @return ARD data frame+ else stats::t.test(data[[variable]], ...) |> broom::tidy() |
||
| 17 | +80 |
- #' @name ard_stats_mood_test+ ), |
||
| 18 | +81 |
- #'+ # styler: on |
||
| 19 | -+ | |||
| 82 | +6x |
- #' @details+ paired = FALSE, |
||
| 20 | +83 |
- #' For the `ard_stats_mood_test()` function, the data is expected to be one row per subject.+ ... |
||
| 21 | +84 |
- #' The data is passed as `mood.test(data[[variable]] ~ data[[by]], ...)`.+ ) |
||
| 22 | +85 |
- #' @rdname ard_stats_mood_test+ } |
||
| 23 | +86 |
- #' @export+ ) |>+ |
+ ||
| 87 | +5x | +
+ dplyr::bind_rows() |
||
| 24 | +88 |
- #'+ } |
||
| 25 | +89 |
- #' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = "broom", reference_pkg = "cardx"))
+
|
||
| 26 | +90 |
- #' cards::ADSL |>+ #' @rdname ard_stats_t_test |
||
| 27 | +91 |
- #' ard_stats_mood_test(by = "SEX", variables = "AGE")+ #' @export |
||
| 28 | +92 |
- ard_stats_mood_test <- function(data, by, variables, ...) {
+ ard_stats_paired_t_test <- function(data, by, variables, id, conf.level = 0.95, ...) {
|
||
| 29 | +93 | 2x |
set_cli_abort_call() |
|
| 30 | +94 | |||
| 31 | +95 |
# check installed packages --------------------------------------------------- |
||
| 32 | +96 | 2x |
check_pkg_installed("broom", reference_pkg = "cardx")
|
|
| 33 | +97 | |||
| 34 | +98 |
# check/process inputs ------------------------------------------------------- |
||
| 35 | +99 | 2x |
check_not_missing(data) |
|
| 36 | +100 | 2x |
check_not_missing(variables) |
|
| 37 | +101 | 2x |
check_not_missing(by) |
|
| 38 | +102 | +2x | +
+ check_not_missing(id)+ |
+ |
| 103 | 2x |
check_data_frame(data) |
||
| 39 | +104 | 2x |
data <- dplyr::ungroup(data) |
|
| 40 | +105 | 2x |
- cards::process_selectors(data, by = {{ by }}, variables = {{ variables }})
+ cards::process_selectors(data, by = {{ by }}, variables = {{ variables }}, id = {{ id }})
|
|
| 41 | +106 | 2x |
check_scalar(by) |
|
| 42 | -+ | |||
| 107 | +2x |
-
+ check_scalar(id) |
||
| 43 | +108 | |||
| 44 | +109 |
# if no variables selected, return empty tibble ------------------------------ |
||
| 45 | +110 | 2x |
if (is_empty(variables)) {
|
|
| 46 | +111 | ! |
return(dplyr::tibble()) |
|
| 47 | +112 |
} |
||
| 48 | +113 | ++ | + + | +|
| 114 |
# build ARD ------------------------------------------------------------------ |
|||
| 49 | +115 | 2x |
lapply( |
|
| 50 | +116 | 2x |
variables, |
|
| 51 | +117 | 2x |
function(variable) {
|
|
| 52 | +118 | 2x |
- .format_moodtest_results(+ .format_ttest_results( |
|
| 53 | +119 | 2x |
by = by, |
|
| 54 | +120 | 2x |
variable = variable, |
|
| 55 | +121 | 2x |
lst_tidy = |
|
| 56 | +122 | 2x |
- cards::eval_capture_conditions(+ cards::eval_capture_conditions({
+ |
+ |
| 123 | ++ |
+ # adding this reshape inside the eval, so if there is an error it's captured in the ARD object |
||
| 57 | +124 | 2x |
- stats::mood.test(data[[variable]] ~ data[[by]], ...) |>+ data_wide <- .paired_data_pivot_wider(data, by = by, variable = variable, id = id)+ |
+ |
| 125 | ++ |
+ # perform paired t-test |
||
| 58 | -2x | +126 | +1x | +
+ stats::t.test(x = data_wide[["by1"]], y = data_wide[["by2"]], paired = TRUE, conf.level = conf.level, ...) |>+ |
+
| 127 | +1x |
broom::tidy() |
||
| 59 | +128 |
- ),+ }),+ |
+ ||
| 129 | +2x | +
+ paired = TRUE, |
||
| 60 | +130 |
... |
||
| 61 | +131 |
) |
||
| 62 | +132 |
} |
||
| 63 | +133 |
) |> |
||
| 64 | +134 | 2x |
dplyr::bind_rows() |
|
| 65 | +135 |
} |
||
| 66 | +136 |
- #' Convert mood test results to ARD+ |
||
| 67 | +137 | ++ |
+ #' Convert t-test to ARD+ |
+ |
| 138 |
#' |
|||
| 68 | +139 |
#' @inheritParams cards::tidy_as_ard |
||
| 69 | +140 |
- #' @inheritParams stats::mood.test+ #' @inheritParams stats::t.test |
||
| 70 | +141 |
#' @param by (`string`)\cr by column name |
||
| 71 | +142 |
#' @param variable (`string`)\cr variable column name |
||
| 72 | +143 |
- #' @param ... passed to `mood.test(...)`+ #' @param ... passed to `t.test(...)` |
||
| 73 | +144 |
#' |
||
| 74 | +145 |
#' @return ARD data frame |
||
| 75 | +146 |
#' @keywords internal |
||
| 76 | +147 |
#' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = "broom", reference_pkg = "cardx"))
|
||
| 77 | +148 |
- #' cardx:::.format_moodtest_results(+ #' cardx:::.format_ttest_results( |
||
| 78 | +149 |
- #' by = "SEX",+ #' by = "ARM", |
||
| 79 | +150 |
#' variable = "AGE", |
||
| 80 | +151 | ++ |
+ #' paired = FALSE,+ |
+ |
| 152 |
#' lst_tidy = |
|||
| 81 | +153 |
#' cards::eval_capture_conditions( |
||
| 82 | +154 |
- #' stats::mood.test(ADSL[["AGE"]] ~ ADSL[["SEX"]]) |>+ #' stats::t.test(ADSL[["AGE"]] ~ ADSL[["ARM"]], paired = FALSE) |> |
||
| 83 | +155 |
#' broom::tidy() |
||
| 84 | +156 |
#' ) |
||
| 85 | +157 |
#' ) |
||
| 86 | +158 |
- .format_moodtest_results <- function(by, variable, lst_tidy, ...) {
+ .format_ttest_results <- function(by = NULL, variable, lst_tidy, paired, ...) {
|
||
| 87 | +159 |
# build ARD ------------------------------------------------------------------ |
||
| 88 | -2x | +160 | +8x |
ret <- |
| 89 | -2x | +161 | +8x |
cards::tidy_as_ard( |
| 90 | -2x | +162 | +8x |
lst_tidy = lst_tidy, |
| 91 | -2x | -
- tidy_result_names = c("statistic", "p.value", "method", "alternative"),
- |
- ||
| 92 | -2x | -
- formals = formals(asNamespace("stats")[["mood.test.default"]]),
- |
- ||
| 93 | -2x | -
- passed_args = c(dots_list(...)),- |
- ||
| 94 | -2x | -
- lst_ard_columns = list(group1 = by, variable = variable, context = "stats_mood_test")- |
- ||
| 95 | -- |
- )- |
- ||
| 96 | -- | - - | -||
| 97 | -- |
- # add the stat label ---------------------------------------------------------- |
- ||
| 98 | -2x | -
- ret |>- |
- ||
| 99 | -2x | -
- dplyr::left_join(- |
- ||
| 100 | -2x | -
- .df_moodtest_stat_labels(),- |
- ||
| 101 | -2x | +163 | +8x |
- by = "stat_name"+ tidy_result_names = |
| 102 | -+ | |||
| 164 | +8x |
- ) |>+ c( |
||
| 103 | -2x | +165 | +8x |
- dplyr::mutate(stat_label = dplyr::coalesce(.data$stat_label, .data$stat_name)) |>+ "estimate", "statistic", |
| 104 | -2x | +166 | +8x |
- cards::tidy_ard_column_order()+ "p.value", "parameter", "conf.low", "conf.high", |
| 105 | -+ | |||
| 167 | +8x |
- }+ "method", "alternative" |
||
| 106 | +168 |
-
+ ) |> |
||
| 107 | +169 |
- .df_moodtest_stat_labels <- function() {
+ # add estimate1 and estimate2 if there is a by variable |
||
| 108 | -2x | +170 | +8x |
- dplyr::tribble(+ append(values = switch(!is_empty(by), c("estimate1", "estimate2")), after = 1L), # styler: off
|
| 109 | -2x | +171 | +8x |
- ~stat_name, ~stat_label,+ fun_args_to_record = c("mu", "paired", "var.equal", "conf.level"),
|
| 110 | -2x | +172 | +8x |
- "statistic", "Z-Statistic",+ formals = formals(asNamespace("stats")[["t.test.default"]]),
|
| 111 | -2x | +173 | +8x |
- "p.value", "p-value",+ passed_args = c(list(paired = paired), dots_list(...)), |
| 112 | -2x | +174 | +8x |
- "alternative", "Alternative Hypothesis"+ lst_ard_columns = list(variable = variable, context = "stats_t_test") |
| 113 | +175 |
- )+ ) |
||
| 114 | +176 |
- }+ |
| 1 | -+ | |||
| 177 | +8x |
- #' ARD for Difference in Survival+ if (!is_empty(by)) {
|
||
| 2 | -+ | |||
| 178 | +7x |
- #'+ ret <- ret |> |
||
| 3 | -+ | |||
| 179 | +7x |
- #' @description+ dplyr::mutate(group1 = by) |
||
| 4 | +180 |
- #' Analysis results data for comparison of survival using [survival::survdiff()].+ } |
||
| 5 | +181 |
- #'+ |
||
| 6 | +182 |
- #' @param formula (`formula`)\cr+ # add the stat label --------------------------------------------------------- |
||
| 7 | -+ | |||
| 183 | +8x |
- #' a formula+ ret |> |
||
| 8 | -+ | |||
| 184 | +8x |
- #' @param data (`data.frame`)\cr+ dplyr::left_join( |
||
| 9 | -+ | |||
| 185 | +8x |
- #' a data frame+ .df_ttest_stat_labels(by = by), |
||
| 10 | -+ | |||
| 186 | +8x |
- #' @param rho (`scalar numeric`)\cr+ by = "stat_name" |
||
| 11 | +187 |
- #' numeric scalar passed to `survival::survdiff(rho)`. Default is `rho=0`.+ ) |> |
||
| 12 | -+ | |||
| 188 | +8x |
- #' @param ... additional arguments passed to `survival::survdiff()`+ dplyr::mutate(stat_label = dplyr::coalesce(.data$stat_label, .data$stat_name)) |> |
||
| 13 | -+ | |||
| 189 | +8x |
- #'+ cards::tidy_ard_column_order() |
||
| 14 | +190 |
- #' @return an ARD data frame of class 'card'+ } |
||
| 15 | +191 |
- #' @export+ |
||
| 16 | +192 |
- #'+ |
||
| 17 | +193 |
- #' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = c("survival", "broom", "ggsurvfit"), reference_pkg = "cardx"))
+ #' Convert long paired data to wide |
||
| 18 | +194 |
- #' library(survival)+ #' |
||
| 19 | +195 |
- #' library(ggsurvfit)+ #' |
||
| 20 | +196 |
- #'+ #' @param data (`data.frame`)\cr a data frame that is one line per subject per group |
||
| 21 | +197 |
- #' ard_survival_survdiff(Surv_CNSR(AVAL, CNSR) ~ TRTA, data = cards::ADTTE)+ #' @param by (`string`)\cr by column name |
||
| 22 | +198 |
- ard_survival_survdiff <- function(formula, data, rho = 0, ...) {
- |
- ||
| 23 | -4x | -
- set_cli_abort_call()+ #' @param variable (`string`)\cr variable column name |
||
| 24 | +199 |
-
+ #' @param id (`string`)\cr subject id column name |
||
| 25 | +200 |
- # check installed packages ---------------------------------------------------+ #' |
||
| 26 | -4x | +|||
| 201 | +
- check_pkg_installed(c("survival", "broom"), reference_pkg = "cardx")
+ #' @return a wide data frame |
|||
| 27 | +202 |
-
+ #' @keywords internal |
||
| 28 | +203 |
- # check/process inputs -------------------------------------------------------+ #' @examples |
||
| 29 | -4x | +|||
| 204 | +
- check_not_missing(formula)+ #' cards::ADSL[c("ARM", "AGE")] |>
|
|||
| 30 | -4x | +|||
| 205 | +
- check_class(formula, cls = "formula")+ #' dplyr::filter(ARM %in% c("Placebo", "Xanomeline High Dose")) |>
|
|||
| 31 | -4x | +|||
| 206 | +
- if (!missing(data)) check_class(data, cls = "data.frame")+ #' dplyr::mutate(.by = ARM, USUBJID = dplyr::row_number()) |> |
|||
| 32 | -4x | +|||
| 207 | +
- check_scalar(rho)+ #' dplyr::arrange(USUBJID, ARM) |> |
|||
| 33 | -4x | +|||
| 208 | +
- check_class(rho, cls = "numeric")+ #' cardx:::.paired_data_pivot_wider(by = "ARM", variable = "AGE", id = "USUBJID") |
|||
| 34 | +209 |
-
+ .paired_data_pivot_wider <- function(data, by, variable, id) {
|
||
| 35 | +210 |
- # assign method+ # check the number of levels before pivoting data to wider format |
||
| 36 | -4x | +211 | +9x |
- method <- dplyr::case_when(+ if (dplyr::n_distinct(data[[by]], na.rm = TRUE) != 2L) {
|
| 37 | +212 | 4x |
- rho == 0 ~ "Log-rank test",+ cli::cli_abort("The {.arg by} argument must have two and only two levels.",
|
|
| 38 | +213 | 4x |
- rho == 1.5 ~ "Tarone-Ware test",+ call = get_cli_abort_call() |
|
| 39 | -4x | +|||
| 214 | +
- rho == 1 ~ "Peto & Peto modification of Gehan-Wilcoxon test",+ ) |
|||
| 40 | -4x | +|||
| 215 | +
- .default = glue::glue("G-rho test (\U03C1 = {rho})")
+ } |
|||
| 41 | +216 |
- ) |>+ |
||
| 42 | -4x | +217 | +5x |
- as.character()+ data |> |
| 43 | +218 |
-
+ # arrange data so the first group always appears first |
||
| 44 | -+ | |||
| 219 | +5x |
- # calculate survdiff() results -----------------------------------------------+ dplyr::arrange(.data[[by]]) |> |
||
| 45 | -4x | +220 | +5x |
- lst_glance <-+ tidyr::pivot_wider( |
| 46 | -4x | +221 | +5x |
- cards::eval_capture_conditions(+ id_cols = all_of(id), |
| 47 | -4x | +222 | +5x |
- survival::survdiff(formula = formula, data = data, rho = rho, ...) |>+ names_from = all_of(by), |
| 48 | -4x | +223 | +5x |
- broom::glance() |>+ values_from = all_of(variable)+ |
+
| 224 | ++ |
+ ) |> |
||
| 49 | -4x | +225 | +5x |
- dplyr::mutate(method = .env$method)+ stats::setNames(c(id, "by1", "by2")) |
| 50 | +226 |
- )+ } |
||
| 51 | +227 | |||
| 52 | +228 |
- # tidy results up in an ARD format -------------------------------------------+ .df_ttest_stat_labels <- function(by = NULL) {
|
||
| 53 | -+ | |||
| 229 | +18x |
- # extract variable names from formula+ dplyr::tribble( |
||
| 54 | -4x | +230 | +18x |
- variables <- stats::terms(formula) |>+ ~stat_name, ~stat_label, |
| 55 | -4x | +231 | +18x |
- attr("term.labels") |>
+ "estimate1", "Group 1 Mean", |
| 56 | -4x | +232 | +18x |
- .strip_backticks()+ "estimate2", "Group 2 Mean", |
| 57 | -+ | |||
| 233 | +18x |
-
+ "estimate", ifelse(is_empty(by), "Mean", "Mean Difference"), |
||
| 58 | -+ | |||
| 234 | +18x |
- # if there was an error, return results early+ "p.value", "p-value", |
||
| 59 | -4x | +235 | +18x |
- if (is.null(lst_glance[["result"]])) {
+ "statistic", "t Statistic", |
| 60 | -+ | |||
| 236 | +18x |
- # if no variables in formula, then return an error+ "parameter", "Degrees of Freedom", |
||
| 61 | -+ | |||
| 237 | +18x |
- # otherwise, if we do have variable names, then we can construct an empty ARD which will be done below+ "conf.low", "CI Lower Bound", |
||
| 62 | -2x | +238 | +18x |
- if (is_empty(variables)) {
+ "conf.high", "CI Upper Bound", |
| 63 | -1x | +239 | +18x |
- cli::cli_abort(+ "mu", "H0 Mean", |
| 64 | -1x | +240 | +18x |
- message =+ "paired", "Paired t-test", |
| 65 | -1x | +241 | +18x |
- c("There was an error in {.fun survival::survdiff}. See below:",
+ "var.equal", "Equal Variances", |
| 66 | -1x | +242 | +18x |
- "x" = lst_glance[["error"]]+ "conf.level", "CI Confidence Level", |
| 67 | +243 |
- ),- |
- ||
| 68 | -1x | -
- call = get_cli_abort_call()+ ) |
||
| 69 | +244 |
- )+ } |
| 70 | +1 |
- }+ #' ARD for LS Mean Difference |
||
| 71 | +2 |
- }+ #' |
||
| 72 | +3 |
-
+ #' @description |
||
| 73 | -3x | +|||
| 4 | +
- .variables_to_survdiff_ard(+ #' This function calculates least-squares mean differences using the 'emmeans' |
|||
| 74 | -3x | +|||
| 5 | +
- variables = variables,+ #' package using the following |
|||
| 75 | -3x | +|||
| 6 | +
- method = method,+ #' |
|||
| 76 | +7 |
- # styler: off+ #' ```r |
||
| 77 | -3x | +|||
| 8 | +
- stat_names =+ #' emmeans::emmeans(object = <regression model>, specs = ~ <primary covariate>) |> |
|||
| 78 | -3x | +|||
| 9 | +
- if (!is.null(lst_glance[["result"]])) names(lst_glance[["result"]])+ #' emmeans::contrast(method = "pairwise") |> |
|||
| 79 | -3x | +|||
| 10 | +
- else c("statistic", "df", "p.value", "method"),
+ #' summary(infer = TRUE, level = <confidence level>) |
|||
| 80 | -3x | +|||
| 11 | +
- stats =+ #' ``` |
|||
| 81 | -3x | +|||
| 12 | +
- if (!is.null(lst_glance[["result"]])) unname(as.list(lst_glance[["result"]]))+ #' |
|||
| 82 | -3x | +|||
| 13 | +
- else rep_along(c("statistic", "df", "p.value"), list(NULL)) |> c(list(method = method))
+ #' The arguments `data`, `formula`, `method`, `method.args`, `package` are used |
|||
| 83 | +14 |
- # styler: on+ #' to construct the regression model via `cardx::construct_model()`. |
||
| 84 | +15 |
- ) |>+ #' |
||
| 85 | -3x | +|||
| 16 | +
- .add_survdiff_stat_labels() |>+ #' @param data (`data.frame`/`survey.design`)\cr |
|||
| 86 | -3x | +|||
| 17 | +
- dplyr::mutate(+ #' a data frame or survey design object |
|||
| 87 | -3x | +|||
| 18 | +
- context = "survival_survdiff",+ #' @inheritParams construct_model |
|||
| 88 | -3x | +|||
| 19 | +
- warning = lst_glance["warning"],+ #' @param response_type (`string`) |
|||
| 89 | -3x | +|||
| 20 | +
- error = lst_glance["error"],+ #' string indicating whether the model outcome is `'continuous'` |
|||
| 90 | -3x | +|||
| 21 | +
- fmt_fn = map(+ #' or `'dichotomous'`. When `'dichotomous'`, the call to `emmeans::emmeans()` is |
|||
| 91 | -3x | +|||
| 22 | +
- .data$stat,+ #' supplemented with argument `regrid="response"`. |
|||
| 92 | -3x | +|||
| 23 | +
- function(x) {
+ #' @param conf.level (scalar `numeric`)\cr |
|||
| 93 | -6x | +|||
| 24 | +
- if (is.numeric(x)) return(1L) # styler: off+ #' confidence level for confidence interval. Default is `0.95`. |
|||
| 94 | -6x | +|||
| 25 | +
- NULL+ #' @param primary_covariate (`string`)\cr |
|||
| 95 | +26 |
- }+ #' string indicating the primary covariate (typically the dichotomous treatment variable). |
||
| 96 | +27 |
- )+ #' Default is the first covariate listed in the formula. |
||
| 97 | +28 |
- ) |>+ #' |
||
| 98 | -3x | +|||
| 29 | +
- cards::tidy_ard_column_order() %>%+ #' @return ARD data frame |
|||
| 99 | -3x | +|||
| 30 | +
- {structure(., class = c("card", class(.)))} # styler: off
+ #' @export |
|||
| 100 | +31 |
- }+ #' |
||
| 101 | +32 |
-
+ #' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = "emmeans", reference_pkg = "cardx"))
|
||
| 102 | +33 |
- .variables_to_survdiff_ard <- function(variables,+ #' ard_emmeans_mean_difference( |
||
| 103 | +34 |
- method,+ #' data = mtcars, |
||
| 104 | +35 |
- stat_names,+ #' formula = mpg ~ am + cyl, |
||
| 105 | +36 |
- stats) {
+ #' method = "lm" |
||
| 106 | -3x | +|||
| 37 | +
- len <- length(variables)+ #' ) |
|||
| 107 | +38 |
-
+ #' |
||
| 108 | -3x | +|||
| 39 | +
- df_vars <- dplyr::tibble(!!!rev(variables)) |>+ #' ard_emmeans_mean_difference( |
|||
| 109 | -3x | +|||
| 40 | +
- set_names(+ #' data = mtcars, |
|||
| 110 | -3x | +|||
| 41 | +
- ifelse(+ #' formula = vs ~ am + mpg, |
|||
| 111 | -3x | +|||
| 42 | +
- len > 1L,+ #' method = "glm", |
|||
| 112 | -3x | +|||
| 43 | +
- c(paste0("group_", rev(seq_len(len - 1L))), "variable"),
+ #' method.args = list(family = binomial), |
|||
| 113 | -3x | +|||
| 44 | +
- "variable"+ #' response_type = "dichotomous" |
|||
| 114 | +45 |
- )+ #' ) |
||
| 115 | +46 |
- )+ ard_emmeans_mean_difference <- function(data, formula, method, |
||
| 116 | +47 |
-
+ method.args = list(), |
||
| 117 | -3x | +|||
| 48 | +
- dplyr::bind_cols(+ package = "base", |
|||
| 118 | -3x | +|||
| 49 | +
- df_vars,+ response_type = c("continuous", "dichotomous"),
|
|||
| 119 | -3x | +|||
| 50 | +
- dplyr::tibble(+ conf.level = 0.95, |
|||
| 120 | -3x | +|||
| 51 | +
- stat_name = .env$stat_names,+ primary_covariate = |
|||
| 121 | -3x | +|||
| 52 | +
- stat = .env$stats+ stats::terms(formula) |> |
|||
| 122 | +53 |
- )+ attr("term.labels") |>
|
||
| 123 | +54 |
- )+ getElement(1L)) {
|
||
| 124 | -+ | |||
| 55 | +3x |
- }+ set_cli_abort_call() |
||
| 125 | +56 | |||
| 126 | +57 |
- .add_survdiff_stat_labels <- function(x) {
+ # check package installation ------------------------------------------------- |
||
| 127 | +58 | 3x |
- x |>+ check_pkg_installed(c("emmeans", package), reference_pkg = "cardx")
|
|
| 128 | +59 | 3x |
- dplyr::left_join(+ check_not_missing(data) |
|
| 129 | +60 | 3x |
- dplyr::tribble(+ check_not_missing(formula) |
|
| 130 | +61 | 3x |
- ~stat_name, ~stat_label,+ check_not_missing(method) |
|
| 131 | +62 | 3x |
- "statistic", "X^2 Statistic",+ check_class(data, c("data.frame", "survey.design"))
|
|
| 132 | +63 | 3x |
- "df", "Degrees of Freedom",+ check_class(formula, cls = "formula") |
|
| 133 | +64 | 3x |
- "p.value", "p-value"+ check_string(package) |
|
| 134 | -+ | |||
| 65 | +3x |
- ),+ check_string(primary_covariate) |
||
| 135 | +66 | 3x |
- by = "stat_name"+ check_scalar(conf.level) |
|
| 136 | -+ | |||
| 67 | +3x |
- ) |>+ check_range(conf.level, range = c(0, 1)) |
||
| 137 | +68 | 3x |
- dplyr::mutate(stat_label = dplyr::coalesce(.data$stat_label, .data$stat_name))+ response_type <- arg_match(response_type, error_call = get_cli_abort_call()) |
|
| 138 | +69 |
- }+ |
||
| 139 | +70 |
-
+ # construct primary model ---------------------------------------------------- |
||
| 140 | -+ | |||
| 71 | +3x |
- .strip_backticks <- function(x) {
+ mod <- |
||
| 141 | -4x | +72 | +3x |
- ifelse(+ construct_model( |
| 142 | -4x | +73 | +3x |
- str_detect(x, "^`.*`$"),+ data = data, formula = formula, method = method, |
| 143 | -4x | +74 | +3x |
- substr(x, 2, nchar(x) - 1),+ method.args = {{ method.args }},
|
| 144 | -4x | +75 | +3x |
- x+ package = package, env = caller_env() |
| 145 | +76 |
- )+ ) |
||
| 146 | +77 |
- }+ |
| 1 | +78 |
- #' ARD 2-sample proportion test+ # emmeans -------------------------------------------------------------------- |
||
| 2 | -+ | |||
| 79 | +3x |
- #'+ emmeans_args <- list(object = mod, specs = reformulate2(primary_covariate)) |
||
| 3 | -+ | |||
| 80 | +2x |
- #' @description+ if (response_type %in% "dichotomous") emmeans_args <- c(emmeans_args, list(regrid = "response")) |
||
| 4 | -+ | |||
| 81 | +3x |
- #' Analysis results data for a 2-sample test or proportions using [`stats::prop.test()`].+ emmeans <- |
||
| 5 | -+ | |||
| 82 | +3x |
- #'+ withr::with_namespace( |
||
| 6 | -+ | |||
| 83 | +3x |
- #' @param data (`data.frame`)\cr+ package = "emmeans", |
||
| 7 | -+ | |||
| 84 | +3x |
- #' a data frame.+ code = do.call("emmeans", args = emmeans_args)
|
||
| 8 | +85 |
- #' @param by ([`tidy-select`][dplyr::dplyr_tidy_select])\cr+ ) |
||
| 9 | +86 |
- #' column name to compare by+ + |
+ ||
| 87 | +3x | +
+ df_results <- |
||
| 10 | -+ | |||
| 88 | +3x |
- #' @param variables ([`tidy-select`][dplyr::dplyr_tidy_select])\cr+ emmeans |> |
||
| 11 | -+ | |||
| 89 | +3x |
- #' column names to be compared. Must be a binary column coded as `TRUE`/`FALSE`+ emmeans::contrast(method = "pairwise") |> |
||
| 12 | -+ | |||
| 90 | +3x |
- #' or `1`/`0`. Independent tests will be computed for each variable.+ summary(infer = TRUE, level = conf.level) |
||
| 13 | +91 |
- #' @param conf.level (scalar `numeric`)\cr+ |
||
| 14 | +92 |
- #' confidence level for confidence interval. Default is `0.95`.+ # convert results to ARD format ---------------------------------------------- |
||
| 15 | -+ | |||
| 93 | +3x |
- #' @param ... arguments passed to `prop.test(...)`+ df_results |> |
||
| 16 | -+ | |||
| 94 | +3x |
- #'+ dplyr::as_tibble() |> |
||
| 17 | -+ | |||
| 95 | +3x |
- #' @return ARD data frame+ dplyr::rename( |
||
| 18 | -+ | |||
| 96 | +3x |
- #' @export+ conf.low = any_of("asymp.LCL"),
|
||
| 19 | -+ | |||
| 97 | +3x |
- #'+ conf.high = any_of("asymp.UCL"),
|
||
| 20 | -+ | |||
| 98 | +3x |
- #' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = "broom", reference_pkg = "cardx"))
+ conf.low = any_of("lower.CL"),
|
||
| 21 | -+ | |||
| 99 | +3x |
- #' mtcars |>+ conf.high = any_of("upper.CL")
|
||
| 22 | +100 |
- #' ard_stats_prop_test(by = vs, variables = am)+ ) %>% |
||
| 23 | -+ | |||
| 101 | +3x |
- ard_stats_prop_test <- function(data, by, variables, conf.level = 0.95, ...) {
+ dplyr::select( |
||
| 24 | -5x | +102 | +3x |
- set_cli_abort_call()+ variable_level = "contrast", |
| 25 | -+ | |||
| 103 | +3x |
-
+ "estimate", |
||
| 26 | -+ | |||
| 104 | +3x |
- # check installed packages ---------------------------------------------------+ std.error = "SE", "df", |
||
| 27 | -5x | +105 | +3x |
- check_pkg_installed(pkg = "broom", reference_pkg = "cardx")+ "conf.low", "conf.high", "p.value" |
| 28 | +106 |
-
+ ) %>% |
||
| 29 | -+ | |||
| 107 | +3x |
- # check inputs ---------------------------------------------------------------+ dplyr::mutate( |
||
| 30 | -5x | +108 | +3x |
- check_not_missing(data)+ conf.level = .env$conf.level, |
| 31 | -5x | +109 | +3x |
- check_not_missing(variables)+ method = |
| 32 | -5x | +110 | +3x |
- check_not_missing(by)+ ifelse( |
| 33 | -5x | +111 | +3x |
- check_data_frame(data)+ length(attr(stats::terms(formula), "term.labels") |> discard(~ startsWith(., "1 |"))) == 1L, |
| 34 | -5x | +112 | +3x |
- check_range(conf.level, range = c(0, 1))+ "Least-squares mean difference", |
| 35 | -+ | |||
| 113 | +3x |
-
+ "Least-squares adjusted mean difference" |
||
| 36 | +114 |
- # process inputs -------------------------------------------------------------+ ), |
||
| 37 | -5x | +115 | +3x |
- cards::process_selectors(data, by = {{ by }}, variables = {{ variables }})
+ across(everything(), as.list), |
| 38 | -5x | +116 | +3x |
- check_scalar(by)+ variable = "contrast", |
| 39 | -5x | +117 | +3x |
- data <- data[c(by, variables)] |> dplyr::ungroup() |> tidyr::drop_na() # styler: off+ group1 = .env$primary_covariate |
| 40 | +118 |
-
+ ) |> |
||
| 41 | -+ | |||
| 119 | +3x |
- # if no variables selected, return empty tibble ------------------------------+ tidyr::pivot_longer( |
||
| 42 | -5x | +120 | +3x |
- if (is_empty(variables)) {
+ cols = -c("group1", "variable", "variable_level"),
|
| 43 | -! | +|||
| 121 | +3x |
- return(dplyr::tibble())+ names_to = "stat_name", |
||
| 44 | -+ | |||
| 122 | +3x |
- }+ values_to = "stat" |
||
| 45 | +123 |
-
+ ) |> |
||
| 46 | -+ | |||
| 124 | +3x |
- # build ARD ------------------------------------------------------------------+ dplyr::left_join(.df_ttest_stat_labels(primary_covariate), by = "stat_name") |> |
||
| 47 | -5x | +125 | +3x |
- lapply(+ dplyr::mutate( |
| 48 | -5x | +126 | +3x |
- variables,+ context = "emmeans_mean_difference", |
| 49 | -5x | +127 | +3x |
- function(variable) {
+ stat_label = dplyr::coalesce(.data$stat_label, .data$stat_name), |
| 50 | -6x | +128 | +3x |
- .format_proptest_results(+ warning = list(NULL), |
| 51 | -6x | +129 | +3x |
- by = by,+ error = list(NULL), |
| 52 | -6x | +130 | +3x |
- variable = variable,+ fmt_fn = map(.data$stat, \(.x) if (is.numeric(.x)) 1L else NULL) # styler: off |
| 53 | -6x | +|||
| 131 | +
- lst_tidy =+ ) |> |
|||
| 54 | -6x | +132 | +3x |
- cards::eval_capture_conditions({
+ cards::tidy_ard_column_order() %>% |
| 55 | -6x | +133 | +3x |
- check_binary(data[[variable]], arg_name = "variable")+ {structure(., class = c("card", class(.)))} # styler: off
|
| 56 | +134 |
-
+ } |
||
| 57 | -3x | +
| 1 | +
- data_counts <-+ #' ARD McNemar's Test |
|||
| 58 | -3x | +|||
| 2 | +
- dplyr::arrange(data, .data[[by]]) |>+ #' |
|||
| 59 | -3x | +|||
| 3 | +
- dplyr::summarise(+ #' @description |
|||
| 60 | -3x | +|||
| 4 | +
- .by = all_of(by),+ #' Analysis results data for McNemar's statistical test. |
|||
| 61 | -3x | +|||
| 5 | +
- x = sum(.data[[variable]]),+ #' We have two functions depending on the structure of the data. |
|||
| 62 | -3x | +|||
| 6 | +
- n = length(.data[[variable]])+ #' - `ard_stats_mcnemar_test()` is the structure expected by [`stats::mcnemar.test()`] |
|||
| 63 | +7 |
- )+ #' - `ard_stats_mcnemar_test_long()` is one row per ID per group |
||
| 64 | +8 |
-
+ #' |
||
| 65 | -3x | +|||
| 9 | +
- if (nrow(data_counts) != 2) {
+ #' @param data (`data.frame`)\cr |
|||
| 66 | -1x | +|||
| 10 | +
- cli::cli_abort(+ #' a data frame. See below for details. |
|||
| 67 | -1x | +|||
| 11 | +
- c(+ #' @param by ([`tidy-select`][dplyr::dplyr_tidy_select])\cr |
|||
| 68 | -1x | +|||
| 12 | +
- "The {.arg by} column must have exactly 2 levels.",
+ #' column name to compare by. |
|||
| 69 | -1x | +|||
| 13 | +
- "The levels are {.val {data_counts[[by]]}}"
+ #' @param variables ([`tidy-select`][dplyr::dplyr_tidy_select])\cr |
|||
| 70 | +14 |
- ),+ #' column names to be compared. Independent tests will |
||
| 71 | -1x | +|||
| 15 | +
- call = get_cli_abort_call()+ #' be computed for each variable. |
|||
| 72 | +16 |
- )+ #' @param ... arguments passed to `stats::mcnemar.test(...)` |
||
| 73 | +17 |
- }+ #' @param id ([`tidy-select`][dplyr::dplyr_tidy_select])\cr |
||
| 74 | +18 |
-
+ #' column name of the subject or participant ID |
||
| 75 | -2x | +|||
| 19 | +
- stats::prop.test(+ #' |
|||
| 76 | -2x | +|||
| 20 | +
- x = data_counts[["x"]],+ #' @return ARD data frame |
|||
| 77 | -2x | +|||
| 21 | +
- n = data_counts[["n"]],+ #' @name ard_stats_mcnemar_test |
|||
| 78 | -2x | +|||
| 22 | +
- conf.level = conf.level,+ #' |
|||
| 79 | +23 |
- ...+ #' @details |
||
| 80 | +24 |
- ) |>+ #' For the `ard_stats_mcnemar_test()` function, the data is expected to be one row per subject. |
||
| 81 | -2x | +|||
| 25 | +
- broom::tidy() |>+ #' The data is passed as `stats::mcnemar.test(x = data[[variable]], y = data[[by]], ...)`.+ |
+ |||
| 26 | ++ |
+ #' Please use `table(x = data[[variable]], y = data[[by]])` to check the contingency table.+ |
+ ||
| 27 | ++ |
+ #'+ |
+ ||
| 28 | ++ |
+ #' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = "broom", reference_pkg = "cardx"))
+ |
+ ||
| 29 | ++ |
+ #' cards::ADSL |> |
||
| 82 | +30 |
- # add central estimate for difference+ #' ard_stats_mcnemar_test(by = "SEX", variables = "EFFFL") |
||
| 83 | -2x | +|||
| 31 | +
- dplyr::mutate(estimate = .data$estimate1 - .data$estimate2, .before = 1L)+ #' |
|||
| 84 | +32 |
- }),+ #' set.seed(1234) |
||
| 85 | +33 |
- ...+ #' cards::ADSL[c("USUBJID", "TRT01P")] |>
|
||
| 86 | +34 |
- )+ #' dplyr::mutate(TYPE = "PLANNED") |> |
||
| 87 | +35 |
- }+ #' dplyr::rename(TRT01 = TRT01P) %>% |
||
| 88 | +36 |
- ) |>+ #' dplyr::bind_rows(dplyr::mutate(., TYPE = "ACTUAL", TRT01 = sample(TRT01))) |> |
||
| 89 | -5x | +|||
| 37 | +
- dplyr::bind_rows()+ #' ard_stats_mcnemar_test_long( |
|||
| 90 | +38 |
- }+ #' by = TYPE, |
||
| 91 | +39 |
-
+ #' variable = TRT01, |
||
| 92 | +40 |
-
+ #' id = USUBJID |
||
| 93 | +41 |
- #' Convert prop.test to ARD+ #' ) |
||
| 94 | +42 |
- #'+ NULL |
||
| 95 | +43 |
- #' @inheritParams cards::tidy_as_ard+ |
||
| 96 | +44 |
- #' @param by (`string`)\cr by column name+ #' @rdname ard_stats_mcnemar_test |
||
| 97 | +45 |
- #' @param variable (`string`)\cr variable column name+ #' @export |
||
| 98 | +46 |
- #' @param ... passed to `prop.test(...)`+ ard_stats_mcnemar_test <- function(data, by, variables, ...) {
|
||
| 99 | -+ | |||
| 47 | +6x |
- #'+ set_cli_abort_call() |
||
| 100 | +48 |
- #' @return ARD data frame+ |
||
| 101 | +49 |
- #' @keywords internal+ # check installed packages ---------------------------------------------------+ |
+ ||
| 50 | +6x | +
+ check_pkg_installed("broom", reference_pkg = "cardx")
|
||
| 102 | +51 |
- .format_proptest_results <- function(by, variable, lst_tidy, ...) {
+
|
||
| 103 | +52 |
- # build ARD ------------------------------------------------------------------+ # check/process inputs ------------------------------------------------------- |
||
| 104 | +53 | 6x |
- ret <-+ check_not_missing(data) |
|
| 105 | +54 | 6x |
- cards::tidy_as_ard(+ check_not_missing(variables) |
|
| 106 | +55 | 6x |
- lst_tidy = lst_tidy,+ check_not_missing(by) |
|
| 107 | +56 | 6x |
- tidy_result_names = c(+ check_data_frame(data) |
|
| 108 | +57 | 6x |
- "estimate", "estimate1", "estimate2", "statistic",+ data <- dplyr::ungroup(data) |
|
| 109 | +58 | 6x |
- "p.value", "parameter", "conf.low", "conf.high",+ cards::process_selectors(data, by = {{ by }}, variables = {{ variables }})
|
|
| 110 | +59 | 6x |
- "method", "alternative"+ check_scalar(by) |
|
| 111 | +60 |
- ),+ + |
+ ||
| 61 | ++ |
+ # if no variables selected, return empty tibble ------------------------------ |
||
| 112 | +62 | 6x |
- fun_args_to_record = c("p", "conf.level", "correct"),
+ if (is_empty(variables)) {
+ |
+ |
| 63 | +! | +
+ return(dplyr::tibble())+ |
+ ||
| 64 | ++ |
+ }+ |
+ ||
| 65 | ++ |
+ # build ARD ------------------------------------------------------------------ |
||
| 113 | +66 | 6x |
- formals = formals(stats::prop.test),+ lapply( |
|
| 114 | +67 | 6x |
- passed_args = dots_list(...),+ variables, |
|
| 115 | +68 | 6x |
- lst_ard_columns = list(group1 = by, variable = variable, context = "stats_prop_test")+ function(variable) {
|
|
| 116 | -+ | |||
| 69 | +7x |
- )+ .format_mcnemartest_results( |
||
| 117 | -+ | |||
| 70 | +7x |
-
+ by = by, |
||
| 118 | -+ | |||
| 71 | +7x |
- # add the stat label ---------------------------------------------------------+ variable = variable, |
||
| 119 | -6x | +72 | +7x |
- ret |>+ lst_tidy = |
| 120 | -6x | +73 | +7x |
- dplyr::left_join(+ cards::eval_capture_conditions( |
| 121 | -6x | +74 | +7x |
- .df_proptest_stat_labels(),+ stats::mcnemar.test(x = data[[variable]], y = data[[by]], ...) |> |
| 122 | -6x | +75 | +7x |
- by = "stat_name"+ broom::tidy() |
| 123 | +76 |
- ) |>+ ), |
||
| 124 | -6x | +|||
| 77 | +
- dplyr::mutate(stat_label = dplyr::coalesce(.data$stat_label, .data$stat_name)) |>+ ...+ |
+ |||
| 78 | ++ |
+ )+ |
+ ||
| 79 | ++ |
+ }+ |
+ ||
| 80 | ++ |
+ ) |> |
||
| 125 | +81 | 6x |
- cards::tidy_ard_column_order()+ dplyr::bind_rows() |
|
| 126 | +82 |
} |
||
| 127 | +83 | |||
| 128 | +84 |
- .df_proptest_stat_labels <- function() {
+ #' @rdname ard_stats_mcnemar_test |
||
| 129 | -6x | +|||
| 85 | +
- dplyr::tribble(+ #' @export+ |
+ |||
| 86 | ++ |
+ ard_stats_mcnemar_test_long <- function(data, by, variables, id, ...) {
|
||
| 130 | -6x | +87 | +1x |
- ~stat_name, ~stat_label,+ set_cli_abort_call()+ |
+
| 88 | ++ | + + | +||
| 89 | ++ |
+ # check installed packages --------------------------------------------------- |
||
| 131 | -6x | +90 | +1x |
- "estimate1", "Group 1 Rate",+ check_pkg_installed("broom", reference_pkg = "cardx")
+ |
+
| 91 | ++ | + + | +||
| 92 | ++ |
+ # check/process inputs ------------------------------------------------------- |
||
| 132 | -6x | +93 | +1x |
- "estimate2", "Group 2 Rate",+ check_not_missing(data) |
| 133 | -6x | +94 | +1x |
- "estimate", "Rate Difference",+ check_not_missing(variables) |
| 134 | -6x | +95 | +1x |
- "p.value", "p-value",+ check_not_missing(by) |
| 135 | -6x | +96 | +1x |
- "statistic", "X-squared Statistic",+ check_not_missing(id) |
| 136 | -6x | +97 | +1x |
- "parameter", "Degrees of Freedom",+ check_data_frame(data) |
| 137 | -6x | +98 | +1x |
- "conf.low", "CI Lower Bound",+ data <- dplyr::ungroup(data) |
| 138 | -6x | +99 | +1x |
- "conf.high", "CI Upper Bound",+ cards::process_selectors(data, by = {{ by }}, variables = {{ variables }}, id = {{ id }})
|
| 139 | -6x | +100 | +1x |
- "conf.level", "CI Confidence Level",+ check_scalar(by) |
| 140 | -6x | +101 | +1x |
- "correct", "Yates' continuity correction",+ check_scalar(id) |
| 141 | +102 |
- )+ |
||
| 142 | +103 |
- }+ # if no variables selected, return empty tibble ------------------------------ |
| 1 | -+ | |||
| 104 | +1x |
- #' ARD Continuous Survey Statistics+ if (is_empty(variables)) {
|
||
| 2 | -+ | |||
| 105 | +! |
- #'+ return(dplyr::tibble()) |
||
| 3 | +106 |
- #' Returns an ARD of weighted statistics using the `{survey}` package.
+ } |
||
| 4 | +107 |
- #'+ # build ARD ------------------------------------------------------------------ |
||
| 5 | -+ | |||
| 108 | +1x |
- #' @param data (`survey.design`)\cr+ lapply( |
||
| 6 | -+ | |||
| 109 | +1x |
- #' a design object often created with [`survey::svydesign()`].+ variables, |
||
| 7 | -+ | |||
| 110 | +1x |
- #' @param variables ([`tidy-select`][dplyr::dplyr_tidy_select])\cr+ function(variable) {
|
||
| 8 | -+ | |||
| 111 | +1x |
- #' columns to include in summaries.+ .format_mcnemartest_results( |
||
| 9 | -+ | |||
| 112 | +1x |
- #' @param by ([`tidy-select`][dplyr::dplyr_tidy_select])\cr+ by = by,+ |
+ ||
| 113 | +1x | +
+ variable = variable,+ |
+ ||
| 114 | +1x | +
+ lst_tidy =+ |
+ ||
| 115 | +1x | +
+ cards::eval_capture_conditions({
|
||
| 10 | +116 |
- #' results are calculated for **all combinations** of the columns specified,+ # adding this reshape inside the eval, so if there is an error it's captured in the ARD object+ |
+ ||
| 117 | +1x | +
+ data_wide <- .paired_data_pivot_wider(data, by = by, variable = variable, id = id) |
||
| 11 | +118 |
- #' including unobserved combinations and unobserved factor levels.+ # performing McNemars test+ |
+ ||
| 119 | +1x | +
+ stats::mcnemar.test(x = data_wide[["by1"]], y = data_wide[["by2"]], ...) |>+ |
+ ||
| 120 | +1x | +
+ broom::tidy() |
||
| 12 | +121 |
- #' @param statistic ([`formula-list-selector`][syntax])\cr+ }), |
||
| 13 | +122 |
- #' a named list, a list of formulas,+ ... |
||
| 14 | +123 |
- #' or a single formula where the list element is a character vector of+ ) |
||
| 15 | +124 |
- #' statistic names to include. See below for options.+ } |
||
| 16 | +125 |
- #' @param fmt_fn ([`formula-list-selector`][syntax])\cr+ ) |> |
||
| 17 | -+ | |||
| 126 | +1x |
- #' a named list, a list of formulas,+ dplyr::bind_rows() |
||
| 18 | +127 |
- #' or a single formula where the list element is a named list of functions+ } |
||
| 19 | +128 |
- #' (or the RHS of a formula),+ |
||
| 20 | +129 |
- #' e.g. `list(mpg = list(mean = \(x) round(x, digits = 2) |> as.character))`.+ #' Convert McNemar's test to ARD |
||
| 21 | +130 |
- #' @param stat_label ([`formula-list-selector`][syntax])\cr+ #' |
||
| 22 | +131 |
- #' a named list, a list of formulas, or a single formula where+ #' @inheritParams cards::tidy_as_ard |
||
| 23 | +132 |
- #' the list element is either a named list or a list of formulas defining the+ #' @inheritParams stats::mcnemar.test |
||
| 24 | +133 |
- #' statistic labels, e.g. `everything() ~ list(mean = "Mean", sd = "SD")` or+ #' @param by (`string`)\cr by column name |
||
| 25 | +134 |
- #' `everything() ~ list(mean ~ "Mean", sd ~ "SD")`.+ #' @param variable (`string`)\cr variable column name |
||
| 26 | +135 |
- #' @inheritParams rlang::args_dots_empty+ #' @param ... passed to `stats::mcnemar.test(...)` |
||
| 27 | +136 |
#' |
||
| 28 | +137 |
- #' @section statistic argument:+ #' @return ARD data frame |
||
| 29 | +138 |
#' |
||
| 30 | -- |
- #' The following statistics are available:- |
- ||
| 31 | +139 |
- #' `r cardx:::accepted_svy_stats(FALSE) |> shQuote("sh") |> paste(collapse = ", ")`,
+ #' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = "broom", reference_pkg = "cardx"))
|
||
| 32 | +140 |
- #' where 'p##' is are the percentiles and `##` is an integer between 0 and 100.+ #' cardx:::.format_mcnemartest_results( |
||
| 33 | +141 |
- #'+ #' by = "ARM", |
||
| 34 | +142 |
- #'+ #' variable = "AGE", |
||
| 35 | +143 |
- #' @return an ARD data frame of class 'card'+ #' lst_tidy = |
||
| 36 | +144 |
- #' @export+ #' cards::eval_capture_conditions( |
||
| 37 | +145 |
- #'+ #' stats::mcnemar.test(cards::ADSL[["SEX"]], cards::ADSL[["EFFFL"]]) |> |
||
| 38 | +146 |
- #' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = "survey", reference_pkg = "cardx"))
+ #' broom::tidy() |
||
| 39 | +147 |
- #' data(api, package = "survey")+ #' ) |
||
| 40 | +148 |
- #' dclus1 <- survey::svydesign(id = ~dnum, weights = ~pw, data = apiclus1, fpc = ~fpc)+ #' ) |
||
| 41 | +149 |
#' |
||
| 42 | +150 |
- #' ard_continuous(+ #' @keywords internal |
||
| 43 | +151 |
- #' data = dclus1,+ .format_mcnemartest_results <- function(by, variable, lst_tidy, ...) {
|
||
| 44 | +152 |
- #' variables = api00,+ # build ARD ------------------------------------------------------------------ |
||
| 45 | -+ | |||
| 153 | +8x |
- #' by = stype+ ret <- |
||
| 46 | -+ | |||
| 154 | +8x |
- #' )+ cards::tidy_as_ard( |
||
| 47 | -+ | |||
| 155 | +8x |
- ard_continuous.survey.design <- function(data, variables, by = NULL,+ lst_tidy = lst_tidy, |
||
| 48 | -+ | |||
| 156 | +8x |
- statistic = everything() ~ c("median", "p25", "p75"),
+ tidy_result_names = c("statistic", "p.value", "method"),
|
||
| 49 | -+ | |||
| 157 | +8x |
- fmt_fn = NULL,+ fun_args_to_record = c("correct"),
|
||
| 50 | -+ | |||
| 158 | +8x |
- stat_label = NULL,+ formals = formals(asNamespace("stats")[["mcnemar.test"]]),
|
||
| 51 | -+ | |||
| 159 | +8x |
- ...) {
+ passed_args = dots_list(...), |
||
| 52 | -10x | +160 | +8x |
- set_cli_abort_call()+ lst_ard_columns = list(group1 = by, variable = variable, context = "stats_mcnemar_test") |
| 53 | -10x | +|||
| 161 | +
- check_dots_empty()+ ) |
|||
| 54 | +162 | |||
| 55 | +163 |
- # check installed packages ---------------------------------------------------+ # add the stat label --------------------------------------------------------- |
||
| 56 | -10x | +164 | +8x |
- check_pkg_installed(pkg = "survey", reference_pkg = "cardx")+ ret |> |
| 57 | -+ | |||
| 165 | +8x |
-
+ dplyr::left_join( |
||
| 58 | -+ | |||
| 166 | +8x |
- # check inputs ---------------------------------------------------------------+ .df_mcnemar_stat_labels(), |
||
| 59 | -10x | +167 | +8x |
- check_not_missing(variables)+ by = "stat_name" |
| 60 | +168 |
-
+ ) |> |
||
| 61 | -+ | |||
| 169 | +8x |
- # process inputs -------------------------------------------------------------+ dplyr::mutate(stat_label = dplyr::coalesce(.data$stat_label, .data$stat_name)) |> |
||
| 62 | -10x | +170 | +8x |
- cards::process_selectors(data$variables, variables = {{ variables }}, by = {{ by }})
+ cards::tidy_ard_column_order() |
| 63 | -10x | +|||
| 171 | +
- variables <- setdiff(variables, by)+ } |
|||
| 64 | -10x | +|||
| 172 | +
- check_na_factor_levels(data$variables, by)+ |
|||
| 65 | +173 |
-
+ .df_mcnemar_stat_labels <- function() {
|
||
| 66 | -10x | +174 | +8x |
- cards::process_formula_selectors(+ dplyr::tribble( |
| 67 | -10x | +175 | +8x |
- data$variables[variables],+ ~stat_name, ~stat_label, |
| 68 | -10x | +176 | +8x |
- statistic = statistic,+ "statistic", "X-squared Statistic", |
| 69 | -10x | +177 | +8x |
- fmt_fn = fmt_fn,+ "parameter", "Degrees of Freedom", |
| 70 | -10x | +178 | +8x |
- stat_label = stat_label+ "p.value", "p-value", |
| 71 | +179 |
) |
||
| 72 | -10x | +|||
| 180 | +
- cards::fill_formula_selectors(+ } |
|||
| 73 | -10x | +
| 1 | +
- data$variables[variables],+ #' ARD survey categorical CIs |
|||
| 74 | -10x | +|||
| 2 | +
- statistic = formals(asNamespace("cardx")[["ard_continuous.survey.design"]])[["statistic"]] |> eval()
+ #' |
|||
| 75 | +3 |
- )+ #' Confidence intervals for categorical variables calculated via |
||
| 76 | -10x | +|||
| 4 | +
- cards::check_list_elements(+ #' [`survey::svyciprop()`]. |
|||
| 77 | -10x | +|||
| 5 | +
- x = statistic,+ #' |
|||
| 78 | -10x | +|||
| 6 | +
- predicate = \(x) all(x %in% accepted_svy_stats()),+ #' @inheritParams ard_continuous.survey.design |
|||
| 79 | -10x | +|||
| 7 | +
- error_msg = c("Error in the values of the {.arg statistic} argument for variable {.val {variable}}.",
+ #' @param method (`string`)\cr |
|||
| 80 | -10x | +|||
| 8 | +
- i = "Values must be in {.val {cardx:::accepted_svy_stats(FALSE)}}"
+ #' Method passed to `survey::svyciprop(method)` |
|||
| 81 | +9 |
- )+ #' @param conf.level (scalar `numeric`)\cr |
||
| 82 | +10 |
- )+ #' confidence level for confidence interval. Default is `0.95`. |
||
| 83 | +11 |
-
+ #' @param df (`numeric`)\cr |
||
| 84 | +12 |
- # return empty tibble if no variables selected -------------------------------+ #' denominator degrees of freedom, passed to `survey::svyciprop(df)`. |
||
| 85 | -10x | +|||
| 13 | +
- if (is_empty(variables)) {
+ #' Default is `survey::degf(data)`. |
|||
| 86 | -! | +|||
| 14 | +
- return(dplyr::tibble())+ #' @param ... arguments passed to `survey::svyciprop()` |
|||
| 87 | +15 |
- }+ #' |
||
| 88 | +16 |
-
+ #' @return ARD data frame |
||
| 89 | +17 |
- # compute the weighted statistics --------------------------------------------+ #' @export |
||
| 90 | -10x | +|||
| 18 | +
- df_stats <-+ #' |
|||
| 91 | -10x | +|||
| 19 | +
- map(+ #' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = "survey", reference_pkg = "cardx"))
|
|||
| 92 | -10x | +|||
| 20 | +
- names(statistic),+ #' data(api, package = "survey") |
|||
| 93 | -10x | +|||
| 21 | +
- function(variable) {
+ #' dclus1 <- survey::svydesign(id = ~dnum, weights = ~pw, data = apiclus1, fpc = ~fpc) |
|||
| 94 | -12x | +|||
| 22 | +
- map(+ #' |
|||
| 95 | -12x | +|||
| 23 | +
- statistic[[variable]],+ #' ard_survey_categorical_ci(dclus1, variables = sch.wide) |
|||
| 96 | -12x | +|||
| 24 | +
- function(statistic) {
+ #' ard_survey_categorical_ci(dclus1, variables = sch.wide, method = "xlogit") |
|||
| 97 | -84x | +|||
| 25 | +
- .compute_svy_stat(data, variable = variable, by = by, stat_name = statistic)+ ard_survey_categorical_ci <- function(data, |
|||
| 98 | +26 |
- }+ variables, |
||
| 99 | +27 |
- )+ by = NULL,+ |
+ ||
| 28 | ++ |
+ method = c("logit", "likelihood", "asin", "beta", "mean", "xlogit"),
+ |
+ ||
| 29 | ++ |
+ conf.level = 0.95, |
||
| 100 | +30 |
- }+ df = survey::degf(data), |
||
| 101 | +31 |
- ) |>+ ...) {
|
||
| 102 | -10x | +32 | +12x |
- dplyr::bind_rows()+ set_cli_abort_call() |
| 103 | +33 | |||
| 104 | +34 |
-
+ # check inputs --------------------------------------------------------------- |
||
| 105 | -+ | |||
| 35 | +12x |
- # add stat_labels ------------------------------------------------------------+ check_not_missing(data) |
||
| 106 | -10x | +36 | +12x |
- df_stats <-+ check_class(data, "survey.design") |
| 107 | -10x | +37 | +12x |
- df_stats |>+ check_not_missing(variables) |
| 108 | -10x | +|||
| 38 | +
- dplyr::left_join(+ |
|||
| 109 | -10x | +39 | +12x |
- .default_svy_stat_labels(),+ cards::process_selectors( |
| 110 | -10x | +40 | +12x |
- by = "stat_name"+ data = data$variables, |
| 111 | -+ | |||
| 41 | +12x |
- ) |>+ variables = {{ variables }},
|
||
| 112 | -10x | +42 | +12x |
- dplyr::mutate(stat_label = dplyr::coalesce(.data$stat_label, .data$stat_name))+ by = {{ by }}
|
| 113 | -10x | +|||
| 43 | +
- if (!is_empty(stat_label)) {
+ ) |
|||
| 114 | -1x | +44 | +12x |
- df_stats <-+ check_scalar(by, allow_empty = TRUE) |
| 115 | -1x | +45 | +12x |
- dplyr::rows_update(+ check_scalar_range(conf.level, range = c(0, 1)) |
| 116 | -1x | +46 | +12x |
- df_stats,+ method <- arg_match(method) |
| 117 | -1x | +|||
| 47 | +
- dplyr::tibble(+ |
|||
| 118 | -1x | +|||
| 48 | +
- variable = names(stat_label),+ # calculate and return ARD of one sample CI ---------------------------------- |
|||
| 119 | -1x | +49 | +12x |
- stat_name = map(.data$variable, ~ names(stat_label[[.x]])),+ .calculate_ard_onesample_survey_ci( |
| 120 | -1x | +50 | +12x |
- stat_label = map(.data$variable, ~ stat_label[[.x]] |>+ FUN = .svyciprop_wrapper, |
| 121 | -1x | +51 | +12x |
- unname() |>+ data = data, |
| 122 | -1x | +52 | +12x |
- unlist())+ variables = variables, |
| 123 | -+ | |||
| 53 | +12x |
- ) |>+ by = by, |
||
| 124 | -1x | +54 | +12x |
- tidyr::unnest(cols = c("stat_name", "stat_label")),
+ conf.level = conf.level, |
| 125 | -1x | +55 | +12x |
- by = c("variable", "stat_name"),
+ method = method, |
| 126 | -1x | +56 | +12x |
- unmatched = "ignore"+ df = df, |
| 127 | +57 |
- )+ ... |
||
| 128 | +58 |
- }+ ) |
||
| 129 | +59 |
-
+ } |
||
| 130 | +60 |
- # add formatting stats -------------------------------------------------------+ |
||
| 131 | -10x | +|||
| 61 | +
- df_stats$fmt_fn <- list(1L)+ .calculate_ard_onesample_survey_ci <- function(FUN, data, variables, by, conf.level, ...) {
|
|||
| 132 | -10x | +|||
| 62 | +
- if (!is_empty(fmt_fn)) {
+ # return empty data frame if no variables to process ------------------------- |
|||
| 133 | +63 | 1x |
- df_stats <-+ if (is_empty(variables)) return(dplyr::tibble()) # styler: off |
|
| 134 | -1x | +|||
| 64 | +
- dplyr::rows_update(+ |
|||
| 135 | -1x | +|||
| 65 | +
- df_stats,+ # calculate results ---------------------------------------------------------- |
|||
| 136 | -1x | +66 | +11x |
- dplyr::tibble(+ map( |
| 137 | -1x | +67 | +11x |
- variable = names(fmt_fn),+ variables, |
| 138 | -1x | +68 | +11x |
- stat_name = map(.data$variable, ~ names(fmt_fn[[.x]])),+ function(variable) {
|
| 139 | -1x | +69 | +18x |
- fmt_fn = map(.data$variable, ~ fmt_fn[[.x]] |> unname())+ .calculate_one_ard_categorical_survey_ci( |
| 140 | -+ | |||
| 70 | +18x |
- ) |>+ FUN = FUN, |
||
| 141 | -1x | +71 | +18x |
- tidyr::unnest(cols = c("stat_name", "fmt_fn")),
+ data = data, |
| 142 | -1x | +72 | +18x |
- by = c("variable", "stat_name"),
+ variable = variable, |
| 143 | -1x | +73 | +18x |
- unmatched = "ignore"+ by = by, |
| 144 | -+ | |||
| 74 | +18x |
- )+ conf.level = conf.level, |
||
| 145 | +75 |
- }+ ... |
||
| 146 | +76 |
-
+ ) |
||
| 147 | +77 |
- # add class and return ARD object --------------------------------------------- |
- ||
| 148 | -10x | -
- df_stats |>- |
- ||
| 149 | -10x | -
- dplyr::mutate(context = "continuous") |>+ } |
||
| 150 | -10x | +|||
| 78 | +
- cards::tidy_ard_column_order() %>%+ ) |> |
|||
| 151 | -10x | +79 | +11x |
- {structure(., class = c("card", class(.)))} # styler: off
+ dplyr::bind_rows() |
| 152 | +80 |
} |
||
| 153 | +81 | |||
| 154 | +82 |
- .default_svy_stat_labels <- function(stat_label = NULL) {
- |
- ||
| 155 | -10x | -
- dplyr::tribble(- |
- ||
| 156 | -10x | -
- ~stat_name, ~stat_label,- |
- ||
| 157 | -10x | -
- "mean", "Mean",- |
- ||
| 158 | -10x | -
- "median", "Median",- |
- ||
| 159 | -10x | -
- "var", "Variance",- |
- ||
| 160 | -10x | -
- "sd", "Standard Deviation",+ .calculate_one_ard_categorical_survey_ci <- function(FUN, data, variable, by, conf.level, ...) {
|
||
| 161 | -10x | +83 | +18x |
- "sum", "Sum",+ variable_levels <- .unique_values_sort(data$variables, variable = variable) |
| 162 | -10x | +84 | +18x |
- "deff", "Design Effect",+ if (!is_empty(by)) {
|
| 163 | -10x | +85 | +6x |
- "mean.std.error", "SE(Mean)",+ by_levels <- .unique_values_sort(data$variables, variable = by) |
| 164 | -10x | +86 | +6x |
- "min", "Minimum",+ lst_data <- |
| 165 | -10x | +87 | +6x |
- "max", "Maximum",+ map( |
| 166 | -10x | +88 | +6x |
- "p25", "25% Percentile",+ by_levels, |
| 167 | -10x | +89 | +6x |
- "p75", "75% Percentile"+ ~ call2("subset", expr(data), expr(!!sym(by) == !!.x)) |> eval()
|
| 168 | +90 |
- )+ ) |> |
||
| 169 | -+ | |||
| 91 | +6x |
- }+ set_names(as.character(by_levels)) |
||
| 170 | +92 |
-
+ } |
||
| 171 | +93 |
- accepted_svy_stats <- function(expand_quantiles = TRUE) {
+
|
||
| 172 | -12x | +94 | +18x |
- base_stats <-+ df_full <- |
| 173 | -12x | +95 | +18x |
- c("mean", "median", "min", "max", "sum", "var", "sd", "mean.std.error", "deff")
+ case_switch( |
| 174 | -12x | +96 | +18x |
- if (expand_quantiles) {
+ !is_empty(by) ~ |
| 175 | -12x | +97 | +18x |
- return(c(base_stats, paste0("p", 0:100)))
+ tidyr::expand_grid( |
| 176 | -+ | |||
| 98 | +18x |
- }+ group1_level = as.character(by_levels) |> as.list(), |
||
| 177 | -! | +|||
| 99 | +18x |
- c(base_stats, "p##")+ variable_level = as.character(variable_levels) |> as.list() |
||
| 178 | +100 |
- }+ ) |> |
||
| 179 | -+ | |||
| 101 | +18x |
-
+ dplyr::mutate(group1 = .env$by, variable = .env$variable), |
||
| 180 | -+ | |||
| 102 | +18x |
-
+ .default = |
||
| 181 | -+ | |||
| 103 | +18x |
-
+ dplyr::tibble( |
||
| 182 | -+ | |||
| 104 | +18x |
- # this function calculates the summary for a single variable, single statistic+ variable = .env$variable, |
||
| 183 | -+ | |||
| 105 | +18x |
- # and for all `by` levels. it returns an ARD data frame+ variable_level = as.character(variable_levels) |> as.list() |
||
| 184 | +106 |
- .compute_svy_stat <- function(data, variable, by = NULL, stat_name) {
+ ) |
||
| 185 | +107 |
- # difftime variable needs to be transformed into numeric for svyquantile+ ) |> |
||
| 186 | -84x | +108 | +18x |
- if (inherits(data$variables[[variable]], "difftime")) {
+ dplyr::rowwise() |> |
| 187 | -! | +|||
| 109 | +18x |
- data$variables[[variable]] <- unclass(data$variables[[variable]])+ dplyr::mutate( |
||
| 188 | -+ | |||
| 110 | +18x |
- }+ lst_result = |
||
| 189 | -+ | |||
| 111 | +18x |
-
+ FUN( |
||
| 190 | -+ | |||
| 112 | +18x |
- # styler: off+ data = |
||
| 191 | -12x | +113 | +18x |
- if (stat_name %in% "mean") args <- list(FUN = survey::svymean)+ case_switch( |
| 192 | -6x | +114 | +18x |
- else if (stat_name %in% "sum") args <- list(FUN = survey::svytotal)+ is_empty(.env$by) ~ data, |
| 193 | -6x | +115 | +18x |
- else if (stat_name %in% "var") args <- list(FUN = survey::svyvar)+ .default = lst_data[[.data$group1_level]] |
| 194 | -6x | +|||
| 116 | +
- else if (stat_name %in% "sd") args <- list(FUN = \(...) survey::svyvar(...) |> sqrt())+ ), |
|||
| 195 | -6x | +117 | +18x |
- else if (stat_name %in% "mean.std.error") args <- list(FUN = \(...) survey::svymean(...) |> survey::SE())+ variable = .data$variable, |
| 196 | -6x | +118 | +18x |
- else if (stat_name %in% "deff") args <- list(FUN = \(...) survey::svymean(..., deff = TRUE) |> survey::deff())+ variable_level = .data$variable_level, |
| 197 | -12x | +119 | +18x |
- else if (stat_name %in% "min") args <- list(FUN = \(x, design, na.rm, ...) min(design$variables[[all.vars(x)]], na.rm = na.rm))+ conf.level = .env$conf.level, |
| 198 | -12x | +|||
| 120 | +
- else if (stat_name %in% "max") args <- list(FUN = \(x, design, na.rm, ...) max(design$variables[[all.vars(x)]], na.rm = na.rm))+ ... |
|||
| 199 | +121 |
- # define functions for the quantiles+ ) |> |
||
| 200 | +122 | 18x |
- else if (stat_name %in% c("median", paste0("p", 0:100))) {
+ list(), |
|
| 201 | +123 | 18x |
- quantile <- ifelse(stat_name %in% "median", 0.5, as.numeric(substr(stat_name, 2, nchar(stat_name))) / 100)+ result = |
|
| 202 | -+ | |||
| 124 | +18x |
- # univariate results are returned in a different format from stratified.+ .data$lst_result[["result"]] |> |
||
| 203 | +125 | 18x |
- args <-+ enframe("stat_name", "stat") |>
|
|
| 204 | +126 | 18x |
- if (is_empty(by)) list(FUN = \(...) survey::svyquantile(...)[[1]], quantiles = quantile)+ list(), |
|
| 205 | +127 | 18x |
- else list(FUN = \(...) survey::svyquantile(...), quantiles = quantile)+ warning = .data$lst_result["warning"] |> unname(), |
|
| 206 | -+ | |||
| 128 | +18x |
- }+ error = .data$lst_result["error"] |> unname(), |
||
| 207 | -+ | |||
| 129 | +18x |
- # styler: on+ context = "survey_categorical_ci" |
||
| 208 | +130 |
-
+ ) |> |
||
| 209 | -+ | |||
| 131 | +18x |
- # adding additional args to pass+ dplyr::select(-"lst_result") |> |
||
| 210 | -84x | +132 | +18x |
- args <-+ dplyr::ungroup() |> |
| 211 | -84x | +133 | +18x |
- args |>+ tidyr::unnest("result") |>
|
| 212 | -84x | +134 | +18x |
- append(+ dplyr::mutate( |
| 213 | -84x | +135 | +18x |
- list(+ stat_label = .data$stat_name, |
| 214 | -84x | +136 | +18x |
- design = data,+ fmt_fn = map(.data$stat, ~ case_switch(is.numeric(.x) ~ 2L, .default = as.character)) |
| 215 | +137 |
- # if all values are NA, turn na.rm to FALSE to avoid error+ ) |> |
||
| 216 | -84x | +138 | +18x |
- na.rm = !all(is.na(data$variables[[variable]])),+ cards::tidy_ard_column_order() %>% |
| 217 | -84x | +139 | +18x |
- keep.var = FALSE+ structure(., class = c("card", class(.)))
|
| 218 | +140 |
- )+ } |
||
| 219 | +141 |
- )+ |
||
| 220 | +142 | |||
| 221 | +143 |
-
+ .svyciprop_wrapper <- function(data, variable, variable_level, conf.level, method, df, ...) {
|
||
| 222 | -+ | |||
| 144 | +48x |
- # if no by variable, calculate univariate statistics+ lst_results <- |
||
| 223 | -84x | +145 | +48x |
- if (is_empty(by)) {
+ cards::eval_capture_conditions( |
| 224 | -46x | +146 | +48x |
- args$x <- reformulate2(variable)+ survey::svyciprop( |
| 225 | -+ | |||
| 147 | +48x |
- # calculate statistic (and remove FUN from the argument list)+ formula = inject(~ I(!!sym(variable) == !!variable_level)), |
||
| 226 | -46x | +148 | +48x |
- stat <-+ design = data, |
| 227 | -46x | +149 | +48x |
- cards::eval_capture_conditions(+ method = method, |
| 228 | -46x | +150 | +48x |
- do.call(args$FUN, args = args |> utils::modifyList(list(FUN = NULL)))+ level = conf.level,+ |
+
| 151 | +48x | +
+ df = df, |
||
| 229 | +152 |
- )+ ... |
||
| 230 | +153 |
- # if the result was calculated, then put it into a tibble+ ) %>% |
||
| 231 | -46x | +154 | +48x |
- if (!is.null(stat[["result"]])) {
+ {list(.[[1]], attr(., "ci"))} |> # styler: off
|
| 232 | -40x | +155 | +48x |
- df_stat <-+ unlist() |> |
| 233 | -40x | +156 | +48x |
- dplyr::tibble(variable, stat[["result"]][1]) |>+ set_names(c("estimate", "conf.low", "conf.high")) |>
|
| 234 | -40x | +157 | +48x |
- set_names(c("variable", "stat")) |>
+ as.list() |
| 235 | -40x | +|||
| 158 | +
- dplyr::mutate(+ ) |
|||
| 236 | -40x | +|||
| 159 | +
- stat = as.list(unname(.data$stat)),+ |
|||
| 237 | -40x | +|||
| 160 | +
- warning = list(stat[["warning"]]),+ # add NULL results if error |
|||
| 238 | -40x | +161 | +48x |
- error = list(stat[["error"]])+ if (is_empty(lst_results[["result"]])) {
|
| 239 | -+ | |||
| 162 | +! |
- )+ lst_results[["result"]] <- rep_named(c("estimate", "conf.low", "conf.high"), list(NULL))
|
||
| 240 | +163 |
- }+ } |
||
| 241 | +164 |
- # otherwise, if there was an error return tibble with error message+ |
||
| 242 | +165 |
- else {
- |
- ||
| 243 | -6x | -
- df_stat <-- |
- ||
| 244 | -6x | -
- dplyr::tibble(+ # add other args |
||
| 245 | -6x | +166 | +48x |
- variable = .env$variable,+ lst_results[["result"]] <- lst_results[["result"]] |> append(list(method = method, conf.level = conf.level)) |
| 246 | -6x | +|||
| 167 | +
- stat = list(NULL),+ |
|||
| 247 | -6x | +|||
| 168 | +
- warning = list(.env$stat[["warning"]]),+ # return list result |
|||
| 248 | -6x | +169 | +48x |
- error = list(.env$stat[["error"]])+ lst_results |
| 249 | +170 |
- )+ } |
||
| 250 | +171 |
- }+ |
||
| 251 | +172 |
- }+ |
||
| 252 | +173 |
-
+ case_switch <- function(..., .default = NULL) {
|
||
| 253 | -+ | |||
| 174 | +632x |
- # if there is by variable(s), calculate statistics for the combinations+ dots <- dots_list(...) |
||
| 254 | +175 |
- else {
- |
- ||
| 255 | -38x | -
- args$formula <- reformulate2(variable)+ |
||
| 256 | -38x | +176 | +632x |
- args$by <- reformulate2(by)+ for (f in dots) {
|
| 257 | -38x | +177 | +801x |
- stat <-+ if (isTRUE(eval(f_lhs(f), envir = attr(f, ".Environment")))) {
|
| 258 | -38x | +178 | +503x |
- if (stat_name %in% c("median", paste0("p", 0:100))) {
+ return(eval(f_rhs(f), envir = attr(f, ".Environment"))) |
| 259 | -8x | +|||
| 179 | +
- cards::eval_capture_conditions(+ } |
|||
| 260 | -8x | +|||
| 180 | +
- do.call(survey::svyby, args) |> set_names(c(by, "quantile", "ci.2.5", "ci.97.5", "se"))+ } |
|||
| 261 | +181 |
- )+ |
||
| 262 | -38x | +182 | +129x |
- } else if (stat_name %in% "deff") {
+ return(.default) |
| 263 | -3x | +|||
| 183 | +
- stat <-+ } |
|||
| 264 | -3x | +
| 1 | +
- cards::eval_capture_conditions(+ #' ARD Continuous Survey Statistics |
|||
| 265 | -3x | +|||
| 2 | +
- do.call(+ #' |
|||
| 266 | -3x | +|||
| 3 | ++ |
+ #' Returns an ARD of weighted statistics using the `{survey}` package.
+ |
+ ||
| 4 | +
- survey::svyby,+ #' |
|||
| 267 | -3x | +|||
| 5 | +
- args |> utils::modifyList(list(FUN = survey::svymean, deff = TRUE))+ #' @param data (`survey.design`)\cr |
|||
| 268 | +6 |
- ) |>+ #' a design object often created with [`survey::svydesign()`]. |
||
| 269 | -3x | +|||
| 7 | +
- dplyr::select(all_of(by), dplyr::last_col()) # the last column is DEff+ #' @param variables ([`tidy-select`][dplyr::dplyr_tidy_select])\cr |
|||
| 270 | +8 |
- )+ #' columns to include in summaries. |
||
| 271 | +9 |
- } else {
+ #' @param by ([`tidy-select`][dplyr::dplyr_tidy_select])\cr |
||
| 272 | -27x | +|||
| 10 | +
- cards::eval_capture_conditions(do.call(survey::svyby, args))+ #' results are calculated for **all combinations** of the columns specified, |
|||
| 273 | +11 |
- }+ #' including unobserved combinations and unobserved factor levels. |
||
| 274 | +12 |
-
+ #' @param statistic ([`formula-list-selector`][syntax])\cr |
||
| 275 | +13 |
- # if the result was calculated, then put it into a tibble+ #' a named list, a list of formulas, |
||
| 276 | -38x | +|||
| 14 | +
- if (!is.null(stat[["result"]])) {
+ #' or a single formula where the list element is a character vector of |
|||
| 277 | -32x | +|||
| 15 | +
- df_stat <- stat[["result"]][seq_len(length(by) + 1L)] |>+ #' statistic names to include. See below for options. |
|||
| 278 | -32x | +|||
| 16 | +
- dplyr::as_tibble() %>%+ #' @param fmt_fn ([`formula-list-selector`][syntax])\cr |
|||
| 279 | +17 |
- # adding unobserved combinations of "by" variables+ #' a named list, a list of formulas, |
||
| 280 | +18 |
- {
+ #' or a single formula where the list element is a named list of functions |
||
| 281 | -32x | +|||
| 19 | +
- dplyr::full_join(+ #' (or the RHS of a formula), |
|||
| 282 | -32x | +|||
| 20 | +
- cards::nest_for_ard(data$variables, by = by, key = "...ard_no_one_will_ever_pick_this...", rename = FALSE, list_columns = FALSE) |>+ #' e.g. `list(mpg = list(mean = \(x) round(x, digits = 2) |> as.character))`. |
|||
| 283 | -32x | +|||
| 21 | +
- dplyr::select(-"...ard_no_one_will_ever_pick_this..."),+ #' @param stat_label ([`formula-list-selector`][syntax])\cr |
|||
| 284 | +22 |
- .,+ #' a named list, a list of formulas, or a single formula where |
||
| 285 | -32x | +|||
| 23 | +
- by = by+ #' the list element is either a named list or a list of formulas defining the |
|||
| 286 | +24 |
- )+ #' statistic labels, e.g. `everything() ~ list(mean = "Mean", sd = "SD")` or |
||
| 287 | +25 |
- } |>+ #' `everything() ~ list(mean ~ "Mean", sd ~ "SD")`. |
||
| 288 | -32x | +|||
| 26 | +
- set_names(paste0("group", seq_along(by), "_level"), "stat") |>
+ #' @inheritParams rlang::args_dots_empty |
|||
| 289 | -32x | +|||
| 27 | +
- dplyr::bind_cols(+ #' |
|||
| 290 | -32x | +|||
| 28 | +
- dplyr::tibble(!!!c(by, variable)) |>+ #' @section statistic argument: |
|||
| 291 | -32x | +|||
| 29 | +
- set_names(paste0("group", seq_along(by)), "variable")
+ #' |
|||
| 292 | +30 |
- ) |>+ #' The following statistics are available: |
||
| 293 | -32x | +|||
| 31 | +
- dplyr::mutate(+ #' `r cardx:::accepted_svy_stats(FALSE) |> shQuote("sh") |> paste(collapse = ", ")`,
|
|||
| 294 | -32x | +|||
| 32 | +
- dplyr::across(c(cards::all_ard_groups("levels"), "stat"), as.list),
+ #' where 'p##' is are the percentiles and `##` is an integer between 0 and 100. |
|||
| 295 | -32x | +|||
| 33 | +
- warning = list(.env$stat[["warning"]]),+ #' |
|||
| 296 | -32x | +|||
| 34 | +
- error = list(.env$stat[["error"]])+ #' |
|||
| 297 | +35 |
- )+ #' @return an ARD data frame of class 'card' |
||
| 298 | +36 |
- }+ #' @export |
||
| 299 | +37 |
- # otherwise, if there was an error return tibble with error message+ #' |
||
| 300 | +38 |
- else {
+ #' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = "survey", reference_pkg = "cardx"))
|
||
| 301 | -6x | +|||
| 39 | +
- df_stat <-+ #' data(api, package = "survey") |
|||
| 302 | -6x | +|||
| 40 | +
- cards::nest_for_ard(data$variables, by = by, key = "...ard_no_one_will_ever_pick_this...") |>+ #' dclus1 <- survey::svydesign(id = ~dnum, weights = ~pw, data = apiclus1, fpc = ~fpc) |
|||
| 303 | -6x | +|||
| 41 | +
- dplyr::select(-"...ard_no_one_will_ever_pick_this...") |>+ #' |
|||
| 304 | -6x | +|||
| 42 | +
- dplyr::mutate(+ #' ard_continuous( |
|||
| 305 | -6x | +|||
| 43 | +
- variable = .env$variable,+ #' data = dclus1, |
|||
| 306 | -6x | +|||
| 44 | +
- stat = list(NULL),+ #' variables = api00, |
|||
| 307 | -6x | +|||
| 45 | +
- warning = list(.env$stat[["warning"]]),+ #' by = stype |
|||
| 308 | -6x | +|||
| 46 | +
- error = list(.env$stat[["error"]])+ #' ) |
|||
| 309 | +47 |
- )+ ard_continuous.survey.design <- function(data, variables, by = NULL, |
||
| 310 | +48 |
- }+ statistic = everything() ~ c("median", "p25", "p75"),
|
||
| 311 | +49 |
- }+ fmt_fn = NULL, |
||
| 312 | +50 |
-
+ stat_label = NULL, |
||
| 313 | -84x | +|||
| 51 | +
- df_stat |>+ ...) {
|
|||
| 314 | -84x | +52 | +10x |
- dplyr::mutate(+ set_cli_abort_call() |
| 315 | -84x | +53 | +10x |
- stat_name = .env$stat_name,+ check_dots_empty() |
| 316 | -84x | +|||
| 54 | +
- across(+ |
|||
| 317 | -84x | +|||
| 55 | +
- c(cards::all_ard_groups("levels"), cards::all_ard_variables("levels")),
+ # check installed packages --------------------------------------------------- |
|||
| 318 | -84x | +56 | +10x |
- ~ map(.x, as.character)+ check_pkg_installed(pkg = "survey", reference_pkg = "cardx") |
| 319 | +57 |
- )+ |
||
| 320 | +58 |
- )+ # check inputs --------------------------------------------------------------- |
||
| 321 | -+ | |||
| 59 | +10x |
- }+ check_not_missing(variables) |
| 1 | +60 |
- #' ARD t-test+ |
||
| 2 | +61 |
- #'+ # process inputs ------------------------------------------------------------- |
||
| 3 | -+ | |||
| 62 | +10x |
- #' @description+ cards::process_selectors(data$variables, variables = {{ variables }}, by = {{ by }})
|
||
| 4 | -+ | |||
| 63 | +10x |
- #' Analysis results data for paired and non-paired t-tests.+ variables <- setdiff(variables, by) |
||
| 5 | -+ | |||
| 64 | +10x |
- #'+ check_na_factor_levels(data$variables, by) |
||
| 6 | +65 |
- #' @param data (`data.frame`)\cr+ |
||
| 7 | -+ | |||
| 66 | +10x |
- #' a data frame. See below for details.+ cards::process_formula_selectors( |
||
| 8 | -+ | |||
| 67 | +10x |
- #' @param by ([`tidy-select`][dplyr::dplyr_tidy_select])\cr+ data$variables[variables], |
||
| 9 | -+ | |||
| 68 | +10x |
- #' optional column name to compare by.+ statistic = statistic, |
||
| 10 | -+ | |||
| 69 | +10x |
- #' @param variables ([`tidy-select`][dplyr::dplyr_tidy_select])\cr+ fmt_fn = fmt_fn, |
||
| 11 | -+ | |||
| 70 | +10x |
- #' column names to be compared. Independent t-tests will be computed for+ stat_label = stat_label |
||
| 12 | +71 |
- #' each variable.+ ) |
||
| 13 | -+ | |||
| 72 | +10x |
- #' @param id ([`tidy-select`][dplyr::dplyr_tidy_select])\cr+ cards::fill_formula_selectors( |
||
| 14 | -+ | |||
| 73 | +10x |
- #' column name of the subject or participant ID+ data$variables[variables], |
||
| 15 | -+ | |||
| 74 | +10x |
- #' @param conf.level (scalar `numeric`)\cr+ statistic = formals(asNamespace("cardx")[["ard_continuous.survey.design"]])[["statistic"]] |> eval()
|
||
| 16 | +75 |
- #' confidence level for confidence interval. Default is `0.95`.+ ) |
||
| 17 | -+ | |||
| 76 | +10x |
- #' @param ... arguments passed to `t.test(...)`+ cards::check_list_elements( |
||
| 18 | -+ | |||
| 77 | +10x |
- #'+ x = statistic, |
||
| 19 | -+ | |||
| 78 | +10x |
- #' @return ARD data frame+ predicate = \(x) all(x %in% accepted_svy_stats()), |
||
| 20 | -+ | |||
| 79 | +10x |
- #' @name ard_stats_t_test+ error_msg = c("Error in the values of the {.arg statistic} argument for variable {.val {variable}}.",
|
||
| 21 | -+ | |||
| 80 | +10x |
- #'+ i = "Values must be in {.val {cardx:::accepted_svy_stats(FALSE)}}"
|
||
| 22 | +81 |
- #' @details+ ) |
||
| 23 | +82 |
- #' For the `ard_stats_t_test()` function, the data is expected to be one row per subject.+ ) |
||
| 24 | +83 |
- #' The data is passed as `t.test(data[[variable]] ~ data[[by]], paired = FALSE, ...)`.+ |
||
| 25 | +84 |
- #'+ # return empty tibble if no variables selected ------------------------------- |
||
| 26 | -+ | |||
| 85 | +10x |
- #' For the `ard_stats_paired_t_test()` function, the data is expected to be one row+ if (is_empty(variables)) {
|
||
| 27 | -+ | |||
| 86 | +! |
- #' per subject per by level. Before the t-test is calculated, the data are+ return(dplyr::tibble()) |
||
| 28 | +87 |
- #' reshaped to a wide format to be one row per subject.+ } |
||
| 29 | +88 |
- #' The data are then passed as+ |
||
| 30 | +89 |
- #' `t.test(x = data_wide[[<by level 1>]], y = data_wide[[<by level 2>]], paired = TRUE, ...)`.+ # compute the weighted statistics -------------------------------------------- |
||
| 31 | -+ | |||
| 90 | +10x |
- #'+ df_stats <- |
||
| 32 | -+ | |||
| 91 | +10x |
- #' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = "broom", reference_pkg = "cardx"))
+ map( |
||
| 33 | -+ | |||
| 92 | +10x |
- #' cards::ADSL |>+ names(statistic), |
||
| 34 | -+ | |||
| 93 | +10x |
- #' dplyr::filter(ARM %in% c("Placebo", "Xanomeline High Dose")) |>
+ function(variable) {
|
||
| 35 | -+ | |||
| 94 | +12x |
- #' ard_stats_t_test(by = ARM, variables = c(AGE, BMIBL))+ map( |
||
| 36 | -+ | |||
| 95 | +12x |
- #'+ statistic[[variable]], |
||
| 37 | -+ | |||
| 96 | +12x |
- #' # constructing a paired data set,+ function(statistic) {
|
||
| 38 | -+ | |||
| 97 | +84x |
- #' # where patients receive both treatments+ .compute_svy_stat(data, variable = variable, by = by, stat_name = statistic) |
||
| 39 | +98 |
- #' cards::ADSL[c("ARM", "AGE")] |>
+ } |
||
| 40 | +99 |
- #' dplyr::filter(ARM %in% c("Placebo", "Xanomeline High Dose")) |>
+ ) |
||
| 41 | +100 |
- #' dplyr::mutate(.by = ARM, USUBJID = dplyr::row_number()) |>+ } |
||
| 42 | +101 |
- #' dplyr::arrange(USUBJID, ARM) |>+ ) |> |
||
| 43 | -+ | |||
| 102 | +10x |
- #' ard_stats_paired_t_test(by = ARM, variables = AGE, id = USUBJID)+ dplyr::bind_rows() |
||
| 44 | +103 |
- NULL+ |
||
| 45 | +104 | |||
| 46 | +105 |
- #' @rdname ard_stats_t_test+ # add stat_labels ------------------------------------------------------------ |
||
| 47 | -+ | |||
| 106 | +10x |
- #' @export+ df_stats <- |
||
| 48 | -+ | |||
| 107 | +10x |
- ard_stats_t_test <- function(data, variables, by = NULL, conf.level = 0.95, ...) {
+ df_stats |> |
||
| 49 | -5x | +108 | +10x |
- set_cli_abort_call()+ dplyr::left_join( |
| 50 | -+ | |||
| 109 | +10x |
-
+ .default_svy_stat_labels(),+ |
+ ||
| 110 | +10x | +
+ by = "stat_name" |
||
| 51 | +111 |
- # check installed packages ---------------------------------------------------+ ) |> |
||
| 52 | -5x | +112 | +10x |
- check_pkg_installed("broom", reference_pkg = "cardx")
+ dplyr::mutate(stat_label = dplyr::coalesce(.data$stat_label, .data$stat_name)) |
| 53 | -+ | |||
| 113 | +10x |
-
+ if (!is_empty(stat_label)) {
|
||
| 54 | -+ | |||
| 114 | +1x |
- # check/process inputs -------------------------------------------------------+ df_stats <- |
||
| 55 | -5x | +115 | +1x |
- check_not_missing(data)+ dplyr::rows_update( |
| 56 | -5x | +116 | +1x |
- check_not_missing(variables)+ df_stats, |
| 57 | -5x | +117 | +1x |
- check_data_frame(data)+ dplyr::tibble( |
| 58 | -5x | +118 | +1x |
- data <- dplyr::ungroup(data)+ variable = names(stat_label), |
| 59 | -5x | +119 | +1x |
- cards::process_selectors(data, by = {{ by }}, variables = {{ variables }})
+ stat_name = map(.data$variable, ~ names(stat_label[[.x]])), |
| 60 | -5x | +120 | +1x |
- check_scalar(by, allow_empty = TRUE)+ stat_label = map(.data$variable, ~ stat_label[[.x]] |> |
| 61 | -5x | +121 | +1x |
- check_range(conf.level, range = c(0, 1))+ unname() |> |
| 62 | -+ | |||
| 122 | +1x |
-
+ unlist()) |
||
| 63 | +123 |
- # if no variables selected, return empty tibble ------------------------------+ ) |> |
||
| 64 | -5x | +124 | +1x |
- if (is_empty(variables)) {
+ tidyr::unnest(cols = c("stat_name", "stat_label")),
|
| 65 | -! | +|||
| 125 | +1x |
- return(dplyr::tibble())+ by = c("variable", "stat_name"),
+ |
+ ||
| 126 | +1x | +
+ unmatched = "ignore" |
||
| 66 | +127 | ++ |
+ )+ |
+ |
| 128 |
} |
|||
| 67 | +129 | |||
| 68 | +130 |
- # build ARD ------------------------------------------------------------------+ # add formatting stats ------------------------------------------------------- |
||
| 69 | -5x | +131 | +10x |
- lapply(+ df_stats$fmt_fn <- list(1L) |
| 70 | -5x | +132 | +10x |
- variables,+ if (!is_empty(fmt_fn)) {
|
| 71 | -5x | +133 | +1x |
- function(variable) {
+ df_stats <- |
| 72 | -6x | +134 | +1x |
- .format_ttest_results(+ dplyr::rows_update( |
| 73 | -6x | +135 | +1x |
- by = by,+ df_stats, |
| 74 | -6x | +136 | +1x |
- variable = variable,+ dplyr::tibble( |
| 75 | -6x | +137 | +1x |
- lst_tidy =+ variable = names(fmt_fn),+ |
+
| 138 | +1x | +
+ stat_name = map(.data$variable, ~ names(fmt_fn[[.x]])),+ |
+ ||
| 139 | +1x | +
+ fmt_fn = map(.data$variable, ~ fmt_fn[[.x]] |> unname()) |
||
| 76 | +140 |
- # styler: off+ ) |> |
||
| 77 | -6x | +141 | +1x |
- cards::eval_capture_conditions(+ tidyr::unnest(cols = c("stat_name", "fmt_fn")),
|
| 78 | -6x | +142 | +1x |
- if (!is_empty(by)) stats::t.test(data[[variable]] ~ data[[by]], conf.level = conf.level, ...) |> broom::tidy()+ by = c("variable", "stat_name"),
|
| 79 | -6x | +143 | +1x |
- else stats::t.test(data[[variable]], ...) |> broom::tidy()+ unmatched = "ignore" |
| 80 | +144 |
- ),+ ) |
||
| 81 | +145 |
- # styler: on+ } |
||
| 82 | -6x | +|||
| 146 | +
- paired = FALSE,+ |
|||
| 83 | +147 |
- ...+ # add class and return ARD object -------------------------------------------- |
||
| 84 | -+ | |||
| 148 | +10x |
- )+ df_stats |> |
||
| 85 | -+ | |||
| 149 | +10x |
- }+ dplyr::mutate(context = "continuous") |> |
||
| 86 | -+ | |||
| 150 | +10x |
- ) |>+ cards::tidy_ard_column_order() %>% |
||
| 87 | -5x | +151 | +10x |
- dplyr::bind_rows()+ {structure(., class = c("card", class(.)))} # styler: off
|
| 88 | +152 |
} |
||
| 89 | +153 | |||
| 90 | +154 |
- #' @rdname ard_stats_t_test+ .default_svy_stat_labels <- function(stat_label = NULL) {
|
||
| 91 | -+ | |||
| 155 | +10x |
- #' @export+ dplyr::tribble( |
||
| 92 | -+ | |||
| 156 | +10x |
- ard_stats_paired_t_test <- function(data, by, variables, id, conf.level = 0.95, ...) {
+ ~stat_name, ~stat_label, |
||
| 93 | -2x | +157 | +10x |
- set_cli_abort_call()+ "mean", "Mean", |
| 94 | -+ | |||
| 158 | +10x |
-
+ "median", "Median", |
||
| 95 | -+ | |||
| 159 | +10x |
- # check installed packages ---------------------------------------------------+ "var", "Variance", |
||
| 96 | -2x | +160 | +10x | +
+ "sd", "Standard Deviation",+ |
+
| 161 | +10x | +
+ "sum", "Sum",+ |
+ ||
| 162 | +10x | +
+ "deff", "Design Effect",+ |
+ ||
| 163 | +10x | +
+ "mean.std.error", "SE(Mean)",+ |
+ ||
| 164 | +10x | +
+ "min", "Minimum",+ |
+ ||
| 165 | +10x | +
+ "max", "Maximum",+ |
+ ||
| 166 | +10x | +
+ "p25", "25% Percentile",+ |
+ ||
| 167 | +10x |
- check_pkg_installed("broom", reference_pkg = "cardx")
+ "p75", "75% Percentile" |
||
| 97 | +168 |
-
+ ) |
||
| 98 | +169 |
- # check/process inputs -------------------------------------------------------+ } |
||
| 99 | -2x | +|||
| 170 | +
- check_not_missing(data)+ |
|||
| 100 | -2x | +|||
| 171 | +
- check_not_missing(variables)+ accepted_svy_stats <- function(expand_quantiles = TRUE) {
|
|||
| 101 | -2x | +172 | +12x |
- check_not_missing(by)+ base_stats <- |
| 102 | -2x | +173 | +12x |
- check_not_missing(id)+ c("mean", "median", "min", "max", "sum", "var", "sd", "mean.std.error", "deff")
|
| 103 | -2x | +174 | +12x |
- check_data_frame(data)+ if (expand_quantiles) {
|
| 104 | -2x | +175 | +12x |
- data <- dplyr::ungroup(data)+ return(c(base_stats, paste0("p", 0:100)))
|
| 105 | -2x | +|||
| 176 | +
- cards::process_selectors(data, by = {{ by }}, variables = {{ variables }}, id = {{ id }})
+ } |
|||
| 106 | -2x | +|||
| 177 | +! |
- check_scalar(by)+ c(base_stats, "p##") |
||
| 107 | -2x | +|||
| 178 | +
- check_scalar(id)+ } |
|||
| 108 | +179 | |||
| 109 | +180 |
- # if no variables selected, return empty tibble ------------------------------+ |
||
| 110 | -2x | +|||
| 181 | +
- if (is_empty(variables)) {
+
|
|||
| 111 | -! | +|||
| 182 | +
- return(dplyr::tibble())+ # this function calculates the summary for a single variable, single statistic |
|||
| 112 | +183 |
- }+ # and for all `by` levels. it returns an ARD data frame |
||
| 113 | +184 |
-
+ .compute_svy_stat <- function(data, variable, by = NULL, stat_name) {
|
||
| 114 | +185 |
- # build ARD ------------------------------------------------------------------+ # difftime variable needs to be transformed into numeric for svyquantile |
||
| 115 | -2x | +186 | +84x |
- lapply(+ if (inherits(data$variables[[variable]], "difftime")) {
|
| 116 | -2x | +|||
| 187 | +! |
- variables,+ data$variables[[variable]] <- unclass(data$variables[[variable]]) |
||
| 117 | -2x | +|||
| 188 | +
- function(variable) {
+ } |
|||
| 118 | -2x | +|||
| 189 | +
- .format_ttest_results(+ |
|||
| 119 | -2x | +|||
| 190 | +
- by = by,+ # styler: off |
|||
| 120 | -2x | +191 | +12x |
- variable = variable,+ if (stat_name %in% "mean") args <- list(FUN = survey::svymean) |
| 121 | -2x | +192 | +6x |
- lst_tidy =+ else if (stat_name %in% "sum") args <- list(FUN = survey::svytotal) |
| 122 | -2x | +193 | +6x |
- cards::eval_capture_conditions({
+ else if (stat_name %in% "var") args <- list(FUN = survey::svyvar) |
| 123 | -+ | |||
| 194 | +6x |
- # adding this reshape inside the eval, so if there is an error it's captured in the ARD object+ else if (stat_name %in% "sd") args <- list(FUN = \(...) survey::svyvar(...) |> sqrt()) |
||
| 124 | -2x | +195 | +6x |
- data_wide <- .paired_data_pivot_wider(data, by = by, variable = variable, id = id)+ else if (stat_name %in% "mean.std.error") args <- list(FUN = \(...) survey::svymean(...) |> survey::SE()) |
| 125 | -+ | |||
| 196 | +6x |
- # perform paired t-test+ else if (stat_name %in% "deff") args <- list(FUN = \(...) survey::svymean(..., deff = TRUE) |> survey::deff()) |
||
| 126 | -1x | +197 | +12x |
- stats::t.test(x = data_wide[["by1"]], y = data_wide[["by2"]], paired = TRUE, conf.level = conf.level, ...) |>+ else if (stat_name %in% "min") args <- list(FUN = \(x, design, na.rm, ...) min(design$variables[[all.vars(x)]], na.rm = na.rm)) |
| 127 | -1x | +198 | +12x |
- broom::tidy()+ else if (stat_name %in% "max") args <- list(FUN = \(x, design, na.rm, ...) max(design$variables[[all.vars(x)]], na.rm = na.rm)) |
| 128 | +199 |
- }),+ # define functions for the quantiles |
||
| 129 | -2x | +200 | +18x |
- paired = TRUE,+ else if (stat_name %in% c("median", paste0("p", 0:100))) {
|
| 130 | -+ | |||
| 201 | +18x |
- ...+ quantile <- ifelse(stat_name %in% "median", 0.5, as.numeric(substr(stat_name, 2, nchar(stat_name))) / 100) |
||
| 131 | +202 |
- )+ # univariate results are returned in a different format from stratified. |
||
| 132 | -+ | |||
| 203 | +18x |
- }+ args <- |
||
| 133 | -+ | |||
| 204 | +18x |
- ) |>+ if (is_empty(by)) list(FUN = \(...) survey::svyquantile(...)[[1]], quantiles = quantile) |
||
| 134 | -2x | +205 | +18x |
- dplyr::bind_rows()+ else list(FUN = \(...) survey::svyquantile(...), quantiles = quantile) |
| 135 | +206 |
- }+ } |
||
| 136 | +207 |
-
+ # styler: on |
||
| 137 | +208 |
- #' Convert t-test to ARD+ |
||
| 138 | +209 |
- #'+ # adding additional args to pass |
||
| 139 | -+ | |||
| 210 | +84x |
- #' @inheritParams cards::tidy_as_ard+ args <- |
||
| 140 | -+ | |||
| 211 | +84x |
- #' @inheritParams stats::t.test+ args |> |
||
| 141 | -+ | |||
| 212 | +84x |
- #' @param by (`string`)\cr by column name+ append( |
||
| 142 | -+ | |||
| 213 | +84x |
- #' @param variable (`string`)\cr variable column name+ list( |
||
| 143 | -+ | |||
| 214 | +84x |
- #' @param ... passed to `t.test(...)`+ design = data, |
||
| 144 | +215 |
- #'+ # if all values are NA, turn na.rm to FALSE to avoid error |
||
| 145 | -+ | |||
| 216 | +84x |
- #' @return ARD data frame+ na.rm = !all(is.na(data$variables[[variable]])), |
||
| 146 | -+ | |||
| 217 | +84x |
- #' @keywords internal+ keep.var = FALSE |
||
| 147 | +218 |
- #' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = "broom", reference_pkg = "cardx"))
+ ) |
||
| 148 | +219 |
- #' cardx:::.format_ttest_results(+ ) |
||
| 149 | +220 |
- #' by = "ARM",+ |
||
| 150 | +221 |
- #' variable = "AGE",+ |
||
| 151 | +222 |
- #' paired = FALSE,+ # if no by variable, calculate univariate statistics |
||
| 152 | -+ | |||
| 223 | +84x |
- #' lst_tidy =+ if (is_empty(by)) {
|
||
| 153 | -+ | |||
| 224 | +46x |
- #' cards::eval_capture_conditions(+ args$x <- reformulate2(variable) |
||
| 154 | +225 |
- #' stats::t.test(ADSL[["AGE"]] ~ ADSL[["ARM"]], paired = FALSE) |>+ # calculate statistic (and remove FUN from the argument list) |
||
| 155 | -+ | |||
| 226 | +46x |
- #' broom::tidy()+ stat <- |
||
| 156 | -+ | |||
| 227 | +46x |
- #' )+ cards::eval_capture_conditions( |
||
| 157 | -+ | |||
| 228 | +46x |
- #' )+ do.call(args$FUN, args = args |> utils::modifyList(list(FUN = NULL))) |
||
| 158 | +229 |
- .format_ttest_results <- function(by = NULL, variable, lst_tidy, paired, ...) {
+ ) |
||
| 159 | +230 |
- # build ARD ------------------------------------------------------------------+ # if the result was calculated, then put it into a tibble |
||
| 160 | -8x | +231 | +46x |
- ret <-+ if (!is.null(stat[["result"]])) {
|
| 161 | -8x | +232 | +40x |
- cards::tidy_as_ard(+ df_stat <- |
| 162 | -8x | +233 | +40x |
- lst_tidy = lst_tidy,+ dplyr::tibble(variable, stat[["result"]][1]) |> |
| 163 | -8x | +234 | +40x |
- tidy_result_names =+ set_names(c("variable", "stat")) |>
|
| 164 | -8x | +235 | +40x |
- c(+ dplyr::mutate( |
| 165 | -8x | +236 | +40x |
- "estimate", "statistic",+ stat = as.list(unname(.data$stat)), |
| 166 | -8x | +237 | +40x |
- "p.value", "parameter", "conf.low", "conf.high",+ warning = list(stat[["warning"]]), |
| 167 | -8x | +238 | +40x |
- "method", "alternative"+ error = list(stat[["error"]]) |
| 168 | +239 |
- ) |>+ ) |
||
| 169 | +240 |
- # add estimate1 and estimate2 if there is a by variable+ } |
||
| 170 | -8x | +|||
| 241 | +
- append(values = switch(!is_empty(by), c("estimate1", "estimate2")), after = 1L), # styler: off
+ # otherwise, if there was an error return tibble with error message |
|||
| 171 | -8x | +|||
| 242 | +
- fun_args_to_record = c("mu", "paired", "var.equal", "conf.level"),
+ else {
|
|||
| 172 | -8x | +243 | +6x |
- formals = formals(asNamespace("stats")[["t.test.default"]]),
+ df_stat <- |
| 173 | -8x | +244 | +6x |
- passed_args = c(list(paired = paired), dots_list(...)),+ dplyr::tibble( |
| 174 | -8x | +245 | +6x |
- lst_ard_columns = list(variable = variable, context = "stats_t_test")+ variable = .env$variable, |
| 175 | -+ | |||
| 246 | +6x |
- )+ stat = list(NULL), |
||
| 176 | -+ | |||
| 247 | +6x |
-
+ warning = list(.env$stat[["warning"]]), |
||
| 177 | -8x | +248 | +6x |
- if (!is_empty(by)) {
+ error = list(.env$stat[["error"]]) |
| 178 | -7x | +|||
| 249 | +
- ret <- ret |>+ ) |
|||
| 179 | -7x | +|||
| 250 | +
- dplyr::mutate(group1 = by)+ } |
|||
| 180 | +251 |
} |
||
| 181 | +252 | |||
| 182 | +253 |
- # add the stat label ---------------------------------------------------------+ # if there is by variable(s), calculate statistics for the combinations |
||
| 183 | -8x | +|||
| 254 | +
- ret |>+ else {
|
|||
| 184 | -8x | +255 | +38x |
- dplyr::left_join(+ args$formula <- reformulate2(variable) |
| 185 | -8x | +256 | +38x |
- .df_ttest_stat_labels(by = by),+ args$by <- reformulate2(by) |
| 186 | -8x | +257 | +38x |
- by = "stat_name"+ stat <- |
| 187 | -+ | |||
| 258 | +38x |
- ) |>+ if (stat_name %in% c("median", paste0("p", 0:100))) {
|
||
| 188 | +259 | 8x |
- dplyr::mutate(stat_label = dplyr::coalesce(.data$stat_label, .data$stat_name)) |>+ cards::eval_capture_conditions( |
|
| 189 | +260 | 8x |
- cards::tidy_ard_column_order()- |
- |
| 190 | -- |
- }+ do.call(survey::svyby, args) |> set_names(c(by, "quantile", "ci.2.5", "ci.97.5", "se")) |
||
| 191 | +261 |
-
+ ) |
||
| 192 | -+ | |||
| 262 | +38x |
-
+ } else if (stat_name %in% "deff") {
|
||
| 193 | -+ | |||
| 263 | +3x |
- #' Convert long paired data to wide+ stat <- |
||
| 194 | -+ | |||
| 264 | +3x |
- #'+ cards::eval_capture_conditions( |
||
| 195 | -+ | |||
| 265 | +3x |
- #'+ do.call( |
||
| 196 | -+ | |||
| 266 | +3x |
- #' @param data (`data.frame`)\cr a data frame that is one line per subject per group+ survey::svyby, |
||
| 197 | -+ | |||
| 267 | +3x |
- #' @param by (`string`)\cr by column name+ args |> utils::modifyList(list(FUN = survey::svymean, deff = TRUE)) |
||
| 198 | +268 |
- #' @param variable (`string`)\cr variable column name+ ) |> |
||
| 199 | -+ | |||
| 269 | +3x |
- #' @param id (`string`)\cr subject id column name+ dplyr::select(all_of(by), dplyr::last_col()) # the last column is DEff |
||
| 200 | +270 |
- #'+ ) |
||
| 201 | +271 |
- #' @return a wide data frame+ } else {
|
||
| 202 | -+ | |||
| 272 | +27x |
- #' @keywords internal+ cards::eval_capture_conditions(do.call(survey::svyby, args)) |
||
| 203 | +273 |
- #' @examples+ } |
||
| 204 | +274 |
- #' cards::ADSL[c("ARM", "AGE")] |>
+
|
||
| 205 | +275 |
- #' dplyr::filter(ARM %in% c("Placebo", "Xanomeline High Dose")) |>
+ # if the result was calculated, then put it into a tibble |
||
| 206 | -+ | |||
| 276 | +38x |
- #' dplyr::mutate(.by = ARM, USUBJID = dplyr::row_number()) |>+ if (!is.null(stat[["result"]])) {
|
||
| 207 | -+ | |||
| 277 | +32x |
- #' dplyr::arrange(USUBJID, ARM) |>+ df_stat <- stat[["result"]][seq_len(length(by) + 1L)] |> |
||
| 208 | -+ | |||
| 278 | +32x |
- #' cardx:::.paired_data_pivot_wider(by = "ARM", variable = "AGE", id = "USUBJID")+ dplyr::as_tibble() %>% |
||
| 209 | +279 |
- .paired_data_pivot_wider <- function(data, by, variable, id) {
+ # adding unobserved combinations of "by" variables |
||
| 210 | +280 |
- # check the number of levels before pivoting data to wider format+ {
|
||
| 211 | -9x | +281 | +32x |
- if (dplyr::n_distinct(data[[by]], na.rm = TRUE) != 2L) {
+ dplyr::full_join( |
| 212 | -4x | +282 | +32x |
- cli::cli_abort("The {.arg by} argument must have two and only two levels.",
+ cards::nest_for_ard(data$variables, by = by, key = "...ard_no_one_will_ever_pick_this...", rename = FALSE, list_columns = FALSE) |> |
| 213 | -4x | +283 | +32x |
- call = get_cli_abort_call()+ dplyr::select(-"...ard_no_one_will_ever_pick_this..."), |
| 214 | +284 |
- )+ .,+ |
+ ||
| 285 | +32x | +
+ by = by |
||
| 215 | +286 |
- }+ ) |
||
| 216 | +287 |
-
+ } |> |
||
| 217 | -5x | +288 | +32x |
- data |>+ set_names(paste0("group", seq_along(by), "_level"), "stat") |>
|
| 218 | -+ | |||
| 289 | +32x |
- # arrange data so the first group always appears first+ dplyr::bind_cols( |
||
| 219 | -5x | +290 | +32x |
- dplyr::arrange(.data[[by]]) |>+ dplyr::tibble(!!!c(by, variable)) |> |
| 220 | -5x | +291 | +32x |
- tidyr::pivot_wider(+ set_names(paste0("group", seq_along(by)), "variable")
|
| 221 | -5x | +|||
| 292 | +
- id_cols = all_of(id),+ ) |> |
|||
| 222 | -5x | +293 | +32x |
- names_from = all_of(by),+ dplyr::mutate( |
| 223 | -5x | +294 | +32x |
- values_from = all_of(variable)+ dplyr::across(c(cards::all_ard_groups("levels"), "stat"), as.list),
|
| 224 | -+ | |||
| 295 | +32x |
- ) |>+ warning = list(.env$stat[["warning"]]), |
||
| 225 | -5x | +296 | +32x |
- stats::setNames(c(id, "by1", "by2"))+ error = list(.env$stat[["error"]]) |
| 226 | +297 |
- }+ ) |
||
| 227 | +298 |
-
+ } |
||
| 228 | +299 |
- .df_ttest_stat_labels <- function(by = NULL) {
+ # otherwise, if there was an error return tibble with error message+ |
+ ||
| 300 | ++ |
+ else {
|
||
| 229 | -18x | +301 | +6x |
- dplyr::tribble(+ df_stat <- |
| 230 | -18x | +302 | +6x |
- ~stat_name, ~stat_label,+ cards::nest_for_ard(data$variables, by = by, key = "...ard_no_one_will_ever_pick_this...") |> |
| 231 | -18x | +303 | +6x |
- "estimate1", "Group 1 Mean",+ dplyr::select(-"...ard_no_one_will_ever_pick_this...") |> |
| 232 | -18x | +304 | +6x |
- "estimate2", "Group 2 Mean",+ dplyr::mutate( |
| 233 | -18x | +305 | +6x |
- "estimate", ifelse(is_empty(by), "Mean", "Mean Difference"),+ variable = .env$variable, |
| 234 | -18x | +306 | +6x |
- "p.value", "p-value",+ stat = list(NULL), |
| 235 | -18x | +307 | +6x |
- "statistic", "t Statistic",+ warning = list(.env$stat[["warning"]]), |
| 236 | -18x | +308 | +6x |
- "parameter", "Degrees of Freedom",+ error = list(.env$stat[["error"]])+ |
+
| 309 | ++ |
+ )+ |
+ ||
| 310 | ++ |
+ }+ |
+ ||
| 311 | ++ |
+ }+ |
+ ||
| 312 | ++ | + | ||
| 237 | -18x | +313 | +84x |
- "conf.low", "CI Lower Bound",+ df_stat |> |
| 238 | -18x | +314 | +84x |
- "conf.high", "CI Upper Bound",+ dplyr::mutate( |
| 239 | -18x | +315 | +84x |
- "mu", "H0 Mean",+ stat_name = .env$stat_name, |
| 240 | -18x | +316 | +84x |
- "paired", "Paired t-test",+ across( |
| 241 | -18x | +317 | +84x |
- "var.equal", "Equal Variances",+ c(cards::all_ard_groups("levels"), cards::all_ard_variables("levels")),
|
| 242 | -18x | +318 | +84x |
- "conf.level", "CI Confidence Level",+ ~ map(.x, as.character) |
| 243 | +319 |
- )+ ) |
||
| 244 | +320 | ++ |
+ )+ |
+ |
| 321 |
}@@ -29239,14 +27892,14 @@ cardx coverage - 95.32% |
| 1 |
- #' ARD for LS Mean Difference+ #' ARD Dichotomous Survey Statistics |
|||
| 3 |
- #' @description+ #' Compute Analysis Results Data (ARD) for dichotomous summary statistics. |
|||
| 4 |
- #' This function calculates least-squares mean differences using the 'emmeans'+ #' |
|||
| 5 |
- #' package using the following+ #' @inheritParams ard_categorical.survey.design |
|||
| 6 |
- #'+ #' @param value (named `list`)\cr |
|||
| 7 |
- #' ```r+ #' named list of dichotomous values to tabulate. |
|||
| 8 |
- #' emmeans::emmeans(object = <regression model>, specs = ~ <primary covariate>) |>+ #' Default is `cards::maximum_variable_value(data$variables)`, |
|||
| 9 |
- #' emmeans::contrast(method = "pairwise") |>+ #' which returns the largest/last value after a sort. |
|||
| 10 |
- #' summary(infer = TRUE, level = <confidence level>)+ #' |
|||
| 11 |
- #' ```+ #' @return an ARD data frame of class 'card' |
|||
| 12 |
- #'+ #' @export |
|||
| 13 |
- #' The arguments `data`, `formula`, `method`, `method.args`, `package` are used+ #' |
|||
| 14 |
- #' to construct the regression model via `cardx::construct_model()`.+ #' @examples |
|||
| 15 |
- #'+ #' survey::svydesign(ids = ~1, data = mtcars, weights = ~1) |> |
|||
| 16 |
- #' @param data (`data.frame`/`survey.design`)\cr+ #' ard_dichotomous(by = vs, variables = c(cyl, am), value = list(cyl = 4)) |
|||
| 17 |
- #' a data frame or survey design object+ ard_dichotomous.survey.design <- function(data, |
|||
| 18 |
- #' @inheritParams construct_model+ variables, |
|||
| 19 |
- #' @param response_type (`string`)+ by = NULL, |
|||
| 20 |
- #' string indicating whether the model outcome is `'continuous'`+ value = cards::maximum_variable_value(data$variables[variables]), |
|||
| 21 |
- #' or `'dichotomous'`. When `'dichotomous'`, the call to `emmeans::emmeans()` is+ statistic = everything() ~ c("n", "N", "p", "p.std.error", "deff", "n_unweighted", "N_unweighted", "p_unweighted"),
|
|||
| 22 |
- #' supplemented with argument `regrid="response"`.+ denominator = c("column", "row", "cell"),
|
|||
| 23 |
- #' @param conf.level (scalar `numeric`)\cr+ fmt_fn = NULL, |
|||
| 24 |
- #' confidence level for confidence interval. Default is `0.95`.+ stat_label = everything() ~ list( |
|||
| 25 |
- #' @param primary_covariate (`string`)\cr+ p = "%", |
|||
| 26 |
- #' string indicating the primary covariate (typically the dichotomous treatment variable).+ p.std.error = "SE(%)", |
|||
| 27 |
- #' Default is the first covariate listed in the formula.+ deff = "Design Effect", |
|||
| 28 |
- #'+ "n_unweighted" = "Unweighted n", |
|||
| 29 |
- #' @return ARD data frame+ "N_unweighted" = "Unweighted N", |
|||
| 30 |
- #' @export+ "p_unweighted" = "Unweighted %" |
|||
| 31 |
- #'+ ), |
|||
| 32 |
- #' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = "emmeans", reference_pkg = "cardx"))
+ ...) {
|
|||
| 33 | -+ | 13x |
- #' ard_emmeans_mean_difference(+ set_cli_abort_call() |
|
| 34 | -+ | 13x |
- #' data = mtcars,+ check_dots_empty() |
|
| 35 | -+ | 13x |
- #' formula = mpg ~ am + cyl,+ check_pkg_installed(pkg = "survey", reference_pkg = "cardx") |
|
| 36 |
- #' method = "lm"+ |
|||
| 37 |
- #' )+ # check inputs --------------------------------------------------------------- |
|||
| 38 | -+ | 13x |
- #'+ check_not_missing(variables) |
|
| 39 |
- #' ard_emmeans_mean_difference(+ |
|||
| 40 |
- #' data = mtcars,+ # process inputs ------------------------------------------------------------- |
|||
| 41 | -+ | 13x |
- #' formula = vs ~ am + mpg,+ cards::process_selectors(data$variables, variables = {{ variables }})
|
|
| 42 | -+ | 13x |
- #' method = "glm",+ cards::process_formula_selectors(data$variables[variables], value = value) |
|
| 43 | -+ | 13x |
- #' method.args = list(family = binomial),+ cards::fill_formula_selectors( |
|
| 44 | -+ | 13x |
- #' response_type = "dichotomous"+ data$variables[variables], |
|
| 45 | -+ | 13x |
- #' )+ value = formals(asNamespace("cardx")[["ard_dichotomous.survey.design"]])[["value"]] |> eval()
|
|
| 46 |
- ard_emmeans_mean_difference <- function(data, formula, method,+ ) |
|||
| 47 | -+ | 13x |
- method.args = list(),+ .check_dichotomous_value(data$variables, value) |
|
| 48 |
- package = "base",+ |
|||
| 49 |
- response_type = c("continuous", "dichotomous"),
+ # return empty tibble if no variables selected ------------------------------- |
|||
| 50 | -+ | 12x |
- conf.level = 0.95,+ if (is_empty(variables)) {
|
|
| 51 | -+ | ! |
- primary_covariate =+ return(dplyr::tibble()) |
|
| 52 |
- stats::terms(formula) |>+ } |
|||
| 53 |
- attr("term.labels") |>
+
|
|||
| 54 |
- getElement(1L)) {
+ # calculate summary statistics ----------------------------------------------- |
|||
| 55 | -3x | +12x |
- set_cli_abort_call()+ ard_categorical( |
|
| 56 | -+ | 12x |
-
+ data = data, |
|
| 57 | -+ | 12x |
- # check package installation -------------------------------------------------+ variables = all_of(variables), |
|
| 58 | -3x | +12x |
- check_pkg_installed(c("emmeans", package), reference_pkg = "cardx")
+ by = {{ by }},
|
|
| 59 | -3x | +12x |
- check_not_missing(data)+ statistic = statistic, |
|
| 60 | -3x | +12x |
- check_not_missing(formula)+ denominator = denominator, |
|
| 61 | -3x | +12x |
- check_not_missing(method)+ fmt_fn = fmt_fn, |
|
| 62 | -3x | +12x |
- check_class(data, c("data.frame", "survey.design"))
+ stat_label = stat_label |
|
| 63 | -3x | +
- check_class(formula, cls = "formula")+ ) |> |
||
| 64 | -3x | +12x |
- check_string(package)+ dplyr::filter( |
|
| 65 | -3x | +12x |
- check_string(primary_covariate)+ pmap( |
|
| 66 | -3x | +12x |
- check_scalar(conf.level)+ list(.data$variable, .data$variable_level), |
|
| 67 | -3x | +12x |
- check_range(conf.level, range = c(0, 1))+ function(variable, variable_level) {
|
|
| 68 | -3x | +792x |
- response_type <- arg_match(response_type, error_call = get_cli_abort_call())+ variable_level %in% .env$value[[variable]] |
|
| 69 |
-
+ } |
|||
| 70 |
- # construct primary model ----------------------------------------------------+ ) |> |
|||
| 71 | -3x | +12x |
- mod <-+ unlist() |
|
| 72 | -3x | +
- construct_model(+ ) |> |
||
| 73 | -3x | +12x |
- data = data, formula = formula, method = method,+ dplyr::mutate(context = "dichotomous") |
|
| 74 | -3x | +
- method.args = {{ method.args }},
+ } |
||
| 75 | -3x | +
- package = package, env = caller_env()+ |
||
| 76 |
- )+ #' Perform Value Checks |
|||
| 77 |
-
+ #' |
|||
| 78 |
- # emmeans --------------------------------------------------------------------+ #' Check the validity of the values passed in `ard_dichotomous(value)`. |
|||
| 79 | -3x | +
- emmeans_args <- list(object = mod, specs = reformulate2(primary_covariate))+ #' |
||
| 80 | -2x | +
- if (response_type %in% "dichotomous") emmeans_args <- c(emmeans_args, list(regrid = "response"))+ #' @param data (`data.frame`)\cr |
||
| 81 | -3x | +
- emmeans <-+ #' a data frame |
||
| 82 | -3x | +
- withr::with_namespace(+ #' @param value (named `list`)\cr |
||
| 83 | -3x | +
- package = "emmeans",+ #' a named list |
||
| 84 | -3x | +
- code = do.call("emmeans", args = emmeans_args)
+ #' |
||
| 85 |
- )+ #' @return returns invisible if check is successful, throws an error message if not. |
|||
| 86 |
-
+ #' @keywords internal |
|||
| 87 | -3x | +
- df_results <-+ #' |
||
| 88 | -3x | +
- emmeans |>+ #' @examples |
||
| 89 | -3x | +
- emmeans::contrast(method = "pairwise") |>+ #' cardx:::.check_dichotomous_value(mtcars, list(cyl = 4)) |
||
| 90 | -3x | +
- summary(infer = TRUE, level = conf.level)+ .check_dichotomous_value <- function(data, value) {
|
||
| 91 | -+ | 13x |
-
+ imap( |
|
| 92 | -+ | 13x |
- # convert results to ARD format ----------------------------------------------+ value, |
|
| 93 | -3x | +13x |
- df_results |>+ function(value, column) {
|
|
| 94 | -3x | +25x |
- dplyr::as_tibble() |>+ accepted_values <- .unique_and_sorted(data[[column]]) |
|
| 95 | -3x | +25x |
- dplyr::rename(+ if (length(value) != 1L || !value %in% accepted_values) {
|
|
| 96 | -3x | +1x |
- conf.low = any_of("asymp.LCL"),
+ message <- "Error in argument {.arg value} for variable {.val {column}}."
|
|
| 97 | -3x | +1x |
- conf.high = any_of("asymp.UCL"),
+ message <- |
|
| 98 | -3x | +1x |
- conf.low = any_of("lower.CL"),
+ case_switch( |
|
| 99 | -3x | +1x |
- conf.high = any_of("upper.CL")
+ length(value) != 1L ~ c(message, "i" = "The value must be one of {.val {accepted_values}}."),
|
|
| 100 | -+ | 1x |
- ) %>%+ .default = c(message, "i" = "A value of {.val {value}} was passed, but must be one of {.val {accepted_values}}.")
|
|
| 101 | -3x | +
- dplyr::select(+ ) |
||
| 102 | -3x | +1x |
- variable_level = "contrast",+ if (length(value) == 1L) {
|
|
| 103 | -3x | +1x |
- "estimate",+ message <- |
|
| 104 | -3x | +1x |
- std.error = "SE", "df",+ case_switch( |
|
| 105 | -3x | +1x |
- "conf.low", "conf.high", "p.value"+ inherits(data[[column]], "factor") ~ |
|
| 106 | -+ | 1x |
- ) %>%+ c(message, i = "To summarize this value, use {.fun forcats::fct_expand} to add {.val {value}} as a level."),
|
|
| 107 | -3x | +1x |
- dplyr::mutate(+ .default = c(message, i = "To summarize this value, make the column a factor and include {.val {value}} as a level.")
|
|
| 108 | -3x | +
- conf.level = .env$conf.level,+ ) |
||
| 109 | -3x | +
- method =+ }+ |
+ ||
| 110 | ++ | + + | +||
| 111 | ++ | + + | +||
| 112 | +1x | +
+ cli::cli_abort(+ |
+ ||
| 113 | +1x | +
+ message = message,+ |
+ ||
| 114 | +1x | +
+ call = get_cli_abort_call()+ |
+ ||
| 115 | ++ |
+ )+ |
+ ||
| 116 | ++ |
+ }+ |
+ ||
| 117 | ++ |
+ }+ |
+ ||
| 118 | ++ |
+ ) |>+ |
+ ||
| 119 | +13x | +
+ invisible()+ |
+ ||
| 120 | ++ |
+ }+ |
+ ||
| 121 | ++ | + + | +||
| 122 | ++ |
+ #' ARD-flavor of unique()+ |
+ ||
| 123 | ++ |
+ #'+ |
+ ||
| 124 | ++ |
+ #' Essentially a wrapper for `unique(x) |> sort()` with `NA` levels removed.+ |
+ ||
| 125 | ++ |
+ #' For factors, all levels are returned even if they are unobserved.+ |
+ ||
| 126 | ++ |
+ #' Similarly, logical vectors always return `c(TRUE, FALSE)`, even if+ |
+ ||
| 127 | ++ |
+ #' both levels are not observed.+ |
+ ||
| 128 | ++ |
+ #'+ |
+ ||
| 129 | ++ |
+ #' @param x (`any`)\cr+ |
+ ||
| 130 | ++ |
+ #' a vector+ |
+ ||
| 131 | ++ |
+ #'+ |
+ ||
| 132 | ++ |
+ #' @return a vector+ |
+ ||
| 133 | ++ |
+ #' @keywords internal+ |
+ ||
| 134 | ++ |
+ #'+ |
+ ||
| 135 | ++ |
+ #' @examples+ |
+ ||
| 136 | ++ |
+ #' cards:::.unique_and_sorted(factor(letters[c(5, 5:1)], levels = letters))+ |
+ ||
| 137 | ++ |
+ #' |
||
| 110 | -3x | +|||
| 138 | +
- ifelse(+ #' cards:::.unique_and_sorted(c(FALSE, TRUE, TRUE, FALSE)) |
|||
| 111 | -3x | +|||
| 139 | +
- length(attr(stats::terms(formula), "term.labels") |> discard(~ startsWith(., "1 |"))) == 1L,+ #' |
|||
| 112 | -3x | +|||
| 140 | +
- "Least-squares mean difference",+ #' cards:::.unique_and_sorted(c(5, 5:1)) |
|||
| 113 | -3x | +|||
| 141 | +
- "Least-squares adjusted mean difference"+ .unique_and_sorted <- function(x, useNA = c("no", "always")) {
|
|||
| 114 | +142 |
- ),+ # styler: off |
||
| 115 | -3x | +143 | +25x |
- across(everything(), as.list),+ useNA <- match.arg(useNA) |
| 116 | -3x | +|||
| 144 | +
- variable = "contrast",+ # if a factor return a factor that includes the same levels (including unobserved levels) |
|||
| 117 | -3x | +145 | +25x |
- group1 = .env$primary_covariate+ if (inherits(x, "factor")) {
|
| 118 | -+ | |||
| 146 | +12x |
- ) |>+ return( |
||
| 119 | -3x | +147 | +12x |
- tidyr::pivot_longer(+ factor( |
| 120 | -3x | +148 | +12x |
- cols = -c("group1", "variable", "variable_level"),
+ if (useNA == "no") levels(x) |
| 121 | -3x | +149 | +12x |
- names_to = "stat_name",+ else c(levels(x), NA_character_), |
| 122 | -3x | +150 | +12x |
- values_to = "stat"+ levels = levels(x) |
| 123 | +151 |
- ) |>+ ) |
||
| 124 | -3x | +|||
| 152 | +
- dplyr::left_join(.df_ttest_stat_labels(primary_covariate), by = "stat_name") |>+ ) |
|||
| 125 | -3x | +|||
| 153 | +
- dplyr::mutate(+ } |
|||
| 126 | -3x | +154 | +13x |
- context = "emmeans_mean_difference",+ if (inherits(x, "logical")) {
|
| 127 | -3x | +155 | +7x |
- stat_label = dplyr::coalesce(.data$stat_label, .data$stat_name),+ if (useNA == "no") return(c(TRUE, FALSE)) |
| 128 | -3x | +|||
| 156 | +! |
- warning = list(NULL),+ else return(c(TRUE, FALSE, NA)) |
||
| 129 | -3x | +|||
| 157 | +
- error = list(NULL),+ } |
|||
| 130 | -3x | +|||
| 158 | +
- fmt_fn = map(.data$stat, \(.x) if (is.numeric(.x)) 1L else NULL) # styler: off+ |
|||
| 131 | +159 |
- ) |>+ # otherwise, return a simple unique and sort of the vector |
||
| 132 | -3x | +160 | +6x |
- cards::tidy_ard_column_order() %>%+ if (useNA == "no") return(unique(x) |> sort()) |
| 133 | -3x | +|||
| 161 | +! |
- {structure(., class = c("card", class(.)))} # styler: off
+ else return(unique(x) |> sort() |> c(NA)) |
||
| 134 | +162 | ++ |
+ # styler: on+ |
+ |
| 163 |
}@@ -30183,14 +29039,14 @@ cardx coverage - 95.32% |
| 1 |
- #' ARD Dichotomous Survey Statistics+ #' ARD Missing Survey Statistics |
|||
| 3 |
- #' Compute Analysis Results Data (ARD) for dichotomous summary statistics.+ #' Compute Analysis Results Data (ARD) for statistics related to data missingness for survey objects |
|||
| 6 |
- #' @param value (named `list`)\cr+ #' |
|||
| 7 |
- #' named list of dichotomous values to tabulate.+ #' @return an ARD data frame of class 'card' |
|||
| 8 |
- #' Default is `cards::maximum_variable_value(data$variables)`,+ #' @export |
|||
| 9 |
- #' which returns the largest/last value after a sort.+ #' |
|||
| 10 |
- #'+ #' @examplesIf cardx:::is_pkg_installed("survey", reference_pkg = "cardx")
|
|||
| 11 |
- #' @return an ARD data frame of class 'card'+ #' svy_titanic <- survey::svydesign(~1, data = as.data.frame(Titanic), weights = ~Freq) |
|||
| 12 |
- #' @export+ #' |
|||
| 13 |
- #'+ #' ard_missing(svy_titanic, variables = c(Class, Age), by = Survived) |
|||
| 14 |
- #' @examples+ ard_missing.survey.design <- function(data, |
|||
| 15 |
- #' survey::svydesign(ids = ~1, data = mtcars, weights = ~1) |>+ variables, |
|||
| 16 |
- #' ard_dichotomous(by = vs, variables = c(cyl, am), value = list(cyl = 4))+ by = NULL, |
|||
| 17 |
- ard_dichotomous.survey.design <- function(data,+ statistic = |
|||
| 18 |
- variables,+ everything() ~ c( |
|||
| 19 |
- by = NULL,+ "N_obs", "N_miss", "N_nonmiss", "p_miss", "p_nonmiss", |
|||
| 20 |
- value = cards::maximum_variable_value(data$variables[variables]),+ "N_obs_unweighted", "N_miss_unweighted", "N_nonmiss_unweighted", |
|||
| 21 |
- statistic = everything() ~ c("n", "N", "p", "p.std.error", "deff", "n_unweighted", "N_unweighted", "p_unweighted"),
+ "p_miss_unweighted", "p_nonmiss_unweighted" |
|||
| 22 |
- denominator = c("column", "row", "cell"),
+ ), |
|||
| 23 |
- fmt_fn = NULL,+ fmt_fn = NULL, |
|||
| 24 |
- stat_label = everything() ~ list(+ stat_label = |
|||
| 25 |
- p = "%",+ everything() ~ list( |
|||
| 26 |
- p.std.error = "SE(%)",+ N_obs = "Total N", |
|||
| 27 |
- deff = "Design Effect",+ N_miss = "N Missing", |
|||
| 28 |
- "n_unweighted" = "Unweighted n",+ N_nonmiss = "N not Missing", |
|||
| 29 |
- "N_unweighted" = "Unweighted N",+ p_miss = "% Missing", |
|||
| 30 |
- "p_unweighted" = "Unweighted %"+ p_nonmiss = "% not Missing",+ |
+ |||
| 31 | ++ |
+ N_obs_unweighted = "Total N (unweighted)",+ |
+ ||
| 32 | ++ |
+ N_miss_unweighted = "N Missing (unweighted)",+ |
+ ||
| 33 | ++ |
+ N_nonmiss_unweighted = "N not Missing (unweighted)",+ |
+ ||
| 34 | ++ |
+ p_miss_unweighted = "% Missing (unweighted)",+ |
+ ||
| 35 | ++ |
+ p_nonmiss_unweighted = "% not Missing (unweighted)"+ |
+ ||
| 36 | ++ |
+ ),+ |
+ ||
| 37 | ++ |
+ ...) {
+ |
+ ||
| 38 | +4x | +
+ set_cli_abort_call()+ |
+ ||
| 39 | +4x | +
+ check_dots_empty()+ |
+ ||
| 40 | +4x | +
+ check_pkg_installed(pkg = "survey", reference_pkg = "cardx")+ |
+ ||
| 41 | ++ | + + | +||
| 42 | ++ |
+ # process inputs -------------------------------------------------------------+ |
+ ||
| 43 | +4x | +
+ check_not_missing(variables)+ |
+ ||
| 44 | +4x | +
+ cards::process_selectors(+ |
+ ||
| 45 | +4x | +
+ data = data$variables,+ |
+ ||
| 46 | +4x | +
+ variables = {{ variables }},
+ |
+ ||
| 47 | +4x | +
+ by = {{ by }}
+ |
+ ||
| 48 | ++ |
+ )+ |
+ ||
| 49 | ++ | + + | +||
| 50 | ++ |
+ # convert all variables to T/F whether it's missing --------------------------+ |
+ ||
| 51 | +4x | +
+ data$variables <- data$variables |>+ |
+ ||
| 52 | +4x | +
+ dplyr::mutate(across(all_of(variables), Negate(is.na)))+ |
+ ||
| 53 | ++ | + + | +||
| 54 | +4x | +
+ cards::process_formula_selectors(+ |
+ ||
| 55 | +4x | +
+ data$variables[variables],+ |
+ ||
| 56 | +4x | +
+ statistic = statistic,+ |
+ ||
| 57 | +4x | +
+ fmt_fn = fmt_fn,+ |
+ ||
| 58 | +4x | +
+ stat_label = stat_label+ |
+ ||
| 59 | ++ |
+ )+ |
+ ||
| 60 | +4x | +
+ cards::fill_formula_selectors(+ |
+ ||
| 61 | +4x | +
+ data$variables[variables],+ |
+ ||
| 62 | +4x | +
+ statistic = formals(asNamespace("cardx")[["ard_missing.survey.design"]])[["statistic"]] |> eval()
+ |
+ ||
| 63 | ++ |
+ )+ |
+ ||
| 64 | +4x | +
+ cards::fill_formula_selectors(+ |
+ ||
| 65 | +4x | +
+ data$variables[variables],+ |
+ ||
| 66 | +4x | +
+ stat_label = formals(asNamespace("cardx")[["ard_missing.survey.design"]])[["stat_label"]] |> eval()
+ |
+ ||
| 67 | ++ |
+ )+ |
+ ||
| 68 | ++ | + + | +||
| 69 | +4x | +
+ stats_available <- c(+ |
+ ||
| 70 | +4x | +
+ "N_obs", "N_miss", "N_nonmiss", "p_miss", "p_nonmiss",+ |
+ ||
| 71 | +4x | +
+ "N_obs_unweighted", "N_miss_unweighted", "N_nonmiss_unweighted", |
||
| 31 | -+ | |||
| 72 | +4x |
- ),+ "p_miss_unweighted", "p_nonmiss_unweighted" |
||
| 32 | +73 |
- ...) {
+ ) |
||
| 33 | -13x | +74 | +4x |
- set_cli_abort_call()+ cards::check_list_elements( |
| 34 | -13x | +75 | +4x |
- check_dots_empty()+ x = statistic, |
| 35 | -13x | +76 | +4x |
- check_pkg_installed(pkg = "survey", reference_pkg = "cardx")+ predicate = \(x) is.character(x) && all(x %in% stats_available), |
| 36 | -+ | |||
| 77 | +4x |
-
+ error_msg = "Elements passed in the {.arg statistic} argument must be one or more of {.val {stats_available}}"
|
||
| 37 | +78 |
- # check inputs ---------------------------------------------------------------- |
- ||
| 38 | -13x | -
- check_not_missing(variables)+ ) |
||
| 39 | +79 | |||
| 40 | +80 |
- # process inputs -------------------------------------------------------------+ # calculate results ---------------------------------------------------------- |
||
| 41 | -13x | +81 | +4x |
- cards::process_selectors(data$variables, variables = {{ variables }})
+ result <- |
| 42 | -13x | +82 | +4x |
- cards::process_formula_selectors(data$variables[variables], value = value)+ ard_categorical( |
| 43 | -13x | +83 | +4x |
- cards::fill_formula_selectors(+ data = data, |
| 44 | -13x | +84 | +4x |
- data$variables[variables],+ variables = all_of(variables), |
| 45 | -13x | +85 | +4x |
- value = formals(asNamespace("cardx")[["ard_dichotomous.survey.design"]])[["value"]] |> eval()
+ by = any_of(by), |
| 46 | -+ | |||
| 86 | +4x |
- )+ statistic = everything() ~ c("n", "N", "p", "n_unweighted", "N_unweighted", "p_unweighted")
|
||
| 47 | -13x | +|||
| 87 | +
- .check_dichotomous_value(data$variables, value)+ ) |
|||
| 48 | +88 | |||
| 49 | +89 |
- # return empty tibble if no variables selected -------------------------------+ # rename the stats for missingness ------------------------------------------- |
||
| 50 | -12x | -
- if (is_empty(variables)) {
- |
- ||
| 51 | -! | +90 | +4x |
- return(dplyr::tibble())+ result <- result |> |
| 52 | -+ | |||
| 91 | +4x |
- }+ dplyr::mutate( |
||
| 53 | -+ | |||
| 92 | +4x |
-
+ stat_name = |
||
| 54 | -+ | |||
| 93 | +4x |
- # calculate summary statistics -----------------------------------------------+ dplyr::case_when( |
||
| 55 | -12x | +94 | +4x |
- ard_categorical(+ .data$stat_name %in% "N" ~ "N_obs", |
| 56 | -12x | +95 | +4x |
- data = data,+ .data$stat_name %in% "n" & .data$variable_level %in% FALSE ~ "N_miss", |
| 57 | -12x | +96 | +4x |
- variables = all_of(variables),+ .data$stat_name %in% "n" & .data$variable_level %in% TRUE ~ "N_nonmiss", |
| 58 | -12x | +97 | +4x |
- by = {{ by }},
+ .data$stat_name %in% "p" & .data$variable_level %in% FALSE ~ "p_miss", |
| 59 | -12x | +98 | +4x |
- statistic = statistic,+ .data$stat_name %in% "p" & .data$variable_level %in% TRUE ~ "p_nonmiss", |
| 60 | -12x | +99 | +4x |
- denominator = denominator,+ .data$stat_name %in% "N_unweighted" ~ "N_obs_unweighted", |
| 61 | -12x | +100 | +4x |
- fmt_fn = fmt_fn,+ .data$stat_name %in% "n_unweighted" & .data$variable_level %in% FALSE ~ "N_miss_unweighted", |
| 62 | -12x | +101 | +4x |
- stat_label = stat_label+ .data$stat_name %in% "n_unweighted" & .data$variable_level %in% TRUE ~ "N_nonmiss_unweighted", |
| 63 | -+ | |||
| 102 | +4x |
- ) |>+ .data$stat_name %in% "p_unweighted" & .data$variable_level %in% FALSE ~ "p_miss_unweighted", |
||
| 64 | -12x | +103 | +4x |
- dplyr::filter(+ .data$stat_name %in% "p_unweighted" & .data$variable_level %in% TRUE ~ "p_nonmiss_unweighted" |
| 65 | -12x | +|||
| 104 | +
- pmap(+ ) |
|||
| 66 | -12x | +|||
| 105 | +
- list(.data$variable, .data$variable_level),+ ) |> |
|||
| 67 | -12x | +106 | +4x |
- function(variable, variable_level) {
+ dplyr::select(-cards::all_ard_variables("levels"), -"stat_label", -"fmt_fn") |>
|
| 68 | -792x | +107 | +4x |
- variable_level %in% .env$value[[variable]]+ dplyr::slice(1L, .by = c(cards::all_ard_groups(), cards::all_ard_variables(), "stat_name")) |
| 69 | +108 |
- }+ |
||
| 70 | +109 |
- ) |>+ # final processing of fmt_fn ------------------------------------------------- |
||
| 71 | -12x | +110 | +4x |
- unlist()+ result <- result |> |
| 72 | -+ | |||
| 111 | +4x |
- ) |>+ .process_nested_list_as_df( |
||
| 73 | -12x | +112 | +4x |
- dplyr::mutate(context = "dichotomous")+ arg = fmt_fn, |
| 74 | -+ | |||
| 113 | +4x |
- }+ new_column = "fmt_fn" |
||
| 75 | +114 |
-
+ ) |> |
||
| 76 | -+ | |||
| 115 | +4x |
- #' Perform Value Checks+ .default_svy_cat_fmt_fn() |
||
| 77 | +116 |
- #'+ |
||
| 78 | +117 |
- #' Check the validity of the values passed in `ard_dichotomous(value)`.+ # merge in statistic labels -------------------------------------------------- |
||
| 79 | -+ | |||
| 118 | +4x |
- #'+ result <- result |> |
||
| 80 | -+ | |||
| 119 | +4x |
- #' @param data (`data.frame`)\cr+ .process_nested_list_as_df( |
||
| 81 | -+ | |||
| 120 | +4x |
- #' a data frame+ arg = stat_label, |
||
| 82 | -+ | |||
| 121 | +4x |
- #' @param value (named `list`)\cr+ new_column = "stat_label", |
||
| 83 | -+ | |||
| 122 | +4x |
- #' a named list+ unlist = TRUE |
||
| 84 | +123 |
- #'+ ) |> |
||
| 85 | -+ | |||
| 124 | +4x |
- #' @return returns invisible if check is successful, throws an error message if not.+ dplyr::mutate(stat_label = dplyr::coalesce(.data$stat_label, .data$stat_name)) |
||
| 86 | +125 |
- #' @keywords internal+ |
||
| 87 | +126 |
- #'+ # return final object -------------------------------------------------------- |
||
| 88 | -+ | |||
| 127 | +4x |
- #' @examples+ result |> |
||
| 89 | -+ | |||
| 128 | +4x |
- #' cardx:::.check_dichotomous_value(mtcars, list(cyl = 4))+ dplyr::mutate(context = "missing") |> |
||
| 90 | -+ | |||
| 129 | +4x |
- .check_dichotomous_value <- function(data, value) {
+ cards::tidy_ard_column_order() %>% |
||
| 91 | -13x | +130 | +4x |
- imap(+ {structure(., class = c("card", class(.)))} # styler: off
|
| 92 | -13x | +|||
| 131 | +
- value,+ } |
|||
| 93 | -13x | +
| 1 | +
- function(value, column) {
+ #' ARD Kruskal-Wallis Test |
|||
| 94 | -25x | +|||
| 2 | +
- accepted_values <- .unique_and_sorted(data[[column]])+ #' |
|||
| 95 | -25x | +|||
| 3 | +
- if (length(value) != 1L || !value %in% accepted_values) {
+ #' @description |
|||
| 96 | -1x | +|||
| 4 | +
- message <- "Error in argument {.arg value} for variable {.val {column}}."
+ #' Analysis results data for Kruskal-Wallis Rank Sum Test. |
|||
| 97 | -1x | +|||
| 5 | +
- cli::cli_abort(+ #' |
|||
| 98 | -1x | +|||
| 6 | +
- if (length(value) != 1L) {
+ #' Calculated with `kruskal.test(data[[variable]], data[[by]], ...)` |
|||
| 99 | -! | +|||
| 7 | +
- c(message, "i" = "The value must be one of {.val {accepted_values}}.")
+ #' |
|||
| 100 | +8 |
- } else {
+ #' @param data (`data.frame`)\cr |
||
| 101 | -1x | +|||
| 9 | +
- c(message, "i" = "A value of {.val {value}} was passed, but must be one of {.val {accepted_values}}.")
+ #' a data frame. |
|||
| 102 | +10 |
- },+ #' @param by ([`tidy-select`][dplyr::dplyr_tidy_select])\cr |
||
| 103 | -1x | +|||
| 11 | +
- call = get_cli_abort_call()+ #' column name to compare by. |
|||
| 104 | +12 |
- )+ #' @param variables ([`tidy-select`][dplyr::dplyr_tidy_select])\cr |
||
| 105 | +13 |
- }+ #' column names to be compared. Independent tests will |
||
| 106 | +14 |
- }+ #' be computed for each variable. |
||
| 107 | +15 |
- ) |>+ #' |
||
| 108 | -13x | +|||
| 16 | +
- invisible()+ #' @return ARD data frame |
|||
| 109 | +17 |
- }+ #' @export |
||
| 110 | +18 |
-
+ #' |
||
| 111 | +19 |
- #' ARD-flavor of unique()+ #' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = "broom", reference_pkg = "cardx"))
|
||
| 112 | +20 |
- #'+ #' cards::ADSL |> |
||
| 113 | +21 |
- #' Essentially a wrapper for `unique(x) |> sort()` with `NA` levels removed.+ #' ard_stats_kruskal_test(by = "ARM", variables = "AGE") |
||
| 114 | +22 |
- #' For factors, all levels are returned even if they are unobserved.+ ard_stats_kruskal_test <- function(data, by, variables) {
|
||
| 115 | -+ | |||
| 23 | +2x |
- #' Similarly, logical vectors always return `c(TRUE, FALSE)`, even if+ set_cli_abort_call() |
||
| 116 | +24 |
- #' both levels are not observed.+ |
||
| 117 | +25 |
- #'+ # check installed packages --------------------------------------------------- |
||
| 118 | -+ | |||
| 26 | +2x |
- #' @param x (`any`)\cr+ check_pkg_installed("broom", reference_pkg = "cardx")
|
||
| 119 | +27 |
- #' a vector+ |
||
| 120 | +28 |
- #'+ # check/process inputs ------------------------------------------------------- |
||
| 121 | -+ | |||
| 29 | +2x |
- #' @return a vector+ check_not_missing(data) |
||
| 122 | -+ | |||
| 30 | +2x |
- #' @keywords internal+ check_not_missing(variables) |
||
| 123 | -+ | |||
| 31 | +2x |
- #'+ check_not_missing(by) |
||
| 124 | -+ | |||
| 32 | +2x |
- #' @examples+ check_data_frame(data) |
||
| 125 | -+ | |||
| 33 | +2x |
- #' cards:::.unique_and_sorted(factor(letters[c(5, 5:1)], levels = letters))+ cards::process_selectors(data, by = {{ by }}, variables = {{ variables }})
|
||
| 126 | -+ | |||
| 34 | +2x |
- #'+ check_scalar(by) |
||
| 127 | +35 |
- #' cards:::.unique_and_sorted(c(FALSE, TRUE, TRUE, FALSE))+ |
||
| 128 | +36 |
- #'+ # if no variables selected, return empty tibble ------------------------------ |
||
| 129 | -+ | |||
| 37 | +2x |
- #' cards:::.unique_and_sorted(c(5, 5:1))+ if (is_empty(variables)) {
+ |
+ ||
| 38 | +! | +
+ return(dplyr::tibble()) |
||
| 130 | +39 |
- .unique_and_sorted <- function(x, useNA = c("no", "always")) {
+ } |
||
| 131 | +40 |
- # styler: off+ # build ARD ------------------------------------------------------------------ |
||
| 132 | -25x | +41 | +2x |
- useNA <- match.arg(useNA)+ lapply( |
| 133 | -+ | |||
| 42 | +2x |
- # if a factor return a factor that includes the same levels (including unobserved levels)+ variables, |
||
| 134 | -25x | +43 | +2x |
- if (inherits(x, "factor")) {
+ function(variable) {
|
| 135 | -12x | +44 | +2x |
- return(+ cards::tidy_as_ard( |
| 136 | -12x | +45 | +2x |
- factor(+ lst_tidy = |
| 137 | -12x | +46 | +2x |
- if (useNA == "no") levels(x)+ cards::eval_capture_conditions( |
| 138 | -12x | +47 | +2x |
- else c(levels(x), NA_character_),+ stats::kruskal.test(x = data[[variable]], g = data[[by]]) |> |
| 139 | -12x | +48 | +2x |
- levels = levels(x)+ broom::tidy() |
| 140 | +49 |
- )+ ), |
||
| 141 | -+ | |||
| 50 | +2x |
- )+ tidy_result_names = c("statistic", "p.value", "parameter", "method"),
+ |
+ ||
| 51 | +2x | +
+ lst_ard_columns = list(group1 = by, variable = variable, context = "stats_kruskal_test") |
||
| 142 | +52 |
- }+ ) |> |
||
| 143 | -13x | +53 | +2x |
- if (inherits(x, "logical")) {
+ dplyr::mutate( |
| 144 | -7x | +54 | +2x |
- if (useNA == "no") return(c(TRUE, FALSE))+ .after = "stat_name", |
| 145 | -! | +|||
| 55 | +2x |
- else return(c(TRUE, FALSE, NA))+ stat_label = |
||
| 146 | -+ | |||
| 56 | +2x |
- }+ dplyr::case_when( |
||
| 147 | -+ | |||
| 57 | +2x |
-
+ .data$stat_name %in% "statistic" ~ "Kruskal-Wallis chi-squared Statistic",+ |
+ ||
| 58 | +2x | +
+ .data$stat_name %in% "p.value" ~ "p-value",+ |
+ ||
| 59 | +2x | +
+ .data$stat_name %in% "parameter" ~ "Degrees of Freedom",+ |
+ ||
| 60 | +2x | +
+ TRUE ~ .data$stat_name, |
||
| 148 | +61 |
- # otherwise, return a simple unique and sort of the vector+ ) |
||
| 149 | -6x | +|||
| 62 | +
- if (useNA == "no") return(unique(x) |> sort())+ ) |
|||
| 150 | -! | +|||
| 63 | +
- else return(unique(x) |> sort() |> c(NA))+ } |
|||
| 151 | +64 |
- # styler: on+ ) |>+ |
+ ||
| 65 | +2x | +
+ dplyr::bind_rows() |
||
| 152 | +66 |
}@@ -31253,14 +30430,14 @@ cardx coverage - 95.32% |
| 1 |
- #' ARD survey categorical CIs+ #' ARD 2-sample proportion test |
||
| 3 |
- #' One-sample confidence intervals for continuous variables' means and medians.+ #' @description |
||
| 4 |
- #' Confidence limits are calculated with `survey::svymean()` and `survey::svyquantile()`.+ #' Analysis results data for a 2-sample test or proportions using [`stats::prop.test()`]. |
||
| 6 |
- #'+ #' @param data (`data.frame`)\cr |
||
| 7 |
- #' @inheritParams ard_continuous.survey.design+ #' a data frame. |
||
| 8 |
- #' @param method (`string`)\cr+ #' @param by ([`tidy-select`][dplyr::dplyr_tidy_select])\cr |
||
| 9 |
- #' Method for confidence interval calculation.+ #' column name to compare by |
||
| 10 |
- #' When `"svymean"`, the calculation is computed via `survey::svymean()`.+ #' @param variables ([`tidy-select`][dplyr::dplyr_tidy_select])\cr |
||
| 11 |
- #' Otherwise, it is calculated via`survey::svyquantile(interval.type=method)`+ #' column names to be compared. Must be a binary column coded as `TRUE`/`FALSE` |
||
| 12 |
- #' @param conf.level (scalar `numeric`)\cr+ #' or `1`/`0`. Independent tests will be computed for each variable. |
||
| 13 |
- #' confidence level for confidence interval. Default is `0.95`.+ #' @param conf.level (scalar `numeric`)\cr |
||
| 14 |
- #' @param df (`numeric`)\cr+ #' confidence level for confidence interval. Default is `0.95`. |
||
| 15 |
- #' denominator degrees of freedom, passed to `survey::confint(df)`.+ #' @param ... arguments passed to `prop.test(...)` |
||
| 16 |
- #' Default is `survey::degf(data)`.+ #' |
||
| 17 |
- #' @param ... arguments passed to `survey::confint()`+ #' @return ARD data frame |
||
| 18 |
- #'+ #' @export |
||
| 19 |
- #' @return ARD data frame+ #' |
||
| 20 |
- #' @export+ #' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = "broom", reference_pkg = "cardx"))
|
||
| 21 |
- #'+ #' mtcars |> |
||
| 22 |
- #' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = "survey", reference_pkg = "cardx"))
+ #' ard_stats_prop_test(by = vs, variables = am) |
||
| 23 |
- #' data(api, package = "survey")+ ard_stats_prop_test <- function(data, by, variables, conf.level = 0.95, ...) {
|
||
| 24 | -+ | 5x |
- #' dclus1 <- survey::svydesign(id = ~dnum, weights = ~pw, data = apiclus1, fpc = ~fpc)+ set_cli_abort_call() |
| 25 |
- #'+ |
||
| 26 |
- #' ard_survey_continuous_ci(dclus1, variables = api00)+ # check installed packages --------------------------------------------------- |
||
| 27 | -+ | 5x |
- #' ard_survey_continuous_ci(dclus1, variables = api00, method = "xlogit")+ check_pkg_installed(pkg = "broom", reference_pkg = "cardx") |
| 28 |
- ard_survey_continuous_ci <- function(data,+ |
||
| 29 |
- variables,+ # check inputs --------------------------------------------------------------- |
||
| 30 | -+ | 5x |
- by = NULL,+ check_not_missing(data) |
| 31 | -+ | 5x |
- method = c("svymean", "mean", "beta", "xlogit", "asin", "score"),
+ check_not_missing(variables) |
| 32 | -+ | 5x |
- conf.level = 0.95,+ check_not_missing(by) |
| 33 | -+ | 5x |
- df = survey::degf(data),+ check_data_frame(data) |
| 34 | -+ | 5x |
- ...) {
+ check_range(conf.level, range = c(0, 1)) |
| 35 | -14x | +
- set_cli_abort_call()+ |
|
| 36 |
-
+ # process inputs ------------------------------------------------------------- |
||
| 37 | -+ | 5x |
- # check inputs ---------------------------------------------------------------+ cards::process_selectors(data, by = {{ by }}, variables = {{ variables }})
|
| 38 | -14x | +5x |
- check_not_missing(data)+ check_scalar(by) |
| 39 | -14x | +5x |
- check_class(data, "survey.design")+ data <- data[c(by, variables)] |> dplyr::ungroup() |> tidyr::drop_na() # styler: off |
| 40 | -14x | +
- check_not_missing(variables)+ |
|
| 41 |
-
+ # if no variables selected, return empty tibble ------------------------------ |
||
| 42 | -14x | +5x |
- cards::process_selectors(+ if (is_empty(variables)) {
|
| 43 | -14x | +! |
- data = data$variables,+ return(dplyr::tibble()) |
| 44 | -14x | +
- variables = {{ variables }},
+ } |
|
| 45 | -14x | +
- by = {{ by }}
+
|
|
| 46 |
- )+ # build ARD ------------------------------------------------------------------ |
||
| 47 | -14x | +5x |
- check_scalar(by, allow_empty = TRUE)+ lapply( |
| 48 | -14x | +5x |
- check_scalar_range(conf.level, range = c(0, 1))+ variables, |
| 49 | -14x | +5x |
- method <- arg_match(method)+ function(variable) {
|
| 50 | -+ | 6x |
-
+ .format_proptest_results( |
| 51 | -14x | +6x |
- walk(+ by = by, |
| 52 | -14x | +6x |
- variables,+ variable = variable, |
| 53 | -14x | +6x |
- \(variable) {
+ lst_tidy = |
| 54 | -24x | +6x |
- if (!is.numeric(data$variables[[variable]])) {
+ cards::eval_capture_conditions({
|
| 55 | -! | +6x |
- cli::cli_inform(+ check_binary(data[[variable]], arg_name = "variable") |
| 56 | -! | +
- "Column {.val {variable}} is not {.cls numeric} and results may be an unexpected format."
+
|
|
| 57 | -+ | 3x |
- )+ data_counts <- |
| 58 | -+ | 3x |
- }+ dplyr::arrange(data, .data[[by]]) |> |
| 59 | -+ | 3x |
- }+ dplyr::summarise( |
| 60 | -+ | 3x |
- )+ .by = all_of(by), |
| 61 | -+ | 3x |
-
+ x = sum(.data[[variable]]), |
| 62 | -+ | 3x |
- # calculate and return ARD of one sample CI ----------------------------------+ n = length(.data[[variable]]) |
| 63 | -14x | +
- .calculate_ard_continuous_survey_ci(+ ) |
|
| 64 | -14x | +
- FUN = ifelse(method == "svymean", .svymean_confint_wrapper, .svyquantile_confint_wrapper),+ |
|
| 65 | -14x | +3x |
- data = data,+ if (nrow(data_counts) != 2) {
|
| 66 | -14x | +1x |
- variables = variables,+ cli::cli_abort( |
| 67 | -14x | +1x |
- by = by,+ c( |
| 68 | -14x | +1x |
- conf.level = conf.level,+ "The {.arg by} column must have exactly 2 levels.",
|
| 69 | -14x | +1x |
- method = method,+ "The levels are {.val {data_counts[[by]]}}"
|
| 70 | -14x | +
- df = df,+ ), |
|
| 71 | -+ | 1x |
- ...+ call = get_cli_abort_call() |
| 72 |
- )+ ) |
||
| 73 |
- }+ } |
||
| 75 | -+ | 2x |
- .calculate_ard_continuous_survey_ci <- function(FUN, data, variables, by, conf.level, ...) {
+ stats::prop.test( |
| 76 | -+ | 2x |
- # return empty data frame if no variables to process -------------------------+ x = data_counts[["x"]], |
| 77 | -1x | +2x |
- if (is_empty(variables)) return(dplyr::tibble()) # styler: off+ n = data_counts[["n"]], |
| 78 | -+ | 2x |
-
+ conf.level = conf.level, |
| 79 |
- # calculate results ----------------------------------------------------------+ ... |
||
| 80 | -13x | +
- map(+ ) |> |
|
| 81 | -13x | +2x |
- variables,+ broom::tidy() |> |
| 82 | -13x | +
- function(variable) {
+ # add central estimate for difference |
|
| 83 | -24x | +2x |
- .calculate_one_ard_continuous_survey_ci(+ dplyr::mutate(estimate = .data$estimate1 - .data$estimate2, .before = 1L) |
| 84 | -24x | +
- FUN = FUN,+ }), |
|
| 85 | -24x | +
- data = data,+ ... |
|
| 86 | -24x | +
- variable = variable,+ ) |
|
| 87 | -24x | +
- by = by,+ } |
|
| 88 | -24x | +
- conf.level = conf.level,+ ) |> |
|
| 89 | -+ | 5x |
- ...+ dplyr::bind_rows() |
| 90 |
- )+ } |
||
| 91 |
- }+ |
||
| 92 |
- ) |>+ |
||
| 93 | -13x | +
- dplyr::bind_rows()+ #' Convert prop.test to ARD |
|
| 94 |
- }+ #' |
||
| 95 |
-
+ #' @inheritParams cards::tidy_as_ard |
||
| 96 |
- .calculate_one_ard_continuous_survey_ci <- function(FUN, data, variable, by, conf.level, ...) {
+ #' @param by (`string`)\cr by column name |
||
| 97 | -24x | +
- if (!is_empty(by)) {
+ #' @param variable (`string`)\cr variable column name |
|
| 98 | -8x | +
- by_levels <- .unique_values_sort(data$variables, variable = by)+ #' @param ... passed to `prop.test(...)` |
|
| 99 | -8x | +
- lst_data <-+ #' |
|
| 100 | -8x | +
- map(+ #' @return ARD data frame |
|
| 101 | -8x | +
- by_levels,+ #' @keywords internal |
|
| 102 | -8x | +
- ~ call2("subset", expr(data), expr(!!sym(by) == !!.x)) |> eval()
+ .format_proptest_results <- function(by, variable, lst_tidy, ...) {
|
|
| 103 |
- ) |>+ # build ARD ------------------------------------------------------------------ |
||
| 104 | -8x | +6x |
- set_names(as.character(by_levels))+ ret <- |
| 105 | -+ | 6x |
- }+ cards::tidy_as_ard( |
| 106 | -+ | 6x |
-
+ lst_tidy = lst_tidy, |
| 107 | -24x | +6x |
- df_full <-+ tidy_result_names = c( |
| 108 | -24x | +6x |
- case_switch(+ "estimate", "estimate1", "estimate2", "statistic", |
| 109 | -24x | +6x |
- !is_empty(by) ~+ "p.value", "parameter", "conf.low", "conf.high", |
| 110 | -24x | +6x |
- tidyr::expand_grid(+ "method", "alternative" |
| 111 | -24x | +
- group1_level = as.character(by_levels) |> as.list()+ ), |
|
| 112 | -+ | 6x |
- ) |>+ fun_args_to_record = c("p", "conf.level", "correct"),
|
| 113 | -24x | +6x |
- dplyr::mutate(group1 = .env$by, variable = .env$variable),+ formals = formals(stats::prop.test), |
| 114 | -24x | +6x |
- .default =+ passed_args = dots_list(...), |
| 115 | -24x | +6x |
- dplyr::tibble(variable = .env$variable)+ lst_ard_columns = list(group1 = by, variable = variable, context = "stats_prop_test") |
| 116 |
- ) |>+ ) |
||
| 117 | -24x | +
- dplyr::rowwise() |>+ |
|
| 118 | -24x | +
- dplyr::mutate(+ # add the stat label --------------------------------------------------------- |
|
| 119 | -24x | +6x |
- lst_result =+ ret |> |
| 120 | -24x | +6x |
- FUN(+ dplyr::left_join( |
| 121 | -24x | +6x |
- data =+ .df_proptest_stat_labels(), |
| 122 | -24x | +6x |
- case_switch(+ by = "stat_name" |
| 123 | -24x | +
- is_empty(.env$by) ~ data,+ ) |> |
|
| 124 | -24x | +6x |
- .default = lst_data[[.data$group1_level]]+ dplyr::mutate(stat_label = dplyr::coalesce(.data$stat_label, .data$stat_name)) |> |
| 125 | -+ | 6x |
- ),+ cards::tidy_ard_column_order() |
| 126 | -24x | +
- variable = .data$variable,+ } |
|
| 127 | -24x | +
- conf.level = .env$conf.level,+ |
|
| 128 |
- ...+ .df_proptest_stat_labels <- function() {
|
||
| 129 | -+ | 6x |
- ) |>+ dplyr::tribble( |
| 130 | -24x | +6x |
- list(),+ ~stat_name, ~stat_label, |
| 131 | -24x | +6x |
- result =+ "estimate1", "Group 1 Rate", |
| 132 | -24x | +6x |
- .data$lst_result[["result"]] |>+ "estimate2", "Group 2 Rate", |
| 133 | -24x | +6x |
- enframe("stat_name", "stat") |>
+ "estimate", "Rate Difference", |
| 134 | -24x | +6x |
- list(),+ "p.value", "p-value", |
| 135 | -24x | +6x |
- warning = .data$lst_result["warning"] |> unname(),+ "statistic", "X-squared Statistic", |
| 136 | -24x | +6x |
- error = .data$lst_result["error"] |> unname(),+ "parameter", "Degrees of Freedom", |
| 137 | -24x | +6x |
- context = "survey_continuous_ci"+ "conf.low", "CI Lower Bound", |
| 138 | -+ | 6x |
- ) |>+ "conf.high", "CI Upper Bound", |
| 139 | -24x | +6x |
- dplyr::select(-"lst_result") |>+ "conf.level", "CI Confidence Level", |
| 140 | -24x | +6x |
- dplyr::ungroup() |>+ "correct", "Yates' continuity correction", |
| 141 | -24x | +
- tidyr::unnest("result") |>
+ ) |
|
| 142 | -24x | -
- dplyr::mutate(- |
- |
| 143 | -24x | -
- stat_label = .data$stat_name,- |
- |
| 144 | -24x | +
- fmt_fn = map(.data$stat, ~ case_switch(is.numeric(.x) ~ 2L, .default = as.character))+ } |
| 145 | +1 |
- ) |>+ #' ARD ANOVA from car Package |
||
| 146 | -24x | +|||
| 2 | +
- cards::tidy_ard_column_order() %>%+ #' |
|||
| 147 | -24x | +|||
| 3 | +
- structure(., class = c("card", class(.)))
+ #' Function takes a regression model object and calculated ANOVA using [`car::Anova()`]. |
|||
| 148 | +4 |
- }+ #' |
||
| 149 | +5 |
-
+ #' @param x regression model object |
||
| 150 | +6 |
- .svymean_confint_wrapper <- function(data, variable, conf.level, df, ...) {
+ #' @param ... arguments passed to `car::Anova(...)` |
||
| 151 | -24x | +|||
| 7 | +
- lst_results <-+ #' |
|||
| 152 | -24x | +|||
| 8 | +
- cards::eval_capture_conditions({
+ #' @return data frame |
|||
| 153 | -24x | +|||
| 9 | +
- svymean <-+ #' @export |
|||
| 154 | -24x | +|||
| 10 | +
- survey::svymean(x = reformulate2(variable), design = data, na.rm = TRUE)+ #' |
|||
| 155 | +11 |
-
+ #' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = c("broom.helpers", "car", "parameters"), reference_pkg = "cardx"))
|
||
| 156 | -24x | +|||
| 12 | +
- lst_svymean <- as.data.frame(svymean) |>+ #' lm(AGE ~ ARM, data = cards::ADSL) |> |
|||
| 157 | -24x | +|||
| 13 | +
- as.list() |>+ #' ard_car_anova() |
|||
| 158 | -24x | +|||
| 14 | +
- set_names(c("estimate", "std.error"))
+ #' |
|||
| 159 | +15 |
-
+ #' glm(vs ~ factor(cyl) + factor(am), data = mtcars, family = binomial) |> |
||
| 160 | -24x | +|||
| 16 | +
- lst_confint <- stats::confint(svymean, level = conf.level, df = df, ...) |>+ #' ard_car_anova(test.statistic = "Wald") |
|||
| 161 | -24x | +|||
| 17 | +
- as.data.frame() |>+ ard_car_anova <- function(x, ...) {
|
|||
| 162 | -24x | +18 | +2x |
- as.list() |>+ set_cli_abort_call() |
| 163 | -24x | +|||
| 19 | +
- set_names(c("conf.low", "conf.high"))
+
|
|||
| 164 | +20 |
-
+ # check installed packages --------------------------------------------------- |
||
| 165 | -22x | +21 | +2x |
- c(lst_svymean, lst_confint)+ check_pkg_installed(pkg = c("broom.helpers", "car", "parameters"), reference_pkg = "cardx")
|
| 166 | +22 |
- })+ |
||
| 167 | +23 |
-
+ # check inputs ---------------------------------------------------------------+ |
+ ||
| 24 | +2x | +
+ check_not_missing(x) |
||
| 168 | +25 |
- # add NULL results if error+ |
||
| 169 | -24x | +|||
| 26 | +
- if (is_empty(lst_results[["result"]])) {
+ # run car::Anova() ----------------------------------------------------------- |
|||
| 170 | +27 | 2x |
- lst_results[["result"]] <- rep_named(c("estimate", "std.error", "conf.low", "conf.high"), list(NULL))
+ car_anova <- cards::eval_capture_conditions(car::Anova(x, ...)) |
|
| 171 | +28 |
- }+ |
||
| 172 | -+ | |||
| 29 | +2x |
-
+ if (!is.null(car_anova[["error"]])) {
|
||
| 173 | -+ | |||
| 30 | +1x |
- # add other args+ cli::cli_abort( |
||
| 174 | -24x | +31 | +1x |
- lst_results[["result"]] <- lst_results[["result"]] |> append(list(conf.level = conf.level))+ c( |
| 175 | -+ | |||
| 32 | +1x |
-
+ "There was an error running {.fun car::Anova}. See error message below.",
+ |
+ ||
| 33 | +1x | +
+ x = car_anova[["error"]] |
||
| 176 | +34 |
- # return list result+ ), |
||
| 177 | -24x | +35 | +1x |
- lst_results+ call = get_cli_abort_call() |
| 178 | +36 |
- }+ ) |
||
| 179 | +37 |
-
+ } |
||
| 180 | +38 |
- .svyquantile_confint_wrapper <- function(data, variable, conf.level, method, df, ...) {
+
|
||
| 181 | -8x | +39 | +1x |
- lst_results <-+ car_anova[["result"]] |> |
| 182 | -8x | +40 | +1x |
- cards::eval_capture_conditions({
+ broom.helpers::tidy_parameters(conf.int = FALSE) |> # using broom.helpers, because it handle non-syntactic names for us |
| 183 | -8x | +41 | +1x |
- svyquantile <-+ dplyr::filter(!(dplyr::row_number() == dplyr::n() & .data$term %in% "Residuals")) |> # removing Residual rows |
| 184 | -8x | +42 | +1x |
- survey::svyquantile(+ dplyr::rename(variable = "term") |> |
| 185 | -8x | +43 | +1x |
- x = reformulate2(variable), design = data, quantiles = 0.5,+ tidyr::pivot_longer( |
| 186 | -8x | +44 | +1x |
- na.rm = TRUE, interval.type = method+ cols = -"variable", |
| 187 | -+ | |||
| 45 | +1x |
- )+ names_to = "stat_name",+ |
+ ||
| 46 | +1x | +
+ values_to = "stat" |
||
| 188 | +47 |
-
+ ) |> |
||
| 189 | -8x | +48 | +1x |
- lst_svyquantile <- svyquantile |>+ dplyr::mutate( |
| 190 | -8x | +49 | +1x |
- getElement(1L) |>+ stat = as.list(.data$stat), |
| 191 | -8x | +50 | +1x |
- as.data.frame() |>+ stat_label = |
| 192 | -8x | +51 | +1x |
- dplyr::select(1L, last_col()) |>+ dplyr::case_when( |
| 193 | -8x | +52 | +1x |
- as.list() |>+ .data$stat_name %in% "statistic" ~ "Statistic", |
| 194 | -8x | +53 | +1x |
- set_names(c("estimate", "std.error"))
+ .data$stat_name %in% "df" ~ "Degrees of Freedom", |
| 195 | -+ | |||
| 54 | +1x |
-
+ .data$stat_name %in% "p.value" ~ "p-value", |
||
| 196 | -8x | +55 | +1x |
- lst_confint <- stats::confint(svyquantile, level = conf.level, df = df, ...) |>+ TRUE ~ .data$stat_name |
| 197 | -8x | +|||
| 56 | +
- as.data.frame() |>+ ), |
|||
| 198 | -8x | +57 | +1x |
- as.list() |>+ fmt_fn = |
| 199 | -8x | +58 | +1x |
- set_names(c("conf.low", "conf.high"))
+ map( |
| 200 | -+ | |||
| 59 | +1x |
-
+ .data$stat, |
||
| 201 | -8x | +60 | +1x |
- c(lst_svyquantile, lst_confint)+ function(.x) {
|
| 202 | +61 |
- })+ # styler: off |
||
| 203 | -+ | |||
| 62 | +! |
-
+ if (is.integer(.x)) return(0L) |
||
| 204 | -+ | |||
| 63 | +6x |
- # add NULL results if error+ if (is.numeric(.x)) return(1L) |
||
| 205 | -8x | +|||
| 64 | +
- if (is_empty(lst_results[["result"]])) {
+ # styler: on |
|||
| 206 | +65 | ! |
- lst_results[["result"]] <- rep_named(c("estimate", "std.error", "conf.low", "conf.high"), list(NULL))
+ NULL |
|
| 207 | +66 |
- }+ } |
||
| 208 | +67 |
-
+ ), |
||
| 209 | -+ | |||
| 68 | +1x |
- # add other args+ context = "car_anova", |
||
| 210 | -8x | +69 | +1x |
- lst_results[["result"]] <- lst_results[["result"]] |> append(list(conf.level = conf.level))+ warning = car_anova["warning"], |
| 211 | -+ | |||
| 70 | +1x |
-
+ error = car_anova["error"] |
||
| 212 | +71 |
- # return list result+ ) |> |
||
| 213 | -8x | +72 | +1x |
- lst_results+ cards::tidy_ard_column_order() %>%+ |
+
| 73 | +1x | +
+ {structure(., class = c("card", class(.)))} # styler: off
|
||
| 214 | +74 |
}@@ -32757,14 +31954,14 @@ cardx coverage - 95.32% |
| 1 |
- #' Basic Regression ARD+ #' ARD one-sample t-test |
|||
| 4 |
- #' A function that takes a regression model and provides basic statistics in an+ #' Analysis results data for one-sample t-tests. |
|||
| 5 |
- #' ARD structure.+ #' Result may be stratified by including the `by` argument. |
|||
| 6 |
- #' The default output is simpler than [`ard_regression()`].+ #' |
|||
| 7 |
- #' The function primarily matches regression terms to underlying variable names+ #' @param data (`data.frame`)\cr |
|||
| 8 |
- #' and levels.+ #' a data frame. See below for details. |
|||
| 9 |
- #' The default arguments used are+ #' @param variables ([`tidy-select`][dplyr::dplyr_tidy_select])\cr |
|||
| 10 |
- #'+ #' column names to be analyzed. Independent t-tests will be computed for |
|||
| 11 |
- #' ```r+ #' each variable. |
|||
| 12 |
- #' broom.helpers::tidy_plus_plus(+ #' @param by ([`tidy-select`][dplyr::dplyr_tidy_select])\cr |
|||
| 13 |
- #' add_reference_rows = FALSE,+ #' optional column name to stratify results by. |
|||
| 14 |
- #' add_estimate_to_reference_rows = FALSE,+ #' @inheritParams ard_stats_t_test |
|||
| 15 |
- #' add_n = FALSE,+ #' |
|||
| 16 |
- #' intercept = FALSE+ #' @return ARD data frame |
|||
| 17 |
- #' )+ #' @export |
|||
| 18 |
- #' ```+ #' |
|||
| 19 |
- #'+ #' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = "broom", reference_pkg = "cardx"))
|
|||
| 20 |
- #' @inheritParams ard_regression+ #' cards::ADSL |> |
|||
| 21 |
- #' @param stats_to_remove (`character`)\cr+ #' ard_stats_t_test_onesample(by = ARM, variables = AGE) |
|||
| 22 |
- #' character vector of statistic names to remove. Default is+ ard_stats_t_test_onesample <- function(data, variables, by = dplyr::group_vars(data), conf.level = 0.95, ...) {
|
|||
| 23 | -+ | 2x |
- #' `c("term", "var_type", "var_label", "var_class", "label", "contrasts_type", "contrasts", "var_nlevels")`.
+ set_cli_abort_call() |
|
| 24 |
- #'+ |
|||
| 25 |
- #' @return data frame+ # check installed packages --------------------------------------------------- |
|||
| 26 | -+ | 2x |
- #' @name ard_regression_basic+ check_pkg_installed("broom", reference_pkg = "cardx")
|
|
| 27 |
- #' @export+ |
|||
| 28 |
- #'+ # check/process inputs ------------------------------------------------------- |
|||
| 29 | -+ | 2x |
- #' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = "broom.helpers", reference_pkg = "cardx"))
+ check_not_missing(data) |
|
| 30 | -+ | 2x |
- #' lm(AGE ~ ARM, data = cards::ADSL) |>+ check_not_missing(variables) |
|
| 31 | -+ | 2x |
- #' ard_regression_basic()+ check_data_frame(data) |
|
| 32 | -+ | 2x |
- ard_regression_basic <- function(x, tidy_fun = broom.helpers::tidy_with_broom_or_parameters,+ data <- dplyr::ungroup(data) |
|
| 33 | -+ | 2x |
- stats_to_remove = c(+ cards::process_selectors(data, by = {{ by }}, variables = {{ variables }})
|
|
| 34 | -+ | 2x |
- "term", "var_type", "var_label", "var_class",+ check_scalar_range(conf.level, range = c(0, 1)) |
|
| 35 |
- "label", "contrasts_type", "contrasts", "var_nlevels"+ |
|||
| 36 |
- ),+ # if no variables selected, return empty tibble ------------------------------ |
|||
| 37 | -+ | 2x |
- ...) {
+ if (is_empty(variables)) {
|
|
| 38 | -3x | +1x |
- set_cli_abort_call()+ return(dplyr::tibble()) |
|
| 39 |
-
+ } |
|||
| 40 |
- # check installed packages ---------------------------------------------------+ |
|||
| 41 | -3x | +1x |
- check_pkg_installed(pkg = "broom.helpers", reference_pkg = "cardx")+ cards::ard_continuous(+ |
+ |
| 42 | +1x | +
+ data = data,+ |
+ ||
| 43 | +1x | +
+ variables = all_of(variables),+ |
+ ||
| 44 | +1x | +
+ by = all_of(by),+ |
+ ||
| 45 | +1x | +
+ statistic = all_of(variables) ~ list(t_test_onesample = \(x) stats::t.test(x = x, conf.level = conf.level, ...) |> broom::tidy())+ |
+ ||
| 46 | ++ |
+ ) |>+ |
+ ||
| 47 | +1x | +
+ cards::bind_ard(+ |
+ ||
| 48 | +1x | +
+ cards::ard_continuous(+ |
+ ||
| 49 | +1x | +
+ data = data,+ |
+ ||
| 50 | +1x | +
+ variables = all_of(variables),+ |
+ ||
| 51 | +1x | +
+ by = all_of(by), |
||
| 42 | -+ | |||
| 52 | +1x |
-
+ statistic = |
||
| 43 | -+ | |||
| 53 | +1x |
- # check inputs ---------------------------------------------------------------+ all_of(variables) ~ |
||
| 44 | -3x | +54 | +1x |
- check_not_missing(x)+ list(conf.level = \(x) {
|
| 45 | +55 | 3x |
- check_class(stats_to_remove, cls = "character", allow_empty = TRUE)+ formals(asNamespace("stats")[["t.test.default"]])["mu"] |>
|
|
| 46 | -! | +|||
| 56 | +3x |
- if (is_empty(stats_to_remove)) stats_to_remove <- character(0L) # styler: off+ utils::modifyList(list(conf.level = conf.level, ...)) |
||
| 47 | +57 |
-
+ }) |
||
| 48 | -3x | +|||
| 58 | +
- args <-+ ) |
|||
| 49 | -3x | +|||
| 59 | +
- list(+ ) |> |
|||
| 50 | -3x | +60 | +1x |
- add_reference_rows = FALSE,+ dplyr::select(-"stat_label") |> |
| 51 | -3x | +61 | +1x |
- add_estimate_to_reference_rows = FALSE,+ dplyr::left_join( |
| 52 | -3x | +62 | +1x |
- add_n = FALSE,+ .df_ttest_stat_labels(by = NULL), |
| 53 | -3x | +63 | +1x |
- intercept = FALSE+ by = "stat_name" |
| 54 | +64 |
) |> |
||
| 55 | -3x | +65 | +1x |
- utils::modifyList(val = rlang::dots_list(...))+ dplyr::mutate( |
| 56 | -+ | |||
| 66 | +1x |
-
+ stat_label = dplyr::coalesce(.data$stat_label, .data$stat_name), |
||
| 57 | -3x | +67 | +1x |
- rlang::inject(ard_regression(x = x, tidy_fun = tidy_fun, !!!args)) |>+ context = "stats_t_test_onesample",+ |
+
| 68 | ++ |
+ ) |> |
||
| 58 | -3x | +69 | +1x |
- dplyr::filter(!.data$stat_name %in% stats_to_remove) |>+ cards::tidy_ard_row_order() |> |
| 59 | -3x | +70 | +1x |
- dplyr::select(-(cards::all_ard_variables("levels") & dplyr::where(\(x) all(is.na(x)))))
+ cards::tidy_ard_column_order() |
| 60 | +71 |
}@@ -33183,14 +32457,14 @@ cardx coverage - 95.32% |
| 1 |
- #' ARD ANOVA+ #' ARD One-way Test |
||
| 3 |
- #' Prepare ANOVA results from the `stats::anova()` function.+ #' @description |
||
| 4 |
- #' Users may pass a pre-calculated `stats::anova()` object or a list of+ #' Analysis results data for Testing Equal Means in a One-Way Layout. |
||
| 5 |
- #' formulas. In the latter case, the models will be constructed using the+ #' calculated with `oneway.test()` |
||
| 6 |
- #' information passed and models will be passed to `stats::anova()`.+ #' |
||
| 7 |
- #'+ #' @inheritParams stats::oneway.test |
||
| 8 |
- #' @param x (`anova` or `data.frame`)\cr+ #' @param ... additional arguments passed to `oneway.test(...)` |
||
| 9 |
- #' an object of class `'anova'` created with `stats::anova()` or+ #' |
||
| 10 |
- #' a data frame+ #' @return ARD data frame |
||
| 11 |
- #' @param formulas (`list`)\cr+ #' @export |
||
| 12 |
- #' a list of formulas+ #' |
||
| 13 |
- #' @param method_text (`string`)\cr+ #' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = "broom", reference_pkg = "cardx"))
|
||
| 14 |
- #' string of the method used. Default is `"ANOVA results from `stats::anova()`"`.+ #' ard_stats_oneway_test(AGE ~ ARM, data = cards::ADSL) |
||
| 15 |
- #' We provide the option to change this as `stats::anova()` can produce+ ard_stats_oneway_test <- function(formula, data, ...) {
|
||
| 16 | -+ | 2x |
- #' results from many types of models that may warrant a more precise+ set_cli_abort_call() |
| 17 |
- #' description.+ |
||
| 18 |
- #' @inheritParams rlang::args_dots_empty+ # check installed packages --------------------------------------------------- |
||
| 19 | -+ | 2x |
- #' @inheritParams construction_helpers+ check_pkg_installed(c("broom"), reference_pkg = "cardx")
|
| 20 |
- #'+ |
||
| 21 |
- #' @details+ # check/process inputs ------------------------------------------------------- |
||
| 22 | -+ | 2x |
- #' When a list of formulas is supplied to `ard_stats_anova()`, these formulas+ check_not_missing(formula) |
| 23 | -+ | 2x |
- #' along with information from other arguments, are used to construct models+ check_not_missing(data) |
| 24 | -+ | 2x |
- #' and pass those models to `stats::anova()`.+ check_data_frame(data) |
| 25 | -+ | 2x |
- #'+ check_class(formula, cls = "formula") |
| 26 |
- #' The models are constructed using `rlang::exec()`, which is similar to `do.call()`.+ |
||
| 27 |
- #'+ # build ARD ------------------------------------------------------------------ |
||
| 28 | -+ | 2x |
- #' ```r+ df_results <- |
| 29 | -+ | 2x |
- #' rlang::exec(.fn = method, formula = formula, data = data, !!!method.args)+ cards::tidy_as_ard( |
| 30 | -+ | 2x |
- #' ```+ lst_tidy = |
| 31 | -+ | 2x |
- #'+ cards::eval_capture_conditions( |
| 32 | -+ | 2x |
- #' The above function is executed in `withr::with_namespace(package)`, which+ stats::oneway.test(formula, data = data, ...) |> |
| 33 | -+ | 2x |
- #' allows for the use of `ard_stats_anova(method)` from packages,+ broom::tidy() |
| 34 |
- #' e.g. `package = 'lme4'` must be specified when `method = 'glmer'`.+ ), |
||
| 35 | -+ | 2x |
- #' See example below.+ tidy_result_names = c("num.df", "den.df", "statistic", "p.value", "method"),
|
| 36 | -+ | 2x |
- #'+ fun_args_to_record = |
| 37 | -+ | 2x |
- #' @return ARD data frame+ c("var.equal"),
|
| 38 | -+ | 2x |
- #' @name ard_stats_anova+ formals = formals(stats::oneway.test), |
| 39 | -+ | 2x |
- #'+ passed_args = dots_list(...), |
| 40 | -+ | 2x |
- #' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = c("broom", "withr", "lme4"), reference_pkg = "cardx"))
+ lst_ard_columns = list(context = "stats_oneway_test") |
| 41 |
- #' anova(+ ) |> |
||
| 42 | -+ | 2x |
- #' lm(mpg ~ am, mtcars),+ dplyr::mutate( |
| 43 | -+ | 2x |
- #' lm(mpg ~ am + hp, mtcars)+ .after = "stat_name", |
| 44 | -+ | 2x |
- #' ) |>+ stat_label = |
| 45 | -+ | 2x |
- #' ard_stats_anova()+ dplyr::case_when( |
| 46 | -+ | 2x |
- #'+ .data$stat_name %in% "num.df" ~ "Degrees of Freedom", |
| 47 | -+ | 2x |
- #' ard_stats_anova(+ .data$stat_name %in% "den.df" ~ "Denominator Degrees of Freedom", |
| 48 | -+ | 2x |
- #' x = mtcars,+ .data$stat_name %in% "statistic" ~ "F Statistic", |
| 49 | -+ | 2x |
- #' formulas = list(am ~ mpg, am ~ mpg + hp),+ .data$stat_name %in% "p.value" ~ "p-value", |
| 50 | -+ | 2x |
- #' method = "glm",+ .data$stat_name %in% "method" ~ "Method", |
| 51 | -+ | 2x |
- #' method.args = list(family = binomial)+ TRUE ~ .data$stat_name, |
| 52 |
- #' )+ ) |
||
| 53 |
- #'+ ) |
||
| 54 |
- #' ard_stats_anova(+ |
||
| 55 |
- #' x = mtcars,+ # add variable/groups to results and return result |
||
| 56 | -+ | 2x |
- #' formulas = list(am ~ 1 + (1 | vs), am ~ mpg + (1 | vs)),+ df_results |> |
| 57 | -+ | 2x |
- #' method = "glmer",+ dplyr::bind_cols( |
| 58 | -+ | 2x |
- #' method.args = list(family = binomial),+ dplyr::tibble(!!!map(as.list(attr(stats::terms(formula), "variables"))[-1], as_label)) %>% |
| 59 | -+ | 2x |
- #' package = "lme4"+ set_names(., c("variable", paste0("group", seq_len(length(.) - 1L))))
|
| 60 |
- #' )+ ) |> |
||
| 61 | -+ | 2x |
- NULL+ cards::tidy_ard_column_order() |
| 62 |
-
+ } |
| 63 | +1 |
- #' @rdname ard_stats_anova+ #' ARD Hedge's G Test |
||
| 64 | +2 |
- #' @export+ #' |
||
| 65 | +3 |
- ard_stats_anova <- function(x, ...) {
- |
- ||
| 66 | -8x | -
- UseMethod("ard_stats_anova")
+ #' @description |
||
| 67 | +4 |
- }+ #' Analysis results data for paired and non-paired Hedge's G Effect Size Test |
||
| 68 | +5 |
-
+ #' using [`effectsize::hedges_g()`]. |
||
| 69 | +6 |
- #' @rdname ard_stats_anova+ #' |
||
| 70 | +7 |
- #' @export+ #' @param data (`data.frame`)\cr |
||
| 71 | +8 |
- ard_stats_anova.anova <- function(x, method_text = "ANOVA results from `stats::anova()`", ...) {
+ #' a data frame. See below for details. |
||
| 72 | -2x | +|||
| 9 | +
- set_cli_abort_call()+ #' @param by ([`tidy-select`][dplyr::dplyr_tidy_select])\cr |
|||
| 73 | +10 |
-
+ #' column name to compare by. Must be a categorical variable with exactly two levels. |
||
| 74 | +11 |
- # check inputs ---------------------------------------------------------------+ #' @param variables ([`tidy-select`][dplyr::dplyr_tidy_select])\cr |
||
| 75 | -2x | +|||
| 12 | +
- check_dots_empty()+ #' column names to be compared. Must be a continuous variable. Independent |
|||
| 76 | -2x | +|||
| 13 | +
- check_pkg_installed("broom", reference_pkg = "cardx")
+ #' tests will be run for each variable |
|||
| 77 | -2x | +|||
| 14 | +
- check_string(method_text)+ #' @param id ([`tidy-select`][dplyr::dplyr_tidy_select])\cr |
|||
| 78 | +15 |
-
+ #' column name of the subject or participant ID |
||
| 79 | +16 |
- # return df in cards formats -------------------------------------------------+ #' @param conf.level (scalar `numeric`)\cr |
||
| 80 | -2x | +|||
| 17 | +
- lst_results <-+ #' confidence level for confidence interval. Default is `0.95`. |
|||
| 81 | -2x | +|||
| 18 | +
- cards::eval_capture_conditions(+ #' @param ... arguments passed to `effectsize::hedges_g(...)` |
|||
| 82 | -2x | +|||
| 19 | +
- .anova_tidy_and_reshape(x, method_text = method_text)+ #' |
|||
| 83 | +20 |
- )+ #' @return ARD data frame |
||
| 84 | +21 |
-
+ #' @name ard_effectsize_hedges_g |
||
| 85 | +22 |
- # final tidying up of cards data frame ---------------------------------------+ #' |
||
| 86 | -2x | +|||
| 23 | +
- .anova_final_ard_prep(lst_results, method_text = method_text)+ #' @details |
|||
| 87 | +24 |
- }+ #' For the `ard_effectsize_hedges_g()` function, the data is expected to be one row per subject. |
||
| 88 | +25 |
-
+ #' The data is passed as `effectsize::hedges_g(data[[variable]]~data[[by]], data, paired = FALSE, ...)`. |
||
| 89 | +26 |
-
+ #' |
||
| 90 | +27 |
- #' @rdname ard_stats_anova+ #' For the `ard_effectsize_paired_hedges_g()` function, the data is expected to be one row |
||
| 91 | +28 |
- #' @export+ #' per subject per by level. Before the effect size is calculated, the data are |
||
| 92 | +29 |
- ard_stats_anova.data.frame <- function(x,+ #' reshaped to a wide format to be one row per subject. |
||
| 93 | +30 |
- formulas,+ #' The data are then passed as |
||
| 94 | +31 |
- method,+ #' `effectsize::hedges_g(x = data_wide[[<by level 1>]], y = data_wide[[<by level 2>]], paired = TRUE, ...)`. |
||
| 95 | +32 |
- method.args = list(),+ #' |
||
| 96 | +33 |
- package = "base",+ #' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = c("effectsize", "parameters"), reference_pkg = "cardx"))
|
||
| 97 | +34 |
- method_text = "ANOVA results from `stats::anova()`",+ #' cards::ADSL |> |
||
| 98 | +35 |
- ...) {
+ #' dplyr::filter(ARM %in% c("Placebo", "Xanomeline High Dose")) |>
|
||
| 99 | -6x | +|||
| 36 | +
- set_cli_abort_call()+ #' ard_effectsize_hedges_g(by = ARM, variables = AGE) |
|||
| 100 | +37 |
-
+ #' |
||
| 101 | +38 |
- # check inputs ---------------------------------------------------------------+ #' # constructing a paired data set, |
||
| 102 | -6x | +|||
| 39 | +
- check_dots_empty()+ #' # where patients receive both treatments |
|||
| 103 | -6x | +|||
| 40 | +
- check_pkg_installed(c("broom", "withr", package), reference_pkg = "cardx")
+ #' cards::ADSL[c("ARM", "AGE")] |>
|
|||
| 104 | -6x | +|||
| 41 | +
- check_not_missing(formulas)+ #' dplyr::filter(ARM %in% c("Placebo", "Xanomeline High Dose")) |>
|
|||
| 105 | -6x | +|||
| 42 | +
- check_class(formulas, cls = "list")+ #' dplyr::mutate(.by = ARM, USUBJID = dplyr::row_number()) |> |
|||
| 106 | -6x | +|||
| 43 | +
- walk(+ #' dplyr::arrange(USUBJID, ARM) |> |
|||
| 107 | -6x | +|||
| 44 | +
- formulas,+ #' dplyr::group_by(USUBJID) |> |
|||
| 108 | -6x | +|||
| 45 | +
- ~ check_class(+ #' dplyr::filter(dplyr::n() > 1) |> |
|||
| 109 | -6x | +|||
| 46 | +
- .x,+ #' ard_effectsize_paired_hedges_g(by = ARM, variables = AGE, id = USUBJID) |
|||
| 110 | -6x | +|||
| 47 | +
- cls = "formula",+ NULL |
|||
| 111 | -6x | +|||
| 48 | +
- arg_name = "formulas",+ |
|||
| 112 | -6x | +|||
| 49 | +
- message = "Each element of {.arg formulas} must be class {.cls formula}"
+ #' @rdname ard_effectsize_hedges_g |
|||
| 113 | +50 |
- )+ #' @export |
||
| 114 | +51 |
- )+ ard_effectsize_hedges_g <- function(data, by, variables, conf.level = 0.95, ...) {
|
||
| 115 | -+ | |||
| 52 | +3x |
-
+ set_cli_abort_call() |
||
| 116 | +53 |
- # calculate results and return df in cards formats ---------------------------+ |
||
| 117 | +54 |
- # create models+ # check installed packages --------------------------------------------------- |
||
| 118 | -6x | +55 | +3x |
- lst_results <-+ check_pkg_installed(c("effectsize", "parameters"), reference_pkg = "cardx")
|
| 119 | -6x | +|||
| 56 | +
- cards::eval_capture_conditions({
+
|
|||
| 120 | +57 |
- # first build the models+ # check/process inputs ------------------------------------------------------- |
||
| 121 | -6x | +58 | +3x |
- models <-+ check_not_missing(data) |
| 122 | -6x | +59 | +3x |
- lapply(+ check_not_missing(variables) |
| 123 | -6x | +60 | +3x |
- formulas,+ check_data_frame(data) |
| 124 | -6x | +61 | +3x |
- function(formula) {
+ data <- dplyr::ungroup(data) |
| 125 | -11x | +62 | +3x |
- construct_model(data = x, formula = formula, method = method, method.args = {{ method.args }}, package = package)
+ cards::process_selectors(data, by = {{ by }}, variables = {{ variables }})
|
| 126 | -+ | |||
| 63 | +3x |
- }+ check_scalar(by) |
||
| 127 | -+ | |||
| 64 | +3x |
- )+ check_range(conf.level, range = c(0, 1)) |
||
| 128 | +65 | |||
| 129 | +66 |
- # now calculate `stats::anova()` and reshape results+ # if no variables selected, return empty tibble ------------------------------ |
||
| 130 | -5x | +67 | +3x |
- rlang::inject(stats::anova(!!!models)) |>+ if (is_empty(variables)) {
|
| 131 | -5x | +|||
| 68 | +! |
- .anova_tidy_and_reshape(method_text = method_text)+ return(dplyr::tibble()) |
||
| 132 | +69 |
- })+ } |
||
| 133 | +70 | |||
| 134 | +71 |
- # final tidying up of cards data frame ---------------------------------------+ # build ARD ------------------------------------------------------------------ |
||
| 135 | -6x | -
- .anova_final_ard_prep(lst_results, method_text = method_text)- |
- ||
| 136 | -- |
- }- |
- ||
| 137 | -- | - - | -||
| 138 | -+ | 72 | +3x |
- .anova_tidy_and_reshape <- function(x, method_text) {
+ lapply( |
| 139 | -7x | +73 | +3x |
- broom::tidy(x) |>+ variables, |
| 140 | -7x | +74 | +3x |
- dplyr::mutate(+ function(variable) {
|
| 141 | -7x | +75 | +4x |
- across(everything(), as.list),+ .format_hedges_g_results( |
| 142 | -7x | +76 | +4x |
- variable = paste0("model_", dplyr::row_number())
+ by = by, |
| 143 | -+ | |||
| 77 | +4x |
- ) |>+ variable = variable, |
||
| 144 | -7x | +78 | +4x |
- tidyr::pivot_longer(+ lst_tidy = |
| 145 | -7x | +79 | +4x |
- cols = -"variable",+ cards::eval_capture_conditions( |
| 146 | -7x | +80 | +4x |
- names_to = "stat_name",+ effectsize::hedges_g( |
| 147 | -7x | +81 | +4x |
- values_to = "stat"+ reformulate2(by, response = variable), |
| 148 | -+ | |||
| 82 | +4x |
- ) |>+ data = data |> tidyr::drop_na(all_of(c(by, variable))), |
||
| 149 | -7x | +83 | +4x |
- dplyr::filter(!is.na(.data$stat)) %>%+ paired = FALSE, |
| 150 | -+ | |||
| 84 | +4x |
- # add one more row with the method+ ci = conf.level, |
||
| 151 | +85 |
- {
- |
- ||
| 152 | -7x | -
- dplyr::bind_rows(+ ... |
||
| 153 | +86 |
- .,+ ) |> |
||
| 154 | -7x | +87 | +4x |
- dplyr::filter(., dplyr::n() == dplyr::row_number()) |>+ parameters::standardize_names(style = "broom") |> |
| 155 | -7x | +88 | +4x |
- dplyr::mutate(+ dplyr::mutate(method = "Hedge's G") |
| 156 | -7x | +|||
| 89 | +
- stat_name = "method",+ ), |
|||
| 157 | -7x | +90 | +4x |
- stat = list(.env$method_text)+ paired = FALSE, |
| 158 | +91 |
- )+ ... |
||
| 159 | +92 |
) |
||
| 160 | +93 |
} |
||
| 161 | +94 |
- }+ ) |> |
||
| 162 | -+ | |||
| 95 | +3x |
-
+ dplyr::bind_rows() |
||
| 163 | +96 |
- .anova_final_ard_prep <- function(lst_results, method_text) {
+ } |
||
| 164 | +97 |
- # saving the results in data frame -------------------------------------------- |
- ||
| 165 | -8x | -
- df_card <-- |
- ||
| 166 | -8x | -
- if (!is.null(lst_results[["result"]])) {
- |
- ||
| 167 | -7x | -
- lst_results[["result"]]+ |
||
| 168 | -8x | +|||
| 98 | +
- } else { # if there was an error return a shell of an ARD data frame
+ #' @rdname ard_effectsize_hedges_g |
|||
| 169 | -1x | +|||
| 99 | +
- dplyr::tibble(+ #' @export |
|||
| 170 | -1x | +|||
| 100 | +
- variable = "model_1",+ ard_effectsize_paired_hedges_g <- function(data, by, variables, id, conf.level = 0.95, ...) {
|
|||
| 171 | -1x | +101 | +2x |
- stat_name = c("p.value", "method"),
+ set_cli_abort_call() |
| 172 | -1x | +|||
| 102 | +
- stat = list(NULL, method_text)+ |
|||
| 173 | +103 |
- )+ # check installed packages --------------------------------------------------- |
||
| 174 | -+ | |||
| 104 | +2x |
- }+ check_pkg_installed(c("effectsize", "parameters"), reference_pkg = "cardx")
|
||
| 175 | +105 | |||
| 176 | +106 |
- # final tidying up of cards data frame ---------------------------------------+ # check/process inputs ------------------------------------------------------- |
||
| 177 | -8x | +107 | +2x |
- df_card |>+ check_not_missing(data) |
| 178 | -8x | +108 | +2x |
- dplyr::mutate(+ check_not_missing(variables) |
| 179 | -8x | +109 | +2x |
- warning = lst_results["warning"],+ check_not_missing(by) |
| 180 | -8x | +110 | +2x |
- error = lst_results["error"],+ check_not_missing(id) |
| 181 | -8x | +111 | +2x |
- context = "stats_anova",+ check_data_frame(data) |
| 182 | -8x | +112 | +2x |
- fmt_fn = lapply(+ data <- dplyr::ungroup(data) |
| 183 | -8x | +113 | +2x |
- .data$stat,+ cards::process_selectors(data, by = {{ by }}, variables = {{ variables }}, id = {{ id }})
|
| 184 | -8x | +114 | +2x |
- function(x) {
+ check_scalar(by) |
| 185 | -77x | +115 | +2x |
- switch(is.integer(x),+ check_scalar(id) |
| 186 | -77x | +116 | +2x |
- 0L+ check_range(conf.level, range = c(0, 1)) |
| 187 | -77x | +|||
| 117 | +
- ) %||% switch(is.numeric(x),+ + |
+ |||
| 118 | ++ |
+ # if no variables selected, return empty tibble ------------------------------ |
||
| 188 | -77x | +119 | +2x |
- 1L+ if (is_empty(variables)) {
+ |
+
| 120 | +! | +
+ return(dplyr::tibble()) |
||
| 189 | +121 |
- )+ } |
||
| 190 | +122 |
- }+ # build ARD ------------------------------------------------------------------ |
||
| 191 | +123 |
- ),+ |
||
| 192 | -8x | +124 | +2x |
- stat_label =+ lapply( |
| 193 | -8x | +125 | +2x |
- dplyr::case_when(+ variables, |
| 194 | -8x | +126 | +2x |
- .data$stat_name %in% "p.value" ~ "p-value",+ function(variable) {
|
| 195 | -8x | +127 | +2x |
- .data$stat_name %in% "sumsq" ~ "Sum of Squares",+ .format_hedges_g_results( |
| 196 | -8x | +128 | +2x |
- .data$stat_name %in% "rss" ~ "Residual Sum of Squares",+ by = by, |
| 197 | -8x | +129 | +2x |
- .data$stat_name %in% "df" ~ "Degrees of Freedom",+ variable = variable, |
| 198 | -8x | +130 | +2x |
- .data$stat_name %in% "df.residual" ~ "df for residuals",+ lst_tidy = |
| 199 | -8x | +131 | +2x |
- .default = .data$stat_name+ cards::eval_capture_conditions({
|
| 200 | +132 |
- )+ # adding this reshape inside the eval, so if there is an error it's captured in the ARD object |
||
| 201 | -+ | |||
| 133 | +2x |
- ) |>+ data_wide <- |
||
| 202 | -8x | +134 | +2x |
- cards::tidy_ard_column_order() %>%+ data |> |
| 203 | -8x | +135 | +2x |
- {structure(., class = c("card", class(.)))} # styler: off
+ tidyr::drop_na(all_of(c(id, by, variable))) |> |
| 204 | -+ | |||
| 136 | +2x |
- }+ .paired_data_pivot_wider(by = by, variable = variable, id = id) |> |
| 1 | -+ | |||
| 137 | +2x |
- #' ARD ANOVA from car Package+ tidyr::drop_na(any_of(c("by1", "by2")))
|
||
| 2 | +138 |
- #'+ # perform paired cohen's d test |
||
| 3 | -+ | |||
| 139 | +1x |
- #' Function takes a regression model object and calculated ANOVA using [`car::Anova()`].+ effectsize::hedges_g(x = data_wide[["by1"]], y = data_wide[["by2"]], paired = TRUE, ci = conf.level, ...) |> |
||
| 4 | -+ | |||
| 140 | +1x |
- #'+ parameters::standardize_names(style = "broom") |> |
||
| 5 | -+ | |||
| 141 | +1x |
- #' @param x regression model object+ dplyr::mutate(method = "Paired Hedge's G") |
||
| 6 | +142 |
- #' @param ... arguments passed to `car::Anova(...)`+ }), |
||
| 7 | -+ | |||
| 143 | +2x |
- #'+ paired = TRUE, |
||
| 8 | +144 |
- #' @return data frame+ ... |
||
| 9 | +145 |
- #' @export+ ) |
||
| 10 | +146 |
- #'+ } |
||
| 11 | +147 |
- #' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = c("broom.helpers", "car", "parameters"), reference_pkg = "cardx"))
+ ) |> |
||
| 12 | -+ | |||
| 148 | +2x |
- #' lm(AGE ~ ARM, data = cards::ADSL) |>+ dplyr::bind_rows() |
||
| 13 | +149 |
- #' ard_car_anova()+ } |
||
| 14 | +150 |
- #'+ |
||
| 15 | +151 |
- #' glm(vs ~ factor(cyl) + factor(am), data = mtcars, family = binomial) |>+ #' Convert Hedge's G Test to ARD |
||
| 16 | +152 |
- #' ard_car_anova(test.statistic = "Wald")+ #' |
||
| 17 | +153 |
- ard_car_anova <- function(x, ...) {
- |
- ||
| 18 | -2x | -
- set_cli_abort_call()+ #' @inheritParams cards::tidy_as_ard |
||
| 19 | +154 |
-
+ #' @inheritParams effectsize::hedges_g |
||
| 20 | +155 |
- # check installed packages ---------------------------------------------------- |
- ||
| 21 | -2x | -
- check_pkg_installed(pkg = c("broom.helpers", "car", "parameters"), reference_pkg = "cardx")
+ #' @param by (`string`)\cr by column name |
||
| 22 | +156 |
-
+ #' @param variable (`string`)\cr variable column name |
||
| 23 | +157 |
- # check inputs ---------------------------------------------------------------- |
- ||
| 24 | -2x | -
- check_not_missing(x)+ #' @param ... passed to `hedges_g(...)` |
||
| 25 | +158 |
-
+ #' |
||
| 26 | +159 |
- # run car::Anova() ------------------------------------------------------------ |
- ||
| 27 | -2x | -
- car_anova <- cards::eval_capture_conditions(car::Anova(x, ...))+ #' @return ARD data frame |
||
| 28 | +160 | - - | -||
| 29 | -2x | -
- if (!is.null(car_anova[["error"]])) {
- |
- ||
| 30 | -1x | -
- cli::cli_abort(- |
- ||
| 31 | -1x | -
- c(- |
- ||
| 32 | -1x | -
- "There was an error running {.fun car::Anova}. See error message below.",
- |
- ||
| 33 | -1x | -
- x = car_anova[["error"]]+ #' @keywords internal |
||
| 34 | +161 |
- ),- |
- ||
| 35 | -1x | -
- call = get_cli_abort_call()+ #' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = c("effectsize", "parameters"), reference_pkg = "cardx"))
|
||
| 36 | +162 |
- )+ #' cardx:::.format_hedges_g_results( |
||
| 37 | +163 |
- }+ #' by = "ARM", |
||
| 38 | +164 | - - | -||
| 39 | -1x | -
- car_anova[["result"]] |>- |
- ||
| 40 | -1x | -
- broom.helpers::tidy_parameters(conf.int = FALSE) |> # using broom.helpers, because it handle non-syntactic names for us- |
- ||
| 41 | -1x | -
- dplyr::filter(!(dplyr::row_number() == dplyr::n() & .data$term %in% "Residuals")) |> # removing Residual rows- |
- ||
| 42 | -1x | -
- dplyr::rename(variable = "term") |>- |
- ||
| 43 | -1x | -
- tidyr::pivot_longer(- |
- ||
| 44 | -1x | -
- cols = -"variable",+ #' variable = "AGE", |
||
| 45 | -1x | +|||
| 165 | +
- names_to = "stat_name",+ #' paired = FALSE, |
|||
| 46 | -1x | +|||
| 166 | +
- values_to = "stat"+ #' lst_tidy = |
|||
| 47 | +167 |
- ) |>+ #' cards::eval_capture_conditions( |
||
| 48 | -1x | +|||
| 168 | +
- dplyr::mutate(+ #' effectsize::hedges_g(data[[variable]] ~ data[[by]], paired = FALSE) |> |
|||
| 49 | -1x | +|||
| 169 | +
- stat = as.list(.data$stat),+ #' parameters::standardize_names(style = "broom") |
|||
| 50 | -1x | +|||
| 170 | +
- stat_label =+ #' ) |
|||
| 51 | -1x | +|||
| 171 | +
- dplyr::case_when(+ #' ) |
|||
| 52 | -1x | +|||
| 172 | +
- .data$stat_name %in% "statistic" ~ "Statistic",+ .format_hedges_g_results <- function(by, variable, lst_tidy, paired, ...) {
|
|||
| 53 | -1x | +|||
| 173 | +
- .data$stat_name %in% "df" ~ "Degrees of Freedom",+ # build ARD ------------------------------------------------------------------ |
|||
| 54 | -1x | +174 | +6x |
- .data$stat_name %in% "p.value" ~ "p-value",+ ret <- |
| 55 | -1x | +175 | +6x |
- TRUE ~ .data$stat_name+ cards::tidy_as_ard( |
| 56 | -+ | |||
| 176 | +6x |
- ),+ lst_tidy = lst_tidy, |
||
| 57 | -1x | +177 | +6x |
- fmt_fn =+ tidy_result_names = c( |
| 58 | -1x | +178 | +6x |
- map(+ "estimate", "conf.level", "conf.low", "conf.high" |
| 59 | -1x | +|||
| 179 | +
- .data$stat,+ ), |
|||
| 60 | -1x | +180 | +6x |
- function(.x) {
+ fun_args_to_record = c("mu", "paired", "pooled_sd", "alternative"),
|
| 61 | -+ | |||
| 181 | +6x |
- # styler: off+ formals = formals(asNamespace("effectsize")[["hedges_g"]]),
|
||
| 62 | -! | +|||
| 182 | +6x |
- if (is.integer(.x)) return(0L)+ passed_args = c(list(paired = paired), dots_list(...)), |
||
| 63 | +183 | 6x |
- if (is.numeric(.x)) return(1L)+ lst_ard_columns = list(group1 = by, variable = variable, context = "effectsize_hedges_g") |
|
| 64 | +184 |
- # styler: on+ ) |
||
| 65 | -! | +|||
| 185 | +
- NULL+ |
|||
| 66 | +186 |
- }+ # add the stat label --------------------------------------------------------- |
||
| 67 | -+ | |||
| 187 | +6x |
- ),+ ret |> |
||
| 68 | -1x | +188 | +6x |
- context = "car_anova",+ dplyr::left_join( |
| 69 | -1x | +189 | +6x |
- warning = car_anova["warning"],+ .df_effectsize_stat_labels(), |
| 70 | -1x | +190 | +6x |
- error = car_anova["error"]+ by = "stat_name" |
| 71 | +191 |
) |> |
||
| 72 | -1x | +192 | +6x |
- cards::tidy_ard_column_order() %>%+ dplyr::mutate(stat_label = dplyr::coalesce(.data$stat_label, .data$stat_name)) |> |
| 73 | -1x | +193 | +6x |
- {structure(., class = c("card", class(.)))} # styler: off
+ cards::tidy_ard_column_order() |
| 74 | +194 |
}@@ -35141,14 +34261,14 @@ cardx coverage - 95.32% |
| 1 |
- #' ARD Survey t-test+ #' ARD Survey rank test |
|||
| 4 |
- #' Analysis results data for survey t-test using [`survey::svyttest()`].+ #' Analysis results data for survey wilcox test using [`survey::svyranktest()`]. |
|||
| 12 |
- #' @param conf.level (`double`)\cr+ #' @param test (`string`)\cr |
|||
| 13 |
- #' confidence level of the returned confidence interval. Must be between `c(0, 1)`.+ #' a string to denote which rank test to use: |
|||
| 14 |
- #' Default is `0.95`+ #' `"wilcoxon"`, `"vanderWaerden"`, `"median"`, `"KruskalWallis"` |
|||
| 15 |
- #' @param ... arguments passed to [`survey::svyttest()`]+ #' @param ... arguments passed to [`survey::svyranktest()`] |
|||
| 24 |
- #' ard_survey_svyttest(dclus2, variables = enroll, by = comp.imp, conf.level = 0.9)+ #' ard_survey_svyranktest(dclus2, variables = enroll, by = comp.imp, test = "wilcoxon") |
|||
| 25 |
- ard_survey_svyttest <- function(data, by, variables, conf.level = 0.95, ...) {
+ #' ard_survey_svyranktest(dclus2, variables = enroll, by = comp.imp, test = "vanderWaerden") |
|||
| 26 | -4x | +
- set_cli_abort_call()+ #' ard_survey_svyranktest(dclus2, variables = enroll, by = comp.imp, test = "median") |
||
| 27 |
-
+ #' ard_survey_svyranktest(dclus2, variables = enroll, by = comp.imp, test = "KruskalWallis") |
|||
| 28 |
- # check installed packages ---------------------------------------------------+ ard_survey_svyranktest <- function(data, by, variables, test, ...) {
|
|||
| 29 | -4x | +5x |
- check_pkg_installed(c("survey", "broom"), reference_pkg = "cardx")
+ set_cli_abort_call() |
|
| 31 |
- # check/process inputs -------------------------------------------------------+ # check installed packages --------------------------------------------------- |
|||
| 32 | -4x | +5x |
- check_not_missing(data)+ check_pkg_installed(c("survey", "broom"), reference_pkg = "cardx")
|
|
| 33 | -4x | +
- check_not_missing(variables)+ |
||
| 34 | -4x | +
- check_not_missing(by)+ # check/process inputs ------------------------------------------------------- |
||
| 35 | -4x | +5x |
- check_range(conf.level, range = c(0, 1))+ check_not_missing(data) |
|
| 36 | -4x | +5x |
- check_class(data, cls = "survey.design")+ check_not_missing(variables) |
|
| 37 | -4x | +5x |
- cards::process_selectors(data[["variables"]], by = {{ by }}, variables = {{ variables }})
+ check_not_missing(by) |
|
| 38 | -4x | +5x | +
+ check_class(data, cls = "survey.design")+ |
+ |
| 39 | +5x | +
+ cards::process_selectors(data[["variables"]], by = {{ by }}, variables = {{ variables }})
+ |
+ ||
| 40 | +5x |
check_scalar(by) |
||
| 39 | +41 | |||
| 40 | +42 |
# build ARD ------------------------------------------------------------------ |
||
| 41 | -4x | +43 | +5x |
lapply( |
| 42 | -4x | +44 | +5x |
variables, |
| 43 | -4x | +45 | +5x |
function(variable) {
|
| 44 | +46 | 5x |
- .format_svyttest_results(+ .format_svyranktest_results( |
|
| 45 | +47 | 5x |
by = by, |
|
| 46 | +48 | 5x |
variable = variable, |
|
| 47 | +49 | 5x |
lst_tidy = |
|
| 48 | +50 | 5x |
cards::eval_capture_conditions( |
|
| 49 | +51 | 5x |
- survey::svyttest(reformulate2(termlabels = by, response = variable), design = data, ...) %>%+ survey::svyranktest(reformulate2(termlabels = by, response = variable), design = data, test = test, ...) |>+ |
+ |
| 52 | +5x | +
+ broom::tidy() |
||
| 50 | +53 |
- # a slightly enhanced tidier that allows us to specify the conf.level+ ) |
||
| 51 | +54 |
- {
+ )+ |
+ ||
| 55 | ++ |
+ }+ |
+ ||
| 56 | ++ |
+ ) |> |
||
| 52 | -4x | +57 | +5x |
- dplyr::bind_cols(+ dplyr::bind_rows()+ |
+
| 58 | ++ |
+ }+ |
+ ||
| 59 | ++ | + + | +||
| 60 | ++ |
+ .format_svyranktest_results <- function(by, variable, lst_tidy, ...) {
+ |
+ ||
| 61 | ++ |
+ # build ARD ------------------------------------------------------------------ |
||
| 53 | -4x | +62 | +5x | +
+ ret <-+ |
+
| 63 | +5x | +
+ cards::tidy_as_ard(+ |
+ ||
| 64 | +5x | +
+ lst_tidy = lst_tidy,+ |
+ ||
| 65 | +5x | +
+ tidy_result_names = c(+ |
+ ||
| 66 | +5x | +
+ "estimate", "statistic",+ |
+ ||
| 67 | +5x | +
+ "p.value", "parameter",+ |
+ ||
| 68 | +5x | +
+ "method", "alternative"+ |
+ ||
| 69 | ++ |
+ ),+ |
+ ||
| 70 | +5x | +
+ passed_args = dots_list(...),+ |
+ ||
| 71 | +5x | +
+ lst_ard_columns = list(group1 = by, variable = variable, context = "survey_svyranktest")+ |
+ ||
| 72 | ++ |
+ )+ |
+ ||
| 73 | ++ | + + | +||
| 74 | ++ |
+ # add the stat label ---------------------------------------------------------+ |
+ ||
| 75 | +5x | +
+ ret |>+ |
+ ||
| 76 | +5x | +
+ dplyr::left_join(+ |
+ ||
| 77 | +5x | +
+ .df_surveyrank_stat_labels(),+ |
+ ||
| 78 | +5x | +
+ by = "stat_name"+ |
+ ||
| 79 | ++ |
+ ) |>+ |
+ ||
| 80 | +5x | +
+ dplyr::mutate(stat_label = dplyr::coalesce(.data$stat_label, .data$stat_name)) |>+ |
+ ||
| 81 | +5x | +
+ cards::tidy_ard_column_order()+ |
+ ||
| 82 | ++ |
+ }+ |
+ ||
| 83 | ++ | + + | +||
| 84 | ++ | + + | +||
| 85 | ++ |
+ .df_surveyrank_stat_labels <- function() {
+ |
+ ||
| 86 | +5x | +
+ dplyr::tribble(+ |
+ ||
| 87 | +5x | +
+ ~stat_name, ~stat_label,+ |
+ ||
| 88 | +5x | +
+ "statistic", "Statistic",+ |
+ ||
| 89 | +5x | +
+ "parameter", "Degrees of Freedom",+ |
+ ||
| 90 | +5x | +
+ "estimate", "Median of the Difference",+ |
+ ||
| 91 | +5x | +
+ "null.value", "Null Value",+ |
+ ||
| 92 | +5x |
- broom::tidy(.) |> dplyr::select(-c("conf.low", "conf.high")),
+ "alternative", "Alternative Hypothesis", |
||
| 54 | -4x | +93 | +5x |
- dplyr::tibble(!!!stats::confint(., level = conf.level) |> set_names(c("conf.low", "conf.high"))) |>
+ "data.name", "Data Name", |
| 55 | -4x | +94 | +5x |
- dplyr::mutate(conf.level = conf.level)+ "p.value", "p-value" |
| 56 | +95 |
- )+ ) |
||
| 57 | +96 |
- }+ } |
| 58 | +1 |
- ),+ #' ARD Cohen's D Test |
|
| 59 | +2 |
- ...+ #' |
|
| 60 | +3 |
- )+ #' @description |
|
| 61 | +4 |
- }+ #' Analysis results data for paired and non-paired Cohen's D Effect Size Test |
|
| 62 | +5 |
- ) |>+ #' using [`effectsize::cohens_d()`]. |
|
| 63 | -4x | +||
| 6 | +
- dplyr::bind_rows()+ #' |
||
| 64 | +7 |
- }+ #' @param data (`data.frame`)\cr |
|
| 65 | +8 |
-
+ #' a data frame. See below for details. |
|
| 66 | +9 |
- .format_svyttest_results <- function(by, variable, lst_tidy, ...) {
+ #' @param by ([`tidy-select`][dplyr::dplyr_tidy_select])\cr |
|
| 67 | +10 |
- # build ARD ------------------------------------------------------------------+ #' column name to compare by. Must be a categorical variable with exactly two levels. |
|
| 68 | -5x | +||
| 11 | +
- ret <-+ #' @param variables ([`tidy-select`][dplyr::dplyr_tidy_select])\cr |
||
| 69 | -5x | +||
| 12 | +
- cards::tidy_as_ard(+ #' column names to be compared. Must be a continuous variables. |
||
| 70 | -5x | +||
| 13 | +
- lst_tidy = lst_tidy,+ #' Independent tests will be run for each variable. |
||
| 71 | -5x | +||
| 14 | +
- tidy_result_names = c(+ #' @param id ([`tidy-select`][dplyr::dplyr_tidy_select])\cr |
||
| 72 | -5x | +||
| 15 | +
- "estimate", "statistic",+ #' column name of the subject or participant ID |
||
| 73 | -5x | +||
| 16 | +
- "p.value", "parameter",+ #' @param conf.level (scalar `numeric`)\cr |
||
| 74 | -5x | +||
| 17 | +
- "conf.low", "conf.high",+ #' confidence level for confidence interval. Default is `0.95`. |
||
| 75 | -5x | +||
| 18 | +
- "conf.level", "method", "alternative"+ #' @param ... arguments passed to `effectsize::cohens_d(...)` |
||
| 76 | +19 |
- ),+ #' |
|
| 77 | -5x | +||
| 20 | +
- passed_args = dots_list(...),+ #' @return ARD data frame |
||
| 78 | -5x | +||
| 21 | +
- lst_ard_columns = list(group1 = by, variable = variable, context = "survey_svyttest")+ #' @name ard_effectsize_cohens_d |
||
| 79 | +22 |
- )+ #' |
|
| 80 | +23 |
-
+ #' @details |
|
| 81 | +24 |
- # add the stat label ---------------------------------------------------------+ #' For the `ard_effectsize_cohens_d()` function, the data is expected to be one row per subject. |
|
| 82 | -5x | +||
| 25 | +
- ret |>+ #' The data is passed as `effectsize::cohens_d(data[[variable]]~data[[by]], data, paired = FALSE, ...)`. |
||
| 83 | -5x | +||
| 26 | +
- dplyr::left_join(+ #' |
||
| 84 | -5x | +||
| 27 | +
- .df_ttest_stat_labels(),+ #' For the `ard_effectsize_paired_cohens_d()` function, the data is expected to be one row |
||
| 85 | -5x | +||
| 28 | +
- by = "stat_name"+ #' per subject per by level. Before the effect size is calculated, the data are |
||
| 86 | +29 |
- ) |>+ #' reshaped to a wide format to be one row per subject. |
|
| 87 | -5x | +||
| 30 | +
- dplyr::mutate(stat_label = dplyr::coalesce(.data$stat_label, .data$stat_name)) |>+ #' The data are then passed as |
||
| 88 | -5x | +||
| 31 | +
- cards::tidy_ard_column_order()+ #' `effectsize::cohens_d(x = data_wide[[<by level 1>]], y = data_wide[[<by level 2>]], paired = TRUE, ...)`. |
||
| 89 | +32 |
- }+ #' |
| 1 | +33 |
- #' ARD Proportion Confidence Intervals+ #' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = c("effectsize", "parameters"), reference_pkg = "cardx"))
|
||
| 2 | +34 |
- #'+ #' cards::ADSL |> |
||
| 3 | +35 |
- #' `r lifecycle::badge('experimental')`\cr
+ #' dplyr::filter(ARM %in% c("Placebo", "Xanomeline High Dose")) |>
|
||
| 4 | +36 |
- #' Calculate confidence intervals for proportions.+ #' ard_effectsize_cohens_d(by = ARM, variables = AGE) |
||
| 5 | +37 |
#' |
||
| 6 | +38 |
- #' @inheritParams cards::ard_categorical+ #' # constructing a paired data set, |
||
| 7 | +39 |
- #' @param variables ([`tidy-select`][dplyr::dplyr_tidy_select])\cr+ #' # where patients receive both treatments |
||
| 8 | +40 |
- #' columns to include in summaries. Columns must be class `<logical>`+ #' cards::ADSL[c("ARM", "AGE")] |>
|
||
| 9 | +41 |
- #' or `<numeric>` values coded as `c(0, 1)`.+ #' dplyr::filter(ARM %in% c("Placebo", "Xanomeline High Dose")) |>
|
||
| 10 | +42 |
- #' @param by ([`tidy-select`][dplyr::dplyr_tidy_select])\cr+ #' dplyr::mutate(.by = ARM, USUBJID = dplyr::row_number()) |> |
||
| 11 | +43 |
- #' columns to stratify calculations by+ #' dplyr::arrange(USUBJID, ARM) |> |
||
| 12 | +44 |
- #' @param conf.level (`numeric`)\cr+ #' dplyr::group_by(USUBJID) |> |
||
| 13 | +45 |
- #' a scalar in `(0, 1)` indicating the confidence level.+ #' dplyr::filter(dplyr::n() > 1) |> |
||
| 14 | +46 |
- #' Default is `0.95`+ #' ard_effectsize_paired_cohens_d(by = ARM, variables = AGE, id = USUBJID) |
||
| 15 | +47 |
- #' @param method (`string`)\cr+ NULL |
||
| 16 | +48 |
- #' string indicating the type of confidence interval to calculate.+ |
||
| 17 | +49 |
- #' Must be one of `r formals(ard_proportion_ci)[["method"]] |> eval() |> shQuote("sh")`.
+ #' @rdname ard_effectsize_cohens_d |
||
| 18 | +50 |
- #' See `?proportion_ci` for details.+ #' @export |
||
| 19 | +51 |
- #' @param strata,weights,max.iterations arguments passed to `proportion_ci_strat_wilson()`,+ ard_effectsize_cohens_d <- function(data, by, variables, conf.level = 0.95, ...) {
|
||
| 20 | -+ | |||
| 52 | +3x |
- #' when `method='strat_wilson'`+ set_cli_abort_call() |
||
| 21 | +53 |
- #' @param value ([`formula-list-selector`][syntax])\cr+ |
||
| 22 | +54 |
- #' function will calculate the CIs for all levels of the variables specified.+ # check installed packages --------------------------------------------------- |
||
| 23 | -+ | |||
| 55 | +3x |
- #' Use this argument to instead request only a single level by summarized.+ check_pkg_installed(c("effectsize", "parameters"), reference_pkg = "cardx")
|
||
| 24 | +56 |
- #' Default is `list(where(is_binary) ~ 1L, where(is.logical) ~ TRUE)`, where+ |
||
| 25 | +57 |
- #' columns coded as `0`/`1` and `TRUE`/`FALSE` will summarize the `1` and `TRUE` levels.+ # check/process inputs ------------------------------------------------------- |
||
| 26 | -+ | |||
| 58 | +3x |
- #'+ check_not_missing(data) |
||
| 27 | -+ | |||
| 59 | +3x |
- #' @return an ARD data frame+ check_not_missing(variables) |
||
| 28 | -+ | |||
| 60 | +3x |
- #' @export+ check_not_missing(by)+ |
+ ||
| 61 | +3x | +
+ check_data_frame(data)+ |
+ ||
| 62 | +3x | +
+ data <- dplyr::ungroup(data)+ |
+ ||
| 63 | +3x | +
+ cards::process_selectors(data, by = {{ by }}, variables = {{ variables }})
+ |
+ ||
| 64 | +3x | +
+ check_scalar(by)+ |
+ ||
| 65 | +3x | +
+ check_range(conf.level, range = c(0, 1)) |
||
| 29 | +66 |
- #'+ # if no variables selected, return empty tibble ------------------------------+ |
+ ||
| 67 | +3x | +
+ if (is_empty(variables)) {
+ |
+ ||
| 68 | +! | +
+ return(dplyr::tibble()) |
||
| 30 | +69 |
- #' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = "broom", reference_pkg = "cardx"))
+ } |
||
| 31 | +70 |
- #' # compute CI for binary variables+ |
||
| 32 | +71 |
- #' ard_proportion_ci(mtcars, variables = c(vs, am), method = "wilson")+ # build ARD ------------------------------------------------------------------+ |
+ ||
| 72 | +3x | +
+ lapply(+ |
+ ||
| 73 | +3x | +
+ variables,+ |
+ ||
| 74 | +3x | +
+ function(variable) {
+ |
+ ||
| 75 | +4x | +
+ .format_cohens_d_results(+ |
+ ||
| 76 | +4x | +
+ by = by,+ |
+ ||
| 77 | +4x | +
+ variable = variable,+ |
+ ||
| 78 | +4x | +
+ lst_tidy =+ |
+ ||
| 79 | +4x | +
+ cards::eval_capture_conditions(+ |
+ ||
| 80 | +4x | +
+ effectsize::cohens_d(+ |
+ ||
| 81 | +4x | +
+ reformulate2(by, response = variable),+ |
+ ||
| 82 | +4x | +
+ data = data |> tidyr::drop_na(all_of(c(by, variable))),+ |
+ ||
| 83 | +4x | +
+ paired = FALSE,+ |
+ ||
| 84 | +4x | +
+ ci = conf.level, |
||
| 33 | +85 |
- #'+ ... |
||
| 34 | +86 |
- #' # compute CIs for each level of a categorical variable+ ) |> |
||
| 35 | -+ | |||
| 87 | +4x |
- #' ard_proportion_ci(mtcars, variables = cyl, method = "jeffreys")+ parameters::standardize_names(style = "broom") |> |
||
| 36 | -+ | |||
| 88 | +4x |
- ard_proportion_ci <- function(data,+ dplyr::mutate(method = "Cohen's D") |
||
| 37 | +89 |
- variables,+ ), |
||
| 38 | -+ | |||
| 90 | +4x |
- by = dplyr::group_vars(data),+ paired = FALSE, |
||
| 39 | +91 |
- method = c(+ ... |
||
| 40 | +92 |
- "waldcc", "wald", "clopper-pearson",+ ) |
||
| 41 | +93 |
- "wilson", "wilsoncc",+ } |
||
| 42 | +94 |
- "strat_wilson", "strat_wilsoncc",+ ) |> |
||
| 43 | -+ | |||
| 95 | +3x |
- "agresti-coull", "jeffreys"+ dplyr::bind_rows() |
||
| 44 | +96 |
- ),+ } |
||
| 45 | +97 |
- conf.level = 0.95,+ |
||
| 46 | +98 |
- value = list(where(is_binary) ~ 1L, where(is.logical) ~ TRUE),+ |
||
| 47 | +99 |
- strata = NULL,+ #' @rdname ard_effectsize_cohens_d |
||
| 48 | +100 |
- weights = NULL,+ #' @export |
||
| 49 | +101 |
- max.iterations = 10) {
+ ard_effectsize_paired_cohens_d <- function(data, by, variables, id, conf.level = 0.95, ...) {
|
||
| 50 | -10x | +102 | +2x |
set_cli_abort_call() |
| 51 | +103 | |||
| 52 | +104 |
# check installed packages --------------------------------------------------- |
||
| 53 | -10x | +105 | +2x |
- check_pkg_installed(pkg = "broom", reference_pkg = "cardx")+ check_pkg_installed(c("effectsize", "parameters"), reference_pkg = "cardx")
|
| 54 | +106 | |||
| 55 | +107 |
- # process inputs -------------------------------------------------------------+ # check/process inputs ------------------------------------------------------- |
||
| 56 | -10x | +108 | +2x |
- cards::process_selectors(data, variables = {{ variables }}, by = {{ by }})
+ check_not_missing(data) |
| 57 | -10x | +109 | +2x |
- method <- arg_match(method)+ check_not_missing(variables) |
| 58 | -10x | +110 | +2x |
- if (method %in% c("strat_wilson", "strat_wilsoncc")) {
+ check_not_missing(by) |
| 59 | -1x | +111 | +2x |
- cards::process_selectors(data, strata = strata)+ check_not_missing(id) |
| 60 | -1x | +112 | +2x |
- check_scalar(strata)+ check_data_frame(data) |
| 61 | -+ | |||
| 113 | +2x |
- }+ data <- dplyr::ungroup(data) |
||
| 62 | -10x | +114 | +2x |
- cards::process_formula_selectors(+ cards::process_selectors(data, by = {{ by }}, variables = {{ variables }}, id = {{ id }})
|
| 63 | -10x | +115 | +2x |
- data[variables],+ check_scalar(by) |
| 64 | -10x | +116 | +2x |
- value = value+ check_scalar(id) |
| 65 | -+ | |||
| 117 | +2x |
- )+ check_range(conf.level, range = c(0, 1)) |
||
| 66 | +118 | |||
| 67 | +119 |
- # calculate confidence intervals ---------------------------------------------- |
- ||
| 68 | -10x | -
- map(+ # if no variables selected, return empty tibble ------------------------------ |
||
| 69 | -10x | +120 | +2x |
- variables,+ if (is_empty(variables)) {
|
| 70 | -10x | +|||
| 121 | +! |
- function(variable) {
+ return(dplyr::tibble()) |
||
| 71 | -17x | +|||
| 122 | +
- levels <- .unique_values_sort(data, variable = variable, value = value[[variable]])+ } |
|||
| 72 | +123 | |||
| 73 | -17x | +|||
| 124 | +
- .calculate_ard_proportion(+ # build ARD ------------------------------------------------------------------ |
|||
| 74 | -17x | +125 | +2x |
- data = .as_dummy(data, variable = variable, levels = levels, by = by, strata = strata),+ lapply( |
| 75 | -17x | +126 | +2x |
- variables = c(everything(), -all_of(c(by, strata))),+ variables, |
| 76 | -17x | +127 | +2x |
- by = all_of(by),+ function(variable) {
|
| 77 | -17x | +128 | +2x |
- method = method,+ .format_cohens_d_results( |
| 78 | -17x | +129 | +2x |
- conf.level = conf.level,+ by = by, |
| 79 | -17x | +130 | +2x |
- strata = strata,+ variable = variable, |
| 80 | -17x | +131 | +2x |
- weights = weights,+ lst_tidy = |
| 81 | -17x | -
- max.iterations = max.iterations- |
- ||
| 82 | -+ | 132 | +2x |
- ) %>%+ cards::eval_capture_conditions({
|
| 83 | +133 |
- # merge in the variable levels+ # adding this reshape inside the eval, so if there is an error it's captured in the ARD object |
||
| 84 | -17x | +134 | +2x |
- dplyr::left_join(+ data_wide <- |
| 85 | -17x | +135 | +2x |
- dplyr::select(., "variable") |>+ data |> |
| 86 | -17x | +136 | +2x |
- dplyr::distinct() |>+ tidyr::drop_na(all_of(c(id, by, variable))) |> |
| 87 | -17x | +137 | +2x |
- dplyr::mutate(variable_level = as.list(.env$levels)),+ .paired_data_pivot_wider(by = by, variable = variable, id = id) |> |
| 88 | -17x | -
- by = "variable"- |
- ||
| 89 | -+ | 138 | +2x |
- ) |>+ tidyr::drop_na(any_of(c("by1", "by2")))
|
| 90 | +139 |
- # rename variable column+ # perform paired cohen's d test |
||
| 91 | -17x | +140 | +1x |
- dplyr::mutate(variable = .env$variable) |>+ effectsize::cohens_d(x = data_wide[["by1"]], y = data_wide[["by2"]], paired = TRUE, ci = conf.level, ...) |> |
| 92 | -17x | +141 | +1x |
- dplyr::relocate("variable_level", .after = "variable")
+ parameters::standardize_names(style = "broom") |> |
| 93 | -+ | |||
| 142 | +1x |
- }+ dplyr::mutate(method = "Paired Cohen's D") |
||
| 94 | +143 |
- ) |>+ }), |
||
| 95 | -10x | +144 | +2x |
- dplyr::bind_rows()+ paired = TRUE, |
| 96 | +145 |
- }+ ... |
||
| 97 | +146 |
-
+ ) |
||
| 98 | +147 |
- .calculate_ard_proportion <- function(data, variables, by, method, conf.level, strata, weights, max.iterations) {
- |
- ||
| 99 | -17x | -
- cards::ard_complex(+ } |
||
| 100 | -17x | +|||
| 148 | +
- data = data,+ ) |> |
|||
| 101 | -17x | +149 | +2x |
- variables = {{ variables }},
+ dplyr::bind_rows() |
| 102 | -17x | +|||
| 150 | +
- by = {{ by }},
+ } |
|||
| 103 | -17x | +|||
| 151 | +
- statistic =+ |
|||
| 104 | -17x | +|||
| 152 | +
- ~ list(+ .df_effectsize_stat_labels <- function() {
|
|||
| 105 | -17x | +153 | +12x |
- prop_ci =+ dplyr::tribble( |
| 106 | -17x | +154 | +12x |
- switch(method,+ ~stat_name, ~stat_label, |
| 107 | -17x | +155 | +12x |
- "waldcc" = \(x, ...) proportion_ci_wald(x, conf.level = conf.level, correct = TRUE),+ "estimate", "Effect Size Estimate", |
| 108 | -17x | +156 | +12x |
- "wald" = \(x, ...) proportion_ci_wald(x, conf.level = conf.level, correct = FALSE),+ "conf.low", "CI Lower Bound", |
| 109 | -17x | +157 | +12x |
- "wilsoncc" = \(x, ...) proportion_ci_wilson(x, conf.level = conf.level, correct = TRUE),+ "conf.high", "CI Upper Bound", |
| 110 | -17x | +158 | +12x |
- "wilson" = \(x, ...) proportion_ci_wilson(x, conf.level = conf.level, correct = FALSE),+ "conf.level", "CI Confidence Level", |
| 111 | -17x | +159 | +12x |
- "clopper-pearson" = \(x, ...) proportion_ci_clopper_pearson(x, conf.level = conf.level),+ "mu", "H0 Mean", |
| 112 | -17x | +160 | +12x |
- "agresti-coull" = \(x, ...) proportion_ci_agresti_coull(x, conf.level = conf.level),+ "paired", "Paired test", |
| 113 | -17x | +161 | +12x |
- "jeffreys" = \(x, ...) proportion_ci_jeffreys(x, conf.level = conf.level),+ "pooled_sd", "Pooled Standard Deviation", |
| 114 | -17x | -
- "strat_wilsoncc" = \(x, data, ...) {
- |
- ||
| 115 | -! | -
- proportion_ci_strat_wilson(x,- |
- ||
| 116 | -! | -
- strata = data[[strata]], weights = weights,- |
- ||
| 117 | -! | +162 | +12x |
- max.iterations = max.iterations,+ "alternative", "Alternative Hypothesis" |
| 118 | -! | +|||
| 163 | +
- conf.level = conf.level, correct = TRUE+ ) |
|||
| 119 | +164 |
- )+ } |
||
| 120 | +165 |
- },+ |
||
| 121 | -17x | +|||
| 166 | +
- "strat_wilson" = \(x, data, ...) {
+
|
|||
| 122 | -1x | +|||
| 167 | +
- proportion_ci_strat_wilson(x,+ #' Convert Cohen's D Test to ARD |
|||
| 123 | -1x | +|||
| 168 | +
- strata = data[[strata]], weights = weights,+ #' |
|||
| 124 | -1x | +|||
| 169 | +
- max.iterations = max.iterations,+ #' @inheritParams cards::tidy_as_ard |
|||
| 125 | -1x | +|||
| 170 | +
- conf.level = conf.level, correct = FALSE+ #' @inheritParams effectsize::cohens_d |
|||
| 126 | +171 |
- )+ #' @param by (`string`)\cr by column name |
||
| 127 | +172 |
- }+ #' @param variable (`string`)\cr variable column name |
||
| 128 | +173 |
- )+ #' @param ... passed to `cohens_d(...)` |
||
| 129 | +174 |
- )+ #' |
||
| 130 | +175 |
- ) |>+ #' @return ARD data frame |
||
| 131 | -17x | +|||
| 176 | +
- dplyr::mutate(+ #' @keywords internal |
|||
| 132 | -17x | +|||
| 177 | +
- context = "proportion_ci"+ #' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = c("effectsize", "parameters"), reference_pkg = "cardx"))
|
|||
| 133 | +178 |
- )+ #' cardx:::.format_cohens_d_results( |
||
| 134 | +179 |
- }+ #' by = "ARM", |
||
| 135 | +180 |
-
+ #' variable = "AGE", |
||
| 136 | +181 |
- .unique_values_sort <- function(data, variable, value = NULL) {
+ #' paired = FALSE, |
||
| 137 | -177x | +|||
| 182 | +
- unique_levels <-+ #' lst_tidy = |
|||
| 138 | +183 |
- # styler: off+ #' cards::eval_capture_conditions( |
||
| 139 | -177x | +|||
| 184 | +
- if (is.logical(data[[variable]])) c(TRUE, FALSE)+ #' effectsize::hedges_g(data[[variable]] ~ data[[by]], paired = FALSE) |> |
|||
| 140 | -177x | +|||
| 185 | +
- else if (is.factor(data[[variable]])) factor(levels(data[[variable]]), levels = levels(data[[variable]]))+ #' parameters::standardize_names(style = "broom") |
|||
| 141 | -177x | +|||
| 186 | +
- else unique(data[[variable]]) |> sort()+ #' ) |
|||
| 142 | +187 |
- # styler: on+ #' ) |
||
| 143 | +188 |
-
+ .format_cohens_d_results <- function(by, variable, lst_tidy, paired, ...) {
|
||
| 144 | -177x | +|||
| 189 | +
- if (!is_empty(value) && !value %in% unique_levels) {
+ # build ARD ------------------------------------------------------------------ |
|||
| 145 | -1x | +190 | +6x |
- cli::cli_warn(+ ret <- |
| 146 | -1x | +191 | +6x |
- c("A value of {.code value={.val {value}}} for variable {.val {variable}}
+ cards::tidy_as_ard( |
| 147 | -1x | +192 | +6x |
- was passed, but is not one of the observed levels: {.val {unique_levels}}.",
+ lst_tidy = lst_tidy, |
| 148 | -1x | +193 | +6x |
- i = "This may be an error.",+ tidy_result_names = c( |
| 149 | -1x | +194 | +6x |
- i = "If value is a valid, convert variable to factor with all levels specified to avoid this message."+ "estimate", "conf.level", "conf.low", "conf.high" |
| 150 | +195 |
- )+ ), |
||
| 151 | -+ | |||
| 196 | +6x |
- )+ fun_args_to_record = c("mu", "paired", "pooled_sd", "alternative"),
|
||
| 152 | -+ | |||
| 197 | +6x |
- }+ formals = formals(asNamespace("effectsize")[["cohens_d"]]),
|
||
| 153 | -177x | +198 | +6x |
- if (!is_empty(value)) {
+ passed_args = c(list(paired = paired), dots_list(...)), |
| 154 | -16x | +199 | +6x |
- unique_levels <- value+ lst_ard_columns = list(group1 = by, variable = variable, context = "effectsize_cohens_d") |
| 155 | +200 |
- }+ ) |
||
| 156 | +201 | |||
| 157 | -177x | -
- unique_levels- |
- ||
| 158 | +202 |
- }+ # add the stat label --------------------------------------------------------- |
||
| 159 | -+ | |||
| 203 | +6x |
-
+ ret |> |
||
| 160 | -+ | |||
| 204 | +6x |
- .as_dummy <- function(data, variable, levels, by, strata) {
+ dplyr::left_join( |
||
| 161 | -+ | |||
| 205 | +6x |
- # define dummy variables and return tibble+ .df_effectsize_stat_labels(), |
||
| 162 | -17x | +206 | +6x |
- map(levels, ~ data[[variable]] == .x) |>+ by = "stat_name" |
| 163 | -17x | +|||
| 207 | +
- set_names(paste0("this_is_not_a_column_name_anyone_would_choose_", variable, "_", levels, "...")) %>%
+ ) |> |
|||
| 164 | -17x | +208 | +6x |
- {dplyr::tibble(!!!.)} |> # styler: off
+ dplyr::mutate(stat_label = dplyr::coalesce(.data$stat_label, .data$stat_name)) |> |
| 165 | -17x | +209 | +6x |
- dplyr::bind_cols(data[c(by, strata)])+ cards::tidy_ard_column_order() |
| 166 | +210 |
}@@ -36938,14 +36415,14 @@ cardx coverage - 95.32% |
| 1 |
- #' ARD ANOVA+ #' ARD one-sample Wilcox Rank-sum |
|||
| 4 |
- #' Analysis results data for Analysis of Variance.+ #' Analysis results data for one-sample Wilcox Rank-sum. |
|||
| 5 |
- #' Calculated with `stats::aov()`+ #' Result may be stratified by including the `by` argument. |
|||
| 7 |
- #' @inheritParams stats::aov+ #' @param data (`data.frame`)\cr |
|||
| 8 |
- #' @param ... arguments passed to `stats::aov(...)`+ #' a data frame. See below for details. |
|||
| 9 |
- #'+ #' @param variables ([`tidy-select`][dplyr::dplyr_tidy_select])\cr |
|||
| 10 |
- #' @return ARD data frame+ #' column names to be analyzed. Independent Wilcox Rank-sum tests will be computed for |
|||
| 11 |
- #' @export+ #' each variable. |
|||
| 12 |
- #'+ #' @param by ([`tidy-select`][dplyr::dplyr_tidy_select])\cr |
|||
| 13 |
- #' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = c("broom.helpers", "parameters"), reference_pkg = "cardx"))
+ #' optional column name to stratify results by. |
|||
| 14 |
- #' ard_stats_aov(AGE ~ ARM, data = cards::ADSL)+ #' @inheritParams ard_stats_wilcox_test |
|||
| 15 |
- ard_stats_aov <- function(formula, data, ...) {
+ #' |
|||
| 16 | -2x | +
- set_cli_abort_call()+ #' @return ARD data frame |
||
| 17 |
-
+ #' @export |
|||
| 18 |
- # check installed packages ---------------------------------------------------+ #' |
|||
| 19 | -2x | +
- check_pkg_installed(c("broom.helpers", "parameters"), reference_pkg = "cardx")
+ #' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = "broom", reference_pkg = "cardx"))
|
||
| 20 |
-
+ #' cards::ADSL |> |
|||
| 21 |
- # check/process inputs -------------------------------------------------------+ #' ard_stats_wilcox_test_onesample(by = ARM, variables = AGE) |
|||
| 22 | -2x | +
- check_not_missing(formula)+ ard_stats_wilcox_test_onesample <- function(data, variables, by = dplyr::group_vars(data), conf.level = 0.95, ...) {
|
||
| 23 | 2x |
- check_not_missing(data)+ set_cli_abort_call() |
||
| 24 | -2x | +
- check_data_frame(data)+ |
||
| 25 | -2x | +
- check_class(formula, cls = "formula")+ # check installed packages --------------------------------------------------- |
||
| 26 | -+ | 2x |
-
+ check_pkg_installed("broom", reference_pkg = "cardx")
|
|
| 27 |
- # build ARD ------------------------------------------------------------------+ |
|||
| 28 | -2x | +
- aov <-+ # check/process inputs ------------------------------------------------------- |
||
| 29 | 2x |
- cards::eval_capture_conditions(+ check_not_missing(data) |
||
| 30 | 2x |
- stats::aov(formula, data, ...)+ check_not_missing(variables) |
||
| 31 | -+ | 2x |
- )+ check_data_frame(data) |
|
| 32 | 2x |
- aov[["result"]] |>+ data <- dplyr::ungroup(data) |
||
| 33 | 2x |
- broom.helpers::tidy_parameters() |> # using broom.helpers, because it handle non-syntactic names+ cards::process_selectors(data, by = {{ by }}, variables = {{ variables }})
|
||
| 34 | 2x |
- dplyr::filter(!(dplyr::row_number() == dplyr::n() & .data$term %in% "Residuals")) |> # removing Residual rows+ check_scalar_range(conf.level, range = c(0, 1)) |
||
| 35 | -2x | +
- dplyr::rename(variable = "term") |>+ |
||
| 36 | -2x | +
- tidyr::pivot_longer(+ # if no variables selected, return empty tibble ------------------------------ |
||
| 37 | 2x |
- cols = -"variable",+ if (is_empty(variables)) {
|
||
| 38 | -2x | +1x |
- names_to = "stat_name",+ return(dplyr::tibble()) |
|
| 39 | -2x | +
- values_to = "stat"+ } |
||
| 40 |
- ) |>+ |
|||
| 41 | -2x | +1x |
- dplyr::mutate(+ cards::ard_continuous( |
|
| 42 | -2x | +1x |
- stat = as.list(.data$stat),+ data = data, |
|
| 43 | -2x | +1x |
- stat_label =+ variables = all_of(variables), |
|
| 44 | -2x | +1x |
- dplyr::case_when(+ by = all_of(by), |
|
| 45 | -2x | +1x |
- .data$stat_name %in% "statistic" ~ "Statistic",+ statistic = all_of(variables) ~ list(t_test_onesample = \(x) stats::wilcox.test(x = x, conf.level = conf.level, ...) |> broom::tidy()) |
|
| 46 | -2x | +
- .data$stat_name %in% "df" ~ "Degrees of Freedom",+ ) |> |
||
| 47 | -2x | +1x | +
+ cards::bind_ard(+ |
+ |
| 48 | +1x | +
+ cards::ard_continuous(+ |
+ ||
| 49 | +1x | +
+ data = data,+ |
+ ||
| 50 | +1x | +
+ variables = all_of(variables),+ |
+ ||
| 51 | +1x | +
+ by = all_of(by),+ |
+ ||
| 52 | +1x | +
+ statistic =+ |
+ ||
| 53 | +1x | +
+ all_of(variables) ~+ |
+ ||
| 54 | +1x | +
+ list(conf.level = \(x) {
+ |
+ ||
| 55 | +3x | +
+ formals(asNamespace("stats")[["wilcox.test.default"]])[c("mu", "exact", "conf.int", "tol.root", "digits.rank")] |>
+ |
+ ||
| 56 | +3x | +
+ utils::modifyList(list(conf.level = conf.level, ...)) |>+ |
+ ||
| 57 | +3x | +
+ compact()+ |
+ ||
| 58 | ++ |
+ })+ |
+ ||
| 59 | ++ |
+ )+ |
+ ||
| 60 | ++ |
+ ) |>+ |
+ ||
| 61 | +1x |
- .data$stat_name %in% "p.value" ~ "p-value",+ dplyr::select(-"stat_label") |> |
||
| 48 | -2x | +62 | +1x |
- .data$stat_name %in% "sumsq" ~ "Sum of Squares",+ dplyr::left_join( |
| 49 | -2x | +63 | +1x |
- .data$stat_name %in% "meansq" ~ "Mean of Sum of Squares",+ .df_ttest_stat_labels(by = NULL), |
| 50 | -2x | +64 | +1x |
- TRUE ~ .data$stat_name+ by = "stat_name" |
| 51 | +65 |
- ),+ ) |> |
||
| 52 | -2x | +66 | +1x |
- context = "stats_aov",+ dplyr::mutate( |
| 53 | -2x | +67 | +1x |
- warning = aov["warning"],+ stat_label = dplyr::coalesce(.data$stat_label, .data$stat_name), |
| 54 | -2x | +68 | +1x |
- error = aov["error"]+ context = "stats_wilcox_test_onesample", |
| 55 | +69 |
) |> |
||
| 56 | -2x | +70 | +1x |
- cards::tidy_ard_column_order() %>%+ cards::tidy_ard_row_order() |> |
| 57 | -2x | +71 | +1x |
- {structure(., class = c("card", class(.)))} # styler: off
+ cards::tidy_ard_column_order() |
| 58 | +72 |
}@@ -37350,14 +36925,14 @@ cardx coverage - 95.32% |
| 1 |
- #' ARD survey categorical CIs+ #' ARD Fisher's Exact Test |
||
| 3 |
- #' Confidence intervals for categorical variables calculated via+ #' @description |
||
| 4 |
- #' [`survey::svyciprop()`].+ #' Analysis results data for Fisher's Exact Test. |
||
| 5 |
- #'+ #' Calculated with `fisher.test(x = data[[variable]], y = data[[by]], ...)` |
||
| 6 |
- #' @inheritParams ard_continuous.survey.design+ #' |
||
| 7 |
- #' @param method (`string`)\cr+ #' |
||
| 8 |
- #' Method passed to `survey::svyciprop(method)`+ #' @param data (`data.frame`)\cr |
||
| 9 |
- #' @param conf.level (scalar `numeric`)\cr+ #' a data frame. |
||
| 10 |
- #' confidence level for confidence interval. Default is `0.95`.+ #' @param by ([`tidy-select`][dplyr::dplyr_tidy_select])\cr |
||
| 11 |
- #' @param df (`numeric`)\cr+ #' column name to compare by |
||
| 12 |
- #' denominator degrees of freedom, passed to `survey::svyciprop(df)`.+ #' @param variables ([`tidy-select`][dplyr::dplyr_tidy_select])\cr |
||
| 13 |
- #' Default is `survey::degf(data)`.+ #' column names to be compared. Independent tests will be computed for |
||
| 14 |
- #' @param ... arguments passed to `survey::svyciprop()`+ #' each variable. |
||
| 15 |
- #'+ #' @param conf.level (scalar `numeric`)\cr |
||
| 16 |
- #' @return ARD data frame+ #' confidence level for confidence interval. Default is `0.95`. |
||
| 17 |
- #' @export+ #' @param ... additional arguments passed to `fisher.test(...)` |
||
| 19 |
- #' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = "survey", reference_pkg = "cardx"))
+ #' @return ARD data frame |
||
| 20 |
- #' data(api, package = "survey")+ #' @export |
||
| 21 |
- #' dclus1 <- survey::svydesign(id = ~dnum, weights = ~pw, data = apiclus1, fpc = ~fpc)+ #' |
||
| 22 |
- #'+ #' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = "broom", reference_pkg = "cardx"))
|
||
| 23 |
- #' ard_survey_categorical_ci(dclus1, variables = sch.wide)+ #' cards::ADSL[1:30, ] |> |
||
| 24 |
- #' ard_survey_categorical_ci(dclus1, variables = sch.wide, method = "xlogit")+ #' ard_stats_fisher_test(by = "ARM", variables = "AGEGR1") |
||
| 25 |
- ard_survey_categorical_ci <- function(data,+ ard_stats_fisher_test <- function(data, by, variables, conf.level = 0.95, ...) {
|
||
| 26 | -+ | 3x |
- variables,+ set_cli_abort_call() |
| 27 |
- by = NULL,+ |
||
| 28 |
- method = c("logit", "likelihood", "asin", "beta", "mean", "xlogit"),
+ # check installed packages --------------------------------------------------- |
||
| 29 | -+ | 3x |
- conf.level = 0.95,+ check_pkg_installed("broom", reference_pkg = "cardx")
|
| 30 |
- df = survey::degf(data),+ |
||
| 31 |
- ...) {
+ # check/process inputs ------------------------------------------------------- |
||
| 32 | -12x | +3x |
- set_cli_abort_call()+ check_not_missing(data) |
| 33 | -+ | 3x |
-
+ check_not_missing(variables) |
| 34 | -+ | 3x |
- # check inputs ---------------------------------------------------------------+ check_not_missing(by) |
| 35 | -12x | +3x |
- check_not_missing(data)+ check_data_frame(data) |
| 36 | -12x | +3x |
- check_class(data, "survey.design")+ cards::process_selectors(data, by = {{ by }}, variables = {{ variables }})
|
| 37 | -12x | +3x |
- check_not_missing(variables)+ check_scalar(by) |
| 38 | -+ | 3x |
-
+ check_range(conf.level, range = c(0, 1)) |
| 39 | -12x | +
- cards::process_selectors(+ |
|
| 40 | -12x | +
- data = data$variables,+ # if no variables selected, return empty tibble ------------------------------ |
|
| 41 | -12x | +3x |
- variables = {{ variables }},
+ if (is_empty(variables)) {
|
| 42 | -12x | +! |
- by = {{ by }}
+ return(dplyr::tibble()) |
| 43 |
- )+ } |
||
| 44 | -12x | +
- check_scalar(by, allow_empty = TRUE)+ # build ARD ------------------------------------------------------------------ |
|
| 45 | -12x | +3x |
- check_scalar_range(conf.level, range = c(0, 1))+ lapply( |
| 46 | -12x | +3x |
- method <- arg_match(method)+ variables, |
| 47 | -+ | 3x |
-
+ function(variable) {
|
| 48 | -+ | 4x |
- # calculate and return ARD of one sample CI ----------------------------------+ cards::tidy_as_ard( |
| 49 | -12x | +4x |
- .calculate_ard_onesample_survey_ci(+ lst_tidy = |
| 50 | -12x | +4x |
- FUN = .svyciprop_wrapper,+ cards::eval_capture_conditions( |
| 51 | -12x | +4x |
- data = data,+ stats::fisher.test(x = data[[variable]], y = data[[by]], conf.level = conf.level, ...) |> |
| 52 | -12x | +4x |
- variables = variables,+ broom::tidy() |
| 53 | -12x | +
- by = by,+ ), |
|
| 54 | -12x | +4x |
- conf.level = conf.level,+ tidy_result_names = |
| 55 | -12x | +4x |
- method = method,+ c("estimate", "p.value", "conf.low", "conf.high", "method", "alternative"),
|
| 56 | -12x | +4x |
- df = df,+ fun_args_to_record = |
| 57 | -+ | 4x |
- ...+ c( |
| 58 | -+ | 4x |
- )+ "workspace", "hybrid", "hybridPars", "control", "or", |
| 59 | -+ | 4x |
- }+ "conf.int", "conf.level", "simulate.p.value", "B" |
| 60 |
-
+ ), |
||
| 61 | -+ | 4x |
- .calculate_ard_onesample_survey_ci <- function(FUN, data, variables, by, conf.level, ...) {
+ formals = formals(stats::fisher.test), |
| 62 | -+ | 4x |
- # return empty data frame if no variables to process -------------------------+ passed_args = dots_list(...), |
| 63 | -1x | +4x |
- if (is_empty(variables)) return(dplyr::tibble()) # styler: off+ lst_ard_columns = list(group1 = by, variable = variable, context = "stats_fisher_test") |
| 64 |
-
+ ) |> |
||
| 65 | -+ | 4x |
- # calculate results ----------------------------------------------------------+ dplyr::mutate( |
| 66 | -11x | +4x |
- map(+ .after = "stat_name", |
| 67 | -11x | +4x |
- variables,+ stat_label = |
| 68 | -11x | +4x |
- function(variable) {
+ dplyr::case_when( |
| 69 | -18x | +4x |
- .calculate_one_ard_categorical_survey_ci(+ .data$stat_name %in% "p.value" ~ "p-value", |
| 70 | -18x | +4x |
- FUN = FUN,+ TRUE ~ .data$stat_name, |
| 71 | -18x | +
- data = data,+ ) |
|
| 72 | -18x | +
- variable = variable,+ ) |
|
| 73 | -18x | +
- by = by,+ } |
|
| 74 | -18x | +
- conf.level = conf.level,+ ) |> |
|
| 75 | -+ | 3x |
- ...+ dplyr::bind_rows() |
| 76 |
- )+ } |
| 77 | +1 |
- }+ #' ARD Standardized Mean Difference |
||
| 78 | +2 |
- ) |>+ #' |
||
| 79 | -11x | +|||
| 3 | +
- dplyr::bind_rows()+ #' @description |
|||
| 80 | +4 |
- }+ #' Standardized mean difference calculated via [`smd::smd()`] with `na.rm = TRUE`. |
||
| 81 | +5 |
-
+ #' Additionally, this function add a confidence interval to the SMD when |
||
| 82 | +6 |
- .calculate_one_ard_categorical_survey_ci <- function(FUN, data, variable, by, conf.level, ...) {
+ #' `std.error=TRUE`, which the original `smd::smd()` does not include. |
||
| 83 | -18x | +|||
| 7 | +
- variable_levels <- .unique_values_sort(data$variables, variable = variable)+ #' |
|||
| 84 | -18x | +|||
| 8 | +
- if (!is_empty(by)) {
+ #' @param data (`data.frame`/`survey.design`)\cr |
|||
| 85 | -6x | +|||
| 9 | +
- by_levels <- .unique_values_sort(data$variables, variable = by)+ #' a data frame or object of class 'survey.design' |
|||
| 86 | -6x | +|||
| 10 | +
- lst_data <-+ #' (typically created with [`survey::svydesign()`]). |
|||
| 87 | -6x | +|||
| 11 | ++ |
+ #' @param by ([`tidy-select`][dplyr::dplyr_tidy_select])\cr+ |
+ ||
| 12 | ++ |
+ #' column name to compare by.+ |
+ ||
| 13 | ++ |
+ #' @param variables ([`tidy-select`][dplyr::dplyr_tidy_select])\cr+ |
+ ||
| 14 | ++ |
+ #' column names to be compared. Independent tests will be computed for+ |
+ ||
| 15 | ++ |
+ #' each variable.+ |
+ ||
| 16 | ++ |
+ #' @param conf.level (scalar `numeric`)\cr+ |
+ ||
| 17 | ++ |
+ #' confidence level for confidence interval. Default is `0.95`.+ |
+ ||
| 18 | ++ |
+ #' @param std.error (scalar `logical`)\cr+ |
+ ||
| 19 | ++ |
+ #' Logical indicator for computing standard errors using `smd::compute_smd_var()`.+ |
+ ||
| 20 | ++ |
+ #' Default is `TRUE`.+ |
+ ||
| 21 | ++ |
+ #' @param ... arguments passed to `smd::smd()`+ |
+ ||
| 22 | ++ |
+ #'+ |
+ ||
| 23 | ++ |
+ #' @return ARD data frame+ |
+ ||
| 24 | ++ |
+ #' @export+ |
+ ||
| 25 | ++ |
+ #'+ |
+ ||
| 26 | +
- map(+ #' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = "smd", reference_pkg = "cardx"))
|
|||
| 88 | -6x | +|||
| 27 | +
- by_levels,+ #' ard_smd_smd(cards::ADSL, by = SEX, variables = AGE) |
|||
| 89 | -6x | +|||
| 28 | +
- ~ call2("subset", expr(data), expr(!!sym(by) == !!.x)) |> eval()
+ #' ard_smd_smd(cards::ADSL, by = SEX, variables = AGEGR1) |
|||
| 90 | +29 |
- ) |>+ ard_smd_smd <- function(data, by, variables, std.error = TRUE, conf.level = 0.95, ...) {
|
||
| 91 | -6x | +30 | +5x |
- set_names(as.character(by_levels))+ set_cli_abort_call() |
| 92 | +31 |
- }+ |
||
| 93 | +32 |
-
+ # check installed packages --------------------------------------------------- |
||
| 94 | -18x | +33 | +5x |
- df_full <-+ check_pkg_installed("smd", reference_pkg = "cardx")
|
| 95 | -18x | +|||
| 34 | +
- case_switch(+ |
|||
| 96 | -18x | +|||
| 35 | +
- !is_empty(by) ~+ # check/process inputs ------------------------------------------------------- |
|||
| 97 | -18x | +36 | +5x |
- tidyr::expand_grid(+ check_not_missing(data) |
| 98 | -18x | +37 | +5x |
- group1_level = as.character(by_levels) |> as.list(),+ check_not_missing(variables) |
| 99 | -18x | +38 | +5x |
- variable_level = as.character(variable_levels) |> as.list()+ check_not_missing(by) |
| 100 | +39 |
- ) |>+ |
||
| 101 | -18x | +|||
| 40 | +
- dplyr::mutate(group1 = .env$by, variable = .env$variable),+ # grab design object if from `survey` ---------------------------------------- |
|||
| 102 | -18x | +41 | +5x |
- .default =+ is_survey <- inherits(data, "survey.design") |
| 103 | -18x | +42 | +5x |
- dplyr::tibble(+ if (is_survey) {
|
| 104 | -18x | +43 | +1x |
- variable = .env$variable,+ design <- data |
| 105 | -18x | +44 | +1x |
- variable_level = as.character(variable_levels) |> as.list()+ data <- design$variables |
| 106 | +45 |
- )+ } |
||
| 107 | +46 |
- ) |>+ |
||
| 108 | -18x | +|||
| 47 | +
- dplyr::rowwise() |>+ |
|||
| 109 | -18x | +|||
| 48 | +
- dplyr::mutate(+ # continue check/process inputs ---------------------------------------------- |
|||
| 110 | -18x | +49 | +5x |
- lst_result =+ check_data_frame(data) |
| 111 | -18x | +50 | +5x |
- FUN(+ data <- dplyr::ungroup(data) |
| 112 | -18x | +51 | +5x |
- data =+ cards::process_selectors(data, by = {{ by }}, variables = {{ variables }})
|
| 113 | -18x | +52 | +5x |
- case_switch(+ check_scalar(by) |
| 114 | -18x | +|||
| 53 | +
- is_empty(.env$by) ~ data,+ # This check can be relaxed, but would require some changes to handle multi-row outputs |
|||
| 115 | -18x | +54 | +5x |
- .default = lst_data[[.data$group1_level]]+ check_n_levels(data[[by]], 2L, message = "The {.arg by} column must have {.val {length}} levels.")
|
| 116 | +55 |
- ),+ |
||
| 117 | -18x | +|||
| 56 | +
- variable = .data$variable,+ # if no variables selected, return empty tibble ------------------------------ |
|||
| 118 | -18x | +57 | +5x |
- variable_level = .data$variable_level,+ if (is_empty(variables)) {
|
| 119 | -18x | +|||
| 58 | +! |
- conf.level = .env$conf.level,+ return(dplyr::tibble()) |
||
| 120 | +59 |
- ...+ } |
||
| 121 | +60 |
- ) |>+ |
||
| 122 | -18x | +|||
| 61 | +
- list(),+ # build ARD ------------------------------------------------------------------ |
|||
| 123 | -18x | +62 | +5x |
- result =+ lapply( |
| 124 | -18x | +63 | +5x |
- .data$lst_result[["result"]] |>+ variables, |
| 125 | -18x | +64 | +5x |
- enframe("stat_name", "stat") |>
+ function(variable) {
|
| 126 | -18x | +65 | +6x |
- list(),+ .format_smd_results( |
| 127 | -18x | +66 | +6x |
- warning = .data$lst_result["warning"] |> unname(),+ by = by, |
| 128 | -18x | +67 | +6x |
- error = .data$lst_result["error"] |> unname(),+ variable = variable, |
| 129 | -18x | -
- context = "survey_categorical_ci"- |
- ||
| 130 | -+ | 68 | +6x |
- ) |>+ lst_tidy = |
| 131 | -18x | +69 | +6x |
- dplyr::select(-"lst_result") |>+ cards::eval_capture_conditions( |
| 132 | -18x | +70 | +6x |
- dplyr::ungroup() |>+ switch(as.character(is_survey), |
| 133 | -18x | +71 | +6x |
- tidyr::unnest("result") |>
+ "TRUE" = smd::smd(x = data[[variable]], g = data[[by]], w = stats::weights(design), na.rm = TRUE, std.error = std.error, ...), |
| 134 | -18x | +72 | +6x |
- dplyr::mutate(+ "FALSE" = smd::smd(x = data[[variable]], g = data[[by]], na.rm = TRUE, std.error = std.error, ...) |
| 135 | -18x | +|||
| 73 | +
- stat_label = .data$stat_name,+ ) |> |
|||
| 136 | -18x | +74 | +6x |
- fmt_fn = map(.data$stat, ~ case_switch(is.numeric(.x) ~ 2L, .default = as.character))+ dplyr::select(-any_of("term")) %>%
|
| 137 | +75 |
- ) |>+ # styler: off |
||
| 138 | -18x | +76 | +5x |
- cards::tidy_ard_column_order() %>%+ {if (isTRUE(std.error))
|
| 139 | -18x | +77 | +5x |
- structure(., class = c("card", class(.)))
+ dplyr::mutate( |
| 140 | +78 |
- }+ ., |
||
| 141 | -+ | |||
| 79 | +5x |
-
+ conf.low = .data$estimate + stats::qnorm((1 - .env$conf.level) / 2) * .data$std.error, |
||
| 142 | -+ | |||
| 80 | +5x |
-
+ conf.high = .data$estimate - stats::qnorm((1 - .env$conf.level) / 2) * .data$std.error, |
||
| 143 | -+ | |||
| 81 | +5x |
- .svyciprop_wrapper <- function(data, variable, variable_level, conf.level, method, df, ...) {
+ method = "Standardized Mean Difference" |
||
| 144 | -48x | +|||
| 82 | +
- lst_results <-+ ) |
|||
| 145 | -48x | +|||
| 83 | +
- cards::eval_capture_conditions(+ else |
|||
| 146 | -48x | +|||
| 84 | +! |
- survey::svyciprop(+ dplyr::mutate( |
||
| 147 | -48x | +|||
| 85 | +
- formula = inject(~ I(!!sym(variable) == !!variable_level)),+ ., |
|||
| 148 | -48x | +|||
| 86 | +! |
- design = data,+ method = "Standardized Mean Difference" |
||
| 149 | -48x | +|||
| 87 | +
- method = method,+ )} |
|||
| 150 | -48x | +|||
| 88 | +
- level = conf.level,+ # styler: on |
|||
| 151 | -48x | +|||
| 89 | +
- df = df,+ ), |
|||
| 152 | +90 |
... |
||
| 153 | +91 |
- ) %>%+ ) |
||
| 154 | -48x | +|||
| 92 | +
- {list(.[[1]], attr(., "ci"))} |> # styler: off
+ } |
|||
| 155 | -48x | +|||
| 93 | +
- unlist() |>+ ) |> |
|||
| 156 | -48x | +94 | +5x |
- set_names(c("estimate", "conf.low", "conf.high")) |>
+ dplyr::bind_rows() |
| 157 | -48x | +|||
| 95 | +
- as.list()+ } |
|||
| 158 | +96 |
- )+ |
||
| 159 | +97 | |||
| 160 | +98 |
- # add NULL results if error+ .format_smd_results <- function(by, variable, lst_tidy, ...) {
+ |
+ ||
| 99 | ++ |
+ # build ARD ------------------------------------------------------------------ |
||
| 161 | -48x | +100 | +6x |
- if (is_empty(lst_results[["result"]])) {
+ ret <- |
| 162 | -! | +|||
| 101 | +6x |
- lst_results[["result"]] <- rep_named(c("estimate", "conf.low", "conf.high"), list(NULL))
+ cards::tidy_as_ard( |
||
| 163 | -+ | |||
| 102 | +6x |
- }+ lst_tidy = lst_tidy, |
||
| 164 | -+ | |||
| 103 | +6x |
-
+ tidy_result_names = c("estimate", "std.error"),
|
||
| 165 | -+ | |||
| 104 | +6x |
- # add other args+ fun_args_to_record = c("gref"),
|
||
| 166 | -48x | +105 | +6x |
- lst_results[["result"]] <- lst_results[["result"]] |> append(list(method = method, conf.level = conf.level))+ formals = formals(smd::smd)[c("gref")],
|
| 167 | +106 |
-
+ # removing the `std.error` ARGUMENT (not the result) |
||
| 168 | -+ | |||
| 107 | +6x |
- # return list result+ passed_args = dots_list(...) |> utils::modifyList(list(std.error = NULL)), |
||
| 169 | -48x | +108 | +6x |
- lst_results+ lst_ard_columns = list(group1 = by, variable = variable, context = "smd_smd") |
| 170 | +109 |
- }+ ) |
||
| 171 | +110 | |||
| 172 | +111 |
-
+ # add the stat label --------------------------------------------------------- |
||
| 173 | -+ | |||
| 112 | +6x |
- case_switch <- function(..., .default = NULL) {
+ ret |> |
||
| 174 | -630x | +113 | +6x |
- dots <- dots_list(...)+ dplyr::left_join( |
| 175 | -+ | |||
| 114 | +6x |
-
+ dplyr::tribble( |
||
| 176 | -630x | +115 | +6x |
- for (f in dots) {
+ ~stat_name, ~stat_label, |
| 177 | -799x | +116 | +6x |
- if (isTRUE(eval(f_lhs(f), envir = attr(f, ".Environment")))) {
+ "estimate", "Standardized Mean Difference", |
| 178 | -503x | +117 | +6x |
- return(eval(f_rhs(f), envir = attr(f, ".Environment")))+ "std.error", "Standard Error", |
| 179 | -+ | |||
| 118 | +6x |
- }+ "gref", "Integer Reference Group Level" |
||
| 180 | +119 |
- }+ ),+ |
+ ||
| 120 | +6x | +
+ by = "stat_name" |
||
| 181 | +121 |
-
+ ) |> |
||
| 182 | -127x | +122 | +6x |
- return(.default)+ dplyr::mutate(stat_label = dplyr::coalesce(.data$stat_label, .data$stat_name)) |>+ |
+
| 123 | +6x | +
+ cards::tidy_ard_column_order() |
||
| 183 | +124 |
}@@ -38637,14 +38337,14 @@ cardx coverage - 95.32% |
| 1 |
- #' Regression ARD+ #' ARD Survey Chi-Square Test |
|||
| 3 |
- #' Function takes a regression model object and converts it to a ARD+ #' @description |
|||
| 4 |
- #' structure using the `broom.helpers` package.+ #' Analysis results data for survey Chi-Square test using [`survey::svychisq()`]. |
|||
| 5 |
- #'+ #' Only two-way comparisons are supported. |
|||
| 6 |
- #' @param x regression model object+ #' |
|||
| 7 |
- #' @param tidy_fun (`function`)\cr+ #' @param data (`survey.design`)\cr |
|||
| 8 |
- #' a tidier. Default is [`broom.helpers::tidy_with_broom_or_parameters`]+ #' a survey design object often created with the \{survey\} package
|
|||
| 9 |
- #' @param ... Arguments passed to [`broom.helpers::tidy_plus_plus()`]+ #' @param by ([`tidy-select`][dplyr::dplyr_tidy_select])\cr |
|||
| 10 |
- #'+ #' column name to compare by. |
|||
| 11 |
- #' @return data frame+ #' @param variables ([`tidy-select`][dplyr::dplyr_tidy_select])\cr |
|||
| 12 |
- #' @name ard_regression+ #' column names to be compared. Independent tests will be computed for |
|||
| 13 |
- #'+ #' each variable. |
|||
| 14 |
- #' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = "broom.helpers", reference_pkg = "cardx"))
+ #' @param statistic (`character`)\cr |
|||
| 15 |
- #' lm(AGE ~ ARM, data = cards::ADSL) |>+ #' statistic used to estimate Chisq p-value. |
|||
| 16 |
- #' ard_regression(add_estimate_to_reference_rows = TRUE)+ #' Default is the Rao-Scott second-order correction ("F"). See [`survey::svychisq`]
|
|||
| 17 |
- NULL+ #' for available statistics options. |
|||
| 18 |
-
+ #' @param ... arguments passed to [`survey::svychisq()`]. |
|||
| 19 |
- #' @rdname ard_regression+ #' |
|||
| 20 |
- #' @export+ #' @return ARD data frame |
|||
| 21 |
- ard_regression <- function(x, ...) {
+ #' @export |
|||
| 22 | -7x | +
- UseMethod("ard_regression")
+ #' |
||
| 23 |
- }+ #' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = c("survey", "broom"), reference_pkg = "cardx"))
|
|||
| 24 |
-
+ #' data(api, package = "survey") |
|||
| 25 |
- #' @rdname ard_regression+ #' dclus1 <- survey::svydesign(id = ~dnum, weights = ~pw, data = apiclus1, fpc = ~fpc) |
|||
| 26 |
- #' @export+ #' |
|||
| 27 |
- ard_regression.default <- function(x, tidy_fun = broom.helpers::tidy_with_broom_or_parameters, ...) {
+ #' ard_survey_svychisq(dclus1, variables = sch.wide, by = comp.imp, statistic = "F") |
|||
| 28 | -7x | ++ |
+ ard_survey_svychisq <- function(data, by, variables, statistic = "F", ...) {
+ |
+ |
| 29 | +2x |
set_cli_abort_call() |
||
| 29 | +30 | |||
| 30 | +31 |
# check installed packages --------------------------------------------------- |
||
| 31 | -7x | +32 | +2x |
- check_pkg_installed(pkg = "broom.helpers", reference_pkg = "cardx")+ check_pkg_installed(c("survey", "broom"), reference_pkg = "cardx")
|
| 32 | +33 | |||
| 33 | +34 |
- # check inputs ---------------------------------------------------------------+ # check/process inputs ------------------------------------------------------- |
||
| 34 | -7x | -
- check_not_missing(x)- |
- ||
| 35 | -+ | 2x |
-
+ check_not_missing(data) |
|
| 36 | -+ | 2x |
- # summarize model ------------------------------------------------------------+ check_not_missing(variables) |
|
| 37 | -7x | +2x |
- broom.helpers::tidy_plus_plus(+ check_not_missing(by) |
|
| 38 | -7x | +2x |
- model = x,+ check_class(data, cls = "survey.design") |
|
| 39 | -7x | +2x |
- tidy_fun = tidy_fun,+ cards::process_selectors(data[["variables"]], by = {{ by }}, variables = {{ variables }})
|
|
| 40 | -+ | 2x |
- ...+ check_scalar(by) |
|
| 41 |
- ) |>+ |
|||
| 42 | -7x | +
- dplyr::mutate(+ # if no variables selected, return empty tibble ------------------------------ |
||
| 43 | -7x | +2x |
- variable_level = dplyr::if_else(.data$var_type %in% "continuous", NA_character_, .data$label),+ if (is_empty(variables)) {
|
|
| 44 | -7x | +! |
- dplyr::across(-c("variable", "variable_level"), .fns = as.list)
+ return(dplyr::tibble()) |
|
| 45 |
- ) |>+ } |
|||
| 46 | -7x | +
- tidyr::pivot_longer(+ # build ARD ------------------------------------------------------------------ |
||
| 47 | -7x | +2x |
- cols = -c("variable", "variable_level"),
+ lapply( |
|
| 48 | -7x | +2x |
- names_to = "stat_name",+ variables, |
|
| 49 | -7x | +2x |
- values_to = "stat"+ function(variable) {
|
|
| 50 | -+ | 3x |
- ) |>+ cards::tidy_as_ard( |
|
| 51 | -7x | +3x |
- dplyr::filter(map_lgl(.data$stat, Negate(is.na))) |>+ lst_tidy = |
|
| 52 | -7x | +3x |
- dplyr::select(-(cards::all_ard_variables("levels") & dplyr::where(\(x) all(is.na(x))))) |>
+ cards::eval_capture_conditions( |
|
| 53 | -7x | +3x |
- dplyr::mutate(+ survey::svychisq(reformulate2(termlabels = c(variable, by)), design = data, statistic = statistic, ...) |> |
|
| 54 | -7x | +3x |
- fmt_fn =+ broom::tidy() |
|
| 55 | -7x | +
- lapply(+ ), |
||
| 56 | -7x | +3x |
- .data$stat,+ tidy_result_names = c("statistic", "p.value", "ndf", "ddf", "method"),
|
|
| 57 | -7x | +3x |
- function(x) {
+ passed_args = dots_list(...), |
|
| 58 | -185x | +3x |
- switch(is.integer(x), 0L) %||% # styler: off+ lst_ard_columns = list(group1 = by, variable = variable, context = "survey_svychisq") |
|
| 59 | -185x | +
- switch(is.numeric(x), 1L) # styler: off+ ) |> |
||
| 60 | -+ | 3x |
- }+ dplyr::mutate( |
|
| 61 | -+ | 3x |
- ),+ .after = "stat_name", |
|
| 62 | -7x | +3x |
- context = "regression",+ stat_label = |
|
| 63 | -7x | +3x |
- stat_label =+ dplyr::case_when( |
|
| 64 | -7x | +3x | +
+ .data$stat_name %in% "statistic" ~ "Statistic",+ |
+ |
| 65 | +3x | +
+ .data$stat_name %in% "p.value" ~ "p-value",+ |
+ ||
| 66 | +3x | +
+ .data$stat_name %in% "ndf" ~ "Nominator Degrees of Freedom",+ |
+ ||
| 67 | +3x | +
+ .data$stat_name %in% "ddf" ~ "Denominator Degrees of Freedom",+ |
+ ||
| 68 | +3x | +
+ TRUE ~ .data$stat_name,+ |
+ ||
| 69 | ++ |
+ )+ |
+ ||
| 70 | ++ |
+ )+ |
+ ||
| 71 | ++ |
+ }+ |
+ ||
| 72 | ++ |
+ ) |>+ |
+ ||
| 73 | +2x | +
+ dplyr::bind_rows()+ |
+ ||
| 74 | ++ |
+ }+ |
+
| 1 | ++ |
+ #' ARD Attributes+ |
+ ||
| 2 | ++ |
+ #'+ |
+ ||
| 3 | ++ |
+ #' @description+ |
+ ||
| 4 | ++ |
+ #' Add variable attributes to an ARD data frame.+ |
+ ||
| 5 | ++ |
+ #' - The `label` attribute will be added for all columns, and when no label+ |
+ ||
| 6 | ++ |
+ #' is specified and no label has been set for a column using the `label=` argument,+ |
+ ||
| 7 | ++ |
+ #' the column name will be placed in the label statistic.+ |
+ ||
| 8 | ++ |
+ #' - The `class` attribute will also be returned for all columns.+ |
+ ||
| 9 | ++ |
+ #' - Any other attribute returned by `attributes()` will also be added, e.g. factor levels.+ |
+ ||
| 10 | ++ |
+ #'+ |
+ ||
| 11 | ++ |
+ #' @rdname ard_attributes+ |
+ ||
| 12 | ++ |
+ #' @param data (`survey.design`)\cr+ |
+ ||
| 13 | ++ |
+ #' a design object often created with [`survey::svydesign()`].+ |
+ ||
| 14 | ++ |
+ #' @param variables ([`tidy-select`][dplyr::dplyr_tidy_select])\cr+ |
+ ||
| 15 | ++ |
+ #' variables to include+ |
+ ||
| 16 | +
- dplyr::case_when(+ #' @param label (named `list`)\cr |
|||
| 65 | -7x | +|||
| 17 | +
- .data$stat_name %in% "var_label" ~ "Label",+ #' named list of variable labels, e.g. `list(cyl = "No. Cylinders")`. |
|||
| 66 | -7x | +|||
| 18 | +
- .data$stat_name %in% "var_class" ~ "Class",+ #' Default is `NULL` |
|||
| 67 | -7x | +|||
| 19 | +
- .data$stat_name %in% "var_type" ~ "Type",+ #' @inheritParams rlang::args_dots_empty |
|||
| 68 | -7x | +|||
| 20 | +
- .data$stat_name %in% "var_nlevels" ~ "N Levels",+ #' |
|||
| 69 | -7x | +|||
| 21 | +
- .data$stat_name %in% "contrasts_type" ~ "Contrast Type",+ #' @return an ARD data frame of class 'card' |
|||
| 70 | -7x | +|||
| 22 | +
- .data$stat_name %in% "label" ~ "Level Label",+ #' @export |
|||
| 71 | -7x | +|||
| 23 | +
- .data$stat_name %in% "n_obs" ~ "N Obs.",+ #' |
|||
| 72 | -7x | +|||
| 24 | +
- .data$stat_name %in% "n_event" ~ "N Events",+ #' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = "survey", reference_pkg = "cardx"))
|
|||
| 73 | -7x | +|||
| 25 | +
- .data$stat_name %in% "exposure" ~ "Exposure Time",+ #' data(api, package = "survey") |
|||
| 74 | -7x | +|||
| 26 | +
- .data$stat_name %in% "estimate" ~ "Coefficient",+ #' dclus1 <- survey::svydesign(id = ~dnum, weights = ~pw, data = apiclus1, fpc = ~fpc) |
|||
| 75 | -7x | +|||
| 27 | +
- .data$stat_name %in% "std.error" ~ "Standard Error",+ #' |
|||
| 76 | -7x | +|||
| 28 | +
- .data$stat_name %in% "p.value" ~ "p-value",+ #' ard_attributes( |
|||
| 77 | -7x | +|||
| 29 | +
- .data$stat_name %in% "conf.low" ~ "CI Lower Bound",+ #' data = dclus1, |
|||
| 78 | -7x | +|||
| 30 | +
- .data$stat_name %in% "conf.high" ~ "CI Upper Bound",+ #' variables = c(sname, dname), |
|||
| 79 | -7x | +|||
| 31 | +
- TRUE ~ .data$stat_name+ #' label = list(sname = "School Name", dname = "District Name") |
|||
| 80 | +32 |
- )+ #' ) |
||
| 81 | +33 |
- ) |>+ ard_attributes.survey.design <- function(data, variables = everything(), label = NULL, ...) {
|
||
| 82 | -7x | +34 | +1x |
- cards::tidy_ard_column_order() %>%+ set_cli_abort_call()+ |
+
| 35 | ++ | + | ||
| 83 | -7x | +36 | +1x |
- {structure(., class = c("card", class(.)))} # styler: off
+ cards::ard_attributes(data = data[["variables"]], variables = {{ variables }}, label = label, ...)
|
| 84 | +37 |
}@@ -39231,14 +39126,14 @@ cardx coverage - 95.32% |
| 1 |
- #' ARD Attributes+ #' ARD Chi-squared Test |
|||
| 4 |
- #' Add variable attributes to an ARD data frame.+ #' Analysis results data for Pearson's Chi-squared Test. |
|||
| 5 |
- #' - The `label` attribute will be added for all columns, and when no label+ #' Calculated with `chisq.test(x = data[[variable]], y = data[[by]], ...)` |
|||
| 6 |
- #' is specified and no label has been set for a column using the `label=` argument,+ #' |
|||
| 7 |
- #' the column name will be placed in the label statistic.+ #' |
|||
| 8 |
- #' - The `class` attribute will also be returned for all columns.+ #' @param data (`data.frame`)\cr |
|||
| 9 |
- #' - Any other attribute returned by `attributes()` will also be added, e.g. factor levels.+ #' a data frame. |
|||
| 10 |
- #'+ #' @param by ([`tidy-select`][dplyr::dplyr_tidy_select])\cr |
|||
| 11 |
- #' @rdname ard_attributes+ #' column name to compare by. |
|||
| 12 |
- #' @param data (`survey.design`)\cr+ #' @param variables ([`tidy-select`][dplyr::dplyr_tidy_select])\cr |
|||
| 13 |
- #' a design object often created with [`survey::svydesign()`].+ #' column names to be compared. Independent tests will be computed for |
|||
| 14 |
- #' @param variables ([`tidy-select`][dplyr::dplyr_tidy_select])\cr+ #' each variable. |
|||
| 15 |
- #' variables to include+ #' @param ... additional arguments passed to `chisq.test(...)` |
|||
| 16 |
- #' @param label (named `list`)\cr+ #' |
|||
| 17 |
- #' named list of variable labels, e.g. `list(cyl = "No. Cylinders")`.+ #' @return ARD data frame |
|||
| 18 |
- #' Default is `NULL`+ #' @export |
|||
| 19 |
- #' @inheritParams rlang::args_dots_empty+ #' |
|||
| 20 |
- #'+ #' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = "broom", reference_pkg = "cardx"))
|
|||
| 21 |
- #' @return an ARD data frame of class 'card'+ #' cards::ADSL |> |
|||
| 22 |
- #' @export+ #' ard_stats_chisq_test(by = "ARM", variables = "AGEGR1") |
|||
| 23 |
- #'+ ard_stats_chisq_test <- function(data, by, variables, ...) {
|
|||
| 24 | -+ | 5x |
- #' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = "survey", reference_pkg = "cardx"))
+ set_cli_abort_call() |
|
| 25 |
- #' data(api, package = "survey")+ |
|||
| 26 |
- #' dclus1 <- survey::svydesign(id = ~dnum, weights = ~pw, data = apiclus1, fpc = ~fpc)+ # check installed packages --------------------------------------------------- |
|||
| 27 | -+ | 5x |
- #'+ check_pkg_installed("broom", reference_pkg = "cardx")
|
|
| 28 |
- #' ard_attributes(+ |
|||
| 29 |
- #' data = dclus1,+ # check/process inputs ------------------------------------------------------- |
|||
| 30 | +5x | +
+ check_not_missing(data)+ |
+ ||
| 31 | +5x | +
+ check_not_missing(variables)+ |
+ ||
| 32 | +5x | +
+ check_not_missing(by)+ |
+ ||
| 33 | +5x | +
+ check_data_frame(data)+ |
+ ||
| 34 | +5x | +
+ cards::process_selectors(data, by = {{ by }}, variables = {{ variables }})
+ |
+ ||
| 35 | +5x | +
+ check_scalar(by)+ |
+ ||
| 36 |
- #' variables = c(sname, dname),+ |
|||
| 31 | +37 |
- #' label = list(sname = "School Name", dname = "District Name")+ # if no variables selected, return empty tibble ------------------------------+ |
+ ||
| 38 | +5x | +
+ if (is_empty(variables)) {
+ |
+ ||
| 39 | +! | +
+ return(dplyr::tibble()) |
||
| 32 | +40 |
- #' )+ } |
||
| 33 | +41 |
- ard_attributes.survey.design <- function(data, variables = everything(), label = NULL, ...) {
+ # build ARD ------------------------------------------------------------------ |
||
| 34 | -1x | +42 | +5x |
- set_cli_abort_call()+ lapply(+ |
+
| 43 | +5x | +
+ variables,+ |
+ ||
| 44 | +5x | +
+ function(variable) {
+ |
+ ||
| 45 | +6x | +
+ cards::tidy_as_ard(+ |
+ ||
| 46 | +6x | +
+ lst_tidy =+ |
+ ||
| 47 | +6x | +
+ cards::eval_capture_conditions(+ |
+ ||
| 48 | +6x | +
+ stats::chisq.test(x = data[[variable]], y = data[[by]], ...) |>+ |
+ ||
| 49 | +6x | +
+ broom::tidy() |
||
| 35 | +50 |
-
+ ), |
||
| 36 | -1x | +51 | +6x |
- cards::ard_attributes(data = data[["variables"]], variables = {{ variables }}, label = label, ...)
+ tidy_result_names = c("statistic", "p.value", "parameter", "method"),
+ |
+
| 52 | +6x | +
+ fun_args_to_record =+ |
+ ||
| 53 | +6x | +
+ c("correct", "p", "rescale.p", "simulate.p.value", "B"),
+ |
+ ||
| 54 | +6x | +
+ formals = formals(stats::chisq.test),+ |
+ ||
| 55 | +6x | +
+ passed_args = dots_list(...),+ |
+ ||
| 56 | +6x | +
+ lst_ard_columns = list(group1 = by, variable = variable, context = "stats_chisq_test") |
||
| 37 | +57 | ++ |
+ ) |>+ |
+ |
| 58 | +6x | +
+ dplyr::mutate(+ |
+ ||
| 59 | +6x | +
+ .after = "stat_name",+ |
+ ||
| 60 | +6x | +
+ stat_label =+ |
+ ||
| 61 | +6x | +
+ dplyr::case_when(+ |
+ ||
| 62 | +6x | +
+ .data$stat_name %in% "statistic" ~ "X-squared Statistic",+ |
+ ||
| 63 | +6x | +
+ .data$stat_name %in% "p.value" ~ "p-value",+ |
+ ||
| 64 | +6x | +
+ .data$stat_name %in% "parameter" ~ "Degrees of Freedom",+ |
+ ||
| 65 | +6x | +
+ TRUE ~ .data$stat_name,+ |
+ ||
| 66 | ++ |
+ )+ |
+ ||
| 67 | ++ |
+ )+ |
+ ||
| 68 | ++ |
+ }+ |
+ ||
| 69 | ++ |
+ ) |>+ |
+ ||
| 70 | +5x | +
+ dplyr::bind_rows()+ |
+ ||
| 71 |
}@@ -39496,14 +39629,14 @@ cardx coverage - 95.32% |
| 1 |
- #' ARD One-way Test+ #' ARD ANOVA |
||
| 4 |
- #' Analysis results data for Testing Equal Means in a One-Way Layout.+ #' Analysis results data for Analysis of Variance. |
||
| 5 |
- #' calculated with `oneway.test()`+ #' Calculated with `stats::aov()` |
||
| 7 |
- #' @inheritParams stats::oneway.test+ #' @inheritParams stats::aov |
||
| 8 |
- #' @param ... additional arguments passed to `oneway.test(...)`+ #' @param ... arguments passed to `stats::aov(...)` |
||
| 13 |
- #' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = "broom", reference_pkg = "cardx"))
+ #' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = c("broom.helpers", "parameters"), reference_pkg = "cardx"))
|
||
| 14 |
- #' ard_stats_oneway_test(AGE ~ ARM, data = cards::ADSL)+ #' ard_stats_aov(AGE ~ ARM, data = cards::ADSL) |
||
| 15 |
- ard_stats_oneway_test <- function(formula, data, ...) {
+ ard_stats_aov <- function(formula, data, ...) {
|
||
| 19 | 2x |
- check_pkg_installed(c("broom"), reference_pkg = "cardx")
+ check_pkg_installed(c("broom.helpers", "parameters"), reference_pkg = "cardx")
|
|
| 28 | 2x |
- df_results <-+ aov <- |
|
| 29 | 2x |
- cards::tidy_as_ard(+ cards::eval_capture_conditions( |
|
| 30 | 2x |
- lst_tidy =+ stats::aov(formula, data, ...) |
|
| 31 | -2x | +
- cards::eval_capture_conditions(+ ) |
|
| 32 | 2x |
- stats::oneway.test(formula, data = data, ...) |>+ aov[["result"]] |> |
|
| 33 | 2x |
- broom::tidy()+ broom.helpers::tidy_parameters() |> # using broom.helpers, because it handle non-syntactic names |
|
| 34 | -+ | 2x |
- ),+ dplyr::filter(!(dplyr::row_number() == dplyr::n() & .data$term %in% "Residuals")) |> # removing Residual rows |
| 35 | 2x |
- tidy_result_names = c("num.df", "den.df", "statistic", "p.value", "method"),
+ dplyr::rename(variable = "term") |> |
|
| 36 | 2x |
- fun_args_to_record =+ tidyr::pivot_longer( |
|
| 37 | 2x |
- c("var.equal"),
+ cols = -"variable", |
|
| 38 | 2x |
- formals = formals(stats::oneway.test),+ names_to = "stat_name", |
|
| 39 | 2x |
- passed_args = dots_list(...),+ values_to = "stat" |
|
| 40 | -2x | +
- lst_ard_columns = list(context = "stats_oneway_test")+ ) |> |
|
| 41 | -+ | 2x |
- ) |>+ dplyr::mutate( |
| 42 | 2x |
- dplyr::mutate(+ stat = as.list(.data$stat), |
|
| 43 | 2x |
- .after = "stat_name",+ stat_label = |
|
| 44 | 2x |
- stat_label =+ dplyr::case_when( |
|
| 45 | 2x |
- dplyr::case_when(+ .data$stat_name %in% "statistic" ~ "Statistic", |
|
| 46 | 2x |
- .data$stat_name %in% "num.df" ~ "Degrees of Freedom",+ .data$stat_name %in% "df" ~ "Degrees of Freedom", |
|
| 47 | 2x |
- .data$stat_name %in% "den.df" ~ "Denominator Degrees of Freedom",+ .data$stat_name %in% "p.value" ~ "p-value", |
|
| 48 | 2x |
- .data$stat_name %in% "statistic" ~ "F Statistic",+ .data$stat_name %in% "sumsq" ~ "Sum of Squares", |
|
| 49 | 2x |
- .data$stat_name %in% "p.value" ~ "p-value",+ .data$stat_name %in% "meansq" ~ "Mean of Sum of Squares", |
|
| 50 | 2x |
- .data$stat_name %in% "method" ~ "Method",+ TRUE ~ .data$stat_name |
|
| 51 | -2x | +
- TRUE ~ .data$stat_name,+ ), |
|
| 52 | -+ | 2x |
- )+ context = "stats_aov", |
| 53 | -+ | 2x |
- )+ warning = aov["warning"], |
| 54 | -+ | 2x |
-
+ error = aov["error"] |
| 55 |
- # add variable/groups to results and return result+ ) |> |
||
| 56 | 2x |
- df_results |>+ cards::tidy_ard_column_order() %>% |
|
| 57 | 2x |
- dplyr::bind_cols(- |
- |
| 58 | -2x | -
- dplyr::tibble(!!!map(as.list(attr(stats::terms(formula), "variables"))[-1], as_label)) %>%- |
- |
| 59 | -2x | -
- set_names(., c("variable", paste0("group", seq_len(length(.) - 1L))))
- |
- |
| 60 | -- |
- ) |>- |
- |
| 61 | -2x | -
- cards::tidy_ard_column_order()+ {structure(., class = c("card", class(.)))} # styler: off
|
|
| 62 | +58 |
}@@ -39936,14 +40041,14 @@ cardx coverage - 95.32% |
| 1 |
- #' ARD Wald Test+ #' ARD Survival Differences |
||
| 3 |
- #' @description+ #' Calculate differences in the Kaplan-Meier estimator of survival using the |
||
| 4 |
- #' Function takes a regression model object and calculates Wald+ #' results from [`survival::survfit()`]. |
||
| 5 |
- #' statistical test using [`aod::wald.test()`].+ #' |
||
| 6 |
- #'+ #' @param x (`survift`)\cr |
||
| 7 |
- #' @param x regression model object+ #' object of class `'survfit'` typically created with [`survival::survfit()`] |
||
| 8 |
- #' @param ... arguments passed to `aod::wald.test(...)`+ #' @param conf.level (scalar `numeric`)\cr |
||
| 9 |
- #' @inheritParams ard_regression+ #' confidence level for confidence interval. Default is `0.95`. |
||
| 10 |
- #'+ #' @inheritParams ard_survival_survfit |
||
| 11 |
- #' @return data frame+ #' |
||
| 12 |
- #' @export+ #' @return an ARD data frame of class 'card' |
||
| 13 |
- #'+ #' @export |
||
| 14 |
- #' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = "aod", reference_pkg = "cardx"))
+ #' |
||
| 15 |
- #' lm(AGE ~ ARM, data = cards::ADSL) |>+ #' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = c("survival", "ggsurvfit"), reference_pkg = "cardx"))
|
||
| 16 |
- #' ard_aod_wald_test()+ #' library(ggsurvfit) |
||
| 17 |
- ard_aod_wald_test <- function(x, tidy_fun = broom.helpers::tidy_with_broom_or_parameters, ...) {
+ #' library(survival) |
||
| 18 | -1x | +
- set_cli_abort_call()+ #' |
|
| 19 | -1x | +
- check_pkg_installed("broom.helpers", reference_pkg = "cardx")
+ #' survfit(Surv_CNSR() ~ TRTA, data = cards::ADTTE) |> |
|
| 20 |
-
+ #' ard_survival_survfit_diff(times = c(25, 50)) |
||
| 21 |
- # check installed packages ---------------------------------------------------+ ard_survival_survfit_diff <- function(x, times, conf.level = 0.95) {
|
||
| 22 | -1x | +2x |
- check_pkg_installed("aod", reference_pkg = "cardx")
+ set_cli_abort_call() |
| 24 |
- # check inputs ---------------------------------------------------------------+ # check installed packages --------------------------------------------------- |
||
| 25 | -1x | +2x |
- check_not_missing(x)+ check_pkg_installed(c("survival", "broom"), reference_pkg = "cardx")
|
| 26 | -+ | 2x |
-
+ check_not_missing(x) |
| 27 | -+ | 2x |
- # run regression() -----------------------------------------------------------+ check_not_missing(times) |
| 28 | -1x | +2x |
- reg_model <- cards::eval_capture_conditions(+ check_class(x, "survfit") |
| 29 | -1x | +
- ard_regression_basic(x, tidy_fun = tidy_fun, intercept = TRUE, stats_to_remove = c(+ |
|
| 30 | -1x | +2x |
- "var_type",+ if (inherits(x, c("survfitms", "survfitcox"))) {
|
| 31 | -1x | +! |
- "var_label",+ cli::cli_abort( |
| 32 | -1x | +! |
- "var_class", "label",+ "Argument {.arg x} cannot be class {.cls {c('survfitms', 'survfitcox')}}.",
|
| 33 | -1x | +! |
- "contrasts_type", "contrasts", "var_nlevels", "std.error",+ call = get_cli_abort_call() |
| 34 | -1x | +
- "conf.low", "conf.high", "statistic", "p.value", "estimate"+ ) |
|
| 35 |
- ))+ } |
||
| 36 | -+ | 2x |
- )+ check_scalar_range(conf.level, range = c(0, 1)) |
| 37 | -+ | 2x |
-
+ check_length( |
| 38 | -1x | +2x |
- if (!is.null(reg_model[["error"]])) {
+ as.list(x$call)[["formula"]] |> stats::as.formula() |> stats::terms() |> attr("term.labels"),
|
| 39 | -! | +2x |
- cli::cli_abort(+ length = 1L, |
| 40 | -! | +2x |
- c("Unable to identify underlying variable names in regression model.",
+ message = "The {.cls survfit} object passed in argument {.arg x} must be stratified by a single variable."
|
| 41 | -! | +
- i = "Is this model type supported by {.fun broom.helpers::tidy_plus_plus}, which is the function used to identify variable names?"
+ ) |
|
| 42 | -+ | 1x |
- ),+ if (length(x$strata) < 2) {
|
| 43 | ! |
- call = get_cli_abort_call()+ cli::cli_abort( |
|
| 44 | -+ | ! |
- )+ "The {.cls survfit} object's stratifying variable must have 2 or more levels.",
|
| 45 | -+ | ! |
- }+ call = get_cli_abort_call() |
| 46 | -1x | +
- aod <-+ ) |
|
| 47 | -1x | +
- reg_model[["result"]] %>%+ } |
|
| 48 | -1x | +
- dplyr::select(c(+ |
|
| 49 | -1x | +
- variable = "variable",+ # calculate the survival at the specified times |
|
| 50 | 1x |
- model_terms = "stat"+ ard_survival_survfit <- |
|
| 51 | -+ | 1x |
- )) %>%+ ard_survival_survfit(x = x, times = times) |> |
| 52 | 1x |
- dplyr::mutate(term_id = dplyr::row_number()) %>%+ dplyr::filter(.data$stat_name %in% c("estimate", "std.error")) |>
|
|
| 53 | 1x |
- tidyr::nest(data = -"variable") %>%+ dplyr::select(-c("stat_label", "context", "fmt_fn"))
|
|
| 54 | -1x | +
- dplyr::rowwise() %>%+ |
|
| 55 | -1x | +
- dplyr::mutate(+ # transform the survival ARD into a cards object with the survival difference |
|
| 56 | 1x |
- model_terms = unlist(.data$data[["model_terms"]]) %>% list(),+ card <- |
|
| 57 | 1x |
- model_terms_id = rlang::set_names(.data$data[["term_id"]]) %>% list()+ ard_survival_survfit %>% |
|
| 58 | -+ | 1x |
- )+ {dplyr::left_join( # styler: off
|
| 59 |
- # run wald.test() -----------------------------------------------------------+ # remove the first group from the data frame (this is our reference group) |
||
| 60 | 1x |
- wald_test <-+ dplyr::filter(., .by = cards::all_ard_groups(), dplyr::cur_group_id() > 1L) |> |
|
| 61 | 1x |
- cards::eval_capture_conditions(lapply(seq_len(length(aod$model_terms_id)), function(terms_id) {
+ dplyr::rename(stat1 = "stat"), |
|
| 62 | -2x | +
- aod::wald.test(+ # merge the reference group data |
|
| 63 | -2x | +1x |
- Sigma = stats::vcov(x),+ dplyr::filter(., .by = cards::all_ard_groups(), dplyr::cur_group_id() == 1L) |> |
| 64 | -2x | +1x |
- b = stats::coef(x), Terms = aod$model_terms_id[[terms_id]]+ dplyr::select(stat0 = "stat", everything(), -c("group1_level", "error", "warning")),
|
| 65 | -+ | 1x |
- )+ by = c("group1", "variable", "variable_level", "stat_name")
|
| 66 | -+ | 1x |
- }))+ )} |> # styler: off |
| 67 |
-
+ # reshape to put the stats that need to be combined on the same row |
||
| 68 | -+ | 1x |
-
+ tidyr::pivot_wider( |
| 69 | 1x |
- df_list <- do.call(rbind, lapply(wald_test$result, .extract_wald_results))+ id_cols = c("group1", "group1_level", "variable", "variable_level"),
|
|
| 70 | -+ | 1x |
-
+ names_from = "stat_name", |
| 71 | 1x |
- cbind(aod$variable, df_list) %>%+ values_from = c("stat0", "stat1"),
|
|
| 72 | 1x |
- tidyr::pivot_longer(+ values_fn = unlist |
|
| 73 | -1x | +
- cols = !"aod$variable",+ ) |> |
|
| 74 | -1x | +
- names_to = "stat_name",+ # calcualte the primary statistics to return |
|
| 75 | 1x |
- values_to = "stat"+ dplyr::mutate( |
|
| 76 |
- ) %>%+ # reference level |
||
| 77 | 1x |
- dplyr::rename(+ reference_level = ard_survival_survfit[["group1_level"]][1], |
|
| 78 | -1x | +
- "variable" = "aod$variable"+ # short description of method |
|
| 79 | -+ | 1x |
- ) |>+ method = "Survival Difference (Z-test)", |
| 80 | -1x | +
- dplyr::mutate(+ # survival difference |
|
| 81 | 1x |
- stat = as.list(.data$stat),+ estimate = .data$stat0_estimate - .data$stat1_estimate, |
|
| 82 | -1x | +
- stat_label =+ # survival difference standard error |
|
| 83 | 1x |
- dplyr::case_when(+ std.error = sqrt(.data$stat0_std.error^2 + .data$stat1_std.error^2), |
|
| 84 | -1x | +
- .data$stat_name %in% "statistic" ~ "Statistic",+ # Z test statistic |
|
| 85 | 1x |
- .data$stat_name %in% "df" ~ "Degrees of Freedom",+ statistic = .data$estimate / .data$std.error, |
|
| 86 | -1x | +
- .data$stat_name %in% "p.value" ~ "p-value",+ # confidence limits of the survival difference |
|
| 87 | 1x |
- TRUE ~ .data$stat_name+ conf.low = .data$estimate - .data$std.error * stats::qnorm(1 - (1 - .env$conf.level) / 2), |
|
| 88 | -+ | 1x |
- ),+ conf.high = .data$estimate + .data$std.error * stats::qnorm(1 - (1 - .env$conf.level) / 2), |
| 89 | -1x | +
- fmt_fn =+ # p-value for test where H0: no difference |
|
| 90 | 1x |
- map(+ p.value = 2 * (1 - stats::pnorm(abs(.data$statistic))), |
|
| 91 | 1x |
- .data$stat,+ across(c("reference_level", "estimate", "std.error", "statistic", "conf.low", "conf.high", "p.value", "method"), as.list)
|
|
| 92 | -1x | +
- function(.x) {
+ ) |> |
|
| 93 |
- # styler: off+ # reshape into the cards structure |
||
| 94 | -! | +1x |
- if (is.integer(.x)) return(0L)+ dplyr::select(-starts_with("stat0_"), -starts_with("stat1_")) |>
|
| 95 | -6x | +1x |
- if (is.numeric(.x)) return(1L)+ tidyr::pivot_longer( |
| 96 | -+ | 1x |
- # styler: on+ cols = -c(cards::all_ard_groups(), cards::all_ard_variables()), |
| 97 | -! | +1x |
- NULL+ names_to = "stat_name", |
| 98 | -+ | 1x |
- }+ values_to = "stat" |
| 99 |
- ),+ ) |
||
| 100 | -1x | +
- context = "aod_wald_test",+ |
|
| 101 | -1x | +
- warning = wald_test["warning"],+ # final prepping of the cards object ----------------------------------------- |
|
| 102 | 1x |
- error = wald_test["error"]+ card |> |
|
| 103 | -+ | 1x |
- ) |>+ dplyr::mutate( |
| 104 | 1x |
- cards::tidy_ard_column_order() %>%+ warning = ard_survival_survfit[["warning"]][1], |
|
| 105 | 1x |
- {structure(., class = c("card", class(.)))} # styler: off
+ error = ard_survival_survfit[["error"]][1], |
|
| 106 | -+ | 1x |
- }+ fmt_fn = list(1L), |
| 107 | -+ | 1x |
-
+ stat_label = |
| 108 | -+ | 1x |
- #' Extract data from wald.test object+ dplyr::case_when( |
| 109 | -+ | 1x |
- #'+ .data$stat_name %in% "estimate" ~ "Survival Difference", |
| 110 | -+ | 1x |
- #' @param wald_test (`data.frame`)\cr wald test object object from `aod::wald.test()`+ .data$stat_name %in% "std.error" ~ "Survival Difference Standard Error", |
| 111 | -+ | 1x |
- #'+ .data$stat_name %in% "conf.low" ~ "CI Lower Bound", |
| 112 | -+ | 1x |
- #' @return a data frame containing the wald test results.+ .data$stat_name %in% "conf.high" ~ "CI Upper Bound", |
| 113 | -+ | 1x |
- #' @keywords internal+ .data$stat_name %in% "statistic" ~ "z statistic", |
| 114 | -+ | 1x |
- .extract_wald_results <- function(wald_test) {
+ .data$stat_name %in% "p.value" ~ "p-value", |
| 115 | -2x | +1x |
- df <- wald_test$result$chi2[("df")]
+ .default = .data$stat_name |
| 116 | -2x | +
- statistic <- wald_test$result$chi2[("chi2")]
+ ), |
|
| 117 | -2x | +1x |
- p.value <- wald_test$result$chi2[("P")]
+ context = "survival_survfit_diff", |
| 118 | -2x | +
- data.frame(df, statistic, p.value)+ ) |> |
|
| 119 | +1x | +
+ cards::tidy_ard_column_order() %>%+ |
+ |
| 120 | +1x | +
+ structure(., class = c("card", class(.)))
+ |
+ |
| 121 |
}@@ -40775,14 +40894,14 @@ cardx coverage - 95.32% |
| 1 |
- #' ARD Missing Survey Statistics+ #' ARD Wald Test |
|||
| 3 |
- #' Compute Analysis Results Data (ARD) for statistics related to data missingness for survey objects+ #' @description |
|||
| 4 |
- #'+ #' Function takes a regression model object and calculates Wald |
|||
| 5 |
- #' @inheritParams ard_categorical.survey.design+ #' statistical test using [`aod::wald.test()`]. |
|||
| 7 |
- #' @return an ARD data frame of class 'card'+ #' @param x regression model object |
|||
| 8 |
- #' @export+ #' @param ... arguments passed to `aod::wald.test(...)` |
|||
| 9 |
- #'+ #' @inheritParams ard_regression |
|||
| 10 |
- #' @examplesIf cardx:::is_pkg_installed("survey", reference_pkg = "cardx")
+ #' |
|||
| 11 |
- #' svy_titanic <- survey::svydesign(~1, data = as.data.frame(Titanic), weights = ~Freq)+ #' @return data frame |
|||
| 12 |
- #'+ #' @export |
|||
| 13 |
- #' ard_missing(svy_titanic, variables = c(Class, Age), by = Survived)+ #' |
|||
| 14 |
- ard_missing.survey.design <- function(data,+ #' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = "aod", reference_pkg = "cardx"))
|
|||
| 15 |
- variables,+ #' lm(AGE ~ ARM, data = cards::ADSL) |> |
|||
| 16 |
- by = NULL,+ #' ard_aod_wald_test() |
|||
| 17 |
- statistic =+ ard_aod_wald_test <- function(x, tidy_fun = broom.helpers::tidy_with_broom_or_parameters, ...) {
|
|||
| 18 | -+ | 1x |
- everything() ~ c(+ set_cli_abort_call() |
|
| 19 | -+ | 1x |
- "N_obs", "N_miss", "N_nonmiss", "p_miss", "p_nonmiss",+ check_pkg_installed("broom.helpers", reference_pkg = "cardx")
|
|
| 20 |
- "N_obs_unweighted", "N_miss_unweighted", "N_nonmiss_unweighted",+ |
|||
| 21 |
- "p_miss_unweighted", "p_nonmiss_unweighted"+ # check installed packages --------------------------------------------------- |
|||
| 22 | -+ | 1x |
- ),+ check_pkg_installed("aod", reference_pkg = "cardx")
|
|
| 23 |
- fmt_fn = NULL,+ |
|||
| 24 |
- stat_label =+ # check inputs --------------------------------------------------------------- |
|||
| 25 | -+ | 1x |
- everything() ~ list(+ check_not_missing(x) |
|
| 26 |
- N_obs = "Total N",+ |
|||
| 27 |
- N_miss = "N Missing",+ # run regression() ----------------------------------------------------------- |
|||
| 28 | -+ | 1x |
- N_nonmiss = "N not Missing",+ reg_model <- cards::eval_capture_conditions( |
|
| 29 | -+ | 1x |
- p_miss = "% Missing",+ ard_regression_basic(x, tidy_fun = tidy_fun, intercept = TRUE, stats_to_remove = c( |
|
| 30 | -+ | 1x |
- p_nonmiss = "% not Missing",+ "var_type", |
|
| 31 | -+ | 1x |
- N_obs_unweighted = "Total N (unweighted)",+ "var_label", |
|
| 32 | -+ | 1x |
- N_miss_unweighted = "N Missing (unweighted)",+ "var_class", "label", |
|
| 33 | -+ | 1x |
- N_nonmiss_unweighted = "N not Missing (unweighted)",+ "contrasts_type", "contrasts", "var_nlevels", "std.error", |
|
| 34 | -+ | 1x |
- p_miss_unweighted = "% Missing (unweighted)",+ "conf.low", "conf.high", "statistic", "p.value", "estimate" |
|
| 35 |
- p_nonmiss_unweighted = "% not Missing (unweighted)"+ )) |
|||
| 36 |
- ),+ ) |
|||
| 37 |
- ...) {
+
|
|||
| 38 | -4x | +1x |
- set_cli_abort_call()+ if (!is.null(reg_model[["error"]])) {
|
|
| 39 | -4x | +! |
- check_dots_empty()+ cli::cli_abort( |
|
| 40 | -4x | +! |
- check_pkg_installed(pkg = "survey", reference_pkg = "cardx")+ c("Unable to identify underlying variable names in regression model.",
|
|
| 41 | -+ | ! |
-
+ i = "Is this model type supported by {.fun broom.helpers::tidy_plus_plus}, which is the function used to identify variable names?"
|
|
| 42 |
- # process inputs -------------------------------------------------------------+ ), |
|||
| 43 | -4x | +! |
- check_not_missing(variables)+ call = get_cli_abort_call() |
|
| 44 | -4x | +
- cards::process_selectors(+ ) |
||
| 45 | -4x | +
- data = data$variables,+ } |
||
| 46 | -4x | +1x |
- variables = {{ variables }},
+ aod <- |
|
| 47 | -4x | +1x |
- by = {{ by }}
+ reg_model[["result"]] %>% |
|
| 48 | -+ | 1x |
- )+ dplyr::select(c( |
|
| 49 | -+ | 1x |
-
+ variable = "variable", |
|
| 50 | -+ | 1x |
- # convert all variables to T/F whether it's missing --------------------------+ model_terms = "stat" |
|
| 51 | -4x | +
- data$variables <- data$variables |>+ )) %>% |
||
| 52 | -4x | +1x |
- dplyr::mutate(across(all_of(variables), Negate(is.na)))+ dplyr::mutate(term_id = dplyr::row_number()) %>% |
|
| 53 | -+ | 1x |
-
+ tidyr::nest(data = -"variable") %>% |
|
| 54 | -4x | +1x |
- cards::process_formula_selectors(+ dplyr::rowwise() %>% |
|
| 55 | -4x | +1x |
- data$variables[variables],+ dplyr::mutate( |
|
| 56 | -4x | +1x |
- statistic = statistic,+ model_terms = unlist(.data$data[["model_terms"]]) %>% list(), |
|
| 57 | -4x | +1x |
- fmt_fn = fmt_fn,+ model_terms_id = rlang::set_names(.data$data[["term_id"]]) %>% list() |
|
| 58 | -4x | +
- stat_label = stat_label+ ) |
||
| 59 |
- )+ # run wald.test() ----------------------------------------------------------- |
|||
| 60 | -4x | +1x |
- cards::fill_formula_selectors(+ wald_test <- |
|
| 61 | -4x | +1x |
- data$variables[variables],+ cards::eval_capture_conditions(lapply(seq_len(length(aod$model_terms_id)), function(terms_id) {
|
|
| 62 | -4x | +2x |
- statistic = formals(asNamespace("cardx")[["ard_missing.survey.design"]])[["statistic"]] |> eval()
+ aod::wald.test( |
|
| 63 | -+ | 2x |
- )+ Sigma = stats::vcov(x), |
|
| 64 | -4x | +2x |
- cards::fill_formula_selectors(+ b = stats::coef(x), Terms = aod$model_terms_id[[terms_id]] |
|
| 65 | -4x | +
- data$variables[variables],+ ) |
||
| 66 | -4x | +
- stat_label = formals(asNamespace("cardx")[["ard_missing.survey.design"]])[["stat_label"]] |> eval()
+ })) |
||
| 67 |
- )+ |
|||
| 69 | -4x | +1x |
- stats_available <- c(+ df_list <- do.call(rbind, lapply(wald_test$result, .extract_wald_results)) |
|
| 70 | -4x | +
- "N_obs", "N_miss", "N_nonmiss", "p_miss", "p_nonmiss",+ |
||
| 71 | -4x | +1x |
- "N_obs_unweighted", "N_miss_unweighted", "N_nonmiss_unweighted",+ cbind(aod$variable, df_list) %>% |
|
| 72 | -4x | +1x |
- "p_miss_unweighted", "p_nonmiss_unweighted"+ tidyr::pivot_longer( |
|
| 73 | -+ | 1x |
- )+ cols = !"aod$variable", |
|
| 74 | -4x | +1x |
- cards::check_list_elements(+ names_to = "stat_name", |
|
| 75 | -4x | +1x |
- x = statistic,+ values_to = "stat" |
|
| 76 | -4x | +
- predicate = \(x) is.character(x) && all(x %in% stats_available),+ ) %>% |
||
| 77 | -4x | +1x |
- error_msg = "Elements passed in the {.arg statistic} argument must be one or more of {.val {stats_available}}"
+ dplyr::rename( |
|
| 78 | -+ | 1x |
- )+ "variable" = "aod$variable" |
|
| 79 |
-
+ ) |> |
|||
| 80 | -+ | 1x |
- # calculate results ----------------------------------------------------------+ dplyr::mutate( |
|
| 81 | -4x | +1x |
- result <-+ stat = as.list(.data$stat), |
|
| 82 | -4x | +1x |
- ard_categorical(+ stat_label = |
|
| 83 | -4x | +1x |
- data = data,+ dplyr::case_when( |
|
| 84 | -4x | +1x |
- variables = all_of(variables),+ .data$stat_name %in% "statistic" ~ "Statistic", |
|
| 85 | -4x | +1x |
- by = any_of(by),+ .data$stat_name %in% "df" ~ "Degrees of Freedom", |
|
| 86 | -4x | +1x |
- statistic = everything() ~ c("n", "N", "p", "n_unweighted", "N_unweighted", "p_unweighted")
+ .data$stat_name %in% "p.value" ~ "p-value", |
|
| 87 | -+ | 1x |
- )+ TRUE ~ .data$stat_name |
|
| 88 |
-
+ ), |
|||
| 89 | -+ | 1x |
- # rename the stats for missingness -------------------------------------------+ fmt_fn = |
|
| 90 | -4x | +1x |
- result <- result |>+ map( |
|
| 91 | -4x | +1x |
- dplyr::mutate(+ .data$stat, |
|
| 92 | -4x | +1x |
- stat_name =+ function(.x) {
|
|
| 93 | -4x | +
- dplyr::case_when(+ # styler: off |
||
| 94 | -4x | +! |
- .data$stat_name %in% "N" ~ "N_obs",+ if (is.integer(.x)) return(0L) |
|
| 95 | -4x | +6x |
- .data$stat_name %in% "n" & .data$variable_level %in% FALSE ~ "N_miss",+ if (is.numeric(.x)) return(1L) |
|
| 96 | -4x | +
- .data$stat_name %in% "n" & .data$variable_level %in% TRUE ~ "N_nonmiss",+ # styler: on |
||
| 97 | -4x | +! |
- .data$stat_name %in% "p" & .data$variable_level %in% FALSE ~ "p_miss",+ NULL |
|
| 98 | -4x | +
- .data$stat_name %in% "p" & .data$variable_level %in% TRUE ~ "p_nonmiss",+ } |
||
| 99 | -4x | +
- .data$stat_name %in% "N_unweighted" ~ "N_obs_unweighted",+ ), |
||
| 100 | -4x | +1x |
- .data$stat_name %in% "n_unweighted" & .data$variable_level %in% FALSE ~ "N_miss_unweighted",+ context = "aod_wald_test", |
|
| 101 | -4x | +1x |
- .data$stat_name %in% "n_unweighted" & .data$variable_level %in% TRUE ~ "N_nonmiss_unweighted",+ warning = wald_test["warning"], |
|
| 102 | -4x | -
- .data$stat_name %in% "p_unweighted" & .data$variable_level %in% FALSE ~ "p_miss_unweighted",- |
- ||
| 103 | -4x | -
- .data$stat_name %in% "p_unweighted" & .data$variable_level %in% TRUE ~ "p_nonmiss_unweighted"- |
- ||
| 104 | -+ | 1x |
- )+ error = wald_test["error"] |
|
| 105 | +103 |
) |> |
||
| 106 | -4x | +104 | +1x |
- dplyr::select(-cards::all_ard_variables("levels"), -"stat_label", -"fmt_fn") |>
+ cards::tidy_ard_column_order() %>% |
| 107 | -4x | +105 | +1x |
- dplyr::slice(1L, .by = c(cards::all_ard_groups(), cards::all_ard_variables(), "stat_name"))+ {structure(., class = c("card", class(.)))} # styler: off
|
| 108 | +106 |
-
+ } |
||
| 109 | +107 |
- # final processing of fmt_fn -------------------------------------------------- |
- ||
| 110 | -4x | -
- result <- result |>- |
- ||
| 111 | -4x | -
- .process_nested_list_as_df(- |
- ||
| 112 | -4x | -
- arg = fmt_fn,- |
- ||
| 113 | -4x | -
- new_column = "fmt_fn"+ |
||
| 114 | +108 |
- ) |>- |
- ||
| 115 | -4x | -
- .default_svy_cat_fmt_fn()+ #' Extract data from wald.test object |
||
| 116 | +109 |
-
+ #' |
||
| 117 | +110 |
- # merge in statistic labels --------------------------------------------------- |
- ||
| 118 | -4x | -
- result <- result |>- |
- ||
| 119 | -4x | -
- .process_nested_list_as_df(- |
- ||
| 120 | -4x | -
- arg = stat_label,- |
- ||
| 121 | -4x | -
- new_column = "stat_label",- |
- ||
| 122 | -4x | -
- unlist = TRUE+ #' @param wald_test (`data.frame`)\cr wald test object object from `aod::wald.test()` |
||
| 123 | +111 |
- ) |>+ #' |
||
| 124 | -4x | +|||
| 112 | +
- dplyr::mutate(stat_label = dplyr::coalesce(.data$stat_label, .data$stat_name))+ #' @return a data frame containing the wald test results. |
|||
| 125 | +113 |
-
+ #' @keywords internal |
||
| 126 | +114 |
- # return final object --------------------------------------------------------+ .extract_wald_results <- function(wald_test) {
|
||
| 127 | -4x | +115 | +2x |
- result |>+ df <- wald_test$result$chi2[("df")]
|
| 128 | -4x | +116 | +2x |
- dplyr::mutate(context = "missing") |>+ statistic <- wald_test$result$chi2[("chi2")]
|
| 129 | -4x | +117 | +2x |
- cards::tidy_ard_column_order() %>%+ p.value <- wald_test$result$chi2[("P")]
|
| 130 | -4x | +118 | +2x |
- {structure(., class = c("card", class(.)))} # styler: off
+ data.frame(df, statistic, p.value) |
| 131 | +119 |
}@@ -41698,14 +41733,14 @@ cardx coverage - 95.32% |
| 1 |
- #' ARD one-sample Wilcox Rank-sum+ #' Regression ARD |
||
| 3 |
- #' @description+ #' Function takes a regression model object and converts it to a ARD |
||
| 4 |
- #' Analysis results data for one-sample Wilcox Rank-sum.+ #' structure using the `broom.helpers` package. |
||
| 5 |
- #' Result may be stratified by including the `by` argument.+ #' |
||
| 6 |
- #'+ #' @param x regression model object |
||
| 7 |
- #' @param data (`data.frame`)\cr+ #' @param tidy_fun (`function`)\cr |
||
| 8 |
- #' a data frame. See below for details.+ #' a tidier. Default is [`broom.helpers::tidy_with_broom_or_parameters`] |
||
| 9 |
- #' @param variables ([`tidy-select`][dplyr::dplyr_tidy_select])\cr+ #' @param ... Arguments passed to [`broom.helpers::tidy_plus_plus()`] |
||
| 10 |
- #' column names to be analyzed. Independent Wilcox Rank-sum tests will be computed for+ #' |
||
| 11 |
- #' each variable.+ #' @return data frame |
||
| 12 |
- #' @param by ([`tidy-select`][dplyr::dplyr_tidy_select])\cr+ #' @name ard_regression |
||
| 13 |
- #' optional column name to stratify results by.+ #' |
||
| 14 |
- #' @inheritParams ard_stats_wilcox_test+ #' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = "broom.helpers", reference_pkg = "cardx"))
|
||
| 15 |
- #'+ #' lm(AGE ~ ARM, data = cards::ADSL) |> |
||
| 16 |
- #' @return ARD data frame+ #' ard_regression(add_estimate_to_reference_rows = TRUE) |
||
| 17 |
- #' @export+ NULL |
||
| 18 |
- #'+ |
||
| 19 |
- #' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = "broom", reference_pkg = "cardx"))
+ #' @rdname ard_regression |
||
| 20 |
- #' cards::ADSL |>+ #' @export |
||
| 21 |
- #' ard_stats_wilcox_test_onesample(by = ARM, variables = AGE)+ ard_regression <- function(x, ...) {
|
||
| 22 | -+ | 7x |
- ard_stats_wilcox_test_onesample <- function(data, variables, by = dplyr::group_vars(data), conf.level = 0.95, ...) {
+ UseMethod("ard_regression")
|
| 23 | -2x | +
- set_cli_abort_call()+ } |
|
| 25 |
- # check installed packages ---------------------------------------------------+ #' @rdname ard_regression |
||
| 26 | -2x | +
- check_pkg_installed("broom", reference_pkg = "cardx")
+ #' @export |
|
| 27 |
-
+ ard_regression.default <- function(x, tidy_fun = broom.helpers::tidy_with_broom_or_parameters, ...) {
|
||
| 28 | -+ | 7x |
- # check/process inputs -------------------------------------------------------+ set_cli_abort_call() |
| 29 | -2x | +
- check_not_missing(data)+ |
|
| 30 | -2x | +
- check_not_missing(variables)+ # check installed packages --------------------------------------------------- |
|
| 31 | -2x | +7x |
- check_data_frame(data)+ check_pkg_installed(pkg = "broom.helpers", reference_pkg = "cardx") |
| 32 | -2x | +
- data <- dplyr::ungroup(data)+ |
|
| 33 | -2x | +
- cards::process_selectors(data, by = {{ by }}, variables = {{ variables }})
+ # check inputs --------------------------------------------------------------- |
|
| 34 | -2x | +7x |
- check_scalar_range(conf.level, range = c(0, 1))+ check_not_missing(x) |
| 36 |
- # if no variables selected, return empty tibble ------------------------------+ # summarize model ------------------------------------------------------------ |
||
| 37 | -2x | +7x |
- if (is_empty(variables)) {
+ broom.helpers::tidy_plus_plus( |
| 38 | -1x | +7x |
- return(dplyr::tibble())+ model = x, |
| 39 | -+ | 7x |
- }+ tidy_fun = tidy_fun, |
| 40 |
-
+ ... |
||
| 41 | -1x | +
- cards::ard_continuous(+ ) |> |
|
| 42 | -1x | +7x |
- data = data,+ dplyr::mutate( |
| 43 | -1x | +7x |
- variables = all_of(variables),+ variable_level = dplyr::if_else(.data$var_type %in% "continuous", NA_character_, .data$label), |
| 44 | -1x | +7x |
- by = all_of(by),+ dplyr::across(-c("variable", "variable_level"), .fns = as.list)
|
| 45 | -1x | +
- statistic = all_of(variables) ~ list(t_test_onesample = \(x) stats::wilcox.test(x = x, conf.level = conf.level, ...) |> broom::tidy())+ ) |> |
|
| 46 | -+ | 7x |
- ) |>+ tidyr::pivot_longer( |
| 47 | -1x | +7x |
- cards::bind_ard(+ cols = -c("variable", "variable_level"),
|
| 48 | -1x | +7x |
- cards::ard_continuous(+ names_to = "stat_name", |
| 49 | -1x | +7x |
- data = data,+ values_to = "stat" |
| 50 | -1x | +
- variables = all_of(variables),+ ) |> |
|
| 51 | -1x | +7x |
- by = all_of(by),+ dplyr::filter(map_lgl(.data$stat, Negate(is.na))) |> |
| 52 | -1x | +7x |
- statistic =+ dplyr::select(-(cards::all_ard_variables("levels") & dplyr::where(\(x) all(is.na(x))))) |>
|
| 53 | -1x | +7x |
- all_of(variables) ~+ dplyr::mutate( |
| 54 | -1x | +7x |
- list(conf.level = \(x) {
+ fmt_fn = |
| 55 | -3x | +7x |
- formals(asNamespace("stats")[["wilcox.test.default"]])[c("mu", "exact", "conf.int", "tol.root", "digits.rank")] |>
+ lapply( |
| 56 | -3x | +7x |
- utils::modifyList(list(conf.level = conf.level, ...)) |>+ .data$stat, |
| 57 | -3x | +7x |
- compact()+ function(x) {
|
| 58 | -+ | 185x |
- })+ switch(is.integer(x), 0L) %||% # styler: off |
| 59 | -+ | 185x |
- )+ switch(is.numeric(x), 1L) # styler: off |
| 60 |
- ) |>+ } |
||
| 61 | -1x | +
- dplyr::select(-"stat_label") |>+ ), |
|
| 62 | -1x | +7x |
- dplyr::left_join(+ context = "regression", |
| 63 | -1x | +7x |
- .df_ttest_stat_labels(by = NULL),+ stat_label = |
| 64 | -1x | +7x |
- by = "stat_name"+ dplyr::case_when( |
| 65 | -+ | 7x |
- ) |>+ .data$stat_name %in% "var_label" ~ "Label", |
| 66 | -1x | +7x |
- dplyr::mutate(+ .data$stat_name %in% "var_class" ~ "Class", |
| 67 | -1x | +7x |
- stat_label = dplyr::coalesce(.data$stat_label, .data$stat_name),+ .data$stat_name %in% "var_type" ~ "Type", |
| 68 | -1x | +7x |
- context = "stats_wilcox_test_onesample",+ .data$stat_name %in% "var_nlevels" ~ "N Levels", |
| 69 | -+ | 7x |
- ) |>+ .data$stat_name %in% "contrasts_type" ~ "Contrast Type", |
| 70 | -1x | +7x |
- cards::tidy_ard_row_order() |>+ .data$stat_name %in% "label" ~ "Level Label", |
| 71 | -1x | +7x |
- cards::tidy_ard_column_order()+ .data$stat_name %in% "n_obs" ~ "N Obs.", |
| 72 | +7x | +
+ .data$stat_name %in% "n_event" ~ "N Events",+ |
+ |
| 73 | +7x | +
+ .data$stat_name %in% "exposure" ~ "Exposure Time",+ |
+ |
| 74 | +7x | +
+ .data$stat_name %in% "estimate" ~ "Coefficient",+ |
+ |
| 75 | +7x | +
+ .data$stat_name %in% "std.error" ~ "Standard Error",+ |
+ |
| 76 | +7x | +
+ .data$stat_name %in% "p.value" ~ "p-value",+ |
+ |
| 77 | +7x | +
+ .data$stat_name %in% "conf.low" ~ "CI Lower Bound",+ |
+ |
| 78 | +7x | +
+ .data$stat_name %in% "conf.high" ~ "CI Upper Bound",+ |
+ |
| 79 | +7x | +
+ TRUE ~ .data$stat_name+ |
+ |
| 80 | ++ |
+ )+ |
+ |
| 81 | ++ |
+ ) |>+ |
+ |
| 82 | +7x | +
+ cards::tidy_ard_column_order() %>%+ |
+ |
| 83 | +7x | +
+ {structure(., class = c("card", class(.)))} # styler: off
+ |
+ |
| 84 |
}@@ -42208,14 +42327,14 @@ cardx coverage - 95.32% |
| 1 |
- #' ARD Kruskal-Wallis Test+ #' Basic Regression ARD |
||
| 4 |
- #' Analysis results data for Kruskal-Wallis Rank Sum Test.+ #' A function that takes a regression model and provides basic statistics in an |
||
| 5 |
- #'+ #' ARD structure. |
||
| 6 |
- #' Calculated with `kruskal.test(data[[variable]], data[[by]], ...)`+ #' The default output is simpler than [`ard_regression()`]. |
||
| 7 |
- #'+ #' The function primarily matches regression terms to underlying variable names |
||
| 8 |
- #' @param data (`data.frame`)\cr+ #' and levels. |
||
| 9 |
- #' a data frame.+ #' The default arguments used are |
||
| 10 |
- #' @param by ([`tidy-select`][dplyr::dplyr_tidy_select])\cr+ #' |
||
| 11 |
- #' column name to compare by.+ #' ```r |
||
| 12 |
- #' @param variables ([`tidy-select`][dplyr::dplyr_tidy_select])\cr+ #' broom.helpers::tidy_plus_plus( |
||
| 13 |
- #' column names to be compared. Independent tests will+ #' add_reference_rows = FALSE, |
||
| 14 |
- #' be computed for each variable.+ #' add_estimate_to_reference_rows = FALSE, |
||
| 15 |
- #'+ #' add_n = FALSE, |
||
| 16 |
- #' @return ARD data frame+ #' intercept = FALSE |
||
| 17 |
- #' @export+ #' ) |
||
| 18 |
- #'+ #' ``` |
||
| 19 |
- #' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = "broom", reference_pkg = "cardx"))
+ #' |
||
| 20 |
- #' cards::ADSL |>+ #' @inheritParams ard_regression |
||
| 21 |
- #' ard_stats_kruskal_test(by = "ARM", variables = "AGE")+ #' @param stats_to_remove (`character`)\cr |
||
| 22 |
- ard_stats_kruskal_test <- function(data, by, variables) {
+ #' character vector of statistic names to remove. Default is |
||
| 23 | -2x | +
- set_cli_abort_call()+ #' `c("term", "var_type", "var_label", "var_class", "label", "contrasts_type", "contrasts", "var_nlevels")`.
|
|
| 24 |
-
+ #' |
||
| 25 |
- # check installed packages ---------------------------------------------------+ #' @return data frame |
||
| 26 | -2x | +
- check_pkg_installed("broom", reference_pkg = "cardx")
+ #' @name ard_regression_basic |
|
| 27 |
-
+ #' @export |
||
| 28 |
- # check/process inputs -------------------------------------------------------+ #' |
||
| 29 | -2x | +
- check_not_missing(data)+ #' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = "broom.helpers", reference_pkg = "cardx"))
|
|
| 30 | -2x | +
- check_not_missing(variables)+ #' lm(AGE ~ ARM, data = cards::ADSL) |> |
|
| 31 | -2x | +
- check_not_missing(by)+ #' ard_regression_basic() |
|
| 32 | -2x | +
- check_data_frame(data)+ ard_regression_basic <- function(x, tidy_fun = broom.helpers::tidy_with_broom_or_parameters, |
|
| 33 | -2x | +
- cards::process_selectors(data, by = {{ by }}, variables = {{ variables }})
+ stats_to_remove = c( |
|
| 34 | -2x | +
- check_scalar(by)+ "term", "var_type", "var_label", "var_class", |
|
| 35 |
-
+ "label", "contrasts_type", "contrasts", "var_nlevels" |
||
| 36 |
- # if no variables selected, return empty tibble ------------------------------+ ), |
||
| 37 | -2x | +
- if (is_empty(variables)) {
+ ...) {
|
|
| 38 | -! | +3x |
- return(dplyr::tibble())+ set_cli_abort_call() |
| 39 |
- }+ |
||
| 40 |
- # build ARD ------------------------------------------------------------------+ # check installed packages --------------------------------------------------- |
||
| 41 | -2x | +3x |
- lapply(+ check_pkg_installed(pkg = "broom.helpers", reference_pkg = "cardx") |
| 42 | -2x | +
- variables,+ |
|
| 43 | -2x | +
- function(variable) {
+ # check inputs --------------------------------------------------------------- |
|
| 44 | -2x | +3x |
- cards::tidy_as_ard(+ check_not_missing(x) |
| 45 | -2x | +3x |
- lst_tidy =+ check_class(stats_to_remove, cls = "character", allow_empty = TRUE) |
| 46 | -2x | +! |
- cards::eval_capture_conditions(+ if (is_empty(stats_to_remove)) stats_to_remove <- character(0L) # styler: off |
| 47 | -2x | +
- stats::kruskal.test(x = data[[variable]], g = data[[by]]) |>+ |
|
| 48 | -2x | +3x |
- broom::tidy()+ args <- |
| 49 | -+ | 3x |
- ),+ list( |
| 50 | -2x | +3x |
- tidy_result_names = c("statistic", "p.value", "parameter", "method"),
+ add_reference_rows = FALSE, |
| 51 | -2x | +3x |
- lst_ard_columns = list(group1 = by, variable = variable, context = "stats_kruskal_test")+ add_estimate_to_reference_rows = FALSE, |
| 52 | -+ | 3x |
- ) |>+ add_n = FALSE, |
| 53 | -2x | +3x |
- dplyr::mutate(+ intercept = FALSE |
| 54 | -2x | +
- .after = "stat_name",+ ) |> |
|
| 55 | -2x | +3x |
- stat_label =+ utils::modifyList(val = rlang::dots_list(...)) |
| 56 | -2x | +
- dplyr::case_when(+ |
|
| 57 | -2x | +3x |
- .data$stat_name %in% "statistic" ~ "Kruskal-Wallis chi-squared Statistic",+ rlang::inject(ard_regression(x = x, tidy_fun = tidy_fun, !!!args)) |> |
| 58 | -2x | +3x |
- .data$stat_name %in% "p.value" ~ "p-value",+ dplyr::filter(!.data$stat_name %in% stats_to_remove) |> |
| 59 | -2x | -
- .data$stat_name %in% "parameter" ~ "Degrees of Freedom",- |
- |
| 60 | -2x | -
- TRUE ~ .data$stat_name,- |
- |
| 61 | -- |
- )- |
- |
| 62 | -- |
- )- |
- |
| 63 | -- |
- }- |
- |
| 64 | -- |
- ) |>- |
- |
| 65 | -2x | +3x |
- dplyr::bind_rows()+ dplyr::select(-(cards::all_ard_variables("levels") & dplyr::where(\(x) all(is.na(x)))))
|
| 66 | +60 |
} |