add ability to pass arguments to score and prune functions

NEWS.md

@@ -4,6 +4,7 @@
  * Added `stat_string` to `as_result_df(make_ard = TRUE)` to preserve the original string representation of the statistics.
  * Added `add_tbl_name_split` to `as_result_df()` to handle split levels constituted by different table names.
  * Analysis and content functions can now accept `.alt_df_full` which will always be the full `alt_counts_df` data.frame.
+ * Score and pruning functions can now optionally accept additional arguments passed to `sort_at_path` or `prune_table`, score functions can also accept `decreasing` to receive sort order.
 
 ### Bug Fixes
  * Fixed issue with `split_cols_by_multivar()` when having more than one value. Now `as_result_df(make_ard = TRUE)` adds a predefined split name for each of the `multivar` splits.

R/tt_compare_tables.R

@@ -216,6 +216,8 @@ low_obs_pruner <- function(min, type = c("sum", "mean")) {
 #' @param stop_depth (`numeric(1)`)\cr the depth after which subtrees should not be checked for pruning.
 #'   Defaults to `NA` which indicates pruning should happen at all levels.
 #' @param depth (`numeric(1)`)\cr used internally, not intended to be set by the end user.
+#' @param ... named arguments to optionally be passed down to `prune_func` if it
+#'   accepts them (or `...`)
 #'
 #' @return A `TableTree` pruned via recursive application of `prune_func`.
 #'
@@ -241,7 +243,8 @@ low_obs_pruner <- function(min, type = c("sum", "mean")) {
 prune_table <- function(tt,
                         prune_func = prune_empty_level,
                         stop_depth = NA_real_,
-                        depth = 0) {
+                        depth = 0,
+                        ...) {
   if (!is.na(stop_depth) && depth > stop_depth) {
     return(tt)
   }
@@ -254,15 +257,17 @@ prune_table <- function(tt,
 
   kids <- tree_children(tt)
 
+  more_args <- match_fun_args(prune_func, depth = depth, ...)
   torm <- vapply(kids, function(tb) {
-    !is.null(tb) && prune_func(tb)
+    !is.null(tb) && do.call(prune_func, c(list(tb), more_args))
   }, NA)
 
   keepkids <- kids[!torm]
   keepkids <- lapply(keepkids, prune_table,
     prune_func = prune_func,
     stop_depth = stop_depth,
-    depth = depth + 1
+    depth = depth + 1,
+    ...
   )
 
   keepkids <- keepkids[!vapply(keepkids, is.null, NA)]

R/tt_sort.R

@@ -41,6 +41,19 @@ cont_n_onecol <- function(j) {
   }
 }
 
+## used for pruning functions and scoring functions(sorting)
+match_fun_args <- function(fun, ...) {
+  dotargs <- list(...)
+  retargs <- list()
+  formnms <- names(formals(fun))
+  if ("..." %in% formnms) {
+    retargs <- dotargs
+  } else if (any(names(dotargs) %in% formnms)) {
+    retargs <- dotargs[names(dotargs) %in% formnms]
+  }
+  retargs
+}
+
 #' Sorting a table at a specific path
 #'
 #' Main sorting function to order the sub-structure of a `TableTree` at a particular path in the table tree.
@@ -56,6 +69,8 @@ cont_n_onecol <- function(j) {
 #'   `"omit"`, which removes them. Other allowed values are `"last"`  and `"first"`, which indicate where `NA` scores
 #'   should be placed in the order.
 #' @param .prev_path (`character`)\cr internal detail, do not set manually.
+#' @param ... Additional (named) arguments that will be passed directly down to
+#'   `score_fun` *if* it accepts them (or accepts `...` itself).
 #'
 #' @return A `TableTree` with the same structure as `tt` with the exception that the requested sorting has been done
 #'   at `path`.
@@ -66,6 +81,11 @@ cont_n_onecol <- function(j) {
 #' scores to determine their sorted order. `tt` is then modified to reflect each of these one or more sorting
 #' operations.
 #'
+#' `score_fun` can optionally accept `decreasing`, which will be passed the value passed
+#' to `sort_at_path` automatically, and other arguments which can be set via `...`. The
+#' first argument passed to `scorefun` will always be the table structure (subtable or row)
+#' it is scoring.
+#'
 #' In `path`, a leading `"root"` element will be ignored, regardless of whether this matches the object name (and thus
 #' actual root path name) of `tt`. Including `"root"` in paths where it does not match the name of `tt` may mask deeper
 #' misunderstandings of how valid paths within a `TableTree` object correspond to the layout used to originally declare
@@ -148,13 +168,31 @@ cont_n_onecol <- function(j) {
 #' # Sorting mean and median for all the AGE leaves!
 #' sort_at_path(tbl, c("RACE", "*", "STRATA1", "*", "AGE"), scorefun)
 #'
+#' last_cat_scorefun <- function(x, decreasing, lastcat) {
+#'   mycat <- obj_name(x)
+#'   if (mycat == lastcat) {
+#'     ifelse(isTRUE(decreasing), -Inf, Inf)
+#'   } else {
+#'     match(tolower(substr(mycat, 1, 1)), letters)
+#'   }
+#' }
+#'
+#' lyt2 <- basic_table() %>%
+#'   split_rows_by("SEX") %>%
+#'   analyze("AGE")
+#'
+#' tbl2 <- build_table(lyt2, DM)
+#' sort_at_path(tbl2, "SEX", last_cat_scorefun, lastcat = "M")
+#' sort_at_path(tbl2, "SEX", last_cat_scorefun, lastcat = "M", decreasing = FALSE)
+#'
 #' @export
 sort_at_path <- function(tt,
                          path,
                          scorefun,
                          decreasing = NA,
                          na.pos = c("omit", "last", "first"),
-                         .prev_path = character()) {
+                         .prev_path = character(),
+                         ...) {
   if (NROW(tt) == 0) {
     return(tt)
   }
@@ -195,7 +233,8 @@ sort_at_path <- function(tt,
             na.pos = na.pos,
             ## its ok to modify the "path" here because its only ever used for
             ## informative error reporting.
-            .prev_path = c(.prev_path, backpath, paste0("* (", oldnames[i], ")"))
+            .prev_path = c(.prev_path, backpath, paste0("* (", oldnames[i], ")")),
+            ...
           )
         }
       )
@@ -229,7 +268,12 @@ sort_at_path <- function(tt,
   kids <- tree_children(subtree)
   ## relax this to allow character "scores"
   ## scores <- vapply(kids, scorefun, NA_real_)
-  scores <- lapply(kids, function(x) tryCatch(scorefun(x), error = function(e) e))
+  more_args <- match_fun_args(scorefun, decreasing = decreasing, ...)
+  scores <- lapply(kids, function(x) {
+    tryCatch(do.call(scorefun, c(list(x), more_args)),
+      error = function(e) e
+    )
+  })
   errs <- which(vapply(scores, is, class2 = "error", TRUE))
   if (length(errs) > 0) {
     stop("Encountered at least ", length(errs), " error(s) when applying score function.\n",

tests/testthat/test-sort-prune.R

@@ -322,3 +322,41 @@ test_that("sort_at_path throws an error when trying to sort a table with identic
     "position element flag appears more than once, not currently supported"
   )
 })
+
+test_that("passing extra stuff to sorting and pruning works", {
+  prfun <- function(x, myarg) {
+    force(myarg) ## cause error if it isn't passed
+    TRUE
+  }
+  lyt <- basic_table() %>%
+    split_rows_by("STRATA1") %>%
+    analyze("SEX")
+
+  tbl <- build_table(lyt, ex_adsl)
+
+  expect_error(prune_table(tbl, prfun))
+  expect_silent(prune_table(tbl, prfun, myarg = "hi"))
+
+  scorefun1 <- function(x, decreasing) {
+    force(decreasing)
+    rnorm(1)
+  }
+
+  scorefun2 <- function(x, myarg) {
+    force(myarg)
+    rnorm(1)
+  }
+
+  scorefun3 <- function(x, decreasing, myarg) {
+    force(decreasing)
+    force(myarg)
+    rnorm(1)
+  }
+
+  ## score functions that don't accept decreasing are tested elsewhere
+  expect_error(sort_at_path(tbl, c("STRATA1", "*", "SEX"), scorefun2))
+  expect_error(sort_at_path(tbl, c("STRATA1", "*", "SEX"), scorefun3))
+  expect_silent(sort_at_path(tbl, c("STRATA1", "*", "SEX"), scorefun1))
+  expect_silent(sort_at_path(tbl, c("STRATA1", "*", "SEX"), scorefun2, myarg = "hi"))
+  expect_silent(sort_at_path(tbl, c("STRATA1", "*", "SEX"), scorefun3, myarg = "hi"))
+})