diff --git a/DESCRIPTION b/DESCRIPTION index 171067bcdb..6abf75480e 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 cbc71df906..7fb6afca93 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -106,7 +106,13 @@ export(export_as_txt) export(facet_colcount) export(find_degen_struct) export(format_rcell) +export(get_anchor_dfs) export(get_formatted_cells) +export(get_full_lyt_df) +export(get_kid_types) +export(get_layout_dfs) +export(get_row_anchor_df) +export(get_row_anchor_list) export(has_force_pag) export(head) export(header_section_div) @@ -270,6 +276,8 @@ exportMethods(coltree) exportMethods(content_table) exportMethods(dim) exportMethods(facet_colcount) +exportMethods(get_full_lyt_df) +exportMethods(get_kid_types) exportMethods(has_force_pag) exportMethods(head) exportMethods(horizontal_sep) diff --git a/NEWS.md b/NEWS.md index 810e02bb2a..e89cd53e94 100644 --- a/NEWS.md +++ b/NEWS.md @@ -21,9 +21,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 * content functions now receive correct `.ref_group` value instead of a data.frame with zero rows, when requested. #1117 @gmbecker * Fix in the now exported `RefFootnote` in check for disallowed values in `symbol` argument diff --git a/R/00tabletrees.R b/R/00tabletrees.R index 8741cff421..7f483f6968 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,9 @@ setClass("SplitVector", } else { lst <- NULL } - all(sapply(head(object, -1), is, "Split")) && - (is.null(lst) || is(lst, "Split") || is(lst, "VTableNodeInfo")) + ## only last element can be a splitvectree, others must be splits + all(sapply(head(object, -1), function(x) is(x, "Split"))) && + (is.null(lst) || split_or_splitvectree(lst) || is(lst, "VTableNodeInfo")) } ) @@ -1936,7 +1940,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 60258e6a92..7b64edfb2f 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 d54c927bf6..39296f2066 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,9 +325,38 @@ split_rows_by <- function(lyt, split_name = parent_name ) - pos <- next_rpos(lyt, nested) - ret <- split_rows(lyt, spl, pos) + ret <- do_next_split_rows(lyt = lyt, spl = spl, at_sibling = at_sibling, nested = nested) + ret +} + +is_analyze_spl <- function(spl) is(spl, "VAnalyzeSplit") || is(spl, "AnalyzeMultiVars") +## workhorse, this fires off all the checks via find_branch_pos + +do_next_split_rows <- function(lyt, spl, nested, at_sibling) { + checkmate::assert_string(at_sibling, null.ok = TRUE) + force(lyt) + if (!is.null(at_sibling)) { + anchordf <- get_row_anchor_df(lyt) + ## anchor point existence and validity checks occur here + bprow <- find_branch_pos_df(anchordf = anchordf, at_sibling = at_sibling) + if (bprow$is_toplevel) { + nested <- FALSE + at_sibling <- NULL + } + } + if (is.null(at_sibling)) { + cmpfun <- AnalyzeMultiVars + pos <- next_rpos(lyt, nested, at_sibling = at_sibling) + } else { + cmpfun <- pack_in_svt ## SplitVectorTree + pos <- bprow$anchor_step + } + if (is_analyze_spl(spl) && is_analyze_spl(last_rowsplit(lyt)) && nested && is.null(at_sibling)) { + ret <- cmpnd_last_rowsplit(lyt, spl, cmpfun) + } else { + ret <- split_rows(lyt, spl, pos, at_sibling = at_sibling, cmpnd_fun = cmpfun) + } ret } @@ -612,6 +432,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 +457,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 +474,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) + ret <- do_next_split_rows(lyt = lyt, spl = spl, at_sibling = at_sibling, nested = nested) + ret } #' Split on static or dynamic cuts of the data @@ -774,6 +597,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 +606,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 +624,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) + ret <- do_next_split_rows(lyt = lyt, spl = spl, at_sibling = at_sibling, nested = nested) + ret } #' @export @@ -874,11 +699,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 +723,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 +731,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 +755,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 +777,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) + ret <- do_next_split_rows(lyt = lyt, spl = spl, at_sibling = at_sibling, nested = nested) + ret } #' .spl_context within analysis and split functions @@ -1156,6 +972,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 +1016,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,13 +1090,35 @@ analyze <- function(lyt, na_strs_var = na_strs_var ) - if (nested && (is(last_rowsplit(lyt), "VAnalyzeSplit") || is(last_rowsplit(lyt), "AnalyzeMultiVars"))) { - cmpnd_last_rowsplit(lyt, spl, AnalyzeMultiVars) + ret <- do_next_split_rows(lyt = lyt, spl = spl, at_sibling = at_sibling, nested = nested) + ret + + ## ## drop down to pure nested = FALSE behavior for root anchor pts + ## if (!is.null(at_sibling) && branch_is_root(lyt, at_sibling)) { + ## nested <- FALSE + ## at_sibling <- NULL + ## } + ## 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, cmpfun) + ## } else { + ## ## analysis compounding now done in split_rows + ## pos <- next_rpos(lyt, nested, at_sibling = at_sibling) + ## split_rows(lyt, spl, pos, at_sibling = at_sibling, cmpnd_fun = cmpfun ) + ## } +} + +pack_in_svt <- function(.payload) { + a <- .payload[[1]] + b <- .payload[[2]] + nw <- SplitVector(b) + if (is(a, "SplitVectorTree")) { + lst <- c(a, list(nw)) } else { - ## analysis compounding now done in split_rows - pos <- next_rpos(lyt, nested) - split_rows(lyt, spl, pos) + lst <- list(SplitVector(a), SplitVector(b)) } + SplitVectorTree(lst = lst) } get_acolvar_name <- function(lyt) { @@ -1312,6 +1152,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 +1205,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 +1249,8 @@ analyze_colvars <- function(lyt, extra_args = extra_args, inclNAs = inclNAs ) - pos <- next_rpos(lyt, nested, for_analyze = TRUE) - split_rows(lyt, spl, pos) + ret <- do_next_split_rows(lyt = lyt, spl = spl, at_sibling = at_sibling, nested = nested) + ret } ## Add a total column at the next **top level** spot in @@ -1568,6 +1410,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 +1712,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 +1812,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 0000000000..486516326d --- /dev/null +++ b/R/nesting_impl.R @@ -0,0 +1,892 @@ +#' @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 { + for (i in seq_along(obj)) { + cur <- obj[[i]] + if (is(cur, "SplitVectorTree")) { + break + } + } + last_rowsplit(cur) + } + } +) + +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)) +} + +first_spl_forcepag <- function(splvectree) { + if (is(splvectree, "Split")) { ## could generic + methods but ... whyyyyy? + spl <- splvectree + } else { + spl <- unlist(splvectree, recursive = TRUE)[[1]] + } + has_force_pag(spl) +} + +first_spl_anchor_df <- function(splvectree, step) { + data.frame( + name = first_spl_name(splvectree), + force_pag = first_spl_forcepag(splvectree), + step = step + ) +} + + +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) +} + + +#' @rdname int_methods +#' @export +setGeneric("get_kid_types", function(obj, type) standardGeneric("get_kid_types")) +#' @rdname int_methods +#' @export +setMethod("get_kid_types", "Split", function(obj, type) type) +#' @rdname int_methods +#' @export +setMethod( + "get_kid_types", "SplitVector", + function(obj, type) { + switch(type, + anchor = c("anchor", rep("inactive", times = length(obj) - 1)), + inactive = c("sibling", rep("inactive", times = length(obj) - 1)), + active = rep("active", length(obj)) + ) + } +) + +#' @rdname int_methods +#' @export +setMethod( + "get_kid_types", "SplitVectorTree", + function(obj, type) { + c("anchor", rep("inactive", times = length(obj) - 2), type) + } +) +#' @rdname int_methods +#' @export +setMethod( + "get_kid_types", "PreDataRowLayout", + function(obj, type) { + c(rep("inactive", times = length(obj) - 1), "active") + } +) + + +## 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 + +#' Retrieve Info About Possible Nesting Anchors +#' +#' This function scans an existing layout's row structure and lists +#' valid `at_sibling` anchors for intermediate nesting. +#' +#' @param lyt (`PreDataTableLayouts`)\cr the layout. +#' @param splvec (`PreDataTableLayouts` or internal classes)\cr The layout or partial +#' layout to list anchors for. +#' @param next_node (`integer(1)`)\cr For internal use +#' @param next_anchor_step (`integer(1)`)\cr For internal use. +#' @param parent (`integer(1)`)\cr For internal use. +#' @param depth (`integer(1)`)\cr For internal use. +#' @param node_type (`character(1)`)\cr For internal use. +#' @details +#' +#' A layout data.frame is a data.frame describing a single dimension +#' of pre-data layout structure, containing the following columns +#' (most of which are used for internal implementations and will not +#' be useful to the end-user): +#' +#' - `name`: name of the element +#' - `nodeid`: sequential numeric id of the node, for use in +#' constructing graphs (0 is the root node) +#' - `parentid`: node id of the layout instructions direct parent +#' - `depth`: length of path from root to the current node through the +#' implicit graph defined by the (`nodeid`, `parentid`) pairings +#' - `type`: a description of the 'type' of the node, used internally +#' - `is_toplevel`: whether the node represents a top-level split/analysis. +#' - `anchor_step`: position *along the path of eligible anchor +#' points*, (`NA` for nodes not along that path). +#' +#' The core difference between a layout data.frame and an anchor +#' data.frame is that the anchor df has been subset to remove rows for +#' nodes not currently eligible to be anchor points (ie allowed +#' targets for a subsequent instruction's `at_sibling` argument). +#' +#' @return for `get_layout_dfs` a list with `rows` and `cols` elements +#' containing layout data.frames (see Details) for each structural +#' dimension; `get_anchor_dfs` returns the same, but with anchor +#' data.frames rather than full layout ones. `get_anchor_row_df` +#' is a convenience function that returns only the `rows` anchor +#' data.frame. `get_row_anchor_list` returns a list, each element +#' of which is a set of the names of one or more layout +#' instructions that will be placed as direct siblings to +#' each-other; i.e., anchored to the first element of the vector +#' when the length of the element is greater than one. +#' +#' @note Instructions which are anchored in such a way that they +#' ultimately become top-level instructions in the layout (i.e., +#' by being anchored as a sibling to a top-level instruction) are +#' handled somewhat differently for implementation reasons and may +#' present differently to those anchored to non-top-level +#' instructions. +#' @examples +#' +#' lyt <- basic_table() |> +#' split_cols_by("ARM") |> +#' split_rows_by("STRATA1") |> +#' split_rows_by("RACE") |> +#' split_rows_by("SEX") |> +#' analyze("AGE") |> +#' split_rows_by("BMRKR1", at_sibling = "RACE") |> +#' analyze("AGE") +#' +#' get_layout_dfs(lyt) +#' get_anchor_dfs(lyt) +#' get_row_anchor_df(lyt) +#' +#' @export +#' @rdname get_anchor_df +setGeneric( + "get_full_lyt_df", + function(splvec, next_node = 1L, next_anchor_step = 1L, parent, depth, node_type) { + standardGeneric("get_full_lyt_df") + } +) + +#' @rdname get_anchor_df +#' @export +setMethod( + "get_full_lyt_df", "PreDataTableLayouts", + function(splvec, next_node, next_anchor_step = 1, parent, depth, node_type) { + get_full_lyt_df(rlayout(splvec), + next_node = next_node, + next_anchor_step = next_anchor_step, + parent = 0, depth = 1, node_type = "active" + ) + } +) + +make_lyt_df_row <- function(name, nodeid, parentid, depth, type, anchor_step, force_pag = NA, spl_abbrev = NA) { + data.frame( + name = name, + nodeid = nodeid, + parentid = parentid, + depth = depth, + type = type, + is_toplevel = parentid == 0, + anchor_step = anchor_step, + force_pag = force_pag, + spl_abbrev = spl_abbrev + ) +} + +#' @rdname get_anchor_df +#' @export +get_layout_dfs <- function(lyt) { + stopifnot(is(lyt, "PreDataTableLayouts")) + list( + cols = get_full_lyt_df(clayout(lyt)), + rows = get_full_lyt_df(rlayout(lyt)) + ) +} + + +.gflytdf_predataaxis <- function(splvec, next_node = 1, next_anchor_step = 1L, + parent = 0L, depth = 1L, node_type = "active") { + len <- length(splvec) + prvlst <- vector("list", length(splvec)) + + for (i in seq_len(len)) { + prvlst[[i]] <- get_full_lyt_df(splvec[[i]], + next_node = next_node, + next_anchor_step = next_anchor_step + i - 1, + parent = 0L, + depth = 1, + node_type = ifelse(i == len, "active", "inactive") + ) + next_node <- max(prvlst[[i]]$nodeid) + 1 + } + ret <- do.call(rbind.data.frame, prvlst) + ret +} + +## note the different behaviors for the 0 length case below +#' @rdname get_anchor_df +#' @export +setMethod( + "get_full_lyt_df", "PreDataRowLayout", + function(splvec, next_node = 1, next_anchor_step = 1L, parent = 0L, depth = 1L, node_type = "active") { + if (length(splvec) == 1 && length(splvec[[1]]) == 0) { + return(make_lyt_df_row(NA, NA, NA, NA, NA, NA, NA)[0, ]) + } + .gflytdf_predataaxis( + splvec = splvec, + next_node = next_node, + next_anchor_step = next_anchor_step, + parent = parent, + depth = depth, + node_type = node_type + ) + } +) + + +#' @rdname get_anchor_df +#' @export +setMethod( + "get_full_lyt_df", "PreDataColLayout", + function(splvec, next_node = 1, next_anchor_step = 1L, parent = 0L, depth = 1L, node_type = "active") { + if (length(splvec) == 1 && length(splvec[[1]]) == 0) { + return(get_full_lyt_df(AllSplit(""), 1, 1, 0, 1, NA)) + } + .gflytdf_predataaxis( + splvec = splvec, + next_node = next_node, + next_anchor_step = next_anchor_step, + parent = parent, + depth = depth, + node_type = node_type + ) + } +) + +#' @rdname get_anchor_df +#' @export +setMethod( + "get_full_lyt_df", "SplitVector", + function(splvec, next_node, next_anchor_step = 1L, parent, depth, node_type) { + lst <- vector("list", length(splvec)) + an_step <- next_anchor_step + nid <- next_node + ktypes <- get_kid_types(splvec, node_type) + for (i in seq_along(lst)) { + if (ktypes[i] == "inactive") { + an_step <- NA_integer_ + } + lst[[i]] <- get_full_lyt_df( + splvec[[i]], + next_node = nid, + next_anchor_step = an_step, + depth = depth + i - 1, + parent = parent, + node_type = ktypes[i] + ) + an_step <- suppressWarnings(max(next_anchor_step, lst[[i]]$anchor_step, na.rm = TRUE)) + 1 + parent <- max(lst[[i]]$nodeid) + nid <- parent + 1 + } + do.call(rbind.data.frame, lst) + } +) + +#' @rdname get_anchor_df +#' @export +setMethod( + "get_full_lyt_df", "SplitVectorTree", + function(splvec, next_node, next_anchor_step, parent, depth, node_type) { + len <- length(splvec) + lst <- vector("list", length(splvec)) + ktypes <- get_kid_types(splvec, node_type) + nid <- next_node + for (i in seq_len(len)) { + lst[[i]] <- get_full_lyt_df( + splvec[[i]], + next_anchor_step = next_anchor_step, + next_node = nid, + parent = parent, + depth = depth, + node_type = ktypes[i] + ) + nid <- max(lst[[i]]$nodeid) + 1 + } + ret <- do.call(rbind.data.frame, lst) + ret + } +) + +#' @rdname get_anchor_df +#' @export +setMethod( + "get_full_lyt_df", "Split", + function(splvec, next_node, next_anchor_step, parent, depth, node_type) { + make_lyt_df_row( + name = obj_name(splvec), + nodeid = next_node, + anchor_step = next_anchor_step, + parentid = parent, + depth = depth, + type = node_type, + force_pag = has_force_pag(splvec), + spl_abbrev = spltype_abbrev(splvec) + ) + } +) + + +## the ***never*** used insert an existing table into a layout +## support that I regret deeply. +#' @rdname get_anchor_df +#' @export +setMethod( + "get_full_lyt_df", "VTableNodeInfo", + function(splvec, next_node, next_anchor_step, parent, depth, node_type) { + make_lyt_df_row( + name = obj_name(splvec), + nodeid = next_node, + anchor_step = next_anchor_step, + parentid = parent, + depth = depth, + type = node_type, + force_pag = FALSE, + spl_abbrev = paste0(nrow(splvec), "x", ncol(splvec), " table") + ) + } +) + + +## f-f-f-f-f-future proooooofin' +#' @rdname get_anchor_df +#' @export +get_anchor_dfs <- function(lyt) { + fdfs <- get_layout_dfs(lyt) + + ret <- lapply( + fdfs, + function(curdf) { + curdf[!is.na(curdf$anchor_step), ] + } + ) + names(ret) <- names(fdfs) + ret +} + +#' @rdname get_anchor_df +#' @export +get_row_anchor_df <- function(lyt) { + get_anchor_dfs(lyt)[["rows"]] +} + +#' @rdname get_anchor_df +#' @param lyt (`PreDataTableLayouts` or `PreDataRowLayout`)\cr A layout or row +#' to identify anchors for. +#' @export +get_row_anchor_list <- function(lyt) { + df <- get_row_anchor_df(lyt) + unname(split(df$name, df$anchor_step)) +} + +## this is where all the valid anchor checks happen, and it should occur very early +## (in do_next_row_split), after that we can assume branch_pos is correct and +## anchor pt it leads to is valid +## recursive walking of tree happens once in anchordf creation +find_branch_pos_df <- function(tt, at_sibling, anchordf = get_row_anchor_df(tt), nofind_ok = FALSE) { + atsib <- deuniqify_path_elements(at_sibling) + dup_pos <- extract_dup_pos(at_sibling) + found_lgl <- anchordf$name == atsib ## both deuniqified + if (sum(found_lgl) < dup_pos && nofind_ok) { + return(anchordf[NA, ]) + } + 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( + "'", + anchordf$name, + "'" + ) + ) + ) + } 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, "'" + ) + } else if (anchordf$force_pag[found[dup_pos]]) { + stop( + "at_sibling pointed to an element with forced pagination (page_by = TRUE). ", + "This is not supported." + ) + } + anchordf[found[dup_pos], ] +} + +## steps is how many (more) elements we need to walk +## to get to the anchor point with the "algorithm" +## that whenever we need to walk past the end of our vector +## we check that the last element is a SplitVectorTree and if so, +## step into the last existing branch of that tree and continue +branch_at_pos <- function(splv, steps, newspl) { + len <- length(splv) + if (steps > len) { ## step down into tree at end of vector and keep going + if (!is(splv[[len]], "SplitVectorTree")) { + stop("Bad branching position, please contact the maintainer") ## nocov + } + tr <- splv[[len]] + tr[[length(tr)]] <- branch_at_pos(tr[[length(tr)]], steps - len + 1, newspl) + splv[[len]] <- tr + } else { ## branch somewhere along vector + el <- splv[[steps]] + if (is(el, "SplitVectorTree")) { + stopifnot(steps == len) ## nocov + splv[[steps]] <- SplitVectorTree(lst = c(el, list(SplitVector(newspl)))) + } else { + if (label_position(el) == "default") { + label_position(splv[[steps]]) <- "visible" + } + + splv <- SplitVector( + lst = c( + if (steps > 1) splv[seq_len(steps - 1)], + list(SplitVectorTree( + SplitVector(lst = splv[seq(steps, len)]), + SplitVector(newspl) + )) + ) + ) + } + } + splv +} + +## **!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!** +## pos means different things depending on +## if it points to an anchor point or +## (!is.null(at_sibling)) or simply a place +## in the root tree (is.null(at_sibling) +## **!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!** +#' @rdname int_methods +setMethod( + "split_rows", "PreDataRowLayout", + function(lyt, spl, pos, cmpnd_fun = AnalyzeMultiVars, at_sibling = NULL) { + stopifnot(is.na(pos) || (pos > 0 && (!is.null(at_sibling) || pos <= length(lyt) + 1))) + root_branching <- FALSE + if (!is.null(at_sibling)) { + ## oof this is an ugly hack :( + pos2 <- pos + pos <- min(length(lyt), pos) + oldval <- lyt[[pos]] + tmp <- branch_at_pos(oldval, steps = pos2 - pos + 1, spl) + } 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) + lyt[[pos]] <- cmpnd_last_rowsplit(lyt[[pos]], spl, constructor) + lyt + } +) + +#' @rdname int_methods +setMethod( + "cmpnd_last_rowsplit", "CompoundSplit", + function(lyt, spl, constructor) { + spl_payload(lyt) <- c( + .uncompound(spl_payload(lyt)), + .uncompound(spl) + ) + obj_name(lyt) <- make_ma_name(spl = lyt) + lyt + } +) + + +#' @rdname int_methods +setMethod( + "cmpnd_last_rowsplit", "Split", + function(lyt, spl, constructor) { + constructor(.payload = list(lyt, spl)) + } +) + + +#' @rdname int_methods +setMethod( + "cmpnd_last_rowsplit", "SplitVectorTree", + function(lyt, spl, constructor) { + pos <- length(lyt) + lyt[[pos]] <- cmpnd_last_rowsplit(lyt[[pos]], spl, constructor) + 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 967b334923..54f114981d 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<-")) @@ -3368,6 +3273,15 @@ setMethod( } ) +#' @rdname vil +setMethod( + "vars_in_layout", "SplitVectorTree", + function(lyt) { + vil_collapse(lapply(lyt, vars_in_layout)) + } +) + + #' @rdname vil setMethod( "vars_in_layout", "SplitVector", @@ -3935,7 +3849,11 @@ setMethod("has_force_pag", "TableTree", function(obj) !is.na(ptitle_prefix(obj)) #' @exportMethod has_force_pag #' @rdname int_methods -setMethod("has_force_pag", "Split", function(obj) !is.na(ptitle_prefix(obj))) +setMethod( + "has_force_pag", "Split", + ## RootSplit was returning logical(0) like a psychopath + function(obj) !is.na(ptitle_prefix(obj)) %||% FALSE +) #' @exportMethod has_force_pag #' @rdname int_methods diff --git a/R/tt_dotabulation.R b/R/tt_dotabulation.R index 870bd572d6..30d6e833a5 100644 --- a/R/tt_dotabulation.R +++ b/R/tt_dotabulation.R @@ -884,6 +884,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, @@ -1184,6 +1220,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 @@ -1459,7 +1528,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 @@ -1489,7 +1558,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 @@ -1681,6 +1751,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( @@ -1898,6 +1977,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 @@ -1931,6 +2019,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 0629ed6eeb..fc09ba421b 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 = ":") { @@ -125,6 +132,82 @@ spldesc <- function(spl, value = "") { ) } +lyt_desc_mat <- function(obj) { + df <- get_full_lyt_df(obj, parent = 0, depth = 1, node_type = "inactive") + + outrow <- 1 + outmat <- matrix("", nrow = NROW(df), ncol = max(0, df$depth)) + lastdepth <- 0 + for (i in seq_len(NROW(df))) { + curdepth <- df$depth[i] + if (lastdepth >= curdepth) { + outrow <- outrow + 1 + } + outmat[outrow, curdepth] <- paste0(df$name[i], " (", df$spl_abbrev[i], ")") + lastdepth <- curdepth + } + rs <- rowSums(nchar(outmat)) + outmat <- outmat[rs > 0, , drop = FALSE] + outmat +} + +lyt_desc_add_spans <- function(obj, mat = lyt_desc_mat(obj)) { + nempty <- matrix(nzchar(mat), nrow = nrow(mat), ncol = ncol(mat)) + spans <- list() + if (NROW(mat) <= 1) { + return(mat) + } ## no padding needed + for (i in seq(2, NROW(mat))) { + if (nempty[i, 1]) { + next + } + col <- min(which(nempty[i, , drop = TRUE])) + anchor_row <- max(which(nempty[seq_len(i - 1), col, drop = TRUE])) + stopifnot(is.finite(anchor_row)) + spans <- c(spans, list(list(rows = seq(anchor_row, i), col = col))) + } + + for (j in seq_along(spans)) { + rws <- spans[[j]]$rows + cl <- spans[[j]]$col + mat[rws, cl] <- paste("|", mat[rws, cl]) + } + mat +} +pad_lyt_desc_mat <- function(mat) { + matrix(apply( + mat, 2, + function(x) { + vapply(x, padstr, just = "left", n = max(nchar(x)), fontspec = NULL, FUN.VALUE = "") + } + ), nrow = nrow(mat), ncol = ncol(mat)) +} + +build_lyt_desc_msg <- function(obj, sep_lines = FALSE) { + mat <- lyt_desc_mat(obj) + ## before |'s are added + nonempty <- matrix(nzchar(mat), nrow = nrow(mat), ncol = ncol(mat)) + mat <- lyt_desc_add_spans(mat = mat) + padmat <- pad_lyt_desc_mat(mat) + rvs <- lapply( + seq_len(nrow(mat)), + function(i) { + vec <- padmat[i, , drop = TRUE] + nempvec <- nonempty[i, , drop = TRUE] + sep <- c(ifelse(head(nempvec, -1) & tail(nempvec, -1), " -> ", " "), if (sep_lines) "" else "\n") + paste( + collapse = "", + paste0(vec, sep) + ) + } + ) + + if (sep_lines) { + unlist(rvs) + } else { + do.call(paste0, rvs) + } +} layoutmsg <- function(obj) { ## if(!is(obj, "VLayoutNode")) ## stop("how did a non layoutnode object get in docatlayout??") @@ -241,7 +324,7 @@ setMethod( setMethod( "spltype_abbrev", "AnalyzeVarSplit", - function(obj) "** analysis **" + function(obj) "** var **" ) setMethod( @@ -251,47 +334,70 @@ setMethod( setMethod( "spltype_abbrev", "AnalyzeMultiVars", - function(obj) "** multivar analysis **" + function(obj) "** multivar **" ) setMethod( "spltype_abbrev", "AnalyzeColVarSplit", - function(obj) "** col-var analysis **" + function(obj) "** col-var **" ) -docat_splitvec <- function(object, indent = 0) { - if (indent > 0) { - cat(rep(" ", times = indent), sep = "") - } - if (length(object) == 1L && is(object[[1]], "VTableNodeInfo")) { - tab <- object[[1]] - msg <- sprintf( - "A Pre-Existing Table [%d x %d]", - nrow(tab), ncol(tab) - ) - } else { - plds <- ploads_to_str(object) ## lapply(object, spl_payload)) +setMethod( + "spltype_abbrev", "SplitVectorTree", + function(obj) "" +) - tabbrev <- sapply(object, spltype_abbrev) - msg <- paste( - collapse = " -> ", - paste0(plds, " (", tabbrev, ")") - ) - } - cat(msg, "\n") -} +## docat_splitvec <- function(object, indent = 0) { +## if (indent > 0) { +## cat(rep(" ", times = indent), sep = "") +## } +## if (length(object) == 1L && is(object[[1]], "VTableNodeInfo")) { +## tab <- object[[1]] +## msg <- sprintf( +## "A Pre-Existing Table [%d x %d]", +## 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) +## msg <- paste( +## collapse = " -> ", +## paste0(plds, " (", tabbrev, ")") +## ) +## } +## cat(msg, "\n") +## } setMethod( "show", "SplitVector", function(object) { cat("A SplitVector Pre-defining a Tree Structure\n\n") docat_splitvec(object) - cat("\n") + docat_lyt_legend() invisible(object) } ) docat_predataxis <- function(object, indent = 0) { - lapply(object, docat_splitvec) + cat(build_lyt_desc_msg(object)) + + # lapply(object, docat_splitvec) +} + +docat_splitvec <- docat_predataxis + +docat_lyt_legend <- function() { + cat("\n", + paste0( + "'->' indicates nesting, vertical stacks of '|' indicate anchoring/siblings.\n", + "'()' indicates split type, while '(** **)' indicates an analyze instruction." + ), + "\n\n", + sep = "" + ) } setMethod( @@ -299,6 +405,7 @@ setMethod( function(object) { cat("A Pre-data Column Layout Object\n\n") docat_predataxis(object) + docat_lyt_legend() invisible(object) } ) @@ -308,6 +415,7 @@ setMethod( function(object) { cat("A Pre-data Row Layout Object\n\n") docat_predataxis(object) + docat_lyt_legend() invisible(object) } ) @@ -320,7 +428,7 @@ setMethod( docat_predataxis(object@col_layout) cat("\nRow-Split Structure:\n") docat_predataxis(object@row_layout) - cat("\n") + docat_lyt_legend() invisible(object) } ) diff --git a/_pkgdown.yml b/_pkgdown.yml index c3e5e36984..7005260f3e 100644 --- a/_pkgdown.yml +++ b/_pkgdown.yml @@ -160,6 +160,7 @@ reference: - add_overall_col - add_existing_table - formatters::table_inset + - get_layout_dfs - RefFootnote - title: Tabulation Utility Functions diff --git a/man/analyze.Rd b/man/analyze.Rd index 378dc14d40..ae626697a2 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 9c7a1bc2dd..6826078d7c 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_df.Rd b/man/get_anchor_df.Rd new file mode 100644 index 0000000000..62468b3ebe --- /dev/null +++ b/man/get_anchor_df.Rd @@ -0,0 +1,177 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/nesting_impl.R +\name{get_full_lyt_df} +\alias{get_full_lyt_df} +\alias{get_full_lyt_df,PreDataTableLayouts-method} +\alias{get_layout_dfs} +\alias{get_full_lyt_df,PreDataRowLayout-method} +\alias{get_full_lyt_df,PreDataColLayout-method} +\alias{get_full_lyt_df,SplitVector-method} +\alias{get_full_lyt_df,SplitVectorTree-method} +\alias{get_full_lyt_df,Split-method} +\alias{get_full_lyt_df,VTableNodeInfo-method} +\alias{get_anchor_dfs} +\alias{get_row_anchor_df} +\alias{get_row_anchor_list} +\title{Retrieve Info About Possible Nesting Anchors} +\usage{ +get_full_lyt_df( + splvec, + next_node = 1L, + next_anchor_step = 1L, + parent, + depth, + node_type +) + +\S4method{get_full_lyt_df}{PreDataTableLayouts}( + splvec, + next_node = 1L, + next_anchor_step = 1, + parent, + depth, + node_type +) + +get_layout_dfs(lyt) + +\S4method{get_full_lyt_df}{PreDataRowLayout}( + splvec, + next_node = 1, + next_anchor_step = 1L, + parent = 0L, + depth = 1L, + node_type = "active" +) + +\S4method{get_full_lyt_df}{PreDataColLayout}( + splvec, + next_node = 1, + next_anchor_step = 1L, + parent = 0L, + depth = 1L, + node_type = "active" +) + +\S4method{get_full_lyt_df}{SplitVector}( + splvec, + next_node = 1L, + next_anchor_step = 1L, + parent, + depth, + node_type +) + +\S4method{get_full_lyt_df}{SplitVectorTree}( + splvec, + next_node = 1L, + next_anchor_step = 1L, + parent, + depth, + node_type +) + +\S4method{get_full_lyt_df}{Split}( + splvec, + next_node = 1L, + next_anchor_step = 1L, + parent, + depth, + node_type +) + +\S4method{get_full_lyt_df}{VTableNodeInfo}( + splvec, + next_node = 1L, + next_anchor_step = 1L, + parent, + depth, + node_type +) + +get_anchor_dfs(lyt) + +get_row_anchor_df(lyt) + +get_row_anchor_list(lyt) +} +\arguments{ +\item{splvec}{(\code{PreDataTableLayouts} or internal classes)\cr The layout or partial +layout to list anchors for.} + +\item{next_node}{(\code{integer(1)})\cr For internal use} + +\item{next_anchor_step}{(\code{integer(1)})\cr For internal use.} + +\item{parent}{(\code{integer(1)})\cr For internal use.} + +\item{depth}{(\code{integer(1)})\cr For internal use.} + +\item{node_type}{(\code{character(1)})\cr For internal use.} + +\item{lyt}{(\code{PreDataTableLayouts} or \code{PreDataRowLayout})\cr A layout or row +to identify anchors for.} +} +\value{ +for \code{get_layout_dfs} a list with \code{rows} and \code{cols} elements +containing layout data.frames (see Details) for each structural +dimension; \code{get_anchor_dfs} returns the same, but with anchor +data.frames rather than full layout ones. \code{get_anchor_row_df} +is a convenience function that returns only the \code{rows} anchor +data.frame. \code{get_row_anchor_list} returns a list, each element +of which is a set of the names of one or more layout +instructions that will be placed as direct siblings to +each-other; i.e., anchored to the first element of the vector +when the length of the element is greater than one. +} +\description{ +This function scans an existing layout's row structure and lists +valid \code{at_sibling} anchors for intermediate nesting. +} +\details{ +A layout data.frame is a data.frame describing a single dimension +of pre-data layout structure, containing the following columns +(most of which are used for internal implementations and will not +be useful to the end-user): +\itemize{ +\item \code{name}: name of the element +\item \code{nodeid}: sequential numeric id of the node, for use in +constructing graphs (0 is the root node) +\item \code{parentid}: node id of the layout instructions direct parent +\item \code{depth}: length of path from root to the current node through the +implicit graph defined by the (\code{nodeid}, \code{parentid}) pairings +\item \code{type}: a description of the 'type' of the node, used internally +\item \code{is_toplevel}: whether the node represents a top-level split/analysis. +\item \code{anchor_step}: position \emph{along the path of eligible anchor +points}, (\code{NA} for nodes not along that path). +} + +The core difference between a layout data.frame and an anchor +data.frame is that the anchor df has been subset to remove rows for +nodes not currently eligible to be anchor points (ie allowed +targets for a subsequent instruction's \code{at_sibling} argument). +} +\note{ +Instructions which are anchored in such a way that they +ultimately become top-level instructions in the layout (i.e., +by being anchored as a sibling to a top-level instruction) are +handled somewhat differently for implementation reasons and may +present differently to those anchored to non-top-level +instructions. +} +\examples{ + +lyt <- basic_table() |> + split_cols_by("ARM") |> + split_rows_by("STRATA1") |> + split_rows_by("RACE") |> + split_rows_by("SEX") |> + analyze("AGE") |> + split_rows_by("BMRKR1", at_sibling = "RACE") |> + analyze("AGE") + +get_layout_dfs(lyt) +get_anchor_dfs(lyt) +get_row_anchor_df(lyt) + +} diff --git a/man/int_methods.Rd b/man/int_methods.Rd index a531cf5ae2..bf8fcc5290 100644 --- a/man/int_methods.Rd +++ b/man/int_methods.Rd @@ -1,12 +1,29 @@ % 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{get_kid_types} +\alias{get_kid_types,Split-method} +\alias{get_kid_types,SplitVector-method} +\alias{get_kid_types,SplitVectorTree-method} +\alias{get_kid_types,PreDataRowLayout-method} \alias{split_rows,PreDataRowLayout-method} \alias{split_rows,SplitVector-method} \alias{split_rows,PreDataTableLayouts-method} @@ -15,6 +32,9 @@ \alias{cmpnd_last_rowsplit,NULL-method} \alias{cmpnd_last_rowsplit,PreDataRowLayout-method} \alias{cmpnd_last_rowsplit,SplitVector-method} +\alias{cmpnd_last_rowsplit,CompoundSplit-method} +\alias{cmpnd_last_rowsplit,Split-method} +\alias{cmpnd_last_rowsplit,SplitVectorTree-method} \alias{cmpnd_last_rowsplit,PreDataTableLayouts-method} \alias{cmpnd_last_rowsplit,ANY-method} \alias{split_cols} @@ -23,10 +43,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 +58,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 +82,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 +141,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 +398,79 @@ \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) -split_rows(lyt = NULL, spl, pos, cmpnd_fun = AnalyzeMultiVars) +\S4method{next_rpos}{PreDataTableLayouts}(obj, nested = TRUE, for_analyze = FALSE, at_sibling = NULL) -\S4method{split_rows}{NULL}(lyt = NULL, spl, pos, cmpnd_fun = AnalyzeMultiVars) +\S4method{next_rpos}{PreDataRowLayout}(obj, nested = TRUE, for_analyze = FALSE, at_sibling = NULL) -\S4method{split_rows}{PreDataRowLayout}(lyt = NULL, spl, pos, cmpnd_fun = AnalyzeMultiVars) +\S4method{next_rpos}{ANY}(obj, nested) -\S4method{split_rows}{SplitVector}(lyt = NULL, spl, pos, cmpnd_fun = AnalyzeMultiVars) +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}{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 +) + +get_kid_types(obj, type) + +\S4method{get_kid_types}{Split}(obj, type) + +\S4method{get_kid_types}{SplitVector}(obj, type) + +\S4method{get_kid_types}{SplitVectorTree}(obj, type) + +\S4method{get_kid_types}{PreDataRowLayout}(obj, type) + +\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) +\S4method{split_rows}{PreDataTableLayouts}(lyt, spl, pos, at_sibling = NULL) -\S4method{split_rows}{ANY}(lyt, spl, pos) +\S4method{split_rows}{ANY}(lyt, spl, pos, at_sibling = NULL) cmpnd_last_rowsplit(lyt, spl, constructor) @@ -408,6 +480,12 @@ cmpnd_last_rowsplit(lyt, spl, constructor) \S4method{cmpnd_last_rowsplit}{SplitVector}(lyt, spl, constructor) +\S4method{cmpnd_last_rowsplit}{CompoundSplit}(lyt, spl, constructor) + +\S4method{cmpnd_last_rowsplit}{Split}(lyt, spl, constructor) + +\S4method{cmpnd_last_rowsplit}{SplitVectorTree}(lyt, spl, constructor) + \S4method{cmpnd_last_rowsplit}{PreDataTableLayouts}(lyt, spl, constructor) \S4method{cmpnd_last_rowsplit}{ANY}(lyt, spl, constructor) @@ -424,6 +502,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 +552,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 +590,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 +636,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 +754,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 +1265,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 +1288,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 +1318,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 +1331,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 ed05d03091..1dc1f8f812 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 2069ca88e9..de3c8fd65e 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 2e99b223d0..6eff02528e 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 10aa405a95..bfe3db0b65 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/man/vil.Rd b/man/vil.Rd index d60f83aebe..ae3aff65eb 100644 --- a/man/vil.Rd +++ b/man/vil.Rd @@ -4,6 +4,7 @@ \alias{vars_in_layout} \alias{vars_in_layout,PreDataTableLayouts-method} \alias{vars_in_layout,PreDataAxisLayout-method} +\alias{vars_in_layout,SplitVectorTree-method} \alias{vars_in_layout,SplitVector-method} \alias{vars_in_layout,Split-method} \alias{vars_in_layout,CompoundSplit-method} @@ -16,6 +17,8 @@ vars_in_layout(lyt) \S4method{vars_in_layout}{PreDataAxisLayout}(lyt) +\S4method{vars_in_layout}{SplitVectorTree}(lyt) + \S4method{vars_in_layout}{SplitVector}(lyt) \S4method{vars_in_layout}{Split}(lyt) diff --git a/tests/testthat/test-lyt-tabulation.R b/tests/testthat/test-lyt-tabulation.R index 891565e37c..214ad628cb 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() |> @@ -494,7 +495,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") |> @@ -1013,32 +1013,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 0000000000..3fbad01bba --- /dev/null +++ b/tests/testthat/test-nesting.R @@ -0,0 +1,705 @@ +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]) + + +## 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 an element 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("basic usage of 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) + ) +}) + +test_that("anchoring to top-level element gives exact nested = FALSE behavior", { + ## 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) +}) + +test_that("bad at_sibling values give informative errors", { + ## 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 an element with forced pagination" + ) + base <- basic_table() |> + split_rows_by("SEX") |> + split_rows_by("RACE") |> + analyze("AGE") + expect_error(split_rows_by(base, "STRATA1", at_sibling = 1)) + expect_error(analyze(base, "STRATA1", at_sibling = 1)) + expect_error(analyze(base, "STRATA1", at_sibling = character())) + expect_error(split_rows_by_quartiles(base, "AGE", at_sibling = NA_character_)) +}) + +test_that("previously placed siblings can be targeted by at_sibling", { + ## 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 + ) +}) + +test_that("at_sibling finds and respects overridden table names", { + ## 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 + ) +}) + +test_that("extreme/repeated usage of intermediate nesting works correctly", { + 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_row_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[3]") |> + analyze("AGE") + + expect_identical( + get_row_anchor_list(clown_base), + list( + "RACE", + "SEX", + "RACE", + "STRATA1", + c( + "RACE", + "BMRKR2" + ), + "AGE" + ) + ) + + + ## RACE + ## SEX -> | RACE (2) -> STRATA1 -> | RACE (3) + ## |------------------------| BMRKR2 -> AGE + ## | COUNTRY -> BMRKR1 + + clown_shoes <- clown_base |> + split_rows_by("COUNTRY", + split_fun = keep_2_levels("COUNTRY"), + at_sibling = "RACE[2]" + ) |> + 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 + ## SEX -> | RACE (2)-> STRATA1 -> | RACE (3) + ## | BMRKR2 -> AGE + ## | COUNTRY -> BMRKR1 + ## + + clown_shoes2 <- clown_base |> + split_rows_by("COUNTRY", + split_fun = keep_2_levels("COUNTRY"), + at_sibling = "RACE[3]" + ) |> + 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 + ) + + ## + expect_error( + clown_base |> + split_rows_by("COUNTRY", at_sibling = "RACE[4]"), + regexp = "Found only 3 eligible elements named 'RACE', but at_sibling was 'RACE\\[4\\]'" + ) + + clown_nose <- basic_table() |> + split_rows_by("STRATA1", split_fun = keep_2_levels("STRATA1")) |> + 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_row_anchor_list(clown_nose), + list( + "STRATA1", + "SEX", + c("RACE", "BMRKR2", "SITEID"), + "BEP01FL", + "AGE" + ) + ) + + expect_identical( + vars_in_layout(clown_nose), + c( + "STRATA1", + "STRATA2", + "ARM", + "SEX", + "RACE", + "BMRKR1", + "BMRKR2", + "COUNTRY", + "AGE", + "SITEID", + "BEP01FL" + ) + ) + + ## "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 + ) +}) + +test_that("at_sibling doesn't mash 2 analyzes up all willy nilly", { + ## also ensures the anchor lookup behavior is correct when anchor + ## pt is a previous root split (which it wasn't when the test + ## was written x.x) + lyt <- basic_table() |> + split_rows_by("RACE", split_fun = keep_2_levels("RACE")) |> + split_rows_by("SEX", split_fun = keep_2_levels("SEX")) |> + analyze("AGE") |> + analyze("BMRKR1", at_sibling = "RACE") |> + analyze("AGE", at_sibling = "RACE") + + tbl <- build_table(lyt, ex_adsl) + expect_equal(path_count(tbl, c("root", "BMRKR1")), 1L) + expect_equal(path_count(tbl, c("root", "AGE")), 1L) + expect_equal(path_count(tbl, c("RACE", "*", "SEX", "*", "AGE")), 4L) + expect_equal(path_count(tbl, c("RACE", "*", "SEX", "*", "BMRKR1")), 0L) + ## no surrounding multivar table + expect_equal(path_count(tbl, c("ma_BMRKR1_AGE", "*")), 0L) + + + ## old, ie non-at_sibling behavior remains unchanged + ## TODO: deprecate this eventually now that we can have analyzes + ## within row faceting (which we couldn't before, thus the creation + ## of the ma_bla_bla_bla parent table. + lyt2 <- basic_table() |> + split_rows_by("RACE", split_fun = keep_2_levels("RACE")) |> + split_rows_by("SEX", split_fun = keep_2_levels("SEX")) |> + analyze("AGE") |> + analyze("BMRKR1", at_sibling = "SEX") |> + analyze("AGE", at_sibling = "SEX") + tbl2 <- build_table(lyt2, ex_adsl) + ## no surrounding multivar table + expect_equal(path_count(tbl2, c("RACE", "*", "ma_BMRKR1_AGE")), 0L) + + lytbad <- basic_table() |> + split_rows_by("RACE", split_fun = keep_2_levels("RACE")) |> + split_rows_by("SEX", split_fun = keep_2_levels("SEX")) |> + analyze("AGE") |> + analyze("BMRKR1", nested = FALSE) |> + analyze("AGE") + tblbad <- build_table(lytbad, ex_adsl) + ## no surrounding multivar table + expect_equal(path_count(tblbad, c("ma_BMRKR1_AGE", "*")), 2L) +}) + +test_that("more than 2 analyzes get mashed together correctly", { + lyt <- basic_table(show_colcounts = TRUE) |> + ## Column faceting + split_cols_by("ARM", ref_group = "A: Drug X") |> + analyze("AGE") |> + analyze("RACE") |> + analyze("BMRKR1") |> + analyze("BMRKR2") + + tbl <- build_table(lyt, ex_adsl) + + expect_equal(obj_name(tbl), "ma_AGE_RACE_BMRKR1_BMRKR2") + expect_equal(path_count(tbl, c("ma_AGE_RACE_BMRKR1_BMRKR2", "*")), 4L) +}) + +test_that("random intermediate nesting stuff", { + expect_error( + { + basic_table() |> + split_rows_by("STRATA1", page_by = TRUE) |> + analyze("AGE") |> + split_rows_by("SEX", at_sibling = "STRATA1") + }, + regexp = "at_sibling pointed to an element with forced pagination" + ) + + + expect_no_error({ + basic_table() |> + analyze("AGE") |> + split_rows_by("STRATA1") |> + analyze("AGE") |> + split_rows_by("SEX", nested = FALSE, at_sibling = "STRATA1") + }) + + + lyt <- basic_table() |> + split_rows_by("SEX") |> + split_rows_by("STRATA1") |> + analyze("AGE") |> + split_rows_by("SEX", nested = FALSE, at_sibling = "STRATA1") + + + lyt <- basic_table() |> + split_rows_by("SEX") |> + analyze("AGE") |> + split_rows_by("BMRKR2", nested = FALSE) |> + split_rows_by("RACE") |> + analyze("AGE") + expect_no_error({ + lyt |> split_rows_by("STRATA1", at_sibling = "SEX") + }) +}) + + +test_that("nested analyses are compounded correctly when on branch", { + lyt <- basic_table() |> + split_rows_by("STRATA1", split_fun = keep_2_levels("STRATA1")) |> + split_rows_by("SEX", split_fun = keep_2_levels("SEX")) |> + analyze("AGE", table_names = "a1") |> + split_rows_by("RACE", + split_fun = keep_2_levels("RACE"), + at_sibling = "SEX" + ) |> + analyze("AGE", table_names = "a2") |> + analyze("BMRKR1") + tbl <- build_table(lyt, ex_adsl) + + expect_equal( + path_count(tbl, c("STRATA1", "*", "SEX", "*")), + 4L + ) +}) diff --git a/tests/testthat/test-printing.R b/tests/testthat/test-printing.R index e831daac34..392123047a 100644 --- a/tests/testthat/test-printing.R +++ b/tests/testthat/test-printing.R @@ -384,6 +384,15 @@ test_that("Various Printing things work", { expect_false(any(grepl("new..AnalyzeColVarSplit., analysis_fun =", printoutput))) }) +test_that("layout printing works for cornercases", { + adsl_lyt <- basic_table(show_colcounts = TRUE) |> + split_cols_by("ARM") |> + analyze(c("AGE", "SEX"), afun = mean) + + expect_no_error(capture.output(print(adsl_lyt))) + expect_no_error(capture.output(print(basic_table()))) +}) + test_that("section_div works throughout", { lyt <- basic_table() |> diff --git a/vignettes/guided_intro_nesting.Rmd b/vignettes/guided_intro_nesting.Rmd index d28e1fd65b..500d9e41f4 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,492 @@ 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_row_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. + +We can consider the current state to help us visualize the eligible +anchor points by printing our current layout: + +```{r} +lyt_stack +``` + + +# Designing Multi-Section Row-Layouts To Support Subgroup Variants + +In setting with standardized table outputs, we commonly want both +all-patient and split-by-subgroups variants of a given core table +structure. Intermediate nesting allows us to develop layouts with this +in mind as we will see in this section. + +Consider a table layout with multiple sections in row space, e.g., an +overall analysis, an analysis split by `RACE` and the same analysis +split by `SEX`: + +```{r} +lyt <- basic_table() |> + split_cols_by("ARM") |> + analyze("AGE") |> + split_rows_by("RACE", split_fun = keep_2_levels("RACE")) |> + analyze("AGE") |> + split_rows_by("SEX", split_fun = keep_2_levels("SEX")) |> + analyze("AGE") + +build_table(lyt, ex_adsl) +``` + +Now supposing we want the same structure for each strata in our +sample, if we apply `split_rows_by("STRATA1")` as the first row +instruction, we do not get the desired table, because each +`split_rows_by` that follows an `analyze` is `nested = FALSE` by +default, bringing it all the way to the top level, ie.e, outside of +our new strata splitting: + + +```{r} +lyt2 <- basic_table() |> + split_cols_by("ARM") |> + split_rows_by("STRATA1", split_fun = keep_2_levels("STRATA1")) |> + analyze("AGE") |> + split_rows_by("RACE", split_fun = keep_2_levels("RACE")) |> + analyze("AGE") |> + split_rows_by("SEX", split_fun = keep_2_levels("SEX")) |> + analyze("AGE") + +build_table(lyt2, ex_adsl) +``` + +This is not a subgroup variant of our table. + +If we anchor those `split_rows_by` (each of which essentially starts a +new section of the layout in row space) to our overall `AGE` analyze +call, we will get the same table for the full variant: + +```{r} +lyt_good <- basic_table() |> + split_cols_by("ARM") |> + analyze("AGE") |> + split_rows_by("RACE", + split_fun = keep_2_levels("RACE"), + at_sibling = "AGE" + ) |> + analyze("AGE") |> + split_rows_by("SEX", + split_fun = keep_2_levels("SEX"), + at_sibling = "AGE" + ) |> + analyze("AGE") + +build_table(lyt_good, ex_adsl) +``` + +Crucially, however, when we prepend a new row splitting instruction to +the sequence of row layout instructions, we immediately get our +desired subgroup variant with no extra effort required: + + +```{r} +lyt_good_subgrp <- basic_table() |> + split_cols_by("ARM") |> + split_rows_by("STRATA1", split_fun = keep_2_levels("STRATA1")) |> + analyze("AGE") |> + split_rows_by("RACE", + split_fun = keep_2_levels("RACE"), + at_sibling = "AGE" + ) |> + analyze("AGE") |> + split_rows_by("SEX", + split_fun = keep_2_levels("SEX"), + at_sibling = "AGE" + ) |> + analyze("AGE") + +build_table(lyt_good, ex_adsl) +``` + +Note can use either standard splitting or splitting with `page_by = +TRUE` when injecting our subgroups, depending on the desired behavior, +with no other changes. + +Thus, it is good practice to anchor all top level (seemingly +non-nested) row instructions after the first to that first instruction +to make our layouts easily support the creation of subgroup variants.