Add by_level argument to sort_ard_hierarchical() (#548)

NEWS.md

@@ -1,5 +1,7 @@
 # cards 0.8.1.9000
 
+* Added the `by_level` argument to `sort_ard_hierarchical()`, allowing `"descending"` sorting to rank variable groups by the counts observed within specific `by` variable levels (e.g. `by_level = list(TRTA = "Placebo")`) rather than the sums across all `by` variable levels. The argument accepts a named list, so any combination of `by` variables may be used. (#548, @rikoprogrammer)
+
 * Reduced the run time and memory use of `sort_ard_hierarchical()` and `filter_ard_hierarchical()`, particularly for ARDs with many hierarchy sections. The per-level grouped sums, the group-wise filter loop (including the previously per-group `tidyr::pivot_wider()` for column statistics and the per-group join used to derive the `_overall` statistics), the reformatting helper, and the empty-section pruning were all replaced with `vctrs`-based equivalents. Because `sort_ard_hierarchical()` also runs inside `ard_stack_hierarchical()`, this speeds up ARD construction as well. Results are unchanged. (#176)
 
 * Further reduced the run time and memory use of `ard_stack_hierarchical()` and `ard_stack_hierarchical_count()`, primarily by replacing the per-level `dplyr::slice_tail()` de-duplication with a `vctrs`-based equivalent and by avoiding unnecessary coercions of data frame denominators. Results are unchanged. (#176)

R/sort_ard_hierarchical.R

@@ -24,6 +24,15 @@
 #'     sums, otherwise `p` is used. If neither `n` nor `p` are present in `x` for the variable, an error will occur.
 #'
 #'   Defaults to `everything() ~ "descending"`.
+#' @param by_level (named `list`)\cr
+#'   a named list used to restrict the counts used for `"descending"` sorting to one or more specific `by` variable
+#'   levels. Each name must be one of the `by` variables used to create `x`, and each element must be a single level of
+#'   that `by` variable. When supplied, `"descending"` sorts rank variable groups by the count sums calculated only from
+#'   the rows matching every specified `by` variable level (e.g. `list(TRTA = "Placebo")` sorts by the counts observed
+#'   in the `"Placebo"` arm), rather than the sums across all `by` variable levels. Any `by` variable not named in the
+#'   list is not restricted. This argument has no effect on variables sorted `"alphanumeric"`.
+#'
+#'   Defaults to `NULL`, in which case count sums are calculated across all `by` variable levels.
 #'
 #' @return an ARD data frame of class 'card'
 #' @seealso [filter_ard_hierarchical()]
@@ -51,11 +60,21 @@
 #'   denominator = ADSL
 #' ) |>
 #'   sort_ard_hierarchical(sort = list(AESOC ~ "alphanumeric", AEDECOD ~ "descending"))
+#'
+#' # sort by the counts observed in the "Placebo" arm only
+#' ard_stack_hierarchical(
+#'   ADAE,
+#'   variables = c(AESOC, AEDECOD),
+#'   by = TRTA,
+#'   denominator = ADSL,
+#'   id = USUBJID
+#' ) |>
+#'   sort_ard_hierarchical(by_level = list(TRTA = "Placebo"))
 NULL
 
 #' @rdname sort_ard_hierarchical
 #' @export
-sort_ard_hierarchical <- function(x, sort = everything() ~ "descending") {
+sort_ard_hierarchical <- function(x, sort = everything() ~ "descending", by_level = NULL) {
   set_cli_abort_call()
 
   # check and process inputs ---------------------------------------------------------------------
@@ -78,6 +97,12 @@ sort_ard_hierarchical <- function(x, sort = everything() ~ "descending") {
 
   ard_args <- attributes(x)$args
 
+  # `by` variables as originally supplied to `ard_stack_hierarchical()` - captured before the
+  # highest-severity extraction below (which moves the innermost `by` variable into `variables`).
+  # `by_level` is validated and applied in terms of these original `by` variables.
+  all_by <- ard_args$by
+  by_level <- .check_by_level(by_level, all_by, x)
+
   # for calculations by highest severity, innermost variable is extracted from `by`
   if (length(ard_args$by) > 1) {
     ard_args$variables <- c(ard_args$variables, dplyr::last(ard_args$by))
@@ -132,6 +157,11 @@ sort_ard_hierarchical <- function(x, sort = everything() ~ "descending") {
       dplyr::filter(!.data$variable %in% c(by, "..ard_hierarchical_overall.."))
   }
 
+  # per-row logical mask restricting `"descending"` count sums to the requested `by` variable
+  # level(s). Computed on the pre-reformatting `by` columns (which are not reordered by the sort),
+  # so it stays aligned with `x_sort` by position. `NULL` when `by_level` is not supplied.
+  by_level_keep <- .hierarchy_by_level_mask(x, by_level, all_by)
+
   # reformat ARD for sorting ---------------------------------------------------------------------
   x_sort <- x |>
     # for sorting, assign indices to each row in original order
@@ -159,7 +189,7 @@ sort_ard_hierarchical <- function(x, sort = everything() ~ "descending") {
     sort_groups[[i]] <-
       if (sort[[cols[i]]] == "descending") {
         # rank groups by descending count sum (summed across `by`), levels ascending
-        .hierarchy_sort_group_desc(x_sort, gk_cols, gid, sort_stat, ard_args, cols, i)
+        .hierarchy_sort_group_desc(x_sort, gk_cols, gid, sort_stat, ard_args, cols, i, by_level_keep)
       } else {
         # rank groups alphanumerically by their grouping-variable levels
         .hierarchy_sort_group_alpha(x_sort, gk_cols, gid)
@@ -274,14 +304,16 @@ sort_ard_hierarchical <- function(x, sort = everything() ~ "descending") {
 # grouping levels ascending and their count sum (summed across `by`) descending.
 # Returns NA for groups that contribute no `sort_stat` rows (as the legacy
 # left_join did).
-.hierarchy_sort_group_desc <- function(x, gk_cols, gid, sort_stat, ard_args, cols, i) {
+.hierarchy_sort_group_desc <- function(x, gk_cols, gid, sort_stat, ard_args, cols, i, by_level_keep = NULL) {
   cur_var <- names(cols)[i]
   next_var <- names(cols)[i + 1L]
   by <- ard_args$by
 
   # rows contributing to the count sum at this level (verbatim translation of
   # the legacy .append_hierarchy_sums() filter)
   keep <- x$stat_name == sort_stat
+  # restrict the summed rows to the requested `by` variable level(s), if any
+  if (!is.null(by_level_keep)) keep <- keep & by_level_keep
   if (!is_empty(by)) keep <- keep & x$group1 %in% by
   if (length(c(by, ard_args$variables)) > 1L &&
     ard_args$variables[i] %in% ard_args$include && !cur_var %in% "variable") {
@@ -319,3 +351,85 @@ sort_ard_hierarchical <- function(x, sort = everything() ~ "descending") {
   rank[ord] <- seq_len(n_grp)
   rank[gid]
 }
+
+# the `by` variables occupy the leading group## columns in the order they were supplied to
+# `ard_stack_hierarchical()`. Given a `by` variable name, return the index of its group## column.
+.hierarchy_by_group_index <- function(by_var, all_by) {
+  match(by_var, all_by)
+}
+
+# validate the `by_level` argument and return it unchanged (or `NULL`). `all_by` is the vector of
+# `by` variables as originally supplied; `x` is the input ARD (used to check the requested levels
+# actually exist). Errors with an informative message on any invalid input.
+.check_by_level <- function(by_level, all_by, x) {
+  if (is.null(by_level)) {
+    return(NULL)
+  }
+
+  # must be a fully-named list
+  nms <- rlang::names2(by_level)
+  if (!rlang::is_list(by_level) || is_empty(by_level) || any(!nzchar(nms))) {
+    cli::cli_abort(
+      "The {.arg by_level} argument must be a fully named list, e.g. {.code list(TRTA = \"Placebo\")}.",
+      call = get_cli_abort_call()
+    )
+  }
+
+  # requires at least one `by` variable in `x`
+  if (is_empty(all_by)) {
+    cli::cli_abort(
+      "The {.arg by_level} argument cannot be used because {.arg x} was created without a {.arg by} argument.",
+      call = get_cli_abort_call()
+    )
+  }
+
+  # names must be `by` variables
+  if (!all(nms %in% all_by)) {
+    cli::cli_abort(
+      c("The names of {.arg by_level} must be {.arg by} variables used to create {.arg x}.",
+        "i" = "The {.arg by} variable{?s} {.val {all_by}} {?is/are} available."
+      ),
+      call = get_cli_abort_call()
+    )
+  }
+
+  # each element must be a single level
+  if (any(lengths(by_level) != 1L)) {
+    cli::cli_abort(
+      "Each element of {.arg by_level} must be a single {.arg by} variable level.",
+      call = get_cli_abort_call()
+    )
+  }
+
+  # each level must be present in the corresponding `by` variable
+  for (by_var in nms) {
+    lvl_col <- paste0("group", .hierarchy_by_group_index(by_var, all_by), "_level")
+    valid <- unique(as.character(unlist(x[[lvl_col]])))
+    if (!as.character(by_level[[by_var]]) %in% valid) {
+      cli::cli_abort(
+        "The {.arg by_level} element {.code {by_var}} must be one of {.val {valid}}, not {.val {by_level[[by_var]]}}.",
+        call = get_cli_abort_call()
+      )
+    }
+  }
+
+  by_level
+}
+
+# per-row logical mask selecting the rows whose `by` variable levels match every level requested in
+# `by_level`. Returns `NULL` when `by_level` is not supplied (no restriction). The mask is computed
+# from the original `by` group##_level columns, so it must be evaluated before `.ard_reformat_sort()`.
+.hierarchy_by_level_mask <- function(x, by_level, all_by) {
+  if (is.null(by_level)) {
+    return(NULL)
+  }
+
+  keep <- rep(TRUE, nrow(x))
+  for (by_var in names(by_level)) {
+    lvl_col <- paste0("group", .hierarchy_by_group_index(by_var, all_by), "_level")
+    lvl_vals <- as.character(unlist(lapply(x[[lvl_col]], \(z) if (is_empty(z)) NA_character_ else z[[1]])))
+    keep <- keep & !is.na(lvl_vals) & lvl_vals == as.character(by_level[[by_var]])
+  }
+
+  keep
+}

tests/testthat/_snaps/sort_ard_hierarchical.md

@@ -80,8 +80,49 @@
 ---
 
     Code
-      sort_ard_hierarchical(ard)
+      sort_ard_hierarchical(ard_no_np)
     Condition
       Error in `sort_ard_hierarchical()`:
       ! If `sort='descending'` for any variables then either "n" or "p" must be present in `x` for each of these specified variables in order to calculate the count sums used for sorting.
 
+---
+
+    Code
+      sort_ard_hierarchical(ard, by_level = list(TRTA = "not-a-level"))
+    Condition
+      Error in `sort_ard_hierarchical()`:
+      ! The `by_level` element `TRTA` must be one of "Placebo", "Xanomeline High Dose", and "Xanomeline Low Dose", not "not-a-level".
+
+---
+
+    Code
+      sort_ard_hierarchical(ard, by_level = list(not_a_by_var = "Placebo"))
+    Condition
+      Error in `sort_ard_hierarchical()`:
+      ! The names of `by_level` must be `by` variables used to create `x`.
+      i The `by` variable "TRTA" is available.
+
+---
+
+    Code
+      sort_ard_hierarchical(ard, by_level = list("Placebo"))
+    Condition
+      Error in `sort_ard_hierarchical()`:
+      ! The `by_level` argument must be a fully named list, e.g. `list(TRTA = "Placebo")`.
+
+---
+
+    Code
+      sort_ard_hierarchical(ard, by_level = list(TRTA = c("Placebo", "Xanomeline Low Dose")))
+    Condition
+      Error in `sort_ard_hierarchical()`:
+      ! Each element of `by_level` must be a single `by` variable level.
+
+---
+
+    Code
+      sort_ard_hierarchical(ard_no_by, by_level = list(TRTA = "Placebo"))
+    Condition
+      Error in `sort_ard_hierarchical()`:
+      ! The `by_level` argument cannot be used because `x` was created without a `by` argument.
+