| 1 | ++ |
+ #' Functions for Calculating Proportion Confidence Intervals+ |
+
| 2 | ++ |
+ #'+ |
+
| 3 | ++ |
+ #' Functions to calculate different proportion confidence intervals for use in `ard_proportion()`.+ |
+
| 4 | ++ |
+ #'+ |
+
| 5 | ++ |
+ #' @inheritParams ard_categorical_ci+ |
+
| 6 | ++ |
+ #' @param x vector of a binary values, i.e. a logical vector, or numeric with values `c(0, 1)`+ |
+
| 7 | ++ |
+ #' @return Confidence interval of a proportion.+ |
+
| 8 | ++ |
+ #'+ |
+
| 9 | ++ |
+ #' @name proportion_ci+ |
+
| 10 | ++ |
+ #' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = "broom", reference_pkg = "cardx"))
+ |
+
| 11 | ++ |
+ #' x <- c(+ |
+
| 12 | ++ |
+ #' TRUE, TRUE, TRUE, TRUE, TRUE,+ |
+
| 13 | ++ |
+ #' FALSE, FALSE, FALSE, FALSE, FALSE+ |
+
| 14 | ++ |
+ #' )+ |
+
| 15 | ++ |
+ #'+ |
+
| 16 | ++ |
+ #' proportion_ci_wald(x, conf.level = 0.9)+ |
+
| 17 | ++ |
+ #' proportion_ci_wilson(x, correct = TRUE)+ |
+
| 18 | ++ |
+ #' proportion_ci_clopper_pearson(x)+ |
+
| 19 | ++ |
+ #' proportion_ci_agresti_coull(x)+ |
+
| 20 | ++ |
+ #' proportion_ci_jeffreys(x)+ |
+
| 21 | ++ |
+ NULL+ |
+
| 22 | ++ | + + | +
| 23 | ++ |
+ #' @describeIn proportion_ci Calculates the Wald interval by following the usual textbook definition+ |
+
| 24 | ++ |
+ #' for a single proportion confidence interval using the normal approximation.+ |
+
| 25 | ++ |
+ #'+ |
+
| 26 | ++ |
+ #' \deqn{\hat{p} \pm z_{\alpha/2} \sqrt{\frac{\hat{p}(1 - \hat{p})}{n}}}
+ |
+
| 27 | ++ |
+ #'+ |
+
| 28 | ++ |
+ #' @param correct (`logical`)\cr apply continuity correction.+ |
+
| 29 | ++ |
+ #'+ |
+
| 30 | ++ |
+ #' @export+ |
+
| 31 | ++ |
+ proportion_ci_wald <- function(x, conf.level = 0.95, correct = FALSE) {
+ |
+
| 32 | +17x | +
+ set_cli_abort_call()+ |
+
| 33 | ++ | + + | +
| 34 | ++ |
+ # check inputs ---------------------------------------------------------------+ |
+
| 35 | +17x | +
+ check_not_missing(x)+ |
+
| 36 | +17x | +
+ check_binary(x)+ |
+
| 37 | +17x | +
+ check_range(conf.level, range = c(0, 1), include_bounds = c(FALSE, FALSE))+ |
+
| 38 | +17x | +
+ check_scalar(conf.level)+ |
+
| 39 | +17x | +
+ check_class(x = correct, "logical")+ |
+
| 40 | +17x | +
+ check_scalar(correct)+ |
+
| 41 | ++ | + + | +
| 42 | +17x | +
+ x <- stats::na.omit(x)+ |
+
| 43 | ++ | + + | +
| 44 | +17x | +
+ n <- length(x)+ |
+
| 45 | +17x | +
+ p_hat <- mean(x)+ |
+
| 46 | +17x | +
+ z <- stats::qnorm((1 + conf.level) / 2)+ |
+
| 47 | +17x | +
+ q_hat <- 1 - p_hat+ |
+
| 48 | +17x | +
+ correction_factor <- ifelse(correct, 1 / (2 * n), 0)+ |
+
| 49 | ++ | + + | +
| 50 | +17x | +
+ err <- z * sqrt(p_hat * q_hat) / sqrt(n) + correction_factor+ |
+
| 51 | +17x | +
+ l_ci <- max(0, p_hat - err)+ |
+
| 52 | +17x | +
+ u_ci <- min(1, p_hat + err)+ |
+
| 53 | ++ | + + | +
| 54 | +17x | +
+ list(+ |
+
| 55 | +17x | +
+ N = n,+ |
+
| 56 | +17x | +
+ estimate = p_hat,+ |
+
| 57 | +17x | +
+ conf.low = l_ci,+ |
+
| 58 | +17x | +
+ conf.high = u_ci,+ |
+
| 59 | +17x | +
+ conf.level = conf.level,+ |
+
| 60 | +17x | +
+ method =+ |
+
| 61 | +17x | +
+ glue::glue("Wald Confidence Interval {ifelse(correct, 'with', 'without')} continuity correction")
+ |
+
| 62 | ++ |
+ )+ |
+
| 63 | ++ |
+ }+ |
+
| 64 | ++ | + + | +
| 65 | ++ | + + | +
| 66 | ++ |
+ #' @describeIn proportion_ci Calculates the Wilson interval by calling [stats::prop.test()].+ |
+
| 67 | ++ |
+ #' Also referred to as Wilson score interval.+ |
+
| 68 | ++ |
+ #'+ |
+
| 69 | ++ |
+ #' \deqn{\frac{\hat{p} +
+ |
+
| 70 | ++ |
+ #' \frac{z^2_{\alpha/2}}{2n} \pm z_{\alpha/2} \sqrt{\frac{\hat{p}(1 - \hat{p})}{n} +
+ |
+
| 71 | ++ |
+ #' \frac{z^2_{\alpha/2}}{4n^2}}}{1 + \frac{z^2_{\alpha/2}}{n}}}
+ |
+
| 72 | ++ |
+ #'+ |
+
| 73 | ++ |
+ #' @export+ |
+
| 74 | ++ |
+ proportion_ci_wilson <- function(x, conf.level = 0.95, correct = FALSE) {
+ |
+
| 75 | +5x | +
+ set_cli_abort_call()+ |
+
| 76 | ++ | + + | +
| 77 | ++ |
+ # check installed packages ---------------------------------------------------+ |
+
| 78 | +5x | +
+ check_pkg_installed(pkg = "broom", reference_pkg = "cardx")+ |
+
| 79 | ++ | + + | +
| 80 | ++ |
+ # check inputs ---------------------------------------------------------------+ |
+
| 81 | +5x | +
+ check_not_missing(x)+ |
+
| 82 | +5x | +
+ check_binary(x)+ |
+
| 83 | +5x | +
+ check_class(x = correct, "logical")+ |
+
| 84 | +5x | +
+ check_scalar(correct)+ |
+
| 85 | +5x | +
+ check_range(conf.level, range = c(0, 1), include_bounds = c(FALSE, FALSE))+ |
+
| 86 | +5x | +
+ check_scalar(conf.level)+ |
+
| 87 | ++ | + + | +
| 88 | +5x | +
+ x <- stats::na.omit(x)+ |
+
| 89 | ++ | + + | +
| 90 | +5x | +
+ n <- length(x)+ |
+
| 91 | +5x | +
+ y <- stats::prop.test(x = sum(x), n = n, correct = correct, conf.level = conf.level)+ |
+
| 92 | ++ | + + | +
| 93 | +5x | +
+ list(N = n, conf.level = conf.level) |>+ |
+
| 94 | +5x | +
+ utils::modifyList(val = broom::tidy(y) |> as.list()) |>+ |
+
| 95 | +5x | +
+ utils::modifyList(+ |
+
| 96 | +5x | +
+ list(+ |
+
| 97 | +5x | +
+ method =+ |
+
| 98 | +5x | +
+ glue::glue("Wilson Confidence Interval {ifelse(correct, 'with', 'without')} continuity correction")
+ |
+
| 99 | ++ |
+ )+ |
+
| 100 | ++ |
+ )+ |
+
| 101 | ++ |
+ }+ |
+
| 102 | ++ | + + | +
| 103 | ++ |
+ #' @describeIn proportion_ci Calculates the Clopper-Pearson interval by calling [stats::binom.test()].+ |
+
| 104 | ++ |
+ #' Also referred to as the `exact` method.+ |
+
| 105 | ++ |
+ #'+ |
+
| 106 | ++ |
+ #' \deqn{
+ |
+
| 107 | ++ |
+ #' \left( \frac{k}{n} \pm z_{\alpha/2} \sqrt{\frac{\frac{k}{n}(1-\frac{k}{n})}{n} +
+ |
+
| 108 | ++ |
+ #' \frac{z^2_{\alpha/2}}{4n^2}} \right)
+ |
+
| 109 | ++ |
+ #' / \left( 1 + \frac{z^2_{\alpha/2}}{n} \right)}
+ |
+
| 110 | ++ |
+ #'+ |
+
| 111 | ++ |
+ #' @export+ |
+
| 112 | ++ |
+ proportion_ci_clopper_pearson <- function(x, conf.level = 0.95) {
+ |
+
| 113 | +2x | +
+ set_cli_abort_call()+ |
+
| 114 | ++ | + + | +
| 115 | ++ |
+ # check installed packages ---------------------------------------------------+ |
+
| 116 | +2x | +
+ check_pkg_installed(pkg = "broom", reference_pkg = "cardx")+ |
+
| 117 | ++ | + + | +
| 118 | ++ |
+ # check inputs ---------------------------------------------------------------+ |
+
| 119 | +2x | +
+ check_not_missing(x)+ |
+
| 120 | +2x | +
+ check_binary(x)+ |
+
| 121 | +2x | +
+ check_range(conf.level, range = c(0, 1), include_bounds = c(FALSE, FALSE))+ |
+
| 122 | +2x | +
+ check_scalar(conf.level)+ |
+
| 123 | ++ | + + | +
| 124 | +2x | +
+ x <- stats::na.omit(x)+ |
+
| 125 | +2x | +
+ n <- length(x)+ |
+
| 126 | ++ | + + | +
| 127 | +2x | +
+ y <- stats::binom.test(x = sum(x), n = n, conf.level = conf.level)+ |
+
| 128 | ++ | + + | +
| 129 | +2x | +
+ list(N = n, conf.level = conf.level) |>+ |
+
| 130 | +2x | +
+ utils::modifyList(val = broom::tidy(y) |> as.list()) |>+ |
+
| 131 | +2x | +
+ utils::modifyList(list(method = "Clopper-Pearson Confidence Interval"))+ |
+
| 132 | ++ |
+ }+ |
+
| 133 | ++ | + + | +
| 134 | ++ |
+ #' @describeIn proportion_ci Calculates the `Agresti-Coull` interval (created by `Alan Agresti` and `Brent Coull`) by+ |
+
| 135 | ++ |
+ #' (for 95% CI) adding two successes and two failures to the data and then using the Wald formula to construct a CI.+ |
+
| 136 | ++ |
+ #'+ |
+
| 137 | ++ |
+ #' \deqn{
+ |
+
| 138 | ++ |
+ #' \left( \frac{\tilde{p} + z^2_{\alpha/2}/2}{n + z^2_{\alpha/2}} \pm
+ |
+
| 139 | ++ |
+ #' z_{\alpha/2} \sqrt{\frac{\tilde{p}(1 - \tilde{p})}{n} +
+ |
+
| 140 | ++ |
+ #' \frac{z^2_{\alpha/2}}{4n^2}} \right)}
+ |
+
| 141 | ++ |
+ #'+ |
+
| 142 | ++ |
+ #' @export+ |
+
| 143 | ++ |
+ proportion_ci_agresti_coull <- function(x, conf.level = 0.95) {
+ |
+
| 144 | +2x | +
+ set_cli_abort_call()+ |
+
| 145 | ++ | + + | +
| 146 | ++ |
+ # check inputs ---------------------------------------------------------------+ |
+
| 147 | +2x | +
+ check_not_missing(x)+ |
+
| 148 | +2x | +
+ check_binary(x)+ |
+
| 149 | +2x | +
+ check_range(conf.level, range = c(0, 1), include_bounds = c(FALSE, FALSE))+ |
+
| 150 | +2x | +
+ check_scalar(conf.level)+ |
+
| 151 | ++ | + + | +
| 152 | +2x | +
+ x <- stats::na.omit(x)+ |
+
| 153 | ++ | + + | +
| 154 | +2x | +
+ n <- length(x)+ |
+
| 155 | +2x | +
+ x_sum <- sum(x)+ |
+
| 156 | +2x | +
+ z <- stats::qnorm((1 + conf.level) / 2)+ |
+
| 157 | ++ | + + | +
| 158 | ++ |
+ # Add here both z^2 / 2 successes and failures.+ |
+
| 159 | +2x | +
+ x_sum_tilde <- x_sum + z^2 / 2+ |
+
| 160 | +2x | +
+ n_tilde <- n + z^2+ |
+
| 161 | ++ | + + | +
| 162 | ++ |
+ # Then proceed as with the Wald interval.+ |
+
| 163 | +2x | +
+ p_tilde <- x_sum_tilde / n_tilde+ |
+
| 164 | +2x | +
+ q_tilde <- 1 - p_tilde+ |
+
| 165 | +2x | +
+ err <- z * sqrt(p_tilde * q_tilde) / sqrt(n_tilde)+ |
+
| 166 | +2x | +
+ l_ci <- max(0, p_tilde - err)+ |
+
| 167 | +2x | +
+ u_ci <- min(1, p_tilde + err)+ |
+
| 168 | ++ | + + | +
| 169 | +2x | +
+ list(+ |
+
| 170 | +2x | +
+ N = n,+ |
+
| 171 | +2x | +
+ estimate = mean(x),+ |
+
| 172 | +2x | +
+ conf.low = l_ci,+ |
+
| 173 | +2x | +
+ conf.high = u_ci,+ |
+
| 174 | +2x | +
+ conf.level = conf.level,+ |
+
| 175 | +2x | +
+ method = "Agresti-Coull Confidence Interval"+ |
+
| 176 | ++ |
+ )+ |
+
| 177 | ++ |
+ }+ |
+
| 178 | ++ | + + | +
| 179 | ++ |
+ #' @describeIn proportion_ci Calculates the Jeffreys interval, an equal-tailed interval based on the+ |
+
| 180 | ++ |
+ #' non-informative Jeffreys prior for a binomial proportion.+ |
+
| 181 | ++ |
+ #'+ |
+
| 182 | ++ |
+ #' \deqn{\left( \text{Beta}\left(\frac{k}{2} + \frac{1}{2}, \frac{n - k}{2} + \frac{1}{2}\right)_\alpha,
+ |
+
| 183 | ++ |
+ #' \text{Beta}\left(\frac{k}{2} + \frac{1}{2}, \frac{n - k}{2} + \frac{1}{2}\right)_{1-\alpha} \right)}
+ |
+
| 184 | ++ |
+ #'+ |
+
| 185 | ++ |
+ #' @export+ |
+
| 186 | ++ |
+ proportion_ci_jeffreys <- function(x, conf.level = 0.95) {
+ |
+
| 187 | +3x | +
+ set_cli_abort_call()+ |
+
| 188 | ++ | + + | +
| 189 | ++ |
+ # check inputs ---------------------------------------------------------------+ |
+
| 190 | +3x | +
+ check_not_missing(x)+ |
+
| 191 | +3x | +
+ check_binary(x)+ |
+
| 192 | +3x | +
+ check_range(conf.level, range = c(0, 1), include_bounds = c(FALSE, FALSE))+ |
+
| 193 | +3x | +
+ check_scalar(conf.level)+ |
+
| 194 | +3x | +
+ x <- stats::na.omit(x)+ |
+
| 195 | ++ | + + | +
| 196 | +3x | +
+ n <- length(x)+ |
+
| 197 | +3x | +
+ x_sum <- sum(x)+ |
+
| 198 | ++ | + + | +
| 199 | +3x | +
+ alpha <- 1 - conf.level+ |
+
| 200 | +3x | +
+ l_ci <- ifelse(+ |
+
| 201 | +3x | +
+ x_sum == 0,+ |
+
| 202 | +3x | +
+ 0,+ |
+
| 203 | +3x | +
+ stats::qbeta(alpha / 2, x_sum + 0.5, n - x_sum + 0.5)+ |
+
| 204 | ++ |
+ )+ |
+
| 205 | ++ | + + | +
| 206 | +3x | +
+ u_ci <- ifelse(+ |
+
| 207 | +3x | +
+ x_sum == n,+ |
+
| 208 | +3x | +
+ 1,+ |
+
| 209 | +3x | +
+ stats::qbeta(1 - alpha / 2, x_sum + 0.5, n - x_sum + 0.5)+ |
+
| 210 | ++ |
+ )+ |
+
| 211 | ++ | + + | +
| 212 | +3x | +
+ list(+ |
+
| 213 | +3x | +
+ N = n,+ |
+
| 214 | +3x | +
+ estimate = mean(x),+ |
+
| 215 | +3x | +
+ conf.low = l_ci,+ |
+
| 216 | +3x | +
+ conf.high = u_ci,+ |
+
| 217 | +3x | +
+ conf.level = conf.level,+ |
+
| 218 | +3x | +
+ method = glue::glue("Jeffreys Interval")
+ |
+
| 219 | ++ |
+ )+ |
+
| 220 | ++ |
+ }+ |
+
| 221 | ++ | + + | +
| 222 | ++ | + + | +
| 223 | ++ |
+ #' @describeIn proportion_ci Calculates the stratified Wilson confidence+ |
+
| 224 | ++ |
+ #' interval for unequal proportions as described in+ |
+
| 225 | ++ |
+ #' Xin YA, Su XG. Stratified Wilson and Newcombe confidence intervals+ |
+
| 226 | ++ |
+ #' for multiple binomial proportions. _Statistics in Biopharmaceutical Research_. 2010;2(3).+ |
+
| 227 | ++ |
+ #'+ |
+
| 228 | ++ |
+ #' \deqn{\frac{\hat{p}_j + \frac{z^2_{\alpha/2}}{2n_j} \pm
+ |
+
| 229 | ++ |
+ #' z_{\alpha/2} \sqrt{\frac{\hat{p}_j(1 - \hat{p}_j)}{n_j} +
+ |
+
| 230 | ++ |
+ #' \frac{z^2_{\alpha/2}}{4n_j^2}}}{1 + \frac{z^2_{\alpha/2}}{n_j}}}
+ |
+
| 231 | ++ |
+ #'+ |
+
| 232 | ++ |
+ #'+ |
+
| 233 | ++ |
+ #' @param strata (`factor`)\cr variable with one level per stratum and same length as `x`.+ |
+
| 234 | ++ |
+ #' @param weights (`numeric` or `NULL`)\cr weights for each level of the strata. If `NULL`, they are+ |
+
| 235 | ++ |
+ #' estimated using the iterative algorithm that+ |
+
| 236 | ++ |
+ #' minimizes the weighted squared length of the confidence interval.+ |
+
| 237 | ++ |
+ #' @param max.iterations (`count`)\cr maximum number of iterations for the iterative procedure used+ |
+
| 238 | ++ |
+ #' to find estimates of optimal weights.+ |
+
| 239 | ++ |
+ #' @param correct (`flag`)\cr include the continuity correction. For further information, see for example+ |
+
| 240 | ++ |
+ #' [stats::prop.test()].+ |
+
| 241 | ++ |
+ #'+ |
+
| 242 | ++ |
+ #' @examples+ |
+
| 243 | ++ |
+ #' # Stratified Wilson confidence interval with unequal probabilities+ |
+
| 244 | ++ |
+ #'+ |
+
| 245 | ++ |
+ #' set.seed(1)+ |
+
| 246 | ++ |
+ #' rsp <- sample(c(TRUE, FALSE), 100, TRUE)+ |
+
| 247 | ++ |
+ #' strata_data <- data.frame(+ |
+
| 248 | ++ |
+ #' "f1" = sample(c("a", "b"), 100, TRUE),
+ |
+
| 249 | ++ |
+ #' "f2" = sample(c("x", "y", "z"), 100, TRUE),
+ |
+
| 250 | ++ |
+ #' stringsAsFactors = TRUE+ |
+
| 251 | ++ |
+ #' )+ |
+
| 252 | ++ |
+ #' strata <- interaction(strata_data)+ |
+
| 253 | ++ |
+ #' n_strata <- ncol(table(rsp, strata)) # Number of strata+ |
+
| 254 | ++ |
+ #'+ |
+
| 255 | ++ |
+ #' proportion_ci_strat_wilson(+ |
+
| 256 | ++ |
+ #' x = rsp, strata = strata,+ |
+
| 257 | ++ |
+ #' conf.level = 0.90+ |
+
| 258 | ++ |
+ #' )+ |
+
| 259 | ++ |
+ #'+ |
+
| 260 | ++ |
+ #' # Not automatic setting of weights+ |
+
| 261 | ++ |
+ #' proportion_ci_strat_wilson(+ |
+
| 262 | ++ |
+ #' x = rsp, strata = strata,+ |
+
| 263 | ++ |
+ #' weights = rep(1 / n_strata, n_strata),+ |
+
| 264 | ++ |
+ #' conf.level = 0.90+ |
+
| 265 | ++ |
+ #' )+ |
+
| 266 | ++ |
+ #'+ |
+
| 267 | ++ |
+ #' @export+ |
+
| 268 | ++ |
+ proportion_ci_strat_wilson <- function(x,+ |
+
| 269 | ++ |
+ strata,+ |
+
| 270 | ++ |
+ weights = NULL,+ |
+
| 271 | ++ |
+ conf.level = 0.95,+ |
+
| 272 | ++ |
+ max.iterations = 10L,+ |
+
| 273 | ++ |
+ correct = FALSE) {
+ |
+
| 274 | +2x | +
+ set_cli_abort_call()+ |
+
| 275 | ++ | + + | +
| 276 | ++ |
+ # check inputs ---------------------------------------------------------------+ |
+
| 277 | +2x | +
+ check_not_missing(x)+ |
+
| 278 | +2x | +
+ check_not_missing(strata)+ |
+
| 279 | +2x | +
+ check_binary(x)+ |
+
| 280 | +2x | +
+ check_class(correct, "logical")+ |
+
| 281 | +2x | +
+ check_scalar(correct)+ |
+
| 282 | +2x | +
+ check_class(strata, "factor")+ |
+
| 283 | +2x | +
+ check_range(conf.level, range = c(0, 1), include_bounds = c(FALSE, FALSE))+ |
+
| 284 | +2x | +
+ check_scalar(conf.level)+ |
+
| 285 | ++ | + + | +
| 286 | ++ |
+ # remove missing values from x and strata+ |
+
| 287 | +2x | +
+ is_na <- is.na(x) | is.na(strata)+ |
+
| 288 | +2x | +
+ x <- x[!is_na]+ |
+
| 289 | +2x | +
+ strata <- strata[!is_na]+ |
+
| 290 | +! | +
+ if (!inherits(x, "logical")) x <- as.logical(x)+ |
+
| 291 | ++ |
+ # check all TRUE/FALSE, if so, not calculable+ |
+
| 292 | +2x | +
+ if (all(x) || all(!x)) {
+ |
+
| 293 | +! | +
+ cli::cli_abort("All values in {.arg x} argument are either {.code TRUE} or {.code FALSE} and CI is not estimable.")
+ |
+
| 294 | ++ |
+ }+ |
+
| 295 | ++ | + + | +
| 296 | +2x | +
+ tbl <- table(factor(x, levels = c(FALSE, TRUE)), strata, useNA = "no")+ |
+
| 297 | +2x | +
+ n_strata <- length(unique(strata))+ |
+
| 298 | ++ | + + | +
| 299 | ++ |
+ # Checking the weights and maximum number of iterations.+ |
+
| 300 | +2x | +
+ do_iter <- FALSE+ |
+
| 301 | +2x | +
+ if (is.null(weights)) {
+ |
+
| 302 | +! | +
+ weights <- rep(1 / n_strata, n_strata) # Initialization for iterative procedure+ |
+
| 303 | +! | +
+ do_iter <- TRUE+ |
+
| 304 | ++ | + + | +
| 305 | ++ |
+ # Iteration parameters+ |
+
| 306 | +! | +
+ if (!is_scalar_integerish(max.iterations) || max.iterations < 1) {
+ |
+
| 307 | +! | +
+ cli::cli_abort("Argument {.arg max.iterations} must be a positive integer.")
+ |
+
| 308 | ++ |
+ }+ |
+
| 309 | ++ |
+ }+ |
+
| 310 | +2x | +
+ check_range(weights, range = c(0, 1), include_bounds = c(TRUE, TRUE))+ |
+
| 311 | +2x | +
+ sum_weights <- sum(weights) |>+ |
+
| 312 | +2x | +
+ round() |>+ |
+
| 313 | +2x | +
+ as.integer()+ |
+
| 314 | +2x | +
+ if (sum_weights != 1L || abs(sum_weights - sum(weights)) > sqrt(.Machine$double.eps)) {
+ |
+
| 315 | +! | +
+ cli::cli_abort("The sum of the {.arg weights} argument must be {.val {1L}}")
+ |
+
| 316 | ++ |
+ }+ |
+
| 317 | ++ | + + | +
| 318 | +2x | +
+ xs <- tbl["TRUE", ]+ |
+
| 319 | +2x | +
+ ns <- colSums(tbl)+ |
+
| 320 | +2x | +
+ use_stratum <- (ns > 0)+ |
+
| 321 | +2x | +
+ ns <- ns[use_stratum]+ |
+
| 322 | +2x | +
+ xs <- xs[use_stratum]+ |
+
| 323 | +2x | +
+ ests <- xs / ns+ |
+
| 324 | +2x | +
+ vars <- ests * (1 - ests) / ns+ |
+
| 325 | ++ | + + | +
| 326 | +2x | +
+ strata_qnorm <- .strata_normal_quantile(vars, weights, conf.level)+ |
+
| 327 | ++ | + + | +
| 328 | ++ |
+ # Iterative setting of weights if they were not passed in `weights` argument+ |
+
| 329 | +2x | +
+ weights_new <- if (do_iter) {
+ |
+
| 330 | +! | +
+ .update_weights_strat_wilson(vars, strata_qnorm, weights, ns, max.iterations, conf.level)$weights+ |
+
| 331 | ++ |
+ } else {
+ |
+
| 332 | +2x | +
+ weights+ |
+
| 333 | ++ |
+ }+ |
+
| 334 | ++ | + + | +
| 335 | +2x | +
+ strata_conf.level <- 2 * stats::pnorm(strata_qnorm) - 1+ |
+
| 336 | ++ | + + | +
| 337 | +2x | +
+ ci_by_strata <- Map(+ |
+
| 338 | +2x | +
+ function(x, n) {
+ |
+
| 339 | ++ |
+ # Classic Wilson's confidence interval+ |
+
| 340 | +12x | +
+ suppressWarnings(stats::prop.test(x, n, correct = correct, conf.level = strata_conf.level)$conf.int)+ |
+
| 341 | ++ |
+ },+ |
+
| 342 | +2x | +
+ x = xs,+ |
+
| 343 | +2x | +
+ n = ns+ |
+
| 344 | ++ |
+ )+ |
+
| 345 | +2x | +
+ lower_by_strata <- sapply(ci_by_strata, "[", 1L)+ |
+
| 346 | +2x | +
+ upper_by_strata <- sapply(ci_by_strata, "[", 2L)+ |
+
| 347 | ++ | + + | +
| 348 | +2x | +
+ lower <- sum(weights_new * lower_by_strata)+ |
+
| 349 | +2x | +
+ upper <- sum(weights_new * upper_by_strata)+ |
+
| 350 | ++ | + + | +
| 351 | ++ |
+ # Return values+ |
+
| 352 | +2x | +
+ list(+ |
+
| 353 | +2x | +
+ N = length(x),+ |
+
| 354 | +2x | +
+ estimate = mean(x),+ |
+
| 355 | +2x | +
+ conf.low = lower,+ |
+
| 356 | +2x | +
+ conf.high = upper,+ |
+
| 357 | +2x | +
+ conf.level = conf.level,+ |
+
| 358 | +2x | +
+ weights = if (do_iter) weights_new else NULL,+ |
+
| 359 | +2x | +
+ method =+ |
+
| 360 | +2x | +
+ glue::glue("Stratified Wilson Confidence Interval {ifelse(correct, 'with', 'without')} continuity correction")
+ |
+
| 361 | ++ |
+ ) |>+ |
+
| 362 | +2x | +
+ compact()+ |
+
| 363 | ++ |
+ }+ |
+
| 364 | ++ | + + | +
| 365 | ++ |
+ #' @describeIn proportion_ci Helper to determine if vector is binary (logical or 0/1)+ |
+
| 366 | ++ |
+ #'+ |
+
| 367 | ++ |
+ #' @export+ |
+
| 368 | ++ |
+ is_binary <- function(x) {
+ |
+
| 369 | +525x | +
+ is.logical(x) || (is_integerish(x) && is_empty(setdiff(x, c(0, 1, NA))))+ |
+
| 370 | ++ |
+ }+ |
+
| 371 | ++ | + + | +
| 372 | ++ |
+ #' Helper Function for the Estimation of Stratified Quantiles+ |
+
| 373 | ++ |
+ #'+ |
+
| 374 | ++ |
+ #' This function wraps the estimation of stratified percentiles when we assume+ |
+
| 375 | ++ |
+ #' the approximation for large numbers. This is necessary only in the case+ |
+
| 376 | ++ |
+ #' proportions for each strata are unequal.+ |
+
| 377 | ++ |
+ #'+ |
+
| 378 | ++ |
+ #' @inheritParams proportion_ci_strat_wilson+ |
+
| 379 | ++ |
+ #'+ |
+
| 380 | ++ |
+ #' @return Stratified quantile.+ |
+
| 381 | ++ |
+ #'+ |
+
| 382 | ++ |
+ #' @seealso [proportion_ci_strat_wilson()]+ |
+
| 383 | ++ |
+ #'+ |
+
| 384 | ++ |
+ #' @keywords internal+ |
+
| 385 | ++ |
+ #'+ |
+
| 386 | ++ |
+ #' @examples+ |
+
| 387 | ++ |
+ #' strata_data <- table(data.frame(+ |
+
| 388 | ++ |
+ #' "f1" = sample(c(TRUE, FALSE), 100, TRUE),+ |
+
| 389 | ++ |
+ #' "f2" = sample(c("x", "y", "z"), 100, TRUE),
+ |
+
| 390 | ++ |
+ #' stringsAsFactors = TRUE+ |
+
| 391 | ++ |
+ #' ))+ |
+
| 392 | ++ |
+ #' ns <- colSums(strata_data)+ |
+
| 393 | ++ |
+ #' ests <- strata_data["TRUE", ] / ns+ |
+
| 394 | ++ |
+ #' vars <- ests * (1 - ests) / ns+ |
+
| 395 | ++ |
+ #' weights <- rep(1 / length(ns), length(ns))+ |
+
| 396 | ++ |
+ #'+ |
+
| 397 | ++ |
+ #' cardx:::.strata_normal_quantile(vars, weights, 0.95)+ |
+
| 398 | ++ |
+ .strata_normal_quantile <- function(vars, weights, conf.level) {
+ |
+
| 399 | +2x | +
+ summands <- weights^2 * vars+ |
+
| 400 | ++ |
+ # Stratified quantile+ |
+
| 401 | +2x | +
+ sqrt(sum(summands)) / sum(sqrt(summands)) * stats::qnorm((1 + conf.level) / 2)+ |
+
| 402 | ++ |
+ }+ |
+
| 403 | ++ | + + | +
| 404 | ++ |
+ #' Helper Function for the Estimation of Weights for `proportion_ci_strat_wilson()`+ |
+
| 405 | ++ |
+ #'+ |
+
| 406 | ++ |
+ #' This function wraps the iteration procedure that allows you to estimate+ |
+
| 407 | ++ |
+ #' the weights for each proportional strata. This assumes to minimize the+ |
+
| 408 | ++ |
+ #' weighted squared length of the confidence interval.+ |
+
| 409 | ++ |
+ #'+ |
+
| 410 | ++ |
+ #' @keywords internal+ |
+
| 411 | ++ |
+ #' @inheritParams proportion_ci_strat_wilson+ |
+
| 412 | ++ |
+ #' @param vars (`numeric`)\cr normalized proportions for each strata.+ |
+
| 413 | ++ |
+ #' @param strata_qnorm (`numeric`)\cr initial estimation with identical weights of the quantiles.+ |
+
| 414 | ++ |
+ #' @param initial_weights (`numeric`)\cr initial weights used to calculate `strata_qnorm`. This can+ |
+
| 415 | ++ |
+ #' be optimized in the future if we need to estimate better initial weights.+ |
+
| 416 | ++ |
+ #' @param n_per_strata (`numeric`)\cr number of elements in each strata.+ |
+
| 417 | ++ |
+ #' @param max.iterations (`count`)\cr maximum number of iterations to be tried. Convergence is always checked.+ |
+
| 418 | ++ |
+ #' @param tol (`number`)\cr tolerance threshold for convergence.+ |
+
| 419 | ++ |
+ #'+ |
+
| 420 | ++ |
+ #' @return A `list` of 3 elements: `n_it`, `weights`, and `diff_v`.+ |
+
| 421 | ++ |
+ #'+ |
+
| 422 | ++ |
+ #' @seealso For references and details see [`proportion_ci_strat_wilson()`].+ |
+
| 423 | ++ |
+ #'+ |
+
| 424 | ++ |
+ #' @examples+ |
+
| 425 | ++ |
+ #' vs <- c(0.011, 0.013, 0.012, 0.014, 0.017, 0.018)+ |
+
| 426 | ++ |
+ #' sq <- 0.674+ |
+
| 427 | ++ |
+ #' ws <- rep(1 / length(vs), length(vs))+ |
+
| 428 | ++ |
+ #' ns <- c(22, 18, 17, 17, 14, 12)+ |
+
| 429 | ++ |
+ #'+ |
+
| 430 | ++ |
+ #' cardx:::.update_weights_strat_wilson(vs, sq, ws, ns, 100, 0.95, 0.001)+ |
+
| 431 | ++ |
+ .update_weights_strat_wilson <- function(vars,+ |
+
| 432 | ++ |
+ strata_qnorm,+ |
+
| 433 | ++ |
+ initial_weights,+ |
+
| 434 | ++ |
+ n_per_strata,+ |
+
| 435 | ++ |
+ max.iterations = 50,+ |
+
| 436 | ++ |
+ conf.level = 0.95,+ |
+
| 437 | ++ |
+ tol = 0.001) {
+ |
+
| 438 | +! | +
+ it <- 0+ |
+
| 439 | +! | +
+ diff_v <- NULL+ |
+
| 440 | ++ | + + | +
| 441 | +! | +
+ while (it < max.iterations) {
+ |
+
| 442 | +! | +
+ it <- it + 1+ |
+
| 443 | +! | +
+ weights_new_t <- (1 + strata_qnorm^2 / n_per_strata)^2+ |
+
| 444 | +! | +
+ weights_new_b <- (vars + strata_qnorm^2 / (4 * n_per_strata^2))+ |
+
| 445 | +! | +
+ weights_new <- weights_new_t / weights_new_b+ |
+
| 446 | +! | +
+ weights_new <- weights_new / sum(weights_new)+ |
+
| 447 | +! | +
+ strata_qnorm <- .strata_normal_quantile(vars, weights_new, conf.level)+ |
+
| 448 | +! | +
+ diff_v <- c(diff_v, sum(abs(weights_new - initial_weights)))+ |
+
| 449 | +! | +
+ if (diff_v[length(diff_v)] < tol) break+ |
+
| 450 | +! | +
+ initial_weights <- weights_new+ |
+
| 451 | ++ |
+ }+ |
+
| 452 | ++ | + + | +
| 453 | +! | +
+ if (it == max.iterations) {
+ |
+
| 454 | +! | +
+ warning("The heuristic to find weights did not converge with max.iterations = ", max.iterations)
+ |
+
| 455 | ++ |
+ }+ |
+
| 456 | ++ | + + | +
| 457 | +! | +
+ list(+ |
+
| 458 | +! | +
+ "n_it" = it,+ |
+
| 459 | +! | +
+ "weights" = weights_new,+ |
+
| 460 | +! | +
+ "diff_v" = diff_v+ |
+
| 461 | ++ |
+ )+ |
+
| 462 | ++ |
+ }+ |
+
| 1 | ++ |
+ #' ARD t-test+ |
+
| 2 | ++ |
+ #'+ |
+
| 3 | ++ |
+ #' @description+ |
+
| 4 | ++ |
+ #' Analysis results data for paired and non-paired t-tests.+ |
+
| 5 | ++ |
+ #'+ |
+
| 6 | ++ |
+ #' @param data (`data.frame`)\cr+ |
+
| 7 | ++ |
+ #' a data frame. See below for details.+ |
+
| 8 | ++ |
+ #' @param by ([`tidy-select`][dplyr::dplyr_tidy_select])\cr+ |
+
| 9 | ++ |
+ #' optional column name to compare by.+ |
+
| 10 | ++ |
+ #' @param variables ([`tidy-select`][dplyr::dplyr_tidy_select])\cr+ |
+
| 11 | ++ |
+ #' column names to be compared. Independent t-tests will be computed for+ |
+
| 12 | ++ |
+ #' each variable.+ |
+
| 13 | ++ |
+ #' @param id ([`tidy-select`][dplyr::dplyr_tidy_select])\cr+ |
+
| 14 | ++ |
+ #' column name of the subject or participant ID+ |
+
| 15 | ++ |
+ #' @param conf.level (scalar `numeric`)\cr+ |
+
| 16 | ++ |
+ #' confidence level for confidence interval. Default is `0.95`.+ |
+
| 17 | ++ |
+ #' @param ... arguments passed to `t.test()`+ |
+
| 18 | ++ |
+ #'+ |
+
| 19 | ++ |
+ #' @return ARD data frame+ |
+
| 20 | ++ |
+ #' @name ard_stats_t_test+ |
+
| 21 | ++ |
+ #'+ |
+
| 22 | ++ |
+ #' @details+ |
+
| 23 | ++ |
+ #' For the `ard_stats_t_test()` function, the data is expected to be one row per subject.+ |
+
| 24 | ++ |
+ #' The data is passed as `t.test(data[[variable]] ~ data[[by]], paired = FALSE, ...)`.+ |
+
| 25 | ++ |
+ #'+ |
+
| 26 | ++ |
+ #' For the `ard_stats_paired_t_test()` function, the data is expected to be one row+ |
+
| 27 | ++ |
+ #' per subject per by level. Before the t-test is calculated, the data are+ |
+
| 28 | ++ |
+ #' reshaped to a wide format to be one row per subject.+ |
+
| 29 | ++ |
+ #' The data are then passed as+ |
+
| 30 | ++ |
+ #' `t.test(x = data_wide[[<by level 1>]], y = data_wide[[<by level 2>]], paired = TRUE, ...)`.+ |
+
| 31 | ++ |
+ #'+ |
+
| 32 | ++ |
+ #' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = "broom", reference_pkg = "cardx"))
+ |
+
| 33 | ++ |
+ #' cards::ADSL |>+ |
+
| 34 | ++ |
+ #' dplyr::filter(ARM %in% c("Placebo", "Xanomeline High Dose")) |>
+ |
+
| 35 | ++ |
+ #' ard_stats_t_test(by = ARM, variables = c(AGE, BMIBL))+ |
+
| 36 | ++ |
+ #'+ |
+
| 37 | ++ |
+ #' # constructing a paired data set,+ |
+
| 38 | ++ |
+ #' # where patients receive both treatments+ |
+
| 39 | ++ |
+ #' cards::ADSL[c("ARM", "AGE")] |>
+ |
+
| 40 | ++ |
+ #' dplyr::filter(ARM %in% c("Placebo", "Xanomeline High Dose")) |>
+ |
+
| 41 | ++ |
+ #' dplyr::mutate(.by = ARM, USUBJID = dplyr::row_number()) |>+ |
+
| 42 | ++ |
+ #' dplyr::arrange(USUBJID, ARM) |>+ |
+
| 43 | ++ |
+ #' ard_stats_paired_t_test(by = ARM, variables = AGE, id = USUBJID)+ |
+
| 44 | ++ |
+ NULL+ |
+
| 45 | ++ | + + | +
| 46 | ++ |
+ #' @rdname ard_stats_t_test+ |
+
| 47 | ++ |
+ #' @export+ |
+
| 48 | ++ |
+ ard_stats_t_test <- function(data, variables, by = NULL, conf.level = 0.95, ...) {
+ |
+
| 49 | +6x | +
+ set_cli_abort_call()+ |
+
| 50 | ++ | + + | +
| 51 | ++ |
+ # check installed packages ---------------------------------------------------+ |
+
| 52 | +6x | +
+ check_pkg_installed("broom", reference_pkg = "cardx")
+ |
+
| 53 | ++ | + + | +
| 54 | ++ |
+ # check/process inputs -------------------------------------------------------+ |
+
| 55 | +6x | +
+ check_not_missing(data)+ |
+
| 56 | +6x | +
+ check_not_missing(variables)+ |
+
| 57 | +6x | +
+ check_data_frame(data)+ |
+
| 58 | +6x | +
+ data <- dplyr::ungroup(data)+ |
+
| 59 | +6x | +
+ cards::process_selectors(data, by = {{ by }}, variables = {{ variables }})
+ |
+
| 60 | +6x | +
+ check_scalar(by, allow_empty = TRUE)+ |
+
| 61 | +6x | +
+ check_range(conf.level, range = c(0, 1))+ |
+
| 62 | ++ | + + | +
| 63 | ++ |
+ # return empty ARD if no variables selected ----------------------------------+ |
+
| 64 | +6x | +
+ if (is_empty(variables)) {
+ |
+
| 65 | +! | +
+ return(dplyr::tibble() |> cards::as_card())+ |
+
| 66 | ++ |
+ }+ |
+
| 67 | ++ | + + | +
| 68 | ++ |
+ # build ARD ------------------------------------------------------------------+ |
+
| 69 | +6x | +
+ lapply(+ |
+
| 70 | +6x | +
+ variables,+ |
+
| 71 | +6x | +
+ function(variable) {
+ |
+
| 72 | +7x | +
+ .format_ttest_results(+ |
+
| 73 | +7x | +
+ by = by,+ |
+
| 74 | +7x | +
+ variable = variable,+ |
+
| 75 | +7x | +
+ lst_tidy =+ |
+
| 76 | ++ |
+ # styler: off+ |
+
| 77 | +7x | +
+ cards::eval_capture_conditions(+ |
+
| 78 | +7x | +
+ if (!is_empty(by)) stats::t.test(data[[variable]] ~ data[[by]], conf.level = conf.level, ...) |> broom::tidy()+ |
+
| 79 | +7x | +
+ else stats::t.test(data[[variable]], ...) |> broom::tidy()+ |
+
| 80 | ++ |
+ ),+ |
+
| 81 | ++ |
+ # styler: on+ |
+
| 82 | +7x | +
+ paired = FALSE,+ |
+
| 83 | ++ |
+ ...+ |
+
| 84 | ++ |
+ )+ |
+
| 85 | ++ |
+ }+ |
+
| 86 | ++ |
+ ) |>+ |
+
| 87 | +6x | +
+ dplyr::bind_rows()+ |
+
| 88 | ++ |
+ }+ |
+
| 89 | ++ | + + | +
| 90 | ++ |
+ #' @rdname ard_stats_t_test+ |
+
| 91 | ++ |
+ #' @export+ |
+
| 92 | ++ |
+ ard_stats_paired_t_test <- function(data, by, variables, id, conf.level = 0.95, ...) {
+ |
+
| 93 | +2x | +
+ set_cli_abort_call()+ |
+
| 94 | ++ | + + | +
| 95 | ++ |
+ # check installed packages ---------------------------------------------------+ |
+
| 96 | +2x | +
+ check_pkg_installed("broom", reference_pkg = "cardx")
+ |
+
| 97 | ++ | + + | +
| 98 | ++ |
+ # check/process inputs -------------------------------------------------------+ |
+
| 99 | +2x | +
+ check_not_missing(data)+ |
+
| 100 | +2x | +
+ check_not_missing(variables)+ |
+
| 101 | +2x | +
+ check_not_missing(by)+ |
+
| 102 | +2x | +
+ check_not_missing(id)+ |
+
| 103 | +2x | +
+ check_data_frame(data)+ |
+
| 104 | +2x | +
+ data <- dplyr::ungroup(data)+ |
+
| 105 | +2x | +
+ cards::process_selectors(data, by = {{ by }}, variables = {{ variables }}, id = {{ id }})
+ |
+
| 106 | +2x | +
+ check_scalar(by)+ |
+
| 107 | +2x | +
+ check_scalar(id)+ |
+
| 108 | ++ | + + | +
| 109 | ++ |
+ # return empty ARD if no variables selected ----------------------------------+ |
+
| 110 | +2x | +
+ if (is_empty(variables)) {
+ |
+
| 111 | +! | +
+ return(dplyr::tibble() |> cards::as_card())+ |
+
| 112 | ++ |
+ }+ |
+
| 113 | ++ | + + | +
| 114 | ++ |
+ # build ARD ------------------------------------------------------------------+ |
+
| 115 | +2x | +
+ lapply(+ |
+
| 116 | +2x | +
+ variables,+ |
+
| 117 | +2x | +
+ function(variable) {
+ |
+
| 118 | +2x | +
+ .format_ttest_results(+ |
+
| 119 | +2x | +
+ by = by,+ |
+
| 120 | +2x | +
+ variable = variable,+ |
+
| 121 | +2x | +
+ lst_tidy =+ |
+
| 122 | +2x | +
+ cards::eval_capture_conditions({
+ |
+
| 123 | ++ |
+ # adding this reshape inside the eval, so if there is an error it's captured in the ARD object+ |
+
| 124 | +2x | +
+ data_wide <- .paired_data_pivot_wider(data, by = by, variable = variable, id = id)+ |
+
| 125 | ++ |
+ # perform paired t-test+ |
+
| 126 | +1x | +
+ stats::t.test(x = data_wide[["by1"]], y = data_wide[["by2"]], paired = TRUE, conf.level = conf.level, ...) |>+ |
+
| 127 | +1x | +
+ broom::tidy()+ |
+
| 128 | ++ |
+ }),+ |
+
| 129 | +2x | +
+ paired = TRUE,+ |
+
| 130 | ++ |
+ ...+ |
+
| 131 | ++ |
+ )+ |
+
| 132 | ++ |
+ }+ |
+
| 133 | ++ |
+ ) |>+ |
+
| 134 | +2x | +
+ dplyr::bind_rows()+ |
+
| 135 | ++ |
+ }+ |
+
| 136 | ++ | + + | +
| 137 | ++ |
+ #' Convert t-test to ARD+ |
+
| 138 | ++ |
+ #'+ |
+
| 139 | ++ |
+ #' @inheritParams cards::tidy_as_ard+ |
+
| 140 | ++ |
+ #' @inheritParams stats::t.test+ |
+
| 141 | ++ |
+ #' @param by (`string`)\cr by column name+ |
+
| 142 | ++ |
+ #' @param variable (`string`)\cr variable column name+ |
+
| 143 | ++ |
+ #' @param ... passed to `t.test(...)`+ |
+
| 144 | ++ |
+ #'+ |
+
| 145 | ++ |
+ #' @return ARD data frame+ |
+
| 146 | ++ |
+ #' @keywords internal+ |
+
| 147 | ++ |
+ #' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = "broom", reference_pkg = "cardx"))
+ |
+
| 148 | ++ |
+ #' cardx:::.format_ttest_results(+ |
+
| 149 | ++ |
+ #' by = "ARM",+ |
+
| 150 | ++ |
+ #' variable = "AGE",+ |
+
| 151 | ++ |
+ #' paired = FALSE,+ |
+
| 152 | ++ |
+ #' lst_tidy =+ |
+
| 153 | ++ |
+ #' cards::eval_capture_conditions(+ |
+
| 154 | ++ |
+ #' stats::t.test(ADSL[["AGE"]] ~ ADSL[["ARM"]], paired = FALSE) |>+ |
+
| 155 | ++ |
+ #' broom::tidy()+ |
+
| 156 | ++ |
+ #' )+ |
+
| 157 | ++ |
+ #' )+ |
+
| 158 | ++ |
+ .format_ttest_results <- function(by = NULL, variable, lst_tidy, paired, ...) {
+ |
+
| 159 | ++ |
+ # build ARD ------------------------------------------------------------------+ |
+
| 160 | +9x | +
+ ret <-+ |
+
| 161 | +9x | +
+ cards::tidy_as_ard(+ |
+
| 162 | +9x | +
+ lst_tidy = lst_tidy,+ |
+
| 163 | +9x | +
+ tidy_result_names =+ |
+
| 164 | +9x | +
+ c(+ |
+
| 165 | +9x | +
+ "estimate", "statistic",+ |
+
| 166 | +9x | +
+ "p.value", "parameter", "conf.low", "conf.high",+ |
+
| 167 | +9x | +
+ "method", "alternative"+ |
+
| 168 | ++ |
+ ) |>+ |
+
| 169 | ++ |
+ # add estimate1 and estimate2 if there is a by variable+ |
+
| 170 | +9x | +
+ append(values = switch(!is_empty(by), c("estimate1", "estimate2")), after = 1L), # styler: off
+ |
+
| 171 | +9x | +
+ fun_args_to_record = c("mu", "paired", "var.equal", "conf.level"),
+ |
+
| 172 | +9x | +
+ formals = formals(asNamespace("stats")[["t.test.default"]]),
+ |
+
| 173 | +9x | +
+ passed_args = c(list(paired = paired), dots_list(...)),+ |
+
| 174 | +9x | +
+ lst_ard_columns = list(variable = variable, context = "stats_t_test")+ |
+
| 175 | ++ |
+ )+ |
+
| 176 | ++ | + + | +
| 177 | +9x | +
+ if (!is_empty(by)) {
+ |
+
| 178 | +8x | +
+ ret <- ret |>+ |
+
| 179 | +8x | +
+ dplyr::mutate(group1 = by)+ |
+
| 180 | ++ |
+ }+ |
+
| 181 | ++ | + + | +
| 182 | ++ |
+ # add the stat label ---------------------------------------------------------+ |
+
| 183 | +9x | +
+ ret |>+ |
+
| 184 | +9x | +
+ dplyr::left_join(+ |
+
| 185 | +9x | +
+ .df_ttest_stat_labels(by = by),+ |
+
| 186 | +9x | +
+ by = "stat_name"+ |
+
| 187 | ++ |
+ ) |>+ |
+
| 188 | +9x | +
+ dplyr::mutate(stat_label = dplyr::coalesce(.data$stat_label, .data$stat_name)) |>+ |
+
| 189 | +9x | +
+ cards::as_card() |>+ |
+
| 190 | +9x | +
+ cards::tidy_ard_column_order()+ |
+
| 191 | ++ |
+ }+ |
+
| 192 | ++ | + + | +
| 193 | ++ | + + | +
| 194 | ++ |
+ #' Convert long paired data to wide+ |
+
| 195 | ++ |
+ #'+ |
+
| 196 | ++ |
+ #'+ |
+
| 197 | ++ |
+ #' @param data (`data.frame`)\cr a data frame that is one line per subject per group+ |
+
| 198 | ++ |
+ #' @param by (`string`)\cr by column name+ |
+
| 199 | ++ |
+ #' @param variable (`string`)\cr variable column name+ |
+
| 200 | ++ |
+ #' @param id (`string`)\cr subject id column name+ |
+
| 201 | ++ |
+ #'+ |
+
| 202 | ++ |
+ #' @return a wide data frame+ |
+
| 203 | ++ |
+ #' @keywords internal+ |
+
| 204 | ++ |
+ #' @examples+ |
+
| 205 | ++ |
+ #' cards::ADSL[c("ARM", "AGE")] |>
+ |
+
| 206 | ++ |
+ #' dplyr::filter(ARM %in% c("Placebo", "Xanomeline High Dose")) |>
+ |
+
| 207 | ++ |
+ #' dplyr::mutate(.by = ARM, USUBJID = dplyr::row_number()) |>+ |
+
| 208 | ++ |
+ #' dplyr::arrange(USUBJID, ARM) |>+ |
+
| 209 | ++ |
+ #' cardx:::.paired_data_pivot_wider(by = "ARM", variable = "AGE", id = "USUBJID")+ |
+
| 210 | ++ |
+ .paired_data_pivot_wider <- function(data, by, variable, id) {
+ |
+
| 211 | ++ |
+ # check the number of levels before pivoting data to wider format+ |
+
| 212 | +11x | +
+ if (dplyr::n_distinct(data[[by]], na.rm = TRUE) != 2L) {
+ |
+
| 213 | +4x | +
+ cli::cli_abort("The {.arg by} argument must have two and only two levels.",
+ |
+
| 214 | +4x | +
+ call = get_cli_abort_call()+ |
+
| 215 | ++ |
+ )+ |
+
| 216 | ++ |
+ }+ |
+
| 217 | ++ | + + | +
| 218 | +7x | +
+ data |>+ |
+
| 219 | ++ |
+ # arrange data so the first group always appears first+ |
+
| 220 | +7x | +
+ dplyr::arrange(.data[[by]]) |>+ |
+
| 221 | +7x | +
+ tidyr::pivot_wider(+ |
+
| 222 | +7x | +
+ id_cols = all_of(id),+ |
+
| 223 | +7x | +
+ names_from = all_of(by),+ |
+
| 224 | +7x | +
+ values_from = all_of(variable)+ |
+
| 225 | ++ |
+ ) |>+ |
+
| 226 | +7x | +
+ stats::setNames(c(id, "by1", "by2"))+ |
+
| 227 | ++ |
+ }+ |
+
| 228 | ++ | + + | +
| 229 | ++ |
+ .df_ttest_stat_labels <- function(by = NULL) {
+ |
+
| 230 | +28x | +
+ dplyr::tribble(+ |
+
| 231 | +28x | +
+ ~stat_name, ~stat_label,+ |
+
| 232 | +28x | +
+ "estimate1", "Group 1 Mean",+ |
+
| 233 | +28x | +
+ "estimate2", "Group 2 Mean",+ |
+
| 234 | +28x | +
+ "estimate", ifelse(is_empty(by), "Mean", "Mean Difference"),+ |
+
| 235 | +28x | +
+ "p.value", "p-value",+ |
+
| 236 | +28x | +
+ "statistic", "t Statistic",+ |
+
| 237 | +28x | +
+ "parameter", "Degrees of Freedom",+ |
+
| 238 | +28x | +
+ "conf.low", "CI Lower Bound",+ |
+
| 239 | +28x | +
+ "conf.high", "CI Upper Bound",+ |
+
| 240 | +28x | +
+ "mu", "H0 Mean",+ |
+
| 241 | +28x | +
+ "paired", "Paired t-test",+ |
+
| 242 | +28x | +
+ "var.equal", "Equal Variances",+ |
+
| 243 | +28x | +
+ "conf.level", "CI Confidence Level",+ |
+
| 244 | ++ |
+ )+ |
+
| 245 | ++ |
+ }+ |
+
| 1 | ++ |
+ #' ARD for Difference in Survival+ |
+
| 2 | ++ |
+ #'+ |
+
| 3 | ++ |
+ #' @description+ |
+
| 4 | ++ |
+ #' Analysis results data for comparison of survival using [survival::survdiff()].+ |
+
| 5 | ++ |
+ #'+ |
+
| 6 | ++ |
+ #' @param formula (`formula`)\cr+ |
+
| 7 | ++ |
+ #' a formula+ |
+
| 8 | ++ |
+ #' @param data (`data.frame`)\cr+ |
+
| 9 | ++ |
+ #' a data frame+ |
+
| 10 | ++ |
+ #' @param rho (`scalar numeric`)\cr+ |
+
| 11 | ++ |
+ #' numeric scalar passed to `survival::survdiff(rho)`. Default is `rho=0`.+ |
+
| 12 | ++ |
+ #' @param ... additional arguments passed to `survival::survdiff()`+ |
+
| 13 | ++ |
+ #'+ |
+
| 14 | ++ |
+ #' @return an ARD data frame of class 'card'+ |
+
| 15 | ++ |
+ #' @export+ |
+
| 16 | ++ |
+ #'+ |
+
| 17 | ++ |
+ #' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = c("survival", "broom", "ggsurvfit"), reference_pkg = "cardx"))
+ |
+
| 18 | ++ |
+ #' library(survival)+ |
+
| 19 | ++ |
+ #' library(ggsurvfit)+ |
+
| 20 | ++ |
+ #'+ |
+
| 21 | ++ |
+ #' ard_survival_survdiff(Surv_CNSR(AVAL, CNSR) ~ TRTA, data = cards::ADTTE)+ |
+
| 22 | ++ |
+ ard_survival_survdiff <- function(formula, data, rho = 0, ...) {
+ |
+
| 23 | +5x | +
+ set_cli_abort_call()+ |
+
| 24 | ++ | + + | +
| 25 | ++ |
+ # check installed packages ---------------------------------------------------+ |
+
| 26 | +5x | +
+ check_pkg_installed(c("survival", "broom"), reference_pkg = "cardx")
+ |
+
| 27 | ++ | + + | +
| 28 | ++ |
+ # check/process inputs -------------------------------------------------------+ |
+
| 29 | +5x | +
+ check_not_missing(formula)+ |
+
| 30 | +5x | +
+ check_class(formula, cls = "formula")+ |
+
| 31 | +5x | +
+ if (!missing(data)) check_class(data, cls = "data.frame")+ |
+
| 32 | +5x | +
+ check_scalar(rho)+ |
+
| 33 | +5x | +
+ check_class(rho, cls = "numeric")+ |
+
| 34 | ++ | + + | +
| 35 | ++ |
+ # assign method+ |
+
| 36 | +5x | +
+ method <- dplyr::case_when(+ |
+
| 37 | +5x | +
+ rho == 0 ~ "Log-rank test",+ |
+
| 38 | +5x | +
+ rho == 1.5 ~ "Tarone-Ware test",+ |
+
| 39 | +5x | +
+ rho == 1 ~ "Peto & Peto modification of Gehan-Wilcoxon test",+ |
+
| 40 | +5x | +
+ .default = glue::glue("G-rho test (\U03C1 = {rho})")
+ |
+
| 41 | ++ |
+ ) |>+ |
+
| 42 | +5x | +
+ as.character()+ |
+
| 43 | ++ | + + | +
| 44 | ++ |
+ # calculate survdiff() results -----------------------------------------------+ |
+
| 45 | +5x | +
+ lst_glance <-+ |
+
| 46 | +5x | +
+ cards::eval_capture_conditions(+ |
+
| 47 | +5x | +
+ survival::survdiff(formula = formula, data = data, rho = rho, ...) |>+ |
+
| 48 | +5x | +
+ broom::glance() |>+ |
+
| 49 | +5x | +
+ dplyr::mutate(method = .env$method)+ |
+
| 50 | ++ |
+ )+ |
+
| 51 | ++ | + + | +
| 52 | ++ |
+ # tidy results up in an ARD format -------------------------------------------+ |
+
| 53 | ++ |
+ # extract variable names from formula+ |
+
| 54 | +5x | +
+ variables <- stats::terms(formula) |>+ |
+
| 55 | +5x | +
+ attr("term.labels") |>
+ |
+
| 56 | +5x | +
+ .strip_backticks()+ |
+
| 57 | ++ | + + | +
| 58 | ++ |
+ # if there was an error, return results early+ |
+
| 59 | +5x | +
+ if (is.null(lst_glance[["result"]])) {
+ |
+
| 60 | ++ |
+ # if no variables in formula, then return an error+ |
+
| 61 | ++ |
+ # otherwise, if we do have variable names, then we can construct an empty ARD which will be done below+ |
+
| 62 | +2x | +
+ if (is_empty(variables)) {
+ |
+
| 63 | +1x | +
+ cli::cli_abort(+ |
+
| 64 | +1x | +
+ message =+ |
+
| 65 | +1x | +
+ c("There was an error in {.fun survival::survdiff}. See below:",
+ |
+
| 66 | +1x | +
+ "x" = lst_glance[["error"]]+ |
+
| 67 | ++ |
+ ),+ |
+
| 68 | +1x | +
+ call = get_cli_abort_call()+ |
+
| 69 | ++ |
+ )+ |
+
| 70 | ++ |
+ }+ |
+
| 71 | ++ |
+ }+ |
+
| 72 | ++ | + + | +
| 73 | +4x | +
+ .variables_to_survdiff_ard(+ |
+
| 74 | +4x | +
+ variables = variables,+ |
+
| 75 | +4x | +
+ method = method,+ |
+
| 76 | ++ |
+ # styler: off+ |
+
| 77 | +4x | +
+ stat_names =+ |
+
| 78 | +4x | +
+ if (!is.null(lst_glance[["result"]])) names(lst_glance[["result"]])+ |
+
| 79 | +4x | +
+ else c("statistic", "df", "p.value", "method"),
+ |
+
| 80 | +4x | +
+ stats =+ |
+
| 81 | +4x | +
+ if (!is.null(lst_glance[["result"]])) unname(as.list(lst_glance[["result"]]))+ |
+
| 82 | +4x | +
+ else rep_along(c("statistic", "df", "p.value"), list(NULL)) |> c(list(method = method))
+ |
+
| 83 | ++ |
+ # styler: on+ |
+
| 84 | ++ |
+ ) |>+ |
+
| 85 | +4x | +
+ .add_survdiff_stat_labels() |>+ |
+
| 86 | +4x | +
+ dplyr::mutate(+ |
+
| 87 | +4x | +
+ context = "survival_survdiff",+ |
+
| 88 | +4x | +
+ warning = lst_glance["warning"],+ |
+
| 89 | +4x | +
+ error = lst_glance["error"],+ |
+
| 90 | +4x | +
+ fmt_fn = map(+ |
+
| 91 | +4x | +
+ .data$stat,+ |
+
| 92 | +4x | +
+ function(x) {
+ |
+
| 93 | +9x | +
+ if (is.numeric(x)) return(1L) # styler: off+ |
+
| 94 | +7x | +
+ NULL+ |
+
| 95 | ++ |
+ }+ |
+
| 96 | ++ |
+ )+ |
+
| 97 | ++ |
+ ) |>+ |
+
| 98 | +4x | +
+ cards::as_card() |>+ |
+
| 99 | +4x | +
+ cards::tidy_ard_column_order()+ |
+
| 100 | ++ |
+ }+ |
+
| 101 | ++ | + + | +
| 102 | ++ |
+ .variables_to_survdiff_ard <- function(variables,+ |
+
| 103 | ++ |
+ method,+ |
+
| 104 | ++ |
+ stat_names,+ |
+
| 105 | ++ |
+ stats) {
+ |
+
| 106 | +4x | +
+ len <- length(variables)+ |
+
| 107 | ++ | + + | +
| 108 | +4x | +
+ df_vars <- dplyr::tibble(!!!rev(variables)) |>+ |
+
| 109 | +4x | +
+ set_names(+ |
+
| 110 | +4x | +
+ ifelse(+ |
+
| 111 | +4x | +
+ len > 1L,+ |
+
| 112 | +4x | +
+ c(paste0("group_", rev(seq_len(len - 1L))), "variable"),
+ |
+
| 113 | +4x | +
+ "variable"+ |
+
| 114 | ++ |
+ )+ |
+
| 115 | ++ |
+ )+ |
+
| 116 | ++ | + + | +
| 117 | +4x | +
+ dplyr::bind_cols(+ |
+
| 118 | +4x | +
+ df_vars,+ |
+
| 119 | +4x | +
+ dplyr::tibble(+ |
+
| 120 | +4x | +
+ stat_name = .env$stat_names,+ |
+
| 121 | +4x | +
+ stat = .env$stats+ |
+
| 122 | ++ |
+ )+ |
+
| 123 | ++ |
+ )+ |
+
| 124 | ++ |
+ }+ |
+
| 125 | ++ | + + | +
| 126 | ++ |
+ .add_survdiff_stat_labels <- function(x) {
+ |
+
| 127 | +4x | +
+ x |>+ |
+
| 128 | +4x | +
+ dplyr::left_join(+ |
+
| 129 | +4x | +
+ dplyr::tribble(+ |
+
| 130 | +4x | +
+ ~stat_name, ~stat_label,+ |
+
| 131 | +4x | +
+ "statistic", "X^2 Statistic",+ |
+
| 132 | +4x | +
+ "df", "Degrees of Freedom",+ |
+
| 133 | +4x | +
+ "p.value", "p-value"+ |
+
| 134 | ++ |
+ ),+ |
+
| 135 | +4x | +
+ by = "stat_name"+ |
+
| 136 | ++ |
+ ) |>+ |
+
| 137 | +4x | +
+ dplyr::mutate(stat_label = dplyr::coalesce(.data$stat_label, .data$stat_name))+ |
+
| 138 | ++ |
+ }+ |
+
| 139 | ++ | + + | +
| 140 | ++ |
+ .strip_backticks <- function(x) {
+ |
+
| 141 | +5x | +
+ ifelse(+ |
+
| 142 | +5x | +
+ str_detect(x, "^`.*`$"),+ |
+
| 143 | +5x | +
+ substr(x, 2, nchar(x) - 1),+ |
+
| 144 | +5x | +
+ x+ |
+
| 145 | ++ |
+ )+ |
+
| 146 | ++ |
+ }+ |
+
| 1 | ++ |
+ #' ARD Categorical Survey Statistics+ |
+
| 2 | ++ |
+ #'+ |
+
| 3 | ++ |
+ #' @description+ |
+
| 4 | ++ |
+ #' Compute tabulations on survey-weighted data.+ |
+
| 5 | ++ |
+ #'+ |
+
| 6 | ++ |
+ #' The counts and proportion (`"N"`, `"n"`, `"p"`) are calculated using `survey::svytable()`,+ |
+
| 7 | ++ |
+ #' and the standard errors and design effect (`"p.std.error"`, `"deff"`) are+ |
+
| 8 | ++ |
+ #' calculated using `survey::svymean()`.+ |
+
| 9 | ++ |
+ #'+ |
+
| 10 | ++ |
+ #' The unweighted statistics are calculated with `cards::ard_categorical.data.frame()`.+ |
+
| 11 | ++ |
+ #'+ |
+
| 12 | ++ |
+ #' @param data (`survey.design`)\cr+ |
+
| 13 | ++ |
+ #' a design object often created with [`survey::svydesign()`].+ |
+
| 14 | ++ |
+ #' @param variables ([`tidy-select`][dplyr::dplyr_tidy_select])\cr+ |
+
| 15 | ++ |
+ #' columns to include in summaries.+ |
+
| 16 | ++ |
+ #' @param by ([`tidy-select`][dplyr::dplyr_tidy_select])\cr+ |
+
| 17 | ++ |
+ #' results are calculated for **all combinations** of the column specified+ |
+
| 18 | ++ |
+ #' and the variables. A single column may be specified.+ |
+
| 19 | ++ |
+ #' @param denominator (`string`)\cr+ |
+
| 20 | ++ |
+ #' a string indicating the type proportions to calculate. Must be one of+ |
+
| 21 | ++ |
+ #' `"column"` (the default), `"row"`, and `"cell"`.+ |
+
| 22 | ++ |
+ #' @param statistic ([`formula-list-selector`][cards::syntax])\cr+ |
+
| 23 | ++ |
+ #' a named list, a list of formulas,+ |
+
| 24 | ++ |
+ #' or a single formula where the list element is a character vector of+ |
+
| 25 | ++ |
+ #' statistic names to include. See default value for options.+ |
+
| 26 | ++ |
+ #' @param fmt_fn ([`formula-list-selector`][cards::syntax])\cr+ |
+
| 27 | ++ |
+ #' a named list, a list of formulas,+ |
+
| 28 | ++ |
+ #' or a single formula where the list element is a named list of functions+ |
+
| 29 | ++ |
+ #' (or the RHS of a formula),+ |
+
| 30 | ++ |
+ #' e.g. `list(mpg = list(mean = \(x) round(x, digits = 2) |> as.character))`.+ |
+
| 31 | ++ |
+ #' @param stat_label ([`formula-list-selector`][cards::syntax])\cr+ |
+
| 32 | ++ |
+ #' a named list, a list of formulas, or a single formula where+ |
+
| 33 | ++ |
+ #' the list element is either a named list or a list of formulas defining the+ |
+
| 34 | ++ |
+ #' statistic labels, e.g. `everything() ~ list(mean = "Mean", sd = "SD")` or+ |
+
| 35 | ++ |
+ #' `everything() ~ list(mean ~ "Mean", sd ~ "SD")`.+ |
+
| 36 | ++ |
+ #' @inheritParams rlang::args_dots_empty+ |
+
| 37 | ++ |
+ #'+ |
+
| 38 | ++ |
+ #' @return an ARD data frame of class 'card'+ |
+
| 39 | ++ |
+ #' @export+ |
+
| 40 | ++ |
+ #'+ |
+
| 41 | ++ |
+ #' @examplesIf cardx:::is_pkg_installed("survey", reference_pkg = "cardx")
+ |
+
| 42 | ++ |
+ #' svy_titanic <- survey::svydesign(~1, data = as.data.frame(Titanic), weights = ~Freq)+ |
+
| 43 | ++ |
+ #'+ |
+
| 44 | ++ |
+ #' ard_categorical(svy_titanic, variables = c(Class, Age), by = Survived)+ |
+
| 45 | ++ |
+ ard_categorical.survey.design <- function(data,+ |
+
| 46 | ++ |
+ variables,+ |
+
| 47 | ++ |
+ by = NULL,+ |
+
| 48 | ++ |
+ statistic = everything() ~ c("n", "N", "p", "p.std.error", "deff", "n_unweighted", "N_unweighted", "p_unweighted"),
+ |
+
| 49 | ++ |
+ denominator = c("column", "row", "cell"),
+ |
+
| 50 | ++ |
+ fmt_fn = NULL,+ |
+
| 51 | ++ |
+ stat_label = everything() ~ list(+ |
+
| 52 | ++ |
+ p = "%",+ |
+
| 53 | ++ |
+ p.std.error = "SE(%)",+ |
+
| 54 | ++ |
+ deff = "Design Effect",+ |
+
| 55 | ++ |
+ "n_unweighted" = "Unweighted n",+ |
+
| 56 | ++ |
+ "N_unweighted" = "Unweighted N",+ |
+
| 57 | ++ |
+ "p_unweighted" = "Unweighted %"+ |
+
| 58 | ++ |
+ ),+ |
+
| 59 | ++ |
+ ...) {
+ |
+
| 60 | +78x | +
+ set_cli_abort_call()+ |
+
| 61 | +78x | +
+ check_pkg_installed(pkg = "survey", reference_pkg = "cardx")+ |
+
| 62 | +78x | +
+ check_dots_empty()+ |
+
| 63 | +78x | +
+ deff <- TRUE # we may update in the future to make this an argument for users+ |
+
| 64 | ++ | + + | +
| 65 | ++ |
+ # process arguments ----------------------------------------------------------+ |
+
| 66 | +78x | +
+ check_not_missing(variables)+ |
+
| 67 | +78x | +
+ cards::process_selectors(+ |
+
| 68 | +78x | +
+ data = data$variables,+ |
+
| 69 | +78x | +
+ variables = {{ variables }},
+ |
+
| 70 | +78x | +
+ by = {{ by }}
+ |
+
| 71 | ++ |
+ )+ |
+
| 72 | +78x | +
+ variables <- setdiff(variables, by)+ |
+
| 73 | +78x | +
+ check_scalar(by, allow_empty = TRUE)+ |
+
| 74 | ++ | + + | +
| 75 | ++ |
+ # return empty ARD if no variables selected ----------------------------------+ |
+
| 76 | +78x | +
+ if (is_empty(variables)) {
+ |
+
| 77 | +! | +
+ return(dplyr::tibble() |> cards::as_card())+ |
+
| 78 | ++ |
+ }+ |
+
| 79 | ++ | + + | +
| 80 | +78x | +
+ check_na_factor_levels(data$variables, c(by, variables))+ |
+
| 81 | ++ | + + | +
| 82 | +78x | +
+ cards::process_formula_selectors(+ |
+
| 83 | +78x | +
+ data = data$variables[variables],+ |
+
| 84 | +78x | +
+ statistic = statistic,+ |
+
| 85 | +78x | +
+ fmt_fn = fmt_fn,+ |
+
| 86 | +78x | +
+ stat_label = stat_label+ |
+
| 87 | ++ |
+ )+ |
+
| 88 | +78x | +
+ cards::fill_formula_selectors(+ |
+
| 89 | +78x | +
+ data = data$variables[variables],+ |
+
| 90 | +78x | +
+ statistic = formals(asNamespace("cardx")[["ard_categorical.survey.design"]])[["statistic"]] |> eval(),
+ |
+
| 91 | ++ |
+ )+ |
+
| 92 | +78x | +
+ accepted_svy_stats <- c("n", "N", "p", "p.std.error", "deff", "n_unweighted", "N_unweighted", "p_unweighted")
+ |
+
| 93 | +78x | +
+ cards::check_list_elements(+ |
+
| 94 | +78x | +
+ x = statistic,+ |
+
| 95 | +78x | +
+ predicate = \(x) all(x %in% accepted_svy_stats),+ |
+
| 96 | +78x | +
+ error_msg = c("Error in the values of the {.arg statistic} argument.",
+ |
+
| 97 | +78x | +
+ i = "Values must be in {.val {accepted_svy_stats}}"
+ |
+
| 98 | ++ |
+ )+ |
+
| 99 | ++ |
+ )+ |
+
| 100 | +78x | +
+ denominator <- arg_match(denominator)+ |
+
| 101 | ++ | + + | +
| 102 | ++ |
+ # check the missingness+ |
+
| 103 | +78x | +
+ walk(+ |
+
| 104 | +78x | +
+ variables,+ |
+
| 105 | +78x | +
+ \(.x) {
+ |
+
| 106 | +144x | +
+ if (all(is.na(data$variables[[.x]])) && !inherits(.x, c("logical", "factor"))) {
+ |
+
| 107 | +1x | +
+ cli::cli_abort(+ |
+
| 108 | +1x | +
+ c("Column {.val {.x}} is all missing and cannot be tabulated.",
+ |
+
| 109 | +1x | +
+ i = "Only columns of class {.cls logical} and {.cls factor} can be tabulated when all values are missing."
+ |
+
| 110 | ++ |
+ ),+ |
+
| 111 | +1x | +
+ call = get_cli_abort_call()+ |
+
| 112 | ++ |
+ )+ |
+
| 113 | ++ |
+ }+ |
+
| 114 | ++ |
+ }+ |
+
| 115 | ++ |
+ )+ |
+
| 116 | ++ | + + | +
| 117 | ++ |
+ # return note about column names that result in errors -----------------------+ |
+
| 118 | +77x | +
+ if (any(by %in% c("variable", "variable_level", "group1_level", "p", "n"))) {
+ |
+
| 119 | +1x | +
+ cli::cli_abort(+ |
+
| 120 | +1x | +
+ "The {.arg by} argument cannot include variables named {.val {c('variable', 'variable_level', 'group1_level', 'p', 'n')}}.",
+ |
+
| 121 | +1x | +
+ call = get_cli_abort_call()+ |
+
| 122 | ++ |
+ )+ |
+
| 123 | ++ |
+ }+ |
+
| 124 | ++ | + + | +
| 125 | +76x | +
+ if (any(variables %in% c("by", "name", "n", "p", "p.std.error"))) {
+ |
+
| 126 | +! | +
+ cli::cli_abort(+ |
+
| 127 | +! | +
+ "The {.arg variables} argument cannot include variables named {.val {c('by', 'name', 'n', 'p', 'p.std.error')}}.",
+ |
+
| 128 | +! | +
+ call = get_cli_abort_call()+ |
+
| 129 | ++ |
+ )+ |
+
| 130 | ++ |
+ }+ |
+
| 131 | ++ | + + | +
| 132 | ++ | + + | +
| 133 | ++ | + + | +
| 134 | ++ |
+ # calculate counts -----------------------------------------------------------+ |
+
| 135 | ++ |
+ # this tabulation accounts for unobserved combinations+ |
+
| 136 | +76x | +
+ svytable_counts <- .svytable_counts(data, variables, by, denominator)+ |
+
| 137 | ++ | + + | +
| 138 | ++ |
+ # calculate rate SE and DEFF -------------------------------------------------+ |
+
| 139 | +76x | +
+ svytable_rates <- .svytable_rate_stats(data, variables, by, denominator, deff)+ |
+
| 140 | ++ | + + | +
| 141 | ++ |
+ # convert results into a proper ARD object -----------------------------------+ |
+
| 142 | +76x | +
+ cards <-+ |
+
| 143 | +76x | +
+ svytable_counts |>+ |
+
| 144 | ++ |
+ # merge in the SE(p) and DEFF+ |
+
| 145 | +76x | +
+ dplyr::left_join(+ |
+
| 146 | +76x | +
+ svytable_rates |> dplyr::select(-"p"),+ |
+
| 147 | +76x | +
+ by = intersect(c("group1", "group1_level", "variable", "variable_level"), names(svytable_counts))
+ |
+
| 148 | ++ |
+ ) |>+ |
+
| 149 | ++ |
+ # make columns list columns+ |
+
| 150 | +76x | +
+ dplyr::mutate(across(-any_of(c("group1", "variable")), as.list)) |>
+ |
+
| 151 | +76x | +
+ tidyr::pivot_longer(+ |
+
| 152 | +76x | +
+ cols = -c(cards::all_ard_groups(), cards::all_ard_variables()),+ |
+
| 153 | +76x | +
+ names_to = "stat_name",+ |
+
| 154 | +76x | +
+ values_to = "stat"+ |
+
| 155 | ++ |
+ ) |>+ |
+
| 156 | ++ |
+ # keep statistics requested by user+ |
+
| 157 | +76x | +
+ dplyr::inner_join(+ |
+
| 158 | +76x | +
+ statistic |> enframe("variable", "stat_name") |> tidyr::unnest(cols = "stat_name"),
+ |
+
| 159 | +76x | +
+ by = c("variable", "stat_name")
+ |
+
| 160 | ++ |
+ )+ |
+
| 161 | ++ | + + | +
| 162 | ++ |
+ # add unweighted statistics --------------------------------------------------+ |
+
| 163 | +76x | +
+ statistic_unweighted <- statistic |>+ |
+
| 164 | +76x | +
+ lapply(\(x) keep(x, ~ endsWith(.x, "_unweighted")) |> str_remove("_unweighted$")) |>
+ |
+
| 165 | +76x | +
+ compact()+ |
+
| 166 | ++ | + + | +
| 167 | +76x | +
+ if (!is_empty(statistic_unweighted)) {
+ |
+
| 168 | +76x | +
+ cards_unweighted <-+ |
+
| 169 | +76x | +
+ ard_categorical(+ |
+
| 170 | +76x | +
+ data = data[["variables"]],+ |
+
| 171 | +76x | +
+ variables = all_of(names(statistic_unweighted)),+ |
+
| 172 | +76x | +
+ by = any_of(by),+ |
+
| 173 | +76x | +
+ statistic = statistic_unweighted,+ |
+
| 174 | +76x | +
+ denominator = denominator+ |
+
| 175 | ++ |
+ ) |>+ |
+
| 176 | ++ |
+ # all the survey levels are reported as character, so we do the same here.+ |
+
| 177 | +76x | +
+ dplyr::mutate(+ |
+
| 178 | +76x | +
+ across(+ |
+
| 179 | +76x | +
+ c(cards::all_ard_groups("levels"), cards::all_ard_variables("levels")),
+ |
+
| 180 | +76x | +
+ ~ map(.x, as.character)+ |
+
| 181 | ++ |
+ )+ |
+
| 182 | ++ |
+ ) |>+ |
+
| 183 | +76x | +
+ dplyr::select(-c("stat_label", "fmt_fn", "warning", "error")) |>
+ |
+
| 184 | +76x | +
+ dplyr::mutate(+ |
+
| 185 | +76x | +
+ stat_name =+ |
+
| 186 | +76x | +
+ dplyr::case_match(.data$stat_name, "n" ~ "n_unweighted", "N" ~ "N_unweighted", "p" ~ "p_unweighted")+ |
+
| 187 | ++ |
+ )+ |
+
| 188 | +76x | +
+ cards <- cards |> dplyr::bind_rows(cards_unweighted) # styler: off+ |
+
| 189 | ++ |
+ }+ |
+
| 190 | ++ | + + | +
| 191 | ++ |
+ # final processing of fmt_fn -------------------------------------------------+ |
+
| 192 | +76x | +
+ cards <- cards |>+ |
+
| 193 | +76x | +
+ .process_nested_list_as_df(+ |
+
| 194 | +76x | +
+ arg = fmt_fn,+ |
+
| 195 | +76x | +
+ new_column = "fmt_fn"+ |
+
| 196 | ++ |
+ ) |>+ |
+
| 197 | +76x | +
+ .default_svy_cat_fmt_fn()+ |
+
| 198 | ++ | + + | +
| 199 | ++ |
+ # merge in statistic labels --------------------------------------------------+ |
+
| 200 | +76x | +
+ cards <- cards |>+ |
+
| 201 | +76x | +
+ .process_nested_list_as_df(+ |
+
| 202 | +76x | +
+ arg = stat_label,+ |
+
| 203 | +76x | +
+ new_column = "stat_label",+ |
+
| 204 | +76x | +
+ unlist = TRUE+ |
+
| 205 | ++ |
+ ) |>+ |
+
| 206 | +76x | +
+ dplyr::mutate(stat_label = dplyr::coalesce(.data$stat_label, .data$stat_name))+ |
+
| 207 | ++ | + + | +
| 208 | ++ |
+ # return final object --------------------------------------------------------+ |
+
| 209 | +76x | +
+ cards |>+ |
+
| 210 | +76x | +
+ dplyr::mutate(+ |
+
| 211 | +76x | +
+ context = "categorical",+ |
+
| 212 | +76x | +
+ warning = list(NULL),+ |
+
| 213 | +76x | +
+ error = list(NULL),+ |
+
| 214 | ++ |
+ ) |>+ |
+
| 215 | +76x | +
+ cards::as_card() |>+ |
+
| 216 | +76x | +
+ cards::tidy_ard_column_order() |>+ |
+
| 217 | +76x | +
+ cards::tidy_ard_row_order()+ |
+
| 218 | ++ |
+ }+ |
+
| 219 | ++ | + + | +
| 220 | ++ |
+ # check for functions with NA factor levels (these are not allowed)+ |
+
| 221 | ++ |
+ check_na_factor_levels <- function(data, variables) {
+ |
+
| 222 | +127x | +
+ walk(+ |
+
| 223 | +127x | +
+ variables,+ |
+
| 224 | +127x | +
+ \(variable) {
+ |
+
| 225 | +246x | +
+ if (is.factor(data[[variable]]) && any(is.na(levels(data[[variable]])))) {
+ |
+
| 226 | +! | +
+ cli::cli_abort(+ |
+
| 227 | +! | +
+ "Column {.val {variable}} is a factor with {.val {NA}} levels, which are not allowed.",
+ |
+
| 228 | +! | +
+ call = get_cli_abort_call()+ |
+
| 229 | ++ |
+ )+ |
+
| 230 | ++ |
+ }+ |
+
| 231 | ++ |
+ }+ |
+
| 232 | ++ |
+ )+ |
+
| 233 | ++ |
+ }+ |
+
| 234 | ++ | + + | +
| 235 | ++ |
+ # this function returns a tibble with the SE(p) and DEFF+ |
+
| 236 | ++ |
+ .svytable_rate_stats <- function(data, variables, by, denominator, deff) {
+ |
+
| 237 | +54x | +
+ if (!is_empty(by)) by_lvls <- .unique_values_sort(data$variables, by) # styler: off+ |
+
| 238 | +76x | +
+ if (!is_empty(by) && length(by_lvls) == 1L) {
+ |
+
| 239 | +6x | +
+ data$variables[[by]] <-+ |
+
| 240 | +6x | +
+ case_switch(+ |
+
| 241 | +6x | +
+ inherits(data$variables[[by]], "factor") ~ fct_expand(data$variables[[by]], paste("not", by_lvls)),
+ |
+
| 242 | +6x | +
+ .default = factor(data$variables[[by]], levels = c(by_lvls, paste("not", by_lvls)))
+ |
+
| 243 | ++ |
+ )+ |
+
| 244 | ++ |
+ }+ |
+
| 245 | +76x | +
+ if (!is_empty(by) && inherits(data$variables[[by]], "logical")) {
+ |
+
| 246 | +9x | +
+ data$variables[[by]] <- factor(data$variables[[by]], levels = c(TRUE, FALSE))+ |
+
| 247 | ++ |
+ }+ |
+
| 248 | +76x | +
+ if (!is_empty(by) && !inherits(data$variables[[by]], "factor")) {
+ |
+
| 249 | +3x | +
+ data$variables[[by]] <- factor(data$variables[[by]])+ |
+
| 250 | ++ |
+ }+ |
+
| 251 | ++ | + + | +
| 252 | +76x | +
+ lapply(+ |
+
| 253 | +76x | +
+ variables,+ |
+
| 254 | +76x | +
+ \(variable) {
+ |
+
| 255 | ++ |
+ # convert the variable to a factor if not already one or a lgl, so we get the correct rate stats from svymean+ |
+
| 256 | +142x | +
+ if (!inherits(data$variables[[variable]], c("factor", "logical"))) {
+ |
+
| 257 | +6x | +
+ data$variables[[variable]] <- factor(data$variables[[variable]])+ |
+
| 258 | ++ |
+ }+ |
+
| 259 | ++ | + + | +
| 260 | ++ |
+ # there are issues with svymean() when a variable has only one level. adding a second as needed+ |
+
| 261 | +142x | +
+ variable_lvls <- .unique_values_sort(data$variables, variable)+ |
+
| 262 | +142x | +
+ if (length(variable_lvls) == 1L) {
+ |
+
| 263 | +6x | +
+ data$variables[[variable]] <-+ |
+
| 264 | +6x | +
+ case_switch(+ |
+
| 265 | +6x | +
+ inherits(data$variables[[variable]], "factor") ~ fct_expand(data$variables[[variable]], paste("not", variable_lvls)),
+ |
+
| 266 | +6x | +
+ .default = factor(data$variables[[variable]], levels = c(variable_lvls, paste("not", variable_lvls)))
+ |
+
| 267 | ++ |
+ )+ |
+
| 268 | ++ |
+ }+ |
+
| 269 | +142x | +
+ if (inherits(data$variables[[variable]], "logical")) {
+ |
+
| 270 | +22x | +
+ data$variables[[variable]] <- factor(data$variables[[variable]], levels = c(TRUE, FALSE))+ |
+
| 271 | ++ |
+ }+ |
+
| 272 | +142x | +
+ if (!inherits(data$variables[[variable]], "factor")) {
+ |
+
| 273 | +! | +
+ data$variables[[variable]] <- factor(data$variables[[variable]])+ |
+
| 274 | ++ |
+ }+ |
+
| 275 | ++ | + + | +
| 276 | ++ |
+ # each combination of denominator and whether there is a by variable is handled separately+ |
+
| 277 | +142x | +
+ result <-+ |
+
| 278 | +142x | +
+ case_switch(+ |
+
| 279 | ++ |
+ # by variable and column percentages+ |
+
| 280 | +142x | +
+ !is_empty(by) && denominator == "column" ~+ |
+
| 281 | +142x | +
+ .one_svytable_rates_by_column(data, variable, by, deff),+ |
+
| 282 | ++ |
+ # by variable and row percentages+ |
+
| 283 | +142x | +
+ !is_empty(by) && denominator == "row" ~+ |
+
| 284 | +142x | +
+ .one_svytable_rates_by_row(data, variable, by, deff),+ |
+
| 285 | ++ |
+ # by variable and cell percentages+ |
+
| 286 | +142x | +
+ !is_empty(by) && denominator == "cell" ~+ |
+
| 287 | +142x | +
+ .one_svytable_rates_by_cell(data, variable, by, deff),+ |
+
| 288 | ++ |
+ # no by variable and column/cell percentages+ |
+
| 289 | +142x | +
+ denominator %in% c("column", "cell") ~
+ |
+
| 290 | +142x | +
+ .one_svytable_rates_no_by_column_and_cell(data, variable, deff),+ |
+
| 291 | ++ |
+ # no by variable and row percentages+ |
+
| 292 | +142x | +
+ denominator == "row" ~+ |
+
| 293 | +142x | +
+ .one_svytable_rates_no_by_row(data, variable, deff)+ |
+
| 294 | ++ |
+ )+ |
+
| 295 | ++ | + + | +
| 296 | ++ |
+ # if a level was added, remove the fake level+ |
+
| 297 | +142x | +
+ if (length(variable_lvls) == 1L) {
+ |
+
| 298 | +6x | +
+ result <- result |> dplyr::filter(.data$variable_level %in% variable_lvls)+ |
+
| 299 | ++ |
+ }+ |
+
| 300 | +142x | +
+ if (!is_empty(by) && length(by_lvls) == 1L) {
+ |
+
| 301 | +12x | +
+ result <- result |> dplyr::filter(.data$group1_level %in% by_lvls)+ |
+
| 302 | ++ |
+ }+ |
+
| 303 | ++ | + + | +
| 304 | +142x | +
+ result+ |
+
| 305 | ++ |
+ }+ |
+
| 306 | ++ |
+ ) |>+ |
+
| 307 | +76x | +
+ dplyr::bind_rows()+ |
+
| 308 | ++ |
+ }+ |
+
| 309 | ++ | + + | +
| 310 | ++ |
+ .one_svytable_rates_no_by_row <- function(data, variable, deff) {
+ |
+
| 311 | +10x | +
+ dplyr::tibble(+ |
+
| 312 | +10x | +
+ variable = .env$variable,+ |
+
| 313 | +10x | +
+ variable_level = unique(data$variables[[variable]]) |> sort() |> as.character(),+ |
+
| 314 | +10x | +
+ p = 1,+ |
+
| 315 | +10x | +
+ p.std.error = 0,+ |
+
| 316 | +10x | +
+ deff = NaN+ |
+
| 317 | ++ |
+ )+ |
+
| 318 | ++ |
+ }+ |
+
| 319 | ++ | + + | +
| 320 | ++ |
+ .one_svytable_rates_no_by_column_and_cell <- function(data, variable, deff) {
+ |
+
| 321 | +29x | +
+ survey::svymean(reformulate2(variable), design = data, na.rm = TRUE, deff = deff) |>+ |
+
| 322 | +29x | +
+ dplyr::as_tibble(rownames = "var_level") |>+ |
+
| 323 | +29x | +
+ dplyr::mutate(+ |
+
| 324 | +29x | +
+ variable_level = str_remove(.data$var_level, pattern = paste0("^", .env$variable)),
+ |
+
| 325 | +29x | +
+ variable = .env$variable+ |
+
| 326 | ++ |
+ ) |>+ |
+
| 327 | +29x | +
+ dplyr::select("variable", "variable_level", p = "mean", p.std.error = "SE", any_of("deff"))
+ |
+
| 328 | ++ |
+ }+ |
+
| 329 | ++ | + + | +
| 330 | ++ |
+ .one_svytable_rates_by_cell <- function(data, variable, by, deff) {
+ |
+
| 331 | +20x | +
+ df_interaction_id <-+ |
+
| 332 | +20x | +
+ .df_all_combos(data, variable, by) |>+ |
+
| 333 | +20x | +
+ dplyr::mutate(+ |
+
| 334 | +20x | +
+ var_level =+ |
+
| 335 | +20x | +
+ glue::glue("interaction({.env$by}, {.env$variable}){.data$group1_level}.{.data$variable_level}")
+ |
+
| 336 | ++ |
+ )+ |
+
| 337 | ++ | + + | +
| 338 | +20x | +
+ survey::svymean(+ |
+
| 339 | +20x | +
+ x = inject(~ interaction(!!sym(bt(by)), !!sym(bt(variable)))),+ |
+
| 340 | +20x | +
+ design = data,+ |
+
| 341 | +20x | +
+ na.rm = TRUE,+ |
+
| 342 | +20x | +
+ deff = deff+ |
+
| 343 | ++ |
+ ) |>+ |
+
| 344 | +20x | +
+ dplyr::as_tibble(rownames = "var_level") |>+ |
+
| 345 | +20x | +
+ dplyr::left_join(df_interaction_id, by = "var_level") |>+ |
+
| 346 | +20x | +
+ dplyr::select(+ |
+
| 347 | +20x | +
+ cards::all_ard_groups(), cards::all_ard_variables(),+ |
+
| 348 | +20x | +
+ p = "mean", p.std.error = "SE", any_of("deff")
+ |
+
| 349 | ++ |
+ )+ |
+
| 350 | ++ |
+ }+ |
+
| 351 | ++ | + + | +
| 352 | ++ |
+ .one_svytable_rates_by_row <- function(data, variable, by, deff) {
+ |
+
| 353 | +60x | +
+ survey::svyby(+ |
+
| 354 | +60x | +
+ formula = reformulate2(by),+ |
+
| 355 | +60x | +
+ by = reformulate2(variable),+ |
+
| 356 | +60x | +
+ design = data,+ |
+
| 357 | +60x | +
+ FUN = survey::svymean,+ |
+
| 358 | +60x | +
+ na.rm = TRUE,+ |
+
| 359 | +60x | +
+ deff = deff+ |
+
| 360 | ++ |
+ ) |>+ |
+
| 361 | +60x | +
+ dplyr::as_tibble() |>+ |
+
| 362 | +60x | +
+ tidyr::pivot_longer(-all_of(variable)) |>+ |
+
| 363 | +60x | +
+ dplyr::mutate(+ |
+
| 364 | +60x | +
+ stat =+ |
+
| 365 | +60x | +
+ dplyr::case_when(+ |
+
| 366 | +60x | +
+ startsWith(.data$name, paste0("se.", by)) | startsWith(.data$name, paste0("se.`", by, "`")) ~ "p.std.error",
+ |
+
| 367 | +60x | +
+ startsWith(.data$name, paste0("DEff.", by)) | startsWith(.data$name, paste0("DEff.`", by, "`")) ~ "deff",
+ |
+
| 368 | +60x | +
+ TRUE ~ "p"+ |
+
| 369 | ++ |
+ ),+ |
+
| 370 | +60x | +
+ name =+ |
+
| 371 | +60x | +
+ str_remove_all(.data$name, "se\\.") %>%+ |
+
| 372 | +60x | +
+ str_remove_all("DEff\\.") %>%
+ |
+
| 373 | +60x | +
+ str_remove_all(by) %>%+ |
+
| 374 | +60x | +
+ str_remove_all("`")
+ |
+
| 375 | ++ |
+ ) |>+ |
+
| 376 | +60x | +
+ tidyr::pivot_wider(names_from = "stat", values_from = "value") |>+ |
+
| 377 | +60x | +
+ set_names(c("variable_level", "group1_level", "p", "p.std.error", "deff")) |>
+ |
+
| 378 | +60x | +
+ dplyr::mutate(+ |
+
| 379 | +60x | +
+ group1 = .env$by,+ |
+
| 380 | +60x | +
+ variable = .env$variable,+ |
+
| 381 | +60x | +
+ across(c("group1_level", "variable_level"), as.character)
+ |
+
| 382 | ++ |
+ )+ |
+
| 383 | ++ |
+ }+ |
+
| 384 | ++ | + + | +
| 385 | ++ |
+ .one_svytable_rates_by_column <- function(data, variable, by, deff) {
+ |
+
| 386 | +23x | +
+ survey::svyby(+ |
+
| 387 | +23x | +
+ formula = reformulate2(variable),+ |
+
| 388 | +23x | +
+ by = reformulate2(by),+ |
+
| 389 | +23x | +
+ design = data,+ |
+
| 390 | +23x | +
+ FUN = survey::svymean,+ |
+
| 391 | +23x | +
+ na.rm = TRUE,+ |
+
| 392 | +23x | +
+ deff = deff+ |
+
| 393 | ++ |
+ ) |>+ |
+
| 394 | +23x | +
+ dplyr::as_tibble() |>+ |
+
| 395 | +23x | +
+ tidyr::pivot_longer(-all_of(by)) |>+ |
+
| 396 | +23x | +
+ dplyr::mutate(+ |
+
| 397 | +23x | +
+ stat =+ |
+
| 398 | +23x | +
+ dplyr::case_when(+ |
+
| 399 | +23x | +
+ startsWith(.data$name, paste0("se.", variable)) | startsWith(.data$name, paste0("se.`", variable, "`")) ~ "p.std.error",
+ |
+
| 400 | +23x | +
+ startsWith(.data$name, paste0("DEff.", variable)) | startsWith(.data$name, paste0("DEff.`", variable, "`")) ~ "deff",
+ |
+
| 401 | +23x | +
+ TRUE ~ "p"+ |
+
| 402 | ++ |
+ ),+ |
+
| 403 | +23x | +
+ name =+ |
+
| 404 | +23x | +
+ str_remove_all(.data$name, "se\\.") %>%+ |
+
| 405 | +23x | +
+ str_remove_all("DEff\\.") %>%
+ |
+
| 406 | +23x | +
+ str_remove_all(variable) %>%+ |
+
| 407 | +23x | +
+ str_remove_all("`")
+ |
+
| 408 | ++ |
+ ) |>+ |
+
| 409 | +23x | +
+ tidyr::pivot_wider(names_from = "stat", values_from = "value") |>+ |
+
| 410 | +23x | +
+ set_names(c("group1_level", "variable_level", "p", "p.std.error", "deff")) |>
+ |
+
| 411 | +23x | +
+ dplyr::mutate(+ |
+
| 412 | +23x | +
+ group1 = .env$by,+ |
+
| 413 | +23x | +
+ variable = .env$variable,+ |
+
| 414 | +23x | +
+ across(c("group1_level", "variable_level"), as.character)
+ |
+
| 415 | ++ |
+ )+ |
+
| 416 | ++ |
+ }+ |
+
| 417 | ++ | + + | +
| 418 | ++ |
+ .svytable_counts <- function(data, variables, by, denominator) {
+ |
+
| 419 | +76x | +
+ df_counts <-+ |
+
| 420 | +76x | +
+ lapply(+ |
+
| 421 | +76x | +
+ variables,+ |
+
| 422 | +76x | +
+ \(variable) {
+ |
+
| 423 | ++ |
+ # perform weighted tabulation+ |
+
| 424 | +142x | +
+ df_count <-+ |
+
| 425 | +142x | +
+ survey::svytable(formula = reformulate2(c(by, variable)), design = data) |>+ |
+
| 426 | +142x | +
+ dplyr::as_tibble()+ |
+
| 427 | +142x | +
+ if (is_empty(by)) {
+ |
+
| 428 | +39x | +
+ names(df_count) <- c("variable_level", "n")
+ |
+
| 429 | +39x | +
+ df_count$variable <- variable+ |
+
| 430 | ++ |
+ } else {
+ |
+
| 431 | +103x | +
+ names(df_count) <- c("group1_level", "variable_level", "n")
+ |
+
| 432 | +103x | +
+ df_count$variable <- variable+ |
+
| 433 | +103x | +
+ df_count$group1 <- by+ |
+
| 434 | ++ |
+ }+ |
+
| 435 | ++ | + + | +
| 436 | ++ |
+ # adding unobserved levels+ |
+
| 437 | +142x | +
+ .df_all_combos(data, variable, by) %>%+ |
+
| 438 | +142x | +
+ dplyr::left_join(+ |
+
| 439 | +142x | +
+ df_count,+ |
+
| 440 | +142x | +
+ by = names(.)+ |
+
| 441 | ++ |
+ ) |>+ |
+
| 442 | +142x | +
+ tidyr::replace_na(list(n = 0)) # unobserved levels assigned zero count+ |
+
| 443 | ++ |
+ }+ |
+
| 444 | ++ |
+ ) |>+ |
+
| 445 | +76x | +
+ dplyr::bind_rows()+ |
+
| 446 | ++ | + + | +
| 447 | ++ |
+ # add big N and p, then return data frame of results+ |
+
| 448 | +76x | +
+ switch(denominator,+ |
+
| 449 | ++ |
+ "column" =+ |
+
| 450 | +24x | +
+ df_counts |>+ |
+
| 451 | +24x | +
+ dplyr::mutate(+ |
+
| 452 | +24x | +
+ .by = c(cards::all_ard_groups(), cards::all_ard_variables("names")),
+ |
+
| 453 | +24x | +
+ N = sum(.data$n),+ |
+
| 454 | +24x | +
+ p = .data$n / .data$N+ |
+
| 455 | ++ |
+ ),+ |
+
| 456 | ++ |
+ "row" =+ |
+
| 457 | +37x | +
+ df_counts |>+ |
+
| 458 | +37x | +
+ dplyr::mutate(+ |
+
| 459 | +37x | +
+ .by = cards::all_ard_variables(),+ |
+
| 460 | +37x | +
+ N = sum(.data$n),+ |
+
| 461 | +37x | +
+ p = .data$n / .data$N+ |
+
| 462 | ++ |
+ ),+ |
+
| 463 | ++ |
+ "cell" =+ |
+
| 464 | +15x | +
+ df_counts |>+ |
+
| 465 | +15x | +
+ dplyr::mutate(+ |
+
| 466 | +15x | +
+ .by = c(cards::all_ard_groups("names"), cards::all_ard_variables("names")),
+ |
+
| 467 | +15x | +
+ N = sum(.data$n),+ |
+
| 468 | +15x | +
+ p = .data$n / .data$N+ |
+
| 469 | ++ |
+ )+ |
+
| 470 | ++ |
+ )+ |
+
| 471 | ++ |
+ }+ |
+
| 472 | ++ | + + | +
| 473 | ++ |
+ .df_all_combos <- function(data, variable, by) {
+ |
+
| 474 | +162x | +
+ df <-+ |
+
| 475 | +162x | +
+ tidyr::expand_grid(+ |
+
| 476 | +162x | +
+ group1_level = switch(!is_empty(by),+ |
+
| 477 | +162x | +
+ .unique_and_sorted(data$variables[[by]])+ |
+
| 478 | ++ |
+ ),+ |
+
| 479 | +162x | +
+ variable_level = .unique_and_sorted(data$variables[[variable]])+ |
+
| 480 | ++ |
+ ) |>+ |
+
| 481 | +162x | +
+ dplyr::mutate(variable = .env$variable)+ |
+
| 482 | +123x | +
+ if (!is_empty(by)) df$group1 <- by+ |
+
| 483 | +162x | +
+ df <- dplyr::relocate(df, any_of(c("group1", "group1_level", "variable", "variable_level")))
+ |
+
| 484 | ++ | + + | +
| 485 | ++ |
+ # convert levels to character for merging later+ |
+
| 486 | +162x | +
+ df |>+ |
+
| 487 | +162x | +
+ dplyr::mutate(+ |
+
| 488 | +162x | +
+ across(+ |
+
| 489 | +162x | +
+ c(cards::all_ard_groups("levels"), cards::all_ard_variables("levels")),
+ |
+
| 490 | +162x | +
+ as.character+ |
+
| 491 | ++ |
+ )+ |
+
| 492 | ++ |
+ )+ |
+
| 493 | ++ |
+ }+ |
+
| 494 | ++ | + + | +
| 495 | ++ |
+ case_switch <- function(..., .default = NULL) {
+ |
+
| 496 | ++ |
+ dots <- dots_list(...)+ |
+
| 497 | ++ | + + | +
| 498 | ++ |
+ for (f in dots) {
+ |
+
| 499 | ++ |
+ if (isTRUE(eval(f_lhs(f), envir = attr(f, ".Environment")))) {
+ |
+
| 500 | ++ |
+ return(eval(f_rhs(f), envir = attr(f, ".Environment")))+ |
+
| 501 | ++ |
+ }+ |
+
| 502 | ++ |
+ }+ |
+
| 503 | ++ | + + | +
| 504 | ++ |
+ return(.default)+ |
+
| 505 | ++ |
+ }+ |
+
| 506 | ++ | + + | +
| 507 | ++ |
+ .default_svy_cat_fmt_fn <- function(x) {
+ |
+
| 508 | +81x | +
+ x |>+ |
+
| 509 | +81x | +
+ dplyr::mutate(+ |
+
| 510 | +81x | +
+ fmt_fn =+ |
+
| 511 | +81x | +
+ pmap(+ |
+
| 512 | +81x | +
+ list(.data$stat_name, .data$stat, .data$fmt_fn),+ |
+
| 513 | +81x | +
+ function(stat_name, stat, fmt_fn) {
+ |
+
| 514 | +5478x | +
+ if (!is_empty(fmt_fn)) {
+ |
+
| 515 | +! | +
+ return(fmt_fn)+ |
+
| 516 | ++ |
+ }+ |
+
| 517 | +5478x | +
+ if (stat_name %in% c("p", "p_miss", "p_nonmiss", "p_unweighted")) {
+ |
+
| 518 | +1372x | +
+ return(cards::label_cards(digits = 1, scale = 100))+ |
+
| 519 | ++ |
+ }+ |
+
| 520 | +4106x | +
+ if (stat_name %in% c("n", "N", "N_miss", "N_nonmiss", "N_obs", "n_unweighted", "N_unweighted")) {
+ |
+
| 521 | +2745x | +
+ return(cards::label_cards(digits = 0))+ |
+
| 522 | ++ |
+ }+ |
+
| 523 | +1361x | +
+ if (is.integer(stat)) {
+ |
+
| 524 | +33x | +
+ return(0L)+ |
+
| 525 | ++ |
+ }+ |
+
| 526 | +1328x | +
+ if (is.numeric(stat)) {
+ |
+
| 527 | +1328x | +
+ return(1L)+ |
+
| 528 | ++ |
+ }+ |
+
| 529 | +! | +
+ return(as.character)+ |
+
| 530 | ++ |
+ }+ |
+
| 531 | ++ |
+ )+ |
+
| 532 | ++ |
+ )+ |
+
| 533 | ++ |
+ }+ |
+
| 534 | ++ | + + | +
| 535 | ++ |
+ #' Convert Nested Lists to Column+ |
+
| 536 | ++ |
+ #'+ |
+
| 537 | ++ |
+ #' Some arguments, such as `stat_label`, are passed as nested lists. This+ |
+
| 538 | ++ |
+ #' function properly unnests these lists and adds them to the results data frame.+ |
+
| 539 | ++ |
+ #'+ |
+
| 540 | ++ |
+ #' @param x (`data.frame`)\cr+ |
+
| 541 | ++ |
+ #' result data frame+ |
+
| 542 | ++ |
+ #' @param arg (`list`)\cr+ |
+
| 543 | ++ |
+ #' the nested list+ |
+
| 544 | ++ |
+ #' @param new_column (`string`)\cr+ |
+
| 545 | ++ |
+ #' new column name+ |
+
| 546 | ++ |
+ #' @param unlist (`logical`)\cr+ |
+
| 547 | ++ |
+ #' whether to fully unlist final results+ |
+
| 548 | ++ |
+ #'+ |
+
| 549 | ++ |
+ #' @return a data frame+ |
+
| 550 | ++ |
+ #' @keywords internal+ |
+
| 551 | ++ |
+ #'+ |
+
| 552 | ++ |
+ #' @examples+ |
+
| 553 | ++ |
+ #' ard <- ard_categorical(cards::ADSL, by = "ARM", variables = "AGEGR1")+ |
+
| 554 | ++ |
+ #'+ |
+
| 555 | ++ |
+ #' cardx:::.process_nested_list_as_df(ard, NULL, "new_col")+ |
+
| 556 | ++ |
+ .process_nested_list_as_df <- function(x, arg, new_column, unlist = FALSE) {
+ |
+
| 557 | ++ |
+ # add fmt_fn column if not already present+ |
+
| 558 | +162x | +
+ if (!new_column %in% names(x)) {
+ |
+
| 559 | +162x | +
+ x[[new_column]] <- list(NULL)+ |
+
| 560 | ++ |
+ }+ |
+
| 561 | ++ | + + | +
| 562 | ++ |
+ # process argument if not NULL, and update new column+ |
+
| 563 | +162x | +
+ if (!is_empty(arg)) {
+ |
+
| 564 | +81x | +
+ df_argument <-+ |
+
| 565 | +81x | +
+ imap(+ |
+
| 566 | +81x | +
+ arg,+ |
+
| 567 | +81x | +
+ function(enlst_arg, variable) {
+ |
+
| 568 | +150x | +
+ lst_stat_names <-+ |
+
| 569 | +150x | +
+ x[c("variable", "stat_name")] |>
+ |
+
| 570 | +150x | +
+ dplyr::filter(.data$variable %in% .env$variable) |>+ |
+
| 571 | +150x | +
+ unique() %>%+ |
+
| 572 | +150x | +
+ {stats::setNames(as.list(.[["stat_name"]]), .[["stat_name"]])} # styler: off
+ |
+
| 573 | ++ | + + | +
| 574 | +150x | +
+ cards::compute_formula_selector(+ |
+
| 575 | +150x | +
+ data = lst_stat_names,+ |
+
| 576 | +150x | +
+ x = enlst_arg+ |
+
| 577 | ++ |
+ ) %>%+ |
+
| 578 | ++ |
+ # styler: off+ |
+
| 579 | +150x | +
+ {dplyr::tibble(
+ |
+
| 580 | +150x | +
+ variable = variable,+ |
+
| 581 | +150x | +
+ stat_name = names(.),+ |
+
| 582 | +150x | +
+ "{new_column}" := unname(.)
+ |
+
| 583 | ++ |
+ )}+ |
+
| 584 | ++ |
+ # styler: on+ |
+
| 585 | ++ |
+ }+ |
+
| 586 | ++ |
+ ) |>+ |
+
| 587 | +81x | +
+ dplyr::bind_rows()+ |
+
| 588 | ++ | + + | +
| 589 | +81x | +
+ x <- x |> dplyr::rows_update(df_argument, by = c("variable", "stat_name"), unmatched = "ignore")
+ |
+
| 590 | ++ |
+ }+ |
+
| 591 | ++ | + + | +
| 592 | +162x | +
+ if (isTRUE(unlist)) {
+ |
+
| 593 | +81x | +
+ x[[new_column]] <- lapply(x[[new_column]], function(x) x %||% NA) |> unlist()+ |
+
| 594 | ++ |
+ }+ |
+
| 595 | ++ | + + | +
| 596 | +162x | +
+ x+ |
+
| 597 | ++ |
+ }+ |
+
| 1 | ++ |
+ #' Construction Helpers+ |
+
| 2 | ++ |
+ #'+ |
+
| 3 | ++ |
+ #' These functions help construct calls to various types of models.+ |
+
| 4 | ++ |
+ #'+ |
+
| 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+ |
+
| 7 | ++ |
+ #' when the model is evaluated.+ |
+
| 8 | ++ |
+ #'+ |
+
| 9 | ++ |
+ #' - `reformulate2()`: This is a copy of `reformulate()` except that variable+ |
+
| 10 | ++ |
+ #' names that contain a space are wrapped in backticks.+ |
+
| 11 | ++ |
+ #'+ |
+
| 12 | ++ |
+ #' - `bt()`: Adds backticks to a character vector.+ |
+
| 13 | ++ |
+ #'+ |
+
| 14 | ++ |
+ #' - `bt_strip()`: Removes backticks from a string if it begins and ends with a backtick.+ |
+
| 15 | ++ |
+ #'+ |
+
| 16 | ++ |
+ #' @param data+ |
+
| 17 | ++ |
+ #' - `construct_model.data.frame()` (`data.frame`) a data frame+ |
+
| 18 | ++ |
+ #' - `construct_model.survey.design()` (`survey.design`) a survey design object+ |
+
| 19 | ++ |
+ #' @param x (`character`)\cr+ |
+
| 20 | ++ |
+ #' character vector, typically of variable names+ |
+
| 21 | ++ |
+ #' @param formula (`formula`)\cr+ |
+
| 22 | ++ |
+ #' a formula+ |
+
| 23 | ++ |
+ #' @param method (`string`)\cr+ |
+
| 24 | ++ |
+ #' string of function naming the function to be called, e.g. `"glm"`.+ |
+
| 25 | ++ |
+ #' If function belongs to a library that is not attached, the package name+ |
+
| 26 | ++ |
+ #' must be specified in the `package` argument.+ |
+
| 27 | ++ |
+ #' @param method.args (named `list`)\cr+ |
+
| 28 | ++ |
+ #' named list of arguments that will be passed to `method`.+ |
+
| 29 | ++ |
+ #'+ |
+
| 30 | ++ |
+ #' Note that this list may contain non-standard evaluation components.+ |
+
| 31 | ++ |
+ #' If you are wrapping this function in other functions, the argument+ |
+
| 32 | ++ |
+ #' must be passed in a way that does not evaluate the list, e.g.+ |
+
| 33 | ++ |
+ #' using rlang's embrace operator `{{ . }}`.
+ |
+
| 34 | ++ |
+ #' @param package (`string`)\cr+ |
+
| 35 | ++ |
+ #' string of package name that will be temporarily loaded when function+ |
+
| 36 | ++ |
+ #' specified in `method` is executed.+ |
+
| 37 | ++ |
+ #' @param pattern,pattern_term,pattern_response DEPRECATED+ |
+
| 38 | ++ |
+ #' @inheritParams rlang::eval_tidy+ |
+
| 39 | ++ |
+ #' @inheritParams stats::reformulate+ |
+
| 40 | ++ |
+ #' @inheritParams rlang::args_dots_empty+ |
+
| 41 | ++ |
+ #'+ |
+
| 42 | ++ |
+ #' @return depends on the calling function+ |
+
| 43 | ++ |
+ #' @name construction_helpers+ |
+
| 44 | ++ |
+ #'+ |
+
| 45 | ++ |
+ #' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = c("withr", "lme4", "broom.helpers", "broom.mixed"), reference_pkg = "cardx"))
+ |
+
| 46 | ++ |
+ #' construct_model(+ |
+
| 47 | ++ |
+ #' data = mtcars,+ |
+
| 48 | ++ |
+ #' formula = am ~ mpg + (1 | vs),+ |
+
| 49 | ++ |
+ #' method = "glmer",+ |
+
| 50 | ++ |
+ #' method.args = list(family = binomial),+ |
+
| 51 | ++ |
+ #' package = "lme4"+ |
+
| 52 | ++ |
+ #' ) |>+ |
+
| 53 | ++ |
+ #' broom.mixed::tidy()+ |
+
| 54 | ++ |
+ #'+ |
+
| 55 | ++ |
+ #' construct_model(+ |
+
| 56 | ++ |
+ #' data = mtcars |> dplyr::rename(`M P G` = mpg),+ |
+
| 57 | ++ |
+ #' formula = reformulate2(c("M P G", "cyl"), response = "hp"),
+ |
+
| 58 | ++ |
+ #' method = "lm"+ |
+
| 59 | ++ |
+ #' ) |>+ |
+
| 60 | ++ |
+ #' ard_regression() |>+ |
+
| 61 | ++ |
+ #' dplyr::filter(stat_name %in% c("term", "estimate", "p.value"))
+ |
+
| 62 | ++ |
+ NULL+ |
+
| 63 | ++ | + + | +
| 64 | ++ |
+ #' @rdname construction_helpers+ |
+
| 65 | ++ |
+ #' @export+ |
+
| 66 | ++ |
+ construct_model <- function(data, ...) {
+ |
+
| 67 | +17x | +
+ UseMethod("construct_model")
+ |
+
| 68 | ++ |
+ }+ |
+
| 69 | ++ | + + | +
| 70 | ++ |
+ #' @rdname construction_helpers+ |
+
| 71 | ++ |
+ #' @export+ |
+
| 72 | ++ |
+ construct_model.data.frame <- function(data, formula, method, method.args = list(), package = "base", env = caller_env(), ...) {
+ |
+
| 73 | +16x | +
+ set_cli_abort_call()+ |
+
| 74 | ++ |
+ # check pkg installations ----------------------------------------------------+ |
+
| 75 | +16x | +
+ check_dots_empty()+ |
+
| 76 | +16x | +
+ check_pkg_installed(c("withr", package), reference_pkg = "cardx")
+ |
+
| 77 | ++ | + + | +
| 78 | +16x | +
+ check_not_missing(formula)+ |
+
| 79 | +16x | +
+ check_class(formula, cls = "formula")+ |
+
| 80 | ++ | + + | +
| 81 | +16x | +
+ check_not_missing(method)+ |
+
| 82 | +16x | +
+ check_string_or_function(method)+ |
+
| 83 | +16x | +
+ if (is_string(method)) check_not_namespaced(method)+ |
+
| 84 | ++ | + + | +
| 85 | ++ |
+ # convert method.args to list of expressions (to account for NSE inputs) -----+ |
+
| 86 | +14x | +
+ method.args <- .as_list_of_exprs({{ method.args }})
+ |
+
| 87 | ++ | + + | +
| 88 | ++ |
+ # build model ----------------------------------------------------------------+ |
+
| 89 | +14x | +
+ call_to_run <- call2(.fn = method, formula = formula, data = data, !!!method.args)+ |
+
| 90 | ++ | + + | +
| 91 | +14x | +
+ try_fetch(+ |
+
| 92 | +14x | +
+ withr::with_namespace(+ |
+
| 93 | +14x | +
+ package = package,+ |
+
| 94 | +14x | +
+ eval_tidy(call_to_run, env = env)+ |
+
| 95 | ++ |
+ ),+ |
+
| 96 | +14x | +
+ error = function(e) {
+ |
+
| 97 | +! | +
+ msg <- "There was an error evaluating the model"+ |
+
| 98 | +14x | +
+ if (is_string(method)) {
+ |
+
| 99 | +! | +
+ call_to_run$data <- expr(.)+ |
+
| 100 | +! | +
+ msg <- paste(msg, "{.code {truncate_call(call_to_run)}}")
+ |
+
| 101 | ++ |
+ }+ |
+
| 102 | ++ | + + | +
| 103 | +! | +
+ cli::cli_abort(+ |
+
| 104 | +! | +
+ message = msg,+ |
+
| 105 | +! | +
+ parent = e,+ |
+
| 106 | +! | +
+ call = get_cli_abort_call()+ |
+
| 107 | ++ |
+ )+ |
+
| 108 | ++ |
+ }+ |
+
| 109 | ++ |
+ )+ |
+
| 110 | ++ |
+ }+ |
+
| 111 | ++ | + + | +
| 112 | ++ |
+ #' @rdname construction_helpers+ |
+
| 113 | ++ |
+ #' @export+ |
+
| 114 | ++ |
+ construct_model.survey.design <- function(data, formula, method, method.args = list(), package = "survey", env = caller_env(), ...) {
+ |
+
| 115 | +1x | +
+ set_cli_abort_call()+ |
+
| 116 | ++ |
+ # check pkg installations ----------------------------------------------------+ |
+
| 117 | +1x | +
+ check_dots_empty()+ |
+
| 118 | +1x | +
+ check_pkg_installed(c("withr", package), reference_pkg = "cardx")
+ |
+
| 119 | ++ | + + | +
| 120 | +1x | +
+ check_not_missing(formula)+ |
+
| 121 | +1x | +
+ check_class(formula, cls = "formula")+ |
+
| 122 | ++ | + + | +
| 123 | +1x | +
+ check_not_missing(method)+ |
+
| 124 | +1x | +
+ check_string_or_function(method)+ |
+
| 125 | +1x | +
+ if (is_string(method)) check_not_namespaced(method)+ |
+
| 126 | ++ | + + | +
| 127 | ++ |
+ # convert method.args to list of expressions (to account for NSE inputs) -----+ |
+
| 128 | +1x | +
+ method.args <- .as_list_of_exprs({{ method.args }})
+ |
+
| 129 | ++ | + + | +
| 130 | ++ |
+ # build model ----------------------------------------------------------------+ |
+
| 131 | +1x | +
+ call_to_run <- call2(.fn = method, formula = formula, design = data, !!!method.args)+ |
+
| 132 | ++ | + + | +
| 133 | +1x | +
+ try_fetch(+ |
+
| 134 | +1x | +
+ withr::with_namespace(+ |
+
| 135 | +1x | +
+ package = package,+ |
+
| 136 | +1x | +
+ eval_tidy(call_to_run, env = env)+ |
+
| 137 | ++ |
+ ),+ |
+
| 138 | +1x | +
+ error = function(e) {
+ |
+
| 139 | +! | +
+ msg <- "There was an error evaluating the model"+ |
+
| 140 | +! | +
+ if (is_string(method)) {
+ |
+
| 141 | +! | +
+ call_to_run$design <- expr(.)+ |
+
| 142 | +! | +
+ msg <- paste(msg, "{.code {truncate_call(call_to_run)}}")
+ |
+
| 143 | ++ |
+ }+ |
+
| 144 | ++ | + + | +
| 145 | +! | +
+ cli::cli_abort(+ |
+
| 146 | +! | +
+ message = msg,+ |
+
| 147 | +! | +
+ parent = e,+ |
+
| 148 | +! | +
+ call = get_cli_abort_call()+ |
+
| 149 | ++ |
+ )+ |
+
| 150 | ++ |
+ }+ |
+
| 151 | ++ |
+ )+ |
+
| 152 | ++ |
+ }+ |
+
| 153 | ++ | + + | +
| 154 | ++ |
+ .as_list_of_exprs <- function(x, arg_name = "method.args") {
+ |
+
| 155 | +15x | +
+ x_enexpr <- enexpr(x)+ |
+
| 156 | +15x | +
+ if (is_call_simple(x_enexpr)) {
+ |
+
| 157 | +15x | +
+ return(call_args(x_enexpr))+ |
+
| 158 | ++ |
+ }+ |
+
| 159 | ++ | + + | +
| 160 | +! | +
+ cli::cli_abort(+ |
+
| 161 | +! | +
+ c("There was an error processing the {.arg {argname}} argument.",
+ |
+
| 162 | +! | +
+ i = "Expecting a simple call. See {.help rlang::is_call_simple} for details."
+ |
+
| 163 | ++ |
+ ),+ |
+
| 164 | +! | +
+ call = get_cli_abort_call()+ |
+
| 165 | ++ |
+ )+ |
+
| 166 | ++ |
+ }+ |
+
| 167 | ++ | + + | +
| 168 | ++ |
+ #' @rdname construction_helpers+ |
+
| 169 | ++ |
+ #' @export+ |
+
| 170 | ++ |
+ reformulate2 <- function(termlabels, response = NULL, intercept = TRUE,+ |
+
| 171 | ++ |
+ env = parent.frame(),+ |
+
| 172 | ++ |
+ pattern_term = NULL, pattern_response = NULL) {
+ |
+
| 173 | ++ |
+ # deprecated argument --------------------------------------------------------+ |
+
| 174 | +! | +
+ if (!missing(pattern_term)) lifecycle::deprecate_warn("0.2.1", what = "cardx::reformulate2(pattern_term)", details = "Argument has been ignored.") # styler: off
+ |
+
| 175 | +! | +
+ if (!missing(pattern_response)) lifecycle::deprecate_warn("0.2.1", what = "cardx::reformulate2(pattern_response)", details = "Argument has been ignored.") # styler: off
+ |
+
| 176 | ++ | + + | +
| 177 | +1036x | +
+ stats::reformulate(+ |
+
| 178 | +1036x | +
+ termlabels = bt(termlabels),+ |
+
| 179 | +1036x | +
+ response = bt(response),+ |
+
| 180 | +1036x | +
+ intercept = intercept,+ |
+
| 181 | +1036x | +
+ env = env+ |
+
| 182 | ++ |
+ )+ |
+
| 183 | ++ |
+ }+ |
+
| 184 | ++ | + + | +
| 185 | ++ |
+ #' @rdname construction_helpers+ |
+
| 186 | ++ |
+ #' @export+ |
+
| 187 | ++ |
+ bt <- function(x, pattern = NULL) {
+ |
+
| 188 | ++ |
+ # deprecated argument --------------------------------------------------------+ |
+
| 189 | +! | +
+ if (!missing(pattern)) lifecycle::deprecate_warn("0.2.1", what = "cardx::bt(pattern)", details = "Argument has been ignored.") # styler: off
+ |
+
| 190 | ++ | + + | +
| 191 | +2132x | +
+ if (is_empty(x)) {
+ |
+
| 192 | +1013x | +
+ return(x)+ |
+
| 193 | ++ |
+ }+ |
+
| 194 | ++ | + + | +
| 195 | +1119x | +
+ ifelse(+ |
+
| 196 | +1119x | +
+ make.names(x) != x & !str_detect(x, "^`.*`$"),+ |
+
| 197 | +1119x | +
+ paste0("`", x, "`"),
+ |
+
| 198 | +1119x | +
+ x+ |
+
| 199 | ++ |
+ )+ |
+
| 200 | ++ |
+ }+ |
+
| 201 | ++ | + + | +
| 202 | ++ |
+ #' @rdname construction_helpers+ |
+
| 203 | ++ |
+ #' @export+ |
+
| 204 | ++ |
+ bt_strip <- function(x) {
+ |
+
| 205 | +! | +
+ ifelse(+ |
+
| 206 | +! | +
+ str_detect(x, "^`.*`$"),+ |
+
| 207 | +! | +
+ substr(x, 2, nchar(x) - 1),+ |
+
| 208 | +! | +
+ x+ |
+
| 209 | ++ |
+ )+ |
+
| 210 | ++ |
+ }+ |
+
| 211 | ++ | + + | +
| 212 | ++ |
+ check_not_namespaced <- function(x,+ |
+
| 213 | ++ |
+ arg_name = rlang::caller_arg(x),+ |
+
| 214 | ++ |
+ class = "check_not_namespaced",+ |
+
| 215 | ++ |
+ call = get_cli_abort_call()) {
+ |
+
| 216 | +17x | +
+ check_string(x, arg_name = arg_name, call = call, class = "check_not_namespaced")+ |
+
| 217 | ++ | + + | +
| 218 | +17x | +
+ if (str_detect(x, "::")) {
+ |
+
| 219 | +2x | +
+ cli::cli_abort(+ |
+
| 220 | +2x | +
+ "Argument {.arg {arg_name}} cannot be namespaced when passed as a {.cls string}.",
+ |
+
| 221 | +2x | +
+ call = call,+ |
+
| 222 | +2x | +
+ class = class+ |
+
| 223 | ++ |
+ )+ |
+
| 224 | ++ |
+ }+ |
+
| 225 | ++ | + + | +
| 226 | +15x | +
+ invisible(x)+ |
+
| 227 | ++ |
+ }+ |
+
| 228 | ++ | + + | +
| 229 | ++ | + + | +
| 230 | ++ |
+ check_string_or_function <- function(x,+ |
+
| 231 | ++ |
+ arg_name = rlang::caller_arg(x),+ |
+
| 232 | ++ |
+ class = "check_string_or_function",+ |
+
| 233 | ++ |
+ call = get_cli_abort_call()) {
+ |
+
| 234 | +17x | +
+ if (!is.function(x) && !is_string(x)) {
+ |
+
| 235 | +! | +
+ cli::cli_abort(+ |
+
| 236 | +! | +
+ c("Argument {.arg {arg_name}} must be a {.cls string} or {.cls function}."),
+ |
+
| 237 | +! | +
+ call = call,+ |
+
| 238 | +! | +
+ class = class+ |
+
| 239 | ++ |
+ )+ |
+
| 240 | ++ |
+ }+ |
+
| 241 | ++ | + + | +
| 242 | +17x | +
+ invisible(x)+ |
+
| 243 | ++ |
+ }+ |
+
| 244 | ++ | + + | +
| 245 | ++ |
+ truncate_call <- function(call, max_out = 100) {
+ |
+
| 246 | +! | +
+ call_text <- expr_text(call)+ |
+
| 247 | +! | +
+ if (nchar(call_text) > max_out) {
+ |
+
| 248 | +! | +
+ call_text <- paste(substr(call_text, 1, max_out), "...")+ |
+
| 249 | ++ |
+ }+ |
+
| 250 | +! | +
+ call_text+ |
+
| 251 | ++ |
+ }+ |
+
| 1 | ++ |
+ #' ARD Proportion Confidence Intervals+ |
+
| 2 | ++ |
+ #'+ |
+
| 3 | ++ |
+ #' `r lifecycle::badge('experimental')`\cr
+ |
+
| 4 | ++ |
+ #' Calculate confidence intervals for proportions.+ |
+
| 5 | ++ |
+ #'+ |
+
| 6 | ++ |
+ #' @inheritParams cards::ard_categorical+ |
+
| 7 | ++ |
+ #' @param variables ([`tidy-select`][dplyr::dplyr_tidy_select])\cr+ |
+
| 8 | ++ |
+ #' columns to include in summaries. Columns must be class `<logical>`+ |
+
| 9 | ++ |
+ #' or `<numeric>` values coded as `c(0, 1)`.+ |
+
| 10 | ++ |
+ #' @param by ([`tidy-select`][dplyr::dplyr_tidy_select])\cr+ |
+
| 11 | ++ |
+ #' columns to stratify calculations by+ |
+
| 12 | ++ |
+ #' @param conf.level (`numeric`)\cr+ |
+
| 13 | ++ |
+ #' a scalar in `(0, 1)` indicating the confidence level.+ |
+
| 14 | ++ |
+ #' Default is `0.95`+ |
+
| 15 | ++ |
+ #' @param method (`string`)\cr+ |
+
| 16 | ++ |
+ #' string indicating the type of confidence interval to calculate.+ |
+
| 17 | ++ |
+ #' Must be one of `r formals(ard_categorical_ci)[["method"]] |> eval() |> shQuote("sh")`.
+ |
+
| 18 | ++ |
+ #' See `?proportion_ci` for details.+ |
+
| 19 | ++ |
+ #' @param strata,weights,max.iterations arguments passed to `proportion_ci_strat_wilson()`,+ |
+
| 20 | ++ |
+ #' when `method='strat_wilson'`+ |
+
| 21 | ++ |
+ #' @param value ([`formula-list-selector`][cards::syntax])\cr+ |
+
| 22 | ++ |
+ #' function will calculate the CIs for all levels of the variables specified.+ |
+
| 23 | ++ |
+ #' Use this argument to instead request only a single level by summarized.+ |
+
| 24 | ++ |
+ #' Default is `list(where(is_binary) ~ 1L, where(is.logical) ~ TRUE)`, where+ |
+
| 25 | ++ |
+ #' columns coded as `0`/`1` and `TRUE`/`FALSE` will summarize the `1` and `TRUE` levels.+ |
+
| 26 | ++ |
+ #'+ |
+
| 27 | ++ |
+ #' @return an ARD data frame+ |
+
| 28 | ++ |
+ #' @name ard_categorical_ci+ |
+
| 29 | ++ |
+ #'+ |
+
| 30 | ++ |
+ #' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = "broom", reference_pkg = "cardx"))
+ |
+
| 31 | ++ |
+ #' # compute CI for binary variables+ |
+
| 32 | ++ |
+ #' ard_categorical_ci(mtcars, variables = c(vs, am), method = "wilson")+ |
+
| 33 | ++ |
+ #'+ |
+
| 34 | ++ |
+ #' # compute CIs for each level of a categorical variable+ |
+
| 35 | ++ |
+ #' ard_categorical_ci(mtcars, variables = cyl, method = "jeffreys")+ |
+
| 36 | ++ |
+ NULL+ |
+
| 37 | ++ | + + | +
| 38 | ++ |
+ #' @rdname ard_categorical_ci+ |
+
| 39 | ++ |
+ #' @export+ |
+
| 40 | ++ |
+ ard_categorical_ci <- function(data, ...) {
+ |
+
| 41 | +24x | +
+ check_not_missing(data)+ |
+
| 42 | +24x | +
+ UseMethod("ard_categorical_ci")
+ |
+
| 43 | ++ |
+ }+ |
+
| 44 | ++ | + + | +
| 45 | ++ |
+ #' @rdname ard_categorical_ci+ |
+
| 46 | ++ |
+ #' @export+ |
+
| 47 | ++ |
+ ard_categorical_ci.data.frame <- function(data,+ |
+
| 48 | ++ |
+ variables,+ |
+
| 49 | ++ |
+ by = dplyr::group_vars(data),+ |
+
| 50 | ++ |
+ method = c(+ |
+
| 51 | ++ |
+ "waldcc", "wald", "clopper-pearson",+ |
+
| 52 | ++ |
+ "wilson", "wilsoncc",+ |
+
| 53 | ++ |
+ "strat_wilson", "strat_wilsoncc",+ |
+
| 54 | ++ |
+ "agresti-coull", "jeffreys"+ |
+
| 55 | ++ |
+ ),+ |
+
| 56 | ++ |
+ conf.level = 0.95,+ |
+
| 57 | ++ |
+ value = list(where(is_binary) ~ 1L, where(is.logical) ~ TRUE),+ |
+
| 58 | ++ |
+ strata = NULL,+ |
+
| 59 | ++ |
+ weights = NULL,+ |
+
| 60 | ++ |
+ max.iterations = 10,+ |
+
| 61 | ++ |
+ ...) {
+ |
+
| 62 | +11x | +
+ set_cli_abort_call()+ |
+
| 63 | +11x | +
+ check_dots_empty()+ |
+
| 64 | ++ | + + | +
| 65 | ++ |
+ # check installed packages ---------------------------------------------------+ |
+
| 66 | +11x | +
+ check_pkg_installed(pkg = "broom", reference_pkg = "cardx")+ |
+
| 67 | ++ | + + | +
| 68 | ++ |
+ # process inputs -------------------------------------------------------------+ |
+
| 69 | +11x | +
+ cards::process_selectors(data, variables = {{ variables }}, by = {{ by }})
+ |
+
| 70 | +11x | +
+ method <- arg_match(method)+ |
+
| 71 | +11x | +
+ if (method %in% c("strat_wilson", "strat_wilsoncc")) {
+ |
+
| 72 | +1x | +
+ cards::process_selectors(data, strata = strata)+ |
+
| 73 | +1x | +
+ check_scalar(strata)+ |
+
| 74 | ++ |
+ }+ |
+
| 75 | +11x | +
+ cards::process_formula_selectors(+ |
+
| 76 | +11x | +
+ data[variables],+ |
+
| 77 | +11x | +
+ value = value+ |
+
| 78 | ++ |
+ )+ |
+
| 79 | +11x | +
+ check_not_missing(variables)+ |
+
| 80 | ++ | + + | +
| 81 | ++ |
+ # return empty ARD if no variables selected ----------------------------------+ |
+
| 82 | +11x | +
+ if (is_empty(variables)) {
+ |
+
| 83 | +! | +
+ return(dplyr::tibble() |> cards::as_card())+ |
+
| 84 | ++ |
+ }+ |
+
| 85 | ++ | + + | +
| 86 | ++ |
+ # calculate confidence intervals ---------------------------------------------+ |
+
| 87 | +11x | +
+ map(+ |
+
| 88 | +11x | +
+ variables,+ |
+
| 89 | +11x | +
+ function(variable) {
+ |
+
| 90 | +19x | +
+ levels <- .unique_values_sort(data, variable = variable, value = value[[variable]])+ |
+
| 91 | ++ | + + | +
| 92 | +19x | +
+ .calculate_ard_proportion(+ |
+
| 93 | +19x | +
+ data = .as_dummy(data, variable = variable, levels = levels, by = by, strata = strata),+ |
+
| 94 | +19x | +
+ variables = c(everything(), -all_of(c(by, strata))),+ |
+
| 95 | +19x | +
+ by = all_of(by),+ |
+
| 96 | +19x | +
+ method = method,+ |
+
| 97 | +19x | +
+ conf.level = conf.level,+ |
+
| 98 | +19x | +
+ strata = strata,+ |
+
| 99 | +19x | +
+ weights = weights,+ |
+
| 100 | +19x | +
+ max.iterations = max.iterations+ |
+
| 101 | ++ |
+ ) %>%+ |
+
| 102 | ++ |
+ # merge in the variable levels+ |
+
| 103 | +19x | +
+ dplyr::left_join(+ |
+
| 104 | +19x | +
+ dplyr::select(., "variable") |>+ |
+
| 105 | +19x | +
+ dplyr::distinct() |>+ |
+
| 106 | +19x | +
+ dplyr::mutate(variable_level = as.list(.env$levels)),+ |
+
| 107 | +19x | +
+ by = "variable"+ |
+
| 108 | ++ |
+ ) |>+ |
+
| 109 | ++ |
+ # rename variable column+ |
+
| 110 | +19x | +
+ dplyr::mutate(variable = .env$variable) |>+ |
+
| 111 | +19x | +
+ dplyr::relocate("variable_level", .after = "variable")
+ |
+
| 112 | ++ |
+ }+ |
+
| 113 | ++ |
+ ) |>+ |
+
| 114 | +11x | +
+ dplyr::bind_rows()+ |
+
| 115 | ++ |
+ }+ |
+
| 116 | ++ | + + | +
| 117 | ++ |
+ .calculate_ard_proportion <- function(data, variables, by, method, conf.level, strata, weights, max.iterations) {
+ |
+
| 118 | +19x | +
+ cards::ard_complex(+ |
+
| 119 | +19x | +
+ data = data,+ |
+
| 120 | +19x | +
+ variables = {{ variables }},
+ |
+
| 121 | +19x | +
+ by = {{ by }},
+ |
+
| 122 | +19x | +
+ statistic =+ |
+
| 123 | +19x | +
+ ~ list(+ |
+
| 124 | +19x | +
+ prop_ci =+ |
+
| 125 | +19x | +
+ switch(method,+ |
+
| 126 | +19x | +
+ "waldcc" = \(x, ...) proportion_ci_wald(x, conf.level = conf.level, correct = TRUE),+ |
+
| 127 | +19x | +
+ "wald" = \(x, ...) proportion_ci_wald(x, conf.level = conf.level, correct = FALSE),+ |
+
| 128 | +19x | +
+ "wilsoncc" = \(x, ...) proportion_ci_wilson(x, conf.level = conf.level, correct = TRUE),+ |
+
| 129 | +19x | +
+ "wilson" = \(x, ...) proportion_ci_wilson(x, conf.level = conf.level, correct = FALSE),+ |
+
| 130 | +19x | +
+ "clopper-pearson" = \(x, ...) proportion_ci_clopper_pearson(x, conf.level = conf.level),+ |
+
| 131 | +19x | +
+ "agresti-coull" = \(x, ...) proportion_ci_agresti_coull(x, conf.level = conf.level),+ |
+
| 132 | +19x | +
+ "jeffreys" = \(x, ...) proportion_ci_jeffreys(x, conf.level = conf.level),+ |
+
| 133 | +19x | +
+ "strat_wilsoncc" = \(x, data, ...) {
+ |
+
| 134 | +! | +
+ proportion_ci_strat_wilson(x,+ |
+
| 135 | +! | +
+ strata = data[[strata]], weights = weights,+ |
+
| 136 | +! | +
+ max.iterations = max.iterations,+ |
+
| 137 | +! | +
+ conf.level = conf.level, correct = TRUE+ |
+
| 138 | ++ |
+ )+ |
+
| 139 | ++ |
+ },+ |
+
| 140 | +19x | +
+ "strat_wilson" = \(x, data, ...) {
+ |
+
| 141 | +1x | +
+ proportion_ci_strat_wilson(x,+ |
+
| 142 | +1x | +
+ strata = data[[strata]], weights = weights,+ |
+
| 143 | +1x | +
+ max.iterations = max.iterations,+ |
+
| 144 | +1x | +
+ conf.level = conf.level, correct = FALSE+ |
+
| 145 | ++ |
+ )+ |
+
| 146 | ++ |
+ }+ |
+
| 147 | ++ |
+ )+ |
+
| 148 | ++ |
+ )+ |
+
| 149 | ++ |
+ ) |>+ |
+
| 150 | +19x | +
+ dplyr::mutate(+ |
+
| 151 | +19x | +
+ context = "proportion_ci"+ |
+
| 152 | ++ |
+ )+ |
+
| 153 | ++ |
+ }+ |
+
| 154 | ++ | + + | +
| 155 | ++ |
+ .unique_values_sort <- function(data, variable, value = NULL) {
+ |
+
| 156 | +249x | +
+ unique_levels <-+ |
+
| 157 | ++ |
+ # styler: off+ |
+
| 158 | +249x | +
+ if (is.logical(data[[variable]])) c(TRUE, FALSE)+ |
+
| 159 | +249x | +
+ else if (is.factor(data[[variable]])) factor(levels(data[[variable]]), levels = levels(data[[variable]]))+ |
+
| 160 | +249x | +
+ else unique(data[[variable]]) |> sort()+ |
+
| 161 | ++ |
+ # styler: on+ |
+
| 162 | ++ | + + | +
| 163 | +249x | +
+ if (!is_empty(value) && !value %in% unique_levels) {
+ |
+
| 164 | +1x | +
+ cli::cli_warn(+ |
+
| 165 | +1x | +
+ c("A value of {.code value={.val {value}}} for variable {.val {variable}}
+ |
+
| 166 | +1x | +
+ was passed, but is not one of the observed levels: {.val {unique_levels}}.",
+ |
+
| 167 | +1x | +
+ i = "This may be an error.",+ |
+
| 168 | +1x | +
+ i = "If value is a valid, convert variable to factor with all levels specified to avoid this message."+ |
+
| 169 | ++ |
+ )+ |
+
| 170 | ++ |
+ )+ |
+
| 171 | ++ |
+ }+ |
+
| 172 | +249x | +
+ if (!is_empty(value)) {
+ |
+
| 173 | +18x | +
+ unique_levels <- value+ |
+
| 174 | ++ |
+ }+ |
+
| 175 | ++ | + + | +
| 176 | +249x | +
+ unique_levels+ |
+
| 177 | ++ |
+ }+ |
+
| 178 | ++ | + + | +
| 179 | ++ |
+ .as_dummy <- function(data, variable, levels, by, strata) {
+ |
+
| 180 | ++ |
+ # define dummy variables and return tibble+ |
+
| 181 | +19x | +
+ map(levels, ~ data[[variable]] == .x) |>+ |
+
| 182 | +19x | +
+ set_names(paste0("this_is_not_a_column_name_anyone_would_choose_", variable, "_", levels, "...")) %>%
+ |
+
| 183 | +19x | +
+ {dplyr::tibble(!!!.)} |> # styler: off
+ |
+
| 184 | +19x | +
+ dplyr::bind_cols(data[c(by, strata)])+ |
+
| 185 | ++ |
+ }+ |
+
| 1 | ++ |
+ #' ARD ANOVA+ |
+
| 2 | ++ |
+ #'+ |
+
| 3 | ++ |
+ #' @description+ |
+
| 4 | ++ |
+ #' Analysis results data for Analysis of Variance.+ |
+
| 5 | ++ |
+ #' Calculated with `stats::aov()`+ |
+
| 6 | ++ |
+ #'+ |
+
| 7 | ++ |
+ #' @inheritParams stats::aov+ |
+
| 8 | ++ |
+ #' @param ... arguments passed to `stats::aov(...)`+ |
+
| 9 | ++ |
+ #'+ |
+
| 10 | ++ |
+ #' @return ARD data frame+ |
+
| 11 | ++ |
+ #' @export+ |
+
| 12 | ++ |
+ #'+ |
+
| 13 | ++ |
+ #' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = c("broom.helpers", "parameters"), reference_pkg = "cardx"))
+ |
+
| 14 | ++ |
+ #' ard_stats_aov(AGE ~ ARM, data = cards::ADSL)+ |
+
| 15 | ++ |
+ ard_stats_aov <- function(formula, data, ...) {
+ |
+
| 16 | +3x | +
+ set_cli_abort_call()+ |
+
| 17 | ++ | + + | +
| 18 | ++ |
+ # check installed packages ---------------------------------------------------+ |
+
| 19 | +3x | +
+ check_pkg_installed(c("broom.helpers", "parameters"), reference_pkg = "cardx")
+ |
+
| 20 | ++ | + + | +
| 21 | ++ |
+ # check/process inputs -------------------------------------------------------+ |
+
| 22 | +3x | +
+ check_not_missing(formula)+ |
+
| 23 | +3x | +
+ check_not_missing(data)+ |
+
| 24 | +3x | +
+ check_data_frame(data)+ |
+
| 25 | +3x | +
+ check_class(formula, cls = "formula")+ |
+
| 26 | ++ | + + | +
| 27 | ++ |
+ # build ARD ------------------------------------------------------------------+ |
+
| 28 | +3x | +
+ aov <-+ |
+
| 29 | +3x | +
+ cards::eval_capture_conditions(+ |
+
| 30 | +3x | +
+ stats::aov(formula, data, ...)+ |
+
| 31 | ++ |
+ )+ |
+
| 32 | +3x | +
+ aov[["result"]] |>+ |
+
| 33 | +3x | +
+ broom.helpers::tidy_parameters() |> # using broom.helpers, because it handle non-syntactic names+ |
+
| 34 | +3x | +
+ dplyr::filter(!(dplyr::row_number() == dplyr::n() & .data$term %in% "Residuals")) |> # removing Residual rows+ |
+
| 35 | +3x | +
+ dplyr::rename(variable = "term") |>+ |
+
| 36 | +3x | +
+ tidyr::pivot_longer(+ |
+
| 37 | +3x | +
+ cols = -"variable",+ |
+
| 38 | +3x | +
+ names_to = "stat_name",+ |
+
| 39 | +3x | +
+ values_to = "stat"+ |
+
| 40 | ++ |
+ ) |>+ |
+
| 41 | +3x | +
+ dplyr::mutate(+ |
+
| 42 | +3x | +
+ stat = as.list(.data$stat),+ |
+
| 43 | +3x | +
+ stat_label =+ |
+
| 44 | +3x | +
+ dplyr::case_when(+ |
+
| 45 | +3x | +
+ .data$stat_name %in% "statistic" ~ "Statistic",+ |
+
| 46 | +3x | +
+ .data$stat_name %in% "df" ~ "Degrees of Freedom",+ |
+
| 47 | +3x | +
+ .data$stat_name %in% "p.value" ~ "p-value",+ |
+
| 48 | +3x | +
+ .data$stat_name %in% "sumsq" ~ "Sum of Squares",+ |
+
| 49 | +3x | +
+ .data$stat_name %in% "meansq" ~ "Mean of Sum of Squares",+ |
+
| 50 | +3x | +
+ TRUE ~ .data$stat_name+ |
+
| 51 | ++ |
+ ),+ |
+
| 52 | +3x | +
+ context = "stats_aov",+ |
+
| 53 | +3x | +
+ fmt_fn = lapply(+ |
+
| 54 | +3x | +
+ .data$stat,+ |
+
| 55 | +3x | +
+ function(x) {
+ |
+
| 56 | +20x | +
+ switch(is.integer(x),+ |
+
| 57 | +20x | +
+ 0L+ |
+
| 58 | +20x | +
+ ) %||% switch(is.numeric(x),+ |
+
| 59 | +20x | +
+ 1L+ |
+
| 60 | ++ |
+ )+ |
+
| 61 | ++ |
+ }+ |
+
| 62 | ++ |
+ ),+ |
+
| 63 | +3x | +
+ warning = aov["warning"],+ |
+
| 64 | +3x | +
+ error = aov["error"]+ |
+
| 65 | ++ |
+ ) |>+ |
+
| 66 | +3x | +
+ cards::as_card() |>+ |
+
| 67 | +3x | +
+ cards::tidy_ard_column_order()+ |
+
| 68 | ++ |
+ }+ |
+
| 1 | ++ |
+ #' ARD ANOVA+ |
+
| 2 | ++ |
+ #'+ |
+
| 3 | ++ |
+ #' Prepare ANOVA results from the `stats::anova()` function.+ |
+
| 4 | ++ |
+ #' Users may pass a pre-calculated `stats::anova()` object or a list of+ |
+
| 5 | ++ |
+ #' formulas. In the latter case, the models will be constructed using the+ |
+
| 6 | ++ |
+ #' information passed and models will be passed to `stats::anova()`.+ |
+
| 7 | ++ |
+ #'+ |
+
| 8 | ++ |
+ #' @param x (`anova` or `data.frame`)\cr+ |
+
| 9 | ++ |
+ #' an object of class `'anova'` created with `stats::anova()` or+ |
+
| 10 | ++ |
+ #' a data frame+ |
+
| 11 | ++ |
+ #' @param formulas (`list`)\cr+ |
+
| 12 | ++ |
+ #' a list of formulas+ |
+
| 13 | ++ |
+ #' @param method_text (`string`)\cr+ |
+
| 14 | ++ |
+ #' string of the method used. Default is `"ANOVA results from `stats::anova()`"`.+ |
+
| 15 | ++ |
+ #' We provide the option to change this as `stats::anova()` can produce+ |
+
| 16 | ++ |
+ #' results from many types of models that may warrant a more precise+ |
+
| 17 | ++ |
+ #' description.+ |
+
| 18 | ++ |
+ #' @inheritParams rlang::args_dots_empty+ |
+
| 19 | ++ |
+ #' @inheritParams construction_helpers+ |
+
| 20 | ++ |
+ #'+ |
+
| 21 | ++ |
+ #' @details+ |
+
| 22 | ++ |
+ #' When a list of formulas is supplied to `ard_stats_anova()`, these formulas+ |
+
| 23 | ++ |
+ #' along with information from other arguments, are used to construct models+ |
+
| 24 | ++ |
+ #' and pass those models to `stats::anova()`.+ |
+
| 25 | ++ |
+ #'+ |
+
| 26 | ++ |
+ #' The models are constructed using `rlang::exec()`, which is similar to `do.call()`.+ |
+
| 27 | ++ |
+ #'+ |
+
| 28 | ++ |
+ #' ```r+ |
+
| 29 | ++ |
+ #' rlang::exec(.fn = method, formula = formula, data = data, !!!method.args)+ |
+
| 30 | ++ |
+ #' ```+ |
+
| 31 | ++ |
+ #'+ |
+
| 32 | ++ |
+ #' The above function is executed in `withr::with_namespace(package)`, which+ |
+
| 33 | ++ |
+ #' allows for the use of `ard_stats_anova(method)` from packages,+ |
+
| 34 | ++ |
+ #' e.g. `package = 'lme4'` must be specified when `method = 'glmer'`.+ |
+
| 35 | ++ |
+ #' See example below.+ |
+
| 36 | ++ |
+ #'+ |
+
| 37 | ++ |
+ #' @return ARD data frame+ |
+
| 38 | ++ |
+ #' @name ard_stats_anova+ |
+
| 39 | ++ |
+ #'+ |
+
| 40 | ++ |
+ #' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = c("broom", "withr", "lme4"), reference_pkg = "cardx"))
+ |
+
| 41 | ++ |
+ #' anova(+ |
+
| 42 | ++ |
+ #' lm(mpg ~ am, mtcars),+ |
+
| 43 | ++ |
+ #' lm(mpg ~ am + hp, mtcars)+ |
+
| 44 | ++ |
+ #' ) |>+ |
+
| 45 | ++ |
+ #' ard_stats_anova()+ |
+
| 46 | ++ |
+ #'+ |
+
| 47 | ++ |
+ #' ard_stats_anova(+ |
+
| 48 | ++ |
+ #' x = mtcars,+ |
+
| 49 | ++ |
+ #' formulas = list(am ~ mpg, am ~ mpg + hp),+ |
+
| 50 | ++ |
+ #' method = "glm",+ |
+
| 51 | ++ |
+ #' method.args = list(family = binomial)+ |
+
| 52 | ++ |
+ #' )+ |
+
| 53 | ++ |
+ #'+ |
+
| 54 | ++ |
+ #' ard_stats_anova(+ |
+
| 55 | ++ |
+ #' x = mtcars,+ |
+
| 56 | ++ |
+ #' formulas = list(am ~ 1 + (1 | vs), am ~ mpg + (1 | vs)),+ |
+
| 57 | ++ |
+ #' method = "glmer",+ |
+
| 58 | ++ |
+ #' method.args = list(family = binomial),+ |
+
| 59 | ++ |
+ #' package = "lme4"+ |
+
| 60 | ++ |
+ #' )+ |
+
| 61 | ++ |
+ NULL+ |
+
| 62 | ++ | + + | +
| 63 | ++ |
+ #' @rdname ard_stats_anova+ |
+
| 64 | ++ |
+ #' @export+ |
+
| 65 | ++ |
+ ard_stats_anova <- function(x, ...) {
+ |
+
| 66 | +9x | +
+ UseMethod("ard_stats_anova")
+ |
+
| 67 | ++ |
+ }+ |
+
| 68 | ++ | + + | +
| 69 | ++ |
+ #' @rdname ard_stats_anova+ |
+
| 70 | ++ |
+ #' @export+ |
+
| 71 | ++ |
+ ard_stats_anova.anova <- function(x, method_text = "ANOVA results from `stats::anova()`", ...) {
+ |
+
| 72 | +3x | +
+ set_cli_abort_call()+ |
+
| 73 | ++ | + + | +
| 74 | ++ |
+ # check inputs ---------------------------------------------------------------+ |
+
| 75 | +3x | +
+ check_dots_empty()+ |
+
| 76 | +3x | +
+ check_pkg_installed("broom", reference_pkg = "cardx")
+ |
+
| 77 | +3x | +
+ check_string(method_text)+ |
+
| 78 | ++ | + + | +
| 79 | ++ |
+ # return df in cards formats -------------------------------------------------+ |
+
| 80 | +3x | +
+ lst_results <-+ |
+
| 81 | +3x | +
+ cards::eval_capture_conditions(+ |
+
| 82 | +3x | +
+ .anova_tidy_and_reshape(x, method_text = method_text)+ |
+
| 83 | ++ |
+ )+ |
+
| 84 | ++ | + + | +
| 85 | ++ |
+ # final tidying up of cards data frame ---------------------------------------+ |
+
| 86 | +3x | +
+ .anova_final_ard_prep(lst_results, method_text = method_text)+ |
+
| 87 | ++ |
+ }+ |
+
| 88 | ++ | + + | +
| 89 | ++ | + + | +
| 90 | ++ |
+ #' @rdname ard_stats_anova+ |
+
| 91 | ++ |
+ #' @export+ |
+
| 92 | ++ |
+ ard_stats_anova.data.frame <- function(x,+ |
+
| 93 | ++ |
+ formulas,+ |
+
| 94 | ++ |
+ method,+ |
+
| 95 | ++ |
+ method.args = list(),+ |
+
| 96 | ++ |
+ package = "base",+ |
+
| 97 | ++ |
+ method_text = "ANOVA results from `stats::anova()`",+ |
+
| 98 | ++ |
+ ...) {
+ |
+
| 99 | +6x | +
+ set_cli_abort_call()+ |
+
| 100 | ++ | + + | +
| 101 | ++ |
+ # check inputs ---------------------------------------------------------------+ |
+
| 102 | +6x | +
+ check_dots_empty()+ |
+
| 103 | +6x | +
+ check_pkg_installed(c("broom", "withr", package), reference_pkg = "cardx")
+ |
+
| 104 | +6x | +
+ check_not_missing(formulas)+ |
+
| 105 | +6x | +
+ check_class(formulas, cls = "list")+ |
+
| 106 | +6x | +
+ walk(+ |
+
| 107 | +6x | +
+ formulas,+ |
+
| 108 | +6x | +
+ ~ check_class(+ |
+
| 109 | +6x | +
+ .x,+ |
+
| 110 | +6x | +
+ cls = "formula",+ |
+
| 111 | +6x | +
+ arg_name = "formulas",+ |
+
| 112 | +6x | +
+ message = "Each element of {.arg formulas} must be class {.cls formula}"
+ |
+
| 113 | ++ |
+ )+ |
+
| 114 | ++ |
+ )+ |
+
| 115 | ++ | + + | +
| 116 | ++ |
+ # calculate results and return df in cards formats ---------------------------+ |
+
| 117 | ++ |
+ # create models+ |
+
| 118 | +6x | +
+ lst_results <-+ |
+
| 119 | +6x | +
+ cards::eval_capture_conditions({
+ |
+
| 120 | ++ |
+ # first build the models+ |
+
| 121 | +6x | +
+ models <-+ |
+
| 122 | +6x | +
+ lapply(+ |
+
| 123 | +6x | +
+ formulas,+ |
+
| 124 | +6x | +
+ function(formula) {
+ |
+
| 125 | +11x | +
+ construct_model(data = x, formula = formula, method = method, method.args = {{ method.args }}, package = package)
+ |
+
| 126 | ++ |
+ }+ |
+
| 127 | ++ |
+ )+ |
+
| 128 | ++ | + + | +
| 129 | ++ |
+ # now calculate `stats::anova()` and reshape results+ |
+
| 130 | +5x | +
+ rlang::inject(stats::anova(!!!models)) |>+ |
+
| 131 | +5x | +
+ .anova_tidy_and_reshape(method_text = method_text)+ |
+
| 132 | ++ |
+ })+ |
+
| 133 | ++ | + + | +
| 134 | ++ |
+ # final tidying up of cards data frame ---------------------------------------+ |
+
| 135 | +6x | +
+ .anova_final_ard_prep(lst_results, method_text = method_text)+ |
+
| 136 | ++ |
+ }+ |
+
| 137 | ++ | + + | +
| 138 | ++ |
+ .anova_tidy_and_reshape <- function(x, method_text) {
+ |
+
| 139 | +8x | +
+ broom::tidy(x) |>+ |
+
| 140 | +8x | +
+ dplyr::mutate(+ |
+
| 141 | +8x | +
+ across(everything(), as.list),+ |
+
| 142 | +8x | +
+ variable = paste0("model_", dplyr::row_number())
+ |
+
| 143 | ++ |
+ ) |>+ |
+
| 144 | +8x | +
+ tidyr::pivot_longer(+ |
+
| 145 | +8x | +
+ cols = -"variable",+ |
+
| 146 | +8x | +
+ names_to = "stat_name",+ |
+
| 147 | +8x | +
+ values_to = "stat"+ |
+
| 148 | ++ |
+ ) |>+ |
+
| 149 | +8x | +
+ dplyr::filter(!is.na(.data$stat)) %>%+ |
+
| 150 | ++ |
+ # add one more row with the method+ |
+
| 151 | ++ |
+ {
+ |
+
| 152 | +8x | +
+ dplyr::bind_rows(+ |
+
| 153 | ++ |
+ .,+ |
+
| 154 | +8x | +
+ dplyr::filter(., dplyr::n() == dplyr::row_number()) |>+ |
+
| 155 | +8x | +
+ dplyr::mutate(+ |
+
| 156 | +8x | +
+ stat_name = "method",+ |
+
| 157 | +8x | +
+ stat = list(.env$method_text)+ |
+
| 158 | ++ |
+ )+ |
+
| 159 | ++ |
+ )+ |
+
| 160 | ++ |
+ }+ |
+
| 161 | ++ |
+ }+ |
+
| 162 | ++ | + + | +
| 163 | ++ |
+ .anova_final_ard_prep <- function(lst_results, method_text) {
+ |
+
| 164 | ++ |
+ # saving the results in data frame -------------------------------------------+ |
+
| 165 | +9x | +
+ df_card <-+ |
+
| 166 | +9x | +
+ if (!is.null(lst_results[["result"]])) {
+ |
+
| 167 | +8x | +
+ lst_results[["result"]]+ |
+
| 168 | +9x | +
+ } else { # if there was an error return a shell of an ARD data frame
+ |
+
| 169 | +1x | +
+ dplyr::tibble(+ |
+
| 170 | +1x | +
+ variable = "model_1",+ |
+
| 171 | +1x | +
+ stat_name = c("p.value", "method"),
+ |
+
| 172 | +1x | +
+ stat = list(NULL, method_text)+ |
+
| 173 | ++ |
+ )+ |
+
| 174 | ++ |
+ }+ |
+
| 175 | ++ | + + | +
| 176 | ++ |
+ # final tidying up of cards data frame ---------------------------------------+ |
+
| 177 | +9x | +
+ df_card |>+ |
+
| 178 | +9x | +
+ dplyr::mutate(+ |
+
| 179 | +9x | +
+ warning = lst_results["warning"],+ |
+
| 180 | +9x | +
+ error = lst_results["error"],+ |
+
| 181 | +9x | +
+ context = "stats_anova",+ |
+
| 182 | +9x | +
+ fmt_fn = lapply(+ |
+
| 183 | +9x | +
+ .data$stat,+ |
+
| 184 | +9x | +
+ function(x) {
+ |
+
| 185 | +88x | +
+ switch(is.integer(x),+ |
+
| 186 | +88x | +
+ 0L+ |
+
| 187 | +88x | +
+ ) %||% switch(is.numeric(x),+ |
+
| 188 | +88x | +
+ 1L+ |
+
| 189 | ++ |
+ )+ |
+
| 190 | ++ |
+ }+ |
+
| 191 | ++ |
+ ),+ |
+
| 192 | +9x | +
+ stat_label =+ |
+
| 193 | +9x | +
+ dplyr::case_when(+ |
+
| 194 | +9x | +
+ .data$stat_name %in% "p.value" ~ "p-value",+ |
+
| 195 | +9x | +
+ .data$stat_name %in% "sumsq" ~ "Sum of Squares",+ |
+
| 196 | +9x | +
+ .data$stat_name %in% "rss" ~ "Residual Sum of Squares",+ |
+
| 197 | +9x | +
+ .data$stat_name %in% "df" ~ "Degrees of Freedom",+ |
+
| 198 | +9x | +
+ .data$stat_name %in% "df.residual" ~ "df for residuals",+ |
+
| 199 | +9x | +
+ .default = .data$stat_name+ |
+
| 200 | ++ |
+ )+ |
+
| 201 | ++ |
+ ) |>+ |
+
| 202 | +9x | +
+ cards::as_card() |>+ |
+
| 203 | +9x | +
+ cards::tidy_ard_column_order()+ |
+
| 204 | ++ |
+ }+ |
+
| 1 | ++ |
+ #' ARD Survey Chi-Square Test+ |
+
| 2 | ++ |
+ #'+ |
+
| 3 | ++ |
+ #' @description+ |
+
| 4 | ++ |
+ #' Analysis results data for survey Chi-Square test using [`survey::svychisq()`].+ |
+
| 5 | ++ |
+ #' Only two-way comparisons are supported.+ |
+
| 6 | ++ |
+ #'+ |
+
| 7 | ++ |
+ #' @param data (`survey.design`)\cr+ |
+
| 8 | ++ |
+ #' a survey design object often created with the \{survey\} package
+ |
+
| 9 | ++ |
+ #' @param by ([`tidy-select`][dplyr::dplyr_tidy_select])\cr+ |
+
| 10 | ++ |
+ #' column name to compare by.+ |
+
| 11 | ++ |
+ #' @param variables ([`tidy-select`][dplyr::dplyr_tidy_select])\cr+ |
+
| 12 | ++ |
+ #' column names to be compared. Independent tests will be computed for+ |
+
| 13 | ++ |
+ #' each variable.+ |
+
| 14 | ++ |
+ #' @param statistic (`character`)\cr+ |
+
| 15 | ++ |
+ #' statistic used to estimate Chisq p-value.+ |
+
| 16 | ++ |
+ #' Default is the Rao-Scott second-order correction ("F"). See [`survey::svychisq`]
+ |
+
| 17 | ++ |
+ #' for available statistics options.+ |
+
| 18 | ++ |
+ #' @param ... arguments passed to [`survey::svychisq()`].+ |
+
| 19 | ++ |
+ #'+ |
+
| 20 | ++ |
+ #' @return ARD data frame+ |
+
| 21 | ++ |
+ #' @export+ |
+
| 22 | ++ |
+ #'+ |
+
| 23 | ++ |
+ #' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = c("survey", "broom"), reference_pkg = "cardx"))
+ |
+
| 24 | ++ |
+ #' data(api, package = "survey")+ |
+
| 25 | ++ |
+ #' dclus1 <- survey::svydesign(id = ~dnum, weights = ~pw, data = apiclus1, fpc = ~fpc)+ |
+
| 26 | ++ |
+ #'+ |
+
| 27 | ++ |
+ #' ard_survey_svychisq(dclus1, variables = sch.wide, by = comp.imp, statistic = "F")+ |
+
| 28 | ++ |
+ ard_survey_svychisq <- function(data, by, variables, statistic = "F", ...) {
+ |
+
| 29 | +3x | +
+ set_cli_abort_call()+ |
+
| 30 | ++ | + + | +
| 31 | ++ |
+ # check installed packages ---------------------------------------------------+ |
+
| 32 | +3x | +
+ check_pkg_installed(c("survey", "broom"), reference_pkg = "cardx")
+ |
+
| 33 | ++ | + + | +
| 34 | ++ |
+ # check/process inputs -------------------------------------------------------+ |
+
| 35 | +3x | +
+ check_not_missing(data)+ |
+
| 36 | +3x | +
+ check_not_missing(variables)+ |
+
| 37 | +3x | +
+ check_not_missing(by)+ |
+
| 38 | +3x | +
+ check_class(data, cls = "survey.design")+ |
+
| 39 | +3x | +
+ cards::process_selectors(data[["variables"]], by = {{ by }}, variables = {{ variables }})
+ |
+
| 40 | +3x | +
+ check_scalar(by)+ |
+
| 41 | ++ | + + | +
| 42 | ++ |
+ # return empty ARD if no variables selected ----------------------------------+ |
+
| 43 | +3x | +
+ if (is_empty(variables)) {
+ |
+
| 44 | +! | +
+ return(dplyr::tibble() |> cards::as_card())+ |
+
| 45 | ++ |
+ }+ |
+
| 46 | ++ | + + | +
| 47 | ++ |
+ # build ARD ------------------------------------------------------------------+ |
+
| 48 | +3x | +
+ lapply(+ |
+
| 49 | +3x | +
+ variables,+ |
+
| 50 | +3x | +
+ function(variable) {
+ |
+
| 51 | +4x | +
+ cards::tidy_as_ard(+ |
+
| 52 | +4x | +
+ lst_tidy =+ |
+
| 53 | +4x | +
+ cards::eval_capture_conditions(+ |
+
| 54 | +4x | +
+ survey::svychisq(reformulate2(termlabels = c(variable, by)), design = data, statistic = statistic, ...) |>+ |
+
| 55 | +4x | +
+ broom::tidy()+ |
+
| 56 | ++ |
+ ),+ |
+
| 57 | +4x | +
+ tidy_result_names = c("statistic", "p.value", "ndf", "ddf", "method"),
+ |
+
| 58 | +4x | +
+ passed_args = dots_list(...),+ |
+
| 59 | +4x | +
+ lst_ard_columns = list(group1 = by, variable = variable, context = "survey_svychisq")+ |
+
| 60 | ++ |
+ ) |>+ |
+
| 61 | +4x | +
+ dplyr::mutate(+ |
+
| 62 | +4x | +
+ .after = "stat_name",+ |
+
| 63 | +4x | +
+ stat_label =+ |
+
| 64 | +4x | +
+ dplyr::case_when(+ |
+
| 65 | +4x | +
+ .data$stat_name %in% "statistic" ~ "Statistic",+ |
+
| 66 | +4x | +
+ .data$stat_name %in% "p.value" ~ "p-value",+ |
+
| 67 | +4x | +
+ .data$stat_name %in% "ndf" ~ "Nominator Degrees of Freedom",+ |
+
| 68 | +4x | +
+ .data$stat_name %in% "ddf" ~ "Denominator Degrees of Freedom",+ |
+
| 69 | +4x | +
+ TRUE ~ .data$stat_name,+ |
+
| 70 | ++ |
+ )+ |
+
| 71 | ++ |
+ )+ |
+
| 72 | ++ |
+ }+ |
+
| 73 | ++ |
+ ) |>+ |
+
| 74 | +3x | +
+ dplyr::bind_rows() |>+ |
+
| 75 | +3x | +
+ cards::as_card()+ |
+
| 76 | ++ |
+ }+ |
+
| 1 | ++ |
+ #' ARD Survival Estimates+ |
+
| 2 | ++ |
+ #'+ |
+
| 3 | ++ |
+ #' @description+ |
+
| 4 | ++ |
+ #' Analysis results data for survival quantiles and x-year survival estimates, extracted+ |
+
| 5 | ++ |
+ #' from a [survival::survfit()] model.+ |
+
| 6 | ++ |
+ #'+ |
+
| 7 | ++ |
+ #' @param x ([survival::survfit()])\cr+ |
+
| 8 | ++ |
+ #' a [survival::survfit()] object. See below for details.+ |
+
| 9 | ++ |
+ #' @param times (`numeric`)\cr+ |
+
| 10 | ++ |
+ #' a vector of times for which to return survival probabilities.+ |
+
| 11 | ++ |
+ #' @param probs (`numeric`)\cr+ |
+
| 12 | ++ |
+ #' a vector of probabilities with values in (0,1) specifying the survival quantiles to return.+ |
+
| 13 | ++ |
+ #' @param type (`string` or `NULL`)\cr+ |
+
| 14 | ++ |
+ #' type of statistic to report. Available for Kaplan-Meier time estimates only, otherwise `type`+ |
+
| 15 | ++ |
+ #' is ignored. Default is `NULL`.+ |
+
| 16 | ++ |
+ #' Must be one of the following:+ |
+
| 17 | ++ |
+ #' ```{r, echo = FALSE}
+ |
+
| 18 | ++ |
+ #' dplyr::tribble(+ |
+
| 19 | ++ |
+ #' ~type, ~transformation,+ |
+
| 20 | ++ |
+ #' '`"survival"`', '`x`',+ |
+
| 21 | ++ |
+ #' '`"risk"`', '`1 - x`',+ |
+
| 22 | ++ |
+ #' '`"cumhaz"`', '`-log(x)`',+ |
+
| 23 | ++ |
+ #' ) %>%+ |
+
| 24 | ++ |
+ #' knitr::kable()+ |
+
| 25 | ++ |
+ #' ```+ |
+
| 26 | ++ |
+ #'+ |
+
| 27 | ++ |
+ #' @return an ARD data frame of class 'card'+ |
+
| 28 | ++ |
+ #' @name ard_survival_survfit+ |
+
| 29 | ++ |
+ #'+ |
+
| 30 | ++ |
+ #' @details+ |
+
| 31 | ++ |
+ #' * Only one of either the `times` or `probs` parameters can be specified.+ |
+
| 32 | ++ |
+ #' * Times should be provided using the same scale as the time variable used to fit the provided+ |
+
| 33 | ++ |
+ #' survival fit model.+ |
+
| 34 | ++ |
+ #'+ |
+
| 35 | ++ |
+ #' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = c("survival", "broom", "ggsurvfit"), reference_pkg = "cardx"))
+ |
+
| 36 | ++ |
+ #' library(survival)+ |
+
| 37 | ++ |
+ #' library(ggsurvfit)+ |
+
| 38 | ++ |
+ #'+ |
+
| 39 | ++ |
+ #' survfit(Surv_CNSR(AVAL, CNSR) ~ TRTA, cards::ADTTE) |>+ |
+
| 40 | ++ |
+ #' ard_survival_survfit(times = c(60, 180))+ |
+
| 41 | ++ |
+ #'+ |
+
| 42 | ++ |
+ #' survfit(Surv_CNSR(AVAL, CNSR) ~ TRTA, cards::ADTTE) |>+ |
+
| 43 | ++ |
+ #' ard_survival_survfit(probs = c(0.25, 0.5, 0.75))+ |
+
| 44 | ++ |
+ #'+ |
+
| 45 | ++ |
+ #' # Competing Risks Example ---------------------------+ |
+
| 46 | ++ |
+ #' set.seed(1)+ |
+
| 47 | ++ |
+ #' ADTTE_MS <- cards::ADTTE %>%+ |
+
| 48 | ++ |
+ #' dplyr::mutate(+ |
+
| 49 | ++ |
+ #' CNSR = dplyr::case_when(+ |
+
| 50 | ++ |
+ #' CNSR == 0 ~ "censor",+ |
+
| 51 | ++ |
+ #' runif(dplyr::n()) < 0.5 ~ "death from cancer",+ |
+
| 52 | ++ |
+ #' TRUE ~ "death other causes"+ |
+
| 53 | ++ |
+ #' ) %>% factor()+ |
+
| 54 | ++ |
+ #' )+ |
+
| 55 | ++ |
+ #'+ |
+
| 56 | ++ |
+ #' survfit(Surv(AVAL, CNSR) ~ TRTA, data = ADTTE_MS) %>%+ |
+
| 57 | ++ |
+ #' ard_survival_survfit(times = c(60, 180))+ |
+
| 58 | ++ |
+ NULL+ |
+
| 59 | ++ | + + | +
| 60 | ++ |
+ #' @rdname ard_survival_survfit+ |
+
| 61 | ++ |
+ #' @export+ |
+
| 62 | ++ |
+ ard_survival_survfit <- function(x, times = NULL, probs = NULL, type = NULL) {
+ |
+
| 63 | +13x | +
+ set_cli_abort_call()+ |
+
| 64 | ++ | + + | +
| 65 | ++ |
+ # check installed packages ---------------------------------------------------+ |
+
| 66 | +13x | +
+ check_pkg_installed(c("survival", "broom"), reference_pkg = "cardx")
+ |
+
| 67 | ++ | + + | +
| 68 | ++ |
+ # check/process inputs -------------------------------------------------------+ |
+
| 69 | +13x | +
+ check_not_missing(x)+ |
+
| 70 | +13x | +
+ check_class(x, cls = "survfit")+ |
+
| 71 | +12x | +
+ if (inherits(x, "survfitcox")) {
+ |
+
| 72 | +1x | +
+ cli::cli_abort("Argument {.arg x} cannot be class {.cls survfitcox}.",
+ |
+
| 73 | +1x | +
+ call = get_cli_abort_call()+ |
+
| 74 | ++ |
+ )+ |
+
| 75 | ++ |
+ }+ |
+
| 76 | ++ | + + | +
| 77 | ++ |
+ # competing risks models cannot use the type argument+ |
+
| 78 | +11x | +
+ if (inherits(x, c("survfitms", "survfitcoxms")) && !is.null(type)) {
+ |
+
| 79 | +! | +
+ cli::cli_abort("Cannot use {.arg type} argument with {.code survfit} models with class {.cls {c('survfitms', 'survfitcoxms')}}.",
+ |
+
| 80 | +! | +
+ call = get_cli_abort_call()+ |
+
| 81 | ++ |
+ )+ |
+
| 82 | ++ |
+ }+ |
+
| 83 | +1x | +
+ if (!is.null(probs)) check_range(probs, c(0, 1))+ |
+
| 84 | +11x | +
+ if (sum(is.null(times), is.null(probs)) != 1) {
+ |
+
| 85 | +! | +
+ cli::cli_abort("One and only one of {.arg times} and {.arg probs} must be specified.")
+ |
+
| 86 | ++ |
+ }+ |
+
| 87 | ++ | + + | +
| 88 | ++ |
+ # for regular KM estimators, we allow the type argument+ |
+
| 89 | +11x | +
+ if (!inherits(x, "survfitms") && !is.null(type)) {
+ |
+
| 90 | +1x | +
+ type <- arg_match(type, values = c("survival", "risk", "cumhaz"))
+ |
+
| 91 | ++ |
+ }+ |
+
| 92 | ++ | + + | +
| 93 | ++ |
+ # cannot specify type arg when probs supplied+ |
+
| 94 | +11x | +
+ if (!is.null(probs) && !is.null(type)) {
+ |
+
| 95 | +! | +
+ cli::cli_abort("Cannot use {.arg type} argument when {.arg probs} argument specifed.",
+ |
+
| 96 | +! | +
+ call = get_cli_abort_call()+ |
+
| 97 | ++ |
+ )+ |
+
| 98 | ++ |
+ }+ |
+
| 99 | ++ | + + | +
| 100 | ++ |
+ # build ARD ------------------------------------------------------------------+ |
+
| 101 | +11x | +
+ est_type <- ifelse(is.null(probs), "times", "probs")+ |
+
| 102 | +11x | +
+ tidy_survfit <- switch(est_type,+ |
+
| 103 | +11x | +
+ "times" = .process_survfit_time(x, times, type %||% "survival"),+ |
+
| 104 | +11x | +
+ "probs" = .process_survfit_probs(x, probs)+ |
+
| 105 | ++ |
+ )+ |
+
| 106 | ++ | + + | +
| 107 | +11x | +
+ .format_survfit_results(tidy_survfit)+ |
+
| 108 | ++ |
+ }+ |
+
| 109 | ++ | + + | +
| 110 | ++ |
+ #' Process Survival Fit For Time Estimates+ |
+
| 111 | ++ |
+ #'+ |
+
| 112 | ++ |
+ #' @inheritParams cards::tidy_as_ard+ |
+
| 113 | ++ |
+ #' @inheritParams ard_survival_survfit+ |
+
| 114 | ++ |
+ #' @param start.time (`numeric`)\cr+ |
+
| 115 | ++ |
+ #' default starting time. See [survival::survfit0()] for more details.+ |
+
| 116 | ++ |
+ #'+ |
+
| 117 | ++ |
+ #' @return a `tibble`+ |
+
| 118 | ++ |
+ #'+ |
+
| 119 | ++ |
+ #' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = c("survival", "broom"), reference_pkg = "cardx"))
+ |
+
| 120 | ++ |
+ #' survival::survfit(survival::Surv(AVAL, CNSR) ~ TRTA, cards::ADTTE) |>+ |
+
| 121 | ++ |
+ #' cardx:::.process_survfit_time(times = c(60, 180), type = "risk")+ |
+
| 122 | ++ |
+ #'+ |
+
| 123 | ++ |
+ #' @keywords internal+ |
+
| 124 | ++ |
+ .process_survfit_time <- function(x, times, type, start.time = NULL) {
+ |
+
| 125 | ++ |
+ # add start time+ |
+
| 126 | +10x | +
+ min_time <- min(x$time)+ |
+
| 127 | +10x | +
+ if (is.null(start.time) && min_time < 0) {
+ |
+
| 128 | +! | +
+ cli::cli_inform(paste(+ |
+
| 129 | +! | +
+ "The {.arg start.time} argument has not been set and negative times have been observed. Please set start",
+ |
+
| 130 | +! | +
+ "time via the {.arg start.time} argument, otherwise the minimum observed time will be used by default."
+ |
+
| 131 | ++ |
+ ))+ |
+
| 132 | +! | +
+ start.time <- min_time+ |
+
| 133 | +10x | +
+ } else if (is.null(start.time)) {
+ |
+
| 134 | +10x | +
+ start.time <- 0+ |
+
| 135 | ++ |
+ }+ |
+
| 136 | +10x | +
+ x <- survival::survfit0(x, start.time) %>%+ |
+
| 137 | +10x | +
+ summary(times)+ |
+
| 138 | ++ | + + | +
| 139 | ++ |
+ # process competing risks/multi-state models+ |
+
| 140 | +10x | +
+ multi_state <- inherits(x, "summary.survfitms")+ |
+
| 141 | ++ | + + | +
| 142 | +10x | +
+ if (multi_state) {
+ |
+
| 143 | ++ |
+ # selecting state to show+ |
+
| 144 | +1x | +
+ state <- setdiff(unique(x$states), "(s0)")[[1]]+ |
+
| 145 | +1x | +
+ cli::cli_inform("Multi-state model detected. Showing probabilities into state '{state}'.")
+ |
+
| 146 | +1x | +
+ x$n.risk <- x$n.risk[, 1]+ |
+
| 147 | +1x | +
+ ms_cols <- c("pstate", "std.err", "upper", "lower")
+ |
+
| 148 | +1x | +
+ state_col <- which(colnames(x$pstate) == state)+ |
+
| 149 | +1x | +
+ x[ms_cols] <- lapply(x[ms_cols], function(m) m[, state_col])+ |
+
| 150 | +1x | +
+ x$surv <- x$pstate+ |
+
| 151 | ++ |
+ }+ |
+
| 152 | ++ | + + | +
| 153 | ++ |
+ # tidy survfit results+ |
+
| 154 | +10x | +
+ x_cols <- intersect(names(x), c("time", "n.risk", "surv", "std.err", "upper", "lower", "strata"))
+ |
+
| 155 | +10x | +
+ tidy_x <- data.frame(x[x_cols]) %>%+ |
+
| 156 | +10x | +
+ dplyr::rename(estimate = "surv", std.error = "std.err", conf.high = "upper", conf.low = "lower")+ |
+
| 157 | ++ | + + | +
| 158 | +10x | +
+ strat <- "strata" %in% names(tidy_x)+ |
+
| 159 | ++ | + + | +
| 160 | ++ |
+ # get requested estimates+ |
+
| 161 | +10x | +
+ df_stat <- tidy_x %>%+ |
+
| 162 | ++ |
+ # find max time+ |
+
| 163 | +10x | +
+ dplyr::group_by_at(., dplyr::vars(dplyr::any_of("strata"))) %>%
+ |
+
| 164 | +10x | +
+ dplyr::mutate(time_max = max(.data$time)) %>%+ |
+
| 165 | +10x | +
+ dplyr::ungroup() %>%+ |
+
| 166 | ++ |
+ # add requested timepoints+ |
+
| 167 | +10x | +
+ dplyr::full_join(+ |
+
| 168 | +10x | +
+ tidy_x %>%+ |
+
| 169 | +10x | +
+ dplyr::select(any_of("strata")) %>%
+ |
+
| 170 | +10x | +
+ dplyr::distinct() %>%+ |
+
| 171 | +10x | +
+ dplyr::mutate(+ |
+
| 172 | +10x | +
+ time = list(.env$times),+ |
+
| 173 | +10x | +
+ col_name = list(paste("stat", seq_len(length(.env$times)), sep = "_"))
+ |
+
| 174 | ++ |
+ ) %>%+ |
+
| 175 | +10x | +
+ tidyr::unnest(cols = c("time", "col_name")),
+ |
+
| 176 | +10x | +
+ by = unlist(intersect(c("strata", "time"), names(tidy_x)))
+ |
+
| 177 | ++ |
+ )+ |
+
| 178 | ++ | + + | +
| 179 | +10x | +
+ if (strat) {
+ |
+
| 180 | +9x | +
+ df_stat <- df_stat %>% dplyr::arrange(.data$strata)+ |
+
| 181 | ++ |
+ }+ |
+
| 182 | ++ | + + | +
| 183 | +10x | +
+ df_stat <- df_stat %>%+ |
+
| 184 | +10x | +
+ dplyr::arrange(.data$time) %>%+ |
+
| 185 | ++ |
+ # if user-specified time is after max time, make estimate NA+ |
+
| 186 | +10x | +
+ dplyr::mutate_at(+ |
+
| 187 | +10x | +
+ dplyr::vars("estimate", "conf.high", "conf.low"),
+ |
+
| 188 | +10x | +
+ ~ ifelse(.data$time > .data$time_max, NA_real_, .)+ |
+
| 189 | ++ |
+ ) %>%+ |
+
| 190 | +10x | +
+ dplyr::mutate(context = type) %>%+ |
+
| 191 | +10x | +
+ dplyr::select(!dplyr::any_of(c("time_max", "col_name")))
+ |
+
| 192 | ++ | + + | +
| 193 | ++ |
+ # convert estimates to requested type+ |
+
| 194 | +10x | +
+ if (type != "survival") {
+ |
+
| 195 | +1x | +
+ df_stat <- df_stat %>%+ |
+
| 196 | +1x | +
+ dplyr::mutate(dplyr::across(+ |
+
| 197 | +1x | +
+ any_of(c("estimate", "conf.low", "conf.high")),
+ |
+
| 198 | +1x | +
+ if (type == "cumhaz") ~ -log(.x) else ~ 1 - .x+ |
+
| 199 | ++ |
+ )) %>%+ |
+
| 200 | +1x | +
+ dplyr::rename(conf.low = "conf.high", conf.high = "conf.low")+ |
+
| 201 | ++ |
+ }+ |
+
| 202 | ++ | + + | +
| 203 | +10x | +
+ df_stat <- extract_multi_strata(x, df_stat)+ |
+
| 204 | ++ | + + | +
| 205 | +10x | +
+ df_stat+ |
+
| 206 | ++ |
+ }+ |
+
| 207 | ++ | + + | +
| 208 | ++ |
+ #' Process Survival Fit For Quantile Estimates+ |
+
| 209 | ++ |
+ #'+ |
+
| 210 | ++ |
+ #' @inheritParams cards::tidy_as_ard+ |
+
| 211 | ++ |
+ #' @inheritParams ard_survival_survfit+ |
+
| 212 | ++ |
+ #'+ |
+
| 213 | ++ |
+ #' @return a `tibble`+ |
+
| 214 | ++ |
+ #'+ |
+
| 215 | ++ |
+ #' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = "survival", reference_pkg = "cardx"))
+ |
+
| 216 | ++ |
+ #' survival::survfit(survival::Surv(AVAL, CNSR) ~ TRTA, cards::ADTTE) |>+ |
+
| 217 | ++ |
+ #' cardx:::.process_survfit_probs(probs = c(0.25, 0.75))+ |
+
| 218 | ++ |
+ #'+ |
+
| 219 | ++ |
+ #' @keywords internal+ |
+
| 220 | ++ |
+ .process_survfit_probs <- function(x, probs) {
+ |
+
| 221 | ++ |
+ # calculate survival quantiles and add estimates to df+ |
+
| 222 | +1x | +
+ df_stat <- map2(+ |
+
| 223 | +1x | +
+ probs,+ |
+
| 224 | +1x | +
+ seq_along(probs),+ |
+
| 225 | +1x | +
+ ~ stats::quantile(x, probs = .x) %>%+ |
+
| 226 | +1x | +
+ as.data.frame() %>%+ |
+
| 227 | +1x | +
+ set_names(c("estimate", "conf.low", "conf.high")) %>%
+ |
+
| 228 | +1x | +
+ dplyr::mutate(strata = row.names(.)) %>%+ |
+
| 229 | +1x | +
+ dplyr::select(dplyr::any_of(c("n.risk", "strata", "estimate", "std.error", "conf.low", "conf.high"))) %>%
+ |
+
| 230 | +1x | +
+ dplyr::mutate(prob = .x)+ |
+
| 231 | ++ |
+ ) %>%+ |
+
| 232 | +1x | +
+ dplyr::bind_rows() %>%+ |
+
| 233 | +1x | +
+ `rownames<-`(NULL) %>%+ |
+
| 234 | +1x | +
+ dplyr::mutate(context = "survival_survfit") %>%+ |
+
| 235 | +1x | +
+ dplyr::as_tibble()+ |
+
| 236 | ++ | + + | +
| 237 | +! | +
+ if (length(x$n) == 1) df_stat <- df_stat %>% dplyr::select(-"strata")+ |
+
| 238 | ++ | + + | +
| 239 | +1x | +
+ df_stat <- extract_multi_strata(x, df_stat)+ |
+
| 240 | ++ | + + | +
| 241 | +1x | +
+ df_stat+ |
+
| 242 | ++ |
+ }+ |
+
| 243 | ++ | + + | +
| 244 | ++ |
+ # process multiple stratifying variables+ |
+
| 245 | ++ |
+ extract_multi_strata <- function(x, df_stat) {
+ |
+
| 246 | +11x | +
+ x_terms <- attr(stats::terms(stats::as.formula(x$call$formula)), "term.labels")+ |
+
| 247 | +11x | +
+ x_terms <- gsub(".*\\(", "", gsub("\\)", "", x_terms))
+ |
+
| 248 | +11x | +
+ if (length(x_terms) > 1) {
+ |
+
| 249 | +3x | +
+ strata_lvls <- data.frame()+ |
+
| 250 | ++ | + + | +
| 251 | +3x | +
+ for (i in df_stat[["strata"]]) {
+ |
+
| 252 | +42x | +
+ i <- gsub(".*\\(", "", gsub("\\)", "", i))
+ |
+
| 253 | +42x | +
+ terms_str <- strsplit(i, paste(c(paste0(x_terms, "="), paste0(", ", x_terms, "=")), collapse = "|"))[[1]]
+ |
+
| 254 | +42x | +
+ s_lvl <- terms_str[nchar(terms_str) > 0]+ |
+
| 255 | +42x | +
+ strata_lvls <- rbind(strata_lvls, s_lvl)+ |
+
| 256 | ++ |
+ }+ |
+
| 257 | +3x | +
+ if (nrow(strata_lvls) > 0) {
+ |
+
| 258 | +3x | +
+ strata_lvls <- cbind(strata_lvls, t(x_terms))+ |
+
| 259 | +3x | +
+ names(strata_lvls) <- c(+ |
+
| 260 | +3x | +
+ t(sapply(seq_along(x_terms), function(i) c(paste0("group", i, "_level"), paste0("group", i))))
+ |
+
| 261 | ++ |
+ )+ |
+
| 262 | +3x | +
+ df_stat <- cbind(df_stat, strata_lvls) %>%+ |
+
| 263 | +3x | +
+ dplyr::select(-"strata")+ |
+
| 264 | ++ |
+ }+ |
+
| 265 | ++ |
+ }+ |
+
| 266 | +11x | +
+ df_stat+ |
+
| 267 | ++ |
+ }+ |
+
| 268 | ++ | + + | +
| 269 | ++ |
+ #' Convert Tidied Survival Fit to ARD+ |
+
| 270 | ++ |
+ #'+ |
+
| 271 | ++ |
+ #' @inheritParams cards::tidy_as_ard+ |
+
| 272 | ++ |
+ #'+ |
+
| 273 | ++ |
+ #' @return an ARD data frame of class 'card'+ |
+
| 274 | ++ |
+ #'+ |
+
| 275 | ++ |
+ #' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = c("survival", "broom"), reference_pkg = "cardx"))
+ |
+
| 276 | ++ |
+ #' cardx:::.format_survfit_results(+ |
+
| 277 | ++ |
+ #' broom::tidy(survival::survfit(survival::Surv(AVAL, CNSR) ~ TRTA, cards::ADTTE))+ |
+
| 278 | ++ |
+ #' )+ |
+
| 279 | ++ |
+ #'+ |
+
| 280 | ++ |
+ #' @keywords internal+ |
+
| 281 | ++ |
+ .format_survfit_results <- function(tidy_survfit) {
+ |
+
| 282 | +11x | +
+ est <- if ("time" %in% names(tidy_survfit)) "time" else "prob"
+ |
+
| 283 | ++ | + + | +
| 284 | +11x | +
+ ret <- tidy_survfit %>%+ |
+
| 285 | +11x | +
+ dplyr::mutate(dplyr::across(+ |
+
| 286 | +11x | +
+ dplyr::any_of(c("n.risk", "estimate", "std.error", "conf.high", "conf.low", "time", "prob")), ~ as.list(.)
+ |
+
| 287 | ++ |
+ )) %>%+ |
+
| 288 | +11x | +
+ tidyr::pivot_longer(+ |
+
| 289 | +11x | +
+ cols = dplyr::any_of(c("n.risk", "estimate", "std.error", "conf.high", "conf.low")),
+ |
+
| 290 | +11x | +
+ names_to = "stat_name",+ |
+
| 291 | +11x | +
+ values_to = "stat"+ |
+
| 292 | ++ |
+ ) %>%+ |
+
| 293 | +11x | +
+ dplyr::mutate(+ |
+
| 294 | +11x | +
+ variable = est,+ |
+
| 295 | +11x | +
+ variable_level = .data[[est]]+ |
+
| 296 | ++ |
+ ) %>%+ |
+
| 297 | +11x | +
+ dplyr::select(-all_of(est))+ |
+
| 298 | ++ | + + | +
| 299 | +11x | +
+ if ("strata" %in% names(ret)) {
+ |
+
| 300 | +7x | +
+ ret <- ret %>%+ |
+
| 301 | +7x | +
+ tidyr::separate_wider_delim("strata", "=", names = c("group1", "group1_level"))
+ |
+
| 302 | ++ |
+ }+ |
+
| 303 | ++ | + + | +
| 304 | +11x | +
+ ret %>%+ |
+
| 305 | +11x | +
+ dplyr::left_join(+ |
+
| 306 | +11x | +
+ .df_survfit_stat_labels(),+ |
+
| 307 | +11x | +
+ by = "stat_name"+ |
+
| 308 | ++ |
+ ) %>%+ |
+
| 309 | +11x | +
+ dplyr::mutate(+ |
+
| 310 | +11x | +
+ fmt_fn = lapply(+ |
+
| 311 | +11x | +
+ .data$stat,+ |
+
| 312 | +11x | +
+ function(x) {
+ |
+
| 313 | +398x | +
+ switch(is.integer(x),+ |
+
| 314 | +398x | +
+ 0L+ |
+
| 315 | +398x | +
+ ) %||% switch(is.numeric(x),+ |
+
| 316 | +398x | +
+ 1L+ |
+
| 317 | ++ |
+ )+ |
+
| 318 | ++ |
+ }+ |
+
| 319 | ++ |
+ ),+ |
+
| 320 | +11x | +
+ stat_label = dplyr::coalesce(.data$stat_label, .data$stat_name)+ |
+
| 321 | ++ |
+ ) %>%+ |
+
| 322 | +11x | +
+ dplyr::mutate(dplyr::across(matches("group[0-9]*_level"), ~ as.list(as.factor(.x)))) %>%
+ |
+
| 323 | +11x | +
+ dplyr::mutate(+ |
+
| 324 | +11x | +
+ warning = list(NULL),+ |
+
| 325 | +11x | +
+ error = list(NULL)+ |
+
| 326 | ++ |
+ ) %>%+ |
+
| 327 | +11x | +
+ cards::as_card() %>%+ |
+
| 328 | +11x | +
+ cards::tidy_ard_column_order() %>%+ |
+
| 329 | +11x | +
+ cards::tidy_ard_row_order()+ |
+
| 330 | ++ |
+ }+ |
+
| 331 | ++ | + + | +
| 332 | ++ |
+ .df_survfit_stat_labels <- function() {
+ |
+
| 333 | +11x | +
+ dplyr::tribble(+ |
+
| 334 | +11x | +
+ ~stat_name, ~stat_label,+ |
+
| 335 | +11x | +
+ "n.risk", "Number of Subjects at Risk",+ |
+
| 336 | +11x | +
+ "estimate", "Survival Probability",+ |
+
| 337 | +11x | +
+ "std.error", "Standard Error (untransformed)",+ |
+
| 338 | +11x | +
+ "conf.low", "CI Lower Bound",+ |
+
| 339 | +11x | +
+ "conf.high", "CI Upper Bound",+ |
+
| 340 | +11x | +
+ "conf.level", "CI Confidence Level",+ |
+
| 341 | +11x | +
+ "prob", "Quantile",+ |
+
| 342 | +11x | +
+ "time", "Time"+ |
+
| 343 | ++ |
+ )+ |
+
| 344 | ++ |
+ }+ |
+
| 1 | ++ |
+ #' ARD Wilcoxon Rank-Sum Test+ |
+
| 2 | ++ |
+ #'+ |
+
| 3 | ++ |
+ #' @description+ |
+
| 4 | ++ |
+ #' Analysis results data for paired and non-paired Wilcoxon Rank-Sum tests.+ |
+
| 5 | ++ |
+ #'+ |
+
| 6 | ++ |
+ #' @param data (`data.frame`)\cr+ |
+
| 7 | ++ |
+ #' a data frame. See below for details.+ |
+
| 8 | ++ |
+ #' @param by ([`tidy-select`][dplyr::dplyr_tidy_select])\cr+ |
+
| 9 | ++ |
+ #' optional column name to compare by.+ |
+
| 10 | ++ |
+ #' @param variables ([`tidy-select`][dplyr::dplyr_tidy_select])\cr+ |
+
| 11 | ++ |
+ #' column names to be compared. Independent tests will be computed for+ |
+
| 12 | ++ |
+ #' each variable.+ |
+
| 13 | ++ |
+ #' @param id ([`tidy-select`][dplyr::dplyr_tidy_select])\cr+ |
+
| 14 | ++ |
+ #' column name of the subject or participant ID.+ |
+
| 15 | ++ |
+ #' @param conf.level (scalar `numeric`)\cr+ |
+
| 16 | ++ |
+ #' confidence level for confidence interval. Default is `0.95`.+ |
+
| 17 | ++ |
+ #' @param ... arguments passed to `wilcox.test(...)`+ |
+
| 18 | ++ |
+ #'+ |
+
| 19 | ++ |
+ #' @return ARD data frame+ |
+
| 20 | ++ |
+ #' @name ard_stats_wilcox_test+ |
+
| 21 | ++ |
+ #'+ |
+
| 22 | ++ |
+ #' @details+ |
+
| 23 | ++ |
+ #' For the `ard_stats_wilcox_test()` function, the data is expected to be one row per subject.+ |
+
| 24 | ++ |
+ #' The data is passed as `wilcox.test(data[[variable]] ~ data[[by]], paired = FALSE, ...)`.+ |
+
| 25 | ++ |
+ #'+ |
+
| 26 | ++ |
+ #' For the `ard_stats_paired_wilcox_test()` function, the data is expected to be one row+ |
+
| 27 | ++ |
+ #' per subject per by level. Before the test is calculated, the data are+ |
+
| 28 | ++ |
+ #' reshaped to a wide format to be one row per subject.+ |
+
| 29 | ++ |
+ #' The data are then passed as+ |
+
| 30 | ++ |
+ #' `wilcox.test(x = data_wide[[<by level 1>]], y = data_wide[[<by level 2>]], paired = TRUE, ...)`.+ |
+
| 31 | ++ |
+ #'+ |
+
| 32 | ++ |
+ #' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = "broom", reference_pkg = "cardx"))
+ |
+
| 33 | ++ |
+ #' cards::ADSL |>+ |
+
| 34 | ++ |
+ #' dplyr::filter(ARM %in% c("Placebo", "Xanomeline High Dose")) |>
+ |
+
| 35 | ++ |
+ #' ard_stats_wilcox_test(by = "ARM", variables = "AGE")+ |
+
| 36 | ++ |
+ #'+ |
+
| 37 | ++ |
+ #' # constructing a paired data set,+ |
+
| 38 | ++ |
+ #' # where patients receive both treatments+ |
+
| 39 | ++ |
+ #' cards::ADSL[c("ARM", "AGE")] |>
+ |
+
| 40 | ++ |
+ #' dplyr::filter(ARM %in% c("Placebo", "Xanomeline High Dose")) |>
+ |
+
| 41 | ++ |
+ #' dplyr::mutate(.by = ARM, USUBJID = dplyr::row_number()) |>+ |
+
| 42 | ++ |
+ #' dplyr::arrange(USUBJID, ARM) |>+ |
+
| 43 | ++ |
+ #' ard_stats_paired_wilcox_test(by = ARM, variables = AGE, id = USUBJID)+ |
+
| 44 | ++ |
+ NULL+ |
+
| 45 | ++ | + + | +
| 46 | ++ |
+ #' @rdname ard_stats_wilcox_test+ |
+
| 47 | ++ |
+ #' @export+ |
+
| 48 | ++ |
+ ard_stats_wilcox_test <- function(data, variables, by = NULL, conf.level = 0.95, ...) {
+ |
+
| 49 | +6x | +
+ set_cli_abort_call()+ |
+
| 50 | ++ | + + | +
| 51 | ++ |
+ # check installed packages ---------------------------------------------------+ |
+
| 52 | +6x | +
+ check_pkg_installed("broom", reference_pkg = "cardx")
+ |
+
| 53 | ++ | + + | +
| 54 | ++ |
+ # check/process inputs -------------------------------------------------------+ |
+
| 55 | +6x | +
+ check_not_missing(data)+ |
+
| 56 | +6x | +
+ check_not_missing(variables)+ |
+
| 57 | +6x | +
+ check_data_frame(data)+ |
+
| 58 | +6x | +
+ data <- dplyr::ungroup(data)+ |
+
| 59 | +6x | +
+ cards::process_selectors(data, by = {{ by }}, variables = {{ variables }})
+ |
+
| 60 | +6x | +
+ check_scalar(by, allow_empty = TRUE)+ |
+
| 61 | +6x | +
+ check_range(conf.level, range = c(0, 1))+ |
+
| 62 | ++ | + + | +
| 63 | ++ |
+ # return empty ARD if no variables selected ----------------------------------+ |
+
| 64 | +6x | +
+ if (is_empty(variables)) {
+ |
+
| 65 | +! | +
+ return(dplyr::tibble() |> cards::as_card())+ |
+
| 66 | ++ |
+ }+ |
+
| 67 | ++ | + + | +
| 68 | ++ |
+ # build ARD ------------------------------------------------------------------+ |
+
| 69 | +6x | +
+ lapply(+ |
+
| 70 | +6x | +
+ variables,+ |
+
| 71 | +6x | +
+ function(variable) {
+ |
+
| 72 | +7x | +
+ .format_wilcoxtest_results(+ |
+
| 73 | +7x | +
+ by = by,+ |
+
| 74 | +7x | +
+ variable = variable,+ |
+
| 75 | +7x | +
+ lst_tidy =+ |
+
| 76 | ++ |
+ # styler: off+ |
+
| 77 | +7x | +
+ cards::eval_capture_conditions(+ |
+
| 78 | +7x | +
+ if (!is_empty(by)) {
+ |
+
| 79 | +6x | +
+ stats::wilcox.test(data[[variable]] ~ data[[by]], conf.level = conf.level, ...) |>+ |
+
| 80 | +6x | +
+ broom::tidy()+ |
+
| 81 | ++ |
+ }+ |
+
| 82 | ++ |
+ else {
+ |
+
| 83 | +1x | +
+ stats::wilcox.test(data[[variable]], ...) |>+ |
+
| 84 | +1x | +
+ broom::tidy()+ |
+
| 85 | ++ |
+ }+ |
+
| 86 | ++ |
+ ),+ |
+
| 87 | ++ |
+ # styler: on+ |
+
| 88 | +7x | +
+ paired = FALSE,+ |
+
| 89 | ++ |
+ ...+ |
+
| 90 | ++ |
+ )+ |
+
| 91 | ++ |
+ }+ |
+
| 92 | ++ |
+ ) |>+ |
+
| 93 | +6x | +
+ dplyr::bind_rows()+ |
+
| 94 | ++ |
+ }+ |
+
| 95 | ++ | + + | +
| 96 | ++ |
+ #' @rdname ard_stats_wilcox_test+ |
+
| 97 | ++ |
+ #' @export+ |
+
| 98 | ++ |
+ ard_stats_paired_wilcox_test <- function(data, by, variables, id, conf.level = 0.95, ...) {
+ |
+
| 99 | +2x | +
+ set_cli_abort_call()+ |
+
| 100 | ++ | + + | +
| 101 | ++ |
+ # check installed packages ---------------------------------------------------+ |
+
| 102 | +2x | +
+ check_pkg_installed("broom", reference_pkg = "cardx")
+ |
+
| 103 | ++ | + + | +
| 104 | ++ |
+ # check/process inputs -------------------------------------------------------+ |
+
| 105 | +2x | +
+ check_not_missing(data)+ |
+
| 106 | +2x | +
+ check_not_missing(variables)+ |
+
| 107 | +2x | +
+ check_not_missing(by)+ |
+
| 108 | +2x | +
+ check_not_missing(id)+ |
+
| 109 | +2x | +
+ check_data_frame(data)+ |
+
| 110 | +2x | +
+ data <- dplyr::ungroup(data)+ |
+
| 111 | +2x | +
+ cards::process_selectors(data, by = {{ by }}, variables = {{ variables }}, id = {{ id }})
+ |
+
| 112 | +2x | +
+ check_scalar(by)+ |
+
| 113 | +2x | +
+ check_scalar(id)+ |
+
| 114 | ++ | + + | +
| 115 | ++ |
+ # return empty ARD if no variables selected ----------------------------------+ |
+
| 116 | +2x | +
+ if (is_empty(variables)) {
+ |
+
| 117 | +! | +
+ return(dplyr::tibble() |> cards::as_card())+ |
+
| 118 | ++ |
+ }+ |
+
| 119 | ++ | + + | +
| 120 | ++ |
+ # build ARD ------------------------------------------------------------------+ |
+
| 121 | +2x | +
+ lapply(+ |
+
| 122 | +2x | +
+ variables,+ |
+
| 123 | +2x | +
+ function(variable) {
+ |
+
| 124 | +2x | +
+ .format_wilcoxtest_results(+ |
+
| 125 | +2x | +
+ by = by,+ |
+
| 126 | +2x | +
+ variable = variable,+ |
+
| 127 | +2x | +
+ lst_tidy =+ |
+
| 128 | +2x | +
+ cards::eval_capture_conditions({
+ |
+
| 129 | ++ |
+ # adding this reshape inside the eval, so if there is an error it's captured in the ARD object+ |
+
| 130 | +2x | +
+ data_wide <- .paired_data_pivot_wider(data, by = by, variable = variable, id = id)+ |
+
| 131 | ++ |
+ # perform paired wilcox test+ |
+
| 132 | +1x | +
+ stats::wilcox.test(x = data_wide[["by1"]], y = data_wide[["by2"]], paired = TRUE, conf.level = conf.level, ...) |>+ |
+
| 133 | +1x | +
+ broom::tidy()+ |
+
| 134 | ++ |
+ }),+ |
+
| 135 | +2x | +
+ paired = TRUE,+ |
+
| 136 | ++ |
+ ...+ |
+
| 137 | ++ |
+ )+ |
+
| 138 | ++ |
+ }+ |
+
| 139 | ++ |
+ ) |>+ |
+
| 140 | +2x | +
+ dplyr::bind_rows()+ |
+
| 141 | ++ |
+ }+ |
+
| 142 | ++ | + + | +
| 143 | ++ | + + | +
| 144 | ++ |
+ #' Convert Wilcoxon test to ARD+ |
+
| 145 | ++ |
+ #'+ |
+
| 146 | ++ |
+ #' @inheritParams cards::tidy_as_ard+ |
+
| 147 | ++ |
+ #' @inheritParams stats::wilcox.test+ |
+
| 148 | ++ |
+ #' @param by (`string`)\cr by column name+ |
+
| 149 | ++ |
+ #' @param variable (`string`)\cr variable column name+ |
+
| 150 | ++ |
+ #' @param ... passed to `stats::wilcox.test(...)`+ |
+
| 151 | ++ |
+ #'+ |
+
| 152 | ++ |
+ #' @return ARD data frame+ |
+
| 153 | ++ |
+ #'+ |
+
| 154 | ++ |
+ #' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = "broom", reference_pkg = "cardx"))
+ |
+
| 155 | ++ |
+ #' # Pre-processing ADSL to have grouping factor (ARM here) with 2 levels+ |
+
| 156 | ++ |
+ #' ADSL <- cards::ADSL |>+ |
+
| 157 | ++ |
+ #' dplyr::filter(ARM %in% c("Placebo", "Xanomeline High Dose")) |>
+ |
+
| 158 | ++ |
+ #' ard_stats_wilcox_test(by = "ARM", variables = "AGE")+ |
+
| 159 | ++ |
+ #'+ |
+
| 160 | ++ |
+ #' cardx:::.format_wilcoxtest_results(+ |
+
| 161 | ++ |
+ #' by = "ARM",+ |
+
| 162 | ++ |
+ #' variable = "AGE",+ |
+
| 163 | ++ |
+ #' paired = FALSE,+ |
+
| 164 | ++ |
+ #' lst_tidy =+ |
+
| 165 | ++ |
+ #' cards::eval_capture_conditions(+ |
+
| 166 | ++ |
+ #' stats::wilcox.test(ADSL[["AGE"]] ~ ADSL[["ARM"]], paired = FALSE) |>+ |
+
| 167 | ++ |
+ #' broom::tidy()+ |
+
| 168 | ++ |
+ #' )+ |
+
| 169 | ++ |
+ #' )+ |
+
| 170 | ++ |
+ #'+ |
+
| 171 | ++ |
+ #' @keywords internal+ |
+
| 172 | ++ |
+ .format_wilcoxtest_results <- function(by = NULL, variable, lst_tidy, paired, ...) {
+ |
+
| 173 | ++ |
+ # build ARD ------------------------------------------------------------------+ |
+
| 174 | +9x | +
+ ret <-+ |
+
| 175 | +9x | +
+ cards::tidy_as_ard(+ |
+
| 176 | +9x | +
+ lst_tidy = lst_tidy,+ |
+
| 177 | +9x | +
+ tidy_result_names = c("statistic", "p.value", "method", "alternative"),
+ |
+
| 178 | +9x | +
+ fun_args_to_record = c(+ |
+
| 179 | +9x | +
+ "mu", "paired", "exact", "correct", "conf.int",+ |
+
| 180 | +9x | +
+ "conf.level", "tol.root", "digits.rank"+ |
+
| 181 | ++ |
+ ),+ |
+
| 182 | +9x | +
+ formals = formals(asNamespace("stats")[["wilcox.test.default"]]),
+ |
+
| 183 | +9x | +
+ passed_args = c(list(paired = paired), dots_list(...)),+ |
+
| 184 | +9x | +
+ lst_ard_columns = list(variable = variable, context = "stats_wilcox_test")+ |
+
| 185 | ++ |
+ )+ |
+
| 186 | ++ | + + | +
| 187 | +9x | +
+ if (!is_empty(by)) {
+ |
+
| 188 | +8x | +
+ ret <- ret |>+ |
+
| 189 | +8x | +
+ dplyr::mutate(group1 = by)+ |
+
| 190 | ++ |
+ }+ |
+
| 191 | ++ | + + | +
| 192 | ++ |
+ # add the stat label ---------------------------------------------------------+ |
+
| 193 | +9x | +
+ ret |>+ |
+
| 194 | +9x | +
+ dplyr::left_join(+ |
+
| 195 | +9x | +
+ .df_wilcoxtest_stat_labels(by),+ |
+
| 196 | +9x | +
+ by = "stat_name"+ |
+
| 197 | ++ |
+ ) |>+ |
+
| 198 | +9x | +
+ dplyr::mutate(stat_label = dplyr::coalesce(.data$stat_label, .data$stat_name)) |>+ |
+
| 199 | +9x | +
+ cards::as_card() |>+ |
+
| 200 | +9x | +
+ cards::tidy_ard_column_order()+ |
+
| 201 | ++ |
+ }+ |
+
| 202 | ++ | + + | +
| 203 | ++ | + + | +
| 204 | ++ |
+ .df_wilcoxtest_stat_labels <- function(by = NULL) {
+ |
+
| 205 | +9x | +
+ dplyr::tribble(+ |
+
| 206 | +9x | +
+ ~stat_name, ~stat_label,+ |
+
| 207 | +9x | +
+ "statistic", ifelse(is.null(by), "V Statistic", "X-squared Statistic"),+ |
+
| 208 | +9x | +
+ "parameter", "Degrees of Freedom",+ |
+
| 209 | +9x | +
+ "estimate", "Median of the Difference",+ |
+
| 210 | +9x | +
+ "p.value", "p-value",+ |
+
| 211 | +9x | +
+ "conf.low", "CI Lower Bound",+ |
+
| 212 | +9x | +
+ "conf.high", "CI Upper Bound",+ |
+
| 213 | +9x | +
+ "paired", "Paired test",+ |
+
| 214 | +9x | +
+ "conf.level", "CI Confidence Level",+ |
+
| 215 | ++ |
+ )+ |
+
| 216 | ++ |
+ }+ |
+
| 1 | ++ |
+ #' ARD Cohen's D Test+ |
+
| 2 | ++ |
+ #'+ |
+
| 3 | ++ |
+ #' @description+ |
+
| 4 | ++ |
+ #' Analysis results data for paired and non-paired Cohen's D Effect Size Test+ |
+
| 5 | ++ |
+ #' using [`effectsize::cohens_d()`].+ |
+
| 6 | ++ |
+ #'+ |
+
| 7 | ++ |
+ #' @param data (`data.frame`)\cr+ |
+
| 8 | ++ |
+ #' a data frame. See below for details.+ |
+
| 9 | ++ |
+ #' @param by ([`tidy-select`][dplyr::dplyr_tidy_select])\cr+ |
+
| 10 | ++ |
+ #' column name to compare by. Must be a categorical variable with exactly two levels.+ |
+
| 11 | ++ |
+ #' @param variables ([`tidy-select`][dplyr::dplyr_tidy_select])\cr+ |
+
| 12 | ++ |
+ #' column names to be compared. Must be a continuous variables.+ |
+
| 13 | ++ |
+ #' Independent tests will be run for each variable.+ |
+
| 14 | ++ |
+ #' @param id ([`tidy-select`][dplyr::dplyr_tidy_select])\cr+ |
+
| 15 | ++ |
+ #' column name of the subject or participant ID+ |
+
| 16 | ++ |
+ #' @param conf.level (scalar `numeric`)\cr+ |
+
| 17 | ++ |
+ #' confidence level for confidence interval. Default is `0.95`.+ |
+
| 18 | ++ |
+ #' @param ... arguments passed to `effectsize::cohens_d(...)`+ |
+
| 19 | ++ |
+ #'+ |
+
| 20 | ++ |
+ #' @return ARD data frame+ |
+
| 21 | ++ |
+ #' @name ard_effectsize_cohens_d+ |
+
| 22 | ++ |
+ #'+ |
+
| 23 | ++ |
+ #' @details+ |
+
| 24 | ++ |
+ #' For the `ard_effectsize_cohens_d()` function, the data is expected to be one row per subject.+ |
+
| 25 | ++ |
+ #' The data is passed as `effectsize::cohens_d(data[[variable]]~data[[by]], data, paired = FALSE, ...)`.+ |
+
| 26 | ++ |
+ #'+ |
+
| 27 | ++ |
+ #' For the `ard_effectsize_paired_cohens_d()` function, the data is expected to be one row+ |
+
| 28 | ++ |
+ #' per subject per by level. Before the effect size is calculated, the data are+ |
+
| 29 | ++ |
+ #' reshaped to a wide format to be one row per subject.+ |
+
| 30 | ++ |
+ #' The data are then passed as+ |
+
| 31 | ++ |
+ #' `effectsize::cohens_d(x = data_wide[[<by level 1>]], y = data_wide[[<by level 2>]], paired = TRUE, ...)`.+ |
+
| 32 | ++ |
+ #'+ |
+
| 33 | ++ |
+ #' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = c("effectsize", "parameters"), reference_pkg = "cardx"))
+ |
+
| 34 | ++ |
+ #' cards::ADSL |>+ |
+
| 35 | ++ |
+ #' dplyr::filter(ARM %in% c("Placebo", "Xanomeline High Dose")) |>
+ |
+
| 36 | ++ |
+ #' ard_effectsize_cohens_d(by = ARM, variables = AGE)+ |
+
| 37 | ++ |
+ #'+ |
+
| 38 | ++ |
+ #' # constructing a paired data set,+ |
+
| 39 | ++ |
+ #' # where patients receive both treatments+ |
+
| 40 | ++ |
+ #' cards::ADSL[c("ARM", "AGE")] |>
+ |
+
| 41 | ++ |
+ #' dplyr::filter(ARM %in% c("Placebo", "Xanomeline High Dose")) |>
+ |
+
| 42 | ++ |
+ #' dplyr::mutate(.by = ARM, USUBJID = dplyr::row_number()) |>+ |
+
| 43 | ++ |
+ #' dplyr::arrange(USUBJID, ARM) |>+ |
+
| 44 | ++ |
+ #' dplyr::group_by(USUBJID) |>+ |
+
| 45 | ++ |
+ #' dplyr::filter(dplyr::n() > 1) |>+ |
+
| 46 | ++ |
+ #' ard_effectsize_paired_cohens_d(by = ARM, variables = AGE, id = USUBJID)+ |
+
| 47 | ++ |
+ NULL+ |
+
| 48 | ++ | + + | +
| 49 | ++ |
+ #' @rdname ard_effectsize_cohens_d+ |
+
| 50 | ++ |
+ #' @export+ |
+
| 51 | ++ |
+ ard_effectsize_cohens_d <- function(data, by, variables, conf.level = 0.95, ...) {
+ |
+
| 52 | +4x | +
+ set_cli_abort_call()+ |
+
| 53 | ++ | + + | +
| 54 | ++ |
+ # check installed packages ---------------------------------------------------+ |
+
| 55 | +4x | +
+ check_pkg_installed(c("effectsize", "parameters"), reference_pkg = "cardx")
+ |
+
| 56 | ++ | + + | +
| 57 | ++ |
+ # check/process inputs -------------------------------------------------------+ |
+
| 58 | +4x | +
+ check_not_missing(data)+ |
+
| 59 | +4x | +
+ check_not_missing(variables)+ |
+
| 60 | +4x | +
+ check_not_missing(by)+ |
+
| 61 | +4x | +
+ check_data_frame(data)+ |
+
| 62 | +4x | +
+ data <- dplyr::ungroup(data)+ |
+
| 63 | +4x | +
+ cards::process_selectors(data, by = {{ by }}, variables = {{ variables }})
+ |
+
| 64 | +4x | +
+ check_scalar(by)+ |
+
| 65 | +4x | +
+ check_range(conf.level, range = c(0, 1))+ |
+
| 66 | ++ | + + | +
| 67 | ++ |
+ # return empty ARD if no variables selected ----------------------------------+ |
+
| 68 | +4x | +
+ if (is_empty(variables)) {
+ |
+
| 69 | +! | +
+ return(dplyr::tibble() |> cards::as_card())+ |
+
| 70 | ++ |
+ }+ |
+
| 71 | ++ | + + | +
| 72 | ++ |
+ # build ARD ------------------------------------------------------------------+ |
+
| 73 | +4x | +
+ lapply(+ |
+
| 74 | +4x | +
+ variables,+ |
+
| 75 | +4x | +
+ function(variable) {
+ |
+
| 76 | +5x | +
+ .format_cohens_d_results(+ |
+
| 77 | +5x | +
+ by = by,+ |
+
| 78 | +5x | +
+ variable = variable,+ |
+
| 79 | +5x | +
+ lst_tidy =+ |
+
| 80 | +5x | +
+ cards::eval_capture_conditions(+ |
+
| 81 | +5x | +
+ effectsize::cohens_d(+ |
+
| 82 | +5x | +
+ reformulate2(by, response = variable),+ |
+
| 83 | +5x | +
+ data = data |> tidyr::drop_na(all_of(c(by, variable))),+ |
+
| 84 | +5x | +
+ paired = FALSE,+ |
+
| 85 | +5x | +
+ ci = conf.level,+ |
+
| 86 | ++ |
+ ...+ |
+
| 87 | ++ |
+ ) |>+ |
+
| 88 | +5x | +
+ parameters::standardize_names(style = "broom") |>+ |
+
| 89 | +5x | +
+ dplyr::mutate(method = "Cohen's D")+ |
+
| 90 | ++ |
+ ),+ |
+
| 91 | +5x | +
+ paired = FALSE,+ |
+
| 92 | ++ |
+ ...+ |
+
| 93 | ++ |
+ )+ |
+
| 94 | ++ |
+ }+ |
+
| 95 | ++ |
+ ) |>+ |
+
| 96 | +4x | +
+ dplyr::bind_rows()+ |
+
| 97 | ++ |
+ }+ |
+
| 98 | ++ | + + | +
| 99 | ++ | + + | +
| 100 | ++ |
+ #' @rdname ard_effectsize_cohens_d+ |
+
| 101 | ++ |
+ #' @export+ |
+
| 102 | ++ |
+ ard_effectsize_paired_cohens_d <- function(data, by, variables, id, conf.level = 0.95, ...) {
+ |
+
| 103 | +3x | +
+ set_cli_abort_call()+ |
+
| 104 | ++ | + + | +
| 105 | ++ |
+ # check installed packages ---------------------------------------------------+ |
+
| 106 | +3x | +
+ check_pkg_installed(c("effectsize", "parameters"), reference_pkg = "cardx")
+ |
+
| 107 | ++ | + + | +
| 108 | ++ |
+ # check/process inputs -------------------------------------------------------+ |
+
| 109 | +3x | +
+ check_not_missing(data)+ |
+
| 110 | +3x | +
+ check_not_missing(variables)+ |
+
| 111 | +3x | +
+ check_not_missing(by)+ |
+
| 112 | +3x | +
+ check_not_missing(id)+ |
+
| 113 | +3x | +
+ check_data_frame(data)+ |
+
| 114 | +3x | +
+ data <- dplyr::ungroup(data)+ |
+
| 115 | +3x | +
+ cards::process_selectors(data, by = {{ by }}, variables = {{ variables }}, id = {{ id }})
+ |
+
| 116 | +3x | +
+ check_scalar(by)+ |
+
| 117 | +3x | +
+ check_scalar(id)+ |
+
| 118 | +3x | +
+ check_range(conf.level, range = c(0, 1))+ |
+
| 119 | ++ | + + | +
| 120 | ++ |
+ # return empty ARD if no variables selected ----------------------------------+ |
+
| 121 | +3x | +
+ if (is_empty(variables)) {
+ |
+
| 122 | +! | +
+ return(dplyr::tibble() |> cards::as_card())+ |
+
| 123 | ++ |
+ }+ |
+
| 124 | ++ | + + | +
| 125 | ++ |
+ # build ARD ------------------------------------------------------------------+ |
+
| 126 | +3x | +
+ lapply(+ |
+
| 127 | +3x | +
+ variables,+ |
+
| 128 | +3x | +
+ function(variable) {
+ |
+
| 129 | +3x | +
+ .format_cohens_d_results(+ |
+
| 130 | +3x | +
+ by = by,+ |
+
| 131 | +3x | +
+ variable = variable,+ |
+
| 132 | +3x | +
+ lst_tidy =+ |
+
| 133 | +3x | +
+ cards::eval_capture_conditions({
+ |
+
| 134 | ++ |
+ # adding this reshape inside the eval, so if there is an error it's captured in the ARD object+ |
+
| 135 | +3x | +
+ data_wide <-+ |
+
| 136 | +3x | +
+ data |>+ |
+
| 137 | +3x | +
+ tidyr::drop_na(all_of(c(id, by, variable))) |>+ |
+
| 138 | +3x | +
+ .paired_data_pivot_wider(by = by, variable = variable, id = id) |>+ |
+
| 139 | +3x | +
+ tidyr::drop_na(any_of(c("by1", "by2")))
+ |
+
| 140 | ++ |
+ # perform paired cohen's d test+ |
+
| 141 | +2x | +
+ effectsize::cohens_d(x = data_wide[["by1"]], y = data_wide[["by2"]], paired = TRUE, ci = conf.level, ...) |>+ |
+
| 142 | +2x | +
+ parameters::standardize_names(style = "broom") |>+ |
+
| 143 | +2x | +
+ dplyr::mutate(method = "Paired Cohen's D")+ |
+
| 144 | ++ |
+ }),+ |
+
| 145 | +3x | +
+ paired = TRUE,+ |
+
| 146 | ++ |
+ ...+ |
+
| 147 | ++ |
+ )+ |
+
| 148 | ++ |
+ }+ |
+
| 149 | ++ |
+ ) |>+ |
+
| 150 | +3x | +
+ dplyr::bind_rows()+ |
+
| 151 | ++ |
+ }+ |
+
| 152 | ++ | + + | +
| 153 | ++ |
+ .df_effectsize_stat_labels <- function() {
+ |
+
| 154 | +16x | +
+ dplyr::tribble(+ |
+
| 155 | +16x | +
+ ~stat_name, ~stat_label,+ |
+
| 156 | +16x | +
+ "estimate", "Effect Size Estimate",+ |
+
| 157 | +16x | +
+ "conf.low", "CI Lower Bound",+ |
+
| 158 | +16x | +
+ "conf.high", "CI Upper Bound",+ |
+
| 159 | +16x | +
+ "conf.level", "CI Confidence Level",+ |
+
| 160 | +16x | +
+ "mu", "H0 Mean",+ |
+
| 161 | +16x | +
+ "paired", "Paired test",+ |
+
| 162 | +16x | +
+ "pooled_sd", "Pooled Standard Deviation",+ |
+
| 163 | +16x | +
+ "alternative", "Alternative Hypothesis"+ |
+
| 164 | ++ |
+ )+ |
+
| 165 | ++ |
+ }+ |
+
| 166 | ++ | + + | +
| 167 | ++ | + + | +
| 168 | ++ |
+ #' Convert Cohen's D Test to ARD+ |
+
| 169 | ++ |
+ #'+ |
+
| 170 | ++ |
+ #' @inheritParams cards::tidy_as_ard+ |
+
| 171 | ++ |
+ #' @inheritParams effectsize::cohens_d+ |
+
| 172 | ++ |
+ #' @param by (`string`)\cr by column name+ |
+
| 173 | ++ |
+ #' @param variable (`string`)\cr variable column name+ |
+
| 174 | ++ |
+ #' @param ... passed to `cohens_d(...)`+ |
+
| 175 | ++ |
+ #'+ |
+
| 176 | ++ |
+ #' @return ARD data frame+ |
+
| 177 | ++ |
+ #' @keywords internal+ |
+
| 178 | ++ |
+ #' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = c("effectsize", "parameters"), reference_pkg = "cardx"))
+ |
+
| 179 | ++ |
+ #' cardx:::.format_cohens_d_results(+ |
+
| 180 | ++ |
+ #' by = "ARM",+ |
+
| 181 | ++ |
+ #' variable = "AGE",+ |
+
| 182 | ++ |
+ #' paired = FALSE,+ |
+
| 183 | ++ |
+ #' lst_tidy =+ |
+
| 184 | ++ |
+ #' cards::eval_capture_conditions(+ |
+
| 185 | ++ |
+ #' effectsize::hedges_g(data[[variable]] ~ data[[by]], paired = FALSE) |>+ |
+
| 186 | ++ |
+ #' parameters::standardize_names(style = "broom")+ |
+
| 187 | ++ |
+ #' )+ |
+
| 188 | ++ |
+ #' )+ |
+
| 189 | ++ |
+ .format_cohens_d_results <- function(by, variable, lst_tidy, paired, ...) {
+ |
+
| 190 | ++ |
+ # build ARD ------------------------------------------------------------------+ |
+
| 191 | +8x | +
+ ret <-+ |
+
| 192 | +8x | +
+ cards::tidy_as_ard(+ |
+
| 193 | +8x | +
+ lst_tidy = lst_tidy,+ |
+
| 194 | +8x | +
+ tidy_result_names = c(+ |
+
| 195 | +8x | +
+ "estimate", "conf.level", "conf.low", "conf.high"+ |
+
| 196 | ++ |
+ ),+ |
+
| 197 | +8x | +
+ fun_args_to_record = c("mu", "paired", "pooled_sd", "alternative"),
+ |
+
| 198 | +8x | +
+ formals = formals(asNamespace("effectsize")[["cohens_d"]]),
+ |
+
| 199 | +8x | +
+ passed_args = c(list(paired = paired), dots_list(...)),+ |
+
| 200 | +8x | +
+ lst_ard_columns = list(group1 = by, variable = variable, context = "effectsize_cohens_d")+ |
+
| 201 | ++ |
+ )+ |
+
| 202 | ++ | + + | +
| 203 | ++ |
+ # add the stat label ---------------------------------------------------------+ |
+
| 204 | +8x | +
+ ret |>+ |
+
| 205 | +8x | +
+ dplyr::left_join(+ |
+
| 206 | +8x | +
+ .df_effectsize_stat_labels(),+ |
+
| 207 | +8x | +
+ by = "stat_name"+ |
+
| 208 | ++ |
+ ) |>+ |
+
| 209 | +8x | +
+ dplyr::mutate(stat_label = dplyr::coalesce(.data$stat_label, .data$stat_name)) |>+ |
+
| 210 | +8x | +
+ cards::as_card() |>+ |
+
| 211 | +8x | +
+ cards::tidy_ard_column_order()+ |
+
| 212 | ++ |
+ }+ |
+
| 1 | ++ |
+ #' ARD continuous CIs+ |
+
| 2 | ++ |
+ #'+ |
+
| 3 | ++ |
+ #' One-sample confidence intervals for continuous variable means and medians.+ |
+
| 4 | ++ |
+ #'+ |
+
| 5 | ++ |
+ #' @inheritParams ard_stats_t_test+ |
+
| 6 | ++ |
+ #' @param method (`string`)\cr+ |
+
| 7 | ++ |
+ #' a string indicating the method to use for the confidence interval+ |
+
| 8 | ++ |
+ #' calculation. Must be one of `"t.test"` or `"wilcox.test"`+ |
+
| 9 | ++ |
+ #' @param ... arguments passed to `t.test()` or `wilcox.test()`+ |
+
| 10 | ++ |
+ #'+ |
+
| 11 | ++ |
+ #' @return ARD data frame+ |
+
| 12 | ++ |
+ #' @name ard_continuous_ci+ |
+
| 13 | ++ |
+ #'+ |
+
| 14 | ++ |
+ #' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = "broom", reference_pkg = "cardx"))
+ |
+
| 15 | ++ |
+ #' ard_continuous_ci(mtcars, variables = c(mpg, hp), method = "wilcox.test")+ |
+
| 16 | ++ |
+ #' ard_continuous_ci(mtcars, variables = mpg, by = am, method = "t.test")+ |
+
| 17 | ++ |
+ NULL+ |
+
| 18 | ++ | + + | +
| 19 | ++ |
+ #' @rdname ard_continuous_ci+ |
+
| 20 | ++ |
+ #' @export+ |
+
| 21 | ++ |
+ ard_continuous_ci <- function(data, ...) {
+ |
+
| 22 | +18x | +
+ check_not_missing(data)+ |
+
| 23 | +18x | +
+ UseMethod("ard_continuous_ci")
+ |
+
| 24 | ++ |
+ }+ |
+
| 25 | ++ | + + | +
| 26 | ++ |
+ #' @rdname ard_continuous_ci+ |
+
| 27 | ++ |
+ #' @export+ |
+
| 28 | ++ |
+ ard_continuous_ci.data.frame <- function(data, variables, by = dplyr::group_vars(data), conf.level = 0.95, method = c("t.test", "wilcox.test"), ...) {
+ |
+
| 29 | +3x | +
+ set_cli_abort_call()+ |
+
| 30 | ++ | + + | +
| 31 | ++ |
+ # check inputs ---------------------------------------------------------------+ |
+
| 32 | +3x | +
+ method <- arg_match(method)+ |
+
| 33 | +3x | +
+ check_not_missing(variables)+ |
+
| 34 | +3x | +
+ cards::process_selectors(data, by = {{ by }}, variables = {{ variables }})
+ |
+
| 35 | ++ | + + | +
| 36 | ++ |
+ # return empty ARD if no variables selected ----------------------------------+ |
+
| 37 | +3x | +
+ if (is_empty(variables)) {
+ |
+
| 38 | +! | +
+ return(dplyr::tibble() |> cards::as_card())+ |
+
| 39 | ++ |
+ }+ |
+
| 40 | ++ | + + | +
| 41 | ++ |
+ # calculate CIs --------------------------------------------------------------+ |
+
| 42 | +3x | +
+ switch(method,+ |
+
| 43 | +3x | +
+ "t.test" =+ |
+
| 44 | +3x | +
+ ard_stats_t_test_onesample(+ |
+
| 45 | +3x | +
+ data = data,+ |
+
| 46 | +3x | +
+ variables = {{ variables }},
+ |
+
| 47 | +3x | +
+ by = {{ by }},
+ |
+
| 48 | +3x | +
+ conf.level = conf.level,+ |
+
| 49 | ++ |
+ ...+ |
+
| 50 | ++ |
+ ),+ |
+
| 51 | +3x | +
+ "wilcox.test" =+ |
+
| 52 | +3x | +
+ ard_stats_wilcox_test_onesample(+ |
+
| 53 | +3x | +
+ data = data,+ |
+
| 54 | +3x | +
+ variables = {{ variables }},
+ |
+
| 55 | +3x | +
+ by = {{ by }},
+ |
+
| 56 | +3x | +
+ conf.level = conf.level,+ |
+
| 57 | +3x | +
+ conf.int = TRUE,+ |
+
| 58 | ++ |
+ ...+ |
+
| 59 | ++ |
+ )+ |
+
| 60 | ++ |
+ ) |>+ |
+
| 61 | +3x | +
+ dplyr::mutate(context = "continuous_ci")+ |
+
| 62 | ++ |
+ }+ |
+
| 1 | ++ |
+ #' ARD survey continuous CIs+ |
+
| 2 | ++ |
+ #'+ |
+
| 3 | ++ |
+ #' One-sample confidence intervals for continuous variables' means and medians.+ |
+
| 4 | ++ |
+ #' Confidence limits are calculated with `survey::svymean()` and `survey::svyquantile()`.+ |
+
| 5 | ++ |
+ #'+ |
+
| 6 | ++ |
+ #'+ |
+
| 7 | ++ |
+ #' @inheritParams ard_continuous.survey.design+ |
+
| 8 | ++ |
+ #' @param method (`string`)\cr+ |
+
| 9 | ++ |
+ #' Method for confidence interval calculation.+ |
+
| 10 | ++ |
+ #' When `"svymean"`, the calculation is computed via `survey::svymean()`.+ |
+
| 11 | ++ |
+ #' Otherwise, it is calculated via`survey::svyquantile(interval.type=method)`+ |
+
| 12 | ++ |
+ #' @param conf.level (scalar `numeric`)\cr+ |
+
| 13 | ++ |
+ #' confidence level for confidence interval. Default is `0.95`.+ |
+
| 14 | ++ |
+ #' @param df (`numeric`)\cr+ |
+
| 15 | ++ |
+ #' denominator degrees of freedom, passed to `survey::confint(df)`.+ |
+
| 16 | ++ |
+ #' Default is `survey::degf(data)`.+ |
+
| 17 | ++ |
+ #' @param ... arguments passed to `survey::confint()`+ |
+
| 18 | ++ |
+ #'+ |
+
| 19 | ++ |
+ #' @return ARD data frame+ |
+
| 20 | ++ |
+ #' @export+ |
+
| 21 | ++ |
+ #'+ |
+
| 22 | ++ |
+ #' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = "survey", reference_pkg = "cardx"))
+ |
+
| 23 | ++ |
+ #' data(api, package = "survey")+ |
+
| 24 | ++ |
+ #' dclus1 <- survey::svydesign(id = ~dnum, weights = ~pw, data = apiclus1, fpc = ~fpc)+ |
+
| 25 | ++ |
+ #'+ |
+
| 26 | ++ |
+ #' ard_continuous_ci(dclus1, variables = api00)+ |
+
| 27 | ++ |
+ #' ard_continuous_ci(dclus1, variables = api00, method = "svymedian.xlogit")+ |
+
| 28 | ++ |
+ ard_continuous_ci.survey.design <- function(data,+ |
+
| 29 | ++ |
+ variables,+ |
+
| 30 | ++ |
+ by = NULL,+ |
+
| 31 | ++ |
+ method = c("svymean", "svymedian.mean", "svymedian.beta", "svymedian.xlogit", "svymedian.asin", "svymedian.score"),
+ |
+
| 32 | ++ |
+ conf.level = 0.95,+ |
+
| 33 | ++ |
+ df = survey::degf(data),+ |
+
| 34 | ++ |
+ ...) {
+ |
+
| 35 | +15x | +
+ set_cli_abort_call()+ |
+
| 36 | ++ | + + | +
| 37 | ++ |
+ # check inputs ---------------------------------------------------------------+ |
+
| 38 | +15x | +
+ check_not_missing(data)+ |
+
| 39 | +15x | +
+ check_class(data, "survey.design")+ |
+
| 40 | +15x | +
+ check_not_missing(variables)+ |
+
| 41 | ++ | + + | +
| 42 | +15x | +
+ cards::process_selectors(+ |
+
| 43 | +15x | +
+ data = data$variables,+ |
+
| 44 | +15x | +
+ variables = {{ variables }},
+ |
+
| 45 | +15x | +
+ by = {{ by }}
+ |
+
| 46 | ++ |
+ )+ |
+
| 47 | +15x | +
+ check_scalar(by, allow_empty = TRUE)+ |
+
| 48 | +15x | +
+ check_scalar_range(conf.level, range = c(0, 1))+ |
+
| 49 | +15x | +
+ method <- arg_match(method)+ |
+
| 50 | ++ | + + | +
| 51 | +15x | +
+ walk(+ |
+
| 52 | +15x | +
+ variables,+ |
+
| 53 | +15x | +
+ \(variable) {
+ |
+
| 54 | +26x | +
+ if (!is.numeric(data$variables[[variable]])) {
+ |
+
| 55 | +! | +
+ cli::cli_inform(+ |
+
| 56 | +! | +
+ "Column {.val {variable}} is not {.cls numeric} and results may be an unexpected format."
+ |
+
| 57 | ++ |
+ )+ |
+
| 58 | ++ |
+ }+ |
+
| 59 | ++ |
+ }+ |
+
| 60 | ++ |
+ )+ |
+
| 61 | ++ | + + | +
| 62 | ++ |
+ # return empty ARD if no variables selected ----------------------------------+ |
+
| 63 | +15x | +
+ if (is_empty(variables)) {
+ |
+
| 64 | +1x | +
+ return(dplyr::tibble() |> cards::as_card())+ |
+
| 65 | ++ |
+ }+ |
+
| 66 | ++ | + + | +
| 67 | ++ |
+ # calculate and return ARD of one sample CI ----------------------------------+ |
+
| 68 | +14x | +
+ .calculate_ard_continuous_survey_ci(+ |
+
| 69 | +14x | +
+ FUN = ifelse(method == "svymean", .svymean_confint_wrapper, .svyquantile_confint_wrapper),+ |
+
| 70 | +14x | +
+ data = data,+ |
+
| 71 | +14x | +
+ variables = variables,+ |
+
| 72 | +14x | +
+ by = by,+ |
+
| 73 | +14x | +
+ conf.level = conf.level,+ |
+
| 74 | +14x | +
+ method = method,+ |
+
| 75 | +14x | +
+ df = df,+ |
+
| 76 | ++ |
+ ...+ |
+
| 77 | ++ |
+ )+ |
+
| 78 | ++ |
+ }+ |
+
| 79 | ++ | + + | +
| 80 | ++ |
+ .calculate_ard_continuous_survey_ci <- function(FUN, data, variables, by, conf.level, ...) {
+ |
+
| 81 | ++ |
+ # calculate results ----------------------------------------------------------+ |
+
| 82 | +14x | +
+ map(+ |
+
| 83 | +14x | +
+ variables,+ |
+
| 84 | +14x | +
+ function(variable) {
+ |
+
| 85 | +26x | +
+ .calculate_one_ard_continuous_survey_ci(+ |
+
| 86 | +26x | +
+ FUN = FUN,+ |
+
| 87 | +26x | +
+ data = data,+ |
+
| 88 | +26x | +
+ variable = variable,+ |
+
| 89 | +26x | +
+ by = by,+ |
+
| 90 | +26x | +
+ conf.level = conf.level,+ |
+
| 91 | ++ |
+ ...+ |
+
| 92 | ++ |
+ )+ |
+
| 93 | ++ |
+ }+ |
+
| 94 | ++ |
+ ) |>+ |
+
| 95 | +14x | +
+ dplyr::bind_rows()+ |
+
| 96 | ++ |
+ }+ |
+
| 97 | ++ | + + | +
| 98 | ++ |
+ .calculate_one_ard_continuous_survey_ci <- function(FUN, data, variable, by, conf.level, ...) {
+ |
+
| 99 | +26x | +
+ if (!is_empty(by)) {
+ |
+
| 100 | +8x | +
+ by_levels <- .unique_values_sort(data$variables, variable = by)+ |
+
| 101 | +8x | +
+ lst_data <-+ |
+
| 102 | +8x | +
+ map(+ |
+
| 103 | +8x | +
+ by_levels,+ |
+
| 104 | +8x | +
+ ~ call2("subset", expr(data), expr(!!sym(by) == !!.x)) |> eval()
+ |
+
| 105 | ++ |
+ ) |>+ |
+
| 106 | +8x | +
+ set_names(as.character(by_levels))+ |
+
| 107 | ++ |
+ }+ |
+
| 108 | ++ | + + | +
| 109 | +26x | +
+ df_full <-+ |
+
| 110 | +26x | +
+ case_switch(+ |
+
| 111 | +26x | +
+ !is_empty(by) ~+ |
+
| 112 | +26x | +
+ tidyr::expand_grid(+ |
+
| 113 | +26x | +
+ group1_level = as.character(by_levels) |> as.list()+ |
+
| 114 | ++ |
+ ) |>+ |
+
| 115 | +26x | +
+ dplyr::mutate(group1 = .env$by, variable = .env$variable),+ |
+
| 116 | +26x | +
+ .default =+ |
+
| 117 | +26x | +
+ dplyr::tibble(variable = .env$variable)+ |
+
| 118 | ++ |
+ ) |>+ |
+
| 119 | +26x | +
+ dplyr::rowwise() |>+ |
+
| 120 | +26x | +
+ dplyr::mutate(+ |
+
| 121 | +26x | +
+ lst_result =+ |
+
| 122 | +26x | +
+ FUN(+ |
+
| 123 | +26x | +
+ data =+ |
+
| 124 | +26x | +
+ case_switch(+ |
+
| 125 | +26x | +
+ is_empty(.env$by) ~ data,+ |
+
| 126 | +26x | +
+ .default = lst_data[[.data$group1_level]]+ |
+
| 127 | ++ |
+ ),+ |
+
| 128 | +26x | +
+ variable = .data$variable,+ |
+
| 129 | +26x | +
+ conf.level = .env$conf.level,+ |
+
| 130 | ++ |
+ ...+ |
+
| 131 | ++ |
+ ) |>+ |
+
| 132 | +26x | +
+ list(),+ |
+
| 133 | +26x | +
+ result =+ |
+
| 134 | +26x | +
+ .data$lst_result[["result"]] |>+ |
+
| 135 | +26x | +
+ enframe("stat_name", "stat") |>
+ |
+
| 136 | +26x | +
+ list(),+ |
+
| 137 | +26x | +
+ warning = .data$lst_result["warning"] |> unname(),+ |
+
| 138 | +26x | +
+ error = .data$lst_result["error"] |> unname(),+ |
+
| 139 | +26x | +
+ context = "survey_continuous_ci"+ |
+
| 140 | ++ |
+ ) |>+ |
+
| 141 | +26x | +
+ dplyr::select(-"lst_result") |>+ |
+
| 142 | +26x | +
+ dplyr::ungroup() |>+ |
+
| 143 | +26x | +
+ tidyr::unnest("result") |>
+ |
+
| 144 | +26x | +
+ dplyr::mutate(+ |
+
| 145 | +26x | +
+ stat_label = .data$stat_name,+ |
+
| 146 | +26x | +
+ fmt_fn = map(.data$stat, ~ case_switch(is.numeric(.x) ~ 2L, .default = as.character))+ |
+
| 147 | ++ |
+ ) |>+ |
+
| 148 | +26x | +
+ cards::as_card() |>+ |
+
| 149 | +26x | +
+ cards::tidy_ard_column_order()+ |
+
| 150 | ++ |
+ }+ |
+
| 151 | ++ | + + | +
| 152 | ++ |
+ .svymean_confint_wrapper <- function(data, variable, conf.level, df, ...) {
+ |
+
| 153 | +26x | +
+ lst_results <-+ |
+
| 154 | +26x | +
+ cards::eval_capture_conditions({
+ |
+
| 155 | +26x | +
+ svymean <-+ |
+
| 156 | +26x | +
+ survey::svymean(x = reformulate2(variable), design = data, na.rm = TRUE)+ |
+
| 157 | ++ | + + | +
| 158 | +26x | +
+ lst_svymean <- as.data.frame(svymean) |>+ |
+
| 159 | +26x | +
+ as.list() |>+ |
+
| 160 | +26x | +
+ set_names(c("estimate", "std.error"))
+ |
+
| 161 | ++ | + + | +
| 162 | +26x | +
+ lst_confint <- stats::confint(svymean, level = conf.level, df = df, ...) |>+ |
+
| 163 | +26x | +
+ as.data.frame() |>+ |
+
| 164 | +26x | +
+ as.list() |>+ |
+
| 165 | +26x | +
+ set_names(c("conf.low", "conf.high"))
+ |
+
| 166 | ++ | + + | +
| 167 | +24x | +
+ c(lst_svymean, lst_confint)+ |
+
| 168 | ++ |
+ })+ |
+
| 169 | ++ | + + | +
| 170 | ++ |
+ # add NULL results if error+ |
+
| 171 | +26x | +
+ if (is_empty(lst_results[["result"]])) {
+ |
+
| 172 | +2x | +
+ lst_results[["result"]] <- rep_named(c("estimate", "std.error", "conf.low", "conf.high"), list(NULL))
+ |
+
| 173 | ++ |
+ }+ |
+
| 174 | ++ | + + | +
| 175 | ++ |
+ # add other args+ |
+
| 176 | +26x | +
+ lst_results[["result"]] <- lst_results[["result"]] |> append(list(conf.level = conf.level))+ |
+
| 177 | ++ | + + | +
| 178 | ++ |
+ # return list result+ |
+
| 179 | +26x | +
+ lst_results+ |
+
| 180 | ++ |
+ }+ |
+
| 181 | ++ | + + | +
| 182 | ++ |
+ .svyquantile_confint_wrapper <- function(data, variable, conf.level, method, df, ...) {
+ |
+
| 183 | +8x | +
+ lst_results <-+ |
+
| 184 | +8x | +
+ cards::eval_capture_conditions({
+ |
+
| 185 | +8x | +
+ svyquantile <-+ |
+
| 186 | +8x | +
+ survey::svyquantile(+ |
+
| 187 | +8x | +
+ x = reformulate2(variable), design = data, quantiles = 0.5,+ |
+
| 188 | +8x | +
+ na.rm = TRUE, interval.type = str_remove(method, pattern = "^svymedian\\.")+ |
+
| 189 | ++ |
+ )+ |
+
| 190 | ++ | + + | +
| 191 | +8x | +
+ lst_svyquantile <- svyquantile |>+ |
+
| 192 | +8x | +
+ getElement(1L) |>+ |
+
| 193 | +8x | +
+ as.data.frame() |>+ |
+
| 194 | +8x | +
+ dplyr::select(1L, last_col()) |>+ |
+
| 195 | +8x | +
+ as.list() |>+ |
+
| 196 | +8x | +
+ set_names(c("estimate", "std.error"))
+ |
+
| 197 | ++ | + + | +
| 198 | +8x | +
+ lst_confint <- stats::confint(svyquantile, level = conf.level, df = df, ...) |>+ |
+
| 199 | +8x | +
+ as.data.frame() |>+ |
+
| 200 | +8x | +
+ as.list() |>+ |
+
| 201 | +8x | +
+ set_names(c("conf.low", "conf.high"))
+ |
+
| 202 | ++ | + + | +
| 203 | +8x | +
+ c(lst_svyquantile, lst_confint)+ |
+
| 204 | ++ |
+ })+ |
+
| 205 | ++ | + + | +
| 206 | ++ |
+ # add NULL results if error+ |
+
| 207 | +8x | +
+ if (is_empty(lst_results[["result"]])) {
+ |
+
| 208 | +! | +
+ lst_results[["result"]] <- rep_named(c("estimate", "std.error", "conf.low", "conf.high"), list(NULL))
+ |
+
| 209 | ++ |
+ }+ |
+
| 210 | ++ | + + | +
| 211 | ++ |
+ # add other args+ |
+
| 212 | +8x | +
+ lst_results[["result"]] <- lst_results[["result"]] |> append(list(conf.level = conf.level))+ |
+
| 213 | ++ | + + | +
| 214 | ++ |
+ # return list result+ |
+
| 215 | +8x | +
+ lst_results+ |
+
| 216 | ++ |
+ }+ |
+
| 1 | ++ |
+ #' ARD 2-sample proportion test+ |
+
| 2 | ++ |
+ #'+ |
+
| 3 | ++ |
+ #' @description+ |
+
| 4 | ++ |
+ #' Analysis results data for a 2-sample test or proportions using [`stats::prop.test()`].+ |
+
| 5 | ++ |
+ #'+ |
+
| 6 | ++ |
+ #' @param data (`data.frame`)\cr+ |
+
| 7 | ++ |
+ #' a data frame.+ |
+
| 8 | ++ |
+ #' @param by ([`tidy-select`][dplyr::dplyr_tidy_select])\cr+ |
+
| 9 | ++ |
+ #' column name to compare by+ |
+
| 10 | ++ |
+ #' @param variables ([`tidy-select`][dplyr::dplyr_tidy_select])\cr+ |
+
| 11 | ++ |
+ #' column names to be compared. Must be a binary column coded as `TRUE`/`FALSE`+ |
+
| 12 | ++ |
+ #' or `1`/`0`. Independent tests will be computed for each variable.+ |
+
| 13 | ++ |
+ #' @param conf.level (scalar `numeric`)\cr+ |
+
| 14 | ++ |
+ #' confidence level for confidence interval. Default is `0.95`.+ |
+
| 15 | ++ |
+ #' @param ... arguments passed to `prop.test(...)`+ |
+
| 16 | ++ |
+ #'+ |
+
| 17 | ++ |
+ #' @return ARD data frame+ |
+
| 18 | ++ |
+ #' @export+ |
+
| 19 | ++ |
+ #'+ |
+
| 20 | ++ |
+ #' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = "broom", reference_pkg = "cardx"))
+ |
+
| 21 | ++ |
+ #' mtcars |>+ |
+
| 22 | ++ |
+ #' ard_stats_prop_test(by = vs, variables = am)+ |
+
| 23 | ++ |
+ ard_stats_prop_test <- function(data, by, variables, conf.level = 0.95, ...) {
+ |
+
| 24 | +6x | +
+ set_cli_abort_call()+ |
+
| 25 | ++ | + + | +
| 26 | ++ |
+ # check installed packages ---------------------------------------------------+ |
+
| 27 | +6x | +
+ check_pkg_installed(pkg = "broom", reference_pkg = "cardx")+ |
+
| 28 | ++ | + + | +
| 29 | ++ |
+ # check inputs ---------------------------------------------------------------+ |
+
| 30 | +6x | +
+ check_not_missing(data)+ |
+
| 31 | +6x | +
+ check_not_missing(variables)+ |
+
| 32 | +6x | +
+ check_not_missing(by)+ |
+
| 33 | +6x | +
+ check_data_frame(data)+ |
+
| 34 | +6x | +
+ check_range(conf.level, range = c(0, 1))+ |
+
| 35 | ++ | + + | +
| 36 | ++ |
+ # process inputs -------------------------------------------------------------+ |
+
| 37 | +6x | +
+ cards::process_selectors(data, by = {{ by }}, variables = {{ variables }})
+ |
+
| 38 | +6x | +
+ check_scalar(by)+ |
+
| 39 | +6x | +
+ data <- data[c(by, variables)] |> dplyr::ungroup() |> tidyr::drop_na() # styler: off+ |
+
| 40 | ++ | + + | +
| 41 | ++ |
+ # return empty ARD if no variables selected ----------------------------------+ |
+
| 42 | +6x | +
+ if (is_empty(variables)) {
+ |
+
| 43 | +! | +
+ return(dplyr::tibble() |> cards::as_card())+ |
+
| 44 | ++ |
+ }+ |
+
| 45 | ++ | + + | +
| 46 | ++ |
+ # build ARD ------------------------------------------------------------------+ |
+
| 47 | +6x | +
+ lapply(+ |
+
| 48 | +6x | +
+ variables,+ |
+
| 49 | +6x | +
+ function(variable) {
+ |
+
| 50 | +7x | +
+ .format_proptest_results(+ |
+
| 51 | +7x | +
+ by = by,+ |
+
| 52 | +7x | +
+ variable = variable,+ |
+
| 53 | +7x | +
+ lst_tidy =+ |
+
| 54 | +7x | +
+ cards::eval_capture_conditions({
+ |
+
| 55 | +7x | +
+ check_binary(data[[variable]], arg_name = "variable")+ |
+
| 56 | ++ | + + | +
| 57 | +4x | +
+ data_counts <-+ |
+
| 58 | +4x | +
+ dplyr::arrange(data, .data[[by]]) |>+ |
+
| 59 | +4x | +
+ dplyr::summarise(+ |
+
| 60 | +4x | +
+ .by = all_of(by),+ |
+
| 61 | +4x | +
+ x = sum(.data[[variable]]),+ |
+
| 62 | +4x | +
+ n = length(.data[[variable]])+ |
+
| 63 | ++ |
+ )+ |
+
| 64 | ++ | + + | +
| 65 | +4x | +
+ if (nrow(data_counts) != 2) {
+ |
+
| 66 | +1x | +
+ cli::cli_abort(+ |
+
| 67 | +1x | +
+ c(+ |
+
| 68 | +1x | +
+ "The {.arg by} column must have exactly 2 levels.",
+ |
+
| 69 | +1x | +
+ "The levels are {.val {data_counts[[by]]}}"
+ |
+
| 70 | ++ |
+ ),+ |
+
| 71 | +1x | +
+ call = get_cli_abort_call()+ |
+
| 72 | ++ |
+ )+ |
+
| 73 | ++ |
+ }+ |
+
| 74 | ++ | + + | +
| 75 | +3x | +
+ stats::prop.test(+ |
+
| 76 | +3x | +
+ x = data_counts[["x"]],+ |
+
| 77 | +3x | +
+ n = data_counts[["n"]],+ |
+
| 78 | +3x | +
+ conf.level = conf.level,+ |
+
| 79 | ++ |
+ ...+ |
+
| 80 | ++ |
+ ) |>+ |
+
| 81 | +3x | +
+ broom::tidy() |>+ |
+
| 82 | ++ |
+ # add central estimate for difference+ |
+
| 83 | +3x | +
+ dplyr::mutate(estimate = .data$estimate1 - .data$estimate2, .before = 1L)+ |
+
| 84 | ++ |
+ }),+ |
+
| 85 | ++ |
+ ...+ |
+
| 86 | ++ |
+ )+ |
+
| 87 | ++ |
+ }+ |
+
| 88 | ++ |
+ ) |>+ |
+
| 89 | +6x | +
+ dplyr::bind_rows()+ |
+
| 90 | ++ |
+ }+ |
+
| 91 | ++ | + + | +
| 92 | ++ | + + | +
| 93 | ++ |
+ #' Convert prop.test to ARD+ |
+
| 94 | ++ |
+ #'+ |
+
| 95 | ++ |
+ #' @inheritParams cards::tidy_as_ard+ |
+
| 96 | ++ |
+ #' @param by (`string`)\cr by column name+ |
+
| 97 | ++ |
+ #' @param variable (`string`)\cr variable column name+ |
+
| 98 | ++ |
+ #' @param ... passed to `prop.test(...)`+ |
+
| 99 | ++ |
+ #'+ |
+
| 100 | ++ |
+ #' @return ARD data frame+ |
+
| 101 | ++ |
+ #' @keywords internal+ |
+
| 102 | ++ |
+ .format_proptest_results <- function(by, variable, lst_tidy, ...) {
+ |
+
| 103 | ++ |
+ # build ARD ------------------------------------------------------------------+ |
+
| 104 | +7x | +
+ ret <-+ |
+
| 105 | +7x | +
+ cards::tidy_as_ard(+ |
+
| 106 | +7x | +
+ lst_tidy = lst_tidy,+ |
+
| 107 | +7x | +
+ tidy_result_names = c(+ |
+
| 108 | +7x | +
+ "estimate", "estimate1", "estimate2", "statistic",+ |
+
| 109 | +7x | +
+ "p.value", "parameter", "conf.low", "conf.high",+ |
+
| 110 | +7x | +
+ "method", "alternative"+ |
+
| 111 | ++ |
+ ),+ |
+
| 112 | +7x | +
+ fun_args_to_record = c("p", "conf.level", "correct"),
+ |
+
| 113 | +7x | +
+ formals = formals(stats::prop.test),+ |
+
| 114 | +7x | +
+ passed_args = dots_list(...),+ |
+
| 115 | +7x | +
+ lst_ard_columns = list(group1 = by, variable = variable, context = "stats_prop_test")+ |
+
| 116 | ++ |
+ )+ |
+
| 117 | ++ | + + | +
| 118 | ++ |
+ # add the stat label ---------------------------------------------------------+ |
+
| 119 | +7x | +
+ ret |>+ |
+
| 120 | +7x | +
+ dplyr::left_join(+ |
+
| 121 | +7x | +
+ .df_proptest_stat_labels(),+ |
+
| 122 | +7x | +
+ by = "stat_name"+ |
+
| 123 | ++ |
+ ) |>+ |
+
| 124 | +7x | +
+ dplyr::mutate(stat_label = dplyr::coalesce(.data$stat_label, .data$stat_name)) |>+ |
+
| 125 | +7x | +
+ cards::as_card() |>+ |
+
| 126 | +7x | +
+ cards::tidy_ard_column_order()+ |
+
| 127 | ++ |
+ }+ |
+
| 128 | ++ | + + | +
| 129 | ++ |
+ .df_proptest_stat_labels <- function() {
+ |
+
| 130 | +7x | +
+ dplyr::tribble(+ |
+
| 131 | +7x | +
+ ~stat_name, ~stat_label,+ |
+
| 132 | +7x | +
+ "estimate1", "Group 1 Rate",+ |
+
| 133 | +7x | +
+ "estimate2", "Group 2 Rate",+ |
+
| 134 | +7x | +
+ "estimate", "Rate Difference",+ |
+
| 135 | +7x | +
+ "p.value", "p-value",+ |
+
| 136 | +7x | +
+ "statistic", "X-squared Statistic",+ |
+
| 137 | +7x | +
+ "parameter", "Degrees of Freedom",+ |
+
| 138 | +7x | +
+ "conf.low", "CI Lower Bound",+ |
+
| 139 | +7x | +
+ "conf.high", "CI Upper Bound",+ |
+
| 140 | +7x | +
+ "conf.level", "CI Confidence Level",+ |
+
| 141 | +7x | +
+ "correct", "Yates' continuity correction",+ |
+
| 142 | ++ |
+ )+ |
+
| 143 | ++ |
+ }+ |
+
| 1 | ++ |
+ #' ARD Continuous Survey Statistics+ |
+
| 2 | ++ |
+ #'+ |
+
| 3 | ++ |
+ #' Returns an ARD of weighted statistics using the `{survey}` package.
+ |
+
| 4 | ++ |
+ #'+ |
+
| 5 | ++ |
+ #' @param data (`survey.design`)\cr+ |
+
| 6 | ++ |
+ #' a design object often created with [`survey::svydesign()`].+ |
+
| 7 | ++ |
+ #' @param variables ([`tidy-select`][dplyr::dplyr_tidy_select])\cr+ |
+
| 8 | ++ |
+ #' columns to include in summaries.+ |
+
| 9 | ++ |
+ #' @param by ([`tidy-select`][dplyr::dplyr_tidy_select])\cr+ |
+
| 10 | ++ |
+ #' results are calculated for **all combinations** of the columns specified,+ |
+
| 11 | ++ |
+ #' including unobserved combinations and unobserved factor levels.+ |
+
| 12 | ++ |
+ #' @param statistic ([`formula-list-selector`][cards::syntax])\cr+ |
+
| 13 | ++ |
+ #' a named list, a list of formulas,+ |
+
| 14 | ++ |
+ #' or a single formula where the list element is a character vector of+ |
+
| 15 | ++ |
+ #' statistic names to include. See below for options.+ |
+
| 16 | ++ |
+ #' @param fmt_fn ([`formula-list-selector`][cards::syntax])\cr+ |
+
| 17 | ++ |
+ #' a named list, a list of formulas,+ |
+
| 18 | ++ |
+ #' or a single formula where the list element is a named list of functions+ |
+
| 19 | ++ |
+ #' (or the RHS of a formula),+ |
+
| 20 | ++ |
+ #' e.g. `list(mpg = list(mean = \(x) round(x, digits = 2) |> as.character))`.+ |
+
| 21 | ++ |
+ #' @param stat_label ([`formula-list-selector`][cards::syntax])\cr+ |
+
| 22 | ++ |
+ #' a named list, a list of formulas, or a single formula where+ |
+
| 23 | ++ |
+ #' the list element is either a named list or a list of formulas defining the+ |
+
| 24 | ++ |
+ #' statistic labels, e.g. `everything() ~ list(mean = "Mean", sd = "SD")` or+ |
+
| 25 | ++ |
+ #' `everything() ~ list(mean ~ "Mean", sd ~ "SD")`.+ |
+
| 26 | ++ |
+ #' @inheritParams rlang::args_dots_empty+ |
+
| 27 | ++ |
+ #'+ |
+
| 28 | ++ |
+ #' @section statistic argument:+ |
+
| 29 | ++ |
+ #'+ |
+
| 30 | ++ |
+ #' The following statistics are available:+ |
+
| 31 | ++ |
+ #' `r cardx:::accepted_svy_stats(FALSE) |> shQuote("sh") |> paste(collapse = ", ")`,
+ |
+
| 32 | ++ |
+ #' where 'p##' is are the percentiles and `##` is an integer between 0 and 100.+ |
+
| 33 | ++ |
+ #'+ |
+
| 34 | ++ |
+ #'+ |
+
| 35 | ++ |
+ #' @return an ARD data frame of class 'card'+ |
+
| 36 | ++ |
+ #' @export+ |
+
| 37 | ++ |
+ #'+ |
+
| 38 | ++ |
+ #' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = "survey", reference_pkg = "cardx"))
+ |
+
| 39 | ++ |
+ #' data(api, package = "survey")+ |
+
| 40 | ++ |
+ #' dclus1 <- survey::svydesign(id = ~dnum, weights = ~pw, data = apiclus1, fpc = ~fpc)+ |
+
| 41 | ++ |
+ #'+ |
+
| 42 | ++ |
+ #' ard_continuous(+ |
+
| 43 | ++ |
+ #' data = dclus1,+ |
+
| 44 | ++ |
+ #' variables = api00,+ |
+
| 45 | ++ |
+ #' by = stype+ |
+
| 46 | ++ |
+ #' )+ |
+
| 47 | ++ |
+ ard_continuous.survey.design <- function(data, variables, by = NULL,+ |
+
| 48 | ++ |
+ statistic = everything() ~ c("median", "p25", "p75"),
+ |
+
| 49 | ++ |
+ fmt_fn = NULL,+ |
+
| 50 | ++ |
+ stat_label = NULL,+ |
+
| 51 | ++ |
+ ...) {
+ |
+
| 52 | +49x | +
+ set_cli_abort_call()+ |
+
| 53 | +49x | +
+ check_dots_empty()+ |
+
| 54 | ++ | + + | +
| 55 | ++ |
+ # check installed packages ---------------------------------------------------+ |
+
| 56 | +49x | +
+ check_pkg_installed(pkg = "survey", reference_pkg = "cardx")+ |
+
| 57 | ++ | + + | +
| 58 | ++ |
+ # check inputs ---------------------------------------------------------------+ |
+
| 59 | +49x | +
+ check_not_missing(variables)+ |
+
| 60 | ++ | + + | +
| 61 | ++ |
+ # process inputs -------------------------------------------------------------+ |
+
| 62 | +49x | +
+ cards::process_selectors(data$variables, variables = {{ variables }}, by = {{ by }})
+ |
+
| 63 | +49x | +
+ variables <- setdiff(variables, by)+ |
+
| 64 | +49x | +
+ check_na_factor_levels(data$variables, by)+ |
+
| 65 | ++ | + + | +
| 66 | +49x | +
+ cards::process_formula_selectors(+ |
+
| 67 | +49x | +
+ data$variables[variables],+ |
+
| 68 | +49x | +
+ statistic = statistic,+ |
+
| 69 | +49x | +
+ fmt_fn = fmt_fn,+ |
+
| 70 | +49x | +
+ stat_label = stat_label+ |
+
| 71 | ++ |
+ )+ |
+
| 72 | +49x | +
+ cards::fill_formula_selectors(+ |
+
| 73 | +49x | +
+ data$variables[variables],+ |
+
| 74 | +49x | +
+ statistic = formals(asNamespace("cardx")[["ard_continuous.survey.design"]])[["statistic"]] |> eval()
+ |
+
| 75 | ++ |
+ )+ |
+
| 76 | +49x | +
+ cards::check_list_elements(+ |
+
| 77 | +49x | +
+ x = statistic,+ |
+
| 78 | +49x | +
+ predicate = \(x) all(x %in% accepted_svy_stats()),+ |
+
| 79 | +49x | +
+ error_msg = c("Error in the values of the {.arg statistic} argument for variable {.val {variable}}.",
+ |
+
| 80 | +49x | +
+ i = "Values must be in {.val {cardx:::accepted_svy_stats(FALSE)}}"
+ |
+
| 81 | ++ |
+ )+ |
+
| 82 | ++ |
+ )+ |
+
| 83 | ++ | + + | +
| 84 | ++ |
+ # return empty ARD if no variables selected ----------------------------------+ |
+
| 85 | +49x | +
+ if (is_empty(variables)) {
+ |
+
| 86 | +! | +
+ return(dplyr::tibble() |> cards::as_card())+ |
+
| 87 | ++ |
+ }+ |
+
| 88 | ++ | + + | +
| 89 | ++ |
+ # compute the weighted statistics --------------------------------------------+ |
+
| 90 | +49x | +
+ df_stats <-+ |
+
| 91 | +49x | +
+ map(+ |
+
| 92 | +49x | +
+ names(statistic),+ |
+
| 93 | +49x | +
+ function(variable) {
+ |
+
| 94 | +90x | +
+ map(+ |
+
| 95 | +90x | +
+ statistic[[variable]],+ |
+
| 96 | +90x | +
+ function(statistic) {
+ |
+
| 97 | +318x | +
+ .compute_svy_stat(data, variable = variable, by = by, stat_name = statistic)+ |
+
| 98 | ++ |
+ }+ |
+
| 99 | ++ |
+ )+ |
+
| 100 | ++ |
+ }+ |
+
| 101 | ++ |
+ ) |>+ |
+
| 102 | +49x | +
+ dplyr::bind_rows()+ |
+
| 103 | ++ | + + | +
| 104 | ++ | + + | +
| 105 | ++ |
+ # add stat_labels ------------------------------------------------------------+ |
+
| 106 | +49x | +
+ df_stats <-+ |
+
| 107 | +49x | +
+ df_stats |>+ |
+
| 108 | +49x | +
+ dplyr::left_join(+ |
+
| 109 | +49x | +
+ .default_svy_stat_labels(),+ |
+
| 110 | +49x | +
+ by = "stat_name"+ |
+
| 111 | ++ |
+ ) |>+ |
+
| 112 | +49x | +
+ dplyr::mutate(stat_label = dplyr::coalesce(.data$stat_label, .data$stat_name))+ |
+
| 113 | +49x | +
+ if (!is_empty(stat_label)) {
+ |
+
| 114 | +1x | +
+ df_stats <-+ |
+
| 115 | +1x | +
+ dplyr::rows_update(+ |
+
| 116 | +1x | +
+ df_stats,+ |
+
| 117 | +1x | +
+ dplyr::tibble(+ |
+
| 118 | +1x | +
+ variable = names(stat_label),+ |
+
| 119 | +1x | +
+ stat_name = map(.data$variable, ~ names(stat_label[[.x]])),+ |
+
| 120 | +1x | +
+ stat_label = map(.data$variable, ~ stat_label[[.x]] |>+ |
+
| 121 | +1x | +
+ unname() |>+ |
+
| 122 | +1x | +
+ unlist())+ |
+
| 123 | ++ |
+ ) |>+ |
+
| 124 | +1x | +
+ tidyr::unnest(cols = c("stat_name", "stat_label")),
+ |
+
| 125 | +1x | +
+ by = c("variable", "stat_name"),
+ |
+
| 126 | +1x | +
+ unmatched = "ignore"+ |
+
| 127 | ++ |
+ )+ |
+
| 128 | ++ |
+ }+ |
+
| 129 | ++ | + + | +
| 130 | ++ |
+ # add formatting stats -------------------------------------------------------+ |
+
| 131 | +49x | +
+ df_stats$fmt_fn <- list(1L)+ |
+
| 132 | +49x | +
+ if (!is_empty(fmt_fn)) {
+ |
+
| 133 | +1x | +
+ df_stats <-+ |
+
| 134 | +1x | +
+ dplyr::rows_update(+ |
+
| 135 | +1x | +
+ df_stats,+ |
+
| 136 | +1x | +
+ dplyr::tibble(+ |
+
| 137 | +1x | +
+ variable = names(fmt_fn),+ |
+
| 138 | +1x | +
+ stat_name = map(.data$variable, ~ names(fmt_fn[[.x]])),+ |
+
| 139 | +1x | +
+ fmt_fn = map(.data$variable, ~ fmt_fn[[.x]] |> unname())+ |
+
| 140 | ++ |
+ ) |>+ |
+
| 141 | +1x | +
+ tidyr::unnest(cols = c("stat_name", "fmt_fn")),
+ |
+
| 142 | +1x | +
+ by = c("variable", "stat_name"),
+ |
+
| 143 | +1x | +
+ unmatched = "ignore"+ |
+
| 144 | ++ |
+ )+ |
+
| 145 | ++ |
+ }+ |
+
| 146 | ++ | + + | +
| 147 | ++ |
+ # add class and return ARD object --------------------------------------------+ |
+
| 148 | +49x | +
+ df_stats |>+ |
+
| 149 | +49x | +
+ dplyr::mutate(context = "continuous") |>+ |
+
| 150 | +49x | +
+ cards::as_card() |>+ |
+
| 151 | +49x | +
+ cards::tidy_ard_column_order()+ |
+
| 152 | ++ |
+ }+ |
+
| 153 | ++ | + + | +
| 154 | ++ |
+ .default_svy_stat_labels <- function(stat_label = NULL) {
+ |
+
| 155 | +49x | +
+ dplyr::tribble(+ |
+
| 156 | +49x | +
+ ~stat_name, ~stat_label,+ |
+
| 157 | +49x | +
+ "mean", "Mean",+ |
+
| 158 | +49x | +
+ "median", "Median",+ |
+
| 159 | +49x | +
+ "var", "Variance",+ |
+
| 160 | +49x | +
+ "sd", "Standard Deviation",+ |
+
| 161 | +49x | +
+ "sum", "Sum",+ |
+
| 162 | +49x | +
+ "deff", "Design Effect",+ |
+
| 163 | +49x | +
+ "mean.std.error", "SE(Mean)",+ |
+
| 164 | +49x | +
+ "min", "Minimum",+ |
+
| 165 | +49x | +
+ "max", "Maximum",+ |
+
| 166 | +49x | +
+ "p25", "25% Percentile",+ |
+
| 167 | +49x | +
+ "p75", "75% Percentile"+ |
+
| 168 | ++ |
+ )+ |
+
| 169 | ++ |
+ }+ |
+
| 170 | ++ | + + | +
| 171 | ++ |
+ accepted_svy_stats <- function(expand_quantiles = TRUE) {
+ |
+
| 172 | +90x | +
+ base_stats <-+ |
+
| 173 | +90x | +
+ c("mean", "median", "min", "max", "sum", "var", "sd", "mean.std.error", "deff")
+ |
+
| 174 | +90x | +
+ if (expand_quantiles) {
+ |
+
| 175 | +90x | +
+ return(c(base_stats, paste0("p", 0:100)))
+ |
+
| 176 | ++ |
+ }+ |
+
| 177 | +! | +
+ c(base_stats, "p##")+ |
+
| 178 | ++ |
+ }+ |
+
| 179 | ++ | + + | +
| 180 | ++ | + + | +
| 181 | ++ | + + | +
| 182 | ++ |
+ # this function calculates the summary for a single variable, single statistic+ |
+
| 183 | ++ |
+ # and for all `by` levels. it returns an ARD data frame+ |
+
| 184 | ++ |
+ .compute_svy_stat <- function(data, variable, by = NULL, stat_name) {
+ |
+
| 185 | ++ |
+ # difftime variable needs to be transformed into numeric for svyquantile+ |
+
| 186 | +318x | +
+ if (inherits(data$variables[[variable]], "difftime")) {
+ |
+
| 187 | +! | +
+ data$variables[[variable]] <- unclass(data$variables[[variable]])+ |
+
| 188 | ++ |
+ }+ |
+
| 189 | ++ | + + | +
| 190 | ++ |
+ # styler: off+ |
+
| 191 | +12x | +
+ if (stat_name %in% "mean") args <- list(FUN = survey::svymean)+ |
+
| 192 | +6x | +
+ else if (stat_name %in% "sum") args <- list(FUN = survey::svytotal)+ |
+
| 193 | +6x | +
+ else if (stat_name %in% "var") args <- list(FUN = survey::svyvar)+ |
+
| 194 | +6x | +
+ else if (stat_name %in% "sd") args <- list(FUN = \(...) survey::svyvar(...) |> sqrt())+ |
+
| 195 | +6x | +
+ else if (stat_name %in% "mean.std.error") args <- list(FUN = \(...) survey::svymean(...) |> survey::SE())+ |
+
| 196 | +6x | +
+ else if (stat_name %in% "deff") args <- list(FUN = \(...) survey::svymean(..., deff = TRUE) |> survey::deff())+ |
+
| 197 | +12x | +
+ else if (stat_name %in% "min") args <- list(FUN = \(x, design, na.rm, ...) min(design$variables[[all.vars(x)]], na.rm = na.rm))+ |
+
| 198 | +12x | +
+ else if (stat_name %in% "max") args <- list(FUN = \(x, design, na.rm, ...) max(design$variables[[all.vars(x)]], na.rm = na.rm))+ |
+
| 199 | ++ |
+ # define functions for the quantiles+ |
+
| 200 | +252x | +
+ else if (stat_name %in% c("median", paste0("p", 0:100))) {
+ |
+
| 201 | +252x | +
+ quantile <- ifelse(stat_name %in% "median", 0.5, as.numeric(substr(stat_name, 2, nchar(stat_name))) / 100)+ |
+
| 202 | ++ |
+ # univariate results are returned in a different format from stratified.+ |
+
| 203 | +252x | +
+ args <-+ |
+
| 204 | +252x | +
+ if (is_empty(by)) list(FUN = \(...) survey::svyquantile(...)[[1]], quantiles = quantile)+ |
+
| 205 | +252x | +
+ else list(FUN = \(...) survey::svyquantile(...), quantiles = quantile)+ |
+
| 206 | ++ |
+ }+ |
+
| 207 | ++ |
+ # styler: on+ |
+
| 208 | ++ | + + | +
| 209 | ++ |
+ # adding additional args to pass+ |
+
| 210 | +318x | +
+ args <-+ |
+
| 211 | +318x | +
+ args |>+ |
+
| 212 | +318x | +
+ append(+ |
+
| 213 | +318x | +
+ list(+ |
+
| 214 | +318x | +
+ design = data,+ |
+
| 215 | ++ |
+ # if all values are NA, turn na.rm to FALSE to avoid error+ |
+
| 216 | +318x | +
+ na.rm = !all(is.na(data$variables[[variable]])),+ |
+
| 217 | +318x | +
+ keep.var = FALSE+ |
+
| 218 | ++ |
+ )+ |
+
| 219 | ++ |
+ )+ |
+
| 220 | ++ | + + | +
| 221 | ++ | + + | +
| 222 | ++ |
+ # if no by variable, calculate univariate statistics+ |
+
| 223 | +318x | +
+ if (is_empty(by)) {
+ |
+
| 224 | +46x | +
+ args$x <- reformulate2(variable)+ |
+
| 225 | ++ |
+ # calculate statistic (and remove FUN from the argument list)+ |
+
| 226 | +46x | +
+ stat <-+ |
+
| 227 | +46x | +
+ cards::eval_capture_conditions(+ |
+
| 228 | +46x | +
+ do.call(args$FUN, args = args |> utils::modifyList(list(FUN = NULL)))+ |
+
| 229 | ++ |
+ )+ |
+
| 230 | ++ |
+ # if the result was calculated, then put it into a tibble+ |
+
| 231 | +46x | +
+ if (!is.null(stat[["result"]])) {
+ |
+
| 232 | +40x | +
+ df_stat <-+ |
+
| 233 | +40x | +
+ dplyr::tibble(variable, stat[["result"]][1]) |>+ |
+
| 234 | +40x | +
+ set_names(c("variable", "stat")) |>
+ |
+
| 235 | +40x | +
+ dplyr::mutate(+ |
+
| 236 | +40x | +
+ stat = as.list(unname(.data$stat)),+ |
+
| 237 | +40x | +
+ warning = list(stat[["warning"]]),+ |
+
| 238 | +40x | +
+ error = list(stat[["error"]])+ |
+
| 239 | ++ |
+ )+ |
+
| 240 | ++ |
+ }+ |
+
| 241 | ++ |
+ # otherwise, if there was an error return tibble with error message+ |
+
| 242 | ++ |
+ else {
+ |
+
| 243 | +6x | +
+ df_stat <-+ |
+
| 244 | +6x | +
+ dplyr::tibble(+ |
+
| 245 | +6x | +
+ variable = .env$variable,+ |
+
| 246 | +6x | +
+ stat = list(NULL),+ |
+
| 247 | +6x | +
+ warning = list(.env$stat[["warning"]]),+ |
+
| 248 | +6x | +
+ error = list(.env$stat[["error"]])+ |
+
| 249 | ++ |
+ )+ |
+
| 250 | ++ |
+ }+ |
+
| 251 | ++ |
+ }+ |
+
| 252 | ++ | + + | +
| 253 | ++ |
+ # if there is by variable(s), calculate statistics for the combinations+ |
+
| 254 | ++ |
+ else {
+ |
+
| 255 | +272x | +
+ args$formula <- reformulate2(variable)+ |
+
| 256 | +272x | +
+ args$by <- reformulate2(by)+ |
+
| 257 | +272x | +
+ stat <-+ |
+
| 258 | +272x | +
+ if (stat_name %in% c("median", paste0("p", 0:100))) {
+ |
+
| 259 | +242x | +
+ cards::eval_capture_conditions(+ |
+
| 260 | +242x | +
+ do.call(survey::svyby, args) |> set_names(c(by, "quantile", "ci.2.5", "ci.97.5", "se"))+ |
+
| 261 | ++ |
+ )+ |
+
| 262 | +272x | +
+ } else if (stat_name %in% "deff") {
+ |
+
| 263 | +3x | +
+ stat <-+ |
+
| 264 | +3x | +
+ cards::eval_capture_conditions(+ |
+
| 265 | +3x | +
+ do.call(+ |
+
| 266 | +3x | +
+ survey::svyby,+ |
+
| 267 | +3x | +
+ args |> utils::modifyList(list(FUN = survey::svymean, deff = TRUE))+ |
+
| 268 | ++ |
+ ) |>+ |
+
| 269 | +3x | +
+ dplyr::select(all_of(by), dplyr::last_col()) # the last column is DEff+ |
+
| 270 | ++ |
+ )+ |
+
| 271 | ++ |
+ } else {
+ |
+
| 272 | +27x | +
+ cards::eval_capture_conditions(do.call(survey::svyby, args))+ |
+
| 273 | ++ |
+ }+ |
+
| 274 | ++ | + + | +
| 275 | ++ |
+ # if the result was calculated, then put it into a tibble+ |
+
| 276 | +272x | +
+ if (!is.null(stat[["result"]])) {
+ |
+
| 277 | +116x | +
+ df_stat <- stat[["result"]][seq_len(length(by) + 1L)] |>+ |
+
| 278 | +116x | +
+ dplyr::as_tibble() %>%+ |
+
| 279 | ++ |
+ # adding unobserved combinations of "by" variables+ |
+
| 280 | ++ |
+ {
+ |
+
| 281 | +116x | +
+ dplyr::full_join(+ |
+
| 282 | +116x | +
+ cards::nest_for_ard(data$variables, by = by, key = "...ard_no_one_will_ever_pick_this...", rename = FALSE, list_columns = FALSE) |>+ |
+
| 283 | +116x | +
+ dplyr::select(-"...ard_no_one_will_ever_pick_this..."),+ |
+
| 284 | ++ |
+ .,+ |
+
| 285 | +116x | +
+ by = by+ |
+
| 286 | ++ |
+ )+ |
+
| 287 | ++ |
+ } |>+ |
+
| 288 | +116x | +
+ set_names(paste0("group", seq_along(by), "_level"), "stat") |>
+ |
+
| 289 | +116x | +
+ dplyr::bind_cols(+ |
+
| 290 | +116x | +
+ dplyr::tibble(!!!c(by, variable)) |>+ |
+
| 291 | +116x | +
+ set_names(paste0("group", seq_along(by)), "variable")
+ |
+
| 292 | ++ |
+ ) |>+ |
+
| 293 | +116x | +
+ dplyr::mutate(+ |
+
| 294 | +116x | +
+ dplyr::across(c(cards::all_ard_groups("levels"), "stat"), as.list),
+ |
+
| 295 | +116x | +
+ warning = list(.env$stat[["warning"]]),+ |
+
| 296 | +116x | +
+ error = list(.env$stat[["error"]])+ |
+
| 297 | ++ |
+ )+ |
+
| 298 | ++ |
+ }+ |
+
| 299 | ++ |
+ # otherwise, if there was an error return tibble with error message+ |
+
| 300 | ++ |
+ else {
+ |
+
| 301 | +156x | +
+ df_stat <-+ |
+
| 302 | +156x | +
+ cards::nest_for_ard(data$variables, by = by, key = "...ard_no_one_will_ever_pick_this...") |>+ |
+
| 303 | +156x | +
+ dplyr::select(-"...ard_no_one_will_ever_pick_this...") |>+ |
+
| 304 | +156x | +
+ dplyr::mutate(+ |
+
| 305 | +156x | +
+ variable = .env$variable,+ |
+
| 306 | +156x | +
+ stat = list(NULL),+ |
+
| 307 | +156x | +
+ warning = list(.env$stat[["warning"]]),+ |
+
| 308 | +156x | +
+ error = list(.env$stat[["error"]])+ |
+
| 309 | ++ |
+ )+ |
+
| 310 | ++ |
+ }+ |
+
| 311 | ++ |
+ }+ |
+
| 312 | ++ | + + | +
| 313 | +318x | +
+ df_stat |>+ |
+
| 314 | +318x | +
+ dplyr::mutate(+ |
+
| 315 | +318x | +
+ stat_name = .env$stat_name,+ |
+
| 316 | +318x | +
+ across(+ |
+
| 317 | +318x | +
+ c(cards::all_ard_groups("levels"), cards::all_ard_variables("levels")),
+ |
+
| 318 | +318x | +
+ ~ map(.x, as.character)+ |
+
| 319 | ++ |
+ )+ |
+
| 320 | ++ |
+ )+ |
+
| 321 | ++ |
+ }+ |
+
| 1 | ++ |
+ #' ARD McNemar's Test+ |
+
| 2 | ++ |
+ #'+ |
+
| 3 | ++ |
+ #' @description+ |
+
| 4 | ++ |
+ #' Analysis results data for McNemar's statistical test.+ |
+
| 5 | ++ |
+ #' We have two functions depending on the structure of the data.+ |
+
| 6 | ++ |
+ #' - `ard_stats_mcnemar_test()` is the structure expected by [`stats::mcnemar.test()`]+ |
+
| 7 | ++ |
+ #' - `ard_stats_mcnemar_test_long()` is one row per ID per group+ |
+
| 8 | ++ |
+ #'+ |
+
| 9 | ++ |
+ #' @param data (`data.frame`)\cr+ |
+
| 10 | ++ |
+ #' a data frame. See below for details.+ |
+
| 11 | ++ |
+ #' @param by ([`tidy-select`][dplyr::dplyr_tidy_select])\cr+ |
+
| 12 | ++ |
+ #' column name to compare by.+ |
+
| 13 | ++ |
+ #' @param variables ([`tidy-select`][dplyr::dplyr_tidy_select])\cr+ |
+
| 14 | ++ |
+ #' column names to be compared. Independent tests will+ |
+
| 15 | ++ |
+ #' be computed for each variable.+ |
+
| 16 | ++ |
+ #' @param ... arguments passed to `stats::mcnemar.test(...)`+ |
+
| 17 | ++ |
+ #' @param id ([`tidy-select`][dplyr::dplyr_tidy_select])\cr+ |
+
| 18 | ++ |
+ #' column name of the subject or participant ID+ |
+
| 19 | ++ |
+ #'+ |
+
| 20 | ++ |
+ #' @return ARD data frame+ |
+
| 21 | ++ |
+ #' @name ard_stats_mcnemar_test+ |
+
| 22 | ++ |
+ #'+ |
+
| 23 | ++ |
+ #' @details+ |
+
| 24 | ++ |
+ #' For the `ard_stats_mcnemar_test()` function, the data is expected to be one row per subject.+ |
+
| 25 | ++ |
+ #' The data is passed as `stats::mcnemar.test(x = data[[variable]], y = data[[by]], ...)`.+ |
+
| 26 | ++ |
+ #' Please use `table(x = data[[variable]], y = data[[by]])` to check the contingency table.+ |
+
| 27 | ++ |
+ #'+ |
+
| 28 | ++ |
+ #' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = "broom", reference_pkg = "cardx"))
+ |
+
| 29 | ++ |
+ #' cards::ADSL |>+ |
+
| 30 | ++ |
+ #' ard_stats_mcnemar_test(by = "SEX", variables = "EFFFL")+ |
+
| 31 | ++ |
+ #'+ |
+
| 32 | ++ |
+ #' set.seed(1234)+ |
+
| 33 | ++ |
+ #' cards::ADSL[c("USUBJID", "TRT01P")] |>
+ |
+
| 34 | ++ |
+ #' dplyr::mutate(TYPE = "PLANNED") |>+ |
+
| 35 | ++ |
+ #' dplyr::rename(TRT01 = TRT01P) %>%+ |
+
| 36 | ++ |
+ #' dplyr::bind_rows(dplyr::mutate(., TYPE = "ACTUAL", TRT01 = sample(TRT01))) |>+ |
+
| 37 | ++ |
+ #' ard_stats_mcnemar_test_long(+ |
+
| 38 | ++ |
+ #' by = TYPE,+ |
+
| 39 | ++ |
+ #' variable = TRT01,+ |
+
| 40 | ++ |
+ #' id = USUBJID+ |
+
| 41 | ++ |
+ #' )+ |
+
| 42 | ++ |
+ NULL+ |
+
| 43 | ++ | + + | +
| 44 | ++ |
+ #' @rdname ard_stats_mcnemar_test+ |
+
| 45 | ++ |
+ #' @export+ |
+
| 46 | ++ |
+ ard_stats_mcnemar_test <- function(data, by, variables, ...) {
+ |
+
| 47 | +7x | +
+ set_cli_abort_call()+ |
+
| 48 | ++ | + + | +
| 49 | ++ |
+ # check installed packages ---------------------------------------------------+ |
+
| 50 | +7x | +
+ check_pkg_installed("broom", reference_pkg = "cardx")
+ |
+
| 51 | ++ | + + | +
| 52 | ++ |
+ # check/process inputs -------------------------------------------------------+ |
+
| 53 | +7x | +
+ check_not_missing(data)+ |
+
| 54 | +7x | +
+ check_not_missing(variables)+ |
+
| 55 | +7x | +
+ check_not_missing(by)+ |
+
| 56 | +7x | +
+ check_data_frame(data)+ |
+
| 57 | +7x | +
+ data <- dplyr::ungroup(data)+ |
+
| 58 | +7x | +
+ cards::process_selectors(data, by = {{ by }}, variables = {{ variables }})
+ |
+
| 59 | +7x | +
+ check_scalar(by)+ |
+
| 60 | ++ | + + | +
| 61 | ++ |
+ # return empty ARD if no variables selected ----------------------------------+ |
+
| 62 | +7x | +
+ if (is_empty(variables)) {
+ |
+
| 63 | +! | +
+ return(dplyr::tibble() |> cards::as_card())+ |
+
| 64 | ++ |
+ }+ |
+
| 65 | ++ | + + | +
| 66 | ++ |
+ # build ARD ------------------------------------------------------------------+ |
+
| 67 | +7x | +
+ lapply(+ |
+
| 68 | +7x | +
+ variables,+ |
+
| 69 | +7x | +
+ function(variable) {
+ |
+
| 70 | +8x | +
+ .format_mcnemartest_results(+ |
+
| 71 | +8x | +
+ by = by,+ |
+
| 72 | +8x | +
+ variable = variable,+ |
+
| 73 | +8x | +
+ lst_tidy =+ |
+
| 74 | +8x | +
+ cards::eval_capture_conditions(+ |
+
| 75 | +8x | +
+ stats::mcnemar.test(x = data[[variable]], y = data[[by]], ...) |>+ |
+
| 76 | +8x | +
+ broom::tidy()+ |
+
| 77 | ++ |
+ ),+ |
+
| 78 | ++ |
+ ...+ |
+
| 79 | ++ |
+ )+ |
+
| 80 | ++ |
+ }+ |
+
| 81 | ++ |
+ ) |>+ |
+
| 82 | +7x | +
+ dplyr::bind_rows()+ |
+
| 83 | ++ |
+ }+ |
+
| 84 | ++ | + + | +
| 85 | ++ |
+ #' @rdname ard_stats_mcnemar_test+ |
+
| 86 | ++ |
+ #' @export+ |
+
| 87 | ++ |
+ ard_stats_mcnemar_test_long <- function(data, by, variables, id, ...) {
+ |
+
| 88 | +1x | +
+ set_cli_abort_call()+ |
+
| 89 | ++ | + + | +
| 90 | ++ |
+ # check installed packages ---------------------------------------------------+ |
+
| 91 | +1x | +
+ check_pkg_installed("broom", reference_pkg = "cardx")
+ |
+
| 92 | ++ | + + | +
| 93 | ++ |
+ # check/process inputs -------------------------------------------------------+ |
+
| 94 | +1x | +
+ check_not_missing(data)+ |
+
| 95 | +1x | +
+ check_not_missing(variables)+ |
+
| 96 | +1x | +
+ check_not_missing(by)+ |
+
| 97 | +1x | +
+ check_not_missing(id)+ |
+
| 98 | +1x | +
+ check_data_frame(data)+ |
+
| 99 | +1x | +
+ data <- dplyr::ungroup(data)+ |
+
| 100 | +1x | +
+ cards::process_selectors(data, by = {{ by }}, variables = {{ variables }}, id = {{ id }})
+ |
+
| 101 | +1x | +
+ check_scalar(by)+ |
+
| 102 | +1x | +
+ check_scalar(id)+ |
+
| 103 | ++ | + + | +
| 104 | ++ |
+ # return empty ARD if no variables selected ----------------------------------+ |
+
| 105 | +1x | +
+ if (is_empty(variables)) {
+ |
+
| 106 | +! | +
+ return(dplyr::tibble() |> cards::as_card())+ |
+
| 107 | ++ |
+ }+ |
+
| 108 | ++ | + + | +
| 109 | ++ |
+ # build ARD ------------------------------------------------------------------+ |
+
| 110 | +1x | +
+ lapply(+ |
+
| 111 | +1x | +
+ variables,+ |
+
| 112 | +1x | +
+ function(variable) {
+ |
+
| 113 | +1x | +
+ .format_mcnemartest_results(+ |
+
| 114 | +1x | +
+ by = by,+ |
+
| 115 | +1x | +
+ variable = variable,+ |
+
| 116 | +1x | +
+ lst_tidy =+ |
+
| 117 | +1x | +
+ cards::eval_capture_conditions({
+ |
+
| 118 | ++ |
+ # adding this reshape inside the eval, so if there is an error it's captured in the ARD object+ |
+
| 119 | +1x | +
+ data_wide <- .paired_data_pivot_wider(data, by = by, variable = variable, id = id)+ |
+
| 120 | ++ |
+ # performing McNemars test+ |
+
| 121 | +1x | +
+ stats::mcnemar.test(x = data_wide[["by1"]], y = data_wide[["by2"]], ...) |>+ |
+
| 122 | +1x | +
+ broom::tidy()+ |
+
| 123 | ++ |
+ }),+ |
+
| 124 | ++ |
+ ...+ |
+
| 125 | ++ |
+ )+ |
+
| 126 | ++ |
+ }+ |
+
| 127 | ++ |
+ ) |>+ |
+
| 128 | +1x | +
+ dplyr::bind_rows()+ |
+
| 129 | ++ |
+ }+ |
+
| 130 | ++ | + + | +
| 131 | ++ |
+ #' Convert McNemar's test to ARD+ |
+
| 132 | ++ |
+ #'+ |
+
| 133 | ++ |
+ #' @inheritParams cards::tidy_as_ard+ |
+
| 134 | ++ |
+ #' @inheritParams stats::mcnemar.test+ |
+
| 135 | ++ |
+ #' @param by (`string`)\cr by column name+ |
+
| 136 | ++ |
+ #' @param variable (`string`)\cr variable column name+ |
+
| 137 | ++ |
+ #' @param ... passed to `stats::mcnemar.test(...)`+ |
+
| 138 | ++ |
+ #'+ |
+
| 139 | ++ |
+ #' @return ARD data frame+ |
+
| 140 | ++ |
+ #'+ |
+
| 141 | ++ |
+ #' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = "broom", reference_pkg = "cardx"))
+ |
+
| 142 | ++ |
+ #' cardx:::.format_mcnemartest_results(+ |
+
| 143 | ++ |
+ #' by = "ARM",+ |
+
| 144 | ++ |
+ #' variable = "AGE",+ |
+
| 145 | ++ |
+ #' lst_tidy =+ |
+
| 146 | ++ |
+ #' cards::eval_capture_conditions(+ |
+
| 147 | ++ |
+ #' stats::mcnemar.test(cards::ADSL[["SEX"]], cards::ADSL[["EFFFL"]]) |>+ |
+
| 148 | ++ |
+ #' broom::tidy()+ |
+
| 149 | ++ |
+ #' )+ |
+
| 150 | ++ |
+ #' )+ |
+
| 151 | ++ |
+ #'+ |
+
| 152 | ++ |
+ #' @keywords internal+ |
+
| 153 | ++ |
+ .format_mcnemartest_results <- function(by, variable, lst_tidy, ...) {
+ |
+
| 154 | ++ |
+ # build ARD ------------------------------------------------------------------+ |
+
| 155 | +9x | +
+ ret <-+ |
+
| 156 | +9x | +
+ cards::tidy_as_ard(+ |
+
| 157 | +9x | +
+ lst_tidy = lst_tidy,+ |
+
| 158 | +9x | +
+ tidy_result_names = c("statistic", "p.value", "method"),
+ |
+
| 159 | +9x | +
+ fun_args_to_record = c("correct"),
+ |
+
| 160 | +9x | +
+ formals = formals(asNamespace("stats")[["mcnemar.test"]]),
+ |
+
| 161 | +9x | +
+ passed_args = dots_list(...),+ |
+
| 162 | +9x | +
+ lst_ard_columns = list(group1 = by, variable = variable, context = "stats_mcnemar_test")+ |
+
| 163 | ++ |
+ )+ |
+
| 164 | ++ | + + | +
| 165 | ++ |
+ # add the stat label ---------------------------------------------------------+ |
+
| 166 | +9x | +
+ ret |>+ |
+
| 167 | +9x | +
+ dplyr::left_join(+ |
+
| 168 | +9x | +
+ .df_mcnemar_stat_labels(),+ |
+
| 169 | +9x | +
+ by = "stat_name"+ |
+
| 170 | ++ |
+ ) |>+ |
+
| 171 | +9x | +
+ dplyr::mutate(stat_label = dplyr::coalesce(.data$stat_label, .data$stat_name)) |>+ |
+
| 172 | +9x | +
+ cards::as_card() |>+ |
+
| 173 | +9x | +
+ cards::tidy_ard_column_order()+ |
+
| 174 | ++ |
+ }+ |
+
| 175 | ++ | + + | +
| 176 | ++ |
+ .df_mcnemar_stat_labels <- function() {
+ |
+
| 177 | +9x | +
+ dplyr::tribble(+ |
+
| 178 | +9x | +
+ ~stat_name, ~stat_label,+ |
+
| 179 | +9x | +
+ "statistic", "X-squared Statistic",+ |
+
| 180 | +9x | +
+ "parameter", "Degrees of Freedom",+ |
+
| 181 | +9x | +
+ "p.value", "p-value",+ |
+
| 182 | ++ |
+ )+ |
+
| 183 | ++ |
+ }+ |
+
| 1 | ++ |
+ #' ARD One-way Test+ |
+
| 2 | ++ |
+ #'+ |
+
| 3 | ++ |
+ #' @description+ |
+
| 4 | ++ |
+ #' Analysis results data for Testing Equal Means in a One-Way Layout.+ |
+
| 5 | ++ |
+ #' calculated with `oneway.test()`+ |
+
| 6 | ++ |
+ #'+ |
+
| 7 | ++ |
+ #' @inheritParams stats::oneway.test+ |
+
| 8 | ++ |
+ #' @param ... additional arguments passed to `oneway.test(...)`+ |
+
| 9 | ++ |
+ #'+ |
+
| 10 | ++ |
+ #' @return ARD data frame+ |
+
| 11 | ++ |
+ #' @export+ |
+
| 12 | ++ |
+ #'+ |
+
| 13 | ++ |
+ #' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = "broom", reference_pkg = "cardx"))
+ |
+
| 14 | ++ |
+ #' ard_stats_oneway_test(AGE ~ ARM, data = cards::ADSL)+ |
+
| 15 | ++ |
+ ard_stats_oneway_test <- function(formula, data, ...) {
+ |
+
| 16 | +3x | +
+ set_cli_abort_call()+ |
+
| 17 | ++ | + + | +
| 18 | ++ |
+ # check installed packages ---------------------------------------------------+ |
+
| 19 | +3x | +
+ check_pkg_installed(c("broom"), reference_pkg = "cardx")
+ |
+
| 20 | ++ | + + | +
| 21 | ++ |
+ # check/process inputs -------------------------------------------------------+ |
+
| 22 | +3x | +
+ check_not_missing(formula)+ |
+
| 23 | +3x | +
+ check_not_missing(data)+ |
+
| 24 | +3x | +
+ check_data_frame(data)+ |
+
| 25 | +3x | +
+ check_class(formula, cls = "formula")+ |
+
| 26 | ++ | + + | +
| 27 | ++ |
+ # build ARD ------------------------------------------------------------------+ |
+
| 28 | +3x | +
+ df_results <-+ |
+
| 29 | +3x | +
+ cards::tidy_as_ard(+ |
+
| 30 | +3x | +
+ lst_tidy =+ |
+
| 31 | +3x | +
+ cards::eval_capture_conditions(+ |
+
| 32 | +3x | +
+ stats::oneway.test(formula, data = data, ...) |>+ |
+
| 33 | +3x | +
+ broom::tidy()+ |
+
| 34 | ++ |
+ ),+ |
+
| 35 | +3x | +
+ tidy_result_names = c("num.df", "den.df", "statistic", "p.value", "method"),
+ |
+
| 36 | +3x | +
+ fun_args_to_record =+ |
+
| 37 | +3x | +
+ c("var.equal"),
+ |
+
| 38 | +3x | +
+ formals = formals(stats::oneway.test),+ |
+
| 39 | +3x | +
+ passed_args = dots_list(...),+ |
+
| 40 | +3x | +
+ lst_ard_columns = list(context = "stats_oneway_test")+ |
+
| 41 | ++ |
+ ) |>+ |
+
| 42 | +3x | +
+ dplyr::mutate(+ |
+
| 43 | +3x | +
+ .after = "stat_name",+ |
+
| 44 | +3x | +
+ stat_label =+ |
+
| 45 | +3x | +
+ dplyr::case_when(+ |
+
| 46 | +3x | +
+ .data$stat_name %in% "num.df" ~ "Degrees of Freedom",+ |
+
| 47 | +3x | +
+ .data$stat_name %in% "den.df" ~ "Denominator Degrees of Freedom",+ |
+
| 48 | +3x | +
+ .data$stat_name %in% "statistic" ~ "F Statistic",+ |
+
| 49 | +3x | +
+ .data$stat_name %in% "p.value" ~ "p-value",+ |
+
| 50 | +3x | +
+ .data$stat_name %in% "method" ~ "Method",+ |
+
| 51 | +3x | +
+ TRUE ~ .data$stat_name,+ |
+
| 52 | ++ |
+ )+ |
+
| 53 | ++ |
+ )+ |
+
| 54 | ++ | + + | +
| 55 | ++ |
+ # add variable/groups to results and return result+ |
+
| 56 | +3x | +
+ df_results |>+ |
+
| 57 | +3x | +
+ dplyr::bind_cols(+ |
+
| 58 | +3x | +
+ dplyr::tibble(!!!map(as.list(attr(stats::terms(formula), "variables"))[-1], as_label)) %>%+ |
+
| 59 | +3x | +
+ set_names(., c("variable", paste0("group", seq_len(length(.) - 1L))))
+ |
+
| 60 | ++ |
+ ) |>+ |
+
| 61 | +3x | +
+ cards::as_card() |>+ |
+
| 62 | +3x | +
+ cards::tidy_ard_column_order()+ |
+
| 63 | ++ |
+ }+ |
+
| 1 | ++ |
+ #' ARD Mood Test+ |
+
| 2 | ++ |
+ #'+ |
+
| 3 | ++ |
+ #' @description+ |
+
| 4 | ++ |
+ #' Analysis results data for Mood two sample test of scale. Note this not to be confused with+ |
+
| 5 | ++ |
+ #' the Brown-Mood test of medians.+ |
+
| 6 | ++ |
+ #'+ |
+
| 7 | ++ |
+ #' @param data (`data.frame`)\cr+ |
+
| 8 | ++ |
+ #' a data frame. See below for details.+ |
+
| 9 | ++ |
+ #' @param by ([`tidy-select`][dplyr::dplyr_tidy_select])\cr+ |
+
| 10 | ++ |
+ #' column name to compare by.+ |
+
| 11 | ++ |
+ #' @param variables ([`tidy-select`][dplyr::dplyr_tidy_select])\cr+ |
+
| 12 | ++ |
+ #' column name to be compared. Independent tests will+ |
+
| 13 | ++ |
+ #' be run for each variable.+ |
+
| 14 | ++ |
+ #' @param ... arguments passed to `mood.test(...)`+ |
+
| 15 | ++ |
+ #'+ |
+
| 16 | ++ |
+ #' @return ARD data frame+ |
+
| 17 | ++ |
+ #' @name ard_stats_mood_test+ |
+
| 18 | ++ |
+ #'+ |
+
| 19 | ++ |
+ #' @details+ |
+
| 20 | ++ |
+ #' For the `ard_stats_mood_test()` function, the data is expected to be one row per subject.+ |
+
| 21 | ++ |
+ #' The data is passed as `mood.test(data[[variable]] ~ data[[by]], ...)`.+ |
+
| 22 | ++ |
+ #' @rdname ard_stats_mood_test+ |
+
| 23 | ++ |
+ #' @export+ |
+
| 24 | ++ |
+ #'+ |
+
| 25 | ++ |
+ #' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = "broom", reference_pkg = "cardx"))
+ |
+
| 26 | ++ |
+ #' cards::ADSL |>+ |
+
| 27 | ++ |
+ #' ard_stats_mood_test(by = "SEX", variables = "AGE")+ |
+
| 28 | ++ |
+ ard_stats_mood_test <- function(data, by, variables, ...) {
+ |
+
| 29 | +3x | +
+ set_cli_abort_call()+ |
+
| 30 | ++ | + + | +
| 31 | ++ |
+ # check installed packages ---------------------------------------------------+ |
+
| 32 | +3x | +
+ check_pkg_installed("broom", reference_pkg = "cardx")
+ |
+
| 33 | ++ | + + | +
| 34 | ++ |
+ # check/process inputs -------------------------------------------------------+ |
+
| 35 | +3x | +
+ check_not_missing(data)+ |
+
| 36 | +3x | +
+ check_not_missing(variables)+ |
+
| 37 | +3x | +
+ check_not_missing(by)+ |
+
| 38 | +3x | +
+ check_data_frame(data)+ |
+
| 39 | +3x | +
+ data <- dplyr::ungroup(data)+ |
+
| 40 | +3x | +
+ cards::process_selectors(data, by = {{ by }}, variables = {{ variables }})
+ |
+
| 41 | +3x | +
+ check_scalar(by)+ |
+
| 42 | ++ | + + | +
| 43 | ++ |
+ # return empty ARD if no variables selected ----------------------------------+ |
+
| 44 | +3x | +
+ if (is_empty(variables)) {
+ |
+
| 45 | +! | +
+ return(dplyr::tibble() |> cards::as_card())+ |
+
| 46 | ++ |
+ }+ |
+
| 47 | ++ | + + | +
| 48 | ++ |
+ # build ARD ------------------------------------------------------------------+ |
+
| 49 | +3x | +
+ lapply(+ |
+
| 50 | +3x | +
+ variables,+ |
+
| 51 | +3x | +
+ function(variable) {
+ |
+
| 52 | +3x | +
+ .format_moodtest_results(+ |
+
| 53 | +3x | +
+ by = by,+ |
+
| 54 | +3x | +
+ variable = variable,+ |
+
| 55 | +3x | +
+ lst_tidy =+ |
+
| 56 | +3x | +
+ cards::eval_capture_conditions(+ |
+
| 57 | +3x | +
+ stats::mood.test(data[[variable]] ~ data[[by]], ...) |>+ |
+
| 58 | +3x | +
+ broom::tidy()+ |
+
| 59 | ++ |
+ ),+ |
+
| 60 | ++ |
+ ...+ |
+
| 61 | ++ |
+ )+ |
+
| 62 | ++ |
+ }+ |
+
| 63 | ++ |
+ ) |>+ |
+
| 64 | +3x | +
+ dplyr::bind_rows()+ |
+
| 65 | ++ |
+ }+ |
+
| 66 | ++ |
+ #' Convert mood test results to ARD+ |
+
| 67 | ++ |
+ #'+ |
+
| 68 | ++ |
+ #' @inheritParams cards::tidy_as_ard+ |
+
| 69 | ++ |
+ #' @inheritParams stats::mood.test+ |
+
| 70 | ++ |
+ #' @param by (`string`)\cr by column name+ |
+
| 71 | ++ |
+ #' @param variable (`string`)\cr variable column name+ |
+
| 72 | ++ |
+ #' @param ... passed to `mood.test(...)`+ |
+
| 73 | ++ |
+ #'+ |
+
| 74 | ++ |
+ #' @return ARD data frame+ |
+
| 75 | ++ |
+ #' @keywords internal+ |
+
| 76 | ++ |
+ #' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = "broom", reference_pkg = "cardx"))
+ |
+
| 77 | ++ |
+ #' cardx:::.format_moodtest_results(+ |
+
| 78 | ++ |
+ #' by = "SEX",+ |
+
| 79 | ++ |
+ #' variable = "AGE",+ |
+
| 80 | ++ |
+ #' lst_tidy =+ |
+
| 81 | ++ |
+ #' cards::eval_capture_conditions(+ |
+
| 82 | ++ |
+ #' stats::mood.test(ADSL[["AGE"]] ~ ADSL[["SEX"]]) |>+ |
+
| 83 | ++ |
+ #' broom::tidy()+ |
+
| 84 | ++ |
+ #' )+ |
+
| 85 | ++ |
+ #' )+ |
+
| 86 | ++ |
+ .format_moodtest_results <- function(by, variable, lst_tidy, ...) {
+ |
+
| 87 | ++ |
+ # build ARD ------------------------------------------------------------------+ |
+
| 88 | +3x | +
+ ret <-+ |
+
| 89 | +3x | +
+ cards::tidy_as_ard(+ |
+
| 90 | +3x | +
+ lst_tidy = lst_tidy,+ |
+
| 91 | +3x | +
+ tidy_result_names = c("statistic", "p.value", "method", "alternative"),
+ |
+
| 92 | +3x | +
+ formals = formals(asNamespace("stats")[["mood.test.default"]]),
+ |
+
| 93 | +3x | +
+ passed_args = c(dots_list(...)),+ |
+
| 94 | +3x | +
+ lst_ard_columns = list(group1 = by, variable = variable, context = "stats_mood_test")+ |
+
| 95 | ++ |
+ )+ |
+
| 96 | ++ | + + | +
| 97 | ++ |
+ # add the stat label ---------------------------------------------------------+ |
+
| 98 | +3x | +
+ ret |>+ |
+
| 99 | +3x | +
+ dplyr::left_join(+ |
+
| 100 | +3x | +
+ .df_moodtest_stat_labels(),+ |
+
| 101 | +3x | +
+ by = "stat_name"+ |
+
| 102 | ++ |
+ ) |>+ |
+
| 103 | +3x | +
+ dplyr::mutate(stat_label = dplyr::coalesce(.data$stat_label, .data$stat_name)) |>+ |
+
| 104 | +3x | +
+ cards::as_card() |>+ |
+
| 105 | +3x | +
+ cards::tidy_ard_column_order()+ |
+
| 106 | ++ |
+ }+ |
+
| 107 | ++ | + + | +
| 108 | ++ |
+ .df_moodtest_stat_labels <- function() {
+ |
+
| 109 | +3x | +
+ dplyr::tribble(+ |
+
| 110 | +3x | +
+ ~stat_name, ~stat_label,+ |
+
| 111 | +3x | +
+ "statistic", "Z-Statistic",+ |
+
| 112 | +3x | +
+ "p.value", "p-value",+ |
+
| 113 | +3x | +
+ "alternative", "Alternative Hypothesis"+ |
+
| 114 | ++ |
+ )+ |
+
| 115 | ++ |
+ }+ |
+
| 1 | ++ |
+ #' Regression ARD+ |
+
| 2 | ++ |
+ #'+ |
+
| 3 | ++ |
+ #' Function takes a regression model object and converts it to a ARD+ |
+
| 4 | ++ |
+ #' structure using the `broom.helpers` package.+ |
+
| 5 | ++ |
+ #'+ |
+
| 6 | ++ |
+ #' @param x regression model object+ |
+
| 7 | ++ |
+ #' @param tidy_fun (`function`)\cr+ |
+
| 8 | ++ |
+ #' a tidier. Default is [`broom.helpers::tidy_with_broom_or_parameters`]+ |
+
| 9 | ++ |
+ #' @param ... Arguments passed to [`broom.helpers::tidy_plus_plus()`]+ |
+
| 10 | ++ |
+ #'+ |
+
| 11 | ++ |
+ #' @return data frame+ |
+
| 12 | ++ |
+ #' @name ard_regression+ |
+
| 13 | ++ |
+ #'+ |
+
| 14 | ++ |
+ #' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = "broom.helpers", reference_pkg = "cardx"))
+ |
+
| 15 | ++ |
+ #' lm(AGE ~ ARM, data = cards::ADSL) |>+ |
+
| 16 | ++ |
+ #' ard_regression(add_estimate_to_reference_rows = TRUE)+ |
+
| 17 | ++ |
+ NULL+ |
+
| 18 | ++ | + + | +
| 19 | ++ |
+ #' @rdname ard_regression+ |
+
| 20 | ++ |
+ #' @export+ |
+
| 21 | ++ |
+ ard_regression <- function(x, ...) {
+ |
+
| 22 | +11x | +
+ UseMethod("ard_regression")
+ |
+
| 23 | ++ |
+ }+ |
+
| 24 | ++ | + + | +
| 25 | ++ |
+ #' @rdname ard_regression+ |
+
| 26 | ++ |
+ #' @export+ |
+
| 27 | ++ |
+ ard_regression.default <- function(x, tidy_fun = broom.helpers::tidy_with_broom_or_parameters, ...) {
+ |
+
| 28 | +11x | +
+ set_cli_abort_call()+ |
+
| 29 | ++ | + + | +
| 30 | ++ |
+ # check installed packages ---------------------------------------------------+ |
+
| 31 | +11x | +
+ check_pkg_installed(pkg = "broom.helpers", reference_pkg = "cardx")+ |
+
| 32 | ++ | + + | +
| 33 | ++ |
+ # check inputs ---------------------------------------------------------------+ |
+
| 34 | +11x | +
+ check_not_missing(x)+ |
+
| 35 | ++ | + + | +
| 36 | ++ |
+ # summarize model ------------------------------------------------------------+ |
+
| 37 | +11x | +
+ lst_results <- cards::eval_capture_conditions(+ |
+
| 38 | +11x | +
+ broom.helpers::tidy_plus_plus(+ |
+
| 39 | +11x | +
+ model = x,+ |
+
| 40 | +11x | +
+ tidy_fun = tidy_fun,+ |
+
| 41 | ++ |
+ ...+ |
+
| 42 | ++ |
+ )+ |
+
| 43 | ++ |
+ )+ |
+
| 44 | ++ | + + | +
| 45 | ++ |
+ # final tidying up of cards data frame ---------------------------------------+ |
+
| 46 | +11x | +
+ .regression_final_ard_prep(lst_results)+ |
+
| 47 | ++ |
+ }+ |
+
| 48 | ++ | + + | +
| 49 | ++ |
+ .regression_final_ard_prep <- function(lst_results) {
+ |
+
| 50 | ++ |
+ # saving the results in data frame -------------------------------------------+ |
+
| 51 | +11x | +
+ df_card <-+ |
+
| 52 | +11x | +
+ if (!is.null(lst_results[["result"]])) {
+ |
+
| 53 | +10x | +
+ lst_results[["result"]] |>+ |
+
| 54 | +10x | +
+ dplyr::mutate(+ |
+
| 55 | +10x | +
+ variable_level = as.list(dplyr::if_else(.data$var_type %in% "continuous", NA_character_, .data$label)),+ |
+
| 56 | +10x | +
+ dplyr::across(-c("variable", "variable_level"), .fns = as.list)
+ |
+
| 57 | ++ |
+ ) |>+ |
+
| 58 | +10x | +
+ tidyr::pivot_longer(+ |
+
| 59 | +10x | +
+ cols = -c("variable", "variable_level"),
+ |
+
| 60 | +10x | +
+ names_to = "stat_name",+ |
+
| 61 | +10x | +
+ values_to = "stat"+ |
+
| 62 | ++ |
+ ) |>+ |
+
| 63 | +10x | +
+ dplyr::filter(map_lgl(.data$stat, Negate(is.na))) |>+ |
+
| 64 | +10x | +
+ dplyr::select(-(cards::all_ard_variables("levels") & dplyr::where(\(x) all(is.na(x)))))
+ |
+
| 65 | +11x | +
+ } else { # if there was an error return a shell of an ARD data frame
+ |
+
| 66 | +1x | +
+ dplyr::tibble(+ |
+
| 67 | +1x | +
+ variable = "model_1",+ |
+
| 68 | +1x | +
+ stat_name = "estimate",+ |
+
| 69 | +1x | +
+ stat = list(NULL)+ |
+
| 70 | ++ |
+ )+ |
+
| 71 | ++ |
+ }+ |
+
| 72 | ++ | + + | +
| 73 | ++ |
+ # final tidying up of ARD data frame ---------------------------------------+ |
+
| 74 | +11x | +
+ df_card |>+ |
+
| 75 | +11x | +
+ dplyr::mutate(+ |
+
| 76 | +11x | +
+ warning = lst_results["warning"],+ |
+
| 77 | +11x | +
+ error = lst_results["error"],+ |
+
| 78 | +11x | +
+ fmt_fn = lapply(+ |
+
| 79 | +11x | +
+ .data$stat,+ |
+
| 80 | +11x | +
+ function(x) {
+ |
+
| 81 | +295x | +
+ switch(is.integer(x),+ |
+
| 82 | +295x | +
+ 0L+ |
+
| 83 | +295x | +
+ ) %||% switch(is.numeric(x),+ |
+
| 84 | +295x | +
+ 1L+ |
+
| 85 | ++ |
+ )+ |
+
| 86 | ++ |
+ }+ |
+
| 87 | ++ |
+ ),+ |
+
| 88 | +11x | +
+ context = "regression"+ |
+
| 89 | ++ |
+ ) |>+ |
+
| 90 | +11x | +
+ dplyr::left_join(+ |
+
| 91 | +11x | +
+ .df_regression_stat_labels(),+ |
+
| 92 | +11x | +
+ by = "stat_name"+ |
+
| 93 | ++ |
+ ) |>+ |
+
| 94 | +11x | +
+ dplyr::mutate(stat_label = dplyr::coalesce(.data$stat_label, .data$stat_name)) |>+ |
+
| 95 | +11x | +
+ cards::as_card() |>+ |
+
| 96 | +11x | +
+ cards::tidy_ard_column_order()+ |
+
| 97 | ++ |
+ }+ |
+
| 98 | ++ | + + | +
| 99 | ++ |
+ .df_regression_stat_labels <- function() {
+ |
+
| 100 | +11x | +
+ dplyr::tribble(+ |
+
| 101 | +11x | +
+ ~stat_name, ~stat_label,+ |
+
| 102 | +11x | +
+ "var_label", "Label",+ |
+
| 103 | +11x | +
+ "var_class", "Class",+ |
+
| 104 | +11x | +
+ "var_type", "Type",+ |
+
| 105 | +11x | +
+ "var_nlevels", "N Levels",+ |
+
| 106 | +11x | +
+ "contrasts_type", "Contrast Type",+ |
+
| 107 | +11x | +
+ "label", "Level Label",+ |
+
| 108 | +11x | +
+ "n_obs", "N Obs.",+ |
+
| 109 | +11x | +
+ "n_event", "N Events",+ |
+
| 110 | +11x | +
+ "exposure", "Exposure Time",+ |
+
| 111 | +11x | +
+ "estimate", "Coefficient",+ |
+
| 112 | +11x | +
+ "std.error", "Standard Error",+ |
+
| 113 | +11x | +
+ "p.value", "p-value",+ |
+
| 114 | +11x | +
+ "conf.low", "CI Lower Bound",+ |
+
| 115 | +11x | +
+ "conf.high", "CI Upper Bound",+ |
+
| 116 | ++ |
+ )+ |
+
| 117 | ++ |
+ }+ |
+
| 1 | ++ |
+ #' Basic Regression ARD+ |
+
| 2 | ++ |
+ #'+ |
+
| 3 | ++ |
+ #' @description+ |
+
| 4 | ++ |
+ #' A function that takes a regression model and provides basic statistics in an+ |
+
| 5 | ++ |
+ #' ARD structure.+ |
+
| 6 | ++ |
+ #' The default output is simpler than [`ard_regression()`].+ |
+
| 7 | ++ |
+ #' The function primarily matches regression terms to underlying variable names+ |
+
| 8 | ++ |
+ #' and levels.+ |
+
| 9 | ++ |
+ #' The default arguments used are+ |
+
| 10 | ++ |
+ #'+ |
+
| 11 | ++ |
+ #' ```r+ |
+
| 12 | ++ |
+ #' broom.helpers::tidy_plus_plus(+ |
+
| 13 | ++ |
+ #' add_reference_rows = FALSE,+ |
+
| 14 | ++ |
+ #' add_estimate_to_reference_rows = FALSE,+ |
+
| 15 | ++ |
+ #' add_n = FALSE,+ |
+
| 16 | ++ |
+ #' intercept = FALSE+ |
+
| 17 | ++ |
+ #' )+ |
+
| 18 | ++ |
+ #' ```+ |
+
| 19 | ++ |
+ #'+ |
+
| 20 | ++ |
+ #' @inheritParams ard_regression+ |
+
| 21 | ++ |
+ #' @param stats_to_remove (`character`)\cr+ |
+
| 22 | ++ |
+ #' character vector of statistic names to remove. Default is+ |
+
| 23 | ++ |
+ #' `c("term", "var_type", "var_label", "var_class", "label", "contrasts_type", "contrasts", "var_nlevels")`.
+ |
+
| 24 | ++ |
+ #'+ |
+
| 25 | ++ |
+ #' @return data frame+ |
+
| 26 | ++ |
+ #' @name ard_regression_basic+ |
+
| 27 | ++ |
+ #' @export+ |
+
| 28 | ++ |
+ #'+ |
+
| 29 | ++ |
+ #' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = "broom.helpers", reference_pkg = "cardx"))
+ |
+
| 30 | ++ |
+ #' lm(AGE ~ ARM, data = cards::ADSL) |>+ |
+
| 31 | ++ |
+ #' ard_regression_basic()+ |
+
| 32 | ++ |
+ ard_regression_basic <- function(x, tidy_fun = broom.helpers::tidy_with_broom_or_parameters,+ |
+
| 33 | ++ |
+ stats_to_remove = c(+ |
+
| 34 | ++ |
+ "term", "var_type", "var_label", "var_class",+ |
+
| 35 | ++ |
+ "label", "contrasts_type", "contrasts", "var_nlevels"+ |
+
| 36 | ++ |
+ ),+ |
+
| 37 | ++ |
+ ...) {
+ |
+
| 38 | +5x | +
+ set_cli_abort_call()+ |
+
| 39 | ++ | + + | +
| 40 | ++ |
+ # check installed packages ---------------------------------------------------+ |
+
| 41 | +5x | +
+ check_pkg_installed(pkg = "broom.helpers", reference_pkg = "cardx")+ |
+
| 42 | ++ | + + | +
| 43 | ++ |
+ # check inputs ---------------------------------------------------------------+ |
+
| 44 | +5x | +
+ check_not_missing(x)+ |
+
| 45 | +5x | +
+ check_class(stats_to_remove, cls = "character", allow_empty = TRUE)+ |
+
| 46 | +! | +
+ if (is_empty(stats_to_remove)) stats_to_remove <- character(0L) # styler: off+ |
+
| 47 | ++ | + + | +
| 48 | +5x | +
+ args <-+ |
+
| 49 | +5x | +
+ list(+ |
+
| 50 | +5x | +
+ add_reference_rows = FALSE,+ |
+
| 51 | +5x | +
+ add_estimate_to_reference_rows = FALSE,+ |
+
| 52 | +5x | +
+ add_n = FALSE,+ |
+
| 53 | +5x | +
+ intercept = FALSE+ |
+
| 54 | ++ |
+ ) |>+ |
+
| 55 | +5x | +
+ utils::modifyList(val = rlang::dots_list(...))+ |
+
| 56 | ++ | + + | +
| 57 | +5x | +
+ rlang::inject(ard_regression(x = x, tidy_fun = tidy_fun, !!!args)) |>+ |
+
| 58 | +5x | +
+ dplyr::filter(!.data$stat_name %in% stats_to_remove) |>+ |
+
| 59 | +5x | +
+ dplyr::select(-(cards::all_ard_variables("levels") & dplyr::where(\(x) all(is.na(x)))))
+ |
+
| 60 | ++ |
+ }+ |
+
| 1 | ++ |
+ #' ARD Poisson Test+ |
+
| 2 | ++ |
+ #'+ |
+
| 3 | ++ |
+ #' @description+ |
+
| 4 | ++ |
+ #' Analysis results data for exact tests of a simple null hypothesis about the rate parameter+ |
+
| 5 | ++ |
+ #' in Poisson distribution, or the comparison of two rate parameters.+ |
+
| 6 | ++ |
+ #'+ |
+
| 7 | ++ |
+ #' @param data (`data.frame`)\cr+ |
+
| 8 | ++ |
+ #' a data frame. See below for details.+ |
+
| 9 | ++ |
+ #' @param variables ([`tidy-select`][dplyr::dplyr_tidy_select])\cr+ |
+
| 10 | ++ |
+ #' names of the event and time variables (in that order) to be used in computations. Must be of length 2.+ |
+
| 11 | ++ |
+ #' @param by ([`tidy-select`][dplyr::dplyr_tidy_select])\cr+ |
+
| 12 | ++ |
+ #' optional column name to compare by.+ |
+
| 13 | ++ |
+ #' @param conf.level (scalar `numeric`)\cr+ |
+
| 14 | ++ |
+ #' confidence level for confidence interval. Default is `0.95`.+ |
+
| 15 | ++ |
+ #' @param na.rm (scalar `logical`)\cr+ |
+
| 16 | ++ |
+ #' whether missing values should be removed before computations. Default is `TRUE`.+ |
+
| 17 | ++ |
+ #' @param ... arguments passed to [poisson.test()].+ |
+
| 18 | ++ |
+ #' @return an ARD data frame of class 'card'+ |
+
| 19 | ++ |
+ #' @name ard_stats_poisson_test+ |
+
| 20 | ++ |
+ #'+ |
+
| 21 | ++ |
+ #' @details+ |
+
| 22 | ++ |
+ #' * For the `ard_stats_poisson_test()` function, the data is expected to be one row per subject.+ |
+
| 23 | ++ |
+ #' * If `by` is not specified, an exact Poisson test of the rate parameter will be performed. Otherwise, a+ |
+
| 24 | ++ |
+ #' Poisson comparison of two rate parameters will be performed on the levels of `by`. If `by` has more than 2+ |
+
| 25 | ++ |
+ #' levels, an error will occur.+ |
+
| 26 | ++ |
+ #'+ |
+
| 27 | ++ |
+ #' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = "broom", reference_pkg = "cardx"))
+ |
+
| 28 | ++ |
+ #' # Exact test of rate parameter against null hypothesis+ |
+
| 29 | ++ |
+ #' cards::ADTTE |>+ |
+
| 30 | ++ |
+ #' ard_stats_poisson_test(variables = c(CNSR, AVAL))+ |
+
| 31 | ++ |
+ #'+ |
+
| 32 | ++ |
+ #' # Comparison test of ratio of 2 rate parameters against null hypothesis+ |
+
| 33 | ++ |
+ #' cards::ADTTE |>+ |
+
| 34 | ++ |
+ #' dplyr::filter(TRTA %in% c("Placebo", "Xanomeline High Dose")) |>
+ |
+
| 35 | ++ |
+ #' ard_stats_poisson_test(by = TRTA, variables = c(CNSR, AVAL))+ |
+
| 36 | ++ |
+ NULL+ |
+
| 37 | ++ | + + | +
| 38 | ++ |
+ #' @rdname ard_stats_poisson_test+ |
+
| 39 | ++ |
+ #' @export+ |
+
| 40 | ++ |
+ ard_stats_poisson_test <- function(data, variables, na.rm = TRUE, by = NULL, conf.level = 0.95, ...) {
+ |
+
| 41 | +5x | +
+ set_cli_abort_call()+ |
+
| 42 | ++ | + + | +
| 43 | ++ |
+ # check installed packages ---------------------------------------------------+ |
+
| 44 | +5x | +
+ check_pkg_installed("broom", reference_pkg = "cardx")
+ |
+
| 45 | ++ | + + | +
| 46 | ++ |
+ # check/process inputs -------------------------------------------------------+ |
+
| 47 | +5x | +
+ check_not_missing(data)+ |
+
| 48 | +5x | +
+ check_not_missing(variables)+ |
+
| 49 | +5x | +
+ check_data_frame(data)+ |
+
| 50 | +5x | +
+ data <- dplyr::ungroup(data)+ |
+
| 51 | +5x | +
+ cards::process_selectors(data, by = {{ by }}, variables = {{ variables }})
+ |
+
| 52 | +5x | +
+ check_length(variables, 2)+ |
+
| 53 | +5x | +
+ check_logical(na.rm)+ |
+
| 54 | +5x | +
+ check_scalar(by, allow_empty = TRUE)+ |
+
| 55 | +5x | +
+ check_range(conf.level, range = c(0, 1))+ |
+
| 56 | ++ | + + | +
| 57 | ++ |
+ # return empty ARD if no variables selected ----------------------+ |
+
| 58 | +5x | +
+ if (is_empty(variables)) {
+ |
+
| 59 | +! | +
+ return(dplyr::tibble() |> cards::as_card())+ |
+
| 60 | ++ |
+ }+ |
+
| 61 | ++ | + + | +
| 62 | ++ |
+ # check number of levels in `by`+ |
+
| 63 | +5x | +
+ if (!is_empty(by) && dplyr::n_distinct(data[[by]], na.rm = TRUE) != 2L) {
+ |
+
| 64 | +1x | +
+ cli::cli_abort(+ |
+
| 65 | +1x | +
+ "The {.arg by} argument must have a maximum of two levels.",
+ |
+
| 66 | +1x | +
+ call = get_cli_abort_call()+ |
+
| 67 | ++ |
+ )+ |
+
| 68 | ++ |
+ }+ |
+
| 69 | ++ | + + | +
| 70 | ++ |
+ # calculate numerator and denominator values+ |
+
| 71 | +4x | +
+ if (!is_empty(by)) {
+ |
+
| 72 | +1x | +
+ num <- data |>+ |
+
| 73 | +1x | +
+ dplyr::group_by(.data[[by]]) |>+ |
+
| 74 | +1x | +
+ dplyr::summarise(sum = sum(.data[[variables[1]]], na.rm = na.rm)) |>+ |
+
| 75 | +1x | +
+ dplyr::pull(sum)+ |
+
| 76 | +1x | +
+ denom <- data |>+ |
+
| 77 | +1x | +
+ dplyr::group_by(.data[[by]]) |>+ |
+
| 78 | +1x | +
+ dplyr::summarise(sum = sum(.data[[variables[2]]], na.rm = na.rm)) |>+ |
+
| 79 | +1x | +
+ dplyr::pull(sum)+ |
+
| 80 | ++ |
+ } else {
+ |
+
| 81 | +3x | +
+ num <- sum(data[[variables[1]]], na.rm = na.rm)+ |
+
| 82 | +3x | +
+ denom <- sum(data[[variables[2]]], na.rm = na.rm)+ |
+
| 83 | ++ |
+ }+ |
+
| 84 | ++ | + + | +
| 85 | ++ |
+ # build ARD ------------------------------------------------------------------+ |
+
| 86 | +4x | +
+ .format_poissontest_results(+ |
+
| 87 | +4x | +
+ by = by,+ |
+
| 88 | +4x | +
+ variables = variables,+ |
+
| 89 | +4x | +
+ lst_tidy =+ |
+
| 90 | +4x | +
+ cards::eval_capture_conditions(+ |
+
| 91 | +4x | +
+ stats::poisson.test(x = num, T = denom, conf.level = conf.level, ...) |> broom::tidy()+ |
+
| 92 | ++ |
+ ),+ |
+
| 93 | ++ |
+ ...+ |
+
| 94 | ++ |
+ )+ |
+
| 95 | ++ |
+ }+ |
+
| 96 | ++ | + + | +
| 97 | ++ |
+ #' Convert Poisson test to ARD+ |
+
| 98 | ++ |
+ #'+ |
+
| 99 | ++ |
+ #' @inheritParams cards::tidy_as_ard+ |
+
| 100 | ++ |
+ #' @inheritParams stats::poisson.test+ |
+
| 101 | ++ |
+ #' @param by (`string`)\cr by column name+ |
+
| 102 | ++ |
+ #' @param variables (`character`)\cr names of the event and time variables+ |
+
| 103 | ++ |
+ #' @param ... passed to [poisson.test()]+ |
+
| 104 | ++ |
+ #'+ |
+
| 105 | ++ |
+ #' @return ARD data frame+ |
+
| 106 | ++ |
+ #' @keywords internal+ |
+
| 107 | ++ |
+ #' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = "broom", reference_pkg = "cardx"))
+ |
+
| 108 | ++ |
+ #' cardx:::.format_poissontest_results(+ |
+
| 109 | ++ |
+ #' by = "ARM",+ |
+
| 110 | ++ |
+ #' variables = c("CNSR", "AVAL"),
+ |
+
| 111 | ++ |
+ #' lst_tidy =+ |
+
| 112 | ++ |
+ #' cards::eval_capture_conditions(+ |
+
| 113 | ++ |
+ #' stats::poisson.test(sum(cards::ADTTE[["CNSR"]]), sum(cards::ADTTE[["AVAL"]])) |>+ |
+
| 114 | ++ |
+ #' broom::tidy()+ |
+
| 115 | ++ |
+ #' )+ |
+
| 116 | ++ |
+ #' )+ |
+
| 117 | ++ |
+ .format_poissontest_results <- function(by = NULL, variables, lst_tidy, ...) {
+ |
+
| 118 | ++ |
+ # build ARD ------------------------------------------------------------------+ |
+
| 119 | +4x | +
+ ret <-+ |
+
| 120 | +4x | +
+ cards::tidy_as_ard(+ |
+
| 121 | +4x | +
+ lst_tidy = lst_tidy,+ |
+
| 122 | +4x | +
+ tidy_result_names =+ |
+
| 123 | +4x | +
+ c(+ |
+
| 124 | +4x | +
+ "estimate", "statistic",+ |
+
| 125 | +4x | +
+ "p.value", "parameter", "conf.low", "conf.high",+ |
+
| 126 | +4x | +
+ "method", "alternative"+ |
+
| 127 | ++ |
+ ),+ |
+
| 128 | +4x | +
+ fun_args_to_record = c("conf.level", "r"),
+ |
+
| 129 | +4x | +
+ formals = formals(asNamespace("stats")[["poisson.test"]]),
+ |
+
| 130 | +4x | +
+ passed_args = dots_list(...),+ |
+
| 131 | +4x | +
+ lst_ard_columns = list(context = "stats_poisson_test", variable = variables[2])+ |
+
| 132 | ++ |
+ ) |>+ |
+
| 133 | +4x | +
+ dplyr::distinct()+ |
+
| 134 | ++ | + + | +
| 135 | ++ |
+ # rename "r" statistic to "mu"+ |
+
| 136 | +4x | +
+ ret$stat_name[ret$stat_name == "r"] <- "mu"+ |
+
| 137 | ++ | + + | +
| 138 | +4x | +
+ if (!is_empty(by)) {
+ |
+
| 139 | +1x | +
+ ret <- ret |>+ |
+
| 140 | +1x | +
+ dplyr::mutate(group1 = by)+ |
+
| 141 | ++ |
+ }+ |
+
| 142 | ++ | + + | +
| 143 | ++ |
+ # add the stat label ---------------------------------------------------------+ |
+
| 144 | +4x | +
+ ret |>+ |
+
| 145 | +4x | +
+ dplyr::left_join(+ |
+
| 146 | +4x | +
+ .df_poissontest_stat_labels(by = by),+ |
+
| 147 | +4x | +
+ by = "stat_name"+ |
+
| 148 | ++ |
+ ) |>+ |
+
| 149 | +4x | +
+ dplyr::mutate(stat_label = dplyr::coalesce(.data$stat_label, .data$stat_name)) |>+ |
+
| 150 | +4x | +
+ cards::as_card() |>+ |
+
| 151 | +4x | +
+ cards::tidy_ard_column_order()+ |
+
| 152 | ++ |
+ }+ |
+
| 153 | ++ | + + | +
| 154 | ++ |
+ .df_poissontest_stat_labels <- function(by = NULL) {
+ |
+
| 155 | +4x | +
+ dplyr::tribble(+ |
+
| 156 | +4x | +
+ ~stat_name, ~stat_label,+ |
+
| 157 | +4x | +
+ "estimate", ifelse(is_empty(by), "Estimated Rate", "Estimated Rate Ratio"),+ |
+
| 158 | +4x | +
+ "statistic", ifelse(is_empty(by), "Number of Events", "Number of Events in First Sample"),+ |
+
| 159 | +4x | +
+ "p.value", "p-value",+ |
+
| 160 | +4x | +
+ "parameter", "Expected Count",+ |
+
| 161 | +4x | +
+ "conf.low", "CI Lower Bound",+ |
+
| 162 | +4x | +
+ "conf.high", "CI Upper Bound",+ |
+
| 163 | +4x | +
+ "mu", "H0 Mean",+ |
+
| 164 | +4x | +
+ "conf.level", "CI Confidence Level"+ |
+
| 165 | ++ |
+ )+ |
+
| 166 | ++ |
+ }+ |
+
| 1 | ++ |
+ #' ARD Dichotomous Survey Statistics+ |
+
| 2 | ++ |
+ #'+ |
+
| 3 | ++ |
+ #' Compute Analysis Results Data (ARD) for dichotomous summary statistics.+ |
+
| 4 | ++ |
+ #'+ |
+
| 5 | ++ |
+ #' @inheritParams ard_categorical.survey.design+ |
+
| 6 | ++ |
+ #' @param value (named `list`)\cr+ |
+
| 7 | ++ |
+ #' named list of dichotomous values to tabulate.+ |
+
| 8 | ++ |
+ #' Default is `cards::maximum_variable_value(data$variables)`,+ |
+
| 9 | ++ |
+ #' which returns the largest/last value after a sort.+ |
+
| 10 | ++ |
+ #'+ |
+
| 11 | ++ |
+ #' @return an ARD data frame of class 'card'+ |
+
| 12 | ++ |
+ #' @export+ |
+
| 13 | ++ |
+ #'+ |
+
| 14 | ++ |
+ #' @examplesIf cardx:::is_pkg_installed("survey", reference_pkg = "cardx")
+ |
+
| 15 | ++ |
+ #' survey::svydesign(ids = ~1, data = mtcars, weights = ~1) |>+ |
+
| 16 | ++ |
+ #' ard_dichotomous(by = vs, variables = c(cyl, am), value = list(cyl = 4))+ |
+
| 17 | ++ |
+ ard_dichotomous.survey.design <- function(data,+ |
+
| 18 | ++ |
+ variables,+ |
+
| 19 | ++ |
+ by = NULL,+ |
+
| 20 | ++ |
+ value = cards::maximum_variable_value(data$variables[variables]),+ |
+
| 21 | ++ |
+ statistic = everything() ~ c("n", "N", "p", "p.std.error", "deff", "n_unweighted", "N_unweighted", "p_unweighted"),
+ |
+
| 22 | ++ |
+ denominator = c("column", "row", "cell"),
+ |
+
| 23 | ++ |
+ fmt_fn = NULL,+ |
+
| 24 | ++ |
+ stat_label = everything() ~ list(+ |
+
| 25 | ++ |
+ p = "%",+ |
+
| 26 | ++ |
+ p.std.error = "SE(%)",+ |
+
| 27 | ++ |
+ deff = "Design Effect",+ |
+
| 28 | ++ |
+ "n_unweighted" = "Unweighted n",+ |
+
| 29 | ++ |
+ "N_unweighted" = "Unweighted N",+ |
+
| 30 | ++ |
+ "p_unweighted" = "Unweighted %"+ |
+
| 31 | ++ |
+ ),+ |
+
| 32 | ++ |
+ ...) {
+ |
+
| 33 | +16x | +
+ set_cli_abort_call()+ |
+
| 34 | +16x | +
+ check_dots_empty()+ |
+
| 35 | +16x | +
+ check_pkg_installed(pkg = "survey", reference_pkg = "cardx")+ |
+
| 36 | ++ | + + | +
| 37 | ++ |
+ # check inputs ---------------------------------------------------------------+ |
+
| 38 | +16x | +
+ check_not_missing(variables)+ |
+
| 39 | ++ | + + | +
| 40 | ++ |
+ # process inputs -------------------------------------------------------------+ |
+
| 41 | +16x | +
+ cards::process_selectors(data$variables, variables = {{ variables }})
+ |
+
| 42 | +16x | +
+ cards::process_formula_selectors(data$variables[variables], value = value)+ |
+
| 43 | +16x | +
+ cards::fill_formula_selectors(+ |
+
| 44 | +16x | +
+ data$variables[variables],+ |
+
| 45 | +16x | +
+ value = formals(asNamespace("cardx")[["ard_dichotomous.survey.design"]])[["value"]] |> eval()
+ |
+
| 46 | ++ |
+ )+ |
+
| 47 | +16x | +
+ .check_dichotomous_value(data$variables, value)+ |
+
| 48 | ++ | + + | +
| 49 | ++ |
+ # return empty ARD if no variables selected ----------------------------------+ |
+
| 50 | +15x | +
+ if (is_empty(variables)) {
+ |
+
| 51 | +! | +
+ return(dplyr::tibble() |> cards::as_card())+ |
+
| 52 | ++ |
+ }+ |
+
| 53 | ++ | + + | +
| 54 | ++ |
+ # calculate summary statistics -----------------------------------------------+ |
+
| 55 | +15x | +
+ ard_categorical(+ |
+
| 56 | +15x | +
+ data = data,+ |
+
| 57 | +15x | +
+ variables = all_of(variables),+ |
+
| 58 | +15x | +
+ by = {{ by }},
+ |
+
| 59 | +15x | +
+ statistic = statistic,+ |
+
| 60 | +15x | +
+ denominator = denominator,+ |
+
| 61 | +15x | +
+ fmt_fn = fmt_fn,+ |
+
| 62 | +15x | +
+ stat_label = stat_label+ |
+
| 63 | ++ |
+ ) |>+ |
+
| 64 | +15x | +
+ dplyr::filter(+ |
+
| 65 | +15x | +
+ pmap(+ |
+
| 66 | +15x | +
+ list(.data$variable, .data$variable_level),+ |
+
| 67 | +15x | +
+ function(variable, variable_level) {
+ |
+
| 68 | +880x | +
+ variable_level %in% .env$value[[variable]]+ |
+
| 69 | ++ |
+ }+ |
+
| 70 | ++ |
+ ) |>+ |
+
| 71 | +15x | +
+ unlist()+ |
+
| 72 | ++ |
+ ) |>+ |
+
| 73 | +15x | +
+ dplyr::mutate(context = "dichotomous")+ |
+
| 74 | ++ |
+ }+ |
+
| 75 | ++ | + + | +
| 76 | ++ |
+ #' Perform Value Checks+ |
+
| 77 | ++ |
+ #'+ |
+
| 78 | ++ |
+ #' Check the validity of the values passed in `ard_dichotomous(value)`.+ |
+
| 79 | ++ |
+ #'+ |
+
| 80 | ++ |
+ #' @param data (`data.frame`)\cr+ |
+
| 81 | ++ |
+ #' a data frame+ |
+
| 82 | ++ |
+ #' @param value (named `list`)\cr+ |
+
| 83 | ++ |
+ #' a named list+ |
+
| 84 | ++ |
+ #'+ |
+
| 85 | ++ |
+ #' @return returns invisible if check is successful, throws an error message if not.+ |
+
| 86 | ++ |
+ #' @keywords internal+ |
+
| 87 | ++ |
+ #'+ |
+
| 88 | ++ |
+ #' @examples+ |
+
| 89 | ++ |
+ #' cardx:::.check_dichotomous_value(mtcars, list(cyl = 4))+ |
+
| 90 | ++ |
+ .check_dichotomous_value <- function(data, value) {
+ |
+
| 91 | +16x | +
+ imap(+ |
+
| 92 | +16x | +
+ value,+ |
+
| 93 | +16x | +
+ function(value, column) {
+ |
+
| 94 | +29x | +
+ accepted_values <- .unique_and_sorted(data[[column]])+ |
+
| 95 | +29x | +
+ if (length(value) != 1L || !value %in% accepted_values) {
+ |
+
| 96 | +1x | +
+ message <- "Error in argument {.arg value} for variable {.val {column}}."
+ |
+
| 97 | +1x | +
+ message <-+ |
+
| 98 | +1x | +
+ case_switch(+ |
+
| 99 | +1x | +
+ length(value) != 1L ~ c(message, "i" = "The value must be one of {.val {accepted_values}}."),
+ |
+
| 100 | +1x | +
+ .default = c(message, "i" = "A value of {.val {value}} was passed, but must be one of {.val {accepted_values}}.")
+ |
+
| 101 | ++ |
+ )+ |
+
| 102 | +1x | +
+ if (length(value) == 1L) {
+ |
+
| 103 | +1x | +
+ message <-+ |
+
| 104 | +1x | +
+ case_switch(+ |
+
| 105 | +1x | +
+ inherits(data[[column]], "factor") ~+ |
+
| 106 | +1x | +
+ c(message, i = "To summarize this value, use {.fun forcats::fct_expand} to add {.val {value}} as a level."),
+ |
+
| 107 | +1x | +
+ .default = c(message, i = "To summarize this value, make the column a factor and include {.val {value}} as a level.")
+ |
+
| 108 | ++ |
+ )+ |
+
| 109 | ++ |
+ }+ |
+
| 110 | ++ | + + | +
| 111 | ++ | + + | +
| 112 | +1x | +
+ cli::cli_abort(+ |
+
| 113 | +1x | +
+ message = message,+ |
+
| 114 | +1x | +
+ call = get_cli_abort_call()+ |
+
| 115 | ++ |
+ )+ |
+
| 116 | ++ |
+ }+ |
+
| 117 | ++ |
+ }+ |
+
| 118 | ++ |
+ ) |>+ |
+
| 119 | +16x | +
+ invisible()+ |
+
| 120 | ++ |
+ }+ |
+
| 121 | ++ | + + | +
| 122 | ++ |
+ #' ARD-flavor of unique()+ |
+
| 123 | ++ |
+ #'+ |
+
| 124 | ++ |
+ #' Essentially a wrapper for `unique(x) |> sort()` with `NA` levels removed.+ |
+
| 125 | ++ |
+ #' For factors, all levels are returned even if they are unobserved.+ |
+
| 126 | ++ |
+ #' Similarly, logical vectors always return `c(TRUE, FALSE)`, even if+ |
+
| 127 | ++ |
+ #' both levels are not observed.+ |
+
| 128 | ++ |
+ #'+ |
+
| 129 | ++ |
+ #' @param x (`any`)\cr+ |
+
| 130 | ++ |
+ #' a vector+ |
+
| 131 | ++ |
+ #'+ |
+
| 132 | ++ |
+ #' @return a vector+ |
+
| 133 | ++ |
+ #' @keywords internal+ |
+
| 134 | ++ |
+ #'+ |
+
| 135 | ++ |
+ #' @examples+ |
+
| 136 | ++ |
+ #' cards:::.unique_and_sorted(factor(letters[c(5, 5:1)], levels = letters))+ |
+
| 137 | ++ |
+ #'+ |
+
| 138 | ++ |
+ #' cards:::.unique_and_sorted(c(FALSE, TRUE, TRUE, FALSE))+ |
+
| 139 | ++ |
+ #'+ |
+
| 140 | ++ |
+ #' cards:::.unique_and_sorted(c(5, 5:1))+ |
+
| 141 | ++ |
+ .unique_and_sorted <- function(x, useNA = c("no", "always")) {
+ |
+
| 142 | ++ |
+ # styler: off+ |
+
| 143 | +314x | +
+ useNA <- match.arg(useNA)+ |
+
| 144 | ++ |
+ # if a factor return a factor that includes the same levels (including unobserved levels)+ |
+
| 145 | +314x | +
+ if (inherits(x, "factor")) {
+ |
+
| 146 | +241x | +
+ return(+ |
+
| 147 | +241x | +
+ factor(+ |
+
| 148 | +241x | +
+ if (useNA == "no") levels(x)+ |
+
| 149 | +241x | +
+ else c(levels(x), NA_character_),+ |
+
| 150 | +241x | +
+ levels = levels(x)+ |
+
| 151 | ++ |
+ )+ |
+
| 152 | ++ |
+ )+ |
+
| 153 | ++ |
+ }+ |
+
| 154 | +73x | +
+ if (inherits(x, "logical")) {
+ |
+
| 155 | +49x | +
+ if (useNA == "no") return(c(TRUE, FALSE))+ |
+
| 156 | +! | +
+ else return(c(TRUE, FALSE, NA))+ |
+
| 157 | ++ |
+ }+ |
+
| 158 | ++ | + + | +
| 159 | ++ |
+ # otherwise, return a simple unique and sort of the vector+ |
+
| 160 | +24x | +
+ if (useNA == "no") return(unique(x) |> sort())+ |
+
| 161 | +! | +
+ else return(unique(x) |> sort() |> c(NA))+ |
+
| 162 | ++ |
+ # styler: on+ |
+
| 163 | ++ |
+ }+ |
+
| 1 | ++ |
+ #' Regression VIF ARD+ |
+
| 2 | ++ |
+ #'+ |
+
| 3 | ++ |
+ #' @description+ |
+
| 4 | ++ |
+ #' Function takes a regression model object and returns the variance inflation factor (VIF)+ |
+
| 5 | ++ |
+ #' using [`car::vif()`] and converts it to a ARD structure+ |
+
| 6 | ++ |
+ #'+ |
+
| 7 | ++ |
+ #' @param x regression model object+ |
+
| 8 | ++ |
+ #' See car::vif() for details+ |
+
| 9 | ++ |
+ #'+ |
+
| 10 | ++ |
+ #' @param ... arguments passed to `car::vif(...)`+ |
+
| 11 | ++ |
+ #'+ |
+
| 12 | ++ |
+ #' @return data frame+ |
+
| 13 | ++ |
+ #' @name ard_car_vif+ |
+
| 14 | ++ |
+ #' @rdname ard_car_vif+ |
+
| 15 | ++ |
+ #' @export+ |
+
| 16 | ++ |
+ #'+ |
+
| 17 | ++ |
+ #' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = "car", reference_pkg = "cardx"))
+ |
+
| 18 | ++ |
+ #' lm(AGE ~ ARM + SEX, data = cards::ADSL) |>+ |
+
| 19 | ++ |
+ #' ard_car_vif()+ |
+
| 20 | ++ |
+ ard_car_vif <- function(x, ...) {
+ |
+
| 21 | +4x | +
+ set_cli_abort_call()+ |
+
| 22 | ++ | + + | +
| 23 | ++ |
+ # check installed packages ---------------------------------------------------+ |
+
| 24 | +4x | +
+ check_pkg_installed("car", reference_pkg = "cardx")
+ |
+
| 25 | ++ | + + | +
| 26 | ++ |
+ # check inputs ---------------------------------------------------------------+ |
+
| 27 | +4x | +
+ check_not_missing(x)+ |
+
| 28 | ++ | + + | +
| 29 | +4x | +
+ vif <- cards::eval_capture_conditions(car::vif(x, ...))+ |
+
| 30 | ++ | + + | +
| 31 | ++ |
+ # if vif failed, set result as NULL, error will be kept through eval_capture_conditions()+ |
+
| 32 | +4x | +
+ if (is.null(vif$result)) {
+ |
+
| 33 | ++ |
+ # try to capture variable names from `terms()`+ |
+
| 34 | +2x | +
+ lst_terms <- cards::eval_capture_conditions(attr(stats::terms(x), "term.labels"))+ |
+
| 35 | ++ |
+ # we cannot get variable names, error out+ |
+
| 36 | +2x | +
+ if (!is.null(lst_terms[["error"]])) {
+ |
+
| 37 | +1x | +
+ cli::cli_abort(+ |
+
| 38 | +1x | +
+ c("There was an error running {.fun car::vif}. See below.", x = vif[["error"]]),
+ |
+
| 39 | +1x | +
+ call = get_cli_abort_call()+ |
+
| 40 | ++ |
+ )+ |
+
| 41 | ++ |
+ }+ |
+
| 42 | +1x | +
+ vif$result <- dplyr::tibble(+ |
+
| 43 | +1x | +
+ variable = lst_terms[["result"]],+ |
+
| 44 | +1x | +
+ VIF = list(NULL),+ |
+
| 45 | +1x | +
+ GVIF = list(NULL),+ |
+
| 46 | +1x | +
+ aGVIF = list(NULL),+ |
+
| 47 | +1x | +
+ df = list(NULL)+ |
+
| 48 | ++ |
+ )+ |
+
| 49 | ++ |
+ }+ |
+
| 50 | ++ |
+ # if VIF is returned+ |
+
| 51 | +2x | +
+ else if (!is.matrix(vif$result)) {
+ |
+
| 52 | +! | +
+ vif$result <- dplyr::tibble(variable = names(vif$result), VIF = vif$result)+ |
+
| 53 | ++ |
+ }+ |
+
| 54 | ++ |
+ # if Generalized VIF is returned+ |
+
| 55 | +2x | +
+ else if (is.matrix(vif$result)) {
+ |
+
| 56 | +2x | +
+ vif$result <-+ |
+
| 57 | +2x | +
+ vif$result |>+ |
+
| 58 | +2x | +
+ as.data.frame() %>%+ |
+
| 59 | +2x | +
+ dplyr::mutate(., variable = rownames(.), .before = 1L) |>+ |
+
| 60 | +2x | +
+ dplyr::rename(+ |
+
| 61 | +2x | +
+ aGVIF = "GVIF^(1/(2*Df))",+ |
+
| 62 | +2x | +
+ df = "Df"+ |
+
| 63 | ++ |
+ ) |>+ |
+
| 64 | +2x | +
+ dplyr::tibble()+ |
+
| 65 | ++ |
+ }+ |
+
| 66 | ++ | + + | +
| 67 | ++ |
+ # Clean-up the result to fit the ard structure through pivot+ |
+
| 68 | +3x | +
+ vif$result <-+ |
+
| 69 | +3x | +
+ vif$result |>+ |
+
| 70 | +3x | +
+ tidyr::pivot_longer(+ |
+
| 71 | +3x | +
+ cols = -c("variable"),
+ |
+
| 72 | +3x | +
+ names_to = "stat_name",+ |
+
| 73 | +3x | +
+ values_to = "stat"+ |
+
| 74 | ++ |
+ ) |>+ |
+
| 75 | +3x | +
+ dplyr::mutate(+ |
+
| 76 | +3x | +
+ context = "car_vif",+ |
+
| 77 | +3x | +
+ stat = as.list(.data$stat),+ |
+
| 78 | +3x | +
+ stat_label = ifelse(+ |
+
| 79 | +3x | +
+ .data$stat_name == "aGVIF",+ |
+
| 80 | +3x | +
+ "Adjusted GVIF",+ |
+
| 81 | +3x | +
+ .data$stat_name+ |
+
| 82 | ++ |
+ ),+ |
+
| 83 | +3x | +
+ fmt_fn = map(+ |
+
| 84 | +3x | +
+ .data$stat,+ |
+
| 85 | +3x | +
+ function(.x) {
+ |
+
| 86 | ++ |
+ # styler: off+ |
+
| 87 | +! | +
+ if (is.integer(.x)) return(0L)+ |
+
| 88 | +12x | +
+ if (is.numeric(.x)) return(1L)+ |
+
| 89 | ++ |
+ # styler: on+ |
+
| 90 | +4x | +
+ NULL+ |
+
| 91 | ++ |
+ }+ |
+
| 92 | ++ |
+ )+ |
+
| 93 | ++ |
+ )+ |
+
| 94 | ++ | + + | +
| 95 | ++ |
+ # Bind the results and possible warning/errors together+ |
+
| 96 | +3x | +
+ vif_return <- dplyr::tibble(+ |
+
| 97 | +3x | +
+ vif$result,+ |
+
| 98 | +3x | +
+ warning = vif["warning"],+ |
+
| 99 | +3x | +
+ error = vif["error"]+ |
+
| 100 | ++ |
+ )+ |
+
| 101 | ++ | + + | +
| 102 | ++ |
+ # Clean up return object+ |
+
| 103 | +3x | +
+ vif_return |>+ |
+
| 104 | +3x | +
+ cards::as_card() |>+ |
+
| 105 | +3x | +
+ cards::tidy_ard_column_order()+ |
+
| 106 | ++ |
+ }+ |
+
| 1 | ++ |
+ #' ARD Hedge's G Test+ |
+
| 2 | ++ |
+ #'+ |
+
| 3 | ++ |
+ #' @description+ |
+
| 4 | ++ |
+ #' Analysis results data for paired and non-paired Hedge's G Effect Size Test+ |
+
| 5 | ++ |
+ #' using [`effectsize::hedges_g()`].+ |
+
| 6 | ++ |
+ #'+ |
+
| 7 | ++ |
+ #' @param data (`data.frame`)\cr+ |
+
| 8 | ++ |
+ #' a data frame. See below for details.+ |
+
| 9 | ++ |
+ #' @param by ([`tidy-select`][dplyr::dplyr_tidy_select])\cr+ |
+
| 10 | ++ |
+ #' column name to compare by. Must be a categorical variable with exactly two levels.+ |
+
| 11 | ++ |
+ #' @param variables ([`tidy-select`][dplyr::dplyr_tidy_select])\cr+ |
+
| 12 | ++ |
+ #' column names to be compared. Must be a continuous variable. Independent+ |
+
| 13 | ++ |
+ #' tests will be run for each variable+ |
+
| 14 | ++ |
+ #' @param id ([`tidy-select`][dplyr::dplyr_tidy_select])\cr+ |
+
| 15 | ++ |
+ #' column name of the subject or participant ID+ |
+
| 16 | ++ |
+ #' @param conf.level (scalar `numeric`)\cr+ |
+
| 17 | ++ |
+ #' confidence level for confidence interval. Default is `0.95`.+ |
+
| 18 | ++ |
+ #' @param ... arguments passed to `effectsize::hedges_g(...)`+ |
+
| 19 | ++ |
+ #'+ |
+
| 20 | ++ |
+ #' @return ARD data frame+ |
+
| 21 | ++ |
+ #' @name ard_effectsize_hedges_g+ |
+
| 22 | ++ |
+ #'+ |
+
| 23 | ++ |
+ #' @details+ |
+
| 24 | ++ |
+ #' For the `ard_effectsize_hedges_g()` function, the data is expected to be one row per subject.+ |
+
| 25 | ++ |
+ #' The data is passed as `effectsize::hedges_g(data[[variable]]~data[[by]], data, paired = FALSE, ...)`.+ |
+
| 26 | ++ |
+ #'+ |
+
| 27 | ++ |
+ #' For the `ard_effectsize_paired_hedges_g()` function, the data is expected to be one row+ |
+
| 28 | ++ |
+ #' per subject per by level. Before the effect size is calculated, the data are+ |
+
| 29 | ++ |
+ #' reshaped to a wide format to be one row per subject.+ |
+
| 30 | ++ |
+ #' The data are then passed as+ |
+
| 31 | ++ |
+ #' `effectsize::hedges_g(x = data_wide[[<by level 1>]], y = data_wide[[<by level 2>]], paired = TRUE, ...)`.+ |
+
| 32 | ++ |
+ #'+ |
+
| 33 | ++ |
+ #' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = c("effectsize", "parameters"), reference_pkg = "cardx"))
+ |
+
| 34 | ++ |
+ #' cards::ADSL |>+ |
+
| 35 | ++ |
+ #' dplyr::filter(ARM %in% c("Placebo", "Xanomeline High Dose")) |>
+ |
+
| 36 | ++ |
+ #' ard_effectsize_hedges_g(by = ARM, variables = AGE)+ |
+
| 37 | ++ |
+ #'+ |
+
| 38 | ++ |
+ #' # constructing a paired data set,+ |
+
| 39 | ++ |
+ #' # where patients receive both treatments+ |
+
| 40 | ++ |
+ #' cards::ADSL[c("ARM", "AGE")] |>
+ |
+
| 41 | ++ |
+ #' dplyr::filter(ARM %in% c("Placebo", "Xanomeline High Dose")) |>
+ |
+
| 42 | ++ |
+ #' dplyr::mutate(.by = ARM, USUBJID = dplyr::row_number()) |>+ |
+
| 43 | ++ |
+ #' dplyr::arrange(USUBJID, ARM) |>+ |
+
| 44 | ++ |
+ #' dplyr::group_by(USUBJID) |>+ |
+
| 45 | ++ |
+ #' dplyr::filter(dplyr::n() > 1) |>+ |
+
| 46 | ++ |
+ #' ard_effectsize_paired_hedges_g(by = ARM, variables = AGE, id = USUBJID)+ |
+
| 47 | ++ |
+ NULL+ |
+
| 48 | ++ | + + | +
| 49 | ++ |
+ #' @rdname ard_effectsize_hedges_g+ |
+
| 50 | ++ |
+ #' @export+ |
+
| 51 | ++ |
+ ard_effectsize_hedges_g <- function(data, by, variables, conf.level = 0.95, ...) {
+ |
+
| 52 | +4x | +
+ set_cli_abort_call()+ |
+
| 53 | ++ | + + | +
| 54 | ++ |
+ # check installed packages ---------------------------------------------------+ |
+
| 55 | +4x | +
+ check_pkg_installed(c("effectsize", "parameters"), reference_pkg = "cardx")
+ |
+
| 56 | ++ | + + | +
| 57 | ++ |
+ # check/process inputs -------------------------------------------------------+ |
+
| 58 | +4x | +
+ check_not_missing(data)+ |
+
| 59 | +4x | +
+ check_not_missing(variables)+ |
+
| 60 | +4x | +
+ check_data_frame(data)+ |
+
| 61 | +4x | +
+ data <- dplyr::ungroup(data)+ |
+
| 62 | +4x | +
+ cards::process_selectors(data, by = {{ by }}, variables = {{ variables }})
+ |
+
| 63 | +4x | +
+ check_scalar(by)+ |
+
| 64 | +4x | +
+ check_range(conf.level, range = c(0, 1))+ |
+
| 65 | ++ | + + | +
| 66 | ++ |
+ # return empty ARD if no variables selected ----------------------------------+ |
+
| 67 | +4x | +
+ if (is_empty(variables)) {
+ |
+
| 68 | +! | +
+ return(dplyr::tibble() |> cards::as_card())+ |
+
| 69 | ++ |
+ }+ |
+
| 70 | ++ | + + | +
| 71 | ++ |
+ # build ARD ------------------------------------------------------------------+ |
+
| 72 | +4x | +
+ lapply(+ |
+
| 73 | +4x | +
+ variables,+ |
+
| 74 | +4x | +
+ function(variable) {
+ |
+
| 75 | +5x | +
+ .format_hedges_g_results(+ |
+
| 76 | +5x | +
+ by = by,+ |
+
| 77 | +5x | +
+ variable = variable,+ |
+
| 78 | +5x | +
+ lst_tidy =+ |
+
| 79 | +5x | +
+ cards::eval_capture_conditions(+ |
+
| 80 | +5x | +
+ effectsize::hedges_g(+ |
+
| 81 | +5x | +
+ reformulate2(by, response = variable),+ |
+
| 82 | +5x | +
+ data = data |> tidyr::drop_na(all_of(c(by, variable))),+ |
+
| 83 | +5x | +
+ paired = FALSE,+ |
+
| 84 | +5x | +
+ ci = conf.level,+ |
+
| 85 | ++ |
+ ...+ |
+
| 86 | ++ |
+ ) |>+ |
+
| 87 | +5x | +
+ parameters::standardize_names(style = "broom") |>+ |
+
| 88 | +5x | +
+ dplyr::mutate(method = "Hedge's G")+ |
+
| 89 | ++ |
+ ),+ |
+
| 90 | +5x | +
+ paired = FALSE,+ |
+
| 91 | ++ |
+ ...+ |
+
| 92 | ++ |
+ )+ |
+
| 93 | ++ |
+ }+ |
+
| 94 | ++ |
+ ) |>+ |
+
| 95 | +4x | +
+ dplyr::bind_rows()+ |
+
| 96 | ++ |
+ }+ |
+
| 97 | ++ | + + | +
| 98 | ++ |
+ #' @rdname ard_effectsize_hedges_g+ |
+
| 99 | ++ |
+ #' @export+ |
+
| 100 | ++ |
+ ard_effectsize_paired_hedges_g <- function(data, by, variables, id, conf.level = 0.95, ...) {
+ |
+
| 101 | +3x | +
+ set_cli_abort_call()+ |
+
| 102 | ++ | + + | +
| 103 | ++ |
+ # check installed packages ---------------------------------------------------+ |
+
| 104 | +3x | +
+ check_pkg_installed(c("effectsize", "parameters"), reference_pkg = "cardx")
+ |
+
| 105 | ++ | + + | +
| 106 | ++ |
+ # check/process inputs -------------------------------------------------------+ |
+
| 107 | +3x | +
+ check_not_missing(data)+ |
+
| 108 | +3x | +
+ check_not_missing(variables)+ |
+
| 109 | +3x | +
+ check_not_missing(by)+ |
+
| 110 | +3x | +
+ check_not_missing(id)+ |
+
| 111 | +3x | +
+ check_data_frame(data)+ |
+
| 112 | +3x | +
+ data <- dplyr::ungroup(data)+ |
+
| 113 | +3x | +
+ cards::process_selectors(data, by = {{ by }}, variables = {{ variables }}, id = {{ id }})
+ |
+
| 114 | +3x | +
+ check_scalar(by)+ |
+
| 115 | +3x | +
+ check_scalar(id)+ |
+
| 116 | +3x | +
+ check_range(conf.level, range = c(0, 1))+ |
+
| 117 | ++ | + + | +
| 118 | ++ |
+ # return empty ARD if no variables selected ----------------------------------+ |
+
| 119 | +3x | +
+ if (is_empty(variables)) {
+ |
+
| 120 | +! | +
+ return(dplyr::tibble() |> cards::as_card())+ |
+
| 121 | ++ |
+ }+ |
+
| 122 | ++ | + + | +
| 123 | ++ |
+ # build ARD ------------------------------------------------------------------+ |
+
| 124 | +3x | +
+ lapply(+ |
+
| 125 | +3x | +
+ variables,+ |
+
| 126 | +3x | +
+ function(variable) {
+ |
+
| 127 | +3x | +
+ .format_hedges_g_results(+ |
+
| 128 | +3x | +
+ by = by,+ |
+
| 129 | +3x | +
+ variable = variable,+ |
+
| 130 | +3x | +
+ lst_tidy =+ |
+
| 131 | +3x | +
+ cards::eval_capture_conditions({
+ |
+
| 132 | ++ |
+ # adding this reshape inside the eval, so if there is an error it's captured in the ARD object+ |
+
| 133 | +3x | +
+ data_wide <-+ |
+
| 134 | +3x | +
+ data |>+ |
+
| 135 | +3x | +
+ tidyr::drop_na(all_of(c(id, by, variable))) |>+ |
+
| 136 | +3x | +
+ .paired_data_pivot_wider(by = by, variable = variable, id = id) |>+ |
+
| 137 | +3x | +
+ tidyr::drop_na(any_of(c("by1", "by2")))
+ |
+
| 138 | ++ |
+ # perform paired cohen's d test+ |
+
| 139 | +2x | +
+ effectsize::hedges_g(x = data_wide[["by1"]], y = data_wide[["by2"]], paired = TRUE, ci = conf.level, ...) |>+ |
+
| 140 | +2x | +
+ parameters::standardize_names(style = "broom") |>+ |
+
| 141 | +2x | +
+ dplyr::mutate(method = "Paired Hedge's G")+ |
+
| 142 | ++ |
+ }),+ |
+
| 143 | +3x | +
+ paired = TRUE,+ |
+
| 144 | ++ |
+ ...+ |
+
| 145 | ++ |
+ )+ |
+
| 146 | ++ |
+ }+ |
+
| 147 | ++ |
+ ) |>+ |
+
| 148 | +3x | +
+ dplyr::bind_rows()+ |
+
| 149 | ++ |
+ }+ |
+
| 150 | ++ | + + | +
| 151 | ++ |
+ #' Convert Hedge's G Test to ARD+ |
+
| 152 | ++ |
+ #'+ |
+
| 153 | ++ |
+ #' @inheritParams cards::tidy_as_ard+ |
+
| 154 | ++ |
+ #' @inheritParams effectsize::hedges_g+ |
+
| 155 | ++ |
+ #' @param by (`string`)\cr by column name+ |
+
| 156 | ++ |
+ #' @param variable (`string`)\cr variable column name+ |
+
| 157 | ++ |
+ #' @param ... passed to `hedges_g(...)`+ |
+
| 158 | ++ |
+ #'+ |
+
| 159 | ++ |
+ #' @return ARD data frame+ |
+
| 160 | ++ |
+ #' @keywords internal+ |
+
| 161 | ++ |
+ #' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = c("effectsize", "parameters"), reference_pkg = "cardx"))
+ |
+
| 162 | ++ |
+ #' cardx:::.format_hedges_g_results(+ |
+
| 163 | ++ |
+ #' by = "ARM",+ |
+
| 164 | ++ |
+ #' variable = "AGE",+ |
+
| 165 | ++ |
+ #' paired = FALSE,+ |
+
| 166 | ++ |
+ #' lst_tidy =+ |
+
| 167 | ++ |
+ #' cards::eval_capture_conditions(+ |
+
| 168 | ++ |
+ #' effectsize::hedges_g(data[[variable]] ~ data[[by]], paired = FALSE) |>+ |
+
| 169 | ++ |
+ #' parameters::standardize_names(style = "broom")+ |
+
| 170 | ++ |
+ #' )+ |
+
| 171 | ++ |
+ #' )+ |
+
| 172 | ++ |
+ .format_hedges_g_results <- function(by, variable, lst_tidy, paired, ...) {
+ |
+
| 173 | ++ |
+ # build ARD ------------------------------------------------------------------+ |
+
| 174 | +8x | +
+ ret <-+ |
+
| 175 | +8x | +
+ cards::tidy_as_ard(+ |
+
| 176 | +8x | +
+ lst_tidy = lst_tidy,+ |
+
| 177 | +8x | +
+ tidy_result_names = c(+ |
+
| 178 | +8x | +
+ "estimate", "conf.level", "conf.low", "conf.high"+ |
+
| 179 | ++ |
+ ),+ |
+
| 180 | +8x | +
+ fun_args_to_record = c("mu", "paired", "pooled_sd", "alternative"),
+ |
+
| 181 | +8x | +
+ formals = formals(asNamespace("effectsize")[["hedges_g"]]),
+ |
+
| 182 | +8x | +
+ passed_args = c(list(paired = paired), dots_list(...)),+ |
+
| 183 | +8x | +
+ lst_ard_columns = list(group1 = by, variable = variable, context = "effectsize_hedges_g")+ |
+
| 184 | ++ |
+ )+ |
+
| 185 | ++ | + + | +
| 186 | ++ |
+ # add the stat label ---------------------------------------------------------+ |
+
| 187 | +8x | +
+ ret |>+ |
+
| 188 | +8x | +
+ dplyr::left_join(+ |
+
| 189 | +8x | +
+ .df_effectsize_stat_labels(),+ |
+
| 190 | +8x | +
+ by = "stat_name"+ |
+
| 191 | ++ |
+ ) |>+ |
+
| 192 | +8x | +
+ dplyr::mutate(stat_label = dplyr::coalesce(.data$stat_label, .data$stat_name)) |>+ |
+
| 193 | +8x | +
+ cards::as_card() |>+ |
+
| 194 | +8x | +
+ cards::tidy_ard_column_order()+ |
+
| 195 | ++ |
+ }+ |
+
| 1 | ++ |
+ #' ARD for LS Mean Difference+ |
+
| 2 | ++ |
+ #'+ |
+
| 3 | ++ |
+ #' @description+ |
+
| 4 | ++ |
+ #' This function calculates least-squares mean differences using the 'emmeans'+ |
+
| 5 | ++ |
+ #' package using the following+ |
+
| 6 | ++ |
+ #'+ |
+
| 7 | ++ |
+ #' ```r+ |
+
| 8 | ++ |
+ #' emmeans::emmeans(object = <regression model>, specs = ~ <primary covariate>) |>+ |
+
| 9 | ++ |
+ #' emmeans::contrast(method = "pairwise") |>+ |
+
| 10 | ++ |
+ #' summary(infer = TRUE, level = <confidence level>)+ |
+
| 11 | ++ |
+ #' ```+ |
+
| 12 | ++ |
+ #'+ |
+
| 13 | ++ |
+ #' The arguments `data`, `formula`, `method`, `method.args`, `package` are used+ |
+
| 14 | ++ |
+ #' to construct the regression model via `cardx::construct_model()`.+ |
+
| 15 | ++ |
+ #'+ |
+
| 16 | ++ |
+ #' @param data (`data.frame`/`survey.design`)\cr+ |
+
| 17 | ++ |
+ #' a data frame or survey design object+ |
+
| 18 | ++ |
+ #' @inheritParams construct_model+ |
+
| 19 | ++ |
+ #' @param response_type (`string`)+ |
+
| 20 | ++ |
+ #' string indicating whether the model outcome is `'continuous'`+ |
+
| 21 | ++ |
+ #' or `'dichotomous'`. When `'dichotomous'`, the call to `emmeans::emmeans()` is+ |
+
| 22 | ++ |
+ #' supplemented with argument `regrid="response"`.+ |
+
| 23 | ++ |
+ #' @param conf.level (scalar `numeric`)\cr+ |
+
| 24 | ++ |
+ #' confidence level for confidence interval. Default is `0.95`.+ |
+
| 25 | ++ |
+ #' @param primary_covariate (`string`)\cr+ |
+
| 26 | ++ |
+ #' string indicating the primary covariate (typically the dichotomous treatment variable).+ |
+
| 27 | ++ |
+ #' Default is the first covariate listed in the formula.+ |
+
| 28 | ++ |
+ #'+ |
+
| 29 | ++ |
+ #' @return ARD data frame+ |
+
| 30 | ++ |
+ #' @export+ |
+
| 31 | ++ |
+ #'+ |
+
| 32 | ++ |
+ #' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = "emmeans", reference_pkg = "cardx"))
+ |
+
| 33 | ++ |
+ #' ard_emmeans_mean_difference(+ |
+
| 34 | ++ |
+ #' data = mtcars,+ |
+
| 35 | ++ |
+ #' formula = mpg ~ am + cyl,+ |
+
| 36 | ++ |
+ #' method = "lm"+ |
+
| 37 | ++ |
+ #' )+ |
+
| 38 | ++ |
+ #'+ |
+
| 39 | ++ |
+ #' ard_emmeans_mean_difference(+ |
+
| 40 | ++ |
+ #' data = mtcars,+ |
+
| 41 | ++ |
+ #' formula = vs ~ am + mpg,+ |
+
| 42 | ++ |
+ #' method = "glm",+ |
+
| 43 | ++ |
+ #' method.args = list(family = binomial),+ |
+
| 44 | ++ |
+ #' response_type = "dichotomous"+ |
+
| 45 | ++ |
+ #' )+ |
+
| 46 | ++ |
+ ard_emmeans_mean_difference <- function(data, formula, method,+ |
+
| 47 | ++ |
+ method.args = list(),+ |
+
| 48 | ++ |
+ package = "base",+ |
+
| 49 | ++ |
+ response_type = c("continuous", "dichotomous"),
+ |
+
| 50 | ++ |
+ conf.level = 0.95,+ |
+
| 51 | ++ |
+ primary_covariate =+ |
+
| 52 | ++ |
+ stats::terms(formula) |>+ |
+
| 53 | ++ |
+ attr("term.labels") |>
+ |
+
| 54 | ++ |
+ getElement(1L)) {
+ |
+
| 55 | +4x | +
+ set_cli_abort_call()+ |
+
| 56 | ++ | + + | +
| 57 | ++ |
+ # check package installation -------------------------------------------------+ |
+
| 58 | +4x | +
+ check_pkg_installed(c("emmeans", package), reference_pkg = "cardx")
+ |
+
| 59 | +4x | +
+ check_not_missing(data)+ |
+
| 60 | +4x | +
+ check_not_missing(formula)+ |
+
| 61 | +4x | +
+ check_not_missing(method)+ |
+
| 62 | +4x | +
+ check_class(data, c("data.frame", "survey.design"))
+ |
+
| 63 | +4x | +
+ check_class(formula, cls = "formula")+ |
+
| 64 | +4x | +
+ check_string(package)+ |
+
| 65 | +4x | +
+ check_string(primary_covariate)+ |
+
| 66 | +4x | +
+ check_scalar(conf.level)+ |
+
| 67 | +4x | +
+ check_range(conf.level, range = c(0, 1))+ |
+
| 68 | +4x | +
+ response_type <- arg_match(response_type, error_call = get_cli_abort_call())+ |
+
| 69 | ++ | + + | +
| 70 | ++ |
+ # construct primary model ----------------------------------------------------+ |
+
| 71 | +4x | +
+ mod <-+ |
+
| 72 | +4x | +
+ construct_model(+ |
+
| 73 | +4x | +
+ data = data, formula = formula, method = method,+ |
+
| 74 | +4x | +
+ method.args = {{ method.args }},
+ |
+
| 75 | +4x | +
+ package = package, env = caller_env()+ |
+
| 76 | ++ |
+ )+ |
+
| 77 | ++ | + + | +
| 78 | ++ |
+ # emmeans --------------------------------------------------------------------+ |
+
| 79 | +4x | +
+ emmeans_args <- list(object = mod, specs = reformulate2(primary_covariate))+ |
+
| 80 | +3x | +
+ if (response_type %in% "dichotomous") emmeans_args <- c(emmeans_args, list(regrid = "response"))+ |
+
| 81 | +4x | +
+ emmeans <-+ |
+
| 82 | +4x | +
+ withr::with_namespace(+ |
+
| 83 | +4x | +
+ package = "emmeans",+ |
+
| 84 | +4x | +
+ code = do.call("emmeans", args = emmeans_args)
+ |
+
| 85 | ++ |
+ )+ |
+
| 86 | ++ | + + | +
| 87 | +4x | +
+ df_results <-+ |
+
| 88 | +4x | +
+ emmeans |>+ |
+
| 89 | +4x | +
+ emmeans::contrast(method = "pairwise") |>+ |
+
| 90 | +4x | +
+ summary(infer = TRUE, level = conf.level)+ |
+
| 91 | ++ | + + | +
| 92 | ++ |
+ # convert results to ARD format ----------------------------------------------+ |
+
| 93 | +4x | +
+ df_results |>+ |
+
| 94 | +4x | +
+ dplyr::as_tibble() |>+ |
+
| 95 | +4x | +
+ dplyr::rename(+ |
+
| 96 | +4x | +
+ conf.low = any_of("asymp.LCL"),
+ |
+
| 97 | +4x | +
+ conf.high = any_of("asymp.UCL"),
+ |
+
| 98 | +4x | +
+ conf.low = any_of("lower.CL"),
+ |
+
| 99 | +4x | +
+ conf.high = any_of("upper.CL")
+ |
+
| 100 | ++ |
+ ) %>%+ |
+
| 101 | +4x | +
+ dplyr::select(+ |
+
| 102 | +4x | +
+ variable_level = "contrast",+ |
+
| 103 | +4x | +
+ "estimate",+ |
+
| 104 | +4x | +
+ std.error = "SE", "df",+ |
+
| 105 | +4x | +
+ "conf.low", "conf.high", "p.value"+ |
+
| 106 | ++ |
+ ) %>%+ |
+
| 107 | +4x | +
+ dplyr::mutate(+ |
+
| 108 | +4x | +
+ conf.level = .env$conf.level,+ |
+
| 109 | +4x | +
+ method =+ |
+
| 110 | +4x | +
+ ifelse(+ |
+
| 111 | +4x | +
+ length(attr(stats::terms(formula), "term.labels") |> discard(~ startsWith(., "1 |"))) == 1L,+ |
+
| 112 | +4x | +
+ "Least-squares mean difference",+ |
+
| 113 | +4x | +
+ "Least-squares adjusted mean difference"+ |
+
| 114 | ++ |
+ ),+ |
+
| 115 | +4x | +
+ across(everything(), as.list),+ |
+
| 116 | +4x | +
+ variable = "contrast",+ |
+
| 117 | +4x | +
+ group1 = .env$primary_covariate+ |
+
| 118 | ++ |
+ ) |>+ |
+
| 119 | +4x | +
+ tidyr::pivot_longer(+ |
+
| 120 | +4x | +
+ cols = -c("group1", "variable", "variable_level"),
+ |
+
| 121 | +4x | +
+ names_to = "stat_name",+ |
+
| 122 | +4x | +
+ values_to = "stat"+ |
+
| 123 | ++ |
+ ) |>+ |
+
| 124 | +4x | +
+ dplyr::left_join(.df_ttest_stat_labels(primary_covariate), by = "stat_name") |>+ |
+
| 125 | +4x | +
+ dplyr::mutate(+ |
+
| 126 | +4x | +
+ context = "emmeans_mean_difference",+ |
+
| 127 | +4x | +
+ stat_label = dplyr::coalesce(.data$stat_label, .data$stat_name),+ |
+
| 128 | +4x | +
+ warning = list(NULL),+ |
+
| 129 | +4x | +
+ error = list(NULL),+ |
+
| 130 | +4x | +
+ fmt_fn = map(.data$stat, \(.x) if (is.numeric(.x)) 1L else NULL) # styler: off+ |
+
| 131 | ++ |
+ ) |>+ |
+
| 132 | +4x | +
+ cards::as_card() |>+ |
+
| 133 | +4x | +
+ cards::tidy_ard_column_order()+ |
+
| 134 | ++ |
+ }+ |
+
| 1 | ++ |
+ #' ARD one-sample Wilcox Rank-sum+ |
+
| 2 | ++ |
+ #'+ |
+
| 3 | ++ |
+ #' @description+ |
+
| 4 | ++ |
+ #' Analysis results data for one-sample Wilcox Rank-sum.+ |
+
| 5 | ++ |
+ #' Result may be stratified by including the `by` argument.+ |
+
| 6 | ++ |
+ #'+ |
+
| 7 | ++ |
+ #' @param data (`data.frame`)\cr+ |
+
| 8 | ++ |
+ #' a data frame. See below for details.+ |
+
| 9 | ++ |
+ #' @param variables ([`tidy-select`][dplyr::dplyr_tidy_select])\cr+ |
+
| 10 | ++ |
+ #' column names to be analyzed. Independent Wilcox Rank-sum tests will be computed for+ |
+
| 11 | ++ |
+ #' each variable.+ |
+
| 12 | ++ |
+ #' @param by ([`tidy-select`][dplyr::dplyr_tidy_select])\cr+ |
+
| 13 | ++ |
+ #' optional column name to stratify results by.+ |
+
| 14 | ++ |
+ #' @inheritParams ard_stats_wilcox_test+ |
+
| 15 | ++ |
+ #'+ |
+
| 16 | ++ |
+ #' @return ARD data frame+ |
+
| 17 | ++ |
+ #' @export+ |
+
| 18 | ++ |
+ #'+ |
+
| 19 | ++ |
+ #' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = "broom", reference_pkg = "cardx"))
+ |
+
| 20 | ++ |
+ #' cards::ADSL |>+ |
+
| 21 | ++ |
+ #' ard_stats_wilcox_test_onesample(by = ARM, variables = AGE)+ |
+
| 22 | ++ |
+ ard_stats_wilcox_test_onesample <- function(data, variables, by = dplyr::group_vars(data), conf.level = 0.95, ...) {
+ |
+
| 23 | +6x | +
+ set_cli_abort_call()+ |
+
| 24 | ++ | + + | +
| 25 | ++ |
+ # check installed packages ---------------------------------------------------+ |
+
| 26 | +6x | +
+ check_pkg_installed("broom", reference_pkg = "cardx")
+ |
+
| 27 | ++ | + + | +
| 28 | ++ |
+ # check/process inputs -------------------------------------------------------+ |
+
| 29 | +6x | +
+ check_not_missing(data)+ |
+
| 30 | +6x | +
+ check_not_missing(variables)+ |
+
| 31 | +6x | +
+ check_data_frame(data)+ |
+
| 32 | +6x | +
+ data <- dplyr::ungroup(data)+ |
+
| 33 | +6x | +
+ cards::process_selectors(data, by = {{ by }}, variables = {{ variables }})
+ |
+
| 34 | +6x | +
+ check_scalar_range(conf.level, range = c(0, 1))+ |
+
| 35 | ++ | + + | +
| 36 | ++ |
+ # return empty ARD if no variables selected ----------------------------------+ |
+
| 37 | +6x | +
+ if (is_empty(variables)) {
+ |
+
| 38 | +1x | +
+ return(dplyr::tibble() |> cards::as_card())+ |
+
| 39 | ++ |
+ }+ |
+
| 40 | ++ | + + | +
| 41 | +5x | +
+ cards::ard_continuous(+ |
+
| 42 | +5x | +
+ data = data,+ |
+
| 43 | +5x | +
+ variables = all_of(variables),+ |
+
| 44 | +5x | +
+ by = all_of(by),+ |
+
| 45 | +5x | +
+ statistic = all_of(variables) ~ list(wilcox_test_onesample = \(x) stats::wilcox.test(x = x, conf.level = conf.level, ...) |> broom::tidy())+ |
+
| 46 | ++ |
+ ) |>+ |
+
| 47 | +5x | +
+ cards::bind_ard(+ |
+
| 48 | +5x | +
+ cards::ard_continuous(+ |
+
| 49 | +5x | +
+ data = data,+ |
+
| 50 | +5x | +
+ variables = all_of(variables),+ |
+
| 51 | +5x | +
+ by = all_of(by),+ |
+
| 52 | +5x | +
+ statistic =+ |
+
| 53 | +5x | +
+ all_of(variables) ~+ |
+
| 54 | +5x | +
+ list(conf.level = \(x) {
+ |
+
| 55 | +9x | +
+ formals(asNamespace("stats")[["wilcox.test.default"]])[c("mu", "exact", "conf.int", "tol.root", "digits.rank")] |>
+ |
+
| 56 | +9x | +
+ utils::modifyList(list(conf.level = conf.level, ...)) |>+ |
+
| 57 | +9x | +
+ compact()+ |
+
| 58 | ++ |
+ })+ |
+
| 59 | ++ |
+ )+ |
+
| 60 | ++ |
+ ) |>+ |
+
| 61 | +5x | +
+ dplyr::select(-"stat_label") |>+ |
+
| 62 | +5x | +
+ dplyr::left_join(+ |
+
| 63 | +5x | +
+ .df_ttest_stat_labels(by = NULL),+ |
+
| 64 | +5x | +
+ by = "stat_name"+ |
+
| 65 | ++ |
+ ) |>+ |
+
| 66 | +5x | +
+ dplyr::mutate(+ |
+
| 67 | +5x | +
+ stat_label = dplyr::coalesce(.data$stat_label, .data$stat_name),+ |
+
| 68 | +5x | +
+ context = "stats_wilcox_test_onesample",+ |
+
| 69 | ++ |
+ ) |>+ |
+
| 70 | +5x | +
+ cards::as_card() |>+ |
+
| 71 | +5x | +
+ cards::tidy_ard_column_order() |>+ |
+
| 72 | +5x | +
+ cards::tidy_ard_row_order()+ |
+
| 73 | ++ |
+ }+ |
+
| 1 | ++ |
+ #' ARD Survey rank test+ |
+
| 2 | ++ |
+ #'+ |
+
| 3 | ++ |
+ #' @description+ |
+
| 4 | ++ |
+ #' Analysis results data for survey wilcox test using [`survey::svyranktest()`].+ |
+
| 5 | ++ |
+ #'+ |
+
| 6 | ++ |
+ #' @param data (`survey.design`)\cr+ |
+
| 7 | ++ |
+ #' a survey design object often created with [`survey::svydesign()`]+ |
+
| 8 | ++ |
+ #' @param by ([`tidy-select`][dplyr::dplyr_tidy_select])\cr+ |
+
| 9 | ++ |
+ #' column name to compare by+ |
+
| 10 | ++ |
+ #' @param variables ([`tidy-select`][dplyr::dplyr_tidy_select])\cr+ |
+
| 11 | ++ |
+ #' column names to be compared. Independent tests will be run for each variable.+ |
+
| 12 | ++ |
+ #' @param test (`string`)\cr+ |
+
| 13 | ++ |
+ #' a string to denote which rank test to use:+ |
+
| 14 | ++ |
+ #' `"wilcoxon"`, `"vanderWaerden"`, `"median"`, `"KruskalWallis"`+ |
+
| 15 | ++ |
+ #' @param ... arguments passed to [`survey::svyranktest()`]+ |
+
| 16 | ++ |
+ #'+ |
+
| 17 | ++ |
+ #' @return ARD data frame+ |
+
| 18 | ++ |
+ #' @export+ |
+
| 19 | ++ |
+ #'+ |
+
| 20 | ++ |
+ #' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = c("survey", "broom"), reference_pkg = "cardx"))
+ |
+
| 21 | ++ |
+ #' data(api, package = "survey")+ |
+
| 22 | ++ |
+ #' dclus2 <- survey::svydesign(id = ~ dnum + snum, fpc = ~ fpc1 + fpc2, data = apiclus2)+ |
+
| 23 | ++ |
+ #'+ |
+
| 24 | ++ |
+ #' ard_survey_svyranktest(dclus2, variables = enroll, by = comp.imp, test = "wilcoxon")+ |
+
| 25 | ++ |
+ #' ard_survey_svyranktest(dclus2, variables = enroll, by = comp.imp, test = "vanderWaerden")+ |
+
| 26 | ++ |
+ #' ard_survey_svyranktest(dclus2, variables = enroll, by = comp.imp, test = "median")+ |
+
| 27 | ++ |
+ #' ard_survey_svyranktest(dclus2, variables = enroll, by = comp.imp, test = "KruskalWallis")+ |
+
| 28 | ++ |
+ ard_survey_svyranktest <- function(data, by, variables, test, ...) {
+ |
+
| 29 | +6x | +
+ set_cli_abort_call()+ |
+
| 30 | ++ | + + | +
| 31 | ++ |
+ # check installed packages ---------------------------------------------------+ |
+
| 32 | +6x | +
+ check_pkg_installed(c("survey", "broom"), reference_pkg = "cardx")
+ |
+
| 33 | ++ | + + | +
| 34 | ++ |
+ # check/process inputs -------------------------------------------------------+ |
+
| 35 | +6x | +
+ check_not_missing(data)+ |
+
| 36 | +6x | +
+ check_not_missing(variables)+ |
+
| 37 | +6x | +
+ check_not_missing(by)+ |
+
| 38 | +6x | +
+ check_class(data, cls = "survey.design")+ |
+
| 39 | +6x | +
+ cards::process_selectors(data[["variables"]], by = {{ by }}, variables = {{ variables }})
+ |
+
| 40 | +6x | +
+ check_scalar(by)+ |
+
| 41 | ++ | + + | +
| 42 | ++ |
+ # return empty ARD if no variables selected ----------------------------------+ |
+
| 43 | +6x | +
+ if (is_empty(variables)) {
+ |
+
| 44 | +! | +
+ return(dplyr::tibble() |> cards::as_card())+ |
+
| 45 | ++ |
+ }+ |
+
| 46 | ++ | + + | +
| 47 | ++ |
+ # build ARD ------------------------------------------------------------------+ |
+
| 48 | +6x | +
+ lapply(+ |
+
| 49 | +6x | +
+ variables,+ |
+
| 50 | +6x | +
+ function(variable) {
+ |
+
| 51 | +6x | +
+ .format_svyranktest_results(+ |
+
| 52 | +6x | +
+ by = by,+ |
+
| 53 | +6x | +
+ variable = variable,+ |
+
| 54 | +6x | +
+ lst_tidy =+ |
+
| 55 | +6x | +
+ cards::eval_capture_conditions(+ |
+
| 56 | +6x | +
+ survey::svyranktest(reformulate2(termlabels = by, response = variable), design = data, test = test, ...) |>+ |
+
| 57 | +6x | +
+ broom::tidy()+ |
+
| 58 | ++ |
+ )+ |
+
| 59 | ++ |
+ )+ |
+
| 60 | ++ |
+ }+ |
+
| 61 | ++ |
+ ) |>+ |
+
| 62 | +6x | +
+ dplyr::bind_rows()+ |
+
| 63 | ++ |
+ }+ |
+
| 64 | ++ | + + | +
| 65 | ++ |
+ .format_svyranktest_results <- function(by, variable, lst_tidy, ...) {
+ |
+
| 66 | ++ |
+ # build ARD ------------------------------------------------------------------+ |
+
| 67 | +6x | +
+ ret <-+ |
+
| 68 | +6x | +
+ cards::tidy_as_ard(+ |
+
| 69 | +6x | +
+ lst_tidy = lst_tidy,+ |
+
| 70 | +6x | +
+ tidy_result_names = c(+ |
+
| 71 | +6x | +
+ "estimate", "statistic",+ |
+
| 72 | +6x | +
+ "p.value", "parameter",+ |
+
| 73 | +6x | +
+ "method", "alternative"+ |
+
| 74 | ++ |
+ ),+ |
+
| 75 | +6x | +
+ passed_args = dots_list(...),+ |
+
| 76 | +6x | +
+ lst_ard_columns = list(group1 = by, variable = variable, context = "survey_svyranktest")+ |
+
| 77 | ++ |
+ )+ |
+
| 78 | ++ | + + | +
| 79 | ++ |
+ # add the stat label ---------------------------------------------------------+ |
+
| 80 | +6x | +
+ ret |>+ |
+
| 81 | +6x | +
+ dplyr::left_join(+ |
+
| 82 | +6x | +
+ .df_surveyrank_stat_labels(),+ |
+
| 83 | +6x | +
+ by = "stat_name"+ |
+
| 84 | ++ |
+ ) |>+ |
+
| 85 | +6x | +
+ dplyr::mutate(stat_label = dplyr::coalesce(.data$stat_label, .data$stat_name)) |>+ |
+
| 86 | +6x | +
+ cards::as_card() |>+ |
+
| 87 | +6x | +
+ cards::tidy_ard_column_order()+ |
+
| 88 | ++ |
+ }+ |
+
| 89 | ++ | + + | +
| 90 | ++ | + + | +
| 91 | ++ |
+ .df_surveyrank_stat_labels <- function() {
+ |
+
| 92 | +6x | +
+ dplyr::tribble(+ |
+
| 93 | +6x | +
+ ~stat_name, ~stat_label,+ |
+
| 94 | +6x | +
+ "statistic", "Statistic",+ |
+
| 95 | +6x | +
+ "parameter", "Degrees of Freedom",+ |
+
| 96 | +6x | +
+ "estimate", "Median of the Difference",+ |
+
| 97 | +6x | +
+ "null.value", "Null Value",+ |
+
| 98 | +6x | +
+ "alternative", "Alternative Hypothesis",+ |
+
| 99 | +6x | +
+ "data.name", "Data Name",+ |
+
| 100 | +6x | +
+ "p.value", "p-value"+ |
+
| 101 | ++ |
+ )+ |
+
| 102 | ++ |
+ }+ |
+
| 1 | ++ |
+ #' ARD ANOVA from car Package+ |
+
| 2 | ++ |
+ #'+ |
+
| 3 | ++ |
+ #' Function takes a regression model object and calculated ANOVA using [`car::Anova()`].+ |
+
| 4 | ++ |
+ #'+ |
+
| 5 | ++ |
+ #' @param x regression model object+ |
+
| 6 | ++ |
+ #' @param ... arguments passed to `car::Anova(...)`+ |
+
| 7 | ++ |
+ #'+ |
+
| 8 | ++ |
+ #' @return data frame+ |
+
| 9 | ++ |
+ #' @export+ |
+
| 10 | ++ |
+ #'+ |
+
| 11 | ++ |
+ #' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = c("broom.helpers", "car", "parameters"), reference_pkg = "cardx"))
+ |
+
| 12 | ++ |
+ #' lm(AGE ~ ARM, data = cards::ADSL) |>+ |
+
| 13 | ++ |
+ #' ard_car_anova()+ |
+
| 14 | ++ |
+ #'+ |
+
| 15 | ++ |
+ #' glm(vs ~ factor(cyl) + factor(am), data = mtcars, family = binomial) |>+ |
+
| 16 | ++ |
+ #' ard_car_anova(test.statistic = "Wald")+ |
+
| 17 | ++ |
+ ard_car_anova <- function(x, ...) {
+ |
+
| 18 | +3x | +
+ set_cli_abort_call()+ |
+
| 19 | ++ | + + | +
| 20 | ++ |
+ # check installed packages ---------------------------------------------------+ |
+
| 21 | +3x | +
+ check_pkg_installed(pkg = c("broom.helpers", "car", "parameters"), reference_pkg = "cardx")
+ |
+
| 22 | ++ | + + | +
| 23 | ++ |
+ # check inputs ---------------------------------------------------------------+ |
+
| 24 | +3x | +
+ check_not_missing(x)+ |
+
| 25 | ++ | + + | +
| 26 | ++ |
+ # run car::Anova() -----------------------------------------------------------+ |
+
| 27 | +3x | +
+ car_anova <- cards::eval_capture_conditions(car::Anova(x, ...))+ |
+
| 28 | ++ | + + | +
| 29 | +3x | +
+ if (!is.null(car_anova[["error"]])) {
+ |
+
| 30 | +1x | +
+ cli::cli_abort(+ |
+
| 31 | +1x | +
+ c(+ |
+
| 32 | +1x | +
+ "There was an error running {.fun car::Anova}. See error message below.",
+ |
+
| 33 | +1x | +
+ x = car_anova[["error"]]+ |
+
| 34 | ++ |
+ ),+ |
+
| 35 | +1x | +
+ call = get_cli_abort_call()+ |
+
| 36 | ++ |
+ )+ |
+
| 37 | ++ |
+ }+ |
+
| 38 | ++ | + + | +
| 39 | +2x | +
+ car_anova[["result"]] |>+ |
+
| 40 | +2x | +
+ broom.helpers::tidy_parameters(conf.int = FALSE) |> # using broom.helpers, because it handle non-syntactic names for us+ |
+
| 41 | +2x | +
+ dplyr::filter(!(dplyr::row_number() == dplyr::n() & .data$term %in% "Residuals")) |> # removing Residual rows+ |
+
| 42 | +2x | +
+ dplyr::rename(variable = "term") |>+ |
+
| 43 | +2x | +
+ tidyr::pivot_longer(+ |
+
| 44 | +2x | +
+ cols = -"variable",+ |
+
| 45 | +2x | +
+ names_to = "stat_name",+ |
+
| 46 | +2x | +
+ values_to = "stat"+ |
+
| 47 | ++ |
+ ) |>+ |
+
| 48 | +2x | +
+ dplyr::mutate(+ |
+
| 49 | +2x | +
+ stat = as.list(.data$stat),+ |
+
| 50 | +2x | +
+ stat_label =+ |
+
| 51 | +2x | +
+ dplyr::case_when(+ |
+
| 52 | +2x | +
+ .data$stat_name %in% "statistic" ~ "Statistic",+ |
+
| 53 | +2x | +
+ .data$stat_name %in% "df" ~ "Degrees of Freedom",+ |
+
| 54 | +2x | +
+ .data$stat_name %in% "p.value" ~ "p-value",+ |
+
| 55 | +2x | +
+ TRUE ~ .data$stat_name+ |
+
| 56 | ++ |
+ ),+ |
+
| 57 | +2x | +
+ fmt_fn =+ |
+
| 58 | +2x | +
+ map(+ |
+
| 59 | +2x | +
+ .data$stat,+ |
+
| 60 | +2x | +
+ function(.x) {
+ |
+
| 61 | ++ |
+ # styler: off+ |
+
| 62 | +! | +
+ if (is.integer(.x)) return(0L)+ |
+
| 63 | +12x | +
+ if (is.numeric(.x)) return(1L)+ |
+
| 64 | ++ |
+ # styler: on+ |
+
| 65 | +! | +
+ NULL+ |
+
| 66 | ++ |
+ }+ |
+
| 67 | ++ |
+ ),+ |
+
| 68 | +2x | +
+ context = "car_anova",+ |
+
| 69 | +2x | +
+ warning = car_anova["warning"],+ |
+
| 70 | +2x | +
+ error = car_anova["error"]+ |
+
| 71 | ++ |
+ ) |>+ |
+
| 72 | +2x | +
+ cards::as_card() |>+ |
+
| 73 | +2x | +
+ cards::tidy_ard_column_order()+ |
+
| 74 | ++ |
+ }+ |
+
| 1 | ++ |
+ #' ARD survey categorical CIs+ |
+
| 2 | ++ |
+ #'+ |
+
| 3 | ++ |
+ #' Confidence intervals for categorical variables calculated via+ |
+
| 4 | ++ |
+ #' [`survey::svyciprop()`].+ |
+
| 5 | ++ |
+ #'+ |
+
| 6 | ++ |
+ #' @inheritParams ard_continuous.survey.design+ |
+
| 7 | ++ |
+ #' @inheritParams ard_categorical_ci.data.frame+ |
+
| 8 | ++ |
+ #' @param method (`string`)\cr+ |
+
| 9 | ++ |
+ #' Method passed to `survey::svyciprop(method)`+ |
+
| 10 | ++ |
+ #' @param df (`numeric`)\cr+ |
+
| 11 | ++ |
+ #' denominator degrees of freedom, passed to `survey::svyciprop(df)`.+ |
+
| 12 | ++ |
+ #' Default is `survey::degf(data)`.+ |
+
| 13 | ++ |
+ #' @param ... arguments passed to `survey::svyciprop()`+ |
+
| 14 | ++ |
+ #'+ |
+
| 15 | ++ |
+ #' @return ARD data frame+ |
+
| 16 | ++ |
+ #' @export+ |
+
| 17 | ++ |
+ #'+ |
+
| 18 | ++ |
+ #' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = "survey", reference_pkg = "cardx"))
+ |
+
| 19 | ++ |
+ #' data(api, package = "survey")+ |
+
| 20 | ++ |
+ #' dclus1 <- survey::svydesign(id = ~dnum, weights = ~pw, data = apiclus1, fpc = ~fpc)+ |
+
| 21 | ++ |
+ #'+ |
+
| 22 | ++ |
+ #' ard_categorical_ci(dclus1, variables = sch.wide)+ |
+
| 23 | ++ |
+ #' ard_categorical_ci(dclus1, variables = sch.wide, value = sch.wide ~ "Yes", method = "xlogit")+ |
+
| 24 | ++ |
+ ard_categorical_ci.survey.design <- function(data,+ |
+
| 25 | ++ |
+ variables,+ |
+
| 26 | ++ |
+ by = NULL,+ |
+
| 27 | ++ |
+ method = c("logit", "likelihood", "asin", "beta", "mean", "xlogit"),
+ |
+
| 28 | ++ |
+ conf.level = 0.95,+ |
+
| 29 | ++ |
+ value = list(where(is_binary) ~ 1L, where(is.logical) ~ TRUE),+ |
+
| 30 | ++ |
+ df = survey::degf(data),+ |
+
| 31 | ++ |
+ ...) {
+ |
+
| 32 | +13x | +
+ set_cli_abort_call()+ |
+
| 33 | +13x | +
+ check_dots_empty()+ |
+
| 34 | ++ | + + | +
| 35 | ++ |
+ # check inputs ---------------------------------------------------------------+ |
+
| 36 | +13x | +
+ check_not_missing(data)+ |
+
| 37 | +13x | +
+ check_class(data, "survey.design")+ |
+
| 38 | +13x | +
+ check_not_missing(variables)+ |
+
| 39 | ++ | + + | +
| 40 | +13x | +
+ cards::process_selectors(+ |
+
| 41 | +13x | +
+ data = data$variables,+ |
+
| 42 | +13x | +
+ variables = {{ variables }},
+ |
+
| 43 | +13x | +
+ by = {{ by }}
+ |
+
| 44 | ++ |
+ )+ |
+
| 45 | +13x | +
+ cards::process_formula_selectors(+ |
+
| 46 | +13x | +
+ data = data$variables,+ |
+
| 47 | +13x | +
+ value = value+ |
+
| 48 | ++ |
+ )+ |
+
| 49 | +13x | +
+ check_scalar(by, allow_empty = TRUE)+ |
+
| 50 | +13x | +
+ check_scalar_range(conf.level, range = c(0, 1))+ |
+
| 51 | +13x | +
+ method <- arg_match(method)+ |
+
| 52 | ++ | + + | +
| 53 | ++ |
+ # return empty ARD if no variables selected ----------------------------------+ |
+
| 54 | +13x | +
+ if (is_empty(variables)) {
+ |
+
| 55 | +1x | +
+ return(dplyr::tibble() |> cards::as_card())+ |
+
| 56 | ++ |
+ }+ |
+
| 57 | ++ | + + | +
| 58 | ++ |
+ # calculate and return ARD of one sample CI ----------------------------------+ |
+
| 59 | +12x | +
+ .calculate_ard_onesample_survey_ci(+ |
+
| 60 | +12x | +
+ FUN = .svyciprop_wrapper,+ |
+
| 61 | +12x | +
+ data = data,+ |
+
| 62 | +12x | +
+ variables = variables,+ |
+
| 63 | +12x | +
+ by = by,+ |
+
| 64 | +12x | +
+ conf.level = conf.level,+ |
+
| 65 | +12x | +
+ method = method,+ |
+
| 66 | +12x | +
+ df = df,+ |
+
| 67 | +12x | +
+ value = value,+ |
+
| 68 | ++ |
+ ...+ |
+
| 69 | ++ |
+ )+ |
+
| 70 | ++ |
+ }+ |
+
| 71 | ++ | + + | +
| 72 | ++ |
+ .calculate_ard_onesample_survey_ci <- function(FUN, data, variables, by, conf.level, value, ...) {
+ |
+
| 73 | ++ |
+ # calculate results ----------------------------------------------------------+ |
+
| 74 | +12x | +
+ map(+ |
+
| 75 | +12x | +
+ variables,+ |
+
| 76 | +12x | +
+ function(variable) {
+ |
+
| 77 | +20x | +
+ .calculate_one_ard_categorical_survey_ci(+ |
+
| 78 | +20x | +
+ FUN = FUN,+ |
+
| 79 | +20x | +
+ data = data,+ |
+
| 80 | +20x | +
+ variable = variable,+ |
+
| 81 | +20x | +
+ by = by,+ |
+
| 82 | +20x | +
+ conf.level = conf.level,+ |
+
| 83 | +20x | +
+ value = value[[variable]],+ |
+
| 84 | ++ |
+ ...+ |
+
| 85 | ++ |
+ )+ |
+
| 86 | ++ |
+ }+ |
+
| 87 | ++ |
+ ) |>+ |
+
| 88 | +12x | +
+ dplyr::bind_rows()+ |
+
| 89 | ++ |
+ }+ |
+
| 90 | ++ | + + | +
| 91 | ++ |
+ .calculate_one_ard_categorical_survey_ci <- function(FUN, data, variable, by, conf.level, value, ...) {
+ |
+
| 92 | +20x | +
+ variable_levels <- .unique_values_sort(data$variables, variable = variable)+ |
+
| 93 | +20x | +
+ if (!is_empty(by)) {
+ |
+
| 94 | +6x | +
+ by_levels <- .unique_values_sort(data$variables, variable = by)+ |
+
| 95 | +6x | +
+ lst_data <-+ |
+
| 96 | +6x | +
+ map(+ |
+
| 97 | +6x | +
+ by_levels,+ |
+
| 98 | +6x | +
+ ~ call2("subset", expr(data), expr(!!sym(by) == !!.x)) |> eval()
+ |
+
| 99 | ++ |
+ ) |>+ |
+
| 100 | +6x | +
+ set_names(as.character(by_levels))+ |
+
| 101 | ++ |
+ }+ |
+
| 102 | ++ | + + | +
| 103 | +20x | +
+ df_full <-+ |
+
| 104 | +20x | +
+ case_switch(+ |
+
| 105 | +20x | +
+ !is_empty(by) ~+ |
+
| 106 | +20x | +
+ tidyr::expand_grid(+ |
+
| 107 | +20x | +
+ group1_level = as.character(by_levels) |> as.list(),+ |
+
| 108 | +20x | +
+ variable_level = as.character(variable_levels) |> as.list()+ |
+
| 109 | ++ |
+ ) |>+ |
+
| 110 | +20x | +
+ dplyr::mutate(group1 = .env$by, variable = .env$variable),+ |
+
| 111 | +20x | +
+ .default =+ |
+
| 112 | +20x | +
+ dplyr::tibble(+ |
+
| 113 | +20x | +
+ variable = .env$variable,+ |
+
| 114 | +20x | +
+ variable_level = as.character(variable_levels) |> as.list()+ |
+
| 115 | ++ |
+ )+ |
+
| 116 | ++ |
+ ) |>+ |
+
| 117 | +20x | +
+ dplyr::rowwise() |>+ |
+
| 118 | +20x | +
+ dplyr::mutate(+ |
+
| 119 | +20x | +
+ lst_result =+ |
+
| 120 | +20x | +
+ FUN(+ |
+
| 121 | +20x | +
+ data =+ |
+
| 122 | +20x | +
+ case_switch(+ |
+
| 123 | +20x | +
+ is_empty(.env$by) ~ data,+ |
+
| 124 | +20x | +
+ .default = lst_data[[.data$group1_level]]+ |
+
| 125 | ++ |
+ ),+ |
+
| 126 | +20x | +
+ variable = .data$variable,+ |
+
| 127 | +20x | +
+ variable_level = .data$variable_level,+ |
+
| 128 | +20x | +
+ conf.level = .env$conf.level,+ |
+
| 129 | ++ |
+ ...+ |
+
| 130 | ++ |
+ ) |>+ |
+
| 131 | +20x | +
+ list(),+ |
+
| 132 | +20x | +
+ result =+ |
+
| 133 | +20x | +
+ .data$lst_result[["result"]] |>+ |
+
| 134 | +20x | +
+ enframe("stat_name", "stat") |>
+ |
+
| 135 | +20x | +
+ list(),+ |
+
| 136 | +20x | +
+ warning = .data$lst_result["warning"] |> unname(),+ |
+
| 137 | +20x | +
+ error = .data$lst_result["error"] |> unname(),+ |
+
| 138 | +20x | +
+ context = "categorical_ci"+ |
+
| 139 | ++ |
+ ) |>+ |
+
| 140 | +20x | +
+ dplyr::select(-"lst_result") |>+ |
+
| 141 | +20x | +
+ dplyr::ungroup() |>+ |
+
| 142 | +20x | +
+ tidyr::unnest("result") |>
+ |
+
| 143 | +20x | +
+ dplyr::mutate(+ |
+
| 144 | +20x | +
+ stat_label = .data$stat_name,+ |
+
| 145 | +20x | +
+ fmt_fn = map(.data$stat, ~ case_switch(is.numeric(.x) ~ 2L, .default = as.character))+ |
+
| 146 | ++ |
+ ) |>+ |
+
| 147 | +20x | +
+ cards::as_card() |>+ |
+
| 148 | +20x | +
+ cards::tidy_ard_column_order()+ |
+
| 149 | ++ | + + | +
| 150 | ++ |
+ # if a value was passed for the variable, subset on those results+ |
+
| 151 | +20x | +
+ if (!is_empty(value)) {
+ |
+
| 152 | +! | +
+ df_full <- df_full |>+ |
+
| 153 | +! | +
+ dplyr::filter(.data$variable_level %in% .env$value)+ |
+
| 154 | ++ |
+ }+ |
+
| 155 | ++ | + + | +
| 156 | +20x | +
+ df_full+ |
+
| 157 | ++ |
+ }+ |
+
| 158 | ++ | + + | +
| 159 | ++ | + + | +
| 160 | ++ |
+ .svyciprop_wrapper <- function(data, variable, variable_level, conf.level, method, df, ...) {
+ |
+
| 161 | +52x | +
+ lst_results <-+ |
+
| 162 | +52x | +
+ cards::eval_capture_conditions(+ |
+
| 163 | +52x | +
+ survey::svyciprop(+ |
+
| 164 | +52x | +
+ formula = inject(~ I(!!sym(variable) == !!variable_level)),+ |
+
| 165 | +52x | +
+ design = data,+ |
+
| 166 | +52x | +
+ method = method,+ |
+
| 167 | +52x | +
+ level = conf.level,+ |
+
| 168 | +52x | +
+ df = df,+ |
+
| 169 | ++ |
+ ...+ |
+
| 170 | ++ |
+ ) %>%+ |
+
| 171 | +52x | +
+ {list(.[[1]], attr(., "ci"))} |> # styler: off
+ |
+
| 172 | +52x | +
+ unlist() |>+ |
+
| 173 | +52x | +
+ set_names(c("estimate", "conf.low", "conf.high")) |>
+ |
+
| 174 | +52x | +
+ as.list()+ |
+
| 175 | ++ |
+ )+ |
+
| 176 | ++ | + + | +
| 177 | ++ |
+ # add NULL results if error+ |
+
| 178 | +52x | +
+ if (is_empty(lst_results[["result"]])) {
+ |
+
| 179 | +! | +
+ lst_results[["result"]] <- rep_named(c("estimate", "conf.low", "conf.high"), list(NULL))
+ |
+
| 180 | ++ |
+ }+ |
+
| 181 | ++ | + + | +
| 182 | ++ |
+ # add other args+ |
+
| 183 | +52x | +
+ lst_results[["result"]] <- lst_results[["result"]] |> append(list(method = method, conf.level = conf.level))+ |
+
| 184 | ++ | + + | +
| 185 | ++ |
+ # return list result+ |
+
| 186 | +52x | +
+ lst_results+ |
+
| 187 | ++ |
+ }+ |
+
| 188 | ++ | + + | +
| 189 | ++ | + + | +
| 190 | ++ |
+ case_switch <- function(..., .default = NULL) {
+ |
+
| 191 | +718x | +
+ dots <- dots_list(...)+ |
+
| 192 | ++ | + + | +
| 193 | +718x | +
+ for (f in dots) {
+ |
+
| 194 | +945x | +
+ if (isTRUE(eval(f_lhs(f), envir = attr(f, ".Environment")))) {
+ |
+
| 195 | +581x | +
+ return(eval(f_rhs(f), envir = attr(f, ".Environment")))+ |
+
| 196 | ++ |
+ }+ |
+
| 197 | ++ |
+ }+ |
+
| 198 | ++ | + + | +
| 199 | +137x | +
+ return(.default)+ |
+
| 200 | ++ |
+ }+ |
+
| 1 | ++ |
+ #' ARD Standardized Mean Difference+ |
+
| 2 | ++ |
+ #'+ |
+
| 3 | ++ |
+ #' @description+ |
+
| 4 | ++ |
+ #' Standardized mean difference calculated via [`smd::smd()`] with `na.rm = TRUE`.+ |
+
| 5 | ++ |
+ #' Additionally, this function add a confidence interval to the SMD when+ |
+
| 6 | ++ |
+ #' `std.error=TRUE`, which the original `smd::smd()` does not include.+ |
+
| 7 | ++ |
+ #'+ |
+
| 8 | ++ |
+ #' @param data (`data.frame`/`survey.design`)\cr+ |
+
| 9 | ++ |
+ #' a data frame or object of class 'survey.design'+ |
+
| 10 | ++ |
+ #' (typically created with [`survey::svydesign()`]).+ |
+
| 11 | ++ |
+ #' @param by ([`tidy-select`][dplyr::dplyr_tidy_select])\cr+ |
+
| 12 | ++ |
+ #' column name to compare by.+ |
+
| 13 | ++ |
+ #' @param variables ([`tidy-select`][dplyr::dplyr_tidy_select])\cr+ |
+
| 14 | ++ |
+ #' column names to be compared. Independent tests will be computed for+ |
+
| 15 | ++ |
+ #' each variable.+ |
+
| 16 | ++ |
+ #' @param conf.level (scalar `numeric`)\cr+ |
+
| 17 | ++ |
+ #' confidence level for confidence interval. Default is `0.95`.+ |
+
| 18 | ++ |
+ #' @param std.error (scalar `logical`)\cr+ |
+
| 19 | ++ |
+ #' Logical indicator for computing standard errors using `smd::compute_smd_var()`.+ |
+
| 20 | ++ |
+ #' Default is `TRUE`.+ |
+
| 21 | ++ |
+ #' @param ... arguments passed to `smd::smd()`+ |
+
| 22 | ++ |
+ #'+ |
+
| 23 | ++ |
+ #' @return ARD data frame+ |
+
| 24 | ++ |
+ #' @export+ |
+
| 25 | ++ |
+ #'+ |
+
| 26 | ++ |
+ #' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = "smd", reference_pkg = "cardx"))
+ |
+
| 27 | ++ |
+ #' ard_smd_smd(cards::ADSL, by = SEX, variables = AGE)+ |
+
| 28 | ++ |
+ #' ard_smd_smd(cards::ADSL, by = SEX, variables = AGEGR1)+ |
+
| 29 | ++ |
+ ard_smd_smd <- function(data, by, variables, std.error = TRUE, conf.level = 0.95, ...) {
+ |
+
| 30 | +6x | +
+ set_cli_abort_call()+ |
+
| 31 | ++ | + + | +
| 32 | ++ |
+ # check installed packages ---------------------------------------------------+ |
+
| 33 | +6x | +
+ check_pkg_installed("smd", reference_pkg = "cardx")
+ |
+
| 34 | ++ | + + | +
| 35 | ++ |
+ # check/process inputs -------------------------------------------------------+ |
+
| 36 | +6x | +
+ check_not_missing(data)+ |
+
| 37 | +6x | +
+ check_not_missing(variables)+ |
+
| 38 | +6x | +
+ check_not_missing(by)+ |
+
| 39 | ++ | + + | +
| 40 | ++ |
+ # grab design object if from `survey` ----------------------------------------+ |
+
| 41 | +6x | +
+ is_survey <- inherits(data, "survey.design")+ |
+
| 42 | +6x | +
+ if (is_survey) {
+ |
+
| 43 | +1x | +
+ design <- data+ |
+
| 44 | +1x | +
+ data <- design$variables+ |
+
| 45 | ++ |
+ }+ |
+
| 46 | ++ | + + | +
| 47 | ++ |
+ # continue check/process inputs ----------------------------------------------+ |
+
| 48 | +6x | +
+ check_data_frame(data)+ |
+
| 49 | +6x | +
+ data <- dplyr::ungroup(data)+ |
+
| 50 | +6x | +
+ cards::process_selectors(data, by = {{ by }}, variables = {{ variables }})
+ |
+
| 51 | +6x | +
+ check_scalar(by)+ |
+
| 52 | ++ |
+ # This check can be relaxed, but would require some changes to handle multi-row outputs+ |
+
| 53 | +6x | +
+ check_n_levels(data[[by]], 2L, message = "The {.arg by} column must have {.val {length}} levels.")
+ |
+
| 54 | ++ | + + | +
| 55 | ++ |
+ # return empty ARD if no variables selected ----------------------------------+ |
+
| 56 | +6x | +
+ if (is_empty(variables)) {
+ |
+
| 57 | +! | +
+ return(dplyr::tibble() |> cards::as_card())+ |
+
| 58 | ++ |
+ }+ |
+
| 59 | ++ | + + | +
| 60 | ++ |
+ # build ARD ------------------------------------------------------------------+ |
+
| 61 | +6x | +
+ lapply(+ |
+
| 62 | +6x | +
+ variables,+ |
+
| 63 | +6x | +
+ function(variable) {
+ |
+
| 64 | +7x | +
+ .format_smd_results(+ |
+
| 65 | +7x | +
+ by = by,+ |
+
| 66 | +7x | +
+ variable = variable,+ |
+
| 67 | +7x | +
+ lst_tidy =+ |
+
| 68 | +7x | +
+ cards::eval_capture_conditions(+ |
+
| 69 | +7x | +
+ switch(as.character(is_survey),+ |
+
| 70 | +7x | +
+ "TRUE" = smd::smd(x = data[[variable]], g = data[[by]], w = stats::weights(design), na.rm = TRUE, std.error = std.error, ...),+ |
+
| 71 | +7x | +
+ "FALSE" = smd::smd(x = data[[variable]], g = data[[by]], na.rm = TRUE, std.error = std.error, ...)+ |
+
| 72 | ++ |
+ ) |>+ |
+
| 73 | +7x | +
+ dplyr::select(-any_of("term")) %>%
+ |
+
| 74 | ++ |
+ # styler: off+ |
+
| 75 | +6x | +
+ {if (isTRUE(std.error))
+ |
+
| 76 | +6x | +
+ dplyr::mutate(+ |
+
| 77 | ++ |
+ .,+ |
+
| 78 | +6x | +
+ conf.low = .data$estimate + stats::qnorm((1 - .env$conf.level) / 2) * .data$std.error,+ |
+
| 79 | +6x | +
+ conf.high = .data$estimate - stats::qnorm((1 - .env$conf.level) / 2) * .data$std.error,+ |
+
| 80 | +6x | +
+ method = "Standardized Mean Difference"+ |
+
| 81 | ++ |
+ )+ |
+
| 82 | ++ |
+ else+ |
+
| 83 | +! | +
+ dplyr::mutate(+ |
+
| 84 | ++ |
+ .,+ |
+
| 85 | +! | +
+ method = "Standardized Mean Difference"+ |
+
| 86 | ++ |
+ )}+ |
+
| 87 | ++ |
+ # styler: on+ |
+
| 88 | ++ |
+ ),+ |
+
| 89 | ++ |
+ ...+ |
+
| 90 | ++ |
+ )+ |
+
| 91 | ++ |
+ }+ |
+
| 92 | ++ |
+ ) |>+ |
+
| 93 | +6x | +
+ dplyr::bind_rows()+ |
+
| 94 | ++ |
+ }+ |
+
| 95 | ++ | + + | +
| 96 | ++ | + + | +
| 97 | ++ |
+ .format_smd_results <- function(by, variable, lst_tidy, ...) {
+ |
+
| 98 | ++ |
+ # build ARD ------------------------------------------------------------------+ |
+
| 99 | +7x | +
+ ret <-+ |
+
| 100 | +7x | +
+ cards::tidy_as_ard(+ |
+
| 101 | +7x | +
+ lst_tidy = lst_tidy,+ |
+
| 102 | +7x | +
+ tidy_result_names = c("estimate", "std.error"),
+ |
+
| 103 | +7x | +
+ fun_args_to_record = c("gref"),
+ |
+
| 104 | +7x | +
+ formals = formals(smd::smd)[c("gref")],
+ |
+
| 105 | ++ |
+ # removing the `std.error` ARGUMENT (not the result)+ |
+
| 106 | +7x | +
+ passed_args = dots_list(...) |> utils::modifyList(list(std.error = NULL)),+ |
+
| 107 | +7x | +
+ lst_ard_columns = list(group1 = by, variable = variable, context = "smd_smd")+ |
+
| 108 | ++ |
+ )+ |
+
| 109 | ++ | + + | +
| 110 | ++ |
+ # add the stat label ---------------------------------------------------------+ |
+
| 111 | +7x | +
+ ret |>+ |
+
| 112 | +7x | +
+ dplyr::left_join(+ |
+
| 113 | +7x | +
+ dplyr::tribble(+ |
+
| 114 | +7x | +
+ ~stat_name, ~stat_label,+ |
+
| 115 | +7x | +
+ "estimate", "Standardized Mean Difference",+ |
+
| 116 | +7x | +
+ "std.error", "Standard Error",+ |
+
| 117 | +7x | +
+ "gref", "Integer Reference Group Level"+ |
+
| 118 | ++ |
+ ),+ |
+
| 119 | +7x | +
+ by = "stat_name"+ |
+
| 120 | ++ |
+ ) |>+ |
+
| 121 | +7x | +
+ dplyr::mutate(stat_label = dplyr::coalesce(.data$stat_label, .data$stat_name)) |>+ |
+
| 122 | +7x | +
+ cards::as_card() |>+ |
+
| 123 | +7x | +
+ cards::tidy_ard_column_order()+ |
+
| 124 | ++ |
+ }+ |
+
| 1 | ++ |
+ #' ARD Survival Differences+ |
+
| 2 | ++ |
+ #'+ |
+
| 3 | ++ |
+ #' Calculate differences in the Kaplan-Meier estimator of survival using the+ |
+
| 4 | ++ |
+ #' results from [`survival::survfit()`].+ |
+
| 5 | ++ |
+ #'+ |
+
| 6 | ++ |
+ #' @param x (`survift`)\cr+ |
+
| 7 | ++ |
+ #' object of class `'survfit'` typically created with [`survival::survfit()`]+ |
+
| 8 | ++ |
+ #' @param conf.level (scalar `numeric`)\cr+ |
+
| 9 | ++ |
+ #' confidence level for confidence interval. Default is `0.95`.+ |
+
| 10 | ++ |
+ #' @inheritParams ard_survival_survfit+ |
+
| 11 | ++ |
+ #'+ |
+
| 12 | ++ |
+ #' @return an ARD data frame of class 'card'+ |
+
| 13 | ++ |
+ #' @export+ |
+
| 14 | ++ |
+ #'+ |
+
| 15 | ++ |
+ #' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = c("survival", "ggsurvfit"), reference_pkg = "cardx"))
+ |
+
| 16 | ++ |
+ #' library(ggsurvfit)+ |
+
| 17 | ++ |
+ #' library(survival)+ |
+
| 18 | ++ |
+ #'+ |
+
| 19 | ++ |
+ #' survfit(Surv_CNSR() ~ TRTA, data = cards::ADTTE) |>+ |
+
| 20 | ++ |
+ #' ard_survival_survfit_diff(times = c(25, 50))+ |
+
| 21 | ++ |
+ ard_survival_survfit_diff <- function(x, times, conf.level = 0.95) {
+ |
+
| 22 | +3x | +
+ set_cli_abort_call()+ |
+
| 23 | ++ | + + | +
| 24 | ++ |
+ # check installed packages ---------------------------------------------------+ |
+
| 25 | +3x | +
+ check_pkg_installed(c("survival", "broom"), reference_pkg = "cardx")
+ |
+
| 26 | +3x | +
+ check_not_missing(x)+ |
+
| 27 | +3x | +
+ check_not_missing(times)+ |
+
| 28 | +3x | +
+ check_class(x, "survfit")+ |
+
| 29 | ++ | + + | +
| 30 | +3x | +
+ if (inherits(x, c("survfitms", "survfitcox"))) {
+ |
+
| 31 | +! | +
+ cli::cli_abort(+ |
+
| 32 | +! | +
+ "Argument {.arg x} cannot be class {.cls {c('survfitms', 'survfitcox')}}.",
+ |
+
| 33 | +! | +
+ call = get_cli_abort_call()+ |
+
| 34 | ++ |
+ )+ |
+
| 35 | ++ |
+ }+ |
+
| 36 | +3x | +
+ check_scalar_range(conf.level, range = c(0, 1))+ |
+
| 37 | +3x | +
+ check_length(+ |
+
| 38 | +3x | +
+ as.list(x$call)[["formula"]] |> stats::as.formula() |> stats::terms() |> attr("term.labels"),
+ |
+
| 39 | +3x | +
+ length = 1L,+ |
+
| 40 | +3x | +
+ message = "The {.cls survfit} object passed in argument {.arg x} must be stratified by a single variable."
+ |
+
| 41 | ++ |
+ )+ |
+
| 42 | +2x | +
+ if (length(x$strata) < 2) {
+ |
+
| 43 | +! | +
+ cli::cli_abort(+ |
+
| 44 | +! | +
+ "The {.cls survfit} object's stratifying variable must have 2 or more levels.",
+ |
+
| 45 | +! | +
+ call = get_cli_abort_call()+ |
+
| 46 | ++ |
+ )+ |
+
| 47 | ++ |
+ }+ |
+
| 48 | ++ | + + | +
| 49 | ++ |
+ # calculate the survival at the specified times+ |
+
| 50 | +2x | +
+ ard_survival_survfit <-+ |
+
| 51 | +2x | +
+ ard_survival_survfit(x = x, times = times) |>+ |
+
| 52 | +2x | +
+ dplyr::filter(.data$stat_name %in% c("estimate", "std.error")) |>
+ |
+
| 53 | +2x | +
+ dplyr::select(-c("stat_label", "context", "fmt_fn"))
+ |
+
| 54 | ++ | + + | +
| 55 | ++ |
+ # transform the survival ARD into a cards object with the survival difference+ |
+
| 56 | +2x | +
+ card <-+ |
+
| 57 | +2x | +
+ ard_survival_survfit %>%+ |
+
| 58 | +2x | +
+ {dplyr::left_join( # styler: off
+ |
+
| 59 | ++ |
+ # remove the first group from the data frame (this is our reference group)+ |
+
| 60 | +2x | +
+ dplyr::filter(., .by = cards::all_ard_groups(), dplyr::cur_group_id() > 1L) |>+ |
+
| 61 | +2x | +
+ dplyr::rename(stat1 = "stat"),+ |
+
| 62 | ++ |
+ # merge the reference group data+ |
+
| 63 | +2x | +
+ dplyr::filter(., .by = cards::all_ard_groups(), dplyr::cur_group_id() == 1L) |>+ |
+
| 64 | +2x | +
+ dplyr::select(stat0 = "stat", everything(), -c("group1_level", "error", "warning")),
+ |
+
| 65 | +2x | +
+ by = c("group1", "variable", "variable_level", "stat_name")
+ |
+
| 66 | +2x | +
+ )} |> # styler: off+ |
+
| 67 | ++ |
+ # reshape to put the stats that need to be combined on the same row+ |
+
| 68 | +2x | +
+ tidyr::pivot_wider(+ |
+
| 69 | +2x | +
+ id_cols = c("group1", "group1_level", "variable", "variable_level"),
+ |
+
| 70 | +2x | +
+ names_from = "stat_name",+ |
+
| 71 | +2x | +
+ values_from = c("stat0", "stat1"),
+ |
+
| 72 | +2x | +
+ values_fn = unlist+ |
+
| 73 | ++ |
+ ) |>+ |
+
| 74 | ++ |
+ # calcualte the primary statistics to return+ |
+
| 75 | +2x | +
+ dplyr::mutate(+ |
+
| 76 | ++ |
+ # reference level+ |
+
| 77 | +2x | +
+ reference_level = ard_survival_survfit[["group1_level"]][1],+ |
+
| 78 | ++ |
+ # short description of method+ |
+
| 79 | +2x | +
+ method = "Survival Difference (Z-test)",+ |
+
| 80 | ++ |
+ # survival difference+ |
+
| 81 | +2x | +
+ estimate = .data$stat0_estimate - .data$stat1_estimate,+ |
+
| 82 | ++ |
+ # survival difference standard error+ |
+
| 83 | +2x | +
+ std.error = sqrt(.data$stat0_std.error^2 + .data$stat1_std.error^2),+ |
+
| 84 | ++ |
+ # Z test statistic+ |
+
| 85 | +2x | +
+ statistic = .data$estimate / .data$std.error,+ |
+
| 86 | ++ |
+ # confidence limits of the survival difference+ |
+
| 87 | +2x | +
+ conf.low = .data$estimate - .data$std.error * stats::qnorm(1 - (1 - .env$conf.level) / 2),+ |
+
| 88 | +2x | +
+ conf.high = .data$estimate + .data$std.error * stats::qnorm(1 - (1 - .env$conf.level) / 2),+ |
+
| 89 | ++ |
+ # p-value for test where H0: no difference+ |
+
| 90 | +2x | +
+ p.value = 2 * (1 - stats::pnorm(abs(.data$statistic))),+ |
+
| 91 | +2x | +
+ across(c("reference_level", "estimate", "std.error", "statistic", "conf.low", "conf.high", "p.value", "method"), as.list)
+ |
+
| 92 | ++ |
+ ) |>+ |
+
| 93 | ++ |
+ # reshape into the cards structure+ |
+
| 94 | +2x | +
+ dplyr::select(-starts_with("stat0_"), -starts_with("stat1_")) |>
+ |
+
| 95 | +2x | +
+ tidyr::pivot_longer(+ |
+
| 96 | +2x | +
+ cols = -c(cards::all_ard_groups(), cards::all_ard_variables()),+ |
+
| 97 | +2x | +
+ names_to = "stat_name",+ |
+
| 98 | +2x | +
+ values_to = "stat"+ |
+
| 99 | ++ |
+ )+ |
+
| 100 | ++ | + + | +
| 101 | ++ |
+ # final prepping of the cards object -----------------------------------------+ |
+
| 102 | +2x | +
+ card |>+ |
+
| 103 | +2x | +
+ dplyr::mutate(+ |
+
| 104 | +2x | +
+ warning = ard_survival_survfit[["warning"]][1],+ |
+
| 105 | +2x | +
+ error = ard_survival_survfit[["error"]][1],+ |
+
| 106 | +2x | +
+ fmt_fn = list(1L),+ |
+
| 107 | +2x | +
+ stat_label =+ |
+
| 108 | +2x | +
+ dplyr::case_when(+ |
+
| 109 | +2x | +
+ .data$stat_name %in% "estimate" ~ "Survival Difference",+ |
+
| 110 | +2x | +
+ .data$stat_name %in% "std.error" ~ "Survival Difference Standard Error",+ |
+
| 111 | +2x | +
+ .data$stat_name %in% "conf.low" ~ "CI Lower Bound",+ |
+
| 112 | +2x | +
+ .data$stat_name %in% "conf.high" ~ "CI Upper Bound",+ |
+
| 113 | +2x | +
+ .data$stat_name %in% "statistic" ~ "z statistic",+ |
+
| 114 | +2x | +
+ .data$stat_name %in% "p.value" ~ "p-value",+ |
+
| 115 | +2x | +
+ .default = .data$stat_name+ |
+
| 116 | ++ |
+ ),+ |
+
| 117 | +2x | +
+ context = "survival_survfit_diff",+ |
+
| 118 | ++ |
+ ) |>+ |
+
| 119 | +2x | +
+ cards::as_card() |>+ |
+
| 120 | +2x | +
+ cards::tidy_ard_column_order()+ |
+
| 121 | ++ |
+ }+ |
+
| 1 | ++ |
+ #' ARD Chi-squared Test+ |
+
| 2 | ++ |
+ #'+ |
+
| 3 | ++ |
+ #' @description+ |
+
| 4 | ++ |
+ #' Analysis results data for Pearson's Chi-squared Test.+ |
+
| 5 | ++ |
+ #' Calculated with `chisq.test(x = data[[variable]], y = data[[by]], ...)`+ |
+
| 6 | ++ |
+ #'+ |
+
| 7 | ++ |
+ #'+ |
+
| 8 | ++ |
+ #' @param data (`data.frame`)\cr+ |
+
| 9 | ++ |
+ #' a data frame.+ |
+
| 10 | ++ |
+ #' @param by ([`tidy-select`][dplyr::dplyr_tidy_select])\cr+ |
+
| 11 | ++ |
+ #' column name to compare by.+ |
+
| 12 | ++ |
+ #' @param variables ([`tidy-select`][dplyr::dplyr_tidy_select])\cr+ |
+
| 13 | ++ |
+ #' column names to be compared. Independent tests will be computed for+ |
+
| 14 | ++ |
+ #' each variable.+ |
+
| 15 | ++ |
+ #' @param ... additional arguments passed to `chisq.test(...)`+ |
+
| 16 | ++ |
+ #'+ |
+
| 17 | ++ |
+ #' @return ARD data frame+ |
+
| 18 | ++ |
+ #' @export+ |
+
| 19 | ++ |
+ #'+ |
+
| 20 | ++ |
+ #' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = "broom", reference_pkg = "cardx"))
+ |
+
| 21 | ++ |
+ #' cards::ADSL |>+ |
+
| 22 | ++ |
+ #' ard_stats_chisq_test(by = "ARM", variables = "AGEGR1")+ |
+
| 23 | ++ |
+ ard_stats_chisq_test <- function(data, by, variables, ...) {
+ |
+
| 24 | +4x | +
+ set_cli_abort_call()+ |
+
| 25 | ++ | + + | +
| 26 | ++ |
+ # check installed packages ---------------------------------------------------+ |
+
| 27 | +4x | +
+ check_pkg_installed("broom", reference_pkg = "cardx")
+ |
+
| 28 | ++ | + + | +
| 29 | ++ |
+ # check/process inputs -------------------------------------------------------+ |
+
| 30 | +4x | +
+ check_not_missing(data)+ |
+
| 31 | +4x | +
+ check_not_missing(variables)+ |
+
| 32 | +4x | +
+ check_not_missing(by)+ |
+
| 33 | +4x | +
+ check_data_frame(data)+ |
+
| 34 | +4x | +
+ cards::process_selectors(data, by = {{ by }}, variables = {{ variables }})
+ |
+
| 35 | +4x | +
+ check_scalar(by)+ |
+
| 36 | ++ | + + | +
| 37 | ++ |
+ # return empty ARD if no variables selected ----------------------------------+ |
+
| 38 | +4x | +
+ if (is_empty(variables)) {
+ |
+
| 39 | +! | +
+ return(dplyr::tibble() |> cards::as_card())+ |
+
| 40 | ++ |
+ }+ |
+
| 41 | ++ | + + | +
| 42 | ++ |
+ # build ARD ------------------------------------------------------------------+ |
+
| 43 | +4x | +
+ lapply(+ |
+
| 44 | +4x | +
+ variables,+ |
+
| 45 | +4x | +
+ function(variable) {
+ |
+
| 46 | +5x | +
+ cards::tidy_as_ard(+ |
+
| 47 | +5x | +
+ lst_tidy =+ |
+
| 48 | +5x | +
+ cards::eval_capture_conditions(+ |
+
| 49 | +5x | +
+ stats::chisq.test(x = data[[variable]], y = data[[by]], ...) |>+ |
+
| 50 | +5x | +
+ broom::tidy()+ |
+
| 51 | ++ |
+ ),+ |
+
| 52 | +5x | +
+ tidy_result_names = c("statistic", "p.value", "parameter", "method"),
+ |
+
| 53 | +5x | +
+ fun_args_to_record =+ |
+
| 54 | +5x | +
+ c("correct", "p", "rescale.p", "simulate.p.value", "B"),
+ |
+
| 55 | +5x | +
+ formals = formals(stats::chisq.test),+ |
+
| 56 | +5x | +
+ passed_args = dots_list(...),+ |
+
| 57 | +5x | +
+ lst_ard_columns = list(group1 = by, variable = variable, context = "stats_chisq_test")+ |
+
| 58 | ++ |
+ ) |>+ |
+
| 59 | +5x | +
+ dplyr::mutate(+ |
+
| 60 | +5x | +
+ .after = "stat_name",+ |
+
| 61 | +5x | +
+ stat_label =+ |
+
| 62 | +5x | +
+ dplyr::case_when(+ |
+
| 63 | +5x | +
+ .data$stat_name %in% "statistic" ~ "X-squared Statistic",+ |
+
| 64 | +5x | +
+ .data$stat_name %in% "p.value" ~ "p-value",+ |
+
| 65 | +5x | +
+ .data$stat_name %in% "parameter" ~ "Degrees of Freedom",+ |
+
| 66 | +5x | +
+ TRUE ~ .data$stat_name,+ |
+
| 67 | ++ |
+ )+ |
+
| 68 | ++ |
+ )+ |
+
| 69 | ++ |
+ }+ |
+
| 70 | ++ |
+ ) |>+ |
+
| 71 | +4x | +
+ dplyr::bind_rows() |>+ |
+
| 72 | +4x | +
+ cards::as_card()+ |
+
| 73 | ++ |
+ }+ |
+
| 1 | ++ |
+ #' ARD one-sample t-test+ |
+
| 2 | ++ |
+ #'+ |
+
| 3 | ++ |
+ #' @description+ |
+
| 4 | ++ |
+ #' Analysis results data for one-sample t-tests.+ |
+
| 5 | ++ |
+ #' Result may be stratified by including the `by` argument.+ |
+
| 6 | ++ |
+ #'+ |
+
| 7 | ++ |
+ #' @param data (`data.frame`)\cr+ |
+
| 8 | ++ |
+ #' a data frame. See below for details.+ |
+
| 9 | ++ |
+ #' @param variables ([`tidy-select`][dplyr::dplyr_tidy_select])\cr+ |
+
| 10 | ++ |
+ #' column names to be analyzed. Independent t-tests will be computed for+ |
+
| 11 | ++ |
+ #' each variable.+ |
+
| 12 | ++ |
+ #' @param by ([`tidy-select`][dplyr::dplyr_tidy_select])\cr+ |
+
| 13 | ++ |
+ #' optional column name to stratify results by.+ |
+
| 14 | ++ |
+ #' @inheritParams ard_stats_t_test+ |
+
| 15 | ++ |
+ #'+ |
+
| 16 | ++ |
+ #' @return ARD data frame+ |
+
| 17 | ++ |
+ #' @export+ |
+
| 18 | ++ |
+ #'+ |
+
| 19 | ++ |
+ #' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = "broom", reference_pkg = "cardx"))
+ |
+
| 20 | ++ |
+ #' cards::ADSL |>+ |
+
| 21 | ++ |
+ #' ard_stats_t_test_onesample(by = ARM, variables = AGE)+ |
+
| 22 | ++ |
+ ard_stats_t_test_onesample <- function(data, variables, by = dplyr::group_vars(data), conf.level = 0.95, ...) {
+ |
+
| 23 | +5x | +
+ set_cli_abort_call()+ |
+
| 24 | ++ | + + | +
| 25 | ++ |
+ # check installed packages ---------------------------------------------------+ |
+
| 26 | +5x | +
+ check_pkg_installed("broom", reference_pkg = "cardx")
+ |
+
| 27 | ++ | + + | +
| 28 | ++ |
+ # check/process inputs -------------------------------------------------------+ |
+
| 29 | +5x | +
+ check_not_missing(data)+ |
+
| 30 | +5x | +
+ check_not_missing(variables)+ |
+
| 31 | +5x | +
+ check_data_frame(data)+ |
+
| 32 | +5x | +
+ data <- dplyr::ungroup(data)+ |
+
| 33 | +5x | +
+ cards::process_selectors(data, by = {{ by }}, variables = {{ variables }})
+ |
+
| 34 | +5x | +
+ check_scalar_range(conf.level, range = c(0, 1))+ |
+
| 35 | ++ | + + | +
| 36 | ++ |
+ # return empty ARD if no variables selected ----------------------------------+ |
+
| 37 | +5x | +
+ if (is_empty(variables)) {
+ |
+
| 38 | +1x | +
+ return(dplyr::tibble() |> cards::as_card())+ |
+
| 39 | ++ |
+ }+ |
+
| 40 | ++ | + + | +
| 41 | +4x | +
+ cards::ard_continuous(+ |
+
| 42 | +4x | +
+ data = data,+ |
+
| 43 | +4x | +
+ variables = all_of(variables),+ |
+
| 44 | +4x | +
+ by = all_of(by),+ |
+
| 45 | +4x | +
+ statistic = all_of(variables) ~ list(t_test_onesample = \(x) stats::t.test(x = x, conf.level = conf.level, ...) |> broom::tidy())+ |
+
| 46 | ++ |
+ ) |>+ |
+
| 47 | +4x | +
+ cards::bind_ard(+ |
+
| 48 | +4x | +
+ cards::ard_continuous(+ |
+
| 49 | +4x | +
+ data = data,+ |
+
| 50 | +4x | +
+ variables = all_of(variables),+ |
+
| 51 | +4x | +
+ by = all_of(by),+ |
+
| 52 | +4x | +
+ statistic =+ |
+
| 53 | +4x | +
+ all_of(variables) ~+ |
+
| 54 | +4x | +
+ list(conf.level = \(x) {
+ |
+
| 55 | +8x | +
+ formals(asNamespace("stats")[["t.test.default"]])["mu"] |>
+ |
+
| 56 | +8x | +
+ utils::modifyList(list(conf.level = conf.level, ...))+ |
+
| 57 | ++ |
+ })+ |
+
| 58 | ++ |
+ )+ |
+
| 59 | ++ |
+ ) |>+ |
+
| 60 | +4x | +
+ dplyr::select(-"stat_label") |>+ |
+
| 61 | +4x | +
+ dplyr::left_join(+ |
+
| 62 | +4x | +
+ .df_ttest_stat_labels(by = NULL),+ |
+
| 63 | +4x | +
+ by = "stat_name"+ |
+
| 64 | ++ |
+ ) |>+ |
+
| 65 | +4x | +
+ dplyr::mutate(+ |
+
| 66 | +4x | +
+ stat_label = dplyr::coalesce(.data$stat_label, .data$stat_name),+ |
+
| 67 | +4x | +
+ context = "stats_t_test_onesample",+ |
+
| 68 | ++ |
+ ) |>+ |
+
| 69 | +4x | +
+ cards::as_card() |>+ |
+
| 70 | +4x | +
+ cards::tidy_ard_column_order() |>+ |
+
| 71 | +4x | +
+ cards::tidy_ard_row_order()+ |
+
| 72 | ++ |
+ }+ |
+
| 1 | ++ |
+ #' ARD Wald Test+ |
+
| 2 | ++ |
+ #'+ |
+
| 3 | ++ |
+ #' @description+ |
+
| 4 | ++ |
+ #' Function takes a regression model object and calculates Wald+ |
+
| 5 | ++ |
+ #' statistical test using [`aod::wald.test()`].+ |
+
| 6 | ++ |
+ #'+ |
+
| 7 | ++ |
+ #' @param x regression model object+ |
+
| 8 | ++ |
+ #' @param ... arguments passed to `aod::wald.test(...)`+ |
+
| 9 | ++ |
+ #' @inheritParams ard_regression+ |
+
| 10 | ++ |
+ #'+ |
+
| 11 | ++ |
+ #' @return data frame+ |
+
| 12 | ++ |
+ #' @export+ |
+
| 13 | ++ |
+ #'+ |
+
| 14 | ++ |
+ #' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = "aod", reference_pkg = "cardx"))
+ |
+
| 15 | ++ |
+ #' lm(AGE ~ ARM, data = cards::ADSL) |>+ |
+
| 16 | ++ |
+ #' ard_aod_wald_test()+ |
+
| 17 | ++ |
+ ard_aod_wald_test <- function(x, tidy_fun = broom.helpers::tidy_with_broom_or_parameters, ...) {
+ |
+
| 18 | +2x | +
+ set_cli_abort_call()+ |
+
| 19 | +2x | +
+ check_pkg_installed("broom.helpers", reference_pkg = "cardx")
+ |
+
| 20 | ++ | + + | +
| 21 | ++ |
+ # check installed packages ---------------------------------------------------+ |
+
| 22 | +2x | +
+ check_pkg_installed("aod", reference_pkg = "cardx")
+ |
+
| 23 | ++ | + + | +
| 24 | ++ |
+ # check inputs ---------------------------------------------------------------+ |
+
| 25 | +2x | +
+ check_not_missing(x)+ |
+
| 26 | ++ | + + | +
| 27 | ++ |
+ # run regression() -----------------------------------------------------------+ |
+
| 28 | +2x | +
+ reg_model <- cards::eval_capture_conditions(+ |
+
| 29 | +2x | +
+ ard_regression_basic(x, tidy_fun = tidy_fun, intercept = TRUE, stats_to_remove = c(+ |
+
| 30 | +2x | +
+ "var_type",+ |
+
| 31 | +2x | +
+ "var_label",+ |
+
| 32 | +2x | +
+ "var_class", "label",+ |
+
| 33 | +2x | +
+ "contrasts_type", "contrasts", "var_nlevels", "std.error",+ |
+
| 34 | +2x | +
+ "conf.low", "conf.high", "statistic", "p.value", "estimate"+ |
+
| 35 | ++ |
+ ))+ |
+
| 36 | ++ |
+ )+ |
+
| 37 | ++ | + + | +
| 38 | +2x | +
+ if (!is.null(reg_model[["error"]])) {
+ |
+
| 39 | +! | +
+ cli::cli_abort(+ |
+
| 40 | +! | +
+ c("Unable to identify underlying variable names in regression model.",
+ |
+
| 41 | +! | +
+ i = "Is this model type supported by {.fun broom.helpers::tidy_plus_plus}, which is the function used to identify variable names?"
+ |
+
| 42 | ++ |
+ ),+ |
+
| 43 | +! | +
+ call = get_cli_abort_call()+ |
+
| 44 | ++ |
+ )+ |
+
| 45 | ++ |
+ }+ |
+
| 46 | +2x | +
+ aod <-+ |
+
| 47 | +2x | +
+ reg_model[["result"]] %>%+ |
+
| 48 | +2x | +
+ dplyr::select(c(+ |
+
| 49 | +2x | +
+ variable = "variable",+ |
+
| 50 | +2x | +
+ model_terms = "stat"+ |
+
| 51 | ++ |
+ )) %>%+ |
+
| 52 | +2x | +
+ dplyr::mutate(term_id = dplyr::row_number()) %>%+ |
+
| 53 | +2x | +
+ tidyr::nest(data = -"variable") %>%+ |
+
| 54 | +2x | +
+ dplyr::rowwise() %>%+ |
+
| 55 | +2x | +
+ dplyr::mutate(+ |
+
| 56 | +2x | +
+ model_terms = unlist(.data$data[["model_terms"]]) %>% list(),+ |
+
| 57 | +2x | +
+ model_terms_id = rlang::set_names(.data$data[["term_id"]]) %>% list()+ |
+
| 58 | ++ |
+ )+ |
+
| 59 | ++ |
+ # run wald.test() -----------------------------------------------------------+ |
+
| 60 | +2x | +
+ wald_test <-+ |
+
| 61 | +2x | +
+ cards::eval_capture_conditions(lapply(seq_len(length(aod$model_terms_id)), function(terms_id) {
+ |
+
| 62 | +4x | +
+ aod::wald.test(+ |
+
| 63 | +4x | +
+ Sigma = stats::vcov(x),+ |
+
| 64 | +4x | +
+ b = stats::coef(x), Terms = aod$model_terms_id[[terms_id]]+ |
+
| 65 | ++ |
+ )+ |
+
| 66 | ++ |
+ }))+ |
+
| 67 | ++ | + + | +
| 68 | ++ | + + | +
| 69 | +2x | +
+ df_list <- do.call(rbind, lapply(wald_test$result, .extract_wald_results))+ |
+
| 70 | ++ | + + | +
| 71 | +2x | +
+ cbind(aod$variable, df_list) %>%+ |
+
| 72 | +2x | +
+ tidyr::pivot_longer(+ |
+
| 73 | +2x | +
+ cols = !"aod$variable",+ |
+
| 74 | +2x | +
+ names_to = "stat_name",+ |
+
| 75 | +2x | +
+ values_to = "stat"+ |
+
| 76 | ++ |
+ ) %>%+ |
+
| 77 | +2x | +
+ dplyr::rename(+ |
+
| 78 | +2x | +
+ "variable" = "aod$variable"+ |
+
| 79 | ++ |
+ ) |>+ |
+
| 80 | +2x | +
+ dplyr::mutate(+ |
+
| 81 | +2x | +
+ stat = as.list(.data$stat),+ |
+
| 82 | +2x | +
+ stat_label =+ |
+
| 83 | +2x | +
+ dplyr::case_when(+ |
+
| 84 | +2x | +
+ .data$stat_name %in% "statistic" ~ "Statistic",+ |
+
| 85 | +2x | +
+ .data$stat_name %in% "df" ~ "Degrees of Freedom",+ |
+
| 86 | +2x | +
+ .data$stat_name %in% "p.value" ~ "p-value",+ |
+
| 87 | +2x | +
+ TRUE ~ .data$stat_name+ |
+
| 88 | ++ |
+ ),+ |
+
| 89 | +2x | +
+ fmt_fn =+ |
+
| 90 | +2x | +
+ map(+ |
+
| 91 | +2x | +
+ .data$stat,+ |
+
| 92 | +2x | +
+ function(.x) {
+ |
+
| 93 | ++ |
+ # styler: off+ |
+
| 94 | +! | +
+ if (is.integer(.x)) return(0L)+ |
+
| 95 | +12x | +
+ if (is.numeric(.x)) return(1L)+ |
+
| 96 | ++ |
+ # styler: on+ |
+
| 97 | +! | +
+ NULL+ |
+
| 98 | ++ |
+ }+ |
+
| 99 | ++ |
+ ),+ |
+
| 100 | +2x | +
+ context = "aod_wald_test",+ |
+
| 101 | +2x | +
+ warning = wald_test["warning"],+ |
+
| 102 | +2x | +
+ error = wald_test["error"]+ |
+
| 103 | ++ |
+ ) |>+ |
+
| 104 | +2x | +
+ cards::as_card() |>+ |
+
| 105 | +2x | +
+ cards::tidy_ard_column_order()+ |
+
| 106 | ++ |
+ }+ |
+
| 107 | ++ | + + | +
| 108 | ++ |
+ #' Extract data from wald.test object+ |
+
| 109 | ++ |
+ #'+ |
+
| 110 | ++ |
+ #' @param wald_test (`data.frame`)\cr wald test object object from `aod::wald.test()`+ |
+
| 111 | ++ |
+ #'+ |
+
| 112 | ++ |
+ #' @return a data frame containing the wald test results.+ |
+
| 113 | ++ |
+ #' @keywords internal+ |
+
| 114 | ++ |
+ .extract_wald_results <- function(wald_test) {
+ |
+
| 115 | +4x | +
+ df <- wald_test$result$chi2[("df")]
+ |
+
| 116 | +4x | +
+ statistic <- wald_test$result$chi2[("chi2")]
+ |
+
| 117 | +4x | +
+ p.value <- wald_test$result$chi2[("P")]
+ |
+
| 118 | +4x | +
+ data.frame(df, statistic, p.value)+ |
+
| 119 | ++ |
+ }+ |
+
| 1 | ++ |
+ #' ARD Survey t-test+ |
+
| 2 | ++ |
+ #'+ |
+
| 3 | ++ |
+ #' @description+ |
+
| 4 | ++ |
+ #' Analysis results data for survey t-test using [`survey::svyttest()`].+ |
+
| 5 | ++ |
+ #'+ |
+
| 6 | ++ |
+ #' @param data (`survey.design`)\cr+ |
+
| 7 | ++ |
+ #' a survey design object often created with [`survey::svydesign()`]+ |
+
| 8 | ++ |
+ #' @param by ([`tidy-select`][dplyr::dplyr_tidy_select])\cr+ |
+
| 9 | ++ |
+ #' column name to compare by+ |
+
| 10 | ++ |
+ #' @param variables ([`tidy-select`][dplyr::dplyr_tidy_select])\cr+ |
+
| 11 | ++ |
+ #' column names to be compared. Independent tests will be run for each variable.+ |
+
| 12 | ++ |
+ #' @param conf.level (`double`)\cr+ |
+
| 13 | ++ |
+ #' confidence level of the returned confidence interval. Must be between `c(0, 1)`.+ |
+
| 14 | ++ |
+ #' Default is `0.95`+ |
+
| 15 | ++ |
+ #' @param ... arguments passed to [`survey::svyttest()`]+ |
+
| 16 | ++ |
+ #'+ |
+
| 17 | ++ |
+ #' @return ARD data frame+ |
+
| 18 | ++ |
+ #' @export+ |
+
| 19 | ++ |
+ #'+ |
+
| 20 | ++ |
+ #' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = c("survey", "broom"), reference_pkg = "cardx"))
+ |
+
| 21 | ++ |
+ #' data(api, package = "survey")+ |
+
| 22 | ++ |
+ #' dclus2 <- survey::svydesign(id = ~ dnum + snum, fpc = ~ fpc1 + fpc2, data = apiclus2)+ |
+
| 23 | ++ |
+ #'+ |
+
| 24 | ++ |
+ #' ard_survey_svyttest(dclus2, variables = enroll, by = comp.imp, conf.level = 0.9)+ |
+
| 25 | ++ |
+ ard_survey_svyttest <- function(data, by, variables, conf.level = 0.95, ...) {
+ |
+
| 26 | +5x | +
+ set_cli_abort_call()+ |
+
| 27 | ++ | + + | +
| 28 | ++ |
+ # check installed packages ---------------------------------------------------+ |
+
| 29 | +5x | +
+ check_pkg_installed(c("survey", "broom"), reference_pkg = "cardx")
+ |
+
| 30 | ++ | + + | +
| 31 | ++ |
+ # check/process inputs -------------------------------------------------------+ |
+
| 32 | +5x | +
+ check_not_missing(data)+ |
+
| 33 | +5x | +
+ check_not_missing(variables)+ |
+
| 34 | +5x | +
+ check_not_missing(by)+ |
+
| 35 | +5x | +
+ check_range(conf.level, range = c(0, 1))+ |
+
| 36 | +5x | +
+ check_class(data, cls = "survey.design")+ |
+
| 37 | +5x | +
+ cards::process_selectors(data[["variables"]], by = {{ by }}, variables = {{ variables }})
+ |
+
| 38 | +5x | +
+ check_scalar(by)+ |
+
| 39 | ++ | + + | +
| 40 | ++ |
+ # return empty ARD if no variables selected ----------------------------------+ |
+
| 41 | +5x | +
+ if (is_empty(variables)) {
+ |
+
| 42 | +! | +
+ return(dplyr::tibble() |> cards::as_card())+ |
+
| 43 | ++ |
+ }+ |
+
| 44 | ++ | + + | +
| 45 | ++ |
+ # build ARD ------------------------------------------------------------------+ |
+
| 46 | +5x | +
+ lapply(+ |
+
| 47 | +5x | +
+ variables,+ |
+
| 48 | +5x | +
+ function(variable) {
+ |
+
| 49 | +6x | +
+ .format_svyttest_results(+ |
+
| 50 | +6x | +
+ by = by,+ |
+
| 51 | +6x | +
+ variable = variable,+ |
+
| 52 | +6x | +
+ lst_tidy =+ |
+
| 53 | +6x | +
+ cards::eval_capture_conditions(+ |
+
| 54 | +6x | +
+ survey::svyttest(reformulate2(termlabels = by, response = variable), design = data, ...) %>%+ |
+
| 55 | ++ |
+ # a slightly enhanced tidier that allows us to specify the conf.level+ |
+
| 56 | ++ |
+ {
+ |
+
| 57 | +5x | +
+ dplyr::bind_cols(+ |
+
| 58 | +5x | +
+ broom::tidy(.) |> dplyr::select(-c("conf.low", "conf.high")),
+ |
+
| 59 | +5x | +
+ dplyr::tibble(!!!stats::confint(., level = conf.level) |> set_names(c("conf.low", "conf.high"))) |>
+ |
+
| 60 | +5x | +
+ dplyr::mutate(conf.level = conf.level)+ |
+
| 61 | ++ |
+ )+ |
+
| 62 | ++ |
+ }+ |
+
| 63 | ++ |
+ ),+ |
+
| 64 | ++ |
+ ...+ |
+
| 65 | ++ |
+ )+ |
+
| 66 | ++ |
+ }+ |
+
| 67 | ++ |
+ ) |>+ |
+
| 68 | +5x | +
+ dplyr::bind_rows()+ |
+
| 69 | ++ |
+ }+ |
+
| 70 | ++ | + + | +
| 71 | ++ |
+ .format_svyttest_results <- function(by, variable, lst_tidy, ...) {
+ |
+
| 72 | ++ |
+ # build ARD ------------------------------------------------------------------+ |
+
| 73 | +6x | +
+ ret <-+ |
+
| 74 | +6x | +
+ cards::tidy_as_ard(+ |
+
| 75 | +6x | +
+ lst_tidy = lst_tidy,+ |
+
| 76 | +6x | +
+ tidy_result_names = c(+ |
+
| 77 | +6x | +
+ "estimate", "statistic",+ |
+
| 78 | +6x | +
+ "p.value", "parameter",+ |
+
| 79 | +6x | +
+ "conf.low", "conf.high",+ |
+
| 80 | +6x | +
+ "conf.level", "method", "alternative"+ |
+
| 81 | ++ |
+ ),+ |
+
| 82 | +6x | +
+ passed_args = dots_list(...),+ |
+
| 83 | +6x | +
+ lst_ard_columns = list(group1 = by, variable = variable, context = "survey_svyttest")+ |
+
| 84 | ++ |
+ )+ |
+
| 85 | ++ | + + | +
| 86 | ++ |
+ # add the stat label ---------------------------------------------------------+ |
+
| 87 | +6x | +
+ ret |>+ |
+
| 88 | +6x | +
+ dplyr::left_join(+ |
+
| 89 | +6x | +
+ .df_ttest_stat_labels(),+ |
+
| 90 | +6x | +
+ by = "stat_name"+ |
+
| 91 | ++ |
+ ) |>+ |
+
| 92 | +6x | +
+ dplyr::mutate(stat_label = dplyr::coalesce(.data$stat_label, .data$stat_name)) |>+ |
+
| 93 | +6x | +
+ cards::as_card() |>+ |
+
| 94 | +6x | +
+ cards::tidy_ard_column_order()+ |
+
| 95 | ++ |
+ }+ |
+
| 1 | ++ |
+ #' ARD Missing Survey Statistics+ |
+
| 2 | ++ |
+ #'+ |
+
| 3 | ++ |
+ #' Compute Analysis Results Data (ARD) for statistics related to data missingness for survey objects+ |
+
| 4 | ++ |
+ #'+ |
+
| 5 | ++ |
+ #' @inheritParams ard_categorical.survey.design+ |
+
| 6 | ++ |
+ #'+ |
+
| 7 | ++ |
+ #' @return an ARD data frame of class 'card'+ |
+
| 8 | ++ |
+ #' @export+ |
+
| 9 | ++ |
+ #'+ |
+
| 10 | ++ |
+ #' @examplesIf cardx:::is_pkg_installed("survey", reference_pkg = "cardx")
+ |
+
| 11 | ++ |
+ #' svy_titanic <- survey::svydesign(~1, data = as.data.frame(Titanic), weights = ~Freq)+ |
+
| 12 | ++ |
+ #'+ |
+
| 13 | ++ |
+ #' ard_missing(svy_titanic, variables = c(Class, Age), by = Survived)+ |
+
| 14 | ++ |
+ ard_missing.survey.design <- function(data,+ |
+
| 15 | ++ |
+ variables,+ |
+
| 16 | ++ |
+ by = NULL,+ |
+
| 17 | ++ |
+ statistic =+ |
+
| 18 | ++ |
+ everything() ~ c(+ |
+
| 19 | ++ |
+ "N_obs", "N_miss", "N_nonmiss", "p_miss", "p_nonmiss",+ |
+
| 20 | ++ |
+ "N_obs_unweighted", "N_miss_unweighted", "N_nonmiss_unweighted",+ |
+
| 21 | ++ |
+ "p_miss_unweighted", "p_nonmiss_unweighted"+ |
+
| 22 | ++ |
+ ),+ |
+
| 23 | ++ |
+ fmt_fn = NULL,+ |
+
| 24 | ++ |
+ stat_label =+ |
+
| 25 | ++ |
+ everything() ~ list(+ |
+
| 26 | ++ |
+ N_obs = "Total N",+ |
+
| 27 | ++ |
+ N_miss = "N Missing",+ |
+
| 28 | ++ |
+ N_nonmiss = "N not Missing",+ |
+
| 29 | ++ |
+ p_miss = "% Missing",+ |
+
| 30 | ++ |
+ p_nonmiss = "% not Missing",+ |
+
| 31 | ++ |
+ N_obs_unweighted = "Total N (unweighted)",+ |
+
| 32 | ++ |
+ N_miss_unweighted = "N Missing (unweighted)",+ |
+
| 33 | ++ |
+ N_nonmiss_unweighted = "N not Missing (unweighted)",+ |
+
| 34 | ++ |
+ p_miss_unweighted = "% Missing (unweighted)",+ |
+
| 35 | ++ |
+ p_nonmiss_unweighted = "% not Missing (unweighted)"+ |
+
| 36 | ++ |
+ ),+ |
+
| 37 | ++ |
+ ...) {
+ |
+
| 38 | +5x | +
+ set_cli_abort_call()+ |
+
| 39 | +5x | +
+ check_dots_empty()+ |
+
| 40 | +5x | +
+ check_pkg_installed(pkg = "survey", reference_pkg = "cardx")+ |
+
| 41 | ++ | + + | +
| 42 | ++ |
+ # process inputs -------------------------------------------------------------+ |
+
| 43 | +5x | +
+ check_not_missing(variables)+ |
+
| 44 | +5x | +
+ cards::process_selectors(+ |
+
| 45 | +5x | +
+ data = data$variables,+ |
+
| 46 | +5x | +
+ variables = {{ variables }},
+ |
+
| 47 | +5x | +
+ by = {{ by }}
+ |
+
| 48 | ++ |
+ )+ |
+
| 49 | ++ | + + | +
| 50 | ++ |
+ # return empty ARD if no variables selected ----------------------------------+ |
+
| 51 | +5x | +
+ if (is_empty(variables)) {
+ |
+
| 52 | +! | +
+ return(dplyr::tibble() |> cards::as_card())+ |
+
| 53 | ++ |
+ }+ |
+
| 54 | ++ | + + | +
| 55 | ++ |
+ # convert all variables to T/F whether it's missing --------------------------+ |
+
| 56 | +5x | +
+ data$variables <- data$variables |>+ |
+
| 57 | +5x | +
+ dplyr::mutate(across(all_of(variables), Negate(is.na)))+ |
+
| 58 | ++ | + + | +
| 59 | +5x | +
+ cards::process_formula_selectors(+ |
+
| 60 | +5x | +
+ data$variables[variables],+ |
+
| 61 | +5x | +
+ statistic = statistic,+ |
+
| 62 | +5x | +
+ fmt_fn = fmt_fn,+ |
+
| 63 | +5x | +
+ stat_label = stat_label+ |
+
| 64 | ++ |
+ )+ |
+
| 65 | +5x | +
+ cards::fill_formula_selectors(+ |
+
| 66 | +5x | +
+ data$variables[variables],+ |
+
| 67 | +5x | +
+ statistic = formals(asNamespace("cardx")[["ard_missing.survey.design"]])[["statistic"]] |> eval()
+ |
+
| 68 | ++ |
+ )+ |
+
| 69 | +5x | +
+ cards::fill_formula_selectors(+ |
+
| 70 | +5x | +
+ data$variables[variables],+ |
+
| 71 | +5x | +
+ stat_label = formals(asNamespace("cardx")[["ard_missing.survey.design"]])[["stat_label"]] |> eval()
+ |
+
| 72 | ++ |
+ )+ |
+
| 73 | ++ | + + | +
| 74 | +5x | +
+ stats_available <- c(+ |
+
| 75 | +5x | +
+ "N_obs", "N_miss", "N_nonmiss", "p_miss", "p_nonmiss",+ |
+
| 76 | +5x | +
+ "N_obs_unweighted", "N_miss_unweighted", "N_nonmiss_unweighted",+ |
+
| 77 | +5x | +
+ "p_miss_unweighted", "p_nonmiss_unweighted"+ |
+
| 78 | ++ |
+ )+ |
+
| 79 | +5x | +
+ cards::check_list_elements(+ |
+
| 80 | +5x | +
+ x = statistic,+ |
+
| 81 | +5x | +
+ predicate = \(x) is.character(x) && all(x %in% stats_available),+ |
+
| 82 | +5x | +
+ error_msg = "Elements passed in the {.arg statistic} argument must be one or more of {.val {stats_available}}"
+ |
+
| 83 | ++ |
+ )+ |
+
| 84 | ++ | + + | +
| 85 | ++ |
+ # calculate results ----------------------------------------------------------+ |
+
| 86 | +5x | +
+ result <-+ |
+
| 87 | +5x | +
+ ard_categorical(+ |
+
| 88 | +5x | +
+ data = data,+ |
+
| 89 | +5x | +
+ variables = all_of(variables),+ |
+
| 90 | +5x | +
+ by = any_of(by),+ |
+
| 91 | +5x | +
+ statistic = everything() ~ c("n", "N", "p", "n_unweighted", "N_unweighted", "p_unweighted")
+ |
+
| 92 | ++ |
+ )+ |
+
| 93 | ++ | + + | +
| 94 | ++ |
+ # rename the stats for missingness -------------------------------------------+ |
+
| 95 | +5x | +
+ result <- result |>+ |
+
| 96 | +5x | +
+ dplyr::mutate(+ |
+
| 97 | +5x | +
+ stat_name =+ |
+
| 98 | +5x | +
+ dplyr::case_when(+ |
+
| 99 | +5x | +
+ .data$stat_name %in% "N" ~ "N_obs",+ |
+
| 100 | +5x | +
+ .data$stat_name %in% "n" & .data$variable_level %in% FALSE ~ "N_miss",+ |
+
| 101 | +5x | +
+ .data$stat_name %in% "n" & .data$variable_level %in% TRUE ~ "N_nonmiss",+ |
+
| 102 | +5x | +
+ .data$stat_name %in% "p" & .data$variable_level %in% FALSE ~ "p_miss",+ |
+
| 103 | +5x | +
+ .data$stat_name %in% "p" & .data$variable_level %in% TRUE ~ "p_nonmiss",+ |
+
| 104 | +5x | +
+ .data$stat_name %in% "N_unweighted" ~ "N_obs_unweighted",+ |
+
| 105 | +5x | +
+ .data$stat_name %in% "n_unweighted" & .data$variable_level %in% FALSE ~ "N_miss_unweighted",+ |
+
| 106 | +5x | +
+ .data$stat_name %in% "n_unweighted" & .data$variable_level %in% TRUE ~ "N_nonmiss_unweighted",+ |
+
| 107 | +5x | +
+ .data$stat_name %in% "p_unweighted" & .data$variable_level %in% FALSE ~ "p_miss_unweighted",+ |
+
| 108 | +5x | +
+ .data$stat_name %in% "p_unweighted" & .data$variable_level %in% TRUE ~ "p_nonmiss_unweighted"+ |
+
| 109 | ++ |
+ )+ |
+
| 110 | ++ |
+ ) |>+ |
+
| 111 | +5x | +
+ dplyr::select(-cards::all_ard_variables("levels"), -"stat_label", -"fmt_fn") |>
+ |
+
| 112 | +5x | +
+ dplyr::slice(1L, .by = c(cards::all_ard_groups(), cards::all_ard_variables(), "stat_name"))+ |
+
| 113 | ++ | + + | +
| 114 | ++ |
+ # final processing of fmt_fn -------------------------------------------------+ |
+
| 115 | +5x | +
+ result <- result |>+ |
+
| 116 | +5x | +
+ .process_nested_list_as_df(+ |
+
| 117 | +5x | +
+ arg = fmt_fn,+ |
+
| 118 | +5x | +
+ new_column = "fmt_fn"+ |
+
| 119 | ++ |
+ ) |>+ |
+
| 120 | +5x | +
+ .default_svy_cat_fmt_fn()+ |
+
| 121 | ++ | + + | +
| 122 | ++ |
+ # merge in statistic labels --------------------------------------------------+ |
+
| 123 | +5x | +
+ result <- result |>+ |
+
| 124 | +5x | +
+ .process_nested_list_as_df(+ |
+
| 125 | +5x | +
+ arg = stat_label,+ |
+
| 126 | +5x | +
+ new_column = "stat_label",+ |
+
| 127 | +5x | +
+ unlist = TRUE+ |
+
| 128 | ++ |
+ ) |>+ |
+
| 129 | +5x | +
+ dplyr::mutate(stat_label = dplyr::coalesce(.data$stat_label, .data$stat_name))+ |
+
| 130 | ++ | + + | +
| 131 | ++ |
+ # return final object --------------------------------------------------------+ |
+
| 132 | +5x | +
+ result |>+ |
+
| 133 | +5x | +
+ dplyr::mutate(context = "missing") |>+ |
+
| 134 | +5x | +
+ cards::as_card() |>+ |
+
| 135 | +5x | +
+ cards::tidy_ard_column_order()+ |
+
| 136 | ++ |
+ }+ |
+
| 1 | ++ |
+ #' ARD Kruskal-Wallis Test+ |
+
| 2 | ++ |
+ #'+ |
+
| 3 | ++ |
+ #' @description+ |
+
| 4 | ++ |
+ #' Analysis results data for Kruskal-Wallis Rank Sum Test.+ |
+
| 5 | ++ |
+ #'+ |
+
| 6 | ++ |
+ #' Calculated with `kruskal.test(data[[variable]], data[[by]], ...)`+ |
+
| 7 | ++ |
+ #'+ |
+
| 8 | ++ |
+ #' @param data (`data.frame`)\cr+ |
+
| 9 | ++ |
+ #' a data frame.+ |
+
| 10 | ++ |
+ #' @param by ([`tidy-select`][dplyr::dplyr_tidy_select])\cr+ |
+
| 11 | ++ |
+ #' column name to compare by.+ |
+
| 12 | ++ |
+ #' @param variables ([`tidy-select`][dplyr::dplyr_tidy_select])\cr+ |
+
| 13 | ++ |
+ #' column names to be compared. Independent tests will+ |
+
| 14 | ++ |
+ #' be computed for each variable.+ |
+
| 15 | ++ |
+ #'+ |
+
| 16 | ++ |
+ #' @return ARD data frame+ |
+
| 17 | ++ |
+ #' @export+ |
+
| 18 | ++ |
+ #'+ |
+
| 19 | ++ |
+ #' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = "broom", reference_pkg = "cardx"))
+ |
+
| 20 | ++ |
+ #' cards::ADSL |>+ |
+
| 21 | ++ |
+ #' ard_stats_kruskal_test(by = "ARM", variables = "AGE")+ |
+
| 22 | ++ |
+ ard_stats_kruskal_test <- function(data, by, variables) {
+ |
+
| 23 | +3x | +
+ set_cli_abort_call()+ |
+
| 24 | ++ | + + | +
| 25 | ++ |
+ # check installed packages ---------------------------------------------------+ |
+
| 26 | +3x | +
+ check_pkg_installed("broom", reference_pkg = "cardx")
+ |
+
| 27 | ++ | + + | +
| 28 | ++ |
+ # check/process inputs -------------------------------------------------------+ |
+
| 29 | +3x | +
+ check_not_missing(data)+ |
+
| 30 | +3x | +
+ check_not_missing(variables)+ |
+
| 31 | +3x | +
+ check_not_missing(by)+ |
+
| 32 | +3x | +
+ check_data_frame(data)+ |
+
| 33 | +3x | +
+ cards::process_selectors(data, by = {{ by }}, variables = {{ variables }})
+ |
+
| 34 | +3x | +
+ check_scalar(by)+ |
+
| 35 | ++ | + + | +
| 36 | ++ |
+ # return empty ARD if no variables selected ----------------------------------+ |
+
| 37 | +3x | +
+ if (is_empty(variables)) {
+ |
+
| 38 | +! | +
+ return(dplyr::tibble() |> cards::as_card())+ |
+
| 39 | ++ |
+ }+ |
+
| 40 | ++ | + + | +
| 41 | ++ |
+ # build ARD ------------------------------------------------------------------+ |
+
| 42 | +3x | +
+ lapply(+ |
+
| 43 | +3x | +
+ variables,+ |
+
| 44 | +3x | +
+ function(variable) {
+ |
+
| 45 | +3x | +
+ cards::tidy_as_ard(+ |
+
| 46 | +3x | +
+ lst_tidy =+ |
+
| 47 | +3x | +
+ cards::eval_capture_conditions(+ |
+
| 48 | +3x | +
+ stats::kruskal.test(x = data[[variable]], g = data[[by]]) |>+ |
+
| 49 | +3x | +
+ broom::tidy()+ |
+
| 50 | ++ |
+ ),+ |
+
| 51 | +3x | +
+ tidy_result_names = c("statistic", "p.value", "parameter", "method"),
+ |
+
| 52 | +3x | +
+ lst_ard_columns = list(group1 = by, variable = variable, context = "stats_kruskal_test")+ |
+
| 53 | ++ |
+ ) |>+ |
+
| 54 | +3x | +
+ dplyr::mutate(+ |
+
| 55 | +3x | +
+ .after = "stat_name",+ |
+
| 56 | +3x | +
+ stat_label =+ |
+
| 57 | +3x | +
+ dplyr::case_when(+ |
+
| 58 | +3x | +
+ .data$stat_name %in% "statistic" ~ "Kruskal-Wallis chi-squared Statistic",+ |
+
| 59 | +3x | +
+ .data$stat_name %in% "p.value" ~ "p-value",+ |
+
| 60 | +3x | +
+ .data$stat_name %in% "parameter" ~ "Degrees of Freedom",+ |
+
| 61 | +3x | +
+ TRUE ~ .data$stat_name,+ |
+
| 62 | ++ |
+ )+ |
+
| 63 | ++ |
+ )+ |
+
| 64 | ++ |
+ }+ |
+
| 65 | ++ |
+ ) |>+ |
+
| 66 | +3x | +
+ dplyr::bind_rows() |>+ |
+
| 67 | +3x | +
+ cards::as_card()+ |
+
| 68 | ++ |
+ }+ |
+
| 1 | ++ |
+ #' ARD Fisher's Exact Test+ |
+
| 2 | ++ |
+ #'+ |
+
| 3 | ++ |
+ #' @description+ |
+
| 4 | ++ |
+ #' Analysis results data for Fisher's Exact Test.+ |
+
| 5 | ++ |
+ #' Calculated with `fisher.test(x = data[[variable]], y = data[[by]], ...)`+ |
+
| 6 | ++ |
+ #'+ |
+
| 7 | ++ |
+ #'+ |
+
| 8 | ++ |
+ #' @param data (`data.frame`)\cr+ |
+
| 9 | ++ |
+ #' a data frame.+ |
+
| 10 | ++ |
+ #' @param by ([`tidy-select`][dplyr::dplyr_tidy_select])\cr+ |
+
| 11 | ++ |
+ #' column name to compare by+ |
+
| 12 | ++ |
+ #' @param variables ([`tidy-select`][dplyr::dplyr_tidy_select])\cr+ |
+
| 13 | ++ |
+ #' column names to be compared. Independent tests will be computed for+ |
+
| 14 | ++ |
+ #' each variable.+ |
+
| 15 | ++ |
+ #' @param conf.level (scalar `numeric`)\cr+ |
+
| 16 | ++ |
+ #' confidence level for confidence interval. Default is `0.95`.+ |
+
| 17 | ++ |
+ #' @param ... additional arguments passed to `fisher.test(...)`+ |
+
| 18 | ++ |
+ #'+ |
+
| 19 | ++ |
+ #' @return ARD data frame+ |
+
| 20 | ++ |
+ #' @export+ |
+
| 21 | ++ |
+ #'+ |
+
| 22 | ++ |
+ #' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = "broom", reference_pkg = "cardx"))
+ |
+
| 23 | ++ |
+ #' cards::ADSL[1:30, ] |>+ |
+
| 24 | ++ |
+ #' ard_stats_fisher_test(by = "ARM", variables = "AGEGR1")+ |
+
| 25 | ++ |
+ ard_stats_fisher_test <- function(data, by, variables, conf.level = 0.95, ...) {
+ |
+
| 26 | +4x | +
+ set_cli_abort_call()+ |
+
| 27 | ++ | + + | +
| 28 | ++ |
+ # check installed packages ---------------------------------------------------+ |
+
| 29 | +4x | +
+ check_pkg_installed("broom", reference_pkg = "cardx")
+ |
+
| 30 | ++ | + + | +
| 31 | ++ |
+ # check/process inputs -------------------------------------------------------+ |
+
| 32 | +4x | +
+ check_not_missing(data)+ |
+
| 33 | +4x | +
+ check_not_missing(variables)+ |
+
| 34 | +4x | +
+ check_not_missing(by)+ |
+
| 35 | +4x | +
+ check_data_frame(data)+ |
+
| 36 | +4x | +
+ cards::process_selectors(data, by = {{ by }}, variables = {{ variables }})
+ |
+
| 37 | +4x | +
+ check_scalar(by)+ |
+
| 38 | +4x | +
+ check_range(conf.level, range = c(0, 1))+ |
+
| 39 | ++ | + + | +
| 40 | ++ |
+ # return empty ARD if no variables selected ----------------------------------+ |
+
| 41 | +4x | +
+ if (is_empty(variables)) {
+ |
+
| 42 | +! | +
+ return(dplyr::tibble() |> cards::as_card())+ |
+
| 43 | ++ |
+ }+ |
+
| 44 | ++ | + + | +
| 45 | ++ |
+ # build ARD ------------------------------------------------------------------+ |
+
| 46 | +4x | +
+ lapply(+ |
+
| 47 | +4x | +
+ variables,+ |
+
| 48 | +4x | +
+ function(variable) {
+ |
+
| 49 | +5x | +
+ cards::tidy_as_ard(+ |
+
| 50 | +5x | +
+ lst_tidy =+ |
+
| 51 | +5x | +
+ cards::eval_capture_conditions(+ |
+
| 52 | +5x | +
+ stats::fisher.test(x = data[[variable]], y = data[[by]], conf.level = conf.level, ...) |>+ |
+
| 53 | +5x | +
+ broom::tidy()+ |
+
| 54 | ++ |
+ ),+ |
+
| 55 | +5x | +
+ tidy_result_names =+ |
+
| 56 | +5x | +
+ c("estimate", "p.value", "conf.low", "conf.high", "method", "alternative"),
+ |
+
| 57 | +5x | +
+ fun_args_to_record =+ |
+
| 58 | +5x | +
+ c(+ |
+
| 59 | +5x | +
+ "workspace", "hybrid", "hybridPars", "control", "or",+ |
+
| 60 | +5x | +
+ "conf.int", "conf.level", "simulate.p.value", "B"+ |
+
| 61 | ++ |
+ ),+ |
+
| 62 | +5x | +
+ formals = formals(stats::fisher.test),+ |
+
| 63 | +5x | +
+ passed_args = dots_list(...),+ |
+
| 64 | +5x | +
+ lst_ard_columns = list(group1 = by, variable = variable, context = "stats_fisher_test")+ |
+
| 65 | ++ |
+ ) |>+ |
+
| 66 | +5x | +
+ dplyr::mutate(+ |
+
| 67 | +5x | +
+ .after = "stat_name",+ |
+
| 68 | +5x | +
+ stat_label =+ |
+
| 69 | +5x | +
+ dplyr::case_when(+ |
+
| 70 | +5x | +
+ .data$stat_name %in% "p.value" ~ "p-value",+ |
+
| 71 | +5x | +
+ TRUE ~ .data$stat_name,+ |
+
| 72 | ++ |
+ )+ |
+
| 73 | ++ |
+ )+ |
+
| 74 | ++ |
+ }+ |
+
| 75 | ++ |
+ ) |>+ |
+
| 76 | +4x | +
+ dplyr::bind_rows() |>+ |
+
| 77 | +4x | +
+ cards::as_card()+ |
+
| 78 | ++ |
+ }+ |
+
| 1 | ++ |
+ #' ARD Attributes+ |
+
| 2 | ++ |
+ #'+ |
+
| 3 | ++ |
+ #' @description+ |
+
| 4 | ++ |
+ #' Add variable attributes to an ARD data frame.+ |
+
| 5 | ++ |
+ #' - The `label` attribute will be added for all columns, and when no label+ |
+
| 6 | ++ |
+ #' is specified and no label has been set for a column using the `label=` argument,+ |
+
| 7 | ++ |
+ #' the column name will be placed in the label statistic.+ |
+
| 8 | ++ |
+ #' - The `class` attribute will also be returned for all columns.+ |
+
| 9 | ++ |
+ #' - Any other attribute returned by `attributes()` will also be added, e.g. factor levels.+ |
+
| 10 | ++ |
+ #'+ |
+
| 11 | ++ |
+ #' @rdname ard_attributes+ |
+
| 12 | ++ |
+ #' @param data (`survey.design`)\cr+ |
+
| 13 | ++ |
+ #' a design object often created with [`survey::svydesign()`].+ |
+
| 14 | ++ |
+ #' @param variables ([`tidy-select`][dplyr::dplyr_tidy_select])\cr+ |
+
| 15 | ++ |
+ #' variables to include+ |
+
| 16 | ++ |
+ #' @param label (named `list`)\cr+ |
+
| 17 | ++ |
+ #' named list of variable labels, e.g. `list(cyl = "No. Cylinders")`.+ |
+
| 18 | ++ |
+ #' Default is `NULL`+ |
+
| 19 | ++ |
+ #' @inheritParams rlang::args_dots_empty+ |
+
| 20 | ++ |
+ #'+ |
+
| 21 | ++ |
+ #' @return an ARD data frame of class 'card'+ |
+
| 22 | ++ |
+ #' @export+ |
+
| 23 | ++ |
+ #'+ |
+
| 24 | ++ |
+ #' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = "survey", reference_pkg = "cardx"))
+ |
+
| 25 | ++ |
+ #' data(api, package = "survey")+ |
+
| 26 | ++ |
+ #' dclus1 <- survey::svydesign(id = ~dnum, weights = ~pw, data = apiclus1, fpc = ~fpc)+ |
+
| 27 | ++ |
+ #'+ |
+
| 28 | ++ |
+ #' ard_attributes(+ |
+
| 29 | ++ |
+ #' data = dclus1,+ |
+
| 30 | ++ |
+ #' variables = c(sname, dname),+ |
+
| 31 | ++ |
+ #' label = list(sname = "School Name", dname = "District Name")+ |
+
| 32 | ++ |
+ #' )+ |
+
| 33 | ++ |
+ ard_attributes.survey.design <- function(data, variables = everything(), label = NULL, ...) {
+ |
+
| 34 | +1x | +
+ set_cli_abort_call()+ |
+
| 35 | ++ | + + | +
| 36 | +1x | +
+ cards::ard_attributes(data = data[["variables"]], variables = {{ variables }}, label = label, ...)
+ |
+
| 37 | ++ |
+ }+ |
+
| 1 | ++ |
+ #' ARD Total N+ |
+
| 2 | ++ |
+ #'+ |
+
| 3 | ++ |
+ #' Returns the total N for a survey object.+ |
+
| 4 | ++ |
+ #' The placeholder variable name returned in the object is `"..ard_total_n.."`+ |
+
| 5 | ++ |
+ #'+ |
+
| 6 | ++ |
+ #' @inheritParams ard_dichotomous.survey.design+ |
+
| 7 | ++ |
+ #' @inheritParams rlang::args_dots_empty+ |
+
| 8 | ++ |
+ #'+ |
+
| 9 | ++ |
+ #' @return an ARD data frame of class 'card'+ |
+
| 10 | ++ |
+ #' @export+ |
+
| 11 | ++ |
+ #'+ |
+
| 12 | ++ |
+ #' @examplesIf cardx:::is_pkg_installed("survey", reference_pkg = "cardx")
+ |
+
| 13 | ++ |
+ #' svy_titanic <- survey::svydesign(~1, data = as.data.frame(Titanic), weights = ~Freq)+ |
+
| 14 | ++ |
+ #'+ |
+
| 15 | ++ |
+ #' ard_total_n(svy_titanic)+ |
+
| 16 | ++ |
+ ard_total_n.survey.design <- function(data, ...) {
+ |
+
| 17 | ++ |
+ # process inputs -------------------------------------------------------------+ |
+
| 18 | +2x | +
+ set_cli_abort_call()+ |
+
| 19 | +2x | +
+ check_dots_empty()+ |
+
| 20 | ++ | + + | +
| 21 | ++ |
+ # calculate total N ----------------------------------------------------------+ |
+
| 22 | +2x | +
+ data$variables <-+ |
+
| 23 | +2x | +
+ data$variables |>+ |
+
| 24 | +2x | +
+ dplyr::mutate(..ard_total_n.. = TRUE)+ |
+
| 25 | ++ | + + | +
| 26 | +2x | +
+ data |>+ |
+
| 27 | +2x | +
+ ard_dichotomous(+ |
+
| 28 | +2x | +
+ variables = "..ard_total_n..",+ |
+
| 29 | +2x | +
+ statistic = list(..ard_total_n.. = c("N", "N_unweighted"))
+ |
+
| 30 | ++ |
+ ) |>+ |
+
| 31 | +2x | +
+ dplyr::mutate(context = "total_n") |>+ |
+
| 32 | +2x | +
+ dplyr::select(-cards::all_ard_variables("levels"))
+ |
+
| 33 | ++ |
+ }+ |
+