diff --git a/R/00tabletrees.R b/R/00tabletrees.R index 5b64b7c804..a3493ee5e6 100644 --- a/R/00tabletrees.R +++ b/R/00tabletrees.R @@ -46,6 +46,7 @@ setClassUnion("SubsetDef", c("expression", "logical", "integer", "numeric")) setClassUnion("integerOrNULL", c("NULL", "integer")) setClassUnion("characterOrNULL", c("NULL", "character")) +setClassUnion("characterOrList", c("list", "character")) ## should XXX [splits, s_values, sval_labels, subset(?)] be a data.frame? setClass("TreePos", representation( @@ -60,10 +61,29 @@ validity = function(object) { } ) +setOldClass(c("FormatList", "list")) + +FormatList <- function(..., .list = list(...)) { + if (!is.list(.list)) { + .list <- list(.list) + } + valid <- vapply(.list, is, class2 = "FormatSpec", TRUE) + if (!are(.list, "FormatSpec")) { + stop( + "Attempted to construct FormatList with elements that are not ", + "FormatSpec compatible. This should not happen, please contact ", + "the maintainers." + ) + } + + class(.list) <- c("FormatList", "list") + .list +} + 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("FormatSpec", c("NULL", "character", "function", "list", "FormatList")) setClassUnion("ExprOrNULL", c("NULL", "expression")) setClass("ValueWrapper", representation( @@ -133,7 +153,7 @@ setClass("Split", name = "character", split_label = "character", split_format = "FormatSpec", - split_na_str = "character", + split_na_str = "characterOrList", split_label_position = "character", ## NB this is the function which is applied to ## get the content rows for the CHILDREN of this @@ -633,7 +653,9 @@ setClass("VAnalyzeSplit", representation( default_rowlabel = "character", include_NAs = "logical", - var_label_position = "character" + var_label_position = "character", + row_formats_var = "characterOrNULL", + row_na_strs_var = "characterOrNULL" ) ) @@ -672,7 +694,9 @@ AnalyzeVarSplit <- function(var, indent_mod = 0L, label_pos = "default", cvar = "", - section_div = NA_character_) { + section_div = NA_character_, + formats_var = NULL, + na_strs_var = NULL) { check_ok_label(split_label) label_pos <- match.arg(label_pos, c("default", label_pos_values)) if (!any(nzchar(defrowlab))) { @@ -701,7 +725,9 @@ AnalyzeVarSplit <- function(var, page_title_prefix = NA_character_, child_section_div = section_div, child_show_colcounts = FALSE, - child_colcount_format = NA_character_ + child_colcount_format = NA_character_, + row_formats_var = formats_var, + row_na_strs_var = na_strs_var ) ## no content_extra_args } @@ -823,7 +849,9 @@ AnalyzeMultiVars <- function(var, child_labels = c("default", "topleft", "visible", "hidden"), child_names = var, cvar = "", - section_div = NA_character_) { + section_div = NA_character_, + formats_var = NULL, + na_strs_var = NULL) { ## NB we used to resolve to strict TRUE/FALSE for label visibillity ## in this function but that was too greedy for repeated ## analyze calls, so that now occurs in the tabulation machinery @@ -842,26 +870,59 @@ AnalyzeMultiVars <- function(var, ## split_format = .repoutlst(split_format, nv) inclNAs <- .repoutlst(inclNAs, nv) section_div_if_multivar <- if (length(var) > 1) NA_character_ else section_div - pld <- mapply(AnalyzeVarSplit, - var = var, - split_name = child_names, - split_label = split_label, - afun = afun, - defrowlab = defrowlab, - cfun = cfun, - cformat = cformat, - ## split_format = split_format, - inclNAs = inclNAs, - MoreArgs = list( - extra_args = extra_args, - indent_mod = indent_mod, - label_pos = show_kidlabs, - split_format = split_format, - split_na_str = split_na_str, - section_div = section_div_if_multivar - ), ## rvis), - SIMPLIFY = FALSE + + moreargs <- list( + extra_args = extra_args, + indent_mod = indent_mod, + label_pos = show_kidlabs, + section_div = section_div_if_multivar, + formats_var = formats_var, + na_strs_var = na_strs_var ) + mv_list_case <- is.list(split_format) && + all(var %in% names(split_format)) && + all(vapply(split_format, is, class2 = "FormatList", TRUE)) + if (mv_list_case) { # diff format list for each var + stopifnot(all(var %in% names(split_na_str))) + ## split_value does *not* go in more args, not constant across vars + pld <- mapply( + AnalyzeVarSplit, + var = var, + split_name = child_names, + split_label = split_label, + afun = afun, + defrowlab = defrowlab, + cfun = cfun, + cformat = cformat, + ## in case they're in the wrong order for some insane reason + split_format = split_format[var], + split_na_str = split_na_str[var], + inclNAs = inclNAs, + MoreArgs = moreargs, ## rvis), + SIMPLIFY = FALSE + ) + } else { # not diff lists for each var + ## split format goes in more args because its constant across vars + pld <- mapply( + AnalyzeVarSplit, + var = var, + split_name = child_names, + split_label = split_label, + afun = afun, + defrowlab = defrowlab, + cfun = cfun, + cformat = cformat, + inclNAs = inclNAs, + MoreArgs = c( + moreargs, + list( + split_format = split_format, + split_na_str = split_na_str + ) + ), ## rvis), + SIMPLIFY = FALSE + ) + } } else { ## we're combining existing splits here pld <- unlist(lapply(.payload, .uncompound)) diff --git a/R/argument_conventions.R b/R/argument_conventions.R index 958ae2c067..60258e6a92 100644 --- a/R/argument_conventions.R +++ b/R/argument_conventions.R @@ -98,6 +98,14 @@ gen_args <- function(df, alt_counts_df, spl, pos, tt, tr, verbose, colwidths, ob #' functions. See [formatters::list_valid_format_labels()] for a list of all available format strings. #' @param format_na_str (`string`)\cr string which should be displayed when formatted if this cell's value(s) #' are all `NA`. +#' @param formats_var (`string` or `NULL`)\cr `NULL` (the default) or the name of the list column containing named +#' lists of default formats to use. These will be applied with the same precedence as the `format` argument; i.e., +#' they will not override formats (other than `"default"`) set within the afun. +#' Cannot be used simultaneously with `format`. +#' @param na_strs_var (`string` or `NULL`)\cr `NULL` (the default) or the name of the list column containing named +#' lists of default NA strings to use. These will be applied with the same precedence as the `format` argument; i.e., +#' they will not override formats (other than `"default"`) set within the afun. +#' Cannot be used simultaneously with `format`. Cannot be used if `formats_var` is `NULL`. #' @param indent_mod (`numeric`)\cr modifier for the default indent position for the structure created by this #' function (subtable, content table, or row) *and all of that structure's children*. Defaults to 0, which #' corresponds to the unmodified default behavior. @@ -157,7 +165,7 @@ lyt_args <- function(lyt, var, vars, label, labels_var, varlabels, varnames, spl var_labels, cvar, table_names, topleft, align, page_by, page_prefix, format_na_str, section_div, na_str, show_colcounts, - colcount_format, parent_name) { + colcount_format, parent_name, formats_var, na_strs_var) { NULL } diff --git a/R/colby_constructors.R b/R/colby_constructors.R index 60228510b7..9a0161d09b 100644 --- a/R/colby_constructors.R +++ b/R/colby_constructors.R @@ -1067,12 +1067,81 @@ NULL #' divider will be overridden by a split-level section divider when #' both apply to the same position in the rendered output. #' -#' @inherit split_cols_by return -#' -#' @details -#' When non-`NULL`, `format` is used to specify formats for all generated rows, and can be a character vector, a -#' function, or a list of functions. It will be repped out to the number of rows once this is calculated during the -#' tabulation process, but will be overridden by formats specified within `rcell` calls in `afun`. +#' @details When `length(vars) > 1` and when two calls to `analyze` +#' are done in sequence (the second with the default `nested = +#' TRUE`), the analyses will be combined into a multi-variable +#' analysis that will be reflected in the row structure of the +#' resulting table. In these cases, the default is to show the +#' label describing the variable analyzed for each of the +#' resulting subtables, while that is hidden by default in +#' one-variable cases. +#' +#' # Specifying Default Formatting Behavior +#' +#' *Default* formatting behavior for rows generated by `afun` can be +#' specified by one of `format` or `formats_var`. In both cases, these +#' default formatting instructions *will not* supersede formatting +#' specified from within `afun` at either the `rcell` or `in_rows` +#' call levels; They will only apply to rows/cells whose formatting as +#' returned by `afun` is either `NULL` or `"default"`. When +#' non-`NULL`, `format` is used to specify formats for all generated +#' rows, and can be a character vector, a function, or a list of +#' functions. It will be repped out to the number of rows once this is +#' calculated during the tabulation process, but will be overridden by +#' formats specified within `rcell` calls in `afun`. +#' +#' `format` can accept a format label string (see +#' [formatters::list_valid_format_labels()]), a formatting function, an +#' unnamed list, or a named list. +#' +#' When `format` is an unnamed list - or a named list where not all +#' values of `vars` appear in the names - its elements will be repped +#' out to the number of rows generated by `afun` (separately) within +#' each row facet `afun` is applied within. **This includes recycling +#' behavior, even in the case where the number of rows is not cleanly +#' divisible by the number of specified formats**. This behavior is +#' retained largely for legacy reasons and switching to the new +#' named-list behavior is advised where applicable. +#' +#' When `format` is a named list whose names contain all values in +#' `vars`, the elements of `format` are taken to be specific to the +#' analysis of the corresponding variable; this allows us to specify a +#' multi-variable analysis where e.g., the different variables are +#' analyzed by the same `afun` but have different levels of +#' measurement precision (and thus different formatting needs). In +#' this case the var-specific formatting can be a single format (label +#' string or function) or can be a named list whose names will be +#' matched up to those of the rows generated by applying `afun` in +#' each row facet. Matching of formats to rows is performed the same +#' as in the `formats_var` case and is described below. +#' +#' When `formats_var` is non-`NULL`, it specifies the name of a list +#' column containing formatting instructions for one or more rows +#' `afun` will generate when applied within a row facet. This can be +#' used when the analysis results for a single variable (e.g., `value` +#' or `AVAL` in long-form data) should be formatted differently within +#' different row facets (e.g., when faceting on `statistic` or +#' `PARAMCD`). The value of `df[[formats_var]]` is assumed without +#' verification to be constant within each row facet `afun` is applied +#' within, and the first (list) value of the column within the row +#' facet data will be used. +#' +#' In the `formats_var` case as well as the case of `format` being a +#' named list containing the values of `vars`, after rows are created +#' during tabulation, the default formats are matched and applied to +#' them as follows: +#' +#' 1. When the generated row's name (as given by `obj_name`) matches +#' a name in the list, the corresponding default format is applied, +#' 2. for those without exact matches, the default format whose name +#' provides *the best partial match* to each row name is applied, +#' 3. For those without default format names that partially match +#' the row name, no default format is applied. +#' +#' Note carefully that in (2), it is the names of the list of formats +#' that are partially matching the row names not the other way around. +#' +#' # The Analysis Function #' #' The analysis function (`afun`) should take as its first parameter either `x` or `df`. Whichever of these the #' function accepts will change the behavior when tabulation is performed as follows: @@ -1086,6 +1155,8 @@ NULL #' other parameters which, *if and only if* present in the formals, will be passed to the function by the tabulation #' machinery. These are listed and described in [additional_fun_params]. #' +#' @inherit split_cols_by return +#' #' @note None of the arguments described in [additional_fun_params] can be overridden via `extra_args` or when calling #' [make_afun()]. `.N_col` and `.N_total` can be overridden via the `col_counts` argument to [build_table()]. #' Alternative values for the others must be calculated within `afun` based on a combination of extra arguments and @@ -1124,7 +1195,9 @@ analyze <- function(lyt, table_names = vars, parent_name = NULL, format = NULL, + formats_var = NULL, na_str = NA_character_, + na_strs_var = NULL, nested = TRUE, ## can't name this na_rm symbol conflict with possible afuns!! inclNAs = FALSE, @@ -1134,6 +1207,19 @@ analyze <- function(lyt, section_div = NA_character_) { show_labels <- match.arg(show_labels) subafun <- substitute(afun) + if (!is.null(format) && !is.null(formats_var)) { + stop( + "Cannot use 'format' and 'formats_var' arguments at ", + "the same time. Please choose one method for specifying ", + "default formatting." + ) + } else if (is.null(formats_var) && !is.null(na_strs_var)) { + stop( + "Cannot use 'na_strs_var' (got ", + na_strs_var, + ") without using 'formats_var'." + ) + } # R treats a single NA value as a logical atomic. The below # maps all the NAs in `var_labels` to NA_character_ required by `Split` # and avoids the error when `var_labels` is just c(NA). @@ -1159,6 +1245,17 @@ analyze <- function(lyt, defrowlab <- var_labels } + ## hook up the new hotness + var_format_lists <- length(vars) > 1 && + is.list(format) && + all(vars %in% names(format)) + + if (var_format_lists) { + format <- lapply(format, function(x) FormatList(.list = x)) + if (is.character(na_str)) { + na_str <- lapply(format, function(x) na_str) + } + } spl <- AnalyzeMultiVars(vars, var_labels, afun = afun, split_format = format, @@ -1170,7 +1267,9 @@ analyze <- function(lyt, child_names = table_names, child_labels = show_labels, section_div = section_div, - split_name = parent_name + split_name = parent_name, + formats_var = formats_var, + na_strs_var = na_strs_var ) if (nested && (is(last_rowsplit(lyt), "VAnalyzeSplit") || is(last_rowsplit(lyt), "AnalyzeMultiVars"))) { diff --git a/R/tree_accessors.R b/R/tree_accessors.R index 7d3c3d5c25..70efe6f2ad 100644 --- a/R/tree_accessors.R +++ b/R/tree_accessors.R @@ -493,6 +493,18 @@ setMethod("spl_label_var", "VarLevelSplit", function(obj) obj@value_label_var) #' @rdname int_methods setMethod("spl_label_var", "Split", function(obj) NULL) +#' @rdname int_methods +setGeneric("spl_formats_var", function(obj) standardGeneric("spl_formats_var")) + +#' @rdname int_methods +setMethod("spl_formats_var", "VAnalyzeSplit", function(obj) obj@row_formats_var) + +#' @rdname int_methods +setGeneric("spl_na_strs_var", function(obj) standardGeneric("spl_na_strs_var")) + +#' @rdname int_methods +setMethod("spl_na_strs_var", "VAnalyzeSplit", function(obj) obj@row_na_strs_var) + ### name related things # #' @inherit formatters::formatter_methods #' Methods for generics in the `formatters` package @@ -1203,6 +1215,10 @@ setGeneric("set_format_recursive", function(obj, format, na_str, override = FALS standardGeneric("set_format_recursive") }) +fmt_can_inherit <- function(obj, fmt = obj_format(obj)) { + is.null(fmt) || identical(fmt, "default") +} + #' @param override (`flag`)\cr whether to override attribute. #' #' @rdname int_methods @@ -1213,7 +1229,7 @@ setMethod( return(obj) } - if ((is.null(obj_format(obj)) && !is.null(format)) || override) { + if ((fmt_can_inherit(obj) && !is.null(format)) || override) { obj_format(obj) <- format } if ((.no_na_str(obj) && !.no_na_str(na_str)) || override) { @@ -1221,7 +1237,7 @@ setMethod( } lcells <- row_cells(obj) lvals <- lapply(lcells, function(x) { - if (!is.null(x) && (override || is.null(obj_format(x)))) { + if (!is.null(x) && (override || fmt_can_inherit(x))) { obj_format(x) <- obj_format(obj) } if (!is.null(x) && (override || .no_na_str(x))) { @@ -1248,7 +1264,7 @@ setMethod( return(obj) } - if ((is.null(obj_format(obj)) && !is.null(format)) || override) { + if ((fmt_can_inherit(obj) && !is.null(format)) || override) { obj_format(obj) <- format } if ((.no_na_str(obj) && !.no_na_str(na_str)) || override) { diff --git a/R/tt_dotabulation.R b/R/tt_dotabulation.R index 18f8f622b4..6e479c1f20 100644 --- a/R/tt_dotabulation.R +++ b/R/tt_dotabulation.R @@ -550,6 +550,104 @@ gen_rowvalues <- function(dfpart, ctab } +## return index in tbl that has best partial match to str +## or NA_integer_ if none do +inv_pmatch <- function(str, tbl) { + inds <- pmatch(tbl, str, duplicates.ok = TRUE) + found_inds <- which(!is.na(inds)) + ret <- NA_integer_ + if (length(found_inds) == 1) { + ret <- found_inds + } else if (length(found_inds) > 1) { + ncs <- nchar(tbl[found_inds]) + chosen <- which.max(ncs) + ret <- found_inds[chosen] + } + ret +} + +.got_noname_single <- function(lst) { + is.list(lst) && length(lst) == 1 && is.null(names(lst)) +} +.apply_default_formats <- function(kidlst, fmtlst, nastrlst = character()) { + if (length(fmtlst) == 0 && length(nastrlst) == 0) { + return(kidlst) + } + + if (is.null(names(kidlst))) { + names(kidlst) <- vapply(kidlst, obj_name, "") + } + + if (identical(nastrlst, character())) { + nastrlst <- NA_character_ + } + + if (is.character(nastrlst) && length(nastrlst) >= 1) { + missing_nastr_val <- nastrlst + nastrlst <- list() + } else if (.got_noname_single(nastrlst)) { + missing_nastr_val <- nastrlst[[1]] + natsrlst <- list() + } else { + missing_nastr_val <- NA_character_ + } + + if (!is.list(fmtlst)) { ## appears impossible?? + missing_fmt_val <- fmtlst + fmtlst <- list() + } else if (.got_noname_single(fmtlst)) { + stopifnot(is(fmtlst[[1]], "FormatSpec")) + missing_fmt_val <- fmtlst[[1]] + fmtlst <- list() + } else { + missing_fmt_val <- NULL + } + + if (length(names(fmtlst)) > 0 || length(names(nastrlst)) > 0) { + missing_nastrs <- setdiff(names(fmtlst), names(nastrlst)) + missing_fmts <- setdiff(names(nastrlst), names(fmtlst)) + } else { + missing_nastrs <- names(kidlst) + missing_fmts <- names(kidlst) + } + + if (length(missing_nastrs) > 0) { + nastrlst[missing_nastrs] <- missing_nastr_val + } + if (length(missing_fmts) > 0) { + fmtlst[missing_fmts] <- list(missing_fmt_val) + } + + ## they may be in different orders, if so fix it + stopifnot(intersect(names(fmtlst), names(nastrlst)) == names(fmtlst)) + nastrlst <- nastrlst[names(fmtlst)] + + ## checks for exact matches first then (inverse) partial matches + fmt_match <- match(names(kidlst), names(fmtlst)) + no_exact_inds <- which(is.na(fmt_match)) + fmt_match[no_exact_inds] <- vapply( + names(kidlst)[no_exact_inds], + inv_pmatch, + tbl = names(fmtlst), + 1L + ) + + toset <- which(!is.na(fmt_match)) + + fmts <- fmtlst[fmt_match[toset]] + na_strs <- nastrlst[names(fmts)] + + kidlst[toset] <- mapply(function(kid, fmt, na_str) { + if (fmt_can_inherit(kid)) { + kid <- set_format_recursive(kid, fmt, na_str, override = FALSE) + } + kid + }, kid = kidlst[toset], fmt = fmts, na_str = na_strs, SIMPLIFY = FALSE) + + kidlst +} + + .make_analyzed_tab <- function(df, alt_df, alt_df_full, @@ -566,6 +664,20 @@ gen_rowvalues <- function(dfpart, if (nchar(defrlabel) == 0 && !missing(partlabel) && nchar(partlabel) > 0) { defrlabel <- partlabel } + + fmt <- obj_format(spl) + have_fmt_lst <- FALSE + if (is(fmt, "FormatList")) { + ## list for diff vars but each has one format case + if (length(fmt) == 1 && is.null(names(fmt))) { + fmt <- unlist(fmt) + stopifnot(is(fmt, "FormatSpec")) + } else { ## real format list case + fmt <- NULL + have_fmt_lst <- TRUE + } + } + kids <- tryCatch( .make_tablerows(df, func = analysis_fun(spl), @@ -573,7 +685,7 @@ gen_rowvalues <- function(dfpart, cinfo = cinfo, datcol = spl_payload(spl), lev = lvl + 1L, - format = obj_format(spl), + format = fmt, # obj_format(spl), splextra = split_exargs(spl), baselines = baselines, alt_dfpart = alt_df, @@ -595,15 +707,46 @@ gen_rowvalues <- function(dfpart, call. = FALSE ) } + + fmtlist <- NULL + if (!is.null(spl_formats_var(spl))) { + if (is.null(spl_na_strs_var(spl))) { + na_strs <- character() ## case handled in .apply_default_formats + } else { + na_strs <- df[[spl_na_strs_var(spl)]][[1]] + } + fmtlist <- df[[spl_formats_var(spl)]][[1]] + } else if (have_fmt_lst) { + fmtlist <- obj_format(spl) + na_strs <- obj_na_str(spl) + if (is.character(na_strs)) { + na_strs <- lapply(fmtlist, function(nm) na_strs) + names(na_strs) <- names(fmtlist) + } + } + + if (!is.null(fmtlist)) { + kids <- .apply_default_formats( + kids, + fmtlist, + na_strs + ) + } + lab <- obj_label(spl) + if (is.character(obj_na_str(spl))) { + final_na_str <- obj_na_str(spl) + } else { + final_na_str <- NA_character_ + } ret <- TableTree( kids = kids, name = obj_name(spl), label = lab, lev = lvl, cinfo = cinfo, - format = obj_format(spl), - na_str = obj_na_str(spl), + format = if (is.null(fmtlist)) obj_format(spl) else NULL, + na_str = final_na_str, indent_mod = indent_mod(spl), trailing_section_div = spl_section_div(spl) ) diff --git a/inst/WORDLIST b/inst/WORDLIST index d15e79ad5f..f5069ba64c 100644 --- a/inst/WORDLIST +++ b/inst/WORDLIST @@ -1,53 +1,26 @@ +Abinaya AE AEs +afun +afuns +amongst ARD +ard ARDs +biomarker BMEASIFL +Bov +Bov Bové -CRAN's Carreras +charset Cheatsheet Chohan -FFFL -Godwin -Heng -Hoffmann -Kelkhoff -Layouting -Lewandowski -Maximo -Modelling -NSE -ORCID -Paszty -Pathing -Pharma -Phuse -Pre -Qi -RStudio -Resync -Rua -SKELETOMUSCULAR -STUDYID -Sabanés -Saibah -Stoilova -Subtable -Subtables -Tadeusz -Unstratified -ValueWrapper -Yung -afun -afuns -amongst -ard -biomarker -charset colcount combinatorial +CRAN's customizations +Davide de decrementing df @@ -58,44 +31,77 @@ elemtable emph facetted facetting +FFFL formatter forseeable funder +Garolini getter getters +Godwin +Heng +Hoffmann ie indicies ing initializer +Kelkhoff labelled +Layouting layouting +Lewandowski mandatorily +Maximo modelled +Modelling monospace +Mordig multivariable +NSE +ORCID orderable orthogonally oversimplifaction +Paszty pathability pathable pathed +Pathing pathing +Pharma +Phuse postfix postprocessing +Pre pre +Qi reindexed repped responder +Resync reusability roadmap +RStudio +rtables +Rua +Saban +Sabans +Sabanés +Saibah +SKELETOMUSCULAR sortable spl +Stoilova +STUDYID subsplits +Subtable subtable subtable's +Subtables subtables summarization tableone +Tadeusz todo traversable truetype @@ -106,8 +112,14 @@ uniquification univariable unnested unpruned +Unstratified unstratified useR +ValueWrapper visibilities visibilty +Waddell xtable +Yogasekaram +Yung +Zhu diff --git a/man/analyze.Rd b/man/analyze.Rd index d509fb4be3..b03755d533 100644 --- a/man/analyze.Rd +++ b/man/analyze.Rd @@ -12,7 +12,9 @@ analyze( table_names = vars, parent_name = NULL, format = NULL, + formats_var = NULL, na_str = NA_character_, + na_strs_var = NULL, nested = TRUE, inclNAs = FALSE, extra_args = list(), @@ -42,8 +44,18 @@ analyzing a single variable.} strings (\code{"xx.x"}) or function. In cases such as \code{analyze} calls, they can be character vectors or lists of functions. See \code{\link[formatters:list_formats]{formatters::list_valid_format_labels()}} for a list of all available format strings.} +\item{formats_var}{(\code{string} or \code{NULL})\cr \code{NULL} (the default) or the name of the list column containing named +lists of default formats to use. These will be applied with the same precedence as the \code{format} argument; i.e., +they will not override formats (other than \code{"default"}) set within the afun. +Cannot be used simultaneously with \code{format}.} + \item{na_str}{(\code{string})\cr string that should be displayed when the value of \code{x} is missing. Defaults to \code{"NA"}.} +\item{na_strs_var}{(\code{string} or \code{NULL})\cr \code{NULL} (the default) or the name of the list column containing named +lists of default NA strings to use. These will be applied with the same precedence as the \code{format} argument; i.e., +they will not override formats (other than \code{"default"}) set within the afun. +Cannot be used simultaneously with \code{format}. Cannot be used if \code{formats_var} is \code{NULL}.} + \item{nested}{(\code{logical})\cr whether this layout instruction should be applied within the existing layout structure \emph{if possible} (\code{TRUE}, the default) or as a new top-level element (\code{FALSE}). Ignored if it would nest a split underneath analyses, which is not allowed.} @@ -77,10 +89,87 @@ adding calls to \code{analyze} and/or \code{\link[=analyze_colvars]{analyze_colv the tabulation will occur at the current/next level of nesting by default. } \details{ -When non-\code{NULL}, \code{format} is used to specify formats for all generated rows, and can be a character vector, a -function, or a list of functions. It will be repped out to the number of rows once this is calculated during the -tabulation process, but will be overridden by formats specified within \code{rcell} calls in \code{afun}. +When \code{length(vars) > 1} and when two calls to \code{analyze} +are done in sequence (the second with the default \code{nested = TRUE}), the analyses will be combined into a multi-variable +analysis that will be reflected in the row structure of the +resulting table. In these cases, the default is to show the +label describing the variable analyzed for each of the +resulting subtables, while that is hidden by default in +one-variable cases. +} +\note{ +None of the arguments described in \link{additional_fun_params} can be overridden via \code{extra_args} or when calling +\code{\link[=make_afun]{make_afun()}}. \code{.N_col} and \code{.N_total} can be overridden via the \code{col_counts} argument to \code{\link[=build_table]{build_table()}}. +Alternative values for the others must be calculated within \code{afun} based on a combination of extra arguments and +the unmodified values provided by the tabulation framework. +} +\section{Specifying Default Formatting Behavior}{ +\emph{Default} formatting behavior for rows generated by \code{afun} can be +specified by one of \code{format} or \code{formats_var}. In both cases, these +default formatting instructions \emph{will not} supersede formatting +specified from within \code{afun} at either the \code{rcell} or \code{in_rows} +call levels; They will only apply to rows/cells whose formatting as +returned by \code{afun} is either \code{NULL} or \code{"default"}. When +non-\code{NULL}, \code{format} is used to specify formats for all generated +rows, and can be a character vector, a function, or a list of +functions. It will be repped out to the number of rows once this is +calculated during the tabulation process, but will be overridden by +formats specified within \code{rcell} calls in \code{afun}. + +\code{format} can accept a format label string (see +\code{\link[formatters:list_formats]{formatters::list_valid_format_labels()}}), a formatting function, an +unnamed list, or a named list. + +When \code{format} is an unnamed list - or a named list where not all +values of \code{vars} appear in the names - its elements will be repped +out to the number of rows generated by \code{afun} (separately) within +each row facet \code{afun} is applied within. \strong{This includes recycling +behavior, even in the case where the number of rows is not cleanly +divisible by the number of specified formats}. This behavior is +retained largely for legacy reasons and switching to the new +named-list behavior is advised where applicable. + +When \code{format} is a named list whose names contain all values in +\code{vars}, the elements of \code{format} are taken to be specific to the +analysis of the corresponding variable; this allows us to specify a +multi-variable analysis where e.g., the different variables are +analyzed by the same \code{afun} but have different levels of +measurement precision (and thus different formatting needs). In +this case the var-specific formatting can be a single format (label +string or function) or can be a named list whose names will be +matched up to those of the rows generated by applying \code{afun} in +each row facet. Matching of formats to rows is performed the same +as in the \code{formats_var} case and is described below. + +When \code{formats_var} is non-\code{NULL}, it specifies the name of a list +column containing formatting instructions for one or more rows +\code{afun} will generate when applied within a row facet. This can be +used when the analysis results for a single variable (e.g., \code{value} +or \code{AVAL} in long-form data) should be formatted differently within +different row facets (e.g., when faceting on \code{statistic} or +\code{PARAMCD}). The value of \code{df[[formats_var]]} is assumed without +verification to be constant within each row facet \code{afun} is applied +within, and the first (list) value of the column within the row +facet data will be used. + +In the \code{formats_var} case as well as the case of \code{format} being a +named list containing the values of \code{vars}, after rows are created +during tabulation, the default formats are matched and applied to +them as follows: +\enumerate{ +\item When the generated row's name (as given by \code{obj_name}) matches +a name in the list, the corresponding default format is applied, +\item for those without exact matches, the default format whose name +provides \emph{the best partial match} to each row name is applied, +\item For those without default format names that partially match +the row name, no default format is applied. +} +Note carefully that in (2), it is the names of the list of formats +that are partially matching the row names not the other way around. +} + +\section{The Analysis Function}{ The analysis function (\code{afun}) should take as its first parameter either \code{x} or \code{df}. Whichever of these the function accepts will change the behavior when tabulation is performed as follows: \itemize{ @@ -94,12 +183,7 @@ In addition to differentiation on the first argument, the analysis function can other parameters which, \emph{if and only if} present in the formals, will be passed to the function by the tabulation machinery. These are listed and described in \link{additional_fun_params}. } -\note{ -None of the arguments described in \link{additional_fun_params} can be overridden via \code{extra_args} or when calling -\code{\link[=make_afun]{make_afun()}}. \code{.N_col} and \code{.N_total} can be overridden via the \code{col_counts} argument to \code{\link[=build_table]{build_table()}}. -Alternative values for the others must be calculated within \code{afun} based on a combination of extra arguments and -the unmodified values provided by the tabulation framework. -} + \examples{ lyt <- basic_table() \%>\% split_cols_by("ARM") \%>\% diff --git a/man/avarspl.Rd b/man/avarspl.Rd index 99cde01943..94d16afb7e 100644 --- a/man/avarspl.Rd +++ b/man/avarspl.Rd @@ -21,7 +21,9 @@ AnalyzeVarSplit( indent_mod = 0L, label_pos = "default", cvar = "", - section_div = NA_character_ + section_div = NA_character_, + formats_var = NULL, + na_strs_var = NULL ) AnalyzeColVarSplit( @@ -57,7 +59,9 @@ AnalyzeMultiVars( child_labels = c("default", "topleft", "visible", "hidden"), child_names = var, cvar = "", - section_div = NA_character_ + section_div = NA_character_, + formats_var = NULL, + na_strs_var = NULL ) } \arguments{ @@ -104,6 +108,16 @@ analyzed at the same level of nesting.} \item{section_div}{(\code{string})\cr string which should be repeated as a section divider after each group defined by this split instruction, or \code{NA_character_} (the default) for no section divider.} +\item{formats_var}{(\code{string} or \code{NULL})\cr \code{NULL} (the default) or the name of the list column containing named +lists of default formats to use. These will be applied with the same precedence as the \code{format} argument; i.e., +they will not override formats (other than \code{"default"}) set within the afun. +Cannot be used simultaneously with \code{format}.} + +\item{na_strs_var}{(\code{string} or \code{NULL})\cr \code{NULL} (the default) or the name of the list column containing named +lists of default NA strings to use. These will be applied with the same precedence as the \code{format} argument; i.e., +they will not override formats (other than \code{"default"}) set within the afun. +Cannot be used simultaneously with \code{format}. Cannot be used if \code{formats_var} is \code{NULL}.} + \item{.payload}{(\code{list})\cr used internally, not intended to be set by end users.} \item{child_labels}{(\code{string})\cr the display behavior for the labels (i.e. label rows) of the children of this diff --git a/man/int_methods.Rd b/man/int_methods.Rd index 0a662b3de7..9c528cc439 100644 --- a/man/int_methods.Rd +++ b/man/int_methods.Rd @@ -104,6 +104,10 @@ \alias{spl_label_var} \alias{spl_label_var,VarLevelSplit-method} \alias{spl_label_var,Split-method} +\alias{spl_formats_var} +\alias{spl_formats_var,VAnalyzeSplit-method} +\alias{spl_na_strs_var} +\alias{spl_na_strs_var,VAnalyzeSplit-method} \alias{tt_labelrow} \alias{tt_labelrow,VTableTree-method} \alias{tt_labelrow<-} @@ -634,6 +638,14 @@ spl_label_var(obj) \S4method{spl_label_var}{Split}(obj) +spl_formats_var(obj) + +\S4method{spl_formats_var}{VAnalyzeSplit}(obj) + +spl_na_strs_var(obj) + +\S4method{spl_na_strs_var}{VAnalyzeSplit}(obj) + tt_labelrow(obj) \S4method{tt_labelrow}{VTableTree}(obj) diff --git a/man/lyt_args.Rd b/man/lyt_args.Rd index 0b7984345d..7a3d5009c8 100644 --- a/man/lyt_args.Rd +++ b/man/lyt_args.Rd @@ -51,7 +51,9 @@ lyt_args( na_str, show_colcounts, colcount_format, - parent_name + parent_name, + formats_var, + na_strs_var ) } \arguments{ @@ -187,6 +189,16 @@ this split. Defaults to \code{"(N=xx)"}.} to the \emph{split} or \emph{group of sibling analyses}, for \verb{split_rows_by*} and \verb{analyze*} when analyzing more than one variable, respectively. Ignored when analyzing a single variable.} + +\item{formats_var}{(\code{string} or \code{NULL})\cr \code{NULL} (the default) or the name of the list column containing named +lists of default formats to use. These will be applied with the same precedence as the \code{format} argument; i.e., +they will not override formats (other than \code{"default"}) set within the afun. +Cannot be used simultaneously with \code{format}.} + +\item{na_strs_var}{(\code{string} or \code{NULL})\cr \code{NULL} (the default) or the name of the list column containing named +lists of default NA strings to use. These will be applied with the same precedence as the \code{format} argument; i.e., +they will not override formats (other than \code{"default"}) set within the afun. +Cannot be used simultaneously with \code{format}. Cannot be used if \code{formats_var} is \code{NULL}.} } \value{ No return value. diff --git a/tests/testthat/test-lyt-tabulation.R b/tests/testthat/test-lyt-tabulation.R index 78b50cee8c..9db1f7b175 100644 --- a/tests/testthat/test-lyt-tabulation.R +++ b/tests/testthat/test-lyt-tabulation.R @@ -2,10 +2,10 @@ context("Tabulation framework") test_that("summarize_row_groups works with provided funcs", { - l1 <- basic_table() %>% - split_cols_by("ARM") %>% - split_rows_by("RACE") %>% - summarize_row_groups() %>% + l1 <- basic_table() |> + split_cols_by("ARM") |> + split_rows_by("RACE") |> + summarize_row_groups() |> analyze("AGE", mean) expect_silent( @@ -15,7 +15,6 @@ test_that("summarize_row_groups works with provided funcs", { }) - ## this test_that("complex layout works", { lyt <- make_big_lyt() @@ -28,20 +27,17 @@ test_that("complex layout works", { expect_identical(row.names(tab), complx_lyt_rnames) tlvals <- c("Ethnicity", "Factor 2") - lyt2 <- lyt %>% append_topleft(tlvals) + lyt2 <- lyt |> append_topleft(tlvals) tab2 <- build_table(lyt2, rawdat) expect_identical(top_left(tab2), tlvals) }) - - - test_that("existing table in layout works", { - thing2 <- basic_table() %>% - split_cols_by("ARM") %>% + thing2 <- basic_table() |> + split_cols_by("ARM") |> ## add nested column split on SEX with value labels from gend_label - split_cols_by("SEX", "Gender", labels_var = "gend_label") %>% + split_cols_by("SEX", "Gender", labels_var = "gend_label") |> analyze( c("AGE", "AGE"), c("Age Analysis", "Age Analysis Redux"), afun = function(x) list(mean = mean(x), median = median(x)), @@ -52,16 +48,16 @@ test_that("existing table in layout works", { tab2 <- build_table(thing2, rawdat) - thing3 <- basic_table() %>% - split_cols_by("ARM") %>% + thing3 <- basic_table() |> + split_cols_by("ARM") |> ## add nested column split on SEX with value labels from gend_label - split_cols_by("SEX", "Gender", labels_var = "gend_label") %>% - split_rows_by("RACE", "Ethnicity", labels_var = "ethn_label") %>% - summarize_row_groups("RACE", label_fstr = "%s (n)") %>% + split_cols_by("SEX", "Gender", labels_var = "gend_label") |> + split_rows_by("RACE", "Ethnicity", labels_var = "ethn_label") |> + summarize_row_groups("RACE", label_fstr = "%s (n)") |> analyze("AGE", "Age Analysis", afun = function(x) list(mean = mean(x), median = median(x)), format = "xx.xx" - ) %>% + ) |> ## stack an existing table onto the layout and thus the generated table add_existing_table(tab2) @@ -72,10 +68,10 @@ test_that("existing table in layout works", { test_that("Nested splits in column space work", { dat2 <- subset(ex_adsl, SEX %in% c("M", "F")) - tbl2 <- basic_table() %>% - split_cols_by("ARM") %>% - split_cols_by("SEX", split_fun = drop_split_levels) %>% - analyze(c("AGE", "STRATA1")) %>% + tbl2 <- basic_table() |> + split_cols_by("ARM") |> + split_cols_by("SEX", split_fun = drop_split_levels) |> + analyze(c("AGE", "STRATA1")) |> build_table(dat2) mf <- matrix_form(tbl2) @@ -94,15 +90,15 @@ test_that("Nested splits in column space work", { test_that("labelkids parameter works", { - yeslabellyt <- basic_table() %>% - split_cols_by("ARM") %>% - split_cols_by("SEX", "Gender", labels_var = "gend_label") %>% - split_rows_by("RACE", "Ethnicity", labels_var = "ethn_label", child_labels = "visible") %>% - summarize_row_groups("RACE", label_fstr = "%s (n)") %>% + yeslabellyt <- basic_table() |> + split_cols_by("ARM") |> + split_cols_by("SEX", "Gender", labels_var = "gend_label") |> + split_rows_by("RACE", "Ethnicity", labels_var = "ethn_label", child_labels = "visible") |> + summarize_row_groups("RACE", label_fstr = "%s (n)") |> split_rows_by("FACTOR2", "Factor2", split_fun = remove_split_levels("C"), labels_var = "fac2_label", child_labels = "visible" - ) %>% + ) |> analyze( "AGE", "Age Analysis", afun = function(x) list(mean = mean(x), median = median(x)), @@ -118,15 +114,15 @@ test_that("labelkids parameter works", { ) - misslabellyt <- basic_table() %>% - split_cols_by("ARM") %>% - split_cols_by("SEX", "Gender", labels_var = "gend_label") %>% - split_rows_by("RACE", "Ethnicity", labels_var = "ethn_label", child_labels = "default") %>% - summarize_row_groups("RACE", label_fstr = "%s (n)") %>% + misslabellyt <- basic_table() |> + split_cols_by("ARM") |> + split_cols_by("SEX", "Gender", labels_var = "gend_label") |> + split_rows_by("RACE", "Ethnicity", labels_var = "ethn_label", child_labels = "default") |> + summarize_row_groups("RACE", label_fstr = "%s (n)") |> split_rows_by("FACTOR2", "Factor2", split_fun = remove_split_levels("C"), labels_var = "fac2_label", child_labels = "default" - ) %>% + ) |> analyze( "AGE", "Age Analysis", afun = function(x) list(mean = mean(x), median = median(x)), @@ -140,15 +136,15 @@ test_that("labelkids parameter works", { ) - nolabellyt <- basic_table() %>% - split_cols_by("ARM") %>% - split_cols_by("SEX", "Gender", labels_var = "gend_label") %>% - split_rows_by("RACE", "Ethnicity", labels_var = "ethn_label", child_labels = "hidden") %>% - summarize_row_groups("RACE", label_fstr = "%s (n)") %>% + nolabellyt <- basic_table() |> + split_cols_by("ARM") |> + split_cols_by("SEX", "Gender", labels_var = "gend_label") |> + split_rows_by("RACE", "Ethnicity", labels_var = "ethn_label", child_labels = "hidden") |> + summarize_row_groups("RACE", label_fstr = "%s (n)") |> split_rows_by("FACTOR2", "Factor2", split_fun = remove_split_levels("C"), labels_var = "fac2_label", child_labels = "hidden" - ) %>% + ) |> analyze( "AGE", "Age Analysis", afun = function(x) list(mean = mean(x), median = median(x)), @@ -163,15 +159,15 @@ test_that("labelkids parameter works", { c("Caucasian (n)", "mean", "median", "mean") ) - mixedlyt2 <- basic_table() %>% - split_cols_by("ARM") %>% - split_cols_by("SEX", "Gender", labels_var = "gend_label") %>% - split_rows_by("RACE", "Ethnicity", labels_var = "ethn_label", child_labels = "hidden") %>% - summarize_row_groups("RACE", label_fstr = "%s (n)") %>% + mixedlyt2 <- basic_table() |> + split_cols_by("ARM") |> + split_cols_by("SEX", "Gender", labels_var = "gend_label") |> + split_rows_by("RACE", "Ethnicity", labels_var = "ethn_label", child_labels = "hidden") |> + summarize_row_groups("RACE", label_fstr = "%s (n)") |> split_rows_by("FACTOR2", "Factor2", split_fun = remove_split_levels("C"), labels_var = "fac2_label", child_labels = "hidden" - ) %>% + ) |> analyze( "AGE", "Age Analysis", afun = function(x) list(mean = mean(x), median = median(x)), @@ -186,15 +182,15 @@ test_that("labelkids parameter works", { ) - mixedlyt <- basic_table() %>% - split_cols_by("ARM") %>% - split_cols_by("SEX", "Gender", labels_var = "gend_label") %>% - split_rows_by("RACE", "Ethnicity", labels_var = "ethn_label", child_labels = "visible") %>% - summarize_row_groups("RACE", label_fstr = "%s (n)") %>% + mixedlyt <- basic_table() |> + split_cols_by("ARM") |> + split_cols_by("SEX", "Gender", labels_var = "gend_label") |> + split_rows_by("RACE", "Ethnicity", labels_var = "ethn_label", child_labels = "visible") |> + summarize_row_groups("RACE", label_fstr = "%s (n)") |> split_rows_by("FACTOR2", "Factor2", split_fun = remove_split_levels("C"), labels_var = "fac2_label", child_labels = "visible" - ) %>% + ) |> analyze( "AGE", "Age Analysis", afun = function(x) list(mean = mean(x), median = median(x)), @@ -209,16 +205,16 @@ test_that("labelkids parameter works", { ) - varshowlyt <- basic_table() %>% - split_cols_by("ARM") %>% - split_cols_by("SEX", "Gender", labels_var = "gend_label") %>% - split_rows_by("RACE", "Ethnicity", labels_var = "ethn_label") %>% - summarize_row_groups("RACE", label_fstr = "%s (n)") %>% + varshowlyt <- basic_table() |> + split_cols_by("ARM") |> + split_cols_by("SEX", "Gender", labels_var = "gend_label") |> + split_rows_by("RACE", "Ethnicity", labels_var = "ethn_label") |> + summarize_row_groups("RACE", label_fstr = "%s (n)") |> split_rows_by("FACTOR2", "Factor2", split_fun = remove_split_levels("C"), labels_var = "fac2_label", label_pos = "visible" - ) %>% + ) |> analyze( "AGE", "Age Analysis", afun = function(x) list(mean = mean(x), median = median(x)), @@ -234,15 +230,13 @@ test_that("labelkids parameter works", { }) - - test_that("ref_group comparisons work", { skip_if_not_installed("tibble") require(tibble, quietly = TRUE) - blthing <- basic_table() %>% - split_cols_by("ARM", ref_group = "ARM1") %>% - analyze("AGE", show_labels = "hidden") %>% + blthing <- basic_table() |> + split_cols_by("ARM", ref_group = "ARM1") |> + analyze("AGE", show_labels = "hidden") |> analyze("AGE", refcompmean, show_labels = "hidden", table_names = "AGE2") ## function(x) list(mean = mean(x))) @@ -255,19 +249,19 @@ test_that("ref_group comparisons work", { c3 <- bltab[2, 2, drop = TRUE] expect_equivalent(c2 - c1, c3) - lyt <- basic_table() %>% - split_cols_by("ARM") %>% - split_cols_by("SEX", ref_group = "F") %>% - analyze("AGE", mean, show_labels = "hidden") %>% + lyt <- basic_table() |> + split_cols_by("ARM") |> + split_cols_by("SEX", ref_group = "F") |> + analyze("AGE", mean, show_labels = "hidden") |> analyze("AGE", refcompmean, show_labels = "hidden", table_names = "AGE2a" - ) %>% + ) |> split_rows_by("RACE", nested = FALSE, split_fun = drop_split_levels - ) %>% - analyze("AGE", mean, show_labels = "hidden") %>% + ) |> + analyze("AGE", mean, show_labels = "hidden") |> analyze("AGE", refcompmean, show_labels = "hidden", table_names = "AGE2b") bltab2 <- build_table(lyt, DM) @@ -293,12 +287,12 @@ test_that("ref_group comparisons work", { "B_C", "Arms B & C", c("B: Placebo", "C: Combination"), list() ) - l3 <- basic_table(show_colcounts = TRUE) %>% + l3 <- basic_table(show_colcounts = TRUE) |> split_cols_by( "ARM", split_fun = add_combo_levels(combodf, keep_levels = c("A_", "B_C")), ref_group = "A_" - ) %>% + ) |> analyze(c("AGE", "AGE"), afun = list(mean, refcompmean), show_labels = "hidden", table_names = c("AGE1", "AGE2") @@ -313,9 +307,9 @@ test_that("ref_group comparisons work", { }) test_that("missing vars caught", { - misscol <- basic_table() %>% - split_cols_by("ARM") %>% - split_cols_by("SX", "Gender") %>% + misscol <- basic_table() |> + split_cols_by("ARM") |> + split_cols_by("SX", "Gender") |> analyze("AGE", "Age Analysis", afun = function(x) list(mean = mean(x), median = median(x)), format = "xx.xx" @@ -326,10 +320,10 @@ test_that("missing vars caught", { "Split variable [[]SX[]] not found in data being tabulated." ) - missrsplit <- basic_table() %>% - split_cols_by("ARM") %>% - split_cols_by("SEX", "gend_label") %>% - split_rows_by("RACER", "ethn_label") %>% + missrsplit <- basic_table() |> + split_cols_by("ARM") |> + split_cols_by("SEX", "gend_label") |> + split_rows_by("RACER", "ethn_label") |> analyze("AGE", "Age Analysis", afun = function(x) list(mean = mean(x), median = median(x)), format = "xx.xx" @@ -340,10 +334,10 @@ test_that("missing vars caught", { "Split variable [[]RACER[]] not found in data being tabulated." ) - missrsplit <- basic_table() %>% - split_cols_by("ARM") %>% - split_cols_by("SEX", "gend_label") %>% - split_rows_by("RACE", "ethnNA_label") %>% + missrsplit <- basic_table() |> + split_cols_by("ARM") |> + split_cols_by("SEX", "gend_label") |> + split_rows_by("RACE", "ethnNA_label") |> analyze("AGE", "Age Analysis", afun = function(x) list(mean = mean(x), median = median(x)), format = "xx.xx" @@ -354,10 +348,10 @@ test_that("missing vars caught", { "Value label variable [[]ethnNA_label[]] not found in data being tabulated." ) - missavar <- basic_table() %>% - split_cols_by("ARM") %>% - split_cols_by("SEX", labels_var = "gend_label") %>% - split_rows_by("RACE", labels_var = "ethn_label") %>% + missavar <- basic_table() |> + split_cols_by("ARM") |> + split_cols_by("SEX", labels_var = "gend_label") |> + split_rows_by("RACE", labels_var = "ethn_label") |> analyze("AGGE", "Age Analysis", afun = function(x) list(mean = mean(x), median = median(x)), format = "xx.xx" @@ -379,9 +373,9 @@ test_that("error localization works", { in_rows(myrow = 5) } - lyt <- basic_table() %>% - split_rows_by("ARM") %>% - split_rows_by("RACE") %>% + lyt <- basic_table() |> + split_rows_by("ARM") |> + split_rows_by("RACE") |> analyze("BMRKR1", afun = afun) # nolint start expect_error( @@ -396,10 +390,10 @@ test_that("error localization works", { in_rows(val = 5) } - lyt2 <- basic_table() %>% - split_rows_by("ARM") %>% - summarize_row_groups(cfun = cfun) %>% - split_rows_by("RACE") %>% + lyt2 <- basic_table() |> + split_rows_by("ARM") |> + summarize_row_groups(cfun = cfun) |> + split_rows_by("RACE") |> analyze("BMRKR1", afun = mean) expect_error( @@ -411,10 +405,10 @@ test_that("error localization works", { stop("oopsie daisy") } - lyt3 <- basic_table() %>% - split_rows_by("ARM") %>% - summarize_row_groups() %>% - split_rows_by("RACE", split_fun = splfun) %>% + lyt3 <- basic_table() |> + split_rows_by("ARM") |> + summarize_row_groups() |> + split_rows_by("RACE", split_fun = splfun) |> analyze("BMRKR1", afun = mean) # nolint start expect_error( @@ -434,9 +428,9 @@ test_that("cfun args", { .names = labelstr ) } - lyt <- basic_table() %>% - split_cols_by("ARM") %>% - split_rows_by("SEX") %>% + lyt <- basic_table() |> + split_cols_by("ARM") |> + split_rows_by("SEX") |> summarize_row_groups(cfun = cfun1) tbl <- build_table(lyt, rawdat) @@ -454,9 +448,9 @@ test_that("cfun args", { ) ) } - lyt <- basic_table() %>% - split_cols_by("ARM") %>% - split_rows_by("SEX") %>% + lyt <- basic_table() |> + split_cols_by("ARM") |> + split_rows_by("SEX") |> summarize_row_groups("AGE", cfun = cfun2) tbl <- build_table(lyt, rawdat) @@ -467,28 +461,28 @@ test_that("cfun args", { ## regression test for automatically not-nesting ## when a non-analyze comes after an analyze test_that("split under analyze", { - dontnest <- basic_table(show_colcounts = TRUE) %>% - split_cols_by(var = "ARM") %>% - analyze("AGE") %>% - split_rows_by("VAR3") %>% - analyze("AGE") %>% + dontnest <- basic_table(show_colcounts = TRUE) |> + split_cols_by(var = "ARM") |> + analyze("AGE") |> + split_rows_by("VAR3") |> + analyze("AGE") |> build_table(rawdat) expect_equal(nrow(dontnest), 5) }) test_that("label_var works as expected", { - yeslblslyt <- basic_table(show_colcounts = TRUE) %>% - split_cols_by(var = "ARM") %>% - split_rows_by("SEX", labels_var = "gend_label") %>% + yeslblslyt <- basic_table(show_colcounts = TRUE) |> + split_cols_by(var = "ARM") |> + split_rows_by("SEX", labels_var = "gend_label") |> analyze("AGE") yeslbls <- build_table(yeslblslyt, rawdat) expect_identical(row.names(yeslbls)[1], "Male") - nolbls <- basic_table(show_colcounts = TRUE) %>% - split_cols_by(var = "ARM") %>% - split_rows_by("SEX") %>% - analyze("AGE") %>% + nolbls <- basic_table(show_colcounts = TRUE) |> + split_cols_by(var = "ARM") |> + split_rows_by("SEX") |> + analyze("AGE") |> build_table(rawdat) expect_identical(row.names(nolbls)[1], "M") @@ -508,16 +502,16 @@ test_that("label_var works as expected", { test_that("factors with unobserved levels work as expected", { ## default behavior is that empty levels are NOT dropped ## rows - lyt <- basic_table() %>% - split_rows_by("SEX") %>% + lyt <- basic_table() |> + split_rows_by("SEX") |> analyze("AGE") tab <- build_table(lyt, DM) expect_identical(dim(tab), c(8L, 1L)) ## cols - lyt2 <- basic_table() %>% - split_cols_by("SEX") %>% + lyt2 <- basic_table() |> + split_cols_by("SEX") |> analyze("AGE") tab2 <- build_table(lyt2, DM) expect_identical(dim(tab2), c(1L, 4L)) @@ -525,9 +519,9 @@ test_that("factors with unobserved levels work as expected", { test_that(".N_row argument in afun works correctly", { - lyt <- basic_table() %>% - split_cols_by("ARM") %>% - split_rows_by("SEX") %>% + lyt <- basic_table() |> + split_cols_by("ARM") |> + split_rows_by("SEX") |> analyze("AGE", afun = function(x, .N_row) .N_row) tab <- build_table(lyt, rawdat) rows <- collect_leaves(tab) @@ -550,9 +544,9 @@ test_that("extra args works", { } ) - l <- basic_table() %>% - split_cols_by("ARM") %>% - split_cols_by_multivar(c("VALUE", "PCTDIFF")) %>% + l <- basic_table() |> + split_cols_by("ARM") |> + split_cols_by_multivar(c("VALUE", "PCTDIFF")) |> analyze_colvars(afun = colfuns) l @@ -560,9 +554,9 @@ test_that("extra args works", { tbl_noex <- build_table(l, rawdat2) ## one for each different function in colfuns, assigned correctly - l2 <- basic_table() %>% - split_cols_by("ARM") %>% - split_cols_by_multivar(c("VALUE", "PCTDIFF")) %>% + l2 <- basic_table() |> + split_cols_by("ARM") |> + split_cols_by_multivar(c("VALUE", "PCTDIFF")) |> analyze_colvars(afun = colfuns, extra_args = list(list(add = 5), list(cutoff = 100))) @@ -603,9 +597,9 @@ test_that("extra args works", { ) ## single argument passed to all functions - l2b <- basic_table() %>% - split_cols_by("ARM") %>% - split_cols_by_multivar(c("VALUE", "PCTDIFF")) %>% + l2b <- basic_table() |> + split_cols_by("ARM") |> + split_cols_by_multivar(c("VALUE", "PCTDIFF")) |> analyze_colvars(afun = colfuns, extra_args = list(na.rm = FALSE)) tbl_ex2 <- build_table(l2b, rawdat2) @@ -614,7 +608,7 @@ test_that("extra args works", { ## one argument for a single function. - lyt <- basic_table() %>% + lyt <- basic_table() |> analyze("Sepal.Length", afun = function(x, a) { in_rows(mean_a = rcell(mean(x) + a, format = "xx")) }, extra_args = list(a = 1)) @@ -624,7 +618,7 @@ test_that("extra args works", { expect_equal(tbl[1, 1, drop = TRUE], mean(iris$Sepal.Length) + 1) ## two arguments for a single function - lyt2 <- basic_table() %>% + lyt2 <- basic_table() |> analyze("Sepal.Length", afun = function(x, a, b) { in_rows(mean_a = rcell(mean(x) + a + b, format = "xx")) }, extra_args = list(a = 1, b = 3)) @@ -636,13 +630,13 @@ test_that("extra args works", { test_that("Colcounts work correctly", { - lyt1 <- basic_table(show_colcounts = TRUE) %>% + lyt1 <- basic_table(show_colcounts = TRUE) |> analyze("AGE") tbl1 <- build_table(lyt1, DM) expect_identical(col_counts(tbl1), nrow(DM)) - lyt2 <- lyt1 %>% split_cols_by("ARM") + lyt2 <- lyt1 |> split_cols_by("ARM") tbl2 <- build_table(lyt2, DM) expect_identical( @@ -665,16 +659,16 @@ test_that("Colcounts work correctly", { tbl4 <- basic_table( show_colcounts = TRUE, colcount_format = "xx (xx%)" - ) %>% - split_cols_by("ARM") %>% + ) |> + split_cols_by("ARM") |> build_table(DM) mf_tbl4_colcounts <- matrix_form(tbl4)$strings[2, ] expect_identical(mf_tbl4_colcounts, c("", "121 (100%)", "106 (100%)", "129 (100%)")) ## setting col_counts in build_table turns on visibility for leaf col counts - lyt5 <- basic_table() %>% - split_cols_by("ARM") %>% - split_cols_by("STRATA1") %>% + lyt5 <- basic_table() |> + split_cols_by("ARM") |> + split_cols_by("STRATA1") |> analyze("AGE") tbl5 <- build_table(lyt5, ex_adsl, col_counts = 1:9) @@ -701,9 +695,9 @@ test_that("content extra args for summarize_row_groups works", { ) } ## specify single set of args for all columns - l <- basic_table() %>% - split_cols_by("ARM") %>% - split_rows_by("SEX") %>% + l <- basic_table() |> + split_cols_by("ARM") |> + split_rows_by("SEX") |> summarize_row_groups( cfun = sfun, extra_args = list(a = 9) @@ -718,9 +712,9 @@ test_that("content extra args for summarize_row_groups works", { ) ## specify different arg for each column - l2 <- basic_table() %>% - split_cols_by("ARM") %>% - split_rows_by("SEX") %>% + l2 <- basic_table() |> + split_cols_by("ARM") |> + split_rows_by("SEX") |> summarize_row_groups( cfun = sfun, extra_args = list( @@ -739,9 +733,9 @@ test_that("content extra args for summarize_row_groups works", { ## specify arg for only one col - l3 <- basic_table() %>% - split_cols_by("ARM") %>% - split_rows_by("SEX") %>% + l3 <- basic_table() |> + split_cols_by("ARM") |> + split_rows_by("SEX") |> summarize_row_groups( cfun = sfun, extra_args = list(list(a = 9)) @@ -757,8 +751,8 @@ test_that("content extra args for summarize_row_groups works", { ## works on root split - l4 <- basic_table() %>% - split_cols_by("ARM") %>% + l4 <- basic_table() |> + split_cols_by("ARM") |> summarize_row_groups( cfun = sfun, extra_args = list(a = 9) @@ -778,9 +772,9 @@ test_that(".df_row analysis function argument works", { rcell(c(nrow(.df_row), .N_col), format = "(xx.x, xx.x)") } - l <- basic_table() %>% - split_cols_by("ARM") %>% - split_rows_by("SEX") %>% + l <- basic_table() |> + split_cols_by("ARM") |> + split_rows_by("SEX") |> analyze("AGE", afun) tbl <- build_table(l, rawdat) @@ -818,9 +812,9 @@ test_that("analysis function arguments work with NA rows in data", { b_var = factor(c(NA, NA, "x", "x", "y", "x", "x", "y", "x", NA)) ) - l <- basic_table() %>% - add_overall_col("all pts") %>% - split_rows_by("a_var") %>% + l <- basic_table() |> + add_overall_col("all pts") |> + split_rows_by("a_var") |> analyze("b_var", afun = afun) tbl <- build_table(l, df) @@ -846,8 +840,8 @@ test_that("analyze_colvars inclNAs works", { b = c(1, NA) ) - l <- basic_table() %>% - split_cols_by_multivar(c("a", "b")) %>% + l <- basic_table() |> + split_cols_by_multivar(c("a", "b")) |> analyze_colvars(afun = length, inclNAs = TRUE) # We expect: @@ -860,8 +854,8 @@ test_that("analyze_colvars inclNAs works", { res1 <- cell_values(tab) expect_equal(ans, res1) - l2 <- basic_table() %>% - split_cols_by_multivar(c("a", "b")) %>% + l2 <- basic_table() |> + split_cols_by_multivar(c("a", "b")) |> analyze_colvars(afun = length, inclNAs = FALSE) ans2 <- lapply(test, function(x) sum(!is.na(x))) @@ -881,12 +875,12 @@ test_that("analyze_colvars works generally", { d = 4, e = 5 ) - l1 <- basic_table() %>% - split_cols_by_multivar(c("a", "b", "c", "d")) %>% + l1 <- basic_table() |> + split_cols_by_multivar(c("a", "b", "c", "d")) |> analyze_colvars(afun = identity) tab1 <- build_table(l1, test) - l2 <- basic_table() %>% - split_cols_by_multivar(c("a", "b", "c", "d", "e")) %>% + l2 <- basic_table() |> + split_cols_by_multivar(c("a", "b", "c", "d", "e")) |> analyze_colvars(afun = identity) tab2 <- build_table(l2, test) @@ -897,9 +891,9 @@ test_that("analyze_colvars works generally", { function(x, labelstr) 8 ) - l3 <- basic_table() %>% - split_cols_by_multivar(c("a", "b", "c", "d")) %>% - summarize_row_groups(cfun = colfuns, format = "xx") %>% + l3 <- basic_table() |> + split_cols_by_multivar(c("a", "b", "c", "d")) |> + summarize_row_groups(cfun = colfuns, format = "xx") |> analyze_colvars(afun = identity) tab3 <- build_table(l3, test) expect_identical( @@ -911,9 +905,9 @@ test_that("analyze_colvars works generally", { c(summary = "My Summary Row") ) - l4 <- basic_table() %>% - split_cols_by_multivar(c("a", "b", "c", "d")) %>% - summarize_row_groups() %>% + l4 <- basic_table() |> + split_cols_by_multivar(c("a", "b", "c", "d")) |> + summarize_row_groups() |> analyze_colvars(afun = identity) tab4 <- build_table(l4, test) ## this broke before due to formatting missmatches @@ -922,10 +916,10 @@ test_that("analyze_colvars works generally", { expect_identical(obj_format(rws4[[1]]), "xx (xx.x%)") expect_identical(obj_format(rws4[[2]]), NULL) - l5 <- basic_table() %>% - split_cols_by("ARM") %>% - split_cols_by_multivar(c("AGE", "BMRKR1")) %>% - split_rows_by("RACE") %>% + l5 <- basic_table() |> + split_cols_by("ARM") |> + split_cols_by_multivar(c("AGE", "BMRKR1")) |> + split_rows_by("RACE") |> summarize_row_groups( cfun = list( function(x, labelstr) "first fun", @@ -946,8 +940,8 @@ test_that("analyze_colvars works generally", { ## single column in split_cols_by_multivar and analyze_colvars - one_col_lyt <- basic_table() %>% - split_cols_by_multivar(vars = "Sepal.Width") %>% + one_col_lyt <- basic_table() |> + split_cols_by_multivar(vars = "Sepal.Width") |> analyze_colvars(afun = mean) one_col_tbl <- build_table(one_col_lyt, iris) @@ -958,8 +952,8 @@ test_that("analyze_colvars works generally", { # na_str argument works test$d <- NA - l2 <- basic_table() %>% - split_cols_by_multivar(c("a", "b", "c", "d")) %>% + l2 <- basic_table() |> + split_cols_by_multivar(c("a", "b", "c", "d")) |> analyze_colvars(afun = mean, na_str = "no data") tab2 <- build_table(l2, test) expect_identical( @@ -971,10 +965,10 @@ test_that("analyze_colvars works generally", { test_that("alt_counts_df works", { minidm <- DM[1, ] - lyt <- basic_table(show_colcounts = TRUE) %>% - split_cols_by("ARM") %>% - split_rows_by("SEX") %>% - summarize_row_groups() %>% + lyt <- basic_table(show_colcounts = TRUE) |> + split_cols_by("ARM") |> + split_rows_by("SEX") |> + summarize_row_groups() |> analyze("AGE") tbl <- build_table(lyt, DM, minidm) @@ -995,24 +989,23 @@ test_that("alt_counts_df works", { }) - test_that("deeply nested and uneven column layouts work", { - lyt <- basic_table(show_colcounts = TRUE) %>% - split_cols_by(var = "ARM") %>% - split_cols_by("STRATA1") %>% - split_cols_by("STRATA2") %>% - add_overall_col("All Patients") %>% + lyt <- basic_table(show_colcounts = TRUE) |> + split_cols_by(var = "ARM") |> + split_cols_by("STRATA1") |> + split_cols_by("STRATA2") |> + add_overall_col("All Patients") |> analyze("AGE") tbl <- build_table(lyt, ex_adsl) ## printing machinery works str <- toString(tbl) expect_identical(ncol(tbl), 19L) - lyt2 <- basic_table(show_colcounts = TRUE) %>% - split_cols_by("ARM") %>% - split_cols_by("STRATA1") %>% - split_cols_by("STRATA2", nested = FALSE) %>% - add_overall_col("All Patients") %>% + lyt2 <- basic_table(show_colcounts = TRUE) |> + split_cols_by("ARM") |> + split_cols_by("STRATA1") |> + split_cols_by("STRATA2", nested = FALSE) |> + add_overall_col("All Patients") |> analyze("AGE") tbl2 <- build_table(lyt2, ex_adsl) @@ -1022,19 +1015,18 @@ test_that("deeply nested and uneven column layouts work", { }) - test_that("topleft label position works", { - lyt <- basic_table(show_colcounts = TRUE) %>% - split_cols_by("ARM") %>% + lyt <- basic_table(show_colcounts = TRUE) |> + split_cols_by("ARM") |> ## add nested column split on SEX with value lables from gend_label - split_cols_by("SEX", "Gender", labels_var = "gend_label") %>% + split_cols_by("SEX", "Gender", labels_var = "gend_label") |> ## No row splits have been introduced, so this adds ## a root split and puts summary content on it labelled Overall (N) - ## add_colby_total(label = "All") %>% - ## summarize_row_groups(label = "Overall (N)", format = "(N=xx)") %>% + ## add_colby_total(label = "All") |> + ## summarize_row_groups(label = "Overall (N)", format = "(N=xx)") |> ## add a new subtable that splits on RACE, value labels from ethn_label - split_rows_by("RACE", "Ethnicity", labels_var = "ethn_label", label_pos = "topleft") %>% - summarize_row_groups("RACE", label_fstr = "%s (n)") %>% + split_rows_by("RACE", "Ethnicity", labels_var = "ethn_label", label_pos = "topleft") |> + summarize_row_groups("RACE", label_fstr = "%s (n)") |> ## ## Add nested row split within Race categories for FACTOR2 ## using a split function that excludes level C @@ -1043,9 +1035,9 @@ test_that("topleft label position works", { split_fun = remove_split_levels("C"), labels_var = "fac2_label", label_pos = "topleft" - ) %>% + ) |> ## Add count summary within FACTOR2 categories - summarize_row_groups("FACTOR2") %>% + summarize_row_groups("FACTOR2") |> ## Add analysis/data rows by analyzing AGE variable ## Note afun is a function that returns 2 values in a named list ## this will create 2 data rows @@ -1062,12 +1054,12 @@ test_that("topleft label position works", { ) ## https://github.com/insightsengineering/rtables/issues/657 - tab2 <- basic_table() %>% - split_cols_by("ARM") %>% - split_rows_by("RACE", split_fun = drop_split_levels, split_label = "RACE", label_pos = "hidden", page_by = TRUE) %>% - split_rows_by("STRATA1", split_fun = drop_split_levels, split_label = "Strata", label_pos = "topleft") %>% - split_rows_by("SEX", split_fun = drop_split_levels, split_label = "Gender", label_pos = "topleft") %>% - analyze("AGE", mean, var_labels = "Age", format = "xx.xx") %>% + tab2 <- basic_table() |> + split_cols_by("ARM") |> + split_rows_by("RACE", split_fun = drop_split_levels, split_label = "RACE", label_pos = "hidden", page_by = TRUE) |> + split_rows_by("STRATA1", split_fun = drop_split_levels, split_label = "Strata", label_pos = "topleft") |> + split_rows_by("SEX", split_fun = drop_split_levels, split_label = "Gender", label_pos = "topleft") |> + analyze("AGE", mean, var_labels = "Age", format = "xx.xx") |> build_table(DM) ptab <- paginate_table(tab2) @@ -1077,16 +1069,16 @@ test_that("topleft label position works", { ) ## https://github.com/insightsengineering/rtables/issues/651 - lyt2 <- basic_table(show_colcounts = TRUE) %>% - split_cols_by("ARM") %>% - split_rows_by("SEX", split_fun = drop_split_levels, page_by = TRUE) %>% + lyt2 <- basic_table(show_colcounts = TRUE) |> + split_cols_by("ARM") |> + split_rows_by("SEX", split_fun = drop_split_levels, page_by = TRUE) |> analyze("AGE") expect_error(build_table(lyt2, DM[0, ]), "Page-by split resulted in zero") - lyt3 <- basic_table(show_colcounts = TRUE) %>% - split_cols_by("ARM") %>% - split_rows_by("SEX", split_fun = drop_split_levels, page_by = TRUE) %>% - split_rows_by("COUNTRY", split_fun = drop_split_levels, page_by = TRUE) %>% + lyt3 <- basic_table(show_colcounts = TRUE) |> + split_cols_by("ARM") |> + split_rows_by("SEX", split_fun = drop_split_levels, page_by = TRUE) |> + split_rows_by("COUNTRY", split_fun = drop_split_levels, page_by = TRUE) |> analyze("AGE") baddm <- DM @@ -1100,10 +1092,10 @@ test_that("topleft label position works", { expect_error(build_table(lyt3, baddm), error_msg, fixed = TRUE) # Similar error if the problematic split is done on alt_counts_df (related to #651) - lyt4 <- basic_table(show_colcounts = TRUE) %>% - split_cols_by("ARM") %>% - split_rows_by("SEX", split_fun = drop_split_levels, page_by = TRUE) %>% - split_rows_by("COUNTRY", split_fun = drop_split_levels, page_by = TRUE) %>% + lyt4 <- basic_table(show_colcounts = TRUE) |> + split_cols_by("ARM") |> + split_rows_by("SEX", split_fun = drop_split_levels, page_by = TRUE) |> + split_rows_by("COUNTRY", split_fun = drop_split_levels, page_by = TRUE) |> analyze("AGE", afun = function(x, .alt_df) mean(x)) error_msg2 <- paste0( @@ -1114,7 +1106,6 @@ test_that("topleft label position works", { }) - test_that(".spl_context works in content and analysis functions", { ageglobmean <- mean(DM$AGE) cfun <- function(df, labelstr, .spl_context) { @@ -1146,13 +1137,13 @@ test_that(".spl_context works in content and analysis functions", { } - lyt <- basic_table() %>% - split_cols_by("ARM") %>% - split_cols_by("SEX", split_fun = keep_split_levels(c("M", "F"))) %>% - split_rows_by("COUNTRY", split_fun = keep_split_levels(c("CHN", "USA"))) %>% - summarize_row_groups() %>% - split_rows_by("STRATA1") %>% - summarize_row_groups(cfun = cfun) %>% + lyt <- basic_table() |> + split_cols_by("ARM") |> + split_cols_by("SEX", split_fun = keep_split_levels(c("M", "F"))) |> + split_rows_by("COUNTRY", split_fun = keep_split_levels(c("CHN", "USA"))) |> + summarize_row_groups() |> + split_rows_by("STRATA1") |> + summarize_row_groups(cfun = cfun) |> analyze("AGE", afun = afun) tab <- build_table(lyt, DM) @@ -1189,14 +1180,14 @@ test_that(".spl_context works in content and analysis functions", { test_that("cut functions work", { ctnames <- c("young", "medium", "old") ## split_cols_by_cuts - l <- basic_table() %>% - split_cols_by("ARM") %>% + l <- basic_table() |> + split_cols_by("ARM") |> split_cols_by_cuts("AGE", split_label = "Age", cuts = c(0, 25, 35, 1000), cutlabels = ctnames - ) %>% - analyze(c("BMRKR2", "STRATA2")) %>% + ) |> + analyze(c("BMRKR2", "STRATA2")) |> append_topleft("counts") tbl <- build_table(l, ex_adsl) @@ -1217,15 +1208,15 @@ test_that("cut functions work", { c("counts", rep(ctnames, 3)) ) - lcm <- basic_table() %>% - split_cols_by("ARM") %>% + lcm <- basic_table() |> + split_cols_by("ARM") |> split_cols_by_cuts("AGE", split_label = "Age", cuts = c(0, 25, 35, 1000), cutlabels = c("young", "young+medium", "all"), cumulative = TRUE - ) %>% - analyze(c("BMRKR2", "STRATA2")) %>% + ) |> + analyze(c("BMRKR2", "STRATA2")) |> append_topleft("counts") tblcm <- build_table(lcm, ex_adsl) @@ -1237,14 +1228,14 @@ test_that("cut functions work", { unname(unlist(cell_values(tblcm, medpth, bpth))) ) ## split_rows_by_cuts - l2 <- basic_table() %>% - split_cols_by("ARM") %>% + l2 <- basic_table() |> + split_cols_by("ARM") |> split_rows_by_cuts("AGE", split_label = "Age", cuts = c(0, 25, 35, 1000), cutlabels = ctnames - ) %>% - analyze("BMRKR2") %>% + ) |> + analyze("BMRKR2") |> append_topleft("counts") @@ -1258,14 +1249,14 @@ test_that("cut functions work", { ) - l2cm <- basic_table() %>% - split_cols_by("ARM") %>% + l2cm <- basic_table() |> + split_cols_by("ARM") |> split_rows_by_cuts("AGE", split_label = "Age", cuts = c(0, 25, 35, 1000), cutlabels = ctnames, cumulative = TRUE - ) %>% - analyze("BMRKR2") %>% + ) |> + analyze("BMRKR2") |> append_topleft("counts") @@ -1287,28 +1278,28 @@ test_that("cut functions work", { ) # split_cols_by_quartiles - l3 <- basic_table() %>% - split_cols_by("ARM") %>% - split_cols_by_cutfun("AGE") %>% ## (quartiles("AGE", split_label = "Age") %>% - analyze("BMRKR2") %>% + l3 <- basic_table() |> + split_cols_by("ARM") |> + split_cols_by_cutfun("AGE") |> ## (quartiles("AGE", split_label = "Age") |> + analyze("BMRKR2") |> append_topleft("counts") tbl3 <- build_table(l3, ex_adsl) - l3b <- basic_table() %>% - split_cols_by("ARM") %>% - split_cols_by_cuts("AGE", cuts = rtables:::qtile_cuts(ex_adsl$AGE)) %>% - analyze("BMRKR2") %>% + l3b <- basic_table() |> + split_cols_by("ARM") |> + split_cols_by_cuts("AGE", cuts = rtables:::qtile_cuts(ex_adsl$AGE)) |> + analyze("BMRKR2") |> append_topleft("counts") tbl3b <- build_table(l3b, ex_adsl) expect_identical(tbl3, tbl3b) - l3c <- basic_table() %>% - split_cols_by("ARM") %>% - split_cols_by_quartiles("AGE") %>% - analyze("BMRKR2") %>% + l3c <- basic_table() |> + split_cols_by("ARM") |> + split_cols_by_quartiles("AGE") |> + analyze("BMRKR2") |> append_topleft("counts") tbl3c <- build_table(l3c, ex_adsl) @@ -1319,18 +1310,18 @@ test_that("cut functions work", { ) - l3c_cm <- basic_table() %>% - split_cols_by("ARM") %>% - split_cols_by_quartiles("AGE", cumulative = TRUE) %>% - analyze("BMRKR2") %>% + l3c_cm <- basic_table() |> + split_cols_by("ARM") |> + split_cols_by_quartiles("AGE", cumulative = TRUE) |> + analyze("BMRKR2") |> append_topleft("counts") tbl3c_cm <- build_table(l3c_cm, ex_adsl) # split_rows_by_quartiles - l4 <- basic_table(show_colcounts = TRUE) %>% - split_cols_by("ARM") %>% - split_rows_by_quartiles("AGE", split_label = "Age") %>% - analyze("BMRKR2") %>% + l4 <- basic_table(show_colcounts = TRUE) |> + split_cols_by("ARM") |> + split_rows_by_quartiles("AGE", split_label = "Age") |> + analyze("BMRKR2") |> append_topleft(c("Age Quartiles", " Counts BMRKR2")) tbl4 <- build_table(l4, ex_adsl) @@ -1347,10 +1338,10 @@ test_that("cut functions work", { valslst4[names(valslst3)] ) - l4cm <- basic_table(show_colcounts = TRUE) %>% - split_cols_by("ARM") %>% - split_rows_by_quartiles("AGE", split_label = "Age", cumulative = TRUE) %>% - analyze("BMRKR2") %>% + l4cm <- basic_table(show_colcounts = TRUE) |> + split_cols_by("ARM") |> + split_rows_by_quartiles("AGE", split_label = "Age", cumulative = TRUE) |> + analyze("BMRKR2") |> append_topleft(c("Age Cumulative Quartiles", " Counts BMRKR2")) tbl4cm <- build_table(l4cm, ex_adsl) @@ -1376,9 +1367,9 @@ test_that("empty factor levels represented correctly when ref group is set", { ) - tbl <- basic_table() %>% - split_cols_by("grp", ref_group = "a") %>% - analyze("val") %>% + tbl <- basic_table() |> + split_cols_by("grp", ref_group = "a") |> + analyze("val") |> build_table(df) expect_identical(ncol(tbl), 2L) @@ -1393,8 +1384,8 @@ test_that("error on empty level of splitting variable", { mydf2 <- mydf mydf2$x <- factor(mydf2$x) - lyt1 <- basic_table() %>% - split_cols_by("x") %>% + lyt1 <- basic_table() |> + split_cols_by("x") |> analyze("y") expect_error( build_table(lyt1, mydf), @@ -1405,8 +1396,8 @@ test_that("error on empty level of splitting variable", { "Got empty string level in splitting variable x" ) - lyt2 <- basic_table() %>% - split_rows_by("x") %>% + lyt2 <- basic_table() |> + split_rows_by("x") |> analyze("y") expect_error( @@ -1431,16 +1422,16 @@ test_that("error when afun gives differing numbers of rows is informative", { my_broken_afun <- afunconst() - lyt <- basic_table() %>% - split_cols_by("ARM") %>% + lyt <- basic_table() |> + split_cols_by("ARM") |> analyze("AGE", my_broken_afun) expect_error(build_table(lyt, DM), "Number of rows generated by analysis function do not match across all columns.") }) test_that("warning when same name siblings", { - lyt <- basic_table() %>% - analyze("AGE", mean) %>% + lyt <- basic_table() |> + analyze("AGE", mean) |> analyze("AGE", mean, var_labels = "AGE2") expect_warning( @@ -1466,7 +1457,7 @@ test_that("error when inset < 0 or non-number", { }) test_that("error when ref_group value not a level of var when using split_cols_by", { - lyt <- basic_table() %>% + lyt <- basic_table() |> split_cols_by("ARM", ref_group = "test_level") expect_error( tbl <- build_table(lyt, DM), @@ -1495,7 +1486,6 @@ test_that("counts_wpcts returns error correctly", { }) - test_that("qtable works", { nice_comp_table <- function(t1, t2) { expect_identical(row_paths(t1), row_paths(t2)) @@ -1512,42 +1502,42 @@ test_that("qtable works", { nm <- tail(.spl_context$value, 1) rcell(NROW(df), label = nm) } - t0b <- basic_table(show_colcounts = TRUE) %>% - analyze(names(ex_adsl)[1], count) %>% + t0b <- basic_table(show_colcounts = TRUE) |> + analyze(names(ex_adsl)[1], count) |> build_table(ex_adsl) nice_comp_table(t0, t0b) t1 <- qtable(ex_adsl, row_vars = "ARM") - t1b <- basic_table(show_colcounts = TRUE) %>% - split_rows_by("ARM", child_labels = "hidden") %>% - analyze(names(ex_adsl)[1], count_use_nms) %>% - append_topleft("count") %>% + t1b <- basic_table(show_colcounts = TRUE) |> + split_rows_by("ARM", child_labels = "hidden") |> + analyze(names(ex_adsl)[1], count_use_nms) |> + append_topleft("count") |> build_table(ex_adsl) nice_comp_table(t1, t1b) t2 <- qtable(ex_adsl, col_vars = "ARM") - t2b <- basic_table(show_colcounts = TRUE) %>% - split_cols_by("ARM", child_labels = "hidden") %>% - analyze(names(ex_adsl)[1], count) %>% + t2b <- basic_table(show_colcounts = TRUE) |> + split_cols_by("ARM", child_labels = "hidden") |> + analyze(names(ex_adsl)[1], count) |> build_table(ex_adsl) nice_comp_table(t2, t2b) t3 <- qtable(ex_adsl, row_vars = "SEX", col_vars = "ARM") - t3b <- basic_table(show_colcounts = TRUE) %>% - split_cols_by("ARM", child_labels = "hidden") %>% - split_rows_by("SEX", child_labels = "hidden", split_fun = drop_split_levels) %>% - analyze(names(ex_adsl)[1], count_use_nms) %>% - append_topleft("count") %>% + t3b <- basic_table(show_colcounts = TRUE) |> + split_cols_by("ARM", child_labels = "hidden") |> + split_rows_by("SEX", child_labels = "hidden", split_fun = drop_split_levels) |> + analyze(names(ex_adsl)[1], count_use_nms) |> + append_topleft("count") |> build_table(ex_adsl) nice_comp_table(t3, t3b) t4 <- qtable(ex_adsl, row_vars = c("COUNTRY", "SEX"), col_vars = c("ARM", "STRATA1")) - t4b <- basic_table(show_colcounts = TRUE) %>% - split_cols_by("ARM", child_labels = "hidden") %>% - split_cols_by("STRATA1") %>% - split_rows_by("COUNTRY", split_fun = drop_split_levels) %>% - split_rows_by("SEX", split_fun = drop_split_levels, child_labels = "hidden") %>% - analyze(names(ex_adsl)[1], count_use_nms) %>% - append_topleft("count") %>% + t4b <- basic_table(show_colcounts = TRUE) |> + split_cols_by("ARM", child_labels = "hidden") |> + split_cols_by("STRATA1") |> + split_rows_by("COUNTRY", split_fun = drop_split_levels) |> + split_rows_by("SEX", split_fun = drop_split_levels, child_labels = "hidden") |> + analyze(names(ex_adsl)[1], count_use_nms) |> + append_topleft("count") |> build_table(ex_adsl) nice_comp_table(t4, t4b) @@ -1559,21 +1549,21 @@ test_that("qtable works", { mean_use_nm <- function(x, .spl_context, ...) { rcell(mean(x, ...), format = "xx.xx", label = tail(.spl_context$value, 1)) } - t5b <- basic_table(show_colcounts = TRUE) %>% - split_cols_by("ARM", split_fun = drop_split_levels, child_labels = "hidden") %>% - split_cols_by("STRATA1", split_fun = drop_split_levels) %>% - split_rows_by("COUNTRY", split_fun = drop_split_levels) %>% - split_rows_by("SEX", child_labels = "hidden", split_fun = drop_split_levels) %>% - analyze("AGE", mean_use_nm) %>% - append_topleft("AGE - mean") %>% + t5b <- basic_table(show_colcounts = TRUE) |> + split_cols_by("ARM", split_fun = drop_split_levels, child_labels = "hidden") |> + split_cols_by("STRATA1", split_fun = drop_split_levels) |> + split_rows_by("COUNTRY", split_fun = drop_split_levels) |> + split_rows_by("SEX", child_labels = "hidden", split_fun = drop_split_levels) |> + analyze("AGE", mean_use_nm) |> + append_topleft("AGE - mean") |> build_table(ex_adsl) nice_comp_table(t5, t5b) t6 <- qtable(ex_adsl, row_vars = "SEX", col_vars = "ARM", avar = "AGE", afun = summary_list) - t6b <- basic_table(show_colcounts = TRUE) %>% - split_cols_by("ARM", split_fun = drop_split_levels, child_labels = "hidden") %>% - split_rows_by("SEX", split_fun = drop_split_levels) %>% - analyze("AGE", summary_list2) %>% - append_topleft("AGE - summary_list") %>% + t6b <- basic_table(show_colcounts = TRUE) |> + split_cols_by("ARM", split_fun = drop_split_levels, child_labels = "hidden") |> + split_rows_by("SEX", split_fun = drop_split_levels) |> + analyze("AGE", summary_list2) |> + append_topleft("AGE - summary_list") |> build_table(ex_adsl) nice_comp_table(t6, t6b) @@ -1585,11 +1575,11 @@ test_that("qtable works", { rcell(suppressWarnings(range(x)), label = tail(.spl_context$value, 1), format = "xx.x / xx.x") } - t7b <- basic_table(show_colcounts = TRUE) %>% - split_cols_by("ARM", split_fun = drop_split_levels, child_labels = "hidden") %>% - split_rows_by("SEX", child_labels = "hidden", split_fun = drop_split_levels) %>% - analyze("AGE", range_use_nms) %>% - append_topleft("AGE - range") %>% + t7b <- basic_table(show_colcounts = TRUE) |> + split_cols_by("ARM", split_fun = drop_split_levels, child_labels = "hidden") |> + split_rows_by("SEX", child_labels = "hidden", split_fun = drop_split_levels) |> + analyze("AGE", range_use_nms) |> + append_topleft("AGE - range") |> build_table(ex_adsl) nice_comp_table(t7, t7b) @@ -1604,14 +1594,14 @@ test_that("qtable works", { col_vars = c("ARM"), avar = "AGE", afun = summary_list, summarize_groups = TRUE ) - t9b <- basic_table(show_colcounts = TRUE) %>% - split_cols_by("ARM", split_fun = drop_split_levels, child_labels = "hidden") %>% - split_rows_by("COUNTRY", split_fun = drop_split_levels) %>% - summarize_row_groups() %>% - split_rows_by("SEX", split_fun = drop_split_levels) %>% - summarize_row_groups() %>% - analyze("AGE", summary_list2) %>% - append_topleft("AGE - summary_list") %>% + t9b <- basic_table(show_colcounts = TRUE) |> + split_cols_by("ARM", split_fun = drop_split_levels, child_labels = "hidden") |> + split_rows_by("COUNTRY", split_fun = drop_split_levels) |> + summarize_row_groups() |> + split_rows_by("SEX", split_fun = drop_split_levels) |> + summarize_row_groups() |> + analyze("AGE", summary_list2) |> + append_topleft("AGE - summary_list") |> build_table(ex_adsl) nice_comp_table(t9, t9b) @@ -1674,8 +1664,8 @@ test_that("qtable works", { ## https://github.com/insightsengineering/rtables/issues/671 test_that("problematic labels are caught and give informative error message", { - lyt <- basic_table() %>% - split_rows_by("Species") %>% + lyt <- basic_table() |> + split_rows_by("Species") |> analyze("Sepal.Length", afun = make_afun(simple_analysis, .labels = list(Mean = "this is {test}"))) expect_error(build_table(lyt, iris), "Labels cannot contain [{] or [}] due to") @@ -1694,8 +1684,8 @@ test_that("No superfluous warning when ref group is set with custom split fun", ) } - lyt <- basic_table() %>% - split_cols_by("Species", ref_group = "virginica", split_fun = make_split_fun(post = list(reorder_facets))) %>% + lyt <- basic_table() |> + split_cols_by("Species", ref_group = "virginica", split_fun = make_split_fun(post = list(reorder_facets))) |> analyze("Sepal.Length") expect_silent(build_table(lyt, iris)) }) @@ -1719,18 +1709,18 @@ test_that("path uniqueness/sibling name uniqueness is enforced correctly", { } ## analyze and then split on same variable - lyt1 <- basic_table() %>% - analyze("STRATA1") %>% - split_rows_by("STRATA1") %>% - analyze("AGE") %>% + lyt1 <- basic_table() |> + analyze("STRATA1") |> + split_rows_by("STRATA1") |> + analyze("AGE") |> analyze("STRATA1", nested = FALSE) tbl1 <- build_and_check_row_paths(lyt1, TRUE) - lyt1b <- basic_table() %>% - analyze("STRATA1") %>% - split_rows_by("STRATA1", parent_name = "STRATA1[2]") %>% - analyze("AGE") %>% + lyt1b <- basic_table() |> + analyze("STRATA1") |> + split_rows_by("STRATA1", parent_name = "STRATA1[2]") |> + analyze("AGE") |> analyze("STRATA1", table_names = "STRATA1[3]", nested = FALSE) tbl1b <- build_and_check_row_paths(lyt1b, FALSE) @@ -1744,7 +1734,7 @@ test_that("path uniqueness/sibling name uniqueness is enforced correctly", { ) } - lyt2 <- basic_table() %>% + lyt2 <- basic_table() |> analyze("AGE", afun = bad_acfun) tbl2 <- build_and_check_row_paths(lyt2, TRUE) @@ -1754,15 +1744,580 @@ test_that("path uniqueness/sibling name uniqueness is enforced correctly", { ## containing table, probably shouldn't because generally content tables aren't ## named, since you use the @content path element to get them, but for now ## we leave this behavior and match it in the uniqify case. - lyt3 <- basic_table() %>% - analyze(c("STRATA1", "AGE")) %>% + lyt3 <- basic_table() |> + analyze(c("STRATA1", "AGE")) |> analyze(c("STRATA1", "AGE"), nested = FALSE) tbl3 <- build_and_check_row_paths(lyt3, TRUE) - lyt3b <- basic_table() %>% - analyze(c("STRATA1", "AGE")) %>% + lyt3b <- basic_table() |> + analyze(c("STRATA1", "AGE")) |> analyze(c("STRATA1", "AGE"), nested = FALSE, parent_name = "ma_STRATA1_AGE[2]") tbl3b <- build_and_check_row_paths(lyt3b, FALSE) expect_identical(tbl3, tbl3b) }) + + +## used in both formats_var and format var list test sets below +fmts_afun <- function(x, .formats = NULL) { + in_rows( + n = sum(!is.na(x)), + median = median(x, na.rm = TRUE), + "mean (sd)" = c(mean(x, na.rm = TRUE), sd(x, na.rm = TRUE)), + "missing_val" = NA, + .formats = .formats + ) +} + + +## tern style row naming partial match support +factor_count_prepend_var <- function(x, .var) { + stopifnot(is.factor(x)) + vals <- as.list(table(x)) + + in_rows(.list = vals, .names = paste0(.var, names(vals)), .labels = levels(x)) +} + +alt_fmts <- list(list( + median = "xx.x", + "mean (sd)" = "xx.xx (xx.xxx)", + missing_val = "xx", + STRATA1 = "xx" +)) + +crp_fmts <- list(list( + median = "xx.", + "mean (sd)" = "xx.x (xx.xx)", + missing_val = "xx", + STRATA1 = "N=xx" +)) + +iga_fmts <- list(list( + median = "xx.xx", + "mean (sd)" = "xx. (xx.x)", + missing_val = "xx", + STRATA1 = "xx.x" +)) + + +test_that("formats_var works in analyze()", { + adlb <- ex_adlb + + adlb$formats <- alt_fmts + adlb$formats[adlb$PARAMCD == "CRP"] <- crp_fmts + + adlb$formats[adlb$PARAMCD == "IGA"] <- iga_fmts + + adlb$na_strs <- list(list()) + adlb$na_strs[adlb$PARAMCD == "CRP"] <- list(list(missing_val = "n/a")) + adlb$na_strs[adlb$PARAMCD == "IGA"] <- list(list(missing_val = "-")) + + + ## works without also specifying na_strs_var + lyt <- basic_table() |> + split_cols_by("ARM") |> + split_rows_by("PARAMCD") |> + analyze("AVAL", fmts_afun, formats_var = "formats") + + tbl <- build_table(lyt, adlb) + + mpf <- matrix_form(tbl) + + mpf_fmts_real <- mf_formats(mpf)[-1, -1] # no row labs, no col labs + + mpf_fmts_exp <- matrix( + c( + "-", "xx", unlist(alt_fmts[[1]][1:3]), ## no STRATA1 here and below + "-", "xx", unlist(crp_fmts[[1]][1:3]), + "-", "xx", unlist(iga_fmts[[1]][1:3]) + ), + nrow = nrow(mpf_fmts_real), + ncol = ncol(mpf_fmts_real) + ) + + expect_identical( + mpf_fmts_real, + mpf_fmts_exp + ) + + fmtcells <- get_formatted_cells(tbl) + + expect_equal( + fmtcells[c(3:4, 8:9, 13:14), 1], + c( + "49.6", "49.91 (8.098)", + "50", "50.2 (8.61)", + "49.69", "50 (7.8)" + ) + ) + + ## can use formats_var with na_str specified the old way + lyta <- basic_table() |> + split_cols_by("ARM") |> + split_rows_by("PARAMCD") |> + analyze("AVAL", + fmts_afun, + formats_var = "formats", + na_str = "global na cha cha cha" + ) + + tbla <- build_table(lyta, adlb) + + expect_true( + all(get_formatted_cells(tbla)[c(5, 10, 15), ] == "global na cha cha cha") + ) + + lytb <- basic_table() |> + split_cols_by("ARM") |> + split_rows_by("PARAMCD") |> + analyze("AVAL", + fmts_afun, + formats_var = "formats", + na_str = list("global na cha cha cha") + ) + + tblb <- build_table(lytb, adlb) + + ## works when also specifying na_strs_var + lyt2 <- basic_table() |> + split_cols_by("ARM") |> + split_rows_by("PARAMCD") |> + analyze("AVAL", fmts_afun, formats_var = "formats", na_strs_var = "na_strs") + + tbl2 <- build_table(lyt2, adlb) + + fmtcells2 <- get_formatted_cells(tbl2) + expect_true(all(fmtcells2[5, ] == "NA")) + expect_true(all(fmtcells2[10, ] == "n/a")) + expect_true(all(fmtcells2[15, ] == "-")) + + adlb_b <- adlb + adlb_b$na_strs <- ifelse(adlb_b$PARAMCD == "ALT", list(list("NA")), + ifelse(adlb_b$PARAMCD == "CRP", + list(list("n/a")), + list(list("-")) + ) + ) + + tbl2b <- build_table(lyt2, adlb_b) + ## tabletree objects not identical for some reason but... + expect_identical( + get_formatted_cells(tbl2), + get_formatted_cells(tbl2b) + ) + + ## precendence and interaction with .formats use in in_rows + + lyt3 <- basic_table() |> + split_cols_by("ARM") |> + split_rows_by("PARAMCD") |> + analyze("AVAL", fmts_afun, + formats_var = "formats", + extra_args = list( + .formats = list( + n = "xx", + median = "xx.xxx", + "mean (sd)" = "xx.x - xx.x", + missing_val = "xx" + ) + ) + ) + + tbl3 <- build_table(lyt3, adlb) + + lyt3b <- basic_table() |> + split_cols_by("ARM") |> + split_rows_by("PARAMCD") |> + analyze("AVAL", fmts_afun, + extra_args = list( + .formats = list( + n = "xx", + median = "xx.xxx", + "mean (sd)" = "xx.x - xx.x", + missing_val = "xx" + ) + ) + ) + + tbl3b <- build_table(lyt3, adlb) + + expect_identical(tbl3, tbl3b) + + lyt3c <- basic_table() |> + split_cols_by("ARM") |> + split_rows_by("PARAMCD") |> + analyze("AVAL", fmts_afun, + formats_var = "formats", + extra_args = list( + .formats = list( + n = "default", + median = "default", + "mean (sd)" = "default", + missing_val = "default" + ) + ) + ) + + tbl3c <- build_table(lyt3c, adlb) + + expect_identical(get_formatted_cells(tbl), get_formatted_cells(tbl3c)) + + + lyt4 <- basic_table() |> + split_cols_by("ARM") |> + split_rows_by("PARAMCD") |> + analyze("STRATA1", factor_count_prepend_var, formats_var = "formats") + + tbl4 <- build_table(lyt4, adlb) + + fmtcells4 <- get_formatted_cells(tbl4) + + alt_a_cnt <- with(adlb, sum(ARM == "A: Drug X" & PARAMCD == "ALT" & STRATA1 == "A")) + crp_b_cnt <- with(adlb, sum(ARM == "B: Placebo" & PARAMCD == "CRP" & STRATA1 == "B")) + iga_c_cnt <- with(adlb, sum(ARM == "C: Combination" & PARAMCD == "IGA" & STRATA1 == "C")) + expect_identical(fmtcells4[2, 1], format_value(alt_a_cnt, "xx")) + expect_identical(fmtcells4[7, 2], format_value(crp_b_cnt, "N=xx")) + expect_identical(fmtcells4[12, 3], format_value(iga_c_cnt, "xx.x")) + + + ## most specific for multiple partial matches + + adlb2 <- adlb + ## This should do nothing because STRATA1 is an exact match + adlb2$formats <- lapply(adlb2$formats, function(x) c(x, list(STRAT = "xx.xxx"))) + + tbl4b <- build_table(lyt4, adlb2) + expect_identical(tbl4, tbl4b) + + ## remove perfect match to make sure partial match kicks in + adlb3 <- adlb2 + adlb3$formats <- lapply(adlb2$formats, function(x) { + x[["STRATA1"]] <- NULL + x$STRAT <- "xx.x" + x + }) + tbl4c <- build_table(lyt4, adlb3) + expect_equal( + get_formatted_cells(tbl4c[-c(1, 5, 9), ]), + matrix( + vapply( + unlist(cell_values(tbl4c)), + format_value, + format = "xx.x", + "" + ), + ncol = 3, + byrow = TRUE + ) + ) + + adlb4 <- adlb3 + ## this should do nothing because STRAT is a better partial match + adlb4$formats <- lapply(adlb3$formats, function(x) c(list(STR = "xx"), x)) + tbl4d <- build_table(lyt4, adlb4) + expect_identical(tbl4c, tbl4d) + + adlb5 <- adlb + adlb5$formats <- list(list()) + adlb5$na_strs <- list(list()) + tbl4e <- build_table(lyt4, adlb5) + fmtcells4e <- get_formatted_cells(tbl4e) + expect_equal( + get_formatted_cells(tbl4e[-c(1, 5, 9), ]), + matrix( + vapply( + unlist(cell_values(tbl4e)), + format_value, + format = "xx", + "" + ), + ncol = 3, + byrow = TRUE + ) + ) + + adlb6 <- adlb + adlb6$formats <- list(list("xx.x")) + tbl4f <- build_table(lyt4, adlb6) + expect_identical(tbl4c, tbl4f) +}) + +test_that("New format as list of formats for diff vars in analyze works", { + ## ugh apparently simple_analysis applies a format!!!!!!!!!!!! x.x + + my_stupid_afun <- function(x) { + if (is.factor(x)) { + vallst <- lapply(table(x), rcell) + names(vallst) <- levels(x) + } else if (is(x, "numeric")) { + vallst <- list(Mean = rcell(mean(x, na.rm = TRUE))) + } else { + stop("no") + } + in_rows(.list = vallst) + } + + ## basic case: list of individual formats, one for each var + lyt <- basic_table() |> + analyze(c("AGE", "BMRKR1", "STRATA1"), + afun = my_stupid_afun, + format = list( + AGE = "xx.x", + BMRKR1 = "xx.xx", + STRATA1 = "N=xx" + ) + ) + + tbl <- build_table(lyt, ex_adsl) + + age_mean <- mean(ex_adsl$AGE, na.rm = TRUE) + bmrkr1_mean <- mean(ex_adsl$BMRKR1, na.rm = TRUE) + strata1_counts <- table(ex_adsl$STRATA1) + sex_counts <- table(ex_adsl$SEX) + exp <- matrix( + c( + "", + format_value(age_mean, "xx.x"), + "", + format_value(bmrkr1_mean, "xx.xx"), + "", + vapply(strata1_counts, format_value, format = "N=xx", "") + ), + ncol = 1 + ) + + expect_equal(get_formatted_cells(tbl), exp) + + ## preserve old stanky behavior I for some reason thought was a good idea + ## list of formats applied to analysis of all vars and taken in order + ## with recycling (!!!!) + ## ... Past me was a genius of unparalleled insight /s + + lyt_old <- basic_table() |> + analyze(c("AGE", "BMRKR1", "STRATA1", "SEX"), + afun = my_stupid_afun, + format = list( + "xx.x", + "xx.xx", + "N=xx" + ) + ) + + tbl_old <- build_table(lyt_old, ex_adsl) + + fmtvec <- c("xx.x", "xx.xx", "N=xx") + ## supppress **very reasonable** warnings about bad recycling + exp_old <- suppressWarnings(matrix( + ncol = 1, + c( + "", + format_value(age_mean, "xx.x"), + "", + format_value(bmrkr1_mean, "xx.x"), + "", + mapply(format_value, + x = strata1_counts, + format = fmtvec + ), + "", + mapply(format_value, + x = sex_counts, + format = fmtvec + ) # !! insane recycling behavior. what?!? + ) + )) + + ## confirmed this behavior on main before merge. ugh + expect_identical(get_formatted_cells(tbl_old), exp_old) + + + ## even newer extra hotness: list of formats for each var + + ## beware extra layer of listiness between list column case and this one! + varfmts <- list( + AGE = alt_fmts[[1]], + BMRKR1 = crp_fmts[[1]], + STRATA1 = crp_fmts[[1]], + SEX = iga_fmts[[1]] + ) + + ## part one, single afun exact matches + + lyt2 <- basic_table() |> + analyze(c("AGE", "BMRKR1"), + afun = fmts_afun, + format = varfmts + ) + + tbl2 <- build_table(lyt2, ex_adsl) + + fmtcells2 <- get_formatted_cells(tbl2) + + expect_identical( + fmtcells2, + matrix( + ncol = 1, + c( + "", + format_value(sum(!is.na(ex_adsl$AGE)), "xx"), + format_value(median(ex_adsl$AGE), "xx.x"), + format_value(c(mean(ex_adsl$AGE), sd(ex_adsl$AGE)), "xx.xx (xx.xxx)"), + "NA", + "", + format_value(sum(!is.na(ex_adsl$BMRKR1)), "xx"), + format_value(median(ex_adsl$BMRKR1), "xx."), + format_value( + c(mean(ex_adsl$BMRKR1), sd(ex_adsl$BMRKR1)), + "xx.x (xx.xx)" + ), + "NA" + ) + ) + ) + + + lyt2a <- basic_table() |> + analyze(c("AGE", "BMRKR1"), + afun = fmts_afun, + format = varfmts, + na_str = "eh? what?" + ) + + tbl2a <- build_table(lyt2a, ex_adsl) + + fmtcells2a <- get_formatted_cells(tbl2a) + expect_true(all(fmtcells2a[c(5, 10), 1] == "eh? what?")) + expect_equal(fmtcells2[-c(5, 10), ], fmtcells2a[-c(5, 10), ]) + + lyt2b <- basic_table() |> + analyze( + c("AGE", "BMRKR1"), + afun = fmts_afun, + format = list( + AGE = function(x, ...) "what?", + BMRKR1 = function(x, ...) "nah" + ), + na_str = list( + AGE = "-", + BMRKR1 = "X" + ) + ) + + tbl2b <- build_table(lyt2b, ex_adsl) + + fmtcells2b <- get_formatted_cells(tbl2b) + expect_equal( + fmtcells2b, + matrix( + ncol = 1, + c( + "", + rep("what?", 3), + "-", + "", + rep("nah", 3), + "X" + ) + ) + ) + + lyt2c <- basic_table() |> + analyze( + c("AGE", "BMRKR1"), + afun = fmts_afun, + format = list( + AGE = list(function(x, ...) "what?"), + BMRKR1 = list(function(x, ...) "nah") + ), + na_str = list( + AGE = "-", + BMRKR1 = "X" + ) + ) + + tbl2c <- build_table(lyt2c, ex_adsl) + expect_identical(tbl2b, tbl2c) + + ## part two, single afun partial matches + + lyt3 <- basic_table() |> + analyze(c("STRATA1", "SEX"), + afun = factor_count_prepend_var, + format = varfmts + ) + + tbl3 <- build_table(lyt3, ex_adsl) + fmtcells3 <- get_formatted_cells(tbl3) + + expect_identical( + fmtcells3, + matrix( + ncol = 1, + c( + "", + vapply(strata1_counts, format_value, format = "N=xx", ""), + "", + vapply(sex_counts, format_value, format = "xx", "") + ) + ) + ) + + ## part 3 multiple afuns + + lyt4 <- basic_table() |> + analyze(c("AGE", "BMRKR1", "STRATA1", "SEX"), + afun = list( + fmts_afun, + fmts_afun, + factor_count_prepend_var, + factor_count_prepend_var + ), + format = varfmts + ) + + tbl4 <- build_table(lyt4, ex_adsl) + + fmtcells4 <- get_formatted_cells(tbl4) + + expect_identical( + fmtcells4, + rbind(fmtcells2, fmtcells3) + ) + + ## does it work with "the functions"? + + bad_fmt_factory <- function(val) function(x, ...) val + + lyt5 <- basic_table() |> + analyze(c("AGE", "BMRKR1", "STRATA1", "SEX"), + afun = list( + fmts_afun, + fmts_afun, + factor_count_prepend_var, + factor_count_prepend_var + ), + format = list( + AGE = bad_fmt_factory("AGE"), + BMRKR1 = bad_fmt_factory("BMRKR1"), + STRATA1 = bad_fmt_factory("STRATA1"), + SEX = bad_fmt_factory("SEX") + ) + ) + + tbl5 <- build_table(lyt5, ex_adsl) + + fmtcells5 <- get_formatted_cells(tbl5) + + expect_identical( + fmtcells5, + matrix( + ncol = 1, + c( + c("", rep("AGE", 3), "NA"), + c("", rep("BMRKR1", 3), "NA"), + c("", rep("STRATA1", 3)), + c("", rep("SEX", 4)) + ) + ) + ) +})