Add ard_abnormal() for abnormality calculations (#311)

**What changes are proposed in this pull request?**
* Added function `ard_abnormal()` to calculate ARDs for abnormality
analyses. (#310)

Closes #310 


--------------------------------------------------------------------------------

Pre-review Checklist (if item does not apply, mark is as complete)
- [x] **All** GitHub Action workflows pass with a ✅
- [x] PR branch has pulled the most recent updates from master branch:
`usethis::pr_merge_main()`
- [x] If a bug was fixed, a unit test was added.
- [x] If a new `ard_*()` function was added, it passes the ARD
structural checks from `cards::check_ard_structure()`.
- [x] If a new `ard_*()` function was added, `set_cli_abort_call()` has
been set.
- [x] If a new `ard_*()` function was added and it depends on another
package (such as, `broom`), `is_pkg_installed("broom")` has been set in
the function call and the following added to the roxygen comments:
`@examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg =
"broom""))`
- [x] Code coverage is suitable for any new functions/features
(generally, 100% coverage for new code): `devtools::test_coverage()`

Reviewer Checklist (if item does not apply, mark is as complete)

- [x] If a bug was fixed, a unit test was added.
- [x] Code coverage is suitable for any new functions/features:
`devtools::test_coverage()`

When the branch is ready to be merged:
- [ ] Update `NEWS.md` with the changes from this pull request under the
heading "`# cardx (development version)`". If there is an issue
associated with the pull request, reference it in parentheses at the end
update (see `NEWS.md` for examples).
- [ ] **All** GitHub Action workflows pass with a ✅
- [ ] Approve Pull Request
- [ ] Merge the PR. Please use "Squash and merge" or "Rebase and merge".

---------

Signed-off-by: Davide Garolini <dgarolini@gmail.com>
Co-authored-by: melkiades <davide.garolini@roche.com>
Co-authored-by: Davide Garolini <dgarolini@gmail.com>
Co-authored-by: Daniel D. Sjoberg <danield.sjoberg@gmail.com>

Author: 3 people

DESCRIPTION

@@ -20,7 +20,7 @@ BugReports: https://github.com/insightsengineering/cardx/issues
 Depends:
     R (>= 4.2)
 Imports:
-    cards (>= 0.6.1),
+    cards (>= 0.6.1.9008),
     cli (>= 3.6.1),
     dplyr (>= 1.1.2),
     glue (>= 1.6.2),
@@ -44,6 +44,8 @@ Suggests:
     survival (>= 3.6-4),
     testthat (>= 3.2.0),
     withr (>= 2.5.0)
+Remotes: 
+    insightsengineering/cards
 Config/Needs/website: insightsengineering/nesttemplate
 Config/testthat/edition: 3
 Config/testthat/parallel: true

NAMESPACE

@@ -28,6 +28,7 @@ export(ard_attributes)
 export(ard_car_anova)
 export(ard_car_vif)
 export(ard_categorical)
+export(ard_categorical_abnormal)
 export(ard_categorical_ci)
 export(ard_categorical_max)
 export(ard_continuous)

NEWS.md

@@ -1,5 +1,7 @@
 # cardx 0.2.5.9000
 
+* Added function `ard_categorical_abnormal()` to calculate ARDs for abnormality analyses. (#310)
+
 * Adding `strata` argument to `ard_categorical_max()`. (#445, @jtalboys)
 
 * Added function `ard_incidence_rate()` to calculate ARDs for incidence rate estimation. (#234)

R/ard_categorical_abnormal.R

@@ -0,0 +1,158 @@
+#' ARD Abnormality Counts
+#'
+#' @description
+#'
+#' Function counts participants with abnormal analysis range values.
+#'
+#' For each abnormality specified via the `abnormal` parameter (e.g. Low or High), statistic `n` is
+#' calculated as the number of patients with this abnormality recorded, and statistic `N` is calculated as
+#' the total number of patients with at least one post-baseline assessment. `p` is calculated as
+#' `n / N`. If `excl_baseline_abn=TRUE` then participants with abnormality at baseline are excluded
+#' from all statistic calculations.
+#'
+#' @param data (`data.frame`)\cr
+#'   a data frame.
+#' @param postbaseline ([`tidy-select`][dplyr::dplyr_tidy_select])\cr
+#'   column name of post-baseline reference range indicator variable.
+#' @param baseline ([`tidy-select`][dplyr::dplyr_tidy_select])\cr
+#'   column name of baseline reference range indicator variable.
+#' @param id ([`tidy-select`][dplyr::dplyr_tidy_select])\cr
+#'   column name used to identify unique participants in `data`. If `NULL`, each row in `data` is assumed to correspond
+#'   to a unique participants.
+#' @param abnormal (`list`)\cr
+#'   a named list of abnormalities to assess for. Each element should specify all levels of `postbaseline`/`baseline`
+#'   that should be included when assessing for a given abnormality, with the name specifying the name of the
+#'   abnormality. Any levels specified but not present in the data are ignored.
+#' @param excl_baseline_abn (`logical`)\cr
+#'   whether participants with baseline abnormality should be excluded from calculations. Defaults to `TRUE`.
+#' @param quiet (scalar `logical`)\cr
+#'   logical indicating whether to suppress additional messaging. Default is `FALSE`.
+#' @inheritParams cards::ard_continuous
+#'
+#' @return an ARD data frame of class 'card'
+#' @export
+#'
+#' @examples
+#' # Load Data -------------------
+#' set.seed(1)
+#' adlb <- cards::ADLB
+#' adlb$BNRIND <- ifelse(
+#'   adlb$BNRIND != "N", sample(c("LOW", "LOW LOW", "HIGH", "HIGH HIGH"), nrow(adlb), replace = TRUE), "NORMAL"
+#' )
+#'
+#' # Example 1 -------------------
+#' adlb |>
+#'   ard_categorical_abnormal(
+#'     postbaseline = LBNRIND, baseline = BNRIND, id = USUBJID, by = TRTA,
+#'     abnormal = list(Low = c("LOW", "LOW LOW"), High = c("HIGH", "HIGH HIGH"))
+#'   )
+ard_categorical_abnormal <- function(data,
+                                     postbaseline,
+                                     baseline,
+                                     id = NULL,
+                                     by = NULL,
+                                     strata = NULL,
+                                     abnormal = list(Low = "LOW", High = "HIGH"),
+                                     excl_baseline_abn = TRUE,
+                                     quiet = FALSE) {
+  set_cli_abort_call()
+
+  # check inputs ---------------------------------------------------------------
+  check_data_frame(data)
+  cards::process_selectors(
+    data,
+    postbaseline = {{ postbaseline }}, baseline = {{ baseline }}, id = {{ id }}, by = {{ by }}, strata = {{ strata }}
+  )
+  check_not_missing(abnormal)
+  check_scalar_logical(excl_baseline_abn)
+  check_scalar_logical(quiet)
+  check_class(abnormal, "list")
+
+  if (!is_named(abnormal)) {
+    cli::cli_abort(
+      "{.arg abnormal} must be a named list, where each name corresponds to a different abnormality/direction.",
+      call = get_cli_abort_call()
+    )
+  }
+  if (!all(is.character(unlist(abnormal)))) {
+    cli::cli_abort(
+      "Each abnormal level of {.var {postbaseline}} specified via {.arg abnormal} must be a {.cls string}.",
+      call = get_cli_abort_call()
+    )
+  }
+
+  # print abnormality levels ---------------------------------------------------
+  if (!quiet) {
+    for (i in seq_along(abnormal)) {
+      vec <- cli::cli_vec(abnormal[[i]], style = list("vec-sep" = ", ", "vec-sep2" = ", ", "vec-last" = ", "))
+      cli::cli_inform("Abnormality {.val {names(abnormal)[i]}} created {cli::qty(abnormal[[i]])} {?from/by merging} level{?s}: {.val {vec}}")
+    }
+  }
+
+  # build ARD ------------------------------------------------------------------
+  data <- data |>
+    dplyr::mutate(
+      dplyr::across(
+        all_of(c(postbaseline, baseline)),
+        \(x) {
+          # combine levels specified for each abnormality
+          do.call(fct_collapse, args = c(list(f = x), abnormal)) |>
+            suppressWarnings()
+        }
+      )
+    )
+
+  # calculate statistics for each abnormality
+  lapply(
+    names(abnormal),
+    function(abn) {
+      cards::ard_complex(
+        data = data,
+        variables = all_of(postbaseline),
+        by = any_of(by),
+        strata = any_of(strata),
+        statistic = all_of(postbaseline) ~ list(
+          abnormal =
+            .calc_abnormal(data, abn, postbaseline, baseline, id, excl_baseline_abn)
+        )
+      ) |>
+        dplyr::bind_cols(dplyr::tibble(variable_level = list(abn)))
+    }
+  ) |>
+    dplyr::bind_rows() |>
+    dplyr::mutate(
+      stat_label = dplyr::coalesce(.data$stat_label, .data$stat_name),
+      context = "categorical_abnormal",
+    ) |>
+    cards::as_card() |>
+    cards::tidy_ard_column_order() |>
+    cards::tidy_ard_row_order()
+}
+
+# function to perform calculations -------------------------------------------
+.calc_abnormal <- function(data, abnormality, postbaseline, baseline, id, excl_baseline_abn) {
+  cards::as_cards_fn(
+    \(x, data, ...) {
+      # if `excl_baseline_abn=FALSE` then do not exclude baseline abnormal from numerator/denominator calculations
+      baseline_not_abn <- if (excl_baseline_abn) !data[[baseline]] %in% abnormality else TRUE # baseline visit not abnormal
+      postbaseline_abn <- data[[postbaseline]] %in% abnormality # post-baseline visit abnormal
+
+      # numerator: unique participants with any abnormal post-baseline visit, baseline visit not abnormal
+      n <- data |>
+        dplyr::filter(postbaseline_abn & baseline_not_abn) |>
+        dplyr::select(all_of(id)) |>
+        dplyr::distinct() |>
+        nrow()
+
+      # denominator: unique participants with any post-baseline visit, baseline visit not abnormal (if )
+      N <- data |>
+        dplyr::filter(baseline_not_abn) |>
+        dplyr::select(all_of(id)) |>
+        dplyr::distinct() |>
+        nrow()
+
+      dplyr::tibble(n = n, N = N, p = n / N)
+    },
+    stat_names = c("n", "N", "p")
+  )
+}

R/import-standalone-forcats.R

@@ -6,7 +6,7 @@
 # ---
 # repo: insightsengineering/standalone
 # file: standalone-forcats.R
-# last-updated: 2025-05-03
+# last-updated: 2025-06-24
 # license: https://unlicense.org
 # imports:
 # ---
@@ -16,6 +16,8 @@
 # of programming.
 #
 # ## Changelog
+# 2025-06-24
+#   - add `fct_collapse()` function (and its internal helper functions).
 # 2025-05-03
 #   - `add fct_relevel()` fix for non-factor inputs
 # 2025-02-24
@@ -91,5 +93,68 @@ fct_relevel <- function(f, ..., after = 0L) {
   return(new_factor)
 }
 
+# internal forcats function used within `fct_collapse()`
+# to re-value factor levels
+.lvls_revalue <- function(f, new_levels) {
+  if (length(new_levels) != nlevels(f)) {
+    n_new <- length(new_levels)
+    n_old <- nlevels(f)
+    cli::cli_abort("{.arg new_levels} must be the same length ({n_new}) as {.code levels(f)} ({n_old}).")
+  }
+  if (anyDuplicated(new_levels)) {
+    u_levels <- unique(new_levels)
+    index <- match(new_levels, u_levels)
+    out <- index[f]
+    attributes(out) <- attributes(f)
+    attr(out, "levels") <- u_levels
+    out
+  } else {
+    attr(f, "levels") <- new_levels
+    f
+  }
+}
+
+# internal forcats function used within `fct_collapse()`
+# to rename factor levels
+.lvls_rename <- function(f, new_levels) {
+  old_levels <- levels(f)
+  idx <- match(new_levels, old_levels)
+  if (any(is.na(idx))) {
+    bad <- new_levels[is.na(idx)]
+    warning("Unknown levels in `f`: ", paste(bad, collapse = ", "), call. = FALSE)
+    new_levels <- new_levels[!is.na(idx)]
+    idx <- idx[!is.na(idx)]
+  }
+  old_levels[idx] <- names(new_levels)
+  old_levels
+}
+
+# internal forcats function used within `fct_collapse()`
+# to process other factor levels not being collapsed
+.lvls_other <- function(f, keep, other_level = "Other") {
+  if (all(keep)) {
+    f
+  } else {
+    new_levels <- ifelse(keep, levels(f), other_level)
+    f <- .lvls_revalue(f, new_levels)
+    fct_relevel(f, other_level, after = Inf)
+  }
+}
+
+fct_collapse <- function(f, ..., other_level = NULL) {
+  if (!inherits(f, "factor")) f <- factor(f)
+
+  dots <- rlang::list2(...)
+  old <- unlist(dots, use.names = FALSE) %||% character()
+  new <- rep(names(dots), lengths(dots))
+
+  # collapse/re-value factor levels using new names
+  out <- .lvls_revalue(f, .lvls_rename(f, rlang::set_names(old, new)))
+  # add other levels not being collapsed
+  if (!is.null(other_level)) out <- .lvls_other(out, levels(out) %in% new, other_level)
+
+  out
+}
+
 # nocov end
 # styler: on

_pkgdown.yml

@@ -91,6 +91,7 @@ reference:
       - ard_regression_basic
       - ard_categorical_max
       - ard_incidence_rate
+      - ard_categorical_abnormal
 
   - title: "Helpers"
   - contents: