Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Changes from external PR for truetype font #875

Merged
merged 12 commits into from
Jun 4, 2024
6 changes: 3 additions & 3 deletions DESCRIPTION
Original file line number Diff line number Diff line change
Expand Up @@ -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),
Melkiades marked this conversation as resolved.
Show resolved Hide resolved
formatters (>= 0.5.7.9000),
magrittr (>= 1.5),
methods,
R (>= 2.10)
methods
Imports:
checkmate (>= 2.1.0),
htmltools (>= 0.5.4),
Expand Down
12 changes: 11 additions & 1 deletion NEWS.md
Original file line number Diff line number Diff line change
Expand Up @@ -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.
Expand All @@ -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
Expand Down
22 changes: 16 additions & 6 deletions R/00tabletrees.R
Original file line number Diff line number Diff line change
Expand Up @@ -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"
)
Expand All @@ -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)
Expand All @@ -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
Melkiades marked this conversation as resolved.
Show resolved Hide resolved
check_ok_label(label)
new("SplitValue",
value = val,
extra = extr, label = label
extra = extr,
label = label,
subset_expression = sub_expr
)
}

Expand All @@ -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
)
}

Expand Down Expand Up @@ -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(
Expand Down Expand Up @@ -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)
)
)
Expand Down
89 changes: 67 additions & 22 deletions R/make_split_fun.R
Original file line number Diff line number Diff line change
Expand Up @@ -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.
Expand All @@ -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
}
Expand All @@ -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]])
Expand All @@ -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
Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -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) {
Expand Down Expand Up @@ -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()) {
Expand Down
19 changes: 18 additions & 1 deletion R/make_subset_expr.R
Original file line number Diff line number Diff line change
Expand Up @@ -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")) {
Expand All @@ -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)
Expand Down Expand Up @@ -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]])))
}
Expand Down Expand Up @@ -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")) {
Expand All @@ -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)
}
Expand Down
14 changes: 12 additions & 2 deletions R/split_funs.R
Original file line number Diff line number Diff line change
Expand Up @@ -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)
}
Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -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)
}
Expand All @@ -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
)
}
Expand Down
Loading
Loading