diff --git a/DESCRIPTION b/DESCRIPTION index 33c8789d8..be4d7fe25 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -77,6 +77,7 @@ Collate: 'argument_conventions.R' 'as_html.R' 'utils.R' + 'nesting_impl.R' 'colby_constructors.R' 'compare_rtables.R' 'format_rcell.R' diff --git a/NAMESPACE b/NAMESPACE index 2555f7c42..14b869e75 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -105,6 +105,7 @@ export(export_as_txt) export(facet_colcount) export(find_degen_struct) export(format_rcell) +export(get_anchor_list) export(get_formatted_cells) export(has_force_pag) export(head) @@ -269,6 +270,7 @@ exportMethods(coltree) exportMethods(content_table) exportMethods(dim) exportMethods(facet_colcount) +exportMethods(get_anchor_list) exportMethods(has_force_pag) exportMethods(head) exportMethods(horizontal_sep) diff --git a/NEWS.md b/NEWS.md index 02aacd54f..10945b556 100644 --- a/NEWS.md +++ b/NEWS.md @@ -20,9 +20,13 @@ * Added vignette: Guided Tour (Advanced) - (stub) `TableTree` Objects - (stub) Accessing Table Values @gmbecker * Added vignette: Guided Tour (Advanced) - (stub) `TableTree` Objects - (stub) Custom Scoring Functions For Sorting @gmbecker * Added vignette: Guided Tour (Advanced) - (stub) `TableTree` Objects - (stub) Custom Pruning Functions @gmbecker - + * Added `at_sibling` parameter to `split_rows_by*` and `analyze` functions, enabling placement of a new layout directive as a direct sibling of a previously declared split or analysis @gmbecker + * Added `get_anchor_list()` function for inspecting the available sibling anchors in an existing layout @gmbecker + * `label_pos` now accepts `"default"` as a value, which resolves to `"visible"` when `at_sibling` is non-`NULL` and `"hidden"` otherwise @gmbecker + ### Bug Fixes * `indent_mod<-` `RowsVerticalSection` method now correctly recycles length 1 values @gmbecker + * Fixed `uniqify_child_names` emitting messages ending in a literal `FALSE` due to passing `call. = FALSE` to `message()`, which does not accept that argument @gmbecker ## rtables 0.6.15 diff --git a/R/00tabletrees.R b/R/00tabletrees.R index 4ef47e7fb..cd5dfcf8d 100644 --- a/R/00tabletrees.R +++ b/R/00tabletrees.R @@ -27,9 +27,9 @@ check_ok_label <- function(lbl, multi_ok = FALSE) { } valid_lbl_pos <- c("default", "visible", "hidden", "topleft") -.labelkids_helper <- function(charval) { +.labelkids_helper <- function(charval, na_ok = TRUE) { ret <- switch(charval, - "default" = NA, + "default" = if (na_ok) NA else FALSE, "visible" = TRUE, "hidden" = FALSE, "topleft" = FALSE, @@ -466,7 +466,7 @@ MultiVarSplit <- function(vars, colcount_format = NULL) { check_ok_label(split_label) ## no topleft allowed - label_pos <- match.arg(label_pos, label_pos_values[-3]) + label_pos <- match.arg(label_pos, label_pos_values[-4]) child_labels <- match.arg(child_labels) if (length(vars) == 1 && grepl(":", vars)) { vars <- strsplit(vars, ":")[[1]] @@ -1656,8 +1656,7 @@ uniqify_child_names <- function(kidlst) { paste(val_to_fix, " -> {", paste(c(val_to_fix, newnms), collapse = ", "), "}]\n"), " To control table names use split_rows_by*(, parent_name =.) or ", " analyze(., table_names = .) when analyzing a single variable, or ", - "analyze(., parent_name = .) when analyzing multiple variables in a single call.", - call. = FALSE + "analyze(., parent_name = .) when analyzing multiple variables in a single call." ) names(kidlst)[inds] <- newnms } @@ -1914,6 +1913,10 @@ TableTree <- function(kids = list(), ## a pre-existing TableTree/ElementaryTable. ## This is used for add_existing_table in colby_constructors.R +split_or_splitvectree <- function(object) { + is(object, "Split") || is(object, "SplitVectorTree") +} + setClass("SplitVector", contains = "list", validity = function(object) { @@ -1922,8 +1925,8 @@ setClass("SplitVector", } else { lst <- NULL } - all(sapply(head(object, -1), is, "Split")) && - (is.null(lst) || is(lst, "Split") || is(lst, "VTableNodeInfo")) + all(sapply(head(object, -1), split_or_splitvectree)) && + (is.null(lst) || split_or_splitvectree(lst) || is(lst, "VTableNodeInfo")) } ) @@ -1936,7 +1939,28 @@ SplitVector <- function(x = NULL, new("SplitVector", lst) } +setClass("SplitVectorTree", + contains = "list", + validity = function(object) { + all(vapply(object, function(x) is(x, "SplitVector") || is(x, "SplitVectorTree"), TRUE)) + } +) + +SplitVectorTree <- function(x = NULL, + ..., + lst = list(...)) { + if (is.null(x)) { + xlst <- NULL + } else { + xlst <- list(x) + } + new("SplitVectorTree", c(xlst, lst)) +} + avar_noneorlast <- function(vec) { + if (is(vec, "SplitVectorTree")) { + return(all(sapply(vec, avar_noneorlast))) + } if (!is(vec, "SplitVector")) { return(FALSE) } diff --git a/R/argument_conventions.R b/R/argument_conventions.R index 60258e6a9..7b64edfb2 100644 --- a/R/argument_conventions.R +++ b/R/argument_conventions.R @@ -150,6 +150,10 @@ gen_args <- function(df, alt_counts_df, spl, pos, tt, tr, verbose, colwidths, ob #' to the *split* or *group of sibling analyses*, for `split_rows_by*` and #' `analyze*` when analyzing more than one variable, respectively. Ignored when #' analyzing a single variable. +#' @param at_sibling (`character(1)` or `NULL`)\cr If non-null, a preceding +#' split or analyze to anchor this instruction to as a direct sibling. Cannot +#' select an instruction that is downstream of a point where a previously used +#' anchor (See Nesting Anchor Resolution for details). #' #' @inherit gen_args return #' @@ -165,7 +169,8 @@ 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, formats_var, na_strs_var) { + colcount_format, parent_name, formats_var, na_strs_var, + at_sibling) { NULL } diff --git a/R/colby_constructors.R b/R/colby_constructors.R index d54c927bf..a3e77151e 100644 --- a/R/colby_constructors.R +++ b/R/colby_constructors.R @@ -1,4 +1,7 @@ -label_pos_values <- c("hidden", "visible", "topleft") +## default means hidden if it is by itself but visible if it has +## direct siblings due to intermediate nesting (of itself or a subsequent +## split) +label_pos_values <- c("default", "hidden", "visible", "topleft") #' @name internal_methods #' @rdname int_methods @@ -20,257 +23,6 @@ setMethod("c", "SplitVector", function(x, ...) { SplitVector(lst = tmp) }) -## split_rows and split_cols are "recursive method stacks" which follow -## the general pattern of accept object -> call add_*_split on slot of object -> -## update object with value returned from slot method, return object. -## -## Thus each of the methods is idempotent, returning an updated object of the -## same class it was passed. The exception for idempotency is the NULL method -## which constructs a PreDataTableLayouts object with the specified split in the -## correct place. - -## The cascading (by class) in this case is as follows for the row case: -## PreDataTableLayouts -> PreDataRowLayout -> SplitVector -#' @param cmpnd_fun (`function`)\cr intended for internal use. -#' @param pos (`numeric(1)`)\cr intended for internal use. -#' @param spl (`Split`)\cr the split. -#' -#' @rdname int_methods -setGeneric( - "split_rows", - function(lyt = NULL, spl, pos, - cmpnd_fun = AnalyzeMultiVars) { - standardGeneric("split_rows") - } -) - -#' @rdname int_methods -setMethod("split_rows", "NULL", function(lyt, spl, pos, cmpnd_fun = AnalyzeMultiVars) { - lifecycle::deprecate_warn( - when = "0.3.8", - what = I("split_rows(NULL)"), - with = "basic_table()", - details = "Initializing layouts via `NULL` is no longer supported." - ) - rl <- PreDataRowLayout(SplitVector(spl)) - cl <- PreDataColLayout() - PreDataTableLayouts(rlayout = rl, clayout = cl) -}) - -#' @rdname int_methods -setMethod( - "split_rows", "PreDataRowLayout", - function(lyt, spl, pos, cmpnd_fun = AnalyzeMultiVars) { - stopifnot(pos > 0 && pos <= length(lyt) + 1) - tmp <- if (pos <= length(lyt)) { - split_rows(lyt[[pos]], spl, pos, cmpnd_fun) - } else { - if (pos != 1 && has_force_pag(spl)) { - stop("page_by splits cannot have top-level siblings", - call. = FALSE - ) - } - SplitVector(spl) - } - lyt[[pos]] <- tmp - lyt - } -) - -is_analysis_spl <- function(spl) { - is(spl, "VAnalyzeSplit") || is(spl, "AnalyzeMultiVars") -} - -## note "pos" is ignored here because it is for which nest-chain -## spl should be placed in, NOIT for where in that chain it should go -#' @rdname int_methods -setMethod( - "split_rows", "SplitVector", - function(lyt, spl, pos, cmpnd_fun = AnalyzeMultiVars) { - ## if(is_analysis_spl(spl) && - ## is_analysis_spl(last_rowsplit(lyt))) { - ## return(cmpnd_last_rowsplit(lyt, spl, cmpnd_fun)) - ## } - - if (has_force_pag(spl) && length(lyt) > 0 && !has_force_pag(lyt[[length(lyt)]])) { - stop("page_by splits cannot be nested within non-page_by splits", - call. = FALSE - ) - } - tmp <- c(unclass(lyt), spl) - SplitVector(lst = tmp) - } -) - -#' @rdname int_methods -setMethod( - "split_rows", "PreDataTableLayouts", - function(lyt, spl, pos) { - rlyt <- rlayout(lyt) - addtl <- FALSE - split_label <- obj_label(spl) - if ( - is(spl, "Split") && ## exclude existing tables that are being tacked in - identical(label_position(spl), "topleft") && - length(split_label) == 1 && nzchar(split_label) - ) { - addtl <- TRUE - ## label_position(spl) <- "hidden" - } - - rlyt <- split_rows(rlyt, spl, pos) - rlayout(lyt) <- rlyt - if (addtl) { - lyt <- append_topleft(lyt, indent_string(split_label, .tl_indent(lyt))) - } - lyt - } -) - -#' @rdname int_methods -setMethod( - "split_rows", "ANY", - function(lyt, spl, pos) { - stop("nope. can't add a row split to that (", class(lyt), "). contact the maintaner.") - } -) - -## cmpnd_last_rowsplit ===== - -#' @rdname int_methods -#' -#' @param constructor (`function`)\cr constructor function. -setGeneric("cmpnd_last_rowsplit", function(lyt, spl, constructor) standardGeneric("cmpnd_last_rowsplit")) - -#' @rdname int_methods -setMethod("cmpnd_last_rowsplit", "NULL", function(lyt, spl, constructor) { - stop("no existing splits to compound with. contact the maintainer") # nocov -}) - -#' @rdname int_methods -setMethod( - "cmpnd_last_rowsplit", "PreDataRowLayout", - function(lyt, spl, constructor) { - pos <- length(lyt) - tmp <- cmpnd_last_rowsplit(lyt[[pos]], spl, constructor) - lyt[[pos]] <- tmp - lyt - } -) -#' @rdname int_methods -setMethod( - "cmpnd_last_rowsplit", "SplitVector", - function(lyt, spl, constructor) { - pos <- length(lyt) - lst <- lyt[[pos]] - tmp <- if (is(lst, "CompoundSplit")) { - spl_payload(lst) <- c( - .uncompound(spl_payload(lst)), - .uncompound(spl) - ) - obj_name(lst) <- make_ma_name(spl = lst) - lst - ## XXX never reached because AnalzyeMultiVars inherits from - ## CompoundSplit??? - } else { - constructor(.payload = list(lst, spl)) - } - lyt[[pos]] <- tmp - lyt - } -) - -#' @rdname int_methods -setMethod( - "cmpnd_last_rowsplit", "PreDataTableLayouts", - function(lyt, spl, constructor) { - rlyt <- rlayout(lyt) - rlyt <- cmpnd_last_rowsplit(rlyt, spl, constructor) - rlayout(lyt) <- rlyt - lyt - } -) -#' @rdname int_methods -setMethod( - "cmpnd_last_rowsplit", "ANY", - function(lyt, spl, constructor) { - stop( - "nope. can't do cmpnd_last_rowsplit to that (", - class(lyt), "). contact the maintaner." - ) - } -) - -## split_cols ==== - -#' @rdname int_methods -setGeneric( - "split_cols", - function(lyt = NULL, spl, pos) { - standardGeneric("split_cols") - } -) - -#' @rdname int_methods -setMethod("split_cols", "NULL", function(lyt, spl, pos) { - lifecycle::deprecate_warn( - when = "0.3.8", - what = I("split_cols(NULL)"), - with = "basic_table()", - details = "Initializing layouts via `NULL` is no longer supported." - ) - cl <- PreDataColLayout(SplitVector(spl)) - rl <- PreDataRowLayout() - PreDataTableLayouts(rlayout = rl, clayout = cl) -}) - -#' @rdname int_methods -setMethod( - "split_cols", "PreDataColLayout", - function(lyt, spl, pos) { - stopifnot(pos > 0 && pos <= length(lyt) + 1) - tmp <- if (pos <= length(lyt)) { - split_cols(lyt[[pos]], spl, pos) - } else { - SplitVector(spl) - } - - lyt[[pos]] <- tmp - lyt - } -) - -#' @rdname int_methods -setMethod( - "split_cols", "SplitVector", - function(lyt, spl, pos) { - tmp <- c(lyt, spl) - SplitVector(lst = tmp) - } -) - -#' @rdname int_methods -setMethod( - "split_cols", "PreDataTableLayouts", - function(lyt, spl, pos) { - rlyt <- lyt@col_layout - rlyt <- split_cols(rlyt, spl, pos) - lyt@col_layout <- rlyt - lyt - } -) - -#' @rdname int_methods -setMethod( - "split_cols", "ANY", - function(lyt, spl, pos) { - stop( - "nope. can't add a col split to that (", class(lyt), - "). contact the maintaner." - ) - } -) - # Constructors ===== ## Pipe-able functions to add the various types of splits to the current layout @@ -420,7 +172,7 @@ setMethod( function(lyt) { sum(vapply(lyt, function(x) label_position(x) == "topleft", TRUE)) - 1L } -) ## length(lyt) - 1L) +) ## length(lyt) - 1L) .tl_indent <- function(lyt, nested = TRUE) { if (!nested) { @@ -438,6 +190,44 @@ setMethod( #' #' @inheritSection custom_split_funs Custom Splitting Function Details #' +#' @section Nesting Anchor Resolution: +#' +#' When `nested` is `TRUE`, `at_sibling` allows you to set a *nesting +#' anchor* that your new `split_rows_by*` or `analyze*` directive +#' should be placed as a sibling to. The lookup for this anchor +#' occurs *only in the currently active top-level nesting stack*, +#' meaning the directives that have occurred since +#' the last split or analysis with `nested == FALSE`. +#' +#' Furthermore, resolution occurs against the first element of each +#' arm of a branching point caused by any previous uses of +#' `at_sibling` but *only descends into the last arm*. +#' +#' So for example if our previous layout was generated via: +#' +#' ``` +#' lyt <- basic_table() |> +#' split_rows_by("SEX") |> +#' analyze("AGE") |> +#' split_rows_by("BMRKR2", nested = FALSE) |> +#' split_rows_by("RACE") |> +#' analyze("AGE") |> +#' split_rows_by("SEX", at_sibling = "RACE") |> +#' analyze("BMRKR1") +#' ``` +#' +#' The eligible anchor points would be `"BMRKR2"`, `"RACE"`, `"SEX"` +#' and `"BMRKR1"`. `"AGE"` is masked by the branching caused by +#' anchoring our `SEX` split on `RACE`. +#' +#' Finally, while `at_sibling` does support de-duplication of +#' `"[i]"` anchors, it does so **within the set of available +#' anchors**, which can be counter-intuitive. It is strongly suggested +#' that the `parent_name` and `table_names` argument(s) of +#' `split_rows_by*` and `analyze` be used to prevent the need for +#' this. `at_sibling` will resolve to table names overridden in this +#' manner. +#' #' @note #' If `var` is a factor with empty unobserved levels and `labels_var` is specified, it must also be a factor #' with the same number of levels as `var`. Currently the error that occurs when this is not the case is not very @@ -511,8 +301,9 @@ split_rows_by <- function(lyt, format = NULL, na_str = NA_character_, nested = TRUE, + at_sibling = NULL, child_labels = c("default", "visible", "hidden"), - label_pos = "hidden", + label_pos = if (!is.null(at_sibling)) "visible" else "default", indent_mod = 0L, page_by = FALSE, page_prefix = split_label, @@ -534,8 +325,8 @@ split_rows_by <- function(lyt, split_name = parent_name ) - pos <- next_rpos(lyt, nested) - ret <- split_rows(lyt, spl, pos) + pos <- next_rpos(lyt, nested, at_sibling = at_sibling) + ret <- split_rows(lyt, spl, pos, at_sibling = at_sibling) ret } @@ -612,6 +403,8 @@ split_cols_by_multivar <- function(lyt, #' #' @inherit split_rows_by return #' +#' @inheritSection split_rows_by Nesting Anchor Resolution +#' #' @seealso [split_rows_by()] for typical row splitting, and [split_cols_by_multivar()] to perform the same type of #' split on a column basis. #' @@ -635,6 +428,7 @@ split_rows_by_multivar <- function(lyt, format = NULL, na_str = NA_character_, nested = TRUE, + at_sibling = NULL, child_labels = c("default", "visible", "hidden"), indent_mod = 0L, section_div = NA_character_, @@ -651,8 +445,8 @@ split_rows_by_multivar <- function(lyt, extra_args = extra_args, split_name = parent_name ) - pos <- next_rpos(lyt, nested) - split_rows(lyt, spl, pos) + pos <- next_rpos(lyt, nested, at_sibling = at_sibling) + split_rows(lyt, spl, pos, at_sibling = at_sibling) } #' Split on static or dynamic cuts of the data @@ -774,6 +568,7 @@ split_cols_by_cuts <- function(lyt, var, cuts, } #' @export +#' @inheritSection split_rows_by Nesting Anchor Resolution #' @rdname varcuts split_rows_by_cuts <- function(lyt, var, cuts, cutlabels = NULL, @@ -782,8 +577,9 @@ split_rows_by_cuts <- function(lyt, var, cuts, format = NULL, na_str = NA_character_, nested = TRUE, + at_sibling = NULL, cumulative = FALSE, - label_pos = "hidden", + label_pos = if (!is.null(at_sibling)) "visible" else "default", section_div = NA_character_) { label_pos <- match.arg(label_pos, label_pos_values) ## VarStaticCutSplit( @@ -799,8 +595,8 @@ split_rows_by_cuts <- function(lyt, var, cuts, ) ## if(cumulative) ## spl = as(spl, "CumulativeCutSplit") - pos <- next_rpos(lyt, nested) - split_rows(lyt, spl, pos) + pos <- next_rpos(lyt, nested, at_sibling = at_sibling) + split_rows(lyt, spl, pos, at_sibling = at_sibling) } #' @export @@ -874,11 +670,12 @@ split_rows_by_quartiles <- function(lyt, var, split_label = var, format = NULL, na_str = NA_character_, nested = TRUE, + at_sibling = NULL, child_labels = c("default", "visible", "hidden"), extra_args = list(), cumulative = FALSE, indent_mod = 0L, - label_pos = "hidden", + label_pos = if (!is.null(at_sibling)) "visible" else "default", section_div = NA_character_) { split_rows_by_cutfun( lyt = lyt, @@ -897,6 +694,7 @@ split_rows_by_quartiles <- function(lyt, var, split_label = var, ) }, nested = nested, + at_sibling = at_sibling, child_labels = child_labels, extra_args = extra_args, cumulative = cumulative, @@ -904,18 +702,6 @@ split_rows_by_quartiles <- function(lyt, var, split_label = var, label_pos = label_pos, section_div = section_div ) - - ## label_pos <- match.arg(label_pos, label_pos_values) - ## spl = VarDynCutSplit(var, split_label, cutfun = qtile_cuts, - ## cutlabelfun = , - ## split_format = format, - ## child_labels = child_labels, - ## extra_args = extra_args, - ## cumulative = cumulative, - ## indent_mod = indent_mod, - ## label_pos = label_pos) - ## pos = next_rpos(lyt, nested) - ## split_rows(lyt, spl, pos) } qtile_cuts <- function(x) { @@ -940,11 +726,12 @@ split_rows_by_cutfun <- function(lyt, var, format = NULL, na_str = NA_character_, nested = TRUE, + at_sibling = NULL, child_labels = c("default", "visible", "hidden"), extra_args = list(), cumulative = FALSE, indent_mod = 0L, - label_pos = "hidden", + label_pos = if (!is.null(at_sibling)) "visible" else "default", section_div = NA_character_) { label_pos <- match.arg(label_pos, label_pos_values) child_labels <- match.arg(child_labels) @@ -961,8 +748,8 @@ split_rows_by_cutfun <- function(lyt, var, section_div = section_div, split_name = parent_name ) - pos <- next_rpos(lyt, nested) - split_rows(lyt, spl, pos) + pos <- next_rpos(lyt, nested, at_sibling = at_sibling) + split_rows(lyt, spl, pos, at_sibling = at_sibling) } #' .spl_context within analysis and split functions @@ -1156,6 +943,7 @@ NULL #' machinery. These are listed and described in [additional_fun_params]. #' #' @inherit split_cols_by return +#' @inheritSection split_rows_by Nesting Anchor Resolution #' #' @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()]. @@ -1199,6 +987,7 @@ analyze <- function(lyt, na_str = NA_character_, na_strs_var = NULL, nested = TRUE, + at_sibling = NULL, ## can't name this na_rm symbol conflict with possible afuns!! inclNAs = FALSE, extra_args = list(), @@ -1272,12 +1061,13 @@ analyze <- function(lyt, na_strs_var = na_strs_var ) - if (nested && (is(last_rowsplit(lyt), "VAnalyzeSplit") || is(last_rowsplit(lyt), "AnalyzeMultiVars"))) { + is_analyze_spl <- is(last_rowsplit(lyt), "VAnalyzeSplit") || is(last_rowsplit(lyt), "AnalyzeMultiVars") + if (nested && is.null(at_sibling) && is_analyze_spl) { cmpnd_last_rowsplit(lyt, spl, AnalyzeMultiVars) } else { ## analysis compounding now done in split_rows - pos <- next_rpos(lyt, nested) - split_rows(lyt, spl, pos) + pos <- next_rpos(lyt, nested, at_sibling = at_sibling) + split_rows(lyt, spl, pos, at_sibling = at_sibling) } } @@ -1312,6 +1102,7 @@ get_acolvar_vars <- function(lyt) { #' [additional_fun_params]. #' #' @inherit split_cols_by return +#' @inheritSection split_rows_by Nesting Anchor Resolution #' #' @seealso [split_cols_by_multivar()] #' @@ -1364,6 +1155,7 @@ analyze_colvars <- function(lyt, format = NULL, na_str = NA_character_, nested = TRUE, + at_sibling = NULL, extra_args = list(), indent_mod = 0L, inclNAs = FALSE) { @@ -1407,8 +1199,8 @@ analyze_colvars <- function(lyt, extra_args = extra_args, inclNAs = inclNAs ) - pos <- next_rpos(lyt, nested, for_analyze = TRUE) - split_rows(lyt, spl, pos) + pos <- next_rpos(lyt, nested, for_analyze = TRUE, at_sibling = at_sibling) + split_rows(lyt, spl, pos, at_sibling = at_sibling) } ## Add a total column at the next **top level** spot in @@ -1568,6 +1360,33 @@ setMethod( } ) +#' @rdname int_methods +setMethod( + ".add_row_summary", "SplitVectorTree", + function(lyt, + label, + cfun, + child_labels = c("default", "visible", "hidden"), + cformat = NULL, + cna_str = "-", + indent_mod = 0L, + cvar = "", + extra_args = list()) { + len <- length(lyt) + lyt[[len]] <- .add_row_summary(lyt[[len]], + label = label, + cfun = cfun, + child_labels = child_labels, + cformat = cformat, + cna_str = cna_str, + indent_mod = indent_mod, + cvar = cvar, + extra_args = extra_args + ) + lyt + } +) + #' @rdname int_methods setMethod( ".add_row_summary", "Split", @@ -1843,7 +1662,7 @@ add_existing_table <- function(lyt, tt, indent_mod = 0) { lyt <- split_rows( lyt, tt, - next_rpos(lyt, nested = FALSE) + next_rpos(lyt, nested = FALSE, at_sibling = NULL) ) lyt } @@ -1943,6 +1762,14 @@ setMethod( } ) +#' @rdname int_methods +setMethod( + "fix_dyncuts", "SplitVectorTree", + function(spl, df) { + .fd_helper(spl, df) + } +) + #' @rdname int_methods setMethod( "fix_dyncuts", "PreDataTableLayouts", diff --git a/R/nesting_impl.R b/R/nesting_impl.R new file mode 100644 index 000000000..e765e0539 --- /dev/null +++ b/R/nesting_impl.R @@ -0,0 +1,621 @@ +#' @param for_analyze (`flag`) whether split is an analyze split. +#' @rdname int_methods +setGeneric( + "next_rpos", + function(obj, nested = TRUE, for_analyze = FALSE, at_sibling = NULL) standardGeneric("next_rpos") +) + +#' @rdname int_methods +setMethod( + "next_rpos", "PreDataTableLayouts", + function(obj, nested, for_analyze = FALSE, at_sibling = NULL) { + next_rpos(rlayout(obj), nested, for_analyze = for_analyze, at_sibling = at_sibling) + } +) + +.check_if_nest <- function(obj, nested, for_analyze, at_sibling) { + if (!nested) { + FALSE + } else { + ## can always nest analyze splits (almost? what about colvars noncolvars mixing? prolly ok?) + for_analyze || !is.null(at_sibling) || + ## If its not an analyze split it can't go under an analyze split + !(is(last_rowsplit(obj), "VAnalyzeSplit") || + is(last_rowsplit(obj), "AnalyzeMultiVars")) ## should this be CompoundSplit? # nolint + } +} + +#' @rdname int_methods +setMethod( + "next_rpos", "PreDataRowLayout", + function(obj, nested, for_analyze, at_sibling = NULL) { + l <- length(obj) + if (length(obj[[l]]) > 0L && !.check_if_nest(obj, nested, for_analyze, at_sibling = at_sibling)) { + l <- l + 1L + } + l + } +) + +#' @rdname int_methods +setMethod("next_rpos", "ANY", function(obj, nested) 1L) + +#' @rdname int_methods +setGeneric("next_cpos", function(obj, nested = TRUE) standardGeneric("next_cpos")) + +#' @rdname int_methods +setMethod( + "next_cpos", "PreDataTableLayouts", + function(obj, nested) next_cpos(clayout(obj), nested) +) + +#' @rdname int_methods +setMethod( + "next_cpos", "PreDataColLayout", + function(obj, nested) { + if (nested || length(obj[[length(obj)]]) == 0) { + length(obj) + } else { + length(obj) + 1L + } + } +) + +#' @rdname int_methods +setMethod("next_cpos", "ANY", function(obj, nested) 1L) + +#' @rdname int_methods +setGeneric("last_rowsplit", function(obj) standardGeneric("last_rowsplit")) + +#' @rdname int_methods +setMethod( + "last_rowsplit", "NULL", + function(obj) NULL +) + +#' @rdname int_methods +setMethod( + "last_rowsplit", "SplitVector", + function(obj) { + if (length(obj) == 0) { + NULL + } else { + last_rowsplit(obj[[length(obj)]]) + } + } +) + +setMethod( + "last_rowsplit", "Split", + function(obj) obj +) + + +#' @rdname int_methods +setMethod( + "last_rowsplit", "SplitVectorTree", + function(obj) { + if (length(obj) == 0) { + NULL + } else { + last_rowsplit(obj[[length(obj)]]) + } + } +) + + +#' @rdname int_methods +setMethod( + "last_rowsplit", "PreDataRowLayout", + function(obj) { + if (length(obj) == 0) { + NULL + } else { + last_rowsplit(obj[[length(obj)]]) + } + } +) + +#' @rdname int_methods +setMethod( + "last_rowsplit", "PreDataTableLayouts", + function(obj) last_rowsplit(rlayout(obj)) +) + + +## split_rows and split_cols are "recursive method stacks" which follow +## the general pattern of accept object -> call add_*_split on slot of object -> +## update object with value returned from slot method, return object. +## +## Thus each of the methods is idempotent, returning an updated object of the +## same class it was passed. The exception for idempotency is the NULL method +## which constructs a PreDataTableLayouts object with the specified split in the +## correct place. + +## The cascading (by class) in this case is as follows for the row case: +## PreDataTableLayouts -> PreDataRowLayout -> SplitVector +#' @param cmpnd_fun (`function`)\cr intended for internal use. +#' @param pos (`numeric(1)`)\cr intended for internal use. +#' @param spl (`Split`)\cr the split. +#' +#' @rdname int_methods +setGeneric( + "split_rows", + function(lyt = NULL, spl, pos, + cmpnd_fun = AnalyzeMultiVars, at_sibling = NULL) { + standardGeneric("split_rows") + } +) + +#' @rdname int_methods +setMethod("split_rows", "NULL", function(lyt, spl, pos, cmpnd_fun = AnalyzeMultiVars, at_sibling = NULL) { + lifecycle::deprecate_warn( + when = "0.3.8", + what = I("split_rows(NULL)"), + with = "basic_table()", + details = "Initializing layouts via `NULL` is no longer supported." + ) + rl <- PreDataRowLayout(SplitVector(spl)) + cl <- PreDataColLayout() + PreDataTableLayouts(rlayout = rl, clayout = cl) +}) + +first_spl_name <- function(splvectree) { + if (is(splvectree, "Split")) { ## could generic + methods but ... whyyyyy? + spl <- splvectree + } else { + spl <- unlist(splvectree, recursive = TRUE)[[1]] + } + deuniqify_path_elements(obj_name(spl)) +} + + +brack_regex <- "[^[]+\\[([[:digit:]]+)\\]" +extract_dup_pos <- function(str) { + havebracks <- grepl(brack_regex, str) + out <- gsub(brack_regex, "\\1", str) + out[!havebracks] <- 1 + as.numeric(out) +} + +## for +## split_rows_by("STRATA1") |> +## split_rows_by("SEX") |> +## analyze("AGE") |> +## split_rows_by("RACE", at_sibling = "SEX") |> +## split_rows_by("BMRKR2") |> +## analyze("AGE") |> +## analyze("BMRKR1", at_sibling = "BMRKR2") +## +## this should give: STRATA1, c(SEX, RACE), c(BMRKR2, BMRKR1) as valid at_sibling targets + +#' List Possible Nesting Anchors +#' +#' This function scans an existing layout's row structure and lists +#' valid `at_sibling` anchors for intermediate nesting. +#' +#' @param splvec (`PreDataTableLayouts` or internal classes)\cr The layout or partial +#' layout to list anchors for. +#' +#' @return a (possibly nested) list containing the anchors which can be used with +#' `at_sibling` in `split_rows_by*` or `analyze`. +#' @examples +#' +#' lyt <- basic_table() |> +#' split_rows_by("STRATA1") |> +#' split_rows_by("RACE") |> +#' split_rows_by("SEX") |> +#' analyze("AGE") |> +#' split_rows_by("BMRKR1", at_sibling = "RACE") |> +#' analyze("AGE") +#' +#' get_anchor_list(lyt) +#' +#' @export +setGeneric("get_anchor_list", function(splvec) standardGeneric("get_anchor_list")) + +#' @rdname get_anchor_list +#' @export +setMethod( + "get_anchor_list", "PreDataTableLayouts", + function(splvec) { + get_anchor_list(rlayout(splvec)) + } +) + +#' @rdname get_anchor_list +#' @export +setMethod( + "get_anchor_list", "PreDataRowLayout", + function(splvec) { + unlist( + c( + lapply( + splvec[-length(splvec)], + first_spl_name + ), + lapply(splvec[[length(splvec)]], get_anchor_list) + ), + recursive = FALSE + ) + } +) + +#' @rdname get_anchor_list +#' @export +setMethod( + "get_anchor_list", "SplitVector", + function(splvec) { + unlist(lapply(splvec, get_anchor_list), recursive = FALSE) + } +) + +#' @rdname get_anchor_list +#' @export +setMethod( + "get_anchor_list", "SplitVectorTree", + function(splvec) { + ## use this cause it does deuniqify + c( + list(vapply(splvec, first_spl_name, "")), + ## ignore first name of last branch, we use name from first branch for matching here + get_anchor_list(SplitVector(lst = splvec[[length(splvec)]][-1])) + ) + } +) + +#' @rdname get_anchor_list +#' @export +setMethod( + "get_anchor_list", "Split", + function(splvec) first_spl_name(splvec) +) + +find_branch_pos2 <- function(splvec, at_sibling, preceding = NULL) { + nmlst <- get_anchor_list(splvec) + + atsib <- deuniqify_path_elements(at_sibling) + dup_pos <- extract_dup_pos(at_sibling) + found_lgl <- vapply(nmlst, function(lst) atsib %in% deuniqify_path_elements(lst), FALSE) + found <- which(found_lgl) + + if (length(found) == 0) { + stop( + "Unable to find structural element '", at_sibling, "' to add siblings for.\n", + "Eligible elements: ", + paste( + collapse = ", ", + paste0( + "'", + unlist(c(preceding, nmlst)), + "'" + ) + ) + ) + } else if (dup_pos > length(found)) { + stop( + "Found only ", length(found), " eligible elements named '", + deuniqify_path_elements(at_sibling), + "', but at_sibling was '", at_sibling, "'" + ) + } + found[dup_pos] +} + +branch_is_root <- function(splv, at_sibling) find_branch_pos2(splv, at_sibling) == 1 + +## its recursive all the way down ... as always + +branch_above_split <- function(splvec, newspl, at_sibling, + branch_pos = find_branch_pos2(splvec, at_sibling, preceding = preceding), + preceding = NULL) { + svlen <- length(splvec) + if (branch_pos > svlen) { + stopifnot(is(splvec[[svlen]], "SplitVectorTree")) + lasttree <- splvec[[svlen]] + treelen <- length(lasttree) + lasttree[[treelen]] <- branch_above_split(lasttree[[treelen]], + newspl, + at_sibling = at_sibling, ## not used in this path + ## +1 is b/c the first split for this branch + ## was already matched against, otherwise we + ## are double-counting it + branch_pos = branch_pos - svlen + 1, + preceding = c( + preceding, + vapply(splvec, first_spl_name, "") + ) + ) + splvec[[svlen]] <- lasttree + return(splvec) + } + lastel <- splvec[[branch_pos]] + + lstlastel <- if (is(lastel, "SplitVectorTree")) lastel else list(lastel) + + len <- length(splvec) + + endontree <- is(lastel, "SplitVectorTree") + ## counting deduplications already happened in find_branch_pos2, so we just need + ## to ensure they match here, which they already should + sib_matches <- is.null(at_sibling) || deuniqify_path_elements(at_sibling) %in% vapply(lstlastel, first_spl_name, "") + if (endontree && sib_matches) { + splvec[[branch_pos]] <- SplitVectorTree(lst = c(lastel, list(SplitVector(newspl)))) + } else if (has_force_pag(lastel)) { + stop( + "at_sibling pointed to a split with forced pagination (page_by = TRUE).", + " This is not supported." + ) + } else { + ## are_spls <- which(!vapply(splvec, is, "VAnalyzeSplit", FUN.VALUE = TRUE)) + ## branch_pos <- max(0, are_spls) ## ensure no -Inf warning + if (branch_pos > 0 && label_position(splvec[[branch_pos]]) == "default") { + label_position(splvec[[branch_pos]]) <- "visible" + } + lst <- c( + if (branch_pos > 1) splvec[seq(1, branch_pos - 1)], + list(SplitVectorTree(lst = list( + SplitVector(lst = splvec[seq(branch_pos, len)]), + SplitVector(newspl) + ))) + ) + splvec <- SplitVector(lst = lst) + } + splvec +} + +#' @rdname int_methods +setMethod( + "split_rows", "PreDataRowLayout", + function(lyt, spl, pos, cmpnd_fun = AnalyzeMultiVars, at_sibling = NULL) { + stopifnot(is.na(pos) || (pos > 0 && pos <= length(lyt) + 1)) + root_branching <- FALSE + if (!is.null(at_sibling)) { + oldval <- lyt[[pos]] + ## if we at_sibling a top level element we need to handle as nested = FALSE + if (branch_is_root(oldval, at_sibling)) { + if (has_force_pag(last_rowsplit(oldval))) { + stop( + "at_sibling pointed to a split with forced pagination (page_by = TRUE).", + " This is not supported." + ) + } + tmp <- SplitVector(spl) + pos <- length(lyt) + 1 ## pos when nested = FALSE + } else if (is(oldval, "SplitVectorTree")) { + tmp <- SplitVectorTree(lst = c(oldval, list(SplitVector(spl)))) + } else if (is(oldval, "SplitVector")) { + tmp <- branch_above_split(oldval, spl, at_sibling) + } else { + # nocov start + stop( + "split_rows failed with at_sibling ['", at_sibling, "'] and oldval class '", + class(oldval), + "'. This should not happen, contact the maintainer." + ) + # nocov end + } + } else if (pos <= length(lyt)) { + tmp <- split_rows(lyt[[pos]], spl, pos, cmpnd_fun = cmpnd_fun, at_sibling = at_sibling) + } else { + if (pos != 1 && has_force_pag(spl)) { + stop("page_by splits cannot have top-level siblings", + call. = FALSE + ) + } + tmp <- SplitVector(spl) + } + lyt[[pos]] <- tmp + lyt + } +) + +## note "pos" is ignored here because it is for which nest-chain +## spl should be placed in, NOT for where in that chain it should go +#' @rdname int_methods +setMethod( + "split_rows", "SplitVector", + function(lyt, spl, pos, cmpnd_fun = AnalyzeMultiVars, at_sibling = NULL) { + if (has_force_pag(spl) && length(lyt) > 0 && !has_force_pag(lyt[[length(lyt)]])) { + stop("page_by splits cannot be nested within non-page_by splits", + call. = FALSE + ) + } + len <- length(lyt) + + ## now that we have branching we need to recursively replace + if (len > 0 && is(lyt[[len]], "SplitVectorTree")) { + lyt[[len]] <- split_rows(lyt[[len]], spl = spl, pos = pos, cmpnd_fun = cmpnd_fun, at_sibling = at_sibling) + lyt + } else { + tmp <- c(unclass(lyt), spl) + SplitVector(lst = tmp) + } + } +) + +setMethod( + "split_rows", "SplitVectorTree", + function(lyt, spl, pos, cmpnd_fun = AnalyzeMultiVars, at_sibling = NULL) { + ## nested is always TRUE by this point as FALSE + ## should be captured by the pos value in the PreData*Layout + ## methods + len <- length(lyt) + stopifnot(len > 0) + lyt[[len]] <- split_rows(lyt[[len]], spl = spl, pos = pos, cmpnd_fun = cmpnd_fun, at_sibling = at_sibling) + lyt + } +) + +#' @rdname int_methods +setMethod( + "split_rows", "PreDataTableLayouts", + function(lyt, spl, pos, at_sibling = NULL) { + rlyt <- rlayout(lyt) + addtl <- FALSE + split_label <- obj_label(spl) + if ( + is(spl, "Split") && ## exclude existing tables that are being tacked in + identical(label_position(spl), "topleft") && + length(split_label) == 1 && nzchar(split_label) + ) { + addtl <- TRUE + ## label_position(spl) <- "hidden" + } + + rlyt <- split_rows(rlyt, spl, pos, at_sibling = at_sibling) + rlayout(lyt) <- rlyt + if (addtl) { + lyt <- append_topleft(lyt, indent_string(split_label, .tl_indent(lyt))) + } + lyt + } +) + +#' @rdname int_methods +setMethod( + "split_rows", "ANY", + function(lyt, spl, pos, at_sibling = NULL) { + stop("nope. can't add a row split to that (", class(lyt), "). contact the maintainer.") # nocov + } +) + +## cmpnd_last_rowsplit ===== + +#' @rdname int_methods +#' +#' @param constructor (`function`)\cr constructor function. +setGeneric("cmpnd_last_rowsplit", function(lyt, spl, constructor) standardGeneric("cmpnd_last_rowsplit")) + +#' @rdname int_methods +setMethod("cmpnd_last_rowsplit", "NULL", function(lyt, spl, constructor) { + stop("no existing splits to compound with. contact the maintainer") # nocov +}) + +#' @rdname int_methods +setMethod( + "cmpnd_last_rowsplit", "PreDataRowLayout", + function(lyt, spl, constructor) { + pos <- length(lyt) + tmp <- cmpnd_last_rowsplit(lyt[[pos]], spl, constructor) + lyt[[pos]] <- tmp + lyt + } +) +#' @rdname int_methods +setMethod( + "cmpnd_last_rowsplit", "SplitVector", + function(lyt, spl, constructor) { + pos <- length(lyt) + lst <- lyt[[pos]] + tmp <- if (is(lst, "CompoundSplit")) { + spl_payload(lst) <- c( + .uncompound(spl_payload(lst)), + .uncompound(spl) + ) + obj_name(lst) <- make_ma_name(spl = lst) + lst + ## XXX never reached because AnalzyeMultiVars inherits from + ## CompoundSplit??? + } else { + constructor(.payload = list(lst, spl)) + } + lyt[[pos]] <- tmp + lyt + } +) + +#' @rdname int_methods +setMethod( + "cmpnd_last_rowsplit", "PreDataTableLayouts", + function(lyt, spl, constructor) { + rlyt <- rlayout(lyt) + rlyt <- cmpnd_last_rowsplit(rlyt, spl, constructor) + rlayout(lyt) <- rlyt + lyt + } +) +#' @rdname int_methods +setMethod( + "cmpnd_last_rowsplit", "ANY", + function(lyt, spl, constructor) { + # nocov start + stop( + "nope. can't do cmpnd_last_rowsplit to that (", + class(lyt), "). contact the maintainer." + ) + # nocov end + } +) + +## split_cols ==== + +#' @rdname int_methods +setGeneric( + "split_cols", + function(lyt = NULL, spl, pos) { + standardGeneric("split_cols") + } +) + +#' @rdname int_methods +setMethod("split_cols", "NULL", function(lyt, spl, pos) { + lifecycle::deprecate_warn( + when = "0.3.8", + what = I("split_cols(NULL)"), + with = "basic_table()", + details = "Initializing layouts via `NULL` is no longer supported." + ) + cl <- PreDataColLayout(SplitVector(spl)) + rl <- PreDataRowLayout() + PreDataTableLayouts(rlayout = rl, clayout = cl) +}) + +#' @rdname int_methods +setMethod( + "split_cols", "PreDataColLayout", + function(lyt, spl, pos) { + stopifnot(pos > 0 && pos <= length(lyt) + 1) + tmp <- if (pos <= length(lyt)) { + split_cols(lyt[[pos]], spl, pos) + } else { + SplitVector(spl) + } + + lyt[[pos]] <- tmp + lyt + } +) + +#' @rdname int_methods +setMethod( + "split_cols", "SplitVector", + function(lyt, spl, pos) { + tmp <- c(lyt, spl) + SplitVector(lst = tmp) + } +) + +#' @rdname int_methods +setMethod( + "split_cols", "PreDataTableLayouts", + function(lyt, spl, pos) { + rlyt <- lyt@col_layout + rlyt <- split_cols(rlyt, spl, pos) + lyt@col_layout <- rlyt + lyt + } +) + +#' @rdname int_methods +setMethod( + "split_cols", "ANY", + function(lyt, spl, pos) { + # nocov start + stop( + "nope. can't add a col split to that (", class(lyt), + "). contact the maintainer." + ) + # nocov end + } +) diff --git a/R/tree_accessors.R b/R/tree_accessors.R index 967b33492..399e6e1da 100644 --- a/R/tree_accessors.R +++ b/R/tree_accessors.R @@ -194,106 +194,6 @@ setMethod( } ) -#' @param for_analyze (`flag`) whether split is an analyze split. -#' @rdname int_methods -setGeneric("next_rpos", function(obj, nested = TRUE, for_analyze = FALSE) standardGeneric("next_rpos")) - -#' @rdname int_methods -setMethod( - "next_rpos", "PreDataTableLayouts", - function(obj, nested, for_analyze = FALSE) next_rpos(rlayout(obj), nested, for_analyze = for_analyze) -) - -.check_if_nest <- function(obj, nested, for_analyze) { - if (!nested) { - FALSE - } else { - ## can always nest analyze splits (almost? what about colvars noncolvars mixing? prolly ok?) - for_analyze || - ## If its not an analyze split it can't go under an analyze split - !(is(last_rowsplit(obj), "VAnalyzeSplit") || - is(last_rowsplit(obj), "AnalyzeMultiVars")) ## should this be CompoundSplit? # nolint - } -} - -#' @rdname int_methods -setMethod( - "next_rpos", "PreDataRowLayout", - function(obj, nested, for_analyze) { - l <- length(obj) - if (length(obj[[l]]) > 0L && !.check_if_nest(obj, nested, for_analyze)) { - l <- l + 1L - } - l - } -) - -#' @rdname int_methods -setMethod("next_rpos", "ANY", function(obj, nested) 1L) - -#' @rdname int_methods -setGeneric("next_cpos", function(obj, nested = TRUE) standardGeneric("next_cpos")) - -#' @rdname int_methods -setMethod( - "next_cpos", "PreDataTableLayouts", - function(obj, nested) next_cpos(clayout(obj), nested) -) - -#' @rdname int_methods -setMethod( - "next_cpos", "PreDataColLayout", - function(obj, nested) { - if (nested || length(obj[[length(obj)]]) == 0) { - length(obj) - } else { - length(obj) + 1L - } - } -) - -#' @rdname int_methods -setMethod("next_cpos", "ANY", function(obj, nested) 1L) - -#' @rdname int_methods -setGeneric("last_rowsplit", function(obj) standardGeneric("last_rowsplit")) - -#' @rdname int_methods -setMethod( - "last_rowsplit", "NULL", - function(obj) NULL -) - -#' @rdname int_methods -setMethod( - "last_rowsplit", "SplitVector", - function(obj) { - if (length(obj) == 0) { - NULL - } else { - obj[[length(obj)]] - } - } -) - -#' @rdname int_methods -setMethod( - "last_rowsplit", "PreDataRowLayout", - function(obj) { - if (length(obj) == 0) { - NULL - } else { - last_rowsplit(obj[[length(obj)]]) - } - } -) - -#' @rdname int_methods -setMethod( - "last_rowsplit", "PreDataTableLayouts", - function(obj) last_rowsplit(rlayout(obj)) -) - # rlayout ---- ## TODO maybe export these? @@ -730,7 +630,7 @@ setGeneric("vis_label", function(spl) standardGeneric("vis_label")) #' @rdname int_methods setMethod("vis_label", "Split", function(spl) { - .labelkids_helper(label_position(spl)) + .labelkids_helper(label_position(spl), na_ok = FALSE) }) ## #' @rdname int_methods @@ -753,6 +653,11 @@ setMethod("label_position", "Split", function(spl) spl@split_label_position) #' @rdname int_methods setMethod("label_position", "VAnalyzeSplit", function(spl) spl@var_label_position) ## split_label_position) +#' @rdname int_methods +setMethod("label_position", "SplitVectorTree", function(spl) { + label_position(last_rowsplit(spl)) +}) + #' @rdname int_methods setGeneric("label_position<-", function(spl, value) standardGeneric("label_position<-")) diff --git a/R/tt_dotabulation.R b/R/tt_dotabulation.R index 36d8eb7b1..b73991396 100644 --- a/R/tt_dotabulation.R +++ b/R/tt_dotabulation.R @@ -882,6 +882,42 @@ setMethod( } ) +setMethod( + ".make_split_kids", "SplitVectorTree", + function(spl, + have_controws, + make_lrow, + ..., + splvec, ## passed to recursive_applysplit + df, ## used to apply split + alt_df, ## used to apply split for alternative df + alt_df_full, ## passed to recursive_applysplit + lvl, ## used to calculate innerlev + cinfo, ## used for sanity check + baselines, ## used to calc new baselines + spl_context) { + ret <- lapply( + spl, + function(splvecii) { + recursive_applysplit( + df = df, + lvl = lvl + 1L, + alt_df = alt_df, + alt_df_full = alt_df_full, + splvec = splvecii, + name = obj_name(unlist(splvecii, recursive = TRUE)[[1]]), + make_lrow = make_lrow, + cinfo = cinfo, + baselines = baselines, + spl_context = spl_context, + no_outer_tbl = TRUE + ) + } + ) + ret + } +) + setMethod( ".make_split_kids", "Split", function(spl, @@ -1182,6 +1218,39 @@ recursive_applysplit <- function(df, return(splvec[[1]]) } + if (is(splvec, "SplitVectorTree")) { + return( + unlist( + lapply( + seq_along(splvec), + function(ii) { + recursive_applysplit( + df = df, + lvl = lvl, + alt_df = alt_df, + alt_df_full = alt_df_full, + splvec = splvec[[ii]], + name = obj_name(unlist(splvec[[ii]])[[1]]), + make_lrow = make_lrow, + partlabel = partlabel, + cinfo = cinfo, + parent_cfun = parent_cfun, + cformat = cformat, + cna_str = cna_str, + cindent_mod = cindent_mod, + cextra_args = cextra_args, + cvar = cvar, + baselines = baselines, + spl_context = spl_context, + no_outer_tbl = TRUE, + parent_sect_split = parent_sect_split + ) + } + ) + ) + ) + } + ## the content function is the one from the PREVIOUS ## split, i.e. the one whose children we are now constructing ## this is a bit annoying but makes the semantics for @@ -1452,7 +1521,7 @@ build_table <- function(lyt, df, if (length(splvec) == 0) { return(NULL) } - firstspl <- splvec[[1]] + firstspl <- unlist(splvec, recursive = TRUE)[[1]] ## could be a SplitVecTree now... nm <- obj_name(firstspl) ## XXX unused, probably shouldn't be? ## this seems to be covered by grabbing the partlabel @@ -1482,7 +1551,8 @@ build_table <- function(lyt, df, no_outer_tbl = !is(firstspl, "AnalyzeMultiVars") ) }) - kids <- kids[!sapply(kids, is.null)] + ## kids <- kids[!sapply(kids, is.null)] + kids <- unlist(kids, recursive = TRUE) if (length(kids) > 0) names(kids) <- sapply(kids, obj_name) # top level divisor @@ -1674,6 +1744,15 @@ setMethod( } ) +setMethod( + "set_def_child_ord", "SplitVectorTree", + function(lyt, df) { + lyt[] <- lapply(lyt, set_def_child_ord, df = df) + lyt + } +) + + ## for most split types, don't do anything ## becuause their ordering already isn't data-based setMethod( @@ -1891,6 +1970,15 @@ setMethod( } ) +setMethod( + "fix_analyze_vis", "SplitVectorTree", + function(lyt) { + stopifnot(length(lyt) > 0) + lst <- lapply(lyt, fix_analyze_vis) + SplitVectorTree(lst = lst) + } +) + # check_afun_cfun_params ---- # This checks if the input params are used anywhere in cfun/afun @@ -1924,6 +2012,13 @@ setMethod( } ) +setMethod( + "check_afun_cfun_params", "SplitVectorTree", + function(lyt, params) { + param_l <- lapply(lyt, check_afun_cfun_params, params = params) + Reduce(`|`, param_l) + } +) # Helper function for check_afun_cfun_params .afun_cfun_switch <- function(spl_i) { if (is(spl_i, "VAnalyzeSplit")) { diff --git a/R/tt_showmethods.R b/R/tt_showmethods.R index 0629ed6ee..a9ec4f98b 100644 --- a/R/tt_showmethods.R +++ b/R/tt_showmethods.R @@ -41,6 +41,13 @@ setMethod( } ) +setMethod( + "ploads_to_str", "SplitVectorTree", + function(x, collapse = ":") { + sapply(x, ploads_to_str, collapse = collapse) + } +) + setMethod( "ploads_to_str", "CompoundSplit", function(x, collapse = ":") { @@ -258,6 +265,11 @@ setMethod( function(obj) "** col-var analysis **" ) +setMethod( + "spltype_abbrev", "SplitVectorTree", + function(obj) "" +) + docat_splitvec <- function(object, indent = 0) { if (indent > 0) { cat(rep(" ", times = indent), sep = "") @@ -269,6 +281,9 @@ docat_splitvec <- function(object, indent = 0) { nrow(tab), ncol(tab) ) } else { + if (is(object, "SplitVectorTree")) { + return(lapply(object, docat_splitvec)) + } plds <- ploads_to_str(object) ## lapply(object, spl_payload)) tabbrev <- sapply(object, spltype_abbrev) diff --git a/_pkgdown.yml b/_pkgdown.yml index 2bf041f51..2dc9d534a 100644 --- a/_pkgdown.yml +++ b/_pkgdown.yml @@ -158,6 +158,7 @@ reference: - add_overall_col - add_existing_table - formatters::table_inset + - get_anchor_list - title: Tabulation Utility Functions desc: Functions that are useful to be used with the `analyze*` functions. diff --git a/man/analyze.Rd b/man/analyze.Rd index 378dc14d4..ae626697a 100644 --- a/man/analyze.Rd +++ b/man/analyze.Rd @@ -16,6 +16,7 @@ analyze( na_str = NA_character_, na_strs_var = NULL, nested = TRUE, + at_sibling = NULL, inclNAs = FALSE, extra_args = list(), show_labels = c("default", "visible", "hidden"), @@ -60,6 +61,11 @@ Cannot be used simultaneously with \code{format}. Cannot be used if \code{format \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.} +\item{at_sibling}{(\code{character(1)} or \code{NULL})\cr If non-null, a preceding +split or analyze to anchor this instruction to as a direct sibling. Cannot +select an instruction that is downstream of a point where a previously used +anchor (See Nesting Anchor Resolution for details).} + \item{inclNAs}{(\code{logical})\cr whether NA observations in the \code{var} variable(s) should be included when performing the analysis. Defaults to \code{FALSE}.} @@ -184,6 +190,45 @@ other parameters which, \emph{if and only if} present in the formals, will be pa machinery. These are listed and described in \link{additional_fun_params}. } +\section{Nesting Anchor Resolution}{ + + +When \code{nested} is \code{TRUE}, \code{at_sibling} allows you to set a \emph{nesting +anchor} that your new \verb{split_rows_by*} or \verb{analyze*} directive +should be placed as a sibling to. The lookup for this anchor +occurs \emph{only in the currently active top-level nesting stack}, +meaning the directives that have occurred since +the last split or analysis with \code{nested == FALSE}. + +Furthermore, resolution occurs against the first element of each +arm of a branching point caused by any previous uses of +\code{at_sibling} but \emph{only descends into the last arm}. + +So for example if our previous layout was generated via: + +\if{html}{\out{
}}\preformatted{lyt <- basic_table() |> + split_rows_by("SEX") |> + analyze("AGE") |> + split_rows_by("BMRKR2", nested = FALSE) |> + split_rows_by("RACE") |> + analyze("AGE") |> + split_rows_by("SEX", at_sibling = "RACE") |> + analyze("BMRKR1") +}\if{html}{\out{
}} + +The eligible anchor points would be \code{"BMRKR2"}, \code{"RACE"}, \code{"SEX"} +and \code{"BMRKR1"}. \code{"AGE"} is masked by the branching caused by +anchoring our \code{SEX} split on \code{RACE}. + +Finally, while \code{at_sibling} does support de-duplication of +\code{"[i]"} anchors, it does so \strong{within the set of available +anchors}, which can be counter-intuitive. It is strongly suggested +that the \code{parent_name} and \code{table_names} argument(s) of +\verb{split_rows_by*} and \code{analyze} be used to prevent the need for +this. \code{at_sibling} will resolve to table names overridden in this +manner. +} + \examples{ lyt <- basic_table() |> split_cols_by("ARM") |> diff --git a/man/analyze_colvars.Rd b/man/analyze_colvars.Rd index 9c7a1bc2d..6826078d7 100644 --- a/man/analyze_colvars.Rd +++ b/man/analyze_colvars.Rd @@ -11,6 +11,7 @@ analyze_colvars( format = NULL, na_str = NA_character_, nested = TRUE, + at_sibling = NULL, extra_args = list(), indent_mod = 0L, inclNAs = FALSE @@ -39,6 +40,11 @@ functions. See \code{\link[formatters:list_valid_format_labels]{formatters::list \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.} +\item{at_sibling}{(\code{character(1)} or \code{NULL})\cr If non-null, a preceding +split or analyze to anchor this instruction to as a direct sibling. Cannot +select an instruction that is downstream of a point where a previously used +anchor (See Nesting Anchor Resolution for details).} + \item{extra_args}{(\code{list})\cr extra arguments to be passed to the tabulation function. Element position in the list corresponds to the children of this split. Named elements in the child-specific lists are ignored if they do not match a formal argument of the tabulation function.} @@ -56,6 +62,45 @@ A \code{PreDataTableLayouts} object suitable for passing to further layouting fu \description{ Generate rows analyzing different variables across columns } +\section{Nesting Anchor Resolution}{ + + +When \code{nested} is \code{TRUE}, \code{at_sibling} allows you to set a \emph{nesting +anchor} that your new \verb{split_rows_by*} or \verb{analyze*} directive +should be placed as a sibling to. The lookup for this anchor +occurs \emph{only in the currently active top-level nesting stack}, +meaning the directives that have occurred since +the last split or analysis with \code{nested == FALSE}. + +Furthermore, resolution occurs against the first element of each +arm of a branching point caused by any previous uses of +\code{at_sibling} but \emph{only descends into the last arm}. + +So for example if our previous layout was generated via: + +\if{html}{\out{
}}\preformatted{lyt <- basic_table() |> + split_rows_by("SEX") |> + analyze("AGE") |> + split_rows_by("BMRKR2", nested = FALSE) |> + split_rows_by("RACE") |> + analyze("AGE") |> + split_rows_by("SEX", at_sibling = "RACE") |> + analyze("BMRKR1") +}\if{html}{\out{
}} + +The eligible anchor points would be \code{"BMRKR2"}, \code{"RACE"}, \code{"SEX"} +and \code{"BMRKR1"}. \code{"AGE"} is masked by the branching caused by +anchoring our \code{SEX} split on \code{RACE}. + +Finally, while \code{at_sibling} does support de-duplication of +\code{"[i]"} anchors, it does so \strong{within the set of available +anchors}, which can be counter-intuitive. It is strongly suggested +that the \code{parent_name} and \code{table_names} argument(s) of +\verb{split_rows_by*} and \code{analyze} be used to prevent the need for +this. \code{at_sibling} will resolve to table names overridden in this +manner. +} + \examples{ \dontshow{if (require(dplyr)) withAutoprint(\{ # examplesIf} library(dplyr) diff --git a/man/get_anchor_list.Rd b/man/get_anchor_list.Rd new file mode 100644 index 000000000..662049e25 --- /dev/null +++ b/man/get_anchor_list.Rd @@ -0,0 +1,48 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/nesting_impl.R +\name{get_anchor_list} +\alias{get_anchor_list} +\alias{get_anchor_list,PreDataTableLayouts-method} +\alias{get_anchor_list,PreDataRowLayout-method} +\alias{get_anchor_list,SplitVector-method} +\alias{get_anchor_list,SplitVectorTree-method} +\alias{get_anchor_list,Split-method} +\title{List Possible Nesting Anchors} +\usage{ +get_anchor_list(splvec) + +\S4method{get_anchor_list}{PreDataTableLayouts}(splvec) + +\S4method{get_anchor_list}{PreDataRowLayout}(splvec) + +\S4method{get_anchor_list}{SplitVector}(splvec) + +\S4method{get_anchor_list}{SplitVectorTree}(splvec) + +\S4method{get_anchor_list}{Split}(splvec) +} +\arguments{ +\item{splvec}{(\code{PreDataTableLayouts} or internal classes)\cr The layout or partial +layout to list anchors for.} +} +\value{ +a (possibly nested) list containing the anchors which can be used with +\code{at_sibling} in \verb{split_rows_by*} or \code{analyze}. +} +\description{ +This function scans an existing layout's row structure and lists +valid \code{at_sibling} anchors for intermediate nesting. +} +\examples{ + +lyt <- basic_table() |> + split_rows_by("STRATA1") |> + split_rows_by("RACE") |> + split_rows_by("SEX") |> + analyze("AGE") |> + split_rows_by("BMRKR1", at_sibling = "RACE") |> + analyze("AGE") + +get_anchor_list(lyt) + +} diff --git a/man/int_methods.Rd b/man/int_methods.Rd index a531cf5ae..10da3f946 100644 --- a/man/int_methods.Rd +++ b/man/int_methods.Rd @@ -1,10 +1,22 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/colby_constructors.R, R/summary.R, -% R/tree_accessors.R, R/tt_compatibility.R, R/tt_pos_and_access.R, -% R/tt_showmethods.R -\name{internal_methods} -\alias{internal_methods} -\alias{c,SplitVector-method} +% Please edit documentation in R/nesting_impl.R, R/colby_constructors.R, +% R/summary.R, R/tree_accessors.R, R/tt_compatibility.R, +% R/tt_pos_and_access.R, R/tt_showmethods.R +\name{next_rpos} +\alias{next_rpos} +\alias{next_rpos,PreDataTableLayouts-method} +\alias{next_rpos,PreDataRowLayout-method} +\alias{next_rpos,ANY-method} +\alias{next_cpos} +\alias{next_cpos,PreDataTableLayouts-method} +\alias{next_cpos,PreDataColLayout-method} +\alias{next_cpos,ANY-method} +\alias{last_rowsplit} +\alias{last_rowsplit,NULL-method} +\alias{last_rowsplit,SplitVector-method} +\alias{last_rowsplit,SplitVectorTree-method} +\alias{last_rowsplit,PreDataRowLayout-method} +\alias{last_rowsplit,PreDataTableLayouts-method} \alias{split_rows} \alias{split_rows,NULL-method} \alias{split_rows,PreDataRowLayout-method} @@ -23,10 +35,13 @@ \alias{split_cols,SplitVector-method} \alias{split_cols,PreDataTableLayouts-method} \alias{split_cols,ANY-method} +\alias{internal_methods} +\alias{c,SplitVector-method} \alias{.add_row_summary} \alias{.add_row_summary,PreDataTableLayouts-method} \alias{.add_row_summary,PreDataRowLayout-method} \alias{.add_row_summary,SplitVector-method} +\alias{.add_row_summary,SplitVectorTree-method} \alias{.add_row_summary,Split-method} \alias{fix_dyncuts} \alias{fix_dyncuts,Split-method} @@ -35,6 +50,7 @@ \alias{fix_dyncuts,PreDataRowLayout-method} \alias{fix_dyncuts,PreDataColLayout-method} \alias{fix_dyncuts,SplitVector-method} +\alias{fix_dyncuts,SplitVectorTree-method} \alias{fix_dyncuts,PreDataTableLayouts-method} \alias{summarize_rows_inner} \alias{summarize_rows_inner,TableTree-method} @@ -58,19 +74,6 @@ \alias{content_table,TableTree-method} \alias{content_table,ANY-method} \alias{content_table<-,TableTree,ElementaryTable-method} -\alias{next_rpos} -\alias{next_rpos,PreDataTableLayouts-method} -\alias{next_rpos,PreDataRowLayout-method} -\alias{next_rpos,ANY-method} -\alias{next_cpos} -\alias{next_cpos,PreDataTableLayouts-method} -\alias{next_cpos,PreDataColLayout-method} -\alias{next_cpos,ANY-method} -\alias{last_rowsplit} -\alias{last_rowsplit,NULL-method} -\alias{last_rowsplit,SplitVector-method} -\alias{last_rowsplit,PreDataRowLayout-method} -\alias{last_rowsplit,PreDataTableLayouts-method} \alias{rlayout} \alias{rlayout,PreDataTableLayouts-method} \alias{rlayout,ANY-method} @@ -130,6 +133,7 @@ \alias{label_position} \alias{label_position,Split-method} \alias{label_position,VAnalyzeSplit-method} +\alias{label_position,SplitVectorTree-method} \alias{label_position<-} \alias{label_position<-,Split-method} \alias{content_fun} @@ -386,19 +390,69 @@ \alias{show,VTableTree-method} \title{Combine \code{SplitVector} objects} \usage{ -\S4method{c}{SplitVector}(x, ...) +next_rpos(obj, nested = TRUE, for_analyze = FALSE, at_sibling = NULL) + +\S4method{next_rpos}{PreDataTableLayouts}(obj, nested = TRUE, for_analyze = FALSE, at_sibling = NULL) -split_rows(lyt = NULL, spl, pos, cmpnd_fun = AnalyzeMultiVars) +\S4method{next_rpos}{PreDataRowLayout}(obj, nested = TRUE, for_analyze = FALSE, at_sibling = NULL) -\S4method{split_rows}{NULL}(lyt = NULL, spl, pos, cmpnd_fun = AnalyzeMultiVars) +\S4method{next_rpos}{ANY}(obj, nested) -\S4method{split_rows}{PreDataRowLayout}(lyt = NULL, spl, pos, cmpnd_fun = AnalyzeMultiVars) +next_cpos(obj, nested = TRUE) -\S4method{split_rows}{SplitVector}(lyt = NULL, spl, pos, cmpnd_fun = AnalyzeMultiVars) +\S4method{next_cpos}{PreDataTableLayouts}(obj, nested = TRUE) -\S4method{split_rows}{PreDataTableLayouts}(lyt, spl, pos) +\S4method{next_cpos}{PreDataColLayout}(obj, nested = TRUE) -\S4method{split_rows}{ANY}(lyt, spl, pos) +\S4method{next_cpos}{ANY}(obj, nested = TRUE) + +last_rowsplit(obj) + +\S4method{last_rowsplit}{NULL}(obj) + +\S4method{last_rowsplit}{SplitVector}(obj) + +\S4method{last_rowsplit}{SplitVectorTree}(obj) + +\S4method{last_rowsplit}{PreDataRowLayout}(obj) + +\S4method{last_rowsplit}{PreDataTableLayouts}(obj) + +split_rows( + lyt = NULL, + spl, + pos, + cmpnd_fun = AnalyzeMultiVars, + at_sibling = NULL +) + +\S4method{split_rows}{NULL}( + lyt = NULL, + spl, + pos, + cmpnd_fun = AnalyzeMultiVars, + at_sibling = NULL +) + +\S4method{split_rows}{PreDataRowLayout}( + lyt = NULL, + spl, + pos, + cmpnd_fun = AnalyzeMultiVars, + at_sibling = NULL +) + +\S4method{split_rows}{SplitVector}( + lyt = NULL, + spl, + pos, + cmpnd_fun = AnalyzeMultiVars, + at_sibling = NULL +) + +\S4method{split_rows}{PreDataTableLayouts}(lyt, spl, pos, at_sibling = NULL) + +\S4method{split_rows}{ANY}(lyt, spl, pos, at_sibling = NULL) cmpnd_last_rowsplit(lyt, spl, constructor) @@ -424,6 +478,8 @@ split_cols(lyt = NULL, spl, pos) \S4method{split_cols}{ANY}(lyt = NULL, spl, pos) +\S4method{c}{SplitVector}(x, ...) + .add_row_summary( lyt, label, @@ -472,6 +528,18 @@ split_cols(lyt = NULL, spl, pos) extra_args = list() ) +\S4method{.add_row_summary}{SplitVectorTree}( + lyt, + label, + cfun, + child_labels = c("default", "visible", "hidden"), + cformat = NULL, + cna_str = "-", + indent_mod = 0L, + cvar = "", + extra_args = list() +) + \S4method{.add_row_summary}{Split}( lyt, label, @@ -498,6 +566,8 @@ fix_dyncuts(spl, df) \S4method{fix_dyncuts}{SplitVector}(spl, df) +\S4method{fix_dyncuts}{SplitVectorTree}(spl, df) + \S4method{fix_dyncuts}{PreDataTableLayouts}(spl, df) summarize_rows_inner(obj, depth = 0, indent = 0) @@ -542,32 +612,6 @@ str(object, ...) \S4method{content_table}{TableTree,ElementaryTable}(obj) <- value -next_rpos(obj, nested = TRUE, for_analyze = FALSE) - -\S4method{next_rpos}{PreDataTableLayouts}(obj, nested = TRUE, for_analyze = FALSE) - -\S4method{next_rpos}{PreDataRowLayout}(obj, nested = TRUE, for_analyze = FALSE) - -\S4method{next_rpos}{ANY}(obj, nested) - -next_cpos(obj, nested = TRUE) - -\S4method{next_cpos}{PreDataTableLayouts}(obj, nested = TRUE) - -\S4method{next_cpos}{PreDataColLayout}(obj, nested = TRUE) - -\S4method{next_cpos}{ANY}(obj, nested = TRUE) - -last_rowsplit(obj) - -\S4method{last_rowsplit}{NULL}(obj) - -\S4method{last_rowsplit}{SplitVector}(obj) - -\S4method{last_rowsplit}{PreDataRowLayout}(obj) - -\S4method{last_rowsplit}{PreDataTableLayouts}(obj) - rlayout(obj) \S4method{rlayout}{PreDataTableLayouts}(obj) @@ -686,6 +730,8 @@ label_position(spl) \S4method{label_position}{VAnalyzeSplit}(spl) +\S4method{label_position}{SplitVectorTree}(spl) + label_position(spl) <- value \S4method{label_position}{Split}(spl) <- value @@ -1195,9 +1241,18 @@ obj_stat_names(obj) <- value \S4method{show}{VTableTree}(object) } \arguments{ -\item{x}{(\code{ANY})\cr the object.} +\item{obj}{(\code{ANY})\cr the object.} -\item{...}{splits or \code{SplitVector} objects.} +\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.} + +\item{for_analyze}{(\code{flag}) whether split is an analyze split.} + +\item{at_sibling}{(\code{character(1)} or \code{NULL})\cr If non-null, a preceding +split or analyze to anchor this instruction to as a direct sibling. Cannot +select an instruction that is downstream of a point where a previously used +anchor (See Nesting Anchor Resolution for details).} \item{lyt}{(\code{PreDataTableLayouts})\cr layout object pre-data used for tabulation.} @@ -1209,6 +1264,10 @@ obj_stat_names(obj) <- value \item{constructor}{(\code{function})\cr constructor function.} +\item{x}{(\code{ANY})\cr the object.} + +\item{...}{splits or \code{SplitVector} objects.} + \item{label}{(\code{string})\cr a label (not to be confused with the name) for the object/structure.} \item{cfun}{(\code{list}, \code{function}, or \code{NULL})\cr tabulation function(s) for creating content rows. Must accept \code{x} @@ -1235,8 +1294,6 @@ not match a formal argument of the tabulation function.} \item{df}{(\code{data.frame} or \code{tibble})\cr dataset.} -\item{obj}{(\code{ANY})\cr the object.} - \item{depth}{(\code{numeric(1)})\cr depth in tree.} \item{indent}{(\code{numeric(1)})\cr indent.} @@ -1250,12 +1307,6 @@ the underlying default of \code{NA}. \code{NA} is \emph{not} appropriate for \co \item{value}{(\code{ANY})\cr the new value.} -\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.} - -\item{for_analyze}{(\code{flag}) whether split is an analyze split.} - \item{format}{(\code{string}, \code{function}, or \code{list})\cr format associated with this split. Formats can be declared via 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_valid_format_labels]{formatters::list_valid_format_labels()}} for a list of all available format strings.} diff --git a/man/lyt_args.Rd b/man/lyt_args.Rd index ed05d0309..1dc1f8f81 100644 --- a/man/lyt_args.Rd +++ b/man/lyt_args.Rd @@ -53,7 +53,8 @@ lyt_args( colcount_format, parent_name, formats_var, - na_strs_var + na_strs_var, + at_sibling ) } \arguments{ @@ -199,6 +200,11 @@ Cannot be used simultaneously with \code{format}.} 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{at_sibling}{(\code{character(1)} or \code{NULL})\cr If non-null, a preceding +split or analyze to anchor this instruction to as a direct sibling. Cannot +select an instruction that is downstream of a point where a previously used +anchor (See Nesting Anchor Resolution for details).} } \value{ No return value. diff --git a/man/split_rows_by.Rd b/man/split_rows_by.Rd index 2069ca88e..de3c8fd65 100644 --- a/man/split_rows_by.Rd +++ b/man/split_rows_by.Rd @@ -14,8 +14,9 @@ split_rows_by( format = NULL, na_str = NA_character_, nested = TRUE, + at_sibling = NULL, child_labels = c("default", "visible", "hidden"), - label_pos = "hidden", + label_pos = if (!is.null(at_sibling)) "visible" else "default", indent_mod = 0L, page_by = FALSE, page_prefix = split_label, @@ -49,6 +50,11 @@ functions. See \code{\link[formatters:list_valid_format_labels]{formatters::list \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.} +\item{at_sibling}{(\code{character(1)} or \code{NULL})\cr If non-null, a preceding +split or analyze to anchor this instruction to as a direct sibling. Cannot +select an instruction that is downstream of a point where a previously used +anchor (See Nesting Anchor Resolution for details).} + \item{child_labels}{(\code{string})\cr the display behavior for the labels (i.e. label rows) of the children of this split. Accepts \code{"default"}, \code{"visible"}, and \code{"hidden"}. Defaults to \code{"default"} which flags the label row as visible only if the child has 0 content rows.} @@ -82,6 +88,45 @@ If \code{var} is a factor with empty unobserved levels and \code{labels_var} is with the same number of levels as \code{var}. Currently the error that occurs when this is not the case is not very informative, but that will change in the future. } +\section{Nesting Anchor Resolution}{ + + +When \code{nested} is \code{TRUE}, \code{at_sibling} allows you to set a \emph{nesting +anchor} that your new \verb{split_rows_by*} or \verb{analyze*} directive +should be placed as a sibling to. The lookup for this anchor +occurs \emph{only in the currently active top-level nesting stack}, +meaning the directives that have occurred since +the last split or analysis with \code{nested == FALSE}. + +Furthermore, resolution occurs against the first element of each +arm of a branching point caused by any previous uses of +\code{at_sibling} but \emph{only descends into the last arm}. + +So for example if our previous layout was generated via: + +\if{html}{\out{
}}\preformatted{lyt <- basic_table() |> + split_rows_by("SEX") |> + analyze("AGE") |> + split_rows_by("BMRKR2", nested = FALSE) |> + split_rows_by("RACE") |> + analyze("AGE") |> + split_rows_by("SEX", at_sibling = "RACE") |> + analyze("BMRKR1") +}\if{html}{\out{
}} + +The eligible anchor points would be \code{"BMRKR2"}, \code{"RACE"}, \code{"SEX"} +and \code{"BMRKR1"}. \code{"AGE"} is masked by the branching caused by +anchoring our \code{SEX} split on \code{RACE}. + +Finally, while \code{at_sibling} does support de-duplication of +\code{"[i]"} anchors, it does so \strong{within the set of available +anchors}, which can be counter-intuitive. It is strongly suggested +that the \code{parent_name} and \code{table_names} argument(s) of +\verb{split_rows_by*} and \code{analyze} be used to prevent the need for +this. \code{at_sibling} will resolve to table names overridden in this +manner. +} + \section{Custom Splitting Function Details}{ diff --git a/man/split_rows_by_multivar.Rd b/man/split_rows_by_multivar.Rd index 2e99b223d..6eff02528 100644 --- a/man/split_rows_by_multivar.Rd +++ b/man/split_rows_by_multivar.Rd @@ -14,6 +14,7 @@ split_rows_by_multivar( format = NULL, na_str = NA_character_, nested = TRUE, + at_sibling = NULL, child_labels = c("default", "visible", "hidden"), indent_mod = 0L, section_div = NA_character_, @@ -47,6 +48,11 @@ functions. See \code{\link[formatters:list_valid_format_labels]{formatters::list \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.} +\item{at_sibling}{(\code{character(1)} or \code{NULL})\cr If non-null, a preceding +split or analyze to anchor this instruction to as a direct sibling. Cannot +select an instruction that is downstream of a point where a previously used +anchor (See Nesting Anchor Resolution for details).} + \item{child_labels}{(\code{string})\cr the display behavior for the labels (i.e. label rows) of the children of this split. Accepts \code{"default"}, \code{"visible"}, and \code{"hidden"}. Defaults to \code{"default"} which flags the label row as visible only if the child has 0 content rows.} @@ -69,6 +75,45 @@ A \code{PreDataTableLayouts} object suitable for passing to further layouting fu When we need rows to reflect different variables rather than different levels of a single variable, we use \code{split_rows_by_multivar}. } +\section{Nesting Anchor Resolution}{ + + +When \code{nested} is \code{TRUE}, \code{at_sibling} allows you to set a \emph{nesting +anchor} that your new \verb{split_rows_by*} or \verb{analyze*} directive +should be placed as a sibling to. The lookup for this anchor +occurs \emph{only in the currently active top-level nesting stack}, +meaning the directives that have occurred since +the last split or analysis with \code{nested == FALSE}. + +Furthermore, resolution occurs against the first element of each +arm of a branching point caused by any previous uses of +\code{at_sibling} but \emph{only descends into the last arm}. + +So for example if our previous layout was generated via: + +\if{html}{\out{
}}\preformatted{lyt <- basic_table() |> + split_rows_by("SEX") |> + analyze("AGE") |> + split_rows_by("BMRKR2", nested = FALSE) |> + split_rows_by("RACE") |> + analyze("AGE") |> + split_rows_by("SEX", at_sibling = "RACE") |> + analyze("BMRKR1") +}\if{html}{\out{
}} + +The eligible anchor points would be \code{"BMRKR2"}, \code{"RACE"}, \code{"SEX"} +and \code{"BMRKR1"}. \code{"AGE"} is masked by the branching caused by +anchoring our \code{SEX} split on \code{RACE}. + +Finally, while \code{at_sibling} does support de-duplication of +\code{"[i]"} anchors, it does so \strong{within the set of available +anchors}, which can be counter-intuitive. It is strongly suggested +that the \code{parent_name} and \code{table_names} argument(s) of +\verb{split_rows_by*} and \code{analyze} be used to prevent the need for +this. \code{at_sibling} will resolve to table names overridden in this +manner. +} + \examples{ lyt <- basic_table() |> split_cols_by("ARM") |> diff --git a/man/varcuts.Rd b/man/varcuts.Rd index 10aa405a9..bfe3db0b6 100644 --- a/man/varcuts.Rd +++ b/man/varcuts.Rd @@ -31,8 +31,9 @@ split_rows_by_cuts( format = NULL, na_str = NA_character_, nested = TRUE, + at_sibling = NULL, cumulative = FALSE, - label_pos = "hidden", + label_pos = if (!is.null(at_sibling)) "visible" else "default", section_div = NA_character_ ) @@ -68,11 +69,12 @@ split_rows_by_quartiles( format = NULL, na_str = NA_character_, nested = TRUE, + at_sibling = NULL, child_labels = c("default", "visible", "hidden"), extra_args = list(), cumulative = FALSE, indent_mod = 0L, - label_pos = "hidden", + label_pos = if (!is.null(at_sibling)) "visible" else "default", section_div = NA_character_ ) @@ -86,11 +88,12 @@ split_rows_by_cutfun( format = NULL, na_str = NA_character_, nested = TRUE, + at_sibling = NULL, child_labels = c("default", "visible", "hidden"), extra_args = list(), cumulative = FALSE, indent_mod = 0L, - label_pos = "hidden", + label_pos = if (!is.null(at_sibling)) "visible" else "default", section_div = NA_character_ ) } @@ -130,6 +133,11 @@ functions. See \code{\link[formatters:list_valid_format_labels]{formatters::list \item{na_str}{(\code{string})\cr string that should be displayed when the value of \code{x} is missing. Defaults to \code{"NA"}.} +\item{at_sibling}{(\code{character(1)} or \code{NULL})\cr If non-null, a preceding +split or analyze to anchor this instruction to as a direct sibling. Cannot +select an instruction that is downstream of a point where a previously used +anchor (See Nesting Anchor Resolution for details).} + \item{label_pos}{(\code{string})\cr location where the variable label should be displayed. Accepts \code{"hidden"} (default for non-analyze row splits), \code{"visible"}, \code{"topleft"}, and \code{"default"} (for analyze splits only). For \code{analyze} calls, \code{"default"} indicates that the variable should be visible if and only if multiple variables are @@ -167,6 +175,45 @@ For dynamic cuts, the cut is transformed into a static cut by \code{\link[=build before proceeding. Thus even when nested within another split in column/row space, the resulting split will reflect the overall values (e.g., quartiles) in the dataset, NOT the values for subset it is nested under. } +\section{Nesting Anchor Resolution}{ + + +When \code{nested} is \code{TRUE}, \code{at_sibling} allows you to set a \emph{nesting +anchor} that your new \verb{split_rows_by*} or \verb{analyze*} directive +should be placed as a sibling to. The lookup for this anchor +occurs \emph{only in the currently active top-level nesting stack}, +meaning the directives that have occurred since +the last split or analysis with \code{nested == FALSE}. + +Furthermore, resolution occurs against the first element of each +arm of a branching point caused by any previous uses of +\code{at_sibling} but \emph{only descends into the last arm}. + +So for example if our previous layout was generated via: + +\if{html}{\out{
}}\preformatted{lyt <- basic_table() |> + split_rows_by("SEX") |> + analyze("AGE") |> + split_rows_by("BMRKR2", nested = FALSE) |> + split_rows_by("RACE") |> + analyze("AGE") |> + split_rows_by("SEX", at_sibling = "RACE") |> + analyze("BMRKR1") +}\if{html}{\out{
}} + +The eligible anchor points would be \code{"BMRKR2"}, \code{"RACE"}, \code{"SEX"} +and \code{"BMRKR1"}. \code{"AGE"} is masked by the branching caused by +anchoring our \code{SEX} split on \code{RACE}. + +Finally, while \code{at_sibling} does support de-duplication of +\code{"[i]"} anchors, it does so \strong{within the set of available +anchors}, which can be counter-intuitive. It is strongly suggested +that the \code{parent_name} and \code{table_names} argument(s) of +\verb{split_rows_by*} and \code{analyze} be used to prevent the need for +this. \code{at_sibling} will resolve to table names overridden in this +manner. +} + \examples{ \dontshow{if (require(dplyr)) withAutoprint(\{ # examplesIf} library(dplyr) diff --git a/tests/testthat/test-lyt-tabulation.R b/tests/testthat/test-lyt-tabulation.R index 9db1f7b17..d26fda25b 100644 --- a/tests/testthat/test-lyt-tabulation.R +++ b/tests/testthat/test-lyt-tabulation.R @@ -1,5 +1,6 @@ context("Tabulation framework") +## most tests related to nesting behavior moved to test-nesting.R test_that("summarize_row_groups works with provided funcs", { l1 <- basic_table() |> @@ -470,7 +471,6 @@ test_that("split under analyze", { expect_equal(nrow(dontnest), 5) }) - test_that("label_var works as expected", { yeslblslyt <- basic_table(show_colcounts = TRUE) |> split_cols_by(var = "ARM") |> @@ -989,32 +989,6 @@ 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") |> - 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") |> - analyze("AGE") - tbl2 <- build_table(lyt2, ex_adsl) - - ## printing machinery works - str <- toString(tbl2) - expect_identical(ncol(tbl2), 12L) -}) - - test_that("topleft label position works", { lyt <- basic_table(show_colcounts = TRUE) |> split_cols_by("ARM") |> diff --git a/tests/testthat/test-nesting.R b/tests/testthat/test-nesting.R new file mode 100644 index 000000000..84c443b68 --- /dev/null +++ b/tests/testthat/test-nesting.R @@ -0,0 +1,553 @@ +## 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") |> + build_table(rawdat) + expect_equal(nrow(dontnest), 5) +}) + +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") |> + 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") |> + analyze("AGE") + tbl2 <- build_table(lyt2, ex_adsl) + + ## printing machinery works + str <- toString(tbl2) + expect_identical(ncol(tbl2), 12L) +}) + + +test_that("at_sibling creates intermediate row nesting", { + path_count <- function(tt, pth) length(tt_normalize_row_path(tt, pth)) + + lyt <- basic_table() |> + split_rows_by("RACE") |> + split_rows_by("FACTOR2") |> + analyze("AGE") |> + split_rows_by("SEX", at_sibling = "FACTOR2") |> + analyze("AGE") + tbl <- build_table(lyt, rawdat) + + expect_gt(path_count(tbl, c("RACE", "WHITE", "FACTOR2", "A", "AGE", "Mean")), 0L) + expect_gt(path_count(tbl, c("RACE", "WHITE", "SEX", "M", "AGE", "Mean")), 0L) + expect_equal(path_count(tbl, c("RACE", "WHITE", "FACTOR2", "A", "SEX", "M", "AGE", "Mean")), 0L) + expect_true(all(c("FACTOR2", "SEX") %in% row.names(tbl))) + + sibling_analysis <- basic_table() |> + split_rows_by("RACE") |> + split_rows_by("FACTOR2") |> + analyze("AGE") |> + analyze("AGE", at_sibling = "FACTOR2") |> + build_table(rawdat) + expect_gt(path_count(sibling_analysis, c("RACE", "WHITE", "AGE", "Mean")), 0L) +}) + +test_that("at_sibling row split works with row summaries", { + path_count <- function(tt, pth) length(tt_normalize_row_path(tt, pth)) + + lyt <- basic_table() |> + split_rows_by("RACE") |> + summarize_row_groups() |> + analyze("AGE") |> + split_rows_by("SEX", at_sibling = "AGE") |> + summarize_row_groups() |> + analyze("AGE") + + tbl <- build_table(lyt, rawdat) + + expect_gt(path_count(tbl, c("RACE", "*", "@content")), 0L) + expect_gt(path_count(tbl, c("RACE", "*", "SEX", "*", "@content")), 0L) +}) + +test_that("at_sibling rejects page_by splits", { + expect_error( + basic_table() |> + split_rows_by("STRATA1", page_by = TRUE) |> + split_rows_by("RACE", at_sibling = "STRATA1"), + "at_sibling pointed to a split with forced pagination" + ) +}) + +test_that("at_sibling shows dynamic cut split labels", { + path_count <- function(tt, pth) length(tt_normalize_row_path(tt, pth)) + + lyt <- basic_table() |> + split_rows_by("RACE") |> + split_rows_by("FACTOR2") |> + analyze("AGE") |> + split_rows_by_cutfun("AGE", at_sibling = "FACTOR2") |> + analyze("AGE") + tbl <- build_table(lyt, rawdat) + + expect_gt(path_count(tbl, c("RACE", "WHITE", "AGE", "1st qrtile", "AGE", "Mean")), 0L) + expect_true("AGE" %in% row.names(tbl)) +}) + + +test_that("intermediate nesting works correctly", { + ## analyze nested at "proper" (non top level) split + lyt <- basic_table() |> + split_cols_by("ARM") |> + split_rows_by("STRATA1") |> + split_rows_by("SEX", split_fun = keep_split_levels(c("F", "M"))) |> + analyze("AGE") |> + analyze("BMRKR2", at_sibling = "SEX") + + tbl <- build_table(lyt, ex_adsl) + + bmrkr_rpaths <- tt_normalize_row_path(tbl, c("STRATA1", "*", "BMRKR2")) + + expect_identical( + bmrkr_rpaths, + list( + A = c("STRATA1", "A", "BMRKR2"), + B = c("STRATA1", "B", "BMRKR2"), + C = c("STRATA1", "C", "BMRKR2") + ) + ) + + expect_equal( + length(bmrkr_rpaths), + length(tt_normalize_row_path(tbl, c("STRATA1", "*", "SEX"))) + ) + + ## split nested at "proper" (non top level) split + ## summarize_row_groups on a nest at_sibling row split + lyt2 <- basic_table() |> + split_cols_by("ARM") |> + split_rows_by("STRATA1") |> + split_rows_by("SEX", split_fun = keep_split_levels(c("F", "M"))) |> + analyze("AGE") |> + split_rows_by("BMRKR2", nested = TRUE, at_sibling = "SEX") |> + summarize_row_groups("BMRKR2") |> + analyze("AGE") + + tbl2 <- build_table(lyt2, ex_adsl) + ## each facet of BMRKR2 split has (non-empty) content, ie + ## summarize_row_groups attached to the right place + expect_equal( + length(tt_normalize_row_path(tbl2, c("STRATA1", "*", "BMRKR2", "*", "@content"))), + 9L + ) + + ## SEX didn't have a summarize row groups instruction + ## tt_normalize_row_path says c(..., "@content") path doesn't exist + ## if content table is empty (no rows) or NULL + expect_equal( + length(tt_normalize_row_path(tbl2, c("STRATA1", "*", "SEX", "*", "@content"))), + 0L + ) + + + tmpdat <- subset(ex_adsl, STRATA1 == "A" & BMRKR2 == "LOW") + expect_identical( + cell_values(tbl2, c("STRATA1", "A", "BMRKR2", "LOW", "AGE")), + ## tapply insists on making an array which trips up waldo/testthat + lapply(split(tmpdat$AGE, tmpdat$ARM), mean) + ) + + + ## at_sibling = gracefully works as nested = FALSE + ## we are intentionally strict using expect_identical for these + lyt3 <- basic_table() |> + split_cols_by("ARM") |> + split_rows_by("STRATA1") |> + split_rows_by("SEX", split_fun = keep_split_levels(c("F", "M"))) |> + analyze("AGE") |> + analyze("BMRKR2", at_sibling = "STRATA1") + + tbl3 <- build_table(lyt3, ex_adsl) + + lyt3b <- basic_table() |> + split_cols_by("ARM") |> + split_rows_by("STRATA1") |> + split_rows_by("SEX", split_fun = keep_split_levels(c("F", "M"))) |> + analyze("AGE") |> + analyze("BMRKR2", nested = FALSE) + + tbl3b <- build_table(lyt3b, ex_adsl) + expect_identical(tbl3, tbl3b) + + lyt4 <- basic_table() |> + split_cols_by("ARM") |> + split_rows_by("STRATA1") |> + split_rows_by("SEX", split_fun = keep_split_levels(c("F", "M"))) |> + analyze("AGE") |> + ## NB this here, currently different default label behavior. Is that good or bad?? + split_rows_by("BMRKR2", nested = TRUE, at_sibling = "STRATA1", label_pos = "hidden") |> + summarize_row_groups("BMRKR2") |> + analyze("AGE") + + tbl4 <- build_table(lyt4, ex_adsl) + + lyt4b <- basic_table() |> + split_cols_by("ARM") |> + split_rows_by("STRATA1") |> + split_rows_by("SEX", split_fun = keep_split_levels(c("F", "M"))) |> + analyze("AGE") |> + split_rows_by("BMRKR2", nested = FALSE) |> + summarize_row_groups("BMRKR2") |> + analyze("AGE") + + tbl4b <- build_table(lyt4b, ex_adsl) + expect_identical(tbl4, tbl4b) + + ## Useful errors for bad at_sibling + expect_error( + { + basic_table() |> + split_cols_by("ARM") |> + split_rows_by("STRATA1") |> + split_rows_by("SEX", split_fun = keep_split_levels(c("F", "M"))) |> + analyze("AGE") |> + analyze("BMRKR2", at_sibling = "whaaaaat?") + }, + "Unable to find structural element" + ) + + expect_error( + { + basic_table() |> + split_rows_by("ARM", page_by = TRUE) |> + split_rows_by("STRATA1", page_by = TRUE) |> + split_rows_by("SEX") |> + analyze("AGE") |> + split_rows_by("RACE", at_sibling = "STRATA1") + }, + "at_sibling pointed to a split with forced pagination" + ) + + + path_count <- function(tt, pth) length(tt_normalize_row_path(tt, pth)) + keep_2_levels <- function(varnm, dat = ex_adsl) keep_split_levels(levels(dat[[varnm]])[1:2]) + + ## even though this doesn't make a ton of sense, as the correct thing is for + ## BMRKR2's at_sibling to also be "SEX", as that is the anchor point for the + ## tree it (and RACE) is appended to, + ## it was easier to support it than to construct a fully useful error message :-/. + lyt_silly <- basic_table() |> + split_rows_by("STRATA1", split_fun = keep_2_levels("STRATA1")) |> + split_rows_by("SEX", split_fun = keep_2_levels("SEX")) |> + analyze("AGE") |> + split_rows_by("RACE", split_fun = keep_2_levels("RACE"), at_sibling = "SEX") |> + analyze("AGE") |> + split_rows_by("BMRKR2", split_fun = keep_2_levels("BMRKR2"), at_sibling = "RACE") |> + analyze("AGE") + + tbl <- build_table(lyt_silly, ex_adsl) + + ## these are fast enough that we can be a bit repetetive/redundant + ## they're the same cause it's powers of 2 due to keep_2_levels splitfun + expect_equal( + path_count(tbl, c("STRATA1", "*", "SEX", "*", "AGE")), + path_count(tbl, c("STRATA1", "*", "RACE", "*", "AGE")) + ) + + ## RACE and BMRKR2 are siblings to eachother (anchored on SEX) + expect_equal( + path_count(tbl, c("STRATA1", "*", "RACE", "*", "AGE")), + path_count(tbl, c("STRATA1", "*", "BMRKR2", "*", "AGE")) + ) + + ## should not exist + expect_equal( + path_count(tbl, c("STRATA1", "*", "RACE", "*", "BMRKR2")), + 0L + ) + + ## at_sibling finds overridden table names + + lyt_ovrd <- basic_table() |> + split_cols_by("ARM") |> + split_rows_by("RACE", split_fun = keep_2_levels("RACE")) |> + split_rows_by("BMRKR2", + split_fun = keep_2_levels("BMRKR2"), + parent_name = "funkytown" + ) |> + analyze("AGE") |> + split_rows_by("STRATA1", + split_fun = keep_2_levels("STRATA1"), + at_sibling = "funkytown" + ) |> + analyze("BMRKR1") + tbl_ovrd <- build_table(lyt_ovrd, ex_adsl) + + expect_equal( + path_count(tbl_ovrd, c("RACE", "*", "funkytown", "*", "AGE")), + path_count(tbl_ovrd, c("RACE", "*", "STRATA1", "*", "BMRKR1")) + ) + + expect_equal( + path_count(tbl_ovrd, c("STRATA1", "*", "BMRKR1")), + 0L + ) + + lyt_other <- basic_table() |> + split_rows_by("STRATA1") |> + split_rows_by("SEX") |> + analyze("AGE") |> + split_rows_by("RACE", at_sibling = "SEX") |> + split_rows_by("BMRKR2") |> + analyze("AGE") |> + analyze("BMRKR1", at_sibling = "BMRKR2") + + expect_identical( + get_anchor_list(lyt_other), + list( + "STRATA1", + c("SEX", "RACE"), + c("BMRKR2", "BMRKR1") + ) + ) + + ## these layouts are completely ridiculous but they exercise the index resolution in + ## anchor lookup + ## + ## gotta catch them all + + clowndat <- subset(ex_adsl, RACE %in% levels(RACE)[1:2]) + clowndat$RACE <- factor(clowndat$RACE) + + clown_base <- basic_table() |> + analyze("RACE") |> + split_rows_by("SEX", split_fun = keep_2_levels("SEX")) |> + split_rows_by("RACE") |> + split_rows_by("STRATA1", split_fun = keep_2_levels("STRATA1")) |> + analyze("RACE") |> + split_rows_by("BMRKR2", split_fun = keep_2_levels("BMRKR2"), at_sibling = "RACE[2]") |> + analyze("AGE") + + expect_identical( + get_anchor_list(clown_base), + list( + "RACE", + "SEX", + "RACE", + "STRATA1", + c( + "RACE", + "BMRKR2" + ), + "AGE" + ) + ) + + + ## RACE (xx) masked by unnested splitting below + ## SEX -> | RACE -> STRATA1 -> | RACE (2) + ## |--------------------| BMRKR2 -> AGE + ## | COUNTRY -> BMRKR1 + + clown_shoes <- clown_base |> + split_rows_by("COUNTRY", + split_fun = keep_2_levels("COUNTRY"), + at_sibling = "RACE" + ) |> + analyze("BMRKR1") + + tbl_clown <- build_table(clown_shoes, clowndat) + expect_equal( + path_count(tbl_clown, c("RACE", "*")), + 2L + ) + expect_equal( + path_count(tbl_clown, c("SEX", "*", "RACE", "*", "STRATA1", "*", "RACE", "*")), + 16L + ) + + expect_equal( + path_count(tbl_clown, c("SEX", "*", "RACE", "*", "STRATA1", "*", "BMRKR2", "*")), + 16L + ) + + expect_equal( + path_count(tbl_clown, c("SEX", "*", "COUNTRY", "*")), + 4L + ) + + expect_equal( + path_count(tbl_clown, c("COUNTRY", "*")), + 0L + ) + + ## RACE (xx) masked by unnested splitting below + ## SEX -> | RACE -> STRATA1 -> | RACE (2) + ## | BMRKR2 -> AGE + ## | COUNTRY -> BMRKR1 + ## + + clown_shoes2 <- clown_base |> + split_rows_by("COUNTRY", + split_fun = keep_2_levels("COUNTRY"), + at_sibling = "RACE[2]" + ) |> + analyze("BMRKR1") + + tbl_clown2 <- build_table(clown_shoes2, clowndat) + + expect_equal( + path_count(tbl_clown2, c("SEX", "*", "COUNTRY", "*")), + 0L + ) + + expect_equal( + path_count(tbl_clown2, c("SEX", "*", "RACE", "*", "STRATA1", "*", "COUNTRY", "*")), + 16L + ) + + ## first RACE analysis is masked, so it can only find 2 (split after SEX and + ## analyze after STRATA1) + expect_error( + clown_base |> + split_rows_by("COUNTRY", at_sibling = "RACE[3]"), + regexp = "Found only 2 eligible elements named 'RACE', but at_sibling was 'RACE\\[3\\]'" + ) + + clown_nose <- basic_table() |> + split_rows_by("STRATA1", split_fun = keep_2_levels("RACE")) |> + split_rows_by("STRATA2", split_fun = keep_2_levels("STRATA2")) |> + analyze("ARM") |> + split_rows_by("SEX", split_fun = keep_2_levels("SEX")) |> + split_rows_by("RACE") |> + split_rows_by("STRATA1", split_fun = keep_2_levels("STRATA1")) |> + analyze("BMRKR1") |> + split_rows_by("BMRKR2", split_fun = keep_2_levels("BMRKR2"), at_sibling = "RACE") |> + split_rows_by("COUNTRY", split_fun = keep_2_levels("COUNTRY")) |> + analyze("AGE") |> + split_rows_by("SITEID", split_fun = drop_split_levels, at_sibling = "RACE") |> + split_rows_by("BEP01FL") |> + analyze("AGE") + + ## this ensures STRATA2 is masked, ie only the base split of previous + ## top-level structures are available + expect_identical( + get_anchor_list(clown_nose), + list( + "STRATA1", + "SEX", + c("RACE", "BMRKR2", "SITEID"), + "BEP01FL", + "AGE" + ) + ) + + ## "Full On" INSANEO STYLE + ## STRATA1 -> SEX -> | AGE + ## | DCSREAS -> COUNTRY -> AGE + ## | Race -> | COUNTRY -> BMRKR1 + ## | BMRKR2 -> AGE + + lyt7 <- basic_table() |> + split_cols_by("ARM") |> + split_rows_by("STRATA1") |> + split_rows_by("SEX", split_fun = keep_2_levels("SEX")) |> + analyze("AGE") |> + split_rows_by("DCSREAS", split_fun = keep_2_levels("DCSREAS"), nested = TRUE, at_sibling = "AGE") |> + split_rows_by("COUNTRY", split_fun = keep_2_levels("COUNTRY")) |> ## its a trap! + analyze("AGE") |> ## its a trap redux + ## tricky fish AGE == AGE[[1]] + split_rows_by("RACE", split_fun = keep_2_levels("RACE"), nested = TRUE, at_sibling = "AGE") |> + split_rows_by("COUNTRY", split_fun = keep_2_levels("COUNTRY"), nested = TRUE) |> + analyze("BMRKR1") |> + ## did we get the right one? + split_rows_by("BMRKR2", split_fun = keep_2_levels("BMRKR2"), nested = TRUE, at_sibling = "COUNTRY") |> + analyze("AGE") + + tbl_is <- build_table(lyt7, ex_adsl) + + ## should exist + expect_equal( + path_count(tbl_is, c("STRATA1", "*", "SEX", "*", "AGE")), + 6L + ) + expect_equal( + path_count(tbl_is, c("STRATA1", "*", "SEX", "*", "RACE", "*", "COUNTRY", "*", "BMRKR1")), + 24L + ) # 3 strata 2 sex 2 race 2 country + expect_equal( + path_count(tbl_is, c("STRATA1", "*", "SEX", "*", "RACE", "*", "BMRKR2", "*", "AGE")), + 24L + ) + + ## should not exist + expect_equal( + path_count(tbl_is, c("STRATA1", "*", "SEX", "*", "RACE", "*", "AGE")), + 0L + ) + + ## trap 1: does BMRKR2 go to the right COUNTRY + expect_equal( + path_count(tbl_is, c("STRATA1", "*", "SEX", "*", "DCSREAS", "*", "BMRKR2")), + 0L + ) + + ## trap 2: does RACE go to the right AGE + expect_equal( + path_count(tbl_is, c("STRATA1", "*", "SEX", "*", "DCSREAS", "*", "COUNTRY", "*", "RACE")), + 0L + ) + + ## "Full On" INSANEO STYLE v2 + ## STRATA1 -> SEX -> | AGE + ## | DCSREAS -> COUNTRY -> | AGE + ## | ---------------------- | Race -> BMRKR2 -> BMRKR1 + ## | BMRKR2 -> AGE + + lyt7b <- basic_table() |> + split_rows_by("STRATA1", split_fun = keep_2_levels("STRATA1")) |> + split_rows_by("SEX", split_fun = keep_2_levels("SEX")) |> + analyze("AGE") |> + split_rows_by("DCSREAS", split_fun = keep_2_levels("DCSREAS"), nested = TRUE, at_sibling = "AGE") |> + split_rows_by("COUNTRY", split_fun = keep_2_levels("COUNTRY")) |> ## its a trap! + analyze("AGE") |> ## its a trap redux + ## tricky fish AGE == AGE[1] + split_rows_by("RACE", split_fun = keep_2_levels("RACE"), nested = TRUE, at_sibling = "AGE[2]") |> + split_rows_by("BMRKR2", split_fun = keep_2_levels("BMRKR2"), nested = TRUE) |> + analyze("BMRKR1") |> + ## did we get the right one? + split_rows_by("BMRKR2", split_fun = keep_2_levels("BMRKR2"), nested = TRUE, at_sibling = "AGE") |> + analyze("AGE") + + tbl_is2 <- build_table(lyt7b, ex_adsl) + + expect_equal( + path_count( + tbl_is2, + c("STRATA1", "*", "SEX", "*", "DCSREAS", "*", "COUNTRY", "*", "AGE") + ), + 16L + ) + expect_equal( + path_count( + tbl_is2, + c("STRATA1", "*", "SEX", "*", "DCSREAS", "*", "COUNTRY", "*", "RACE", "*", "BMRKR2", "*", "BMRKR1") + ), + 64L + ) + expect_equal( + path_count( + tbl_is2, + c("STRATA1", "*", "SEX", "*", "BMRKR2", "*", "AGE") + ), + 8L + ) +}) diff --git a/vignettes/guided_intro_nesting.Rmd b/vignettes/guided_intro_nesting.Rmd index d28e1fd65..94619b1d4 100644 --- a/vignettes/guided_intro_nesting.Rmd +++ b/vignettes/guided_intro_nesting.Rmd @@ -1,5 +1,5 @@ --- -title: "Introductory rtables - Facet And Analysis Nesting" +title: "Introductory `rtables` - Facet And Analysis Nesting" author: "Gabriel Becker" date: "`r Sys.Date()`" output: rmarkdown::html_vignette @@ -38,6 +38,15 @@ column structure, or both; or combinations of all three of these. We achieve all of these by leveraging *nesting* of layout instructions. +Throughout this vignette we will use a custom split function (`keep_2_levels`) +for table brevity, defined as follows: + +```{r} +keep_2_levels <- function(varnm, dat = ex_adsl) { + keep_split_levels(levels(dat[[varnm]])[1:2]) +} +``` + # Nesting *Nesting* is how we talk about *where* a layout instruction fits with @@ -59,31 +68,384 @@ library(rtables) lyt <- basic_table() |> split_cols_by("ARM") |> split_cols_by("STRATA1") |> - split_rows_by("SEX") |> - split_rows_by("BMRKR2") |> + split_rows_by("SEX", split_fun = keep_2_levels("SEX")) |> + split_rows_by("BMRKR2", split_fun = keep_2_levels("BMRKR2")) |> analyze("AGE") -build_table(lyt, ex_adsl) +table_structure(build_table(lyt, ex_adsl)) ``` When `analyze` instructions are 'nested within' another `analyze`, the analyses are bundled into a 'multi-analysis' parent structure. This -parent structure as a whole, then, has the nesting behavior that an +parent structure as a whole, then, has the nesting behavior that a single `analyze` call would have in its place. ```{r} lyt2 <- basic_table() |> split_cols_by("ARM") |> split_cols_by("STRATA1") |> - split_rows_by("SEX") |> - split_rows_by("BMRKR2") |> + split_rows_by("SEX", split_fun = keep_2_levels("SEX")) |> + split_rows_by("BMRKR2", split_fun = keep_2_levels("BMRKR2")) |> analyze("AGE") |> analyze("BMRKR1") -head(build_table(lyt2, ex_adsl), 32) +table_structure(build_table(lyt2, ex_adsl)) ``` - By default: - `analyze` calls nest within the most recently preceding `split_rows_by` or instruction - multiple `analyze` calls that nest within the + +## Creating 'Multi-Section' Tables With `nested = FALSE` + +We often want to create tables with rows grouped into two or more +logical or analytical sections. For example we might want to analyze +`AGE` overall, then separately by `SEX` and by `RACE`. We can do this by: + +1. `analyze`ing `AGE`, then +2. splitting by `SEX` and `analyze`ing `AGE`, and finally +3. splitting by `RACE` and `analyze`ing `AGE` again. + +We will start each section after the first with `nested = FALSE` to +delineate it from the previous portion of the layout. + +NOTE: while we will do it explicitly for illustration purposes, any +`split_rows_by` layout instruction that follows an `analyze` +defaults to `nested = FALSE`. + +Thus we can create our table with the code below: + +Note: we set a top level section divider to make our different +sections concrete; section dividers will be covered in a later part of +this guide and can be taken as is for now. + +```{r} +trim_adsl <- subset(ex_adsl, RACE %in% levels(ex_adsl$RACE)[1:3] & SEX %in% c("F", "M")) +trim_adsl$RACE <- factor(trim_adsl$RACE) +trim_adsl$SEX <- factor(trim_adsl$SEX) + +nice_mean <- function(x) { + in_rows("Average Age" = mean(x), .formats = list("Average Age" = "xx.x")) +} + +lyt3 <- basic_table(top_level_section_div = "-") |> + split_cols_by("ARM") |> + analyze("AGE", afun = nice_mean) |> + split_rows_by("SEX", nested = FALSE) |> + analyze("AGE", afun = nice_mean) |> + split_rows_by("RACE", nested = FALSE) |> + analyze("AGE", afun = nice_mean) + +tbl3 <- build_table(lyt3, trim_adsl) +tbl3 +``` + +We see three clear top-level 'sections' of our table in row-space, as +desired. Contrast this with our result without `nested = FALSE` (and +with the first two `analyze` calls replaced with +`summarize_row_groups`: + + +```{r} +nice_mean_cfun <- function(x, labelstr) { + lbl <- paste0(labelstr, " (Ave. Age)") + in_rows(mean(x), .labels = lbl, .formats = "xx.x") +} + +lyt3b <- basic_table(top_level_section_div = "-") |> + split_cols_by("ARM") |> + summarize_row_groups("AGE", cfun = nice_mean_cfun) |> + split_rows_by("SEX", split_fun = keep_2_levels("SEX")) |> + summarize_row_groups("AGE", cfun = nice_mean_cfun) |> + split_rows_by("RACE", split_fun = keep_2_levels("RACE")) |> + analyze("AGE", afun = nice_mean) + +tbl3b <- build_table(lyt3b, trim_adsl) +head(tbl3b) +``` + +Here the faceting on `RACE` occurs *nested within* the faceting on +`SEX`, whereas above it occurs *alongside* it. + +### A Brief Note On Removing Sections + +Sometimes we will receive a template script that does more than we +want, but is close to meeting our needs. For example, imagine we +wanted the above table (non-nested version) but only wanted the +overall and race portions, removing the age within gender analysis. + +We do this by simply identifying all of the layout instructions +corresponding to that portion of the table and removing them. Our top +level section dividers can help us reason about this, and can be added +to the template if they were not there originally. + +In our case, the instructions for our section to remove are the +`split_rows_by("SEX", nested = FALSE)`, and directly following +`analyze("AGE")` calls. By starting with our code above and removing +those, we would get our desired table: + + +```{r} +lyt3c <- basic_table(top_level_section_div = "-") |> + split_cols_by("ARM") |> + analyze("AGE", afun = nice_mean) |> + ## split_rows_by("SEX", nested = FALSE) |> + ## analyze("AGE", afun = nice_mean) |> + split_rows_by("RACE", nested = FALSE) |> + analyze("AGE", afun = nice_mean) + +tbl3c <- build_table(lyt3c, trim_adsl) +tbl3c +``` + +When performing this kind of layout pruning in the wild, it is +important to remember that `split_rows_by` calls that follow `analyze` +calls default to `nested = FALSE`, even if that is not made explicit +in the template script you are starting from. + +It is also important to not remove all `analyze` call(s) nested within +any series of row faceting (`split_rows_by*` calls), as this will +result in an degenerate (invalidly structured) table which could have +undefined behavior when passed to some other aspects of the `rtables` +and `formatters` APIs. + +## Intermediate Nesting + +As of `rtables` `0.7.0`, we can declare *intermediate* nesting, rather +than simply full -- the previous and now default behavior when `nested += TRUE` -- and no -- the `nested = FALSE` behavior -- nesting. + +We do this via the new `at_sibling` parameter the `split_rows_by*` and +`analyze*` families of layout functions now accept. `at_sibling` allows +us to specify the *nesting anchor* for a row split or analyze directive; +when we do so, the table resulting from our new directive will appear +*as a direct sibling* to that resulting from our anchor in the +created table. + + +Consider where our `BMRKR2` analysis is placed in when using the +following layouts to build tables: + +The default behavior: +```{r} +lyt4 <- basic_table() |> + split_cols_by("ARM") |> + split_rows_by("STRATA1", split_fun = keep_2_levels("STRATA1")) |> + split_rows_by("SEX", split_fun = keep_2_levels("SEX")) |> + analyze("AGE") |> + analyze("BMRKR2") + +build_table(lyt4, ex_adsl) +``` + +Anchoring the analysis on `"SEX"`: +```{r} +lyt4a <- basic_table() |> + split_cols_by("ARM") |> + split_rows_by("STRATA1", split_fun = keep_2_levels("STRATA1")) |> + split_rows_by("SEX", split_fun = keep_2_levels("SEX")) |> + analyze("AGE") |> + analyze("BMRKR2", at_sibling = "SEX", show_labels = "visible") + +build_table(lyt4a, ex_adsl) +``` + +Anchoring the analysis on `"STRATA1"` +```{r} +lyt4b <- basic_table() |> + split_cols_by("ARM") |> + split_rows_by("STRATA1", split_fun = keep_2_levels("STRATA1")) |> + split_rows_by("SEX", split_fun = keep_2_levels("SEX")) |> + analyze("AGE") |> + analyze("BMRKR2", at_sibling = "STRATA1", show_labels = "visible") + +build_table(lyt4b, ex_adsl) +``` + +Analysis is fully non-nested: +```{r} +lyt4c <- basic_table() |> + split_cols_by("ARM") |> + split_rows_by("STRATA1", split_fun = keep_2_levels("STRATA1")) |> + split_rows_by("SEX", split_fun = keep_2_levels("SEX")) |> + analyze("AGE") |> + analyze("BMRKR2", nested = FALSE, show_labels = "visible") + +build_table(lyt4c, ex_adsl) +``` + +Note that because our `STRATA` split is a top-level split, anchoring +our analysis to it is equivalent to simply using `nested = +FALSE`. While these result in identically-rendering tables, they will +not if our current layout is placed under a new split, such as when we +want the same table structure both globally and split by subgroups or +parameters: + + + +Anchoring the analysis on `"STRATA1"` +```{r} +lyt4d <- basic_table() |> + split_cols_by("ARM") |> + split_rows_by("RACE", split_fun = keep_2_levels("RACE")) |> + split_rows_by("STRATA1", split_fun = keep_2_levels("STRATA1")) |> + split_rows_by("SEX", split_fun = keep_2_levels("SEX")) |> + analyze("AGE") |> + analyze("BMRKR2", at_sibling = "STRATA1", show_labels = "visible") + +build_table(lyt4d, ex_adsl) +``` + +Analysis is fully non-nested: +```{r} +lyt4c <- basic_table() |> + split_cols_by("ARM") |> + split_rows_by("RACE", split_fun = keep_2_levels("RACE")) |> + split_rows_by("STRATA1", split_fun = keep_2_levels("STRATA1")) |> + split_rows_by("SEX", split_fun = keep_2_levels("SEX")) |> + analyze("AGE") |> + analyze("BMRKR2", nested = FALSE, show_labels = "visible") + +build_table(lyt4c, ex_adsl) +``` + +Thus whether to use explicit anchoring to generate top-level sections +is a trade-off between explicit clarity (`nested = FALSE`) and +robustness to this sort of slotting the described structure into a +larger table (`at_sibling = `). + + +### Anchor Resolution + +Given a pre-existing layout, only certain elements are eligible to act +as nesting anchors. For clarity, we will use *element* to refer to +any individual layout instruction that effect the resulting table +row-structure (i.e., `split_rows_by*` and `analyze`); furthermore we +will refer to an element named by `at_sibling` as the *anchor point* +and an element placed via `at_sibling` as the *anchored element*. For +convenience we will refer to elements which do not act as anchor +points nor anchored elements as *standard elements*. + +Using this terminology, the general rules are as follows: + + +1. Elements nested within previous top-level elements are *not eligible*, +2. Elements nested within previous anchor points are *not eligible*, +3. For each previous anchor point, elements nested within anchored + elements other than the most recently placed one are *not + eligible*. + + +We can re-frame this into an algorithm to determine the list of +eligible elements like so: + +1. All previous top-level elements, +2. the current top-level element and all standard elements nested + directly within it until the first anchor point, +3. the anchor point and all of its anchored elements, +4. all standard elements nested within the most recent of this anchor + point's anchored elements, until the next anchor point, +5. repeat (3)-(4) until no more anchor points along the path exist. + +Viewed a certain way, this algorithm defines a horizon along the edge +of the branching structure defined by a layout. + +To illustrate these rules, and this concept of a horizon, consider the +following illustrative - if analytically nonsensical - complex row +layout: + + +```{r} +complex_lyt <- basic_table() |> + split_rows_by("STRATA1", split_fun = keep_2_levels("RACE")) |> + split_rows_by("STRATA2", split_fun = keep_2_levels("STRATA2")) |> + analyze("ARM") |> + split_rows_by("SEX", split_fun = keep_2_levels("SEX")) |> + split_rows_by("RACE", split_fun = keep_2_levels("RACE")) |> + split_rows_by("STRATA1", split_fun = keep_2_levels("STRATA1")) |> + analyze("BMRKR1") |> + split_rows_by("BMRKR2", split_fun = keep_2_levels("BMRKR2"), at_sibling = "RACE") |> + split_rows_by("COUNTRY", split_fun = keep_2_levels("COUNTRY")) |> + analyze("AGE") |> + split_rows_by("SITEID", split_fun = drop_split_levels, at_sibling = "RACE") |> + split_rows_by("BEP01FL", split_fun = keep_2_levels("BEP01FL")) |> + analyze("AGE") +``` + +We can get the list of eligible anchor points via `get_anchor_list`: + + +```{r} +get_anchor_list(complex_lyt) +``` + +We can see that our first `STRATA1` split is eligible, but the +`STRATA2` split nested within it and the `ARM` analysis nested within +that are not. Then, for the current top-level structure, `SEX`(std element) +`RACE`(anchor pt), `BMRKR2` (anchored element), `SITEID` (anchored element), +`BEP01FL` (std element), and `AGE` (std element) are eligible. + + +### Order Of Intermediate Nesting Placement + +The rules above imply a particular order required to place +intermediately nested elements anchored to different points within the +same top-level structure: + +*When you intend to anchor multiple points to different elements in a +sequence of splits, place them in order from most deeply nested anchor +point to least deeply nested anchor point.* + + +We can see this in practice, consider the following sequence of +splitting layout instructions (ending, as always, with an `analyze`): + +```{r} +lyt_stack <- basic_table() |> + split_rows_by("STRATA1", split_fun = keep_2_levels("STRATA1")) |> + split_rows_by("STRATA2", split_fun = keep_2_levels("STRATA2")) |> + split_rows_by("RACE", split_fun = keep_2_levels("RACE")) |> + split_rows_by("SEX", split_fun = keep_2_levels("SEX")) |> + analyze("AGE") +``` + +Now suppose we want to place additional `analyze`'s as siblings to the +`STRATA2` and `RACE` splits. + +If we do so in that order, our first placement will work: + +```{r} +lyt_stack2 <- lyt_stack |> + analyze("BMRKR1", at_sibling = "STRATA2") +``` + +But we will get an error when attempting to anchor another `analyze` onto `RACE`: + +```{r, error = TRUE} +lyt_stack2 |> + analyze("BMRKR2", at_sibling = "RACE") +``` + +If, however, we anchor our `BMRKR2` analyze to `RACE` *first*, and +then place our `BMRKR1` analyze to `STRATA2`, we can achieve both +placements: + + +```{r} +lyt_stack3 <- lyt_stack |> + analyze("BMRKR2", at_sibling = "RACE", show_labels = "visible") |> + analyze("BMRKR1", at_sibling = "STRATA2", show_labels = "visible") +``` + + +Thus we can build the (somewhat lengthy) desired table: + +```{r} +build_table(lyt_stack3, ex_adsl) +``` + +Phrased a different way, placing an anchored element at an anchor +point diverts the stream of eligible nested elements after that point +from those nested within the anchor point, or previously placed +anchored elements, to those nested within the newly placed anchored +element.