| 1 |
- #' Regression VIF ARD+ #' Construction Helpers |
||
| 3 |
- #' @description+ #' These functions help construct calls to various types of models. |
||
| 4 |
- #' Function takes a regression model object and returns the variance inflation factor (VIF)+ #' |
||
| 5 |
- #' using [`car::vif()`] and converts it to a ARD structure+ #' - `construct_model()`: Builds models of the form `method(data = data, formula = formula, method.args!!!)`. |
||
| 6 |
- #'+ #' If the `package` argument is specified, that package is temporarily attached |
||
| 7 |
- #' @param x regression model object+ #' when the model is evaluated. |
||
| 8 |
- #' See car::vif() for details+ #' |
||
| 9 |
- #'+ #' - `reformulate2()`: This is a copy of `reformulate()` except that variable |
||
| 10 |
- #' @param ... arguments passed to `car::vif(...)`+ #' names that contain a space are wrapped in backticks. |
||
| 12 |
- #' @return data frame+ #' - `bt()`: Adds backticks to a character vector. |
||
| 13 |
- #' @name ard_vif+ #' |
||
| 14 |
- #' @rdname ard_vif+ #' - `bt_strip()`: Removes backticks from a string if it begins and ends with a backtick. |
||
| 15 |
- #' @export+ #' |
||
| 16 |
- #'+ #' @param data |
||
| 17 |
- #' @examples+ #' - `construct_model.data.frame()` (`data.frame`) a data frame |
||
| 18 |
- #' lm(AGE ~ ARM + SEX, data = cards::ADSL) |>+ #' - `construct_model.survey.design()` (`survey.design`) a survey design object |
||
| 19 |
- #' ard_vif()+ #' @param x (`character`)\cr |
||
| 20 |
- ard_vif <- function(x, ...) {
+ #' character vector, typically of variable names |
||
| 21 |
- # check inputs ---------------------------------------------------------------+ #' @param formula (`formula`)\cr |
||
| 22 | -3x | +
- check_not_missing(x)+ #' a formula |
|
| 23 |
-
+ #' @param method (`string`)\cr |
||
| 24 | -3x | +
- vif <- cards::eval_capture_conditions(car::vif(x, ...))+ #' string of function naming the function to be called, e.g. `"glm"`. |
|
| 25 |
-
+ #' If function belongs to a library that is not attached, the package name |
||
| 26 |
- # if vif failed, set result as NULL, error will be kept through eval_capture_conditions()+ #' must be specified in the `package` argument. |
||
| 27 | -3x | +
- if (is.null(vif$result)) {
+ #' @param method.args (named `list`)\cr |
|
| 28 |
- # try to capture variable names from `terms()`+ #' named list of arguments that will be passed to `method`. |
||
| 29 | -2x | +
- lst_terms <- cards::eval_capture_conditions(attr(stats::terms(x), "term.labels"))+ #' |
|
| 30 |
- # we cannot get variable names, error out+ #' Note that this list may contain non-standard evaluation components. |
||
| 31 | -2x | +
- if (!is.null(lst_terms[["error"]])) {
+ #' If you are wrapping this function in other functions, the argument |
|
| 32 | -1x | +
- cli::cli_abort(+ #' must be passed in a way that does not evaluate the list, e.g. |
|
| 33 | -1x | +
- c("There was an error running {.fun car::vif}. See below.", x = vif[["error"]])
+ #' using rlang's embrace operator `{{ . }}`.
|
|
| 34 |
- )+ #' @param package (`string`)\cr |
||
| 35 |
- }+ #' string of package name that will be temporarily loaded when function |
||
| 36 | -1x | +
- vif$result <- dplyr::tibble(+ #' specified in `method` is executed. |
|
| 37 | -1x | +
- variable = lst_terms[["result"]],+ #' @param pattern,pattern_term,pattern_response DEPRECATED |
|
| 38 | -1x | +
- VIF = list(NULL),+ #' @inheritParams rlang::eval_tidy |
|
| 39 | -1x | +
- GVIF = list(NULL),+ #' @inheritParams stats::reformulate |
|
| 40 | -1x | +
- aGVIF = list(NULL),+ #' @inheritParams rlang::args_dots_empty |
|
| 41 | -1x | +
- df = list(NULL)+ #' |
|
| 42 |
- )+ #' @return depends on the calling function |
||
| 43 |
- }+ #' @name construction_helpers |
||
| 44 |
- # if VIF is returned+ #' |
||
| 45 | -1x | +
- else if (!is.matrix(vif$result)) {
+ #' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = c("withr", "lme4", "broom.helpers", "broom.mixed")))
|
|
| 46 | -! | +
- vif$result <- dplyr::tibble(variable = names(vif$result), VIF = vif$result)+ #' construct_model( |
|
| 47 |
- }+ #' data = mtcars, |
||
| 48 |
- # if Generalized VIF is returned+ #' formula = am ~ mpg + (1 | vs), |
||
| 49 | -1x | +
- else if (is.matrix(vif$result)) {
+ #' method = "glmer", |
|
| 50 | -1x | +
- vif$result <-+ #' method.args = list(family = binomial), |
|
| 51 | -1x | +
- vif$result |>+ #' package = "lme4" |
|
| 52 | -1x | +
- as.data.frame() %>%+ #' ) |> |
|
| 53 | -1x | +
- dplyr::mutate(., variable = rownames(.), .before = 1L) |>+ #' broom.mixed::tidy() |
|
| 54 | -1x | +
- dplyr::rename(+ #' |
|
| 55 | -1x | +
- aGVIF = "GVIF^(1/(2*Df))",+ #' construct_model( |
|
| 56 | -1x | +
- df = "Df"+ #' data = mtcars |> dplyr::rename(`M P G` = mpg), |
|
| 57 |
- ) |>+ #' formula = reformulate2(c("M P G", "cyl"), response = "hp"),
|
||
| 58 | -1x | +
- dplyr::tibble()+ #' method = "lm" |
|
| 59 |
- }+ #' ) |> |
||
| 60 |
-
+ #' ard_regression() |> |
||
| 61 |
- # Clean-up the result to fit the ard structure through pivot+ #' dplyr::filter(stat_name %in% c("term", "estimate", "p.value"))
|
||
| 62 | -2x | +
- vif$result <-+ NULL |
|
| 63 | -2x | +
- vif$result |>+ |
|
| 64 | -2x | +
- tidyr::pivot_longer(+ #' @rdname construction_helpers |
|
| 65 | -2x | +
- cols = -c("variable"),
+ #' @export |
|
| 66 | -2x | +
- names_to = "stat_name",+ construct_model <- function(data, ...) {
|
|
| 67 | -2x | +26x |
- values_to = "stat"+ UseMethod("construct_model")
|
| 68 |
- ) |>+ } |
||
| 69 | -2x | +
- dplyr::mutate(+ |
|
| 70 | -2x | +
- context = "vif",+ #' @rdname construction_helpers |
|
| 71 | -2x | +
- stat_label = ifelse(+ #' @export |
|
| 72 | -2x | +
- .data$stat_name == "aGVIF",+ construct_model.data.frame <- function(data, formula, method, method.args = list(), package = "base", env = caller_env(), ...) {
|
|
| 73 | -2x | +22x |
- "Adjusted GVIF",+ set_cli_abort_call() |
| 74 | -2x | +
- .data$stat_name+ # check pkg installations ---------------------------------------------------- |
|
| 75 | -+ | 22x |
- ),+ check_dots_empty() |
| 76 | -2x | +22x |
- fmt_fn = map(+ check_pkg_installed(c("withr", package))
|
| 77 | -2x | +
- .data$stat,+ |
|
| 78 | -2x | +22x |
- function(.x) {
+ check_not_missing(formula) |
| 79 | -+ | 22x |
- # styler: off+ check_class(formula, cls = "formula") |
| 80 | -! | +
- if (is.integer(.x)) return(0L)+ |
|
| 81 | -6x | +22x |
- if (is.numeric(.x)) return(1L)+ check_not_missing(method) |
| 82 | -+ | 22x |
- # styler: on+ check_string_or_function(method) |
| 83 | -4x | +18x |
- NULL+ if (is_string(method)) check_not_namespaced(method) |
| 84 |
- }+ |
||
| 85 |
- )+ # convert method.args to list of expressions (to account for NSE inputs) ----- |
||
| 86 | -+ | 19x |
- )+ method.args <- .as_list_of_exprs({{ method.args }})
|
| 88 |
- # Bind the results and possible warning/errors together+ # build model ---------------------------------------------------------------- |
||
| 89 | -2x | +19x |
- vif_return <- dplyr::tibble(+ call_to_run <- call2(.fn = method, formula = formula, data = data, !!!method.args) |
| 90 | -2x | +
- vif$result,+ |
|
| 91 | -2x | +19x |
- warning = vif["warning"],+ try_fetch( |
| 92 | -2x | +19x |
- error = vif["error"]+ withr::with_namespace( |
| 93 | -+ | 19x |
- )+ package = package, |
| 94 | -+ | 19x |
-
+ eval_tidy(call_to_run, env = env) |
| 95 |
- # Clean up return object+ ), |
||
| 96 | -2x | +19x |
- vif_return |>+ error = function(e) {
|
| 97 | 2x |
- cards::tidy_ard_column_order() %>%+ msg <- "There was an error evaluating the model" |
|
| 98 | 2x |
- {structure(., class = c("card", class(.)))} # styler: off
+ if (is_string(method)) {
|
|
| 99 | -- |
- }- |
-
| 1 | -+ | 1x |
- #' Functions for Calculating Proportion Confidence Intervals+ call_to_run$data <- expr(.) |
|
| 2 | -+ | |||
| 100 | +1x |
- #'+ msg <- paste(msg, "{.code {truncate_call(call_to_run)}}")
|
||
| 3 | +101 |
- #' Functions to calculate different proportion confidence intervals for use in `ard_proportion()`.+ } |
||
| 4 | +102 |
- #'+ |
||
| 5 | -+ | |||
| 103 | +2x |
- #' @inheritParams ard_proportion_ci+ cli::cli_abort( |
||
| 6 | -+ | |||
| 104 | +2x |
- #' @param x vector of a binary values, i.e. a logical vector, or numeric with values `c(0, 1)`+ message = msg, |
||
| 7 | -+ | |||
| 105 | +2x |
- #' @return Confidence interval of a proportion.+ parent = e, |
||
| 8 | -+ | |||
| 106 | +2x |
- #'+ call = get_cli_abort_call() |
||
| 9 | +107 |
- #' @name proportion_ci+ ) |
||
| 10 | +108 |
- #' @examplesIf cards::is_pkg_installed("broom", reference_pkg = "cardx")
+ } |
||
| 11 | +109 |
- #' x <- c(+ ) |
||
| 12 | +110 |
- #' TRUE, TRUE, TRUE, TRUE, TRUE,+ } |
||
| 13 | +111 |
- #' FALSE, FALSE, FALSE, FALSE, FALSE+ |
||
| 14 | +112 |
- #' )+ #' @rdname construction_helpers |
||
| 15 | +113 |
- #'+ #' @export |
||
| 16 | +114 |
- #' proportion_ci_wald(x, conf.level = 0.9)+ construct_model.survey.design <- function(data, formula, method, method.args = list(), package = "survey", env = caller_env(), ...) {
|
||
| 17 | -+ | |||
| 115 | +4x |
- #' proportion_ci_wilson(x, correct = TRUE)+ set_cli_abort_call() |
||
| 18 | +116 |
- #' proportion_ci_clopper_pearson(x)+ # check pkg installations ---------------------------------------------------- |
||
| 19 | -+ | |||
| 117 | +4x |
- #' proportion_ci_agresti_coull(x)+ check_dots_empty() |
||
| 20 | -+ | |||
| 118 | +4x |
- #' proportion_ci_jeffreys(x)+ check_pkg_installed(c("withr", package))
|
||
| 21 | +119 |
- NULL+ |
||
| 22 | -+ | |||
| 120 | +4x |
-
+ check_not_missing(formula) |
||
| 23 | -+ | |||
| 121 | +4x |
- #' @describeIn proportion_ci Calculates the Wald interval by following the usual textbook definition+ check_class(formula, cls = "formula") |
||
| 24 | +122 |
- #' for a single proportion confidence interval using the normal approximation.+ |
||
| 25 | -+ | |||
| 123 | +4x |
- #'+ check_not_missing(method) |
||
| 26 | -+ | |||
| 124 | +4x |
- #' \deqn{\hat{p} \pm z_{\alpha/2} \sqrt{\frac{\hat{p}(1 - \hat{p})}{n}}}
+ check_string_or_function(method) |
||
| 27 | -+ | |||
| 125 | +4x |
- #'+ if (is_string(method)) check_not_namespaced(method) |
||
| 28 | +126 |
- #' @param correct (`logical`)\cr apply continuity correction.+ |
||
| 29 | +127 |
- #'+ # convert method.args to list of expressions (to account for NSE inputs) ----- |
||
| 30 | -+ | |||
| 128 | +4x |
- #' @export+ method.args <- .as_list_of_exprs({{ method.args }})
|
||
| 31 | +129 |
- proportion_ci_wald <- function(x, conf.level = 0.95, correct = FALSE) {
+
|
||
| 32 | +130 |
- # check inputs ---------------------------------------------------------------+ # build model ---------------------------------------------------------------- |
||
| 33 | +131 | 4x |
- check_not_missing(x)+ call_to_run <- call2(.fn = method, formula = formula, design = data, !!!method.args) |
|
| 34 | -4x | +|||
| 132 | +
- check_binary(x)+ |
|||
| 35 | +133 | 4x |
- check_range(conf.level, range = c(0, 1), include_bounds = c(FALSE, FALSE))+ try_fetch( |
|
| 36 | +134 | 4x |
- check_scalar(conf.level)+ withr::with_namespace( |
|
| 37 | +135 | 4x |
- check_class(x = correct, "logical")+ package = package, |
|
| 38 | +136 | 4x |
- check_scalar(correct)+ eval_tidy(call_to_run, env = env) |
|
| 39 | +137 |
-
+ ), |
||
| 40 | +138 | 4x |
- x <- stats::na.omit(x)+ error = function(e) {
|
|
| 41 | -+ | |||
| 139 | +2x |
-
+ msg <- "There was an error evaluating the model" |
||
| 42 | -4x | +140 | +2x |
- n <- length(x)+ if (is_string(method)) {
|
| 43 | -4x | +141 | +2x |
- p_hat <- mean(x)+ call_to_run$design <- expr(.) |
| 44 | -4x | +142 | +2x |
- z <- stats::qnorm((1 + conf.level) / 2)+ msg <- paste(msg, "{.code {truncate_call(call_to_run)}}")
|
| 45 | -4x | -
- q_hat <- 1 - p_hat- |
- ||
| 46 | -4x | +|||
| 143 | +
- correction_factor <- ifelse(correct, 1 / (2 * n), 0)+ } |
|||
| 47 | +144 | |||
| 48 | -4x | +145 | +2x |
- err <- z * sqrt(p_hat * q_hat) / sqrt(n) + correction_factor+ cli::cli_abort( |
| 49 | -4x | +146 | +2x |
- l_ci <- max(0, p_hat - err)+ message = msg, |
| 50 | -4x | +147 | +2x |
- u_ci <- min(1, p_hat + err)+ parent = e,+ |
+
| 148 | +2x | +
+ call = get_cli_abort_call() |
||
| 51 | +149 |
-
+ ) |
||
| 52 | -4x | +|||
| 150 | +
- list(+ } |
|||
| 53 | -4x | +|||
| 151 | +
- N = n,+ ) |
|||
| 54 | -4x | +|||
| 152 | +
- estimate = p_hat,+ } |
|||
| 55 | -4x | +|||
| 153 | +
- conf.low = l_ci,+ |
|||
| 56 | -4x | +|||
| 154 | +
- conf.high = u_ci,+ .as_list_of_exprs <- function(x, arg_name = "method.args") {
|
|||
| 57 | -4x | +155 | +24x |
- conf.level = conf.level,+ x_enexpr <- enexpr(x) |
| 58 | -4x | +156 | +24x |
- method =+ if (is_call_simple(x_enexpr)) {
|
| 59 | -4x | +157 | +24x |
- glue::glue("Wald Confidence Interval {ifelse(correct, 'with', 'without')} continuity correction")
+ return(call_args(x_enexpr)) |
| 60 | +158 |
- )+ } |
||
| 61 | +159 |
- }+ |
||
| 62 | -+ | |||
| 160 | +! |
-
+ cli::cli_abort(+ |
+ ||
| 161 | +! | +
+ c("There was an error processing the {.arg {argname}} argument.",
+ |
+ ||
| 162 | +! | +
+ i = "Expecting a simple call. See {.help rlang::is_call_simple} for details."
|
||
| 63 | +163 |
-
+ ),+ |
+ ||
| 164 | +! | +
+ call = get_cli_abort_call() |
||
| 64 | +165 |
- #' @describeIn proportion_ci Calculates the Wilson interval by calling [stats::prop.test()].+ ) |
||
| 65 | +166 |
- #' Also referred to as Wilson score interval.+ } |
||
| 66 | +167 |
- #'+ |
||
| 67 | +168 |
- #' \deqn{\frac{\hat{p} +
+ #' @rdname construction_helpers |
||
| 68 | +169 |
- #' \frac{z^2_{\alpha/2}}{2n} \pm z_{\alpha/2} \sqrt{\frac{\hat{p}(1 - \hat{p})}{n} +
+ #' @export |
||
| 69 | +170 |
- #' \frac{z^2_{\alpha/2}}{4n^2}}}{1 + \frac{z^2_{\alpha/2}}{n}}}
+ reformulate2 <- function(termlabels, response = NULL, intercept = TRUE, |
||
| 70 | +171 |
- #'+ env = parent.frame(), |
||
| 71 | +172 |
- #' @export+ pattern_term = NULL, pattern_response = NULL) {
|
||
| 72 | +173 |
- proportion_ci_wilson <- function(x, conf.level = 0.95, correct = FALSE) {
+ # deprecated argument -------------------------------------------------------- |
||
| 73 | -5x | +|||
| 174 | +! |
- cards::check_pkg_installed("broom", reference_pkg = "cardx")
+ if (!missing(pattern_term)) lifecycle::deprecate_warn("0.2.1", what = "cardx::reformulate2(pattern_term)", details = "Argument has been ignored.") # styler: off
|
||
| 74 | -+ | |||
| 175 | +! |
-
+ if (!missing(pattern_response)) lifecycle::deprecate_warn("0.2.1", what = "cardx::reformulate2(pattern_response)", details = "Argument has been ignored.") # styler: off
|
||
| 75 | +176 |
- # check inputs ---------------------------------------------------------------+ |
||
| 76 | -5x | +177 | +1041x |
- check_not_missing(x)+ stats::reformulate( |
| 77 | -5x | +178 | +1041x |
- check_binary(x)+ termlabels = bt(termlabels), |
| 78 | -5x | +179 | +1041x |
- check_class(x = correct, "logical")+ response = bt(response), |
| 79 | -5x | +180 | +1041x |
- check_scalar(correct)+ intercept = intercept, |
| 80 | -5x | +181 | +1041x |
- check_range(conf.level, range = c(0, 1), include_bounds = c(FALSE, FALSE))+ env = env |
| 81 | -5x | +|||
| 182 | +
- check_scalar(conf.level)+ ) |
|||
| 82 | +183 |
-
+ } |
||
| 83 | -5x | +|||
| 184 | +
- x <- stats::na.omit(x)+ |
|||
| 84 | +185 |
-
+ #' @rdname construction_helpers |
||
| 85 | -5x | +|||
| 186 | +
- n <- length(x)+ #' @export |
|||
| 86 | -5x | +|||
| 187 | +
- y <- stats::prop.test(x = sum(x), n = n, correct = correct, conf.level = conf.level)+ bt <- function(x, pattern = NULL) {
|
|||
| 87 | +188 |
-
+ # deprecated argument -------------------------------------------------------- |
||
| 88 | -5x | +|||
| 189 | +! |
- list(N = n, conf.level = conf.level) |>+ if (!missing(pattern)) lifecycle::deprecate_warn("0.2.1", what = "cardx::bt(pattern)", details = "Argument has been ignored.") # styler: off
|
||
| 89 | -5x | +|||
| 190 | +
- utils::modifyList(val = broom::tidy(y) |> as.list()) |>+ |
|||
| 90 | -5x | +191 | +2144x |
- utils::modifyList(+ if (is_empty(x)) {
|
| 91 | -5x | -
- list(- |
- ||
| 92 | -5x | -
- method =- |
- ||
| 93 | -5x | -
- glue::glue("Wilson Confidence Interval {ifelse(correct, 'with', 'without')} continuity correction")
- |
- ||
| 94 | -- |
- )- |
- ||
| 95 | -+ | 192 | +1018x |
- )+ return(x) |
| 96 | +193 |
- }+ } |
||
| 97 | +194 | |||
| 98 | -+ | |||
| 195 | +1126x |
- #' @describeIn proportion_ci Calculates the Clopper-Pearson interval by calling [stats::binom.test()].+ ifelse( |
||
| 99 | -+ | |||
| 196 | +1126x |
- #' Also referred to as the `exact` method.+ make.names(x) != x & !str_detect(x, "^`.*`$"), |
||
| 100 | -+ | |||
| 197 | +1126x |
- #'+ paste0("`", x, "`"),
|
||
| 101 | -+ | |||
| 198 | +1126x |
- #' \deqn{
+ x |
||
| 102 | +199 |
- #' \left( \frac{k}{n} \pm z_{\alpha/2} \sqrt{\frac{\frac{k}{n}(1-\frac{k}{n})}{n} +
+ ) |
||
| 103 | +200 |
- #' \frac{z^2_{\alpha/2}}{4n^2}} \right)
+ } |
||
| 104 | +201 |
- #' / \left( 1 + \frac{z^2_{\alpha/2}}{n} \right)}
+
|
||
| 105 | +202 |
- #'+ #' @rdname construction_helpers |
||
| 106 | +203 |
#' @export |
||
| 107 | +204 |
- proportion_ci_clopper_pearson <- function(x, conf.level = 0.95) {
+ bt_strip <- function(x) {
|
||
| 108 | -2x | +205 | +1x |
- cards::check_pkg_installed("broom", reference_pkg = "cardx")
+ ifelse( |
| 109 | -+ | |||
| 206 | +1x |
- # check inputs ---------------------------------------------------------------+ str_detect(x, "^`.*`$"), |
||
| 110 | -2x | +207 | +1x |
- check_not_missing(x)+ substr(x, 2, nchar(x) - 1), |
| 111 | -2x | +208 | +1x |
- check_binary(x)+ x |
| 112 | -2x | +|||
| 209 | +
- check_range(conf.level, range = c(0, 1), include_bounds = c(FALSE, FALSE))+ ) |
|||
| 113 | -2x | +|||
| 210 | +
- check_scalar(conf.level)+ } |
|||
| 114 | +211 | |||
| 115 | -2x | +|||
| 212 | +
- x <- stats::na.omit(x)+ check_not_namespaced <- function(x, |
|||
| 116 | -2x | +|||
| 213 | +
- n <- length(x)+ arg_name = rlang::caller_arg(x), |
|||
| 117 | +214 |
-
+ class = "check_not_namespaced",+ |
+ ||
| 215 | ++ |
+ call = get_cli_abort_call()) {
|
||
| 118 | -2x | +216 | +23x |
- y <- stats::binom.test(x = sum(x), n = n, conf.level = conf.level)+ check_string(x, arg_name = arg_name, call = call, class = "check_not_namespaced") |
| 119 | +217 | |||
| 120 | -2x | +218 | +23x |
- list(N = n, conf.level = conf.level) |>+ if (str_detect(x, "::")) {
|
| 121 | -2x | +219 | +3x |
- utils::modifyList(val = broom::tidy(y) |> as.list()) |>+ cli::cli_abort( |
| 122 | -2x | +220 | +3x |
- utils::modifyList(list(method = "Clopper-Pearson Confidence Interval"))+ "Argument {.arg {arg_name}} cannot be namespaced when passed as a {.cls string}.",
|
| 123 | -+ | |||
| 221 | +3x |
- }+ call = call, |
||
| 124 | -+ | |||
| 222 | +3x |
-
+ class = class |
||
| 125 | +223 |
- #' @describeIn proportion_ci Calculates the `Agresti-Coull` interval (created by `Alan Agresti` and `Brent Coull`) by+ ) |
||
| 126 | +224 |
- #' (for 95% CI) adding two successes and two failures to the data and then using the Wald formula to construct a CI.+ } |
||
| 127 | +225 |
- #'+ |
||
| 128 | -+ | |||
| 226 | +20x |
- #' \deqn{
+ invisible(x) |
||
| 129 | +227 |
- #' \left( \frac{\tilde{p} + z^2_{\alpha/2}/2}{n + z^2_{\alpha/2}} \pm
+ } |
||
| 130 | +228 |
- #' z_{\alpha/2} \sqrt{\frac{\tilde{p}(1 - \tilde{p})}{n} +
+
|
||
| 131 | +229 |
- #' \frac{z^2_{\alpha/2}}{4n^2}} \right)}
+
|
||
| 132 | +230 |
- #'+ check_string_or_function <- function(x, |
||
| 133 | +231 |
- #' @export+ arg_name = rlang::caller_arg(x), |
||
| 134 | +232 |
- proportion_ci_agresti_coull <- function(x, conf.level = 0.95) {
+ class = "check_string_or_function", |
||
| 135 | +233 |
- # check inputs ---------------------------------------------------------------+ call = get_cli_abort_call()) {
|
||
| 136 | -2x | +234 | +26x |
- check_not_missing(x)+ if (!is.function(x) && !is_string(x)) {
|
| 137 | -2x | +235 | +1x |
- check_binary(x)+ cli::cli_abort( |
| 138 | -2x | +236 | +1x |
- check_range(conf.level, range = c(0, 1), include_bounds = c(FALSE, FALSE))+ c("Argument {.arg {arg_name}} must be a {.cls string} or {.cls function}."),
|
| 139 | -2x | -
- check_scalar(conf.level)- |
- ||
| 140 | -+ | 237 | +1x |
-
+ call = call, |
| 141 | -2x | +238 | +1x |
- x <- stats::na.omit(x)+ class = class |
| 142 | +239 | - - | -||
| 143 | -2x | -
- n <- length(x)- |
- ||
| 144 | -2x | -
- x_sum <- sum(x)- |
- ||
| 145 | -2x | -
- z <- stats::qnorm((1 + conf.level) / 2)+ ) |
||
| 146 | +240 |
-
+ } |
||
| 147 | +241 |
- # Add here both z^2 / 2 successes and failures.+ |
||
| 148 | -2x | +242 | +25x |
- x_sum_tilde <- x_sum + z^2 / 2+ invisible(x) |
| 149 | -2x | +|||
| 243 | +
- n_tilde <- n + z^2+ } |
|||
| 150 | +244 | |||
| 151 | +245 |
- # Then proceed as with the Wald interval.+ truncate_call <- function(call, max_out = 100) {
|
||
| 152 | -2x | +246 | +3x |
- p_tilde <- x_sum_tilde / n_tilde+ call_text <- expr_text(call) |
| 153 | -2x | +247 | +3x |
- q_tilde <- 1 - p_tilde+ if (nchar(call_text) > max_out) {
|
| 154 | -2x | +|||
| 248 | +! |
- err <- z * sqrt(p_tilde * q_tilde) / sqrt(n_tilde)+ call_text <- paste(substr(call_text, 1, max_out), "...") |
||
| 155 | -2x | +|||
| 249 | +
- l_ci <- max(0, p_tilde - err)+ } |
|||
| 156 | -2x | +250 | +3x |
- u_ci <- min(1, p_tilde + err)+ call_text |
| 157 | +251 |
-
+ } |
||
| 158 | -2x | +
| 1 | +
- list(+ #' ARD ANOVA from car Package |
|||
| 159 | -2x | +|||
| 2 | +
- N = n,+ #' |
|||
| 160 | -2x | +|||
| 3 | +
- estimate = mean(x),+ #' Function takes a regression model object and calculated ANOVA using [`car::Anova()`]. |
|||
| 161 | -2x | +|||
| 4 | +
- conf.low = l_ci,+ #' |
|||
| 162 | -2x | +|||
| 5 | +
- conf.high = u_ci,+ #' @param x regression model object |
|||
| 163 | -2x | +|||
| 6 | +
- conf.level = conf.level,+ #' @param ... arguments passed to `car::Anova(...)` |
|||
| 164 | -2x | +|||
| 7 | +
- method = "Agresti-Coull Confidence Interval"+ #' |
|||
| 165 | +8 |
- )+ #' @return data frame |
||
| 166 | +9 |
- }+ #' @export |
||
| 167 | +10 |
-
+ #' |
||
| 168 | +11 |
- #' @describeIn proportion_ci Calculates the Jeffreys interval, an equal-tailed interval based on the+ #' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = c("broom.helpers", "car", "parameters")))
|
||
| 169 | +12 |
- #' non-informative Jeffreys prior for a binomial proportion.+ #' lm(AGE ~ ARM, data = cards::ADSL) |> |
||
| 170 | +13 |
- #'+ #' ard_car_anova() |
||
| 171 | +14 |
- #' \deqn{\left( \text{Beta}\left(\frac{k}{2} + \frac{1}{2}, \frac{n - k}{2} + \frac{1}{2}\right)_\alpha,
+ #' |
||
| 172 | +15 |
- #' \text{Beta}\left(\frac{k}{2} + \frac{1}{2}, \frac{n - k}{2} + \frac{1}{2}\right)_{1-\alpha} \right)}
+ #' glm(vs ~ factor(cyl) + factor(am), data = mtcars, family = binomial) |> |
||
| 173 | +16 |
- #'+ #' ard_car_anova(test.statistic = "Wald") |
||
| 174 | +17 |
- #' @export+ ard_car_anova <- function(x, ...) {
|
||
| 175 | -+ | |||
| 18 | +3x |
- proportion_ci_jeffreys <- function(x, conf.level = 0.95) {
+ set_cli_abort_call() |
||
| 176 | +19 |
- # check inputs ---------------------------------------------------------------+ |
||
| 177 | -2x | +|||
| 20 | +
- check_not_missing(x)+ # check installed packages --------------------------------------------------- |
|||
| 178 | -2x | +21 | +3x |
- check_binary(x)+ check_pkg_installed(pkg = c("broom.helpers", "car", "parameters"))
|
| 179 | -2x | +|||
| 22 | +
- check_range(conf.level, range = c(0, 1), include_bounds = c(FALSE, FALSE))+ |
|||
| 180 | -2x | +|||
| 23 | +
- check_scalar(conf.level)+ # check inputs --------------------------------------------------------------- |
|||
| 181 | -2x | +24 | +3x |
- x <- stats::na.omit(x)+ check_not_missing(x) |
| 182 | +25 | |||
| 183 | -2x | +|||
| 26 | +
- n <- length(x)+ # run car::Anova() ----------------------------------------------------------- |
|||
| 184 | -2x | +27 | +3x |
- x_sum <- sum(x)+ car_anova <- cards::eval_capture_conditions(car::Anova(x, ...)) |
| 185 | +28 | |||
| 186 | -2x | +29 | +3x |
- alpha <- 1 - conf.level+ if (!is.null(car_anova[["error"]])) {
|
| 187 | -2x | +30 | +1x |
- l_ci <- ifelse(+ cli::cli_abort( |
| 188 | -2x | +31 | +1x |
- x_sum == 0,+ c( |
| 189 | -2x | +32 | +1x |
- 0,+ "There was an error running {.fun car::Anova}. See error message below.",
|
| 190 | -2x | +33 | +1x |
- stats::qbeta(alpha / 2, x_sum + 0.5, n - x_sum + 0.5)+ x = car_anova[["error"]] |
| 191 | +34 |
- )+ ),+ |
+ ||
| 35 | +1x | +
+ call = get_cli_abort_call() |
||
| 192 | +36 | ++ |
+ )+ |
+ |
| 37 | ++ |
+ }+ |
+ ||
| 38 | ||||
| 193 | +39 | 2x |
- u_ci <- ifelse(+ car_anova[["result"]] |> |
|
| 194 | +40 | 2x |
- x_sum == n,+ broom.helpers::tidy_parameters(conf.int = FALSE) |> # using broom.helpers, because it handle non-syntactic names for us |
|
| 195 | +41 | 2x |
- 1,+ dplyr::filter(!(dplyr::row_number() == dplyr::n() & .data$term %in% "Residuals")) |> # removing Residual rows |
|
| 196 | +42 | 2x |
- stats::qbeta(1 - alpha / 2, x_sum + 0.5, n - x_sum + 0.5)+ dplyr::rename(variable = "term") |> |
|
| 197 | -+ | |||
| 43 | +2x |
- )+ tidyr::pivot_longer( |
||
| 198 | -+ | |||
| 44 | +2x |
-
+ cols = -"variable", |
||
| 199 | +45 | 2x |
- list(+ names_to = "stat_name", |
|
| 200 | +46 | 2x |
- N = n,+ values_to = "stat"+ |
+ |
| 47 | ++ |
+ ) |> |
||
| 201 | +48 | 2x |
- estimate = mean(x),+ dplyr::mutate( |
|
| 202 | +49 | 2x |
- conf.low = l_ci,+ stat = as.list(.data$stat), |
|
| 203 | +50 | 2x |
- conf.high = u_ci,+ stat_label = |
|
| 204 | +51 | 2x |
- conf.level = conf.level,+ dplyr::case_when( |
|
| 205 | +52 | 2x |
- method = glue::glue("Jeffreys Interval")
+ .data$stat_name %in% "statistic" ~ "Statistic", |
|
| 206 | -+ | |||
| 53 | +2x |
- )+ .data$stat_name %in% "df" ~ "Degrees of Freedom", |
||
| 207 | -+ | |||
| 54 | +2x |
- }+ .data$stat_name %in% "p.value" ~ "p-value", |
||
| 208 | -+ | |||
| 55 | +2x |
-
+ TRUE ~ .data$stat_name |
||
| 209 | +56 |
-
+ ), |
||
| 210 | -+ | |||
| 57 | +2x |
- #' @describeIn proportion_ci Calculates the stratified Wilson confidence+ fmt_fn = |
||
| 211 | -+ | |||
| 58 | +2x |
- #' interval for unequal proportions as described in+ map( |
||
| 212 | -+ | |||
| 59 | +2x |
- #' Xin YA, Su XG. Stratified Wilson and Newcombe confidence intervals+ .data$stat, |
||
| 213 | -+ | |||
| 60 | +2x |
- #' for multiple binomial proportions. _Statistics in Biopharmaceutical Research_. 2010;2(3).+ function(.x) {
|
||
| 214 | +61 |
- #'+ # styler: off |
||
| 215 | -+ | |||
| 62 | +! |
- #' \deqn{\frac{\hat{p}_j + \frac{z^2_{\alpha/2}}{2n_j} \pm
+ if (is.integer(.x)) return(0L) |
||
| 216 | -+ | |||
| 63 | +12x |
- #' z_{\alpha/2} \sqrt{\frac{\hat{p}_j(1 - \hat{p}_j)}{n_j} +
+ if (is.numeric(.x)) return(1L) |
||
| 217 | +64 |
- #' \frac{z^2_{\alpha/2}}{4n_j^2}}}{1 + \frac{z^2_{\alpha/2}}{n_j}}}
+ # styler: on |
||
| 218 | -+ | |||
| 65 | +! |
- #'+ NULL |
||
| 219 | +66 |
- #'+ } |
||
| 220 | +67 |
- #' @param strata (`factor`)\cr variable with one level per stratum and same length as `x`.+ ), |
||
| 221 | -+ | |||
| 68 | +2x |
- #' @param weights (`numeric` or `NULL`)\cr weights for each level of the strata. If `NULL`, they are+ context = "car_anova", |
||
| 222 | -+ | |||
| 69 | +2x |
- #' estimated using the iterative algorithm that+ warning = car_anova["warning"], |
||
| 223 | -+ | |||
| 70 | +2x |
- #' minimizes the weighted squared length of the confidence interval.+ error = car_anova["error"] |
||
| 224 | +71 |
- #' @param max.iterations (`count`)\cr maximum number of iterations for the iterative procedure used+ ) |> |
||
| 225 | -+ | |||
| 72 | +2x |
- #' to find estimates of optimal weights.+ cards::as_card() |> |
||
| 226 | -+ | |||
| 73 | +2x |
- #' @param correct (`flag`)\cr include the continuity correction. For further information, see for example+ cards::tidy_ard_column_order() |
||
| 227 | +74 |
- #' [stats::prop.test()].+ } |
||
| 228 | +
| 1 |
- #'+ #' ARD Continuous Survey Statistics |
|||
| 229 | +2 |
- #' @examples+ #' |
||
| 230 | +3 |
- #' # Stratified Wilson confidence interval with unequal probabilities+ #' Returns an ARD of weighted statistics using the `{survey}` package.
|
||
| 231 | +4 |
#' |
||
| 232 | +5 |
- #' set.seed(1)+ #' @param data (`survey.design`)\cr |
||
| 233 | +6 |
- #' rsp <- sample(c(TRUE, FALSE), 100, TRUE)+ #' a design object often created with [`survey::svydesign()`]. |
||
| 234 | +7 |
- #' strata_data <- data.frame(+ #' @param variables ([`tidy-select`][dplyr::dplyr_tidy_select])\cr |
||
| 235 | +8 |
- #' "f1" = sample(c("a", "b"), 100, TRUE),
+ #' columns to include in summaries. |
||
| 236 | +9 |
- #' "f2" = sample(c("x", "y", "z"), 100, TRUE),
+ #' @param by ([`tidy-select`][dplyr::dplyr_tidy_select])\cr |
||
| 237 | +10 |
- #' stringsAsFactors = TRUE+ #' results are calculated for **all combinations** of the columns specified, |
||
| 238 | +11 |
- #' )+ #' including unobserved combinations and unobserved factor levels. |
||
| 239 | +12 |
- #' strata <- interaction(strata_data)+ #' @param statistic ([`formula-list-selector`][cards::syntax])\cr |
||
| 240 | +13 |
- #' n_strata <- ncol(table(rsp, strata)) # Number of strata+ #' a named list, a list of formulas, |
||
| 241 | +14 |
- #'+ #' or a single formula where the list element is a character vector of |
||
| 242 | +15 |
- #' proportion_ci_strat_wilson(+ #' statistic names to include. See below for options. |
||
| 243 | +16 |
- #' x = rsp, strata = strata,+ #' @param fmt_fn ([`formula-list-selector`][cards::syntax])\cr |
||
| 244 | +17 |
- #' conf.level = 0.90+ #' a named list, a list of formulas, |
||
| 245 | +18 |
- #' )+ #' or a single formula where the list element is a named list of functions |
||
| 246 | +19 |
- #'+ #' (or the RHS of a formula), |
||
| 247 | +20 |
- #' # Not automatic setting of weights+ #' e.g. `list(mpg = list(mean = \(x) round(x, digits = 2) |> as.character))`. |
||
| 248 | +21 |
- #' proportion_ci_strat_wilson(+ #' @param stat_label ([`formula-list-selector`][cards::syntax])\cr |
||
| 249 | +22 |
- #' x = rsp, strata = strata,+ #' a named list, a list of formulas, or a single formula where |
||
| 250 | +23 |
- #' weights = rep(1 / n_strata, n_strata),+ #' the list element is either a named list or a list of formulas defining the |
||
| 251 | +24 |
- #' conf.level = 0.90+ #' statistic labels, e.g. `everything() ~ list(mean = "Mean", sd = "SD")` or |
||
| 252 | +25 |
- #' )+ #' `everything() ~ list(mean ~ "Mean", sd ~ "SD")`. |
||
| 253 | +26 |
- #'+ #' @inheritParams rlang::args_dots_empty |
||
| 254 | +27 |
- #' @export+ #' |
||
| 255 | +28 |
- proportion_ci_strat_wilson <- function(x,+ #' @section statistic argument: |
||
| 256 | +29 |
- strata,+ #' |
||
| 257 | +30 |
- weights = NULL,+ #' The following statistics are available: |
||
| 258 | +31 |
- conf.level = 0.95,+ #' `r cardx:::accepted_svy_stats(FALSE) |> shQuote("sh") |> paste(collapse = ", ")`,
|
||
| 259 | +32 |
- max.iterations = 10L,+ #' where 'p##' is are the percentiles and `##` is an integer between 0 and 100. |
||
| 260 | +33 |
- correct = FALSE) {
+ #' |
||
| 261 | +34 |
- # check inputs ---------------------------------------------------------------- |
- ||
| 262 | -2x | -
- check_not_missing(x)- |
- ||
| 263 | -2x | -
- check_not_missing(strata)+ #' |
||
| 264 | -2x | +|||
| 35 | +
- check_binary(x)+ #' @return an ARD data frame of class 'card' |
|||
| 265 | -2x | +|||
| 36 | +
- check_class(correct, "logical")+ #' @export |
|||
| 266 | -2x | +|||
| 37 | +
- check_scalar(correct)+ #' |
|||
| 267 | -2x | +|||
| 38 | +
- check_class(strata, "factor")+ #' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = "survey"))
|
|||
| 268 | -2x | +|||
| 39 | +
- check_range(conf.level, range = c(0, 1), include_bounds = c(FALSE, FALSE))+ #' data(api, package = "survey") |
|||
| 269 | -2x | +|||
| 40 | +
- check_scalar(conf.level)+ #' dclus1 <- survey::svydesign(id = ~dnum, weights = ~pw, data = apiclus1, fpc = ~fpc) |
|||
| 270 | +41 |
-
+ #' |
||
| 271 | +42 |
- # remove missing values from x and strata+ #' ard_continuous( |
||
| 272 | -2x | +|||
| 43 | +
- is_na <- is.na(x) | is.na(strata)+ #' data = dclus1, |
|||
| 273 | -2x | +|||
| 44 | +
- x <- x[!is_na]+ #' variables = api00, |
|||
| 274 | -2x | +|||
| 45 | +
- strata <- strata[!is_na]+ #' by = stype |
|||
| 275 | -! | +|||
| 46 | +
- if (!inherits(x, "logical")) x <- as.logical(x)+ #' ) |
|||
| 276 | +47 |
- # check all TRUE/FALSE, if so, not calculable+ ard_continuous.survey.design <- function(data, variables, by = NULL, |
||
| 277 | -2x | +|||
| 48 | +
- if (all(x) || all(!x)) {
+ statistic = everything() ~ c("median", "p25", "p75"),
|
|||
| 278 | -! | +|||
| 49 | +
- cli::cli_abort("All values in {.arg x} argument are either {.code TRUE} or {.code FALSE} and CI is not estimable.")
+ fmt_fn = NULL, |
|||
| 279 | +50 |
- }+ stat_label = NULL, |
||
| 280 | +51 |
-
+ ...) {
|
||
| 281 | -2x | +52 | +49x |
- tbl <- table(factor(x, levels = c(FALSE, TRUE)), strata, useNA = "no")+ set_cli_abort_call() |
| 282 | -2x | +53 | +49x |
- n_strata <- length(unique(strata))+ check_dots_empty() |
| 283 | +54 | |||
| 284 | +55 |
- # Checking the weights and maximum number of iterations.+ # check installed packages --------------------------------------------------- |
||
| 285 | -2x | +56 | +49x |
- do_iter <- FALSE+ check_pkg_installed(pkg = "survey") |
| 286 | -2x | -
- if (is.null(weights)) {
+ | ||
| 57 | ++ | + | ||
| 287 | -! | +|||
| 58 | +
- weights <- rep(1 / n_strata, n_strata) # Initialization for iterative procedure+ # check inputs --------------------------------------------------------------- |
|||
| 288 | -! | +|||
| 59 | +49x |
- do_iter <- TRUE+ check_not_missing(variables) |
||
| 289 | +60 | |||
| 290 | +61 |
- # Iteration parameters+ # process inputs ------------------------------------------------------------- |
||
| 291 | -! | +|||
| 62 | +49x |
- if (!is_scalar_integerish(max.iterations) || max.iterations < 1) {
+ cards::process_selectors(data$variables, variables = {{ variables }}, by = {{ by }})
|
||
| 292 | -! | +|||
| 63 | +49x |
- cli::cli_abort("Argument {.arg max.iterations} must be a positive integer.")
+ variables <- setdiff(variables, by) |
||
| 293 | -+ | |||
| 64 | +49x |
- }+ check_na_factor_levels(data$variables, by) |
||
| 294 | +65 |
- }+ |
||
| 295 | -2x | +66 | +49x |
- check_range(weights, range = c(0, 1), include_bounds = c(TRUE, TRUE))+ cards::process_formula_selectors( |
| 296 | -2x | +67 | +49x |
- sum_weights <- sum(weights) |>+ data$variables[variables], |
| 297 | -2x | +68 | +49x |
- round() |>+ statistic = statistic, |
| 298 | -2x | +69 | +49x |
- as.integer()+ fmt_fn = fmt_fn, |
| 299 | -2x | -
- if (sum_weights != 1L || abs(sum_weights - sum(weights)) > sqrt(.Machine$double.eps)) {
- |
- ||
| 300 | -! | +70 | +49x |
- cli::cli_abort("The sum of the {.arg weights} argument must be {.val {1L}}")
+ stat_label = stat_label |
| 301 | +71 |
- }+ ) |
||
| 302 | -+ | |||
| 72 | +49x |
-
+ cards::fill_formula_selectors( |
||
| 303 | -2x | +73 | +49x |
- xs <- tbl["TRUE", ]+ data$variables[variables], |
| 304 | -2x | +74 | +49x |
- ns <- colSums(tbl)+ statistic = formals(asNamespace("cardx")[["ard_continuous.survey.design"]])[["statistic"]] |> eval()
+ |
+
| 75 | ++ |
+ ) |
||
| 305 | -2x | +76 | +49x |
- use_stratum <- (ns > 0)+ cards::check_list_elements( |
| 306 | -2x | +77 | +49x |
- ns <- ns[use_stratum]+ x = statistic, |
| 307 | -2x | +78 | +49x |
- xs <- xs[use_stratum]+ predicate = \(x) all(x %in% accepted_svy_stats()), |
| 308 | -2x | +79 | +49x |
- ests <- xs / ns+ error_msg = c("Error in the values of the {.arg statistic} argument for variable {.val {variable}}.",
|
| 309 | -2x | +80 | +49x |
- vars <- ests * (1 - ests) / ns+ i = "Values must be in {.val {cardx:::accepted_svy_stats(FALSE)}}"
|
| 310 | +81 |
-
+ ) |
||
| 311 | -2x | +|||
| 82 | +
- strata_qnorm <- .strata_normal_quantile(vars, weights, conf.level)+ ) |
|||
| 312 | +83 | |||
| 313 | +84 |
- # Iterative setting of weights if they were not passed in `weights` argument+ # return empty ARD if no variables selected ---------------------------------- |
||
| 314 | -2x | +85 | +49x |
- weights_new <- if (do_iter) {
+ if (is_empty(variables)) {
|
| 315 | +86 | ! |
- .update_weights_strat_wilson(vars, strata_qnorm, weights, ns, max.iterations, conf.level)$weights+ return(dplyr::tibble() |> cards::as_card()) |
|
| 316 | +87 |
- } else {
- |
- ||
| 317 | -2x | -
- weights+ } |
||
| 318 | +88 |
- }+ |
||
| 319 | +89 |
-
+ # compute the weighted statistics -------------------------------------------- |
||
| 320 | -2x | -
- strata_conf.level <- 2 * stats::pnorm(strata_qnorm) - 1- |
- ||
| 321 | -+ | 90 | +49x |
-
+ df_stats <- |
| 322 | -2x | +91 | +49x |
- ci_by_strata <- Map(+ map( |
| 323 | -2x | +92 | +49x |
- function(x, n) {
+ names(statistic), |
| 324 | -+ | |||
| 93 | +49x |
- # Classic Wilson's confidence interval+ function(variable) {
|
||
| 325 | -12x | +94 | +90x |
- suppressWarnings(stats::prop.test(x, n, correct = correct, conf.level = strata_conf.level)$conf.int)+ map( |
| 326 | -+ | |||
| 95 | +90x |
- },+ statistic[[variable]], |
||
| 327 | -2x | +96 | +90x |
- x = xs,+ function(statistic) {
|
| 328 | -2x | +97 | +318x |
- n = ns+ .compute_svy_stat(data, variable = variable, by = by, stat_name = statistic) |
| 329 | +98 |
- )+ } |
||
| 330 | -2x | +|||
| 99 | +
- lower_by_strata <- sapply(ci_by_strata, "[", 1L)+ ) |
|||
| 331 | -2x | +|||
| 100 | +
- upper_by_strata <- sapply(ci_by_strata, "[", 2L)+ } |
|||
| 332 | +101 |
-
+ ) |> |
||
| 333 | -2x | +102 | +49x |
- lower <- sum(weights_new * lower_by_strata)+ dplyr::bind_rows() |
| 334 | -2x | +|||
| 103 | +
- upper <- sum(weights_new * upper_by_strata)+ |
|||
| 335 | +104 | |||
| 336 | +105 |
- # Return values+ # add stat_labels ------------------------------------------------------------ |
||
| 337 | -2x | +106 | +49x |
- list(+ df_stats <- |
| 338 | -2x | +107 | +49x |
- N = length(x),+ df_stats |> |
| 339 | -2x | +108 | +49x |
- estimate = mean(x),+ dplyr::left_join( |
| 340 | -2x | +109 | +49x |
- conf.low = lower,+ .default_svy_stat_labels(), |
| 341 | -2x | +110 | +49x |
- conf.high = upper,+ by = "stat_name"+ |
+
| 111 | ++ |
+ ) |> |
||
| 342 | -2x | +112 | +49x |
- conf.level = conf.level,+ dplyr::mutate(stat_label = dplyr::coalesce(.data$stat_label, .data$stat_name)) |
| 343 | -2x | +113 | +49x |
- weights = if (do_iter) weights_new else NULL,+ if (!is_empty(stat_label)) {
|
| 344 | -2x | +114 | +1x |
- method =+ df_stats <- |
| 345 | -2x | +115 | +1x |
- glue::glue("Stratified Wilson Confidence Interval {ifelse(correct, 'with', 'without')} continuity correction")
+ dplyr::rows_update( |
| 346 | -+ | |||
| 116 | +1x |
- ) |>+ df_stats, |
||
| 347 | -2x | +117 | +1x |
- compact()+ dplyr::tibble( |
| 348 | -+ | |||
| 118 | +1x |
- }+ variable = names(stat_label), |
||
| 349 | -+ | |||
| 119 | +1x |
-
+ stat_name = map(.data$variable, ~ names(stat_label[[.x]])), |
||
| 350 | -+ | |||
| 120 | +1x |
- #' Helper Function for the Estimation of Stratified Quantiles+ stat_label = map(.data$variable, ~ stat_label[[.x]] |> |
||
| 351 | -+ | |||
| 121 | +1x |
- #'+ unname() |> |
||
| 352 | -+ | |||
| 122 | +1x |
- #' This function wraps the estimation of stratified percentiles when we assume+ unlist()) |
||
| 353 | +123 |
- #' the approximation for large numbers. This is necessary only in the case+ ) |> |
||
| 354 | -+ | |||
| 124 | +1x |
- #' proportions for each strata are unequal.+ tidyr::unnest(cols = c("stat_name", "stat_label")),
|
||
| 355 | -+ | |||
| 125 | +1x |
- #'+ by = c("variable", "stat_name"),
|
||
| 356 | -+ | |||
| 126 | +1x |
- #' @inheritParams proportion_ci_strat_wilson+ unmatched = "ignore" |
||
| 357 | +127 |
- #'+ ) |
||
| 358 | +128 |
- #' @return Stratified quantile.+ } |
||
| 359 | +129 |
- #'+ |
||
| 360 | +130 |
- #' @seealso [proportion_ci_strat_wilson()]+ # add formatting stats ------------------------------------------------------- |
||
| 361 | -+ | |||
| 131 | +49x |
- #'+ df_stats$fmt_fn <- list(1L) |
||
| 362 | -+ | |||
| 132 | +49x |
- #' @keywords internal+ if (!is_empty(fmt_fn)) {
|
||
| 363 | -+ | |||
| 133 | +1x |
- #' @examples+ df_stats <- |
||
| 364 | -+ | |||
| 134 | +1x |
- #' strata_data <- table(data.frame(+ dplyr::rows_update( |
||
| 365 | -+ | |||
| 135 | +1x |
- #' "f1" = sample(c(TRUE, FALSE), 100, TRUE),+ df_stats, |
||
| 366 | -+ | |||
| 136 | +1x |
- #' "f2" = sample(c("x", "y", "z"), 100, TRUE),
+ dplyr::tibble( |
||
| 367 | -+ | |||
| 137 | +1x |
- #' stringsAsFactors = TRUE+ variable = names(fmt_fn), |
||
| 368 | -+ | |||
| 138 | +1x |
- #' ))+ stat_name = map(.data$variable, ~ names(fmt_fn[[.x]])), |
||
| 369 | -+ | |||
| 139 | +1x |
- #' ns <- colSums(strata_data)+ fmt_fn = map(.data$variable, ~ fmt_fn[[.x]] |> unname()) |
||
| 370 | +140 |
- #' ests <- strata_data["TRUE", ] / ns+ ) |> |
||
| 371 | -+ | |||
| 141 | +1x |
- #' vars <- ests * (1 - ests) / ns+ tidyr::unnest(cols = c("stat_name", "fmt_fn")),
+ |
+ ||
| 142 | +1x | +
+ by = c("variable", "stat_name"),
+ |
+ ||
| 143 | +1x | +
+ unmatched = "ignore" |
||
| 372 | +144 |
- #' weights <- rep(1 / length(ns), length(ns))+ ) |
||
| 373 | +145 |
- #'+ } |
||
| 374 | +146 |
- #' cardx:::.strata_normal_quantile(vars, weights, 0.95)+ |
||
| 375 | +147 |
- .strata_normal_quantile <- function(vars, weights, conf.level) {
+ # add class and return ARD object -------------------------------------------- |
||
| 376 | -2x | +148 | +49x |
- summands <- weights^2 * vars+ df_stats |> |
| 377 | -+ | |||
| 149 | +49x |
- # Stratified quantile+ dplyr::mutate(context = "continuous") |> |
||
| 378 | -2x | +150 | +49x |
- sqrt(sum(summands)) / sum(sqrt(summands)) * stats::qnorm((1 + conf.level) / 2)+ cards::as_card() |>+ |
+
| 151 | +49x | +
+ cards::tidy_ard_column_order() |
||
| 379 | +152 |
} |
||
| 380 | +153 | |||
| 381 | +154 |
- #' Helper Function for the Estimation of Weights for `proportion_ci_strat_wilson()`+ .default_svy_stat_labels <- function(stat_label = NULL) {
|
||
| 382 | -- |
- #'- |
- ||
| 383 | -+ | |||
| 155 | +49x |
- #' This function wraps the iteration procedure that allows you to estimate+ dplyr::tribble( |
||
| 384 | -+ | |||
| 156 | +49x |
- #' the weights for each proportional strata. This assumes to minimize the+ ~stat_name, ~stat_label, |
||
| 385 | -+ | |||
| 157 | +49x |
- #' weighted squared length of the confidence interval.+ "mean", "Mean", |
||
| 386 | -+ | |||
| 158 | +49x |
- #'+ "median", "Median", |
||
| 387 | -+ | |||
| 159 | +49x |
- #' @keywords internal+ "var", "Variance", |
||
| 388 | -+ | |||
| 160 | +49x |
- #' @inheritParams proportion_ci_strat_wilson+ "sd", "Standard Deviation", |
||
| 389 | -+ | |||
| 161 | +49x |
- #' @param vars (`numeric`)\cr normalized proportions for each strata.+ "sum", "Sum", |
||
| 390 | -+ | |||
| 162 | +49x |
- #' @param strata_qnorm (`numeric`)\cr initial estimation with identical weights of the quantiles.+ "deff", "Design Effect", |
||
| 391 | -+ | |||
| 163 | +49x |
- #' @param initial_weights (`numeric`)\cr initial weights used to calculate `strata_qnorm`. This can+ "mean.std.error", "SE(Mean)", |
||
| 392 | -+ | |||
| 164 | +49x |
- #' be optimized in the future if we need to estimate better initial weights.+ "min", "Minimum", |
||
| 393 | -+ | |||
| 165 | +49x |
- #' @param n_per_strata (`numeric`)\cr number of elements in each strata.+ "max", "Maximum", |
||
| 394 | -+ | |||
| 166 | +49x |
- #' @param max.iterations (`count`)\cr maximum number of iterations to be tried. Convergence is always checked.+ "p25", "25% Percentile", |
||
| 395 | -+ | |||
| 167 | +49x |
- #' @param tol (`number`)\cr tolerance threshold for convergence.+ "p75", "75% Percentile" |
||
| 396 | +168 |
- #'+ ) |
||
| 397 | +169 |
- #' @return A `list` of 3 elements: `n_it`, `weights`, and `diff_v`.+ } |
||
| 398 | +170 |
- #'+ |
||
| 399 | +171 |
- #' @seealso For references and details see [`proportion_ci_strat_wilson()`].+ accepted_svy_stats <- function(expand_quantiles = TRUE) {
|
||
| 400 | -+ | |||
| 172 | +90x |
- #'+ base_stats <- |
||
| 401 | -+ | |||
| 173 | +90x |
- #' @examples+ c("mean", "median", "min", "max", "sum", "var", "sd", "mean.std.error", "deff")
|
||
| 402 | -+ | |||
| 174 | +90x |
- #' vs <- c(0.011, 0.013, 0.012, 0.014, 0.017, 0.018)+ if (expand_quantiles) {
|
||
| 403 | -+ | |||
| 175 | +90x |
- #' sq <- 0.674+ return(c(base_stats, paste0("p", 0:100)))
|
||
| 404 | +176 |
- #' ws <- rep(1 / length(vs), length(vs))+ } |
||
| 405 | -+ | |||
| 177 | +! |
- #' ns <- c(22, 18, 17, 17, 14, 12)+ c(base_stats, "p##") |
||
| 406 | +178 |
- #'+ } |
||
| 407 | +179 |
- #' cardx:::.update_weights_strat_wilson(vs, sq, ws, ns, 100, 0.95, 0.001)+ |
||
| 408 | +180 |
- .update_weights_strat_wilson <- function(vars,+ |
||
| 409 | +181 |
- strata_qnorm,+ |
||
| 410 | +182 |
- initial_weights,+ # this function calculates the summary for a single variable, single statistic |
||
| 411 | +183 |
- n_per_strata,+ # and for all `by` levels. it returns an ARD data frame |
||
| 412 | +184 |
- max.iterations = 50,+ .compute_svy_stat <- function(data, variable, by = NULL, stat_name) {
|
||
| 413 | +185 |
- conf.level = 0.95,+ # difftime variable needs to be transformed into numeric for svyquantile |
||
| 414 | -+ | |||
| 186 | +318x |
- tol = 0.001) {
+ if (inherits(data$variables[[variable]], "difftime")) {
|
||
| 415 | +187 | ! |
- it <- 0+ data$variables[[variable]] <- unclass(data$variables[[variable]]) |
|
| 416 | -! | +|||
| 188 | +
- diff_v <- NULL+ } |
|||
| 417 | +189 | |||
| 418 | -! | -
- while (it < max.iterations) {
- |
- ||
| 419 | -! | +|||
| 190 | +
- it <- it + 1+ # styler: off |
|||
| 420 | -! | +|||
| 191 | +12x |
- weights_new_t <- (1 + strata_qnorm^2 / n_per_strata)^2+ if (stat_name %in% "mean") args <- list(FUN = survey::svymean) |
||
| 421 | -! | +|||
| 192 | +6x |
- weights_new_b <- (vars + strata_qnorm^2 / (4 * n_per_strata^2))+ else if (stat_name %in% "sum") args <- list(FUN = survey::svytotal) |
||
| 422 | -! | +|||
| 193 | +6x |
- weights_new <- weights_new_t / weights_new_b+ else if (stat_name %in% "var") args <- list(FUN = survey::svyvar) |
||
| 423 | -! | +|||
| 194 | +6x |
- weights_new <- weights_new / sum(weights_new)+ else if (stat_name %in% "sd") args <- list(FUN = \(...) survey::svyvar(...) |> sqrt()) |
||
| 424 | -! | +|||
| 195 | +6x |
- strata_qnorm <- .strata_normal_quantile(vars, weights_new, conf.level)+ else if (stat_name %in% "mean.std.error") args <- list(FUN = \(...) survey::svymean(...) |> survey::SE()) |
||
| 425 | -! | +|||
| 196 | +6x |
- diff_v <- c(diff_v, sum(abs(weights_new - initial_weights)))+ else if (stat_name %in% "deff") args <- list(FUN = \(...) survey::svymean(..., deff = TRUE) |> survey::deff()) |
||
| 426 | -! | +|||
| 197 | +12x |
- if (diff_v[length(diff_v)] < tol) break+ else if (stat_name %in% "min") args <- list(FUN = \(x, design, na.rm, ...) min(design$variables[[all.vars(x)]], na.rm = na.rm)) |
||
| 427 | -! | +|||
| 198 | +12x |
- initial_weights <- weights_new+ else if (stat_name %in% "max") args <- list(FUN = \(x, design, na.rm, ...) max(design$variables[[all.vars(x)]], na.rm = na.rm)) |
||
| 428 | +199 |
- }+ # define functions for the quantiles |
||
| 429 | -- | - - | -||
| 430 | -! | -
- if (it == max.iterations) {
- |
- ||
| 431 | -! | +|||
| 200 | +252x |
- warning("The heuristic to find weights did not converge with max.iterations = ", max.iterations)
+ else if (stat_name %in% c("median", paste0("p", 0:100))) {
|
||
| 432 | -+ | |||
| 201 | +252x |
- }+ quantile <- ifelse(stat_name %in% "median", 0.5, as.numeric(substr(stat_name, 2, nchar(stat_name))) / 100) |
||
| 433 | +202 | - - | -||
| 434 | -! | -
- list(+ # univariate results are returned in a different format from stratified. |
||
| 435 | -! | +|||
| 203 | +252x |
- "n_it" = it,+ args <- |
||
| 436 | -! | +|||
| 204 | +252x |
- "weights" = weights_new,+ if (is_empty(by)) list(FUN = \(...) survey::svyquantile(...)[[1]], quantiles = quantile) |
||
| 437 | -! | +|||
| 205 | +252x |
- "diff_v" = diff_v+ else list(FUN = \(...) survey::svyquantile(...), quantiles = quantile) |
||
| 438 | +206 |
- )+ } |
||
| 439 | +207 |
- }+ # styler: on |
| 1 | +208 |
- #' ARD Hedge's G Test+ |
||
| 2 | +209 |
- #'+ # adding additional args to pass |
||
| 3 | -+ | |||
| 210 | +318x |
- #' @description+ args <- |
||
| 4 | -+ | |||
| 211 | +318x |
- #' Analysis results data for paired and non-paired Hedge's G Effect Size Test+ args |> |
||
| 5 | -+ | |||
| 212 | +318x |
- #' using [`effectsize::hedges_g()`].+ append( |
||
| 6 | -+ | |||
| 213 | +318x |
- #'+ list( |
||
| 7 | -+ | |||
| 214 | +318x |
- #' @param data (`data.frame`)\cr+ design = data, |
||
| 8 | +215 |
- #' a data frame. See below for details.+ # if all values are NA, turn na.rm to FALSE to avoid error |
||
| 9 | -+ | |||
| 216 | +318x |
- #' @param by ([`tidy-select`][dplyr::dplyr_tidy_select])\cr+ na.rm = !all(is.na(data$variables[[variable]])), |
||
| 10 | -+ | |||
| 217 | +318x |
- #' column name to compare by. Must be a categorical variable with exactly two levels.+ keep.var = FALSE |
||
| 11 | +218 |
- #' @param variables ([`tidy-select`][dplyr::dplyr_tidy_select])\cr+ ) |
||
| 12 | +219 |
- #' column names to be compared. Must be a continuous variable. Independent+ ) |
||
| 13 | +220 |
- #' tests will be run for each variable+ |
||
| 14 | +221 |
- #' @param id ([`tidy-select`][dplyr::dplyr_tidy_select])\cr+ |
||
| 15 | +222 |
- #' column name of the subject or participant ID+ # if no by variable, calculate univariate statistics |
||
| 16 | -+ | |||
| 223 | +318x |
- #' @param ... arguments passed to `effectsize::hedges_g(...)`+ if (is_empty(by)) {
|
||
| 17 | -+ | |||
| 224 | +46x |
- #'+ args$x <- reformulate2(variable) |
||
| 18 | +225 |
- #' @return ARD data frame+ # calculate statistic (and remove FUN from the argument list) |
||
| 19 | -+ | |||
| 226 | +46x |
- #' @name ard_hedges_g+ stat <- |
||
| 20 | -+ | |||
| 227 | +46x |
- #'+ cards::eval_capture_conditions( |
||
| 21 | -+ | |||
| 228 | +46x |
- #' @details+ do.call(args$FUN, args = args |> utils::modifyList(list(FUN = NULL))) |
||
| 22 | +229 |
- #' For the `ard_hedges_g()` function, the data is expected to be one row per subject.+ ) |
||
| 23 | +230 |
- #' The data is passed as `effectsize::hedges_g(data[[variable]]~data[[by]], data, paired = FALSE, ...)`.+ # if the result was calculated, then put it into a tibble |
||
| 24 | -+ | |||
| 231 | +46x |
- #'+ if (!is.null(stat[["result"]])) {
|
||
| 25 | -+ | |||
| 232 | +40x |
- #' For the `ard_paired_hedges_g()` function, the data is expected to be one row+ df_stat <- |
||
| 26 | -+ | |||
| 233 | +40x |
- #' per subject per by level. Before the effect size is calculated, the data are+ dplyr::tibble(variable, stat[["result"]][1]) |> |
||
| 27 | -+ | |||
| 234 | +40x |
- #' reshaped to a wide format to be one row per subject.+ set_names(c("variable", "stat")) |>
|
||
| 28 | -+ | |||
| 235 | +40x |
- #' The data are then passed as+ dplyr::mutate( |
||
| 29 | -+ | |||
| 236 | +40x |
- #' `effectsize::hedges_g(x = data_wide[[<by level 1>]], y = data_wide[[<by level 2>]], paired = TRUE, ...)`.+ stat = as.list(unname(.data$stat)), |
||
| 30 | -+ | |||
| 237 | +40x |
- #'+ warning = list(stat[["warning"]]), |
||
| 31 | -+ | |||
| 238 | +40x |
- #' @examplesIf cards::is_pkg_installed(c("effectsize", "parameters"), reference_pkg = "cardx")
+ error = list(stat[["error"]]) |
||
| 32 | +239 |
- #' cards::ADSL |>+ ) |
||
| 33 | +240 |
- #' dplyr::filter(ARM %in% c("Placebo", "Xanomeline High Dose")) |>
+ } |
||
| 34 | +241 |
- #' ard_hedges_g(by = ARM, variables = AGE)+ # otherwise, if there was an error return tibble with error message |
||
| 35 | +242 |
- #'+ else {
|
||
| 36 | -+ | |||
| 243 | +6x |
- #' # constructing a paired data set,+ df_stat <- |
||
| 37 | -+ | |||
| 244 | +6x |
- #' # where patients receive both treatments+ dplyr::tibble( |
||
| 38 | -+ | |||
| 245 | +6x |
- #' cards::ADSL[c("ARM", "AGE")] |>
+ variable = .env$variable, |
||
| 39 | -+ | |||
| 246 | +6x |
- #' dplyr::filter(ARM %in% c("Placebo", "Xanomeline High Dose")) |>
+ stat = list(NULL), |
||
| 40 | -+ | |||
| 247 | +6x |
- #' dplyr::mutate(.by = ARM, USUBJID = dplyr::row_number()) |>+ warning = list(.env$stat[["warning"]]), |
||
| 41 | -+ | |||
| 248 | +6x |
- #' dplyr::arrange(USUBJID, ARM) |>+ error = list(.env$stat[["error"]]) |
||
| 42 | +249 |
- #' dplyr::group_by(USUBJID) |>+ ) |
||
| 43 | +250 |
- #' dplyr::filter(dplyr::n() > 1) |>+ } |
||
| 44 | +251 |
- #' ard_paired_hedges_g(by = ARM, variables = AGE, id = USUBJID)+ } |
||
| 45 | +252 |
- NULL+ |
||
| 46 | +253 |
-
+ # if there is by variable(s), calculate statistics for the combinations |
||
| 47 | +254 |
- #' @rdname ard_hedges_g+ else {
|
||
| 48 | -+ | |||
| 255 | +272x |
- #' @export+ args$formula <- reformulate2(variable) |
||
| 49 | -+ | |||
| 256 | +272x |
- ard_hedges_g <- function(data, by, variables, ...) {
+ args$by <- reformulate2(by) |
||
| 50 | -+ | |||
| 257 | +272x |
- # check installed packages ---------------------------------------------------+ stat <- |
||
| 51 | -2x | +258 | +272x |
- cards::check_pkg_installed(c("effectsize", "parameters"), reference_pkg = "cardx")
+ if (stat_name %in% c("median", paste0("p", 0:100))) {
|
| 52 | -+ | |||
| 259 | +242x |
-
+ cards::eval_capture_conditions(+ |
+ ||
| 260 | +242x | +
+ do.call(survey::svyby, args) |> set_names(c(by, "quantile", "ci.2.5", "ci.97.5", "se")) |
||
| 53 | +261 |
- # check/process inputs -------------------------------------------------------+ ) |
||
| 54 | -2x | +262 | +272x |
- check_not_missing(data)+ } else if (stat_name %in% "deff") {
|
| 55 | -2x | +263 | +3x |
- check_not_missing(variables)+ stat <- |
| 56 | -2x | +264 | +3x |
- check_data_frame(data)+ cards::eval_capture_conditions( |
| 57 | -2x | +265 | +3x |
- data <- dplyr::ungroup(data)+ do.call( |
| 58 | -2x | +266 | +3x |
- cards::process_selectors(data, by = {{ by }}, variables = {{ variables }})
+ survey::svyby, |
| 59 | -2x | +267 | +3x |
- check_scalar(by)+ args |> utils::modifyList(list(FUN = survey::svymean, deff = TRUE)) |
| 60 | +268 |
-
+ ) |>+ |
+ ||
| 269 | +3x | +
+ dplyr::select(all_of(by), dplyr::last_col()) # the last column is DEff |
||
| 61 | +270 |
- # if no variables selected, return empty tibble ------------------------------+ ) |
||
| 62 | -2x | +|||
| 271 | +
- if (is_empty(variables)) {
+ } else {
|
|||
| 63 | -! | +|||
| 272 | +27x |
- return(dplyr::tibble())+ cards::eval_capture_conditions(do.call(survey::svyby, args)) |
||
| 64 | +273 |
- }+ } |
||
| 65 | +274 | |||
| 66 | +275 |
- # build ARD ------------------------------------------------------------------+ # if the result was calculated, then put it into a tibble |
||
| 67 | -2x | +276 | +272x |
- lapply(+ if (!is.null(stat[["result"]])) {
|
| 68 | -2x | +277 | +116x |
- variables,+ df_stat <- stat[["result"]][seq_len(length(by) + 1L)] |> |
| 69 | -2x | +278 | +116x |
- function(variable) {
+ dplyr::as_tibble() %>% |
| 70 | -2x | +|||
| 279 | +
- .format_hedges_g_results(+ # adding unobserved combinations of "by" variables |
|||
| 71 | -2x | +|||
| 280 | +
- by = by,+ {
|
|||
| 72 | -2x | +281 | +116x |
- variable = variable,+ dplyr::full_join( |
| 73 | -2x | +282 | +116x |
- lst_tidy =+ cards::nest_for_ard(data$variables, by = by, key = "...ard_no_one_will_ever_pick_this...", rename = FALSE, list_columns = FALSE) |> |
| 74 | -2x | +283 | +116x |
- cards::eval_capture_conditions(+ dplyr::select(-"...ard_no_one_will_ever_pick_this..."), |
| 75 | -2x | +|||
| 284 | +
- effectsize::hedges_g(data[[variable]] ~ data[[by]], paired = FALSE, ...) |>+ ., |
|||
| 76 | -2x | +285 | +116x |
- parameters::standardize_names(style = "broom")+ by = by |
| 77 | +286 |
- ),+ )+ |
+ ||
| 287 | ++ |
+ } |> |
||
| 78 | -2x | +288 | +116x |
- paired = FALSE,+ set_names(paste0("group", seq_along(by), "_level"), "stat") |>
|
| 79 | -+ | |||
| 289 | +116x |
- ...+ dplyr::bind_cols( |
||
| 80 | -+ | |||
| 290 | +116x |
- )+ dplyr::tibble(!!!c(by, variable)) |> |
||
| 81 | -+ | |||
| 291 | +116x |
- }+ set_names(paste0("group", seq_along(by)), "variable")
|
||
| 82 | +292 |
- ) |>+ ) |> |
||
| 83 | -2x | +293 | +116x |
- dplyr::bind_rows()+ dplyr::mutate( |
| 84 | -+ | |||
| 294 | +116x |
- }+ dplyr::across(c(cards::all_ard_groups("levels"), "stat"), as.list),
|
||
| 85 | -+ | |||
| 295 | +116x |
-
+ warning = list(.env$stat[["warning"]]),+ |
+ ||
| 296 | +116x | +
+ error = list(.env$stat[["error"]]) |
||
| 86 | +297 |
- #' @rdname ard_hedges_g+ ) |
||
| 87 | +298 |
- #' @export+ } |
||
| 88 | +299 |
- ard_paired_hedges_g <- function(data, by, variables, id, ...) {
+ # otherwise, if there was an error return tibble with error message |
||
| 89 | +300 |
- # check installed packages ---------------------------------------------------+ else {
|
||
| 90 | -2x | -
- cards::check_pkg_installed("effectsize", reference_pkg = "cardx")
- |
- ||
| 91 | -2x | -
- cards::check_pkg_installed("parameters", reference_pkg = "cardx")
- |
- ||
| 92 | -- | - - | -||
| 93 | -- |
- # check/process inputs -------------------------------------------------------- |
- ||
| 94 | -2x | -
- check_not_missing(data)- |
- ||
| 95 | -2x | +301 | +156x |
- check_not_missing(variables)+ df_stat <- |
| 96 | -2x | +302 | +156x |
- check_not_missing(by)+ cards::nest_for_ard(data$variables, by = by, key = "...ard_no_one_will_ever_pick_this...") |> |
| 97 | -2x | +303 | +156x |
- check_not_missing(id)+ dplyr::select(-"...ard_no_one_will_ever_pick_this...") |> |
| 98 | -2x | +304 | +156x |
- check_data_frame(data)+ dplyr::mutate( |
| 99 | -2x | +305 | +156x |
- data <- dplyr::ungroup(data)+ variable = .env$variable, |
| 100 | -2x | +306 | +156x |
- cards::process_selectors(data, by = {{ by }}, variables = {{ variables }}, id = {{ id }})
+ stat = list(NULL), |
| 101 | -2x | +307 | +156x |
- check_scalar(by)+ warning = list(.env$stat[["warning"]]), |
| 102 | -2x | +308 | +156x |
- check_scalar(id)+ error = list(.env$stat[["error"]]) |
| 103 | +309 |
-
+ ) |
||
| 104 | +310 |
- # if no variables selected, return empty tibble ------------------------------- |
- ||
| 105 | -2x | -
- if (is_empty(variables)) {
- |
- ||
| 106 | -! | -
- return(dplyr::tibble())+ } |
||
| 107 | +311 |
} |
||
| 108 | -- |
- # build ARD ------------------------------------------------------------------- |
- ||
| 109 | +312 | |||
| 110 | -2x | -
- lapply(- |
- ||
| 111 | -2x | -
- variables,- |
- ||
| 112 | -2x | +313 | +318x |
- function(variable) {
+ df_stat |> |
| 113 | -2x | +314 | +318x |
- .format_hedges_g_results(+ dplyr::mutate( |
| 114 | -2x | +315 | +318x |
- by = by,+ stat_name = .env$stat_name, |
| 115 | -2x | +316 | +318x |
- variable = variable,+ across( |
| 116 | -2x | +317 | +318x |
- lst_tidy =+ c(cards::all_ard_groups("levels"), cards::all_ard_variables("levels")),
|
| 117 | -2x | +318 | +318x |
- cards::eval_capture_conditions({
+ ~ map(.x, as.character) |
| 118 | +319 |
- # adding this reshape inside the eval, so if there is an error it's captured in the ARD object+ ) |
||
| 119 | -2x | +|||
| 320 | +
- data_wide <- .paired_data_pivot_wider(data, by = by, variable = variable, id = id)+ ) |
|||
| 120 | +321 |
- # perform paired cohen's d test+ } |
||
| 121 | -1x | +
| 1 | +
- effectsize::hedges_g(x = data_wide[["by1"]], y = data_wide[["by2"]], paired = TRUE, ...) |>+ #' ARD Chi-squared Test |
|||
| 122 | -1x | +|||
| 2 | +
- parameters::standardize_names(style = "broom")+ #' |
|||
| 123 | +3 |
- }),+ #' @description |
||
| 124 | -2x | +|||
| 4 | +
- paired = TRUE,+ #' Analysis results data for Pearson's Chi-squared Test. |
|||
| 125 | +5 |
- ...+ #' Calculated with `chisq.test(x = data[[variable]], y = data[[by]], ...)` |
||
| 126 | +6 |
- )+ #' |
||
| 127 | +7 |
- }+ #' |
||
| 128 | +8 |
- ) |>+ #' @param data (`data.frame`)\cr |
||
| 129 | -2x | +|||
| 9 | +
- dplyr::bind_rows()+ #' a data frame. |
|||
| 130 | +10 |
- }+ #' @param by ([`tidy-select`][dplyr::dplyr_tidy_select])\cr |
||
| 131 | +11 |
-
+ #' column name to compare by. |
||
| 132 | +12 |
- #' Convert Hedge's G Test to ARD+ #' @param variables ([`tidy-select`][dplyr::dplyr_tidy_select])\cr |
||
| 133 | +13 |
- #'+ #' column names to be compared. Independent tests will be computed for |
||
| 134 | +14 |
- #' @inheritParams cards::tidy_as_ard+ #' each variable. |
||
| 135 | +15 |
- #' @inheritParams effectsize::hedges_g+ #' @param ... additional arguments passed to `chisq.test(...)` |
||
| 136 | +16 |
- #' @param by (`string`)\cr by column name+ #' |
||
| 137 | +17 |
- #' @param variable (`string`)\cr variable column name+ #' @return ARD data frame |
||
| 138 | +18 |
- #' @param ... passed to `hedges_g(...)`+ #' @export |
||
| 139 | +19 |
#' |
||
| 140 | +20 |
- #' @return ARD data frame+ #' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = "broom"))
|
||
| 141 | +21 |
- #' @keywords internal+ #' cards::ADSL |> |
||
| 142 | +22 |
- #' @examples+ #' ard_stats_chisq_test(by = "ARM", variables = "AGEGR1") |
||
| 143 | +23 |
- #' cardx:::.format_hedges_g_results(- |
- ||
| 144 | -- |
- #' by = "ARM",- |
- ||
| 145 | -- |
- #' variable = "AGE",- |
- ||
| 146 | -- |
- #' paired = FALSE,- |
- ||
| 147 | -- |
- #' lst_tidy =+ ard_stats_chisq_test <- function(data, by, variables, ...) {
|
||
| 148 | -+ | |||
| 24 | +4x |
- #' cards::eval_capture_conditions(+ set_cli_abort_call() |
||
| 149 | +25 |
- #' effectsize::hedges_g(data[[variable]] ~ data[[by]], paired = FALSE) |>+ |
||
| 150 | +26 |
- #' parameters::standardize_names(style = "broom")+ # check installed packages --------------------------------------------------- |
||
| 151 | -+ | |||
| 27 | +4x |
- #' )+ check_pkg_installed("broom")
|
||
| 152 | +28 |
- #' )+ |
||
| 153 | +29 |
- .format_hedges_g_results <- function(by, variable, lst_tidy, paired, ...) {
+ # check/process inputs ------------------------------------------------------- |
||
| 154 | -+ | |||
| 30 | +4x |
- # build ARD ------------------------------------------------------------------+ check_not_missing(data) |
||
| 155 | +31 | 4x |
- ret <-+ check_not_missing(variables) |
|
| 156 | +32 | 4x |
- cards::tidy_as_ard(+ check_not_missing(by) |
|
| 157 | +33 | 4x |
- lst_tidy = lst_tidy,+ check_data_frame(data) |
|
| 158 | +34 | 4x |
- tidy_result_names = c(+ cards::process_selectors(data, by = {{ by }}, variables = {{ variables }})
|
|
| 159 | +35 | 4x |
- "estimate", "conf.level", "conf.low", "conf.high"+ check_scalar(by) |
|
| 160 | +36 |
- ),- |
- ||
| 161 | -4x | -
- fun_args_to_record = c("mu", "paired", "pooled_sd", "alternative"),
+
|
||
| 162 | -4x | +|||
| 37 | +
- formals = formals(asNamespace("effectsize")[["hedges_g"]]),
+ # return empty ARD if no variables selected ---------------------------------- |
|||
| 163 | +38 | 4x |
- passed_args = c(list(paired = paired), dots_list(...)),+ if (is_empty(variables)) {
|
|
| 164 | -4x | +|||
| 39 | +! |
- lst_ard_columns = list(group1 = by, variable = variable, context = "hedges_g")+ return(dplyr::tibble() |> cards::as_card()) |
||
| 165 | +40 |
- )+ } |
||
| 166 | +41 | |||
| 167 | +42 |
- # add the stat label ---------------------------------------------------------+ # build ARD ------------------------------------------------------------------ |
||
| 168 | +43 | 4x |
- ret |>+ lapply( |
|
| 169 | +44 | 4x |
- dplyr::left_join(+ variables, |
|
| 170 | +45 | 4x |
- .df_effectsize_stat_labels(),+ function(variable) {
|
|
| 171 | -4x | +46 | +5x |
- by = "stat_name"+ cards::tidy_as_ard( |
| 172 | -+ | |||
| 47 | +5x |
- ) |>+ lst_tidy = |
||
| 173 | -4x | +48 | +5x |
- dplyr::mutate(stat_label = dplyr::coalesce(.data$stat_label, .data$stat_name)) |>+ cards::eval_capture_conditions( |
| 174 | -4x | +49 | +5x |
- cards::tidy_ard_column_order()+ stats::chisq.test(x = data[[variable]], y = data[[by]], ...) |> |
| 175 | -+ | |||
| 50 | +5x |
- }+ broom::tidy() |
| 1 | +51 |
- #' ARD Wilcoxon Rank-Sum Test+ ), |
|
| 2 | -+ | ||
| 52 | +5x |
- #'+ tidy_result_names = c("statistic", "p.value", "parameter", "method"),
|
|
| 3 | -+ | ||
| 53 | +5x |
- #' @description+ fun_args_to_record = |
|
| 4 | -+ | ||
| 54 | +5x |
- #' Analysis results data for paired and non-paired Wilcoxon Rank-Sum tests.+ c("correct", "p", "rescale.p", "simulate.p.value", "B"),
|
|
| 5 | -+ | ||
| 55 | +5x |
- #'+ formals = formals(stats::chisq.test), |
|
| 6 | -+ | ||
| 56 | +5x |
- #' @param data (`data.frame`)\cr+ passed_args = dots_list(...), |
|
| 7 | -+ | ||
| 57 | +5x |
- #' a data frame. See below for details.+ lst_ard_columns = list(group1 = by, variable = variable, context = "stats_chisq_test") |
|
| 8 | +58 |
- #' @param by ([`tidy-select`][dplyr::dplyr_tidy_select])\cr+ ) |> |
|
| 9 | -+ | ||
| 59 | +5x |
- #' column name to compare by.+ dplyr::mutate( |
|
| 10 | -+ | ||
| 60 | +5x |
- #' @param variables ([`tidy-select`][dplyr::dplyr_tidy_select])\cr+ .after = "stat_name", |
|
| 11 | -+ | ||
| 61 | +5x |
- #' column names to be compared. Independent tests will be computed for+ stat_label = |
|
| 12 | -+ | ||
| 62 | +5x |
- #' each variable.+ dplyr::case_when(+ |
+ |
| 63 | +5x | +
+ .data$stat_name %in% "statistic" ~ "X-squared Statistic",+ |
+ |
| 64 | +5x | +
+ .data$stat_name %in% "p.value" ~ "p-value",+ |
+ |
| 65 | +5x | +
+ .data$stat_name %in% "parameter" ~ "Degrees of Freedom",+ |
+ |
| 66 | +5x | +
+ TRUE ~ .data$stat_name, |
|
| 13 | +67 |
- #' @param id ([`tidy-select`][dplyr::dplyr_tidy_select])\cr+ ) |
|
| 14 | +68 |
- #' column name of the subject or participant ID.+ ) |
|
| 15 | +69 |
- #' @param ... arguments passed to `wilcox.test(...)`+ } |
|
| 16 | +70 |
- #'+ ) |>+ |
+ |
| 71 | +4x | +
+ dplyr::bind_rows() |>+ |
+ |
| 72 | +4x | +
+ cards::as_card() |
|
| 17 | +73 |
- #' @return ARD data frame+ } |
| 18 | +1 |
- #' @name ard_wilcoxtest+ #' ARD survey continuous CIs |
||
| 19 | +2 |
#' |
||
| 20 | +3 |
- #' @details+ #' One-sample confidence intervals for continuous variables' means and medians. |
||
| 21 | +4 |
- #' For the `ard_wilcoxtest()` function, the data is expected to be one row per subject.+ #' Confidence limits are calculated with `survey::svymean()` and `survey::svyquantile()`. |
||
| 22 | +5 |
- #' The data is passed as `wilcox.test(data[[variable]] ~ data[[by]], paired = FALSE, ...)`.+ #' |
||
| 23 | +6 |
#' |
||
| 24 | +7 |
- #' For the `ard_paired_wilcoxtest()` function, the data is expected to be one row+ #' @inheritParams ard_continuous.survey.design |
||
| 25 | +8 |
- #' per subject per by level. Before the test is calculated, the data are+ #' @param method (`string`)\cr |
||
| 26 | +9 |
- #' reshaped to a wide format to be one row per subject.+ #' Method for confidence interval calculation. |
||
| 27 | +10 |
- #' The data are then passed as+ #' When `"svymean"`, the calculation is computed via `survey::svymean()`. |
||
| 28 | +11 |
- #' `wilcox.test(x = data_wide[[<by level 1>]], y = data_wide[[<by level 2>]], paired = TRUE, ...)`.+ #' Otherwise, it is calculated via`survey::svyquantile(interval.type=method)` |
||
| 29 | +12 |
- #'+ #' @param conf.level (scalar `numeric`)\cr |
||
| 30 | +13 |
- #' @examplesIf cards::is_pkg_installed("broom", reference_pkg = "cardx")
+ #' confidence level for confidence interval. Default is `0.95`. |
||
| 31 | +14 |
- #' cards::ADSL |>+ #' @param df (`numeric`)\cr |
||
| 32 | +15 |
- #' dplyr::filter(ARM %in% c("Placebo", "Xanomeline High Dose")) |>
+ #' denominator degrees of freedom, passed to `survey::confint(df)`. |
||
| 33 | +16 |
- #' ard_wilcoxtest(by = "ARM", variables = "AGE")+ #' Default is `survey::degf(data)`. |
||
| 34 | +17 | ++ |
+ #' @param ... arguments passed to `survey::confint()`+ |
+ |
| 18 |
#' |
|||
| 35 | +19 |
- #' # constructing a paired data set,+ #' @return ARD data frame |
||
| 36 | +20 |
- #' # where patients receive both treatments+ #' @export |
||
| 37 | +21 |
- #' cards::ADSL[c("ARM", "AGE")] |>
+ #' |
||
| 38 | +22 |
- #' dplyr::filter(ARM %in% c("Placebo", "Xanomeline High Dose")) |>
+ #' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = "survey"))
|
||
| 39 | +23 |
- #' dplyr::mutate(.by = ARM, USUBJID = dplyr::row_number()) |>+ #' data(api, package = "survey") |
||
| 40 | +24 |
- #' dplyr::arrange(USUBJID, ARM) |>+ #' dclus1 <- survey::svydesign(id = ~dnum, weights = ~pw, data = apiclus1, fpc = ~fpc) |
||
| 41 | +25 |
- #' ard_paired_wilcoxtest(by = ARM, variables = AGE, id = USUBJID)+ #' |
||
| 42 | +26 |
- NULL+ #' ard_continuous_ci(dclus1, variables = api00) |
||
| 43 | +27 |
-
+ #' ard_continuous_ci(dclus1, variables = api00, method = "svymedian.xlogit") |
||
| 44 | +28 |
- #' @rdname ard_wilcoxtest+ ard_continuous_ci.survey.design <- function(data, |
||
| 45 | +29 |
- #' @export+ variables, |
||
| 46 | +30 |
- ard_wilcoxtest <- function(data, by, variables, ...) {
+ by = NULL, |
||
| 47 | +31 |
- # check installed packages ---------------------------------------------------+ method = c("svymean", "svymedian.mean", "svymedian.beta", "svymedian.xlogit", "svymedian.asin", "svymedian.score"),
+ |
+ ||
| 32 | ++ |
+ conf.level = 0.95,+ |
+ ||
| 33 | ++ |
+ df = survey::degf(data),+ |
+ ||
| 34 | ++ |
+ ...) {
|
||
| 48 | -4x | +35 | +16x |
- cards::check_pkg_installed("broom", reference_pkg = "cardx")
+ set_cli_abort_call() |
| 49 | +36 | |||
| 50 | +37 |
- # check/process inputs -------------------------------------------------------+ # check inputs --------------------------------------------------------------- |
||
| 51 | -4x | +38 | +16x |
check_not_missing(data) |
| 52 | -4x | +39 | +16x |
- check_not_missing(variables)+ check_class(data, "survey.design") |
| 53 | -4x | +40 | +16x |
- check_not_missing(by)+ check_not_missing(variables) |
| 54 | -4x | +|||
| 41 | +
- check_data_frame(data)+ |
|||
| 55 | -4x | +42 | +16x |
- data <- dplyr::ungroup(data)+ cards::process_selectors( |
| 56 | -4x | +43 | +16x |
- cards::process_selectors(data, by = {{ by }}, variables = {{ variables }})
+ data = data$variables, |
| 57 | -4x | +44 | +16x |
- check_scalar(by)+ variables = {{ variables }},
|
| 58 | -+ | |||
| 45 | +16x |
-
+ by = {{ by }}
|
||
| 59 | +46 |
- # if no variables selected, return empty tibble ------------------------------+ ) |
||
| 60 | -4x | +47 | +16x |
- if (is_empty(variables)) {
+ check_scalar(by, allow_empty = TRUE) |
| 61 | -! | +|||
| 48 | +16x |
- return(dplyr::tibble())+ check_scalar_range(conf.level, range = c(0, 1)) |
||
| 62 | -+ | |||
| 49 | +16x |
- }+ method <- arg_match(method) |
||
| 63 | +50 | |||
| 64 | -+ | |||
| 51 | +16x |
- # build ARD ------------------------------------------------------------------+ walk( |
||
| 65 | -4x | +52 | +16x |
- lapply(+ variables, |
| 66 | -4x | +53 | +16x |
- variables,+ \(variable) {
+ |
+
| 54 | +27x | +
+ if (!is.numeric(data$variables[[variable]])) {
+ |
+ ||
| 55 | +1x | +
+ cli::cli_inform(+ |
+ ||
| 56 | +1x | +
+ "Column {.val {variable}} is not {.cls numeric} and results may be an unexpected format."
+ |
+ ||
| 57 | ++ |
+ )+ |
+ ||
| 58 | ++ |
+ }+ |
+ ||
| 59 | ++ |
+ }+ |
+ ||
| 60 | ++ |
+ )+ |
+ ||
| 61 | ++ | + + | +||
| 62 | ++ |
+ # return empty ARD if no variables selected ----------------------------------+ |
+ ||
| 63 | +16x | +
+ if (is_empty(variables)) {
|
||
| 64 | +1x | +
+ return(dplyr::tibble() |> cards::as_card())+ |
+ ||
| 65 | ++ |
+ }+ |
+ ||
| 66 | ++ | + + | +||
| 67 | -4x | +
- function(variable) {
+ # calculate and return ARD of one sample CI ---------------------------------- |
||
| 68 | -5x | +15x |
- .format_wilcoxtest_results(+ .calculate_ard_continuous_survey_ci( |
|
| 69 | -5x | +15x |
- by = by,+ FUN = ifelse(method == "svymean", .svymean_confint_wrapper, .svyquantile_confint_wrapper), |
|
| 70 | -5x | +15x |
- variable = variable,+ data = data, |
|
| 71 | -5x | +15x |
- lst_tidy =+ variables = variables, |
|
| 72 | -5x | +15x |
- cards::eval_capture_conditions(+ by = by, |
|
| 73 | -5x | +15x |
- stats::wilcox.test(data[[variable]] ~ data[[by]], ...) |>+ conf.level = conf.level, |
|
| 74 | -5x | +15x |
- broom::tidy()+ method = method, |
|
| 75 | -+ | 15x |
- ),+ df = df, |
|
| 76 | -5x | +
- paired = FALSE,+ ... |
||
| 77 |
- ...+ ) |
|||
| 78 |
- )+ } |
|||
| 79 |
- }+ |
|||
| 80 |
- ) |>+ .calculate_ard_continuous_survey_ci <- function(FUN, data, variables, by, conf.level, ...) {
|
|||
| 81 | -4x | +
- dplyr::bind_rows()+ # calculate results ---------------------------------------------------------- |
||
| 82 | -+ | 15x |
- }+ map( |
|
| 83 | -+ | 15x |
-
+ variables, |
|
| 84 | -+ | 15x |
- #' @rdname ard_wilcoxtest+ function(variable) {
|
|
| 85 | -+ | 27x |
- #' @export+ .calculate_one_ard_continuous_survey_ci( |
|
| 86 | -+ | 27x |
- ard_paired_wilcoxtest <- function(data, by, variables, id, ...) {
+ FUN = FUN, |
|
| 87 | -+ | 27x |
- # check installed packages ---------------------------------------------------+ data = data, |
|
| 88 | -2x | +27x |
- cards::check_pkg_installed("broom", reference_pkg = "cardx")
+ variable = variable, |
|
| 89 | -+ | 27x |
-
+ by = by, |
|
| 90 | -+ | 27x |
- # check/process inputs -------------------------------------------------------+ conf.level = conf.level, |
|
| 91 | -2x | +
- check_not_missing(data)+ ... |
||
| 92 | -2x | +
- check_not_missing(variables)+ ) |
||
| 93 | -2x | +
- check_not_missing(by)+ } |
||
| 94 | -2x | +
- check_not_missing(id)+ ) |> |
||
| 95 | -2x | +15x |
- check_data_frame(data)+ dplyr::bind_rows() |
|
| 96 | -2x | +
- data <- dplyr::ungroup(data)+ } |
||
| 97 | -2x | +
- cards::process_selectors(data, by = {{ by }}, variables = {{ variables }}, id = {{ id }})
+
|
||
| 98 | -2x | +
- check_scalar(by)+ .calculate_one_ard_continuous_survey_ci <- function(FUN, data, variable, by, conf.level, ...) {
|
||
| 99 | -2x | +27x |
- check_scalar(id)+ if (!is_empty(by)) {
|
|
| 100 | -+ | 8x |
-
+ by_levels <- .unique_values_sort(data$variables, variable = by) |
|
| 101 | -+ | 8x |
- # if no variables selected, return empty tibble ------------------------------+ lst_data <- |
|
| 102 | -2x | +8x |
- if (is_empty(variables)) {
+ map( |
|
| 103 | -! | +8x |
- return(dplyr::tibble())+ by_levels, |
|
| 104 | -+ | 8x |
- }+ ~ call2("subset", expr(data), expr(!!sym(by) == !!.x)) |> eval()
|
|
| 105 |
-
+ ) |> |
|||
| 106 | -+ | 8x |
- # build ARD ------------------------------------------------------------------+ set_names(as.character(by_levels)) |
|
| 107 | -2x | +
- lapply(+ } |
||
| 108 | -2x | +
- variables,+ |
||
| 109 | -2x | +27x |
- function(variable) {
+ df_full <- |
|
| 110 | -2x | +27x |
- .format_wilcoxtest_results(+ case_switch( |
|
| 111 | -2x | +27x |
- by = by,+ !is_empty(by) ~ |
|
| 112 | -2x | +27x |
- variable = variable,+ tidyr::expand_grid( |
|
| 113 | -2x | +27x |
- lst_tidy =+ group1_level = as.character(by_levels) |> as.list() |
|
| 114 | -2x | +
- cards::eval_capture_conditions({
+ ) |> |
||
| 115 | -+ | 27x |
- # adding this reshape inside the eval, so if there is an error it's captured in the ARD object+ dplyr::mutate(group1 = .env$by, variable = .env$variable), |
|
| 116 | -2x | +27x |
- data_wide <- .paired_data_pivot_wider(data, by = by, variable = variable, id = id)+ .default = |
|
| 117 | -+ | 27x |
- # perform paired wilcox test+ dplyr::tibble(variable = .env$variable) |
|
| 118 | -1x | +
- stats::wilcox.test(x = data_wide[["by1"]], y = data_wide[["by2"]], paired = TRUE, ...) |>+ ) |> |
||
| 119 | -1x | +27x |
- broom::tidy()+ dplyr::rowwise() |> |
|
| 120 | -+ | 27x |
- }),+ dplyr::mutate( |
|
| 121 | -2x | +27x |
- paired = TRUE,+ lst_result = |
|
| 122 | -+ | 27x |
- ...+ FUN( |
|
| 123 | -+ | 27x |
- )+ data = |
|
| 124 | -+ | 27x |
- }+ case_switch( |
|
| 125 | -+ | 27x |
- ) |>+ is_empty(.env$by) ~ data, |
|
| 126 | -2x | +27x |
- dplyr::bind_rows()+ .default = lst_data[[.data$group1_level]] |
|
| 127 |
- }+ ), |
|||
| 128 | -+ | 27x |
-
+ variable = .data$variable, |
|
| 129 | -+ | 27x |
-
+ conf.level = .env$conf.level, |
|
| 130 |
- #' Convert Wilcoxon test to ARD+ ... |
|||
| 131 |
- #'+ ) |> |
|||
| 132 | -+ | 27x |
- #' @inheritParams cards::tidy_as_ard+ list(), |
|
| 133 | -+ | 27x |
- #' @inheritParams stats::wilcox.test+ result = |
|
| 134 | -+ | 27x |
- #' @param by (`string`)\cr by column name+ .data$lst_result[["result"]] |> |
|
| 135 | -+ | 27x |
- #' @param variable (`string`)\cr variable column name+ enframe("stat_name", "stat") |>
|
|
| 136 | -+ | 27x |
- #' @param ... passed to `stats::wilcox.test(...)`+ list(), |
|
| 137 | -+ | 27x |
- #'+ warning = .data$lst_result["warning"] |> unname(), |
|
| 138 | -+ | 27x |
- #' @return ARD data frame+ error = .data$lst_result["error"] |> unname(), |
|
| 139 | -+ | 27x |
- #'+ context = "survey_continuous_ci" |
|
| 140 |
- #' @examples+ ) |> |
|||
| 141 | -+ | 27x |
- #' # Pre-processing ADSL to have grouping factor (ARM here) with 2 levels+ dplyr::select(-"lst_result") |> |
|
| 142 | -+ | 27x |
- #' ADSL <- cards::ADSL |>+ dplyr::ungroup() |> |
|
| 143 | -+ | 27x |
- #' dplyr::filter(ARM %in% c("Placebo", "Xanomeline High Dose")) |>
+ tidyr::unnest("result") |>
|
|
| 144 | -+ | 27x |
- #' ard_wilcoxtest(by = "ARM", variables = "AGE")+ dplyr::mutate( |
|
| 145 | -+ | 27x |
- #'+ stat_label = .data$stat_name, |
|
| 146 | -+ | 27x |
- #' cardx:::.format_wilcoxtest_results(+ fmt_fn = map(.data$stat, ~ case_switch(is.numeric(.x) ~ 2L, .default = as.character)) |
|
| 147 |
- #' by = "ARM",+ ) |> |
|||
| 148 | -+ | 27x |
- #' variable = "AGE",+ cards::as_card() |> |
|
| 149 | -+ | 27x |
- #' paired = FALSE,+ cards::tidy_ard_column_order() |
|
| 150 |
- #' lst_tidy =+ } |
|||
| 151 |
- #' cards::eval_capture_conditions(+ |
|||
| 152 |
- #' stats::wilcox.test(ADSL[["AGE"]] ~ ADSL[["ARM"]], paired = FALSE) |>+ .svymean_confint_wrapper <- function(data, variable, conf.level, df, ...) {
|
|||
| 153 | -+ | 26x |
- #' broom::tidy()+ lst_results <- |
|
| 154 | -+ | 26x |
- #' )+ cards::eval_capture_conditions({
|
|
| 155 | -+ | 26x |
- #' )+ svymean <- |
|
| 156 | -+ | 26x |
- #'+ survey::svymean(x = reformulate2(variable), design = data, na.rm = TRUE) |
|
| 157 |
- #' @keywords internal+ |
|||
| 158 | -+ | 26x |
- .format_wilcoxtest_results <- function(by, variable, lst_tidy, paired, ...) {
+ lst_svymean <- as.data.frame(svymean) |> |
|
| 159 | -+ | 26x |
- # build ARD ------------------------------------------------------------------+ as.list() |> |
|
| 160 | -7x | +26x |
- ret <-+ set_names(c("estimate", "std.error"))
|
|
| 161 | -7x | +
- cards::tidy_as_ard(+ |
||
| 162 | -7x | +26x |
- lst_tidy = lst_tidy,+ lst_confint <- stats::confint(svymean, level = conf.level, df = df, ...) |> |
|
| 163 | -7x | +26x |
- tidy_result_names = c("statistic", "p.value", "method", "alternative"),
+ as.data.frame() |> |
|
| 164 | -7x | +26x |
- fun_args_to_record = c(+ as.list() |> |
|
| 165 | -7x | +26x |
- "mu", "paired", "exact", "correct", "conf.int",+ set_names(c("conf.low", "conf.high"))
|
|
| 166 | -7x | +
- "conf.level", "tol.root", "digits.rank"+ |
||
| 167 | -+ | 24x |
- ),+ c(lst_svymean, lst_confint) |
|
| 168 | -7x | +
- formals = formals(asNamespace("stats")[["wilcox.test.default"]]),
+ }) |
||
| 169 | -7x | +
- passed_args = c(list(paired = paired), dots_list(...)),+ |
||
| 170 | -7x | +
- lst_ard_columns = list(group1 = by, variable = variable, context = "wilcoxtest")+ # add NULL results if error |
||
| 171 | -+ | 26x |
- )+ if (is_empty(lst_results[["result"]])) {
|
|
| 172 | -+ | 2x |
-
+ lst_results[["result"]] <- rep_named(c("estimate", "std.error", "conf.low", "conf.high"), list(NULL))
|
|
| 173 |
- # add the stat label ---------------------------------------------------------+ } |
|||
| 174 | -7x | +
- ret |>+ |
||
| 175 | -7x | +
- dplyr::left_join(+ # add other args |
||
| 176 | -7x | +26x |
- .df_wilcoxtest_stat_labels(),+ lst_results[["result"]] <- lst_results[["result"]] |> append(list(conf.level = conf.level)) |
|
| 177 | -7x | +
- by = "stat_name"+ |
||
| 178 |
- ) |>+ # return list result |
|||
| 179 | -7x | +26x |
- dplyr::mutate(stat_label = dplyr::coalesce(.data$stat_label, .data$stat_name)) |>+ lst_results |
|
| 180 | -7x | +
- cards::tidy_ard_column_order()+ } |
||
| 181 |
- }+ |
|||
| 182 |
-
+ .svyquantile_confint_wrapper <- function(data, variable, conf.level, method, df, ...) {
|
|||
| 183 | -+ | 9x |
-
+ lst_results <- |
|
| 184 | -+ | 9x |
- #' Convert long paired data to wide+ cards::eval_capture_conditions({
|
|
| 185 | -+ | 9x |
- #'+ svyquantile <- |
|
| 186 | -+ | 9x |
- #'+ survey::svyquantile( |
|
| 187 | -+ | 9x |
- #' @param data (`data.frame`)\cr a data frame that is one line per subject per group+ x = reformulate2(variable), design = data, quantiles = 0.5, |
|
| 188 | -+ | 9x |
- #' @param by (`string`)\cr by column name+ na.rm = TRUE, interval.type = str_remove(method, pattern = "^svymedian\\.") |
|
| 189 |
- #' @param variable (`string`)\cr variable column name+ ) |
|||
| 190 |
- #' @param id (`string`)\cr subject id column name+ |
|||
| 191 | -+ | 8x |
- #' @param env (`environment`) used for error messaging. Default is `rlang::caller_env()`+ lst_svyquantile <- svyquantile |> |
|
| 192 | -+ | 8x |
- #'+ getElement(1L) |> |
|
| 193 | -+ | 8x |
- #' @return a wide data frame+ as.data.frame() |> |
|
| 194 | -+ | 8x |
- #' @keywords internal+ dplyr::select(1L, last_col()) |> |
|
| 195 | -+ | 8x |
- #' @examples+ as.list() |> |
|
| 196 | -+ | 8x |
- #' cards::ADSL[c("ARM", "AGE")] |>
+ set_names(c("estimate", "std.error"))
|
|
| 197 |
- #' dplyr::filter(ARM %in% c("Placebo", "Xanomeline High Dose")) |>
+
|
|||
| 198 | -+ | 8x |
- #' dplyr::mutate(.by = ARM, USUBJID = dplyr::row_number()) |>+ lst_confint <- stats::confint(svyquantile, level = conf.level, df = df, ...) |> |
|
| 199 | -+ | 8x |
- #' dplyr::arrange(USUBJID, ARM) |>+ as.data.frame() |> |
|
| 200 | -+ | 8x |
- #' cardx:::.paired_data_pivot_wider(by = "ARM", variable = "AGE", id = "USUBJID")+ as.list() |> |
|
| 201 | -+ | 8x |
- .paired_data_pivot_wider <- function(data, by, variable, id, env = rlang::caller_env()) {
+ set_names(c("conf.low", "conf.high"))
|
|
| 202 |
- # check the number of levels before pivoting data to wider format+ |
|||
| 203 | 8x |
- if (dplyr::n_distinct(data[[by]], na.rm = TRUE) != 2L) {
+ c(lst_svyquantile, lst_confint) |
||
| 204 | -4x | +
- cli::cli_abort("The {.arg by} argument must have two and only two levels.", call = env)
+ }) |
||
| 205 |
- }+ |
|||
| 206 |
-
+ # add NULL results if error |
|||
| 207 | -4x | +9x |
- data |>+ if (is_empty(lst_results[["result"]])) {
|
|
| 208 | -+ | 1x |
- # arrange data so the first group always appears first+ lst_results[["result"]] <- rep_named(c("estimate", "std.error", "conf.low", "conf.high"), list(NULL))
|
|
| 209 | -4x | +
- dplyr::arrange(.data[[by]]) |>+ } |
||
| 210 | -4x | +
- tidyr::pivot_wider(+ |
||
| 211 | -4x | +
- id_cols = all_of(id),+ # add other args |
||
| 212 | -4x | +9x |
- names_from = all_of(by),+ lst_results[["result"]] <- lst_results[["result"]] |> append(list(conf.level = conf.level)) |
|
| 213 | -4x | +
- values_from = all_of(variable)+ |
||
| 214 |
- ) |>+ # return list result |
|||
| 215 | -4x | +9x |
- stats::setNames(c(id, "by1", "by2"))+ lst_results |
|
| 217 | -- | - - | -||
| 218 | -- |
- .df_wilcoxtest_stat_labels <- function() {
- |
- ||
| 219 | -7x | -
- dplyr::tribble(- |
- ||
| 220 | -7x | -
- ~stat_name, ~stat_label,- |
- ||
| 221 | -7x | -
- "statistic", "X-squared Statistic",- |
- ||
| 222 | -7x | -
- "parameter", "Degrees of Freedom",- |
- ||
| 223 | -7x | -
- "estimate", "Median of the Difference",- |
- ||
| 224 | -7x | -
- "p.value", "p-value",- |
- ||
| 225 | -7x | -
- "conf.low", "CI Lower Bound",- |
- ||
| 226 | -7x | -
- "conf.high", "CI Upper Bound",- |
- ||
| 227 | -7x | -
- "paired", "Paired test",- |
- ||
| 228 | -7x | -
- "conf.level", "CI Confidence Level",- |
- ||
| 229 | -- |
- )- |
- ||
| 230 | -- |
- }- |
-
| 16 |
- #' @param ... arguments passed to `effectsize::cohens_d(...)`+ #' @param conf.level (scalar `numeric`)\cr |
|||
| 17 |
- #'+ #' confidence level for confidence interval. Default is `0.95`. |
|||
| 18 |
- #' @return ARD data frame+ #' @param ... arguments passed to `effectsize::cohens_d(...)` |
|||
| 19 |
- #' @name ard_cohens_d+ #' |
|||
| 20 |
- #'+ #' @return ARD data frame |
|||
| 21 |
- #' @details+ #' @name ard_effectsize_cohens_d |
|||
| 22 |
- #' For the `ard_cohens_d()` function, the data is expected to be one row per subject.+ #' |
|||
| 23 |
- #' The data is passed as `effectsize::cohens_d(data[[variable]]~data[[by]], data, paired = FALSE, ...)`.+ #' @details |
|||
| 24 |
- #'+ #' For the `ard_effectsize_cohens_d()` function, the data is expected to be one row per subject. |
|||
| 25 |
- #' For the `ard_paired_cohens_d()` function, the data is expected to be one row+ #' The data is passed as `effectsize::cohens_d(data[[variable]]~data[[by]], data, paired = FALSE, ...)`. |
|||
| 26 |
- #' per subject per by level. Before the effect size is calculated, the data are+ #' |
|||
| 27 |
- #' reshaped to a wide format to be one row per subject.+ #' For the `ard_effectsize_paired_cohens_d()` function, the data is expected to be one row |
|||
| 28 |
- #' The data are then passed as+ #' per subject per by level. Before the effect size is calculated, the data are |
|||
| 29 |
- #' `effectsize::cohens_d(x = data_wide[[<by level 1>]], y = data_wide[[<by level 2>]], paired = TRUE, ...)`.+ #' reshaped to a wide format to be one row per subject. |
|||
| 30 |
- #'+ #' The data are then passed as |
|||
| 31 |
- #' @examplesIf cards::is_pkg_installed(c("effectsize", "parameters"), reference_pkg = "cardx")
+ #' `effectsize::cohens_d(x = data_wide[[<by level 1>]], y = data_wide[[<by level 2>]], paired = TRUE, ...)`. |
|||
| 32 |
- #' cards::ADSL |>+ #' |
|||
| 33 |
- #' dplyr::filter(ARM %in% c("Placebo", "Xanomeline High Dose")) |>
+ #' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = c("effectsize", "parameters")))
|
|||
| 34 |
- #' ard_cohens_d(by = ARM, variables = AGE)+ #' cards::ADSL |> |
|||
| 35 |
- #'+ #' dplyr::filter(ARM %in% c("Placebo", "Xanomeline High Dose")) |>
|
|||
| 36 |
- #' # constructing a paired data set,+ #' ard_effectsize_cohens_d(by = ARM, variables = AGE) |
|||
| 37 |
- #' # where patients receive both treatments+ #' |
|||
| 38 |
- #' cards::ADSL[c("ARM", "AGE")] |>
+ #' # constructing a paired data set, |
|||
| 39 |
- #' dplyr::filter(ARM %in% c("Placebo", "Xanomeline High Dose")) |>
+ #' # where patients receive both treatments |
|||
| 40 |
- #' dplyr::mutate(.by = ARM, USUBJID = dplyr::row_number()) |>+ #' cards::ADSL[c("ARM", "AGE")] |>
|
|||
| 41 |
- #' dplyr::arrange(USUBJID, ARM) |>+ #' dplyr::filter(ARM %in% c("Placebo", "Xanomeline High Dose")) |>
|
|||
| 42 |
- #' dplyr::group_by(USUBJID) |>+ #' dplyr::mutate(.by = ARM, USUBJID = dplyr::row_number()) |> |
|||
| 43 |
- #' dplyr::filter(dplyr::n() > 1) |>+ #' dplyr::arrange(USUBJID, ARM) |> |
|||
| 44 |
- #' ard_paired_cohens_d(by = ARM, variables = AGE, id = USUBJID)+ #' dplyr::group_by(USUBJID) |> |
|||
| 45 |
- NULL+ #' dplyr::filter(dplyr::n() > 1) |> |
|||
| 46 |
-
+ #' ard_effectsize_paired_cohens_d(by = ARM, variables = AGE, id = USUBJID) |
|||
| 47 |
- #' @rdname ard_cohens_d+ NULL |
|||
| 48 |
- #' @export+ |
|||
| 49 |
- ard_cohens_d <- function(data, by, variables, ...) {
+ #' @rdname ard_effectsize_cohens_d |
|||
| 50 |
- # check installed packages ---------------------------------------------------+ #' @export |
|||
| 51 | -2x | +
- cards::check_pkg_installed(c("effectsize", "parameters"), reference_pkg = "cardx")
+ ard_effectsize_cohens_d <- function(data, by, variables, conf.level = 0.95, ...) {
|
||
| 52 | -+ | 4x |
-
+ set_cli_abort_call() |
|
| 53 |
- # check/process inputs -------------------------------------------------------+ |
|||
| 54 | -2x | +
- check_not_missing(data)+ # check installed packages --------------------------------------------------- |
||
| 55 | -2x | +4x |
- check_not_missing(variables)+ check_pkg_installed(c("effectsize", "parameters"))
|
|
| 56 | -2x | +
- check_not_missing(by)+ |
||
| 57 | -2x | +
- check_data_frame(data)+ # check/process inputs ------------------------------------------------------- |
||
| 58 | -2x | +4x |
- data <- dplyr::ungroup(data)+ check_not_missing(data) |
|
| 59 | -2x | +4x |
- cards::process_selectors(data, by = {{ by }}, variables = {{ variables }})
+ check_not_missing(variables) |
|
| 60 | -2x | +4x |
- check_scalar(by)+ check_not_missing(by) |
|
| 61 | -+ | 4x |
-
+ check_data_frame(data) |
|
| 62 | -+ | 4x |
- # if no variables selected, return empty tibble ------------------------------+ data <- dplyr::ungroup(data) |
|
| 63 | -2x | +4x |
- if (is_empty(variables)) {
+ cards::process_selectors(data, by = {{ by }}, variables = {{ variables }})
|
|
| 64 | -! | +4x |
- return(dplyr::tibble())+ check_scalar(by) |
|
| 65 | -+ | 4x |
- }+ check_range(conf.level, range = c(0, 1)) |
|
| 67 |
- # build ARD ------------------------------------------------------------------+ # return empty ARD if no variables selected ---------------------------------- |
|||
| 68 | -2x | +4x |
- lapply(+ if (is_empty(variables)) {
|
|
| 69 | -2x | +! |
- variables,+ return(dplyr::tibble() |> cards::as_card()) |
|
| 70 | -2x | +
- function(variable) {
+ } |
||
| 71 | -2x | +
- .format_cohens_d_results(+ |
||
| 72 | -2x | +
- by = by,+ # build ARD ------------------------------------------------------------------ |
||
| 73 | -2x | +4x |
- variable = variable,+ lapply( |
|
| 74 | -2x | +4x |
- lst_tidy =+ variables, |
|
| 75 | -2x | +4x |
- cards::eval_capture_conditions(+ function(variable) {
|
|
| 76 | -2x | +5x |
- effectsize::cohens_d(data[[variable]] ~ data[[by]], data = data, paired = FALSE, ...) |>+ .format_cohens_d_results( |
|
| 77 | -2x | +5x |
- parameters::standardize_names(style = "broom")+ by = by, |
|
| 78 | -+ | 5x |
- ),+ variable = variable, |
|
| 79 | -2x | +5x |
- paired = FALSE,+ lst_tidy = |
|
| 80 | -+ | 5x |
- ...+ cards::eval_capture_conditions( |
|
| 81 | -+ | 5x |
- )+ effectsize::cohens_d( |
|
| 82 | -+ | 5x |
- }+ reformulate2(by, response = variable), |
|
| 83 | -+ | 5x |
- ) |>+ data = data |> tidyr::drop_na(all_of(c(by, variable))), |
|
| 84 | -2x | +5x |
- dplyr::bind_rows()+ paired = FALSE, |
|
| 85 | -+ | 5x |
- }+ ci = conf.level, |
|
| 86 |
-
+ ... |
|||
| 87 |
-
+ ) |> |
|||
| 88 | -+ | 5x |
- #' @rdname ard_cohens_d+ parameters::standardize_names(style = "broom") |> |
|
| 89 | -+ | 5x |
- #' @export+ dplyr::mutate(method = "Cohen's D") |
|
| 90 |
- ard_paired_cohens_d <- function(data, by, variables, id, ...) {
+ ), |
|||
| 91 | -+ | 5x |
- # check installed packages ---------------------------------------------------+ paired = FALSE, |
|
| 92 | -2x | +
- cards::check_pkg_installed("effectsize", reference_pkg = "cardx")
+ ... |
||
| 93 | -2x | +
- cards::check_pkg_installed("parameters", reference_pkg = "cardx")
+ ) |
||
| 94 |
- # check/process inputs -------------------------------------------------------+ } |
|||
| 95 | -2x | +
- check_not_missing(data)+ ) |> |
||
| 96 | -2x | +4x |
- check_not_missing(variables)+ dplyr::bind_rows() |
|
| 97 | -2x | +
- check_not_missing(by)+ } |
||
| 98 | -2x | +
- check_not_missing(id)+ |
||
| 99 | -2x | +
- check_data_frame(data)+ |
||
| 100 | -2x | +
- data <- dplyr::ungroup(data)+ #' @rdname ard_effectsize_cohens_d |
||
| 101 | -2x | +
- cards::process_selectors(data, by = {{ by }}, variables = {{ variables }}, id = {{ id }})
+ #' @export |
||
| 102 | -2x | +
- check_scalar(by)+ ard_effectsize_paired_cohens_d <- function(data, by, variables, id, conf.level = 0.95, ...) {
|
||
| 103 | -2x | +3x |
- check_scalar(id)+ set_cli_abort_call() |
|
| 105 |
- # if no variables selected, return empty tibble ------------------------------+ # check installed packages --------------------------------------------------- |
|||
| 106 | -2x | +3x |
- if (is_empty(variables)) {
+ check_pkg_installed(c("effectsize", "parameters"))
|
|
| 107 | -! | +
- return(dplyr::tibble())+ |
||
| 108 |
- }+ # check/process inputs ------------------------------------------------------- |
|||
| 109 | -+ | 3x |
-
+ check_not_missing(data) |
|
| 110 | -+ | 3x |
- # build ARD ------------------------------------------------------------------+ check_not_missing(variables) |
|
| 111 | -2x | +3x |
- lapply(+ check_not_missing(by) |
|
| 112 | -2x | +3x |
- variables,+ check_not_missing(id) |
|
| 113 | -2x | +3x |
- function(variable) {
+ check_data_frame(data) |
|
| 114 | -2x | +3x |
- .format_cohens_d_results(+ data <- dplyr::ungroup(data) |
|
| 115 | -2x | +3x |
- by = by,+ cards::process_selectors(data, by = {{ by }}, variables = {{ variables }}, id = {{ id }})
|
|
| 116 | -2x | +3x |
- variable = variable,+ check_scalar(by) |
|
| 117 | -2x | +3x |
- lst_tidy =+ check_scalar(id) |
|
| 118 | -2x | +3x |
- cards::eval_capture_conditions({
+ check_range(conf.level, range = c(0, 1)) |
|
| 119 |
- # adding this reshape inside the eval, so if there is an error it's captured in the ARD object+ |
|||
| 120 | -2x | +
- data_wide <- .paired_data_pivot_wider(data, by = by, variable = variable, id = id)+ # return empty ARD if no variables selected ---------------------------------- |
||
| 121 | -+ | 3x |
- # perform paired cohen's d test+ if (is_empty(variables)) {
|
|
| 122 | -1x | +! |
- effectsize::cohens_d(x = data_wide[["by1"]], y = data_wide[["by2"]], paired = TRUE, ...) |>+ return(dplyr::tibble() |> cards::as_card()) |
|
| 123 | -1x | +
- parameters::standardize_names(style = "broom")+ } |
||
| 124 |
- }),+ |
|||
| 125 | -2x | +
- paired = TRUE,+ # build ARD ------------------------------------------------------------------ |
||
| 126 | -+ | 3x |
- ...+ lapply( |
|
| 127 | -+ | 3x |
- )+ variables, |
|
| 128 | -+ | 3x |
- }+ function(variable) {
|
|
| 129 | -+ | 3x |
- ) |>+ .format_cohens_d_results( |
|
| 130 | -2x | +3x |
- dplyr::bind_rows()+ by = by, |
|
| 131 | -+ | 3x |
- }+ variable = variable, |
|
| 132 | -+ | 3x |
-
+ lst_tidy = |
|
| 133 | -+ | 3x |
- .df_effectsize_stat_labels <- function() {
+ cards::eval_capture_conditions({
|
|
| 134 | -8x | +
- dplyr::tribble(+ # adding this reshape inside the eval, so if there is an error it's captured in the ARD object |
||
| 135 | -8x | +3x |
- ~stat_name, ~stat_label,+ data_wide <- |
|
| 136 | -8x | +3x |
- "estimate", "Effect Size Estimate",+ data |> |
|
| 137 | -8x | +3x |
- "conf.low", "CI Lower Bound",+ tidyr::drop_na(all_of(c(id, by, variable))) |> |
|
| 138 | -8x | +3x |
- "conf.high", "CI Upper Bound",+ .paired_data_pivot_wider(by = by, variable = variable, id = id) |> |
|
| 139 | -8x | +3x |
- "conf.level", "CI Confidence Level",+ tidyr::drop_na(any_of(c("by1", "by2")))
|
|
| 140 | -8x | +
- "mu", "H0 Mean",+ # perform paired cohen's d test |
||
| 141 | -8x | +2x |
- "paired", "Paired test",+ effectsize::cohens_d(x = data_wide[["by1"]], y = data_wide[["by2"]], paired = TRUE, ci = conf.level, ...) |> |
|
| 142 | -8x | +2x |
- "pooled_sd", "Pooled Standard Deviation",+ parameters::standardize_names(style = "broom") |> |
|
| 143 | -8x | +2x |
- "alternative", "Alternative Hypothesis"+ dplyr::mutate(method = "Paired Cohen's D") |
|
| 144 |
- )+ }), |
|||
| 145 | -+ | 3x |
- }+ paired = TRUE, |
|
| 146 |
-
+ ... |
|||
| 147 |
-
+ ) |
|||
| 148 |
- #' Convert Cohen's D Test to ARD+ } |
|||
| 149 |
- #'+ ) |> |
|||
| 150 | -+ | 3x |
- #' @inheritParams cards::tidy_as_ard+ dplyr::bind_rows() |
|
| 151 |
- #' @inheritParams effectsize::cohens_d+ } |
|||
| 152 |
- #' @param by (`string`)\cr by column name+ |
|||
| 153 |
- #' @param variable (`string`)\cr variable column name+ .df_effectsize_stat_labels <- function() {
|
|||
| 154 | -+ | 16x |
- #' @param ... passed to `cohens_d(...)`+ dplyr::tribble( |
|
| 155 | -+ | 16x |
- #'+ ~stat_name, ~stat_label, |
|
| 156 | -+ | 16x |
- #' @return ARD data frame+ "estimate", "Effect Size Estimate", |
|
| 157 | -+ | 16x |
- #' @keywords internal+ "conf.low", "CI Lower Bound", |
|
| 158 | -+ | 16x |
- #' @examples+ "conf.high", "CI Upper Bound", |
|
| 159 | -+ | 16x |
- #' cardx:::.format_cohens_d_results(+ "conf.level", "CI Confidence Level", |
|
| 160 | -+ | 16x |
- #' by = "ARM",+ "mu", "H0 Mean", |
|
| 161 | -+ | 16x |
- #' variable = "AGE",+ "paired", "Paired test", |
|
| 162 | -+ | 16x |
- #' paired = FALSE,+ "pooled_sd", "Pooled Standard Deviation", |
|
| 163 | -+ | 16x |
- #' lst_tidy =+ "alternative", "Alternative Hypothesis" |
|
| 164 |
- #' cards::eval_capture_conditions(+ ) |
|||
| 165 |
- #' effectsize::hedges_g(data[[variable]] ~ data[[by]], paired = FALSE) |>+ } |
|||
| 166 |
- #' parameters::standardize_names(style = "broom")+ |
|||
| 167 |
- #' )+ |
|||
| 168 |
- #' )+ #' Convert Cohen's D Test to ARD |
|||
| 169 |
- .format_cohens_d_results <- function(by, variable, lst_tidy, paired, ...) {
+ #' |
|||
| 170 |
- # build ARD ------------------------------------------------------------------+ #' @inheritParams cards::tidy_as_ard |
|||
| 171 | -4x | +
- ret <-+ #' @inheritParams effectsize::cohens_d |
||
| 172 | -4x | +
- cards::tidy_as_ard(+ #' @param by (`string`)\cr by column name |
||
| 173 | -4x | +
- lst_tidy = lst_tidy,+ #' @param variable (`string`)\cr variable column name |
||
| 174 | -4x | ++ |
+ #' @param ... passed to `cohens_d(...)`+ |
+ |
| 175 | ++ |
+ #'+ |
+ ||
| 176 | ++ |
+ #' @return ARD data frame+ |
+ ||
| 177 | ++ |
+ #' @keywords internal+ |
+ ||
| 178 | ++ |
+ #' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = c("effectsize", "parameters")))
+ |
+ ||
| 179 | ++ |
+ #' cardx:::.format_cohens_d_results(+ |
+ ||
| 180 | ++ |
+ #' by = "ARM",+ |
+ ||
| 181 | ++ |
+ #' variable = "AGE",+ |
+ ||
| 182 | ++ |
+ #' paired = FALSE,+ |
+ ||
| 183 | ++ |
+ #' lst_tidy =+ |
+ ||
| 184 | ++ |
+ #' cards::eval_capture_conditions(+ |
+ ||
| 185 | ++ |
+ #' effectsize::hedges_g(data[[variable]] ~ data[[by]], paired = FALSE) |>+ |
+ ||
| 186 | ++ |
+ #' parameters::standardize_names(style = "broom")+ |
+ ||
| 187 | ++ |
+ #' )+ |
+ ||
| 188 | ++ |
+ #' )+ |
+ ||
| 189 | ++ |
+ .format_cohens_d_results <- function(by, variable, lst_tidy, paired, ...) {
+ |
+ ||
| 190 | ++ |
+ # build ARD ------------------------------------------------------------------+ |
+ ||
| 191 | +8x | +
+ ret <-+ |
+ ||
| 192 | +8x | +
+ cards::tidy_as_ard(+ |
+ ||
| 193 | +8x | +
+ lst_tidy = lst_tidy,+ |
+ ||
| 194 | +8x |
tidy_result_names = c( |
||
| 175 | -4x | +195 | +8x |
"estimate", "conf.level", "conf.low", "conf.high" |
| 176 | +196 |
), |
||
| 177 | -4x | +197 | +8x |
fun_args_to_record = c("mu", "paired", "pooled_sd", "alternative"),
|
| 178 | -4x | +198 | +8x |
formals = formals(asNamespace("effectsize")[["cohens_d"]]),
|
| 179 | -4x | +199 | +8x |
passed_args = c(list(paired = paired), dots_list(...)), |
| 180 | -4x | +200 | +8x |
- lst_ard_columns = list(group1 = by, variable = variable, context = "cohens_d")+ lst_ard_columns = list(group1 = by, variable = variable, context = "effectsize_cohens_d") |
| 181 | +201 |
) |
||
| 182 | +202 | |||
| 183 | +203 |
# add the stat label --------------------------------------------------------- |
||
| 184 | -4x | +204 | +8x |
ret |> |
| 185 | -4x | +205 | +8x |
dplyr::left_join( |
| 186 | -4x | +206 | +8x |
.df_effectsize_stat_labels(), |
| 187 | -4x | +207 | +8x |
by = "stat_name" |
| 188 | +208 |
) |> |
||
| 189 | -4x | +209 | +8x |
dplyr::mutate(stat_label = dplyr::coalesce(.data$stat_label, .data$stat_name)) |> |
| 190 | -4x | +210 | +8x | +
+ cards::as_card() |>+ |
+
| 211 | +8x |
cards::tidy_ard_column_order() |
||
| 191 | +212 |
}@@ -8079,14 +8177,14 @@ cardx coverage - 95.63% |
| 1 |
- #' ARD Mood Test+ #' ARD for Difference in Survival |
||
| 4 |
- #' Analysis results data for Mood two sample test of scale. Note this not to be confused with+ #' Analysis results data for comparison of survival using [survival::survdiff()]. |
||
| 5 |
- #' the Brown-Mood test of medians.+ #' |
||
| 6 |
- #'+ #' @param formula (`formula`)\cr |
||
| 7 |
- #' @param data (`data.frame`)\cr+ #' a formula |
||
| 8 |
- #' a data frame. See below for details.+ #' @param data (`data.frame`)\cr |
||
| 9 |
- #' @param by ([`tidy-select`][dplyr::dplyr_tidy_select])\cr+ #' a data frame |
||
| 10 |
- #' column name to compare by.+ #' @param rho (`scalar numeric`)\cr |
||
| 11 |
- #' @param variables ([`tidy-select`][dplyr::dplyr_tidy_select])\cr+ #' numeric scalar passed to `survival::survdiff(rho)`. Default is `rho=0`. |
||
| 12 |
- #' column name to be compared. Independent tests will+ #' @param ... additional arguments passed to `survival::survdiff()` |
||
| 13 |
- #' be run for each variable.+ #' |
||
| 14 |
- #' @param ... arguments passed to `mood.test(...)`+ #' @return an ARD data frame of class 'card' |
||
| 15 |
- #'+ #' @export |
||
| 16 |
- #' @return ARD data frame+ #' |
||
| 17 |
- #' @name ard_moodtest+ #' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = c("survival", "broom", "ggsurvfit")))
|
||
| 18 |
- #'+ #' library(survival) |
||
| 19 |
- #' @details+ #' library(ggsurvfit) |
||
| 20 |
- #' For the `ard_moodtest()` function, the data is expected to be one row per subject.+ #' |
||
| 21 |
- #' The data is passed as `mood.test(data[[variable]] ~ data[[by]], ...)`.+ #' ard_survival_survdiff(Surv_CNSR(AVAL, CNSR) ~ TRTA, data = cards::ADTTE) |
||
| 22 |
- #' @rdname ard_moodtest+ ard_survival_survdiff <- function(formula, data, rho = 0, ...) {
|
||
| 23 | -+ | 5x |
- #' @export+ set_cli_abort_call() |
| 24 |
- #'+ |
||
| 25 |
- #' @examplesIf cards::is_pkg_installed("broom", reference_pkg = "cardx")
+ # check installed packages --------------------------------------------------- |
||
| 26 | -+ | 5x |
- #' cards::ADSL |>+ check_pkg_installed(c("survival", "broom"))
|
| 27 |
- #' ard_moodtest(by = "SEX", variables = "AGE")+ |
||
| 28 |
- ard_moodtest <- function(data, by, variables, ...) {
+ # check/process inputs ------------------------------------------------------- |
||
| 29 | -+ | 5x |
- # check installed packages ---------------------------------------------------+ check_not_missing(formula) |
| 30 | -2x | +5x |
- cards::check_pkg_installed("broom", reference_pkg = "cardx")
+ check_class(formula, cls = "formula") |
| 31 | -+ | 5x |
-
+ if (!missing(data)) check_class(data, cls = "data.frame") |
| 32 | -+ | 5x |
- # check/process inputs -------------------------------------------------------+ check_scalar(rho) |
| 33 | -2x | +5x |
- check_not_missing(data)+ check_class(rho, cls = "numeric") |
| 34 | -2x | +
- check_not_missing(variables)+ |
|
| 35 | -2x | +
- check_not_missing(by)+ # assign method |
|
| 36 | -2x | +5x |
- check_data_frame(data)+ method <- dplyr::case_when( |
| 37 | -2x | +5x |
- data <- dplyr::ungroup(data)+ rho == 0 ~ "Log-rank test", |
| 38 | -2x | +5x |
- cards::process_selectors(data, by = {{ by }}, variables = {{ variables }})
+ rho == 1.5 ~ "Tarone-Ware test", |
| 39 | -2x | +5x |
- check_scalar(by)+ rho == 1 ~ "Peto & Peto modification of Gehan-Wilcoxon test", |
| 40 | -+ | 5x |
-
+ .default = glue::glue("G-rho test (\U03C1 = {rho})")
|
| 41 |
-
+ ) |> |
||
| 42 | -+ | 5x |
- # if no variables selected, return empty tibble ------------------------------+ as.character() |
| 43 | -2x | +
- if (is_empty(variables)) {
+
|
|
| 44 | -! | +
- return(dplyr::tibble())+ # calculate survdiff() results ----------------------------------------------- |
|
| 45 | -+ | 5x |
- }+ lst_glance <- |
| 46 | -+ | 5x |
- # build ARD ------------------------------------------------------------------+ cards::eval_capture_conditions( |
| 47 | -2x | +5x |
- lapply(+ survival::survdiff(formula = formula, data = data, rho = rho, ...) |> |
| 48 | -2x | +5x |
- variables,+ broom::glance() |> |
| 49 | -2x | +5x |
- function(variable) {
+ dplyr::mutate(method = .env$method) |
| 50 | -2x | +
- .format_moodtest_results(+ ) |
|
| 51 | -2x | +
- by = by,+ |
|
| 52 | -2x | +
- variable = variable,+ # tidy results up in an ARD format ------------------------------------------- |
|
| 53 | -2x | +
- lst_tidy =+ # extract variable names from formula |
|
| 54 | -2x | +5x |
- cards::eval_capture_conditions(+ variables <- stats::terms(formula) |> |
| 55 | -2x | +5x |
- stats::mood.test(data[[variable]] ~ data[[by]], ...) |>+ attr("term.labels") |>
|
| 56 | -2x | +5x |
- broom::tidy()+ .strip_backticks() |
| 57 |
- ),+ |
||
| 58 |
- ...+ # if there was an error, return results early |
||
| 59 | -+ | 5x |
- )+ if (is.null(lst_glance[["result"]])) {
|
| 60 |
- }+ # if no variables in formula, then return an error |
||
| 61 |
- ) |>+ # otherwise, if we do have variable names, then we can construct an empty ARD which will be done below |
||
| 62 | 2x |
- dplyr::bind_rows()+ if (is_empty(variables)) {
|
|
| 63 | -+ | 1x |
- }+ cli::cli_abort( |
| 64 | -+ | 1x |
- #' Convert mood test results to ARD+ message = |
| 65 | -+ | 1x |
- #'+ c("There was an error in {.fun survival::survdiff}. See below:",
|
| 66 | -+ | 1x |
- #' @inheritParams cards::tidy_as_ard+ "x" = lst_glance[["error"]] |
| 67 |
- #' @inheritParams stats::mood.test+ ), |
||
| 68 | -+ | 1x |
- #' @param by (`string`)\cr by column name+ call = get_cli_abort_call() |
| 69 |
- #' @param variable (`string`)\cr variable column name+ ) |
||
| 70 |
- #' @param ... passed to `mood.test(...)`+ } |
||
| 71 |
- #'+ } |
||
| 72 |
- #' @return ARD data frame+ |
||
| 73 | -+ | 4x |
- #' @keywords internal+ .variables_to_survdiff_ard( |
| 74 | -+ | 4x |
- #' @examples+ variables = variables, |
| 75 | -+ | 4x |
- #' cardx:::.format_moodtest_results(+ method = method, |
| 76 |
- #' by = "SEX",+ # styler: off |
||
| 77 | -+ | 4x |
- #' variable = "AGE",+ stat_names = |
| 78 | -+ | 4x |
- #' lst_tidy =+ if (!is.null(lst_glance[["result"]])) names(lst_glance[["result"]]) |
| 79 | -+ | 4x |
- #' cards::eval_capture_conditions(+ else c("statistic", "df", "p.value", "method"),
|
| 80 | -+ | 4x |
- #' stats::mood.test(ADSL[["AGE"]] ~ ADSL[["SEX"]]) |>+ stats = |
| 81 | -+ | 4x |
- #' broom::tidy()+ if (!is.null(lst_glance[["result"]])) unname(as.list(lst_glance[["result"]])) |
| 82 | -+ | 4x |
- #' )+ else rep_along(c("statistic", "df", "p.value"), list(NULL)) |> c(list(method = method))
|
| 83 |
- #' )+ # styler: on |
||
| 84 |
- .format_moodtest_results <- function(by, variable, lst_tidy, ...) {
+ ) |> |
||
| 85 | -+ | 4x |
- # build ARD ------------------------------------------------------------------+ .add_survdiff_stat_labels() |> |
| 86 | -2x | +4x |
- ret <-+ dplyr::mutate( |
| 87 | -2x | +4x |
- cards::tidy_as_ard(+ context = "survival_survdiff", |
| 88 | -2x | +4x |
- lst_tidy = lst_tidy,+ warning = lst_glance["warning"], |
| 89 | -2x | +4x |
- tidy_result_names = c("statistic", "p.value", "method", "alternative"),
+ error = lst_glance["error"], |
| 90 | -2x | +4x |
- formals = formals(asNamespace("stats")[["mood.test.default"]]),
+ fmt_fn = map( |
| 91 | -2x | +4x |
- passed_args = c(dots_list(...)),+ .data$stat, |
| 92 | -2x | +4x |
- lst_ard_columns = list(group1 = by, variable = variable, context = "moodtest")+ function(x) {
|
| 93 | -+ | 9x |
- )+ if (is.numeric(x)) return(1L) # styler: off |
| 94 | -+ | 7x |
-
+ NULL |
| 95 |
- # add the stat label ---------------------------------------------------------+ } |
||
| 96 | -2x | +
- ret |>+ ) |
|
| 97 | -2x | +
- dplyr::left_join(+ ) |> |
|
| 98 | -2x | +4x |
- .df_moodtest_stat_labels(),+ cards::as_card() |> |
| 99 | -2x | +4x |
- by = "stat_name"+ cards::tidy_ard_column_order() |
| 100 |
- ) |>+ } |
||
| 101 | -2x | +
- dplyr::mutate(stat_label = dplyr::coalesce(.data$stat_label, .data$stat_name)) |>+ |
|
| 102 | -2x | +
- cards::tidy_ard_column_order()+ .variables_to_survdiff_ard <- function(variables, |
|
| 103 |
- }+ method, |
||
| 104 |
-
+ stat_names, |
||
| 105 |
- .df_moodtest_stat_labels <- function() {
+ stats) {
|
||
| 106 | -2x | +4x |
- dplyr::tribble(+ len <- length(variables) |
| 107 | -2x | +
- ~stat_name, ~stat_label,+ |
|
| 108 | -2x | +4x |
- "statistic", "Z-Statistic",+ df_vars <- dplyr::tibble(!!!rev(variables)) |> |
| 109 | -2x | +4x |
- "p.value", "p-value",+ set_names( |
| 110 | -2x | +4x |
- "alternative", "Alternative Hypothesis"+ ifelse( |
| 111 | -+ | 4x |
- )+ len > 1L, |
| 112 | -- |
- }- |
-
| 1 | -+ | 4x |
- #' ARD 2-sample proportion test+ c(paste0("group_", rev(seq_len(len - 1L))), "variable"),
|
|
| 2 | -+ | |||
| 113 | +4x |
- #'+ "variable" |
||
| 3 | +114 |
- #' @description+ ) |
||
| 4 | +115 |
- #' Analysis results data for a 2-sample test or proportions using [`stats::prop.test()`].+ ) |
||
| 5 | +116 |
- #'+ |
||
| 6 | -+ | |||
| 117 | +4x |
- #' @param data (`data.frame`)\cr+ dplyr::bind_cols( |
||
| 7 | -+ | |||
| 118 | +4x |
- #' a data frame.+ df_vars, |
||
| 8 | -+ | |||
| 119 | +4x |
- #' @param by ([`tidy-select`][dplyr::dplyr_tidy_select])\cr+ dplyr::tibble( |
||
| 9 | -+ | |||
| 120 | +4x |
- #' column name to compare by+ stat_name = .env$stat_names, |
||
| 10 | -+ | |||
| 121 | +4x |
- #' @param variable ([`tidy-select`][dplyr::dplyr_tidy_select])\cr+ stat = .env$stats |
||
| 11 | +122 |
- #' column name to be compared. Must be a binary column coded as `TRUE`/`FALSE`+ ) |
||
| 12 | +123 |
- #' or `1`/`0`.+ ) |
||
| 13 | +124 |
- #' @param ... arguments passed to `prop.test(...)`+ } |
||
| 14 | +125 |
- #'+ |
||
| 15 | +126 |
- #' @return ARD data frame+ .add_survdiff_stat_labels <- function(x) {
|
||
| 16 | -+ | |||
| 127 | +4x |
- #' @export+ x |> |
||
| 17 | -+ | |||
| 128 | +4x |
- #'+ dplyr::left_join( |
||
| 18 | -+ | |||
| 129 | +4x |
- #' @examplesIf cards::is_pkg_installed("broom", reference_pkg = "cardx")
+ dplyr::tribble( |
||
| 19 | -+ | |||
| 130 | +4x |
- #' mtcars |>+ ~stat_name, ~stat_label, |
||
| 20 | -+ | |||
| 131 | +4x |
- #' ard_proptest(by = vs, variable = am)+ "statistic", "X^2 Statistic", |
||
| 21 | -+ | |||
| 132 | +4x |
- ard_proptest <- function(data, by, variable, ...) {
+ "df", "Degrees of Freedom", |
||
| 22 | -3x | +133 | +4x |
- cards::check_pkg_installed("broom", reference_pkg = "cardx")
+ "p.value", "p-value" |
| 23 | +134 |
- # check inputs ---------------------------------------------------------------+ ), |
||
| 24 | -3x | +135 | +4x |
- check_not_missing(data)+ by = "stat_name" |
| 25 | -3x | +|||
| 136 | +
- check_not_missing(variable)+ ) |> |
|||
| 26 | -3x | +137 | +4x |
- check_not_missing(by)+ dplyr::mutate(stat_label = dplyr::coalesce(.data$stat_label, .data$stat_name)) |
| 27 | -3x | +|||
| 138 | +
- check_data_frame(data)+ } |
|||
| 28 | +139 | |||
| 29 | +140 |
- # process inputs -------------------------------------------------------------+ .strip_backticks <- function(x) {
|
||
| 30 | -3x | +141 | +5x |
- cards::process_selectors(data, by = {{ by }}, variable = {{ variable }})
+ ifelse( |
| 31 | -3x | +142 | +5x |
- check_scalar(by)+ str_detect(x, "^`.*`$"), |
| 32 | -3x | +143 | +5x |
- check_scalar(variable)+ substr(x, 2, nchar(x) - 1), |
| 33 | -3x | +144 | +5x |
- data <- data[c(by, variable)] |> dplyr::ungroup() |> tidyr::drop_na() # styler: off+ x |
| 34 | +145 |
-
+ ) |
||
| 35 | +146 |
- # build ARD ------------------------------------------------------------------+ } |
||
| 36 | -3x | +
| 1 | +
- .format_proptest_results(+ #' ARD McNemar's Test |
|||
| 37 | -3x | +|||
| 2 | +
- by = by,+ #' |
|||
| 38 | -3x | -
- variable = variable,- |
- ||
| 39 | -3x | +|||
| 3 | +
- lst_tidy =+ #' @description |
|||
| 40 | -3x | +|||
| 4 | +
- cards::eval_capture_conditions({
+ #' Analysis results data for McNemar's statistical test. |
|||
| 41 | -3x | +|||
| 5 | +
- check_binary(data[[variable]], arg_name = "variable")+ #' We have two functions depending on the structure of the data. |
|||
| 42 | +6 |
-
+ #' - `ard_stats_mcnemar_test()` is the structure expected by [`stats::mcnemar.test()`] |
||
| 43 | -2x | +|||
| 7 | +
- data_counts <-+ #' - `ard_stats_mcnemar_test_long()` is one row per ID per group |
|||
| 44 | -2x | +|||
| 8 | +
- dplyr::arrange(data, .data[[by]]) |>+ #' |
|||
| 45 | -2x | +|||
| 9 | +
- dplyr::summarise(+ #' @param data (`data.frame`)\cr |
|||
| 46 | -2x | +|||
| 10 | +
- .by = all_of(by),+ #' a data frame. See below for details. |
|||
| 47 | -2x | +|||
| 11 | +
- x = sum(.data[[variable]]),+ #' @param by ([`tidy-select`][dplyr::dplyr_tidy_select])\cr |
|||
| 48 | -2x | +|||
| 12 | +
- n = length(.data[[variable]])+ #' column name to compare by. |
|||
| 49 | +13 |
- )+ #' @param variables ([`tidy-select`][dplyr::dplyr_tidy_select])\cr |
||
| 50 | +14 |
-
+ #' column names to be compared. Independent tests will |
||
| 51 | -2x | +|||
| 15 | +
- if (nrow(data_counts) != 2) {
+ #' be computed for each variable. |
|||
| 52 | -1x | +|||
| 16 | +
- cli::cli_abort(c(+ #' @param ... arguments passed to `stats::mcnemar.test(...)` |
|||
| 53 | -1x | +|||
| 17 | +
- "The {.arg by} column must have exactly 2 levels.",
+ #' @param id ([`tidy-select`][dplyr::dplyr_tidy_select])\cr |
|||
| 54 | -1x | +|||
| 18 | +
- "The levels are {.val {data_counts[[by]]}}"
+ #' column name of the subject or participant ID |
|||
| 55 | +19 |
- ))+ #' |
||
| 56 | +20 |
- }+ #' @return ARD data frame |
||
| 57 | +21 |
-
+ #' @name ard_stats_mcnemar_test |
||
| 58 | -1x | +|||
| 22 | +
- stats::prop.test(+ #' |
|||
| 59 | -1x | +|||
| 23 | +
- x = data_counts[["x"]],+ #' @details |
|||
| 60 | -1x | +|||
| 24 | +
- n = data_counts[["n"]],+ #' For the `ard_stats_mcnemar_test()` function, the data is expected to be one row per subject. |
|||
| 61 | +25 |
- ...+ #' The data is passed as `stats::mcnemar.test(x = data[[variable]], y = data[[by]], ...)`. |
||
| 62 | +26 |
- ) |>+ #' Please use `table(x = data[[variable]], y = data[[by]])` to check the contingency table. |
||
| 63 | -1x | +|||
| 27 | +
- broom::tidy() |>+ #' |
|||
| 64 | +28 |
- # add central estimate for difference+ #' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = "broom"))
|
||
| 65 | -1x | +|||
| 29 | +
- dplyr::mutate(estimate = .data$estimate1 - .data$estimate2, .before = 1L)+ #' cards::ADSL |> |
|||
| 66 | +30 |
- }),+ #' ard_stats_mcnemar_test(by = "SEX", variables = "EFFFL") |
||
| 67 | +31 |
- ...+ #' |
||
| 68 | +32 |
- )+ #' set.seed(1234) |
||
| 69 | +33 |
- }+ #' cards::ADSL[c("USUBJID", "TRT01P")] |>
|
||
| 70 | +34 |
-
+ #' dplyr::mutate(TYPE = "PLANNED") |> |
||
| 71 | +35 |
-
+ #' dplyr::rename(TRT01 = TRT01P) %>% |
||
| 72 | +36 |
- #' Convert prop.test to ARD+ #' dplyr::bind_rows(dplyr::mutate(., TYPE = "ACTUAL", TRT01 = sample(TRT01))) |> |
||
| 73 | +37 |
- #'+ #' ard_stats_mcnemar_test_long( |
||
| 74 | +38 |
- #' @inheritParams cards::tidy_as_ard+ #' by = TYPE, |
||
| 75 | +39 |
- #' @param by (`string`)\cr by column name+ #' variable = TRT01, |
||
| 76 | +40 |
- #' @param variable (`string`)\cr variable column name+ #' id = USUBJID |
||
| 77 | +41 |
- #' @param ... passed to `prop.test(...)`+ #' ) |
||
| 78 | +42 |
- #'+ NULL |
||
| 79 | +43 |
- #' @return ARD data frame+ |
||
| 80 | +44 |
- #' @keywords internal+ #' @rdname ard_stats_mcnemar_test |
||
| 81 | +45 |
- .format_proptest_results <- function(by, variable, lst_tidy, ...) {
+ #' @export |
||
| 82 | +46 |
- # build ARD ------------------------------------------------------------------+ ard_stats_mcnemar_test <- function(data, by, variables, ...) {
|
||
| 83 | -3x | +47 | +7x |
- ret <-+ set_cli_abort_call() |
| 84 | -3x | +|||
| 48 | +
- cards::tidy_as_ard(+ |
|||
| 85 | -3x | +|||
| 49 | +
- lst_tidy = lst_tidy,+ # check installed packages --------------------------------------------------- |
|||
| 86 | -3x | +50 | +7x |
- tidy_result_names = c(+ check_pkg_installed("broom")
|
| 87 | -3x | +|||
| 51 | +
- "estimate", "estimate1", "estimate2", "statistic",+ |
|||
| 88 | -3x | +|||
| 52 | +
- "p.value", "parameter", "conf.low", "conf.high",+ # check/process inputs ------------------------------------------------------- |
|||
| 89 | -3x | +53 | +7x | +
+ check_not_missing(data)+ |
+
| 54 | +7x | +
+ check_not_missing(variables)+ |
+ ||
| 55 | +7x | +
+ check_not_missing(by)+ |
+ ||
| 56 | +7x | +
+ check_data_frame(data)+ |
+ ||
| 57 | +7x | +
+ data <- dplyr::ungroup(data)+ |
+ ||
| 58 | +7x | +
+ cards::process_selectors(data, by = {{ by }}, variables = {{ variables }})
+ |
+ ||
| 59 | +7x | +
+ check_scalar(by)+ |
+ ||
| 60 | ++ | + + | +||
| 61 | ++ |
+ # return empty ARD if no variables selected ----------------------------------+ |
+ ||
| 62 | +7x | +
+ if (is_empty(variables)) {
+ |
+ ||
| 63 | +! | +
+ return(dplyr::tibble() |> cards::as_card())+ |
+ ||
| 64 | ++ |
+ }+ |
+ ||
| 65 | ++ | + + | +||
| 66 | ++ |
+ # build ARD ------------------------------------------------------------------+ |
+ ||
| 67 | +7x | +
+ lapply(+ |
+ ||
| 68 | +7x | +
+ variables,+ |
+ ||
| 69 | +7x | +
+ function(variable) {
+ |
+ ||
| 70 | +8x | +
+ .format_mcnemartest_results(+ |
+ ||
| 71 | +8x | +
+ by = by,+ |
+ ||
| 72 | +8x | +
+ variable = variable,+ |
+ ||
| 73 | +8x | +
+ lst_tidy =+ |
+ ||
| 74 | +8x | +
+ cards::eval_capture_conditions(+ |
+ ||
| 75 | +8x | +
+ stats::mcnemar.test(x = data[[variable]], y = data[[by]], ...) |>+ |
+ ||
| 76 | +8x | +
+ broom::tidy()+ |
+ ||
| 77 | ++ |
+ ),+ |
+ ||
| 78 | ++ |
+ ...+ |
+ ||
| 79 | ++ |
+ )+ |
+ ||
| 80 | ++ |
+ }+ |
+ ||
| 81 | ++ |
+ ) |>+ |
+ ||
| 82 | +7x | +
+ dplyr::bind_rows()+ |
+ ||
| 83 | ++ |
+ }+ |
+ ||
| 84 | ++ | + + | +||
| 85 | ++ |
+ #' @rdname ard_stats_mcnemar_test+ |
+ ||
| 86 | ++ |
+ #' @export+ |
+ ||
| 87 | ++ |
+ ard_stats_mcnemar_test_long <- function(data, by, variables, id, ...) {
+ |
+ ||
| 88 | +1x | +
+ set_cli_abort_call()+ |
+ ||
| 89 | ++ | + + | +||
| 90 | ++ |
+ # check installed packages ---------------------------------------------------+ |
+ ||
| 91 | +1x | +
+ check_pkg_installed("broom")
+ |
+ ||
| 92 | ++ | + + | +||
| 93 | ++ |
+ # check/process inputs -------------------------------------------------------+ |
+ ||
| 94 | +1x | +
+ check_not_missing(data)+ |
+ ||
| 95 | +1x | +
+ check_not_missing(variables)+ |
+ ||
| 96 | +1x | +
+ check_not_missing(by)+ |
+ ||
| 97 | +1x | +
+ check_not_missing(id)+ |
+ ||
| 98 | +1x | +
+ check_data_frame(data)+ |
+ ||
| 99 | +1x | +
+ data <- dplyr::ungroup(data)+ |
+ ||
| 100 | +1x | +
+ cards::process_selectors(data, by = {{ by }}, variables = {{ variables }}, id = {{ id }})
+ |
+ ||
| 101 | +1x | +
+ check_scalar(by)+ |
+ ||
| 102 | +1x | +
+ check_scalar(id)+ |
+ ||
| 103 | ++ | + + | +||
| 104 | ++ |
+ # return empty ARD if no variables selected ----------------------------------+ |
+ ||
| 105 | +1x | +
+ if (is_empty(variables)) {
+ |
+ ||
| 106 | +! | +
+ return(dplyr::tibble() |> cards::as_card())+ |
+ ||
| 107 | ++ |
+ }+ |
+ ||
| 108 | ++ | + + | +||
| 109 | ++ |
+ # build ARD ------------------------------------------------------------------+ |
+ ||
| 110 | +1x | +
+ lapply(+ |
+ ||
| 111 | +1x | +
+ variables,+ |
+ ||
| 112 | +1x | +
+ function(variable) {
+ |
+ ||
| 113 | +1x | +
+ .format_mcnemartest_results(+ |
+ ||
| 114 | +1x | +
+ by = by,+ |
+ ||
| 115 | +1x | +
+ variable = variable,+ |
+ ||
| 116 | +1x | +
+ lst_tidy =+ |
+ ||
| 117 | +1x | +
+ cards::eval_capture_conditions({
+ |
+ ||
| 118 | ++ |
+ # adding this reshape inside the eval, so if there is an error it's captured in the ARD object+ |
+ ||
| 119 | +1x | +
+ data_wide <- .paired_data_pivot_wider(data, by = by, variable = variable, id = id)+ |
+ ||
| 120 | ++ |
+ # performing McNemars test+ |
+ ||
| 121 | +1x | +
+ stats::mcnemar.test(x = data_wide[["by1"]], y = data_wide[["by2"]], ...) |>+ |
+ ||
| 122 | +1x | +
+ broom::tidy()+ |
+ ||
| 123 | ++ |
+ }),+ |
+ ||
| 124 | ++ |
+ ...+ |
+ ||
| 125 | ++ |
+ )+ |
+ ||
| 126 | ++ |
+ }+ |
+ ||
| 127 | ++ |
+ ) |>+ |
+ ||
| 128 | +1x | +
+ dplyr::bind_rows()+ |
+ ||
| 129 | ++ |
+ }+ |
+ ||
| 130 | ++ | + + | +||
| 131 | ++ |
+ #' Convert McNemar's test to ARD+ |
+ ||
| 132 | ++ |
+ #'+ |
+ ||
| 133 | ++ |
+ #' @inheritParams cards::tidy_as_ard+ |
+ ||
| 134 | ++ |
+ #' @inheritParams stats::mcnemar.test+ |
+ ||
| 135 | ++ |
+ #' @param by (`string`)\cr by column name+ |
+ ||
| 136 | ++ |
+ #' @param variable (`string`)\cr variable column name+ |
+ ||
| 137 | ++ |
+ #' @param ... passed to `stats::mcnemar.test(...)`+ |
+ ||
| 138 | ++ |
+ #'+ |
+ ||
| 139 | ++ |
+ #' @return ARD data frame+ |
+ ||
| 140 | ++ |
+ #'+ |
+ ||
| 141 | ++ |
+ #' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = "broom"))
+ |
+ ||
| 142 | ++ |
+ #' cardx:::.format_mcnemartest_results(+ |
+ ||
| 143 | ++ |
+ #' by = "ARM",+ |
+ ||
| 144 | ++ |
+ #' variable = "AGE",+ |
+ ||
| 145 | ++ |
+ #' lst_tidy =+ |
+ ||
| 146 | ++ |
+ #' cards::eval_capture_conditions(+ |
+ ||
| 147 | ++ |
+ #' stats::mcnemar.test(cards::ADSL[["SEX"]], cards::ADSL[["EFFFL"]]) |>+ |
+ ||
| 148 | ++ |
+ #' broom::tidy()+ |
+ ||
| 149 | ++ |
+ #' )+ |
+ ||
| 150 | ++ |
+ #' )+ |
+ ||
| 151 | ++ |
+ #'+ |
+ ||
| 152 | ++ |
+ #' @keywords internal+ |
+ ||
| 153 | ++ |
+ .format_mcnemartest_results <- function(by, variable, lst_tidy, ...) {
+ |
+ ||
| 154 | ++ |
+ # build ARD ------------------------------------------------------------------+ |
+ ||
| 155 | +9x | +
+ ret <-+ |
+ ||
| 156 | +9x | +
+ cards::tidy_as_ard(+ |
+ ||
| 157 | +9x | +
+ lst_tidy = lst_tidy,+ |
+ ||
| 158 | +9x | +
+ tidy_result_names = c("statistic", "p.value", "method"),
+ |
+ ||
| 159 | +9x | +
+ fun_args_to_record = c("correct"),
+ |
+ ||
| 160 | +9x | +
+ formals = formals(asNamespace("stats")[["mcnemar.test"]]),
+ |
+ ||
| 161 | +9x | +
+ passed_args = dots_list(...),+ |
+ ||
| 162 | +9x | +
+ lst_ard_columns = list(group1 = by, variable = variable, context = "stats_mcnemar_test")+ |
+ ||
| 163 | ++ |
+ )+ |
+ ||
| 164 | ++ | + + | +||
| 165 | ++ |
+ # add the stat label ---------------------------------------------------------+ |
+ ||
| 166 | +9x | +
+ ret |>+ |
+ ||
| 167 | +9x | +
+ dplyr::left_join(+ |
+ ||
| 168 | +9x | +
+ .df_mcnemar_stat_labels(),+ |
+ ||
| 169 | +9x | +
+ by = "stat_name"+ |
+ ||
| 170 | ++ |
+ ) |>+ |
+ ||
| 171 | +9x | +
+ dplyr::mutate(stat_label = dplyr::coalesce(.data$stat_label, .data$stat_name)) |>+ |
+ ||
| 172 | +9x | +
+ cards::as_card() |>+ |
+ ||
| 173 | +9x | +
+ cards::tidy_ard_column_order()+ |
+ ||
| 174 | ++ |
+ }+ |
+ ||
| 175 | ++ | + + | +||
| 176 | ++ |
+ .df_mcnemar_stat_labels <- function() {
+ |
+ ||
| 177 | +9x | +
+ dplyr::tribble(+ |
+ ||
| 178 | +9x | +
+ ~stat_name, ~stat_label,+ |
+ ||
| 179 | +9x | +
+ "statistic", "X-squared Statistic",+ |
+ ||
| 180 | +9x | +
+ "parameter", "Degrees of Freedom",+ |
+ ||
| 181 | +9x | +
+ "p.value", "p-value",+ |
+ ||
| 182 | ++ |
+ )+ |
+ ||
| 183 | ++ |
+ }+ |
+
| 1 | ++ |
+ #' ARD Poisson Test+ |
+
| 2 | ++ |
+ #'+ |
+
| 3 | ++ |
+ #' @description+ |
+
| 4 | ++ |
+ #' Analysis results data for exact tests of a simple null hypothesis about the rate parameter+ |
+
| 5 | ++ |
+ #' in Poisson distribution, or the comparison of two rate parameters.+ |
+
| 6 | ++ |
+ #'+ |
+
| 7 | ++ |
+ #' @param data (`data.frame`)\cr+ |
+
| 8 | ++ |
+ #' a data frame. See below for details.+ |
+
| 9 | ++ |
+ #' @param variables ([`tidy-select`][dplyr::dplyr_tidy_select])\cr+ |
+
| 10 | ++ |
+ #' names of the event and time variables (in that order) to be used in computations. Must be of length 2.+ |
+
| 11 | ++ |
+ #' @param by ([`tidy-select`][dplyr::dplyr_tidy_select])\cr+ |
+
| 12 | ++ |
+ #' optional column name to compare by.+ |
+
| 13 | ++ |
+ #' @param conf.level (scalar `numeric`)\cr+ |
+
| 14 | ++ |
+ #' confidence level for confidence interval. Default is `0.95`.+ |
+
| 15 | ++ |
+ #' @param na.rm (scalar `logical`)\cr+ |
+
| 16 | ++ |
+ #' whether missing values should be removed before computations. Default is `TRUE`.+ |
+
| 17 | ++ |
+ #' @param ... arguments passed to [poisson.test()].+ |
+
| 18 | ++ |
+ #' @return an ARD data frame of class 'card'+ |
+
| 19 | ++ |
+ #' @name ard_stats_poisson_test+ |
+
| 20 | ++ |
+ #'+ |
+
| 21 | ++ |
+ #' @details+ |
+
| 22 | ++ |
+ #' * For the `ard_stats_poisson_test()` function, the data is expected to be one row per subject.+ |
+
| 23 | ++ |
+ #' * If `by` is not specified, an exact Poisson test of the rate parameter will be performed. Otherwise, a+ |
+
| 24 | ++ |
+ #' Poisson comparison of two rate parameters will be performed on the levels of `by`. If `by` has more than 2+ |
+
| 25 | ++ |
+ #' levels, an error will occur.+ |
+
| 26 | ++ |
+ #'+ |
+
| 27 | ++ |
+ #' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = "broom"))
+ |
+
| 28 | ++ |
+ #' # Exact test of rate parameter against null hypothesis+ |
+
| 29 | ++ |
+ #' cards::ADTTE |>+ |
+
| 30 | ++ |
+ #' ard_stats_poisson_test(variables = c(CNSR, AVAL))+ |
+
| 31 | ++ |
+ #'+ |
+
| 32 | ++ |
+ #' # Comparison test of ratio of 2 rate parameters against null hypothesis+ |
+
| 33 | ++ |
+ #' cards::ADTTE |>+ |
+
| 34 | ++ |
+ #' dplyr::filter(TRTA %in% c("Placebo", "Xanomeline High Dose")) |>
+ |
+
| 35 | ++ |
+ #' ard_stats_poisson_test(by = TRTA, variables = c(CNSR, AVAL))+ |
+
| 36 | ++ |
+ NULL+ |
+
| 37 | ++ | + + | +
| 38 | ++ |
+ #' @rdname ard_stats_poisson_test+ |
+
| 39 | ++ |
+ #' @export+ |
+
| 40 | ++ |
+ ard_stats_poisson_test <- function(data, variables, na.rm = TRUE, by = NULL, conf.level = 0.95, ...) {
+ |
+
| 41 | +5x | +
+ set_cli_abort_call()+ |
+
| 42 | ++ | + + | +
| 43 | ++ |
+ # check installed packages ---------------------------------------------------+ |
+
| 44 | +5x | +
+ check_pkg_installed("broom")
+ |
+
| 45 | ++ | + + | +
| 46 | ++ |
+ # check/process inputs -------------------------------------------------------+ |
+
| 47 | +5x | +
+ check_not_missing(data)+ |
+
| 48 | +5x | +
+ check_not_missing(variables)+ |
+
| 49 | +5x | +
+ check_data_frame(data)+ |
+
| 50 | +5x | +
+ data <- dplyr::ungroup(data)+ |
+
| 51 | +5x | +
+ cards::process_selectors(data, by = {{ by }}, variables = {{ variables }})
+ |
+
| 52 | +5x | +
+ check_length(variables, 2)+ |
+
| 53 | +5x | +
+ check_logical(na.rm)+ |
+
| 54 | +5x | +
+ check_scalar(by, allow_empty = TRUE)+ |
+
| 55 | +5x | +
+ check_range(conf.level, range = c(0, 1))+ |
+
| 56 | ++ | + + | +
| 57 | ++ |
+ # return empty ARD if no variables selected ----------------------+ |
+
| 58 | +5x | +
+ if (is_empty(variables)) {
+ |
+
| 59 | +! | +
+ return(dplyr::tibble() |> cards::as_card())+ |
+
| 60 | ++ |
+ }+ |
+
| 61 | ++ | + + | +
| 62 | ++ |
+ # check number of levels in `by`+ |
+
| 63 | +5x | +
+ if (!is_empty(by) && dplyr::n_distinct(data[[by]], na.rm = TRUE) != 2L) {
+ |
+
| 64 | +1x | +
+ cli::cli_abort(+ |
+
| 65 | +1x | +
+ "The {.arg by} argument must have a maximum of two levels.",
+ |
+
| 66 | +1x | +
+ call = get_cli_abort_call()+ |
+
| 67 | ++ |
+ )+ |
+
| 68 | ++ |
+ }+ |
+
| 69 | ++ | + + | +
| 70 | ++ |
+ # calculate numerator and denominator values+ |
+
| 71 | +4x | +
+ if (!is_empty(by)) {
+ |
+
| 72 | +1x | +
+ num <- data |>+ |
+
| 73 | +1x | +
+ dplyr::group_by(.data[[by]]) |>+ |
+
| 74 | +1x | +
+ dplyr::summarise(sum = sum(.data[[variables[1]]], na.rm = na.rm)) |>+ |
+
| 75 | +1x | +
+ dplyr::pull(sum)+ |
+
| 76 | +1x | +
+ denom <- data |>+ |
+
| 77 | +1x | +
+ dplyr::group_by(.data[[by]]) |>+ |
+
| 78 | +1x | +
+ dplyr::summarise(sum = sum(.data[[variables[2]]], na.rm = na.rm)) |>+ |
+
| 79 | +1x | +
+ dplyr::pull(sum)+ |
+
| 80 | ++ |
+ } else {
+ |
+
| 81 | +3x | +
+ num <- sum(data[[variables[1]]], na.rm = na.rm)+ |
+
| 82 | +3x | +
+ denom <- sum(data[[variables[2]]], na.rm = na.rm)+ |
+
| 83 | ++ |
+ }+ |
+
| 84 | ++ | + + | +
| 85 | ++ |
+ # build ARD ------------------------------------------------------------------+ |
+
| 86 | +4x | +
+ .format_poissontest_results(+ |
+
| 87 | +4x | +
+ by = by,+ |
+
| 88 | +4x | +
+ variables = variables,+ |
+
| 89 | +4x | +
+ lst_tidy =+ |
+
| 90 | +4x | +
+ cards::eval_capture_conditions(+ |
+
| 91 | +4x | +
+ stats::poisson.test(x = num, T = denom, conf.level = conf.level, ...) |> broom::tidy()+ |
+
| 92 | ++ |
+ ),+ |
+
| 93 | ++ |
+ ...+ |
+
| 94 | ++ |
+ )+ |
+
| 95 | ++ |
+ }+ |
+
| 96 | ++ | + + | +
| 97 | ++ |
+ #' Convert Poisson test to ARD+ |
+
| 98 | ++ |
+ #'+ |
+
| 99 | ++ |
+ #' @inheritParams cards::tidy_as_ard+ |
+
| 100 | ++ |
+ #' @inheritParams stats::poisson.test+ |
+
| 101 | ++ |
+ #' @param by (`string`)\cr by column name+ |
+
| 102 | ++ |
+ #' @param variables (`character`)\cr names of the event and time variables+ |
+
| 103 | ++ |
+ #' @param ... passed to [poisson.test()]+ |
+
| 104 | ++ |
+ #'+ |
+
| 105 | ++ |
+ #' @return ARD data frame+ |
+
| 106 | ++ |
+ #' @keywords internal+ |
+
| 107 | ++ |
+ #' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = "broom"))
+ |
+
| 108 | ++ |
+ #' cardx:::.format_poissontest_results(+ |
+
| 109 | ++ |
+ #' by = "ARM",+ |
+
| 110 | ++ |
+ #' variables = c("CNSR", "AVAL"),
+ |
+
| 111 | ++ |
+ #' lst_tidy =+ |
+
| 112 | ++ |
+ #' cards::eval_capture_conditions(+ |
+
| 113 | ++ |
+ #' stats::poisson.test(sum(cards::ADTTE[["CNSR"]]), sum(cards::ADTTE[["AVAL"]])) |>+ |
+
| 114 | ++ |
+ #' broom::tidy()+ |
+
| 115 | ++ |
+ #' )+ |
+
| 116 | ++ |
+ #' )+ |
+
| 117 | ++ |
+ .format_poissontest_results <- function(by = NULL, variables, lst_tidy, ...) {
+ |
+
| 118 | ++ |
+ # build ARD ------------------------------------------------------------------+ |
+
| 119 | +4x | +
+ ret <-+ |
+
| 120 | +4x | +
+ cards::tidy_as_ard(+ |
+
| 121 | +4x | +
+ lst_tidy = lst_tidy,+ |
+
| 122 | +4x | +
+ tidy_result_names =+ |
+
| 123 | +4x | +
+ c(+ |
+
| 124 | +4x | +
+ "estimate", "statistic",+ |
+
| 125 | +4x | +
+ "p.value", "parameter", "conf.low", "conf.high",+ |
+
| 126 | +4x | +
+ "method", "alternative"+ |
+
| 127 | ++ |
+ ),+ |
+
| 128 | +4x | +
+ fun_args_to_record = c("conf.level", "r"),
+ |
+
| 129 | +4x | +
+ formals = formals(asNamespace("stats")[["poisson.test"]]),
+ |
+
| 130 | +4x | +
+ passed_args = dots_list(...),+ |
+
| 131 | +4x | +
+ lst_ard_columns = list(context = "stats_poisson_test", variable = variables[2])+ |
+
| 132 | ++ |
+ ) |>+ |
+
| 133 | +4x | +
+ dplyr::distinct()+ |
+
| 134 | ++ | + + | +
| 135 | ++ |
+ # rename "r" statistic to "mu"+ |
+
| 136 | +4x | +
+ ret$stat_name[ret$stat_name == "r"] <- "mu"+ |
+
| 137 | ++ | + + | +
| 138 | +4x | +
+ if (!is_empty(by)) {
+ |
+
| 139 | +1x | +
+ ret <- ret |>+ |
+
| 140 | +1x | +
+ dplyr::mutate(group1 = by)+ |
+
| 141 | ++ |
+ }+ |
+
| 142 | ++ | + + | +
| 143 | ++ |
+ # add the stat label ---------------------------------------------------------+ |
+
| 144 | +4x | +
+ ret |>+ |
+
| 145 | +4x | +
+ dplyr::left_join(+ |
+
| 146 | +4x | +
+ .df_poissontest_stat_labels(by = by),+ |
+
| 147 | +4x | +
+ by = "stat_name"+ |
+
| 148 | ++ |
+ ) |>+ |
+
| 149 | +4x | +
+ dplyr::mutate(stat_label = dplyr::coalesce(.data$stat_label, .data$stat_name)) |>+ |
+
| 150 | +4x | +
+ cards::as_card() |>+ |
+
| 151 | +4x | +
+ cards::tidy_ard_column_order()+ |
+
| 152 | ++ |
+ }+ |
+
| 153 | ++ | + + | +
| 154 | ++ |
+ .df_poissontest_stat_labels <- function(by = NULL) {
+ |
+
| 155 | +4x | +
+ dplyr::tribble(+ |
+
| 156 | +4x | +
+ ~stat_name, ~stat_label,+ |
+
| 157 | +4x | +
+ "estimate", ifelse(is_empty(by), "Estimated Rate", "Estimated Rate Ratio"),+ |
+
| 158 | +4x | +
+ "statistic", ifelse(is_empty(by), "Number of Events", "Number of Events in First Sample"),+ |
+
| 159 | +4x | +
+ "p.value", "p-value",+ |
+
| 160 | +4x | +
+ "parameter", "Expected Count",+ |
+
| 161 | +4x | +
+ "conf.low", "CI Lower Bound",+ |
+
| 162 | +4x | +
+ "conf.high", "CI Upper Bound",+ |
+
| 163 | +4x | +
+ "mu", "H0 Mean",+ |
+
| 164 | +4x | +
+ "conf.level", "CI Confidence Level"+ |
+
| 165 | ++ |
+ )+ |
+
| 166 | ++ |
+ }+ |
+
| 1 | ++ |
+ #' ARD Standardized Mean Difference+ |
+
| 2 | ++ |
+ #'+ |
+
| 3 | ++ |
+ #' @description+ |
+
| 4 | ++ |
+ #' Standardized mean difference calculated via [`smd::smd()`] with `na.rm = TRUE`.+ |
+
| 5 | ++ |
+ #' Additionally, this function add a confidence interval to the SMD when+ |
+
| 6 | ++ |
+ #' `std.error=TRUE`, which the original `smd::smd()` does not include.+ |
+
| 7 | ++ |
+ #'+ |
+
| 8 | ++ |
+ #' @param data (`data.frame`/`survey.design`)\cr+ |
+
| 9 | ++ |
+ #' a data frame or object of class 'survey.design'+ |
+
| 10 | ++ |
+ #' (typically created with [`survey::svydesign()`]).+ |
+
| 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 | ++ |
+ #' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = "smd"))
+ |
+
| 27 | ++ |
+ #' ard_smd_smd(cards::ADSL, by = SEX, variables = AGE)+ |
+
| 28 | ++ |
+ #' ard_smd_smd(cards::ADSL, by = SEX, variables = AGEGR1)+ |
+
| 29 | ++ |
+ ard_smd_smd <- function(data, by, variables, std.error = TRUE, conf.level = 0.95, ...) {
+ |
+
| 30 | +6x | +
+ set_cli_abort_call()+ |
+
| 31 | ++ | + + | +
| 32 | ++ |
+ # check installed packages ---------------------------------------------------+ |
+
| 33 | +6x | +
+ check_pkg_installed("smd")
+ |
+
| 34 | ++ | + + | +
| 35 | ++ |
+ # check/process inputs -------------------------------------------------------+ |
+
| 36 | +6x | +
+ check_not_missing(data)+ |
+
| 37 | +6x | +
+ check_not_missing(variables)+ |
+
| 38 | +6x | +
+ check_not_missing(by)+ |
+
| 39 | ++ | + + | +
| 40 | ++ |
+ # grab design object if from `survey` ----------------------------------------+ |
+
| 41 | +6x | +
+ is_survey <- inherits(data, "survey.design")+ |
+
| 42 | +6x | +
+ if (is_survey) {
+ |
+
| 43 | +1x | +
+ design <- data+ |
+
| 44 | +1x | +
+ data <- design$variables+ |
+
| 45 | ++ |
+ }+ |
+
| 46 | ++ | + + | +
| 47 | ++ |
+ # continue check/process inputs ----------------------------------------------+ |
+
| 48 | +6x | +
+ check_data_frame(data)+ |
+
| 49 | +6x | +
+ data <- dplyr::ungroup(data)+ |
+
| 50 | +6x | +
+ cards::process_selectors(data, by = {{ by }}, variables = {{ variables }})
+ |
+
| 51 | +6x | +
+ check_scalar(by)+ |
+
| 52 | ++ |
+ # This check can be relaxed, but would require some changes to handle multi-row outputs+ |
+
| 53 | +6x | +
+ check_n_levels(data[[by]], 2L, message = "The {.arg by} column must have {.val {length}} levels.")
+ |
+
| 54 | ++ | + + | +
| 55 | ++ |
+ # return empty ARD if no variables selected ----------------------------------+ |
+
| 56 | +6x | +
+ if (is_empty(variables)) {
+ |
+
| 57 | +! | +
+ return(dplyr::tibble() |> cards::as_card())+ |
+
| 58 | ++ |
+ }+ |
+
| 59 | ++ | + + | +
| 60 | ++ |
+ # build ARD ------------------------------------------------------------------+ |
+
| 61 | +6x | +
+ lapply(+ |
+
| 62 | +6x | +
+ variables,+ |
+
| 63 | +6x | +
+ function(variable) {
+ |
+
| 64 | +7x | +
+ .format_smd_results(+ |
+
| 65 | +7x | +
+ by = by,+ |
+
| 66 | +7x | +
+ variable = variable,+ |
+
| 67 | +7x | +
+ lst_tidy =+ |
+
| 68 | +7x | +
+ cards::eval_capture_conditions(+ |
+
| 69 | +7x | +
+ switch(as.character(is_survey),+ |
+
| 70 | +7x | +
+ "TRUE" = smd::smd(x = data[[variable]], g = data[[by]], w = stats::weights(design), na.rm = TRUE, std.error = std.error, ...),+ |
+
| 71 | +7x | +
+ "FALSE" = smd::smd(x = data[[variable]], g = data[[by]], na.rm = TRUE, std.error = std.error, ...)+ |
+
| 72 | ++ |
+ ) |>+ |
+
| 73 | +7x | +
+ dplyr::select(-any_of("term")) %>%
+ |
+
| 74 | ++ |
+ # styler: off+ |
+
| 75 | +6x | +
+ {if (isTRUE(std.error))
+ |
+
| 76 | +6x | +
+ dplyr::mutate(+ |
+
| 77 | ++ |
+ .,+ |
+
| 78 | +6x | +
+ conf.low = .data$estimate + stats::qnorm((1 - .env$conf.level) / 2) * .data$std.error,+ |
+
| 79 | +6x | +
+ conf.high = .data$estimate - stats::qnorm((1 - .env$conf.level) / 2) * .data$std.error,+ |
+
| 80 | +6x | +
+ method = "Standardized Mean Difference"+ |
+
| 81 | ++ |
+ )+ |
+
| 82 | ++ |
+ else+ |
+
| 83 | +! | +
+ dplyr::mutate(+ |
+
| 84 | ++ |
+ .,+ |
+
| 85 | +! | +
+ method = "Standardized Mean Difference"+ |
+
| 86 | ++ |
+ )}+ |
+
| 87 | ++ |
+ # styler: on+ |
+
| 88 | ++ |
+ ),+ |
+
| 89 | ++ |
+ ...+ |
+
| 90 | ++ |
+ )+ |
+
| 91 | ++ |
+ }+ |
+
| 92 | ++ |
+ ) |>+ |
+
| 93 | +6x | +
+ dplyr::bind_rows()+ |
+
| 94 | ++ |
+ }+ |
+
| 95 | ++ | + + | +
| 96 | ++ | + + | +
| 97 | ++ |
+ .format_smd_results <- function(by, variable, lst_tidy, ...) {
+ |
+
| 98 | ++ |
+ # build ARD ------------------------------------------------------------------+ |
+
| 99 | +7x | +
+ ret <-+ |
+
| 100 | +7x | +
+ cards::tidy_as_ard(+ |
+
| 101 | +7x | +
+ lst_tidy = lst_tidy,+ |
+
| 102 | +7x | +
+ tidy_result_names = c("estimate", "std.error"),
+ |
+
| 103 | +7x | +
+ fun_args_to_record = c("gref"),
+ |
+
| 104 | +7x | +
+ formals = formals(smd::smd)[c("gref")],
+ |
+
| 105 | ++ |
+ # removing the `std.error` ARGUMENT (not the result)+ |
+
| 106 | +7x | +
+ passed_args = dots_list(...) |> utils::modifyList(list(std.error = NULL)),+ |
+
| 107 | +7x | +
+ lst_ard_columns = list(group1 = by, variable = variable, context = "smd_smd")+ |
+
| 108 | ++ |
+ )+ |
+
| 109 | ++ | + + | +
| 110 | ++ |
+ # add the stat label ---------------------------------------------------------+ |
+
| 111 | +7x | +
+ ret |>+ |
+
| 112 | +7x | +
+ dplyr::left_join(+ |
+
| 113 | +7x | +
+ dplyr::tribble(+ |
+
| 114 | +7x | +
+ ~stat_name, ~stat_label,+ |
+
| 115 | +7x | +
+ "estimate", "Standardized Mean Difference",+ |
+
| 116 | +7x | +
+ "std.error", "Standard Error",+ |
+
| 117 | +7x | +
+ "gref", "Integer Reference Group Level"+ |
+
| 118 | ++ |
+ ),+ |
+
| 119 | +7x | +
+ by = "stat_name"+ |
+
| 120 | ++ |
+ ) |>+ |
+
| 121 | +7x | +
+ dplyr::mutate(stat_label = dplyr::coalesce(.data$stat_label, .data$stat_name)) |>+ |
+
| 122 | +7x | +
+ cards::as_card() |>+ |
+
| 123 | +7x | +
+ cards::tidy_ard_column_order()+ |
+
| 124 | ++ |
+ }+ |
+
| 1 | ++ |
+ #' ARD Survival Estimates+ |
+
| 2 | ++ |
+ #'+ |
+
| 3 | ++ |
+ #' @description+ |
+
| 4 | ++ |
+ #' Analysis results data for survival quantiles and x-year survival estimates, extracted+ |
+
| 5 | ++ |
+ #' from a [survival::survfit()] model.+ |
+
| 6 | ++ |
+ #'+ |
+
| 7 | ++ |
+ #' @param x ([survival::survfit()])\cr+ |
+
| 8 | ++ |
+ #' a [survival::survfit()] object. See below for details.+ |
+
| 9 | ++ |
+ #' @param times (`numeric`)\cr+ |
+
| 10 | ++ |
+ #' a vector of times for which to return survival probabilities.+ |
+
| 11 | ++ |
+ #' @param probs (`numeric`)\cr+ |
+
| 12 | ++ |
+ #' a vector of probabilities with values in (0,1) specifying the survival quantiles to return.+ |
+
| 13 | ++ |
+ #' @param type (`string` or `NULL`)\cr+ |
+
| 14 | ++ |
+ #' type of statistic to report. Available for Kaplan-Meier time estimates only, otherwise `type`+ |
+
| 15 | ++ |
+ #' is ignored. Default is `NULL`.+ |
+
| 16 | ++ |
+ #' Must be one of the following:+ |
+
| 17 | ++ |
+ #' ```{r, echo = FALSE}
+ |
+
| 18 | ++ |
+ #' dplyr::tribble(+ |
+
| 19 | ++ |
+ #' ~type, ~transformation,+ |
+
| 20 | ++ |
+ #' '`"survival"`', '`x`',+ |
+
| 21 | ++ |
+ #' '`"risk"`', '`1 - x`',+ |
+
| 22 | ++ |
+ #' '`"cumhaz"`', '`-log(x)`',+ |
+
| 23 | ++ |
+ #' ) %>%+ |
+
| 24 | ++ |
+ #' knitr::kable()+ |
+
| 25 | ++ |
+ #' ```+ |
+
| 26 | ++ |
+ #'+ |
+
| 27 | ++ |
+ #' @return an ARD data frame of class 'card'+ |
+
| 28 | ++ |
+ #' @name ard_survival_survfit+ |
+
| 29 | ++ |
+ #'+ |
+
| 30 | ++ |
+ #' @details+ |
+
| 31 | ++ |
+ #' * Only one of either the `times` or `probs` parameters can be specified.+ |
+
| 32 | ++ |
+ #' * Times should be provided using the same scale as the time variable used to fit the provided+ |
+
| 33 | ++ |
+ #' survival fit model.+ |
+
| 34 | ++ |
+ #'+ |
+
| 35 | ++ |
+ #' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = c("survival", "broom", "ggsurvfit")))
+ |
+
| 36 | ++ |
+ #' library(survival)+ |
+
| 37 | ++ |
+ #' library(ggsurvfit)+ |
+
| 38 | ++ |
+ #'+ |
+
| 39 | ++ |
+ #' survfit(Surv_CNSR(AVAL, CNSR) ~ TRTA, data = cards::ADTTE) |>+ |
+
| 40 | ++ |
+ #' ard_survival_survfit(times = c(60, 180))+ |
+
| 41 | ++ |
+ #'+ |
+
| 42 | ++ |
+ #' survfit(Surv_CNSR(AVAL, CNSR) ~ TRTA, data = cards::ADTTE, conf.int = 0.90) |>+ |
+
| 43 | ++ |
+ #' ard_survival_survfit(probs = c(0.25, 0.5, 0.75))+ |
+
| 44 | ++ |
+ #'+ |
+
| 45 | ++ |
+ #' # Competing Risks Example ---------------------------+ |
+
| 46 | ++ |
+ #' set.seed(1)+ |
+
| 47 | ++ |
+ #' ADTTE_MS <- cards::ADTTE %>%+ |
+
| 48 | ++ |
+ #' dplyr::mutate(+ |
+
| 49 | ++ |
+ #' CNSR = dplyr::case_when(+ |
+
| 50 | ++ |
+ #' CNSR == 0 ~ "censor",+ |
+
| 51 | ++ |
+ #' runif(dplyr::n()) < 0.5 ~ "death from cancer",+ |
+
| 52 | ++ |
+ #' TRUE ~ "death other causes"+ |
+
| 53 | ++ |
+ #' ) %>% factor()+ |
+
| 54 | ++ |
+ #' )+ |
+
| 55 | ++ |
+ #'+ |
+
| 56 | ++ |
+ #' survfit(Surv(AVAL, CNSR) ~ TRTA, data = ADTTE_MS) %>%+ |
+
| 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) {
+ |
+
| 63 | +17x | +
+ set_cli_abort_call()+ |
+
| 64 | ++ | + + | +
| 65 | ++ |
+ # check installed packages ---------------------------------------------------+ |
+
| 66 | +17x | +
+ check_pkg_installed(c("survival", "broom"))
+ |
+
| 67 | ++ | + + | +
| 68 | ++ |
+ # check/process inputs -------------------------------------------------------+ |
+
| 69 | +17x | +
+ check_not_missing(x)+ |
+
| 70 | +17x | +
+ check_class(x, cls = "survfit")+ |
+
| 71 | +16x | +
+ 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 | ++ |
+ }+ |
+
| 76 | ++ | + + | +
| 77 | ++ |
+ # competing risks models cannot use the type argument+ |
+
| 78 | +15x | +
+ 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')}}.",
+ |
+
| 80 | +! | +
+ call = get_cli_abort_call()+ |
+
| 81 | ++ |
+ )+ |
+
| 82 | ++ |
+ }+ |
+
| 83 | +4x | +
+ if (!is.null(probs)) check_range(probs, c(0, 1))+ |
+
| 84 | +15x | +
+ if (sum(is.null(times), is.null(probs)) != 1) {
+ |
+
| 85 | +1x | +
+ cli::cli_abort("One and only one of {.arg times} and {.arg probs} must be specified.")
+ |
+
| 86 | ++ |
+ }+ |
+
| 87 | ++ | + + | +
| 88 | ++ |
+ # for regular KM estimators, we allow the type argument+ |
+
| 89 | +14x | +
+ if (!inherits(x, "survfitms") && !is.null(type)) {
+ |
+
| 90 | +2x | +
+ type <- arg_match(type, values = c("survival", "risk", "cumhaz"))
+ |
+
| 91 | ++ |
+ }+ |
+
| 92 | ++ | + + | +
| 93 | ++ |
+ # cannot specify type arg when probs supplied+ |
+
| 94 | +13x | +
+ 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()+ |
+
| 97 | ++ |
+ )+ |
+
| 98 | ++ |
+ }+ |
+
| 99 | ++ | + + | +
| 100 | ++ |
+ # build ARD ------------------------------------------------------------------+ |
+
| 101 | +13x | +
+ est_type <- ifelse(is.null(probs), "times", "probs")+ |
+
| 102 | +13x | +
+ tidy_survfit <- switch(est_type,+ |
+
| 103 | +13x | +
+ "times" = .process_survfit_time(x, times, type %||% "survival"),+ |
+
| 104 | +13x | +
+ "probs" = .process_survfit_probs(x, probs)+ |
+
| 105 | ++ |
+ )+ |
+
| 106 | ++ | + + | +
| 107 | +13x | +
+ .format_survfit_results(tidy_survfit)+ |
+
| 108 | ++ |
+ }+ |
+
| 109 | ++ | + + | +
| 110 | ++ |
+ #' Process Survival Fit For Time Estimates+ |
+
| 111 | ++ |
+ #'+ |
+
| 112 | ++ |
+ #' @inheritParams cards::tidy_as_ard+ |
+
| 113 | ++ |
+ #' @inheritParams ard_survival_survfit+ |
+
| 114 | ++ |
+ #' @param start.time (`numeric`)\cr+ |
+
| 115 | ++ |
+ #' default starting time. See [survival::survfit0()] for more details.+ |
+
| 116 | ++ |
+ #'+ |
+
| 117 | ++ |
+ #' @return a `tibble`+ |
+
| 118 | ++ |
+ #'+ |
+
| 119 | ++ |
+ #' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = c("survival", "broom")))
+ |
+
| 120 | ++ |
+ #' survival::survfit(survival::Surv(AVAL, CNSR) ~ TRTA, cards::ADTTE) |>+ |
+
| 121 | ++ |
+ #' cardx:::.process_survfit_time(times = c(60, 180), type = "risk")+ |
+
| 122 | ++ |
+ #'+ |
+
| 123 | ++ |
+ #' @keywords internal+ |
+
| 124 | ++ |
+ .process_survfit_time <- function(x, times, type, start.time = NULL) {
+ |
+
| 125 | ++ |
+ # add start time+ |
+
| 126 | +10x | +
+ min_time <- min(x$time)+ |
+
| 127 | +10x | +
+ if (is.null(start.time) && min_time < 0) {
+ |
+
| 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 | +! | +
+ "time via the {.arg start.time} argument, otherwise the minimum observed time will be used by default."
+ |
+
| 131 | ++ |
+ ))+ |
+
| 132 | +! | +
+ start.time <- min_time+ |
+
| 133 | +10x | +
+ } else if (is.null(start.time)) {
+ |
+
| 134 | +10x | +
+ start.time <- 0+ |
+
| 135 | ++ |
+ }+ |
+
| 136 | +10x | +
+ x <- survival::survfit0(x, start.time) %>%+ |
+
| 137 | +10x | +
+ summary(times)+ |
+
| 138 | ++ | + + | +
| 139 | ++ |
+ # process competing risks/multi-state models+ |
+
| 140 | +10x | +
+ multi_state <- inherits(x, "summary.survfitms")+ |
+
| 141 | ++ | + + | +
| 142 | +10x | +
+ if (multi_state) {
+ |
+
| 143 | ++ |
+ # selecting state to show+ |
+
| 144 | +1x | +
+ state <- setdiff(unique(x$states), "(s0)")[[1]]+ |
+
| 145 | +1x | +
+ cli::cli_inform("Multi-state model detected. Showing probabilities into state '{state}'.")
+ |
+
| 146 | +1x | +
+ x$n.risk <- x$n.risk[, 1]+ |
+
| 147 | +1x | +
+ ms_cols <- c("pstate", "std.err", "upper", "lower")
+ |
+
| 148 | +1x | +
+ state_col <- which(colnames(x$pstate) == state)+ |
+
| 149 | +1x | +
+ x[ms_cols] <- lapply(x[ms_cols], function(m) m[, state_col])+ |
+
| 150 | +1x | +
+ x$surv <- x$pstate+ |
+
| 151 | ++ |
+ }+ |
+
| 152 | ++ | + + | +
| 153 | ++ |
+ # tidy survfit results+ |
+
| 154 | +10x | +
+ x_cols <- intersect(names(x), c("time", "n.risk", "surv", "std.err", "upper", "lower", "strata"))
+ |
+
| 155 | +10x | +
+ tidy_x <- data.frame(x[x_cols]) %>%+ |
+
| 156 | +10x | +
+ dplyr::rename(estimate = "surv", std.error = "std.err", conf.high = "upper", conf.low = "lower")+ |
+
| 157 | ++ | + + | +
| 158 | +10x | +
+ strat <- "strata" %in% names(tidy_x)+ |
+
| 159 | ++ | + + | +
| 160 | ++ |
+ # get requested estimates+ |
+
| 161 | +10x | +
+ df_stat <- tidy_x %>%+ |
+
| 162 | ++ |
+ # find max time+ |
+
| 163 | +10x | +
+ dplyr::group_by_at(., dplyr::vars(dplyr::any_of("strata"))) %>%
+ |
+
| 164 | +10x | +
+ dplyr::mutate(time_max = max(.data$time)) %>%+ |
+
| 165 | +10x | +
+ dplyr::ungroup() %>%+ |
+
| 166 | ++ |
+ # add requested timepoints+ |
+
| 167 | +10x | +
+ dplyr::full_join(+ |
+
| 168 | +10x | +
+ tidy_x %>%+ |
+
| 169 | +10x | +
+ dplyr::select(any_of("strata")) %>%
+ |
+
| 170 | +10x | +
+ dplyr::distinct() %>%+ |
+
| 171 | +10x | +
+ dplyr::mutate(+ |
+
| 172 | +10x | +
+ time = list(.env$times),+ |
+
| 173 | +10x | +
+ col_name = list(paste("stat", seq_len(length(.env$times)), sep = "_"))
+ |
+
| 174 | ++ |
+ ) %>%+ |
+
| 175 | +10x | +
+ tidyr::unnest(cols = c("time", "col_name")),
+ |
+
| 176 | +10x | +
+ by = unlist(intersect(c("strata", "time"), names(tidy_x)))
+ |
+
| 177 | ++ |
+ )+ |
+
| 178 | ++ | + + | +
| 179 | +10x | +
+ if (strat) {
+ |
+
| 180 | +9x | +
+ df_stat <- df_stat %>% dplyr::arrange(.data$strata)+ |
+
| 181 | ++ |
+ }+ |
+
| 182 | ++ | + + | +
| 183 | +10x | +
+ df_stat <- df_stat %>%+ |
+
| 184 | +10x | +
+ dplyr::arrange(.data$time) %>%+ |
+
| 185 | ++ |
+ # if user-specified time is after max time, make estimate NA+ |
+
| 186 | +10x | +
+ dplyr::mutate_at(+ |
+
| 187 | +10x | +
+ dplyr::vars("estimate", "conf.high", "conf.low"),
+ |
+
| 188 | +10x | +
+ ~ ifelse(.data$time > .data$time_max, NA_real_, .)+ |
+
| 189 | ++ |
+ ) %>%+ |
+
| 190 | +10x | +
+ dplyr::mutate(context = type) %>%+ |
+
| 191 | +10x | +
+ dplyr::select(!dplyr::any_of(c("time_max", "col_name")))
+ |
+
| 192 | ++ | + + | +
| 193 | ++ |
+ # convert estimates to requested type+ |
+
| 194 | +10x | +
+ if (type != "survival") {
+ |
+
| 195 | +1x | +
+ df_stat <- df_stat %>%+ |
+
| 196 | +1x | +
+ dplyr::mutate(dplyr::across(+ |
+
| 197 | +1x | +
+ any_of(c("estimate", "conf.low", "conf.high")),
+ |
+
| 198 | +1x | +
+ if (type == "cumhaz") ~ -log(.x) else ~ 1 - .x+ |
+
| 199 | ++ |
+ )) %>%+ |
+
| 200 | +1x | +
+ dplyr::rename(conf.low = "conf.high", conf.high = "conf.low")+ |
+
| 201 | ++ |
+ }+ |
+
| 202 | ++ | + + | +
| 203 | +10x | +
+ df_stat <- extract_multi_strata(x, df_stat)+ |
+
| 204 | ++ | + + | +
| 205 | +10x | +
+ df_stat+ |
+
| 206 | ++ |
+ }+ |
+
| 207 | ++ | + + | +
| 208 | ++ |
+ #' Process Survival Fit For Quantile Estimates+ |
+
| 209 | ++ |
+ #'+ |
+
| 210 | ++ |
+ #' @inheritParams cards::tidy_as_ard+ |
+
| 211 | ++ |
+ #' @inheritParams ard_survival_survfit+ |
+
| 212 | ++ |
+ #'+ |
+
| 213 | ++ |
+ #' @return a `tibble`+ |
+
| 214 | ++ |
+ #'+ |
+
| 215 | ++ |
+ #' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = "survival"))
+ |
+
| 216 | ++ |
+ #' survival::survfit(survival::Surv(AVAL, CNSR) ~ TRTA, cards::ADTTE) |>+ |
+
| 217 | ++ |
+ #' cardx:::.process_survfit_probs(probs = c(0.25, 0.75))+ |
+
| 218 | ++ |
+ #'+ |
+
| 219 | ++ |
+ #' @keywords internal+ |
+
| 220 | ++ |
+ .process_survfit_probs <- function(x, probs) {
+ |
+
| 221 | ++ |
+ # calculate survival quantiles and add estimates to df+ |
+
| 222 | +3x | +
+ df_stat <- map2(+ |
+
| 223 | +3x | +
+ probs,+ |
+
| 224 | +3x | +
+ seq_along(probs),+ |
+
| 225 | +3x | +
+ ~ stats::quantile(x, probs = .x) %>%+ |
+
| 226 | +3x | +
+ as.data.frame() %>%+ |
+
| 227 | +3x | +
+ set_names(c("estimate", "conf.low", "conf.high")) %>%
+ |
+
| 228 | +3x | +
+ dplyr::mutate(strata = row.names(.)) %>%+ |
+
| 229 | +3x | +
+ dplyr::select(dplyr::any_of(c("n.risk", "strata", "estimate", "std.error", "conf.low", "conf.high"))) %>%
+ |
+
| 230 | +3x | +
+ dplyr::mutate(prob = .x)+ |
+
| 231 | ++ |
+ ) %>%+ |
+
| 232 | +3x | +
+ dplyr::bind_rows() %>%+ |
+
| 233 | +3x | +
+ `rownames<-`(NULL) %>%+ |
+
| 234 | +3x | +
+ dplyr::mutate(context = "survival_survfit") %>%+ |
+
| 235 | +3x | +
+ dplyr::as_tibble()+ |
+
| 236 | ++ | + + | +
| 237 | +1x | +
+ if (length(x$n) == 1) df_stat <- df_stat %>% dplyr::select(-"strata")+ |
+
| 238 | ++ | + + | +
| 239 | +3x | +
+ df_stat <- extract_multi_strata(x, df_stat)+ |
+
| 240 | ++ | + + | +
| 241 | +3x | +
+ df_stat+ |
+
| 242 | ++ |
+ }+ |
+
| 243 | ++ | + + | +
| 244 | ++ |
+ # process multiple stratifying variables+ |
+
| 245 | ++ |
+ extract_multi_strata <- function(x, df_stat) {
+ |
+
| 246 | +13x | +
+ x_terms <- attr(stats::terms(stats::as.formula(x$call$formula)), "term.labels")+ |
+
| 247 | +13x | +
+ x_terms <- gsub(".*\\(", "", gsub("\\)", "", x_terms))
+ |
+
| 248 | +13x | +
+ if (length(x_terms) > 1) {
+ |
+
| 249 | +4x | +
+ strata_lvls <- data.frame()+ |
+
| 250 | ++ | + + | +
| 251 | +4x | +
+ for (i in df_stat[["strata"]]) {
+ |
+
| 252 | +56x | +
+ i <- gsub(".*\\(", "", gsub("\\)", "", i))
+ |
+
| 253 | +56x | +
+ terms_str <- strsplit(i, paste(c(paste0(x_terms, "="), paste0(", ", x_terms, "=")), collapse = "|"))[[1]]
+ |
+
| 254 | +56x | +
+ s_lvl <- terms_str[nchar(terms_str) > 0]+ |
+
| 255 | +56x | +
+ strata_lvls <- rbind(strata_lvls, s_lvl)+ |
+
| 256 | ++ |
+ }+ |
+
| 257 | +4x | +
+ if (nrow(strata_lvls) > 0) {
+ |
+
| 258 | +4x | +
+ strata_lvls <- cbind(strata_lvls, t(x_terms))+ |
+
| 259 | +4x | +
+ names(strata_lvls) <- c(+ |
+
| 260 | +4x | +
+ t(sapply(seq_along(x_terms), function(i) c(paste0("group", i, "_level"), paste0("group", i))))
+ |
+
| 261 | ++ |
+ )+ |
+
| 262 | +4x | +
+ df_stat <- cbind(df_stat, strata_lvls) %>%+ |
+
| 263 | +4x | +
+ dplyr::select(-"strata")+ |
+
| 264 | ++ |
+ }+ |
+
| 265 | ++ |
+ }+ |
+
| 266 | +13x | +
+ df_stat+ |
+
| 267 | ++ |
+ }+ |
+
| 268 | ++ | + + | +
| 269 | ++ |
+ #' Convert Tidied Survival Fit to ARD+ |
+
| 270 | ++ |
+ #'+ |
+
| 271 | ++ |
+ #' @inheritParams cards::tidy_as_ard+ |
+
| 272 | ++ |
+ #'+ |
+
| 273 | ++ |
+ #' @return an ARD data frame of class 'card'+ |
+
| 274 | ++ |
+ #'+ |
+
| 275 | ++ |
+ #' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = c("survival", "broom")))
+ |
+
| 276 | ++ |
+ #' cardx:::.format_survfit_results(+ |
+
| 277 | ++ |
+ #' broom::tidy(survival::survfit(survival::Surv(AVAL, CNSR) ~ TRTA, cards::ADTTE))+ |
+
| 278 | ++ |
+ #' )+ |
+
| 279 | ++ |
+ #'+ |
+
| 280 | ++ |
+ #' @keywords internal+ |
+
| 281 | ++ |
+ .format_survfit_results <- function(tidy_survfit) {
+ |
+
| 282 | +13x | +
+ est <- if ("time" %in% names(tidy_survfit)) "time" else "prob"
+ |
+
| 283 | ++ | + + | +
| 284 | +13x | +
+ ret <- tidy_survfit %>%+ |
+
| 285 | +13x | +
+ dplyr::mutate(dplyr::across(+ |
+
| 286 | +13x | +
+ dplyr::any_of(c("n.risk", "estimate", "std.error", "conf.high", "conf.low", "time", "prob")), ~ as.list(.)
+ |
+
| 287 | ++ |
+ )) %>%+ |
+
| 288 | +13x | +
+ tidyr::pivot_longer(+ |
+
| 289 | +13x | +
+ cols = dplyr::any_of(c("n.risk", "estimate", "std.error", "conf.high", "conf.low")),
+ |
+
| 290 | +13x | +
+ names_to = "stat_name",+ |
+
| 291 | +13x | +
+ values_to = "stat"+ |
+
| 292 | ++ |
+ ) %>%+ |
+
| 293 | +13x | +
+ dplyr::mutate(+ |
+
| 294 | +13x | +
+ variable = est,+ |
+
| 295 | +13x | +
+ variable_level = .data[[est]]+ |
+
| 296 | ++ |
+ ) %>%+ |
+
| 297 | +13x | +
+ dplyr::select(-all_of(est))+ |
+
| 298 | ++ | + + | +
| 299 | +13x | +
+ if ("strata" %in% names(ret)) {
+ |
+
| 300 | +7x | +
+ ret <- ret %>%+ |
+
| 301 | +7x | +
+ tidyr::separate_wider_delim("strata", "=", names = c("group1", "group1_level"))
+ |
+
| 302 | ++ |
+ }+ |
+
| 303 | ++ | + + | +
| 304 | +13x | +
+ ret %>%+ |
+
| 305 | +13x | +
+ dplyr::left_join(+ |
+
| 306 | +13x | +
+ .df_survfit_stat_labels(),+ |
+
| 307 | +13x | +
+ by = "stat_name"+ |
+
| 308 | ++ |
+ ) %>%+ |
+
| 309 | +13x | +
+ dplyr::mutate(+ |
+
| 310 | +13x | +
+ fmt_fn = lapply(+ |
+
| 311 | +13x | +
+ .data$stat,+ |
+
| 312 | +13x | +
+ function(x) {
+ |
+
| 313 | +446x | +
+ switch(is.integer(x),+ |
+
| 314 | +446x | +
+ 0L+ |
+
| 315 | +446x | +
+ ) %||% switch(is.numeric(x),+ |
+
| 316 | +446x | +
+ 1L+ |
+
| 317 | ++ |
+ )+ |
+
| 318 | ++ |
+ }+ |
+
| 319 | ++ |
+ ),+ |
+
| 320 | +13x | +
+ stat_label = dplyr::coalesce(.data$stat_label, .data$stat_name)+ |
+
| 321 | ++ |
+ ) %>%+ |
+
| 322 | +13x | +
+ dplyr::mutate(dplyr::across(matches("group[0-9]*_level"), ~ as.list(as.factor(.x)))) %>%
+ |
+
| 323 | +13x | +
+ dplyr::mutate(+ |
+
| 324 | +13x | +
+ warning = list(NULL),+ |
+
| 325 | +13x | +
+ error = list(NULL)+ |
+
| 326 | ++ |
+ ) %>%+ |
+
| 327 | +13x | +
+ cards::as_card() %>%+ |
+
| 328 | +13x | +
+ cards::tidy_ard_column_order() %>%+ |
+
| 329 | +13x | +
+ cards::tidy_ard_row_order()+ |
+
| 330 | ++ |
+ }+ |
+
| 331 | ++ | + + | +
| 332 | ++ |
+ .df_survfit_stat_labels <- function() {
+ |
+
| 333 | +13x | +
+ dplyr::tribble(+ |
+
| 334 | +13x | +
+ ~stat_name, ~stat_label,+ |
+
| 335 | +13x | +
+ "n.risk", "Number of Subjects at Risk",+ |
+
| 336 | +13x | +
+ "estimate", "Survival Probability",+ |
+
| 337 | +13x | +
+ "std.error", "Standard Error (untransformed)",+ |
+
| 338 | +13x | +
+ "conf.low", "CI Lower Bound",+ |
+
| 339 | +13x | +
+ "conf.high", "CI Upper Bound",+ |
+
| 340 | +13x | +
+ "conf.level", "CI Confidence Level",+ |
+
| 341 | +13x | +
+ "prob", "Quantile",+ |
+
| 342 | +13x | +
+ "time", "Time"+ |
+
| 343 | ++ |
+ )+ |
+
| 344 | ++ |
+ }+ |
+
| 1 | ++ |
+ #' ARD Categorical Survey Statistics+ |
+
| 2 | ++ |
+ #'+ |
+
| 3 | ++ |
+ #' @description+ |
+
| 4 | ++ |
+ #' Compute tabulations on survey-weighted data.+ |
+
| 5 | ++ |
+ #'+ |
+
| 6 | ++ |
+ #' The counts and proportion (`"N"`, `"n"`, `"p"`) are calculated using `survey::svytable()`,+ |
+
| 7 | ++ |
+ #' and the standard errors and design effect (`"p.std.error"`, `"deff"`) are+ |
+
| 8 | ++ |
+ #' calculated using `survey::svymean()`.+ |
+
| 9 | ++ |
+ #'+ |
+
| 10 | ++ |
+ #' The unweighted statistics are calculated with `cards::ard_categorical.data.frame()`.+ |
+
| 11 | ++ |
+ #'+ |
+
| 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 | ++ |
+ #' columns to include in summaries.+ |
+
| 16 | ++ |
+ #' @param by ([`tidy-select`][dplyr::dplyr_tidy_select])\cr+ |
+
| 17 | ++ |
+ #' results are calculated for **all combinations** of the column specified+ |
+
| 18 | ++ |
+ #' and the variables. A single column may be specified.+ |
+
| 19 | ++ |
+ #' @param denominator (`string`)\cr+ |
+
| 20 | ++ |
+ #' a string indicating the type proportions to calculate. Must be one of+ |
+
| 21 | ++ |
+ #' `"column"` (the default), `"row"`, and `"cell"`.+ |
+
| 22 | ++ |
+ #' @param statistic ([`formula-list-selector`][cards::syntax])\cr+ |
+
| 23 | ++ |
+ #' a named list, a list of formulas,+ |
+
| 24 | ++ |
+ #' or a single formula where the list element is a character vector of+ |
+
| 25 | ++ |
+ #' statistic names to include. See default value for options.+ |
+
| 26 | ++ |
+ #' @param fmt_fn ([`formula-list-selector`][cards::syntax])\cr+ |
+
| 27 | ++ |
+ #' a named list, a list of formulas,+ |
+
| 28 | ++ |
+ #' or a single formula where the list element is a named list of functions+ |
+
| 29 | ++ |
+ #' (or the RHS of a formula),+ |
+
| 30 | ++ |
+ #' e.g. `list(mpg = list(mean = \(x) round(x, digits = 2) |> as.character))`.+ |
+
| 31 | ++ |
+ #' @param stat_label ([`formula-list-selector`][cards::syntax])\cr+ |
+
| 32 | ++ |
+ #' a named list, a list of formulas, or a single formula where+ |
+
| 33 | ++ |
+ #' the list element is either a named list or a list of formulas defining the+ |
+
| 34 | ++ |
+ #' statistic labels, e.g. `everything() ~ list(mean = "Mean", sd = "SD")` or+ |
+
| 35 | ++ |
+ #' `everything() ~ list(mean ~ "Mean", sd ~ "SD")`.+ |
+
| 36 | ++ |
+ #' @inheritParams rlang::args_dots_empty+ |
+
| 37 | ++ |
+ #'+ |
+
| 38 | ++ |
+ #' @return an ARD data frame of class 'card'+ |
+
| 39 | ++ |
+ #' @export+ |
+
| 40 | ++ |
+ #'+ |
+
| 41 | ++ |
+ #' @examplesIf cardx:::is_pkg_installed("survey")
+ |
+
| 42 | ++ |
+ #' svy_titanic <- survey::svydesign(~1, data = as.data.frame(Titanic), weights = ~Freq)+ |
+
| 43 | ++ |
+ #'+ |
+
| 44 | ++ |
+ #' ard_categorical(svy_titanic, variables = c(Class, Age), by = Survived)+ |
+
| 45 | ++ |
+ ard_categorical.survey.design <- function(data,+ |
+
| 46 | ++ |
+ variables,+ |
+
| 47 | ++ |
+ by = NULL,+ |
+
| 48 | ++ |
+ statistic = everything() ~ c("n", "N", "p", "p.std.error", "deff", "n_unweighted", "N_unweighted", "p_unweighted"),
+ |
+
| 49 | ++ |
+ denominator = c("column", "row", "cell"),
+ |
+
| 50 | ++ |
+ fmt_fn = NULL,+ |
+
| 51 | ++ |
+ stat_label = everything() ~ list(+ |
+
| 52 | ++ |
+ p = "%",+ |
+
| 53 | ++ |
+ p.std.error = "SE(%)",+ |
+
| 54 | ++ |
+ deff = "Design Effect",+ |
+
| 55 | ++ |
+ "n_unweighted" = "Unweighted n",+ |
+
| 56 | ++ |
+ "N_unweighted" = "Unweighted N",+ |
+
| 57 | ++ |
+ "p_unweighted" = "Unweighted %"+ |
+
| 58 | ++ |
+ ),+ |
+
| 59 | ++ |
+ ...) {
+ |
+
| 60 | +83x | +
+ set_cli_abort_call()+ |
+
| 61 | +83x | +
+ check_pkg_installed(pkg = "survey")+ |
+
| 62 | +83x | +
+ check_dots_empty()+ |
+
| 63 | +83x | +
+ deff <- TRUE # we may update in the future to make this an argument for users+ |
+
| 64 | ++ | + + | +
| 65 | ++ |
+ # process arguments ----------------------------------------------------------+ |
+
| 66 | +83x | +
+ check_not_missing(variables)+ |
+
| 67 | +83x | +
+ cards::process_selectors(+ |
+
| 68 | +83x | +
+ data = data$variables,+ |
+
| 69 | +83x | +
+ variables = {{ variables }},
+ |
+
| 70 | +83x | +
+ by = {{ by }}
+ |
+
| 71 | ++ |
+ )+ |
+
| 72 | +83x | +
+ variables <- setdiff(variables, by)+ |
+
| 73 | +83x | +
+ check_scalar(by, allow_empty = TRUE)+ |
+
| 74 | ++ | + + | +
| 75 | ++ |
+ # return empty ARD if no variables selected ----------------------------------+ |
+
| 76 | +83x | +
+ if (is_empty(variables)) {
+ |
+
| 77 | +! | +
+ return(dplyr::tibble() |> cards::as_card())+ |
+
| 78 | ++ |
+ }+ |
+
| 79 | ++ | + + | +
| 80 | +83x | +
+ check_na_factor_levels(data$variables, c(by, variables))+ |
+
| 81 | ++ | + + | +
| 82 | +83x | +
+ cards::process_formula_selectors(+ |
+
| 83 | +83x | +
+ data = data$variables[variables],+ |
+
| 84 | +83x | +
+ statistic = statistic,+ |
+
| 85 | +83x | +
+ fmt_fn = fmt_fn,+ |
+
| 86 | +83x | +
+ stat_label = stat_label+ |
+
| 87 | ++ |
+ )+ |
+
| 88 | +83x | +
+ cards::fill_formula_selectors(+ |
+
| 89 | +83x | +
+ data = data$variables[variables],+ |
+
| 90 | +83x | +
+ statistic = formals(asNamespace("cardx")[["ard_categorical.survey.design"]])[["statistic"]] |> eval(),
+ |
+
| 91 | ++ |
+ )+ |
+
| 92 | +83x | +
+ accepted_svy_stats <- c("n", "N", "p", "p.std.error", "deff", "n_unweighted", "N_unweighted", "p_unweighted")
+ |
+
| 93 | +83x | +
+ cards::check_list_elements(+ |
+
| 94 | +83x | +
+ x = statistic,+ |
+
| 95 | +83x | +
+ predicate = \(x) all(x %in% accepted_svy_stats),+ |
+
| 96 | +83x | +
+ error_msg = c("Error in the values of the {.arg statistic} argument.",
+ |
+
| 97 | +83x | +
+ i = "Values must be in {.val {accepted_svy_stats}}"
+ |
+
| 98 | ++ |
+ )+ |
+
| 99 | ++ |
+ )+ |
+
| 100 | +83x | +
+ denominator <- arg_match(denominator)+ |
+
| 101 | ++ | + + | +
| 102 | ++ |
+ # check the missingness+ |
+
| 103 | +83x | +
+ walk(+ |
+
| 104 | +83x | +
+ variables,+ |
+
| 105 | +83x | +
+ \(.x) {
+ |
+
| 106 | +149x | +
+ if (all(is.na(data$variables[[.x]])) && !inherits(.x, c("logical", "factor"))) {
+ |
+
| 107 | +3x | +
+ cli::cli_abort(+ |
+
| 108 | +3x | +
+ c("Column {.val {.x}} is all missing and cannot be tabulated.",
+ |
+
| 109 | +3x | +
+ i = "Only columns of class {.cls logical} and {.cls factor} can be tabulated when all values are missing."
+ |
+
| 110 | ++ |
+ ),+ |
+
| 111 | +3x | +
+ call = get_cli_abort_call()+ |
+
| 112 | ++ |
+ )+ |
+
| 113 | ++ |
+ }+ |
+
| 114 | ++ |
+ }+ |
+
| 115 | ++ |
+ )+ |
+
| 116 | ++ | + + | +
| 117 | ++ |
+ # return note about column names that result in errors -----------------------+ |
+
| 118 | +80x | +
+ if (any(by %in% c("variable", "variable_level", "group1_level", "p", "n"))) {
+ |
+
| 119 | +2x | +
+ cli::cli_abort(+ |
+
| 120 | +2x | +
+ "The {.arg by} argument cannot include variables named {.val {c('variable', 'variable_level', 'group1_level', 'p', 'n')}}.",
+ |
+
| 121 | +2x | +
+ call = get_cli_abort_call()+ |
+
| 122 | ++ |
+ )+ |
+
| 123 | ++ |
+ }+ |
+
| 124 | ++ | + + | +
| 125 | +78x | +
+ if (any(variables %in% c("by", "name", "n", "p", "p.std.error"))) {
+ |
+
| 126 | +2x | +
+ cli::cli_abort(+ |
+
| 127 | +2x | +
+ "The {.arg variables} argument cannot include variables named {.val {c('by', 'name', 'n', 'p', 'p.std.error')}}.",
+ |
+
| 128 | +2x | +
+ call = get_cli_abort_call()+ |
+
| 129 | ++ |
+ )+ |
+
| 130 | ++ |
+ }+ |
+
| 131 | ++ | + + | +
| 132 | ++ | + + | +
| 133 | ++ | + + | +
| 134 | ++ |
+ # calculate counts -----------------------------------------------------------+ |
+
| 135 | ++ |
+ # this tabulation accounts for unobserved combinations+ |
+
| 136 | +76x | +
+ svytable_counts <- .svytable_counts(data, variables, by, denominator)+ |
+
| 137 | ++ | + + | +
| 138 | ++ |
+ # calculate rate SE and DEFF -------------------------------------------------+ |
+
| 139 | +76x | +
+ svytable_rates <- .svytable_rate_stats(data, variables, by, denominator, deff)+ |
+
| 140 | ++ | + + | +
| 141 | ++ |
+ # convert results into a proper ARD object -----------------------------------+ |
+
| 142 | +76x | +
+ cards <-+ |
+
| 143 | +76x | +
+ svytable_counts |>+ |
+
| 144 | ++ |
+ # merge in the SE(p) and DEFF+ |
+
| 145 | +76x | +
+ dplyr::left_join(+ |
+
| 146 | +76x | +
+ svytable_rates |> dplyr::select(-"p"),+ |
+
| 147 | +76x | +
+ by = intersect(c("group1", "group1_level", "variable", "variable_level"), names(svytable_counts))
+ |
+
| 148 | ++ |
+ ) |>+ |
+
| 149 | ++ |
+ # make columns list columns+ |
+
| 150 | +76x | +
+ dplyr::mutate(across(-any_of(c("group1", "variable")), as.list)) |>
+ |
+
| 151 | +76x | +
+ tidyr::pivot_longer(+ |
+
| 152 | +76x | +
+ cols = -c(cards::all_ard_groups(), cards::all_ard_variables()),+ |
+
| 153 | +76x | +
+ names_to = "stat_name",+ |
+
| 154 | +76x | +
+ values_to = "stat"+ |
+
| 155 | ++ |
+ ) |>+ |
+
| 156 | ++ |
+ # keep statistics requested by user+ |
+
| 157 | +76x | +
+ dplyr::inner_join(+ |
+
| 158 | +76x | +
+ statistic |> enframe("variable", "stat_name") |> tidyr::unnest(cols = "stat_name"),
+ |
+
| 159 | +76x | +
+ by = c("variable", "stat_name")
+ |
+
| 160 | ++ |
+ )+ |
+
| 161 | ++ | + + | +
| 162 | ++ |
+ # add unweighted statistics --------------------------------------------------+ |
+
| 163 | +76x | +
+ statistic_unweighted <- statistic |>+ |
+
| 164 | +76x | +
+ lapply(\(x) keep(x, ~ endsWith(.x, "_unweighted")) |> str_remove("_unweighted$")) |>
+ |
+
| 165 | +76x | +
+ compact()+ |
+
| 166 | ++ | + + | +
| 167 | +76x | +
+ if (!is_empty(statistic_unweighted)) {
+ |
+
| 168 | +76x | +
+ cards_unweighted <-+ |
+
| 169 | +76x | +
+ ard_categorical(+ |
+
| 170 | +76x | +
+ data = data[["variables"]],+ |
+
| 171 | +76x | +
+ variables = all_of(names(statistic_unweighted)),+ |
+
| 172 | +76x | +
+ by = any_of(by),+ |
+
| 173 | +76x | +
+ statistic = statistic_unweighted,+ |
+
| 174 | +76x | +
+ denominator = denominator+ |
+
| 175 | ++ |
+ ) |>+ |
+
| 176 | ++ |
+ # all the survey levels are reported as character, so we do the same here.+ |
+
| 177 | +76x | +
+ dplyr::mutate(+ |
+
| 178 | +76x | +
+ across(+ |
+
| 179 | +76x | +
+ c(cards::all_ard_groups("levels"), cards::all_ard_variables("levels")),
+ |
+
| 180 | +76x | +
+ ~ map(.x, as.character)+ |
+
| 181 | ++ |
+ )+ |
+
| 182 | ++ |
+ ) |>+ |
+
| 183 | +76x | +
+ dplyr::select(-c("stat_label", "fmt_fn", "warning", "error")) |>
+ |
+
| 184 | +76x | +
+ dplyr::mutate(+ |
+
| 185 | +76x | +
+ stat_name =+ |
+
| 186 | +76x | +
+ dplyr::case_match(.data$stat_name, "n" ~ "n_unweighted", "N" ~ "N_unweighted", "p" ~ "p_unweighted")+ |
+
| 187 | ++ |
+ )+ |
+
| 188 | +76x | +
+ cards <- cards |> dplyr::bind_rows(cards_unweighted) # styler: off+ |
+
| 189 | ++ |
+ }+ |
+
| 190 | ++ | + + | +
| 191 | ++ |
+ # final processing of fmt_fn -------------------------------------------------+ |
+
| 192 | +76x | +
+ cards <- cards |>+ |
+
| 193 | +76x | +
+ .process_nested_list_as_df(+ |
+
| 194 | +76x | +
+ arg = fmt_fn,+ |
+
| 195 | +76x | +
+ new_column = "fmt_fn"+ |
+
| 196 | ++ |
+ ) |>+ |
+
| 197 | +76x | +
+ .default_svy_cat_fmt_fn()+ |
+
| 198 | ++ | + + | +
| 199 | ++ |
+ # merge in statistic labels --------------------------------------------------+ |
+
| 200 | +76x | +
+ cards <- cards |>+ |
+
| 201 | +76x | +
+ .process_nested_list_as_df(+ |
+
| 202 | +76x | +
+ arg = stat_label,+ |
+
| 203 | +76x | +
+ new_column = "stat_label",+ |
+
| 204 | +76x | +
+ unlist = TRUE+ |
+
| 205 | ++ |
+ ) |>+ |
+
| 206 | +76x | +
+ dplyr::mutate(stat_label = dplyr::coalesce(.data$stat_label, .data$stat_name))+ |
+
| 207 | ++ | + + | +
| 208 | ++ |
+ # return final object --------------------------------------------------------+ |
+
| 209 | +76x | +
+ cards |>+ |
+
| 210 | +76x | +
+ dplyr::mutate(+ |
+
| 211 | +76x | +
+ context = "categorical",+ |
+
| 212 | +76x | +
+ warning = list(NULL),+ |
+
| 213 | +76x | +
+ error = list(NULL),+ |
+
| 214 | ++ |
+ ) |>+ |
+
| 215 | +76x | +
+ cards::as_card() |>+ |
+
| 216 | +76x | +
+ cards::tidy_ard_column_order() |>+ |
+
| 217 | +76x | +
+ cards::tidy_ard_row_order()+ |
+
| 218 | ++ |
+ }+ |
+
| 219 | ++ | + + | +
| 220 | ++ |
+ # check for functions with NA factor levels (these are not allowed)+ |
+
| 221 | ++ |
+ check_na_factor_levels <- function(data, variables) {
+ |
+
| 222 | +132x | +
+ walk(+ |
+
| 223 | +132x | +
+ variables,+ |
+
| 224 | +132x | +
+ \(variable) {
+ |
+
| 225 | +258x | +
+ if (is.factor(data[[variable]]) && any(is.na(levels(data[[variable]])))) {
+ |
+
| 226 | +! | +
+ cli::cli_abort(+ |
+
| 227 | +! | +
+ "Column {.val {variable}} is a factor with {.val {NA}} levels, which are not allowed.",
+ |
+
| 228 | +! | +
+ call = get_cli_abort_call()+ |
+
| 229 | ++ |
+ )+ |
+
| 230 | ++ |
+ }+ |
+
| 231 | ++ |
+ }+ |
+
| 232 | ++ |
+ )+ |
+
| 233 | ++ |
+ }+ |
+
| 234 | ++ | + + | +
| 235 | ++ |
+ # this function returns a tibble with the SE(p) and DEFF+ |
+
| 236 | ++ |
+ .svytable_rate_stats <- function(data, variables, by, denominator, deff) {
+ |
+
| 237 | +54x | +
+ if (!is_empty(by)) by_lvls <- .unique_values_sort(data$variables, by) # styler: off+ |
+
| 238 | +76x | +
+ if (!is_empty(by) && length(by_lvls) == 1L) {
+ |
+
| 239 | +6x | +
+ data$variables[[by]] <-+ |
+
| 240 | +6x | +
+ case_switch(+ |
+
| 241 | +6x | +
+ inherits(data$variables[[by]], "factor") ~ fct_expand(data$variables[[by]], paste("not", by_lvls)),
+ |
+
| 242 | +6x | +
+ .default = factor(data$variables[[by]], levels = c(by_lvls, paste("not", by_lvls)))
+ |
+
| 243 | ++ |
+ )+ |
+
| 244 | ++ |
+ }+ |
+
| 245 | +76x | +
+ if (!is_empty(by) && inherits(data$variables[[by]], "logical")) {
+ |
+
| 246 | +9x | +
+ data$variables[[by]] <- factor(data$variables[[by]], levels = c(TRUE, FALSE))+ |
+
| 247 | ++ |
+ }+ |
+
| 248 | +76x | +
+ if (!is_empty(by) && !inherits(data$variables[[by]], "factor")) {
+ |
+
| 249 | +3x | +
+ data$variables[[by]] <- factor(data$variables[[by]])+ |
+
| 250 | ++ |
+ }+ |
+
| 251 | ++ | + + | +
| 252 | +76x | +
+ lapply(+ |
+
| 253 | +76x | +
+ variables,+ |
+
| 254 | +76x | +
+ \(variable) {
+ |
+
| 255 | ++ |
+ # convert the variable to a factor if not already one or a lgl, so we get the correct rate stats from svymean+ |
+
| 256 | +142x | +
+ if (!inherits(data$variables[[variable]], c("factor", "logical"))) {
+ |
+
| 257 | +6x | +
+ data$variables[[variable]] <- factor(data$variables[[variable]])+ |
+
| 258 | ++ |
+ }+ |
+
| 259 | ++ | + + | +
| 260 | ++ |
+ # there are issues with svymean() when a variable has only one level. adding a second as needed+ |
+
| 261 | +142x | +
+ variable_lvls <- .unique_values_sort(data$variables, variable)+ |
+
| 262 | +142x | +
+ if (length(variable_lvls) == 1L) {
+ |
+
| 263 | +6x | +
+ data$variables[[variable]] <-+ |
+
| 264 | +6x | +
+ case_switch(+ |
+
| 265 | +6x | +
+ inherits(data$variables[[variable]], "factor") ~ fct_expand(data$variables[[variable]], paste("not", variable_lvls)),
+ |
+
| 266 | +6x | +
+ .default = factor(data$variables[[variable]], levels = c(variable_lvls, paste("not", variable_lvls)))
+ |
+
| 267 | ++ |
+ )+ |
+
| 268 | ++ |
+ }+ |
+
| 269 | +142x | +
+ if (inherits(data$variables[[variable]], "logical")) {
+ |
+
| 270 | +22x | +
+ data$variables[[variable]] <- factor(data$variables[[variable]], levels = c(TRUE, FALSE))+ |
+
| 271 | ++ |
+ }+ |
+
| 272 | +142x | +
+ if (!inherits(data$variables[[variable]], "factor")) {
+ |
+
| 273 | +! | +
+ data$variables[[variable]] <- factor(data$variables[[variable]])+ |
+
| 274 | ++ |
+ }+ |
+
| 275 | ++ | + + | +
| 276 | ++ |
+ # each combination of denominator and whether there is a by variable is handled separately+ |
+
| 277 | +142x | +
+ result <-+ |
+
| 278 | +142x | +
+ case_switch(+ |
+
| 279 | ++ |
+ # by variable and column percentages+ |
+
| 280 | +142x | +
+ !is_empty(by) && denominator == "column" ~+ |
+
| 281 | +142x | +
+ .one_svytable_rates_by_column(data, variable, by, deff),+ |
+
| 282 | ++ |
+ # by variable and row percentages+ |
+
| 283 | +142x | +
+ !is_empty(by) && denominator == "row" ~+ |
+
| 284 | +142x | +
+ .one_svytable_rates_by_row(data, variable, by, deff),+ |
+
| 285 | ++ |
+ # by variable and cell percentages+ |
+
| 286 | +142x | +
+ !is_empty(by) && denominator == "cell" ~+ |
+
| 287 | +142x | +
+ .one_svytable_rates_by_cell(data, variable, by, deff),+ |
+
| 288 | ++ |
+ # no by variable and column/cell percentages+ |
+
| 289 | +142x | +
+ denominator %in% c("column", "cell") ~
+ |
+
| 290 | +142x | +
+ .one_svytable_rates_no_by_column_and_cell(data, variable, deff),+ |
+
| 291 | ++ |
+ # no by variable and row percentages+ |
+
| 292 | +142x | +
+ denominator == "row" ~+ |
+
| 293 | +142x | +
+ .one_svytable_rates_no_by_row(data, variable, deff)+ |
+
| 294 | ++ |
+ )+ |
+
| 295 | ++ | + + | +
| 296 | ++ |
+ # if a level was added, remove the fake level+ |
+
| 297 | +142x | +
+ if (length(variable_lvls) == 1L) {
+ |
+
| 298 | +6x | +
+ result <- result |> dplyr::filter(.data$variable_level %in% variable_lvls)+ |
+
| 299 | ++ |
+ }+ |
+
| 300 | +142x | +
+ if (!is_empty(by) && length(by_lvls) == 1L) {
+ |
+
| 301 | +12x | +
+ result <- result |> dplyr::filter(.data$group1_level %in% by_lvls)+ |
+
| 302 | ++ |
+ }+ |
+
| 303 | ++ | + + | +
| 304 | +142x | +
+ result+ |
+
| 305 | ++ |
+ }+ |
+
| 306 | ++ |
+ ) |>+ |
+
| 307 | +76x | +
+ dplyr::bind_rows()+ |
+
| 308 | ++ |
+ }+ |
+
| 309 | ++ | + + | +
| 310 | ++ |
+ .one_svytable_rates_no_by_row <- function(data, variable, deff) {
+ |
+
| 311 | +10x | +
+ dplyr::tibble(+ |
+
| 312 | +10x | +
+ variable = .env$variable,+ |
+
| 313 | +10x | +
+ variable_level = unique(data$variables[[variable]]) |> sort() |> as.character(),+ |
+
| 314 | +10x | +
+ p = 1,+ |
+
| 315 | +10x | +
+ p.std.error = 0,+ |
+
| 316 | +10x | +
+ deff = NaN+ |
+
| 317 | ++ |
+ )+ |
+
| 318 | ++ |
+ }+ |
+
| 319 | ++ | + + | +
| 320 | ++ |
+ .one_svytable_rates_no_by_column_and_cell <- function(data, variable, deff) {
+ |
+
| 321 | +29x | +
+ survey::svymean(reformulate2(variable), design = data, na.rm = TRUE, deff = deff) |>+ |
+
| 322 | +29x | +
+ dplyr::as_tibble(rownames = "var_level") |>+ |
+
| 323 | +29x | +
+ dplyr::mutate(+ |
+
| 324 | +29x | +
+ variable_level = str_remove(.data$var_level, pattern = paste0("^", .env$variable)),
+ |
+
| 325 | +29x | +
+ variable = .env$variable+ |
+
| 326 | ++ |
+ ) |>+ |
+
| 327 | +29x | +
+ dplyr::select("variable", "variable_level", p = "mean", p.std.error = "SE", any_of("deff"))
+ |
+
| 328 | ++ |
+ }+ |
+
| 329 | ++ | + + | +
| 330 | ++ |
+ .one_svytable_rates_by_cell <- function(data, variable, by, deff) {
+ |
+
| 331 | +20x | +
+ df_interaction_id <-+ |
+
| 332 | +20x | +
+ .df_all_combos(data, variable, by) |>+ |
+
| 333 | +20x | +
+ dplyr::mutate(+ |
+
| 334 | +20x | +
+ var_level =+ |
+
| 335 | +20x | +
+ glue::glue("interaction({.env$by}, {.env$variable}){.data$group1_level}.{.data$variable_level}")
+ |
+
| 336 | ++ |
+ )+ |
+
| 337 | ++ | + + | +
| 338 | +20x | +
+ survey::svymean(+ |
+
| 339 | +20x | +
+ x = inject(~ interaction(!!sym(bt(by)), !!sym(bt(variable)))),+ |
+
| 340 | +20x | +
+ design = data,+ |
+
| 341 | +20x | +
+ na.rm = TRUE,+ |
+
| 342 | +20x | +
+ deff = deff+ |
+
| 343 | ++ |
+ ) |>+ |
+
| 344 | +20x | +
+ dplyr::as_tibble(rownames = "var_level") |>+ |
+
| 345 | +20x | +
+ dplyr::left_join(df_interaction_id, by = "var_level") |>+ |
+
| 346 | +20x | +
+ dplyr::select(+ |
+
| 347 | +20x | +
+ cards::all_ard_groups(), cards::all_ard_variables(),+ |
+
| 348 | +20x | +
+ p = "mean", p.std.error = "SE", any_of("deff")
+ |
+
| 349 | ++ |
+ )+ |
+
| 350 | ++ |
+ }+ |
+
| 351 | ++ | + + | +
| 352 | ++ |
+ .one_svytable_rates_by_row <- function(data, variable, by, deff) {
+ |
+
| 353 | +60x | +
+ survey::svyby(+ |
+
| 354 | +60x | +
+ formula = reformulate2(by),+ |
+
| 355 | +60x | +
+ by = reformulate2(variable),+ |
+
| 356 | +60x | +
+ design = data,+ |
+
| 357 | +60x | +
+ FUN = survey::svymean,+ |
+
| 358 | +60x | +
+ na.rm = TRUE,+ |
+
| 359 | +60x | +
+ deff = deff+ |
+
| 360 | ++ |
+ ) |>+ |
+
| 361 | +60x | +
+ dplyr::as_tibble() |>+ |
+
| 362 | +60x | +
+ tidyr::pivot_longer(-all_of(variable)) |>+ |
+
| 363 | +60x | +
+ dplyr::mutate(+ |
+
| 364 | +60x | +
+ stat =+ |
+
| 365 | +60x | +
+ dplyr::case_when(+ |
+
| 366 | +60x | +
+ startsWith(.data$name, paste0("se.", by)) | startsWith(.data$name, paste0("se.`", by, "`")) ~ "p.std.error",
+ |
+
| 367 | +60x | +
+ startsWith(.data$name, paste0("DEff.", by)) | startsWith(.data$name, paste0("DEff.`", by, "`")) ~ "deff",
+ |
+
| 368 | +60x | +
+ TRUE ~ "p"+ |
+
| 369 | ++ |
+ ),+ |
+
| 370 | +60x | +
+ name =+ |
+
| 371 | +60x | +
+ str_remove_all(.data$name, "se\\.") %>%+ |
+
| 372 | +60x | +
+ str_remove_all("DEff\\.") %>%
+ |
+
| 373 | +60x | +
+ str_remove_all(by) %>%+ |
+
| 374 | +60x | +
+ str_remove_all("`")
+ |
+
| 375 | ++ |
+ ) |>+ |
+
| 376 | +60x | +
+ tidyr::pivot_wider(names_from = "stat", values_from = "value") |>+ |
+
| 377 | +60x | +
+ set_names(c("variable_level", "group1_level", "p", "p.std.error", "deff")) |>
+ |
+
| 378 | +60x | +
+ dplyr::mutate(+ |
+
| 379 | +60x | +
+ group1 = .env$by,+ |
+
| 380 | +60x | +
+ variable = .env$variable,+ |
+
| 381 | +60x | +
+ across(c("group1_level", "variable_level"), as.character)
+ |
+
| 382 | ++ |
+ )+ |
+
| 383 | ++ |
+ }+ |
+
| 384 | ++ | + + | +
| 385 | ++ |
+ .one_svytable_rates_by_column <- function(data, variable, by, deff) {
+ |
+
| 386 | +23x | +
+ survey::svyby(+ |
+
| 387 | +23x | +
+ formula = reformulate2(variable),+ |
+
| 388 | +23x | +
+ by = reformulate2(by),+ |
+
| 389 | +23x | +
+ design = data,+ |
+
| 390 | +23x | +
+ FUN = survey::svymean,+ |
+
| 391 | +23x | +
+ na.rm = TRUE,+ |
+
| 392 | +23x | +
+ deff = deff+ |
+
| 393 | ++ |
+ ) |>+ |
+
| 394 | +23x | +
+ dplyr::as_tibble() |>+ |
+
| 395 | +23x | +
+ tidyr::pivot_longer(-all_of(by)) |>+ |
+
| 396 | +23x | +
+ dplyr::mutate(+ |
+
| 397 | +23x | +
+ stat =+ |
+
| 398 | +23x | +
+ dplyr::case_when(+ |
+
| 399 | +23x | +
+ startsWith(.data$name, paste0("se.", variable)) | startsWith(.data$name, paste0("se.`", variable, "`")) ~ "p.std.error",
+ |
+
| 400 | +23x | +
+ startsWith(.data$name, paste0("DEff.", variable)) | startsWith(.data$name, paste0("DEff.`", variable, "`")) ~ "deff",
+ |
+
| 401 | +23x | +
+ TRUE ~ "p"+ |
+
| 402 | ++ |
+ ),+ |
+
| 403 | +23x | +
+ name =+ |
+
| 404 | +23x | +
+ str_remove_all(.data$name, "se\\.") %>%+ |
+
| 405 | +23x | +
+ str_remove_all("DEff\\.") %>%
+ |
+
| 406 | +23x | +
+ str_remove_all(variable) %>%+ |
+
| 407 | +23x | +
+ str_remove_all("`")
+ |
+
| 408 | ++ |
+ ) |>+ |
+
| 409 | +23x | +
+ tidyr::pivot_wider(names_from = "stat", values_from = "value") |>+ |
+
| 410 | +23x | +
+ set_names(c("group1_level", "variable_level", "p", "p.std.error", "deff")) |>
+ |
+
| 411 | +23x | +
+ dplyr::mutate(+ |
+
| 412 | +23x | +
+ group1 = .env$by,+ |
+
| 413 | +23x | +
+ variable = .env$variable,+ |
+
| 414 | +23x | +
+ across(c("group1_level", "variable_level"), as.character)
+ |
+
| 415 | ++ |
+ )+ |
+
| 416 | ++ |
+ }+ |
+
| 417 | ++ | + + | +
| 418 | ++ |
+ .svytable_counts <- function(data, variables, by, denominator) {
+ |
+
| 419 | +76x | +
+ df_counts <-+ |
+
| 420 | +76x | +
+ lapply(+ |
+
| 421 | +76x | +
+ variables,+ |
+
| 422 | +76x | +
+ \(variable) {
+ |
+
| 423 | ++ |
+ # perform weighted tabulation+ |
+
| 424 | +142x | +
+ df_count <-+ |
+
| 425 | +142x | +
+ survey::svytable(formula = reformulate2(c(by, variable)), design = data) |>+ |
+
| 426 | +142x | +
+ dplyr::as_tibble()+ |
+
| 427 | +142x | +
+ if (is_empty(by)) {
+ |
+
| 428 | +39x | +
+ names(df_count) <- c("variable_level", "n")
+ |
+
| 429 | +39x | +
+ df_count$variable <- variable+ |
+
| 430 | ++ |
+ } else {
+ |
+
| 431 | +103x | +
+ names(df_count) <- c("group1_level", "variable_level", "n")
+ |
+
| 432 | +103x | +
+ df_count$variable <- variable+ |
+
| 433 | +103x | +
+ df_count$group1 <- by+ |
+
| 434 | ++ |
+ }+ |
+
| 435 | ++ | + + | +
| 436 | ++ |
+ # adding unobserved levels+ |
+
| 437 | +142x | +
+ .df_all_combos(data, variable, by) %>%+ |
+
| 438 | +142x | +
+ dplyr::left_join(+ |
+
| 439 | +142x | +
+ df_count,+ |
+
| 440 | +142x | +
+ by = names(.)+ |
+
| 441 | ++ |
+ ) |>+ |
+
| 442 | +142x | +
+ tidyr::replace_na(list(n = 0)) # unobserved levels assigned zero count+ |
+
| 443 | ++ |
+ }+ |
+
| 444 | ++ |
+ ) |>+ |
+
| 445 | +76x | +
+ dplyr::bind_rows()+ |
+
| 446 | ++ | + + | +
| 447 | ++ |
+ # add big N and p, then return data frame of results+ |
+
| 448 | +76x | +
+ switch(denominator,+ |
+
| 449 | ++ |
+ "column" =+ |
+
| 450 | +24x | +
+ df_counts |>+ |
+
| 451 | +24x | +
+ dplyr::mutate(+ |
+
| 452 | +24x | +
+ .by = c(cards::all_ard_groups(), cards::all_ard_variables("names")),
+ |
+
| 453 | +24x | +
+ N = sum(.data$n),+ |
+
| 454 | +24x | +
+ p = .data$n / .data$N+ |
+
| 455 | ++ |
+ ),+ |
+
| 456 | ++ |
+ "row" =+ |
+
| 457 | +37x | +
+ df_counts |>+ |
+
| 458 | +37x | +
+ dplyr::mutate(+ |
+
| 459 | +37x | +
+ .by = cards::all_ard_variables(),+ |
+
| 460 | +37x | +
+ N = sum(.data$n),+ |
+
| 461 | +37x | +
+ p = .data$n / .data$N+ |
+
| 462 | ++ |
+ ),+ |
+
| 463 | ++ |
+ "cell" =+ |
+
| 464 | +15x | +
+ df_counts |>+ |
+
| 465 | +15x | +
+ dplyr::mutate(+ |
+
| 466 | +15x | +
+ .by = c(cards::all_ard_groups("names"), cards::all_ard_variables("names")),
+ |
+
| 467 | +15x | +
+ N = sum(.data$n),+ |
+
| 468 | +15x | +
+ p = .data$n / .data$N+ |
+
| 469 | ++ |
+ )+ |
+
| 470 | ++ |
+ )+ |
+
| 471 | ++ |
+ }+ |
+
| 472 | ++ | + + | +
| 473 | ++ |
+ .df_all_combos <- function(data, variable, by) {
+ |
+
| 474 | +162x | +
+ df <-+ |
+
| 475 | +162x | +
+ tidyr::expand_grid(+ |
+
| 476 | +162x | +
+ group1_level = switch(!is_empty(by),+ |
+
| 477 | +162x | +
+ .unique_and_sorted(data$variables[[by]])+ |
+
| 478 | ++ |
+ ),+ |
+
| 479 | +162x | +
+ variable_level = .unique_and_sorted(data$variables[[variable]])+ |
+
| 480 | ++ |
+ ) |>+ |
+
| 481 | +162x | +
+ dplyr::mutate(variable = .env$variable)+ |
+
| 482 | +123x | +
+ if (!is_empty(by)) df$group1 <- by+ |
+
| 483 | +162x | +
+ df <- dplyr::relocate(df, any_of(c("group1", "group1_level", "variable", "variable_level")))
+ |
+
| 484 | ++ | + + | +
| 485 | ++ |
+ # convert levels to character for merging later+ |
+
| 486 | +162x | +
+ df |>+ |
+
| 487 | +162x | +
+ dplyr::mutate(+ |
+
| 488 | +162x | +
+ across(+ |
+
| 489 | +162x | +
+ c(cards::all_ard_groups("levels"), cards::all_ard_variables("levels")),
+ |
+
| 490 | +162x | +
+ as.character+ |
+
| 491 | ++ |
+ )+ |
+
| 492 | ++ |
+ )+ |
+
| 493 | ++ |
+ }+ |
+
| 494 | ++ | + + | +
| 495 | ++ |
+ case_switch <- function(..., .default = NULL) {
+ |
+
| 496 | ++ |
+ dots <- dots_list(...)+ |
+
| 497 | ++ | + + | +
| 498 | ++ |
+ for (f in dots) {
+ |
+
| 499 | ++ |
+ if (isTRUE(eval(f_lhs(f), envir = attr(f, ".Environment")))) {
+ |
+
| 500 | ++ |
+ return(eval(f_rhs(f), envir = attr(f, ".Environment")))+ |
+
| 501 | ++ |
+ }+ |
+
| 502 | ++ |
+ }+ |
+
| 503 | ++ | + + | +
| 504 | ++ |
+ return(.default)+ |
+
| 505 | ++ |
+ }+ |
+
| 506 | ++ | + + | +
| 507 | ++ |
+ .default_svy_cat_fmt_fn <- function(x) {
+ |
+
| 508 | +81x | +
+ x |>+ |
+
| 509 | +81x | +
+ dplyr::mutate(+ |
+
| 510 | +81x | +
+ fmt_fn =+ |
+
| 511 | +81x | +
+ pmap(+ |
+
| 512 | +81x | +
+ list(.data$stat_name, .data$stat, .data$fmt_fn),+ |
+
| 513 | +81x | +
+ function(stat_name, stat, fmt_fn) {
+ |
+
| 514 | +5478x | +
+ if (!is_empty(fmt_fn)) {
+ |
+
| 515 | +! | +
+ return(fmt_fn)+ |
+
| 516 | ++ |
+ }+ |
+
| 517 | +5478x | +
+ if (stat_name %in% c("p", "p_miss", "p_nonmiss", "p_unweighted")) {
+ |
+
| 518 | +1372x | +
+ return(cards::label_cards(digits = 1, scale = 100))+ |
+
| 519 | ++ |
+ }+ |
+
| 520 | +4106x | +
+ if (stat_name %in% c("n", "N", "N_miss", "N_nonmiss", "N_obs", "n_unweighted", "N_unweighted")) {
+ |
+
| 521 | +2745x | +
+ return(cards::label_cards(digits = 0))+ |
+
| 522 | ++ |
+ }+ |
+
| 523 | +1361x | +
+ if (is.integer(stat)) {
+ |
+
| 524 | +33x | +
+ return(0L)+ |
+
| 525 | ++ |
+ }+ |
+
| 526 | +1328x | +
+ if (is.numeric(stat)) {
+ |
+
| 527 | +1328x | +
+ return(1L)+ |
+
| 528 | ++ |
+ }+ |
+
| 529 | +! | +
+ return(as.character)+ |
+
| 530 | ++ |
+ }+ |
+
| 531 | ++ |
+ )+ |
+
| 532 | ++ |
+ )+ |
+
| 533 | ++ |
+ }+ |
+
| 534 | ++ | + + | +
| 535 | ++ |
+ #' Convert Nested Lists to Column+ |
+
| 536 | ++ |
+ #'+ |
+
| 537 | ++ |
+ #' Some arguments, such as `stat_label`, are passed as nested lists. This+ |
+
| 538 | ++ |
+ #' function properly unnests these lists and adds them to the results data frame.+ |
+
| 539 | ++ |
+ #'+ |
+
| 540 | ++ |
+ #' @param x (`data.frame`)\cr+ |
+
| 541 | ++ |
+ #' result data frame+ |
+
| 542 | ++ |
+ #' @param arg (`list`)\cr+ |
+
| 543 | ++ |
+ #' the nested list+ |
+
| 544 | ++ |
+ #' @param new_column (`string`)\cr+ |
+
| 545 | ++ |
+ #' new column name+ |
+
| 546 | ++ |
+ #' @param unlist (`logical`)\cr+ |
+
| 547 | ++ |
+ #' whether to fully unlist final results+ |
+
| 548 | ++ |
+ #'+ |
+
| 549 | ++ |
+ #' @return a data frame+ |
+
| 550 | ++ |
+ #' @keywords internal+ |
+
| 551 | ++ |
+ #'+ |
+
| 552 | ++ |
+ #' @examples+ |
+
| 553 | ++ |
+ #' ard <- ard_categorical(cards::ADSL, by = "ARM", variables = "AGEGR1")+ |
+
| 554 | ++ |
+ #'+ |
+
| 555 | ++ |
+ #' cardx:::.process_nested_list_as_df(ard, NULL, "new_col")+ |
+
| 556 | ++ |
+ .process_nested_list_as_df <- function(x, arg, new_column, unlist = FALSE) {
+ |
+
| 557 | ++ |
+ # add fmt_fn column if not already present+ |
+
| 558 | +162x | +
+ if (!new_column %in% names(x)) {
+ |
+
| 559 | +162x | +
+ x[[new_column]] <- list(NULL)+ |
+
| 560 | ++ |
+ }+ |
+
| 561 | ++ | + + | +
| 562 | ++ |
+ # process argument if not NULL, and update new column+ |
+
| 563 | +162x | +
+ if (!is_empty(arg)) {
+ |
+
| 564 | +81x | +
+ df_argument <-+ |
+
| 565 | +81x | +
+ imap(+ |
+
| 566 | +81x | +
+ arg,+ |
+
| 567 | +81x | +
+ function(enlst_arg, variable) {
+ |
+
| 568 | +150x | +
+ lst_stat_names <-+ |
+
| 569 | +150x | +
+ x[c("variable", "stat_name")] |>
+ |
+
| 570 | +150x | +
+ dplyr::filter(.data$variable %in% .env$variable) |>+ |
+
| 571 | +150x | +
+ unique() %>%+ |
+
| 572 | +150x | +
+ {stats::setNames(as.list(.[["stat_name"]]), .[["stat_name"]])} # styler: off
+ |
+
| 573 | ++ | + + | +
| 574 | +150x | +
+ cards::compute_formula_selector(+ |
+
| 575 | +150x | +
+ data = lst_stat_names,+ |
+
| 576 | +150x | +
+ x = enlst_arg+ |
+
| 577 | ++ |
+ ) %>%+ |
+
| 578 | ++ |
+ # styler: off+ |
+
| 579 | +150x | +
+ {dplyr::tibble(
+ |
+
| 580 | +150x | +
+ variable = variable,+ |
+
| 581 | +150x | +
+ stat_name = names(.),+ |
+
| 582 | +150x | +
+ "{new_column}" := unname(.)
+ |
+
| 583 | ++ |
+ )}+ |
+
| 584 | ++ |
+ # styler: on+ |
+
| 585 | ++ |
+ }+ |
+
| 586 | ++ |
+ ) |>+ |
+
| 587 | +81x | +
+ dplyr::bind_rows()+ |
+
| 588 | ++ | + + | +
| 589 | +81x | +
+ x <- x |> dplyr::rows_update(df_argument, by = c("variable", "stat_name"), unmatched = "ignore")
+ |
+
| 590 | ++ |
+ }+ |
+
| 591 | ++ | + + | +
| 592 | +162x | +
+ if (isTRUE(unlist)) {
+ |
+
| 593 | +81x | +
+ x[[new_column]] <- lapply(x[[new_column]], function(x) x %||% NA) |> unlist()+ |
+
| 594 | ++ |
+ }+ |
+
| 595 | ++ | + + | +
| 596 | +162x | +
+ x+ |
+
| 597 | ++ |
+ }+ |
+
| 1 | ++ |
+ #' Functions for Calculating Proportion Confidence Intervals+ |
+
| 2 | ++ |
+ #'+ |
+
| 3 | ++ |
+ #' Functions to calculate different proportion confidence intervals for use in `ard_proportion()`.+ |
+
| 4 | ++ |
+ #'+ |
+
| 5 | ++ |
+ #' @inheritParams ard_categorical_ci+ |
+
| 6 | ++ |
+ #' @param x vector of a binary values, i.e. a logical vector, or numeric with values `c(0, 1)`+ |
+
| 7 | ++ |
+ #' @return Confidence interval of a proportion.+ |
+
| 8 | ++ |
+ #'+ |
+
| 9 | ++ |
+ #' @name proportion_ci+ |
+
| 10 | ++ |
+ #' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = "broom"))
+ |
+
| 11 | ++ |
+ #' x <- c(+ |
+
| 12 | ++ |
+ #' TRUE, TRUE, TRUE, TRUE, TRUE,+ |
+
| 13 | ++ |
+ #' FALSE, FALSE, FALSE, FALSE, FALSE+ |
+
| 14 | ++ |
+ #' )+ |
+
| 15 | ++ |
+ #'+ |
+
| 16 | ++ |
+ #' proportion_ci_wald(x, conf.level = 0.9)+ |
+
| 17 | ++ |
+ #' proportion_ci_wilson(x, correct = TRUE)+ |
+
| 18 | ++ |
+ #' proportion_ci_clopper_pearson(x)+ |
+
| 19 | ++ |
+ #' proportion_ci_agresti_coull(x)+ |
+
| 20 | ++ |
+ #' proportion_ci_jeffreys(x)+ |
+
| 21 | ++ |
+ NULL+ |
+
| 22 | ++ | + + | +
| 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.+ |
+
| 25 | ++ |
+ #'+ |
+
| 26 | ++ |
+ #' \deqn{\hat{p} \pm z_{\alpha/2} \sqrt{\frac{\hat{p}(1 - \hat{p})}{n}}}
+ |
+
| 27 | ++ |
+ #'+ |
+
| 28 | ++ |
+ #' @param correct (`logical`)\cr apply continuity correction.+ |
+
| 29 | ++ |
+ #'+ |
+
| 30 | ++ |
+ #' @export+ |
+
| 31 | ++ |
+ proportion_ci_wald <- function(x, conf.level = 0.95, correct = FALSE) {
+ |
+
| 32 | +23x | +
+ set_cli_abort_call()+ |
+
| 33 | ++ | + + | +
| 34 | ++ |
+ # check inputs ---------------------------------------------------------------+ |
+
| 35 | +23x | +
+ check_not_missing(x)+ |
+
| 36 | +23x | +
+ check_binary(x)+ |
+
| 37 | +23x | +
+ check_range(conf.level, range = c(0, 1), include_bounds = c(FALSE, FALSE))+ |
+
| 38 | +23x | +
+ check_scalar(conf.level)+ |
+
| 39 | +23x | +
+ check_class(x = correct, "logical")+ |
+
| 40 | +23x | +
+ check_scalar(correct)+ |
+
| 41 | ++ | + + | +
| 42 | +23x | +
+ x <- stats::na.omit(x)+ |
+
| 43 | ++ | + + | +
| 44 | +23x | +
+ n <- length(x)+ |
+
| 45 | +23x | +
+ p_hat <- mean(x)+ |
+
| 46 | +23x | +
+ z <- stats::qnorm((1 + conf.level) / 2)+ |
+
| 47 | +23x | +
+ q_hat <- 1 - p_hat+ |
+
| 48 | +23x | +
+ correction_factor <- ifelse(correct, 1 / (2 * n), 0)+ |
+
| 49 | ++ | + + | +
| 50 | +23x | +
+ err <- z * sqrt(p_hat * q_hat) / sqrt(n) + correction_factor+ |
+
| 51 | +23x | +
+ l_ci <- max(0, p_hat - err)+ |
+
| 52 | +23x | +
+ u_ci <- min(1, p_hat + err)+ |
+
| 53 | ++ | + + | +
| 54 | +23x | +
+ list(+ |
+
| 55 | +23x | +
+ N = n,+ |
+
| 56 | +23x | +
+ estimate = p_hat,+ |
+
| 57 | +23x | +
+ conf.low = l_ci,+ |
+
| 58 | +23x | +
+ conf.high = u_ci,+ |
+
| 59 | +23x | +
+ conf.level = conf.level,+ |
+
| 60 | +23x | +
+ method =+ |
+
| 61 | +23x | +
+ glue::glue("Wald Confidence Interval {ifelse(correct, 'with', 'without')} continuity correction")
+ |
+
| 62 | ++ |
+ )+ |
+
| 63 | ++ |
+ }+ |
+
| 64 | ++ | + + | +
| 65 | ++ | + + | +
| 66 | ++ |
+ #' @describeIn proportion_ci Calculates the Wilson interval by calling [stats::prop.test()].+ |
+
| 67 | ++ |
+ #' Also referred to as Wilson score interval.+ |
+
| 68 | ++ |
+ #'+ |
+
| 69 | ++ |
+ #' \deqn{\frac{\hat{p} +
+ |
+
| 70 | ++ |
+ #' \frac{z^2_{\alpha/2}}{2n} \pm z_{\alpha/2} \sqrt{\frac{\hat{p}(1 - \hat{p})}{n} +
+ |
+
| 71 | ++ |
+ #' \frac{z^2_{\alpha/2}}{4n^2}}}{1 + \frac{z^2_{\alpha/2}}{n}}}
+ |
+
| 72 | ++ |
+ #'+ |
+
| 73 | ++ |
+ #' @export+ |
+
| 74 | ++ |
+ proportion_ci_wilson <- function(x, conf.level = 0.95, correct = FALSE) {
+ |
+
| 75 | +14x | +
+ set_cli_abort_call()+ |
+
| 76 | ++ | + + | +
| 77 | ++ |
+ # check installed packages ---------------------------------------------------+ |
+
| 78 | +14x | +
+ check_pkg_installed(pkg = "broom")+ |
+
| 79 | ++ | + + | +
| 80 | ++ |
+ # check inputs ---------------------------------------------------------------+ |
+
| 81 | +14x | +
+ check_not_missing(x)+ |
+
| 82 | +14x | +
+ check_binary(x)+ |
+
| 83 | +13x | +
+ check_class(x = correct, "logical")+ |
+
| 84 | +13x | +
+ check_scalar(correct)+ |
+
| 85 | +13x | +
+ check_range(conf.level, range = c(0, 1), include_bounds = c(FALSE, FALSE))+ |
+
| 86 | +13x | +
+ check_scalar(conf.level)+ |
+
| 87 | ++ | + + | +
| 88 | +12x | +
+ x <- stats::na.omit(x)+ |
+
| 89 | ++ | + + | +
| 90 | +12x | +
+ n <- length(x)+ |
+
| 91 | +12x | +
+ y <- stats::prop.test(x = sum(x), n = n, correct = correct, conf.level = conf.level)+ |
+
| 92 | ++ | + + | +
| 93 | +12x | +
+ list(N = n, conf.level = conf.level) |>+ |
+
| 94 | +12x | +
+ utils::modifyList(val = broom::tidy(y) |> as.list()) |>+ |
+
| 95 | +12x | +
+ utils::modifyList(+ |
+
| 96 | +12x | +
+ list(+ |
+
| 97 | +12x | +
+ method =+ |
+
| 98 | +12x | +
+ glue::glue("Wilson Confidence Interval {ifelse(correct, 'with', 'without')} continuity correction")
+ |
+
| 99 | ++ |
+ )+ |
+
| 100 | ++ |
+ )+ |
+
| 101 | ++ |
+ }+ |
+
| 102 | ++ | + + | +
| 103 | ++ |
+ #' @describeIn proportion_ci Calculates the Clopper-Pearson interval by calling [stats::binom.test()].+ |
+
| 104 | ++ |
+ #' Also referred to as the `exact` method.+ |
+
| 105 | ++ |
+ #'+ |
+
| 106 | ++ |
+ #' \deqn{
+ |
+
| 107 | ++ |
+ #' \left( \frac{k}{n} \pm z_{\alpha/2} \sqrt{\frac{\frac{k}{n}(1-\frac{k}{n})}{n} +
+ |
+
| 108 | ++ |
+ #' \frac{z^2_{\alpha/2}}{4n^2}} \right)
+ |
+
| 109 | ++ |
+ #' / \left( 1 + \frac{z^2_{\alpha/2}}{n} \right)}
+ |
+
| 110 | ++ |
+ #'+ |
+
| 111 | ++ |
+ #' @export+ |
+
| 112 | ++ |
+ proportion_ci_clopper_pearson <- function(x, conf.level = 0.95) {
+ |
+
| 113 | +5x | +
+ set_cli_abort_call()+ |
+
| 114 | ++ | + + | +
| 115 | ++ |
+ # check installed packages ---------------------------------------------------+ |
+
| 116 | +5x | +
+ check_pkg_installed(pkg = "broom")+ |
+
| 117 | ++ | + + | +
| 118 | ++ |
+ # check inputs ---------------------------------------------------------------+ |
+
| 119 | +5x | +
+ check_not_missing(x)+ |
+
| 120 | +5x | +
+ check_binary(x)+ |
+
| 121 | +5x | +
+ check_range(conf.level, range = c(0, 1), include_bounds = c(FALSE, FALSE))+ |
+
| 122 | +5x | +
+ check_scalar(conf.level)+ |
+
| 123 | ++ | + + | +
| 124 | +5x | +
+ x <- stats::na.omit(x)+ |
+
| 125 | +5x | +
+ n <- length(x)+ |
+
| 126 | ++ | + + | +
| 127 | +5x | +
+ y <- stats::binom.test(x = sum(x), n = n, conf.level = conf.level)+ |
+
| 128 | ++ | + + | +
| 129 | +5x | +
+ list(N = n, conf.level = conf.level) |>+ |
+
| 130 | +5x | +
+ utils::modifyList(val = broom::tidy(y) |> as.list()) |>+ |
+
| 131 | +5x | +
+ utils::modifyList(list(method = "Clopper-Pearson Confidence Interval"))+ |
+
| 132 | ++ |
+ }+ |
+
| 133 | ++ | + + | +
| 134 | ++ |
+ #' @describeIn proportion_ci Calculates the `Agresti-Coull` interval (created by `Alan Agresti` and `Brent Coull`) by+ |
+
| 135 | ++ |
+ #' (for 95% CI) adding two successes and two failures to the data and then using the Wald formula to construct a CI.+ |
+
| 136 | ++ |
+ #'+ |
+
| 137 | ++ |
+ #' \deqn{
+ |
+
| 138 | ++ |
+ #' \left( \frac{\tilde{p} + z^2_{\alpha/2}/2}{n + z^2_{\alpha/2}} \pm
+ |
+
| 139 | ++ |
+ #' z_{\alpha/2} \sqrt{\frac{\tilde{p}(1 - \tilde{p})}{n} +
+ |
+
| 140 | ++ |
+ #' \frac{z^2_{\alpha/2}}{4n^2}} \right)}
+ |
+
| 141 | ++ |
+ #'+ |
+
| 142 | ++ |
+ #' @export+ |
+
| 143 | ++ |
+ proportion_ci_agresti_coull <- function(x, conf.level = 0.95) {
+ |
+
| 144 | +7x | +
+ set_cli_abort_call()+ |
+
| 145 | ++ | + + | +
| 146 | ++ |
+ # check inputs ---------------------------------------------------------------+ |
+
| 147 | +7x | +
+ check_not_missing(x)+ |
+
| 148 | +7x | +
+ check_binary(x)+ |
+
| 149 | +7x | +
+ check_range(conf.level, range = c(0, 1), include_bounds = c(FALSE, FALSE))+ |
+
| 150 | +7x | +
+ check_scalar(conf.level)+ |
+
| 151 | ++ | + + | +
| 152 | +7x | +
+ x <- stats::na.omit(x)+ |
+
| 153 | ++ | + + | +
| 154 | +7x | +
+ n <- length(x)+ |
+
| 155 | +7x | +
+ x_sum <- sum(x)+ |
+
| 156 | +7x | +
+ z <- stats::qnorm((1 + conf.level) / 2)+ |
+
| 157 | ++ | + + | +
| 158 | ++ |
+ # Add here both z^2 / 2 successes and failures.+ |
+
| 159 | +7x | +
+ x_sum_tilde <- x_sum + z^2 / 2+ |
+
| 160 | +7x | +
+ n_tilde <- n + z^2+ |
+
| 161 | ++ | + + | +
| 162 | ++ |
+ # Then proceed as with the Wald interval.+ |
+
| 163 | +7x | +
+ p_tilde <- x_sum_tilde / n_tilde+ |
+
| 164 | +7x | +
+ q_tilde <- 1 - p_tilde+ |
+
| 165 | +7x | +
+ err <- z * sqrt(p_tilde * q_tilde) / sqrt(n_tilde)+ |
+
| 166 | +7x | +
+ l_ci <- max(0, p_tilde - err)+ |
+
| 167 | +7x | +
+ u_ci <- min(1, p_tilde + err)+ |
+
| 168 | ++ | + + | +
| 169 | +7x | +
+ list(+ |
+
| 170 | +7x | +
+ N = n,+ |
+
| 171 | +7x | +
+ estimate = mean(x),+ |
+
| 172 | +7x | +
+ conf.low = l_ci,+ |
+
| 173 | +7x | +
+ conf.high = u_ci,+ |
+
| 174 | +7x | +
+ conf.level = conf.level,+ |
+
| 175 | +7x | +
+ method = "Agresti-Coull Confidence Interval"+ |
+
| 176 | ++ |
+ )+ |
+
| 177 | ++ |
+ }+ |
+
| 178 | ++ | + + | +
| 179 | ++ |
+ #' @describeIn proportion_ci Calculates the Jeffreys interval, an equal-tailed interval based on the+ |
+
| 180 | ++ |
+ #' non-informative Jeffreys prior for a binomial proportion.+ |
+
| 181 | ++ |
+ #'+ |
+
| 182 | ++ |
+ #' \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) {
+ |
+
| 187 | +8x | +
+ set_cli_abort_call()+ |
+
| 188 | ++ | + + | +
| 189 | ++ |
+ # check inputs ---------------------------------------------------------------+ |
+
| 190 | +8x | +
+ check_not_missing(x)+ |
+
| 191 | +8x | +
+ check_binary(x)+ |
+
| 192 | +8x | +
+ check_range(conf.level, range = c(0, 1), include_bounds = c(FALSE, FALSE))+ |
+
| 193 | +8x | +
+ check_scalar(conf.level)+ |
+
| 194 | +8x | +
+ x <- stats::na.omit(x)+ |
+
| 195 | ++ | + + | +
| 196 | +8x | +
+ n <- length(x)+ |
+
| 197 | +8x | +
+ x_sum <- sum(x)+ |
+
| 198 | ++ | + + | +
| 199 | +8x | +
+ alpha <- 1 - conf.level+ |
+
| 200 | +8x | +
+ l_ci <- ifelse(+ |
+
| 201 | +8x | +
+ x_sum == 0,+ |
+
| 202 | +8x | +
+ 0,+ |
+
| 203 | +8x | +
+ stats::qbeta(alpha / 2, x_sum + 0.5, n - x_sum + 0.5)+ |
+
| 204 | ++ |
+ )+ |
+
| 205 | ++ | + + | +
| 206 | +8x | +
+ u_ci <- ifelse(+ |
+
| 207 | +8x | +
+ x_sum == n,+ |
+
| 208 | +8x | +
+ 1,+ |
+
| 209 | +8x | +
+ stats::qbeta(1 - alpha / 2, x_sum + 0.5, n - x_sum + 0.5)+ |
+
| 210 | ++ |
+ )+ |
+
| 211 | ++ | + + | +
| 212 | +8x | +
+ list(+ |
+
| 213 | +8x | +
+ N = n,+ |
+
| 214 | +8x | +
+ estimate = mean(x),+ |
+
| 215 | +8x | +
+ conf.low = l_ci,+ |
+
| 216 | +8x | +
+ conf.high = u_ci,+ |
+
| 217 | +8x | +
+ conf.level = conf.level,+ |
+
| 218 | +8x | +
+ method = glue::glue("Jeffreys Interval")
+ |
+
| 219 | ++ |
+ )+ |
+
| 220 | ++ |
+ }+ |
+
| 221 | ++ | + + | +
| 222 | ++ | + + | +
| 223 | ++ |
+ #' @describeIn proportion_ci Calculates the stratified Wilson confidence+ |
+
| 224 | ++ |
+ #' interval for unequal proportions as described in+ |
+
| 225 | ++ |
+ #' Xin YA, Su XG. Stratified Wilson and Newcombe confidence intervals+ |
+
| 226 | ++ |
+ #' for multiple binomial proportions. _Statistics in Biopharmaceutical Research_. 2010;2(3).+ |
+
| 227 | ++ |
+ #'+ |
+
| 228 | ++ |
+ #' \deqn{\frac{\hat{p}_j + \frac{z^2_{\alpha/2}}{2n_j} \pm
+ |
+
| 229 | ++ |
+ #' z_{\alpha/2} \sqrt{\frac{\hat{p}_j(1 - \hat{p}_j)}{n_j} +
+ |
+
| 230 | ++ |
+ #' \frac{z^2_{\alpha/2}}{4n_j^2}}}{1 + \frac{z^2_{\alpha/2}}{n_j}}}
+ |
+
| 231 | ++ |
+ #'+ |
+
| 232 | ++ |
+ #'+ |
+
| 233 | ++ |
+ #' @param strata (`factor`)\cr variable with one level per stratum and same length as `x`.+ |
+
| 234 | ++ |
+ #' @param weights (`numeric` or `NULL`)\cr weights for each level of the strata. If `NULL`, they are+ |
+
| 235 | ++ |
+ #' estimated using the iterative algorithm that+ |
+
| 236 | ++ |
+ #' minimizes the weighted squared length of the confidence interval.+ |
+
| 237 | ++ |
+ #' @param max.iterations (`count`)\cr maximum number of iterations for the iterative procedure used+ |
+
| 238 | ++ |
+ #' to find estimates of optimal weights.+ |
+
| 239 | ++ |
+ #' @param correct (`flag`)\cr include the continuity correction. For further information, see for example+ |
+
| 240 | ++ |
+ #' [stats::prop.test()].+ |
+
| 241 | ++ |
+ #'+ |
+
| 242 | ++ |
+ #' @examples+ |
+
| 243 | ++ |
+ #' # Stratified Wilson confidence interval with unequal probabilities+ |
+
| 244 | ++ |
+ #'+ |
+
| 245 | ++ |
+ #' set.seed(1)+ |
+
| 246 | ++ |
+ #' rsp <- sample(c(TRUE, FALSE), 100, TRUE)+ |
+
| 247 | ++ |
+ #' strata_data <- data.frame(+ |
+
| 248 | ++ |
+ #' "f1" = sample(c("a", "b"), 100, TRUE),
+ |
+
| 249 | ++ |
+ #' "f2" = sample(c("x", "y", "z"), 100, TRUE),
+ |
+
| 250 | ++ |
+ #' stringsAsFactors = TRUE+ |
+
| 251 | ++ |
+ #' )+ |
+
| 252 | ++ |
+ #' strata <- interaction(strata_data)+ |
+
| 253 | ++ |
+ #' n_strata <- ncol(table(rsp, strata)) # Number of strata+ |
+
| 254 | ++ |
+ #'+ |
+
| 255 | ++ |
+ #' proportion_ci_strat_wilson(+ |
+
| 256 | ++ |
+ #' x = rsp, strata = strata,+ |
+
| 257 | ++ |
+ #' conf.level = 0.90+ |
+
| 258 | ++ |
+ #' )+ |
+
| 259 | ++ |
+ #'+ |
+
| 260 | ++ |
+ #' # Not automatic setting of weights+ |
+
| 261 | ++ |
+ #' proportion_ci_strat_wilson(+ |
+
| 262 | ++ |
+ #' x = rsp, strata = strata,+ |
+
| 263 | ++ |
+ #' weights = rep(1 / n_strata, n_strata),+ |
+
| 264 | ++ |
+ #' conf.level = 0.90+ |
+
| 265 | ++ |
+ #' )+ |
+
| 266 | ++ |
+ #'+ |
+
| 267 | ++ |
+ #' @export+ |
+
| 268 | ++ |
+ proportion_ci_strat_wilson <- function(x,+ |
+
| 269 | ++ |
+ strata,+ |
+
| 270 | ++ |
+ weights = NULL,+ |
+
| 271 | ++ |
+ conf.level = 0.95,+ |
+
| 272 | ++ |
+ max.iterations = 10L,+ |
+
| 273 | ++ |
+ correct = FALSE) {
+ |
+
| 274 | +12x | +
+ set_cli_abort_call()+ |
+
| 275 | ++ | + + | +
| 276 | ++ |
+ # check inputs ---------------------------------------------------------------+ |
+
| 277 | +12x | +
+ check_not_missing(x)+ |
+
| 278 | +12x | +
+ check_not_missing(strata)+ |
+
| 279 | +12x | +
+ check_binary(x)+ |
+
| 280 | +12x | +
+ check_class(correct, "logical")+ |
+
| 281 | +12x | +
+ check_scalar(correct)+ |
+
| 282 | +12x | +
+ check_class(strata, "factor")+ |
+
| 283 | +12x | +
+ check_range(conf.level, range = c(0, 1), include_bounds = c(FALSE, FALSE))+ |
+
| 284 | +12x | +
+ check_scalar(conf.level)+ |
+
| 285 | ++ | + + | +
| 286 | ++ |
+ # remove missing values from x and strata+ |
+
| 287 | +12x | +
+ is_na <- is.na(x) | is.na(strata)+ |
+
| 288 | +12x | +
+ x <- x[!is_na]+ |
+
| 289 | +12x | +
+ strata <- strata[!is_na]+ |
+
| 290 | +6x | +
+ if (!inherits(x, "logical")) x <- as.logical(x)+ |
+
| 291 | ++ |
+ # check all TRUE/FALSE, if so, not calculable+ |
+
| 292 | +12x | +
+ if (all(x) || all(!x)) {
+ |
+
| 293 | +2x | +
+ cli::cli_abort("All values in {.arg x} argument are either {.code TRUE} or {.code FALSE} and CI is not estimable.")
+ |
+
| 294 | ++ |
+ }+ |
+
| 295 | ++ | + + | +
| 296 | +10x | +
+ tbl <- table(factor(x, levels = c(FALSE, TRUE)), strata, useNA = "no")+ |
+
| 297 | +10x | +
+ n_strata <- length(unique(strata))+ |
+
| 298 | ++ | + + | +
| 299 | ++ |
+ # Checking the weights and maximum number of iterations.+ |
+
| 300 | +10x | +
+ do_iter <- FALSE+ |
+
| 301 | +10x | +
+ if (is.null(weights)) {
+ |
+
| 302 | +3x | +
+ weights <- rep(1 / n_strata, n_strata) # Initialization for iterative procedure+ |
+
| 303 | +3x | +
+ do_iter <- TRUE+ |
+
| 304 | ++ | + + | +
| 305 | ++ |
+ # Iteration parameters+ |
+
| 306 | +3x | +
+ if (!is_scalar_integerish(max.iterations) || max.iterations < 1) {
+ |
+
| 307 | +2x | +
+ cli::cli_abort("Argument {.arg max.iterations} must be a positive integer.")
+ |
+
| 308 | ++ |
+ }+ |
+
| 309 | ++ |
+ }+ |
+
| 310 | +8x | +
+ check_range(weights, range = c(0, 1), include_bounds = c(TRUE, TRUE))+ |
+
| 311 | +7x | +
+ sum_weights <- sum(weights) |>+ |
+
| 312 | +7x | +
+ round() |>+ |
+
| 313 | +7x | +
+ as.integer()+ |
+
| 314 | +7x | +
+ if (sum_weights != 1L || abs(sum_weights - sum(weights)) > sqrt(.Machine$double.eps)) {
+ |
+
| 315 | +1x | +
+ cli::cli_abort("The sum of the {.arg weights} argument must be {.val {1L}}")
+ |
+
| 316 | ++ |
+ }+ |
+
| 317 | ++ | + + | +
| 318 | +6x | +
+ xs <- tbl["TRUE", ]+ |
+
| 319 | +6x | +
+ ns <- colSums(tbl)+ |
+
| 320 | +6x | +
+ use_stratum <- (ns > 0)+ |
+
| 321 | +6x | +
+ ns <- ns[use_stratum]+ |
+
| 322 | +6x | +
+ xs <- xs[use_stratum]+ |
+
| 323 | +6x | +
+ ests <- xs / ns+ |
+
| 324 | +6x | +
+ vars <- ests * (1 - ests) / ns+ |
+
| 325 | ++ | + + | +
| 326 | +6x | +
+ strata_qnorm <- .strata_normal_quantile(vars, weights, conf.level)+ |
+
| 327 | ++ | + + | +
| 328 | ++ |
+ # Iterative setting of weights if they were not passed in `weights` argument+ |
+
| 329 | +6x | +
+ weights_new <- if (do_iter) {
+ |
+
| 330 | +1x | +
+ .update_weights_strat_wilson(vars, strata_qnorm, weights, ns, max.iterations, conf.level)$weights+ |
+
| 331 | ++ |
+ } else {
+ |
+
| 332 | +5x | +
+ weights+ |
+
| 333 | ++ |
+ }+ |
+
| 334 | ++ | + + | +
| 335 | +6x | +
+ strata_conf.level <- 2 * stats::pnorm(strata_qnorm) - 1+ |
+
| 336 | ++ | + + | +
| 337 | +6x | +
+ ci_by_strata <- Map(+ |
+
| 338 | +6x | +
+ function(x, n) {
+ |
+
| 339 | ++ |
+ # Classic Wilson's confidence interval+ |
+
| 340 | +36x | +
+ suppressWarnings(stats::prop.test(x, n, correct = correct, conf.level = strata_conf.level)$conf.int)+ |
+
| 341 | ++ |
+ },+ |
+
| 342 | +6x | +
+ x = xs,+ |
+
| 343 | +6x | +
+ n = ns+ |
+
| 344 | ++ |
+ )+ |
+
| 345 | +6x | +
+ lower_by_strata <- sapply(ci_by_strata, "[", 1L)+ |
+
| 346 | +6x | +
+ upper_by_strata <- sapply(ci_by_strata, "[", 2L)+ |
+
| 347 | ++ | + + | +
| 348 | +6x | +
+ lower <- sum(weights_new * lower_by_strata)+ |
+
| 349 | +6x | +
+ upper <- sum(weights_new * upper_by_strata)+ |
+
| 350 | ++ | + + | +
| 351 | ++ |
+ # Return values+ |
+
| 352 | +6x | +
+ list(+ |
+
| 353 | +6x | +
+ N = length(x),+ |
+
| 354 | +6x | +
+ estimate = mean(x),+ |
+
| 355 | +6x | +
+ conf.low = lower,+ |
+
| 356 | +6x | +
+ conf.high = upper,+ |
+
| 357 | +6x | +
+ conf.level = conf.level,+ |
+
| 358 | +6x | +
+ weights = if (do_iter) weights_new else NULL,+ |
+
| 359 | +6x | +
+ method =+ |
+
| 360 | +6x | +
+ glue::glue("Stratified Wilson Confidence Interval {ifelse(correct, 'with', 'without')} continuity correction")
+ |
+
| 361 | ++ |
+ ) |>+ |
+
| 362 | +6x | +
+ compact()+ |
+
| 363 | ++ |
+ }+ |
+
| 364 | ++ | + + | +
| 365 | ++ |
+ #' @describeIn proportion_ci Helper to determine if vector is binary (logical or 0/1)+ |
+
| 366 | ++ |
+ #'+ |
+
| 367 | ++ |
+ #' @export+ |
+
| 368 | ++ |
+ is_binary <- function(x) {
+ |
+
| 369 | +526x | +
+ is.logical(x) || (is_integerish(x) && is_empty(setdiff(x, c(0, 1, NA))))+ |
+
| 370 | ++ |
+ }+ |
+
| 371 | ++ | + + | +
| 372 | ++ |
+ #' Helper Function for the Estimation of Stratified Quantiles+ |
+
| 373 | ++ |
+ #'+ |
+
| 374 | ++ |
+ #' This function wraps the estimation of stratified percentiles when we assume+ |
+
| 375 | ++ |
+ #' the approximation for large numbers. This is necessary only in the case+ |
+
| 376 | ++ |
+ #' proportions for each strata are unequal.+ |
+
| 377 | ++ |
+ #'+ |
+
| 378 | ++ |
+ #' @inheritParams proportion_ci_strat_wilson+ |
+
| 379 | ++ |
+ #'+ |
+
| 380 | ++ |
+ #' @return Stratified quantile.+ |
+
| 381 | ++ |
+ #'+ |
+
| 382 | ++ |
+ #' @seealso [proportion_ci_strat_wilson()]+ |
+
| 383 | ++ |
+ #'+ |
+
| 384 | ++ |
+ #' @keywords internal+ |
+
| 385 | ++ |
+ #'+ |
+
| 386 | ++ |
+ #' @examples+ |
+
| 387 | ++ |
+ #' strata_data <- table(data.frame(+ |
+
| 388 | ++ |
+ #' "f1" = sample(c(TRUE, FALSE), 100, TRUE),+ |
+
| 389 | ++ |
+ #' "f2" = sample(c("x", "y", "z"), 100, TRUE),
+ |
+
| 390 | ++ |
+ #' stringsAsFactors = TRUE+ |
+
| 391 | ++ |
+ #' ))+ |
+
| 392 | ++ |
+ #' ns <- colSums(strata_data)+ |
+
| 393 | ++ |
+ #' ests <- strata_data["TRUE", ] / ns+ |
+
| 394 | ++ |
+ #' vars <- ests * (1 - ests) / ns+ |
+
| 395 | ++ |
+ #' weights <- rep(1 / length(ns), length(ns))+ |
+
| 396 | ++ |
+ #'+ |
+
| 397 | ++ |
+ #' cardx:::.strata_normal_quantile(vars, weights, 0.95)+ |
+
| 398 | ++ |
+ .strata_normal_quantile <- function(vars, weights, conf.level) {
+ |
+
| 399 | +8x | +
+ summands <- weights^2 * vars+ |
+
| 400 | ++ |
+ # Stratified quantile+ |
+
| 401 | +8x | +
+ sqrt(sum(summands)) / sum(sqrt(summands)) * stats::qnorm((1 + conf.level) / 2)+ |
+
| 402 | ++ |
+ }+ |
+
| 403 | ++ | + + | +
| 404 | ++ |
+ #' Helper Function for the Estimation of Weights for `proportion_ci_strat_wilson()`+ |
+
| 405 | ++ |
+ #'+ |
+
| 406 | ++ |
+ #' This function wraps the iteration procedure that allows you to estimate+ |
+
| 407 | ++ |
+ #' the weights for each proportional strata. This assumes to minimize the+ |
+
| 408 | ++ |
+ #' weighted squared length of the confidence interval.+ |
+
| 409 | ++ |
+ #'+ |
+
| 410 | ++ |
+ #' @keywords internal+ |
+
| 411 | ++ |
+ #' @inheritParams proportion_ci_strat_wilson+ |
+
| 412 | ++ |
+ #' @param vars (`numeric`)\cr normalized proportions for each strata.+ |
+
| 413 | ++ |
+ #' @param strata_qnorm (`numeric`)\cr initial estimation with identical weights of the quantiles.+ |
+
| 414 | ++ |
+ #' @param initial_weights (`numeric`)\cr initial weights used to calculate `strata_qnorm`. This can+ |
+
| 415 | ++ |
+ #' be optimized in the future if we need to estimate better initial weights.+ |
+
| 416 | ++ |
+ #' @param n_per_strata (`numeric`)\cr number of elements in each strata.+ |
+
| 417 | ++ |
+ #' @param max.iterations (`count`)\cr maximum number of iterations to be tried. Convergence is always checked.+ |
+
| 418 | ++ |
+ #' @param tol (`number`)\cr tolerance threshold for convergence.+ |
+
| 419 | ++ |
+ #'+ |
+
| 420 | ++ |
+ #' @return A `list` of 3 elements: `n_it`, `weights`, and `diff_v`.+ |
+
| 421 | ++ |
+ #'+ |
+
| 422 | ++ |
+ #' @seealso For references and details see [`proportion_ci_strat_wilson()`].+ |
+
| 423 | ++ |
+ #'+ |
+
| 424 | ++ |
+ #' @examples+ |
+
| 425 | ++ |
+ #' vs <- c(0.011, 0.013, 0.012, 0.014, 0.017, 0.018)+ |
+
| 426 | ++ |
+ #' sq <- 0.674+ |
+
| 427 | ++ |
+ #' ws <- rep(1 / length(vs), length(vs))+ |
+
| 428 | ++ |
+ #' ns <- c(22, 18, 17, 17, 14, 12)+ |
+
| 429 | ++ |
+ #'+ |
+
| 430 | ++ |
+ #' cardx:::.update_weights_strat_wilson(vs, sq, ws, ns, 100, 0.95, 0.001)+ |
+
| 431 | ++ |
+ .update_weights_strat_wilson <- function(vars,+ |
+
| 432 | ++ |
+ strata_qnorm,+ |
+
| 433 | ++ |
+ initial_weights,+ |
+
| 434 | ++ |
+ n_per_strata,+ |
+
| 435 | ++ |
+ max.iterations = 50,+ |
+
| 436 | ++ |
+ conf.level = 0.95,+ |
+
| 437 | ++ |
+ tol = 0.001) {
+ |
+
| 438 | +1x | +
+ it <- 0+ |
+
| 439 | +1x | +
+ diff_v <- NULL+ |
+
| 440 | ++ | + + | +
| 441 | +1x | +
+ while (it < max.iterations) {
+ |
+
| 442 | +2x | +
+ it <- it + 1+ |
+
| 443 | +2x | +
+ weights_new_t <- (1 + strata_qnorm^2 / n_per_strata)^2+ |
+
| 444 | +2x | +
+ weights_new_b <- (vars + strata_qnorm^2 / (4 * n_per_strata^2))+ |
+
| 445 | +2x | +
+ weights_new <- weights_new_t / weights_new_b+ |
+
| 446 | +2x | +
+ weights_new <- weights_new / sum(weights_new)+ |
+
| 447 | +2x | +
+ strata_qnorm <- .strata_normal_quantile(vars, weights_new, conf.level)+ |
+
| 448 | +2x | +
+ diff_v <- c(diff_v, sum(abs(weights_new - initial_weights)))+ |
+
| 449 | +1x | +
+ if (diff_v[length(diff_v)] < tol) break+ |
+
| 450 | +1x | +
+ initial_weights <- weights_new+ |
+
| 451 | ++ |
+ }+ |
+
| 452 | ++ | + + | +
| 453 | +1x | +
+ if (it == max.iterations) {
+ |
+
| 454 | +! | +
+ warning("The heuristic to find weights did not converge with max.iterations = ", max.iterations)
+ |
+
| 455 | ++ |
+ }+ |
+
| 456 | ++ | + + | +
| 457 | +1x | +
+ list(+ |
+
| 458 | +1x | +
+ "n_it" = it,+ |
+
| 459 | +1x | +
+ "weights" = weights_new,+ |
+
| 460 | +1x | +
+ "diff_v" = diff_v+ |
+
| 461 | ++ |
+ )+ |
+
| 462 | ++ |
+ }+ |
+
| 1 | ++ |
+ #' ARD Wald Test+ |
+
| 2 | ++ |
+ #'+ |
+
| 3 | ++ |
+ #' @description+ |
+
| 4 | ++ |
+ #' Function takes a regression model object and calculates Wald+ |
+
| 5 | ++ |
+ #' statistical test using [`aod::wald.test()`].+ |
+
| 6 | ++ |
+ #'+ |
+
| 7 | ++ |
+ #' @param x regression model object+ |
+
| 8 | ++ |
+ #' @param ... arguments passed to `aod::wald.test(...)`+ |
+
| 9 | ++ |
+ #' @inheritParams ard_regression+ |
+
| 10 | ++ |
+ #'+ |
+
| 11 | ++ |
+ #' @return data frame+ |
+
| 12 | ++ |
+ #' @export+ |
+
| 13 | ++ |
+ #'+ |
+
| 14 | ++ |
+ #' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = c("aod", "broom.helpers")))
+ |
+
| 15 | ++ |
+ #' lm(AGE ~ ARM, data = cards::ADSL) |>+ |
+
| 16 | ++ |
+ #' ard_aod_wald_test()+ |
+
| 17 | ++ |
+ ard_aod_wald_test <- function(x, tidy_fun = broom.helpers::tidy_with_broom_or_parameters, ...) {
+ |
+
| 18 | +3x | +
+ set_cli_abort_call()+ |
+
| 19 | ++ | + + | +
| 20 | ++ |
+ # check installed packages ---------------------------------------------------+ |
+
| 21 | +3x | +
+ check_pkg_installed(c("aod", "broom.helpers"))
+ |
+
| 22 | ++ | + + | +
| 23 | ++ |
+ # check inputs ---------------------------------------------------------------+ |
+
| 24 | +3x | +
+ check_not_missing(x)+ |
+
| 25 | ++ | + + | +
| 26 | ++ |
+ # run regression() -----------------------------------------------------------+ |
+
| 27 | +3x | +
+ reg_model <- cards::eval_capture_conditions(+ |
+
| 28 | +3x | +
+ ard_regression_basic(x, tidy_fun = tidy_fun, intercept = TRUE, stats_to_remove = c(+ |
+
| 29 | +3x | +
+ "var_type",+ |
+
| 30 | +3x | +
+ "var_label",+ |
+
| 31 | +3x | +
+ "var_class", "label",+ |
+
| 32 | +3x | +
+ "contrasts_type", "contrasts", "var_nlevels", "std.error",+ |
+
| 33 | +3x | +
+ "conf.low", "conf.high", "statistic", "p.value", "estimate"+ |
+
| 34 | ++ |
+ ))+ |
+
| 35 | ++ |
+ )+ |
+
| 36 | ++ | + + | +
| 37 | +3x | +
+ if (!is.null(reg_model[["error"]])) {
+ |
+
| 38 | +! | +
+ cli::cli_abort(+ |
+
| 39 | +! | +
+ c("Unable to identify underlying variable names in regression model.",
+ |
+
| 40 | +! | +
+ i = "Is this model type supported by {.fun broom.helpers::tidy_plus_plus}, which is the function used to identify variable names?"
+ |
+
| 41 | ++ |
+ ),+ |
+
| 42 | +! | +
+ call = get_cli_abort_call()+ |
+
| 43 | ++ |
+ )+ |
+
| 44 | ++ |
+ }+ |
+
| 45 | +3x | +
+ aod <-+ |
+
| 46 | +3x | +
+ reg_model[["result"]] %>%+ |
+
| 47 | +3x | +
+ dplyr::select(c(+ |
+
| 48 | +3x | +
+ variable = "variable",+ |
+
| 49 | +3x | +
+ model_terms = "stat"+ |
+
| 50 | ++ |
+ )) %>%+ |
+
| 51 | +3x | +
+ dplyr::mutate(term_id = dplyr::row_number()) %>%+ |
+
| 52 | +3x | +
+ tidyr::nest(data = -"variable") %>%+ |
+
| 53 | +3x | +
+ dplyr::rowwise() %>%+ |
+
| 54 | +3x | +
+ dplyr::mutate(+ |
+
| 55 | +3x | +
+ model_terms = unlist(.data$data[["model_terms"]]) %>% list(),+ |
+
| 56 | +3x | +
+ model_terms_id = rlang::set_names(.data$data[["term_id"]]) %>% list()+ |
+
| 57 | ++ |
+ )+ |
+
| 58 | ++ |
+ # run wald.test() -----------------------------------------------------------+ |
+
| 59 | +2x | +
+ wald_test <-+ |
+
| 60 | +2x | +
+ cards::eval_capture_conditions(lapply(seq_len(length(aod$model_terms_id)), function(terms_id) {
+ |
+
| 61 | +4x | +
+ aod::wald.test(+ |
+
| 62 | +4x | +
+ Sigma = stats::vcov(x),+ |
+
| 63 | +4x | +
+ b = stats::coef(x), Terms = aod$model_terms_id[[terms_id]]+ |
+
| 64 | ++ |
+ )+ |
+
| 65 | ++ |
+ }))+ |
+
| 66 | ++ | + + | +
| 67 | ++ | + + | +
| 68 | +2x | +
+ df_list <- do.call(rbind, lapply(wald_test$result, .extract_wald_results))+ |
+
| 69 | ++ | + + | +
| 70 | +2x | +
+ cbind(aod$variable, df_list) %>%+ |
+
| 71 | +2x | +
+ tidyr::pivot_longer(+ |
+
| 72 | +2x | +
+ cols = !"aod$variable",+ |
+
| 73 | +2x | +
+ names_to = "stat_name",+ |
+
| 74 | +2x | +
+ values_to = "stat"+ |
+
| 75 | ++ |
+ ) %>%+ |
+
| 76 | +2x | +
+ dplyr::rename(+ |
+
| 77 | +2x | +
+ "variable" = "aod$variable"+ |
+
| 78 | ++ |
+ ) |>+ |
+
| 79 | +2x | +
+ dplyr::mutate(+ |
+
| 80 | +2x | +
+ stat = as.list(.data$stat),+ |
+
| 81 | +2x | +
+ stat_label =+ |
+
| 82 | +2x | +
+ dplyr::case_when(+ |
+
| 83 | +2x | +
+ .data$stat_name %in% "statistic" ~ "Statistic",+ |
+
| 84 | +2x | +
+ .data$stat_name %in% "df" ~ "Degrees of Freedom",+ |
+
| 85 | +2x | +
+ .data$stat_name %in% "p.value" ~ "p-value",+ |
+
| 86 | +2x | +
+ TRUE ~ .data$stat_name+ |
+
| 87 | ++ |
+ ),+ |
+
| 88 | +2x | +
+ fmt_fn =+ |
+
| 89 | +2x | +
+ map(+ |
+
| 90 | +2x | +
+ .data$stat,+ |
+
| 91 | +2x | +
+ function(.x) {
+ |
+
| 92 | ++ |
+ # styler: off+ |
+
| 93 | +! | +
+ if (is.integer(.x)) return(0L)+ |
+
| 94 | +12x | +
+ if (is.numeric(.x)) return(1L)+ |
+
| 95 | ++ |
+ # styler: on+ |
+
| 96 | +! | +
+ NULL+ |
+
| 97 | ++ |
+ }+ |
+
| 98 | ++ |
+ ),+ |
+
| 99 | +2x | +
+ context = "aod_wald_test",+ |
+
| 100 | +2x | +
+ warning = wald_test["warning"],+ |
+
| 101 | +2x | +
+ error = wald_test["error"]+ |
+
| 102 | ++ |
+ ) |>+ |
+
| 103 | +2x | +
+ cards::as_card() |>+ |
+
| 104 | +2x | +
+ cards::tidy_ard_column_order()+ |
+
| 105 | ++ |
+ }+ |
+
| 106 | ++ | + + | +
| 107 | ++ |
+ #' Extract data from wald.test object+ |
+
| 108 | ++ |
+ #'+ |
+
| 109 | ++ |
+ #' @param wald_test (`data.frame`)\cr wald test object object from `aod::wald.test()`+ |
+
| 110 | ++ |
+ #'+ |
+
| 111 | ++ |
+ #' @return a data frame containing the wald test results.+ |
+
| 112 | ++ |
+ #' @keywords internal+ |
+
| 113 | ++ |
+ .extract_wald_results <- function(wald_test) {
+ |
+
| 114 | +4x | +
+ df <- wald_test$result$chi2[("df")]
+ |
+
| 115 | +4x | +
+ statistic <- wald_test$result$chi2[("chi2")]
+ |
+
| 116 | +4x | +
+ p.value <- wald_test$result$chi2[("P")]
+ |
+
| 117 | +4x | +
+ data.frame(df, statistic, p.value)+ |
+
| 118 | ++ |
+ }+ |
+
| 1 | ++ |
+ #' ARD Fisher's Exact Test+ |
+
| 2 | ++ |
+ #'+ |
+
| 3 | ++ |
+ #' @description+ |
+
| 4 | ++ |
+ #' Analysis results data for Fisher's Exact Test.+ |
+
| 5 | ++ |
+ #' Calculated with `fisher.test(x = data[[variable]], y = data[[by]], ...)`+ |
+
| 6 | ++ |
+ #'+ |
+
| 7 | ++ |
+ #'+ |
+
| 8 | ++ |
+ #' @param data (`data.frame`)\cr+ |
+
| 9 | ++ |
+ #' a data frame.+ |
+
| 10 | ++ |
+ #' @param by ([`tidy-select`][dplyr::dplyr_tidy_select])\cr+ |
+
| 11 | ++ |
+ #' column name to compare by+ |
+
| 12 | ++ |
+ #' @param variables ([`tidy-select`][dplyr::dplyr_tidy_select])\cr+ |
+
| 13 | ++ |
+ #' column names to be compared. Independent tests will be computed for+ |
+
| 14 | ++ |
+ #' each variable.+ |
+
| 15 | ++ |
+ #' @param conf.level (scalar `numeric`)\cr+ |
+
| 16 | ++ |
+ #' confidence level for confidence interval. Default is `0.95`.+ |
+
| 17 | ++ |
+ #' @param ... additional arguments passed to `fisher.test(...)`+ |
+
| 18 | ++ |
+ #'+ |
+
| 19 | ++ |
+ #' @return ARD data frame+ |
+
| 20 | ++ |
+ #' @export+ |
+
| 21 | ++ |
+ #'+ |
+
| 22 | ++ |
+ #' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = "broom"))
+ |
+
| 23 | ++ |
+ #' cards::ADSL[1:30, ] |>+ |
+
| 24 | ++ |
+ #' ard_stats_fisher_test(by = "ARM", variables = "AGEGR1")+ |
+
| 25 | ++ |
+ ard_stats_fisher_test <- function(data, by, variables, conf.level = 0.95, ...) {
+ |
+
| 26 | +4x | +
+ set_cli_abort_call()+ |
+
| 27 | ++ | + + | +
| 28 | ++ |
+ # check installed packages ---------------------------------------------------+ |
+
| 29 | +4x | +
+ check_pkg_installed("broom")
+ |
+
| 30 | ++ | + + | +
| 31 | ++ |
+ # check/process inputs -------------------------------------------------------+ |
+
| 32 | +4x | +
+ check_not_missing(data)+ |
+
| 33 | +4x | +
+ check_not_missing(variables)+ |
+
| 34 | +4x | +
+ check_not_missing(by)+ |
+
| 35 | +4x | +
+ check_data_frame(data)+ |
+
| 36 | +4x | +
+ cards::process_selectors(data, by = {{ by }}, variables = {{ variables }})
+ |
+
| 37 | +4x | +
+ check_scalar(by)+ |
+
| 38 | +4x | +
+ check_range(conf.level, range = c(0, 1))+ |
+
| 39 | ++ | + + | +
| 40 | ++ |
+ # return empty ARD if no variables selected ----------------------------------+ |
+
| 41 | +4x | +
+ if (is_empty(variables)) {
+ |
+
| 42 | +! | +
+ return(dplyr::tibble() |> cards::as_card())+ |
+
| 43 | ++ |
+ }+ |
+
| 44 | ++ | + + | +
| 45 | ++ |
+ # build ARD ------------------------------------------------------------------+ |
+
| 46 | +4x | +
+ lapply(+ |
+
| 47 | +4x | +
+ variables,+ |
+
| 48 | +4x | +
+ function(variable) {
+ |
+
| 49 | +5x | +
+ cards::tidy_as_ard(+ |
+
| 50 | +5x | +
+ lst_tidy =+ |
+
| 51 | +5x | +
+ cards::eval_capture_conditions(+ |
+
| 52 | +5x | +
+ stats::fisher.test(x = data[[variable]], y = data[[by]], conf.level = conf.level, ...) |>+ |
+
| 53 | +5x | +
+ broom::tidy()+ |
+
| 54 | ++ |
+ ),+ |
+
| 55 | +5x | +
+ tidy_result_names =+ |
+
| 56 | +5x | +
+ c("estimate", "p.value", "conf.low", "conf.high", "method", "alternative"),
+ |
+
| 57 | +5x | +
+ fun_args_to_record =+ |
+
| 58 | +5x | +
+ c(+ |
+
| 59 | +5x | +
+ "workspace", "hybrid", "hybridPars", "control", "or",+ |
+
| 60 | +5x | +
+ "conf.int", "conf.level", "simulate.p.value", "B"+ |
+
| 61 | ++ |
+ ),+ |
+
| 62 | +5x | +
+ formals = formals(stats::fisher.test),+ |
+
| 63 | +5x | +
+ passed_args = dots_list(...),+ |
+
| 64 | +5x | +
+ lst_ard_columns = list(group1 = by, variable = variable, context = "stats_fisher_test")+ |
+
| 65 | ++ |
+ ) |>+ |
+
| 66 | +5x | +
+ dplyr::mutate(+ |
+
| 67 | +5x | +
+ .after = "stat_name",+ |
+
| 68 | +5x | +
+ stat_label =+ |
+
| 69 | +5x | +
+ dplyr::case_when(+ |
+
| 70 | +5x | +
+ .data$stat_name %in% "p.value" ~ "p-value",+ |
+
| 71 | +5x | +
+ TRUE ~ .data$stat_name,+ |
+
| 72 | ++ |
+ )+ |
+
| 73 | ++ |
+ )+ |
+
| 74 | ++ |
+ }+ |
+
| 75 | ++ |
+ ) |>+ |
+
| 76 | +4x | +
+ dplyr::bind_rows() |>+ |
+
| 77 | +4x | +
+ cards::as_card()+ |
+
| 78 | ++ |
+ }+ |
+
| 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"))
+ |
+
| 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 | +6x | +
+ set_cli_abort_call()+ |
+
| 50 | ++ | + + | +
| 51 | ++ |
+ # check installed packages ---------------------------------------------------+ |
+
| 52 | +6x | +
+ check_pkg_installed("broom")
+ |
+
| 53 | ++ | + + | +
| 54 | ++ |
+ # check/process inputs -------------------------------------------------------+ |
+
| 55 | +6x | +
+ check_not_missing(data)+ |
+
| 56 | +6x | +
+ check_not_missing(variables)+ |
+
| 57 | +6x | +
+ check_data_frame(data)+ |
+
| 58 | +6x | +
+ data <- dplyr::ungroup(data)+ |
+
| 59 | +6x | +
+ cards::process_selectors(data, by = {{ by }}, variables = {{ variables }})
+ |
+
| 60 | +6x | +
+ check_scalar(by, allow_empty = TRUE)+ |
+
| 61 | +6x | +
+ check_range(conf.level, range = c(0, 1))+ |
+
| 62 | ++ | + + | +
| 63 | ++ |
+ # return empty ARD if no variables selected ----------------------------------+ |
+
| 64 | +6x | +
+ if (is_empty(variables)) {
+ |
+
| 65 | +! | +
+ return(dplyr::tibble() |> cards::as_card())+ |
+
| 66 | ++ |
+ }+ |
+
| 67 | ++ | + + | +
| 68 | ++ |
+ # build ARD ------------------------------------------------------------------+ |
+
| 69 | +6x | +
+ lapply(+ |
+
| 70 | +6x | +
+ variables,+ |
+
| 71 | +6x | +
+ function(variable) {
+ |
+
| 72 | +7x | +
+ .format_wilcoxtest_results(+ |
+
| 73 | +7x | +
+ by = by,+ |
+
| 74 | +7x | +
+ variable = variable,+ |
+
| 75 | +7x | +
+ lst_tidy =+ |
+
| 76 | ++ |
+ # styler: off+ |
+
| 77 | +7x | +
+ cards::eval_capture_conditions(+ |
+
| 78 | +7x | +
+ if (!is_empty(by)) {
+ |
+
| 79 | +6x | +
+ stats::wilcox.test(data[[variable]] ~ data[[by]], conf.level = conf.level, ...) |>+ |
+
| 80 | +6x | +
+ broom::tidy()+ |
+
| 81 | ++ |
+ }+ |
+
| 82 | ++ |
+ else {
+ |
+
| 83 | +1x | +
+ stats::wilcox.test(data[[variable]], ...) |>+ |
+
| 84 | +1x | +
+ broom::tidy()+ |
+
| 85 | ++ |
+ }+ |
+
| 86 | ++ |
+ ),+ |
+
| 87 | ++ |
+ # styler: on+ |
+
| 88 | +7x | +
+ paired = FALSE,+ |
+
| 89 | ++ |
+ ...+ |
+
| 90 | ++ |
+ )+ |
+
| 91 | ++ |
+ }+ |
+
| 92 | ++ |
+ ) |>+ |
+
| 93 | +6x | +
+ 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")
+ |
+
| 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 | ++ |
+ # return empty ARD if no variables selected ----------------------------------+ |
+
| 116 | +2x | +
+ if (is_empty(variables)) {
+ |
+
| 117 | +! | +
+ return(dplyr::tibble() |> cards::as_card())+ |
+
| 118 | ++ |
+ }+ |
+
| 119 | ++ | + + | +
| 120 | ++ |
+ # build ARD ------------------------------------------------------------------+ |
+
| 121 | +2x | +
+ lapply(+ |
+
| 122 | +2x | +
+ variables,+ |
+
| 123 | +2x | +
+ function(variable) {
+ |
+
| 124 | +2x | +
+ .format_wilcoxtest_results(+ |
+
| 125 | +2x | +
+ by = by,+ |
+
| 126 | +2x | +
+ variable = variable,+ |
+
| 127 | +2x | +
+ lst_tidy =+ |
+
| 128 | +2x | +
+ cards::eval_capture_conditions({
+ |
+
| 129 | ++ |
+ # adding this reshape inside the eval, so if there is an error it's captured in the ARD object+ |
+
| 130 | +2x | +
+ data_wide <- .paired_data_pivot_wider(data, by = by, variable = variable, id = id)+ |
+
| 131 | ++ |
+ # perform paired wilcox test+ |
+
| 132 | +1x | +
+ stats::wilcox.test(x = data_wide[["by1"]], y = data_wide[["by2"]], paired = TRUE, conf.level = conf.level, ...) |>+ |
+
| 133 | +1x | +
+ broom::tidy()+ |
+
| 134 | ++ |
+ }),+ |
+
| 135 | +2x | +
+ paired = TRUE,+ |
+
| 136 | ++ |
+ ...+ |
+
| 137 | ++ |
+ )+ |
+
| 138 | ++ |
+ }+ |
+
| 139 | ++ |
+ ) |>+ |
+
| 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"))
+ |
+
| 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 | ++ |
+ # build ARD ------------------------------------------------------------------+ |
+
| 174 | +9x | +
+ ret <-+ |
+
| 175 | +9x | +
+ cards::tidy_as_ard(+ |
+
| 176 | +9x | +
+ lst_tidy = lst_tidy,+ |
+
| 177 | +9x | +
+ tidy_result_names = c("statistic", "p.value", "method", "alternative"),
+ |
+
| 178 | +9x | +
+ fun_args_to_record = c(+ |
+
| 179 | +9x | +
+ "mu", "paired", "exact", "correct", "conf.int",+ |
+
| 180 | +9x | +
+ "conf.level", "tol.root", "digits.rank"+ |
+
| 181 | ++ |
+ ),+ |
+
| 182 | +9x | +
+ formals = formals(asNamespace("stats")[["wilcox.test.default"]]),
+ |
+
| 183 | +9x | +
+ passed_args = c(list(paired = paired), dots_list(...)),+ |
+
| 184 | +9x | +
+ lst_ard_columns = list(variable = variable, context = "stats_wilcox_test")+ |
+
| 185 | ++ |
+ )+ |
+
| 186 | ++ | + + | +
| 187 | +9x | +
+ if (!is_empty(by)) {
+ |
+
| 188 | +8x | +
+ ret <- ret |>+ |
+
| 189 | +8x | +
+ dplyr::mutate(group1 = by)+ |
+
| 190 | ++ |
+ }+ |
+
| 191 | ++ | + + | +
| 192 | ++ |
+ # add the stat label ---------------------------------------------------------+ |
+
| 193 | +9x | +
+ ret |>+ |
+
| 194 | +9x | +
+ dplyr::left_join(+ |
+
| 195 | +9x | +
+ .df_wilcoxtest_stat_labels(by),+ |
+
| 196 | +9x | +
+ by = "stat_name"+ |
+
| 197 | ++ |
+ ) |>+ |
+
| 198 | +9x | +
+ dplyr::mutate(stat_label = dplyr::coalesce(.data$stat_label, .data$stat_name)) |>+ |
+
| 199 | +9x | +
+ cards::as_card() |>+ |
+
| 200 | +9x | +
+ cards::tidy_ard_column_order()+ |
+
| 201 | ++ |
+ }+ |
+
| 202 | ++ | + + | +
| 203 | ++ | + + | +
| 204 | ++ |
+ .df_wilcoxtest_stat_labels <- function(by = NULL) {
+ |
+
| 205 | +9x | +
+ dplyr::tribble(+ |
+
| 206 | +9x | +
+ ~stat_name, ~stat_label,+ |
+
| 207 | +9x | +
+ "statistic", ifelse(is.null(by), "V Statistic", "X-squared Statistic"),+ |
+
| 208 | +9x | +
+ "parameter", "Degrees of Freedom",+ |
+
| 209 | +9x | +
+ "estimate", "Median of the Difference",+ |
+
| 210 | +9x | +
+ "p.value", "p-value",+ |
+
| 211 | +9x | +
+ "conf.low", "CI Lower Bound",+ |
+
| 212 | +9x | +
+ "conf.high", "CI Upper Bound",+ |
+
| 213 | +9x | +
+ "paired", "Paired test",+ |
+
| 214 | +9x | +
+ "conf.level", "CI Confidence Level",+ |
+
| 215 | ++ |
+ )+ |
+
| 216 | ++ |
+ }+ |
+
| 1 | ++ |
+ #' ARD for LS Mean Difference+ |
+
| 2 | ++ |
+ #'+ |
+
| 3 | ++ |
+ #' @description+ |
+
| 4 | ++ |
+ #' This function calculates least-squares mean differences using the 'emmeans'+ |
+
| 5 | ++ |
+ #' package using the following+ |
+
| 6 | ++ |
+ #'+ |
+
| 7 | ++ |
+ #' ```r+ |
+
| 8 | ++ |
+ #' emmeans::emmeans(object = <regression model>, specs = ~ <primary covariate>) |>+ |
+
| 9 | ++ |
+ #' emmeans::contrast(method = "pairwise") |>+ |
+
| 10 | ++ |
+ #' summary(infer = TRUE, level = <confidence level>)+ |
+
| 11 | ++ |
+ #' ```+ |
+
| 12 | ++ |
+ #'+ |
+
| 13 | ++ |
+ #' The arguments `data`, `formula`, `method`, `method.args`, `package` are used+ |
+
| 14 | ++ |
+ #' to construct the regression model via `cardx::construct_model()`.+ |
+
| 15 | ++ |
+ #'+ |
+
| 16 | ++ |
+ #' @param data (`data.frame`/`survey.design`)\cr+ |
+
| 17 | ++ |
+ #' a data frame or survey design object+ |
+
| 18 | ++ |
+ #' @inheritParams construct_model+ |
+
| 19 | ++ |
+ #' @param response_type (`string`)+ |
+
| 20 | ++ |
+ #' string indicating whether the model outcome is `'continuous'`+ |
+
| 21 | ++ |
+ #' or `'dichotomous'`. When `'dichotomous'`, the call to `emmeans::emmeans()` is+ |
+
| 22 | ++ |
+ #' supplemented with argument `regrid="response"`.+ |
+
| 23 | ++ |
+ #' @param conf.level (scalar `numeric`)\cr+ |
+
| 24 | ++ |
+ #' confidence level for confidence interval. Default is `0.95`.+ |
+
| 25 | ++ |
+ #' @param primary_covariate (`string`)\cr+ |
+
| 26 | ++ |
+ #' string indicating the primary covariate (typically the dichotomous treatment variable).+ |
+
| 27 | ++ |
+ #' Default is the first covariate listed in the formula.+ |
+
| 28 | ++ |
+ #'+ |
+
| 29 | ++ |
+ #' @return ARD data frame+ |
+
| 30 | ++ |
+ #' @export+ |
+
| 31 | ++ |
+ #'+ |
+
| 32 | ++ |
+ #' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = "emmeans"))
+ |
+
| 33 | ++ |
+ #' ard_emmeans_mean_difference(+ |
+
| 34 | ++ |
+ #' data = mtcars,+ |
+
| 35 | ++ |
+ #' formula = mpg ~ am + cyl,+ |
+
| 36 | ++ |
+ #' method = "lm"+ |
+
| 37 | ++ |
+ #' )+ |
+
| 38 | ++ |
+ #'+ |
+
| 39 | ++ |
+ #' ard_emmeans_mean_difference(+ |
+
| 40 | ++ |
+ #' data = mtcars,+ |
+
| 41 | ++ |
+ #' formula = vs ~ am + mpg,+ |
+
| 42 | ++ |
+ #' method = "glm",+ |
+
| 43 | ++ |
+ #' method.args = list(family = binomial),+ |
+
| 44 | ++ |
+ #' response_type = "dichotomous"+ |
+
| 45 | ++ |
+ #' )+ |
+
| 46 | ++ |
+ ard_emmeans_mean_difference <- function(data, formula, method,+ |
+
| 47 | ++ |
+ method.args = list(),+ |
+
| 48 | ++ |
+ package = "base",+ |
+
| 49 | ++ |
+ response_type = c("continuous", "dichotomous"),
+ |
+
| 50 | ++ |
+ conf.level = 0.95,+ |
+
| 51 | ++ |
+ primary_covariate =+ |
+
| 52 | ++ |
+ stats::terms(formula) |>+ |
+
| 53 | ++ |
+ attr("term.labels") |>
+ |
+
| 54 | ++ |
+ getElement(1L)) {
+ |
+
| 55 | +4x | +
+ set_cli_abort_call()+ |
+
| 56 | ++ | + + | +
| 57 | ++ |
+ # check package installation -------------------------------------------------+ |
+
| 58 | +4x | +
+ check_pkg_installed(c("emmeans", package))
+ |
+
| 59 | +4x | +
+ check_not_missing(data)+ |
+
| 60 | +4x | +
+ check_not_missing(formula)+ |
+
| 61 | +4x | +
+ check_not_missing(method)+ |
+
| 62 | +4x | +
+ check_class(data, c("data.frame", "survey.design"))
+ |
+
| 63 | +4x | +
+ check_class(formula, cls = "formula")+ |
+
| 64 | +4x | +
+ check_string(package)+ |
+
| 65 | +4x | +
+ check_string(primary_covariate)+ |
+
| 66 | +4x | +
+ check_scalar(conf.level)+ |
+
| 67 | +4x | +
+ check_range(conf.level, range = c(0, 1))+ |
+
| 68 | +4x | +
+ response_type <- arg_match(response_type, error_call = get_cli_abort_call())+ |
+
| 69 | ++ | + + | +
| 70 | ++ |
+ # construct primary model ----------------------------------------------------+ |
+
| 71 | +4x | +
+ mod <-+ |
+
| 72 | +4x | +
+ construct_model(+ |
+
| 73 | +4x | +
+ data = data, formula = formula, method = method,+ |
+
| 74 | +4x | +
+ method.args = {{ method.args }},
+ |
+
| 75 | +4x | +
+ package = package, env = caller_env()+ |
+
| 76 | ++ |
+ )+ |
+
| 77 | ++ | + + | +
| 78 | ++ |
+ # emmeans --------------------------------------------------------------------+ |
+
| 79 | +4x | +
+ emmeans_args <- list(object = mod, specs = reformulate2(primary_covariate))+ |
+
| 80 | +3x | +
+ if (response_type %in% "dichotomous") emmeans_args <- c(emmeans_args, list(regrid = "response"))+ |
+
| 81 | +4x | +
+ emmeans <-+ |
+
| 82 | +4x | +
+ withr::with_namespace(+ |
+
| 83 | +4x | +
+ package = "emmeans",+ |
+
| 84 | +4x | +
+ code = do.call("emmeans", args = emmeans_args)
+ |
+
| 85 | ++ |
+ )+ |
+
| 86 | ++ | + + | +
| 87 | +4x | +
+ df_results <-+ |
+
| 88 | +4x | +
+ emmeans |>+ |
+
| 89 | +4x | +
+ emmeans::contrast(method = "pairwise") |>+ |
+
| 90 | +4x | +
+ summary(infer = TRUE, level = conf.level)+ |
+
| 91 | ++ | + + | +
| 92 | ++ |
+ # convert results to ARD format ----------------------------------------------+ |
+
| 93 | +4x | +
+ df_results |>+ |
+
| 94 | +4x | +
+ dplyr::as_tibble() |>+ |
+
| 95 | +4x | +
+ dplyr::rename(+ |
+
| 96 | +4x | +
+ conf.low = any_of("asymp.LCL"),
+ |
+
| 97 | +4x | +
+ conf.high = any_of("asymp.UCL"),
+ |
+
| 98 | +4x | +
+ conf.low = any_of("lower.CL"),
+ |
+
| 99 | +4x | +
+ conf.high = any_of("upper.CL")
+ |
+
| 100 | ++ |
+ ) %>%+ |
+
| 101 | +4x | +
+ dplyr::select(+ |
+
| 102 | +4x | +
+ variable_level = "contrast",+ |
+
| 103 | +4x | +
+ "estimate",+ |
+
| 104 | +4x | +
+ std.error = "SE", "df",+ |
+
| 105 | +4x | +
+ "conf.low", "conf.high", "p.value"+ |
+
| 106 | ++ |
+ ) %>%+ |
+
| 107 | +4x | +
+ dplyr::mutate(+ |
+
| 108 | +4x | +
+ conf.level = .env$conf.level,+ |
+
| 109 | +4x | +
+ method =+ |
+
| 110 | +4x | +
+ ifelse(+ |
+
| 111 | +4x | +
+ length(attr(stats::terms(formula), "term.labels") |> discard(~ startsWith(., "1 |"))) == 1L,+ |
+
| 112 | +4x | +
+ "Least-squares mean difference",+ |
+
| 113 | +4x | +
+ "Least-squares adjusted mean difference"+ |
+
| 114 | ++ |
+ ),+ |
+
| 115 | +4x | +
+ across(everything(), as.list),+ |
+
| 116 | +4x | +
+ variable = "contrast",+ |
+
| 117 | +4x | +
+ group1 = .env$primary_covariate+ |
+
| 118 | ++ |
+ ) |>+ |
+
| 119 | +4x | +
+ tidyr::pivot_longer(+ |
+
| 120 | +4x | +
+ cols = -c("group1", "variable", "variable_level"),
+ |
+
| 121 | +4x | +
+ names_to = "stat_name",+ |
+
| 122 | +4x | +
+ values_to = "stat"+ |
+
| 123 | ++ |
+ ) |>+ |
+
| 124 | +4x | +
+ dplyr::left_join(.df_ttest_stat_labels(primary_covariate), by = "stat_name") |>+ |
+
| 125 | +4x | +
+ dplyr::mutate(+ |
+
| 126 | +4x | +
+ context = "emmeans_mean_difference",+ |
+
| 127 | +4x | +
+ stat_label = dplyr::coalesce(.data$stat_label, .data$stat_name),+ |
+
| 128 | +4x | +
+ warning = list(NULL),+ |
+
| 129 | +4x | +
+ error = list(NULL),+ |
+
| 130 | +4x | +
+ fmt_fn = map(.data$stat, \(.x) if (is.numeric(.x)) 1L else NULL) # styler: off+ |
+
| 131 | ++ |
+ ) |>+ |
+
| 132 | +4x | +
+ cards::as_card() |>+ |
+
| 133 | +4x | +
+ cards::tidy_ard_column_order()+ |
+
| 134 | ++ |
+ }+ |
+
| 1 | ++ |
+ #' ARD Survey rank test+ |
+
| 2 | ++ |
+ #'+ |
+
| 3 | ++ |
+ #' @description+ |
+
| 4 | ++ |
+ #' Analysis results data for survey wilcox test using [`survey::svyranktest()`].+ |
+
| 5 | ++ |
+ #'+ |
+
| 6 | ++ |
+ #' @param data (`survey.design`)\cr+ |
+
| 7 | ++ |
+ #' a survey design object often created with [`survey::svydesign()`]+ |
+
| 8 | ++ |
+ #' @param by ([`tidy-select`][dplyr::dplyr_tidy_select])\cr+ |
+
| 9 | ++ |
+ #' 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 run for each variable.+ |
+
| 12 | ++ |
+ #' @param test (`string`)\cr+ |
+
| 13 | ++ |
+ #' a string to denote which rank test to use:+ |
+
| 14 | ++ |
+ #' `"wilcoxon"`, `"vanderWaerden"`, `"median"`, `"KruskalWallis"`+ |
+
| 15 | ++ |
+ #' @param ... arguments passed to [`survey::svyranktest()`]+ |
+
| 16 | ++ |
+ #'+ |
+
| 17 | ++ |
+ #' @return ARD data frame+ |
+
| 18 | ++ |
+ #' @export+ |
+
| 19 | ++ |
+ #'+ |
+
| 20 | ++ |
+ #' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = c("survey", "broom")))
+ |
+
| 21 | ++ |
+ #' data(api, package = "survey")+ |
+
| 22 | ++ |
+ #' dclus2 <- survey::svydesign(id = ~ dnum + snum, fpc = ~ fpc1 + fpc2, data = apiclus2)+ |
+
| 23 | ++ |
+ #'+ |
+
| 24 | ++ |
+ #' ard_survey_svyranktest(dclus2, variables = enroll, by = comp.imp, test = "wilcoxon")+ |
+
| 25 | ++ |
+ #' ard_survey_svyranktest(dclus2, variables = enroll, by = comp.imp, test = "vanderWaerden")+ |
+
| 26 | ++ |
+ #' ard_survey_svyranktest(dclus2, variables = enroll, by = comp.imp, test = "median")+ |
+
| 27 | ++ |
+ #' ard_survey_svyranktest(dclus2, variables = enroll, by = comp.imp, test = "KruskalWallis")+ |
+
| 28 | ++ |
+ ard_survey_svyranktest <- function(data, by, variables, test, ...) {
+ |
+
| 29 | +6x | +
+ set_cli_abort_call()+ |
+
| 30 | ++ | + + | +
| 31 | ++ |
+ # check installed packages ---------------------------------------------------+ |
+
| 32 | +6x | +
+ check_pkg_installed(c("survey", "broom"))
+ |
+
| 33 | ++ | + + | +
| 34 | ++ |
+ # check/process inputs -------------------------------------------------------+ |
+
| 35 | +6x | +
+ check_not_missing(data)+ |
+
| 36 | +6x | +
+ check_not_missing(variables)+ |
+
| 37 | +6x | +
+ check_not_missing(by)+ |
+
| 38 | +6x | +
+ check_class(data, cls = "survey.design")+ |
+
| 39 | +6x | +
+ cards::process_selectors(data[["variables"]], by = {{ by }}, variables = {{ variables }})
+ |
+
| 40 | +6x | +
+ check_scalar(by)+ |
+
| 41 | ++ | + + | +
| 42 | ++ |
+ # return empty ARD if no variables selected ----------------------------------+ |
+
| 43 | +6x | +
+ if (is_empty(variables)) {
+ |
+
| 44 | +! | +
+ return(dplyr::tibble() |> cards::as_card())+ |
+
| 45 | ++ |
+ }+ |
+
| 46 | ++ | + + | +
| 47 | ++ |
+ # build ARD ------------------------------------------------------------------+ |
+
| 48 | +6x | +
+ lapply(+ |
+
| 49 | +6x | +
+ variables,+ |
+
| 50 | +6x | +
+ function(variable) {
+ |
+
| 51 | +6x | +
+ .format_svyranktest_results(+ |
+
| 52 | +6x | +
+ by = by,+ |
+
| 53 | +6x | +
+ variable = variable,+ |
+
| 54 | +6x | +
+ lst_tidy =+ |
+
| 55 | +6x | +
+ cards::eval_capture_conditions(+ |
+
| 56 | +6x | +
+ survey::svyranktest(reformulate2(termlabels = by, response = variable), design = data, test = test, ...) |>+ |
+
| 57 | +6x | +
+ broom::tidy()+ |
+
| 58 | ++ |
+ )+ |
+
| 59 | ++ |
+ )+ |
+
| 60 | ++ |
+ }+ |
+
| 61 | ++ |
+ ) |>+ |
+
| 62 | +6x | +
+ dplyr::bind_rows()+ |
+
| 63 | ++ |
+ }+ |
+
| 64 | ++ | + + | +
| 65 | ++ |
+ .format_svyranktest_results <- function(by, variable, lst_tidy, ...) {
+ |
+
| 66 | ++ |
+ # build ARD ------------------------------------------------------------------+ |
+
| 67 | +6x | +
+ ret <-+ |
+
| 68 | +6x | +
+ cards::tidy_as_ard(+ |
+
| 69 | +6x | +
+ lst_tidy = lst_tidy,+ |
+
| 70 | +6x | +
+ tidy_result_names = c(+ |
+
| 71 | +6x | +
+ "estimate", "statistic",+ |
+
| 72 | +6x | +
+ "p.value", "parameter",+ |
+
| 73 | +6x | +
+ "method", "alternative"+ |
+
| 74 | ++ |
+ ),+ |
+
| 75 | +6x | +
+ passed_args = dots_list(...),+ |
+
| 76 | +6x | +
+ lst_ard_columns = list(group1 = by, variable = variable, context = "survey_svyranktest")+ |
+
| 77 | ++ |
+ )+ |
+
| 78 | ++ | + + | +
| 79 | ++ |
+ # add the stat label ---------------------------------------------------------+ |
+
| 80 | +6x | +
+ ret |>+ |
+
| 81 | +6x | +
+ dplyr::left_join(+ |
+
| 82 | +6x | +
+ .df_surveyrank_stat_labels(),+ |
+
| 83 | +6x | +
+ by = "stat_name"+ |
+
| 84 | ++ |
+ ) |>+ |
+
| 85 | +6x | +
+ dplyr::mutate(stat_label = dplyr::coalesce(.data$stat_label, .data$stat_name)) |>+ |
+
| 86 | +6x | +
+ cards::as_card() |>+ |
+
| 87 | +6x | +
+ cards::tidy_ard_column_order()+ |
+
| 88 | ++ |
+ }+ |
+
| 89 | ++ | + + | +
| 90 | ++ | + + | +
| 91 | ++ |
+ .df_surveyrank_stat_labels <- function() {
+ |
+
| 92 | +6x | +
+ dplyr::tribble(+ |
+
| 93 | +6x | +
+ ~stat_name, ~stat_label,+ |
+
| 94 | +6x | +
+ "statistic", "Statistic",+ |
+
| 95 | +6x | +
+ "parameter", "Degrees of Freedom",+ |
+
| 96 | +6x | +
+ "estimate", "Median of the Difference",+ |
+
| 97 | +6x | +
+ "null.value", "Null Value",+ |
+
| 98 | +6x | +
+ "alternative", "Alternative Hypothesis",+ |
+
| 99 | +6x | +
+ "data.name", "Data Name",+ |
+
| 100 | +6x | +
+ "p.value", "p-value"+ |
+
| 101 | ++ |
+ )+ |
+
| 102 | ++ |
+ }+ |
+
| 1 | ++ |
+ #' ARD survey categorical CIs+ |
+
| 2 | ++ |
+ #'+ |
+
| 3 | ++ |
+ #' Confidence intervals for categorical variables calculated via+ |
+
| 4 | ++ |
+ #' [`survey::svyciprop()`].+ |
+
| 5 | ++ |
+ #'+ |
+
| 6 | ++ |
+ #' @inheritParams ard_continuous.survey.design+ |
+
| 7 | ++ |
+ #' @inheritParams ard_categorical_ci.data.frame+ |
+
| 8 | ++ |
+ #' @param method (`string`)\cr+ |
+
| 9 | ++ |
+ #' Method passed to `survey::svyciprop(method)`+ |
+
| 10 | ++ |
+ #' @param df (`numeric`)\cr+ |
+
| 11 | ++ |
+ #' denominator degrees of freedom, passed to `survey::svyciprop(df)`.+ |
+
| 12 | ++ |
+ #' Default is `survey::degf(data)`.+ |
+
| 13 | ++ |
+ #' @param ... arguments passed to `survey::svyciprop()`+ |
+
| 14 | ++ |
+ #'+ |
+
| 15 | ++ |
+ #' @return ARD data frame+ |
+
| 16 | ++ |
+ #' @export+ |
+
| 17 | ++ |
+ #'+ |
+
| 18 | ++ |
+ #' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = "survey"))
+ |
+
| 19 | ++ |
+ #' data(api, package = "survey")+ |
+
| 20 | ++ |
+ #' dclus1 <- survey::svydesign(id = ~dnum, weights = ~pw, data = apiclus1, fpc = ~fpc)+ |
+
| 21 | ++ |
+ #'+ |
+
| 22 | ++ |
+ #' ard_categorical_ci(dclus1, variables = sch.wide)+ |
+
| 23 | ++ |
+ #' ard_categorical_ci(dclus1, variables = sch.wide, value = sch.wide ~ "Yes", method = "xlogit")+ |
+
| 24 | ++ |
+ ard_categorical_ci.survey.design <- function(data,+ |
+
| 25 | ++ |
+ variables,+ |
+
| 26 | ++ |
+ by = NULL,+ |
+
| 27 | ++ |
+ method = c("logit", "likelihood", "asin", "beta", "mean", "xlogit"),
+ |
+
| 28 | ++ |
+ conf.level = 0.95,+ |
+
| 29 | ++ |
+ value = list(where(is_binary) ~ 1L, where(is.logical) ~ TRUE),+ |
+
| 30 | ++ |
+ df = survey::degf(data),+ |
+
| 31 | ++ |
+ ...) {
+ |
+
| 32 | +13x | +
+ set_cli_abort_call()+ |
+
| 33 | +13x | +
+ check_dots_empty()+ |
+
| 34 | ++ | + + | +
| 35 | ++ |
+ # check inputs ---------------------------------------------------------------+ |
+
| 36 | +13x | +
+ check_not_missing(data)+ |
+
| 37 | +13x | +
+ check_class(data, "survey.design")+ |
+
| 38 | +13x | +
+ check_not_missing(variables)+ |
+
| 39 | ++ | + + | +
| 40 | +13x | +
+ cards::process_selectors(+ |
+
| 41 | +13x | +
+ data = data$variables,+ |
+
| 42 | +13x | +
+ variables = {{ variables }},
+ |
+
| 43 | +13x | +
+ by = {{ by }}
+ |
+
| 44 | ++ |
+ )+ |
+
| 45 | +13x | +
+ cards::process_formula_selectors(+ |
+
| 46 | +13x | +
+ data = data$variables,+ |
+
| 47 | +13x | +
+ value = value+ |
+
| 48 | ++ |
+ )+ |
+
| 49 | +13x | +
+ check_scalar(by, allow_empty = TRUE)+ |
+
| 50 | +13x | +
+ check_scalar_range(conf.level, range = c(0, 1))+ |
+
| 51 | +13x | +
+ method <- arg_match(method)+ |
+
| 52 | ++ | + + | +
| 53 | ++ |
+ # return empty ARD if no variables selected ----------------------------------+ |
+
| 54 | +13x | +
+ if (is_empty(variables)) {
+ |
+
| 55 | +1x | +
+ return(dplyr::tibble() |> cards::as_card())+ |
+
| 56 | ++ |
+ }+ |
+
| 57 | ++ | + + | +
| 58 | ++ |
+ # calculate and return ARD of one sample CI ----------------------------------+ |
+
| 59 | +12x | +
+ .calculate_ard_onesample_survey_ci(+ |
+
| 60 | +12x | +
+ FUN = .svyciprop_wrapper,+ |
+
| 61 | +12x | +
+ data = data,+ |
+
| 62 | +12x | +
+ variables = variables,+ |
+
| 63 | +12x | +
+ by = by,+ |
+
| 64 | +12x | +
+ conf.level = conf.level,+ |
+
| 65 | +12x | +
+ method = method,+ |
+
| 66 | +12x | +
+ df = df,+ |
+
| 67 | +12x | +
+ value = value,+ |
+
| 68 | ++ |
+ ...+ |
+
| 69 | ++ |
+ )+ |
+
| 70 | ++ |
+ }+ |
+
| 71 | ++ | + + | +
| 72 | ++ |
+ .calculate_ard_onesample_survey_ci <- function(FUN, data, variables, by, conf.level, value, ...) {
+ |
+
| 73 | ++ |
+ # calculate results ----------------------------------------------------------+ |
+
| 74 | +12x | +
+ map(+ |
+
| 75 | +12x | +
+ variables,+ |
+
| 76 | +12x | +
+ function(variable) {
+ |
+
| 77 | +20x | +
+ .calculate_one_ard_categorical_survey_ci(+ |
+
| 78 | +20x | +
+ FUN = FUN,+ |
+
| 79 | +20x | +
+ data = data,+ |
+
| 80 | +20x | +
+ variable = variable,+ |
+
| 81 | +20x | +
+ by = by,+ |
+
| 82 | +20x | +
+ conf.level = conf.level,+ |
+
| 83 | +20x | +
+ value = value[[variable]],+ |
+
| 84 | ++ |
+ ...+ |
+
| 85 | ++ |
+ )+ |
+
| 86 | ++ |
+ }+ |
+
| 87 | ++ |
+ ) |>+ |
+
| 88 | +12x | +
+ dplyr::bind_rows()+ |
+
| 89 | ++ |
+ }+ |
+
| 90 | ++ | + + | +
| 91 | ++ |
+ .calculate_one_ard_categorical_survey_ci <- function(FUN, data, variable, by, conf.level, value, ...) {
+ |
+
| 92 | +20x | +
+ variable_levels <- .unique_values_sort(data$variables, variable = variable)+ |
+
| 93 | +20x | +
+ if (!is_empty(by)) {
+ |
+
| 94 | +6x | +
+ by_levels <- .unique_values_sort(data$variables, variable = by)+ |
+
| 95 | +6x | +
+ lst_data <-+ |
+
| 96 | +6x | +
+ map(+ |
+
| 97 | +6x | +
+ by_levels,+ |
+
| 98 | +6x | +
+ ~ call2("subset", expr(data), expr(!!sym(by) == !!.x)) |> eval()
+ |
+
| 99 | ++ |
+ ) |>+ |
+
| 100 | +6x | +
+ set_names(as.character(by_levels))+ |
+
| 101 | ++ |
+ }+ |
+
| 102 | ++ | + + | +
| 103 | +20x | +
+ df_full <-+ |
+
| 104 | +20x | +
+ case_switch(+ |
+
| 105 | +20x | +
+ !is_empty(by) ~+ |
+
| 106 | +20x | +
+ tidyr::expand_grid(+ |
+
| 107 | +20x | +
+ group1_level = as.character(by_levels) |> as.list(),+ |
+
| 108 | +20x | +
+ variable_level = as.character(variable_levels) |> as.list()+ |
+
| 109 | ++ |
+ ) |>+ |
+
| 110 | +20x | +
+ dplyr::mutate(group1 = .env$by, variable = .env$variable),+ |
+
| 111 | +20x | +
+ .default =+ |
+
| 112 | +20x | +
+ dplyr::tibble(+ |
+
| 113 | +20x | +
+ variable = .env$variable,+ |
+
| 114 | +20x | +
+ variable_level = as.character(variable_levels) |> as.list()+ |
+
| 115 | ++ |
+ )+ |
+
| 116 | ++ |
+ ) |>+ |
+
| 117 | +20x | +
+ dplyr::rowwise() |>+ |
+
| 118 | +20x | +
+ dplyr::mutate(+ |
+
| 119 | +20x | +
+ lst_result =+ |
+
| 120 | +20x | +
+ FUN(+ |
+
| 121 | +20x | +
+ data =+ |
+
| 122 | +20x | +
+ case_switch(+ |
+
| 123 | +20x | +
+ is_empty(.env$by) ~ data,+ |
+
| 124 | +20x | +
+ .default = lst_data[[.data$group1_level]]+ |
+
| 125 | ++ |
+ ),+ |
+
| 126 | +20x | +
+ variable = .data$variable,+ |
+
| 127 | +20x | +
+ variable_level = .data$variable_level,+ |
+
| 128 | +20x | +
+ conf.level = .env$conf.level,+ |
+
| 129 | ++ |
+ ...+ |
+
| 130 | ++ |
+ ) |>+ |
+
| 131 | +20x | +
+ list(),+ |
+
| 132 | +20x | +
+ result =+ |
+
| 133 | +20x | +
+ .data$lst_result[["result"]] |>+ |
+
| 134 | +20x | +
+ enframe("stat_name", "stat") |>
+ |
+
| 135 | +20x | +
+ list(),+ |
+
| 136 | +20x | +
+ warning = .data$lst_result["warning"] |> unname(),+ |
+
| 137 | +20x | +
+ error = .data$lst_result["error"] |> unname(),+ |
+
| 138 | +20x | +
+ context = "categorical_ci"+ |
+
| 139 | ++ |
+ ) |>+ |
+
| 140 | +20x | +
+ dplyr::select(-"lst_result") |>+ |
+
| 141 | +20x | +
+ dplyr::ungroup() |>+ |
+
| 142 | +20x | +
+ tidyr::unnest("result") |>
+ |
+
| 143 | +20x | +
+ dplyr::mutate(+ |
+
| 144 | +20x | +
+ stat_label = .data$stat_name,+ |
+
| 145 | +20x | +
+ fmt_fn = map(.data$stat, ~ case_switch(is.numeric(.x) ~ 2L, .default = as.character))+ |
+
| 146 | ++ |
+ ) |>+ |
+
| 147 | +20x | +
+ cards::as_card() |>+ |
+
| 148 | +20x | +
+ cards::tidy_ard_column_order()+ |
+
| 149 | ++ | + + | +
| 150 | ++ |
+ # if a value was passed for the variable, subset on those results+ |
+
| 151 | +20x | +
+ if (!is_empty(value)) {
+ |
+
| 152 | +! | +
+ df_full <- df_full |>+ |
+
| 153 | +! | +
+ dplyr::filter(.data$variable_level %in% .env$value)+ |
+
| 154 | ++ |
+ }+ |
+
| 155 | ++ | + + | +
| 156 | +20x | +
+ df_full+ |
+
| 157 | ++ |
+ }+ |
+
| 158 | ++ | + + | +
| 159 | ++ | + + | +
| 160 | ++ |
+ .svyciprop_wrapper <- function(data, variable, variable_level, conf.level, method, df, ...) {
+ |
+
| 161 | +52x | +
+ lst_results <-+ |
+
| 162 | +52x | +
+ cards::eval_capture_conditions(+ |
+
| 163 | +52x | +
+ survey::svyciprop(+ |
+
| 164 | +52x | +
+ formula = inject(~ I(!!sym(variable) == !!variable_level)),+ |
+
| 165 | +52x | +
+ design = data,+ |
+
| 166 | +52x | +
+ method = method,+ |
+
| 167 | +52x | +
+ level = conf.level,+ |
+
| 168 | +52x | +
+ df = df,+ |
+
| 169 | ++ |
+ ...+ |
+
| 170 | ++ |
+ ) %>%+ |
+
| 171 | +52x | +
+ {list(.[[1]], attr(., "ci"))} |> # styler: off
+ |
+
| 172 | +52x | +
+ unlist() |>+ |
+
| 173 | +52x | +
+ set_names(c("estimate", "conf.low", "conf.high")) |>
+ |
+
| 174 | +52x | +
+ as.list()+ |
+
| 175 | ++ |
+ )+ |
+
| 176 | ++ | + + | +
| 177 | ++ |
+ # add NULL results if error+ |
+
| 178 | +52x | +
+ if (is_empty(lst_results[["result"]])) {
+ |
+
| 179 | +! | +
+ lst_results[["result"]] <- rep_named(c("estimate", "conf.low", "conf.high"), list(NULL))
+ |
+
| 180 | ++ |
+ }+ |
+
| 181 | ++ | + + | +
| 182 | ++ |
+ # add other args+ |
+
| 183 | +52x | +
+ lst_results[["result"]] <- lst_results[["result"]] |> append(list(method = method, conf.level = conf.level))+ |
+
| 184 | ++ | + + | +
| 185 | ++ |
+ # return list result+ |
+
| 186 | +52x | +
+ lst_results+ |
+
| 187 | ++ |
+ }+ |
+
| 188 | ++ | + + | +
| 189 | ++ | + + | +
| 190 | ++ |
+ case_switch <- function(..., .default = NULL) {
+ |
+
| 191 | +729x | +
+ dots <- dots_list(...)+ |
+
| 192 | ++ | + + | +
| 193 | +729x | +
+ for (f in dots) {
+ |
+
| 194 | +956x | +
+ if (isTRUE(eval(f_lhs(f), envir = attr(f, ".Environment")))) {
+ |
+
| 195 | +584x | +
+ return(eval(f_rhs(f), envir = attr(f, ".Environment")))+ |
+
| 196 | ++ |
+ }+ |
+
| 197 | ++ |
+ }+ |
+
| 198 | ++ | + + | +
| 199 | +145x | +
+ return(.default)+ |
+
| 200 | ++ |
+ }+ |
+
| 1 | ++ |
+ #' ARD Dichotomous Survey Statistics+ |
+
| 2 | ++ |
+ #'+ |
+
| 3 | ++ |
+ #' Compute Analysis Results Data (ARD) for dichotomous summary statistics.+ |
+
| 4 | ++ |
+ #'+ |
+
| 5 | ++ |
+ #' @inheritParams ard_categorical.survey.design+ |
+
| 6 | ++ |
+ #' @param value (named `list`)\cr+ |
+
| 7 | ++ |
+ #' named list of dichotomous values to tabulate.+ |
+
| 8 | ++ |
+ #' Default is `cards::maximum_variable_value(data$variables)`,+ |
+
| 9 | ++ |
+ #' which returns the largest/last value after a sort.+ |
+
| 10 | ++ |
+ #'+ |
+
| 11 | ++ |
+ #' @return an ARD data frame of class 'card'+ |
+
| 12 | ++ |
+ #' @export+ |
+
| 13 | ++ |
+ #'+ |
+
| 14 | ++ |
+ #' @examplesIf cardx:::is_pkg_installed("survey")
+ |
+
| 15 | ++ |
+ #' survey::svydesign(ids = ~1, data = mtcars, weights = ~1) |>+ |
+
| 16 | ++ |
+ #' ard_dichotomous(by = vs, variables = c(cyl, am), value = list(cyl = 4))+ |
+
| 17 | ++ |
+ ard_dichotomous.survey.design <- function(data,+ |
+
| 18 | ++ |
+ variables,+ |
+
| 19 | ++ |
+ by = NULL,+ |
+
| 20 | ++ |
+ value = cards::maximum_variable_value(data$variables[variables]),+ |
+
| 21 | ++ |
+ statistic = everything() ~ c("n", "N", "p", "p.std.error", "deff", "n_unweighted", "N_unweighted", "p_unweighted"),
+ |
+
| 22 | ++ |
+ denominator = c("column", "row", "cell"),
+ |
+
| 23 | ++ |
+ fmt_fn = NULL,+ |
+
| 24 | ++ |
+ stat_label = everything() ~ list(+ |
+
| 25 | ++ |
+ p = "%",+ |
+
| 26 | ++ |
+ p.std.error = "SE(%)",+ |
+
| 27 | ++ |
+ deff = "Design Effect",+ |
+
| 28 | ++ |
+ "n_unweighted" = "Unweighted n",+ |
+
| 29 | ++ |
+ "N_unweighted" = "Unweighted N",+ |
+
| 30 | ++ |
+ "p_unweighted" = "Unweighted %"+ |
+
| 31 | ++ |
+ ),+ |
+
| 32 | ++ |
+ ...) {
+ |
+
| 33 | +18x | +
+ set_cli_abort_call()+ |
+
| 34 | +18x | +
+ check_dots_empty()+ |
+
| 35 | +18x | +
+ check_pkg_installed(pkg = "survey")+ |
+
| 36 | ++ | + + | +
| 37 | ++ |
+ # check inputs ---------------------------------------------------------------+ |
+
| 38 | +18x | +
+ check_not_missing(variables)+ |
+
| 39 | ++ | + + | +
| 40 | ++ |
+ # process inputs -------------------------------------------------------------+ |
+
| 41 | +18x | +
+ cards::process_selectors(data$variables, variables = {{ variables }})
+ |
+
| 42 | +18x | +
+ cards::process_formula_selectors(data$variables[variables], value = value)+ |
+
| 43 | +18x | +
+ cards::fill_formula_selectors(+ |
+
| 44 | +18x | +
+ data$variables[variables],+ |
+
| 45 | +18x | +
+ value = formals(asNamespace("cardx")[["ard_dichotomous.survey.design"]])[["value"]] |> eval()
+ |
+
| 46 | ++ |
+ )+ |
+
| 47 | +18x | +
+ .check_dichotomous_value(data$variables, value)+ |
+
| 48 | ++ | + + | +
| 49 | ++ |
+ # return empty ARD if no variables selected ----------------------------------+ |
+
| 50 | +15x | +
+ if (is_empty(variables)) {
+ |
+
| 51 | +! | +
+ return(dplyr::tibble() |> cards::as_card())+ |
+
| 52 | ++ |
+ }+ |
+
| 53 | ++ | + + | +
| 54 | ++ |
+ # calculate summary statistics -----------------------------------------------+ |
+
| 55 | +15x | +
+ ard_categorical(+ |
+
| 56 | +15x | +
+ data = data,+ |
+
| 57 | +15x | +
+ variables = all_of(variables),+ |
+
| 58 | +15x | +
+ by = {{ by }},
+ |
+
| 59 | +15x | +
+ statistic = statistic,+ |
+
| 60 | +15x | +
+ denominator = denominator,+ |
+
| 61 | +15x | +
+ fmt_fn = fmt_fn,+ |
+
| 62 | +15x | +
+ stat_label = stat_label+ |
+
| 63 | ++ |
+ ) |>+ |
+
| 64 | +15x | +
+ dplyr::filter(+ |
+
| 65 | +15x | +
+ pmap(+ |
+
| 66 | +15x | +
+ list(.data$variable, .data$variable_level),+ |
+
| 67 | +15x | +
+ function(variable, variable_level) {
+ |
+
| 68 | +880x | +
+ variable_level %in% .env$value[[variable]]+ |
+
| 69 | ++ |
+ }+ |
+
| 70 | ++ |
+ ) |>+ |
+
| 71 | +15x | +
+ unlist()+ |
+
| 72 | ++ |
+ ) |>+ |
+
| 73 | +15x | +
+ dplyr::mutate(context = "dichotomous")+ |
+
| 74 | ++ |
+ }+ |
+
| 75 | ++ | + + | +
| 76 | ++ |
+ #' Perform Value Checks+ |
+
| 77 | ++ |
+ #'+ |
+
| 78 | ++ |
+ #' Check the validity of the values passed in `ard_dichotomous(value)`.+ |
+
| 79 | ++ |
+ #'+ |
+
| 80 | ++ |
+ #' @param data (`data.frame`)\cr+ |
+
| 81 | ++ |
+ #' a data frame+ |
+
| 82 | ++ |
+ #' @param value (named `list`)\cr+ |
+
| 83 | ++ |
+ #' a named list+ |
+
| 84 | ++ |
+ #'+ |
+
| 85 | ++ |
+ #' @return returns invisible if check is successful, throws an error message if not.+ |
+
| 86 | ++ |
+ #' @keywords internal+ |
+
| 87 | ++ |
+ #'+ |
+
| 88 | ++ |
+ #' @examples+ |
+
| 89 | ++ |
+ #' cardx:::.check_dichotomous_value(mtcars, list(cyl = 4))+ |
+
| 90 | ++ |
+ .check_dichotomous_value <- function(data, value) {
+ |
+
| 91 | +18x | +
+ imap(+ |
+
| 92 | +18x | +
+ value,+ |
+
| 93 | +18x | +
+ function(value, column) {
+ |
+
| 94 | +32x | +
+ accepted_values <- .unique_and_sorted(data[[column]])+ |
+
| 95 | +32x | +
+ if (length(value) != 1L || !value %in% accepted_values) {
+ |
+
| 96 | +3x | +
+ message <- "Error in argument {.arg value} for variable {.val {column}}."
+ |
+
| 97 | +3x | +
+ message <-+ |
+
| 98 | +3x | +
+ case_switch(+ |
+
| 99 | +3x | +
+ length(value) != 1L ~ c(message, "i" = "The value must be one of {.val {accepted_values}}."),
+ |
+
| 100 | +3x | +
+ .default = c(message, "i" = "A value of {.val {value}} was passed, but must be one of {.val {accepted_values}}.")
+ |
+
| 101 | ++ |
+ )+ |
+
| 102 | +3x | +
+ if (length(value) == 1L) {
+ |
+
| 103 | +3x | +
+ message <-+ |
+
| 104 | +3x | +
+ case_switch(+ |
+
| 105 | +3x | +
+ inherits(data[[column]], "factor") ~+ |
+
| 106 | +3x | +
+ c(message, i = "To summarize this value, use {.fun forcats::fct_expand} to add {.val {value}} as a level."),
+ |
+
| 107 | +3x | +
+ .default = c(message, i = "To summarize this value, make the column a factor and include {.val {value}} as a level.")
+ |
+
| 108 | ++ |
+ )+ |
+
| 109 | ++ |
+ }+ |
+
| 110 | ++ | + + | +
| 111 | ++ | + + | +
| 112 | +3x | +
+ cli::cli_abort(+ |
+
| 113 | +3x | +
+ message = message,+ |
+
| 114 | +3x | +
+ call = get_cli_abort_call()+ |
+
| 115 | ++ |
+ )+ |
+
| 116 | ++ |
+ }+ |
+
| 117 | ++ |
+ }+ |
+
| 118 | ++ |
+ ) |>+ |
+
| 119 | +18x | +
+ 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 | ++ |
+ #'+ |
+
| 138 | ++ |
+ #' cards:::.unique_and_sorted(c(FALSE, TRUE, TRUE, FALSE))+ |
+
| 139 | ++ |
+ #'+ |
+
| 140 | ++ |
+ #' cards:::.unique_and_sorted(c(5, 5:1))+ |
+
| 141 | ++ |
+ .unique_and_sorted <- function(x, useNA = c("no", "always")) {
+ |
+
| 142 | ++ |
+ # styler: off+ |
+
| 143 | +317x | +
+ useNA <- match.arg(useNA)+ |
+
| 144 | ++ |
+ # if a factor return a factor that includes the same levels (including unobserved levels)+ |
+
| 145 | +317x | +
+ if (inherits(x, "factor")) {
+ |
+
| 146 | +243x | +
+ return(+ |
+
| 147 | +243x | +
+ factor(+ |
+
| 148 | +243x | +
+ if (useNA == "no") levels(x)+ |
+
| 149 | +243x | +
+ else c(levels(x), NA_character_),+ |
+
| 150 | +243x | +
+ levels = levels(x)+ |
+
| 151 | ++ |
+ )+ |
+
| 152 | ++ |
+ )+ |
+
| 153 | ++ |
+ }+ |
+
| 154 | +74x | +
+ if (inherits(x, "logical")) {
+ |
+
| 155 | +49x | +
+ if (useNA == "no") return(c(TRUE, FALSE))+ |
+
| 156 | +! | +
+ else return(c(TRUE, FALSE, NA))+ |
+
| 157 | ++ |
+ }+ |
+
| 158 | ++ | + + | +
| 159 | ++ |
+ # otherwise, return a simple unique and sort of the vector+ |
+
| 160 | +25x | +
+ if (useNA == "no") return(unique(x) |> sort())+ |
+
| 161 | +! | +
+ else return(unique(x) |> sort() |> c(NA))+ |
+
| 162 | ++ |
+ # styler: on+ |
+
| 163 | ++ |
+ }+ |
+
| 1 | ++ |
+ #' ARD Hedge's G Test+ |
+
| 2 | ++ |
+ #'+ |
+
| 3 | ++ |
+ #' @description+ |
+
| 4 | ++ |
+ #' Analysis results data for paired and non-paired Hedge's G Effect Size Test+ |
+
| 5 | ++ |
+ #' using [`effectsize::hedges_g()`].+ |
+
| 6 | ++ |
+ #'+ |
+
| 7 | ++ |
+ #' @param data (`data.frame`)\cr+ |
+
| 8 | ++ |
+ #' a data frame. See below 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.+ |
+
| 11 | ++ |
+ #' @param variables ([`tidy-select`][dplyr::dplyr_tidy_select])\cr+ |
+
| 12 | ++ |
+ #' column names to be compared. Must be a continuous variable. Independent+ |
+
| 13 | ++ |
+ #' tests will be run for each variable+ |
+
| 14 | ++ |
+ #' @param id ([`tidy-select`][dplyr::dplyr_tidy_select])\cr+ |
+
| 15 | ++ |
+ #' column name of the subject or participant ID+ |
+
| 16 | ++ |
+ #' @param conf.level (scalar `numeric`)\cr+ |
+
| 17 | ++ |
+ #' confidence level for confidence interval. Default is `0.95`.+ |
+
| 18 | ++ |
+ #' @param ... arguments passed to `effectsize::hedges_g(...)`+ |
+
| 19 | ++ |
+ #'+ |
+
| 20 | ++ |
+ #' @return ARD data frame+ |
+
| 21 | ++ |
+ #' @name ard_effectsize_hedges_g+ |
+
| 22 | ++ |
+ #'+ |
+
| 23 | ++ |
+ #' @details+ |
+
| 24 | ++ |
+ #' For the `ard_effectsize_hedges_g()` function, the data is expected to be one row per subject.+ |
+
| 25 | ++ |
+ #' The data is passed as `effectsize::hedges_g(data[[variable]]~data[[by]], data, paired = FALSE, ...)`.+ |
+
| 26 | ++ |
+ #'+ |
+
| 27 | ++ |
+ #' For the `ard_effectsize_paired_hedges_g()` function, the data is expected to be one row+ |
+
| 28 | ++ |
+ #' per subject per by level. Before the effect size is calculated, the data are+ |
+
| 29 | ++ |
+ #' reshaped to a wide format to be one row per subject.+ |
+
| 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, ...)`.+ |
+
| 32 | ++ |
+ #'+ |
+
| 33 | ++ |
+ #' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = c("effectsize", "parameters")))
+ |
+
| 34 | ++ |
+ #' cards::ADSL |>+ |
+
| 35 | ++ |
+ #' dplyr::filter(ARM %in% c("Placebo", "Xanomeline High Dose")) |>
+ |
+
| 36 | ++ |
+ #' ard_effectsize_hedges_g(by = ARM, variables = AGE)+ |
+
| 37 | ++ |
+ #'+ |
+
| 38 | ++ |
+ #' # constructing a paired data set,+ |
+
| 39 | ++ |
+ #' # where patients receive both treatments+ |
+
| 40 | ++ |
+ #' cards::ADSL[c("ARM", "AGE")] |>
+ |
+
| 41 | ++ |
+ #' dplyr::filter(ARM %in% c("Placebo", "Xanomeline High Dose")) |>
+ |
+
| 42 | ++ |
+ #' dplyr::mutate(.by = ARM, USUBJID = dplyr::row_number()) |>+ |
+
| 43 | ++ |
+ #' dplyr::arrange(USUBJID, ARM) |>+ |
+
| 44 | ++ |
+ #' dplyr::group_by(USUBJID) |>+ |
+
| 45 | ++ |
+ #' dplyr::filter(dplyr::n() > 1) |>+ |
+
| 46 | ++ |
+ #' ard_effectsize_paired_hedges_g(by = ARM, variables = AGE, id = USUBJID)+ |
+
| 47 | ++ |
+ NULL+ |
+
| 48 | ++ | + + | +
| 49 | ++ |
+ #' @rdname ard_effectsize_hedges_g+ |
+
| 50 | ++ |
+ #' @export+ |
+
| 51 | ++ |
+ ard_effectsize_hedges_g <- function(data, by, variables, conf.level = 0.95, ...) {
+ |
+
| 52 | +4x | +
+ set_cli_abort_call()+ |
+
| 53 | ++ | + + | +
| 54 | ++ |
+ # check installed packages ---------------------------------------------------+ |
+
| 55 | +4x | +
+ check_pkg_installed(c("effectsize", "parameters"))
+ |
+
| 56 | ++ | + + | +
| 57 | ++ |
+ # check/process inputs -------------------------------------------------------+ |
+
| 58 | +4x | +
+ check_not_missing(data)+ |
+
| 59 | +4x | +
+ check_not_missing(variables)+ |
+
| 60 | +4x | +
+ check_data_frame(data)+ |
+
| 61 | +4x | +
+ data <- dplyr::ungroup(data)+ |
+
| 62 | +4x | +
+ cards::process_selectors(data, by = {{ by }}, variables = {{ variables }})
+ |
+
| 63 | +4x | +
+ check_scalar(by)+ |
+
| 64 | +4x | +
+ check_range(conf.level, range = c(0, 1))+ |
+
| 65 | ++ | + + | +
| 66 | ++ |
+ # return empty ARD if no variables selected ----------------------------------+ |
+
| 67 | +4x | +
+ if (is_empty(variables)) {
+ |
+
| 68 | +! | +
+ return(dplyr::tibble() |> cards::as_card())+ |
+
| 69 | ++ |
+ }+ |
+
| 70 | ++ | + + | +
| 71 | ++ |
+ # build ARD ------------------------------------------------------------------+ |
+
| 72 | +4x | +
+ lapply(+ |
+
| 73 | +4x | +
+ variables,+ |
+
| 74 | +4x | +
+ function(variable) {
+ |
+
| 75 | +5x | +
+ .format_hedges_g_results(+ |
+
| 76 | +5x | +
+ by = by,+ |
+
| 77 | +5x | +
+ variable = variable,+ |
+
| 78 | +5x | +
+ lst_tidy =+ |
+
| 79 | +5x | +
+ cards::eval_capture_conditions(+ |
+
| 80 | +5x | +
+ effectsize::hedges_g(+ |
+
| 81 | +5x | +
+ reformulate2(by, response = variable),+ |
+
| 82 | +5x | +
+ data = data |> tidyr::drop_na(all_of(c(by, variable))),+ |
+
| 83 | +5x | +
+ paired = FALSE,+ |
+
| 84 | +5x | +
+ ci = conf.level,+ |
+
| 85 | ++ |
+ ...+ |
+
| 86 | ++ |
+ ) |>+ |
+
| 87 | +5x | +
+ parameters::standardize_names(style = "broom") |>+ |
+
| 88 | +5x | +
+ dplyr::mutate(method = "Hedge's G")+ |
+
| 89 | ++ |
+ ),+ |
+
| 90 | +5x | +
+ paired = FALSE,+ |
+
| 91 | ++ |
+ ...+ |
+
| 92 | ++ |
+ )+ |
+
| 93 | ++ |
+ }+ |
+
| 94 | ++ |
+ ) |>+ |
+
| 95 | +4x | +
+ dplyr::bind_rows()+ |
+
| 96 | ++ |
+ }+ |
+
| 97 | ++ | + + | +
| 98 | ++ |
+ #' @rdname ard_effectsize_hedges_g+ |
+
| 99 | ++ |
+ #' @export+ |
+
| 100 | ++ |
+ ard_effectsize_paired_hedges_g <- function(data, by, variables, id, conf.level = 0.95, ...) {
+ |
+
| 101 | +3x | +
+ set_cli_abort_call()+ |
+
| 102 | ++ | + + | +
| 103 | ++ |
+ # check installed packages ---------------------------------------------------+ |
+
| 104 | +3x | +
+ check_pkg_installed(c("effectsize", "parameters"))
+ |
+
| 105 | ++ | + + | +
| 106 | ++ |
+ # check/process inputs -------------------------------------------------------+ |
+
| 107 | +3x | +
+ check_not_missing(data)+ |
+
| 108 | +3x | +
+ check_not_missing(variables)+ |
+
| 109 | +3x | +
+ check_not_missing(by)+ |
+
| 110 | +3x | +
+ check_not_missing(id)+ |
+
| 111 | +3x | +
+ check_data_frame(data)+ |
+
| 112 | +3x | +
+ data <- dplyr::ungroup(data)+ |
+
| 113 | +3x | +
+ cards::process_selectors(data, by = {{ by }}, variables = {{ variables }}, id = {{ id }})
+ |
+
| 114 | +3x | +
+ check_scalar(by)+ |
+
| 115 | +3x | +
+ check_scalar(id)+ |
+
| 116 | +3x | +
+ check_range(conf.level, range = c(0, 1))+ |
+
| 117 | ++ | + + | +
| 118 | ++ |
+ # return empty ARD if no variables selected ----------------------------------+ |
+
| 119 | +3x | +
+ if (is_empty(variables)) {
+ |
+
| 120 | +! | +
+ return(dplyr::tibble() |> cards::as_card())+ |
+
| 121 | ++ |
+ }+ |
+
| 122 | ++ | + + | +
| 123 | ++ |
+ # build ARD ------------------------------------------------------------------+ |
+
| 124 | +3x | +
+ lapply(+ |
+
| 125 | +3x | +
+ variables,+ |
+
| 126 | +3x | +
+ function(variable) {
+ |
+
| 127 | +3x | +
+ .format_hedges_g_results(+ |
+
| 128 | +3x | +
+ by = by,+ |
+
| 129 | +3x | +
+ variable = variable,+ |
+
| 130 | +3x | +
+ lst_tidy =+ |
+
| 131 | +3x | +
+ cards::eval_capture_conditions({
+ |
+
| 132 | ++ |
+ # adding this reshape inside the eval, so if there is an error it's captured in the ARD object+ |
+
| 133 | +3x | +
+ data_wide <-+ |
+
| 134 | +3x | +
+ data |>+ |
+
| 135 | +3x | +
+ tidyr::drop_na(all_of(c(id, by, variable))) |>+ |
+
| 136 | +3x | +
+ .paired_data_pivot_wider(by = by, variable = variable, id = id) |>+ |
+
| 137 | +3x | +
+ tidyr::drop_na(any_of(c("by1", "by2")))
+ |
+
| 138 | ++ |
+ # perform paired cohen's d test+ |
+
| 139 | +2x | +
+ effectsize::hedges_g(x = data_wide[["by1"]], y = data_wide[["by2"]], paired = TRUE, ci = conf.level, ...) |>+ |
+
| 140 | +2x | +
+ parameters::standardize_names(style = "broom") |>+ |
+
| 141 | +2x | +
+ dplyr::mutate(method = "Paired Hedge's G")+ |
+
| 142 | ++ |
+ }),+ |
+
| 143 | +3x | +
+ paired = TRUE,+ |
+
| 144 | ++ |
+ ...+ |
+
| 145 | ++ |
+ )+ |
+
| 146 | ++ |
+ }+ |
+
| 147 | ++ |
+ ) |>+ |
+
| 148 | +3x | +
+ dplyr::bind_rows()+ |
+
| 149 | ++ |
+ }+ |
+
| 150 | ++ | + + | +
| 151 | ++ |
+ #' Convert Hedge's G Test to ARD+ |
+
| 152 | ++ |
+ #'+ |
+
| 153 | ++ |
+ #' @inheritParams cards::tidy_as_ard+ |
+
| 154 | ++ |
+ #' @inheritParams effectsize::hedges_g+ |
+
| 155 | ++ |
+ #' @param by (`string`)\cr by column name+ |
+
| 156 | ++ |
+ #' @param variable (`string`)\cr variable column name+ |
+
| 157 | ++ |
+ #' @param ... passed to `hedges_g(...)`+ |
+
| 158 | ++ |
+ #'+ |
+
| 159 | ++ |
+ #' @return ARD data frame+ |
+
| 160 | ++ |
+ #' @keywords internal+ |
+
| 161 | ++ |
+ #' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = c("effectsize", "parameters")))
+ |
+
| 162 | ++ |
+ #' cardx:::.format_hedges_g_results(+ |
+
| 163 | ++ |
+ #' by = "ARM",+ |
+
| 164 | ++ |
+ #' variable = "AGE",+ |
+
| 165 | ++ |
+ #' paired = FALSE,+ |
+
| 166 | ++ |
+ #' lst_tidy =+ |
+
| 167 | ++ |
+ #' cards::eval_capture_conditions(+ |
+
| 168 | ++ |
+ #' effectsize::hedges_g(data[[variable]] ~ data[[by]], paired = FALSE) |>+ |
+
| 169 | ++ |
+ #' parameters::standardize_names(style = "broom")+ |
+
| 170 | ++ |
+ #' )+ |
+
| 171 | ++ |
+ #' )+ |
+
| 172 | ++ |
+ .format_hedges_g_results <- function(by, variable, lst_tidy, paired, ...) {
+ |
+
| 173 | ++ |
+ # build ARD ------------------------------------------------------------------+ |
+
| 174 | +8x | +
+ ret <-+ |
+
| 175 | +8x | +
+ cards::tidy_as_ard(+ |
+
| 176 | +8x | +
+ lst_tidy = lst_tidy,+ |
+
| 177 | +8x | +
+ tidy_result_names = c(+ |
+
| 178 | +8x | +
+ "estimate", "conf.level", "conf.low", "conf.high"+ |
+
| 179 | ++ |
+ ),+ |
+
| 180 | +8x | +
+ fun_args_to_record = c("mu", "paired", "pooled_sd", "alternative"),
+ |
+
| 181 | +8x | +
+ formals = formals(asNamespace("effectsize")[["hedges_g"]]),
+ |
+
| 182 | +8x | +
+ passed_args = c(list(paired = paired), dots_list(...)),+ |
+
| 183 | +8x | +
+ lst_ard_columns = list(group1 = by, variable = variable, context = "effectsize_hedges_g")+ |
+
| 184 | ++ |
+ )+ |
+
| 185 | ++ | + + | +
| 186 | ++ |
+ # add the stat label ---------------------------------------------------------+ |
+
| 187 | +8x | +
+ ret |>+ |
+
| 188 | +8x | +
+ dplyr::left_join(+ |
+
| 189 | +8x | +
+ .df_effectsize_stat_labels(),+ |
+
| 190 | +8x | +
+ by = "stat_name"+ |
+
| 191 | ++ |
+ ) |>+ |
+
| 192 | +8x | +
+ dplyr::mutate(stat_label = dplyr::coalesce(.data$stat_label, .data$stat_name)) |>+ |
+
| 193 | +8x | +
+ cards::as_card() |>+ |
+
| 194 | +8x | +
+ cards::tidy_ard_column_order()+ |
+
| 195 | ++ |
+ }+ |
+
| 1 | ++ |
+ #' ARD ANOVA+ |
+
| 2 | ++ |
+ #'+ |
+
| 3 | ++ |
+ #' Prepare ANOVA results from the `stats::anova()` function.+ |
+
| 4 | ++ |
+ #' Users may pass a pre-calculated `stats::anova()` object or a list of+ |
+
| 5 | ++ |
+ #' formulas. In the latter case, the models will be constructed using the+ |
+
| 6 | ++ |
+ #' information passed and models will be passed to `stats::anova()`.+ |
+
| 7 | ++ |
+ #'+ |
+
| 8 | ++ |
+ #' @param x (`anova` or `data.frame`)\cr+ |
+
| 9 | ++ |
+ #' an object of class `'anova'` created with `stats::anova()` or+ |
+
| 10 | ++ |
+ #' a data frame+ |
+
| 11 | ++ |
+ #' @param formulas (`list`)\cr+ |
+
| 12 | ++ |
+ #' a list of formulas+ |
+
| 13 | ++ |
+ #' @param method_text (`string`)\cr+ |
+
| 14 | ++ |
+ #' string of the method used. Default is `"ANOVA results from `stats::anova()`"`.+ |
+
| 15 | ++ |
+ #' We provide the option to change this as `stats::anova()` can produce+ |
+
| 16 | ++ |
+ #' results from many types of models that may warrant a more precise+ |
+
| 17 | ++ |
+ #' description.+ |
+
| 18 | ++ |
+ #' @inheritParams rlang::args_dots_empty+ |
+
| 19 | ++ |
+ #' @inheritParams construction_helpers+ |
+
| 20 | ++ |
+ #'+ |
+
| 21 | ++ |
+ #' @details+ |
+
| 22 | ++ |
+ #' When a list of formulas is supplied to `ard_stats_anova()`, these formulas+ |
+
| 23 | ++ |
+ #' along with information from other arguments, are used to construct models+ |
+
| 24 | ++ |
+ #' and pass those models to `stats::anova()`.+ |
+
| 25 | ++ |
+ #'+ |
+
| 26 | ++ |
+ #' The models are constructed using `rlang::exec()`, which is similar to `do.call()`.+ |
+
| 27 | ++ |
+ #'+ |
+
| 28 | ++ |
+ #' ```r+ |
+
| 29 | ++ |
+ #' rlang::exec(.fn = method, formula = formula, data = data, !!!method.args)+ |
+
| 30 | ++ |
+ #' ```+ |
+
| 31 | ++ |
+ #'+ |
+
| 32 | ++ |
+ #' The above function is executed in `withr::with_namespace(package)`, which+ |
+
| 33 | ++ |
+ #' allows for the use of `ard_stats_anova(method)` from packages,+ |
+
| 34 | ++ |
+ #' e.g. `package = 'lme4'` must be specified when `method = 'glmer'`.+ |
+
| 35 | ++ |
+ #' See example below.+ |
+
| 36 | ++ |
+ #'+ |
+
| 37 | ++ |
+ #' @return ARD data frame+ |
+
| 38 | ++ |
+ #' @name ard_stats_anova+ |
+
| 39 | ++ |
+ #'+ |
+
| 40 | ++ |
+ #' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = c("broom", "withr", "lme4")))
+ |
+
| 41 | ++ |
+ #' anova(+ |
+
| 42 | ++ |
+ #' lm(mpg ~ am, mtcars),+ |
+
| 43 | ++ |
+ #' lm(mpg ~ am + hp, mtcars)+ |
+
| 44 | ++ |
+ #' ) |>+ |
+
| 45 | ++ |
+ #' ard_stats_anova()+ |
+
| 46 | ++ |
+ #'+ |
+
| 47 | ++ |
+ #' ard_stats_anova(+ |
+
| 48 | ++ |
+ #' x = mtcars,+ |
+
| 49 | ++ |
+ #' formulas = list(am ~ mpg, am ~ mpg + hp),+ |
+
| 50 | ++ |
+ #' method = "glm",+ |
+
| 51 | ++ |
+ #' method.args = list(family = binomial)+ |
+
| 52 | ++ |
+ #' )+ |
+
| 53 | ++ |
+ #'+ |
+
| 54 | ++ |
+ #' ard_stats_anova(+ |
+
| 55 | ++ |
+ #' x = mtcars,+ |
+
| 56 | ++ |
+ #' formulas = list(am ~ 1 + (1 | vs), am ~ mpg + (1 | vs)),+ |
+
| 57 | ++ |
+ #' method = "glmer",+ |
+
| 58 | ++ |
+ #' method.args = list(family = binomial),+ |
+
| 59 | ++ |
+ #' package = "lme4"+ |
+
| 60 | ++ |
+ #' )+ |
+
| 61 | ++ |
+ NULL+ |
+
| 62 | ++ | + + | +
| 63 | ++ |
+ #' @rdname ard_stats_anova+ |
+
| 64 | ++ |
+ #' @export+ |
+
| 65 | ++ |
+ ard_stats_anova <- function(x, ...) {
+ |
+
| 66 | +9x | +
+ UseMethod("ard_stats_anova")
+ |
+
| 67 | ++ |
+ }+ |
+
| 68 | ++ | + + | +
| 69 | ++ |
+ #' @rdname ard_stats_anova+ |
+
| 70 | ++ |
+ #' @export+ |
+
| 71 | ++ |
+ ard_stats_anova.anova <- function(x, method_text = "ANOVA results from `stats::anova()`", ...) {
+ |
+
| 72 | +3x | +
+ set_cli_abort_call()+ |
+
| 73 | ++ | + + | +
| 74 | ++ |
+ # check inputs ---------------------------------------------------------------+ |
+
| 75 | +3x | +
+ check_dots_empty()+ |
+
| 76 | +3x | +
+ check_pkg_installed("broom")
+ |
+
| 77 | +3x | +
+ check_string(method_text)+ |
+
| 78 | ++ | + + | +
| 79 | ++ |
+ # return df in cards formats -------------------------------------------------+ |
+
| 80 | +3x | +
+ lst_results <-+ |
+
| 81 | +3x | +
+ cards::eval_capture_conditions(+ |
+
| 82 | +3x | +
+ .anova_tidy_and_reshape(x, method_text = method_text)+ |
+
| 83 | ++ |
+ )+ |
+
| 84 | ++ | + + | +
| 85 | ++ |
+ # final tidying up of cards data frame ---------------------------------------+ |
+
| 86 | +3x | +
+ .anova_final_ard_prep(lst_results, method_text = method_text)+ |
+
| 87 | ++ |
+ }+ |
+
| 88 | ++ | + + | +
| 89 | ++ | + + | +
| 90 | ++ |
+ #' @rdname ard_stats_anova+ |
+
| 91 | ++ |
+ #' @export+ |
+
| 92 | ++ |
+ ard_stats_anova.data.frame <- function(x,+ |
+
| 93 | ++ |
+ formulas,+ |
+
| 94 | ++ |
+ method,+ |
+
| 95 | ++ |
+ method.args = list(),+ |
+
| 96 | ++ |
+ package = "base",+ |
+
| 97 | ++ |
+ method_text = "ANOVA results from `stats::anova()`",+ |
+
| 98 | ++ |
+ ...) {
+ |
+
| 99 | +6x | +
+ set_cli_abort_call()+ |
+
| 100 | ++ | + + | +
| 101 | ++ |
+ # check inputs ---------------------------------------------------------------+ |
+
| 102 | +6x | +
+ check_dots_empty()+ |
+
| 103 | +6x | +
+ check_pkg_installed(c("broom", "withr", package))
+ |
+
| 104 | +6x | +
+ check_not_missing(formulas)+ |
+
| 105 | +6x | +
+ check_class(formulas, cls = "list")+ |
+
| 106 | +6x | +
+ walk(+ |
+
| 107 | +6x | +
+ formulas,+ |
+
| 108 | +6x | +
+ ~ check_class(+ |
+
| 109 | +6x | +
+ .x,+ |
+
| 110 | +6x | +
+ cls = "formula",+ |
+
| 111 | +6x | +
+ arg_name = "formulas",+ |
+
| 112 | +6x | +
+ message = "Each element of {.arg formulas} must be class {.cls formula}"
+ |
+
| 113 | ++ |
+ )+ |
+
| 114 | ++ |
+ )+ |
+
| 115 | ++ | + + | +
| 116 | ++ |
+ # calculate results and return df in cards formats ---------------------------+ |
+
| 117 | ++ |
+ # create models+ |
+
| 118 | +6x | +
+ lst_results <-+ |
+
| 119 | +6x | +
+ cards::eval_capture_conditions({
+ |
+
| 120 | ++ |
+ # first build the models+ |
+
| 121 | +6x | +
+ models <-+ |
+
| 122 | +6x | +
+ lapply(+ |
+
| 123 | +6x | +
+ formulas,+ |
+
| 124 | +6x | +
+ function(formula) {
+ |
+
| 125 | +11x | +
+ construct_model(data = x, formula = formula, method = method, method.args = {{ method.args }}, package = package)
+ |
+
| 126 | ++ |
+ }+ |
+
| 127 | ++ |
+ )+ |
+
| 128 | ++ | + + | +
| 129 | ++ |
+ # now calculate `stats::anova()` and reshape results+ |
+
| 130 | +5x | +
+ rlang::inject(stats::anova(!!!models)) |>+ |
+
| 131 | +5x | +
+ .anova_tidy_and_reshape(method_text = method_text)+ |
+
| 132 | ++ |
+ })+ |
+
| 133 | ++ | + + | +
| 134 | ++ |
+ # final tidying up of cards data frame ---------------------------------------+ |
+
| 135 | +6x | +
+ .anova_final_ard_prep(lst_results, method_text = method_text)+ |
+
| 136 | ++ |
+ }+ |
+
| 137 | ++ | + + | +
| 138 | ++ |
+ .anova_tidy_and_reshape <- function(x, method_text) {
+ |
+
| 139 | +8x | +
+ broom::tidy(x) |>+ |
+
| 140 | +8x | +
+ dplyr::mutate(+ |
+
| 141 | +8x | +
+ across(everything(), as.list),+ |
+
| 142 | +8x | +
+ variable = paste0("model_", dplyr::row_number())
+ |
+
| 143 | ++ |
+ ) |>+ |
+
| 144 | +8x | +
+ tidyr::pivot_longer(+ |
+
| 145 | +8x | +
+ cols = -"variable",+ |
+
| 146 | +8x | +
+ names_to = "stat_name",+ |
+
| 147 | +8x | +
+ values_to = "stat"+ |
+
| 148 | ++ |
+ ) |>+ |
+
| 149 | +8x | +
+ dplyr::filter(!is.na(.data$stat)) %>%+ |
+
| 150 | ++ |
+ # add one more row with the method+ |
+
| 151 | ++ |
+ {
+ |
+
| 152 | +8x | +
+ dplyr::bind_rows(+ |
+
| 153 | ++ |
+ .,+ |
+
| 154 | +8x | +
+ dplyr::filter(., dplyr::n() == dplyr::row_number()) |>+ |
+
| 155 | +8x | +
+ dplyr::mutate(+ |
+
| 156 | +8x | +
+ stat_name = "method",+ |
+
| 157 | +8x | +
+ stat = list(.env$method_text)+ |
+
| 158 | ++ |
+ )+ |
+
| 159 | ++ |
+ )+ |
+
| 160 | ++ |
+ }+ |
+
| 161 | ++ |
+ }+ |
+
| 162 | ++ | + + | +
| 163 | ++ |
+ .anova_final_ard_prep <- function(lst_results, method_text) {
+ |
+
| 164 | ++ |
+ # saving the results in data frame -------------------------------------------+ |
+
| 165 | +9x | +
+ df_card <-+ |
+
| 166 | +9x | +
+ if (!is.null(lst_results[["result"]])) {
+ |
+
| 167 | +8x | +
+ lst_results[["result"]]+ |
+
| 168 | +9x | +
+ } else { # if there was an error return a shell of an ARD data frame
+ |
+
| 169 | +1x | +
+ dplyr::tibble(+ |
+
| 170 | +1x | +
+ variable = "model_1",+ |
+
| 171 | +1x | +
+ stat_name = c("p.value", "method"),
+ |
+
| 172 | +1x | +
+ stat = list(NULL, method_text)+ |
+
| 173 | ++ |
+ )+ |
+
| 174 | ++ |
+ }+ |
+
| 175 | ++ | + + | +
| 176 | ++ |
+ # final tidying up of cards data frame ---------------------------------------+ |
+
| 177 | +9x | +
+ df_card |>+ |
+
| 178 | +9x | +
+ dplyr::mutate(+ |
+
| 179 | +9x | +
+ warning = lst_results["warning"],+ |
+
| 180 | +9x | +
+ error = lst_results["error"],+ |
+
| 181 | +9x | +
+ context = "stats_anova",+ |
+
| 182 | +9x | +
+ fmt_fn = lapply(+ |
+
| 183 | +9x | +
+ .data$stat,+ |
+
| 184 | +9x | +
+ function(x) {
+ |
+
| 185 | +88x | +
+ switch(is.integer(x),+ |
+
| 186 | +88x | +
+ 0L+ |
+
| 187 | +88x | +
+ ) %||% switch(is.numeric(x),+ |
+
| 188 | +88x | +
+ 1L+ |
+
| 189 | ++ |
+ )+ |
+
| 190 | ++ |
+ }+ |
+
| 191 | ++ |
+ ),+ |
+
| 192 | +9x | +
+ stat_label =+ |
+
| 193 | +9x | +
+ dplyr::case_when(+ |
+
| 194 | +9x | +
+ .data$stat_name %in% "p.value" ~ "p-value",+ |
+
| 195 | +9x | +
+ .data$stat_name %in% "sumsq" ~ "Sum of Squares",+ |
+
| 196 | +9x | +
+ .data$stat_name %in% "rss" ~ "Residual Sum of Squares",+ |
+
| 197 | +9x | +
+ .data$stat_name %in% "df" ~ "Degrees of Freedom",+ |
+
| 198 | +9x | +
+ .data$stat_name %in% "df.residual" ~ "df for residuals",+ |
+
| 199 | +9x | +
+ .default = .data$stat_name+ |
+
| 200 | ++ |
+ )+ |
+
| 201 | ++ |
+ ) |>+ |
+
| 202 | +9x | +
+ cards::as_card() |>+ |
+
| 203 | +9x | +
+ cards::tidy_ard_column_order()+ |
+
| 204 | ++ |
+ }+ |
+
| 1 | ++ |
+ #' Regression ARD+ |
+
| 2 | ++ |
+ #'+ |
+
| 3 | ++ |
+ #' Function takes a regression model object and converts it to a ARD+ |
+
| 4 | ++ |
+ #' structure using the `broom.helpers` package.+ |
+
| 5 | ++ |
+ #'+ |
+
| 6 | ++ |
+ #' @param x regression model object+ |
+
| 7 | ++ |
+ #' @param tidy_fun (`function`)\cr+ |
+
| 8 | ++ |
+ #' a tidier. Default is [`broom.helpers::tidy_with_broom_or_parameters`]+ |
+
| 9 | ++ |
+ #' @param ... Arguments passed to [`broom.helpers::tidy_plus_plus()`]+ |
+
| 10 | ++ |
+ #'+ |
+
| 11 | ++ |
+ #' @return data frame+ |
+
| 12 | ++ |
+ #' @name ard_regression+ |
+
| 13 | ++ |
+ #'+ |
+
| 14 | ++ |
+ #' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = "broom.helpers"))
+ |
+
| 15 | ++ |
+ #' lm(AGE ~ ARM, data = cards::ADSL) |>+ |
+
| 16 | ++ |
+ #' ard_regression(add_estimate_to_reference_rows = TRUE)+ |
+
| 17 | ++ |
+ NULL+ |
+
| 18 | ++ | + + | +
| 19 | ++ |
+ #' @rdname ard_regression+ |
+
| 20 | ++ |
+ #' @export+ |
+
| 21 | ++ |
+ ard_regression <- function(x, ...) {
+ |
+
| 22 | +18x | +
+ UseMethod("ard_regression")
+ |
+
| 23 | ++ |
+ }+ |
+
| 24 | ++ | + + | +
| 25 | ++ |
+ #' @rdname ard_regression+ |
+
| 26 | ++ |
+ #' @export+ |
+
| 27 | ++ |
+ ard_regression.default <- function(x, tidy_fun = broom.helpers::tidy_with_broom_or_parameters, ...) {
+ |
+
| 28 | +18x | +
+ set_cli_abort_call()+ |
+
| 29 | ++ | + + | +
| 30 | ++ |
+ # check installed packages ---------------------------------------------------+ |
+
| 31 | +18x | +
+ check_pkg_installed(pkg = "broom.helpers")+ |
+
| 32 | ++ | + + | +
| 33 | ++ |
+ # check inputs ---------------------------------------------------------------+ |
+
| 34 | +18x | +
+ check_not_missing(x)+ |
+
| 35 | ++ | + + | +
| 36 | ++ |
+ # summarize model ------------------------------------------------------------+ |
+
| 37 | +18x | +
+ lst_results <- cards::eval_capture_conditions(+ |
+
| 38 | +18x | +
+ broom.helpers::tidy_plus_plus(+ |
+
| 39 | +18x | +
+ model = x,+ |
+
| 40 | +18x | +
+ tidy_fun = tidy_fun,+ |
+
| 41 | ++ |
+ ...+ |
+
| 42 | ++ |
+ )+ |
+
| 43 | ++ |
+ )+ |
+
| 44 | ++ | + + | +
| 45 | ++ |
+ # final tidying up of cards data frame ---------------------------------------+ |
+
| 46 | +18x | +
+ .regression_final_ard_prep(lst_results)+ |
+
| 47 | ++ |
+ }+ |
+
| 48 | ++ | + + | +
| 49 | ++ |
+ .regression_final_ard_prep <- function(lst_results) {
+ |
+
| 50 | ++ |
+ # saving the results in data frame -------------------------------------------+ |
+
| 51 | +18x | +
+ df_card <-+ |
+
| 52 | +18x | +
+ if (!is.null(lst_results[["result"]])) {
+ |
+
| 53 | +16x | +
+ lst_results[["result"]] |>+ |
+
| 54 | +16x | +
+ dplyr::mutate(+ |
+
| 55 | +16x | +
+ variable_level = as.list(dplyr::if_else(.data$var_type %in% "continuous", NA_character_, .data$label)),+ |
+
| 56 | +16x | +
+ dplyr::across(-c("variable", "variable_level"), .fns = as.list)
+ |
+
| 57 | ++ |
+ ) |>+ |
+
| 58 | +16x | +
+ tidyr::pivot_longer(+ |
+
| 59 | +16x | +
+ cols = -c("variable", "variable_level"),
+ |
+
| 60 | +16x | +
+ names_to = "stat_name",+ |
+
| 61 | +16x | +
+ values_to = "stat"+ |
+
| 62 | ++ |
+ ) |>+ |
+
| 63 | +16x | +
+ dplyr::filter(map_lgl(.data$stat, Negate(is.na))) |>+ |
+
| 64 | +16x | +
+ dplyr::select(-(cards::all_ard_variables("levels") & dplyr::where(\(x) all(is.na(x)))))
+ |
+
| 65 | +18x | +
+ } else { # if there was an error return a shell of an ARD data frame
+ |
+
| 66 | +2x | +
+ dplyr::tibble(+ |
+
| 67 | +2x | +
+ variable = "model_1",+ |
+
| 68 | +2x | +
+ stat_name = "estimate",+ |
+
| 69 | +2x | +
+ stat = list(NULL)+ |
+
| 70 | ++ |
+ )+ |
+
| 71 | ++ |
+ }+ |
+
| 72 | ++ | + + | +
| 73 | ++ |
+ # final tidying up of ARD data frame ---------------------------------------+ |
+
| 74 | +18x | +
+ df_card |>+ |
+
| 75 | +18x | +
+ dplyr::mutate(+ |
+
| 76 | +18x | +
+ warning = lst_results["warning"],+ |
+
| 77 | +18x | +
+ error = lst_results["error"],+ |
+
| 78 | +18x | +
+ fmt_fn = lapply(+ |
+
| 79 | +18x | +
+ .data$stat,+ |
+
| 80 | +18x | +
+ function(x) {
+ |
+
| 81 | +429x | +
+ switch(is.integer(x),+ |
+
| 82 | +429x | +
+ 0L+ |
+
| 83 | +429x | +
+ ) %||% switch(is.numeric(x),+ |
+
| 84 | +429x | +
+ 1L+ |
+
| 85 | ++ |
+ )+ |
+
| 86 | ++ |
+ }+ |
+
| 87 | ++ |
+ ),+ |
+
| 88 | +18x | +
+ context = "regression"+ |
+
| 89 | ++ |
+ ) |>+ |
+
| 90 | +18x | +
+ dplyr::left_join(+ |
+
| 91 | +18x | +
+ .df_regression_stat_labels(),+ |
+
| 92 | +18x | +
+ by = "stat_name"+ |
+
| 93 | ++ |
+ ) |>+ |
+
| 94 | +18x | +
+ dplyr::mutate(stat_label = dplyr::coalesce(.data$stat_label, .data$stat_name)) |>+ |
+
| 95 | +18x | +
+ cards::as_card() |>+ |
+
| 96 | +18x | +
+ cards::tidy_ard_column_order()+ |
+
| 97 | ++ |
+ }+ |
+
| 98 | ++ | + + | +
| 99 | ++ |
+ .df_regression_stat_labels <- function() {
+ |
+
| 100 | +18x | +
+ dplyr::tribble(+ |
+
| 101 | +18x | +
+ ~stat_name, ~stat_label,+ |
+
| 102 | +18x | +
+ "var_label", "Label",+ |
+
| 103 | +18x | +
+ "var_class", "Class",+ |
+
| 104 | +18x | +
+ "var_type", "Type",+ |
+
| 105 | +18x | +
+ "var_nlevels", "N Levels",+ |
+
| 106 | +18x | +
+ "contrasts_type", "Contrast Type",+ |
+
| 107 | +18x | +
+ "label", "Level Label",+ |
+
| 108 | +18x | +
+ "n_obs", "N Obs.",+ |
+
| 109 | +18x | +
+ "n_event", "N Events",+ |
+
| 110 | +18x | +
+ "exposure", "Exposure Time",+ |
+
| 111 | +18x | +
+ "estimate", "Coefficient",+ |
+
| 112 | +18x | +
+ "std.error", "Standard Error",+ |
+
| 113 | +18x | +
+ "p.value", "p-value",+ |
+
| 114 | +18x | +
+ "conf.low", "CI Lower Bound",+ |
+
| 115 | +18x | +
+ "conf.high", "CI Upper Bound",+ |
+
| 116 | ++ |
+ )+ |
+
| 117 | ++ |
+ }+ |
+
| 1 | ++ |
+ #' ARD t-test+ |
+
| 2 | ++ |
+ #'+ |
+
| 3 | ++ |
+ #' @description+ |
+
| 4 | ++ |
+ #' Analysis results data for paired and non-paired t-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 t-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 `t.test()`+ |
+
| 18 | ++ |
+ #'+ |
+
| 19 | ++ |
+ #' @return ARD data frame+ |
+
| 20 | ++ |
+ #' @name ard_stats_t_test+ |
+
| 21 | ++ |
+ #'+ |
+
| 22 | ++ |
+ #' @details+ |
+
| 23 | ++ |
+ #' For the `ard_stats_t_test()` function, the data is expected to be one row per subject.+ |
+
| 24 | ++ |
+ #' The data is passed as `t.test(data[[variable]] ~ data[[by]], paired = FALSE, ...)`.+ |
+
| 25 | ++ |
+ #'+ |
+
| 26 | ++ |
+ #' For the `ard_stats_paired_t_test()` function, the data is expected to be one row+ |
+
| 27 | ++ |
+ #' per subject per by level. Before the t-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 | ++ |
+ #' `t.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"))
+ |
+
| 33 | ++ |
+ #' cards::ADSL |>+ |
+
| 34 | ++ |
+ #' dplyr::filter(ARM %in% c("Placebo", "Xanomeline High Dose")) |>
+ |
+
| 35 | ++ |
+ #' ard_stats_t_test(by = ARM, variables = c(AGE, BMIBL))+ |
+
| 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_t_test(by = ARM, variables = AGE, id = USUBJID)+ |
+
| 44 | ++ |
+ NULL+ |
+
| 45 | ++ | + + | +
| 46 | ++ |
+ #' @rdname ard_stats_t_test+ |
+
| 47 | ++ |
+ #' @export+ |
+
| 48 | ++ |
+ ard_stats_t_test <- function(data, variables, by = NULL, conf.level = 0.95, ...) {
+ |
+
| 49 | +6x | +
+ set_cli_abort_call()+ |
+
| 50 | ++ | + + | +
| 51 | ++ |
+ # check installed packages ---------------------------------------------------+ |
+
| 52 | +6x | +
+ check_pkg_installed("broom")
+ |
+
| 53 | ++ | + + | +
| 54 | ++ |
+ # check/process inputs -------------------------------------------------------+ |
+
| 55 | +6x | +
+ check_not_missing(data)+ |
+
| 56 | +6x | +
+ check_not_missing(variables)+ |
+
| 57 | +6x | +
+ check_data_frame(data)+ |
+
| 58 | +6x | +
+ data <- dplyr::ungroup(data)+ |
+
| 59 | +6x | +
+ cards::process_selectors(data, by = {{ by }}, variables = {{ variables }})
+ |
+
| 60 | +6x | +
+ check_scalar(by, allow_empty = TRUE)+ |
+
| 61 | +6x | +
+ check_range(conf.level, range = c(0, 1))+ |
+
| 62 | ++ | + + | +
| 63 | ++ |
+ # return empty ARD if no variables selected ----------------------------------+ |
+
| 64 | +6x | +
+ if (is_empty(variables)) {
+ |
+
| 65 | +! | +
+ return(dplyr::tibble() |> cards::as_card())+ |
+
| 66 | ++ |
+ }+ |
+
| 67 | ++ | + + | +
| 68 | ++ |
+ # build ARD ------------------------------------------------------------------+ |
+
| 69 | +6x | +
+ lapply(+ |
+
| 70 | +6x | +
+ variables,+ |
+
| 71 | +6x | +
+ function(variable) {
+ |
+
| 72 | +7x | +
+ .format_ttest_results(+ |
+
| 73 | +7x | +
+ by = by,+ |
+
| 74 | +7x | +
+ variable = variable,+ |
+
| 75 | +7x | +
+ lst_tidy =+ |
+
| 76 | ++ |
+ # styler: off+ |
+
| 77 | +7x | +
+ cards::eval_capture_conditions(+ |
+
| 78 | +7x | +
+ if (!is_empty(by)) stats::t.test(data[[variable]] ~ data[[by]], conf.level = conf.level, ...) |> broom::tidy()+ |
+
| 79 | +7x | +
+ else stats::t.test(data[[variable]], ...) |> broom::tidy()+ |
+
| 80 | ++ |
+ ),+ |
+
| 81 | ++ |
+ # styler: on+ |
+
| 82 | +7x | +
+ paired = FALSE,+ |
+
| 83 | ++ |
+ ...+ |
+
| 84 | ++ |
+ )+ |
+
| 85 | ++ |
+ }+ |
+
| 86 | ++ |
+ ) |>+ |
+
| 87 | +6x | +
+ dplyr::bind_rows()+ |
+
| 88 | ++ |
+ }+ |
+
| 89 | ++ | + + | +
| 90 | ++ |
+ #' @rdname ard_stats_t_test+ |
+
| 91 | ++ |
+ #' @export+ |
+
| 92 | ++ |
+ ard_stats_paired_t_test <- function(data, by, variables, id, conf.level = 0.95, ...) {
+ |
+
| 93 | +2x | +
+ set_cli_abort_call()+ |
+
| 94 | ++ | + + | +
| 95 | ++ |
+ # check installed packages ---------------------------------------------------+ |
+
| 96 | +2x | +
+ check_pkg_installed("broom")
+ |
+
| 97 | ++ | + + | +
| 98 | ++ |
+ # check/process inputs -------------------------------------------------------+ |
+
| 99 | +2x | +
+ check_not_missing(data)+ |
+
| 100 | +2x | +
+ check_not_missing(variables)+ |
+
| 101 | +2x | +
+ check_not_missing(by)+ |
+
| 102 | +2x | +
+ check_not_missing(id)+ |
+
| 103 | +2x | +
+ check_data_frame(data)+ |
+
| 104 | +2x | +
+ data <- dplyr::ungroup(data)+ |
+
| 105 | +2x | +
+ cards::process_selectors(data, by = {{ by }}, variables = {{ variables }}, id = {{ id }})
+ |
+
| 106 | +2x | +
+ check_scalar(by)+ |
+
| 107 | +2x | +
+ check_scalar(id)+ |
+
| 108 | ++ | + + | +
| 109 | ++ |
+ # return empty ARD if no variables selected ----------------------------------+ |
+
| 110 | +2x | +
+ if (is_empty(variables)) {
+ |
+
| 111 | +! | +
+ return(dplyr::tibble() |> cards::as_card())+ |
+
| 112 | ++ |
+ }+ |
+
| 113 | ++ | + + | +
| 114 | ++ |
+ # build ARD ------------------------------------------------------------------+ |
+
| 115 | +2x | +
+ lapply(+ |
+
| 116 | +2x | +
+ variables,+ |
+
| 117 | +2x | +
+ function(variable) {
+ |
+
| 118 | +2x | +
+ .format_ttest_results(+ |
+
| 119 | +2x | +
+ by = by,+ |
+
| 120 | +2x | +
+ variable = variable,+ |
+
| 121 | +2x | +
+ lst_tidy =+ |
+
| 122 | +2x | +
+ cards::eval_capture_conditions({
+ |
+
| 123 | ++ |
+ # adding this reshape inside the eval, so if there is an error it's captured in the ARD object+ |
+
| 124 | +2x | +
+ data_wide <- .paired_data_pivot_wider(data, by = by, variable = variable, id = id)+ |
+
| 125 | ++ |
+ # perform paired t-test+ |
+
| 126 | +1x | +
+ stats::t.test(x = data_wide[["by1"]], y = data_wide[["by2"]], paired = TRUE, conf.level = conf.level, ...) |>+ |
+
| 127 | +1x | +
+ broom::tidy()+ |
+
| 128 | ++ |
+ }),+ |
+
| 129 | +2x | +
+ paired = TRUE,+ |
+
| 130 | ++ |
+ ...+ |
+
| 131 | ++ |
+ )+ |
+
| 132 | ++ |
+ }+ |
+
| 133 | ++ |
+ ) |>+ |
+
| 134 | +2x | +
+ dplyr::bind_rows()+ |
+
| 135 | ++ |
+ }+ |
+
| 136 | ++ | + + | +
| 137 | ++ |
+ #' Convert t-test to ARD+ |
+
| 138 | ++ |
+ #'+ |
+
| 139 | ++ |
+ #' @inheritParams cards::tidy_as_ard+ |
+
| 140 | ++ |
+ #' @inheritParams stats::t.test+ |
+
| 141 | ++ |
+ #' @param by (`string`)\cr by column name+ |
+
| 142 | ++ |
+ #' @param variable (`string`)\cr variable column name+ |
+
| 143 | ++ |
+ #' @param ... passed to `t.test(...)`+ |
+
| 144 | ++ |
+ #'+ |
+
| 145 | ++ |
+ #' @return ARD data frame+ |
+
| 146 | ++ |
+ #' @keywords internal+ |
+
| 147 | ++ |
+ #' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = "broom"))
+ |
+
| 148 | ++ |
+ #' cardx:::.format_ttest_results(+ |
+
| 149 | ++ |
+ #' by = "ARM",+ |
+
| 150 | ++ |
+ #' variable = "AGE",+ |
+
| 151 | ++ |
+ #' paired = FALSE,+ |
+
| 152 | ++ |
+ #' lst_tidy =+ |
+
| 153 | ++ |
+ #' cards::eval_capture_conditions(+ |
+
| 154 | ++ |
+ #' stats::t.test(ADSL[["AGE"]] ~ ADSL[["ARM"]], paired = FALSE) |>+ |
+
| 155 | ++ |
+ #' broom::tidy()+ |
+
| 156 | ++ |
+ #' )+ |
+
| 157 | ++ |
+ #' )+ |
+
| 158 | ++ |
+ .format_ttest_results <- function(by = NULL, variable, lst_tidy, paired, ...) {
+ |
+
| 159 | ++ |
+ # build ARD ------------------------------------------------------------------+ |
+
| 160 | +9x | +
+ ret <-+ |
+
| 161 | +9x | +
+ cards::tidy_as_ard(+ |
+
| 162 | +9x | +
+ lst_tidy = lst_tidy,+ |
+
| 163 | +9x | +
+ tidy_result_names =+ |
+
| 164 | +9x | +
+ c(+ |
+
| 165 | +9x | +
+ "estimate", "statistic",+ |
+
| 166 | +9x | +
+ "p.value", "parameter", "conf.low", "conf.high",+ |
+
| 167 | +9x | +
+ "method", "alternative"+ |
+
| 168 | ++ |
+ ) |>+ |
+
| 169 | ++ |
+ # add estimate1 and estimate2 if there is a by variable+ |
+
| 170 | +9x | +
+ append(values = switch(!is_empty(by), c("estimate1", "estimate2")), after = 1L), # styler: off
+ |
+
| 171 | +9x | +
+ fun_args_to_record = c("mu", "paired", "var.equal", "conf.level"),
+ |
+
| 172 | +9x | +
+ formals = formals(asNamespace("stats")[["t.test.default"]]),
+ |
+
| 173 | +9x | +
+ passed_args = c(list(paired = paired), dots_list(...)),+ |
+
| 174 | +9x | +
+ lst_ard_columns = list(variable = variable, context = "stats_t_test")+ |
+
| 175 | ++ |
+ )+ |
+
| 176 | ++ | + + | +
| 177 | +9x | +
+ if (!is_empty(by)) {
+ |
+
| 178 | +8x | +
+ ret <- ret |>+ |
+
| 179 | +8x | +
+ dplyr::mutate(group1 = by)+ |
+
| 180 | ++ |
+ }+ |
+
| 181 | ++ | + + | +
| 182 | ++ |
+ # add the stat label ---------------------------------------------------------+ |
+
| 183 | +9x | +
+ ret |>+ |
+
| 184 | +9x | +
+ dplyr::left_join(+ |
+
| 185 | +9x | +
+ .df_ttest_stat_labels(by = by),+ |
+
| 186 | +9x | +
+ by = "stat_name"+ |
+
| 187 | ++ |
+ ) |>+ |
+
| 188 | +9x | +
+ dplyr::mutate(stat_label = dplyr::coalesce(.data$stat_label, .data$stat_name)) |>+ |
+
| 189 | +9x | +
+ cards::as_card() |>+ |
+
| 190 | +9x | +
+ cards::tidy_ard_column_order()+ |
+
| 191 | ++ |
+ }+ |
+
| 192 | ++ | + + | +
| 193 | ++ | + + | +
| 194 | ++ |
+ #' Convert long paired data to wide+ |
+
| 195 | ++ |
+ #'+ |
+
| 196 | ++ |
+ #'+ |
+
| 197 | ++ |
+ #' @param data (`data.frame`)\cr a data frame that is one line per subject per group+ |
+
| 198 | ++ |
+ #' @param by (`string`)\cr by column name+ |
+
| 199 | ++ |
+ #' @param variable (`string`)\cr variable column name+ |
+
| 200 | ++ |
+ #' @param id (`string`)\cr subject id column name+ |
+
| 201 | ++ |
+ #'+ |
+
| 202 | ++ |
+ #' @return a wide data frame+ |
+
| 203 | ++ |
+ #' @keywords internal+ |
+
| 204 | ++ |
+ #' @examples+ |
+
| 205 | ++ |
+ #' cards::ADSL[c("ARM", "AGE")] |>
+ |
+
| 206 | ++ |
+ #' dplyr::filter(ARM %in% c("Placebo", "Xanomeline High Dose")) |>
+ |
+
| 207 | ++ |
+ #' dplyr::mutate(.by = ARM, USUBJID = dplyr::row_number()) |>+ |
+
| 208 | ++ |
+ #' dplyr::arrange(USUBJID, ARM) |>+ |
+
| 209 | ++ |
+ #' cardx:::.paired_data_pivot_wider(by = "ARM", variable = "AGE", id = "USUBJID")+ |
+
| 210 | ++ |
+ .paired_data_pivot_wider <- function(data, by, variable, id) {
+ |
+
| 211 | ++ |
+ # check the number of levels before pivoting data to wider format+ |
+
| 212 | +11x | +
+ if (dplyr::n_distinct(data[[by]], na.rm = TRUE) != 2L) {
+ |
+
| 213 | +4x | +
+ cli::cli_abort("The {.arg by} argument must have two and only two levels.",
+ |
+
| 214 | +4x | +
+ call = get_cli_abort_call()+ |
+
| 215 | ++ |
+ )+ |
+
| 216 | ++ |
+ }+ |
+
| 217 | ++ | + + | +
| 218 | +7x | +
+ data |>+ |
+
| 219 | ++ |
+ # arrange data so the first group always appears first+ |
+
| 220 | +7x | +
+ dplyr::arrange(.data[[by]]) |>+ |
+
| 221 | +7x | +
+ tidyr::pivot_wider(+ |
+
| 222 | +7x | +
+ id_cols = all_of(id),+ |
+
| 223 | +7x | +
+ names_from = all_of(by),+ |
+
| 224 | +7x | +
+ values_from = all_of(variable)+ |
+
| 225 | ++ |
+ ) |>+ |
+
| 226 | +7x | +
+ stats::setNames(c(id, "by1", "by2"))+ |
+
| 227 | ++ |
+ }+ |
+
| 228 | ++ | + + | +
| 229 | ++ |
+ .df_ttest_stat_labels <- function(by = NULL) {
+ |
+
| 230 | +28x | +
+ dplyr::tribble(+ |
+
| 231 | +28x | +
+ ~stat_name, ~stat_label,+ |
+
| 232 | +28x | +
+ "estimate1", "Group 1 Mean",+ |
+
| 233 | +28x | +
+ "estimate2", "Group 2 Mean",+ |
+
| 234 | +28x | +
+ "estimate", ifelse(is_empty(by), "Mean", "Mean Difference"),+ |
+
| 235 | +28x | +
+ "p.value", "p-value",+ |
+
| 236 | +28x | +
+ "statistic", "t Statistic",+ |
+
| 237 | +28x | +
+ "parameter", "Degrees of Freedom",+ |
+
| 238 | +28x | +
+ "conf.low", "CI Lower Bound",+ |
+
| 239 | +28x | +
+ "conf.high", "CI Upper Bound",+ |
+
| 240 | +28x | +
+ "mu", "H0 Mean",+ |
+
| 241 | +28x | +
+ "paired", "Paired t-test",+ |
+
| 242 | +28x | +
+ "var.equal", "Equal Variances",+ |
+
| 243 | +28x | +
+ "conf.level", "CI Confidence Level",+ |
+
| 244 | ++ |
+ )+ |
+
| 245 | ++ |
+ }+ |
+
| 1 | ++ |
+ #' ARD ANOVA+ |
+
| 2 | ++ |
+ #'+ |
+
| 3 | ++ |
+ #' @description+ |
+
| 4 | ++ |
+ #' Analysis results data for Analysis of Variance.+ |
+
| 5 | ++ |
+ #' Calculated with `stats::aov()`+ |
+
| 6 | ++ |
+ #'+ |
+
| 7 | ++ |
+ #' @inheritParams stats::aov+ |
+
| 8 | ++ |
+ #' @param ... arguments passed to `stats::aov(...)`+ |
+
| 9 | ++ |
+ #'+ |
+
| 10 | ++ |
+ #' @return ARD data frame+ |
+
| 11 | ++ |
+ #' @export+ |
+
| 12 | ++ |
+ #'+ |
+
| 13 | ++ |
+ #' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = c("broom.helpers", "parameters")))
+ |
+
| 14 | ++ |
+ #' ard_stats_aov(AGE ~ ARM, data = cards::ADSL)+ |
+
| 15 | ++ |
+ ard_stats_aov <- function(formula, data, ...) {
+ |
+
| 16 | +3x | +
+ set_cli_abort_call()+ |
+
| 17 | ++ | + + | +
| 18 | ++ |
+ # check installed packages ---------------------------------------------------+ |
+
| 19 | +3x | +
+ check_pkg_installed(c("broom.helpers", "parameters"))
+ |
+
| 20 | ++ | + + | +
| 21 | ++ |
+ # check/process inputs -------------------------------------------------------+ |
+
| 22 | +3x | +
+ check_not_missing(formula)+ |
+
| 23 | +3x | +
+ check_not_missing(data)+ |
+
| 24 | +3x | +
+ check_data_frame(data)+ |
+
| 25 | +3x | +
+ check_class(formula, cls = "formula")+ |
+
| 26 | ++ | + + | +
| 27 | ++ |
+ # build ARD ------------------------------------------------------------------+ |
+
| 28 | +3x | +
+ aov <-+ |
+
| 29 | +3x | +
+ cards::eval_capture_conditions(+ |
+
| 30 | +3x | +
+ stats::aov(formula, data, ...)+ |
+
| 31 | ++ |
+ )+ |
+
| 32 | +3x | +
+ aov[["result"]] |>+ |
+
| 33 | +3x | +
+ broom.helpers::tidy_parameters() |> # using broom.helpers, because it handle non-syntactic names+ |
+
| 34 | +3x | +
+ dplyr::filter(!(dplyr::row_number() == dplyr::n() & .data$term %in% "Residuals")) |> # removing Residual rows+ |
+
| 35 | +3x | +
+ dplyr::rename(variable = "term") |>+ |
+
| 36 | +3x | +
+ tidyr::pivot_longer(+ |
+
| 37 | +3x | +
+ cols = -"variable",+ |
+
| 38 | +3x | +
+ names_to = "stat_name",+ |
+
| 39 | +3x | +
+ values_to = "stat"+ |
+
| 40 | ++ |
+ ) |>+ |
+
| 41 | +3x | +
+ dplyr::mutate(+ |
+
| 42 | +3x | +
+ stat = as.list(.data$stat),+ |
+
| 43 | +3x | +
+ stat_label =+ |
+
| 44 | +3x | +
+ dplyr::case_when(+ |
+
| 45 | +3x | +
+ .data$stat_name %in% "statistic" ~ "Statistic",+ |
+
| 46 | +3x | +
+ .data$stat_name %in% "df" ~ "Degrees of Freedom",+ |
+
| 47 | +3x | +
+ .data$stat_name %in% "p.value" ~ "p-value",+ |
+
| 48 | +3x | +
+ .data$stat_name %in% "sumsq" ~ "Sum of Squares",+ |
+
| 49 | +3x | +
+ .data$stat_name %in% "meansq" ~ "Mean of Sum of Squares",+ |
+
| 50 | +3x | +
+ TRUE ~ .data$stat_name+ |
+
| 51 | ++ |
+ ),+ |
+
| 52 | +3x | +
+ context = "stats_aov",+ |
+
| 53 | +3x | +
+ fmt_fn = lapply(+ |
+
| 54 | +3x | +
+ .data$stat,+ |
+
| 55 | +3x | +
+ function(x) {
+ |
+
| 56 | +20x | +
+ switch(is.integer(x),+ |
+
| 57 | +20x | +
+ 0L+ |
+
| 58 | +20x | +
+ ) %||% switch(is.numeric(x),+ |
+
| 59 | +20x | +
+ 1L+ |
+
| 60 | ++ |
+ )+ |
+
| 61 | ++ |
+ }+ |
+
| 62 | ++ |
+ ),+ |
+
| 63 | +3x | +
+ warning = aov["warning"],+ |
+
| 64 | +3x | +
+ error = aov["error"]+ |
+
| 65 | ++ |
+ ) |>+ |
+
| 66 | +3x | +
+ cards::as_card() |>+ |
+
| 67 | +3x | +
+ cards::tidy_ard_column_order()+ |
+
| 68 | ++ |
+ }+ |
+
| 1 | ++ |
+ #' ARD continuous CIs+ |
+
| 2 | ++ |
+ #'+ |
+
| 3 | ++ |
+ #' One-sample confidence intervals for continuous variable means and medians.+ |
+
| 4 | ++ |
+ #'+ |
+
| 5 | ++ |
+ #' @inheritParams ard_stats_t_test+ |
+
| 6 | ++ |
+ #' @param method (`string`)\cr+ |
+
| 7 | ++ |
+ #' a string indicating the method to use for the confidence interval+ |
+
| 8 | ++ |
+ #' calculation. Must be one of `"t.test"` or `"wilcox.test"`+ |
+
| 9 | ++ |
+ #' @param ... arguments passed to `t.test()` or `wilcox.test()`+ |
+
| 10 | ++ |
+ #'+ |
+
| 11 | ++ |
+ #' @return ARD data frame+ |
+
| 12 | ++ |
+ #' @name ard_continuous_ci+ |
+
| 13 | ++ |
+ #'+ |
+
| 14 | ++ |
+ #' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = "broom"))
+ |
+
| 15 | ++ |
+ #' ard_continuous_ci(mtcars, variables = c(mpg, hp), method = "wilcox.test")+ |
+
| 16 | ++ |
+ #' ard_continuous_ci(mtcars, variables = mpg, by = am, method = "t.test")+ |
+
| 17 | ++ |
+ NULL+ |
+
| 18 | ++ | + + | +
| 19 | ++ |
+ #' @rdname ard_continuous_ci+ |
+
| 20 | ++ |
+ #' @export+ |
+
| 21 | ++ |
+ ard_continuous_ci <- function(data, ...) {
+ |
+
| 22 | +19x | +
+ check_not_missing(data)+ |
+
| 23 | +19x | +
+ UseMethod("ard_continuous_ci")
+ |
+
| 24 | ++ |
+ }+ |
+
| 25 | ++ | + + | +
| 26 | ++ |
+ #' @rdname ard_continuous_ci+ |
+
| 27 | ++ |
+ #' @export+ |
+
| 28 | ++ |
+ ard_continuous_ci.data.frame <- function(data, variables, by = dplyr::group_vars(data), conf.level = 0.95, method = c("t.test", "wilcox.test"), ...) {
+ |
+
| 29 | +3x | +
+ set_cli_abort_call()+ |
+
| 30 | ++ | + + | +
| 31 | ++ |
+ # check inputs ---------------------------------------------------------------+ |
+
| 32 | +3x | +
+ method <- arg_match(method)+ |
+
| 33 | +3x | +
+ check_not_missing(variables)+ |
+
| 34 | +3x | +
+ cards::process_selectors(data, by = {{ by }}, variables = {{ variables }})
+ |
+
| 35 | ++ | + + | +
| 36 | ++ |
+ # return empty ARD if no variables selected ----------------------------------+ |
+
| 37 | +3x | +
+ if (is_empty(variables)) {
+ |
+
| 38 | +! | +
+ return(dplyr::tibble() |> cards::as_card())+ |
+
| 39 | ++ |
+ }+ |
+
| 40 | ++ | + + | +
| 41 | ++ |
+ # calculate CIs --------------------------------------------------------------+ |
+
| 42 | +3x | +
+ switch(method,+ |
+
| 43 | +3x | +
+ "t.test" =+ |
+
| 44 | +3x | +
+ ard_stats_t_test_onesample(+ |
+
| 45 | +3x | +
+ data = data,+ |
+
| 46 | +3x | +
+ variables = {{ variables }},
+ |
+
| 47 | +3x | +
+ by = {{ by }},
+ |
+
| 48 | +3x | +
+ conf.level = conf.level,+ |
+
| 49 | ++ |
+ ...+ |
+
| 50 | ++ |
+ ),+ |
+
| 51 | +3x | +
+ "wilcox.test" =+ |
+
| 52 | +3x | +
+ ard_stats_wilcox_test_onesample(+ |
+
| 53 | +3x | +
+ data = data,+ |
+
| 54 | +3x | +
+ variables = {{ variables }},
+ |
+
| 55 | +3x | +
+ by = {{ by }},
+ |
+
| 56 | +3x | +
+ conf.level = conf.level,+ |
+
| 57 | +3x | +
+ conf.int = TRUE,+ |
+
| 58 | ++ |
+ ...+ |
+
| 59 | ++ |
+ )+ |
+
| 60 | ++ |
+ ) |>+ |
+
| 61 | +3x | +
+ dplyr::mutate(context = "continuous_ci")+ |
+
| 62 | ++ |
+ }+ |
+
| 1 | ++ |
+ #' ARD one-sample t-test+ |
+
| 2 | ++ |
+ #'+ |
+
| 3 | ++ |
+ #' @description+ |
+
| 4 | ++ |
+ #' Analysis results data for one-sample t-tests.+ |
+
| 5 | ++ |
+ #' Result may be stratified by including the `by` argument.+ |
+
| 6 | ++ |
+ #'+ |
+
| 7 | ++ |
+ #' @param data (`data.frame`)\cr+ |
+
| 8 | ++ |
+ #' a data frame. See below for details.+ |
+
| 9 | ++ |
+ #' @param variables ([`tidy-select`][dplyr::dplyr_tidy_select])\cr+ |
+
| 10 | ++ |
+ #' column names to be analyzed. Independent t-tests will be computed for+ |
+
| 11 | ++ |
+ #' each variable.+ |
+
| 12 | ++ |
+ #' @param by ([`tidy-select`][dplyr::dplyr_tidy_select])\cr+ |
+
| 13 | ++ |
+ #' optional column name to stratify results by.+ |
+
| 14 | ++ |
+ #' @inheritParams ard_stats_t_test+ |
+
| 15 | ++ |
+ #'+ |
+
| 16 | ++ |
+ #' @return ARD data frame+ |
+
| 17 | ++ |
+ #' @export+ |
+
| 18 | ++ |
+ #'+ |
+
| 19 | ++ |
+ #' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = "broom"))
+ |
+
| 20 | ++ |
+ #' cards::ADSL |>+ |
+
| 21 | ++ |
+ #' ard_stats_t_test_onesample(by = ARM, variables = AGE)+ |
+
| 22 | ++ |
+ ard_stats_t_test_onesample <- function(data, variables, by = dplyr::group_vars(data), conf.level = 0.95, ...) {
+ |
+
| 23 | +5x | +
+ set_cli_abort_call()+ |
+
| 24 | ++ | + + | +
| 25 | ++ |
+ # check installed packages ---------------------------------------------------+ |
+
| 26 | +5x | +
+ check_pkg_installed("broom")
+ |
+
| 27 | ++ | + + | +
| 28 | ++ |
+ # check/process inputs -------------------------------------------------------+ |
+
| 29 | +5x | +
+ check_not_missing(data)+ |
+
| 30 | +5x | +
+ check_not_missing(variables)+ |
+
| 31 | +5x | +
+ check_data_frame(data)+ |
+
| 32 | +5x | +
+ data <- dplyr::ungroup(data)+ |
+
| 33 | +5x | +
+ cards::process_selectors(data, by = {{ by }}, variables = {{ variables }})
+ |
+
| 34 | +5x | +
+ check_scalar_range(conf.level, range = c(0, 1))+ |
+
| 35 | ++ | + + | +
| 36 | ++ |
+ # return empty ARD if no variables selected ----------------------------------+ |
+
| 37 | +5x | +
+ if (is_empty(variables)) {
+ |
+
| 38 | +1x | +
+ return(dplyr::tibble() |> cards::as_card())+ |
+
| 39 | ++ |
+ }+ |
+
| 40 | ++ | + + | +
| 41 | +4x | +
+ cards::ard_continuous(+ |
+
| 42 | +4x | +
+ data = data,+ |
+
| 43 | +4x | +
+ variables = all_of(variables),+ |
+
| 44 | +4x | +
+ by = all_of(by),+ |
+
| 45 | +4x | +
+ statistic = all_of(variables) ~ list(t_test_onesample = \(x) stats::t.test(x = x, conf.level = conf.level, ...) |> broom::tidy())+ |
+
| 46 | ++ |
+ ) |>+ |
+
| 47 | +4x | +
+ cards::bind_ard(+ |
+
| 48 | +4x | +
+ cards::ard_continuous(+ |
+
| 49 | +4x | +
+ data = data,+ |
+
| 50 | +4x | +
+ variables = all_of(variables),+ |
+
| 51 | +4x | +
+ by = all_of(by),+ |
+
| 52 | +4x | +
+ statistic =+ |
+
| 53 | +4x | +
+ all_of(variables) ~+ |
+
| 54 | +4x | +
+ list(conf.level = \(x) {
+ |
+
| 55 | +8x | +
+ formals(asNamespace("stats")[["t.test.default"]])["mu"] |>
+ |
+
| 56 | +8x | +
+ utils::modifyList(list(conf.level = conf.level, ...))+ |
+
| 57 | ++ |
+ })+ |
+
| 58 | ++ |
+ )+ |
+
| 59 | ++ |
+ ) |>+ |
+
| 60 | +4x | +
+ dplyr::select(-"stat_label") |>+ |
+
| 61 | +4x | +
+ dplyr::left_join(+ |
+
| 62 | +4x | +
+ .df_ttest_stat_labels(by = NULL),+ |
+
| 63 | +4x | +
+ by = "stat_name"+ |
+
| 64 | ++ |
+ ) |>+ |
+
| 65 | +4x | +
+ dplyr::mutate(+ |
+
| 66 | +4x | +
+ stat_label = dplyr::coalesce(.data$stat_label, .data$stat_name),+ |
+
| 67 | +4x | +
+ context = "stats_t_test_onesample",+ |
+
| 68 | ++ |
+ ) |>+ |
+
| 69 | +4x | +
+ cards::as_card() |>+ |
+
| 70 | +4x | +
+ cards::tidy_ard_column_order() |>+ |
+
| 71 | +4x | +
+ cards::tidy_ard_row_order()+ |
+
| 72 | ++ |
+ }+ |
+
| 1 | ++ |
+ #' ARD Kruskal-Wallis Test+ |
+
| 2 | ++ |
+ #'+ |
+
| 3 | ++ |
+ #' @description+ |
+
| 4 | ++ |
+ #' Analysis results data for Kruskal-Wallis Rank Sum Test.+ |
+
| 5 | ++ |
+ #'+ |
+
| 6 | ++ |
+ #' Calculated with `kruskal.test(data[[variable]], data[[by]], ...)`+ |
+
| 7 | ++ |
+ #'+ |
+
| 8 | ++ |
+ #' @param data (`data.frame`)\cr+ |
+
| 9 | ++ |
+ #' a data frame.+ |
+
| 10 | ++ |
+ #' @param by ([`tidy-select`][dplyr::dplyr_tidy_select])\cr+ |
+
| 11 | ++ |
+ #' column name to compare by.+ |
+
| 12 | ++ |
+ #' @param variables ([`tidy-select`][dplyr::dplyr_tidy_select])\cr+ |
+
| 13 | ++ |
+ #' column names to be compared. Independent tests will+ |
+
| 14 | ++ |
+ #' be computed for each variable.+ |
+
| 15 | ++ |
+ #'+ |
+
| 16 | ++ |
+ #' @return ARD data frame+ |
+
| 17 | ++ |
+ #' @export+ |
+
| 18 | ++ |
+ #'+ |
+
| 19 | ++ |
+ #' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = "broom"))
+ |
+
| 20 | ++ |
+ #' cards::ADSL |>+ |
+
| 21 | ++ |
+ #' ard_stats_kruskal_test(by = "ARM", variables = "AGE")+ |
+
| 22 | ++ |
+ ard_stats_kruskal_test <- function(data, by, variables) {
+ |
+
| 23 | +5x | +
+ set_cli_abort_call()+ |
+
| 24 | ++ | + + | +
| 25 | ++ |
+ # check installed packages ---------------------------------------------------+ |
+
| 26 | +5x | +
+ check_pkg_installed("broom")
+ |
+
| 27 | ++ | + + | +
| 28 | ++ |
+ # check/process inputs -------------------------------------------------------+ |
+
| 29 | +5x | +
+ check_not_missing(data)+ |
+
| 30 | +5x | +
+ check_not_missing(variables)+ |
+
| 31 | +5x | +
+ check_not_missing(by)+ |
+
| 32 | +5x | +
+ check_data_frame(data)+ |
+
| 33 | +5x | +
+ cards::process_selectors(data, by = {{ by }}, variables = {{ variables }})
+ |
+
| 34 | +5x | +
+ check_scalar(by)+ |
+
| 35 | ++ | + + | +
| 36 | ++ |
+ # return empty ARD if no variables selected ----------------------------------+ |
+
| 37 | +5x | +
+ if (is_empty(variables)) {
+ |
+
| 38 | +! | +
+ return(dplyr::tibble() |> cards::as_card())+ |
+
| 39 | ++ |
+ }+ |
+
| 40 | ++ | + + | +
| 41 | ++ |
+ # build ARD ------------------------------------------------------------------+ |
+
| 42 | +5x | +
+ 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::kruskal.test(x = data[[variable]], g = data[[by]]) |>+ |
+
| 49 | +6x | +
+ broom::tidy()+ |
+
| 50 | ++ |
+ ),+ |
+
| 51 | +6x | +
+ tidy_result_names = c("statistic", "p.value", "parameter", "method"),
+ |
+
| 52 | +6x | +
+ lst_ard_columns = list(group1 = by, variable = variable, context = "stats_kruskal_test")+ |
+
| 53 | ++ |
+ ) |>+ |
+
| 54 | +6x | +
+ dplyr::mutate(+ |
+
| 55 | +6x | +
+ .after = "stat_name",+ |
+
| 56 | +6x | +
+ stat_label =+ |
+
| 57 | +6x | +
+ dplyr::case_when(+ |
+
| 58 | +6x | +
+ .data$stat_name %in% "statistic" ~ "Kruskal-Wallis chi-squared Statistic",+ |
+
| 59 | +6x | +
+ .data$stat_name %in% "p.value" ~ "p-value",+ |
+
| 60 | +6x | +
+ .data$stat_name %in% "parameter" ~ "Degrees of Freedom",+ |
+
| 61 | +6x | +
+ TRUE ~ .data$stat_name,+ |
+
| 62 | ++ |
+ )+ |
+
| 63 | ++ |
+ )+ |
+
| 64 | ++ |
+ }+ |
+
| 65 | ++ |
+ ) |>+ |
+
| 66 | +5x | +
+ dplyr::bind_rows() |>+ |
+
| 67 | +5x | +
+ cards::as_card()+ |
+
| 68 | ++ |
+ }+ |
+
| 1 | ++ |
+ #' ARD Survival Differences+ |
+
| 2 | ++ |
+ #'+ |
+
| 3 | ++ |
+ #' Calculate differences in the Kaplan-Meier estimator of survival using the+ |
+
| 4 | ++ |
+ #' results from [`survival::survfit()`].+ |
+
| 5 | ++ |
+ #'+ |
+
| 6 | ++ |
+ #' @param x (`survift`)\cr+ |
+
| 7 | ++ |
+ #' object of class `'survfit'` typically created with [`survival::survfit()`]+ |
+
| 8 | ++ |
+ #' @param conf.level (scalar `numeric`)\cr+ |
+
| 9 | ++ |
+ #' confidence level for confidence interval. Default is `0.95`.+ |
+
| 10 | ++ |
+ #' @inheritParams ard_survival_survfit+ |
+
| 11 | ++ |
+ #'+ |
+
| 12 | ++ |
+ #' @return an ARD data frame of class 'card'+ |
+
| 13 | ++ |
+ #' @export+ |
+
| 14 | ++ |
+ #'+ |
+
| 15 | ++ |
+ #' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = c("survival", "ggsurvfit")))
+ |
+
| 16 | ++ |
+ #' library(ggsurvfit)+ |
+
| 17 | ++ |
+ #' library(survival)+ |
+
| 18 | ++ |
+ #'+ |
+
| 19 | ++ |
+ #' survfit(Surv_CNSR() ~ TRTA, data = cards::ADTTE) |>+ |
+
| 20 | ++ |
+ #' ard_survival_survfit_diff(times = c(25, 50))+ |
+
| 21 | ++ |
+ ard_survival_survfit_diff <- function(x, times, conf.level = 0.95) {
+ |
+
| 22 | +5x | +
+ set_cli_abort_call()+ |
+
| 23 | ++ | + + | +
| 24 | ++ |
+ # check installed packages ---------------------------------------------------+ |
+
| 25 | +5x | +
+ check_pkg_installed(c("survival", "broom"))
+ |
+
| 26 | +5x | +
+ check_not_missing(x)+ |
+
| 27 | +5x | +
+ check_not_missing(times)+ |
+
| 28 | +5x | +
+ check_class(x, "survfit")+ |
+
| 29 | ++ | + + | +
| 30 | +5x | +
+ if (inherits(x, c("survfitms", "survfitcox"))) {
+ |
+
| 31 | +1x | +
+ cli::cli_abort(+ |
+
| 32 | +1x | +
+ "Argument {.arg x} cannot be class {.cls {c('survfitms', 'survfitcox')}}.",
+ |
+
| 33 | +1x | +
+ call = get_cli_abort_call()+ |
+
| 34 | ++ |
+ )+ |
+
| 35 | ++ |
+ }+ |
+
| 36 | +4x | +
+ check_scalar_range(conf.level, range = c(0, 1))+ |
+
| 37 | +4x | +
+ check_length(+ |
+
| 38 | +4x | +
+ as.list(x$call)[["formula"]] |> stats::as.formula() |> stats::terms() |> attr("term.labels"),
+ |
+
| 39 | +4x | +
+ length = 1L,+ |
+
| 40 | +4x | +
+ message = "The {.cls survfit} object passed in argument {.arg x} must be stratified by a single variable."
+ |
+
| 41 | ++ |
+ )+ |
+
| 42 | +3x | +
+ if (length(x$strata) < 2) {
+ |
+
| 43 | +1x | +
+ cli::cli_abort(+ |
+
| 44 | +1x | +
+ "The {.cls survfit} object's stratifying variable must have 2 or more levels.",
+ |
+
| 45 | +1x | +
+ call = get_cli_abort_call()+ |
+
| 46 | ++ |
+ )+ |
+
| 47 | ++ |
+ }+ |
+
| 48 | ++ | + + | +
| 49 | ++ |
+ # calculate the survival at the specified times+ |
+
| 50 | +2x | +
+ ard_survival_survfit <-+ |
+
| 51 | +2x | +
+ ard_survival_survfit(x = x, times = times) |>+ |
+
| 52 | +2x | +
+ dplyr::filter(.data$stat_name %in% c("estimate", "std.error")) |>
+ |
+
| 53 | +2x | +
+ dplyr::select(-c("stat_label", "context", "fmt_fn"))
+ |
+
| 54 | ++ | + + | +
| 55 | ++ |
+ # transform the survival ARD into a cards object with the survival difference+ |
+
| 56 | +2x | +
+ card <-+ |
+
| 57 | +2x | +
+ ard_survival_survfit %>%+ |
+
| 58 | +2x | +
+ {dplyr::left_join( # styler: off
+ |
+
| 59 | ++ |
+ # remove the first group from the data frame (this is our reference group)+ |
+
| 60 | +2x | +
+ dplyr::filter(., .by = cards::all_ard_groups(), dplyr::cur_group_id() > 1L) |>+ |
+
| 61 | +2x | +
+ dplyr::rename(stat1 = "stat"),+ |
+
| 62 | ++ |
+ # merge the reference group data+ |
+
| 63 | +2x | +
+ dplyr::filter(., .by = cards::all_ard_groups(), dplyr::cur_group_id() == 1L) |>+ |
+
| 64 | +2x | +
+ dplyr::select(stat0 = "stat", everything(), -c("group1_level", "error", "warning")),
+ |
+
| 65 | +2x | +
+ by = c("group1", "variable", "variable_level", "stat_name")
+ |
+
| 66 | +2x | +
+ )} |> # styler: off+ |
+
| 67 | ++ |
+ # reshape to put the stats that need to be combined on the same row+ |
+
| 68 | +2x | +
+ tidyr::pivot_wider(+ |
+
| 69 | +2x | +
+ id_cols = c("group1", "group1_level", "variable", "variable_level"),
+ |
+
| 70 | +2x | +
+ names_from = "stat_name",+ |
+
| 71 | +2x | +
+ values_from = c("stat0", "stat1"),
+ |
+
| 72 | +2x | +
+ values_fn = unlist+ |
+
| 73 | ++ |
+ ) |>+ |
+
| 74 | ++ |
+ # calcualte the primary statistics to return+ |
+
| 75 | +2x | +
+ dplyr::mutate(+ |
+
| 76 | ++ |
+ # reference level+ |
+
| 77 | +2x | +
+ reference_level = ard_survival_survfit[["group1_level"]][1],+ |
+
| 78 | ++ |
+ # short description of method+ |
+
| 79 | +2x | +
+ method = "Survival Difference (Z-test)",+ |
+
| 80 | ++ |
+ # survival difference+ |
+
| 81 | +2x | +
+ estimate = .data$stat0_estimate - .data$stat1_estimate,+ |
+
| 82 | ++ |
+ # survival difference standard error+ |
+
| 83 | +2x | +
+ std.error = sqrt(.data$stat0_std.error^2 + .data$stat1_std.error^2),+ |
+
| 84 | ++ |
+ # Z test statistic+ |
+
| 85 | +2x | +
+ statistic = .data$estimate / .data$std.error,+ |
+
| 86 | ++ |
+ # confidence limits of the survival difference+ |
+
| 87 | +2x | +
+ conf.low = .data$estimate - .data$std.error * stats::qnorm(1 - (1 - .env$conf.level) / 2),+ |
+
| 88 | +2x | +
+ conf.high = .data$estimate + .data$std.error * stats::qnorm(1 - (1 - .env$conf.level) / 2),+ |
+
| 89 | ++ |
+ # p-value for test where H0: no difference+ |
+
| 90 | +2x | +
+ p.value = 2 * (1 - stats::pnorm(abs(.data$statistic))),+ |
+
| 91 | +2x | +
+ across(c("reference_level", "estimate", "std.error", "statistic", "conf.low", "conf.high", "p.value", "method"), as.list)
+ |
+
| 92 | ++ |
+ ) |>+ |
+
| 93 | ++ |
+ # reshape into the cards structure+ |
+
| 94 | +2x | +
+ dplyr::select(-starts_with("stat0_"), -starts_with("stat1_")) |>
+ |
+
| 95 | +2x | +
+ tidyr::pivot_longer(+ |
+
| 96 | +2x | +
+ cols = -c(cards::all_ard_groups(), cards::all_ard_variables()),+ |
+
| 97 | +2x | +
+ names_to = "stat_name",+ |
+
| 98 | +2x | +
+ values_to = "stat"+ |
+
| 99 | ++ |
+ )+ |
+
| 100 | ++ | + + | +
| 101 | ++ |
+ # final prepping of the cards object -----------------------------------------+ |
+
| 102 | +2x | +
+ card |>+ |
+
| 103 | +2x | +
+ dplyr::mutate(+ |
+
| 104 | +2x | +
+ warning = ard_survival_survfit[["warning"]][1],+ |
+
| 105 | +2x | +
+ error = ard_survival_survfit[["error"]][1],+ |
+
| 106 | +2x | +
+ fmt_fn = list(1L),+ |
+
| 107 | +2x | +
+ stat_label =+ |
+
| 108 | +2x | +
+ dplyr::case_when(+ |
+
| 109 | +2x | +
+ .data$stat_name %in% "estimate" ~ "Survival Difference",+ |
+
| 110 | +2x | +
+ .data$stat_name %in% "std.error" ~ "Survival Difference Standard Error",+ |
+
| 111 | +2x | +
+ .data$stat_name %in% "conf.low" ~ "CI Lower Bound",+ |
+
| 112 | +2x | +
+ .data$stat_name %in% "conf.high" ~ "CI Upper Bound",+ |
+
| 113 | +2x | +
+ .data$stat_name %in% "statistic" ~ "z statistic",+ |
+
| 114 | +2x | +
+ .data$stat_name %in% "p.value" ~ "p-value",+ |
+
| 115 | +2x | +
+ .default = .data$stat_name+ |
+
| 116 | ++ |
+ ),+ |
+
| 117 | +2x | +
+ context = "survival_survfit_diff",+ |
+
| 118 | ++ |
+ ) |>+ |
+
| 119 | +2x | +
+ cards::as_card() |>+ |
+
| 120 | +2x | +
+ cards::tidy_ard_column_order()+ |
+
| 121 | ++ |
+ }+ |
+
| 1 | ++ |
+ #' ARD 2-sample proportion test+ |
+ |
| 2 | ++ |
+ #'+ |
+ |
| 3 | ++ |
+ #' @description+ |
+ |
| 4 | ++ |
+ #' Analysis results data for a 2-sample test or proportions using [`stats::prop.test()`].+ |
+ |
| 5 | ++ |
+ #'+ |
+ |
| 6 | ++ |
+ #' @param data (`data.frame`)\cr+ |
+ |
| 7 | ++ |
+ #' a data frame.+ |
+ |
| 8 | ++ |
+ #' @param by ([`tidy-select`][dplyr::dplyr_tidy_select])\cr+ |
+ |
| 9 | ++ |
+ #' column name to compare by+ |
+ |
| 10 | ++ |
+ #' @param variables ([`tidy-select`][dplyr::dplyr_tidy_select])\cr+ |
+ |
| 11 | ++ |
+ #' column names to be compared. Must be a binary column coded as `TRUE`/`FALSE`+ |
+ |
| 12 | ++ |
+ #' or `1`/`0`. Independent tests will be computed for each variable.+ |
+ |
| 13 | ++ |
+ #' @param conf.level (scalar `numeric`)\cr+ |
+ |
| 14 | ++ |
+ #' confidence level for confidence interval. Default is `0.95`.+ |
+ |
| 15 | ++ |
+ #' @param ... arguments passed to `prop.test(...)`+ |
+ |
| 16 | ++ |
+ #'+ |
+ |
| 17 | ++ |
+ #' @return ARD data frame+ |
+ |
| 18 | ++ |
+ #' @export+ |
+ |
| 19 | ++ |
+ #'+ |
+ |
| 20 | ++ |
+ #' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = "broom"))
+ |
+ |
| 21 | ++ |
+ #' mtcars |>+ |
+ |
| 22 | ++ |
+ #' ard_stats_prop_test(by = vs, variables = am)+ |
+ |
| 23 | ++ |
+ ard_stats_prop_test <- function(data, by, variables, conf.level = 0.95, ...) {
+ |
+ |
| 24 | +6x | +
+ set_cli_abort_call()+ |
+ |
| 25 | ++ | + + | +|
| 26 | ++ |
+ # check installed packages ---------------------------------------------------+ |
+ |
| 27 | +6x | +
+ check_pkg_installed(pkg = "broom")+ |
+ |
| 28 | ++ | + + | +|
| 29 | ++ |
+ # check inputs ---------------------------------------------------------------+ |
+ |
| 30 | +6x | +
+ check_not_missing(data)+ |
+ |
| 31 | +6x | +
+ check_not_missing(variables)+ |
+ |
| 32 | +6x | +
+ check_not_missing(by)+ |
+ |
| 33 | +6x | +
+ check_data_frame(data)+ |
+ |
| 34 | +6x | +
+ check_range(conf.level, range = c(0, 1))+ |
+ |
| 35 | ++ | + + | +|
| 36 | ++ |
+ # process inputs -------------------------------------------------------------+ |
+ |
| 37 | +6x | +
+ cards::process_selectors(data, by = {{ by }}, variables = {{ variables }})
+ |
+ |
| 38 | +6x | +
+ check_scalar(by)+ |
+ |
| 39 | +6x | +
+ data <- data[c(by, variables)] |> dplyr::ungroup() |> tidyr::drop_na() # styler: off+ |
+ |
| 40 | ++ | + + | +|
| 41 | ++ |
+ # return empty ARD if no variables selected ----------------------------------+ |
+ |
| 42 | +6x | +
+ if (is_empty(variables)) {
+ |
+ |
| 43 | +! | +
+ return(dplyr::tibble() |> cards::as_card())+ |
+ |
| 44 | ++ |
+ }+ |
+ |
| 45 | ++ | + + | +|
| 46 | ++ |
+ # build ARD ------------------------------------------------------------------+ |
+ |
| 47 | +6x | +
+ lapply(+ |
+ |
| 48 | +6x | +
+ variables,+ |
+ |
| 49 | +6x | +
+ function(variable) {
+ |
+ |
| 50 | +7x | +
+ .format_proptest_results(+ |
+ |
| 51 | +7x | +
+ by = by,+ |
+ |
| 52 | +7x | +
+ variable = variable,+ |
+ |
| 53 | +7x | +
+ lst_tidy =+ |
+ |
| 54 | +7x | +
+ cards::eval_capture_conditions({
+ |
+ |
| 55 | +7x | +
+ check_binary(data[[variable]], arg_name = "variable")+ |
+ |
| 56 | ++ | + + | +|
| 57 | +4x | +
+ data_counts <-+ |
+ |
| 58 | +4x | +
+ dplyr::arrange(data, .data[[by]]) |>+ |
+ |
| 59 | +4x | +
+ dplyr::summarise(+ |
+ |
| 60 | +4x | +
+ .by = all_of(by),+ |
+ |
| 61 | +4x | +
+ x = sum(.data[[variable]]),+ |
+ |
| 62 | +4x | +
+ n = length(.data[[variable]])+ |
+ |
| 63 | ++ |
+ )+ |
+ |
| 64 | ++ | + + | +|
| 65 | +4x | +
+ if (nrow(data_counts) != 2) {
+ |
+ |
| 66 | +1x | +
+ cli::cli_abort(+ |
+ |
| 67 | +1x | +
+ c(+ |
+ |
| 68 | +1x | +
+ "The {.arg by} column must have exactly 2 levels.",
+ |
+ |
| 69 | +1x | +
+ "The levels are {.val {data_counts[[by]]}}"
+ |
+ |
| 70 | ++ |
+ ),+ |
+ |
| 71 | +1x | +
+ call = get_cli_abort_call()+ |
+ |
| 72 | ++ |
+ )+ |
+ |
| 73 | ++ |
+ }+ |
+ |
| 74 | ++ | + + | +|
| 75 | +3x | +
+ stats::prop.test(+ |
+ |
| 76 | +3x | +
+ x = data_counts[["x"]],+ |
+ |
| 77 | +3x | +
+ n = data_counts[["n"]],+ |
+ |
| 78 | +3x | +
+ conf.level = conf.level,+ |
+ |
| 79 | ++ |
+ ...+ |
+ |
| 80 | ++ |
+ ) |>+ |
+ |
| 81 | +3x | +
+ broom::tidy() |>+ |
+ |
| 82 | ++ |
+ # add central estimate for difference+ |
+ |
| 83 | +3x | +
+ dplyr::mutate(estimate = .data$estimate1 - .data$estimate2, .before = 1L)+ |
+ |
| 84 | ++ |
+ }),+ |
+ |
| 85 | ++ |
+ ...+ |
+ |
| 86 | ++ |
+ )+ |
+ |
| 87 | ++ |
+ }+ |
+ |
| 88 | ++ |
+ ) |>+ |
+ |
| 89 | +6x | +
+ dplyr::bind_rows()+ |
+ |
| 90 | ++ |
+ }+ |
+ |
| 91 | ++ | + + | +|
| 92 | ++ | + + | +|
| 93 | ++ |
+ #' Convert prop.test to ARD+ |
+ |
| 94 | ++ |
+ #'+ |
+ |
| 95 | ++ |
+ #' @inheritParams cards::tidy_as_ard+ |
+ |
| 96 | ++ |
+ #' @param by (`string`)\cr by column name+ |
+ |
| 97 | ++ |
+ #' @param variable (`string`)\cr variable column name+ |
+ |
| 98 | ++ |
+ #' @param ... passed to `prop.test(...)`+ |
+ |
| 99 | ++ |
+ #'+ |
+ |
| 100 | ++ |
+ #' @return ARD data frame+ |
+ |
| 101 | ++ |
+ #' @keywords internal+ |
+ |
| 102 | ++ |
+ .format_proptest_results <- function(by, variable, lst_tidy, ...) {
+ |
+ |
| 103 | ++ |
+ # build ARD ------------------------------------------------------------------+ |
+ |
| 104 | +7x | +
+ ret <-+ |
+ |
| 105 | +7x | +
+ cards::tidy_as_ard(+ |
+ |
| 106 | +7x | +
+ lst_tidy = lst_tidy,+ |
+ |
| 107 | +7x | +
+ tidy_result_names = c(+ |
+ |
| 108 | +7x | +
+ "estimate", "estimate1", "estimate2", "statistic",+ |
+ |
| 109 | +7x | +
+ "p.value", "parameter", "conf.low", "conf.high",+ |
+ |
| 110 | +7x |
"method", "alternative" |
|
| 90 | +111 | ++ |
+ ),+ |
+
| 112 | +7x | +
+ fun_args_to_record = c("p", "conf.level", "correct"),
+ |
+ |
| 113 | +7x | +
+ formals = formals(stats::prop.test),+ |
+ |
| 114 | +7x | +
+ passed_args = dots_list(...),+ |
+ |
| 115 | +7x | +
+ lst_ard_columns = list(group1 = by, variable = variable, context = "stats_prop_test")+ |
+ |
| 116 | ++ |
+ )+ |
+ |
| 117 | ++ | + + | +|
| 118 | ++ |
+ # add the stat label ---------------------------------------------------------+ |
+ |
| 119 | +7x | +
+ ret |>+ |
+ |
| 120 | +7x | +
+ dplyr::left_join(+ |
+ |
| 121 | +7x | +
+ .df_proptest_stat_labels(),+ |
+ |
| 122 | +7x | +
+ by = "stat_name"+ |
+ |
| 123 | ++ |
+ ) |>+ |
+ |
| 124 | +7x | +
+ dplyr::mutate(stat_label = dplyr::coalesce(.data$stat_label, .data$stat_name)) |>+ |
+ |
| 125 | +7x | +
+ cards::as_card() |>+ |
+ |
| 126 | +7x | +
+ cards::tidy_ard_column_order()+ |
+ |
| 127 | ++ |
+ }+ |
+ |
| 128 | ++ | + + | +|
| 129 | ++ |
+ .df_proptest_stat_labels <- function() {
+ |
+ |
| 130 | +7x | +
+ dplyr::tribble(+ |
+ |
| 131 | +7x | +
+ ~stat_name, ~stat_label,+ |
+ |
| 132 | +7x | +
+ "estimate1", "Group 1 Rate",+ |
+ |
| 133 | +7x | +
+ "estimate2", "Group 2 Rate",+ |
+ |
| 134 | +7x | +
+ "estimate", "Rate Difference",+ |
+ |
| 135 | +7x | +
+ "p.value", "p-value",+ |
+ |
| 136 | +7x | +
+ "statistic", "X-squared Statistic",+ |
+ |
| 137 | +7x | +
+ "parameter", "Degrees of Freedom",+ |
+ |
| 138 | +7x | +
+ "conf.low", "CI Lower Bound",+ |
+ |
| 139 | +7x | +
+ "conf.high", "CI Upper Bound",+ |
+ |
| 140 | +7x | +
+ "conf.level", "CI Confidence Level",+ |
+ |
| 141 | +7x | +
+ "correct", "Yates' continuity correction",+ |
+ |
| 142 | ++ |
+ )+ |
+ |
| 143 | ++ |
+ }+ |
+
| 1 | ++ |
+ #' ARD Survey t-test+ |
+ ||
| 2 | ++ |
+ #'+ |
+ ||
| 3 | ++ |
+ #' @description+ |
+ ||
| 4 | ++ |
+ #' Analysis results data for survey t-test using [`survey::svyttest()`].+ |
+ ||
| 5 | ++ |
+ #'+ |
+ ||
| 6 | ++ |
+ #' @param data (`survey.design`)\cr+ |
+ ||
| 7 | ++ |
+ #' a survey design object often created with [`survey::svydesign()`]+ |
+ ||
| 8 | ++ |
+ #' @param by ([`tidy-select`][dplyr::dplyr_tidy_select])\cr+ |
+ ||
| 9 | ++ |
+ #' 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 run for each variable.+ |
+ ||
| 12 | ++ |
+ #' @param conf.level (`double`)\cr+ |
+ ||
| 13 | ++ |
+ #' 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 | ++ |
+ #'+ |
+ ||
| 17 | ++ |
+ #' @return ARD data frame+ |
+ ||
| 18 | ++ |
+ #' @export+ |
+ ||
| 19 | ++ |
+ #'+ |
+ ||
| 20 | ++ |
+ #' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = c("survey", "broom")))
+ |
+ ||
| 21 | ++ |
+ #' data(api, package = "survey")+ |
+ ||
| 22 | ++ |
+ #' dclus2 <- survey::svydesign(id = ~ dnum + snum, fpc = ~ fpc1 + fpc2, data = apiclus2)+ |
+ ||
| 23 | ++ |
+ #'+ |
+ ||
| 24 | ++ |
+ #' 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 | +5x | +
+ set_cli_abort_call()+ |
+ ||
| 27 | ++ | + + | +||
| 28 | ++ |
+ # check installed packages ---------------------------------------------------+ |
+ ||
| 29 | +5x | +
+ check_pkg_installed(c("survey", "broom"))
+ |
+ ||
| 30 | ++ | + + | +||
| 31 | ++ |
+ # check/process inputs -------------------------------------------------------+ |
+ ||
| 32 | +5x | +
+ check_not_missing(data)+ |
+ ||
| 33 | +5x | +
+ check_not_missing(variables)+ |
+ ||
| 34 | +5x | +
+ check_not_missing(by)+ |
+ ||
| 35 | +5x | +
+ check_range(conf.level, range = c(0, 1))+ |
+ ||
| 36 | +5x | +
+ check_class(data, cls = "survey.design")+ |
+ ||
| 37 | +5x | +
+ cards::process_selectors(data[["variables"]], by = {{ by }}, variables = {{ variables }})
+ |
+ ||
| 38 | +5x | +
+ check_scalar(by)+ |
+ ||
| 39 | ++ | + + | +||
| 40 | ++ |
+ # return empty ARD if no variables selected ----------------------------------+ |
+ ||
| 41 | +5x | +
+ if (is_empty(variables)) {
+ |
+ ||
| 42 | +! | +
+ return(dplyr::tibble() |> cards::as_card())+ |
+ ||
| 43 | ++ |
+ }+ |
+ ||
| 44 | ++ | + + | +||
| 45 |
- ),+ # build ARD ------------------------------------------------------------------ |
|||
| 91 | -3x | +46 | +5x |
- fun_args_to_record = c("p", "conf.level", "correct"),
+ lapply( |
| 92 | -3x | +47 | +5x |
- formals = formals(stats::prop.test),+ variables, |
| 93 | -3x | +48 | +5x |
- passed_args = dots_list(...),+ function(variable) {
|
| 94 | -3x | +49 | +6x |
- lst_ard_columns = list(group1 = by, variable = variable, context = "proptest")+ .format_svyttest_results( |
| 95 | -+ | |||
| 50 | +6x |
- )+ by = by,+ |
+ ||
| 51 | +6x | +
+ variable = variable,+ |
+ ||
| 52 | +6x | +
+ lst_tidy =+ |
+ ||
| 53 | +6x | +
+ cards::eval_capture_conditions(+ |
+ ||
| 54 | +6x | +
+ survey::svyttest(reformulate2(termlabels = by, response = variable), design = data, ...) %>% |
||
| 96 | +55 |
-
+ # a slightly enhanced tidier that allows us to specify the conf.level |
||
| 97 | +56 |
- # add the stat label ---------------------------------------------------------+ {
|
||
| 98 | -3x | +57 | +5x |
- ret |>+ dplyr::bind_cols( |
| 99 | -3x | +58 | +5x |
- dplyr::left_join(+ broom::tidy(.) |> dplyr::select(-c("conf.low", "conf.high")),
|
| 100 | -3x | +59 | +5x |
- .df_proptest_stat_labels(),+ dplyr::tibble(!!!stats::confint(., level = conf.level) |> set_names(c("conf.low", "conf.high"))) |>
|
| 101 | -3x | +60 | +5x |
- by = "stat_name"+ dplyr::mutate(conf.level = conf.level) |
| 102 | +61 |
- ) |>+ ) |
||
| 103 | -3x | +|||
| 62 | +
- dplyr::mutate(stat_label = dplyr::coalesce(.data$stat_label, .data$stat_name)) |>+ }+ |
+ |||
| 63 | ++ |
+ ),+ |
+ ||
| 64 | ++ |
+ ...+ |
+ ||
| 65 | ++ |
+ )+ |
+ ||
| 66 | ++ |
+ }+ |
+ ||
| 67 | ++ |
+ ) |> |
||
| 104 | -3x | +68 | +5x |
- cards::tidy_ard_column_order()+ dplyr::bind_rows() |
| 105 | +69 |
} |
||
| 106 | +70 | |||
| 107 | +71 |
- .df_proptest_stat_labels <- function() {
+ .format_svyttest_results <- function(by, variable, lst_tidy, ...) {
+ |
+ ||
| 72 | ++ |
+ # build ARD ------------------------------------------------------------------ |
||
| 108 | -3x | +73 | +6x |
- dplyr::tribble(+ ret <- |
| 109 | -3x | +74 | +6x |
- ~stat_name, ~stat_label,+ cards::tidy_as_ard( |
| 110 | -3x | +75 | +6x |
- "estimate1", "Group 1 Rate",+ lst_tidy = lst_tidy, |
| 111 | -3x | +76 | +6x |
- "estimate2", "Group 2 Rate",+ tidy_result_names = c( |
| 112 | -3x | +77 | +6x |
- "estimate", "Rate Difference",+ "estimate", "statistic", |
| 113 | -3x | +78 | +6x |
- "p.value", "p-value",+ "p.value", "parameter", |
| 114 | -3x | +79 | +6x |
- "statistic", "X-squared Statistic",+ "conf.low", "conf.high",+ |
+
| 80 | +6x | +
+ "conf.level", "method", "alternative"+ |
+ ||
| 81 | ++ |
+ ),+ |
+ ||
| 82 | +6x | +
+ passed_args = dots_list(...),+ |
+ ||
| 83 | +6x | +
+ lst_ard_columns = list(group1 = by, variable = variable, context = "survey_svyttest")+ |
+ ||
| 84 | ++ |
+ )+ |
+ ||
| 85 | ++ | + + | +||
| 86 | ++ |
+ # add the stat label ---------------------------------------------------------+ |
+ ||
| 87 | +6x | +
+ ret |>+ |
+ ||
| 88 | +6x | +
+ dplyr::left_join( |
||
| 115 | -3x | +89 | +6x |
- "parameter", "Degrees of Freedom",+ .df_ttest_stat_labels(), |
| 116 | -3x | +90 | +6x |
- "conf.low", "CI Lower Bound",+ by = "stat_name" |
| 117 | -3x | +|||
| 91 | +
- "conf.high", "CI Upper Bound",+ ) |> |
|||
| 118 | -3x | +92 | +6x |
- "conf.level", "CI Confidence Level",+ dplyr::mutate(stat_label = dplyr::coalesce(.data$stat_label, .data$stat_name)) |> |
| 119 | -3x | +93 | +6x |
- "correct", "Yates' continuity correction",+ cards::as_card() |> |
| 120 | -+ | |||
| 94 | +6x |
- )+ cards::tidy_ard_column_order() |
||
| 121 | +95 |
}@@ -9722,14 +39288,14 @@ cardx coverage - 95.63% |
| 1 |
- #' ARD Kruskal-Wallis Test+ #' ARD Proportion Confidence Intervals |
||
| 3 |
- #' @description+ #' `r lifecycle::badge('experimental')`\cr
|
||
| 4 |
- #' Analysis results data for Kruskal-Wallis Rank Sum Test.+ #' Calculate confidence intervals for proportions. |
||
| 6 |
- #' Calculated with `kruskal.test(data[[variable]], data[[by]], ...)`+ #' @inheritParams cards::ard_categorical |
||
| 7 |
- #'+ #' @param variables ([`tidy-select`][dplyr::dplyr_tidy_select])\cr |
||
| 8 |
- #' @param data (`data.frame`)\cr+ #' columns to include in summaries. Columns must be class `<logical>` |
||
| 9 |
- #' a data frame.+ #' or `<numeric>` values coded as `c(0, 1)`. |
||
| 11 |
- #' column name to compare by+ #' columns to stratify calculations by |
||
| 12 |
- #' @param variable ([`tidy-select`][dplyr::dplyr_tidy_select])\cr+ #' @param conf.level (`numeric`)\cr |
||
| 13 |
- #' column name to be compared+ #' a scalar in `(0, 1)` indicating the confidence level. |
||
| 14 |
- #'+ #' Default is `0.95` |
||
| 15 |
- #' @return ARD data frame+ #' @param method (`string`)\cr |
||
| 16 |
- #' @export+ #' string indicating the type of confidence interval to calculate. |
||
| 17 |
- #'+ #' Must be one of `r formals(ard_categorical_ci)[["method"]] |> eval() |> shQuote("sh")`.
|
||
| 18 |
- #' @examplesIf cards::is_pkg_installed("broom", reference_pkg = "cardx")
+ #' See `?proportion_ci` for details. |
||
| 19 |
- #' cards::ADSL |>+ #' @param strata,weights,max.iterations arguments passed to `proportion_ci_strat_wilson()`, |
||
| 20 |
- #' ard_kruskaltest(by = "ARM", variable = "AGE")+ #' when `method='strat_wilson'` |
||
| 21 |
- ard_kruskaltest <- function(data, by, variable) {
+ #' @param value ([`formula-list-selector`][cards::syntax])\cr |
||
| 22 |
- # check installed packages ---------------------------------------------------+ #' function will calculate the CIs for all levels of the variables specified. |
||
| 23 | -2x | +
- cards::check_pkg_installed("broom", reference_pkg = "cardx")
+ #' Use this argument to instead request only a single level by summarized. |
|
| 24 |
-
+ #' Default is `list(where(is_binary) ~ 1L, where(is.logical) ~ TRUE)`, where |
||
| 25 |
- # check/process inputs -------------------------------------------------------- |
- ||
| 26 | -2x | -
- check_not_missing(data)- |
- |
| 27 | -2x | -
- check_not_missing(variable)- |
- |
| 28 | -2x | -
- check_not_missing(by)- |
- |
| 29 | -2x | -
- check_data_frame(data)- |
- |
| 30 | -2x | -
- cards::process_selectors(data, by = {{ by }}, variable = {{ variable }})
- |
- |
| 31 | -2x | -
- check_scalar(by)- |
- |
| 32 | -2x | -
- check_scalar(variable)+ #' columns coded as `0`/`1` and `TRUE`/`FALSE` will summarize the `1` and `TRUE` levels. |
|
| 33 | +26 |
-
+ #' |
|
| 34 | +27 |
- # build ARD ------------------------------------------------------------------- |
- |
| 35 | -2x | -
- cards::tidy_as_ard(- |
- |
| 36 | -2x | -
- lst_tidy =- |
- |
| 37 | -2x | -
- cards::eval_capture_conditions(- |
- |
| 38 | -2x | -
- stats::kruskal.test(x = data[[variable]], g = data[[by]]) |>- |
- |
| 39 | -2x | -
- broom::tidy()+ #' @return an ARD data frame |
|
| 40 | +28 |
- ),- |
- |
| 41 | -2x | -
- tidy_result_names = c("statistic", "p.value", "parameter", "method"),
- |
- |
| 42 | -2x | -
- lst_ard_columns = list(group1 = by, variable = variable, context = "kruskaltest")+ #' @name ard_categorical_ci |
|
| 43 | +29 |
- ) |>- |
- |
| 44 | -2x | -
- dplyr::mutate(- |
- |
| 45 | -2x | -
- .after = "stat_name",- |
- |
| 46 | -2x | -
- stat_label =- |
- |
| 47 | -2x | -
- dplyr::case_when(- |
- |
| 48 | -2x | -
- .data$stat_name %in% "statistic" ~ "Kruskal-Wallis chi-squared Statistic",- |
- |
| 49 | -2x | -
- .data$stat_name %in% "p.value" ~ "p-value",- |
- |
| 50 | -2x | -
- .data$stat_name %in% "parameter" ~ "Degrees of Freedom",- |
- |
| 51 | -2x | -
- TRUE ~ .data$stat_name,+ #' |
|
| 52 | +30 |
- )+ #' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = "broom"))
|
|
| 53 | +31 |
- )+ #' # compute CI for binary variables |
|
| 54 | +32 |
- }+ #' ard_categorical_ci(mtcars, variables = c(vs, am), method = "wilson") |
| 1 | +33 |
- #' ARD t-test+ #' |
||
| 2 | +34 |
- #'+ #' # compute CIs for each level of a categorical variable |
||
| 3 | +35 |
- #' @description+ #' ard_categorical_ci(mtcars, variables = cyl, method = "jeffreys") |
||
| 4 | +36 |
- #' Analysis results data for paired and non-paired t-tests.+ NULL |
||
| 5 | +37 |
- #'+ |
||
| 6 | +38 |
- #' @param data (`data.frame`)\cr+ #' @rdname ard_categorical_ci |
||
| 7 | +39 |
- #' a data frame. See below for details.+ #' @export |
||
| 8 | +40 |
- #' @param by ([`tidy-select`][dplyr::dplyr_tidy_select])\cr+ ard_categorical_ci <- function(data, ...) {
|
||
| 9 | -+ | |||
| 41 | +25x |
- #' column name to compare by+ check_not_missing(data) |
||
| 10 | -+ | |||
| 42 | +25x |
- #' @param variable ([`tidy-select`][dplyr::dplyr_tidy_select])\cr+ UseMethod("ard_categorical_ci")
|
||
| 11 | +43 |
- #' column name to be compared+ } |
||
| 12 | +44 |
- #' @param id ([`tidy-select`][dplyr::dplyr_tidy_select])\cr+ |
||
| 13 | +45 |
- #' column name of the subject or participant ID+ #' @rdname ard_categorical_ci |
||
| 14 | +46 |
- #' @param ... arguments passed to `t.test(...)`+ #' @export |
||
| 15 | +47 |
- #'+ ard_categorical_ci.data.frame <- function(data, |
||
| 16 | +48 |
- #' @return ARD data frame+ variables, |
||
| 17 | +49 |
- #' @name ard_ttest+ by = dplyr::group_vars(data), |
||
| 18 | +50 |
- #'+ method = c( |
||
| 19 | +51 |
- #' @details+ "waldcc", "wald", "clopper-pearson", |
||
| 20 | +52 |
- #' For the `ard_ttest()` function, the data is expected to be one row per subject.+ "wilson", "wilsoncc", |
||
| 21 | +53 |
- #' The data is passed as `t.test(data[[variable]] ~ data[[by]], paired = FALSE, ...)`.+ "strat_wilson", "strat_wilsoncc", |
||
| 22 | +54 |
- #'+ "agresti-coull", "jeffreys" |
||
| 23 | +55 |
- #' For the `ard_paired_ttest()` function, the data is expected to be one row+ ), |
||
| 24 | +56 |
- #' per subject per by level. Before the t-test is calculated, the data are+ conf.level = 0.95, |
||
| 25 | +57 |
- #' reshaped to a wide format to be one row per subject.+ value = list(where(is_binary) ~ 1L, where(is.logical) ~ TRUE), |
||
| 26 | +58 |
- #' The data are then passed as+ strata = NULL, |
||
| 27 | +59 |
- #' `t.test(x = data_wide[[<by level 1>]], y = data_wide[[<by level 2>]], paired = TRUE, ...)`.+ weights = NULL, |
||
| 28 | +60 |
- #'+ max.iterations = 10, |
||
| 29 | +61 |
- #' @examplesIf cards::is_pkg_installed("broom", reference_pkg = "cardx")
+ ...) {
|
||
| 30 | -+ | |||
| 62 | +12x |
- #' cards::ADSL |>+ set_cli_abort_call() |
||
| 31 | -+ | |||
| 63 | +12x |
- #' dplyr::filter(ARM %in% c("Placebo", "Xanomeline High Dose")) |>
+ check_dots_empty() |
||
| 32 | +64 |
- #' ard_ttest(by = ARM, variable = AGE)+ |
||
| 33 | +65 |
- #'+ # check installed packages --------------------------------------------------- |
||
| 34 | -+ | |||
| 66 | +12x |
- #' # constructing a paired data set,+ check_pkg_installed(pkg = "broom") |
||
| 35 | +67 |
- #' # where patients receive both treatments+ |
||
| 36 | +68 |
- #' cards::ADSL[c("ARM", "AGE")] |>
+ # process inputs ------------------------------------------------------------- |
||
| 37 | -+ | |||
| 69 | +12x |
- #' dplyr::filter(ARM %in% c("Placebo", "Xanomeline High Dose")) |>
+ cards::process_selectors(data, variables = {{ variables }}, by = {{ by }})
|
||
| 38 | -+ | |||
| 70 | +12x |
- #' dplyr::mutate(.by = ARM, USUBJID = dplyr::row_number()) |>+ method <- arg_match(method) |
||
| 39 | -+ | |||
| 71 | +12x |
- #' dplyr::arrange(USUBJID, ARM) |>+ if (method %in% c("strat_wilson", "strat_wilsoncc")) {
|
||
| 40 | -+ | |||
| 72 | +2x |
- #' ard_paired_ttest(by = ARM, variable = AGE, id = USUBJID)+ cards::process_selectors(data, strata = strata) |
||
| 41 | -+ | |||
| 73 | +2x |
- NULL+ check_scalar(strata) |
||
| 42 | +74 |
-
+ } |
||
| 43 | -+ | |||
| 75 | +12x |
- #' @rdname ard_ttest+ cards::process_formula_selectors( |
||
| 44 | -+ | |||
| 76 | +12x |
- #' @export+ data[variables], |
||
| 45 | -+ | |||
| 77 | +12x |
- ard_ttest <- function(data, by, variable, ...) {
+ value = value |
||
| 46 | +78 |
- # check installed packages ---------------------------------------------------+ ) |
||
| 47 | -2x | +79 | +12x |
- cards::check_pkg_installed("broom", reference_pkg = "cardx")
+ check_not_missing(variables) |
| 48 | +80 | |||
| 49 | +81 |
- # check/process inputs -------------------------------------------------------+ # return empty ARD if no variables selected ---------------------------------- |
||
| 50 | -2x | +82 | +12x |
- check_not_missing(data)+ if (is_empty(variables)) {
|
| 51 | -2x | +|||
| 83 | +! |
- check_not_missing(variable)+ return(dplyr::tibble() |> cards::as_card()) |
||
| 52 | -2x | +|||
| 84 | +
- check_not_missing(by)+ } |
|||
| 53 | -2x | +|||
| 85 | +
- check_data_frame(data)+ |
|||
| 54 | -2x | +|||
| 86 | +
- data <- dplyr::ungroup(data)+ # calculate confidence intervals --------------------------------------------- |
|||
| 55 | -2x | +87 | +12x |
- cards::process_selectors(data, by = {{ by }}, variable = {{ variable }})
+ map( |
| 56 | -2x | +88 | +12x |
- check_scalar(by)+ variables, |
| 57 | -2x | +89 | +12x |
- check_scalar(variable)+ function(variable) {
|
| 58 | -+ | |||
| 90 | +20x |
-
+ levels <- .unique_values_sort(data, variable = variable, value = value[[variable]]) |
||
| 59 | +91 |
- # build ARD ------------------------------------------------------------------+ |
||
| 60 | -2x | +92 | +20x |
- .format_ttest_results(+ .calculate_ard_proportion( |
| 61 | -2x | +93 | +20x |
- by = by,+ data = .as_dummy(data, variable = variable, levels = levels, by = by, strata = strata), |
| 62 | -2x | +94 | +20x |
- variable = variable,+ variables = c(everything(), -all_of(c(by, strata))), |
| 63 | -2x | +95 | +20x |
- lst_tidy =+ by = all_of(by), |
| 64 | -2x | +96 | +20x |
- cards::eval_capture_conditions(+ method = method, |
| 65 | -2x | +97 | +20x |
- stats::t.test(data[[variable]] ~ data[[by]], ...) |>+ conf.level = conf.level, |
| 66 | -2x | +98 | +20x |
- broom::tidy()+ strata = strata, |
| 67 | -+ | |||
| 99 | +20x |
- ),+ weights = weights, |
||
| 68 | -2x | +100 | +20x |
- paired = FALSE,+ max.iterations = max.iterations |
| 69 | +101 |
- ...+ ) %>% |
||
| 70 | +102 |
- )+ # merge in the variable levels |
||
| 71 | -+ | |||
| 103 | +20x |
- }+ dplyr::left_join( |
||
| 72 | -+ | |||
| 104 | +20x |
-
+ dplyr::select(., "variable") |> |
||
| 73 | -+ | |||
| 105 | +20x |
- #' @rdname ard_ttest+ dplyr::distinct() |> |
||
| 74 | -+ | |||
| 106 | +20x |
- #' @export+ dplyr::mutate(variable_level = as.list(.env$levels)),+ |
+ ||
| 107 | +20x | +
+ by = "variable" |
||
| 75 | +108 |
- ard_paired_ttest <- function(data, by, variable, id, ...) {
+ ) |> |
||
| 76 | +109 |
- # check installed packages ---------------------------------------------------+ # rename variable column |
||
| 77 | -2x | +110 | +20x | +
+ dplyr::mutate(variable = .env$variable) |>+ |
+
| 111 | +20x |
- cards::check_pkg_installed("broom", reference_pkg = "cardx")
+ dplyr::relocate("variable_level", .after = "variable")
|
||
| 78 | +112 |
-
+ } |
||
| 79 | +113 |
- # check/process inputs -------------------------------------------------------+ ) |> |
||
| 80 | -2x | +114 | +12x |
- check_not_missing(data)+ dplyr::bind_rows() |
| 81 | -2x | +|||
| 115 | +
- check_not_missing(variable)+ } |
|||
| 82 | -2x | +|||
| 116 | +
- check_not_missing(by)+ |
|||
| 83 | -2x | +|||
| 117 | +
- check_not_missing(id)+ .calculate_ard_proportion <- function(data, variables, by, method, conf.level, strata, weights, max.iterations) {
|
|||
| 84 | -2x | +118 | +20x |
- check_data_frame(data)+ cards::ard_complex( |
| 85 | -2x | +119 | +20x |
- data <- dplyr::ungroup(data)+ data = data, |
| 86 | -2x | +120 | +20x |
- cards::process_selectors(data, by = {{ by }}, variable = {{ variable }}, id = {{ id }})
+ variables = {{ variables }},
|
| 87 | -2x | +121 | +20x |
- check_scalar(by)+ by = {{ by }},
|
| 88 | -2x | +122 | +20x |
- check_scalar(variable)+ statistic = |
| 89 | -2x | +123 | +20x |
- check_scalar(id)+ ~ list( |
| 90 | -+ | |||
| 124 | +20x |
-
+ prop_ci = |
||
| 91 | -+ | |||
| 125 | +20x |
- # build ARD ------------------------------------------------------------------+ switch(method, |
||
| 92 | -2x | +126 | +20x |
- .format_ttest_results(+ "waldcc" = \(x, ...) proportion_ci_wald(x, conf.level = conf.level, correct = TRUE), |
| 93 | -2x | +127 | +20x |
- by = by,+ "wald" = \(x, ...) proportion_ci_wald(x, conf.level = conf.level, correct = FALSE), |
| 94 | -2x | +128 | +20x |
- variable = variable,+ "wilsoncc" = \(x, ...) proportion_ci_wilson(x, conf.level = conf.level, correct = TRUE), |
| 95 | -2x | +129 | +20x |
- lst_tidy =+ "wilson" = \(x, ...) proportion_ci_wilson(x, conf.level = conf.level, correct = FALSE), |
| 96 | -2x | +130 | +20x |
- cards::eval_capture_conditions({
+ "clopper-pearson" = \(x, ...) proportion_ci_clopper_pearson(x, conf.level = conf.level), |
| 97 | -+ | |||
| 131 | +20x |
- # adding this reshape inside the eval, so if there is an error it's captured in the ARD object+ "agresti-coull" = \(x, ...) proportion_ci_agresti_coull(x, conf.level = conf.level), |
||
| 98 | -2x | +132 | +20x |
- data_wide <- .paired_data_pivot_wider(data, by = by, variable = variable, id = id)+ "jeffreys" = \(x, ...) proportion_ci_jeffreys(x, conf.level = conf.level), |
| 99 | -+ | |||
| 133 | +20x |
- # perform paired t-test+ "strat_wilsoncc" = \(x, data, ...) {
|
||
| 100 | +134 | 1x |
- stats::t.test(x = data_wide[["by1"]], y = data_wide[["by2"]], paired = TRUE, ...) |>+ proportion_ci_strat_wilson(x, |
|
| 101 | +135 | 1x |
- broom::tidy()- |
- |
| 102 | -- |
- }),+ strata = data[[strata]], weights = weights, |
||
| 103 | -2x | -
- paired = TRUE,- |
- ||
| 104 | -+ | 136 | +1x |
- ...+ max.iterations = max.iterations, |
| 105 | -+ | |||
| 137 | +1x |
- )+ conf.level = conf.level, correct = TRUE |
||
| 106 | +138 |
- }+ ) |
||
| 107 | +139 |
-
+ }, |
||
| 108 | -+ | |||
| 140 | +20x |
- #' Convert t-test to ARD+ "strat_wilson" = \(x, data, ...) {
|
||
| 109 | -+ | |||
| 141 | +1x |
- #'+ proportion_ci_strat_wilson(x, |
||
| 110 | -+ | |||
| 142 | +1x |
- #' @inheritParams cards::tidy_as_ard+ strata = data[[strata]], weights = weights, |
||
| 111 | -+ | |||
| 143 | +1x |
- #' @inheritParams stats::t.test+ max.iterations = max.iterations, |
||
| 112 | -+ | |||
| 144 | +1x |
- #' @param by (`string`)\cr by column name+ conf.level = conf.level, correct = FALSE |
||
| 113 | +145 |
- #' @param variable (`string`)\cr variable column name+ ) |
||
| 114 | +146 |
- #' @param ... passed to `t.test(...)`+ } |
||
| 115 | +147 |
- #'+ ) |
||
| 116 | +148 |
- #' @return ARD data frame+ ) |
||
| 117 | +149 |
- #' @keywords internal+ ) |> |
||
| 118 | -+ | |||
| 150 | +20x |
- #' @examples+ dplyr::mutate( |
||
| 119 | -+ | |||
| 151 | +20x |
- #' cardx:::.format_ttest_results(+ context = "proportion_ci" |
||
| 120 | +152 |
- #' by = "ARM",+ ) |
||
| 121 | +153 |
- #' variable = "AGE",+ } |
||
| 122 | +154 |
- #' paired = FALSE,+ |
||
| 123 | +155 |
- #' lst_tidy =+ .unique_values_sort <- function(data, variable, value = NULL) {
|
||
| 124 | -+ | |||
| 156 | +250x |
- #' cards::eval_capture_conditions(+ unique_levels <- |
||
| 125 | +157 |
- #' stats::t.test(ADSL[["AGE"]] ~ ADSL[["ARM"]], paired = FALSE) |>+ # styler: off |
||
| 126 | -+ | |||
| 158 | +250x |
- #' broom::tidy()+ if (is.logical(data[[variable]])) c(TRUE, FALSE) |
||
| 127 | -+ | |||
| 159 | +250x |
- #' )+ else if (is.factor(data[[variable]])) factor(levels(data[[variable]]), levels = levels(data[[variable]])) |
||
| 128 | -+ | |||
| 160 | +250x |
- #' )+ else unique(data[[variable]]) |> sort() |
||
| 129 | +161 |
- .format_ttest_results <- function(by, variable, lst_tidy, paired, ...) {
+ # styler: on |
||
| 130 | +162 |
- # build ARD ------------------------------------------------------------------+ |
||
| 131 | -4x | +163 | +250x |
- ret <-+ if (!is_empty(value) && !value %in% unique_levels) {
|
| 132 | -4x | +164 | +1x |
- cards::tidy_as_ard(+ cli::cli_warn( |
| 133 | -4x | +165 | +1x |
- lst_tidy = lst_tidy,+ c("A value of {.code value={.val {value}}} for variable {.val {variable}}
|
| 134 | -4x | +166 | +1x |
- tidy_result_names = c(+ was passed, but is not one of the observed levels: {.val {unique_levels}}.",
|
| 135 | -4x | +167 | +1x |
- "estimate", "estimate1", "estimate2", "statistic",+ i = "This may be an error.", |
| 136 | -4x | +168 | +1x |
- "p.value", "parameter", "conf.low", "conf.high",+ i = "If value is a valid, convert variable to factor with all levels specified to avoid this message." |
| 137 | -4x | +|||
| 169 | +
- "method", "alternative"+ ) |
|||
| 138 | +170 |
- ),+ ) |
||
| 139 | -4x | +|||
| 171 | +
- fun_args_to_record = c("mu", "paired", "var.equal", "conf.level"),
+ } |
|||
| 140 | -4x | +172 | +250x |
- formals = formals(asNamespace("stats")[["t.test.default"]]),
+ if (!is_empty(value)) {
|
| 141 | -4x | +173 | +19x |
- passed_args = c(list(paired = paired), dots_list(...)),+ unique_levels <- value+ |
+
| 174 | ++ |
+ }+ |
+ ||
| 175 | ++ | + | ||
| 142 | -4x | +176 | +250x |
- lst_ard_columns = list(group1 = by, variable = variable, context = "ttest")+ unique_levels |
| 143 | +177 |
- )+ } |
||
| 144 | +178 | |||
| 145 | +179 |
- # add the stat label ---------------------------------------------------------+ .as_dummy <- function(data, variable, levels, by, strata) {
+ |
+ ||
| 180 | ++ |
+ # define dummy variables and return tibble |
||
| 146 | -4x | +181 | +20x |
- ret |>+ map(levels, ~ data[[variable]] == .x) |> |
| 147 | -4x | +182 | +20x |
- dplyr::left_join(+ set_names(paste0("this_is_not_a_column_name_anyone_would_choose_", variable, "_", levels, "...")) %>%
|
| 148 | -4x | +183 | +20x |
- .df_ttest_stat_labels(),+ {dplyr::tibble(!!!.)} |> # styler: off
|
| 149 | -4x | +184 | +20x |
- by = "stat_name"+ dplyr::bind_cols(data[c(by, strata)]) |
| 150 | +185 |
- ) |>+ } |
||
| 151 | -4x | +
| 1 | +
- dplyr::mutate(stat_label = dplyr::coalesce(.data$stat_label, .data$stat_name)) |>+ #' ARD Mood Test |
|||
| 152 | -4x | +|||
| 2 | +
- cards::tidy_ard_column_order()+ #' |
|||
| 153 | +3 |
- }+ #' @description |
||
| 154 | +4 |
-
+ #' Analysis results data for Mood two sample test of scale. Note this not to be confused with |
||
| 155 | +5 |
-
+ #' the Brown-Mood test of medians.+ |
+ ||
| 6 | ++ |
+ #' |
||
| 156 | +7 |
- #' Convert long paired data to wide+ #' @param data (`data.frame`)\cr |
||
| 157 | +8 |
- #'+ #' a data frame. See below for details. |
||
| 158 | +9 |
- #'+ #' @param by ([`tidy-select`][dplyr::dplyr_tidy_select])\cr |
||
| 159 | +10 |
- #' @param data (`data.frame`)\cr a data frame that is one line per subject per group+ #' column name to compare by. |
||
| 160 | +11 |
- #' @param by (`string`)\cr by column name+ #' @param variables ([`tidy-select`][dplyr::dplyr_tidy_select])\cr |
||
| 161 | +12 |
- #' @param variable (`string`)\cr variable column name+ #' column name to be compared. Independent tests will |
||
| 162 | +13 |
- #' @param id (`string`)\cr subject id column name+ #' be run for each variable. |
||
| 163 | +14 |
- #' @param env (`environment`) used for error messaging. Default is `rlang::caller_env()`+ #' @param ... arguments passed to `mood.test(...)` |
||
| 164 | +15 |
#' |
||
| 165 | +16 |
- #' @return a wide data frame+ #' @return ARD data frame |
||
| 166 | +17 |
- #' @keywords internal+ #' @name ard_stats_mood_test |
||
| 167 | +18 |
- #' @examples+ #' |
||
| 168 | +19 |
- #' cards::ADSL[c("ARM", "AGE")] |>
+ #' @details |
||
| 169 | +20 |
- #' dplyr::filter(ARM %in% c("Placebo", "Xanomeline High Dose")) |>
+ #' For the `ard_stats_mood_test()` function, the data is expected to be one row per subject. |
||
| 170 | +21 |
- #' dplyr::mutate(.by = ARM, USUBJID = dplyr::row_number()) |>+ #' The data is passed as `mood.test(data[[variable]] ~ data[[by]], ...)`. |
||
| 171 | +22 |
- #' dplyr::arrange(USUBJID, ARM) |>+ #' @rdname ard_stats_mood_test |
||
| 172 | +23 |
- #' cardx:::.paired_data_pivot_wider(by = "ARM", variable = "AGE", id = "USUBJID")+ #' @export |
||
| 173 | +24 |
- .paired_data_pivot_wider <- function(data, by, variable, id, env = rlang::caller_env()) {
+ #' |
||
| 174 | +25 |
- # check the number of levels before pivoting data to wider format+ #' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = "broom"))
|
||
| 175 | +26 |
- if (dplyr::n_distinct(data[[by]], na.rm = TRUE) != 2L) {
+ #' cards::ADSL |> |
||
| 176 | +27 |
- cli::cli_abort("The {.arg by} argument must have two and only two levels.", call = env)
+ #' ard_stats_mood_test(by = "SEX", variables = "AGE") |
||
| 177 | +28 |
- }+ ard_stats_mood_test <- function(data, by, variables, ...) {
+ |
+ ||
| 29 | +5x | +
+ set_cli_abort_call() |
||
| 178 | +30 | |||
| 179 | +31 |
- data |>+ # check installed packages --------------------------------------------------- |
||
| 180 | -+ | |||
| 32 | +5x |
- # arrange data so the first group always appears first+ check_pkg_installed("broom")
|
||
| 181 | +33 |
- dplyr::arrange(.data[[by]]) |>+ |
||
| 182 | +34 |
- tidyr::pivot_wider(+ # check/process inputs ------------------------------------------------------- |
||
| 183 | -+ | |||
| 35 | +5x |
- id_cols = all_of(id),+ check_not_missing(data) |
||
| 184 | -+ | |||
| 36 | +5x |
- names_from = all_of(by),+ check_not_missing(variables) |
||
| 185 | -+ | |||
| 37 | +5x |
- values_from = all_of(variable)+ check_not_missing(by) |
||
| 186 | -+ | |||
| 38 | +5x |
- ) |>+ check_data_frame(data) |
||
| 187 | -+ | |||
| 39 | +5x |
- stats::setNames(c(id, "by1", "by2"))+ data <- dplyr::ungroup(data) |
||
| 188 | -+ | |||
| 40 | +5x |
- }+ cards::process_selectors(data, by = {{ by }}, variables = {{ variables }})
+ |
+ ||
| 41 | +5x | +
+ check_scalar(by) |
||
| 189 | +42 | |||
| 190 | +43 |
- .df_ttest_stat_labels <- function() {
+ # return empty ARD if no variables selected ---------------------------------- |
||
| 191 | -4x | +44 | +5x |
- dplyr::tribble(+ if (is_empty(variables)) {
|
| 192 | -4x | +|||
| 45 | +! |
- ~stat_name, ~stat_label,+ return(dplyr::tibble() |> cards::as_card()) |
||
| 193 | -4x | +|||
| 46 | +
- "estimate1", "Group 1 Mean",+ } |
|||
| 194 | -4x | +|||
| 47 | +
- "estimate2", "Group 2 Mean",+ + |
+ |||
| 48 | ++ |
+ # build ARD ------------------------------------------------------------------ |
||
| 195 | -4x | +49 | +5x |
- "estimate", "Mean Difference",+ lapply( |
| 196 | -4x | +50 | +5x |
- "p.value", "p-value",+ variables, |
| 197 | -4x | +51 | +5x |
- "statistic", "t Statistic",+ function(variable) {
|
| 198 | -4x | +52 | +6x |
- "parameter", "Degrees of Freedom",+ .format_moodtest_results( |
| 199 | -4x | +53 | +6x |
- "conf.low", "CI Lower Bound",+ by = by, |
| 200 | -4x | +54 | +6x |
- "conf.high", "CI Upper Bound",+ variable = variable, |
| 201 | -4x | +55 | +6x |
- "mu", "H0 Mean",+ lst_tidy = |
| 202 | -4x | +56 | +6x |
- "paired", "Paired t-test",+ cards::eval_capture_conditions( |
| 203 | -4x | +57 | +6x |
- "var.equal", "Equal Variances",+ stats::mood.test(data[[variable]] ~ data[[by]], ...) |> |
| 204 | -4x | +58 | +6x |
- "conf.level", "CI Confidence Level",+ broom::tidy() |
| 205 | +59 |
- )+ ), |
||
| 206 | +60 |
- }+ ... |
| 1 | +61 |
- #' ARD Chi-squared Test+ ) |
||
| 2 | +62 |
- #'+ } |
||
| 3 | +63 |
- #' @description+ ) |> |
||
| 4 | -+ | |||
| 64 | +5x |
- #' Analysis results data for Pearson's Chi-squared Test.+ dplyr::bind_rows() |
||
| 5 | +65 |
- #' Calculated with `chisq.test(x = data[[variable]], y = data[[by]], ...)`+ } |
||
| 6 | +66 |
- #'+ #' Convert mood test results to ARD |
||
| 7 | +67 |
#' |
||
| 8 | +68 |
- #' @param data (`data.frame`)\cr+ #' @inheritParams cards::tidy_as_ard |
||
| 9 | +69 |
- #' a data frame.+ #' @inheritParams stats::mood.test |
||
| 10 | +70 |
- #' @param by,variable ([`tidy-select`][dplyr::dplyr_tidy_select])\cr+ #' @param by (`string`)\cr by column name |
||
| 11 | +71 |
- #' column names to compare+ #' @param variable (`string`)\cr variable column name |
||
| 12 | +72 |
- #' @param ... additional arguments passed to `fisher.test(...)`+ #' @param ... passed to `mood.test(...)` |
||
| 13 | +73 |
#' |
||
| 14 | +74 |
#' @return ARD data frame |
||
| 15 | +75 |
- #' @export+ #' @keywords internal |
||
| 16 | +76 |
- #'+ #' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = "broom"))
|
||
| 17 | +77 |
- #' @examplesIf cards::is_pkg_installed("broom", reference_pkg = "cardx")
+ #' cardx:::.format_moodtest_results( |
||
| 18 | +78 |
- #' cards::ADSL |>+ #' by = "SEX", |
||
| 19 | +79 |
- #' ard_chisqtest(by = "ARM", variable = "AGEGR1")+ #' variable = "AGE", |
||
| 20 | +80 |
- ard_chisqtest <- function(data, by, variable, ...) {
+ #' lst_tidy = |
||
| 21 | +81 |
- # check installed packages ---------------------------------------------------+ #' cards::eval_capture_conditions( |
||
| 22 | -3x | +|||
| 82 | +
- cards::check_pkg_installed("broom", reference_pkg = "cardx")
+ #' stats::mood.test(ADSL[["AGE"]] ~ ADSL[["SEX"]]) |> |
|||
| 23 | +83 |
-
+ #' broom::tidy() |
||
| 24 | +84 |
- # check/process inputs -------------------------------------------------------+ #' ) |
||
| 25 | -3x | +|||
| 85 | +
- check_not_missing(data)+ #' ) |
|||
| 26 | -3x | +|||
| 86 | +
- check_not_missing(variable)+ .format_moodtest_results <- function(by, variable, lst_tidy, ...) {
|
|||
| 27 | -3x | +|||
| 87 | +
- check_not_missing(by)+ # build ARD ------------------------------------------------------------------ |
|||
| 28 | -3x | +88 | +6x |
- check_data_frame(data)+ ret <- |
| 29 | -3x | +89 | +6x |
- cards::process_selectors(data, by = {{ by }}, variable = {{ variable }})
+ cards::tidy_as_ard( |
| 30 | -3x | +90 | +6x |
- check_scalar(by)+ lst_tidy = lst_tidy, |
| 31 | -3x | -
- check_scalar(variable)- |
- ||
| 32 | -- | - - | -||
| 33 | -+ | 91 | +6x |
- # build ARD ------------------------------------------------------------------+ tidy_result_names = c("statistic", "p.value", "method", "alternative"),
|
| 34 | -3x | +92 | +6x |
- cards::tidy_as_ard(+ formals = formals(asNamespace("stats")[["mood.test.default"]]),
|
| 35 | -3x | +93 | +6x |
- lst_tidy =+ passed_args = c(dots_list(...)), |
| 36 | -3x | +94 | +6x |
- cards::eval_capture_conditions(+ lst_ard_columns = list(group1 = by, variable = variable, context = "stats_mood_test") |
| 37 | -3x | +|||
| 95 | +
- stats::chisq.test(x = data[[variable]], y = data[[by]], ...) |>+ ) |
|||
| 38 | -3x | +|||
| 96 | +
- broom::tidy()+ |
|||
| 39 | +97 |
- ),+ # add the stat label --------------------------------------------------------- |
||
| 40 | -3x | +98 | +6x |
- tidy_result_names = c("statistic", "p.value", "parameter", "method"),
+ ret |> |
| 41 | -3x | +99 | +6x |
- fun_args_to_record =+ dplyr::left_join( |
| 42 | -3x | +100 | +6x |
- c("correct", "p", "rescale.p", "simulate.p.value", "B"),
+ .df_moodtest_stat_labels(), |
| 43 | -3x | +101 | +6x |
- formals = formals(stats::chisq.test),+ by = "stat_name" |
| 44 | -3x | +|||
| 102 | +
- passed_args = dots_list(...),+ ) |> |
|||
| 45 | -3x | +103 | +6x |
- lst_ard_columns = list(group1 = by, variable = variable, context = "chisqtest")+ dplyr::mutate(stat_label = dplyr::coalesce(.data$stat_label, .data$stat_name)) |> |
| 46 | -+ | |||
| 104 | +6x |
- ) |>+ cards::as_card() |> |
||
| 47 | -3x | +105 | +6x |
- dplyr::mutate(+ cards::tidy_ard_column_order() |
| 48 | -3x | +|||
| 106 | +
- .after = "stat_name",+ } |
- |||
| 49 | -3x | +|||
| 107 | +
- stat_label =+ |
|||
| 50 | -3x | +|||
| 108 | +
- dplyr::case_when(+ .df_moodtest_stat_labels <- function() {
|
|||
| 51 | -3x | +109 | +6x |
- .data$stat_name %in% "statistic" ~ "X-squared Statistic",+ dplyr::tribble( |
| 52 | -3x | +110 | +6x |
- .data$stat_name %in% "p.value" ~ "p-value",+ ~stat_name, ~stat_label, |
| 53 | -3x | +111 | +6x |
- .data$stat_name %in% "parameter" ~ "Degrees of Freedom",+ "statistic", "Z-Statistic", |
| 54 | -3x | +112 | +6x |
- TRUE ~ .data$stat_name,+ "p.value", "p-value", |
| 55 | -+ | |||
| 113 | +6x |
- )+ "alternative", "Alternative Hypothesis" |
||
| 56 | +114 |
- )+ ) |
||
| 57 | +115 |
}@@ -11959,14 +41400,14 @@ cardx coverage - 95.63% |
| 1 |
- #' ARD Fisher's Exact Test+ #' Regression VIF ARD |
||
| 4 |
- #' Analysis results data for Fisher's Exact Test.+ #' Function takes a regression model object and returns the variance inflation factor (VIF) |
||
| 5 |
- #' Calculated with `fisher.test(x = data[[variable]], y = data[[by]], ...)`+ #' using [`car::vif()`] and converts it to a ARD structure |
||
| 7 |
- #'+ #' @param x regression model object |
||
| 8 |
- #' @param data (`data.frame`)\cr+ #' See car::vif() for details |
||
| 9 |
- #' a data frame.+ #' |
||
| 10 |
- #' @param by,variable ([`tidy-select`][dplyr::dplyr_tidy_select])\cr+ #' @param ... arguments passed to `car::vif(...)` |
||
| 11 |
- #' column names to compare+ #' |
||
| 12 |
- #' @param ... additional arguments passed to `fisher.test(...)`+ #' @return data frame |
||
| 13 |
- #'+ #' @name ard_car_vif |
||
| 14 |
- #' @return ARD data frame+ #' @rdname ard_car_vif |
||
| 17 |
- #' @examplesIf cards::is_pkg_installed("broom", reference_pkg = "cardx")
+ #' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = "car"))
|
||
| 18 |
- #' cards::ADSL[1:30, ] |>+ #' lm(AGE ~ ARM + SEX, data = cards::ADSL) |> |
||
| 19 |
- #' ard_fishertest(by = "ARM", variable = "AGEGR1")+ #' ard_car_vif() |
||
| 20 |
- ard_fishertest <- function(data, by, variable, ...) {
+ ard_car_vif <- function(x, ...) {
|
||
| 21 | -+ | 5x |
- # check installed packages ---------------------------------------------------+ set_cli_abort_call() |
| 22 | -1x | +
- cards::check_pkg_installed("broom", reference_pkg = "cardx")
+
|
|
| 23 |
-
+ # check installed packages --------------------------------------------------- |
||
| 24 | -+ | 5x |
- # check/process inputs -------------------------------------------------------+ check_pkg_installed("car")
|
| 25 | -1x | +
- check_not_missing(data)+ |
|
| 26 | -1x | +
- check_not_missing(variable)+ # check inputs --------------------------------------------------------------- |
|
| 27 | -1x | +5x |
- check_not_missing(by)+ check_not_missing(x) |
| 28 | -1x | +
- check_data_frame(data)+ |
|
| 29 | -1x | +5x |
- cards::process_selectors(data, by = {{ by }}, variable = {{ variable }})
+ vif <- cards::eval_capture_conditions(car::vif(x, ...)) |
| 30 | -1x | +
- check_scalar(by)+ |
|
| 31 | -1x | +
- check_scalar(variable)+ # if vif failed, set result as NULL, error will be kept through eval_capture_conditions() |
|
| 32 | -+ | 5x |
-
+ if (is.null(vif$result)) {
|
| 33 |
- # build ARD ------------------------------------------------------------------+ # try to capture variable names from `terms()` |
||
| 34 | -1x | +2x |
- cards::tidy_as_ard(+ lst_terms <- cards::eval_capture_conditions(attr(stats::terms(x), "term.labels")) |
| 35 | -1x | +
- lst_tidy =+ # we cannot get variable names, error out |
|
| 36 | -1x | +2x |
- cards::eval_capture_conditions(+ if (!is.null(lst_terms[["error"]])) {
|
| 37 | 1x |
- stats::fisher.test(x = data[[variable]], y = data[[by]], ...) |>+ cli::cli_abort( |
|
| 38 | 1x |
- broom::tidy()+ c("There was an error running {.fun car::vif}. See below.", x = vif[["error"]]),
|
|
| 39 | -+ | 1x |
- ),+ call = get_cli_abort_call() |
| 40 | -1x | +
- tidy_result_names =+ ) |
|
| 41 | -1x | +
- c("estimate", "p.value", "conf.low", "conf.high", "method", "alternative"),
+ } |
|
| 42 | 1x |
- fun_args_to_record =+ vif$result <- dplyr::tibble( |
|
| 43 | 1x |
- c(+ variable = lst_terms[["result"]], |
|
| 44 | 1x |
- "workspace", "hybrid", "hybridPars", "control", "or",+ VIF = list(NULL), |
|
| 45 | 1x |
- "conf.int", "conf.level", "simulate.p.value", "B"+ GVIF = list(NULL), |
|
| 46 | -+ | 1x |
- ),+ aGVIF = list(NULL), |
| 47 | 1x |
- formals = formals(stats::fisher.test),+ df = list(NULL) |
|
| 48 | -1x | +
- passed_args = dots_list(...),+ ) |
|
| 49 | -1x | +
- lst_ard_columns = list(group1 = by, variable = variable, context = "fishertest")+ } |
|
| 50 |
- ) |>+ # if VIF is returned |
||
| 51 | -1x | +3x |
- dplyr::mutate(+ else if (!is.matrix(vif$result)) {
|
| 52 | 1x |
- .after = "stat_name",+ vif$result <- dplyr::tibble(variable = names(vif$result), VIF = vif$result) |
|
| 53 | -1x | +
- stat_label =+ } |
|
| 54 | -1x | +
- dplyr::case_when(+ # if Generalized VIF is returned |
|
| 55 | -1x | +2x |
- .data$stat_name %in% "p.value" ~ "p-value",+ else if (is.matrix(vif$result)) {
|
| 56 | -1x | +2x |
- TRUE ~ .data$stat_name,+ vif$result <- |
| 57 | -+ | 2x |
- )+ vif$result |> |
| 58 | -+ | 2x |
- )+ as.data.frame() %>% |
| 59 | -+ | 2x |
- }+ dplyr::mutate(., variable = rownames(.), .before = 1L) |>+ |
+
| 60 | +2x | +
+ dplyr::rename(+ |
+ |
| 61 | +2x | +
+ aGVIF = "GVIF^(1/(2*Df))",+ |
+ |
| 62 | +2x | +
+ df = "Df" |
| 1 | +63 |
- #' ARD McNemar's Test+ ) |>+ |
+ |
| 64 | +2x | +
+ dplyr::tibble() |
|
| 2 | +65 |
- #'+ } |
|
| 3 | +66 |
- #' @description+ |
|
| 4 | +67 |
- #' Analysis results data for McNemar's statistical test.+ # Clean-up the result to fit the ard structure through pivot |
|
| 5 | -+ | ||
| 68 | +4x |
- #'+ vif$result <- |
|
| 6 | -+ | ||
| 69 | +4x |
- #' @param data (`data.frame`)\cr+ vif$result |> |
|
| 7 | -+ | ||
| 70 | +4x |
- #' a data frame. See below for details.+ tidyr::pivot_longer( |
|
| 8 | -+ | ||
| 71 | +4x |
- #' @param by ([`tidy-select`][dplyr::dplyr_tidy_select])\cr+ cols = -c("variable"),
|
|
| 9 | -+ | ||
| 72 | +4x |
- #' column name to compare by.+ names_to = "stat_name", |
|
| 10 | -+ | ||
| 73 | +4x |
- #' @param variable ([`tidy-select`][dplyr::dplyr_tidy_select])\cr+ values_to = "stat" |
|
| 11 | +74 |
- #' column name to be compared.+ ) |> |
|
| 12 | -+ | ||
| 75 | +4x |
- #' @param ... arguments passed to `stats::mcnemar.test(...)`+ dplyr::mutate( |
|
| 13 | -+ | ||
| 76 | +4x |
- #'+ context = "car_vif", |
|
| 14 | -+ | ||
| 77 | +4x |
- #' @return ARD data frame+ stat = as.list(.data$stat), |
|
| 15 | -+ | ||
| 78 | +4x |
- #' @export+ stat_label = ifelse( |
|
| 16 | -+ | ||
| 79 | +4x |
- #'+ .data$stat_name == "aGVIF", |
|
| 17 | -+ | ||
| 80 | +4x |
- #' @details+ "Adjusted GVIF", |
|
| 18 | -+ | ||
| 81 | +4x |
- #' For the `ard_mcnemartest()` function, the data is expected to be one row per subject.+ .data$stat_name |
|
| 19 | +82 |
- #' The data is passed as `stats::mcnemar.test(x = data[[variable]], y = data[[by]], ...)`.+ ), |
|
| 20 | -+ | ||
| 83 | +4x |
- #' Please use `table(x = data[[variable]], y = data[[by]])` to check the contingency table.+ fmt_fn = map( |
|
| 21 | -+ | ||
| 84 | +4x |
- #'+ .data$stat, |
|
| 22 | -+ | ||
| 85 | +4x |
- #' @examplesIf cards::is_pkg_installed("broom", reference_pkg = "cardx")
+ function(.x) {
|
|
| 23 | +86 |
- #' cards::ADSL |>+ # styler: off |
|
| 24 | -+ | ||
| 87 | +! |
- #' ard_mcnemartest(by = "SEX", variable = "EFFFL")+ if (is.integer(.x)) return(0L) |
|
| 25 | -+ | ||
| 88 | +14x |
- ard_mcnemartest <- function(data, by, variable, ...) {
+ if (is.numeric(.x)) return(1L) |
|
| 26 | +89 |
- # check installed packages ---------------------------------------------------+ # styler: on |
|
| 27 | +90 | 4x |
- cards::check_pkg_installed("broom", reference_pkg = "cardx")
+ NULL |
| 28 | +91 |
-
+ } |
|
| 29 | +92 |
- # check/process inputs -------------------------------------------------------+ ) |
|
| 30 | -4x | +||
| 93 | +
- check_not_missing(data)+ ) |
||
| 31 | -4x | +||
| 94 | +
- check_not_missing(variable)+ |
||
| 32 | -4x | +||
| 95 | +
- check_not_missing(by)+ # Bind the results and possible warning/errors together |
||
| 33 | +96 | 4x |
- check_data_frame(data)+ vif_return <- dplyr::tibble( |
| 34 | +97 | 4x |
- data <- dplyr::ungroup(data)+ vif$result, |
| 35 | +98 | 4x |
- cards::process_selectors(data, by = {{ by }}, variable = {{ variable }})
+ warning = vif["warning"], |
| 36 | +99 | 4x |
- check_scalar(by)+ error = vif["error"] |
| 37 | -4x | +||
| 100 | +
- check_scalar(variable)+ ) |
||
| 38 | +101 | ||
| 39 | +102 |
- # build ARD ------------------------------------------------------------------- |
- |
| 40 | -4x | -
- .format_mcnemartest_results(+ # Clean up return object |
|
| 41 | +103 | 4x |
- by = by,+ vif_return |> |
| 42 | +104 | 4x |
- variable = variable,+ cards::as_card() |> |
| 43 | +105 | 4x |
- lst_tidy =+ cards::tidy_ard_column_order() |
| 44 | -4x | +||
| 106 | +
- cards::eval_capture_conditions(+ } |
||
| 45 | -4x | +
| 1 | +
- stats::mcnemar.test(x = data[[variable]], y = data[[by]], ...) |>+ #' Basic Regression ARD |
|||
| 46 | -4x | +|||
| 2 | +
- broom::tidy()+ #' |
|||
| 47 | +3 |
- ),+ #' @description |
||
| 48 | +4 |
- ...+ #' A function that takes a regression model and provides basic statistics in an |
||
| 49 | +5 |
- )+ #' ARD structure. |
||
| 50 | +6 |
- }+ #' The default output is simpler than [`ard_regression()`]. |
||
| 51 | +7 |
-
+ #' The function primarily matches regression terms to underlying variable names |
||
| 52 | +8 |
- #' Convert McNemar's test to ARD+ #' and levels. |
||
| 53 | +9 |
- #'+ #' The default arguments used are |
||
| 54 | +10 |
- #' @inheritParams cards::tidy_as_ard+ #' |
||
| 55 | +11 |
- #' @inheritParams stats::mcnemar.test+ #' ```r |
||
| 56 | +12 |
- #' @param by (`string`)\cr by column name+ #' broom.helpers::tidy_plus_plus( |
||
| 57 | +13 |
- #' @param variable (`string`)\cr variable column name+ #' add_reference_rows = FALSE, |
||
| 58 | +14 |
- #' @param ... passed to `stats::mcnemar.test(...)`+ #' add_estimate_to_reference_rows = FALSE, |
||
| 59 | +15 |
- #'+ #' add_n = FALSE, |
||
| 60 | +16 |
- #' @return ARD data frame+ #' intercept = FALSE |
||
| 61 | +17 |
- #'+ #' ) |
||
| 62 | +18 |
- #' @examples+ #' ``` |
||
| 63 | +19 |
- #' cardx:::.format_mcnemartest_results(+ #' |
||
| 64 | +20 |
- #' by = "ARM",+ #' @inheritParams ard_regression |
||
| 65 | +21 |
- #' variable = "AGE",+ #' @param stats_to_remove (`character`)\cr |
||
| 66 | +22 |
- #' lst_tidy =+ #' character vector of statistic names to remove. Default is |
||
| 67 | +23 |
- #' cards::eval_capture_conditions(+ #' `c("term", "var_type", "var_label", "var_class", "label", "contrasts_type", "contrasts", "var_nlevels")`.
|
||
| 68 | +24 |
- #' stats::mcnemar.test(cards::ADSL[["SEX"]], cards::ADSL[["EFFFL"]]) |>+ #' |
||
| 69 | +25 |
- #' broom::tidy()+ #' @return data frame |
||
| 70 | +26 |
- #' )+ #' @name ard_regression_basic |
||
| 71 | +27 |
- #' )+ #' @export |
||
| 72 | +28 |
#' |
||
| 73 | +29 |
- #' @keywords internal+ #' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = "broom.helpers"))
|
||
| 74 | +30 |
- .format_mcnemartest_results <- function(by, variable, lst_tidy, ...) {
+ #' lm(AGE ~ ARM, data = cards::ADSL) |> |
||
| 75 | +31 |
- # build ARD ------------------------------------------------------------------+ #' ard_regression_basic() |
||
| 76 | -4x | +|||
| 32 | +
- ret <-+ ard_regression_basic <- function(x, tidy_fun = broom.helpers::tidy_with_broom_or_parameters, |
|||
| 77 | -4x | +|||
| 33 | +
- cards::tidy_as_ard(+ stats_to_remove = c( |
|||
| 78 | -4x | +|||
| 34 | +
- lst_tidy = lst_tidy,+ "term", "var_type", "var_label", "var_class", |
|||
| 79 | -4x | +|||
| 35 | +
- tidy_result_names = c("statistic", "p.value", "method"),
+ "label", "contrasts_type", "contrasts", "var_nlevels" |
|||
| 80 | -4x | +|||
| 36 | +
- fun_args_to_record = c("correct"),
+ ), |
|||
| 81 | -4x | +|||
| 37 | +
- formals = formals(asNamespace("stats")[["mcnemar.test"]]),
+ ...) {
|
|||
| 82 | -4x | +38 | +6x |
- passed_args = dots_list(...),+ set_cli_abort_call() |
| 83 | -4x | +|||
| 39 | +
- lst_ard_columns = list(group1 = by, variable = variable, context = "mcnemartest")+ |
|||
| 84 | +40 |
- )+ # check installed packages ---------------------------------------------------+ |
+ ||
| 41 | +6x | +
+ check_pkg_installed(pkg = "broom.helpers") |
||
| 85 | +42 | |||
| 86 | +43 |
- # add the stat label ---------------------------------------------------------+ # check inputs --------------------------------------------------------------- |
||
| 87 | -4x | +44 | +6x |
- ret |>+ check_not_missing(x) |
| 88 | -4x | +45 | +6x |
- dplyr::left_join(+ check_class(stats_to_remove, cls = "character", allow_empty = TRUE) |
| 89 | -4x | +|||
| 46 | +! |
- .df_mcnemar_stat_labels(),+ if (is_empty(stats_to_remove)) stats_to_remove <- character(0L) # styler: off+ |
+ ||
| 47 | ++ | + | ||
| 90 | -4x | +48 | +6x |
- by = "stat_name"+ args <- |
| 91 | -+ | |||
| 49 | +6x |
- ) |>+ list( |
||
| 92 | -4x | +50 | +6x |
- dplyr::mutate(stat_label = dplyr::coalesce(.data$stat_label, .data$stat_name)) |>+ add_reference_rows = FALSE, |
| 93 | -4x | +51 | +6x |
- cards::tidy_ard_column_order()+ add_estimate_to_reference_rows = FALSE, |
| 94 | -+ | |||
| 52 | +6x |
- }+ add_n = FALSE, |
||
| 95 | -+ | |||
| 53 | +6x |
-
+ intercept = FALSE |
||
| 96 | +54 |
- .df_mcnemar_stat_labels <- function() {
+ ) |> |
||
| 97 | -4x | +55 | +6x |
- dplyr::tribble(+ utils::modifyList(val = rlang::dots_list(...)) |
| 98 | -4x | +|||
| 56 | +
- ~stat_name, ~stat_label,+ |
|||
| 99 | -4x | +57 | +6x |
- "statistic", "X-squared Statistic",+ rlang::inject(ard_regression(x = x, tidy_fun = tidy_fun, !!!args)) |> |
| 100 | -4x | +58 | +6x |
- "parameter", "Degrees of Freedom",+ dplyr::filter(!.data$stat_name %in% stats_to_remove) |> |
| 101 | -4x | -
- "p.value", "p-value",- |
- ||
| 102 | -+ | 59 | +6x |
- )+ dplyr::select(-(cards::all_ard_variables("levels") & dplyr::where(\(x) all(is.na(x)))))
|
| 103 | +60 |
}@@ -13105,14 +42574,14 @@ cardx coverage - 95.63% |
| 1 |
- #' ARD ANOVA from car Package+ #' ARD One-way Test |
|||
| 3 |
- #' Function takes a regression model object and calculated ANOVA using [`car::Anova()`].+ #' @description |
|||
| 4 |
- #'+ #' Analysis results data for Testing Equal Means in a One-Way Layout. |
|||
| 5 |
- #' @param x regression model object+ #' calculated with `oneway.test()` |
|||
| 6 |
- #' @param ... arguments passed to `car::Anova(...)`+ #' |
|||
| 7 |
- #'+ #' @inheritParams stats::oneway.test |
|||
| 8 |
- #' @return data frame+ #' @param ... additional arguments passed to `oneway.test(...)` |
|||
| 9 |
- #' @export+ #' |
|||
| 10 |
- #'+ #' @return ARD data frame |
|||
| 11 |
- #' @examplesIf cards::is_pkg_installed(c("broom.helpers", "car"), reference_pkg = "cardx")
+ #' @export |
|||
| 12 |
- #' lm(AGE ~ ARM, data = cards::ADSL) |>+ #' |
|||
| 13 |
- #' ard_car_anova()+ #' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = "broom"))
|
|||
| 14 |
- #'+ #' ard_stats_oneway_test(AGE ~ ARM, data = cards::ADSL) |
|||
| 15 |
- #' glm(vs ~ factor(cyl) + factor(am), data = mtcars, family = binomial) |>+ ard_stats_oneway_test <- function(formula, data, ...) {
|
|||
| 16 | -+ | 3x |
- #' ard_car_anova(test.statistic = "Wald")+ set_cli_abort_call() |
|
| 17 |
- ard_car_anova <- function(x, ...) {
+
|
|||
| 19 | -2x | +3x |
- cards::check_pkg_installed(c("broom.helpers", "car"), reference_pkg = "cardx")
+ check_pkg_installed(c("broom"))
|
|
| 21 |
- # check inputs ---------------------------------------------------------------+ # check/process inputs ------------------------------------------------------- |
|||
| 22 | -2x | +3x |
- check_not_missing(x)+ check_not_missing(formula) |
|
| 23 | -+ | 3x |
-
+ check_not_missing(data) |
|
| 24 | -+ | 3x |
- # run car::Anova() -----------------------------------------------------------+ check_data_frame(data) |
|
| 25 | -2x | +3x |
- car_anova <- cards::eval_capture_conditions(car::Anova(x, ...))+ check_class(formula, cls = "formula") |
|
| 27 | -2x | +
- if (!is.null(car_anova[["error"]])) {
+ # build ARD ------------------------------------------------------------------ |
||
| 28 | -1x | +3x |
- cli::cli_abort(c(+ df_results <- |
|
| 29 | -1x | +3x |
- "There was an error running {.fun car::Anova}. See error message below.",
+ cards::tidy_as_ard( |
|
| 30 | -1x | +3x |
- x = car_anova[["error"]]+ lst_tidy = |
|
| 31 | -+ | 3x |
- ))+ cards::eval_capture_conditions( |
|
| 32 | -+ | 3x |
- }+ stats::oneway.test(formula, data = data, ...) |> |
|
| 33 | -+ | 3x |
-
+ broom::tidy() |
|
| 34 | -1x | +
- car_anova[["result"]] |>+ ), |
||
| 35 | -1x | +3x |
- broom.helpers::tidy_parameters(conf.int = FALSE) |> # using broom.helpers, because it handle non-syntactic names for us+ tidy_result_names = c("num.df", "den.df", "statistic", "p.value", "method"),
|
|
| 36 | -1x | +3x |
- dplyr::filter(!(dplyr::row_number() == dplyr::n() & .data$term %in% "Residuals")) |> # removing Residual rows+ fun_args_to_record = |
|
| 37 | -1x | +3x |
- dplyr::rename(variable = "term") |>+ c("var.equal"),
|
|
| 38 | -1x | +3x |
- tidyr::pivot_longer(+ formals = formals(stats::oneway.test), |
|
| 39 | -1x | +3x |
- cols = -"variable",+ passed_args = dots_list(...), |
|
| 40 | -1x | +3x |
- names_to = "stat_name",+ lst_ard_columns = list(context = "stats_oneway_test") |
|
| 41 | -1x | +
- values_to = "stat"+ ) |> |
||
| 42 | -+ | 3x |
- ) |>+ dplyr::mutate( |
|
| 43 | -1x | +3x |
- dplyr::mutate(+ .after = "stat_name", |
|
| 44 | -1x | +3x |
- stat = as.list(.data$stat),+ stat_label = |
|
| 45 | -1x | +3x |
- stat_label =+ dplyr::case_when( |
|
| 46 | -1x | +3x |
- dplyr::case_when(+ .data$stat_name %in% "num.df" ~ "Degrees of Freedom", |
|
| 47 | -1x | +3x |
- .data$stat_name %in% "statistic" ~ "Statistic",+ .data$stat_name %in% "den.df" ~ "Denominator Degrees of Freedom", |
|
| 48 | -1x | +3x |
- .data$stat_name %in% "df" ~ "Degrees of Freedom",+ .data$stat_name %in% "statistic" ~ "F Statistic", |
|
| 49 | -1x | +3x |
.data$stat_name %in% "p.value" ~ "p-value", |
|
| 50 | -1x | -
- TRUE ~ .data$stat_name- |
- ||
| 51 | -- |
- ),- |
- ||
| 52 | -1x | -
- fmt_fn =- |
- ||
| 53 | -1x | -
- map(- |
- ||
| 54 | -1x | -
- .data$stat,- |
- ||
| 55 | -1x | -
- function(.x) {
- |
- ||
| 56 | -- |
- # styler: off- |
- ||
| 57 | -! | +3x |
- if (is.integer(.x)) return(0L)+ .data$stat_name %in% "method" ~ "Method", |
|
| 58 | -6x | +51 | +3x |
- if (is.numeric(.x)) return(1L)+ TRUE ~ .data$stat_name, |
| 59 | +52 |
- # styler: on+ ) |
||
| 60 | -! | +|||
| 53 | +
- NULL+ ) |
|||
| 61 | +54 |
- }+ |
||
| 62 | +55 |
- ),+ # add variable/groups to results and return result |
||
| 63 | -1x | +56 | +3x |
- context = "car_anova",+ df_results |> |
| 64 | -1x | +57 | +3x |
- warning = car_anova["warning"],+ dplyr::bind_cols( |
| 65 | -1x | +58 | +3x |
- error = car_anova["error"]+ dplyr::tibble(!!!map(as.list(attr(stats::terms(formula), "variables"))[-1], as_label)) %>%+ |
+
| 59 | +3x | +
+ set_names(., c("variable", paste0("group", seq_len(length(.) - 1L))))
|
||
| 66 | +60 |
) |> |
||
| 67 | -1x | +61 | +3x |
- cards::tidy_ard_column_order() %>%+ cards::as_card() |> |
| 68 | -1x | +62 | +3x |
- {structure(., class = c("card", class(.)))} # styler: off
+ cards::tidy_ard_column_order() |
| 69 | +63 |
}@@ -13594,14 +43021,14 @@ cardx coverage - 95.63% |
| 1 |
- #' ARD Proportion Confidence Intervals+ #' ARD one-sample Wilcox Rank-sum |
|||
| 3 |
- #' `r lifecycle::badge('experimental')`\cr
+ #' @description |
|||
| 4 |
- #' Calculate confidence intervals for proportions.+ #' Analysis results data for one-sample Wilcox Rank-sum. |
|||
| 5 |
- #'+ #' Result may be stratified by including the `by` argument. |
|||
| 6 |
- #' @inheritParams cards::ard_categorical+ #' |
|||
| 7 |
- #' @param variables ([`tidy-select`][dplyr::dplyr_tidy_select])\cr+ #' @param data (`data.frame`)\cr |
|||
| 8 |
- #' columns to include in summaries. Columns must be class `<logical>`+ #' a data frame. See below for details. |
|||
| 9 |
- #' or `<numeric>` values coded as `c(0, 1)`.+ #' @param variables ([`tidy-select`][dplyr::dplyr_tidy_select])\cr |
|||
| 10 |
- #' @param by ([`tidy-select`][dplyr::dplyr_tidy_select])\cr+ #' column names to be analyzed. Independent Wilcox Rank-sum tests will be computed for |
|||
| 11 |
- #' columns to stratify calculations by+ #' each variable. |
|||
| 12 |
- #' @param conf.level (`numeric`)\cr+ #' @param by ([`tidy-select`][dplyr::dplyr_tidy_select])\cr |
|||
| 13 |
- #' a scalar in `(0, 1)` indicating the confidence level.+ #' optional column name to stratify results by. |
|||
| 14 |
- #' Default is `0.95`+ #' @inheritParams ard_stats_wilcox_test |
|||
| 15 |
- #' @param method (`string`)\cr+ #' |
|||
| 16 |
- #' string indicating the type of confidence interval to calculate.+ #' @return ARD data frame |
|||
| 17 |
- #' Must be one of `r formals(ard_proportion_ci)[["method"]] |> eval() |> shQuote()`.+ #' @export |
|||
| 18 |
- #' See `?proportion_ci` for details.+ #' |
|||
| 19 |
- #' @param strata,weights,max.iterations arguments passed to `proportion_ci_strat_wilson()`,+ #' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = "broom"))
|
|||
| 20 |
- #' when `method='strat_wilson'`+ #' cards::ADSL |> |
|||
| 21 |
- #'+ #' ard_stats_wilcox_test_onesample(by = ARM, variables = AGE) |
|||
| 22 |
- #' @return an ARD data frame+ ard_stats_wilcox_test_onesample <- function(data, variables, by = dplyr::group_vars(data), conf.level = 0.95, ...) {
|
|||
| 23 | -+ | 6x |
- #' @export+ set_cli_abort_call() |
|
| 24 |
- #'+ |
|||
| 25 |
- #' @examplesIf cards::is_pkg_installed("broom", reference_pkg = "cardx")
+ # check installed packages --------------------------------------------------- |
|||
| 26 | -+ | 6x |
- #' ard_proportion_ci(mtcars, variables = c(vs, am), method = "wilson")+ check_pkg_installed("broom")
|
|
| 27 |
- ard_proportion_ci <- function(data, variables, by = dplyr::group_vars(data),+ |
|||
| 28 |
- conf.level = 0.95,+ # check/process inputs ------------------------------------------------------- |
|||
| 29 | -+ | 6x |
- strata,+ check_not_missing(data) |
|
| 30 | -+ | 6x |
- weights = NULL,+ check_not_missing(variables) |
|
| 31 | -+ | 6x |
- max.iterations = 10,+ check_data_frame(data) |
|
| 32 | -+ | 6x |
- method = c(+ data <- dplyr::ungroup(data) |
|
| 33 | -+ | 6x |
- "waldcc", "wald", "clopper-pearson",+ cards::process_selectors(data, by = {{ by }}, variables = {{ variables }})
|
|
| 34 | -+ | 6x |
- "wilson", "wilsoncc",+ check_scalar_range(conf.level, range = c(0, 1)) |
|
| 35 |
- "strat_wilson", "strat_wilsoncc",+ |
|||
| 36 |
- "agresti-coull", "jeffreys"+ # return empty ARD if no variables selected ---------------------------------- |
|||
| 37 | -+ | 6x |
- )) {
+ if (is_empty(variables)) {
|
|
| 38 | -+ | 1x |
- # process inputs -------------------------------------------------------------+ return(dplyr::tibble() |> cards::as_card()) |
|
| 39 | -8x | +
- cards::process_selectors(data, variables = {{ variables }}, by = {{ by }})
+ } |
||
| 40 | -8x | +
- method <- arg_match(method)+ |
||
| 41 | -8x | +5x |
- if (method %in% c("strat_wilson", "strat_wilsoncc")) {
+ cards::ard_continuous( |
|
| 42 | -1x | +5x |
- cards::process_selectors(data, strata = strata)+ data = data, |
|
| 43 | -1x | +5x |
- check_scalar(strata)+ variables = all_of(variables), |
|
| 44 | -+ | 5x |
- }+ by = all_of(by), |
|
| 45 | -+ | 5x |
-
+ statistic = all_of(variables) ~ list(wilcox_test_onesample = \(x) stats::wilcox.test(x = x, conf.level = conf.level, ...) |> broom::tidy()) |
|
| 46 |
- # calculate confidence intervals ---------------------------------------------+ ) |> |
|||
| 47 | -8x | +5x |
- cards::ard_complex(+ cards::bind_ard( |
|
| 48 | -8x | +5x |
- data = data,+ cards::ard_continuous( |
|
| 49 | -8x | +5x |
- variables = {{ variables }},
+ data = data, |
|
| 50 | -8x | +5x |
- by = {{ by }},
+ variables = all_of(variables), |
|
| 51 | -8x | -
- statistic =- |
- ||
| 52 | -8x | -
- ~ list(- |
- ||
| 53 | -8x | -
- prop_ci =- |
- ||
| 54 | -8x | -
- switch(method,- |
- ||
| 55 | -8x | -
- "waldcc" = \(x, ...) proportion_ci_wald(x, conf.level = conf.level, correct = TRUE),- |
- ||
| 56 | -8x | -
- "wald" = \(x, ...) proportion_ci_wald(x, conf.level = conf.level, correct = FALSE),- |
- ||
| 57 | -8x | -
- "wilsoncc" = \(x, ...) proportion_ci_wilson(x, conf.level = conf.level, correct = TRUE),- |
- ||
| 58 | -8x | -
- "wilson" = \(x, ...) proportion_ci_wilson(x, conf.level = conf.level, correct = FALSE),- |
- ||
| 59 | -8x | -
- "clopper-pearson" = \(x, ...) proportion_ci_clopper_pearson(x, conf.level = conf.level),- |
- ||
| 60 | -8x | +5x |
- "agresti-coull" = \(x, ...) proportion_ci_agresti_coull(x, conf.level = conf.level),+ by = all_of(by), |
|
| 61 | -8x | +52 | +5x |
- "jeffreys" = \(x, ...) proportion_ci_jeffreys(x, conf.level = conf.level),+ statistic = |
| 62 | -8x | +53 | +5x |
- "strat_wilsoncc" = \(x, data, ...) {
+ all_of(variables) ~ |
| 63 | -! | +|||
| 54 | +5x |
- proportion_ci_strat_wilson(x,+ list(conf.level = \(x) {
|
||
| 64 | -! | +|||
| 55 | +9x |
- strata = data[[strata]], weights = weights,+ formals(asNamespace("stats")[["wilcox.test.default"]])[c("mu", "exact", "conf.int", "tol.root", "digits.rank")] |>
|
||
| 65 | -! | +|||
| 56 | +9x |
- max.iterations = max.iterations,+ utils::modifyList(list(conf.level = conf.level, ...)) |> |
||
| 66 | -! | +|||
| 57 | +9x |
- conf.level = conf.level, correct = TRUE+ compact() |
||
| 67 | +58 |
- )+ }) |
||
| 68 | +59 |
- },+ ) |
||
| 69 | -8x | +|||
| 60 | +
- "strat_wilson" = \(x, data, ...) {
+ ) |> |
|||
| 70 | -1x | +61 | +5x |
- proportion_ci_strat_wilson(x,+ dplyr::select(-"stat_label") |> |
| 71 | -1x | +62 | +5x |
- strata = data[[strata]], weights = weights,+ dplyr::left_join( |
| 72 | -1x | +63 | +5x |
- max.iterations = max.iterations,+ .df_ttest_stat_labels(by = NULL), |
| 73 | -1x | +64 | +5x |
- conf.level = conf.level, correct = FALSE+ by = "stat_name" |
| 74 | +65 |
- )+ ) |> |
||
| 75 | -+ | |||
| 66 | +5x |
- }+ dplyr::mutate( |
||
| 76 | -+ | |||
| 67 | +5x |
- )+ stat_label = dplyr::coalesce(.data$stat_label, .data$stat_name), |
||
| 77 | -+ | |||
| 68 | +5x |
- )+ context = "stats_wilcox_test_onesample", |
||
| 78 | +69 |
- ) |>+ ) |> |
||
| 79 | -8x | +70 | +5x |
- dplyr::mutate(+ cards::as_card() |> |
| 80 | -8x | +71 | +5x |
- context = "proportion_ci"+ cards::tidy_ard_column_order() |> |
| 81 | -+ | |||
| 72 | +5x |
- )+ cards::tidy_ard_row_order() |
||
| 82 | +73 |
}@@ -14174,14 +43538,14 @@ cardx coverage - 95.63% |
| 1 |
- #' Basic Regression ARD+ #' ARD Missing Survey Statistics |
|||
| 3 |
- #' @description+ #' Compute Analysis Results Data (ARD) for statistics related to data missingness for survey objects |
|||
| 4 |
- #' A function that takes a regression model and provides basic statistics in an+ #' |
|||
| 5 |
- #' ARD structure.+ #' @inheritParams ard_categorical.survey.design |
|||
| 6 |
- #' The default output is simpler than [`ard_regression()`].+ #' |
|||
| 7 |
- #' The function primarily matches regression terms to underlying variable names+ #' @return an ARD data frame of class 'card' |
|||
| 8 |
- #' and levels.+ #' @export |
|||
| 9 |
- #' The default arguments used are+ #' |
|||
| 10 |
- #'+ #' @examplesIf cardx:::is_pkg_installed("survey")
|
|||
| 11 |
- #' ```r+ #' svy_titanic <- survey::svydesign(~1, data = as.data.frame(Titanic), weights = ~Freq) |
|||
| 12 |
- #' broom.helpers::tidy_plus_plus(+ #' |
|||
| 13 |
- #' add_reference_rows = FALSE,+ #' ard_missing(svy_titanic, variables = c(Class, Age), by = Survived) |
|||
| 14 |
- #' add_estimate_to_reference_rows = FALSE,+ ard_missing.survey.design <- function(data, |
|||
| 15 |
- #' add_n = FALSE,+ variables, |
|||
| 16 |
- #' intercept = FALSE+ by = NULL, |
|||
| 17 |
- #' )+ statistic = |
|||
| 18 |
- #' ```+ everything() ~ c( |
|||
| 19 |
- #'+ "N_obs", "N_miss", "N_nonmiss", "p_miss", "p_nonmiss", |
|||
| 20 |
- #' @inheritParams ard_regression+ "N_obs_unweighted", "N_miss_unweighted", "N_nonmiss_unweighted", |
|||
| 21 |
- #' @param stats_to_remove (`character`)\cr+ "p_miss_unweighted", "p_nonmiss_unweighted" |
|||
| 22 |
- #' character vector of statistic names to remove. Default is+ ), |
|||
| 23 |
- #' `c("term", "var_type", "var_label", "var_class", "label", "contrasts_type", "contrasts", "var_nlevels")`.
+ fmt_fn = NULL, |
|||
| 24 |
- #'+ stat_label = |
|||
| 25 |
- #' @return data frame+ everything() ~ list( |
|||
| 26 |
- #' @name ard_regression_basic+ N_obs = "Total N", |
|||
| 27 |
- #' @export+ N_miss = "N Missing", |
|||
| 28 |
- #'+ N_nonmiss = "N not Missing", |
|||
| 29 |
- #' @examplesIf cards::is_pkg_installed("broom.helpers", reference_pkg = "cardx")
+ p_miss = "% Missing", |
|||
| 30 |
- #' lm(AGE ~ ARM, data = cards::ADSL) |>+ p_nonmiss = "% not Missing", |
|||
| 31 |
- #' ard_regression_basic()+ N_obs_unweighted = "Total N (unweighted)", |
|||
| 32 |
- ard_regression_basic <- function(x, tidy_fun = broom.helpers::tidy_with_broom_or_parameters,+ N_miss_unweighted = "N Missing (unweighted)", |
|||
| 33 |
- stats_to_remove = c(+ N_nonmiss_unweighted = "N not Missing (unweighted)", |
|||
| 34 |
- "term", "var_type", "var_label", "var_class",+ p_miss_unweighted = "% Missing (unweighted)", |
|||
| 35 |
- "label", "contrasts_type", "contrasts", "var_nlevels"+ p_nonmiss_unweighted = "% not Missing (unweighted)" |
|||
| 36 |
- ),+ ), |
|||
| 37 |
- ...) {
+ ...) {
|
|||
| 38 | -+ | 5x |
- # check installed packages ---------------------------------------------------+ set_cli_abort_call() |
|
| 39 | -1x | +5x | +
+ check_dots_empty()+ |
+ |
| 40 | +5x | +
+ check_pkg_installed(pkg = "survey")+ |
+ ||
| 41 | ++ | + + | +||
| 42 | ++ |
+ # process inputs -------------------------------------------------------------+ |
+ ||
| 43 | +5x | +
+ check_not_missing(variables)+ |
+ ||
| 44 | +5x | +
+ cards::process_selectors(+ |
+ ||
| 45 | +5x | +
+ data = data$variables,+ |
+ ||
| 46 | +5x | +
+ variables = {{ variables }},
+ |
+ ||
| 47 | +5x | +
+ by = {{ by }}
+ |
+ ||
| 48 | ++ |
+ )+ |
+ ||
| 49 | ++ | + + | +||
| 50 | ++ |
+ # return empty ARD if no variables selected ----------------------------------+ |
+ ||
| 51 | +5x | +
+ if (is_empty(variables)) {
+ |
+ ||
| 52 | +! |
- cards::check_pkg_installed("broom.helpers", reference_pkg = "cardx")
+ return(dplyr::tibble() |> cards::as_card()) |
||
| 40 | +53 |
-
+ } |
||
| 41 | +54 |
- # check inputs ---------------------------------------------------------------+ |
||
| 42 | -1x | +|||
| 55 | +
- check_not_missing(x)+ # convert all variables to T/F whether it's missing -------------------------- |
|||
| 43 | -1x | +56 | +5x |
- check_class(stats_to_remove, cls = "character", allow_empty = TRUE)+ data$variables <- data$variables |> |
| 44 | -! | +|||
| 57 | +5x |
- if (is_empty(stats_to_remove)) stats_to_remove <- character(0L) # styler: off+ dplyr::mutate(across(all_of(variables), Negate(is.na))) |
||
| 45 | +58 | |||
| 46 | -1x | -
- args <-- |
- ||
| 47 | -1x | +59 | +5x |
- list(+ cards::process_formula_selectors( |
| 48 | -1x | +60 | +5x |
- add_reference_rows = FALSE,+ data$variables[variables], |
| 49 | -1x | +61 | +5x |
- add_estimate_to_reference_rows = FALSE,+ statistic = statistic, |
| 50 | -1x | +62 | +5x |
- add_n = FALSE,+ fmt_fn = fmt_fn, |
| 51 | -1x | +63 | +5x |
- intercept = FALSE+ stat_label = stat_label |
| 52 | +64 |
- ) |>+ ) |
||
| 53 | -1x | -
- utils::modifyList(val = rlang::dots_list(...))- |
- ||
| 54 | -+ | 65 | +5x |
-
+ cards::fill_formula_selectors( |
| 55 | -1x | +66 | +5x |
- rlang::inject(ard_regression(x = x, tidy_fun = tidy_fun, !!!args)) |>+ data$variables[variables], |
| 56 | -1x | -
- dplyr::filter(!.data$stat_name %in% stats_to_remove)- |
- ||
| 57 | -- |
- }- |
-
| 1 | -+ | 67 | +5x |
- #' ARD Survey Chi-Square Test+ statistic = formals(asNamespace("cardx")[["ard_missing.survey.design"]])[["statistic"]] |> eval()
|
| 2 | +68 |
- #'+ ) |
||
| 3 | -+ | |||
| 69 | +5x |
- #' @description+ cards::fill_formula_selectors( |
||
| 4 | -+ | |||
| 70 | +5x |
- #' Analysis results data for survey Chi-Square test using [`survey::svychisq()`].+ data$variables[variables], |
||
| 5 | -+ | |||
| 71 | +5x |
- #' Only two-way comparisons are supported.+ stat_label = formals(asNamespace("cardx")[["ard_missing.survey.design"]])[["stat_label"]] |> eval()
|
||
| 6 | +72 |
- #'+ ) |
||
| 7 | +73 |
- #' @param data (`survey.design`)\cr+ |
||
| 8 | -+ | |||
| 74 | +5x |
- #' a survey design object often created with the {survey} package
+ stats_available <- c( |
||
| 9 | -+ | |||
| 75 | +5x |
- #' @param by ([`tidy-select`][dplyr::dplyr_tidy_select])\cr+ "N_obs", "N_miss", "N_nonmiss", "p_miss", "p_nonmiss", |
||
| 10 | -+ | |||
| 76 | +5x |
- #' column name to compare by.+ "N_obs_unweighted", "N_miss_unweighted", "N_nonmiss_unweighted", |
||
| 11 | -+ | |||
| 77 | +5x |
- #' @param variables ([`tidy-select`][dplyr::dplyr_tidy_select])\cr+ "p_miss_unweighted", "p_nonmiss_unweighted" |
||
| 12 | +78 |
- #' column names to be compared. Independent tests will be computed for+ ) |
||
| 13 | -+ | |||
| 79 | +5x |
- #' each variable.+ cards::check_list_elements( |
||
| 14 | -+ | |||
| 80 | +5x |
- #' @param statistic (`character`)\cr+ x = statistic, |
||
| 15 | -+ | |||
| 81 | +5x |
- #' statistic used to estimate Chisq p-value.+ predicate = \(x) is.character(x) && all(x %in% stats_available), |
||
| 16 | -+ | |||
| 82 | +5x |
- #' Default is the Rao-Scott second-order correction ("F"). See [`survey::svychisq`]
+ error_msg = "Elements passed in the {.arg statistic} argument must be one or more of {.val {stats_available}}"
|
||
| 17 | +83 |
- #' for available statistics options.+ ) |
||
| 18 | +84 |
- #' @param ... arguments passed to [`survey::svychisq()`].+ |
||
| 19 | +85 |
- #'+ # calculate results ---------------------------------------------------------- |
||
| 20 | -+ | |||
| 86 | +5x |
- #' @return ARD data frame+ result <- |
||
| 21 | -+ | |||
| 87 | +5x |
- #' @export+ ard_categorical( |
||
| 22 | -+ | |||
| 88 | +5x |
- #'+ data = data, |
||
| 23 | -+ | |||
| 89 | +5x |
- #' @examplesIf cards::is_pkg_installed(c("survey", "broom"), reference_pkg = "cardx")
+ variables = all_of(variables), |
||
| 24 | -+ | |||
| 90 | +5x |
- #' data(api, package = "survey")+ by = any_of(by), |
||
| 25 | -+ | |||
| 91 | +5x |
- #' dclus1 <- survey::svydesign(id = ~dnum, weights = ~pw, data = apiclus1, fpc = ~fpc)+ statistic = everything() ~ c("n", "N", "p", "n_unweighted", "N_unweighted", "p_unweighted")
|
||
| 26 | +92 |
- #'+ ) |
||
| 27 | +93 |
- #' ard_svychisq(dclus1, variables = sch.wide, by = comp.imp, statistic = "F")+ |
||
| 28 | +94 |
- ard_svychisq <- function(data, by, variables, statistic = "F", ...) {
+ # rename the stats for missingness ------------------------------------------- |
||
| 29 | -+ | |||
| 95 | +5x |
- # check installed packages ---------------------------------------------------+ result <- result |> |
||
| 30 | -2x | +96 | +5x |
- cards::check_pkg_installed(c("survey", "broom"), reference_pkg = "cardx")
+ dplyr::mutate( |
| 31 | -+ | |||
| 97 | +5x |
-
+ stat_name = |
||
| 32 | -+ | |||
| 98 | +5x |
- # check/process inputs -------------------------------------------------------+ dplyr::case_when( |
||
| 33 | -2x | +99 | +5x |
- check_not_missing(data)+ .data$stat_name %in% "N" ~ "N_obs", |
| 34 | -2x | +100 | +5x |
- check_not_missing(variables)+ .data$stat_name %in% "n" & .data$variable_level %in% FALSE ~ "N_miss", |
| 35 | -2x | +101 | +5x |
- check_not_missing(by)+ .data$stat_name %in% "n" & .data$variable_level %in% TRUE ~ "N_nonmiss", |
| 36 | -2x | +102 | +5x |
- check_class(data, cls = "survey.design")+ .data$stat_name %in% "p" & .data$variable_level %in% FALSE ~ "p_miss", |
| 37 | -2x | +103 | +5x |
- cards::process_selectors(data[["variables"]], by = {{ by }}, variables = {{ variables }})
+ .data$stat_name %in% "p" & .data$variable_level %in% TRUE ~ "p_nonmiss", |
| 38 | -2x | +104 | +5x |
- check_scalar(by)+ .data$stat_name %in% "N_unweighted" ~ "N_obs_unweighted", |
| 39 | -+ | |||
| 105 | +5x |
-
+ .data$stat_name %in% "n_unweighted" & .data$variable_level %in% FALSE ~ "N_miss_unweighted", |
||
| 40 | -+ | |||
| 106 | +5x |
- # if no variables selected, return empty tibble ------------------------------+ .data$stat_name %in% "n_unweighted" & .data$variable_level %in% TRUE ~ "N_nonmiss_unweighted", |
||
| 41 | -2x | +107 | +5x |
- if (is_empty(variables)) {
+ .data$stat_name %in% "p_unweighted" & .data$variable_level %in% FALSE ~ "p_miss_unweighted", |
| 42 | -! | +|||
| 108 | +5x |
- return(dplyr::tibble())+ .data$stat_name %in% "p_unweighted" & .data$variable_level %in% TRUE ~ "p_nonmiss_unweighted" |
||
| 43 | +109 |
- }+ ) |
||
| 44 | +110 |
- # build ARD ------------------------------------------------------------------+ ) |> |
||
| 45 | -2x | +111 | +5x |
- lapply(+ dplyr::select(-cards::all_ard_variables("levels"), -"stat_label", -"fmt_fn") |>
|
| 46 | -2x | +112 | +5x |
- variables,+ dplyr::slice(1L, .by = c(cards::all_ard_groups(), cards::all_ard_variables(), "stat_name")) |
| 47 | -2x | +|||
| 113 | +
- function(variable) {
+
|
|||
| 48 | -3x | +|||
| 114 | +
- cards::tidy_as_ard(+ # final processing of fmt_fn ------------------------------------------------- |
|||
| 49 | -3x | +115 | +5x |
- lst_tidy =+ result <- result |> |
| 50 | -3x | +116 | +5x |
- cards::eval_capture_conditions(+ .process_nested_list_as_df( |
| 51 | -3x | +117 | +5x |
- survey::svychisq(stats::reformulate(termlabels = paste(variable, by, sep = "+"), response = NULL), design = data, statistic = statistic, ...) |>+ arg = fmt_fn, |
| 52 | -3x | +118 | +5x |
- broom::tidy()+ new_column = "fmt_fn" |
| 53 | +119 |
- ),- |
- ||
| 54 | -3x | -
- tidy_result_names = c("statistic", "p.value", "ndf", "ddf", "method"),
- |
- ||
| 55 | -3x | -
- passed_args = dots_list(...),+ ) |> |
||
| 56 | -3x | +120 | +5x |
- lst_ard_columns = list(group1 = by, variable = variable, context = "svychisq")+ .default_svy_cat_fmt_fn() |
| 57 | +121 |
- ) |>+ |
||
| 58 | -3x | +|||
| 122 | +
- dplyr::mutate(+ # merge in statistic labels -------------------------------------------------- |
|||
| 59 | -3x | +123 | +5x |
- .after = "stat_name",+ result <- result |> |
| 60 | -3x | +124 | +5x |
- stat_label =+ .process_nested_list_as_df( |
| 61 | -3x | +125 | +5x |
- dplyr::case_when(+ arg = stat_label, |
| 62 | -3x | +126 | +5x |
- .data$stat_name %in% "statistic" ~ "Statistic",+ new_column = "stat_label", |
| 63 | -3x | +127 | +5x |
- .data$stat_name %in% "p.value" ~ "p-value",+ unlist = TRUE |
| 64 | -3x | +|||
| 128 | +
- .data$stat_name %in% "ndf" ~ "Nominator Degrees of Freedom",+ ) |> |
|||
| 65 | -3x | +129 | +5x |
- .data$stat_name %in% "ddf" ~ "Denominator Degrees of Freedom",+ dplyr::mutate(stat_label = dplyr::coalesce(.data$stat_label, .data$stat_name)) |
| 66 | -3x | +|||
| 130 | +
- TRUE ~ .data$stat_name,+ |
|||
| 67 | +131 |
- )+ # return final object -------------------------------------------------------- |
||
| 68 | -+ | |||
| 132 | +5x |
- )+ result |> |
||
| 69 | -+ | |||
| 133 | +5x |
- }+ dplyr::mutate(context = "missing") |> |
||
| 70 | -+ | |||
| 134 | +5x |
- ) |>+ cards::as_card() |> |
||
| 71 | -2x | +135 | +5x |
- dplyr::bind_rows()+ cards::tidy_ard_column_order() |
| 72 | +136 |
}@@ -15089,14 +44496,14 @@ cardx coverage - 95.63% |
| 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 cards::is_pkg_installed("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 | -2x | +
- UseMethod("ard_regression")
+ #' |
||
| 23 |
- }+ #' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = c("survey", "broom")))
|
|||
| 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 |
- # check installed packages ---------------------------------------------------+ ard_survey_svychisq <- function(data, by, variables, statistic = "F", ...) {
|
|||
| 29 | -2x | +6x |
- cards::check_pkg_installed("broom.helpers", reference_pkg = "cardx")
+ set_cli_abort_call() |
|
| 31 |
- # check inputs ---------------------------------------------------------------+ # check installed packages --------------------------------------------------- |
|||
| 32 | -2x | +6x |
- check_not_missing(x)+ check_pkg_installed(c("survey", "broom"))
|
|
| 34 |
- # summarize model ------------------------------------------------------------+ # check/process inputs ------------------------------------------------------- |
|||
| 35 | -2x | +6x |
- broom.helpers::tidy_plus_plus(+ check_not_missing(data) |
|
| 36 | -2x | +6x |
- model = x,+ check_not_missing(variables) |
|
| 37 | -2x | +6x |
- tidy_fun = tidy_fun,+ check_not_missing(by) |
|
| 38 | -+ | 6x |
- ...+ check_class(data, cls = "survey.design") |
|
| 39 | -+ | 6x |
- ) |>+ cards::process_selectors(data[["variables"]], by = {{ by }}, variables = {{ variables }})
|
|
| 40 | -2x | +6x |
- dplyr::mutate(+ check_scalar(by) |
|
| 41 | -2x | +
- variable_level = dplyr::if_else(.data$var_type %in% "continuous", NA_character_, .data$label),+ |
||
| 42 | -2x | +
- dplyr::across(-c("variable", "variable_level"), .fns = as.list)
+ # return empty ARD if no variables selected ---------------------------------- |
||
| 43 | -+ | 6x |
- ) |>+ if (is_empty(variables)) {
|
|
| 44 | -2x | +! |
- tidyr::pivot_longer(+ return(dplyr::tibble() |> cards::as_card()) |
|
| 45 | -2x | +
- cols = -c("variable", "variable_level"),
+ } |
||
| 46 | -2x | +
- names_to = "stat_name",+ |
||
| 47 | -2x | +
- values_to = "stat"+ # build ARD ------------------------------------------------------------------ |
||
| 48 | -+ | 6x |
- ) |>+ lapply( |
|
| 49 | -2x | +6x |
- dplyr::filter(map_lgl(.data$stat, Negate(is.na))) |>+ variables, |
|
| 50 | -2x | +6x |
- dplyr::mutate(+ function(variable) {
|
|
| 51 | -2x | +8x |
- fmt_fn =+ cards::tidy_as_ard( |
|
| 52 | -2x | +8x |
- lapply(+ lst_tidy = |
|
| 53 | -2x | +8x |
- .data$stat,+ cards::eval_capture_conditions( |
|
| 54 | -2x | +8x |
- function(x) {
+ survey::svychisq(reformulate2(termlabels = c(variable, by)), design = data, statistic = statistic, ...) |> |
|
| 55 | -71x | +8x |
- switch(is.integer(x), 0L) %||% # styler: off+ broom::tidy() |
|
| 56 | -71x | +
- switch(is.numeric(x), 1L) # styler: off+ ), |
||
| 57 | -+ | 8x |
- }+ tidy_result_names = c("statistic", "p.value", "ndf", "ddf", "method"),
|
|
| 58 | -+ | 8x |
- ),+ passed_args = dots_list(...), |
|
| 59 | -2x | +8x |
- context = "regression",+ lst_ard_columns = list(group1 = by, variable = variable, context = "survey_svychisq") |
|
| 60 | -2x | +
- stat_label =+ ) |> |
||
| 61 | -2x | +8x |
- dplyr::case_when(+ dplyr::mutate( |
|
| 62 | -2x | +8x |
- .data$stat_name %in% "var_label" ~ "Label",+ .after = "stat_name", |
|
| 63 | -2x | +8x |
- .data$stat_name %in% "var_class" ~ "Class",+ stat_label = |
|
| 64 | -2x | +8x |
- .data$stat_name %in% "var_type" ~ "Type",+ dplyr::case_when( |
|
| 65 | -2x | +8x |
- .data$stat_name %in% "var_nlevels" ~ "N Levels",+ .data$stat_name %in% "statistic" ~ "Statistic", |
|
| 66 | -2x | +8x |
- .data$stat_name %in% "contrasts_type" ~ "Contrast Type",+ .data$stat_name %in% "p.value" ~ "p-value", |
|
| 67 | -2x | +8x |
- .data$stat_name %in% "label" ~ "Level Label",+ .data$stat_name %in% "ndf" ~ "Nominator Degrees of Freedom", |
|
| 68 | -2x | +8x |
- .data$stat_name %in% "n_obs" ~ "N Obs.",+ .data$stat_name %in% "ddf" ~ "Denominator Degrees of Freedom", |
|
| 69 | -2x | +8x |
- .data$stat_name %in% "n_event" ~ "N Events",+ TRUE ~ .data$stat_name, |
|
| 70 | -2x | +
- .data$stat_name %in% "exposure" ~ "Exposure Time",+ ) |
||
| 71 | -2x | -
- .data$stat_name %in% "estimate" ~ "Coefficient",- |
- ||
| 72 | -2x | -
- .data$stat_name %in% "std.error" ~ "Standard Error",- |
- ||
| 73 | -2x | -
- .data$stat_name %in% "p.value" ~ "p-value",- |
- ||
| 74 | -2x | -
- .data$stat_name %in% "conf.low" ~ "CI Lower Bound",- |
- ||
| 75 | -2x | -
- .data$stat_name %in% "conf.high" ~ "CI Upper Bound",- |
- ||
| 76 | -2x | +
- TRUE ~ .data$stat_name+ ) |
||
| 77 | +72 |
- )+ } |
||
| 78 | +73 |
- ) |>+ ) |> |
||
| 79 | -2x | +74 | +6x |
- cards::tidy_ard_column_order() %>%+ dplyr::bind_rows() |> |
| 80 | -2x | +75 | +6x |
- {structure(., class = c("card", class(.)))} # styler: off
+ cards::as_card() |
| 81 | +76 |
}@@ -15662,14 +45034,14 @@ cardx coverage - 95.63% |
| 1 |
- #' ARD Standardized Mean Difference+ #' ARD Attributes |
||
| 4 |
- #' Standardized mean difference calculated via [`smd::smd()`] with `na.rm = TRUE`.+ #' Add variable attributes to an ARD data frame. |
||
| 5 |
- #'+ #' - The `label` attribute will be added for all columns, and when no label |
||
| 6 |
- #' @param data (`data.frame`)\cr+ #' is specified and no label has been set for a column using the `label=` argument, |
||
| 7 |
- #' a data frame.+ #' the column name will be placed in the label statistic. |
||
| 8 |
- #' @param by ([`tidy-select`][dplyr::dplyr_tidy_select])\cr+ #' - The `class` attribute will also be returned for all columns. |
||
| 9 |
- #' column name to compare by+ #' - Any other attribute returned by `attributes()` will also be added, e.g. factor levels. |
||
| 10 |
- #' @param variable ([`tidy-select`][dplyr::dplyr_tidy_select])\cr+ #' |
||
| 11 |
- #' column name to be compared.+ #' @rdname ard_attributes |
||
| 12 |
- #' @inheritDotParams smd::smd -x -g -w -na.rm+ #' @param data (`survey.design`)\cr |
||
| 13 |
- #'+ #' a design object often created with [`survey::svydesign()`]. |
||
| 14 |
- #' @return ARD data frame+ #' @param variables ([`tidy-select`][dplyr::dplyr_tidy_select])\cr |
||
| 15 |
- #' @export+ #' variables to include |
||
| 16 |
- #'+ #' @param label (named `list`)\cr |
||
| 17 |
- #' @examplesIf cards::is_pkg_installed("smd", reference_pkg = "cardx")
+ #' named list of variable labels, e.g. `list(cyl = "No. Cylinders")`. |
||
| 18 |
- #' ard_smd(cards::ADSL, by = ARM, variable = AGE, std.error = TRUE)+ #' Default is `NULL` |
||
| 19 |
- #' ard_smd(cards::ADSL, by = ARM, variable = AGEGR1, std.error = TRUE)+ #' @inheritParams rlang::args_dots_empty |
||
| 20 |
- ard_smd <- function(data, by, variable, ...) {
+ #' |
||
| 21 |
- # check installed packages ---------------------------------------------------+ #' @return an ARD data frame of class 'card' |
||
| 22 | -2x | +
- cards::check_pkg_installed("smd", reference_pkg = "cardx")
+ #' @export |
|
| 23 |
-
+ #' |
||
| 24 |
- # check/process inputs -------------------------------------------------------+ #' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = "survey"))
|
||
| 25 | -2x | +
- check_not_missing(data)+ #' data(api, package = "survey") |
|
| 26 | -2x | +
- check_not_missing(variable)+ #' dclus1 <- survey::svydesign(id = ~dnum, weights = ~pw, data = apiclus1, fpc = ~fpc) |
|
| 27 | -2x | +
- check_not_missing(by)+ #' |
|
| 28 | -2x | +
- check_data_frame(data)+ #' ard_attributes( |
|
| 29 | -2x | +
- data <- dplyr::ungroup(data)+ #' data = dclus1, |
|
| 30 | -2x | +
- cards::process_selectors(data, by = {{ by }}, variable = {{ variable }})
+ #' variables = c(sname, dname), |
|
| 31 | -2x | +
- check_scalar(by)+ #' label = list(sname = "School Name", dname = "District Name") |
|
| 32 | -2x | +
- check_scalar(variable)+ #' ) |
|
| 33 |
-
+ ard_attributes.survey.design <- function(data, variables = everything(), label = NULL, ...) {
|
||
| 34 | -+ | 1x |
- # build ARD ------------------------------------------------------------------+ set_cli_abort_call() |
| 35 | -2x | +
- .format_smd_results(+ |
|
| 36 | -2x | +1x |
- by = by,+ cards::ard_attributes(data = data[["variables"]], variables = {{ variables }}, label = label, ...)
|
| 37 | -2x | -
- variable = variable,- |
- |
| 38 | -2x | -
- lst_tidy =- |
- |
| 39 | -2x | +
- cards::eval_capture_conditions(+ } |
|
| 40 | -2x | +
| 1 | +
- smd::smd(x = data[[variable]], g = data[[by]], na.rm = TRUE, ...) |>+ #' ARD Total N |
||
| 41 | -2x | +||
| 2 | +
- dplyr::select(-any_of("term"))
+ #' |
||
| 42 | +3 |
- ),+ #' Returns the total N for a survey object. |
|
| 43 | +4 |
- ...+ #' The placeholder variable name returned in the object is `"..ard_total_n.."` |
|
| 44 | +5 |
- )+ #' |
|
| 45 | +6 |
- }+ #' @inheritParams ard_dichotomous.survey.design |
|
| 46 | +7 |
-
+ #' @inheritParams rlang::args_dots_empty |
|
| 47 | +8 |
-
+ #' |
|
| 48 | +9 |
- .format_smd_results <- function(by, variable, lst_tidy, ...) {
+ #' @return an ARD data frame of class 'card' |
|
| 49 | +10 |
- # build ARD ------------------------------------------------------------------+ #' @export |
|
| 50 | -2x | +||
| 11 | +
- ret <-+ #' |
||
| 51 | -2x | +||
| 12 | +
- cards::tidy_as_ard(+ #' @examplesIf cardx:::is_pkg_installed("survey")
|
||
| 52 | -2x | +||
| 13 | +
- lst_tidy = lst_tidy,+ #' svy_titanic <- survey::svydesign(~1, data = as.data.frame(Titanic), weights = ~Freq) |
||
| 53 | -2x | +||
| 14 | +
- tidy_result_names = c("estimate", "std.error"),
+ #' |
||
| 54 | -2x | +||
| 15 | +
- fun_args_to_record = "gref",+ #' ard_total_n(svy_titanic) |
||
| 55 | -2x | +||
| 16 | +
- formals = formals(smd::smd)["gref"],+ ard_total_n.survey.design <- function(data, ...) {
|
||
| 56 | +17 |
- # removing the `std.error` ARGUMENT (not the result)+ # process inputs ------------------------------------------------------------- |
|
| 57 | +18 | 2x |
- passed_args = dots_list(...) |> utils::modifyList(list(std.error = NULL)),+ set_cli_abort_call() |
| 58 | +19 | 2x |
- lst_ard_columns = list(group1 = by, variable = variable, context = "smd")- |
-
| 59 | -- |
- )+ check_dots_empty() |
|
| 60 | +20 | ||
| 61 | +21 |
- # add the stat label ---------------------------------------------------------+ # calculate total N ---------------------------------------------------------- |
|
| 62 | +22 | 2x |
- ret |>+ data$variables <- |
| 63 | +23 | 2x |
- dplyr::left_join(+ data$variables |> |
| 64 | +24 | 2x |
- dplyr::tribble(+ dplyr::mutate(..ard_total_n.. = TRUE) |
| 65 | -2x | +||
| 25 | +
- ~stat_name, ~stat_label,+ |
||
| 66 | +26 | 2x |
- "estimate", "Standardized Mean Difference",+ data |> |
| 67 | +27 | 2x |
- "std.error", "Standard Error",+ ard_dichotomous( |
| 68 | +28 | 2x |
- "gref", "Integer Reference Group Level"- |
-
| 69 | -- |
- ),+ variables = "..ard_total_n..", |
|
| 70 | +29 | 2x |
- by = "stat_name"+ statistic = list(..ard_total_n.. = c("N", "N_unweighted"))
|
| 71 | +30 |
) |> |
|
| 72 | +31 | 2x |
- dplyr::mutate(stat_label = dplyr::coalesce(.data$stat_label, .data$stat_name)) |>+ dplyr::mutate(context = "total_n") |> |
| 73 | +32 | 2x |
- cards::tidy_ard_column_order()+ dplyr::select(-cards::all_ard_variables("levels"))
|
| 74 | +33 |
}diff --git a/coverage-report/lib/datatables-binding-0.32/datatables.js b/coverage-report/lib/datatables-binding-0.33/datatables.js similarity index 99% rename from coverage-report/lib/datatables-binding-0.32/datatables.js rename to coverage-report/lib/datatables-binding-0.33/datatables.js index 6a3c3d5cb..765b53cb1 100644 --- a/coverage-report/lib/datatables-binding-0.32/datatables.js +++ b/coverage-report/lib/datatables-binding-0.33/datatables.js @@ -1032,6 +1032,9 @@ HTMLWidgets.widget({ updateColsSelected(); updateCellsSelected(); }) + updateRowsSelected(); + updateColsSelected(); + updateCellsSelected(); } var selMode = data.selection.mode, selTarget = data.selection.target; diff --git a/coverage-report/lib/htmltools-fill-0.5.8.1/fill.css b/coverage-report/lib/htmltools-fill-0.5.8.1/fill.css new file mode 100644 index 000000000..841ea9d59 --- /dev/null +++ b/coverage-report/lib/htmltools-fill-0.5.8.1/fill.css @@ -0,0 +1,21 @@ +@layer htmltools { + .html-fill-container { + display: flex; + flex-direction: column; + /* Prevent the container from expanding vertically or horizontally beyond its + parent's constraints. */ + min-height: 0; + min-width: 0; + } + .html-fill-container > .html-fill-item { + /* Fill items can grow and shrink freely within + available vertical space in fillable container */ + flex: 1 1 auto; + min-height: 0; + min-width: 0; + } + .html-fill-container > :not(.html-fill-item) { + /* Prevent shrinking or growing of non-fill items */ + flex: 0 0 auto; + } +} |