From 4eb1a349b5f4f59b3d0dcd05f537bf7fc768b9af Mon Sep 17 00:00:00 2001 From: Gabe Becker Date: Mon, 2 Jun 2025 14:58:34 -0700 Subject: [PATCH 1/5] export subset_cols and has_force_pag --- NAMESPACE | 4 + NEWS.md | 4 + R/tree_accessors.R | 8 ++ R/tt_pos_and_access.R | 42 ++++++++- _pkgdown.yml | 1 + man/int_methods.Rd | 12 +++ man/subset_cols.Rd | 133 ++++++++++++++++++++++++++++ tests/testthat/test-pagination.R | 7 ++ tests/testthat/test-subset-access.R | 48 ++++++++++ 9 files changed, 258 insertions(+), 1 deletion(-) create mode 100644 man/subset_cols.Rd diff --git a/NAMESPACE b/NAMESPACE index 9507bbe1fe..3029658a18 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -103,6 +103,7 @@ export(facet_colcount) export(find_degen_struct) export(format_rcell) export(get_formatted_cells) +export(has_force_pag) export(head) export(header_section_div) export(horizontal_sep) @@ -175,6 +176,7 @@ export(split_rows_by_cuts) export(split_rows_by_multivar) export(split_rows_by_quartiles) export(str) +export(subset_cols) export(summarize_row_groups) export(table_shell) export(table_shell_str) @@ -258,6 +260,7 @@ exportMethods(coltree) exportMethods(content_table) exportMethods(dim) exportMethods(facet_colcount) +exportMethods(has_force_pag) exportMethods(head) exportMethods(horizontal_sep) exportMethods(length) @@ -290,6 +293,7 @@ exportMethods(row_values) exportMethods(simple_analysis) exportMethods(spl_variable) exportMethods(str) +exportMethods(subset_cols) exportMethods(subtitles) exportMethods(table_inset) exportMethods(tail) diff --git a/NEWS.md b/NEWS.md index 2802021bf0..e909d167c4 100644 --- a/NEWS.md +++ b/NEWS.md @@ -20,6 +20,10 @@ * `section_div<-` no longer sets a section div on non-visible label rows when setting a section divider for a content row on the same group. #1024 by @gmbecker * `section_div<-` when given a full-length (`nrow(tt)`) vector now sets 'section dividers' on label rows and content rows correctly when both are visible for the same facet. #1024 by @gmbecker +### Miscellaneous + * `subset_cols` generic and methods are now exported. + * `has_force_pag` generic and methods are now exported. + ## rtables 0.6.12 ### New Features diff --git a/R/tree_accessors.R b/R/tree_accessors.R index 16c4a605c3..283519991f 100644 --- a/R/tree_accessors.R +++ b/R/tree_accessors.R @@ -3835,12 +3835,20 @@ setMethod( } ) +#' @export +#' @rdname int_methods setGeneric("has_force_pag", function(obj) standardGeneric("has_force_pag")) +#' @exportMethod has_force_pag +#' @rdname int_methods 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))) +#' @exportMethod has_force_pag +#' @rdname int_methods setMethod("has_force_pag", "VTableNodeInfo", function(obj) FALSE) setGeneric("ptitle_prefix", function(obj) standardGeneric("ptitle_prefix")) diff --git a/R/tt_pos_and_access.R b/R/tt_pos_and_access.R index 6bb4e6c1f0..2477416d36 100644 --- a/R/tt_pos_and_access.R +++ b/R/tt_pos_and_access.R @@ -843,7 +843,33 @@ setMethod( ## we have two options here: path like we do with rows and positional ## in leaf space. - +#' Subset a table or row to particular columns +#' @inheritParams gen_args +#' @inheritParams brackets +#' @inheritParams head +#' @param j (`integer`, `logical` or `character`)\cr The column(s) to subset `tt` +#' down to. Character vectors are intepreted as a *column path*, not as names. +#' Path can include `"*"` wildcards. +#' @param newcinfo (`NULL` or `InstantiatedColumnInfo`)\cr The new column info, +#' if precomputed. Generally should not be manually set by users. +#' @param ... Ignored. +#' +#' @examples +#' lyt <- basic_table( +#' title = "Title", +#' subtitles = c("Sub", "titles"), +#' prov_footer = "prov footer", +#' main_footer = "main footer" +#' ) %>% +#' split_cols_by("ARM") %>% +#' split_cols_by("SEX") %>% +#' analyze(c("AGE")) +#' +#' tbl <- build_table(lyt, DM) +#' +#' subset_cols(tbl, c(1, 3)) +#' subset_cols(tbl, c("ARM", "*", "SEX", "F")) +#' @export setGeneric( "subset_cols", function(tt, @@ -857,6 +883,8 @@ setGeneric( } ) +#' @exportMethod subset_cols +#' @rdname subset_cols setMethod( "subset_cols", c("TableTree", "numeric"), function(tt, j, newcinfo = NULL, @@ -889,6 +917,8 @@ setMethod( } ) +#' @exportMethod subset_cols +#' @rdname subset_cols setMethod( "subset_cols", c("ElementaryTable", "numeric"), function(tt, j, newcinfo = NULL, @@ -1021,6 +1051,8 @@ select_cells_j <- function(cells, j) { }, cl = retcells, sp = newspans, SIMPLIFY = FALSE) } +#' @exportMethod subset_cols +#' @rdname subset_cols setMethod( "subset_cols", c("ANY", "character"), function(tt, j, newcinfo = NULL, keep_topleft = TRUE, ...) { @@ -1029,6 +1061,8 @@ setMethod( } ) +#' @exportMethod subset_cols +#' @rdname subset_cols setMethod( "subset_cols", c("TableRow", "numeric"), function(tt, j, newcinfo = NULL, keep_topleft = TRUE, ...) { @@ -1048,6 +1082,8 @@ setMethod( } ) +#' @exportMethod subset_cols +#' @rdname subset_cols setMethod( "subset_cols", c("LabelRow", "numeric"), function(tt, j, newcinfo = NULL, keep_topleft = TRUE, ...) { @@ -1061,6 +1097,8 @@ setMethod( } ) +#' @exportMethod subset_cols +#' @rdname subset_cols setMethod( "subset_cols", c("InstantiatedColumnInfo", "numeric"), function(tt, j, newcinfo = NULL, keep_topleft = TRUE, ...) { @@ -1085,6 +1123,8 @@ setMethod( } ) +#' @exportMethod subset_cols +#' @rdname subset_cols setMethod( "subset_cols", c("LayoutColTree", "numeric"), function(tt, j, newcinfo = NULL, ...) { diff --git a/_pkgdown.yml b/_pkgdown.yml index 33ad99b7fe..038858db67 100644 --- a/_pkgdown.yml +++ b/_pkgdown.yml @@ -199,6 +199,7 @@ reference: - cbind_rtables - asvec - brackets + - subset_cols - clear_indent_mods - head - section_div diff --git a/man/int_methods.Rd b/man/int_methods.Rd index e67995f18a..f5cefe26d1 100644 --- a/man/int_methods.Rd +++ b/man/int_methods.Rd @@ -351,6 +351,10 @@ \alias{ref_msg,RefFootnote-method} \alias{fnotes_at_path<-,VTableTree,character-method} \alias{fnotes_at_path<-,VTableTree,NULL-method} +\alias{has_force_pag} +\alias{has_force_pag,TableTree-method} +\alias{has_force_pag,Split-method} +\alias{has_force_pag,VTableNodeInfo-method} \alias{obj_stat_names} \alias{obj_stat_names<-} \alias{obj_stat_names<-,CellValue-method} @@ -1123,6 +1127,14 @@ spl_varnames(object) <- value \S4method{fnotes_at_path}{VTableTree,NULL}(obj, rowpath = NULL, colpath = NULL, reset_idx = TRUE) <- value +has_force_pag(obj) + +\S4method{has_force_pag}{TableTree}(obj) + +\S4method{has_force_pag}{Split}(obj) + +\S4method{has_force_pag}{VTableNodeInfo}(obj) + obj_stat_names(obj) obj_stat_names(obj) <- value diff --git a/man/subset_cols.Rd b/man/subset_cols.Rd new file mode 100644 index 0000000000..c2d87e4a43 --- /dev/null +++ b/man/subset_cols.Rd @@ -0,0 +1,133 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/tt_pos_and_access.R +\name{subset_cols} +\alias{subset_cols} +\alias{subset_cols,TableTree,numeric-method} +\alias{subset_cols,ElementaryTable,numeric-method} +\alias{subset_cols,ANY,character-method} +\alias{subset_cols,TableRow,numeric-method} +\alias{subset_cols,LabelRow,numeric-method} +\alias{subset_cols,InstantiatedColumnInfo,numeric-method} +\alias{subset_cols,LayoutColTree,numeric-method} +\title{Subset a table or row to particular columns} +\usage{ +subset_cols( + tt, + j, + newcinfo = NULL, + keep_topleft = TRUE, + keep_titles = TRUE, + keep_footers = keep_titles, + ... +) + +\S4method{subset_cols}{TableTree,numeric}( + tt, + j, + newcinfo = NULL, + keep_topleft = TRUE, + keep_titles = TRUE, + keep_footers = keep_titles, + ... +) + +\S4method{subset_cols}{ElementaryTable,numeric}( + tt, + j, + newcinfo = NULL, + keep_topleft = TRUE, + keep_titles = TRUE, + keep_footers = keep_titles, + ... +) + +\S4method{subset_cols}{ANY,character}( + tt, + j, + newcinfo = NULL, + keep_topleft = TRUE, + keep_titles = TRUE, + keep_footers = keep_titles, + ... +) + +\S4method{subset_cols}{TableRow,numeric}( + tt, + j, + newcinfo = NULL, + keep_topleft = TRUE, + keep_titles = TRUE, + keep_footers = keep_titles, + ... +) + +\S4method{subset_cols}{LabelRow,numeric}( + tt, + j, + newcinfo = NULL, + keep_topleft = TRUE, + keep_titles = TRUE, + keep_footers = keep_titles, + ... +) + +\S4method{subset_cols}{InstantiatedColumnInfo,numeric}( + tt, + j, + newcinfo = NULL, + keep_topleft = TRUE, + keep_titles = TRUE, + keep_footers = keep_titles, + ... +) + +\S4method{subset_cols}{LayoutColTree,numeric}( + tt, + j, + newcinfo = NULL, + keep_topleft = TRUE, + keep_titles = TRUE, + keep_footers = keep_titles, + ... +) +} +\arguments{ +\item{tt}{(\code{TableTree} or related class)\cr a \code{TableTree} object representing a populated table.} + +\item{j}{(\code{integer}, \code{logical} or \code{character})\cr The column(s) to subset \code{tt} +down to. Character vectors are intepreted as a \emph{column path}, not as names. +Path can include \code{"*"} wildcards.} + +\item{newcinfo}{(\code{NULL} or \code{InstantiatedColumnInfo})\cr The new column info, +if precomputed. Generally should not be manually set by users.} + +\item{keep_topleft}{(\code{flag})\cr if \code{TRUE} (the default), top_left material for the table will be carried over to the +subset.} + +\item{keep_titles}{(\code{flag})\cr if \code{TRUE} (the default), all title material for the table will be carried over to the +subset.} + +\item{keep_footers}{(\code{flag})\cr if \code{TRUE}, all footer material for the table will be carried over to the subset. It +defaults to \code{keep_titles}.} + +\item{...}{Ignored.} +} +\description{ +Subset a table or row to particular columns +} +\examples{ +lyt <- basic_table( + title = "Title", + subtitles = c("Sub", "titles"), + prov_footer = "prov footer", + main_footer = "main footer" +) \%>\% + split_cols_by("ARM") \%>\% + split_cols_by("SEX") \%>\% + analyze(c("AGE")) + +tbl <- build_table(lyt, DM) + +subset_cols(tbl, c(1, 3)) +subset_cols(tbl, c("ARM", "*", "SEX", "F")) +} diff --git a/tests/testthat/test-pagination.R b/tests/testthat/test-pagination.R index a939a1fe82..4a5e773b76 100644 --- a/tests/testthat/test-pagination.R +++ b/tests/testthat/test-pagination.R @@ -7,8 +7,15 @@ test_that("Page by splitting works", { analyze("AGE") tt <- build_table(lyt, DM) + expect_true(has_force_pag(tt)) + + expect_false(any(vapply(collect_leaves(tt, add.labrows = TRUE), has_force_pag, NA))) + + expect_false(has_force_pag(VarLevelSplit("AGE", "Age"))) + expect_true(has_force_pag(VarLevelSplit("AGE", "Age", page_prefix = "hi"))) ttlst <- paginate_table(tt) + expect_false(any(vapply(ttlst, has_force_pag, NA))) expect_identical( names(ttlst), diff --git a/tests/testthat/test-subset-access.R b/tests/testthat/test-subset-access.R index 6772ad5a8a..37f968c6f4 100644 --- a/tests/testthat/test-subset-access.R +++ b/tests/testthat/test-subset-access.R @@ -829,3 +829,51 @@ test_that("tt_row_path_exists and tt_normalize_row_path work", { strip_root_els(rdf3$path[rdf3$node_class == "ContentRow"]) ) }) + +test_that("subset_cols works as intended", { + lyt <- basic_table(title = "Title", + subtitles = c("Sub", "titles"), + prov_footer = "prov footer", + main_footer = "main footer") %>% + split_cols_by("ARM") %>% + split_cols_by("SEX") %>% + add_overall_col("All Patients") %>% + split_rows_by("STRATA1") %>% + summarize_row_groups() %>% + analyze(c("AGE")) + + tbl <- build_table(lyt, DM) + stbl1 <- subset_cols(tbl, 1) + stbl1b <- subset_cols(tbl, c("ARM", "A: Drug X", "SEX", "F")) + expect_equal(ncol(stbl1), 1) + expect_identical(stbl1, stbl1b) + expect_identical(all_titles(tbl), + all_titles(stbl1)) + expect_identical(all_footers(tbl), + all_footers(stbl1)) + + ## grab elementary table "for teh covrs" + ctab <- tt_at_path(tbl, c("STRATA1", "A", "@content")) + expect_identical(subset_cols(ctab, j = 1), + tt_at_path(stbl1, c("STRATA1", "A", "@content"))) + + stbl2 <- subset_cols(tbl, c(2, 6, 10)) + stbl2b <- subset_cols(tbl, c("*", "*", "*", "M")) + expect_equal(ncol(stbl2), 3) + expect_identical(stbl2, stbl2b) + + stbl3 <- subset_cols(tbl, c("All Patients")) + stbl3b <- subset_cols(tbl, 13) + + expect_equal(ncol(stbl3), 1) + expect_identical(stbl3, stbl3b) + + ## exercise direct-on-row column subsetting + ## contains all types of rows + rws <- collect_leaves(tbl, add.labrows = TRUE) + expect_identical(lapply(rws, subset_cols, j = 1), + collect_leaves(stbl1, add.labrows = TRUE)) + + expect_identical(lapply(rws, subset_cols, j = c("*", "*", "*", "M")), + collect_leaves(stbl2, add.labrows = TRUE)) +}) From af41bb13df175856e74deb9e7cc404308ab7849f Mon Sep 17 00:00:00 2001 From: github-actions <41898282+github-actions[bot]@users.noreply.github.com> Date: Mon, 2 Jun 2025 22:01:53 +0000 Subject: [PATCH 2/5] [skip style] [skip vbump] Restyle files --- tests/testthat/test-subset-access.R | 40 +++++++++++++++++++---------- 1 file changed, 26 insertions(+), 14 deletions(-) diff --git a/tests/testthat/test-subset-access.R b/tests/testthat/test-subset-access.R index 37f968c6f4..5a25a40e3e 100644 --- a/tests/testthat/test-subset-access.R +++ b/tests/testthat/test-subset-access.R @@ -831,10 +831,12 @@ test_that("tt_row_path_exists and tt_normalize_row_path work", { }) test_that("subset_cols works as intended", { - lyt <- basic_table(title = "Title", - subtitles = c("Sub", "titles"), - prov_footer = "prov footer", - main_footer = "main footer") %>% + lyt <- basic_table( + title = "Title", + subtitles = c("Sub", "titles"), + prov_footer = "prov footer", + main_footer = "main footer" + ) %>% split_cols_by("ARM") %>% split_cols_by("SEX") %>% add_overall_col("All Patients") %>% @@ -847,15 +849,21 @@ test_that("subset_cols works as intended", { stbl1b <- subset_cols(tbl, c("ARM", "A: Drug X", "SEX", "F")) expect_equal(ncol(stbl1), 1) expect_identical(stbl1, stbl1b) - expect_identical(all_titles(tbl), - all_titles(stbl1)) - expect_identical(all_footers(tbl), - all_footers(stbl1)) + expect_identical( + all_titles(tbl), + all_titles(stbl1) + ) + expect_identical( + all_footers(tbl), + all_footers(stbl1) + ) ## grab elementary table "for teh covrs" ctab <- tt_at_path(tbl, c("STRATA1", "A", "@content")) - expect_identical(subset_cols(ctab, j = 1), - tt_at_path(stbl1, c("STRATA1", "A", "@content"))) + expect_identical( + subset_cols(ctab, j = 1), + tt_at_path(stbl1, c("STRATA1", "A", "@content")) + ) stbl2 <- subset_cols(tbl, c(2, 6, 10)) stbl2b <- subset_cols(tbl, c("*", "*", "*", "M")) @@ -871,9 +879,13 @@ test_that("subset_cols works as intended", { ## exercise direct-on-row column subsetting ## contains all types of rows rws <- collect_leaves(tbl, add.labrows = TRUE) - expect_identical(lapply(rws, subset_cols, j = 1), - collect_leaves(stbl1, add.labrows = TRUE)) + expect_identical( + lapply(rws, subset_cols, j = 1), + collect_leaves(stbl1, add.labrows = TRUE) + ) - expect_identical(lapply(rws, subset_cols, j = c("*", "*", "*", "M")), - collect_leaves(stbl2, add.labrows = TRUE)) + expect_identical( + lapply(rws, subset_cols, j = c("*", "*", "*", "M")), + collect_leaves(stbl2, add.labrows = TRUE) + ) }) From f53f432175cae916e94f2e89f68ef548e09cbdd5 Mon Sep 17 00:00:00 2001 From: Gabe Becker Date: Tue, 3 Jun 2025 07:59:13 -0700 Subject: [PATCH 3/5] Update R/tt_pos_and_access.R Co-authored-by: Davide Garolini Signed-off-by: Gabe Becker --- R/tt_pos_and_access.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/tt_pos_and_access.R b/R/tt_pos_and_access.R index 2477416d36..a3e86f8f58 100644 --- a/R/tt_pos_and_access.R +++ b/R/tt_pos_and_access.R @@ -848,7 +848,7 @@ setMethod( #' @inheritParams brackets #' @inheritParams head #' @param j (`integer`, `logical` or `character`)\cr The column(s) to subset `tt` -#' down to. Character vectors are intepreted as a *column path*, not as names. +#' down to. Character vectors are interpreted as a *column path*, not as names. #' Path can include `"*"` wildcards. #' @param newcinfo (`NULL` or `InstantiatedColumnInfo`)\cr The new column info, #' if precomputed. Generally should not be manually set by users. From 293a6e2f815989ec4b523a9609868c5cd7539986 Mon Sep 17 00:00:00 2001 From: github-actions <41898282+github-actions[bot]@users.noreply.github.com> Date: Tue, 3 Jun 2025 15:02:53 +0000 Subject: [PATCH 4/5] [skip roxygen] [skip vbump] Roxygen Man Pages Auto Update --- man/subset_cols.Rd | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/man/subset_cols.Rd b/man/subset_cols.Rd index c2d87e4a43..5bb88207de 100644 --- a/man/subset_cols.Rd +++ b/man/subset_cols.Rd @@ -95,7 +95,7 @@ subset_cols( \item{tt}{(\code{TableTree} or related class)\cr a \code{TableTree} object representing a populated table.} \item{j}{(\code{integer}, \code{logical} or \code{character})\cr The column(s) to subset \code{tt} -down to. Character vectors are intepreted as a \emph{column path}, not as names. +down to. Character vectors are interpreted as a \emph{column path}, not as names. Path can include \code{"*"} wildcards.} \item{newcinfo}{(\code{NULL} or \code{InstantiatedColumnInfo})\cr The new column info, From 9d1a41bac2cd21a89185b2f3bcce0c2d9e4f35c1 Mon Sep 17 00:00:00 2001 From: Joe Zhu Date: Wed, 4 Jun 2025 23:49:51 +0800 Subject: [PATCH 5/5] Trigger Build