| 1 |
- #' Construction Helpers+ #' ARD 2-sample proportion test |
||
| 3 |
- #' These functions help construct calls to various types of models.+ #' @description |
||
| 4 |
- #'+ #' Analysis results data for a 2-sample test or proportions using [`stats::prop.test()`]. |
||
| 5 |
- #' - `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+ #' @param data (`data.frame`)\cr |
||
| 7 |
- #' when the model is evaluated.+ #' a data frame. |
||
| 8 |
- #'+ #' @param by ([`tidy-select`][dplyr::dplyr_tidy_select])\cr |
||
| 9 |
- #' - `reformulate2()`: This is a copy of `reformulate()` except that variable+ #' column name to compare by |
||
| 10 |
- #' names that contain a space are wrapped in backticks.+ #' @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 |
- #' - `bt()`: Adds backticks to a character vector.+ #' or `1`/`0`. Independent tests will be computed for each variable. |
||
| 13 |
- #'+ #' @param ... arguments passed to `prop.test(...)` |
||
| 14 |
- #' - `bt_strip()`: Removes backticks from a string if it begins and ends with a backtick.+ #' |
||
| 15 |
- #'+ #' @return ARD data frame |
||
| 16 |
- #' @param x (`data.frame`)\cr+ #' @export |
||
| 17 |
- #' a data frame+ #' |
||
| 18 |
- #' @param formula (`formula`)\cr+ #' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = "broom", reference_pkg = "cardx"))
|
||
| 19 |
- #' a formula+ #' mtcars |> |
||
| 20 |
- #' @param method (`string`)\cr+ #' ard_stats_prop_test(by = vs, variables = am) |
||
| 21 |
- #' string naming the function to be called, e.g. `"glm"`.+ ard_stats_prop_test <- function(data, by, variables, ...) {
|
||
| 22 | -+ | 5x |
- #' If function belongs to a library that is not attached, the package name+ set_cli_abort_call() |
| 23 |
- #' must be specified in the `package` argument.+ |
||
| 24 |
- #' @param method.args (named `list`)\cr+ # check installed packages --------------------------------------------------- |
||
| 25 | -+ | 5x |
- #' named list of arguments that will be passed to `fn`.+ check_pkg_installed(pkg = "broom", reference_pkg = "cardx") |
| 26 |
- #' @param package (`string`)\cr+ |
||
| 27 |
- #' string of package name that will be temporarily loaded when function+ # check inputs --------------------------------------------------------------- |
||
| 28 | -+ | 5x |
- #' specified in `method` is executed.+ check_not_missing(data) |
| 29 | -+ | 5x |
- #' @param x (`character`)\cr+ check_not_missing(variables) |
| 30 | -+ | 5x |
- #' character vector, typically of variable names+ check_not_missing(by) |
| 31 | -+ | 5x |
- #' @param pattern (`string`)\cr+ check_data_frame(data) |
| 32 |
- #' regular expression string. If the regex matches, backticks are added+ |
||
| 33 |
- #' to the string. When `NULL`, backticks are not added.+ # process inputs ------------------------------------------------------------- |
||
| 34 | -+ | 5x |
- #' @param pattern_term,pattern_response passed to `bt(pattern)` for arguments+ cards::process_selectors(data, by = {{ by }}, variables = {{ variables }})
|
| 35 | -+ | 5x |
- #' `stats::reformulate(termlabels, response)`.+ check_scalar(by) |
| 36 | -+ | 5x |
- #' @inheritParams rlang::eval_tidy+ data <- data[c(by, variables)] |> dplyr::ungroup() |> tidyr::drop_na() # styler: off |
| 37 |
- #' @inheritParams stats::reformulate+ |
||
| 38 |
- #' @inheritParams rlang::args_dots_empty+ # if no variables selected, return empty tibble ------------------------------ |
||
| 39 | -+ | 5x |
- #'+ if (is_empty(variables)) {
|
| 40 | -+ | ! |
- #' @return depends on the calling function+ return(dplyr::tibble()) |
| 41 |
- #' @name construction_helpers+ } |
||
| 42 |
- #'+ |
||
| 43 |
- #' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = c("withr", "lme4"), reference_pkg = "cardx"))
+ # build ARD ------------------------------------------------------------------ |
||
| 44 | -+ | 5x |
- #' construct_model(+ lapply( |
| 45 | -+ | 5x |
- #' x = mtcars,+ variables, |
| 46 | -+ | 5x |
- #' formula = am ~ mpg + (1 | vs),+ function(variable) {
|
| 47 | -+ | 6x |
- #' method = "glmer",+ .format_proptest_results( |
| 48 | -+ | 6x |
- #' method.args = list(family = binomial),+ by = by, |
| 49 | -+ | 6x |
- #' package = "lme4"+ variable = variable, |
| 50 | -+ | 6x |
- #' )+ lst_tidy = |
| 51 | -+ | 6x |
- #'+ cards::eval_capture_conditions({
|
| 52 | -+ | 6x |
- #' construct_model(+ check_binary(data[[variable]], arg_name = "variable") |
| 53 |
- #' x = mtcars |> dplyr::rename(`M P G` = mpg),+ |
||
| 54 | -+ | 3x |
- #' formula = reformulate2(c("M P G", "cyl"), response = "hp"),
+ data_counts <- |
| 55 | -+ | 3x |
- #' method = "lm"+ dplyr::arrange(data, .data[[by]]) |> |
| 56 | -+ | 3x |
- #' ) |>+ dplyr::summarise( |
| 57 | -+ | 3x |
- #' ard_regression() |>+ .by = all_of(by), |
| 58 | -+ | 3x |
- #' dplyr::filter(stat_name %in% c("term", "estimate", "p.value"))
+ x = sum(.data[[variable]]), |
| 59 | -+ | 3x |
- NULL+ n = length(.data[[variable]]) |
| 60 |
-
+ ) |
||
| 61 |
- #' @rdname construction_helpers+ |
||
| 62 | -+ | 3x |
- #' @export+ if (nrow(data_counts) != 2) {
|
| 63 | -+ | 1x |
- construct_model <- function(x, ...) {
+ cli::cli_abort( |
| 64 | -12x | +1x |
- UseMethod("construct_model")
+ c( |
| 65 | -+ | 1x |
- }+ "The {.arg by} column must have exactly 2 levels.",
|
| 66 | -+ | 1x |
-
+ "The levels are {.val {data_counts[[by]]}}"
|
| 67 |
- #' @rdname construction_helpers+ ), |
||
| 68 | -+ | 1x |
- #' @export+ call = get_cli_abort_call() |
| 69 |
- construct_model.data.frame <- function(x, formula, method, method.args = list(), package = "base", env = caller_env(), ...) {
+ ) |
||
| 70 | -12x | +
- set_cli_abort_call()+ } |
|
| 71 |
- # check pkg installations ----------------------------------------------------+ |
||
| 72 | -12x | +2x |
- check_dots_empty()+ stats::prop.test( |
| 73 | -12x | +2x |
- check_pkg_installed(c("withr", package), reference_pkg = "cardx")
+ x = data_counts[["x"]], |
| 74 | -+ | 2x |
-
+ n = data_counts[["n"]], |
| 75 | -12x | +
- check_not_missing(formula)+ ... |
|
| 76 | -12x | +
- check_class(formula, cls = "formula")+ ) |> |
|
| 77 | -+ | 2x |
-
+ broom::tidy() |> |
| 78 | -12x | +
- check_not_missing(method)+ # add central estimate for difference |
|
| 79 | -12x | +2x |
- check_string(method)+ dplyr::mutate(estimate = .data$estimate1 - .data$estimate2, .before = 1L) |
| 80 | -12x | +
- check_not_namespaced(method)+ }), |
|
| 81 |
-
+ ... |
||
| 82 |
- # convert method.args to list of expressions (to account for NSE inputs) -----+ ) |
||
| 83 | -11x | +
- method.args <- call_args(enexpr(method.args))+ } |
|
| 84 |
-
+ ) |> |
||
| 85 | -+ | 5x |
- # build model ----------------------------------------------------------------+ dplyr::bind_rows() |
| 86 | -11x | +
- withr::with_namespace(+ } |
|
| 87 | -11x | +
- package = package,+ |
|
| 88 | -11x | +
- call2(.fn = method, formula = formula, data = x, !!!method.args) |>+ |
|
| 89 | -11x | +
- eval_tidy(env = env)+ #' Convert prop.test to ARD |
|
| 90 |
- )+ #' |
||
| 91 |
- }+ #' @inheritParams cards::tidy_as_ard |
||
| 92 |
-
+ #' @param by (`string`)\cr by column name |
||
| 93 |
- #' @rdname construction_helpers+ #' @param variable (`string`)\cr variable column name |
||
| 94 |
- #' @export+ #' @param ... passed to `prop.test(...)` |
||
| 95 |
- reformulate2 <- function(termlabels, response = NULL, intercept = TRUE,+ #' |
||
| 96 |
- pattern_term = "[ \n\r]", pattern_response = "[ \n\r]",+ #' @return ARD data frame |
||
| 97 |
- env = parent.frame()) {
+ #' @keywords internal |
||
| 98 | -4x | +
- stats::reformulate(+ .format_proptest_results <- function(by, variable, lst_tidy, ...) {
|
|
| 99 | -4x | +
- termlabels = bt(termlabels, pattern_term),+ # build ARD ------------------------------------------------------------------ |
|
| 100 | -4x | +6x |
- response = bt(response, pattern_response),+ ret <- |
| 101 | -4x | +6x |
- intercept = intercept,+ cards::tidy_as_ard( |
| 102 | -4x | +6x |
- env = env+ lst_tidy = lst_tidy, |
| 103 | -+ | 6x |
- )+ tidy_result_names = c( |
| 104 | -+ | 6x |
- }+ "estimate", "estimate1", "estimate2", "statistic", |
| 105 | -+ | 6x |
-
+ "p.value", "parameter", "conf.low", "conf.high", |
| 106 | -+ | 6x |
- #' @rdname construction_helpers+ "method", "alternative" |
| 107 |
- #' @export+ ), |
||
| 108 | -+ | 6x |
- bt <- function(x, pattern = "[ \n\r]") {
+ fun_args_to_record = c("p", "conf.level", "correct"),
|
| 109 | -8x | +6x |
- if (is_empty(x)) {
+ formals = formals(stats::prop.test), |
| 110 | -3x | +6x |
- return(x)+ passed_args = dots_list(...), |
| 111 | -+ | 6x |
- }+ lst_ard_columns = list(group1 = by, variable = variable, context = "stats_prop_test") |
| 112 | -5x | +
- if (is_empty(pattern)) {
+ ) |
|
| 113 | -! | +
- return(x)+ |
|
| 114 |
- }+ # add the stat label --------------------------------------------------------- |
||
| 115 | -5x | +6x |
- ifelse(+ ret |> |
| 116 | -5x | +6x |
- str_detect(x, pattern = pattern),+ dplyr::left_join( |
| 117 | -5x | +6x |
- paste0("`", x, "`"),
+ .df_proptest_stat_labels(), |
| 118 | -5x | +6x |
- x+ by = "stat_name" |
| 119 |
- )+ ) |> |
||
| 120 | -+ | 6x |
- }+ dplyr::mutate(stat_label = dplyr::coalesce(.data$stat_label, .data$stat_name)) |> |
| 121 | -+ | 6x |
-
+ cards::tidy_ard_column_order() |
| 122 |
- #' @rdname construction_helpers+ } |
||
| 123 |
- #' @export+ |
||
| 124 |
- bt_strip <- function(x) {
+ .df_proptest_stat_labels <- function() {
|
||
| 125 | -! | +6x |
- ifelse(+ dplyr::tribble( |
| 126 | -! | +6x |
- str_detect(x, "^`.*`$"),+ ~stat_name, ~stat_label, |
| 127 | -! | +6x |
- substr(x, 2, nchar(x) - 1),+ "estimate1", "Group 1 Rate", |
| 128 | -! | +6x |
- x+ "estimate2", "Group 2 Rate", |
| 129 | -+ | 6x |
- )+ "estimate", "Rate Difference", |
| 130 | -+ | 6x |
- }+ "p.value", "p-value", |
| 131 | -+ | 6x |
-
+ "statistic", "X-squared Statistic", |
| 132 | -+ | 6x |
- check_not_namespaced <- function(x,+ "parameter", "Degrees of Freedom", |
| 133 | -+ | 6x |
- arg_name = rlang::caller_arg(x),+ "conf.low", "CI Lower Bound", |
| 134 | -+ | 6x |
- class = "check_not_namespaced",+ "conf.high", "CI Upper Bound", |
| 135 | -+ | 6x |
- call = get_cli_abort_call()) {
+ "conf.level", "CI Confidence Level", |
| 136 | -12x | +6x |
- check_string(x, arg_name = arg_name, call = call, class = "check_not_namespaced")+ "correct", "Yates' continuity correction", |
| 137 | - - | -||
| 138 | -12x | -
- if (str_detect(x, "::")) {
- |
- |
| 139 | -1x | -
- c("Argument {.arg {arg_name}} cannot be namespaced.",
- |
- |
| 140 | -1x | -
- i = "Put the package name in the {.arg package} argument."
- |
- |
| 141 | -- |
- ) |>- |
- |
| 142 | -1x | -
- cli::cli_abort(call = call, class = class)- |
- |
| 143 | -- |
- }- |
- |
| 144 | -- | - - | -|
| 145 | -11x | -
- invisible(x)+ ) |
|
| 146 | +138 |
}@@ -1140,14 +1084,14 @@ cardx coverage - 95.93% |
| 1 |
- #' ARD 2-sample proportion test+ #' ARD Cohen's D Test |
||
| 4 |
- #' Analysis results data for a 2-sample test or proportions using [`stats::prop.test()`].+ #' Analysis results data for paired and non-paired Cohen's D Effect Size Test |
||
| 5 |
- #'+ #' using [`effectsize::cohens_d()`]. |
||
| 6 |
- #' @param data (`data.frame`)\cr+ #' |
||
| 7 |
- #' a data frame.+ #' @param data (`data.frame`)\cr |
||
| 8 |
- #' @param by ([`tidy-select`][dplyr::dplyr_tidy_select])\cr+ #' a data frame. See below for details. |
||
| 9 |
- #' column name to compare by+ #' @param by ([`tidy-select`][dplyr::dplyr_tidy_select])\cr |
||
| 10 |
- #' @param variables ([`tidy-select`][dplyr::dplyr_tidy_select])\cr+ #' column name to compare by. Must be a categorical variable with exactly two levels. |
||
| 11 |
- #' column names to be compared. Must be a binary column coded as `TRUE`/`FALSE`+ #' @param variables ([`tidy-select`][dplyr::dplyr_tidy_select])\cr |
||
| 12 |
- #' or `1`/`0`. Independent tests will be computed for each variable.+ #' column names to be compared. Must be a continuous variables. |
||
| 13 |
- #' @param ... arguments passed to `prop.test(...)`+ #' Independent tests will be run for each variable. |
||
| 14 |
- #'+ #' @param id ([`tidy-select`][dplyr::dplyr_tidy_select])\cr |
||
| 15 |
- #' @return ARD data frame+ #' column name of the subject or participant ID |
||
| 16 |
- #' @export+ #' @param ... arguments passed to `effectsize::cohens_d(...)` |
||
| 18 |
- #' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = "broom", reference_pkg = "cardx"))
+ #' @return ARD data frame |
||
| 19 |
- #' mtcars |>+ #' @name ard_effectsize_cohens_d |
||
| 20 |
- #' ard_stats_prop_test(by = vs, variables = am)+ #' |
||
| 21 |
- ard_stats_prop_test <- function(data, by, variables, ...) {
+ #' @details |
||
| 22 | -5x | +
- set_cli_abort_call()+ #' For the `ard_effectsize_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, ...)`. |
||
| 24 |
- # check installed packages ---------------------------------------------------+ #' |
||
| 25 | -5x | +
- check_pkg_installed(pkg = "broom", reference_pkg = "cardx")+ #' For the `ard_effectsize_paired_cohens_d()` function, the data is expected to be one row |
|
| 26 |
-
+ #' per subject per by level. Before the effect size is calculated, the data are |
||
| 27 |
- # check inputs ---------------------------------------------------------------+ #' reshaped to a wide format to be one row per subject. |
||
| 28 | -5x | +
- check_not_missing(data)+ #' The data are then passed as |
|
| 29 | -5x | +
- check_not_missing(variables)+ #' `effectsize::cohens_d(x = data_wide[[<by level 1>]], y = data_wide[[<by level 2>]], paired = TRUE, ...)`. |
|
| 30 | -5x | +
- check_not_missing(by)+ #' |
|
| 31 | -5x | +
- check_data_frame(data)+ #' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = c("effectsize", "parameters"), reference_pkg = "cardx"))
|
|
| 32 |
-
+ #' cards::ADSL |> |
||
| 33 |
- # process inputs -------------------------------------------------------------+ #' dplyr::filter(ARM %in% c("Placebo", "Xanomeline High Dose")) |>
|
||
| 34 | -5x | +
- cards::process_selectors(data, by = {{ by }}, variables = {{ variables }})
+ #' ard_effectsize_cohens_d(by = ARM, variables = AGE) |
|
| 35 | -5x | +
- check_scalar(by)+ #' |
|
| 36 | -5x | +
- data <- data[c(by, variables)] |> dplyr::ungroup() |> tidyr::drop_na() # styler: off+ #' # constructing a paired data set, |
|
| 37 |
-
+ #' # where patients receive both treatments |
||
| 38 |
- # if no variables selected, return empty tibble ------------------------------+ #' cards::ADSL[c("ARM", "AGE")] |>
|
||
| 39 | -5x | +
- if (is_empty(variables)) {
+ #' dplyr::filter(ARM %in% c("Placebo", "Xanomeline High Dose")) |>
|
|
| 40 | -! | +
- return(dplyr::tibble())+ #' dplyr::mutate(.by = ARM, USUBJID = dplyr::row_number()) |> |
|
| 41 |
- }+ #' dplyr::arrange(USUBJID, ARM) |> |
||
| 42 |
-
+ #' dplyr::group_by(USUBJID) |> |
||
| 43 |
- # build ARD ------------------------------------------------------------------+ #' dplyr::filter(dplyr::n() > 1) |> |
||
| 44 | -5x | +
- lapply(+ #' ard_effectsize_paired_cohens_d(by = ARM, variables = AGE, id = USUBJID) |
|
| 45 | -5x | +
- variables,+ NULL |
|
| 46 | -5x | +
- function(variable) {
+
|
|
| 47 | -6x | +
- .format_proptest_results(+ #' @rdname ard_effectsize_cohens_d |
|
| 48 | -6x | +
- by = by,+ #' @export |
|
| 49 | -6x | +
- variable = variable,+ ard_effectsize_cohens_d <- function(data, by, variables, ...) {
|
|
| 50 | -6x | +2x |
- lst_tidy =+ set_cli_abort_call() |
| 51 | -6x | +
- cards::eval_capture_conditions({
+
|
|
| 52 | -6x | +
- check_binary(data[[variable]], arg_name = "variable")+ # check installed packages --------------------------------------------------- |
|
| 53 | -+ | 2x |
-
+ check_pkg_installed(c("effectsize", "parameters"), reference_pkg = "cardx")
|
| 54 | -3x | +
- data_counts <-+ |
|
| 55 | -3x | +
- dplyr::arrange(data, .data[[by]]) |>+ # check/process inputs ------------------------------------------------------- |
|
| 56 | -3x | +2x |
- dplyr::summarise(+ check_not_missing(data) |
| 57 | -3x | +2x |
- .by = all_of(by),+ check_not_missing(variables) |
| 58 | -3x | +2x |
- x = sum(.data[[variable]]),+ check_not_missing(by) |
| 59 | -3x | +2x |
- n = length(.data[[variable]])+ check_data_frame(data) |
| 60 | -+ | 2x |
- )+ data <- dplyr::ungroup(data) |
| 61 | -+ | 2x |
-
+ cards::process_selectors(data, by = {{ by }}, variables = {{ variables }})
|
| 62 | -3x | +2x |
- if (nrow(data_counts) != 2) {
+ check_scalar(by) |
| 63 | -1x | +
- cli::cli_abort(+ |
|
| 64 | -1x | +
- c(+ # if no variables selected, return empty tibble ------------------------------ |
|
| 65 | -1x | +2x |
- "The {.arg by} column must have exactly 2 levels.",
+ if (is_empty(variables)) {
|
| 66 | -1x | +! |
- "The levels are {.val {data_counts[[by]]}}"
+ return(dplyr::tibble()) |
| 67 |
- ),+ } |
||
| 68 | -1x | +
- call = get_cli_abort_call()+ |
|
| 69 |
- )+ # build ARD ------------------------------------------------------------------ |
||
| 70 | -+ | 2x |
- }+ lapply( |
| 71 | -+ | 2x |
-
+ variables, |
| 72 | 2x |
- stats::prop.test(+ function(variable) {
|
|
| 73 | 2x |
- x = data_counts[["x"]],+ .format_cohens_d_results( |
|
| 74 | 2x |
- n = data_counts[["n"]],+ by = by, |
|
| 75 | -+ | 2x |
- ...+ variable = variable, |
| 76 | -+ | 2x |
- ) |>+ lst_tidy = |
| 77 | 2x |
- broom::tidy() |>+ cards::eval_capture_conditions( |
|
| 78 | -+ | 2x |
- # add central estimate for difference+ effectsize::cohens_d(data[[variable]] ~ data[[by]], data = data, paired = FALSE, ...) |> |
| 79 | 2x |
- dplyr::mutate(estimate = .data$estimate1 - .data$estimate2, .before = 1L)+ parameters::standardize_names(style = "broom") |
|
| 80 |
- }),+ ), |
||
| 81 | -+ | 2x |
- ...+ paired = FALSE, |
| 82 |
- )+ ... |
||
| 83 |
- }+ ) |
||
| 84 |
- ) |>+ } |
||
| 85 | -5x | +
- dplyr::bind_rows()+ ) |> |
|
| 86 | -+ | 2x |
- }+ dplyr::bind_rows() |
| 87 |
-
+ } |
||
| 89 |
- #' Convert prop.test to ARD+ |
||
| 90 |
- #'+ #' @rdname ard_effectsize_cohens_d |
||
| 91 |
- #' @inheritParams cards::tidy_as_ard+ #' @export |
||
| 92 |
- #' @param by (`string`)\cr by column name+ ard_effectsize_paired_cohens_d <- function(data, by, variables, id, ...) {
|
||
| 93 | -+ | 2x |
- #' @param variable (`string`)\cr variable column name+ set_cli_abort_call() |
| 94 |
- #' @param ... passed to `prop.test(...)`+ |
||
| 95 |
- #'+ # check installed packages --------------------------------------------------- |
||
| 96 | -+ | 2x |
- #' @return ARD data frame+ check_pkg_installed(c("effectsize", "parameters"), reference_pkg = "cardx")
|
| 97 |
- #' @keywords internal+ |
||
| 98 |
- .format_proptest_results <- function(by, variable, lst_tidy, ...) {
+ # check/process inputs ------------------------------------------------------- |
||
| 99 | -+ | 2x |
- # build ARD ------------------------------------------------------------------+ check_not_missing(data) |
| 100 | -6x | +2x |
- ret <-+ check_not_missing(variables) |
| 101 | -6x | +2x |
- cards::tidy_as_ard(+ check_not_missing(by) |
| 102 | -6x | +2x |
- lst_tidy = lst_tidy,+ check_not_missing(id) |
| 103 | -6x | +2x |
- tidy_result_names = c(+ check_data_frame(data) |
| 104 | -6x | +2x |
- "estimate", "estimate1", "estimate2", "statistic",+ data <- dplyr::ungroup(data) |
| 105 | -6x | +2x |
- "p.value", "parameter", "conf.low", "conf.high",+ cards::process_selectors(data, by = {{ by }}, variables = {{ variables }}, id = {{ id }})
|
| 106 | -6x | +2x |
- "method", "alternative"+ check_scalar(by) |
| 107 | -+ | 2x |
- ),+ check_scalar(id) |
| 108 | -6x | +
- fun_args_to_record = c("p", "conf.level", "correct"),
+
|
|
| 109 | -6x | +
- formals = formals(stats::prop.test),+ # if no variables selected, return empty tibble ------------------------------ |
|
| 110 | -6x | +2x |
- passed_args = dots_list(...),+ if (is_empty(variables)) {
|
| 111 | -6x | +! |
- lst_ard_columns = list(group1 = by, variable = variable, context = "stats_prop_test")+ return(dplyr::tibble()) |
| 112 |
- )+ } |
||
| 114 |
- # add the stat label ---------------------------------------------------------+ # build ARD ------------------------------------------------------------------ |
||
| 115 | -6x | +2x |
- ret |>+ lapply( |
| 116 | -6x | +2x |
- dplyr::left_join(+ variables, |
| 117 | -6x | +2x |
- .df_proptest_stat_labels(),+ function(variable) {
|
| 118 | -6x | +2x |
- by = "stat_name"+ .format_cohens_d_results( |
| 119 | -+ | 2x |
- ) |>+ by = by, |
| 120 | -6x | +2x |
- dplyr::mutate(stat_label = dplyr::coalesce(.data$stat_label, .data$stat_name)) |>+ variable = variable, |
| 121 | -6x | +2x |
- cards::tidy_ard_column_order()+ 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 |
- .df_proptest_stat_labels <- function() {
+ data_wide <- .paired_data_pivot_wider(data, by = by, variable = variable, id = id) |
| 125 | -6x | +
- dplyr::tribble(+ # perform paired cohen's d test |
|
| 126 | -6x | +1x |
- ~stat_name, ~stat_label,+ effectsize::cohens_d(x = data_wide[["by1"]], y = data_wide[["by2"]], paired = TRUE, ...) |> |
| 127 | -6x | +1x |
- "estimate1", "Group 1 Rate",+ parameters::standardize_names(style = "broom") |
| 128 | -6x | +
- "estimate2", "Group 2 Rate",+ }), |
|
| 129 | -6x | +2x |
- "estimate", "Rate Difference",+ paired = TRUE, |
| 130 | -6x | +
- "p.value", "p-value",+ ... |
|
| 131 | -6x | +
- "statistic", "X-squared Statistic",+ ) |
|
| 132 | -6x | +
- "parameter", "Degrees of Freedom",+ } |
|
| 133 | -6x | +
- "conf.low", "CI Lower Bound",+ ) |> |
|
| 134 | -6x | +2x |
- "conf.high", "CI Upper Bound",+ dplyr::bind_rows() |
| 135 | -6x | +
- "conf.level", "CI Confidence Level",+ } |
|
| 136 | -6x | +
- "correct", "Yates' continuity correction",+ |
|
| 137 |
- )+ .df_effectsize_stat_labels <- function() {
|
||
| 138 | -+ | 8x |
- }+ dplyr::tribble( |
| 1 | -+ | |||
| 139 | +8x |
- #' ARD Cohen's D Test+ ~stat_name, ~stat_label, |
||
| 2 | -+ | |||
| 140 | +8x |
- #'+ "estimate", "Effect Size Estimate", |
||
| 3 | -+ | |||
| 141 | +8x |
- #' @description+ "conf.low", "CI Lower Bound", |
||
| 4 | -+ | |||
| 142 | +8x |
- #' Analysis results data for paired and non-paired Cohen's D Effect Size Test+ "conf.high", "CI Upper Bound", |
||
| 5 | -+ | |||
| 143 | +8x |
- #' using [`effectsize::cohens_d()`].+ "conf.level", "CI Confidence Level", |
||
| 6 | -+ | |||
| 144 | +8x |
- #'+ "mu", "H0 Mean", |
||
| 7 | -+ | |||
| 145 | +8x |
- #' @param data (`data.frame`)\cr+ "paired", "Paired test", |
||
| 8 | -+ | |||
| 146 | +8x |
- #' a data frame. See below for details.+ "pooled_sd", "Pooled Standard Deviation", |
||
| 9 | -+ | |||
| 147 | +8x |
- #' @param by ([`tidy-select`][dplyr::dplyr_tidy_select])\cr+ "alternative", "Alternative Hypothesis" |
||
| 10 | +148 |
- #' column name to compare by. Must be a categorical variable with exactly two levels.+ ) |
||
| 11 | +149 |
- #' @param variables ([`tidy-select`][dplyr::dplyr_tidy_select])\cr+ } |
||
| 12 | +150 |
- #' column names to be compared. Must be a continuous variables.+ |
||
| 13 | +151 |
- #' Independent tests will be run for each variable.+ |
||
| 14 | +152 |
- #' @param id ([`tidy-select`][dplyr::dplyr_tidy_select])\cr+ #' Convert Cohen's D Test to ARD |
||
| 15 | +153 |
- #' column name of the subject or participant ID+ #' |
||
| 16 | +154 |
- #' @param ... arguments passed to `effectsize::cohens_d(...)`+ #' @inheritParams cards::tidy_as_ard |
||
| 17 | +155 |
- #'+ #' @inheritParams effectsize::cohens_d |
||
| 18 | +156 |
- #' @return ARD data frame+ #' @param by (`string`)\cr by column name |
||
| 19 | +157 |
- #' @name ard_effectsize_cohens_d+ #' @param variable (`string`)\cr variable column name |
||
| 20 | +158 |
- #'+ #' @param ... passed to `cohens_d(...)` |
||
| 21 | +159 |
- #' @details+ #' |
||
| 22 | +160 |
- #' For the `ard_effectsize_cohens_d()` function, the data is expected to be one row per subject.+ #' @return ARD data frame |
||
| 23 | +161 |
- #' The data is passed as `effectsize::cohens_d(data[[variable]]~data[[by]], data, paired = FALSE, ...)`.+ #' @keywords internal |
||
| 24 | +162 |
- #'+ #' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = c("effectsize", "parameters"), reference_pkg = "cardx"))
|
||
| 25 | +163 |
- #' For the `ard_effectsize_paired_cohens_d()` function, the data is expected to be one row+ #' cardx:::.format_cohens_d_results( |
||
| 26 | +164 |
- #' per subject per by level. Before the effect size is calculated, the data are+ #' by = "ARM", |
||
| 27 | +165 |
- #' reshaped to a wide format to be one row per subject.+ #' variable = "AGE", |
||
| 28 | +166 |
- #' The data are then passed as+ #' paired = FALSE, |
||
| 29 | +167 |
- #' `effectsize::cohens_d(x = data_wide[[<by level 1>]], y = data_wide[[<by level 2>]], paired = TRUE, ...)`.+ #' lst_tidy = |
||
| 30 | +168 |
- #'+ #' cards::eval_capture_conditions( |
||
| 31 | +169 |
- #' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = c("effectsize", "parameters"), reference_pkg = "cardx"))
+ #' effectsize::hedges_g(data[[variable]] ~ data[[by]], paired = FALSE) |> |
||
| 32 | +170 |
- #' cards::ADSL |>+ #' parameters::standardize_names(style = "broom") |
||
| 33 | +171 |
- #' dplyr::filter(ARM %in% c("Placebo", "Xanomeline High Dose")) |>
+ #' ) |
||
| 34 | +172 |
- #' ard_effectsize_cohens_d(by = ARM, variables = AGE)+ #' ) |
||
| 35 | +173 |
- #'+ .format_cohens_d_results <- function(by, variable, lst_tidy, paired, ...) {
|
||
| 36 | +174 |
- #' # constructing a paired data set,+ # build ARD ------------------------------------------------------------------ |
||
| 37 | -+ | |||
| 175 | +4x |
- #' # where patients receive both treatments+ ret <- |
||
| 38 | -+ | |||
| 176 | +4x |
- #' cards::ADSL[c("ARM", "AGE")] |>
+ cards::tidy_as_ard( |
||
| 39 | -+ | |||
| 177 | +4x |
- #' dplyr::filter(ARM %in% c("Placebo", "Xanomeline High Dose")) |>
+ lst_tidy = lst_tidy, |
||
| 40 | -+ | |||
| 178 | +4x |
- #' dplyr::mutate(.by = ARM, USUBJID = dplyr::row_number()) |>+ tidy_result_names = c( |
||
| 41 | -+ | |||
| 179 | +4x |
- #' dplyr::arrange(USUBJID, ARM) |>+ "estimate", "conf.level", "conf.low", "conf.high" |
||
| 42 | +180 |
- #' dplyr::group_by(USUBJID) |>+ ), |
||
| 43 | -+ | |||
| 181 | +4x |
- #' dplyr::filter(dplyr::n() > 1) |>+ fun_args_to_record = c("mu", "paired", "pooled_sd", "alternative"),
|
||
| 44 | -+ | |||
| 182 | +4x |
- #' ard_effectsize_paired_cohens_d(by = ARM, variables = AGE, id = USUBJID)+ formals = formals(asNamespace("effectsize")[["cohens_d"]]),
|
||
| 45 | -+ | |||
| 183 | +4x |
- NULL+ passed_args = c(list(paired = paired), dots_list(...)), |
||
| 46 | -+ | |||
| 184 | +4x |
-
+ lst_ard_columns = list(group1 = by, variable = variable, context = "effectsize_cohens_d") |
||
| 47 | +185 |
- #' @rdname ard_effectsize_cohens_d+ ) |
||
| 48 | +186 |
- #' @export+ |
||
| 49 | +187 |
- ard_effectsize_cohens_d <- function(data, by, variables, ...) {
+ # add the stat label --------------------------------------------------------- |
||
| 50 | -2x | -
- set_cli_abort_call()- |
- ||
| 51 | -+ | 188 | +4x |
-
+ ret |> |
| 52 | -+ | |||
| 189 | +4x |
- # check installed packages ---------------------------------------------------+ dplyr::left_join( |
||
| 53 | -2x | +190 | +4x |
- check_pkg_installed(c("effectsize", "parameters"), reference_pkg = "cardx")
+ .df_effectsize_stat_labels(), |
| 54 | -+ | |||
| 191 | +4x |
-
+ by = "stat_name" |
||
| 55 | +192 |
- # check/process inputs -------------------------------------------------------- |
- ||
| 56 | -2x | -
- check_not_missing(data)+ ) |> |
||
| 57 | -2x | +193 | +4x |
- check_not_missing(variables)+ dplyr::mutate(stat_label = dplyr::coalesce(.data$stat_label, .data$stat_name)) |> |
| 58 | -2x | +194 | +4x |
- check_not_missing(by)+ cards::tidy_ard_column_order() |
| 59 | -2x | +|||
| 195 | +
- check_data_frame(data)+ } |
|||
| 60 | -2x | +
| 1 | +
- data <- dplyr::ungroup(data)+ #' ARD Kruskal-Wallis Test |
|||
| 61 | -2x | +|||
| 2 | +
- cards::process_selectors(data, by = {{ by }}, variables = {{ variables }})
+ #' |
|||
| 62 | -2x | +|||
| 3 | +
- check_scalar(by)+ #' @description |
|||
| 63 | +4 |
-
+ #' Analysis results data for Kruskal-Wallis Rank Sum Test. |
||
| 64 | +5 |
- # if no variables selected, return empty tibble ------------------------------- |
- ||
| 65 | -2x | -
- if (is_empty(variables)) {
- |
- ||
| 66 | -! | -
- return(dplyr::tibble())+ #' |
||
| 67 | +6 |
- }+ #' Calculated with `kruskal.test(data[[variable]], data[[by]], ...)` |
||
| 68 | +7 |
-
+ #' |
||
| 69 | +8 |
- # build ARD ------------------------------------------------------------------- |
- ||
| 70 | -2x | -
- lapply(- |
- ||
| 71 | -2x | -
- variables,- |
- ||
| 72 | -2x | -
- function(variable) {
- |
- ||
| 73 | -2x | -
- .format_cohens_d_results(- |
- ||
| 74 | -2x | -
- by = by,- |
- ||
| 75 | -2x | -
- variable = variable,- |
- ||
| 76 | -2x | -
- lst_tidy =- |
- ||
| 77 | -2x | -
- cards::eval_capture_conditions(- |
- ||
| 78 | -2x | -
- effectsize::cohens_d(data[[variable]] ~ data[[by]], data = data, paired = FALSE, ...) |>+ #' @param data (`data.frame`)\cr |
||
| 79 | -2x | +|||
| 9 | +
- parameters::standardize_names(style = "broom")+ #' a data frame. |
|||
| 80 | +10 |
- ),+ #' @param by ([`tidy-select`][dplyr::dplyr_tidy_select])\cr |
||
| 81 | -2x | +|||
| 11 | +
- paired = FALSE,+ #' column name to compare by. |
|||
| 82 | +12 |
- ...+ #' @param variables ([`tidy-select`][dplyr::dplyr_tidy_select])\cr |
||
| 83 | +13 |
- )+ #' column names to be compared. Independent tests will |
||
| 84 | +14 |
- }+ #' be computed for each variable. |
||
| 85 | +15 |
- ) |>+ #' |
||
| 86 | -2x | +|||
| 16 | +
- dplyr::bind_rows()+ #' @return ARD data frame |
|||
| 87 | +17 |
- }+ #' @export |
||
| 88 | +18 |
-
+ #' |
||
| 89 | +19 |
-
+ #' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = "broom", reference_pkg = "cardx"))
|
||
| 90 | +20 |
- #' @rdname ard_effectsize_cohens_d+ #' cards::ADSL |> |
||
| 91 | +21 |
- #' @export+ #' ard_stats_kruskal_test(by = "ARM", variables = "AGE") |
||
| 92 | +22 |
- ard_effectsize_paired_cohens_d <- function(data, by, variables, id, ...) {
+ ard_stats_kruskal_test <- function(data, by, variables) {
|
||
| 93 | +23 | 2x |
set_cli_abort_call() |
|
| 94 | +24 | |||
| 95 | +25 |
# check installed packages --------------------------------------------------- |
||
| 96 | +26 | 2x |
- check_pkg_installed(c("effectsize", "parameters"), reference_pkg = "cardx")
+ check_pkg_installed("broom", reference_pkg = "cardx")
|
|
| 97 | +27 | |||
| 98 | +28 |
# check/process inputs ------------------------------------------------------- |
||
| 99 | +29 | 2x |
check_not_missing(data) |
|
| 100 | +30 | 2x |
check_not_missing(variables) |
|
| 101 | +31 | 2x |
check_not_missing(by) |
|
| 102 | -2x | -
- check_not_missing(id)- |
- ||
| 103 | +32 | 2x |
check_data_frame(data) |
|
| 104 | -2x | -
- data <- dplyr::ungroup(data)- |
- ||
| 105 | +33 | 2x |
- cards::process_selectors(data, by = {{ by }}, variables = {{ variables }}, id = {{ id }})
+ cards::process_selectors(data, by = {{ by }}, variables = {{ variables }})
|
|
| 106 | +34 | 2x |
check_scalar(by) |
|
| 107 | -2x | -
- check_scalar(id)- |
- ||
| 108 | +35 | |||
| 109 | +36 |
# if no variables selected, return empty tibble ------------------------------ |
||
| 110 | +37 | 2x |
if (is_empty(variables)) {
|
|
| 111 | +38 | ! |
return(dplyr::tibble()) |
|
| 112 | +39 |
} |
||
| 113 | -- | - - | -||
| 114 | +40 |
# build ARD ------------------------------------------------------------------ |
||
| 115 | +41 | 2x |
lapply( |
|
| 116 | +42 | 2x |
variables, |
|
| 117 | +43 | 2x |
function(variable) {
|
|
| 118 | +44 | 2x |
- .format_cohens_d_results(+ cards::tidy_as_ard( |
|
| 119 | +45 | 2x |
- by = by,+ lst_tidy = |
|
| 120 | +46 | 2x |
- variable = variable,+ cards::eval_capture_conditions( |
|
| 121 | +47 | 2x |
- lst_tidy =+ stats::kruskal.test(x = data[[variable]], g = data[[by]]) |> |
|
| 122 | +48 | 2x |
- cards::eval_capture_conditions({
+ broom::tidy() |
|
| 123 | +49 |
- # adding this reshape inside the eval, so if there is an error it's captured in the ARD object+ ), |
||
| 124 | +50 | 2x |
- data_wide <- .paired_data_pivot_wider(data, by = by, variable = variable, id = id)+ tidy_result_names = c("statistic", "p.value", "parameter", "method"),
+ |
+ |
| 51 | +2x | +
+ lst_ard_columns = list(group1 = by, variable = variable, context = "stats_kruskal_test") |
||
| 125 | +52 |
- # perform paired cohen's d test+ ) |> |
||
| 126 | -1x | +53 | +2x |
- effectsize::cohens_d(x = data_wide[["by1"]], y = data_wide[["by2"]], paired = TRUE, ...) |>+ dplyr::mutate( |
| 127 | -1x | +54 | +2x |
- parameters::standardize_names(style = "broom")+ .after = "stat_name", |
| 128 | -+ | |||
| 55 | +2x |
- }),+ stat_label = |
||
| 129 | +56 | 2x |
- paired = TRUE,+ dplyr::case_when(+ |
+ |
| 57 | +2x | +
+ .data$stat_name %in% "statistic" ~ "Kruskal-Wallis chi-squared Statistic",+ |
+ ||
| 58 | +2x | +
+ .data$stat_name %in% "p.value" ~ "p-value",+ |
+ ||
| 59 | +2x | +
+ .data$stat_name %in% "parameter" ~ "Degrees of Freedom",+ |
+ ||
| 60 | +2x | +
+ TRUE ~ .data$stat_name, |
||
| 130 | +61 |
- ...+ ) |
||
| 131 | +62 |
- )+ ) |
||
| 132 | +63 |
} |
||
| 133 | +64 |
) |> |
||
| 134 | +65 | 2x |
dplyr::bind_rows() |
|
| 135 | +66 |
} |
| 136 | +1 |
-
+ #' Functions for Calculating Proportion Confidence Intervals |
|
| 137 | +2 |
- .df_effectsize_stat_labels <- function() {
+ #' |
|
| 138 | -8x | +||
| 3 | +
- dplyr::tribble(+ #' Functions to calculate different proportion confidence intervals for use in `ard_proportion()`. |
||
| 139 | -8x | +||
| 4 | +
- ~stat_name, ~stat_label,+ #' |
||
| 140 | -8x | +||
| 5 | +
- "estimate", "Effect Size Estimate",+ #' @inheritParams ard_proportion_ci |
||
| 141 | -8x | +||
| 6 | +
- "conf.low", "CI Lower Bound",+ #' @param x vector of a binary values, i.e. a logical vector, or numeric with values `c(0, 1)` |
||
| 142 | -8x | +||
| 7 | +
- "conf.high", "CI Upper Bound",+ #' @return Confidence interval of a proportion. |
||
| 143 | -8x | +||
| 8 | +
- "conf.level", "CI Confidence Level",+ #' |
||
| 144 | -8x | +||
| 9 | +
- "mu", "H0 Mean",+ #' @name proportion_ci |
||
| 145 | -8x | +||
| 10 | +
- "paired", "Paired test",+ #' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = "broom", reference_pkg = "cardx"))
|
||
| 146 | -8x | +||
| 11 | +
- "pooled_sd", "Pooled Standard Deviation",+ #' x <- c( |
||
| 147 | -8x | +||
| 12 | +
- "alternative", "Alternative Hypothesis"+ #' TRUE, TRUE, TRUE, TRUE, TRUE, |
||
| 148 | +13 |
- )+ #' FALSE, FALSE, FALSE, FALSE, FALSE |
|
| 149 | +14 |
- }+ #' ) |
|
| 150 | +15 |
-
+ #' |
|
| 151 | +16 |
-
+ #' proportion_ci_wald(x, conf.level = 0.9) |
|
| 152 | +17 |
- #' Convert Cohen's D Test to ARD+ #' proportion_ci_wilson(x, correct = TRUE) |
|
| 153 | +18 |
- #'+ #' proportion_ci_clopper_pearson(x) |
|
| 154 | +19 |
- #' @inheritParams cards::tidy_as_ard+ #' proportion_ci_agresti_coull(x) |
|
| 155 | +20 |
- #' @inheritParams effectsize::cohens_d+ #' proportion_ci_jeffreys(x) |
|
| 156 | +21 |
- #' @param by (`string`)\cr by column name+ NULL |
|
| 157 | +22 |
- #' @param variable (`string`)\cr variable column name+ |
|
| 158 | +23 |
- #' @param ... passed to `cohens_d(...)`+ #' @describeIn proportion_ci Calculates the Wald interval by following the usual textbook definition |
|
| 159 | +24 |
- #'+ #' for a single proportion confidence interval using the normal approximation. |
|
| 160 | +25 |
- #' @return ARD data frame+ #' |
|
| 161 | +26 |
- #' @keywords internal+ #' \deqn{\hat{p} \pm z_{\alpha/2} \sqrt{\frac{\hat{p}(1 - \hat{p})}{n}}}
|
|
| 162 | +27 |
- #' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = c("effectsize", "parameters"), reference_pkg = "cardx"))
+ #' |
|
| 163 | +28 |
- #' cardx:::.format_cohens_d_results(+ #' @param correct (`logical`)\cr apply continuity correction. |
|
| 164 | +29 |
- #' by = "ARM",+ #' |
|
| 165 | +30 |
- #' variable = "AGE",+ #' @export |
|
| 166 | +31 |
- #' paired = FALSE,+ proportion_ci_wald <- function(x, conf.level = 0.95, correct = FALSE) {
|
|
| 167 | -+ | ||
| 32 | +4x |
- #' lst_tidy =+ set_cli_abort_call() |
|
| 168 | +33 |
- #' cards::eval_capture_conditions(+ |
|
| 169 | +34 |
- #' effectsize::hedges_g(data[[variable]] ~ data[[by]], paired = FALSE) |>+ # check inputs --------------------------------------------------------------- |
|
| 170 | -+ | ||
| 35 | +4x |
- #' parameters::standardize_names(style = "broom")+ check_not_missing(x) |
|
| 171 | -+ | ||
| 36 | +4x |
- #' )+ check_binary(x) |
|
| 172 | -+ | ||
| 37 | +4x |
- #' )+ check_range(conf.level, range = c(0, 1), include_bounds = c(FALSE, FALSE)) |
|
| 173 | -+ | ||
| 38 | +4x |
- .format_cohens_d_results <- function(by, variable, lst_tidy, paired, ...) {
+ check_scalar(conf.level) |
|
| 174 | -+ | ||
| 39 | +4x |
- # build ARD ------------------------------------------------------------------+ check_class(x = correct, "logical") |
|
| 175 | +40 | 4x |
- ret <-+ check_scalar(correct) |
| 176 | -4x | +||
| 41 | +
- cards::tidy_as_ard(+ |
||
| 177 | +42 | 4x |
- lst_tidy = lst_tidy,+ x <- stats::na.omit(x)+ |
+
| 43 | ++ | + | |
| 178 | +44 | 4x |
- tidy_result_names = c(+ n <- length(x) |
| 179 | +45 | 4x |
- "estimate", "conf.level", "conf.low", "conf.high"+ p_hat <- mean(x) |
| 180 | -+ | ||
| 46 | +4x |
- ),+ z <- stats::qnorm((1 + conf.level) / 2) |
|
| 181 | +47 | 4x |
- fun_args_to_record = c("mu", "paired", "pooled_sd", "alternative"),
+ q_hat <- 1 - p_hat |
| 182 | +48 | 4x |
- formals = formals(asNamespace("effectsize")[["cohens_d"]]),
+ correction_factor <- ifelse(correct, 1 / (2 * n), 0)+ |
+
| 49 | ++ | + | |
| 183 | +50 | 4x |
- passed_args = c(list(paired = paired), dots_list(...)),+ err <- z * sqrt(p_hat * q_hat) / sqrt(n) + correction_factor |
| 184 | +51 | 4x |
- lst_ard_columns = list(group1 = by, variable = variable, context = "effectsize_cohens_d")+ l_ci <- max(0, p_hat - err) |
| 185 | -+ | ||
| 52 | +4x |
- )+ u_ci <- min(1, p_hat + err) |
|
| 186 | +53 | ||
| 187 | -+ | ||
| 54 | +4x |
- # add the stat label ---------------------------------------------------------+ list( |
|
| 188 | +55 | 4x |
- ret |>+ N = n, |
| 189 | +56 | 4x |
- dplyr::left_join(+ estimate = p_hat, |
| 190 | +57 | 4x |
- .df_effectsize_stat_labels(),+ conf.low = l_ci, |
| 191 | +58 | 4x |
- by = "stat_name"+ conf.high = u_ci, |
| 192 | -+ | ||
| 59 | +4x |
- ) |>+ conf.level = conf.level, |
|
| 193 | +60 | 4x |
- dplyr::mutate(stat_label = dplyr::coalesce(.data$stat_label, .data$stat_name)) |>+ method = |
| 194 | +61 | 4x |
- cards::tidy_ard_column_order()+ glue::glue("Wald Confidence Interval {ifelse(correct, 'with', 'without')} continuity correction")
|
| 195 | +62 |
- }+ ) |
| 1 | +63 |
- #' ARD Kruskal-Wallis Test+ } |
||
| 2 | +64 |
- #'+ |
||
| 3 | +65 |
- #' @description+ |
||
| 4 | +66 |
- #' Analysis results data for Kruskal-Wallis Rank Sum Test.+ #' @describeIn proportion_ci Calculates the Wilson interval by calling [stats::prop.test()]. |
||
| 5 | +67 |
- #'+ #' Also referred to as Wilson score interval. |
||
| 6 | +68 |
- #' Calculated with `kruskal.test(data[[variable]], data[[by]], ...)`+ #' |
||
| 7 | +69 |
- #'+ #' \deqn{\frac{\hat{p} +
|
||
| 8 | +70 |
- #' @param data (`data.frame`)\cr+ #' \frac{z^2_{\alpha/2}}{2n} \pm z_{\alpha/2} \sqrt{\frac{\hat{p}(1 - \hat{p})}{n} +
|
||
| 9 | +71 |
- #' a data frame.+ #' \frac{z^2_{\alpha/2}}{4n^2}}}{1 + \frac{z^2_{\alpha/2}}{n}}}
|
||
| 10 | +72 |
- #' @param by ([`tidy-select`][dplyr::dplyr_tidy_select])\cr+ #' |
||
| 11 | +73 |
- #' column name to compare by.+ #' @export |
||
| 12 | +74 |
- #' @param variables ([`tidy-select`][dplyr::dplyr_tidy_select])\cr+ proportion_ci_wilson <- function(x, conf.level = 0.95, correct = FALSE) {
|
||
| 13 | -+ | |||
| 75 | +5x |
- #' column names to be compared. Independent tests will+ set_cli_abort_call() |
||
| 14 | +76 |
- #' be computed for each variable.+ |
||
| 15 | +77 |
- #'+ # check installed packages --------------------------------------------------- |
||
| 16 | -+ | |||
| 78 | +5x |
- #' @return ARD data frame+ check_pkg_installed(pkg = "broom", reference_pkg = "cardx") |
||
| 17 | +79 |
- #' @export+ |
||
| 18 | +80 |
- #'+ # check inputs --------------------------------------------------------------- |
||
| 19 | -+ | |||
| 81 | +5x |
- #' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = "broom", reference_pkg = "cardx"))
+ check_not_missing(x) |
||
| 20 | -+ | |||
| 82 | +5x |
- #' cards::ADSL |>+ check_binary(x) |
||
| 21 | -+ | |||
| 83 | +5x |
- #' ard_stats_kruskal_test(by = "ARM", variables = "AGE")+ check_class(x = correct, "logical") |
||
| 22 | -+ | |||
| 84 | +5x |
- ard_stats_kruskal_test <- function(data, by, variables) {
+ check_scalar(correct) |
||
| 23 | -2x | +85 | +5x |
- set_cli_abort_call()+ check_range(conf.level, range = c(0, 1), include_bounds = c(FALSE, FALSE)) |
| 24 | -+ | |||
| 86 | +5x |
-
+ check_scalar(conf.level) |
||
| 25 | +87 |
- # check installed packages ---------------------------------------------------+ |
||
| 26 | -2x | +88 | +5x |
- check_pkg_installed("broom", reference_pkg = "cardx")
+ x <- stats::na.omit(x) |
| 27 | +89 | |||
| 90 | +5x | +
+ n <- length(x)+ |
+ ||
| 91 | +5x | +
+ y <- stats::prop.test(x = sum(x), n = n, correct = correct, conf.level = conf.level)+ |
+ ||
| 28 | +92 |
- # check/process inputs -------------------------------------------------------+ |
||
| 29 | -2x | +93 | +5x |
- check_not_missing(data)+ list(N = n, conf.level = conf.level) |> |
| 30 | -2x | +94 | +5x |
- check_not_missing(variables)+ utils::modifyList(val = broom::tidy(y) |> as.list()) |> |
| 31 | -2x | +95 | +5x |
- check_not_missing(by)+ utils::modifyList( |
| 32 | -2x | +96 | +5x |
- check_data_frame(data)+ list( |
| 33 | -2x | +97 | +5x |
- cards::process_selectors(data, by = {{ by }}, variables = {{ variables }})
+ method = |
| 34 | -2x | +98 | +5x |
- check_scalar(by)+ glue::glue("Wilson Confidence Interval {ifelse(correct, 'with', 'without')} continuity correction")
|
| 35 | +99 |
-
+ ) |
||
| 36 | +100 |
- # if no variables selected, return empty tibble ------------------------------+ ) |
||
| 37 | -2x | +|||
| 101 | +
- if (is_empty(variables)) {
+ } |
|||
| 38 | -! | +|||
| 102 | +
- return(dplyr::tibble())+ |
|||
| 39 | +103 |
- }+ #' @describeIn proportion_ci Calculates the Clopper-Pearson interval by calling [stats::binom.test()]. |
||
| 40 | +104 |
- # build ARD ------------------------------------------------------------------+ #' Also referred to as the `exact` method. |
||
| 41 | -2x | +|||
| 105 | +
- lapply(+ #' |
|||
| 42 | -2x | +|||
| 106 | +
- variables,+ #' \deqn{
|
|||
| 43 | -2x | +|||
| 107 | +
- function(variable) {
+ #' \left( \frac{k}{n} \pm z_{\alpha/2} \sqrt{\frac{\frac{k}{n}(1-\frac{k}{n})}{n} +
|
|||
| 44 | -2x | +|||
| 108 | +
- cards::tidy_as_ard(+ #' \frac{z^2_{\alpha/2}}{4n^2}} \right)
|
|||
| 45 | -2x | +|||
| 109 | +
- lst_tidy =+ #' / \left( 1 + \frac{z^2_{\alpha/2}}{n} \right)}
|
|||
| 46 | -2x | +|||
| 110 | +
- cards::eval_capture_conditions(+ #' |
|||
| 47 | -2x | +|||
| 111 | +
- stats::kruskal.test(x = data[[variable]], g = data[[by]]) |>+ #' @export+ |
+ |||
| 112 | ++ |
+ proportion_ci_clopper_pearson <- function(x, conf.level = 0.95) {
|
||
| 48 | +113 | 2x |
- broom::tidy()+ set_cli_abort_call() |
|
| 49 | +114 |
- ),+ |
||
| 50 | -2x | +|||
| 115 | +
- tidy_result_names = c("statistic", "p.value", "parameter", "method"),
+ # check installed packages --------------------------------------------------- |
|||
| 51 | +116 | 2x |
- lst_ard_columns = list(group1 = by, variable = variable, context = "stats_kruskal_test")+ check_pkg_installed(pkg = "broom", reference_pkg = "cardx") |
|
| 52 | +117 |
- ) |>+ |
||
| 53 | -2x | +|||
| 118 | +
- dplyr::mutate(+ # check inputs --------------------------------------------------------------- |
|||
| 54 | +119 | 2x |
- .after = "stat_name",+ check_not_missing(x) |
|
| 55 | +120 | 2x |
- stat_label =+ check_binary(x) |
|
| 56 | +121 | 2x |
- dplyr::case_when(+ check_range(conf.level, range = c(0, 1), include_bounds = c(FALSE, FALSE)) |
|
| 57 | +122 | 2x |
- .data$stat_name %in% "statistic" ~ "Kruskal-Wallis chi-squared Statistic",+ check_scalar(conf.level) |
|
| 58 | -2x | +|||
| 123 | +
- .data$stat_name %in% "p.value" ~ "p-value",+ |
|||
| 59 | +124 | 2x |
- .data$stat_name %in% "parameter" ~ "Degrees of Freedom",+ x <- stats::na.omit(x) |
|
| 60 | +125 | 2x |
- TRUE ~ .data$stat_name,+ n <- length(x) |
|
| 61 | +126 |
- )+ |
||
| 62 | -+ | |||
| 127 | +2x |
- )+ y <- stats::binom.test(x = sum(x), n = n, conf.level = conf.level) |
||
| 63 | +128 |
- }+ |
||
| 64 | -+ | |||
| 129 | +2x |
- ) |>+ list(N = n, conf.level = conf.level) |> |
||
| 65 | +130 | 2x |
- dplyr::bind_rows()+ utils::modifyList(val = broom::tidy(y) |> as.list()) |>+ |
+ |
| 131 | +2x | +
+ utils::modifyList(list(method = "Clopper-Pearson Confidence Interval")) |
||
| 66 | +132 |
} |
| 1 | +133 |
- #' ARD Continuous Survey Statistics+ |
||
| 2 | +134 |
- #'+ #' @describeIn proportion_ci Calculates the `Agresti-Coull` interval (created by `Alan Agresti` and `Brent Coull`) by |
||
| 3 | +135 |
- #' Returns an ARD of weighted statistics using the `{survey}` package.
+ #' (for 95% CI) adding two successes and two failures to the data and then using the Wald formula to construct a CI. |
||
| 4 | +136 |
#' |
||
| 5 | +137 |
- #' @param data (`survey.design`)\cr+ #' \deqn{
|
||
| 6 | +138 |
- #' a design object often created with [`survey::svydesign()`].+ #' \left( \frac{\tilde{p} + z^2_{\alpha/2}/2}{n + z^2_{\alpha/2}} \pm
|
||
| 7 | +139 |
- #' @param variables ([`tidy-select`][dplyr::dplyr_tidy_select])\cr+ #' z_{\alpha/2} \sqrt{\frac{\tilde{p}(1 - \tilde{p})}{n} +
|
||
| 8 | +140 |
- #' columns to include in summaries. Default is `everything()`.+ #' \frac{z^2_{\alpha/2}}{4n^2}} \right)}
|
||
| 9 | +141 |
- #' @param by ([`tidy-select`][dplyr::dplyr_tidy_select])\cr+ #' |
||
| 10 | +142 |
- #' results are calculated for **all combinations** of the columns specified,+ #' @export |
||
| 11 | +143 |
- #' including unobserved combinations and unobserved factor levels.+ proportion_ci_agresti_coull <- function(x, conf.level = 0.95) {
|
||
| 12 | -+ | |||
| 144 | +2x |
- #' @param statistic ([`formula-list-selector`][syntax])\cr+ set_cli_abort_call() |
||
| 13 | +145 |
- #' a named list, a list of formulas,+ |
||
| 14 | +146 |
- #' or a single formula where the list element is a character vector of+ # check inputs --------------------------------------------------------------- |
||
| 15 | -+ | |||
| 147 | +2x |
- #' statistic names to include. See below for options.+ check_not_missing(x) |
||
| 16 | -+ | |||
| 148 | +2x |
- #' @param fmt_fn ([`formula-list-selector`][syntax])\cr+ check_binary(x) |
||
| 17 | -+ | |||
| 149 | +2x |
- #' a named list, a list of formulas,+ check_range(conf.level, range = c(0, 1), include_bounds = c(FALSE, FALSE)) |
||
| 18 | -+ | |||
| 150 | +2x |
- #' or a single formula where the list element is a named list of functions+ check_scalar(conf.level) |
||
| 19 | +151 |
- #' (or the RHS of a formula),+ |
||
| 20 | -+ | |||
| 152 | +2x |
- #' e.g. `list(mpg = list(mean = \(x) round(x, digits = 2) |> as.character))`.+ x <- stats::na.omit(x) |
||
| 21 | +153 |
- #' @param stat_label ([`formula-list-selector`][syntax])\cr+ |
||
| 22 | -+ | |||
| 154 | +2x |
- #' a named list, a list of formulas, or a single formula where+ n <- length(x) |
||
| 23 | -+ | |||
| 155 | +2x |
- #' the list element is either a named list or a list of formulas defining the+ x_sum <- sum(x) |
||
| 24 | -+ | |||
| 156 | +2x |
- #' statistic labels, e.g. `everything() ~ list(mean = "Mean", sd = "SD")` or+ z <- stats::qnorm((1 + conf.level) / 2) |
||
| 25 | +157 |
- #' `everything() ~ list(mean ~ "Mean", sd ~ "SD")`.+ |
||
| 26 | +158 |
- #'+ # Add here both z^2 / 2 successes and failures. |
||
| 27 | -+ | |||
| 159 | +2x |
- #' @section statistic argument:+ x_sum_tilde <- x_sum + z^2 / 2 |
||
| 28 | -+ | |||
| 160 | +2x |
- #'+ n_tilde <- n + z^2 |
||
| 29 | +161 |
- #' The following statistics are available:+ |
||
| 30 | +162 |
- #' `r cardx:::accepted_svy_stats(FALSE) |> shQuote("sh") |> paste(collapse = ", ")`,
+ # Then proceed as with the Wald interval. |
||
| 31 | -+ | |||
| 163 | +2x |
- #' where 'p##' is are the percentiles and `##` is an integer between 0 and 100.+ p_tilde <- x_sum_tilde / n_tilde |
||
| 32 | -+ | |||
| 164 | +2x |
- #'+ q_tilde <- 1 - p_tilde |
||
| 33 | -+ | |||
| 165 | +2x |
- #'+ err <- z * sqrt(p_tilde * q_tilde) / sqrt(n_tilde) |
||
| 34 | -+ | |||
| 166 | +2x |
- #' @return an ARD data frame of class 'card'+ l_ci <- max(0, p_tilde - err) |
||
| 35 | -+ | |||
| 167 | +2x |
- #' @export+ u_ci <- min(1, p_tilde + err) |
||
| 36 | +168 |
- #'+ |
||
| 37 | -+ | |||
| 169 | +2x |
- #' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = "survey", reference_pkg = "cardx"))
+ list( |
||
| 38 | -+ | |||
| 170 | +2x |
- #' data(api, package = "survey")+ N = n, |
||
| 39 | -+ | |||
| 171 | +2x |
- #' dclus1 <- survey::svydesign(id = ~dnum, weights = ~pw, data = apiclus1, fpc = ~fpc)+ estimate = mean(x), |
||
| 40 | -+ | |||
| 172 | +2x |
- #'+ conf.low = l_ci, |
||
| 41 | -+ | |||
| 173 | +2x |
- #' ard_survey_svycontinuous(+ conf.high = u_ci,+ |
+ ||
| 174 | +2x | +
+ conf.level = conf.level,+ |
+ ||
| 175 | +2x | +
+ method = "Agresti-Coull Confidence Interval" |
||
| 42 | +176 |
- #' data = dclus1,+ ) |
||
| 43 | +177 |
- #' variables = api00,+ } |
||
| 44 | +178 |
- #' by = stype+ |
||
| 45 | +179 |
- #' )+ #' @describeIn proportion_ci Calculates the Jeffreys interval, an equal-tailed interval based on the |
||
| 46 | +180 |
- ard_survey_svycontinuous <- function(data, variables, by = NULL,+ #' non-informative Jeffreys prior for a binomial proportion. |
||
| 47 | +181 |
- statistic = everything() ~ c("median", "p25", "p75"),
+ #' |
||
| 48 | +182 |
- fmt_fn = NULL,+ #' \deqn{\left( \text{Beta}\left(\frac{k}{2} + \frac{1}{2}, \frac{n - k}{2} + \frac{1}{2}\right)_\alpha,
|
||
| 49 | +183 |
- stat_label = NULL) {
+ #' \text{Beta}\left(\frac{k}{2} + \frac{1}{2}, \frac{n - k}{2} + \frac{1}{2}\right)_{1-\alpha} \right)}
|
||
| 50 | -10x | +|||
| 184 | +
- set_cli_abort_call()+ #' |
|||
| 51 | +185 |
-
+ #' @export |
||
| 52 | +186 |
- # check installed packages ---------------------------------------------------+ proportion_ci_jeffreys <- function(x, conf.level = 0.95) {
|
||
| 53 | -10x | +187 | +2x |
- check_pkg_installed(pkg = "survey", reference_pkg = "cardx")+ set_cli_abort_call() |
| 54 | +188 | |||
| 55 | +189 |
# check inputs --------------------------------------------------------------- |
||
| 56 | -10x | +190 | +2x |
- check_not_missing(data)+ check_not_missing(x) |
| 57 | -10x | +191 | +2x |
- check_class(data, cls = "survey.design")+ check_binary(x) |
| 58 | -10x | +192 | +2x |
- check_not_missing(variables)+ check_range(conf.level, range = c(0, 1), include_bounds = c(FALSE, FALSE)) |
| 59 | -+ | |||
| 193 | +2x |
-
+ check_scalar(conf.level)+ |
+ ||
| 194 | +2x | +
+ x <- stats::na.omit(x) |
||
| 60 | +195 |
- # process inputs -------------------------------------------------------------+ |
||
| 61 | -10x | +196 | +2x |
- cards::process_selectors(data$variables, variables = {{ variables }}, by = {{ by }})
+ n <- length(x) |
| 62 | -10x | +197 | +2x |
- variables <- setdiff(variables, by)+ x_sum <- sum(x)+ |
+
| 198 | ++ | + | ||
| 63 | -10x | +199 | +2x |
- cards::process_formula_selectors(+ alpha <- 1 - conf.level |
| 64 | -10x | +200 | +2x |
- data$variables[variables],+ l_ci <- ifelse( |
| 65 | -10x | +201 | +2x |
- statistic = statistic,+ x_sum == 0, |
| 66 | -10x | +202 | +2x |
- fmt_fn = fmt_fn,+ 0, |
| 67 | -10x | +203 | +2x |
- stat_label = stat_label+ stats::qbeta(alpha / 2, x_sum + 0.5, n - x_sum + 0.5) |
| 68 | +204 |
) |
||
| 205 | ++ | + + | +||
| 69 | -10x | +206 | +2x |
- cards::fill_formula_selectors(+ u_ci <- ifelse( |
| 70 | -10x | +207 | +2x |
- data$variables[variables],+ x_sum == n, |
| 71 | -10x | +208 | +2x |
- statistic = formals(ard_survey_svycontinuous)[["statistic"]] |> eval()+ 1,+ |
+
| 209 | +2x | +
+ stats::qbeta(1 - alpha / 2, x_sum + 0.5, n - x_sum + 0.5) |
||
| 72 | +210 |
) |
||
| 73 | -10x | +|||
| 211 | +
- cards::check_list_elements(+ |
|||
| 74 | -10x | +212 | +2x |
- x = statistic,+ list( |
| 75 | -10x | +213 | +2x |
- predicate = \(x) all(x %in% accepted_svy_stats()),+ N = n, |
| 76 | -10x | +214 | +2x |
- error_msg = c("Error in the values of the {.arg statistic} argument.",
+ estimate = mean(x), |
| 77 | -10x | +215 | +2x |
- i = "Values must be in {.val {accepted_svy_stats(FALSE)}}"
+ conf.low = l_ci,+ |
+
| 216 | +2x | +
+ conf.high = u_ci,+ |
+ ||
| 217 | +2x | +
+ conf.level = conf.level,+ |
+ ||
| 218 | +2x | +
+ method = glue::glue("Jeffreys Interval")
|
||
| 78 | +219 |
- )+ ) |
||
| 79 | +220 |
- )+ } |
||
| 80 | +221 | |||
| 81 | +222 |
- # compute the weighted statistics --------------------------------------------+ |
||
| 82 | -10x | +|||
| 223 | +
- df_stats <-+ #' @describeIn proportion_ci Calculates the stratified Wilson confidence |
|||
| 83 | -10x | +|||
| 224 | +
- map(+ #' interval for unequal proportions as described in |
|||
| 84 | -10x | +|||
| 225 | +
- names(statistic),+ #' Xin YA, Su XG. Stratified Wilson and Newcombe confidence intervals |
|||
| 85 | -10x | +|||
| 226 | +
- function(variable) {
+ #' for multiple binomial proportions. _Statistics in Biopharmaceutical Research_. 2010;2(3). |
|||
| 86 | -10x | +|||
| 227 | +
- map(+ #' |
|||
| 87 | -10x | +|||
| 228 | +
- statistic[[variable]],+ #' \deqn{\frac{\hat{p}_j + \frac{z^2_{\alpha/2}}{2n_j} \pm
|
|||
| 88 | -10x | +|||
| 229 | +
- function(statistic) {
+ #' z_{\alpha/2} \sqrt{\frac{\hat{p}_j(1 - \hat{p}_j)}{n_j} +
|
|||
| 89 | -76x | +|||
| 230 | +
- .compute_svy_stat(data, variable = variable, by = by, stat_name = statistic)+ #' \frac{z^2_{\alpha/2}}{4n_j^2}}}{1 + \frac{z^2_{\alpha/2}}{n_j}}}
|
|||
| 90 | +231 |
- }+ #' |
||
| 91 | +232 |
- )+ #' |
||
| 92 | +233 |
- }+ #' @param strata (`factor`)\cr variable with one level per stratum and same length as `x`. |
||
| 93 | +234 |
- ) |>+ #' @param weights (`numeric` or `NULL`)\cr weights for each level of the strata. If `NULL`, they are |
||
| 94 | -10x | +|||
| 235 | +
- dplyr::bind_rows()+ #' estimated using the iterative algorithm that |
|||
| 95 | +236 |
-
+ #' minimizes the weighted squared length of the confidence interval. |
||
| 96 | +237 |
-
+ #' @param max.iterations (`count`)\cr maximum number of iterations for the iterative procedure used |
||
| 97 | +238 |
- # add stat_labels ------------------------------------------------------------+ #' to find estimates of optimal weights. |
||
| 98 | -10x | +|||
| 239 | +
- df_stats <-+ #' @param correct (`flag`)\cr include the continuity correction. For further information, see for example |
|||
| 99 | -10x | +|||
| 240 | +
- df_stats |>+ #' [stats::prop.test()]. |
|||
| 100 | -10x | +|||
| 241 | +
- dplyr::left_join(+ #' |
|||
| 101 | -10x | +|||
| 242 | +
- .default_svy_stat_labels(),+ #' @examples |
|||
| 102 | -10x | +|||
| 243 | +
- by = "stat_name"+ #' # Stratified Wilson confidence interval with unequal probabilities |
|||
| 103 | +244 |
- ) |>+ #' |
||
| 104 | -10x | +|||
| 245 | +
- dplyr::mutate(stat_label = dplyr::coalesce(.data$stat_label, .data$stat_name))+ #' set.seed(1) |
|||
| 105 | -10x | +|||
| 246 | +
- if (!is_empty(stat_label)) {
+ #' rsp <- sample(c(TRUE, FALSE), 100, TRUE) |
|||
| 106 | -1x | +|||
| 247 | +
- df_stats <-+ #' strata_data <- data.frame( |
|||
| 107 | -1x | +|||
| 248 | +
- dplyr::rows_update(+ #' "f1" = sample(c("a", "b"), 100, TRUE),
|
|||
| 108 | -1x | +|||
| 249 | +
- df_stats,+ #' "f2" = sample(c("x", "y", "z"), 100, TRUE),
|
|||
| 109 | -1x | +|||
| 250 | +
- dplyr::tibble(+ #' stringsAsFactors = TRUE |
|||
| 110 | -1x | +|||
| 251 | +
- variable = names(stat_label),+ #' ) |
|||
| 111 | -1x | -
- stat_name = map(.data$variable, ~ names(stat_label[[.x]])),- |
- ||
| 112 | -1x | +|||
| 252 | +
- stat_label = map(.data$variable, ~ stat_label[[.x]] |>+ #' strata <- interaction(strata_data) |
|||
| 113 | -1x | +|||
| 253 | +
- unname() |>+ #' n_strata <- ncol(table(rsp, strata)) # Number of strata |
|||
| 114 | -1x | +|||
| 254 | +
- unlist())+ #' |
|||
| 115 | +255 |
- ) |>+ #' proportion_ci_strat_wilson( |
||
| 116 | -1x | +|||
| 256 | +
- tidyr::unnest(cols = c("stat_name", "stat_label")),
+ #' x = rsp, strata = strata, |
|||
| 117 | -1x | +|||
| 257 | +
- by = "stat_name",+ #' conf.level = 0.90 |
|||
| 118 | -1x | +|||
| 258 | +
- unmatched = "ignore"+ #' ) |
|||
| 119 | +259 |
- )+ #' |
||
| 120 | +260 |
- }+ #' # Not automatic setting of weights |
||
| 121 | +261 |
-
+ #' proportion_ci_strat_wilson( |
||
| 122 | +262 |
- # add formatting stats -------------------------------------------------------+ #' x = rsp, strata = strata, |
||
| 123 | -10x | +|||
| 263 | +
- df_stats$fmt_fn <- list(1L)+ #' weights = rep(1 / n_strata, n_strata), |
|||
| 124 | -10x | +|||
| 264 | +
- if (!is_empty(fmt_fn)) {
+ #' conf.level = 0.90 |
|||
| 125 | -1x | +|||
| 265 | +
- df_stats <-+ #' ) |
|||
| 126 | -1x | +|||
| 266 | +
- dplyr::rows_update(+ #' |
|||
| 127 | -1x | +|||
| 267 | +
- df_stats,+ #' @export |
|||
| 128 | -1x | +|||
| 268 | +
- dplyr::tibble(+ proportion_ci_strat_wilson <- function(x, |
|||
| 129 | -1x | +|||
| 269 | +
- variable = names(fmt_fn),+ strata, |
|||
| 130 | -1x | +|||
| 270 | +
- stat_name = map(.data$variable, ~ names(fmt_fn[[.x]])),+ weights = NULL, |
|||
| 131 | -1x | +|||
| 271 | +
- fmt_fn = map(.data$variable, ~ fmt_fn[[.x]] |> unname())+ conf.level = 0.95, |
|||
| 132 | +272 |
- ) |>+ max.iterations = 10L, |
||
| 133 | -1x | +|||
| 273 | +
- tidyr::unnest(cols = c("stat_name", "fmt_fn")),
+ correct = FALSE) {
|
|||
| 134 | -1x | +274 | +2x |
- by = "stat_name",+ set_cli_abort_call() |
| 135 | -1x | +|||
| 275 | +
- unmatched = "ignore"+ |
|||
| 136 | +276 |
- )+ # check inputs --------------------------------------------------------------- |
||
| 137 | -+ | |||
| 277 | +2x |
- }+ check_not_missing(x) |
||
| 138 | -+ | |||
| 278 | +2x |
-
+ check_not_missing(strata) |
||
| 139 | -+ | |||
| 279 | +2x |
- # add class and return ARD object --------------------------------------------+ check_binary(x) |
||
| 140 | -10x | +280 | +2x |
- df_stats |>+ check_class(correct, "logical") |
| 141 | -10x | +281 | +2x |
- dplyr::mutate(context = "survey_svycontinuous") |>+ check_scalar(correct) |
| 142 | -10x | +282 | +2x |
- cards::tidy_ard_column_order() %>%+ check_class(strata, "factor") |
| 143 | -10x | +283 | +2x |
- {structure(., class = c("card", class(.)))} # styler: off
+ check_range(conf.level, range = c(0, 1), include_bounds = c(FALSE, FALSE)) |
| 144 | -+ | |||
| 284 | +2x |
- }+ check_scalar(conf.level) |
||
| 145 | +285 | |||
| 146 | +286 |
- .default_svy_stat_labels <- function(stat_label = NULL) {
+ # remove missing values from x and strata |
||
| 147 | -10x | +287 | +2x |
- dplyr::tribble(+ is_na <- is.na(x) | is.na(strata) |
| 148 | -10x | +288 | +2x |
- ~stat_name, ~stat_label,+ x <- x[!is_na] |
| 149 | -10x | +289 | +2x |
- "mean", "Mean",+ strata <- strata[!is_na] |
| 150 | -10x | -
- "median", "Median",- |
- ||
| 151 | -10x | -
- "var", "Variance",- |
- ||
| 152 | -10x | +|||
| 290 | +! |
- "sd", "Standard Deviation",+ if (!inherits(x, "logical")) x <- as.logical(x) |
||
| 153 | -10x | +|||
| 291 | +
- "sum", "Sum",+ # check all TRUE/FALSE, if so, not calculable |
|||
| 154 | -10x | +292 | +2x |
- "deff", "Design Effect",+ if (all(x) || all(!x)) {
|
| 155 | -10x | +|||
| 293 | +! |
- "mean.std.error", "SE(Mean)",+ cli::cli_abort("All values in {.arg x} argument are either {.code TRUE} or {.code FALSE} and CI is not estimable.")
|
||
| 156 | -10x | +|||
| 294 | +
- "min", "Minimum",+ } |
|||
| 157 | -10x | +|||
| 295 | +
- "max", "Maximum",+ |
|||
| 158 | -10x | +296 | +2x |
- "p25", "25% Percentile",+ tbl <- table(factor(x, levels = c(FALSE, TRUE)), strata, useNA = "no") |
| 159 | -10x | -
- "p75", "75% Percentile"- |
- ||
| 160 | -- |
- )- |
- ||
| 161 | -+ | 297 | +2x |
- }+ n_strata <- length(unique(strata)) |
| 162 | +298 | |||
| 163 | +299 |
- accepted_svy_stats <- function(expand_quantiles = TRUE) {
+ # Checking the weights and maximum number of iterations. |
||
| 164 | -10x | +300 | +2x |
- base_stats <-+ do_iter <- FALSE |
| 165 | -10x | +301 | +2x |
- c("mean", "median", "min", "max", "sum", "var", "sd", "mean.std.error", "deff")
+ if (is.null(weights)) {
|
| 166 | -10x | +|||
| 302 | +! |
- if (expand_quantiles) {
+ weights <- rep(1 / n_strata, n_strata) # Initialization for iterative procedure |
||
| 167 | -10x | +|||
| 303 | +! |
- return(c(base_stats, paste0("p", 0:100)))
+ do_iter <- TRUE |
||
| 168 | +304 |
- }+ |
||
| 169 | -! | +|||
| 305 | +
- c(base_stats, "p##")+ # Iteration parameters |
|||
| 170 | -+ | |||
| 306 | +! |
- }+ if (!is_scalar_integerish(max.iterations) || max.iterations < 1) {
|
||
| 171 | -+ | |||
| 307 | +! |
-
+ cli::cli_abort("Argument {.arg max.iterations} must be a positive integer.")
|
||
| 172 | +308 |
-
+ } |
||
| 173 | +309 |
-
+ } |
||
| 174 | -+ | |||
| 310 | +2x |
- # this function calculates the summary for a single variable, single statistic+ check_range(weights, range = c(0, 1), include_bounds = c(TRUE, TRUE)) |
||
| 175 | -+ | |||
| 311 | +2x |
- # and for all `by` levels. it returns an ARD data frame+ sum_weights <- sum(weights) |> |
||
| 176 | -+ | |||
| 312 | +2x |
- .compute_svy_stat <- function(data, variable, by = NULL, stat_name) {
+ round() |> |
||
| 177 | -+ | |||
| 313 | +2x |
- # difftime variable needs to be transformed into numeric for svyquantile+ as.integer() |
||
| 178 | -76x | +314 | +2x |
- if (inherits(data$variables[[variable]], "difftime")) {
+ if (sum_weights != 1L || abs(sum_weights - sum(weights)) > sqrt(.Machine$double.eps)) {
|
| 179 | +315 | ! |
- data$variables[[variable]] <- unclass(data$variables[[variable]])+ cli::cli_abort("The sum of the {.arg weights} argument must be {.val {1L}}")
|
|
| 180 | +316 |
} |
||
| 181 | +317 | |||
| 182 | -+ | |||
| 318 | +2x |
- # styler: off+ xs <- tbl["TRUE", ] |
||
| 183 | -10x | +319 | +2x |
- if (stat_name %in% "mean") args <- list(FUN = survey::svymean)+ ns <- colSums(tbl) |
| 184 | -6x | +320 | +2x |
- else if (stat_name %in% "sum") args <- list(FUN = survey::svytotal)+ use_stratum <- (ns > 0) |
| 185 | -6x | +321 | +2x |
- else if (stat_name %in% "var") args <- list(FUN = survey::svyvar)+ ns <- ns[use_stratum] |
| 186 | -6x | +322 | +2x |
- else if (stat_name %in% "sd") args <- list(FUN = \(...) survey::svyvar(...) |> sqrt())+ xs <- xs[use_stratum] |
| 187 | -6x | +323 | +2x |
- else if (stat_name %in% "mean.std.error") args <- list(FUN = \(...) survey::svymean(...) |> survey::SE())+ ests <- xs / ns |
| 188 | -6x | +324 | +2x |
- else if (stat_name %in% "deff") args <- list(FUN = \(...) survey::svymean(..., deff = TRUE) |> survey::deff())+ vars <- ests * (1 - ests) / ns |
| 189 | -10x | +|||
| 325 | +
- else if (stat_name %in% "min") args <- list(FUN = \(x, design, na.rm, ...) min(design$variables[[all.vars(x)]], na.rm = na.rm))+ |
|||
| 190 | -10x | +326 | +2x |
- else if (stat_name %in% "max") args <- list(FUN = \(x, design, na.rm, ...) max(design$variables[[all.vars(x)]], na.rm = na.rm))+ strata_qnorm <- .strata_normal_quantile(vars, weights, conf.level) |
| 191 | +327 |
- # define functions for the quantiles+ |
||
| 192 | -16x | +|||
| 328 | +
- else if (stat_name %in% c("median", paste0("p", 0:100))) {
+ # Iterative setting of weights if they were not passed in `weights` argument |
|||
| 193 | -16x | -
- quantile <- ifelse(stat_name %in% "median", 0.5, substr(stat_name, 2, nchar(stat_name)) |> as.numeric() %>% `/`(100))- |
- ||
| 194 | -+ | 329 | +2x |
- # univariate results are returned in a different format from stratified.+ weights_new <- if (do_iter) {
|
| 195 | -16x | +|||
| 330 | +! |
- args <-+ .update_weights_strat_wilson(vars, strata_qnorm, weights, ns, max.iterations, conf.level)$weights |
||
| 196 | -16x | +|||
| 331 | +
- if (is_empty(by)) list(FUN = \(...) survey::svyquantile(...)[[1]], quantiles = quantile)+ } else {
|
|||
| 197 | -16x | +332 | +2x |
- else list(FUN = \(...) survey::svyquantile(...), quantiles = quantile)+ weights |
| 198 | +333 |
} |
||
| 199 | +334 |
- # styler: on+ |
||
| 200 | -+ | |||
| 335 | +2x |
-
+ strata_conf.level <- 2 * stats::pnorm(strata_qnorm) - 1 |
||
| 201 | +336 |
- # adding additional args to pass- |
- ||
| 202 | -76x | -
- args <-+ |
||
| 203 | -76x | +337 | +2x |
- args |>+ ci_by_strata <- Map( |
| 204 | -76x | +338 | +2x |
- append(+ function(x, n) {
|
| 205 | -76x | +|||
| 339 | +
- list(+ # Classic Wilson's confidence interval |
|||
| 206 | -76x | +340 | +12x |
- design = data,+ suppressWarnings(stats::prop.test(x, n, correct = correct, conf.level = strata_conf.level)$conf.int) |
| 207 | +341 |
- # if all values are NA, turn na.rm to FALSE to avoid error+ }, |
||
| 208 | -76x | +342 | +2x |
- na.rm = !all(is.na(data$variables[[variable]])),+ x = xs, |
| 209 | -76x | +343 | +2x |
- keep.var = FALSE+ n = ns |
| 210 | +344 |
- )+ ) |
||
| 211 | -+ | |||
| 345 | +2x |
- )+ lower_by_strata <- sapply(ci_by_strata, "[", 1L) |
||
| 212 | -+ | |||
| 346 | +2x |
-
+ upper_by_strata <- sapply(ci_by_strata, "[", 2L) |
||
| 213 | +347 | |||
| 214 | -- |
- # if no by variable, calculate univariate statistics- |
- ||
| 215 | -76x | +348 | +2x |
- if (is_empty(by)) {
+ lower <- sum(weights_new * lower_by_strata) |
| 216 | -38x | +349 | +2x |
- args$x <- stats::reformulate(variable)+ upper <- sum(weights_new * upper_by_strata) |
| 217 | +350 |
- # calculate statistic (and remove FUN from the argument list)+ |
||
| 218 | -38x | +|||
| 351 | +
- stat <-+ # Return values |
|||
| 219 | -38x | +352 | +2x |
- cards::eval_capture_conditions(+ list( |
| 220 | -38x | -
- do.call(args$FUN, args = args |> utils::modifyList(list(FUN = NULL)))- |
- ||
| 221 | -+ | 353 | +2x |
- )+ N = length(x), |
| 222 | -+ | |||
| 354 | +2x |
- # if the result was calculated, then put it into a tibble+ estimate = mean(x), |
||
| 223 | -38x | +355 | +2x |
- if (!is.null(stat[["result"]])) {
+ conf.low = lower, |
| 224 | -32x | +356 | +2x |
- df_stat <-+ conf.high = upper, |
| 225 | -32x | +357 | +2x |
- dplyr::tibble(variable, stat[["result"]][1]) |>+ conf.level = conf.level, |
| 226 | -32x | +358 | +2x |
- set_names(c("variable", "stat")) |>
+ weights = if (do_iter) weights_new else NULL, |
| 227 | -32x | +359 | +2x |
- dplyr::mutate(+ method = |
| 228 | -32x | +360 | +2x |
- stat = as.list(unname(.data$stat)),+ glue::glue("Stratified Wilson Confidence Interval {ifelse(correct, 'with', 'without')} continuity correction")
|
| 229 | -32x | +|||
| 361 | +
- warning = list(stat[["warning"]]),+ ) |> |
|||
| 230 | -32x | +362 | +2x |
- error = list(stat[["error"]])+ compact() |
| 231 | +363 |
- )+ } |
||
| 232 | +364 |
- }+ |
||
| 233 | +365 |
- # otherwise, if there was an error return tibble with error message+ #' Helper Function for the Estimation of Stratified Quantiles |
||
| 234 | +366 |
- else {
+ #' |
||
| 235 | -6x | +|||
| 367 | +
- df_stat <-+ #' This function wraps the estimation of stratified percentiles when we assume |
|||
| 236 | -6x | +|||
| 368 | +
- dplyr::tibble(+ #' the approximation for large numbers. This is necessary only in the case |
|||
| 237 | -6x | +|||
| 369 | +
- variable = .env$variable,+ #' proportions for each strata are unequal. |
|||
| 238 | -6x | +|||
| 370 | +
- stat = list(NULL),+ #' |
|||
| 239 | -6x | +|||
| 371 | +
- warning = list(.env$stat[["warning"]]),+ #' @inheritParams proportion_ci_strat_wilson |
|||
| 240 | -6x | +|||
| 372 | +
- error = list(.env$stat[["error"]])+ #' |
|||
| 241 | +373 |
- )+ #' @return Stratified quantile. |
||
| 242 | +374 |
- }+ #' |
||
| 243 | +375 |
- }+ #' @seealso [proportion_ci_strat_wilson()] |
||
| 244 | +376 |
-
+ #' |
||
| 245 | +377 |
- # if there is by variable(s), calculate statistics for the combinations+ #' @keywords internal |
||
| 246 | +378 |
- else {
+ #' |
||
| 247 | -38x | +|||
| 379 | +
- args$formula <- stats::reformulate(variable)+ #' @examples |
|||
| 248 | -38x | +|||
| 380 | +
- args$by <- stats::reformulate(by)+ #' strata_data <- table(data.frame( |
|||
| 249 | -38x | +|||
| 381 | +
- stat <-+ #' "f1" = sample(c(TRUE, FALSE), 100, TRUE), |
|||
| 250 | -38x | +|||
| 382 | +
- if (stat_name %in% c("median", paste0("p", 0:100))) {
+ #' "f2" = sample(c("x", "y", "z"), 100, TRUE),
|
|||
| 251 | -8x | +|||
| 383 | +
- cards::eval_capture_conditions(+ #' stringsAsFactors = TRUE |
|||
| 252 | -8x | +|||
| 384 | +
- do.call(survey::svyby, args) |> set_names(c(by, "quantile", "ci.2.5", "ci.97.5", "se"))+ #' )) |
|||
| 253 | +385 |
- )+ #' ns <- colSums(strata_data) |
||
| 254 | -38x | +|||
| 386 | +
- } else if (stat_name %in% "deff") {
+ #' ests <- strata_data["TRUE", ] / ns |
|||
| 255 | -3x | +|||
| 387 | +
- stat <-+ #' vars <- ests * (1 - ests) / ns |
|||
| 256 | -3x | +|||
| 388 | +
- cards::eval_capture_conditions(+ #' weights <- rep(1 / length(ns), length(ns)) |
|||
| 257 | -3x | +|||
| 389 | +
- do.call(+ #' |
|||
| 258 | -3x | +|||
| 390 | +
- survey::svyby,+ #' cardx:::.strata_normal_quantile(vars, weights, 0.95)+ |
+ |||
| 391 | ++ |
+ .strata_normal_quantile <- function(vars, weights, conf.level) {
|
||
| 259 | -3x | +392 | +2x |
- args |> utils::modifyList(list(FUN = survey::svymean, deff = TRUE))+ summands <- weights^2 * vars |
| 260 | +393 |
- ) |>+ # Stratified quantile |
||
| 261 | -3x | +394 | +2x |
- dplyr::select(all_of(by), dplyr::last_col()) # the last column is DEff+ sqrt(sum(summands)) / sum(sqrt(summands)) * stats::qnorm((1 + conf.level) / 2) |
| 262 | +395 |
- )+ } |
||
| 263 | +396 |
- } else {
+
|
||
| 264 | -27x | +|||
| 397 | +
- cards::eval_capture_conditions(do.call(survey::svyby, args))+ #' Helper Function for the Estimation of Weights for `proportion_ci_strat_wilson()` |
|||
| 265 | +398 |
- }+ #' |
||
| 266 | +399 |
-
+ #' This function wraps the iteration procedure that allows you to estimate |
||
| 267 | +400 |
- # if the result was calculated, then put it into a tibble+ #' the weights for each proportional strata. This assumes to minimize the |
||
| 268 | -38x | +|||
| 401 | +
- if (!is.null(stat[["result"]])) {
+ #' weighted squared length of the confidence interval. |
|||
| 269 | -32x | +|||
| 402 | +
- df_stat <- stat[["result"]][seq_len(length(by) + 1L)] |>+ #' |
|||
| 270 | -32x | +|||
| 403 | +
- dplyr::as_tibble() %>%+ #' @keywords internal |
|||
| 271 | +404 | ++ |
+ #' @inheritParams proportion_ci_strat_wilson+ |
+ |
| 405 | ++ |
+ #' @param vars (`numeric`)\cr normalized proportions for each strata.+ |
+ ||
| 406 | ++ |
+ #' @param strata_qnorm (`numeric`)\cr initial estimation with identical weights of the quantiles.+ |
+ ||
| 407 | ++ |
+ #' @param initial_weights (`numeric`)\cr initial weights used to calculate `strata_qnorm`. This can+ |
+ ||
| 408 | ++ |
+ #' be optimized in the future if we need to estimate better initial weights.+ |
+ ||
| 409 | ++ |
+ #' @param n_per_strata (`numeric`)\cr number of elements in each strata.+ |
+ ||
| 410 | ++ |
+ #' @param max.iterations (`count`)\cr maximum number of iterations to be tried. Convergence is always checked.+ |
+ ||
| 411 | ++ |
+ #' @param tol (`number`)\cr tolerance threshold for convergence.+ |
+ ||
| 412 | ++ |
+ #'+ |
+ ||
| 413 | ++ |
+ #' @return A `list` of 3 elements: `n_it`, `weights`, and `diff_v`.+ |
+ ||
| 414 | ++ |
+ #'+ |
+ ||
| 415 | ++ |
+ #' @seealso For references and details see [`proportion_ci_strat_wilson()`].+ |
+ ||
| 416 | ++ |
+ #'+ |
+ ||
| 417 | ++ |
+ #' @examples+ |
+ ||
| 418 | ++ |
+ #' vs <- c(0.011, 0.013, 0.012, 0.014, 0.017, 0.018)+ |
+ ||
| 419 | ++ |
+ #' sq <- 0.674+ |
+ ||
| 420 | ++ |
+ #' ws <- rep(1 / length(vs), length(vs))+ |
+ ||
| 421 | ++ |
+ #' ns <- c(22, 18, 17, 17, 14, 12)+ |
+ ||
| 422 | ++ |
+ #'+ |
+ ||
| 423 | ++ |
+ #' cardx:::.update_weights_strat_wilson(vs, sq, ws, ns, 100, 0.95, 0.001)+ |
+ ||
| 424 | ++ |
+ .update_weights_strat_wilson <- function(vars,+ |
+ ||
| 425 | ++ |
+ strata_qnorm,+ |
+ ||
| 426 | ++ |
+ initial_weights,+ |
+ ||
| 427 | ++ |
+ n_per_strata,+ |
+ ||
| 428 | ++ |
+ max.iterations = 50,+ |
+ ||
| 429 | ++ |
+ conf.level = 0.95,+ |
+ ||
| 430 | ++ |
+ tol = 0.001) {
+ |
+ ||
| 431 | +! | +
+ it <- 0+ |
+ ||
| 432 | +! | +
+ diff_v <- NULL+ |
+ ||
| 433 | ++ | + + | +||
| 434 | +! | +
+ while (it < max.iterations) {
+ |
+ ||
| 435 | +! | +
+ it <- it + 1+ |
+ ||
| 436 | +! | +
+ weights_new_t <- (1 + strata_qnorm^2 / n_per_strata)^2+ |
+ ||
| 437 | +! | +
+ weights_new_b <- (vars + strata_qnorm^2 / (4 * n_per_strata^2))+ |
+ ||
| 438 | +! | +
+ weights_new <- weights_new_t / weights_new_b+ |
+ ||
| 439 | +! | +
+ weights_new <- weights_new / sum(weights_new)+ |
+ ||
| 440 | +! | +
+ strata_qnorm <- .strata_normal_quantile(vars, weights_new, conf.level)+ |
+ ||
| 441 | +! | +
+ diff_v <- c(diff_v, sum(abs(weights_new - initial_weights)))+ |
+ ||
| 442 | +! | +
+ if (diff_v[length(diff_v)] < tol) break+ |
+ ||
| 443 | +! | +
+ initial_weights <- weights_new+ |
+ ||
| 444 | ++ |
+ }+ |
+ ||
| 445 | ++ | + + | +||
| 446 | +! | +
+ if (it == max.iterations) {
+ |
+ ||
| 447 | +! | +
+ warning("The heuristic to find weights did not converge with max.iterations = ", max.iterations)
+ |
+ ||
| 448 | ++ |
+ }+ |
+ ||
| 449 |
- # adding unobserved combinations of "by" variables+ |
|||
| 272 | -+ | |||
| 450 | +! |
- {
+ list( |
||
| 273 | -32x | +|||
| 451 | +! |
- dplyr::full_join(+ "n_it" = it, |
||
| 274 | -32x | +|||
| 452 | +! |
- cards::nest_for_ard(data$variables, by = by, key = "...ard_no_one_will_ever_pick_this...", rename = FALSE, list_columns = FALSE) |>+ "weights" = weights_new, |
||
| 275 | -32x | +|||
| 453 | +! |
- dplyr::select(-"...ard_no_one_will_ever_pick_this..."),+ "diff_v" = diff_v |
||
| 276 | +454 |
- .,+ ) |
||
| 277 | -32x | +|||
| 455 | +
- by = by+ } |
| 278 | +1 |
- )+ #' ARD Continuous Survey Statistics |
|
| 279 | +2 |
- } |>+ #' |
|
| 280 | -32x | +||
| 3 | +
- set_names(paste0("group", seq_along(by), "_level"), "stat") |>
+ #' Returns an ARD of weighted statistics using the `{survey}` package.
|
||
| 281 | -32x | +||
| 4 | +
- dplyr::bind_cols(+ #' |
||
| 282 | -32x | +||
| 5 | +
- dplyr::tibble(!!!c(by, variable)) |>+ #' @param data (`survey.design`)\cr |
||
| 283 | -32x | +||
| 6 | +
- set_names(paste0("group", seq_along(by)), "variable")
+ #' a design object often created with [`survey::svydesign()`]. |
||
| 284 | +7 |
- ) |>+ #' @param variables ([`tidy-select`][dplyr::dplyr_tidy_select])\cr |
|
| 285 | -32x | +||
| 8 | +
- dplyr::mutate(+ #' columns to include in summaries. Default is `everything()`. |
||
| 286 | -32x | +||
| 9 | +
- dplyr::across(c(cards::all_ard_groups("levels"), "stat"), as.list),
+ #' @param by ([`tidy-select`][dplyr::dplyr_tidy_select])\cr |
||
| 287 | -32x | +||
| 10 | +
- warning = list(.env$stat[["warning"]]),+ #' results are calculated for **all combinations** of the columns specified, |
||
| 288 | -32x | +||
| 11 | +
- error = list(.env$stat[["error"]])+ #' including unobserved combinations and unobserved factor levels. |
||
| 289 | +12 |
- )+ #' @param statistic ([`formula-list-selector`][syntax])\cr |
|
| 290 | +13 |
- }+ #' a named list, a list of formulas, |
|
| 291 | +14 |
- # otherwise, if there was an error return tibble with error message+ #' or a single formula where the list element is a character vector of |
|
| 292 | +15 |
- else {
+ #' statistic names to include. See below for options. |
|
| 293 | -6x | +||
| 16 | +
- df_stat <-+ #' @param fmt_fn ([`formula-list-selector`][syntax])\cr |
||
| 294 | -6x | +||
| 17 | +
- cards::nest_for_ard(data$variables, by = by, key = "...ard_no_one_will_ever_pick_this...") |>+ #' a named list, a list of formulas, |
||
| 295 | -6x | +||
| 18 | +
- dplyr::select(-"...ard_no_one_will_ever_pick_this...") |>+ #' or a single formula where the list element is a named list of functions |
||
| 296 | -6x | +||
| 19 | +
- dplyr::mutate(+ #' (or the RHS of a formula), |
||
| 297 | -6x | +||
| 20 | +
- variable = .env$variable,+ #' e.g. `list(mpg = list(mean = \(x) round(x, digits = 2) |> as.character))`. |
||
| 298 | -6x | +||
| 21 | +
- stat = list(NULL),+ #' @param stat_label ([`formula-list-selector`][syntax])\cr |
||
| 299 | -6x | +||
| 22 | +
- warning = list(.env$stat[["warning"]]),+ #' a named list, a list of formulas, or a single formula where |
||
| 300 | -6x | +||
| 23 | +
- error = list(.env$stat[["error"]])+ #' the list element is either a named list or a list of formulas defining the |
||
| 301 | +24 |
- )+ #' statistic labels, e.g. `everything() ~ list(mean = "Mean", sd = "SD")` or |
|
| 302 | +25 |
- }+ #' `everything() ~ list(mean ~ "Mean", sd ~ "SD")`. |
|
| 303 | +26 |
- }+ #' |
|
| 304 | +27 |
-
+ #' @section statistic argument: |
|
| 305 | -76x | +||
| 28 | +
- df_stat |>+ #' |
||
| 306 | -76x | +||
| 29 | +
- dplyr::mutate(stat_name = .env$stat_name)+ #' The following statistics are available: |
||
| 307 | +30 |
- }+ #' `r cardx:::accepted_svy_stats(FALSE) |> shQuote("sh") |> paste(collapse = ", ")`,
+ |
+ |
| 31 | ++ |
+ #' where 'p##' is are the percentiles and `##` is an integer between 0 and 100. |
| 1 | +32 |
- #' ARD Wilcoxon Rank-Sum Test+ #' |
||
| 2 | +33 |
#' |
||
| 3 | +34 |
- #' @description+ #' @return an ARD data frame of class 'card' |
||
| 4 | +35 |
- #' Analysis results data for paired and non-paired Wilcoxon Rank-Sum tests.+ #' @export |
||
| 5 | +36 |
#' |
||
| 6 | +37 |
- #' @param data (`data.frame`)\cr+ #' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = "survey", reference_pkg = "cardx"))
|
||
| 7 | +38 |
- #' a data frame. See below for details.+ #' data(api, package = "survey") |
||
| 8 | +39 |
- #' @param by ([`tidy-select`][dplyr::dplyr_tidy_select])\cr+ #' dclus1 <- survey::svydesign(id = ~dnum, weights = ~pw, data = apiclus1, fpc = ~fpc) |
||
| 9 | +40 |
- #' optional column name to compare by.+ #' |
||
| 10 | +41 |
- #' @param variables ([`tidy-select`][dplyr::dplyr_tidy_select])\cr+ #' ard_survey_svycontinuous( |
||
| 11 | +42 |
- #' column names to be compared. Independent tests will be computed for+ #' data = dclus1, |
||
| 12 | +43 |
- #' each variable.+ #' variables = api00, |
||
| 13 | +44 |
- #' @param id ([`tidy-select`][dplyr::dplyr_tidy_select])\cr+ #' by = stype |
||
| 14 | +45 |
- #' column name of the subject or participant ID.+ #' ) |
||
| 15 | +46 |
- #' @param ... arguments passed to `wilcox.test(...)`+ ard_survey_svycontinuous <- function(data, variables, by = NULL, |
||
| 16 | +47 |
- #'+ statistic = everything() ~ c("median", "p25", "p75"),
|
||
| 17 | +48 |
- #' @return ARD data frame+ fmt_fn = NULL, |
||
| 18 | +49 |
- #' @name ard_stats_wilcox_test+ stat_label = NULL) {
|
||
| 19 | -+ | |||
| 50 | +10x |
- #'+ set_cli_abort_call() |
||
| 20 | +51 |
- #' @details+ |
||
| 21 | +52 |
- #' For the `ard_stats_wilcox_test()` function, the data is expected to be one row per subject.+ # check installed packages --------------------------------------------------- |
||
| 22 | -+ | |||
| 53 | +10x |
- #' The data is passed as `wilcox.test(data[[variable]] ~ data[[by]], paired = FALSE, ...)`.+ check_pkg_installed(pkg = "survey", reference_pkg = "cardx") |
||
| 23 | +54 |
- #'+ |
||
| 24 | +55 |
- #' For the `ard_stats_paired_wilcox_test()` function, the data is expected to be one row+ # check inputs --------------------------------------------------------------- |
||
| 25 | -+ | |||
| 56 | +10x |
- #' per subject per by level. Before the test is calculated, the data are+ check_not_missing(data) |
||
| 26 | -+ | |||
| 57 | +10x |
- #' reshaped to a wide format to be one row per subject.+ check_class(data, cls = "survey.design") |
||
| 27 | -+ | |||
| 58 | +10x |
- #' The data are then passed as+ check_not_missing(variables) |
||
| 28 | +59 |
- #' `wilcox.test(x = data_wide[[<by level 1>]], y = data_wide[[<by level 2>]], paired = TRUE, ...)`.+ |
||
| 29 | +60 |
- #'+ # process inputs ------------------------------------------------------------- |
||
| 30 | -+ | |||
| 61 | +10x |
- #' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = "broom", reference_pkg = "cardx"))
+ cards::process_selectors(data$variables, variables = {{ variables }}, by = {{ by }})
|
||
| 31 | -+ | |||
| 62 | +10x |
- #' cards::ADSL |>+ variables <- setdiff(variables, by) |
||
| 32 | -+ | |||
| 63 | +10x |
- #' dplyr::filter(ARM %in% c("Placebo", "Xanomeline High Dose")) |>
+ cards::process_formula_selectors( |
||
| 33 | -+ | |||
| 64 | +10x |
- #' ard_stats_wilcox_test(by = "ARM", variables = "AGE")+ data$variables[variables], |
||
| 34 | -+ | |||
| 65 | +10x |
- #'+ statistic = statistic, |
||
| 35 | -+ | |||
| 66 | +10x |
- #' # constructing a paired data set,+ fmt_fn = fmt_fn, |
||
| 36 | -+ | |||
| 67 | +10x |
- #' # where patients receive both treatments+ stat_label = stat_label |
||
| 37 | +68 |
- #' cards::ADSL[c("ARM", "AGE")] |>
+ ) |
||
| 38 | -+ | |||
| 69 | +10x |
- #' dplyr::filter(ARM %in% c("Placebo", "Xanomeline High Dose")) |>
+ cards::fill_formula_selectors( |
||
| 39 | -+ | |||
| 70 | +10x |
- #' dplyr::mutate(.by = ARM, USUBJID = dplyr::row_number()) |>+ data$variables[variables], |
||
| 40 | -+ | |||
| 71 | +10x |
- #' dplyr::arrange(USUBJID, ARM) |>+ statistic = formals(ard_survey_svycontinuous)[["statistic"]] |> eval() |
||
| 41 | +72 |
- #' ard_stats_paired_wilcox_test(by = ARM, variables = AGE, id = USUBJID)+ ) |
||
| 42 | -+ | |||
| 73 | +10x |
- NULL+ cards::check_list_elements( |
||
| 43 | -+ | |||
| 74 | +10x |
-
+ x = statistic, |
||
| 44 | -+ | |||
| 75 | +10x | +
+ predicate = \(x) all(x %in% accepted_svy_stats()),+ |
+ ||
| 76 | +10x | +
+ error_msg = c("Error in the values of the {.arg statistic} argument.",
+ |
+ ||
| 77 | +10x |
- #' @rdname ard_stats_wilcox_test+ i = "Values must be in {.val {accepted_svy_stats(FALSE)}}"
|
||
| 45 | +78 |
- #' @export+ ) |
||
| 46 | +79 |
- ard_stats_wilcox_test <- function(data, variables, by = NULL, ...) {
- |
- ||
| 47 | -5x | -
- set_cli_abort_call()+ ) |
||
| 48 | +80 | |||
| 49 | +81 |
- # check installed packages ---------------------------------------------------+ # compute the weighted statistics -------------------------------------------- |
||
| 50 | -5x | +82 | +10x |
- check_pkg_installed("broom", reference_pkg = "cardx")
+ df_stats <- |
| 51 | -+ | |||
| 83 | +10x |
-
+ map( |
||
| 52 | -+ | |||
| 84 | +10x |
- # check/process inputs -------------------------------------------------------+ names(statistic), |
||
| 53 | -5x | +85 | +10x |
- check_not_missing(data)+ function(variable) {
|
| 54 | -5x | +86 | +10x |
- check_not_missing(variables)+ map( |
| 55 | -5x | +87 | +10x |
- check_data_frame(data)+ statistic[[variable]], |
| 56 | -5x | +88 | +10x |
- data <- dplyr::ungroup(data)+ function(statistic) {
|
| 57 | -5x | +89 | +76x |
- cards::process_selectors(data, by = {{ by }}, variables = {{ variables }})
+ .compute_svy_stat(data, variable = variable, by = by, stat_name = statistic) |
| 58 | -5x | +|||
| 90 | +
- check_scalar(by, allow_empty = TRUE)+ } |
|||
| 59 | +91 |
-
+ ) |
||
| 60 | +92 |
- # if no variables selected, return empty tibble ------------------------------+ } |
||
| 61 | -5x | +|||
| 93 | +
- if (is_empty(variables)) {
+ ) |> |
|||
| 62 | -! | +|||
| 94 | +10x |
- return(dplyr::tibble())+ dplyr::bind_rows() |
||
| 63 | +95 |
- }+ |
||
| 64 | +96 | |||
| 65 | +97 |
- # build ARD ------------------------------------------------------------------- |
- ||
| 66 | -5x | -
- lapply(- |
- ||
| 67 | -5x | -
- variables,+ # add stat_labels ------------------------------------------------------------ |
||
| 68 | -5x | +98 | +10x |
- function(variable) {
+ df_stats <- |
| 69 | -6x | +99 | +10x |
- .format_wilcoxtest_results(+ df_stats |> |
| 70 | -6x | +100 | +10x |
- by = by,+ dplyr::left_join( |
| 71 | -6x | +101 | +10x |
- variable = variable,+ .default_svy_stat_labels(), |
| 72 | -6x | +102 | +10x |
- lst_tidy =+ by = "stat_name" |
| 73 | +103 |
- # styler: off+ ) |> |
||
| 74 | -6x | +104 | +10x |
- cards::eval_capture_conditions(+ dplyr::mutate(stat_label = dplyr::coalesce(.data$stat_label, .data$stat_name)) |
| 75 | -6x | +105 | +10x |
- if (!is_empty(by)) {
+ if (!is_empty(stat_label)) {
|
| 76 | -5x | +106 | +1x |
- stats::wilcox.test(data[[variable]] ~ data[[by]], ...) |>+ df_stats <- |
| 77 | -5x | -
- broom::tidy()- |
- ||
| 78 | -- |
- }- |
- ||
| 79 | -+ | 107 | +1x |
- else {
+ dplyr::rows_update( |
| 80 | +108 | 1x |
- stats::wilcox.test(data[[variable]], ...) |>+ df_stats, |
|
| 81 | +109 | 1x |
- broom::tidy()- |
- |
| 82 | -- |
- }- |
- ||
| 83 | -- |
- ),- |
- ||
| 84 | -- |
- # styler: on+ dplyr::tibble( |
||
| 85 | -6x | -
- paired = FALSE,- |
- ||
| 86 | -- |
- ...- |
- ||
| 87 | -- |
- )- |
- ||
| 88 | -+ | 110 | +1x |
- }+ variable = names(stat_label), |
| 89 | -+ | |||
| 111 | +1x |
- ) |>+ stat_name = map(.data$variable, ~ names(stat_label[[.x]])), |
||
| 90 | -5x | +112 | +1x |
- dplyr::bind_rows()+ stat_label = map(.data$variable, ~ stat_label[[.x]] |> |
| 91 | -+ | |||
| 113 | +1x |
- }+ unname() |> |
||
| 92 | -+ | |||
| 114 | +1x |
-
+ unlist()) |
||
| 93 | +115 |
- #' @rdname ard_stats_wilcox_test+ ) |> |
||
| 94 | -+ | |||
| 116 | +1x |
- #' @export+ tidyr::unnest(cols = c("stat_name", "stat_label")),
|
||
| 95 | -+ | |||
| 117 | +1x |
- ard_stats_paired_wilcox_test <- function(data, by, variables, id, ...) {
+ by = "stat_name", |
||
| 96 | -2x | +118 | +1x |
- set_cli_abort_call()+ unmatched = "ignore" |
| 97 | +119 |
-
+ ) |
||
| 98 | +120 |
- # check installed packages ---------------------------------------------------- |
- ||
| 99 | -2x | -
- check_pkg_installed("broom", reference_pkg = "cardx")
+ } |
||
| 100 | +121 | |||
| 101 | +122 |
- # check/process inputs -------------------------------------------------------+ # add formatting stats ------------------------------------------------------- |
||
| 102 | -2x | +123 | +10x |
- check_not_missing(data)+ df_stats$fmt_fn <- list(1L) |
| 103 | -2x | +124 | +10x |
- check_not_missing(variables)+ if (!is_empty(fmt_fn)) {
|
| 104 | -2x | +125 | +1x |
- check_not_missing(by)+ df_stats <- |
| 105 | -2x | +126 | +1x |
- check_not_missing(id)+ dplyr::rows_update( |
| 106 | -2x | +127 | +1x |
- check_data_frame(data)+ df_stats, |
| 107 | -2x | +128 | +1x |
- data <- dplyr::ungroup(data)+ dplyr::tibble( |
| 108 | -2x | +129 | +1x |
- cards::process_selectors(data, by = {{ by }}, variables = {{ variables }}, id = {{ id }})
+ variable = names(fmt_fn), |
| 109 | -2x | +130 | +1x |
- check_scalar(by)+ stat_name = map(.data$variable, ~ names(fmt_fn[[.x]])), |
| 110 | -2x | +131 | +1x |
- check_scalar(id)+ fmt_fn = map(.data$variable, ~ fmt_fn[[.x]] |> unname()) |
| 111 | +132 |
-
+ ) |> |
||
| 112 | -+ | |||
| 133 | +1x |
- # if no variables selected, return empty tibble ------------------------------+ tidyr::unnest(cols = c("stat_name", "fmt_fn")),
|
||
| 113 | -2x | +134 | +1x |
- if (is_empty(variables)) {
+ by = "stat_name", |
| 114 | -! | +|||
| 135 | +1x |
- return(dplyr::tibble())+ unmatched = "ignore" |
||
| 115 | +136 | ++ |
+ )+ |
+ |
| 137 |
} |
|||
| 116 | +138 | |||
| 117 | +139 |
- # build ARD ------------------------------------------------------------------+ # add class and return ARD object -------------------------------------------- |
||
| 118 | -2x | +140 | +10x |
- lapply(+ df_stats |> |
| 119 | -2x | +141 | +10x |
- variables,+ dplyr::mutate(context = "survey_svycontinuous") |> |
| 120 | -2x | +142 | +10x |
- function(variable) {
+ cards::tidy_ard_column_order() %>% |
| 121 | -2x | +143 | +10x |
- .format_wilcoxtest_results(+ {structure(., class = c("card", class(.)))} # styler: off
|
| 122 | -2x | +|||
| 144 | +
- by = by,+ } |
|||
| 123 | -2x | +|||
| 145 | +
- variable = variable,+ + |
+ |||
| 146 | ++ |
+ .default_svy_stat_labels <- function(stat_label = NULL) {
|
||
| 124 | -2x | +147 | +10x |
- lst_tidy =+ dplyr::tribble( |
| 125 | -2x | +148 | +10x |
- cards::eval_capture_conditions({
+ ~stat_name, ~stat_label, |
| 126 | -+ | |||
| 149 | +10x |
- # adding this reshape inside the eval, so if there is an error it's captured in the ARD object+ "mean", "Mean", |
||
| 127 | -2x | +150 | +10x |
- data_wide <- .paired_data_pivot_wider(data, by = by, variable = variable, id = id)+ "median", "Median", |
| 128 | -+ | |||
| 151 | +10x |
- # perform paired wilcox test+ "var", "Variance", |
||
| 129 | -1x | +152 | +10x |
- stats::wilcox.test(x = data_wide[["by1"]], y = data_wide[["by2"]], paired = TRUE, ...) |>+ "sd", "Standard Deviation", |
| 130 | -1x | +153 | +10x |
- broom::tidy()+ "sum", "Sum", |
| 131 | -+ | |||
| 154 | +10x |
- }),+ "deff", "Design Effect", |
||
| 132 | -2x | +155 | +10x |
- paired = TRUE,+ "mean.std.error", "SE(Mean)", |
| 133 | -+ | |||
| 156 | +10x |
- ...+ "min", "Minimum", |
||
| 134 | -+ | |||
| 157 | +10x |
- )+ "max", "Maximum", |
||
| 135 | -+ | |||
| 158 | +10x |
- }+ "p25", "25% Percentile", |
||
| 136 | -+ | |||
| 159 | +10x |
- ) |>+ "p75", "75% Percentile" |
||
| 137 | -2x | +|||
| 160 | +
- dplyr::bind_rows()+ ) |
|||
| 138 | +161 |
} |
||
| 139 | +162 | |||
| 140 | +163 |
-
+ accepted_svy_stats <- function(expand_quantiles = TRUE) {
|
||
| 141 | -+ | |||
| 164 | +10x |
- #' Convert Wilcoxon test to ARD+ base_stats <- |
||
| 142 | -+ | |||
| 165 | +10x |
- #'+ c("mean", "median", "min", "max", "sum", "var", "sd", "mean.std.error", "deff")
|
||
| 143 | -+ | |||
| 166 | +10x |
- #' @inheritParams cards::tidy_as_ard+ if (expand_quantiles) {
|
||
| 144 | -+ | |||
| 167 | +10x |
- #' @inheritParams stats::wilcox.test+ return(c(base_stats, paste0("p", 0:100)))
|
||
| 145 | +168 |
- #' @param by (`string`)\cr by column name+ } |
||
| 146 | -+ | |||
| 169 | +! |
- #' @param variable (`string`)\cr variable column name+ c(base_stats, "p##") |
||
| 147 | +170 |
- #' @param ... passed to `stats::wilcox.test(...)`+ } |
||
| 148 | +171 |
- #'+ |
||
| 149 | +172 |
- #' @return ARD data frame+ |
||
| 150 | +173 |
- #'+ |
||
| 151 | +174 |
- #' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = "broom", reference_pkg = "cardx"))
+ # this function calculates the summary for a single variable, single statistic |
||
| 152 | +175 |
- #' # Pre-processing ADSL to have grouping factor (ARM here) with 2 levels+ # and for all `by` levels. it returns an ARD data frame |
||
| 153 | +176 |
- #' ADSL <- cards::ADSL |>+ .compute_svy_stat <- function(data, variable, by = NULL, stat_name) {
|
||
| 154 | +177 |
- #' dplyr::filter(ARM %in% c("Placebo", "Xanomeline High Dose")) |>
+ # difftime variable needs to be transformed into numeric for svyquantile |
||
| 155 | -+ | |||
| 178 | +76x |
- #' ard_stats_wilcox_test(by = "ARM", variables = "AGE")+ if (inherits(data$variables[[variable]], "difftime")) {
|
||
| 156 | -+ | |||
| 179 | +! |
- #'+ data$variables[[variable]] <- unclass(data$variables[[variable]]) |
||
| 157 | +180 |
- #' cardx:::.format_wilcoxtest_results(+ } |
||
| 158 | +181 |
- #' by = "ARM",+ |
||
| 159 | +182 |
- #' variable = "AGE",+ # styler: off |
||
| 160 | -+ | |||
| 183 | +10x |
- #' paired = FALSE,+ if (stat_name %in% "mean") args <- list(FUN = survey::svymean) |
||
| 161 | -+ | |||
| 184 | +6x |
- #' lst_tidy =+ else if (stat_name %in% "sum") args <- list(FUN = survey::svytotal) |
||
| 162 | -+ | |||
| 185 | +6x |
- #' cards::eval_capture_conditions(+ else if (stat_name %in% "var") args <- list(FUN = survey::svyvar) |
||
| 163 | -+ | |||
| 186 | +6x |
- #' stats::wilcox.test(ADSL[["AGE"]] ~ ADSL[["ARM"]], paired = FALSE) |>+ else if (stat_name %in% "sd") args <- list(FUN = \(...) survey::svyvar(...) |> sqrt()) |
||
| 164 | -+ | |||
| 187 | +6x |
- #' broom::tidy()+ else if (stat_name %in% "mean.std.error") args <- list(FUN = \(...) survey::svymean(...) |> survey::SE()) |
||
| 165 | -+ | |||
| 188 | +6x |
- #' )+ else if (stat_name %in% "deff") args <- list(FUN = \(...) survey::svymean(..., deff = TRUE) |> survey::deff()) |
||
| 166 | -+ | |||
| 189 | +10x |
- #' )+ else if (stat_name %in% "min") args <- list(FUN = \(x, design, na.rm, ...) min(design$variables[[all.vars(x)]], na.rm = na.rm)) |
||
| 167 | -+ | |||
| 190 | +10x |
- #'+ else if (stat_name %in% "max") args <- list(FUN = \(x, design, na.rm, ...) max(design$variables[[all.vars(x)]], na.rm = na.rm)) |
||
| 168 | +191 |
- #' @keywords internal+ # define functions for the quantiles |
||
| 169 | -+ | |||
| 192 | +16x | +
+ else if (stat_name %in% c("median", paste0("p", 0:100))) {
+ |
+ ||
| 193 | +16x |
- .format_wilcoxtest_results <- function(by = NULL, variable, lst_tidy, paired, ...) {
+ quantile <- ifelse(stat_name %in% "median", 0.5, substr(stat_name, 2, nchar(stat_name)) |> as.numeric() %>% `/`(100)) |
||
| 170 | +194 |
- # build ARD ------------------------------------------------------------------+ # univariate results are returned in a different format from stratified. |
||
| 171 | -8x | +195 | +16x |
- ret <-+ args <- |
| 172 | -8x | +196 | +16x |
- cards::tidy_as_ard(+ if (is_empty(by)) list(FUN = \(...) survey::svyquantile(...)[[1]], quantiles = quantile) |
| 173 | -8x | +197 | +16x |
- lst_tidy = lst_tidy,+ else list(FUN = \(...) survey::svyquantile(...), quantiles = quantile) |
| 174 | -8x | +|||
| 198 | +
- tidy_result_names = c("statistic", "p.value", "method", "alternative"),
+ } |
|||
| 175 | -8x | +|||
| 199 | +
- fun_args_to_record = c(+ # styler: on |
|||
| 176 | -8x | +|||
| 200 | +
- "mu", "paired", "exact", "correct", "conf.int",+ |
|||
| 177 | -8x | +|||
| 201 | +
- "conf.level", "tol.root", "digits.rank"+ # adding additional args to pass |
|||
| 178 | -+ | |||
| 202 | +76x |
- ),+ args <- |
||
| 179 | -8x | +203 | +76x |
- formals = formals(asNamespace("stats")[["wilcox.test.default"]]),
+ args |> |
| 180 | -8x | +204 | +76x |
- passed_args = c(list(paired = paired), dots_list(...)),+ append( |
| 181 | -8x | +205 | +76x |
- lst_ard_columns = list(variable = variable, context = "stats_wilcox_test")+ list( |
| 182 | -+ | |||
| 206 | +76x |
- )+ design = data, |
||
| 183 | +207 |
-
+ # if all values are NA, turn na.rm to FALSE to avoid error |
||
| 184 | -8x | +208 | +76x |
- if (!is_empty(by)) {
+ na.rm = !all(is.na(data$variables[[variable]])), |
| 185 | -7x | +209 | +76x |
- ret <- ret |>+ keep.var = FALSE |
| 186 | -7x | +|||
| 210 | +
- dplyr::mutate(group1 = by)+ ) |
|||
| 187 | +211 |
- }+ ) |
||
| 188 | +212 | |||
| 189 | +213 |
- # add the stat label ---------------------------------------------------------- |
- ||
| 190 | -8x | -
- ret |>+ |
||
| 191 | -8x | +|||
| 214 | +
- dplyr::left_join(+ # if no by variable, calculate univariate statistics |
|||
| 192 | -8x | +215 | +76x |
- .df_wilcoxtest_stat_labels(by),+ if (is_empty(by)) {
|
| 193 | -8x | +216 | +38x |
- by = "stat_name"+ args$x <- stats::reformulate(variable) |
| 194 | +217 |
- ) |>+ # calculate statistic (and remove FUN from the argument list) |
||
| 195 | -8x | +218 | +38x |
- dplyr::mutate(stat_label = dplyr::coalesce(.data$stat_label, .data$stat_name)) |>+ stat <- |
| 196 | -8x | +219 | +38x |
- cards::tidy_ard_column_order()+ cards::eval_capture_conditions( |
| 197 | -+ | |||
| 220 | +38x |
- }+ do.call(args$FUN, args = args |> utils::modifyList(list(FUN = NULL))) |
||
| 198 | +221 |
-
+ ) |
||
| 199 | +222 |
-
+ # if the result was calculated, then put it into a tibble |
||
| 200 | -+ | |||
| 223 | +38x |
- .df_wilcoxtest_stat_labels <- function(by = NULL) {
+ if (!is.null(stat[["result"]])) {
|
||
| 201 | -8x | +224 | +32x |
- dplyr::tribble(+ df_stat <- |
| 202 | -8x | +225 | +32x |
- ~stat_name, ~stat_label,+ dplyr::tibble(variable, stat[["result"]][1]) |> |
| 203 | -8x | +226 | +32x |
- "statistic", ifelse(is.null(by), "V Statistic", "X-squared Statistic"),+ set_names(c("variable", "stat")) |>
|
| 204 | -8x | +227 | +32x |
- "parameter", "Degrees of Freedom",+ dplyr::mutate( |
| 205 | -8x | +228 | +32x |
- "estimate", "Median of the Difference",+ stat = as.list(unname(.data$stat)), |
| 206 | -8x | +229 | +32x |
- "p.value", "p-value",+ warning = list(stat[["warning"]]), |
| 207 | -8x | +230 | +32x | +
+ error = list(stat[["error"]])+ |
+
| 231 | ++ |
+ )+ |
+ ||
| 232 | ++ |
+ }+ |
+ ||
| 233 | +
- "conf.low", "CI Lower Bound",+ # otherwise, if there was an error return tibble with error message |
|||
| 208 | -8x | +|||
| 234 | +
- "conf.high", "CI Upper Bound",+ else {
|
|||
| 209 | -8x | +235 | +6x |
- "paired", "Paired test",+ df_stat <- |
| 210 | -8x | +236 | +6x |
- "conf.level", "CI Confidence Level",+ dplyr::tibble( |
| 211 | -+ | |||
| 237 | +6x |
- )+ variable = .env$variable, |
||
| 212 | -+ | |||
| 238 | +6x |
- }+ stat = list(NULL), |
| 1 | -+ | |||
| 239 | +6x |
- #' ARD for Difference in Survival+ warning = list(.env$stat[["warning"]]), |
||
| 2 | -+ | |||
| 240 | +6x |
- #'+ error = list(.env$stat[["error"]]) |
||
| 3 | +241 |
- #' @description+ ) |
||
| 4 | +242 |
- #' Analysis results data for comparison of survival using [survival::survdiff()].+ } |
||
| 5 | +243 |
- #'+ } |
||
| 6 | +244 |
- #' @param formula (`formula`)\cr+ |
||
| 7 | +245 |
- #' a formula+ # if there is by variable(s), calculate statistics for the combinations |
||
| 8 | +246 |
- #' @param data (`data.frame`)\cr+ else {
|
||
| 9 | -+ | |||
| 247 | +38x |
- #' a data frame+ args$formula <- stats::reformulate(variable) |
||
| 10 | -+ | |||
| 248 | +38x |
- #' @param rho (`scalar numeric`)\cr+ args$by <- stats::reformulate(by) |
||
| 11 | -+ | |||
| 249 | +38x |
- #' numeric scalar passed to `survival::survdiff(rho)`. Default is `rho=0`.+ stat <- |
||
| 12 | -+ | |||
| 250 | +38x |
- #' @param ... additional arguments passed to `survival::survdiff()`+ if (stat_name %in% c("median", paste0("p", 0:100))) {
|
||
| 13 | -+ | |||
| 251 | +8x |
- #'+ cards::eval_capture_conditions( |
||
| 14 | -+ | |||
| 252 | +8x |
- #' @return an ARD data frame of class 'card'+ do.call(survey::svyby, args) |> set_names(c(by, "quantile", "ci.2.5", "ci.97.5", "se")) |
||
| 15 | +253 |
- #' @export+ ) |
||
| 16 | -+ | |||
| 254 | +38x |
- #'+ } else if (stat_name %in% "deff") {
|
||
| 17 | -+ | |||
| 255 | +3x |
- #' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = c("survival", "broom", "ggsurvfit"), reference_pkg = "cardx"))
+ stat <- |
||
| 18 | -+ | |||
| 256 | +3x |
- #' library(survival)+ cards::eval_capture_conditions( |
||
| 19 | -+ | |||
| 257 | +3x |
- #' library(ggsurvfit)+ do.call( |
||
| 20 | -+ | |||
| 258 | +3x |
- #'+ survey::svyby, |
||
| 21 | -+ | |||
| 259 | +3x |
- #' ard_survival_survdiff(Surv_CNSR(AVAL, CNSR) ~ TRTA, data = cards::ADTTE)+ args |> utils::modifyList(list(FUN = survey::svymean, deff = TRUE)) |
||
| 22 | +260 |
- ard_survival_survdiff <- function(formula, data, rho = 0, ...) {
+ ) |> |
||
| 23 | -4x | +261 | +3x |
- set_cli_abort_call()+ dplyr::select(all_of(by), dplyr::last_col()) # the last column is DEff |
| 24 | +262 |
-
+ ) |
||
| 25 | +263 |
- # check installed packages ---------------------------------------------------+ } else {
|
||
| 26 | -4x | +264 | +27x |
- check_pkg_installed(c("survival", "broom"), reference_pkg = "cardx")
+ cards::eval_capture_conditions(do.call(survey::svyby, args)) |
| 27 | +265 |
-
+ } |
||
| 28 | +266 |
- # check/process inputs -------------------------------------------------------- |
- ||
| 29 | -4x | -
- check_not_missing(formula)+ |
||
| 30 | -4x | +|||
| 267 | +
- check_class(formula, cls = "formula")+ # if the result was calculated, then put it into a tibble |
|||
| 31 | -4x | +268 | +38x |
- if (!missing(data)) check_class(data, cls = "data.frame")+ if (!is.null(stat[["result"]])) {
|
| 32 | -4x | +269 | +32x |
- check_scalar(rho)+ df_stat <- stat[["result"]][seq_len(length(by) + 1L)] |> |
| 33 | -4x | -
- check_class(rho, cls = "numeric")- |
- ||
| 34 | -+ | 270 | +32x |
-
+ dplyr::as_tibble() %>% |
| 35 | +271 |
- # assign method- |
- ||
| 36 | -4x | -
- method <- dplyr::case_when(+ # adding unobserved combinations of "by" variables |
||
| 37 | -4x | +|||
| 272 | +
- rho == 0 ~ "Log-rank test",+ {
|
|||
| 38 | -4x | +273 | +32x |
- rho == 1.5 ~ "Tarone-Ware test",+ dplyr::full_join( |
| 39 | -4x | +274 | +32x |
- rho == 1 ~ "Peto & Peto modification of Gehan-Wilcoxon test",+ cards::nest_for_ard(data$variables, by = by, key = "...ard_no_one_will_ever_pick_this...", rename = FALSE, list_columns = FALSE) |> |
| 40 | -4x | +275 | +32x |
- .default = glue::glue("G-rho test (\U03C1 = {rho})")
+ dplyr::select(-"...ard_no_one_will_ever_pick_this..."), |
| 41 | +276 |
- ) |>+ ., |
||
| 42 | -4x | +277 | +32x |
- as.character()+ by = by |
| 43 | +278 |
-
+ ) |
||
| 44 | +279 |
- # calculate survdiff() results ------------------------------------------------ |
- ||
| 45 | -4x | -
- lst_glance <-+ } |> |
||
| 46 | -4x | +280 | +32x |
- cards::eval_capture_conditions(+ set_names(paste0("group", seq_along(by), "_level"), "stat") |>
|
| 47 | -4x | +281 | +32x |
- survival::survdiff(formula = formula, data = data, rho = rho, ...) |>+ dplyr::bind_cols( |
| 48 | -4x | +282 | +32x |
- broom::glance() |>+ dplyr::tibble(!!!c(by, variable)) |> |
| 49 | -4x | -
- dplyr::mutate(method = .env$method)- |
- ||
| 50 | -- |
- )- |
- ||
| 51 | -+ | 283 | +32x |
-
+ set_names(paste0("group", seq_along(by)), "variable")
|
| 52 | +284 |
- # tidy results up in an ARD format -------------------------------------------+ ) |> |
||
| 53 | -+ | |||
| 285 | +32x |
- # extract variable names from formula+ dplyr::mutate( |
||
| 54 | -4x | +286 | +32x |
- variables <- stats::terms(formula) |>+ dplyr::across(c(cards::all_ard_groups("levels"), "stat"), as.list),
|
| 55 | -4x | +287 | +32x |
- attr("term.labels") |>
+ warning = list(.env$stat[["warning"]]), |
| 56 | -4x | +288 | +32x |
- .strip_backticks()+ error = list(.env$stat[["error"]]) |
| 57 | +289 |
-
+ ) |
||
| 58 | +290 |
- # if there was an error, return results early+ } |
||
| 59 | -4x | +|||
| 291 | +
- if (is.null(lst_glance[["result"]])) {
+ # otherwise, if there was an error return tibble with error message |
|||
| 60 | +292 |
- # if no variables in formula, then return an error+ else {
|
||
| 61 | -+ | |||
| 293 | +6x |
- # otherwise, if we do have variable names, then we can construct an empty ARD which will be done below+ df_stat <- |
||
| 62 | -2x | +294 | +6x |
- if (is_empty(variables)) {
+ cards::nest_for_ard(data$variables, by = by, key = "...ard_no_one_will_ever_pick_this...") |> |
| 63 | -1x | +295 | +6x |
- cli::cli_abort(+ dplyr::select(-"...ard_no_one_will_ever_pick_this...") |> |
| 64 | -1x | +296 | +6x |
- message =+ dplyr::mutate( |
| 65 | -1x | +297 | +6x |
- c("There was an error in {.fun survival::survdiff}. See below:",
+ variable = .env$variable, |
| 66 | -1x | +298 | +6x |
- "x" = lst_glance[["error"]]+ stat = list(NULL), |
| 67 | -+ | |||
| 299 | +6x |
- ),+ warning = list(.env$stat[["warning"]]), |
||
| 68 | -1x | +300 | +6x |
- call = get_cli_abort_call()+ error = list(.env$stat[["error"]]) |
| 69 | +301 |
- )+ ) |
||
| 70 | +302 |
} |
||
| 71 | +303 |
} |
||
| 72 | +304 | |||
| 73 | -3x | +305 | +76x |
- .variables_to_survdiff_ard(+ df_stat |> |
| 74 | -3x | +306 | +76x |
- variables = variables,+ dplyr::mutate(stat_name = .env$stat_name) |
| 75 | -3x | +|||
| 307 | +
- method = method,+ } |
| 76 | +1 |
- # styler: off+ #' ARD Wilcoxon Rank-Sum Test |
||
| 77 | -3x | +|||
| 2 | +
- stat_names =+ #'+ |
+ |||
| 3 | ++ |
+ #' @description |
||
| 78 | -3x | +|||
| 4 | +
- if (!is.null(lst_glance[["result"]])) names(lst_glance[["result"]])+ #' Analysis results data for paired and non-paired Wilcoxon Rank-Sum tests. |
|||
| 79 | -3x | +|||
| 5 | +
- else c("statistic", "df", "p.value", "method"),
+ #' |
|||
| 80 | -3x | +|||
| 6 | +
- stats =+ #' @param data (`data.frame`)\cr |
|||
| 81 | -3x | +|||
| 7 | +
- if (!is.null(lst_glance[["result"]])) unname(as.list(lst_glance[["result"]]))+ #' a data frame. See below for details. |
|||
| 82 | -3x | +|||
| 8 | +
- else rep_along(c("statistic", "df", "p.value"), list(NULL)) |> c(list(method = method))
+ #' @param by ([`tidy-select`][dplyr::dplyr_tidy_select])\cr |
|||
| 83 | +9 |
- # styler: on+ #' optional column name to compare by. |
||
| 84 | +10 |
- ) |>+ #' @param variables ([`tidy-select`][dplyr::dplyr_tidy_select])\cr |
||
| 85 | -3x | +|||
| 11 | +
- .add_survdiff_stat_labels() |>+ #' column names to be compared. Independent tests will be computed for |
|||
| 86 | -3x | +|||
| 12 | +
- dplyr::mutate(+ #' each variable. |
|||
| 87 | -3x | +|||
| 13 | +
- context = "survival_survdiff",+ #' @param id ([`tidy-select`][dplyr::dplyr_tidy_select])\cr |
|||
| 88 | -3x | +|||
| 14 | +
- warning = lst_glance["warning"],+ #' column name of the subject or participant ID. |
|||
| 89 | -3x | +|||
| 15 | +
- error = lst_glance["error"],+ #' @param ... arguments passed to `wilcox.test(...)` |
|||
| 90 | -3x | +|||
| 16 | +
- fmt_fn = map(+ #' |
|||
| 91 | -3x | +|||
| 17 | +
- .data$stat,+ #' @return ARD data frame |
|||
| 92 | -3x | +|||
| 18 | +
- function(x) {
+ #' @name ard_stats_wilcox_test |
|||
| 93 | -6x | +|||
| 19 | +
- if (is.numeric(x)) return(1L) # styler: off+ #' |
|||
| 94 | -6x | +|||
| 20 | +
- NULL+ #' @details |
|||
| 95 | +21 |
- }+ #' For the `ard_stats_wilcox_test()` function, the data is expected to be one row per subject. |
||
| 96 | +22 |
- )+ #' The data is passed as `wilcox.test(data[[variable]] ~ data[[by]], paired = FALSE, ...)`. |
||
| 97 | +23 |
- ) |>+ #' |
||
| 98 | -3x | +|||
| 24 | +
- cards::tidy_ard_column_order() %>%+ #' For the `ard_stats_paired_wilcox_test()` function, the data is expected to be one row |
|||
| 99 | -3x | +|||
| 25 | +
- {structure(., class = c("card", class(.)))} # styler: off
+ #' per subject per by level. Before the test is calculated, the data are |
|||
| 100 | +26 |
- }+ #' reshaped to a wide format to be one row per subject. |
||
| 101 | +27 |
-
+ #' The data are then passed as |
||
| 102 | +28 |
- .variables_to_survdiff_ard <- function(variables,+ #' `wilcox.test(x = data_wide[[<by level 1>]], y = data_wide[[<by level 2>]], paired = TRUE, ...)`. |
||
| 103 | +29 |
- method,+ #' |
||
| 104 | +30 |
- stat_names,+ #' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = "broom", reference_pkg = "cardx"))
|
||
| 105 | +31 |
- stats) {
+ #' cards::ADSL |> |
||
| 106 | -3x | +|||
| 32 | +
- len <- length(variables)+ #' dplyr::filter(ARM %in% c("Placebo", "Xanomeline High Dose")) |>
|
|||
| 107 | +33 |
-
+ #' ard_stats_wilcox_test(by = "ARM", variables = "AGE") |
||
| 108 | -3x | +|||
| 34 | +
- df_vars <- dplyr::tibble(!!!rev(variables)) |>+ #' |
|||
| 109 | -3x | +|||
| 35 | +
- set_names(+ #' # constructing a paired data set, |
|||
| 110 | -3x | +|||
| 36 | +
- ifelse(+ #' # where patients receive both treatments |
|||
| 111 | -3x | +|||
| 37 | +
- len > 1L,+ #' cards::ADSL[c("ARM", "AGE")] |>
|
|||
| 112 | -3x | +|||
| 38 | +
- c(paste0("group_", rev(seq_len(len - 1L))), "variable"),
+ #' dplyr::filter(ARM %in% c("Placebo", "Xanomeline High Dose")) |>
|
|||
| 113 | -3x | +|||
| 39 | +
- "variable"+ #' dplyr::mutate(.by = ARM, USUBJID = dplyr::row_number()) |> |
|||
| 114 | +40 |
- )+ #' dplyr::arrange(USUBJID, ARM) |> |
||
| 115 | +41 |
- )+ #' ard_stats_paired_wilcox_test(by = ARM, variables = AGE, id = USUBJID) |
||
| 116 | +42 |
-
+ NULL |
||
| 117 | -3x | +|||
| 43 | +
- dplyr::bind_cols(+ |
|||
| 118 | -3x | +|||
| 44 | +
- df_vars,+ #' @rdname ard_stats_wilcox_test |
|||
| 119 | -3x | +|||
| 45 | +
- dplyr::tibble(+ #' @export |
|||
| 120 | -3x | +|||
| 46 | +
- stat_name = .env$stat_names,+ ard_stats_wilcox_test <- function(data, variables, by = NULL, ...) {
|
|||
| 121 | -3x | +47 | +5x |
- stat = .env$stats+ set_cli_abort_call() |
| 122 | +48 |
- )+ |
||
| 123 | +49 |
- )+ # check installed packages --------------------------------------------------- |
||
| 124 | -+ | |||
| 50 | +5x |
- }+ check_pkg_installed("broom", reference_pkg = "cardx")
|
||
| 125 | +51 | |||
| 126 | +52 |
- .add_survdiff_stat_labels <- function(x) {
+ # check/process inputs ------------------------------------------------------- |
||
| 127 | -3x | +53 | +5x |
- x |>+ check_not_missing(data) |
| 128 | -3x | +54 | +5x |
- dplyr::left_join(+ check_not_missing(variables) |
| 129 | -3x | +55 | +5x |
- dplyr::tribble(+ check_data_frame(data) |
| 130 | -3x | +56 | +5x |
- ~stat_name, ~stat_label,+ data <- dplyr::ungroup(data) |
| 131 | -3x | +57 | +5x |
- "statistic", "X^2 Statistic",+ cards::process_selectors(data, by = {{ by }}, variables = {{ variables }})
|
| 132 | -3x | +58 | +5x |
- "df", "Degrees of Freedom",+ check_scalar(by, allow_empty = TRUE) |
| 133 | -3x | +|||
| 59 | +
- "p.value", "p-value"+ |
|||
| 134 | +60 |
- ),+ # if no variables selected, return empty tibble ------------------------------ |
||
| 135 | -3x | -
- by = "stat_name"- |
- ||
| 136 | -+ | 61 | +5x |
- ) |>+ if (is_empty(variables)) {
|
| 137 | -3x | +|||
| 62 | +! |
- dplyr::mutate(stat_label = dplyr::coalesce(.data$stat_label, .data$stat_name))+ return(dplyr::tibble()) |
||
| 138 | +63 |
- }+ } |
||
| 139 | +64 | |||
| 140 | +65 |
- .strip_backticks <- function(x) {
+ # build ARD ------------------------------------------------------------------ |
||
| 141 | -4x | +66 | +5x |
- ifelse(+ lapply( |
| 142 | -4x | +67 | +5x |
- str_detect(x, "^`.*`$"),+ variables, |
| 143 | -4x | +68 | +5x |
- substr(x, 2, nchar(x) - 1),+ function(variable) {
|
| 144 | -4x | +69 | +6x |
- x+ .format_wilcoxtest_results( |
| 145 | -+ | |||
| 70 | +6x |
- )+ by = by, |
||
| 146 | -+ | |||
| 71 | +6x |
- }+ variable = variable, |
| 1 | -+ | |||
| 72 | +6x |
- #' ARD Fisher's Exact Test+ lst_tidy = |
||
| 2 | +73 |
- #'+ # styler: off |
||
| 3 | -+ | |||
| 74 | +6x |
- #' @description+ cards::eval_capture_conditions( |
||
| 4 | -+ | |||
| 75 | +6x |
- #' Analysis results data for Fisher's Exact Test.+ if (!is_empty(by)) {
|
||
| 5 | -+ | |||
| 76 | +5x |
- #' Calculated with `fisher.test(x = data[[variable]], y = data[[by]], ...)`+ stats::wilcox.test(data[[variable]] ~ data[[by]], ...) |> |
||
| 6 | -+ | |||
| 77 | +5x |
- #'+ broom::tidy() |
||
| 7 | +78 |
- #'+ } |
||
| 8 | +79 |
- #' @param data (`data.frame`)\cr+ else {
|
||
| 9 | -+ | |||
| 80 | +1x |
- #' a data frame.+ stats::wilcox.test(data[[variable]], ...) |>+ |
+ ||
| 81 | +1x | +
+ broom::tidy() |
||
| 10 | +82 |
- #' @param by ([`tidy-select`][dplyr::dplyr_tidy_select])\cr+ } |
||
| 11 | +83 |
- #' column name to compare by+ ), |
||
| 12 | +84 |
- #' @param variables ([`tidy-select`][dplyr::dplyr_tidy_select])\cr+ # styler: on |
||
| 13 | -+ | |||
| 85 | +6x |
- #' column names to be compared. Independent tests will be computed for+ paired = FALSE, |
||
| 14 | +86 |
- #' each variable.+ ... |
||
| 15 | +87 |
- #' @param ... additional arguments passed to `fisher.test(...)`+ ) |
||
| 16 | +88 |
- #'+ } |
||
| 17 | +89 |
- #' @return ARD data frame+ ) |> |
||
| 18 | -+ | |||
| 90 | +5x |
- #' @export+ dplyr::bind_rows() |
||
| 19 | +91 |
- #'+ } |
||
| 20 | +92 |
- #' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = "broom", reference_pkg = "cardx"))
+
|
||
| 21 | +93 |
- #' cards::ADSL[1:30, ] |>+ #' @rdname ard_stats_wilcox_test |
||
| 22 | +94 |
- #' ard_stats_fisher_test(by = "ARM", variables = "AGEGR1")+ #' @export |
||
| 23 | +95 |
- ard_stats_fisher_test <- function(data, by, variables, ...) {
+ ard_stats_paired_wilcox_test <- function(data, by, variables, id, ...) {
|
||
| 24 | -3x | +96 | +2x |
set_cli_abort_call() |
| 25 | +97 | |||
| 26 | +98 |
# check installed packages --------------------------------------------------- |
||
| 27 | -3x | +99 | +2x |
check_pkg_installed("broom", reference_pkg = "cardx")
|
| 28 | +100 | |||
| 29 | +101 |
# check/process inputs ------------------------------------------------------- |
||
| 30 | -3x | +102 | +2x |
check_not_missing(data) |
| 31 | -3x | +103 | +2x |
check_not_missing(variables) |
| 32 | -3x | +104 | +2x |
check_not_missing(by) |
| 33 | -3x | +105 | +2x | +
+ check_not_missing(id)+ |
+
| 106 | +2x |
check_data_frame(data) |
||
| 34 | -3x | +107 | +2x |
- cards::process_selectors(data, by = {{ by }}, variables = {{ variables }})
+ data <- dplyr::ungroup(data) |
| 35 | -3x | +108 | +2x | +
+ cards::process_selectors(data, by = {{ by }}, variables = {{ variables }}, id = {{ id }})
+ |
+
| 109 | +2x |
check_scalar(by) |
||
| 110 | +2x | +
+ check_scalar(id)+ |
+ ||
| 36 | +111 | |||
| 37 | +112 |
# if no variables selected, return empty tibble ------------------------------ |
||
| 38 | -3x | +113 | +2x |
if (is_empty(variables)) {
|
| 39 | +114 | ! |
return(dplyr::tibble()) |
|
| 40 | +115 |
} |
||
| 41 | +116 |
- # build ARD ------------------------------------------------------------------- |
- ||
| 42 | -3x | -
- lapply(- |
- ||
| 43 | -3x | -
- variables,- |
- ||
| 44 | -3x | -
- function(variable) {
- |
- ||
| 45 | -4x | -
- cards::tidy_as_ard(- |
- ||
| 46 | -4x | -
- lst_tidy =- |
- ||
| 47 | -4x | -
- cards::eval_capture_conditions(- |
- ||
| 48 | -4x | -
- stats::fisher.test(x = data[[variable]], y = data[[by]], ...) |>- |
- ||
| 49 | -4x | -
- broom::tidy()+ |
||
| 50 | +117 |
- ),- |
- ||
| 51 | -4x | -
- tidy_result_names =+ # build ARD ------------------------------------------------------------------ |
||
| 52 | -4x | +118 | +2x |
- c("estimate", "p.value", "conf.low", "conf.high", "method", "alternative"),
+ lapply( |
| 53 | -4x | +119 | +2x |
- fun_args_to_record =+ variables, |
| 54 | -4x | +120 | +2x |
- c(+ function(variable) {
|
| 55 | -4x | +121 | +2x |
- "workspace", "hybrid", "hybridPars", "control", "or",+ .format_wilcoxtest_results( |
| 56 | -4x | -
- "conf.int", "conf.level", "simulate.p.value", "B"- |
- ||
| 57 | -+ | 122 | +2x |
- ),+ by = by, |
| 58 | -4x | +123 | +2x |
- formals = formals(stats::fisher.test),+ variable = variable, |
| 59 | -4x | +124 | +2x |
- passed_args = dots_list(...),+ lst_tidy = |
| 60 | -4x | +125 | +2x |
- lst_ard_columns = list(group1 = by, variable = variable, context = "stats_fisher_test")+ cards::eval_capture_conditions({
|
| 61 | +126 |
- ) |>+ # adding this reshape inside the eval, so if there is an error it's captured in the ARD object |
||
| 62 | -4x | +127 | +2x |
- dplyr::mutate(+ data_wide <- .paired_data_pivot_wider(data, by = by, variable = variable, id = id) |
| 63 | -4x | +|||
| 128 | +
- .after = "stat_name",+ # perform paired wilcox test |
|||
| 64 | -4x | +129 | +1x |
- stat_label =+ stats::wilcox.test(x = data_wide[["by1"]], y = data_wide[["by2"]], paired = TRUE, ...) |> |
| 65 | -4x | +130 | +1x |
- dplyr::case_when(+ broom::tidy() |
| 66 | -4x | +|||
| 131 | +
- .data$stat_name %in% "p.value" ~ "p-value",+ }), |
|||
| 67 | -4x | +132 | +2x |
- TRUE ~ .data$stat_name,+ paired = TRUE, |
| 68 | +133 |
- )+ ... |
||
| 69 | +134 |
- )+ ) |
||
| 70 | +135 |
} |
||
| 71 | +136 |
) |> |
||
| 72 | -3x | +137 | +2x |
dplyr::bind_rows() |
| 73 | +138 |
} |
| 1 | -- |
- #' ARD Hedge's G Test- |
- ||
| 2 | +139 |
- #'+ |
||
| 3 | +140 |
- #' @description+ |
||
| 4 | +141 |
- #' Analysis results data for paired and non-paired Hedge's G Effect Size Test+ #' Convert Wilcoxon test to ARD |
||
| 5 | +142 |
- #' using [`effectsize::hedges_g()`].+ #' |
||
| 6 | +143 |
- #'+ #' @inheritParams cards::tidy_as_ard |
||
| 7 | +144 |
- #' @param data (`data.frame`)\cr+ #' @inheritParams stats::wilcox.test |
||
| 8 | +145 |
- #' a data frame. See below for details.+ #' @param by (`string`)\cr by column name |
||
| 9 | +146 |
- #' @param by ([`tidy-select`][dplyr::dplyr_tidy_select])\cr+ #' @param variable (`string`)\cr variable column name |
||
| 10 | +147 |
- #' column name to compare by. Must be a categorical variable with exactly two levels.+ #' @param ... passed to `stats::wilcox.test(...)` |
||
| 11 | +148 |
- #' @param variables ([`tidy-select`][dplyr::dplyr_tidy_select])\cr+ #' |
||
| 12 | +149 |
- #' column names to be compared. Must be a continuous variable. Independent+ #' @return ARD data frame |
||
| 13 | +150 |
- #' tests will be run for each variable+ #' |
||
| 14 | +151 |
- #' @param id ([`tidy-select`][dplyr::dplyr_tidy_select])\cr+ #' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = "broom", reference_pkg = "cardx"))
|
||
| 15 | +152 |
- #' column name of the subject or participant ID+ #' # Pre-processing ADSL to have grouping factor (ARM here) with 2 levels |
||
| 16 | +153 |
- #' @param ... arguments passed to `effectsize::hedges_g(...)`+ #' ADSL <- cards::ADSL |> |
||
| 17 | +154 |
- #'+ #' dplyr::filter(ARM %in% c("Placebo", "Xanomeline High Dose")) |>
|
||
| 18 | +155 |
- #' @return ARD data frame+ #' ard_stats_wilcox_test(by = "ARM", variables = "AGE") |
||
| 19 | +156 |
- #' @name ard_effectsize_hedges_g+ #' |
||
| 20 | +157 |
- #'+ #' cardx:::.format_wilcoxtest_results( |
||
| 21 | +158 |
- #' @details+ #' by = "ARM", |
||
| 22 | +159 |
- #' For the `ard_effectsize_hedges_g()` function, the data is expected to be one row per subject.+ #' variable = "AGE", |
||
| 23 | +160 |
- #' The data is passed as `effectsize::hedges_g(data[[variable]]~data[[by]], data, paired = FALSE, ...)`.+ #' paired = FALSE, |
||
| 24 | +161 |
- #'+ #' lst_tidy = |
||
| 25 | +162 |
- #' For the `ard_effectsize_paired_hedges_g()` function, the data is expected to be one row+ #' cards::eval_capture_conditions( |
||
| 26 | +163 |
- #' per subject per by level. Before the effect size is calculated, the data are+ #' stats::wilcox.test(ADSL[["AGE"]] ~ ADSL[["ARM"]], paired = FALSE) |> |
||
| 27 | +164 |
- #' reshaped to a wide format to be one row per subject.+ #' broom::tidy() |
||
| 28 | +165 |
- #' The data are then passed as+ #' ) |
||
| 29 | +166 |
- #' `effectsize::hedges_g(x = data_wide[[<by level 1>]], y = data_wide[[<by level 2>]], paired = TRUE, ...)`.+ #' ) |
||
| 30 | +167 |
#' |
||
| 31 | +168 |
- #' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = c("effectsize", "parameters", "withr"), reference_pkg = "cardx"))
+ #' @keywords internal |
||
| 32 | +169 |
- #' cards::ADSL |>+ .format_wilcoxtest_results <- function(by = NULL, variable, lst_tidy, paired, ...) {
|
||
| 33 | +170 |
- #' dplyr::filter(ARM %in% c("Placebo", "Xanomeline High Dose")) |>
+ # build ARD ------------------------------------------------------------------ |
||
| 34 | -+ | |||
| 171 | +8x |
- #' ard_effectsize_hedges_g(by = ARM, variables = AGE)+ ret <- |
||
| 35 | -+ | |||
| 172 | +8x |
- #'+ cards::tidy_as_ard( |
||
| 36 | -+ | |||
| 173 | +8x |
- #' # constructing a paired data set,+ lst_tidy = lst_tidy, |
||
| 37 | -+ | |||
| 174 | +8x |
- #' # where patients receive both treatments+ tidy_result_names = c("statistic", "p.value", "method", "alternative"),
|
||
| 38 | -+ | |||
| 175 | +8x |
- #' cards::ADSL[c("ARM", "AGE")] |>
+ fun_args_to_record = c( |
||
| 39 | -+ | |||
| 176 | +8x |
- #' dplyr::filter(ARM %in% c("Placebo", "Xanomeline High Dose")) |>
+ "mu", "paired", "exact", "correct", "conf.int", |
||
| 40 | -+ | |||
| 177 | +8x |
- #' dplyr::mutate(.by = ARM, USUBJID = dplyr::row_number()) |>+ "conf.level", "tol.root", "digits.rank" |
||
| 41 | +178 |
- #' dplyr::arrange(USUBJID, ARM) |>+ ), |
||
| 42 | -+ | |||
| 179 | +8x |
- #' dplyr::group_by(USUBJID) |>+ formals = formals(asNamespace("stats")[["wilcox.test.default"]]),
|
||
| 43 | -+ | |||
| 180 | +8x |
- #' dplyr::filter(dplyr::n() > 1) |>+ passed_args = c(list(paired = paired), dots_list(...)), |
||
| 44 | -+ | |||
| 181 | +8x |
- #' ard_effectsize_paired_hedges_g(by = ARM, variables = AGE, id = USUBJID)+ lst_ard_columns = list(variable = variable, context = "stats_wilcox_test") |
||
| 45 | +182 |
- NULL+ ) |
||
| 46 | +183 | |||
| 47 | -+ | |||
| 184 | +8x |
- #' @rdname ard_effectsize_hedges_g+ if (!is_empty(by)) {
|
||
| 48 | -+ | |||
| 185 | +7x |
- #' @export+ ret <- ret |> |
||
| 49 | -+ | |||
| 186 | +7x |
- ard_effectsize_hedges_g <- function(data, by, variables, ...) {
+ dplyr::mutate(group1 = by) |
||
| 50 | -2x | +|||
| 187 | +
- set_cli_abort_call()+ } |
|||
| 51 | +188 | |||
| 52 | +189 |
- # check installed packages ---------------------------------------------------+ # add the stat label --------------------------------------------------------- |
||
| 53 | -2x | +190 | +8x |
- check_pkg_installed(c("effectsize", "parameters", "withr"), reference_pkg = "cardx")
+ ret |> |
| 54 | -+ | |||
| 191 | +8x |
-
+ dplyr::left_join( |
||
| 55 | -+ | |||
| 192 | +8x |
- # check/process inputs -------------------------------------------------------+ .df_wilcoxtest_stat_labels(by), |
||
| 56 | -2x | +193 | +8x |
- check_not_missing(data)+ by = "stat_name" |
| 57 | -2x | +|||
| 194 | +
- check_not_missing(variables)+ ) |> |
|||
| 58 | -2x | +195 | +8x |
- check_data_frame(data)+ dplyr::mutate(stat_label = dplyr::coalesce(.data$stat_label, .data$stat_name)) |> |
| 59 | -2x | +196 | +8x |
- data <- dplyr::ungroup(data)+ cards::tidy_ard_column_order() |
| 60 | -2x | +|||
| 197 | +
- cards::process_selectors(data, by = {{ by }}, variables = {{ variables }})
+ } |
|||
| 61 | -2x | +|||
| 198 | +
- check_scalar(by)+ |
|||
| 62 | +199 | |||
| 63 | +200 |
- # if no variables selected, return empty tibble ------------------------------+ .df_wilcoxtest_stat_labels <- function(by = NULL) {
|
||
| 64 | -2x | +201 | +8x |
- if (is_empty(variables)) {
+ dplyr::tribble( |
| 65 | -! | +|||
| 202 | +8x |
- return(dplyr::tibble())+ ~stat_name, ~stat_label, |
||
| 66 | -+ | |||
| 203 | +8x |
- }+ "statistic", ifelse(is.null(by), "V Statistic", "X-squared Statistic"), |
||
| 67 | -+ | |||
| 204 | +8x |
-
+ "parameter", "Degrees of Freedom", |
||
| 68 | -+ | |||
| 205 | +8x |
- # build ARD ------------------------------------------------------------------+ "estimate", "Median of the Difference", |
||
| 69 | -2x | +206 | +8x |
- lapply(+ "p.value", "p-value", |
| 70 | -2x | +207 | +8x |
- variables,+ "conf.low", "CI Lower Bound", |
| 71 | -2x | +208 | +8x |
- function(variable) {
+ "conf.high", "CI Upper Bound", |
| 72 | -2x | +209 | +8x |
- .format_hedges_g_results(+ "paired", "Paired test", |
| 73 | -2x | +210 | +8x |
- by = by,+ "conf.level", "CI Confidence Level", |
| 74 | -2x | +|||
| 211 | +
- variable = variable,+ ) |
|||
| 75 | -2x | +|||
| 212 | +
- lst_tidy =+ } |
|||
| 76 | -2x | +
| 1 | +
- cards::eval_capture_conditions(+ #' ARD for Difference in Survival |
|||
| 77 | +2 |
- # Need to eval in NAMESAPCE DUE TO BUG IN effectsize v0.8.7.+ #' |
||
| 78 | +3 | ++ |
+ #' @description+ |
+ |
| 4 |
- # Can remove this later along with requirements for withr to be installed.+ #' Analysis results data for comparison of survival using [survival::survdiff()]. |
|||
| 79 | +5 |
- # Will also need to remove `hedges_g` from globalVariables()+ #' |
||
| 80 | -2x | +|||
| 6 | +
- withr::with_namespace(+ #' @param formula (`formula`)\cr |
|||
| 81 | -2x | +|||
| 7 | +
- package = "effectsize",+ #' a formula |
|||
| 82 | -2x | +|||
| 8 | +
- code = hedges_g(data[[variable]] ~ data[[by]], paired = FALSE, ...)+ #' @param data (`data.frame`)\cr |
|||
| 83 | +9 |
- ) |>+ #' a data frame |
||
| 84 | -2x | +|||
| 10 | +
- parameters::standardize_names(style = "broom")+ #' @param rho (`scalar numeric`)\cr |
|||
| 85 | +11 |
- ),+ #' numeric scalar passed to `survival::survdiff(rho)`. Default is `rho=0`. |
||
| 86 | -2x | +|||
| 12 | +
- paired = FALSE,+ #' @param ... additional arguments passed to `survival::survdiff()` |
|||
| 87 | +13 |
- ...+ #' |
||
| 88 | +14 |
- )+ #' @return an ARD data frame of class 'card' |
||
| 89 | +15 |
- }+ #' @export |
||
| 90 | +16 |
- ) |>+ #' |
||
| 91 | -2x | +|||
| 17 | +
- dplyr::bind_rows()+ #' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = c("survival", "broom", "ggsurvfit"), reference_pkg = "cardx"))
|
|||
| 92 | +18 |
- }+ #' library(survival) |
||
| 93 | +19 |
-
+ #' library(ggsurvfit) |
||
| 94 | +20 |
- #' @rdname ard_effectsize_hedges_g+ #' |
||
| 95 | +21 |
- #' @export+ #' ard_survival_survdiff(Surv_CNSR(AVAL, CNSR) ~ TRTA, data = cards::ADTTE) |
||
| 96 | +22 |
- ard_effectsize_paired_hedges_g <- function(data, by, variables, id, ...) {
+ ard_survival_survdiff <- function(formula, data, rho = 0, ...) {
|
||
| 97 | -2x | +23 | +4x |
set_cli_abort_call() |
| 98 | +24 | |||
| 99 | +25 |
# check installed packages --------------------------------------------------- |
||
| 100 | -2x | +26 | +4x |
- check_pkg_installed(c("effectsize", "parameters"), reference_pkg = "cardx")
+ check_pkg_installed(c("survival", "broom"), reference_pkg = "cardx")
|
| 101 | +27 | |||
| 102 | +28 |
# check/process inputs ------------------------------------------------------- |
||
| 103 | -2x | +29 | +4x |
- check_not_missing(data)+ check_not_missing(formula) |
| 104 | -2x | +30 | +4x |
- check_not_missing(variables)+ check_class(formula, cls = "formula") |
| 105 | -2x | +31 | +4x |
- check_not_missing(by)+ if (!missing(data)) check_class(data, cls = "data.frame") |
| 106 | -2x | +32 | +4x |
- check_not_missing(id)+ check_scalar(rho) |
| 107 | -2x | +33 | +4x |
- check_data_frame(data)+ check_class(rho, cls = "numeric") |
| 108 | -2x | +|||
| 34 | +
- data <- dplyr::ungroup(data)+ |
|||
| 109 | -2x | +|||
| 35 | +
- cards::process_selectors(data, by = {{ by }}, variables = {{ variables }}, id = {{ id }})
+ # assign method |
|||
| 110 | -2x | +36 | +4x |
- check_scalar(by)+ method <- dplyr::case_when( |
| 111 | -2x | -
- check_scalar(id)- |
- ||
| 112 | -+ | 37 | +4x |
-
+ rho == 0 ~ "Log-rank test", |
| 113 | -+ | |||
| 38 | +4x |
- # if no variables selected, return empty tibble ------------------------------+ rho == 1.5 ~ "Tarone-Ware test", |
||
| 114 | -2x | +39 | +4x |
- if (is_empty(variables)) {
+ rho == 1 ~ "Peto & Peto modification of Gehan-Wilcoxon test", |
| 115 | -! | +|||
| 40 | +4x |
- return(dplyr::tibble())+ .default = glue::glue("G-rho test (\U03C1 = {rho})")
|
||
| 116 | +41 |
- }+ ) |> |
||
| 117 | -+ | |||
| 42 | +4x |
- # build ARD ------------------------------------------------------------------+ as.character() |
||
| 118 | +43 | |||
| 119 | -2x | -
- lapply(- |
- ||
| 120 | -2x | +|||
| 44 | +
- variables,+ # calculate survdiff() results ----------------------------------------------- |
|||
| 121 | -2x | +45 | +4x |
- function(variable) {
+ lst_glance <- |
| 122 | -2x | +46 | +4x |
- .format_hedges_g_results(+ cards::eval_capture_conditions( |
| 123 | -2x | +47 | +4x |
- by = by,+ survival::survdiff(formula = formula, data = data, rho = rho, ...) |> |
| 124 | -2x | +48 | +4x |
- variable = variable,+ broom::glance() |> |
| 125 | -2x | +49 | +4x |
- lst_tidy =+ dplyr::mutate(method = .env$method) |
| 126 | -2x | +|||
| 50 | +
- cards::eval_capture_conditions({
+ ) |
|||
| 127 | +51 |
- # adding this reshape inside the eval, so if there is an error it's captured in the ARD object+ |
||
| 128 | -2x | +|||
| 52 | +
- data_wide <- .paired_data_pivot_wider(data, by = by, variable = variable, id = id)+ # tidy results up in an ARD format ------------------------------------------- |
|||
| 129 | +53 |
- # perform paired cohen's d test+ # extract variable names from formula |
||
| 130 | -1x | +54 | +4x |
- withr::with_namespace(+ variables <- stats::terms(formula) |> |
| 131 | -1x | +55 | +4x |
- package = "effectsize",+ attr("term.labels") |>
|
| 132 | -1x | +56 | +4x |
- code = hedges_g(x = data_wide[["by1"]], y = data_wide[["by2"]], paired = TRUE, ...)+ .strip_backticks() |
| 133 | +57 |
- ) |>- |
- ||
| 134 | -1x | -
- parameters::standardize_names(style = "broom")+ |
||
| 135 | +58 |
- }),+ # if there was an error, return results early |
||
| 136 | -2x | +59 | +4x |
- paired = TRUE,+ if (is.null(lst_glance[["result"]])) {
|
| 137 | +60 |
- ...+ # if no variables in formula, then return an error |
||
| 138 | +61 |
- )+ # otherwise, if we do have variable names, then we can construct an empty ARD which will be done below |
||
| 139 | -+ | |||
| 62 | +2x |
- }+ if (is_empty(variables)) {
|
||
| 140 | -+ | |||
| 63 | +1x |
- ) |>+ cli::cli_abort( |
||
| 141 | -2x | +64 | +1x |
- dplyr::bind_rows()+ message = |
| 142 | -+ | |||
| 65 | +1x |
- }+ c("There was an error in {.fun survival::survdiff}. See below:",
|
||
| 143 | -+ | |||
| 66 | +1x |
-
+ "x" = lst_glance[["error"]] |
||
| 144 | +67 |
- #' Convert Hedge's G Test to ARD+ ), |
||
| 145 | -+ | |||
| 68 | +1x |
- #'+ call = get_cli_abort_call() |
||
| 146 | +69 |
- #' @inheritParams cards::tidy_as_ard+ ) |
||
| 147 | +70 |
- #' @inheritParams effectsize::hedges_g+ } |
||
| 148 | +71 |
- #' @param by (`string`)\cr by column name+ } |
||
| 149 | +72 |
- #' @param variable (`string`)\cr variable column name+ |
||
| 150 | -+ | |||
| 73 | +3x |
- #' @param ... passed to `hedges_g(...)`+ .variables_to_survdiff_ard( |
||
| 151 | -+ | |||
| 74 | +3x |
- #'+ variables = variables, |
||
| 152 | -+ | |||
| 75 | +3x |
- #' @return ARD data frame+ method = method, |
||
| 153 | +76 |
- #' @keywords internal+ # styler: off |
||
| 154 | -+ | |||
| 77 | +3x |
- #' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = c("effectsize", "parameters"), reference_pkg = "cardx"))
+ stat_names = |
||
| 155 | -+ | |||
| 78 | +3x |
- #' cardx:::.format_hedges_g_results(+ if (!is.null(lst_glance[["result"]])) names(lst_glance[["result"]]) |
||
| 156 | -+ | |||
| 79 | +3x |
- #' by = "ARM",+ else c("statistic", "df", "p.value", "method"),
|
||
| 157 | -+ | |||
| 80 | +3x |
- #' variable = "AGE",+ stats = |
||
| 158 | -+ | |||
| 81 | +3x |
- #' paired = FALSE,+ if (!is.null(lst_glance[["result"]])) unname(as.list(lst_glance[["result"]])) |
||
| 159 | -+ | |||
| 82 | +3x |
- #' lst_tidy =+ else rep_along(c("statistic", "df", "p.value"), list(NULL)) |> c(list(method = method))
|
||
| 160 | +83 |
- #' cards::eval_capture_conditions(+ # styler: on |
||
| 161 | +84 |
- #' effectsize::hedges_g(data[[variable]] ~ data[[by]], paired = FALSE) |>+ ) |> |
||
| 162 | -+ | |||
| 85 | +3x |
- #' parameters::standardize_names(style = "broom")+ .add_survdiff_stat_labels() |> |
||
| 163 | -+ | |||
| 86 | +3x |
- #' )+ dplyr::mutate( |
||
| 164 | -+ | |||
| 87 | +3x |
- #' )- |
- ||
| 165 | -+ | |||
| 88 | +3x |
- .format_hedges_g_results <- function(by, variable, lst_tidy, paired, ...) {
+ warning = lst_glance["warning"], |
||
| 166 | -+ | |||
| 89 | +3x |
- # build ARD ------------------------------------------------------------------+ error = lst_glance["error"], |
||
| 167 | -4x | +90 | +3x |
- ret <-+ fmt_fn = map( |
| 168 | -4x | +91 | +3x |
- cards::tidy_as_ard(+ .data$stat, |
| 169 | -4x | +92 | +3x |
- lst_tidy = lst_tidy,+ function(x) {
|
| 170 | -4x | +93 | +6x |
- tidy_result_names = c(+ if (is.numeric(x)) return(1L) # styler: off |
| 171 | -4x | +94 | +6x |
- "estimate", "conf.level", "conf.low", "conf.high"+ NULL |
| 172 | +95 |
- ),+ } |
||
| 173 | -4x | +|||
| 96 | +
- fun_args_to_record = c("mu", "paired", "pooled_sd", "alternative"),
+ ) |
|||
| 174 | -4x | +|||
| 97 | +
- formals = formals(asNamespace("effectsize")[["hedges_g"]]),
+ ) |> |
|||
| 175 | -4x | +98 | +3x |
- passed_args = c(list(paired = paired), dots_list(...)),+ cards::tidy_ard_column_order() %>% |
| 176 | -4x | +99 | +3x |
- lst_ard_columns = list(group1 = by, variable = variable, context = "effectsize_hedges_g")+ {structure(., class = c("card", class(.)))} # styler: off
|
| 177 | +100 |
- )+ } |
||
| 178 | +101 | |||
| 179 | +102 |
- # add the stat label ---------------------------------------------------------+ .variables_to_survdiff_ard <- function(variables, |
||
| 180 | -4x | +|||
| 103 | +
- ret |>+ method, |
|||
| 181 | -4x | +|||
| 104 | +
- dplyr::left_join(+ stat_names, |
|||
| 182 | -4x | +|||
| 105 | +
- .df_effectsize_stat_labels(),+ stats) {
|
|||
| 183 | -4x | +106 | +3x |
- by = "stat_name"+ len <- length(variables) |
| 184 | +107 |
- ) |>+ |
||
| 185 | -4x | +108 | +3x |
- dplyr::mutate(stat_label = dplyr::coalesce(.data$stat_label, .data$stat_name)) |>+ df_vars <- dplyr::tibble(!!!rev(variables)) |> |
| 186 | -4x | +109 | +3x |
- cards::tidy_ard_column_order()+ set_names( |
| 187 | -+ | |||
| 110 | +3x |
- }+ ifelse( |
| 1 | -+ | |||
| 111 | +3x |
- #' ARD Standardized Mean Difference+ len > 1L, |
||
| 2 | -+ | |||
| 112 | +3x |
- #'+ c(paste0("group_", rev(seq_len(len - 1L))), "variable"),
|
||
| 3 | -+ | |||
| 113 | +3x |
- #' @description+ "variable" |
||
| 4 | +114 |
- #' Standardized mean difference calculated via [`smd::smd()`] with `na.rm = TRUE`.+ ) |
||
| 5 | +115 |
- #'+ ) |
||
| 6 | +116 |
- #' @param data (`data.frame`/`survey.design`)\cr+ |
||
| 7 | -+ | |||
| 117 | +3x |
- #' a data frame or object of class 'survey.design'+ dplyr::bind_cols( |
||
| 8 | -+ | |||
| 118 | +3x |
- #' (typically created with [`survey::svydesign()`]).+ df_vars, |
||
| 9 | -+ | |||
| 119 | +3x |
- #' @param by ([`tidy-select`][dplyr::dplyr_tidy_select])\cr+ dplyr::tibble( |
||
| 10 | -+ | |||
| 120 | +3x |
- #' column name to compare by.+ stat_name = .env$stat_names, |
||
| 11 | -+ | |||
| 121 | +3x |
- #' @param variables ([`tidy-select`][dplyr::dplyr_tidy_select])\cr+ stat = .env$stats |
||
| 12 | +122 |
- #' column names to be compared. Independent tests will be computed for+ ) |
||
| 13 | +123 |
- #' each variable.+ ) |
||
| 14 | +124 |
- #' @inheritDotParams smd::smd -x -g -w -na.rm+ } |
||
| 15 | +125 |
- #'+ |
||
| 16 | +126 |
- #' @return ARD data frame+ .add_survdiff_stat_labels <- function(x) {
+ |
+ ||
| 127 | +3x | +
+ x |>+ |
+ ||
| 128 | +3x | +
+ dplyr::left_join( |
||
| 17 | -+ | |||
| 129 | +3x |
- #' @export+ dplyr::tribble( |
||
| 18 | -+ | |||
| 130 | +3x |
- #'+ ~stat_name, ~stat_label, |
||
| 19 | -+ | |||
| 131 | +3x |
- #' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = "smd", reference_pkg = "cardx"))
+ "statistic", "X^2 Statistic", |
||
| 20 | -+ | |||
| 132 | +3x |
- #' ard_smd_smd(cards::ADSL, by = ARM, variables = AGE, std.error = TRUE)+ "df", "Degrees of Freedom", |
||
| 21 | -+ | |||
| 133 | +3x |
- #' ard_smd_smd(cards::ADSL, by = ARM, variables = AGEGR1, std.error = TRUE)+ "p.value", "p-value" |
||
| 22 | +134 |
- ard_smd_smd <- function(data, by, variables, ...) {
+ ), |
||
| 23 | -5x | +135 | +3x |
- set_cli_abort_call()+ by = "stat_name" |
| 24 | +136 |
-
+ ) |> |
||
| 25 | -+ | |||
| 137 | +3x |
- # check installed packages ---------------------------------------------------+ dplyr::mutate(stat_label = dplyr::coalesce(.data$stat_label, .data$stat_name)) |
||
| 26 | -5x | +|||
| 138 | +
- check_pkg_installed("smd", reference_pkg = "cardx")
+ } |
|||
| 27 | +139 | |||
| 28 | +140 |
- # check/process inputs -------------------------------------------------------+ .strip_backticks <- function(x) {
|
||
| 29 | -5x | +141 | +4x |
- check_not_missing(data)+ ifelse( |
| 30 | -5x | +142 | +4x |
- check_not_missing(variables)+ str_detect(x, "^`.*`$"), |
| 31 | -5x | +143 | +4x |
- check_not_missing(by)+ substr(x, 2, nchar(x) - 1), |
| 32 | -+ | |||
| 144 | +4x |
-
+ x |
||
| 33 | +145 |
- # grab design object if from `survey` ----------------------------------------- |
- ||
| 34 | -5x | -
- is_survey <- inherits(data, "survey.design")+ ) |
||
| 35 | -5x | +|||
| 146 | +
- if (is_survey) {
+ } |
|||
| 36 | -1x | +
| 1 | +
- design <- data+ #' Construction Helpers |
|||
| 37 | -1x | +|||
| 2 | +
- data <- design$variables+ #' |
|||
| 38 | +3 |
- }+ #' These functions help construct calls to various types of models. |
||
| 39 | +4 |
-
+ #' |
||
| 40 | +5 |
- # continue check/process inputs ----------------------------------------------+ #' - `construct_model()`: Builds models of the form `method(data = data, formula = formula, method.args!!!)`. |
||
| 41 | -5x | +|||
| 6 | +
- check_data_frame(data)+ #' If the `package` argument is specified, that package is temporarily attached |
|||
| 42 | -5x | +|||
| 7 | +
- data <- dplyr::ungroup(data)+ #' when the model is evaluated. |
|||
| 43 | -5x | +|||
| 8 | +
- cards::process_selectors(data, by = {{ by }}, variables = {{ variables }})
+ #' |
|||
| 44 | -5x | +|||
| 9 | +
- check_scalar(by)+ #' - `reformulate2()`: This is a copy of `reformulate()` except that variable |
|||
| 45 | +10 |
-
+ #' names that contain a space are wrapped in backticks. |
||
| 46 | +11 |
- # if no variables selected, return empty tibble ------------------------------+ #' |
||
| 47 | -5x | +|||
| 12 | +
- if (is_empty(variables)) {
+ #' - `bt()`: Adds backticks to a character vector. |
|||
| 48 | -! | +|||
| 13 | +
- return(dplyr::tibble())+ #' |
|||
| 49 | +14 |
- }+ #' - `bt_strip()`: Removes backticks from a string if it begins and ends with a backtick. |
||
| 50 | +15 |
-
+ #' |
||
| 51 | +16 |
- # build ARD ------------------------------------------------------------------+ #' @param x |
||
| 52 | -5x | +|||
| 17 | +
- lapply(+ #' - `construct_model.data.frame()` (`data.frame`) a data frame |
|||
| 53 | -5x | +|||
| 18 | +
- variables,+ #' - `construct_model.survey.design()` (`survey.design`) a survey design object |
|||
| 54 | -5x | +|||
| 19 | +
- function(variable) {
+ #' - `bt()`/`bt_strip()` (`character`) character vector, typically of variable names |
|||
| 55 | -6x | +|||
| 20 | +
- .format_smd_results(+ #' @param formula (`formula`)\cr |
|||
| 56 | -6x | +|||
| 21 | +
- by = by,+ #' a formula |
|||
| 57 | -6x | +|||
| 22 | +
- variable = variable,+ #' @param method (`string`)\cr |
|||
| 58 | -6x | +|||
| 23 | +
- lst_tidy =+ #' string naming the function to be called, e.g. `"glm"`. |
|||
| 59 | -6x | +|||
| 24 | +
- cards::eval_capture_conditions(+ #' If function belongs to a library that is not attached, the package name |
|||
| 60 | -6x | +|||
| 25 | +
- switch(as.character(is_survey),+ #' must be specified in the `package` argument. |
|||
| 61 | -6x | +|||
| 26 | +
- "TRUE" = smd::smd(x = data[[variable]], g = data[[by]], w = stats::weights(design), na.rm = TRUE, ...),+ #' @param method.args (named `list`)\cr |
|||
| 62 | -6x | +|||
| 27 | +
- "FALSE" = smd::smd(x = data[[variable]], g = data[[by]], na.rm = TRUE, ...)+ #' named list of arguments that will be passed to `fn`. |
|||
| 63 | +28 |
- ) |>+ #' @param package (`string`)\cr |
||
| 64 | -6x | +|||
| 29 | +
- dplyr::select(-any_of("term"))
+ #' string of package name that will be temporarily loaded when function |
|||
| 65 | +30 |
- ),+ #' specified in `method` is executed. |
||
| 66 | +31 |
- ...+ #' @param pattern (`string`)\cr |
||
| 67 | +32 |
- )+ #' regular expression string. If the regex matches, backticks are added |
||
| 68 | +33 |
- }+ #' to the string. When `NULL`, backticks are not added. |
||
| 69 | +34 |
- ) |>+ #' @param pattern_term,pattern_response passed to `bt(pattern)` for arguments |
||
| 70 | -5x | +|||
| 35 | +
- dplyr::bind_rows()+ #' `stats::reformulate(termlabels, response)`. |
|||
| 71 | +36 |
- }+ #' @inheritParams rlang::eval_tidy |
||
| 72 | +37 |
-
+ #' @inheritParams stats::reformulate |
||
| 73 | +38 |
-
+ #' @inheritParams rlang::args_dots_empty |
||
| 74 | +39 |
- .format_smd_results <- function(by, variable, lst_tidy, ...) {
+ #' |
||
| 75 | +40 |
- # build ARD ------------------------------------------------------------------+ #' @return depends on the calling function |
||
| 76 | -6x | +|||
| 41 | +
- ret <-+ #' @name construction_helpers |
|||
| 77 | -6x | +|||
| 42 | +
- cards::tidy_as_ard(+ #' |
|||
| 78 | -6x | +|||
| 43 | +
- lst_tidy = lst_tidy,+ #' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = c("withr", "lme4"), reference_pkg = "cardx"))
|
|||
| 79 | -6x | +|||
| 44 | +
- tidy_result_names = c("estimate", "std.error"),
+ #' construct_model( |
|||
| 80 | -6x | +|||
| 45 | +
- fun_args_to_record = "gref",+ #' x = mtcars, |
|||
| 81 | -6x | +|||
| 46 | +
- formals = formals(smd::smd)["gref"],+ #' formula = am ~ mpg + (1 | vs), |
|||
| 82 | +47 |
- # removing the `std.error` ARGUMENT (not the result)+ #' method = "glmer", |
||
| 83 | -6x | +|||
| 48 | +
- passed_args = dots_list(...) |> utils::modifyList(list(std.error = NULL)),+ #' method.args = list(family = binomial), |
|||
| 84 | -6x | +|||
| 49 | +
- lst_ard_columns = list(group1 = by, variable = variable, context = "smd_smd")+ #' package = "lme4" |
|||
| 85 | +50 |
- )+ #' ) |
||
| 86 | +51 |
-
+ #' |
||
| 87 | +52 |
- # add the stat label ---------------------------------------------------------+ #' construct_model( |
||
| 88 | -6x | +|||
| 53 | +
- ret |>+ #' x = mtcars |> dplyr::rename(`M P G` = mpg), |
|||
| 89 | -6x | +|||
| 54 | +
- dplyr::left_join(+ #' formula = reformulate2(c("M P G", "cyl"), response = "hp"),
|
|||
| 90 | -6x | +|||
| 55 | +
- dplyr::tribble(+ #' method = "lm" |
|||
| 91 | -6x | +|||
| 56 | +
- ~stat_name, ~stat_label,+ #' ) |> |
|||
| 92 | -6x | +|||
| 57 | +
- "estimate", "Standardized Mean Difference",+ #' ard_regression() |> |
|||
| 93 | -6x | +|||
| 58 | +
- "std.error", "Standard Error",+ #' dplyr::filter(stat_name %in% c("term", "estimate", "p.value"))
|
|||
| 94 | -6x | +|||
| 59 | +
- "gref", "Integer Reference Group Level"+ NULL |
|||
| 95 | +60 |
- ),+ |
||
| 96 | -6x | +|||
| 61 | +
- by = "stat_name"+ #' @rdname construction_helpers |
|||
| 97 | +62 |
- ) |>+ #' @export |
||
| 98 | -6x | +|||
| 63 | +
- dplyr::mutate(stat_label = dplyr::coalesce(.data$stat_label, .data$stat_name)) |>+ construct_model <- function(x, ...) {
|
|||
| 99 | -6x | +64 | +12x |
- cards::tidy_ard_column_order()+ UseMethod("construct_model")
|
| 100 | +65 |
} |
| 1 | +66 |
- #' ARD Mood Test+ |
||
| 2 | +67 |
- #'+ #' @rdname construction_helpers |
||
| 3 | +68 |
- #' @description+ #' @export |
||
| 4 | +69 |
- #' Analysis results data for Mood two sample test of scale. Note this not to be confused with+ construct_model.data.frame <- function(x, formula, method, method.args = list(), package = "base", env = caller_env(), ...) {
|
||
| 5 | -+ | |||
| 70 | +12x |
- #' the Brown-Mood test of medians.+ set_cli_abort_call() |
||
| 6 | +71 |
- #'+ # check pkg installations ---------------------------------------------------- |
||
| 7 | -+ | |||
| 72 | +12x |
- #' @param data (`data.frame`)\cr+ check_dots_empty() |
||
| 8 | -+ | |||
| 73 | +12x |
- #' a data frame. See below for details.+ check_pkg_installed(c("withr", package), reference_pkg = "cardx")
|
||
| 9 | +74 |
- #' @param by ([`tidy-select`][dplyr::dplyr_tidy_select])\cr+ |
||
| 10 | -+ | |||
| 75 | +12x |
- #' column name to compare by.+ check_not_missing(formula) |
||
| 11 | -+ | |||
| 76 | +12x |
- #' @param variables ([`tidy-select`][dplyr::dplyr_tidy_select])\cr+ check_class(formula, cls = "formula") |
||
| 12 | +77 |
- #' column name to be compared. Independent tests will+ |
||
| 13 | -+ | |||
| 78 | +12x |
- #' be run for each variable.+ check_not_missing(method) |
||
| 14 | -+ | |||
| 79 | +12x |
- #' @param ... arguments passed to `mood.test(...)`+ check_string(method) |
||
| 15 | -+ | |||
| 80 | +12x |
- #'+ check_not_namespaced(method) |
||
| 16 | +81 |
- #' @return ARD data frame+ |
||
| 17 | +82 |
- #' @name ard_stats_mood_test+ # convert method.args to list of expressions (to account for NSE inputs) ----- |
||
| 18 | -+ | |||
| 83 | +11x |
- #'+ method.args <- .as_list_of_exprs({{ method.args }})
|
||
| 19 | +84 |
- #' @details+ |
||
| 20 | +85 |
- #' For the `ard_stats_mood_test()` function, the data is expected to be one row per subject.+ # build model ---------------------------------------------------------------- |
||
| 21 | -+ | |||
| 86 | +11x |
- #' The data is passed as `mood.test(data[[variable]] ~ data[[by]], ...)`.+ withr::with_namespace( |
||
| 22 | -+ | |||
| 87 | +11x |
- #' @rdname ard_stats_mood_test+ package = package, |
||
| 23 | -+ | |||
| 88 | +11x |
- #' @export+ call2(.fn = method, formula = formula, data = x, !!!method.args) |> |
||
| 24 | -+ | |||
| 89 | +11x |
- #'+ eval_tidy(env = env) |
||
| 25 | +90 |
- #' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = "broom", reference_pkg = "cardx"))
+ ) |
||
| 26 | +91 |
- #' cards::ADSL |>+ } |
||
| 27 | +92 |
- #' ard_stats_mood_test(by = "SEX", variables = "AGE")+ |
||
| 28 | +93 |
- ard_stats_mood_test <- function(data, by, variables, ...) {
- |
- ||
| 29 | -2x | -
- set_cli_abort_call()+ #' @rdname construction_helpers |
||
| 30 | +94 |
-
+ #' @export |
||
| 31 | +95 |
- # check installed packages ---------------------------------------------------+ construct_model.survey.design <- function(x, formula, method, method.args = list(), package = "survey", env = caller_env(), ...) {
|
||
| 32 | -2x | +|||
| 96 | +! |
- check_pkg_installed("broom", reference_pkg = "cardx")
+ set_cli_abort_call() |
||
| 33 | +97 |
-
+ # check pkg installations ---------------------------------------------------- |
||
| 34 | -+ | |||
| 98 | +! |
- # check/process inputs -------------------------------------------------------+ check_dots_empty() |
||
| 35 | -2x | +|||
| 99 | +! |
- check_not_missing(data)+ check_pkg_installed(c("withr", package), reference_pkg = "cardx")
|
||
| 36 | -2x | +|||
| 100 | +
- check_not_missing(variables)+ |
|||
| 37 | -2x | +|||
| 101 | +! |
- check_not_missing(by)+ check_not_missing(formula) |
||
| 38 | -2x | +|||
| 102 | +! |
- check_data_frame(data)+ check_class(formula, cls = "formula") |
||
| 39 | -2x | +|||
| 103 | +
- data <- dplyr::ungroup(data)+ |
|||
| 40 | -2x | +|||
| 104 | +! |
- cards::process_selectors(data, by = {{ by }}, variables = {{ variables }})
+ check_not_missing(method) |
||
| 41 | -2x | +|||
| 105 | +! |
- check_scalar(by)+ check_string(method) |
||
| 42 | -+ | |||
| 106 | +! |
-
+ check_not_namespaced(method) |
||
| 43 | +107 | |||
| 44 | +108 |
- # if no variables selected, return empty tibble ------------------------------- |
- ||
| 45 | -2x | -
- if (is_empty(variables)) {
+ # convert method.args to list of expressions (to account for NSE inputs) ----- |
||
| 46 | +109 | ! |
- return(dplyr::tibble())+ method.args <- .as_list_of_exprs({{ method.args }})
|
|
| 47 | +110 |
- }+ |
||
| 48 | +111 |
- # build ARD ------------------------------------------------------------------+ # build model ---------------------------------------------------------------- |
||
| 49 | -2x | +|||
| 112 | +! |
- lapply(+ withr::with_namespace( |
||
| 50 | -2x | +|||
| 113 | +! |
- variables,+ package = package, |
||
| 51 | -2x | +|||
| 114 | +! |
- function(variable) {
+ call2(.fn = method, formula = formula, design = x, !!!method.args) |> |
||
| 52 | -2x | +|||
| 115 | +! |
- .format_moodtest_results(+ eval_tidy(env = env) |
||
| 53 | -2x | +|||
| 116 | +
- by = by,+ ) |
|||
| 54 | -2x | +|||
| 117 | +
- variable = variable,+ } |
|||
| 55 | -2x | +|||
| 118 | +
- lst_tidy =+ |
|||
| 56 | -2x | +|||
| 119 | +
- cards::eval_capture_conditions(+ .as_list_of_exprs <- function(x) {
|
|||
| 57 | -2x | +120 | +11x |
- stats::mood.test(data[[variable]] ~ data[[by]], ...) |>+ call_args(enexpr(x)) |
| 58 | -2x | +|||
| 121 | +
- broom::tidy()+ } |
|||
| 59 | +122 |
- ),+ |
||
| 60 | +123 |
- ...+ #' @rdname construction_helpers |
||
| 61 | +124 |
- )+ #' @export |
||
| 62 | +125 |
- }+ reformulate2 <- function(termlabels, response = NULL, intercept = TRUE, |
||
| 63 | +126 |
- ) |>+ pattern_term = "[ \n\r]", pattern_response = "[ \n\r]",+ |
+ ||
| 127 | ++ |
+ env = parent.frame()) {
|
||
| 64 | -2x | +128 | +4x |
- dplyr::bind_rows()+ stats::reformulate( |
| 65 | -+ | |||
| 129 | +4x |
- }+ termlabels = bt(termlabels, pattern_term), |
||
| 66 | -+ | |||
| 130 | +4x |
- #' Convert mood test results to ARD+ response = bt(response, pattern_response), |
||
| 67 | -+ | |||
| 131 | +4x |
- #'+ intercept = intercept, |
||
| 68 | -+ | |||
| 132 | +4x |
- #' @inheritParams cards::tidy_as_ard+ env = env |
||
| 69 | +133 |
- #' @inheritParams stats::mood.test+ ) |
||
| 70 | +134 |
- #' @param by (`string`)\cr by column name+ } |
||
| 71 | +135 |
- #' @param variable (`string`)\cr variable column name+ |
||
| 72 | +136 |
- #' @param ... passed to `mood.test(...)`+ #' @rdname construction_helpers |
||
| 73 | +137 |
- #'+ #' @export |
||
| 74 | +138 |
- #' @return ARD data frame+ bt <- function(x, pattern = "[ \n\r]") {
|
||
| 75 | -+ | |||
| 139 | +8x |
- #' @keywords internal+ if (is_empty(x)) {
|
||
| 76 | -+ | |||
| 140 | +3x |
- #' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = "broom", reference_pkg = "cardx"))
+ return(x) |
||
| 77 | +141 |
- #' cardx:::.format_moodtest_results(+ }+ |
+ ||
| 142 | +5x | +
+ if (is_empty(pattern)) {
+ |
+ ||
| 143 | +! | +
+ return(x) |
||
| 78 | +144 |
- #' by = "SEX",+ } |
||
| 79 | -+ | |||
| 145 | +5x |
- #' variable = "AGE",+ ifelse( |
||
| 80 | -+ | |||
| 146 | +5x |
- #' lst_tidy =+ str_detect(x, pattern = pattern), |
||
| 81 | -+ | |||
| 147 | +5x |
- #' cards::eval_capture_conditions(+ paste0("`", x, "`"),
|
||
| 82 | -+ | |||
| 148 | +5x |
- #' stats::mood.test(ADSL[["AGE"]] ~ ADSL[["SEX"]]) |>+ x |
||
| 83 | +149 |
- #' broom::tidy()+ ) |
||
| 84 | +150 |
- #' )+ } |
||
| 85 | +151 |
- #' )+ |
||
| 86 | +152 |
- .format_moodtest_results <- function(by, variable, lst_tidy, ...) {
+ #' @rdname construction_helpers |
||
| 87 | +153 |
- # build ARD ------------------------------------------------------------------- |
- ||
| 88 | -2x | -
- ret <-+ #' @export |
||
| 89 | -2x | +|||
| 154 | +
- cards::tidy_as_ard(+ bt_strip <- function(x) {
|
|||
| 90 | -2x | +|||
| 155 | +! |
- lst_tidy = lst_tidy,+ ifelse( |
||
| 91 | -2x | +|||
| 156 | +! |
- tidy_result_names = c("statistic", "p.value", "method", "alternative"),
+ str_detect(x, "^`.*`$"), |
||
| 92 | -2x | +|||
| 157 | +! |
- formals = formals(asNamespace("stats")[["mood.test.default"]]),
+ substr(x, 2, nchar(x) - 1), |
||
| 93 | -2x | +|||
| 158 | +! |
- passed_args = c(dots_list(...)),+ x |
||
| 94 | -2x | +|||
| 159 | +
- lst_ard_columns = list(group1 = by, variable = variable, context = "stats_mood_test")+ ) |
|||
| 95 | +160 |
- )+ } |
||
| 96 | +161 | |||
| 97 | +162 |
- # add the stat label ---------------------------------------------------------+ check_not_namespaced <- function(x, |
||
| 98 | -2x | +|||
| 163 | +
- ret |>+ arg_name = rlang::caller_arg(x), |
|||
| 99 | -2x | +|||
| 164 | +
- dplyr::left_join(+ class = "check_not_namespaced", |
|||
| 100 | -2x | +|||
| 165 | +
- .df_moodtest_stat_labels(),+ call = get_cli_abort_call()) {
|
|||
| 101 | -2x | +166 | +12x |
- by = "stat_name"+ check_string(x, arg_name = arg_name, call = call, class = "check_not_namespaced") |
| 102 | +167 |
- ) |>+ |
||
| 103 | -2x | +168 | +12x |
- dplyr::mutate(stat_label = dplyr::coalesce(.data$stat_label, .data$stat_name)) |>+ if (str_detect(x, "::")) {
|
| 104 | -2x | -
- cards::tidy_ard_column_order()- |
- ||
| 105 | -+ | 169 | +1x |
- }+ c("Argument {.arg {arg_name}} cannot be namespaced.",
|
| 106 | -+ | |||
| 170 | +1x |
-
+ i = "Put the package name in the {.arg package} argument."
|
||
| 107 | +171 |
- .df_moodtest_stat_labels <- function() {
- |
- ||
| 108 | -2x | -
- dplyr::tribble(+ ) |> |
||
| 109 | -2x | +172 | +1x |
- ~stat_name, ~stat_label,+ cli::cli_abort(call = call, class = class) |
| 110 | -2x | +|||
| 173 | +
- "statistic", "Z-Statistic",+ } |
|||
| 111 | -2x | +|||
| 174 | +
- "p.value", "p-value",+ |
|||
| 112 | -2x | -
- "alternative", "Alternative Hypothesis"- |
- ||
| 113 | -+ | 175 | +11x |
- )+ invisible(x) |
| 114 | +176 |
}@@ -11966,14 +12025,14 @@ cardx coverage - 95.93% |
| 1 |
- #' Functions for Calculating Proportion Confidence Intervals+ #' ARD Fisher's Exact Test |
||
| 3 |
- #' Functions to calculate different proportion confidence intervals for use in `ard_proportion()`.+ #' @description |
||
| 4 |
- #'+ #' Analysis results data for Fisher's Exact Test. |
||
| 5 |
- #' @inheritParams ard_proportion_ci+ #' Calculated with `fisher.test(x = data[[variable]], y = data[[by]], ...)` |
||
| 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 |
- #'+ #' @param data (`data.frame`)\cr |
||
| 9 |
- #' @name proportion_ci+ #' a data frame. |
||
| 10 |
- #' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = "broom", reference_pkg = "cardx"))
+ #' @param by ([`tidy-select`][dplyr::dplyr_tidy_select])\cr |
||
| 11 |
- #' x <- c(+ #' column name to compare by |
||
| 12 |
- #' TRUE, TRUE, TRUE, TRUE, TRUE,+ #' @param variables ([`tidy-select`][dplyr::dplyr_tidy_select])\cr |
||
| 13 |
- #' FALSE, FALSE, FALSE, FALSE, FALSE+ #' column names to be compared. Independent tests will be computed for |
||
| 14 |
- #' )+ #' each variable. |
||
| 15 |
- #'+ #' @param ... additional arguments passed to `fisher.test(...)` |
||
| 16 |
- #' proportion_ci_wald(x, conf.level = 0.9)+ #' |
||
| 17 |
- #' proportion_ci_wilson(x, correct = TRUE)+ #' @return ARD data frame |
||
| 18 |
- #' proportion_ci_clopper_pearson(x)+ #' @export |
||
| 19 |
- #' proportion_ci_agresti_coull(x)+ #' |
||
| 20 |
- #' proportion_ci_jeffreys(x)+ #' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = "broom", reference_pkg = "cardx"))
|
||
| 21 |
- NULL+ #' cards::ADSL[1:30, ] |> |
||
| 22 |
-
+ #' ard_stats_fisher_test(by = "ARM", variables = "AGEGR1") |
||
| 23 |
- #' @describeIn proportion_ci Calculates the Wald interval by following the usual textbook definition+ ard_stats_fisher_test <- function(data, by, variables, ...) {
|
||
| 24 | -+ | 3x |
- #' for a single proportion confidence interval using the normal approximation.+ set_cli_abort_call() |
| 25 |
- #'+ |
||
| 26 |
- #' \deqn{\hat{p} \pm z_{\alpha/2} \sqrt{\frac{\hat{p}(1 - \hat{p})}{n}}}
+ # check installed packages --------------------------------------------------- |
||
| 27 | -+ | 3x |
- #'+ check_pkg_installed("broom", reference_pkg = "cardx")
|
| 28 |
- #' @param correct (`logical`)\cr apply continuity correction.+ |
||
| 29 |
- #'+ # check/process inputs ------------------------------------------------------- |
||
| 30 | -+ | 3x |
- #' @export+ check_not_missing(data) |
| 31 | -+ | 3x |
- proportion_ci_wald <- function(x, conf.level = 0.95, correct = FALSE) {
+ check_not_missing(variables) |
| 32 | -4x | +3x |
- set_cli_abort_call()+ check_not_missing(by) |
| 33 | -+ | 3x |
-
+ check_data_frame(data) |
| 34 | -+ | 3x |
- # check inputs ---------------------------------------------------------------+ cards::process_selectors(data, by = {{ by }}, variables = {{ variables }})
|
| 35 | -4x | +3x |
- check_not_missing(x)+ check_scalar(by) |
| 36 | -4x | +
- check_binary(x)+ |
|
| 37 | -4x | +
- check_range(conf.level, range = c(0, 1), include_bounds = c(FALSE, FALSE))+ # if no variables selected, return empty tibble ------------------------------ |
|
| 38 | -4x | +3x |
- check_scalar(conf.level)+ if (is_empty(variables)) {
|
| 39 | -4x | +! |
- check_class(x = correct, "logical")+ return(dplyr::tibble()) |
| 40 | -4x | +
- check_scalar(correct)+ } |
|
| 41 |
-
+ # build ARD ------------------------------------------------------------------ |
||
| 42 | -4x | +3x |
- x <- stats::na.omit(x)+ lapply( |
| 43 | -+ | 3x |
-
+ variables, |
| 44 | -4x | +3x |
- n <- length(x)+ function(variable) {
|
| 45 | 4x |
- p_hat <- mean(x)+ cards::tidy_as_ard( |
|
| 46 | 4x |
- z <- stats::qnorm((1 + conf.level) / 2)+ lst_tidy = |
|
| 47 | 4x |
- q_hat <- 1 - p_hat+ cards::eval_capture_conditions( |
|
| 48 | 4x |
- correction_factor <- ifelse(correct, 1 / (2 * n), 0)+ stats::fisher.test(x = data[[variable]], y = data[[by]], ...) |> |
|
| 49 | -+ | 4x |
-
+ broom::tidy() |
| 50 | -4x | +
- err <- z * sqrt(p_hat * q_hat) / sqrt(n) + correction_factor+ ), |
|
| 51 | 4x |
- l_ci <- max(0, p_hat - err)+ tidy_result_names = |
|
| 52 | 4x |
- u_ci <- min(1, p_hat + err)+ c("estimate", "p.value", "conf.low", "conf.high", "method", "alternative"),
|
|
| 53 | -+ | 4x |
-
+ fun_args_to_record = |
| 54 | 4x |
- list(+ c( |
|
| 55 | 4x |
- N = n,+ "workspace", "hybrid", "hybridPars", "control", "or", |
|
| 56 | 4x |
- estimate = p_hat,+ "conf.int", "conf.level", "simulate.p.value", "B" |
|
| 57 | -4x | +
- conf.low = l_ci,+ ), |
|
| 58 | 4x |
- conf.high = u_ci,+ formals = formals(stats::fisher.test), |
|
| 59 | 4x |
- conf.level = conf.level,+ passed_args = dots_list(...), |
|
| 60 | 4x |
- method =+ lst_ard_columns = list(group1 = by, variable = variable, context = "stats_fisher_test") |
|
| 61 | ++ |
+ ) |>+ |
+ |
| 62 | 4x |
- glue::glue("Wald Confidence Interval {ifelse(correct, 'with', 'without')} continuity correction")
+ dplyr::mutate(+ |
+ |
| 63 | +4x | +
+ .after = "stat_name",+ |
+ |
| 64 | +4x | +
+ stat_label =+ |
+ |
| 65 | +4x | +
+ dplyr::case_when(+ |
+ |
| 66 | +4x | +
+ .data$stat_name %in% "p.value" ~ "p-value",+ |
+ |
| 67 | +4x | +
+ TRUE ~ .data$stat_name, |
|
| 62 | +68 |
- )+ )+ |
+ |
| 69 | ++ |
+ )+ |
+ |
| 70 | ++ |
+ }+ |
+ |
| 71 | ++ |
+ ) |>+ |
+ |
| 72 | +3x | +
+ dplyr::bind_rows()+ |
+ |
| 73 | ++ |
+ } |
| 63 | +1 |
- }+ #' ARD Hedge's G Test |
||
| 64 | +2 |
-
+ #' |
||
| 65 | +3 |
-
+ #' @description |
||
| 66 | +4 |
- #' @describeIn proportion_ci Calculates the Wilson interval by calling [stats::prop.test()].+ #' Analysis results data for paired and non-paired Hedge's G Effect Size Test |
||
| 67 | +5 |
- #' Also referred to as Wilson score interval.+ #' using [`effectsize::hedges_g()`]. |
||
| 68 | +6 |
#' |
||
| 69 | +7 |
- #' \deqn{\frac{\hat{p} +
+ #' @param data (`data.frame`)\cr |
||
| 70 | +8 |
- #' \frac{z^2_{\alpha/2}}{2n} \pm z_{\alpha/2} \sqrt{\frac{\hat{p}(1 - \hat{p})}{n} +
+ #' a data frame. See below for details. |
||
| 71 | +9 |
- #' \frac{z^2_{\alpha/2}}{4n^2}}}{1 + \frac{z^2_{\alpha/2}}{n}}}
+ #' @param by ([`tidy-select`][dplyr::dplyr_tidy_select])\cr |
||
| 72 | +10 |
- #'+ #' column name to compare by. Must be a categorical variable with exactly two levels. |
||
| 73 | +11 |
- #' @export+ #' @param variables ([`tidy-select`][dplyr::dplyr_tidy_select])\cr |
||
| 74 | +12 |
- proportion_ci_wilson <- function(x, conf.level = 0.95, correct = FALSE) {
- |
- ||
| 75 | -5x | -
- set_cli_abort_call()+ #' column names to be compared. Must be a continuous variable. Independent |
||
| 76 | +13 |
-
+ #' tests will be run for each variable |
||
| 77 | +14 |
- # check installed packages ---------------------------------------------------+ #' @param id ([`tidy-select`][dplyr::dplyr_tidy_select])\cr |
||
| 78 | -5x | +|||
| 15 | +
- check_pkg_installed(pkg = "broom", reference_pkg = "cardx")+ #' column name of the subject or participant ID |
|||
| 79 | +16 |
-
+ #' @param ... arguments passed to `effectsize::hedges_g(...)` |
||
| 80 | +17 |
- # check inputs ---------------------------------------------------------------+ #' |
||
| 81 | -5x | +|||
| 18 | +
- check_not_missing(x)+ #' @return ARD data frame |
|||
| 82 | -5x | +|||
| 19 | +
- check_binary(x)+ #' @name ard_effectsize_hedges_g |
|||
| 83 | -5x | +|||
| 20 | +
- check_class(x = correct, "logical")+ #' |
|||
| 84 | -5x | +|||
| 21 | +
- check_scalar(correct)+ #' @details |
|||
| 85 | -5x | +|||
| 22 | +
- check_range(conf.level, range = c(0, 1), include_bounds = c(FALSE, FALSE))+ #' For the `ard_effectsize_hedges_g()` function, the data is expected to be one row per subject. |
|||
| 86 | -5x | +|||
| 23 | +
- check_scalar(conf.level)+ #' The data is passed as `effectsize::hedges_g(data[[variable]]~data[[by]], data, paired = FALSE, ...)`. |
|||
| 87 | +24 |
-
+ #' |
||
| 88 | -5x | +|||
| 25 | +
- x <- stats::na.omit(x)+ #' For the `ard_effectsize_paired_hedges_g()` function, the data is expected to be one row |
|||
| 89 | +26 |
-
+ #' per subject per by level. Before the effect size is calculated, the data are |
||
| 90 | -5x | +|||
| 27 | +
- n <- length(x)+ #' reshaped to a wide format to be one row per subject. |
|||
| 91 | -5x | +|||
| 28 | +
- y <- stats::prop.test(x = sum(x), n = n, correct = correct, conf.level = conf.level)+ #' The data are then passed as |
|||
| 92 | +29 |
-
+ #' `effectsize::hedges_g(x = data_wide[[<by level 1>]], y = data_wide[[<by level 2>]], paired = TRUE, ...)`. |
||
| 93 | -5x | +|||
| 30 | +
- list(N = n, conf.level = conf.level) |>+ #' |
|||
| 94 | -5x | +|||
| 31 | +
- utils::modifyList(val = broom::tidy(y) |> as.list()) |>+ #' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = c("effectsize", "parameters", "withr"), reference_pkg = "cardx"))
|
|||
| 95 | -5x | +|||
| 32 | +
- utils::modifyList(+ #' cards::ADSL |> |
|||
| 96 | -5x | +|||
| 33 | +
- list(+ #' dplyr::filter(ARM %in% c("Placebo", "Xanomeline High Dose")) |>
|
|||
| 97 | -5x | +|||
| 34 | +
- method =+ #' ard_effectsize_hedges_g(by = ARM, variables = AGE) |
|||
| 98 | -5x | +|||
| 35 | +
- glue::glue("Wilson Confidence Interval {ifelse(correct, 'with', 'without')} continuity correction")
+ #' |
|||
| 99 | +36 |
- )+ #' # constructing a paired data set, |
||
| 100 | +37 |
- )+ #' # where patients receive both treatments |
||
| 101 | +38 |
- }+ #' cards::ADSL[c("ARM", "AGE")] |>
|
||
| 102 | +39 |
-
+ #' dplyr::filter(ARM %in% c("Placebo", "Xanomeline High Dose")) |>
|
||
| 103 | +40 |
- #' @describeIn proportion_ci Calculates the Clopper-Pearson interval by calling [stats::binom.test()].+ #' dplyr::mutate(.by = ARM, USUBJID = dplyr::row_number()) |> |
||
| 104 | +41 |
- #' Also referred to as the `exact` method.+ #' dplyr::arrange(USUBJID, ARM) |> |
||
| 105 | +42 |
- #'+ #' dplyr::group_by(USUBJID) |> |
||
| 106 | +43 |
- #' \deqn{
+ #' dplyr::filter(dplyr::n() > 1) |> |
||
| 107 | +44 |
- #' \left( \frac{k}{n} \pm z_{\alpha/2} \sqrt{\frac{\frac{k}{n}(1-\frac{k}{n})}{n} +
+ #' ard_effectsize_paired_hedges_g(by = ARM, variables = AGE, id = USUBJID) |
||
| 108 | +45 |
- #' \frac{z^2_{\alpha/2}}{4n^2}} \right)
+ NULL |
||
| 109 | +46 |
- #' / \left( 1 + \frac{z^2_{\alpha/2}}{n} \right)}
+
|
||
| 110 | +47 |
- #'+ #' @rdname ard_effectsize_hedges_g |
||
| 111 | +48 |
#' @export |
||
| 112 | +49 |
- proportion_ci_clopper_pearson <- function(x, conf.level = 0.95) {
+ ard_effectsize_hedges_g <- function(data, by, variables, ...) {
|
||
| 113 | +50 | 2x |
set_cli_abort_call() |
|
| 114 | +51 | |||
| 115 | +52 |
# check installed packages --------------------------------------------------- |
||
| 116 | +53 | 2x |
- check_pkg_installed(pkg = "broom", reference_pkg = "cardx")+ check_pkg_installed(c("effectsize", "parameters", "withr"), reference_pkg = "cardx")
|
|
| 117 | +54 | |||
| 118 | +55 |
- # check inputs ---------------------------------------------------------------+ # check/process inputs ------------------------------------------------------- |
||
| 119 | +56 | 2x |
- check_not_missing(x)+ check_not_missing(data) |
|
| 120 | +57 | 2x |
- check_binary(x)+ check_not_missing(variables) |
|
| 121 | +58 | 2x |
- check_range(conf.level, range = c(0, 1), include_bounds = c(FALSE, FALSE))+ check_data_frame(data) |
|
| 122 | +59 | 2x |
- check_scalar(conf.level)- |
- |
| 123 | -- |
-
+ data <- dplyr::ungroup(data) |
||
| 124 | +60 | 2x |
- x <- stats::na.omit(x)+ cards::process_selectors(data, by = {{ by }}, variables = {{ variables }})
|
|
| 125 | +61 | 2x |
- n <- length(x)+ check_scalar(by) |
|
| 126 | +62 | |||
| 127 | -2x | -
- y <- stats::binom.test(x = sum(x), n = n, conf.level = conf.level)- |
- ||
| 128 | +63 | - - | -||
| 129 | -2x | -
- list(N = n, conf.level = conf.level) |>+ # if no variables selected, return empty tibble ------------------------------ |
||
| 130 | +64 | 2x |
- utils::modifyList(val = broom::tidy(y) |> as.list()) |>+ if (is_empty(variables)) {
|
|
| 131 | -2x | +|||
| 65 | +! |
- utils::modifyList(list(method = "Clopper-Pearson Confidence Interval"))+ return(dplyr::tibble()) |
||
| 132 | +66 |
- }+ } |
||
| 133 | +67 | |||
| 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 | +68 |
- #'+ # build ARD ------------------------------------------------------------------ |
||
| 137 | -+ | |||
| 69 | +2x |
- #' \deqn{
+ lapply( |
||
| 138 | -+ | |||
| 70 | +2x |
- #' \left( \frac{\tilde{p} + z^2_{\alpha/2}/2}{n + z^2_{\alpha/2}} \pm
+ variables, |
||
| 139 | -+ | |||
| 71 | +2x |
- #' z_{\alpha/2} \sqrt{\frac{\tilde{p}(1 - \tilde{p})}{n} +
+ function(variable) {
|
||
| 140 | -+ | |||
| 72 | +2x |
- #' \frac{z^2_{\alpha/2}}{4n^2}} \right)}
+ .format_hedges_g_results( |
||
| 141 | -+ | |||
| 73 | +2x |
- #'+ by = by, |
||
| 142 | -+ | |||
| 74 | +2x |
- #' @export+ variable = variable, |
||
| 143 | -+ | |||
| 75 | +2x |
- proportion_ci_agresti_coull <- function(x, conf.level = 0.95) {
+ lst_tidy = |
||
| 144 | +76 | 2x |
- set_cli_abort_call()+ cards::eval_capture_conditions( |
|
| 145 | +77 |
-
+ # Need to eval in NAMESAPCE DUE TO BUG IN effectsize v0.8.7. |
||
| 146 | +78 |
- # check inputs ---------------------------------------------------------------+ # Can remove this later along with requirements for withr to be installed. |
||
| 147 | -2x | +|||
| 79 | +
- check_not_missing(x)+ # Will also need to remove `hedges_g` from globalVariables() |
|||
| 148 | +80 | 2x |
- check_binary(x)+ withr::with_namespace( |
|
| 149 | +81 | 2x |
- check_range(conf.level, range = c(0, 1), include_bounds = c(FALSE, FALSE))+ package = "effectsize", |
|
| 150 | +82 | 2x |
- check_scalar(conf.level)+ code = hedges_g(data[[variable]] ~ data[[by]], paired = FALSE, ...) |
|
| 151 | +83 |
-
+ ) |> |
||
| 152 | +84 | 2x |
- x <- stats::na.omit(x)+ parameters::standardize_names(style = "broom") |
|
| 153 | +85 |
-
+ ), |
||
| 154 | +86 | 2x |
- n <- length(x)+ paired = FALSE, |
|
| 155 | -2x | +|||
| 87 | +
- x_sum <- sum(x)+ ... |
|||
| 156 | -2x | +|||
| 88 | +
- z <- stats::qnorm((1 + conf.level) / 2)+ ) |
|||
| 157 | +89 |
-
+ } |
||
| 158 | +90 |
- # Add here both z^2 / 2 successes and failures.+ ) |> |
||
| 159 | +91 | 2x |
- x_sum_tilde <- x_sum + z^2 / 2+ dplyr::bind_rows() |
|
| 160 | -2x | +|||
| 92 | +
- n_tilde <- n + z^2+ }+ |
+ |||
| 93 | ++ | + | ||
| 161 | +94 |
-
+ #' @rdname ard_effectsize_hedges_g |
||
| 162 | +95 |
- # Then proceed as with the Wald interval.+ #' @export |
||
| 163 | -2x | +|||
| 96 | +
- p_tilde <- x_sum_tilde / n_tilde+ ard_effectsize_paired_hedges_g <- function(data, by, variables, id, ...) {
|
|||
| 164 | +97 | 2x |
- q_tilde <- 1 - p_tilde+ set_cli_abort_call() |
|
| 165 | -2x | +|||
| 98 | +
- err <- z * sqrt(p_tilde * q_tilde) / sqrt(n_tilde)+ |
|||
| 166 | -2x | +|||
| 99 | +
- l_ci <- max(0, p_tilde - err)+ # check installed packages --------------------------------------------------- |
|||
| 167 | +100 | 2x |
- u_ci <- min(1, p_tilde + err)+ check_pkg_installed(c("effectsize", "parameters"), reference_pkg = "cardx")
|
|
| 168 | +101 | |||
| 169 | -2x | +|||
| 102 | +
- list(+ # check/process inputs ------------------------------------------------------- |
|||
| 170 | +103 | 2x |
- N = n,+ check_not_missing(data) |
|
| 171 | +104 | 2x |
- estimate = mean(x),+ check_not_missing(variables) |
|
| 172 | +105 | 2x |
- conf.low = l_ci,+ check_not_missing(by) |
|
| 173 | +106 | 2x |
- conf.high = u_ci,+ check_not_missing(id) |
|
| 174 | +107 | 2x |
- conf.level = conf.level,+ check_data_frame(data) |
|
| 175 | +108 | 2x |
- method = "Agresti-Coull Confidence Interval"- |
- |
| 176 | -- |
- )+ data <- dplyr::ungroup(data) |
||
| 177 | -+ | |||
| 109 | +2x |
- }+ cards::process_selectors(data, by = {{ by }}, variables = {{ variables }}, id = {{ id }})
|
||
| 178 | -+ | |||
| 110 | +2x |
-
+ check_scalar(by) |
||
| 179 | -+ | |||
| 111 | +2x |
- #' @describeIn proportion_ci Calculates the Jeffreys interval, an equal-tailed interval based on the+ check_scalar(id) |
||
| 180 | +112 |
- #' non-informative Jeffreys prior for a binomial proportion.+ |
||
| 181 | +113 |
- #'+ # if no variables selected, return empty tibble ------------------------------ |
||
| 182 | -+ | |||
| 114 | +2x |
- #' \deqn{\left( \text{Beta}\left(\frac{k}{2} + \frac{1}{2}, \frac{n - k}{2} + \frac{1}{2}\right)_\alpha,
+ if (is_empty(variables)) {
|
||
| 183 | -+ | |||
| 115 | +! |
- #' \text{Beta}\left(\frac{k}{2} + \frac{1}{2}, \frac{n - k}{2} + \frac{1}{2}\right)_{1-\alpha} \right)}
+ return(dplyr::tibble()) |
||
| 184 | +116 |
- #'+ } |
||
| 185 | +117 |
- #' @export+ # build ARD ------------------------------------------------------------------ |
||
| 186 | +118 |
- proportion_ci_jeffreys <- function(x, conf.level = 0.95) {
+
|
||
| 187 | +119 | 2x |
- set_cli_abort_call()- |
- |
| 188 | -- | - - | -||
| 189 | -- |
- # check inputs ---------------------------------------------------------------+ lapply( |
||
| 190 | +120 | 2x |
- check_not_missing(x)+ variables, |
|
| 191 | +121 | 2x |
- check_binary(x)+ function(variable) {
|
|
| 192 | +122 | 2x |
- check_range(conf.level, range = c(0, 1), include_bounds = c(FALSE, FALSE))+ .format_hedges_g_results( |
|
| 193 | +123 | 2x |
- check_scalar(conf.level)+ by = by, |
|
| 194 | +124 | 2x |
- x <- stats::na.omit(x)- |
- |
| 195 | -- |
-
+ variable = variable, |
||
| 196 | +125 | 2x |
- n <- length(x)+ lst_tidy = |
|
| 197 | +126 | 2x |
- x_sum <- sum(x)+ cards::eval_capture_conditions({
|
|
| 198 | +127 |
-
+ # adding this reshape inside the eval, so if there is an error it's captured in the ARD object |
||
| 199 | +128 | 2x |
- alpha <- 1 - conf.level+ data_wide <- .paired_data_pivot_wider(data, by = by, variable = variable, id = id) |
|
| 200 | -2x | +|||
| 129 | +
- l_ci <- ifelse(+ # perform paired cohen's d test |
|||
| 201 | -2x | +130 | +1x |
- x_sum == 0,+ withr::with_namespace( |
| 202 | -2x | +131 | +1x |
- 0,+ package = "effectsize", |
| 203 | -2x | -
- stats::qbeta(alpha / 2, x_sum + 0.5, n - x_sum + 0.5)- |
- ||
| 204 | -+ | 132 | +1x |
- )+ code = hedges_g(x = data_wide[["by1"]], y = data_wide[["by2"]], paired = TRUE, ...) |
| 205 | +133 | - - | -||
| 206 | -2x | -
- u_ci <- ifelse(+ ) |> |
||
| 207 | -2x | +134 | +1x |
- x_sum == n,+ parameters::standardize_names(style = "broom") |
| 208 | -2x | +|||
| 135 | +
- 1,+ }), |
|||
| 209 | +136 | 2x |
- stats::qbeta(1 - alpha / 2, x_sum + 0.5, n - x_sum + 0.5)+ paired = TRUE, |
|
| 210 | +137 |
- )+ ... |
||
| 211 | +138 |
-
+ ) |
||
| 212 | -2x | +|||
| 139 | +
- list(+ } |
|||
| 213 | -2x | +|||
| 140 | +
- N = n,+ ) |> |
|||
| 214 | +141 | 2x |
- estimate = mean(x),+ dplyr::bind_rows() |
|
| 215 | -2x | +|||
| 142 | +
- conf.low = l_ci,+ } |
|||
| 216 | -2x | +|||
| 143 | +
- conf.high = u_ci,+ |
|||
| 217 | -2x | +|||
| 144 | +
- conf.level = conf.level,+ #' Convert Hedge's G Test to ARD |
|||
| 218 | -2x | +|||
| 145 | +
- method = glue::glue("Jeffreys Interval")
+ #' |
|||
| 219 | +146 |
- )+ #' @inheritParams cards::tidy_as_ard |
||
| 220 | +147 |
- }+ #' @inheritParams effectsize::hedges_g |
||
| 221 | +148 |
-
+ #' @param by (`string`)\cr by column name |
||
| 222 | +149 |
-
+ #' @param variable (`string`)\cr variable column name |
||
| 223 | +150 |
- #' @describeIn proportion_ci Calculates the stratified Wilson confidence+ #' @param ... passed to `hedges_g(...)` |
||
| 224 | +151 |
- #' interval for unequal proportions as described in+ #' |
||
| 225 | +152 |
- #' Xin YA, Su XG. Stratified Wilson and Newcombe confidence intervals+ #' @return ARD data frame |
||
| 226 | +153 |
- #' for multiple binomial proportions. _Statistics in Biopharmaceutical Research_. 2010;2(3).+ #' @keywords internal |
||
| 227 | +154 |
- #'+ #' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = c("effectsize", "parameters"), reference_pkg = "cardx"))
|
||
| 228 | +155 |
- #' \deqn{\frac{\hat{p}_j + \frac{z^2_{\alpha/2}}{2n_j} \pm
+ #' cardx:::.format_hedges_g_results( |
||
| 229 | +156 |
- #' z_{\alpha/2} \sqrt{\frac{\hat{p}_j(1 - \hat{p}_j)}{n_j} +
+ #' by = "ARM", |
||
| 230 | +157 |
- #' \frac{z^2_{\alpha/2}}{4n_j^2}}}{1 + \frac{z^2_{\alpha/2}}{n_j}}}
+ #' variable = "AGE", |
||
| 231 | +158 |
- #'+ #' paired = FALSE, |
||
| 232 | +159 |
- #'+ #' lst_tidy = |
||
| 233 | +160 |
- #' @param strata (`factor`)\cr variable with one level per stratum and same length as `x`.+ #' cards::eval_capture_conditions( |
||
| 234 | +161 |
- #' @param weights (`numeric` or `NULL`)\cr weights for each level of the strata. If `NULL`, they are+ #' effectsize::hedges_g(data[[variable]] ~ data[[by]], paired = FALSE) |> |
||
| 235 | +162 |
- #' estimated using the iterative algorithm that+ #' parameters::standardize_names(style = "broom") |
||
| 236 | +163 |
- #' minimizes the weighted squared length of the confidence interval.+ #' ) |
||
| 237 | +164 |
- #' @param max.iterations (`count`)\cr maximum number of iterations for the iterative procedure used+ #' ) |
||
| 238 | +165 |
- #' to find estimates of optimal weights.+ .format_hedges_g_results <- function(by, variable, lst_tidy, paired, ...) {
|
||
| 239 | +166 |
- #' @param correct (`flag`)\cr include the continuity correction. For further information, see for example+ # build ARD ------------------------------------------------------------------ |
||
| 240 | -+ | |||
| 167 | +4x |
- #' [stats::prop.test()].+ ret <-+ |
+ ||
| 168 | +4x | +
+ cards::tidy_as_ard(+ |
+ ||
| 169 | +4x | +
+ lst_tidy = lst_tidy,+ |
+ ||
| 170 | +4x | +
+ tidy_result_names = c(+ |
+ ||
| 171 | +4x | +
+ "estimate", "conf.level", "conf.low", "conf.high" |
||
| 241 | +172 |
- #'+ ),+ |
+ ||
| 173 | +4x | +
+ fun_args_to_record = c("mu", "paired", "pooled_sd", "alternative"),
+ |
+ ||
| 174 | +4x | +
+ formals = formals(asNamespace("effectsize")[["hedges_g"]]),
+ |
+ ||
| 175 | +4x | +
+ passed_args = c(list(paired = paired), dots_list(...)),+ |
+ ||
| 176 | +4x | +
+ lst_ard_columns = list(group1 = by, variable = variable, context = "effectsize_hedges_g") |
||
| 242 | +177 |
- #' @examples+ ) |
||
| 243 | +178 |
- #' # Stratified Wilson confidence interval with unequal probabilities+ |
||
| 244 | +179 |
- #'+ # add the stat label ---------------------------------------------------------+ |
+ ||
| 180 | +4x | +
+ ret |>+ |
+ ||
| 181 | +4x | +
+ dplyr::left_join(+ |
+ ||
| 182 | +4x | +
+ .df_effectsize_stat_labels(),+ |
+ ||
| 183 | +4x | +
+ by = "stat_name" |
||
| 245 | +184 |
- #' set.seed(1)+ ) |> |
||
| 246 | -+ | |||
| 185 | +4x |
- #' rsp <- sample(c(TRUE, FALSE), 100, TRUE)+ dplyr::mutate(stat_label = dplyr::coalesce(.data$stat_label, .data$stat_name)) |> |
||
| 247 | -+ | |||
| 186 | +4x |
- #' strata_data <- data.frame(+ cards::tidy_ard_column_order() |
||
| 248 | +187 |
- #' "f1" = sample(c("a", "b"), 100, TRUE),
+ } |
| 249 | +1 |
- #' "f2" = sample(c("x", "y", "z"), 100, TRUE),
+ #' ARD Standardized Mean Difference |
||
| 250 | +2 |
- #' stringsAsFactors = TRUE+ #' |
||
| 251 | +3 |
- #' )+ #' @description |
||
| 252 | +4 |
- #' strata <- interaction(strata_data)+ #' Standardized mean difference calculated via [`smd::smd()`] with `na.rm = TRUE`. |
||
| 253 | +5 |
- #' n_strata <- ncol(table(rsp, strata)) # Number of strata+ #' |
||
| 254 | +6 |
- #'+ #' @param data (`data.frame`/`survey.design`)\cr |
||
| 255 | +7 |
- #' proportion_ci_strat_wilson(+ #' a data frame or object of class 'survey.design' |
||
| 256 | +8 |
- #' x = rsp, strata = strata,+ #' (typically created with [`survey::svydesign()`]). |
||
| 257 | +9 |
- #' conf.level = 0.90+ #' @param by ([`tidy-select`][dplyr::dplyr_tidy_select])\cr |
||
| 258 | +10 |
- #' )+ #' column name to compare by. |
||
| 259 | +11 |
- #'+ #' @param variables ([`tidy-select`][dplyr::dplyr_tidy_select])\cr |
||
| 260 | +12 |
- #' # Not automatic setting of weights+ #' column names to be compared. Independent tests will be computed for |
||
| 261 | +13 |
- #' proportion_ci_strat_wilson(+ #' each variable. |
||
| 262 | +14 |
- #' x = rsp, strata = strata,+ #' @inheritDotParams smd::smd -x -g -w -na.rm |
||
| 263 | +15 |
- #' weights = rep(1 / n_strata, n_strata),+ #' |
||
| 264 | +16 |
- #' conf.level = 0.90+ #' @return ARD data frame |
||
| 265 | +17 |
- #' )+ #' @export |
||
| 266 | +18 |
#' |
||
| 267 | +19 |
- #' @export+ #' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = "smd", reference_pkg = "cardx"))
|
||
| 268 | +20 |
- proportion_ci_strat_wilson <- function(x,+ #' ard_smd_smd(cards::ADSL, by = ARM, variables = AGE, std.error = TRUE) |
||
| 269 | +21 |
- strata,+ #' ard_smd_smd(cards::ADSL, by = ARM, variables = AGEGR1, std.error = TRUE) |
||
| 270 | +22 |
- weights = NULL,+ ard_smd_smd <- function(data, by, variables, ...) {
|
||
| 271 | -+ | |||
| 23 | +5x |
- conf.level = 0.95,+ set_cli_abort_call() |
||
| 272 | +24 |
- max.iterations = 10L,+ |
||
| 273 | +25 |
- correct = FALSE) {
+ # check installed packages --------------------------------------------------- |
||
| 274 | -2x | +26 | +5x |
- set_cli_abort_call()+ check_pkg_installed("smd", reference_pkg = "cardx")
|
| 275 | +27 | |||
| 276 | +28 |
- # check inputs ---------------------------------------------------------------+ # check/process inputs ------------------------------------------------------- |
||
| 277 | -2x | +29 | +5x |
- check_not_missing(x)+ check_not_missing(data) |
| 278 | -2x | +30 | +5x |
- check_not_missing(strata)+ check_not_missing(variables) |
| 279 | -2x | +31 | +5x |
- check_binary(x)+ check_not_missing(by) |
| 280 | -2x | +|||
| 32 | +
- check_class(correct, "logical")+ + |
+ |||
| 33 | ++ |
+ # grab design object if from `survey` ---------------------------------------- |
||
| 281 | -2x | +34 | +5x |
- check_scalar(correct)+ is_survey <- inherits(data, "survey.design") |
| 282 | -2x | +35 | +5x |
- check_class(strata, "factor")+ if (is_survey) {
|
| 283 | -2x | +36 | +1x |
- check_range(conf.level, range = c(0, 1), include_bounds = c(FALSE, FALSE))+ design <- data |
| 284 | -2x | +37 | +1x |
- check_scalar(conf.level)+ data <- design$variables |
| 285 | +38 | ++ |
+ }+ |
+ |
| 39 | ||||
| 286 | +40 |
- # remove missing values from x and strata+ # continue check/process inputs ---------------------------------------------- |
||
| 287 | -2x | +41 | +5x |
- is_na <- is.na(x) | is.na(strata)+ check_data_frame(data) |
| 288 | -2x | +42 | +5x |
- x <- x[!is_na]+ data <- dplyr::ungroup(data) |
| 289 | -2x | +43 | +5x |
- strata <- strata[!is_na]+ cards::process_selectors(data, by = {{ by }}, variables = {{ variables }})
|
| 290 | -! | +|||
| 44 | +5x |
- if (!inherits(x, "logical")) x <- as.logical(x)+ check_scalar(by) |
||
| 291 | +45 |
- # check all TRUE/FALSE, if so, not calculable+ + |
+ ||
| 46 | ++ |
+ # if no variables selected, return empty tibble ------------------------------ |
||
| 292 | -2x | +47 | +5x |
- if (all(x) || all(!x)) {
+ if (is_empty(variables)) {
|
| 293 | +48 | ! |
- cli::cli_abort("All values in {.arg x} argument are either {.code TRUE} or {.code FALSE} and CI is not estimable.")
+ return(dplyr::tibble()) |
|
| 294 | +49 |
} |
||
| 295 | +50 | |||
| 296 | -2x | +|||
| 51 | +
- tbl <- table(factor(x, levels = c(FALSE, TRUE)), strata, useNA = "no")+ # build ARD ------------------------------------------------------------------ |
|||
| 297 | -2x | +52 | +5x |
- n_strata <- length(unique(strata))+ lapply( |
| 298 | -+ | |||
| 53 | +5x |
-
+ variables, |
||
| 299 | -+ | |||
| 54 | +5x |
- # Checking the weights and maximum number of iterations.+ function(variable) {
|
||
| 300 | -2x | +55 | +6x |
- do_iter <- FALSE+ .format_smd_results( |
| 301 | -2x | +56 | +6x |
- if (is.null(weights)) {
+ by = by, |
| 302 | -! | +|||
| 57 | +6x |
- weights <- rep(1 / n_strata, n_strata) # Initialization for iterative procedure+ variable = variable, |
||
| 303 | -! | +|||
| 58 | +6x |
- do_iter <- TRUE+ lst_tidy = |
||
| 304 | -+ | |||
| 59 | +6x |
-
+ cards::eval_capture_conditions( |
||
| 305 | -+ | |||
| 60 | +6x |
- # Iteration parameters+ switch(as.character(is_survey), |
||
| 306 | -! | +|||
| 61 | +6x |
- if (!is_scalar_integerish(max.iterations) || max.iterations < 1) {
+ "TRUE" = smd::smd(x = data[[variable]], g = data[[by]], w = stats::weights(design), na.rm = TRUE, ...), |
||
| 307 | -! | +|||
| 62 | +6x |
- cli::cli_abort("Argument {.arg max.iterations} must be a positive integer.")
+ "FALSE" = smd::smd(x = data[[variable]], g = data[[by]], na.rm = TRUE, ...) |
||
| 308 | +63 |
- }+ ) |>+ |
+ ||
| 64 | +6x | +
+ dplyr::select(-any_of("term"))
|
||
| 309 | +65 |
- }+ ), |
||
| 310 | -2x | +|||
| 66 | +
- check_range(weights, range = c(0, 1), include_bounds = c(TRUE, TRUE))+ ... |
|||
| 311 | -2x | +|||
| 67 | +
- sum_weights <- sum(weights) |>+ ) |
|||
| 312 | -2x | +|||
| 68 | +
- round() |>+ } |
|||
| 313 | -2x | +|||
| 69 | +
- as.integer()+ ) |> |
|||
| 314 | -2x | +70 | +5x |
- if (sum_weights != 1L || abs(sum_weights - sum(weights)) > sqrt(.Machine$double.eps)) {
+ dplyr::bind_rows() |
| 315 | -! | +|||
| 71 | +
- cli::cli_abort("The sum of the {.arg weights} argument must be {.val {1L}}")
+ } |
|||
| 316 | +72 |
- }+ |
||
| 317 | +73 | |||
| 318 | -2x | +|||
| 74 | +
- xs <- tbl["TRUE", ]+ .format_smd_results <- function(by, variable, lst_tidy, ...) {
|
|||
| 319 | -2x | +|||
| 75 | +
- ns <- colSums(tbl)+ # build ARD ------------------------------------------------------------------ |
|||
| 320 | -2x | +76 | +6x |
- use_stratum <- (ns > 0)+ ret <- |
| 321 | -2x | +77 | +6x |
- ns <- ns[use_stratum]+ cards::tidy_as_ard( |
| 322 | -2x | +78 | +6x |
- xs <- xs[use_stratum]+ lst_tidy = lst_tidy, |
| 323 | -2x | +79 | +6x |
- ests <- xs / ns+ tidy_result_names = c("estimate", "std.error"),
|
| 324 | -2x | -
- vars <- ests * (1 - ests) / ns- |
- ||
| 325 | -+ | 80 | +6x |
-
+ fun_args_to_record = "gref", |
| 326 | -2x | +81 | +6x |
- strata_qnorm <- .strata_normal_quantile(vars, weights, conf.level)+ formals = formals(smd::smd)["gref"], |
| 327 | +82 |
-
+ # removing the `std.error` ARGUMENT (not the result) |
||
| 328 | -+ | |||
| 83 | +6x |
- # Iterative setting of weights if they were not passed in `weights` argument+ passed_args = dots_list(...) |> utils::modifyList(list(std.error = NULL)), |
||
| 329 | -2x | +84 | +6x |
- weights_new <- if (do_iter) {
+ lst_ard_columns = list(group1 = by, variable = variable, context = "smd_smd") |
| 330 | -! | +|||
| 85 | ++ |
+ )+ |
+ ||
| 86 | +
- .update_weights_strat_wilson(vars, strata_qnorm, weights, ns, max.iterations, conf.level)$weights+ |
|||
| 331 | +87 |
- } else {
+ # add the stat label --------------------------------------------------------- |
||
| 332 | -2x | +88 | +6x |
- weights+ ret |> |
| 333 | -+ | |||
| 89 | +6x |
- }+ dplyr::left_join( |
||
| 334 | -+ | |||
| 90 | +6x |
-
+ dplyr::tribble( |
||
| 335 | -2x | +91 | +6x |
- strata_conf.level <- 2 * stats::pnorm(strata_qnorm) - 1+ ~stat_name, ~stat_label, |
| 336 | -+ | |||
| 92 | +6x |
-
+ "estimate", "Standardized Mean Difference", |
||
| 337 | -2x | +93 | +6x |
- ci_by_strata <- Map(+ "std.error", "Standard Error", |
| 338 | -2x | +94 | +6x |
- function(x, n) {
+ "gref", "Integer Reference Group Level" |
| 339 | +95 |
- # Classic Wilson's confidence interval+ ), |
||
| 340 | -12x | +96 | +6x |
- suppressWarnings(stats::prop.test(x, n, correct = correct, conf.level = strata_conf.level)$conf.int)+ by = "stat_name" |
| 341 | +97 |
- },+ ) |> |
||
| 342 | -2x | +98 | +6x |
- x = xs,+ dplyr::mutate(stat_label = dplyr::coalesce(.data$stat_label, .data$stat_name)) |> |
| 343 | -2x | +99 | +6x |
- n = ns+ cards::tidy_ard_column_order() |
| 344 | +100 |
- )+ } |
||
| 345 | -2x | +
| 1 | +
- lower_by_strata <- sapply(ci_by_strata, "[", 1L)+ #' ARD Mood Test |
||
| 346 | -2x | +||
| 2 | +
- upper_by_strata <- sapply(ci_by_strata, "[", 2L)+ #' |
||
| 347 | +3 |
-
+ #' @description |
|
| 348 | -2x | +||
| 4 | +
- lower <- sum(weights_new * lower_by_strata)+ #' Analysis results data for Mood two sample test of scale. Note this not to be confused with |
||
| 349 | -2x | +||
| 5 | +
- upper <- sum(weights_new * upper_by_strata)+ #' the Brown-Mood test of medians. |
||
| 350 | +6 |
-
+ #' |
|
| 351 | +7 |
- # Return values+ #' @param data (`data.frame`)\cr |
|
| 352 | -2x | +||
| 8 | +
- list(+ #' a data frame. See below for details. |
||
| 353 | -2x | +||
| 9 | +
- N = length(x),+ #' @param by ([`tidy-select`][dplyr::dplyr_tidy_select])\cr |
||
| 354 | -2x | +||
| 10 | +
- estimate = mean(x),+ #' column name to compare by. |
||
| 355 | -2x | +||
| 11 | +
- conf.low = lower,+ #' @param variables ([`tidy-select`][dplyr::dplyr_tidy_select])\cr |
||
| 356 | -2x | +||
| 12 | +
- conf.high = upper,+ #' column name to be compared. Independent tests will |
||
| 357 | -2x | +||
| 13 | +
- conf.level = conf.level,+ #' be run for each variable. |
||
| 358 | -2x | +||
| 14 | +
- weights = if (do_iter) weights_new else NULL,+ #' @param ... arguments passed to `mood.test(...)` |
||
| 359 | -2x | +||
| 15 | +
- method =+ #' |
||
| 360 | -2x | +||
| 16 | +
- glue::glue("Stratified Wilson Confidence Interval {ifelse(correct, 'with', 'without')} continuity correction")
+ #' @return ARD data frame |
||
| 361 | +17 |
- ) |>+ #' @name ard_stats_mood_test |
|
| 362 | -2x | +||
| 18 | +
- compact()+ #' |
||
| 363 | +19 |
- }+ #' @details |
|
| 364 | +20 |
-
+ #' For the `ard_stats_mood_test()` function, the data is expected to be one row per subject. |
|
| 365 | +21 |
- #' Helper Function for the Estimation of Stratified Quantiles+ #' The data is passed as `mood.test(data[[variable]] ~ data[[by]], ...)`. |
|
| 366 | +22 |
- #'+ #' @rdname ard_stats_mood_test |
|
| 367 | +23 |
- #' This function wraps the estimation of stratified percentiles when we assume+ #' @export |
|
| 368 | +24 |
- #' the approximation for large numbers. This is necessary only in the case+ #' |
|
| 369 | +25 | ++ |
+ #' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = "broom", reference_pkg = "cardx"))
+ |
+
| 26 |
- #' proportions for each strata are unequal.+ #' cards::ADSL |> |
||
| 370 | +27 |
- #'+ #' ard_stats_mood_test(by = "SEX", variables = "AGE") |
|
| 371 | +28 |
- #' @inheritParams proportion_ci_strat_wilson+ ard_stats_mood_test <- function(data, by, variables, ...) {
|
|
| 372 | -+ | ||
| 29 | +2x |
- #'+ set_cli_abort_call() |
|
| 373 | +30 |
- #' @return Stratified quantile.+ |
|
| 374 | +31 |
- #'+ # check installed packages --------------------------------------------------- |
|
| 375 | -+ | ||
| 32 | +2x |
- #' @seealso [proportion_ci_strat_wilson()]+ check_pkg_installed("broom", reference_pkg = "cardx")
|
|
| 376 | +33 |
- #'+ |
|
| 377 | +34 |
- #' @keywords internal+ # check/process inputs ------------------------------------------------------- |
|
| 378 | -+ | ||
| 35 | +2x |
- #'+ check_not_missing(data) |
|
| 379 | -+ | ||
| 36 | +2x |
- #' @examples+ check_not_missing(variables) |
|
| 380 | -+ | ||
| 37 | +2x |
- #' strata_data <- table(data.frame(+ check_not_missing(by) |
|
| 381 | -+ | ||
| 38 | +2x |
- #' "f1" = sample(c(TRUE, FALSE), 100, TRUE),+ check_data_frame(data) |
|
| 382 | -+ | ||
| 39 | +2x |
- #' "f2" = sample(c("x", "y", "z"), 100, TRUE),
+ data <- dplyr::ungroup(data) |
|
| 383 | -+ | ||
| 40 | +2x |
- #' stringsAsFactors = TRUE+ cards::process_selectors(data, by = {{ by }}, variables = {{ variables }})
|
|
| 384 | -+ | ||
| 41 | +2x |
- #' ))+ check_scalar(by) |
|
| 385 | +42 |
- #' ns <- colSums(strata_data)+ |
|
| 386 | +43 |
- #' ests <- strata_data["TRUE", ] / ns+ |
|
| 387 | +44 |
- #' vars <- ests * (1 - ests) / ns+ # if no variables selected, return empty tibble ------------------------------ |
|
| 388 | -+ | ||
| 45 | +2x |
- #' weights <- rep(1 / length(ns), length(ns))+ if (is_empty(variables)) {
|
|
| 389 | -+ | ||
| 46 | +! |
- #'+ return(dplyr::tibble()) |
|
| 390 | +47 |
- #' cardx:::.strata_normal_quantile(vars, weights, 0.95)+ } |
|
| 391 | +48 |
- .strata_normal_quantile <- function(vars, weights, conf.level) {
+ # build ARD ------------------------------------------------------------------ |
|
| 392 | +49 | 2x |
- summands <- weights^2 * vars+ lapply( |
| 393 | -+ | ||
| 50 | +2x |
- # Stratified quantile+ variables, |
|
| 394 | +51 | 2x |
- sqrt(sum(summands)) / sum(sqrt(summands)) * stats::qnorm((1 + conf.level) / 2)+ function(variable) {
|
| 395 | -+ | ||
| 52 | +2x |
- }+ .format_moodtest_results( |
|
| 396 | -+ | ||
| 53 | +2x |
-
+ by = by, |
|
| 397 | -+ | ||
| 54 | +2x |
- #' Helper Function for the Estimation of Weights for `proportion_ci_strat_wilson()`+ variable = variable, |
|
| 398 | -+ | ||
| 55 | +2x |
- #'+ lst_tidy = |
|
| 399 | -+ | ||
| 56 | +2x |
- #' This function wraps the iteration procedure that allows you to estimate+ cards::eval_capture_conditions( |
|
| 400 | -+ | ||
| 57 | +2x |
- #' the weights for each proportional strata. This assumes to minimize the+ stats::mood.test(data[[variable]] ~ data[[by]], ...) |> |
|
| 401 | -+ | ||
| 58 | +2x |
- #' weighted squared length of the confidence interval.+ broom::tidy() |
|
| 402 | +59 |
- #'+ ), |
|
| 403 | +60 |
- #' @keywords internal+ ... |
|
| 404 | +61 |
- #' @inheritParams proportion_ci_strat_wilson+ ) |
|
| 405 | +62 |
- #' @param vars (`numeric`)\cr normalized proportions for each strata.+ } |
|
| 406 | +63 |
- #' @param strata_qnorm (`numeric`)\cr initial estimation with identical weights of the quantiles.+ ) |> |
|
| 407 | -+ | ||
| 64 | +2x |
- #' @param initial_weights (`numeric`)\cr initial weights used to calculate `strata_qnorm`. This can+ dplyr::bind_rows() |
|
| 408 | +65 |
- #' be optimized in the future if we need to estimate better initial weights.+ } |
|
| 409 | +66 |
- #' @param n_per_strata (`numeric`)\cr number of elements in each strata.+ #' Convert mood test results to ARD |
|
| 410 | +67 |
- #' @param max.iterations (`count`)\cr maximum number of iterations to be tried. Convergence is always checked.+ #' |
|
| 411 | +68 |
- #' @param tol (`number`)\cr tolerance threshold for convergence.+ #' @inheritParams cards::tidy_as_ard |
|
| 412 | +69 |
- #'+ #' @inheritParams stats::mood.test |
|
| 413 | +70 |
- #' @return A `list` of 3 elements: `n_it`, `weights`, and `diff_v`.+ #' @param by (`string`)\cr by column name |
|
| 414 | +71 |
- #'+ #' @param variable (`string`)\cr variable column name |
|
| 415 | +72 |
- #' @seealso For references and details see [`proportion_ci_strat_wilson()`].+ #' @param ... passed to `mood.test(...)` |
|
| 416 | +73 |
#' |
|
| 417 | +74 |
- #' @examples+ #' @return ARD data frame |
|
| 418 | +75 |
- #' vs <- c(0.011, 0.013, 0.012, 0.014, 0.017, 0.018)+ #' @keywords internal |
|
| 419 | +76 |
- #' sq <- 0.674+ #' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = "broom", reference_pkg = "cardx"))
|
|
| 420 | +77 |
- #' ws <- rep(1 / length(vs), length(vs))+ #' cardx:::.format_moodtest_results( |
|
| 421 | +78 |
- #' ns <- c(22, 18, 17, 17, 14, 12)+ #' by = "SEX", |
|
| 422 | +79 |
- #'+ #' variable = "AGE", |
|
| 423 | +80 |
- #' cardx:::.update_weights_strat_wilson(vs, sq, ws, ns, 100, 0.95, 0.001)+ #' lst_tidy = |
|
| 424 | +81 |
- .update_weights_strat_wilson <- function(vars,+ #' cards::eval_capture_conditions( |
|
| 425 | +82 |
- strata_qnorm,+ #' stats::mood.test(ADSL[["AGE"]] ~ ADSL[["SEX"]]) |> |
|
| 426 | +83 |
- initial_weights,+ #' broom::tidy() |
|
| 427 | +84 |
- n_per_strata,+ #' ) |
|
| 428 | +85 |
- max.iterations = 50,+ #' ) |
|
| 429 | +86 |
- conf.level = 0.95,+ .format_moodtest_results <- function(by, variable, lst_tidy, ...) {
|
|
| 430 | +87 |
- tol = 0.001) {
+ # build ARD ------------------------------------------------------------------ |
|
| 431 | -! | +||
| 88 | +2x |
- it <- 0+ ret <- |
|
| 432 | -! | +||
| 89 | +2x |
- diff_v <- NULL+ cards::tidy_as_ard( |
|
| 433 | -+ | ||
| 90 | +2x |
-
+ lst_tidy = lst_tidy, |
|
| 434 | -! | +||
| 91 | +2x |
- while (it < max.iterations) {
+ tidy_result_names = c("statistic", "p.value", "method", "alternative"),
|
|
| 435 | -! | +||
| 92 | +2x |
- it <- it + 1+ formals = formals(asNamespace("stats")[["mood.test.default"]]),
|
|
| 436 | -! | +||
| 93 | +2x |
- weights_new_t <- (1 + strata_qnorm^2 / n_per_strata)^2+ passed_args = c(dots_list(...)), |
|
| 437 | -! | +||
| 94 | +2x |
- weights_new_b <- (vars + strata_qnorm^2 / (4 * n_per_strata^2))+ lst_ard_columns = list(group1 = by, variable = variable, context = "stats_mood_test") |
|
| 438 | -! | +||
| 95 | +
- weights_new <- weights_new_t / weights_new_b+ ) |
||
| 439 | -! | +||
| 96 | +
- weights_new <- weights_new / sum(weights_new)+ |
||
| 440 | -! | +||
| 97 | +
- strata_qnorm <- .strata_normal_quantile(vars, weights_new, conf.level)+ # add the stat label --------------------------------------------------------- |
||
| 441 | -! | +||
| 98 | +2x |
- diff_v <- c(diff_v, sum(abs(weights_new - initial_weights)))+ ret |> |
|
| 442 | -! | +||
| 99 | +2x |
- if (diff_v[length(diff_v)] < tol) break+ dplyr::left_join( |
|
| 443 | -! | +||
| 100 | +2x |
- initial_weights <- weights_new+ .df_moodtest_stat_labels(), |
|
| 444 | -+ | ||
| 101 | +2x |
- }+ by = "stat_name" |
|
| 445 | +102 |
-
+ ) |> |
|
| 446 | -! | +||
| 103 | +2x |
- if (it == max.iterations) {
+ dplyr::mutate(stat_label = dplyr::coalesce(.data$stat_label, .data$stat_name)) |> |
|
| 447 | -! | +||
| 104 | +2x |
- warning("The heuristic to find weights did not converge with max.iterations = ", max.iterations)
+ cards::tidy_ard_column_order() |
|
| 448 | +105 |
- }+ } |
|
| 449 | +106 | ||
| 450 | -! | +||
| 107 | +
- list(+ .df_moodtest_stat_labels <- function() {
|
||
| 451 | -! | +||
| 108 | +2x |
- "n_it" = it,+ dplyr::tribble( |
|
| 452 | -! | +||
| 109 | +2x |
- "weights" = weights_new,+ ~stat_name, ~stat_label, |
|
| 453 | -! | +||
| 110 | +2x |
- "diff_v" = diff_v+ "statistic", "Z-Statistic",+ |
+ |
| 111 | +2x | +
+ "p.value", "p-value",+ |
+ |
| 112 | +2x | +
+ "alternative", "Alternative Hypothesis" |
|
| 454 | +113 |
) |
|
| 455 | +114 |
} |