Changes from external PR for truetype font (#875)

Signed-off-by: Davide Garolini <[email protected]> Co-authored-by: github-actions <41898282+github-actions[bot]@users.noreply.github.com> Co-authored-by: Davide Garolini <[email protected]> Co-authored-by: Joe Zhu <[email protected]> Co-authored-by: 27856297+dependabot-preview[bot]@users.noreply.github.com <27856297+dependabot-preview[bot]@users.noreply.github.com>
insightsengineering · Jun 4, 2024 · 23dca85 · 23dca85
1 parent bdafa9d
commit 23dca85
Show file tree

Hide file tree

Showing 23 changed files with 462 additions and 128 deletions.
diff --git a/DESCRIPTION b/DESCRIPTION
@@ -29,10 +29,10 @@ URL: https://github.com/insightsengineering/rtables,
     https://insightsengineering.github.io/rtables/
 BugReports: https://github.com/insightsengineering/rtables/issues
 Depends:
-    formatters (>= 0.5.6),
+    R (>= 2.10),
+    formatters (>= 0.5.7.9000),
     magrittr (>= 1.5),
-    methods,
-    R (>= 2.10)
+    methods
 Imports:
     checkmate (>= 2.1.0),
     htmltools (>= 0.5.4),

diff --git a/NEWS.md b/NEWS.md
@@ -3,6 +3,13 @@
  * Added `top_level_section_div` for `basic_table` to set section dividers for top level rows.
  * Added `keep_label_rows` to `as_result_df` to have these lines visible.
  * `sort_at_path` now gives informative error messages when the given path does not exist.
+ * Add support for truetype fonts based on formatters `>= 0.5.6.9007`. Nearly all functions related to pagination or export now accept `fontspec` argument and pass it around accordingly, by @gmbecker.
+ * Core splitting machinery can now be overridden in column space via `make_split_fun` provided that `core_split` associates the generated facets with subsetting expressions. Subsetting expressions remain unnecessary for splits in row space. By @gmbecker.
+ * ValueWrapper objects now carry around subsetting expressions for use during tabulation, by @gmbecker.
+ * `make_split_res`, `add_to_split_result` now accept a list of subsetting expressions which will be attached to the values, by @gmbecker.
+ * New `value_expr` internal getter and setter methods, by @gmbecker.
+
+
 
 ### Bug Fixes
  * Fixed `rlistings` decoration (e.g. titles and footers) expansion when there are new lines. Moved relevant handling from `rtables`' `matrix_form` function to `formatters`' dedicated `mform_handle_newlines` function.
@@ -12,10 +19,13 @@
  * Fixed `section_div` for analysis of multiple variables (`AnalyzeMultiVars`).
  * Fixed mismatch between indentation declared in row info (`mf_rinfo(mf)`) and actual selected indentation from `matrix_form(mf, indent_rownames = FALSE)`.
  * Fixed bug in `as_html` preventing indentation from being applied in `Viewer` output.
+ * `col_counts<-` and `col_total<-` methods now explicitly convert `value` to integer, by @gmbecker.
+ * `col_gap` is now respected in `nlines` row methods, and thus by `make_row_df`, by @gmbecker.
+
 
 ### Miscellaneous
  * Removed deprecated functions `add_analyzed_var` and `trim_zero_rows`.
- * Added `lifecycle` badge files for documentation.
+ * Added `lifecycle` badge files for deprecated documentation.
  * Deprecated the `gap` and `check_headers` arguments to `rbindl_rtables` using `lifecycle`.
 
 ## rtables 0.6.6

diff --git a/R/00tabletrees.R b/R/00tabletrees.R
@@ -64,10 +64,12 @@ setClassUnion("functionOrNULL", c("NULL", "function"))
 setClassUnion("listOrNULL", c("NULL", "list"))
 ## TODO (?) make "list" more specific, e.g FormatList, or FunctionList?
 setClassUnion("FormatSpec", c("NULL", "character", "function", "list"))
+setClassUnion("ExprOrNULL", c("NULL", "expression"))
 
 setClass("ValueWrapper", representation(
   value = "ANY",
-  label = "characterOrNULL"
+  label = "characterOrNULL",
+  subset_expression = "ExprOrNULL"
 ),
 contains = "VIRTUAL"
 )
@@ -80,7 +82,7 @@ setClass("SplitValue",
   representation(extra = "list")
 )
 
-SplitValue <- function(val, extr = list(), label = val) {
+SplitValue <- function(val, extr = list(), label = val, sub_expr = NULL) {
   if (is(val, "SplitValue")) {
     if (length(splv_extra(val)) > 0) {
       extr <- c(splv_extra(val), extr)
@@ -94,10 +96,16 @@ SplitValue <- function(val, extr = list(), label = val) {
   if (!is(label, "character")) {
     label <- as.character(label)
   }
+
+  if (!is.null(sub_expr) && !is.expression(sub_expr)) {
+    sub_expr <- as.expression(sub_expr)
+  } ## sometimes they will be "call" objects, etc
   check_ok_label(label)
   new("SplitValue",
     value = val,
-    extra = extr, label = label
+    extra = extr,
+    label = label,
+    subset_expression = sub_expr
   )
 }
 
@@ -107,13 +115,14 @@ setClass("LevelComboSplitValue",
 )
 
 ## wrapped in user-facing `add_combo_facet`
-LevelComboSplitValue <- function(val, extr, combolevels, label = val) {
+LevelComboSplitValue <- function(val, extr, combolevels, label = val, sub_expr = NULL) {
   check_ok_label(label)
   new("LevelComboSplitValue",
     value = val,
     extra = extr,
     combolevels = combolevels,
-    label = label
+    label = label,
+    subset_expression = sub_expr
   )
 }
 
@@ -955,7 +964,7 @@ TreePos <- function(spls = list(),
                     svlabels = character(),
                     sub = NULL) {
   check_ok_label(svlabels, multi_ok = TRUE)
-  svals <- make_splvalue_vec(vals = svals)
+  svals <- make_splvalue_vec(vals = svals, subset_exprs = lapply(svals, value_expr))
   if (is.null(sub)) {
     if (length(spls) > 0) {
       sub <- make_pos_subset(
@@ -992,6 +1001,7 @@ make_child_pos <- function(parpos,
     svlabels = c(pos_splval_labels(parpos), newlab),
     sub = .combine_subset_exprs(
       pos_subset(parpos),
+      ## this will grab the value's custom subset expression if present
       make_subset_expr(newspl, nsplitval)
     )
   )

diff --git a/R/make_split_fun.R b/R/make_split_fun.R
@@ -81,6 +81,8 @@ validate_split_result <- function(pinfo, component = NULL) {
 #' @param labels (`character`)\cr the labels associated with each facet.
 #' @param extras (`list` or `NULL`)\cr extra values associated with each of the facets which will be passed to
 #'   analysis functions applied within the facet.
+#' @param subset_exprs (`list`)\cr A list of subsetting expressions (e.g.,
+#'     created with `quote()`) to be used during column subsetting.
 #'
 #' @return A named list representing the facets generated by the split with elements `values`, `datasplit`, and
 #'   `labels`, which are the same length and correspond to each other element-wise.
@@ -89,27 +91,37 @@ validate_split_result <- function(pinfo, component = NULL) {
 #' These functions performs various housekeeping tasks to ensure that the split result list is as the rtables
 #' internals expect it, most of which are not relevant to end users.
 #'
+#' @note Column splitting will not work correctly if a split function
+#' calls `make_split_result` without specifying subset expressions;
+#' row splitting will work as normal. This is due to the fact that
+#' subsetting expressions are used during column splitting to
+#' represent the data associated with facets, while actual data
+#' subsets are used during row splitting.
+#'
 #' @examples
 #' splres <- make_split_result(
 #'   values = c("hi", "lo"),
 #'   datasplit = list(hi = mtcars, lo = mtcars[1:10, ]),
-#'   labels = c("more data", "less data")
+#'   labels = c("more data", "less data"),
+#'   subset_exprs = list(expression(TRUE), expression(seq_along(wt) <= 10))
 #' )
 #'
 #' splres2 <- add_to_split_result(splres,
 #'   values = "med",
 #'   datasplit = list(med = mtcars[1:20, ]),
-#'   labels = "kinda some data"
+#'   labels = "kinda some data",
+#'   subset_exprs = quote(seq_along(wt) <= 20)
 #' )
 #'
 #' @family make_custom_split
 #' @rdname make_split_result
 #' @export
-make_split_result <- function(values, datasplit, labels, extras = NULL) {
+#' @family make_custom_split
+make_split_result <- function(values, datasplit, labels, extras = NULL, subset_exprs = vector("list", length(values))) {
   if (length(values) == 1 && is(datasplit, "data.frame")) {
     datasplit <- list(datasplit)
   }
-  ret <- list(values = values, datasplit = datasplit, labels = labels)
+  ret <- list(values = values, datasplit = datasplit, labels = labels, subset_exprs = subset_exprs)
   if (!is.null(extras)) {
     ret$extras <- extras
   }
@@ -120,9 +132,9 @@ make_split_result <- function(values, datasplit, labels, extras = NULL) {
 #'
 #' @rdname make_split_result
 #' @export
-add_to_split_result <- function(splres, values, datasplit, labels, extras = NULL) {
+add_to_split_result <- function(splres, values, datasplit, labels, extras = NULL, subset_exprs = NULL) {
   validate_split_result(splres)
-  newstuff <- make_split_result(values, datasplit, labels, extras)
+  newstuff <- make_split_result(values, datasplit, labels, extras, subset_exprs = list(subset_exprs))
   ret <- lapply(
     names(splres),
     function(nm) c(splres[[nm]], newstuff[[nm]])
@@ -131,6 +143,7 @@ add_to_split_result <- function(splres, values, datasplit, labels, extras = NULL
   .fixupvals(ret)
 }
 
+
 .can_take_spl_context <- function(f) any(c(".spl_context", "...") %in% names(formals(f)))
 
 #' Create a custom splitting function
@@ -161,15 +174,17 @@ add_to_split_result <- function(splres, values, datasplit, labels, extras = NULL
 #' The preprocessing component is useful for things such as manipulating factor levels, e.g., to trim unobserved ones
 #' or to reorder levels based on observed counts, etc.
 #'
-#' Customization of core splitting (2) is currently only supported in row splits. Core splitting functions override the
-#' fundamental splitting procedure, and are only necessary in rare cases. These must accept `spl`, `df`, `vals`, and
-#' `labels`, and can optionally accept `.spl_context`. They must return a named list with elements, all of the same
-#' length, as follows:
+#' Core  splitting functions  override  the  fundamental
+#' splitting procedure,  and are only  necessary in rare  cases. These
+#' must  accept  `spl`, `df`,  `vals`,  `labels`,  and can  optionally
+#' accept `.spl_context`. They should return a split result object
+#' constructed via `make_split_result()`.
+#'
+#' In particular, if the custom split function will be used in
+#' column space, subsetting expressions (e.g., as returned by
+#' `quote()` or `bquote` must be provided, while they are
+#' optional (and largely ignored, currently) in row space.
 #'
-#'   - `datasplit`, containing a list of `data.frame` objects.
-#'   - `values`, containing values associated with the facets, which must be `character` or `SplitValue` objects.
-#'     These values will appear in the paths of the resulting table.
-#'   - `labels`, containing the character labels associated with `values`
 #'
 #' Post-processing functions (3) must accept the result of the core split as their first argument (which can be
 #' anything), in addition to `spl`, and `fulldf`, and can optionally accept `.spl_context`. They must each return a
@@ -275,14 +290,9 @@ make_split_fun <- function(pre = list(), core_split = NULL, post = list()) {
 
     if (is.null(core_split)) {
       ret <- do_base_split(spl = spl, df = df, vals = vals, labels = labels)
-    } else if (!in_col_split(.spl_context)) {
+    } else {
       ret <- core_split(spl = spl, df = df, vals = vals, labels = labels, .spl_context)
       validate_split_result(ret, component = "core_split")
-    } else {
-      stop(
-        "Use of custom split functions which override core splitting ",
-        "behavior is not currently supported in column space."
-      )
     }
 
     for (post_fn in post) {
@@ -334,14 +344,49 @@ make_split_fun <- function(pre = list(), core_split = NULL, post = list()) {
 #' @export
 add_combo_facet <- function(name, label = name, levels, extra = list()) {
   function(ret, spl, .spl_context, fulldf) {
-    val <- LevelComboSplitValue(val = name, extr = extra, combolevels = levels, label = label)
+    if (is(levels, "AllLevelsSentinel")) {
+      subexpr <- expression(TRUE)
+      datpart <- list(fulldf)
+    } else {
+      subexpr <- .combine_value_exprs(ret$value[levels])
+      datpart <- list(do.call(rbind, ret$datasplit[levels]))
+    }
+
+    val <- LevelComboSplitValue(
+      val = name, extr = extra, combolevels = levels, label = label,
+      sub_expr = subexpr
+    )
     add_to_split_result(ret,
       values = list(val), labels = label,
-      datasplit = list(do.call(rbind, ret$datasplit[levels]))
+      datasplit = datpart
     )
   }
 }
 
+.combine_value_exprs <- function(val_lst, spl) {
+  exprs <- lapply(val_lst, value_expr)
+  nulls <- vapply(exprs, is.null, TRUE)
+  if (all(nulls)) {
+    return(NULL) # default behavior all the way down the line, no need to do anything.
+  } else if (any(nulls)) {
+    exprs[nulls] <- lapply(val_lst[nulls], function(vali) make_subset_expr(spl, vali))
+  }
+  Reduce(.or_combine_exprs, exprs)
+}
+
+## no NULLS coming in here, everything has been populated
+## by either custom subsetting expressions or the result of make_subset_expr(spl, val)
+.or_combine_exprs <- function(ex1, ex2) {
+  if (identical(ex1, expression(FALSE))) {
+    return(ex2)
+  } else if (identical(ex2, expression(FALSE))) {
+    return(ex1)
+  } else if (identical(ex1, expression(TRUE)) || identical(ex2, expression(TRUE))) {
+    return(TRUE)
+  }
+  as.expression(bquote((.(a)) | .(b), list(a = ex1[[1]], b = ex2[[1]])))
+}
+
 #' @rdname add_combo_facet
 #' @export
 add_overall_facet <- function(name, label, extra = list()) {

diff --git a/R/make_subset_expr.R b/R/make_subset_expr.R
@@ -7,6 +7,12 @@ setGeneric("make_subset_expr", function(spl, val) standardGeneric("make_subset_e
 setMethod(
   "make_subset_expr", "VarLevelSplit",
   function(spl, val) {
+    ## this is how custom split functions will communicate the correct expression
+    ## to the column modeling code
+    if (length(value_expr(val)) > 0) {
+      return(value_expr(val))
+    }
+
     v <- unlist(rawvalues(val))
     ## XXX if we're including all levels should even missing be included?
     if (is(v, "AllLevelsSentinel")) {
@@ -23,6 +29,12 @@ setMethod(
 setMethod(
   "make_subset_expr", "MultiVarSplit",
   function(spl, val) {
+    ## this is how custom split functions will communicate the correct expression
+    ## to the column modeling code
+    if (length(value_expr(val)) > 0) {
+      return(value_expr(val))
+    }
+
     ## v = rawvalues(val)
     ## as.expression(bquote(!is.na(.(a)), list(a = v)))
     expression(TRUE)
@@ -139,6 +151,10 @@ setMethod(
       return(expression(TRUE))
     }
   }
+
+  if (is.null(ex2)) {
+    ex2 <- expression(TRUE)
+  }
   stopifnot(is.expression(ex1), is.expression(ex2))
   as.expression(bquote((.(a)) & .(b), list(a = ex1[[1]], b = ex2[[1]])))
 }
@@ -240,7 +256,7 @@ create_colinfo <- function(lyt, df, rtpos = TreePos(),
     if (identical(ex, expression(TRUE))) {
       nrow(alt_counts_df)
     } else if (identical(ex, expression(FALSE))) {
-      0
+      0L
     } else {
       vec <- try(eval(ex, envir = alt_counts_df), silent = TRUE)
       if (is(vec, "try-error")) {
@@ -263,6 +279,7 @@ create_colinfo <- function(lyt, df, rtpos = TreePos(),
     }
   })
   counts[calcpos] <- calccounts[calcpos]
+  counts <- as.integer(counts)
   if (is.null(total)) {
     total <- sum(counts)
   }

diff --git a/R/split_funs.R b/R/split_funs.R
@@ -144,6 +144,14 @@ NULL
     }
   }
 
+  subsets <- partinfo$subset_exprs
+  if (is.null(subsets)) {
+    subsets <- vector(mode = "list", length = length(vals))
+    ## use labels here cause we already did all that work
+    ## to get the names on the labels vector right
+    names(subsets) <- names(labels)
+  }
+
   if (is.null(vals) && !is.null(extr)) {
     vals <- seq_along(extr)
   }
@@ -173,7 +181,7 @@ NULL
     if (is.null(extr)) {
       extr <- rep(list(list()), length(vals))
     }
-    vals <- make_splvalue_vec(vals, extr, labels = labels)
+    vals <- make_splvalue_vec(vals, extr, labels = labels, subset_exprs = subsets)
   }
   ## we're done with this so take it off
   partinfo$extras <- NULL
@@ -675,7 +683,8 @@ setMethod(
   function(spl, df, vals, labels) value_labels(spl)
 )
 
-make_splvalue_vec <- function(vals, extrs = list(list()), labels = vals) {
+make_splvalue_vec <- function(vals, extrs = list(list()), labels = vals,
+                              subset_exprs) {
   if (length(vals) == 0) {
     return(vals)
   }
@@ -691,6 +700,7 @@ make_splvalue_vec <- function(vals, extrs = list(list()), labels = vals) {
   mapply(SplitValue,
     val = vals, extr = extrs,
     label = labels,
+    sub_expr = subset_exprs,
     SIMPLIFY = FALSE
   )
 }