adding proportion CIs

DESCRIPTION

@@ -12,9 +12,13 @@ BugReports: https://github.com/insightsengineering/cardx/issues
 Depends:
     R (>= 4.0)
 Imports:
-    cards (>= 0.0.0.9012)
+    cli (>= 3.6.1),
+    cards (>= 0.0.0.9012),
+    dplyr (>= 1.1.2),
+    rlang (>= 1.1.1)
 Suggests:
-    testthat (>= 3.2.0)
+    testthat (>= 3.2.0),
+    withr
 Remotes: 
     insightsengineering/cards
 Config/Needs/website: insightsengineering/nesttemplate

NAMESPACE

@@ -1,2 +1,4 @@
 # Generated by roxygen2: do not edit by hand
 
+export(ard_proportion_ci)
+import(rlang)

R/ard_proportion_ci.R

@@ -0,0 +1,79 @@
+#' Proportion ARD Statistics
+#'
+#' `r lifecycle::badge('experimental')`\cr
+#' Calculate confidence intervals for proportions.
+#'
+#' @inheritParams cards::ard_categorical
+#' @param variables ([`tidy-select`][dplyr::dplyr_tidy_select])\cr
+#'   columns to include in summaries. Columns must be class `<logical>`
+#'   or `<numeric>` values coded as `c(0, 1)`.
+#' @param by ([`tidy-select`][dplyr::dplyr_tidy_select])\cr
+#'   columns to stratify calculations by
+#' @param conf.level (`numeric`)\cr
+#'   a scalar in `(0, 1)` indicating the confidence level.
+#'   Default is `0.95`
+#' @param method (`string`)\cr
+#'   string indicating the type of confidence interval to calculate.
+#'   Must be one of `r formals(ard_proportion_ci)[["method"]] |> eval() |> shQuote()`.
+#'   See `?proportion_ci` for details.
+#' @param strata,weights,max.iterations arguments passed to `proportion_ci_strat_wilson()`,
+#'   when `method = 'strat_wilson'`
+#'
+#' @return an ARD data frame
+#' @export
+#'
+#' @examples
+#' ard_proportion_ci(mtcars, variables = c(vs, am), method = "wilson")
+ard_proportion_ci <- function(data, variables, by = dplyr::group_vars(data),
+                              conf.level = 0.95,
+                              strata,
+                              weights = NULL,
+                              max.iterations = 10,
+                              method = c("waldcc", "wald", "clopper-pearson",
+                                         "wilson", "wilsoncc",
+                                         "strat_wilson", "strat_wilsoncc",
+                                         "agresti-coull", "jeffreys")) {
+  # process inputs -------------------------------------------------------------
+  cards::process_selectors(data, variables = {{  variables }}, by = {{  by }})
+  method <- arg_match(method)
+  if (method %in% c("strat_wilson", "strat_wilsoncc")) {
+    cards::process_selectors(data, strata = strata)
+    check_scalar(strata)
+  }
+
+  # calculate confidence intervals ---------------------------------------------
+  cards::ard_complex(
+    data = data,
+    variables = {{ variables }},
+    by = {{ by }},
+    statistics =
+      ~list(
+        prop_ci =
+          switch(
+            method,
+            "waldcc" = \(x, ...) proportion_ci_wald(x, conf.level = conf.level, correct = TRUE),
+            "wald" = \(x, ...) proportion_ci_wald(x, conf.level = conf.level, correct = FALSE),
+            "wilsoncc" = \(x, ...) proportion_ci_wilson(x, conf.level = conf.level, correct = TRUE),
+            "wilson" = \(x, ...) proportion_ci_wilson(x, conf.level = conf.level, correct = FALSE),
+            "clopper-pearson" = \(x, ...) proportion_ci_clopper_pearson(x, conf.level = conf.level),
+            "agresti-coull" = \(x, ...) proportion_ci_agresti_coull(x, conf.level = conf.level),
+            "jeffreys" = \(x, ...) proportion_ci_jeffreys(x, conf.level = conf.level),
+            "strat_wilsoncc" = \(x, data, ...) {
+              proportion_ci_strat_wilson(x, strata = data[[strata]], weights = weights,
+                                         max.iterations = max.iterations,
+                                         conf.level = conf.level, correct = TRUE)
+            },
+            "strat_wilson" = \(x, data, ...) {
+              proportion_ci_strat_wilson(x, strata = data[[strata]], weights = weights,
+                                         max.iterations = max.iterations,
+                                         conf.level = conf.level, correct = FALSE)
+            }
+          )
+      )
+  ) |>
+    dplyr::mutate(
+      context = "proportion_ci"
+    )
+}
+
+

R/cardx-package.R

@@ -1,4 +1,5 @@
 #' @keywords internal
+#' @import rlang
 "_PACKAGE"
 
 ## usethis namespace: start

R/standalone-checks.R

