261 truetype pag new

R/00tabletrees.R

@@ -64,10 +64,12 @@
 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 @@
   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,15 @@
   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 +114,14 @@
 )
 
 ## 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 +963,7 @@
                     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(
@@ -991,8 +999,9 @@
     svals = c(pos_splvals(parpos), nsplitval),
     svlabels = c(pos_splval_labels(parpos), newlab),
     sub = .combine_subset_exprs(
-      pos_subset(parpos),
-      make_subset_expr(newspl, nsplitval)
+        pos_subset(parpos),
+        ## this will grab the value's custom subset expression if present
+        make_subset_expr(newspl, nsplitval)
     )
   )
   newpos

R/make_split_fun.R

@@ -81,6 +81,8 @@
 #' @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 @@
 #' 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 @@
 #'
 #' @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 @@
   .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 @@
 #' 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 @@
 
     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) {
@@ -333,15 +343,49 @@
 #' @family make_custom_split
 #' @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)
-    add_to_split_result(ret,
-      values = list(val), labels = label,
-      datasplit = list(do.call(rbind, ret$datasplit[levels]))
-    )
+    function(ret, spl, .spl_context, fulldf) {
+        if(is(levels, "AllLevelsSentinel")) {
+            subexpr <- expression(TRUE)
+            datpart <- list(fulldf)
+        } else {
+            subexpr <- .combine_value_exprs(ret$value[levels]) #Reduce(.or_combine_exprs, lapply(ret$value[levels], value_expr))
+            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 = 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()) {

R/make_subset_expr.R

@@ -7,6 +7,11 @@ 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 +28,11 @@ 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 +149,9 @@ 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]])))
 }
@@ -217,16 +230,13 @@ create_colinfo <- function(lyt, df, rtpos = TreePos(),
   ## the counts will obviously be wrong.
   if (is.null(counts)) {
     counts <- rep(NA_integer_, length(cexprs))
-  } else {
-    if (length(counts) != length(cexprs)) {
-      stop(
-        "Length of overriding counts must equal number of columns. Got ",
-        length(counts), " values for ", length(cexprs), " columns. ",
-        "Use NAs to specify that the default counting machinery should be ",
-        "used for that position."
-      )
-    }
-    counts <- as.integer(counts)
+  } else if (length(counts) != length(cexprs)) {
+    stop(
+      "Length of overriding counts must equal number of columns. Got ",
+      length(counts), " values for ", length(cexprs), " columns. ",
+      "Use NAs to specify that the default counting machinery should be ",
+      "used for that position."
+    )
   }
 
   counts_df_name <- "alt_counts_df"
@@ -240,7 +250,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,9 +273,11 @@ create_colinfo <- function(lyt, df, rtpos = TreePos(),
     }
   })
   counts[calcpos] <- calccounts[calcpos]
+  counts <- as.integer(counts)
   if (is.null(total)) {
     total <- sum(counts)
   }
+
   format <- colcount_format(lyt)
   InstantiatedColumnInfo(
     treelyt = ctree,

R/split_funs.R

@@ -134,6 +134,7 @@ NULL
   extr <- partinfo$extras
   dpart <- partinfo$datasplit
   labels <- partinfo$labels
+
   if (is.null(labels)) {
     if (!is.null(names(vals))) {
       labels <- names(vals)
@@ -144,6 +145,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 +182,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 +684,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 +701,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
   )
 }