add restrict_facets and export make_subset_expr

NAMESPACE

@@ -124,6 +124,7 @@ export(make_afun)
 export(make_col_df)
 export(make_split_fun)
 export(make_split_result)
+export(make_subset_expr)
 export(manual_cols)
 export(no_colinfo)
 export(non_ref_rcell)
@@ -145,6 +146,7 @@ export(ref_msg)
 export(ref_symbol)
 export(remove_split_levels)
 export(reorder_split_levels)
+export(restrict_facets)
 export(rheader)
 export(rm_all_colcounts)
 export(row_cells)

NEWS.md

@@ -1,5 +1,9 @@
 ## rtables 0.6.15.9004
 
+### New Features
+ * Added `restrict_facets` function factory for use with `make_split_fun`
+ * Exportd previously internal `make_subset_expr` for use when constructing custom splitting behavior
+
 ## rtables 0.6.15
 
 ### New Features

R/custom_split_funs.R

@@ -584,7 +584,7 @@ setMethod(
     cts <- spl_cuts(spl)
     cfct <- cut(varvec, cts, include.lowest = TRUE) # , labels = lbs)
     ret <- lapply(
-      seq_len(length(levels(cfct))),
+      seq_along(levels(cfct)),
       function(i) df[as.integer(cfct) <= i, ]
     )
     names(ret) <- levels(cfct)

R/default_split_funs.R

@@ -400,7 +400,7 @@ trim_levels_in_group <- function(innervar, drop_outlevs = TRUE) {
 #'
 #' @description
 #' `add_overall_level` is a split function that adds a global level to the current levels in the split. Similarly,
-#' `add_combo_df` uses a user-provided `data.frame` to define the combine the levels to be added. If you need a
+#' `add_combo_levels` uses a user-provided `data.frame` to define the combine the levels to be added. If you need a
 #' single overall column, after all splits, please check [add_overall_col()]. Consider also defining
 #' your custom split function if you need more flexibility (see [custom_split_funs]).
 #'

R/make_split_fun.R

@@ -433,3 +433,94 @@ drop_facet_levels <- function(df, spl, ...) {
   df[[var]] <- factor(df[[var]])
   df
 }
+
+#' Postprocessing split function behavior to generally restrict facets
+#'
+#' @param facets `(character)`\cr Vector of facet names
+#' @param op `("keep", or "exclude")`\cr Whether `facets` names facets
+#'     to be (exclusively) kept (the default) or removed.
+#' @param reorder `(flag)`\cr For `op == "keep"`, should the resulting
+#'     facets be reordered to the order they appear in
+#'     `facets`. Defaults to `TRUE`. Ignored if `op == "exclude"`.
+#' @param quiet `(logical(1))`\cr Whether warnings should be given or
+#'     not (the default) when facets named in `facets` are not found
+#'     in the split result.
+#'
+#' @return a function suitable for use within the `post` argument of
+#'     [make_split_fun()].
+#'
+#' @details This is a function factory which creates a post-process
+#'     behavioral building block for use in [make_split_fun()].
+#'
+#' This factory provides the equivalent of both `keep_split_levels`
+#' and `remove_split_levels` in a form suitable for use in
+#' [make_split_fun()].
+#'
+#' When `op` is `"keep"` (the default), resulting facets are
+#' restricted to only those named in `facets` when the generated
+#' function is applied to a split result; in the case of `"exclude"`,
+#' facets named in `facets` are removed so that only those not named
+#' remain.
+#'
+#' The generated function will throw a warning if any of `facets` are
+#' not found in the split result it receives during splitting, unless
+#' it was created with `quiet = FALSE`.
+#'
+#' @seealso [make_split_fun()]
+#'
+#' @examples
+#'
+#' keep_spl <- make_split_fun(post = list(restrict_facets(c("M", "F"), op = "keep")))
+#'
+#' lyt <- basic_table() |>
+#'   split_cols_by("SEX", split_fun = keep_spl) |>
+#'   analyze("AGE")
+#'
+#' build_table(lyt, ex_adsl)
+#'
+#'
+#' excl_undiff <- restrict_facets("UNDIFFERENTIATED", op = "exclude")
+#' excl_spl <- make_split_fun(post = list(excl_undiff))
+#'
+#' lyt <- basic_table() |>
+#'   split_cols_by("SEX", split_fun = excl_spl) |>
+#'   analyze("AGE")
+#'
+#' build_table(lyt, ex_adsl)
+#'
+#' @family make_custom_split
+#' @export
+restrict_facets <- function(facets,
+                            op = c("keep", "exclude"),
+                            reorder = TRUE,
+                            quiet = FALSE) {
+  op <- match.arg(op)
+  function(splret, spl, fulldf) {
+    nms <- names(splret[[1]])
+    mtch <- match(facets, nms)
+    if (anyNA(mtch)) {
+      if (!quiet) {
+        warning(
+          "restrict facets (op: ",
+          op, ") could not find facets [",
+          paste(facets[is.na(mtch)], collapse = ", "),
+          "]. Ignoring these."
+        )
+      }
+      mtch <- mtch[!is.na(mtch)]
+    }
+
+    sel_vec <- mtch
+    if (op == "exclude") {
+      sel_vec <- -1 * sel_vec
+    } else if (!reorder) { # op is keep
+      sel_vec <- sort(sel_vec)
+    }
+    ret <- lapply(
+      splret,
+      function(lst) lst[sel_vec]
+    )
+    names(ret) <- names(splret)
+    ret
+  }
+}

R/make_subset_expr.R

@@ -2,8 +2,36 @@
 ## which is the only reason expression(TRUE) is ok, because otherwise
 ## we (sometimes) run into
 ## factor()[TRUE] giving <NA> (i.e. length 1)
+
+#' Make subset expression for a split-value pair
+#'
+#' @param spl `(Split)`\cr A split object.
+#' @param val `(SplitValue or string)`\cr The value, either as a
+#'     `SplitValue` object or the raw value as a string.
+#'
+#' @details
+#'
+#' If `val` is a `SplitValue` object which already contains a
+#' subsetting expression with length `>0`, that is immediately
+#' returned. Otherwise, the appropriate subsetting expression is
+#' constructed based on the split type of `spl` and the value `val`.
+#'
+#' @note this is occasionally useful when constructing custom
+#'     splitting behavior which may used for column splitting but
+#'     generally should not be called directly by the end user.
+#'
+#' @return A subseting expression to be used to restrict data to a
+#'     particular column during tabulation.
+#'
+#' @examples
+#'
+#' spl <- VarLevelSplit("ARM", split_label = "ARM")
+#' make_subset_expr(spl, "B: Placebo")
+#' @export
+
 setGeneric("make_subset_expr", function(spl, val) standardGeneric("make_subset_expr"))
 
+#' @rdname make_subset_expr
 setMethod(
   "make_subset_expr", "VarLevelSplit",
   function(spl, val) {
@@ -26,6 +54,7 @@ setMethod(
   }
 )
 
+#' @rdname make_subset_expr
 setMethod(
   "make_subset_expr", "MultiVarSplit",
   function(spl, val) {
@@ -41,6 +70,7 @@ setMethod(
   }
 )
 
+#' @rdname make_subset_expr
 setMethod(
   "make_subset_expr", "AnalyzeVarSplit",
   function(spl, val) {
@@ -55,6 +85,7 @@ setMethod(
   }
 )
 
+#' @rdname make_subset_expr
 setMethod(
   "make_subset_expr", "AnalyzeColVarSplit",
   function(spl, val) {
@@ -65,6 +96,7 @@ setMethod(
 ## XXX these are going to be ridiculously slow
 ## FIXME
 
+#' @rdname make_subset_expr
 setMethod(
   "make_subset_expr", "VarStaticCutSplit",
   function(spl, val) {
@@ -86,6 +118,7 @@ setMethod(
 )
 
 ## NB this assumes spl_cutlabels(spl) is in order!!!!!!
+#' @rdname make_subset_expr
 setMethod(
   "make_subset_expr", "CumulativeCutSplit",
   function(spl, val) {
@@ -123,18 +156,20 @@ setMethod(
 ##                        fun = spl@cut_fun))
 ## })
 
+#' @rdname make_subset_expr
 setMethod(
   "make_subset_expr", "AllSplit",
   function(spl, val) expression(TRUE)
 )
 
 ## probably don't need this
-
+#' @rdname make_subset_expr
 setMethod(
   "make_subset_expr", "expression",
   function(spl, val) spl
 )
 
+#' @rdname make_subset_expr
 setMethod(
   "make_subset_expr", "character",
   function(spl, val) {

R/tt_paginate.R

@@ -237,7 +237,6 @@ setMethod(
            max_width = NULL,
            fontspec = NULL,
            col_gap = 3) {
-
     new_dev <- open_font_dev(fontspec)
     if (new_dev) {
       on.exit(close_font_dev())

_pkgdown.yml

@@ -175,9 +175,11 @@ reference:
     - make_split_fun
     - drop_facet_levels
     - trim_levels_in_facets
+    - restrict_facets
     - add_combo_facet
     - make_split_result
     - spl_variable
+    - make_subset_expr
 
   - title: Cell Formatting related Functions
     desc: cell formatting.