@@ -0,0 +1,155 @@
+# THIS SCRIPT MUST OPERATE AS A STANDALONE SCRIPT
+# DO NOT USE IMPORTED FUNCTIONS AND ONLY USE rlang AND cli NAMESPACING FOR CHECKS
+# nocov start
+
+
+#' Check Class
+#'
+#' @param class (`character`)\cr
+#'   character vector or string indicating accepted classes.
+#'   Passed to `inherits(what=class)`
+#' @param x `(object)`\cr
+#'   object to check
+#' @param allow_null (`logical(1)`)\cr
+#'   Logical indicating whether a NULL value will pass the test.
+#'   Default is `FALSE`
+#' @param arg_name (`string`)\cr
+#'   string indicating the label/symbol of the object being checked.
+#'   Default is `rlang::caller_arg(x)`
+#' @inheritParams cli::cli_abort
+#' @keywords internal
+check_class <- function(x, class, allow_null = FALSE,
+                        arg_name = rlang::caller_arg(x), call = parent.frame()) {
+  # include NULL class as acceptable if allow_null is TRUE
+  if (isTRUE(allow_null) && is.null(x)) return(invisible())
+
+  if (!inherits(x, class)) {
+    cli::cli_abort("The {.arg {arg_name}} argument must be class {.cls {class}}.", call = call)
+  }
+  invisible()
+}
+
+#' Check Class Data Frame
+#'
+#' @inheritParams check_class
+#' @keywords internal
+check_class_data_frame <- function(x, allow_null = FALSE,
+                                   arg_name = rlang::caller_arg(x), call = parent.frame()) {
+  check_class(x = x, class = "data.frame", allow_null = allow_null,
+              arg_name = arg_name, call = call)
+}
+
+#' Check Argument not Missing
+#'
+#' @inheritParams check_class
+#' @keywords internal
+check_not_missing <- function(x, arg_name = caller_arg(x), call = parent.frame()) {
+  if (missing(x)) {
+    cli::cli_abort("The {.arg {arg_name}} argument cannot be missing.", call = call)
+  }
+  invisible()
+}
+
+#' Check Length
+#'
+#' @param msg (`string`)\cr
+#'   string passed to `cli::cli_abort(message=)`
+#' @param length (`integer(1)`)\cr
+#'   integer specifying the required length
+#' @inheritParams check_class
+#' @keywords internal
+#' @name check_length
+NULL
+
+#' @rdname check_length
+check_length <- function(x, length, arg_name = caller_arg(x), call = parent.frame()) {
+  if (length(x) != length) {
+    cli::cli_abort("The {.arg {arg_name}} argument must be length {.val {length}}.", call = call)
+  }
+  invisible()
+}
+
+#' @rdname check_length
+check_scalar <- function(x, arg_name = caller_arg(x), call = parent.frame()) {
+  check_length(x = x, length = 1L, arg_name = arg_name, call = call)
+}
+
+#' Check Range
+#'
+#' @param x numeric scalar to check
+#' @param range numeric vector of length two
+#' @param include_bounds logical of length two indicating whether to allow
+#'   the lower and upper bounds
+#' @param scalar logical indicating whether `x` must be a scalar
+#' @param msg string passed to `cli::cli_abort(message=)`
+#'
+#' @return invisible
+#' @keywords internal
+check_range <- function(x,
+                        range,
+                        include_bounds = c(FALSE, FALSE),
+                        arg_name = caller_arg(x),
+                        scalar = FALSE,
+                        msg = paste(
+                          "The {.arg {arg_name}} argument must be in the interval",
+                          "{.code {ifelse(include_bounds[1], '[', '(')}{range[1]},",
+                          "{range[2]}{ifelse(include_bounds[2], ']', ')')}}."),
+                        call = parent.frame()) {
+  if (isTRUE(scalar)) {
+    check_scalar(x, arg_name = arg_name)
+  }
+
+  print_error <- FALSE
+  # check input is numeric
+  if (!is.numeric(x)) {
+    print_error <- TRUE
+  }
+
+  # check the lower bound of range
+  if (isFALSE(print_error) && isTRUE(include_bounds[1]) && any(x < range[1])) {
+    print_error <- TRUE
+  }
+  if (isFALSE(print_error) && isFALSE(include_bounds[1]) && any(x <= range[1])) {
+    print_error <- TRUE
+  }
+
+  # check upper bound of range
+  if (isFALSE(print_error) && isTRUE(include_bounds[2]) && any(x > range[2])) {
+    print_error <- TRUE
+  }
+  if (isFALSE(print_error) && isFALSE(include_bounds[2]) && any(x >= range[2])) {
+    print_error <- TRUE
+  }
+
+  # print error
+  if (print_error) {
+    cli::cli_abort(msg, call = call)
+  }
+
+  invisible()
+}
+
+
+#' Check Binary
+#'
+#' Checks if a column in a data frame is binary,
+#' that is, if the column is class `<logical>` or
+#' `<numeric/integer>` and coded as `c(0, 1)`
+#'
+#' @param x a vector
+#' @param call call environment
+#'
+#' @return invisible
+#' @keywords internal
+check_binary <- function(x, arg_name = caller_arg(x), call = parent.frame()) {
+  if (!is.logical(x) && !(is_integerish(x) && is_empty(setdiff(x, c(0, 1, NA))))) {
+    paste("Expecting column {.arg {arg_name}} to be either {.cls logical}",
+          "or {.cls {c('numeric', 'integer')}} coded as {.val {c(0, 1)}}.") |>
+      cli::cli_abort(call = call)
+  }
+
+  invisible()
+}
+
+# nocov end
+