From 758b1d241dbf985913869fb03a4d499ba09bdcb8 Mon Sep 17 00:00:00 2001 From: Davide Garolini Date: Mon, 8 Jan 2024 18:25:24 +0100 Subject: [PATCH 1/4] Addition of top level divisor (#796) * addition of top_level_section_div * tests * small fix * Fix integration tests * Update R/colby_constructors.R Signed-off-by: Davide Garolini * roxygen --------- Signed-off-by: Davide Garolini Signed-off-by: Davide Garolini --- NAMESPACE | 2 ++ NEWS.md | 2 ++ R/00tabletrees.R | 3 +++ R/colby_constructors.R | 21 +++++++++++++-------- R/tree_accessors.R | 29 ++++++++++++++++++++++++++++- R/tt_dotabulation.R | 15 +++++++++++---- man/basic_table.Rd | 18 +++++++++++------- man/build_table.Rd | 2 +- man/section_div.Rd | 15 ++++++++++++++- tests/testthat/test-accessors.R | 17 +++++++++++++++++ tests/testthat/test-printing.R | 7 ++++--- 11 files changed, 106 insertions(+), 25 deletions(-) diff --git a/NAMESPACE b/NAMESPACE index 4e35c5200..a67d8ac45 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -21,6 +21,7 @@ export("ref_symbol<-") export("row_footnotes<-") export("section_div<-") export("top_left<-") +export("top_level_section_div<-") export("tree_children<-") export("tt_at_path<-") export(.add_row_summary) @@ -174,6 +175,7 @@ export(table_structure) export(tail) export(theme_docx_default) export(top_left) +export(top_level_section_div) export(tree_children) export(trim_levels_in_facets) export(trim_levels_in_group) diff --git a/NEWS.md b/NEWS.md index 83e7cd9a6..181c3fe3f 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,4 +1,6 @@ ## rtables 0.6.6.9001 +### New Features + * Added `top_level_section_div` for `basic_table` to set section dividers for top level rows. ## rtables 0.6.6 ### New Features diff --git a/R/00tabletrees.R b/R/00tabletrees.R index d9cbfb3db..18419f95c 100644 --- a/R/00tabletrees.R +++ b/R/00tabletrees.R @@ -1806,6 +1806,7 @@ setClass("PreDataTableLayouts", col_layout = "PreDataColLayout", top_left = "character", header_section_div = "character", + top_level_section_div = "character", table_inset = "integer" ) ) @@ -1818,6 +1819,7 @@ PreDataTableLayouts <- function(rlayout = PreDataRowLayout(), main_footer = character(), prov_footer = character(), header_section_div = NA_character_, + top_level_section_div = NA_character_, table_inset = 0L) { new("PreDataTableLayouts", row_layout = rlayout, @@ -1828,6 +1830,7 @@ PreDataTableLayouts <- function(rlayout = PreDataRowLayout(), main_footer = main_footer, provenance_footer = prov_footer, header_section_div = header_section_div, + top_level_section_div = top_level_section_div, table_inset = table_inset ) } diff --git a/R/colby_constructors.R b/R/colby_constructors.R index 0cdfdacc8..2a9820b4e 100644 --- a/R/colby_constructors.R +++ b/R/colby_constructors.R @@ -1987,16 +1987,17 @@ list_wrap_df <- function(f) { #' #' Every layout must start with a basic table. #' -#' @export #' @inheritParams constr_args #' @param show_colcounts logical(1). Should column counts be displayed in the #' resulting table when this layout is applied to data #' @param colcount_format character(1). Format for use when displaying the -#' column counts. Must be 1d, or 2d where one component is a percent. See -#' details. +#' column counts. Must be 1d, or 2d where one component is a percent. See +#' details. +#' @param top_level_section_div character(1). If assigned to a single character, +#' the first (top level) split or division of the table will be highlighted by a line made of that character. +#' See [section_div] for more information. #' #' @details -#' #' `colcount_format` is ignored if `show_colcounts` is `FALSE` (the default). #' When `show_colcounts` is `TRUE`, and `colcount_format` is 2-dimensional with #' a percent component, the value component for the percent is always populated @@ -2006,10 +2007,10 @@ list_wrap_df <- function(f) { #' `colcount` format. See [formatters::list_valid_format_labels()] for #' the list of valid format labels to select from. #' -#' #' @inherit split_cols_by return #' -#' @note - Because percent components in `colcount_format` are *always* +#' @note +#' - Because percent components in `colcount_format` are *always* #' populated with the value 1, we can get arguably strange results, such as #' that individual arm columns and a combined "all patients" column all #' list "100%" as their percentage, even though the individual arm columns @@ -2020,7 +2021,6 @@ list_wrap_df <- function(f) { #' indentation on multiple lines. #' #' @examples -#' #' lyt <- basic_table() %>% #' analyze("AGE", afun = mean) #' @@ -2048,25 +2048,30 @@ list_wrap_df <- function(f) { #' ) %>% #' split_cols_by("ARM") #' +#' @export basic_table <- function(title = "", subtitles = character(), main_footer = character(), prov_footer = character(), - header_section_div = NA_character_, show_colcounts = FALSE, colcount_format = "(N=xx)", + header_section_div = NA_character_, + top_level_section_div = NA_character_, inset = 0L) { inset <- as.integer(inset) if (is.na(inset) || inset < 0L) { stop("Got invalid table_inset value, must be an integer > 0") } .check_header_section_div(header_section_div) + checkmate::assert_character(top_level_section_div, len = 1, n.chars = 1) + ret <- PreDataTableLayouts( title = title, subtitles = subtitles, main_footer = main_footer, prov_footer = prov_footer, header_section_div = header_section_div, + top_level_section_div = top_level_section_div, table_inset = as.integer(inset) ) if (show_colcounts) { diff --git a/R/tree_accessors.R b/R/tree_accessors.R index 616be3e60..09c786fd0 100644 --- a/R/tree_accessors.R +++ b/R/tree_accessors.R @@ -3280,7 +3280,8 @@ setMethod("trailing_section_div<-", "TableRow", function(obj, value) { #' @return The section divider string. Each line that does not have a trailing separator #' will have `NA_character_` as section divider. #' -#' @seealso [basic_table()] parameter `header_section_div` for a global section divider. +#' @seealso [basic_table()] parameter `header_section_div` and `top_level_section_div` for global +#' section dividers. #' #' @details #' Assigned value to section divider must be a character vector. If any value is `NA_character_` @@ -3514,6 +3515,32 @@ setMethod( invisible(TRUE) } +#' @rdname section_div +#' @export +setGeneric("top_level_section_div", function(obj) standardGeneric("top_level_section_div")) + +#' @rdname section_div +#' @aliases top_level_section_div,PreDataTableLayouts-method +setMethod( + "top_level_section_div", "PreDataTableLayouts", + function(obj) obj@top_level_section_div +) + +#' @rdname section_div +#' @export +setGeneric("top_level_section_div<-", function(obj, value) standardGeneric("top_level_section_div<-")) + +#' @rdname section_div +#' @aliases top_level_section_div<-,PreDataTableLayouts-method +setMethod( + "top_level_section_div<-", "PreDataTableLayouts", + function(obj, value) { + checkmate::assert_character(value, len = 1, n.chars = 1) + obj@top_level_section_div <- value + obj + } +) + ## table_inset ---------------------------------------------------------- #' @rdname formatters_methods #' @export diff --git a/R/tt_dotabulation.R b/R/tt_dotabulation.R index 0698bcdc1..6d08d868f 100644 --- a/R/tt_dotabulation.R +++ b/R/tt_dotabulation.R @@ -1145,7 +1145,6 @@ recursive_applysplit <- function(df, #' Layouts are used to describe a table pre-data. `build_table` is used to #' create a table using a layout and a dataset. #' -#' #' @inheritParams gen_args #' @inheritParams lyt_args #' @param col_counts numeric (or `NULL`). Deprecated. If non-null, column counts @@ -1157,7 +1156,6 @@ recursive_applysplit <- function(df, #' @param \dots currently ignored. #' #' @details -#' #' When \code{alt_counts_df} is specified, column counts are calculated by #' applying the exact column subsetting expressions determined when applying #' column splitting to the main data (\code{df}) to \code{alt_counts_df} and @@ -1174,14 +1172,12 @@ recursive_applysplit <- function(df, #' column counts at all (even implicitly) is the only way to ensure overridden #' counts are fully respected. #' -#' @export #' @return A \code{TableTree} or \code{ElementaryTable} object representing the #' table created by performing the tabulations declared in \code{lyt} to the #' data \code{df}. #' @author Gabriel Becker #' #' @examples -#' #' lyt <- basic_table() %>% #' split_cols_by("Species") %>% #' analyze("Sepal.Length", afun = function(x) { @@ -1232,6 +1228,8 @@ recursive_applysplit <- function(df, #' #' tbl6 <- build_table(lyt3, DM, col_counts = 1:3) #' tbl6 +#' +#' @export build_table <- function(lyt, df, alt_counts_df = NULL, col_counts = NULL, @@ -1293,6 +1291,7 @@ build_table <- function(lyt, df, cvar = content_var(rtspl), extra_args = content_extra_args(rtspl) ) + kids <- lapply(seq_along(rlyt), function(i) { splvec <- rlyt[[i]] if (length(splvec) == 0) { @@ -1330,6 +1329,14 @@ build_table <- function(lyt, df, kids <- kids[!sapply(kids, is.null)] if (length(kids) > 0) names(kids) <- sapply(kids, obj_name) + # top level divisor + if (!is.na(top_level_section_div(lyt))) { + kids <- lapply(kids, function(first_level_kids) { + trailing_section_div(first_level_kids) <- top_level_section_div(lyt) + first_level_kids + }) + } + if (nrow(ctab) == 0L && length(kids) == 1L && is(kids[[1]], "VTableTree")) { tab <- kids[[1]] main_title(tab) <- main_title(lyt) diff --git a/man/basic_table.Rd b/man/basic_table.Rd index 2b38a189b..a7c8ce462 100644 --- a/man/basic_table.Rd +++ b/man/basic_table.Rd @@ -9,9 +9,10 @@ basic_table( subtitles = character(), main_footer = character(), prov_footer = character(), - header_section_div = NA_character_, show_colcounts = FALSE, colcount_format = "(N=xx)", + header_section_div = NA_character_, + top_level_section_div = NA_character_, inset = 0L ) } @@ -30,11 +31,6 @@ lines.} (\code{\link[=prov_footer]{prov_footer()}}). It can be also a vector of strings, printed on different lines. Generally should not be modified by hand.} -\item{header_section_div}{character(1). String which will be used to divide the header -from the table. See \code{\link[=header_section_div]{header_section_div()}} for getter and setter of these. -Please consider changing last element of \code{\link[=section_div]{section_div()}} when concatenating -tables that need a divider between them.} - \item{show_colcounts}{logical(1). Should column counts be displayed in the resulting table when this layout is applied to data} @@ -42,6 +38,15 @@ resulting table when this layout is applied to data} column counts. Must be 1d, or 2d where one component is a percent. See details.} +\item{header_section_div}{character(1). String which will be used to divide the header +from the table. See \code{\link[=header_section_div]{header_section_div()}} for getter and setter of these. +Please consider changing last element of \code{\link[=section_div]{section_div()}} when concatenating +tables that need a divider between them.} + +\item{top_level_section_div}{character(1). If assigned to a single character, +the first (top level) split or division of the table will be highlighted by a line made of that character. +See \link{section_div} for more information.} + \item{inset}{numeric(1). Number of spaces to inset the table header, table body, referential footnotes, and main_footer, as compared to alignment of title, subtitle, and provenance footer. Defaults to 0 (no inset).} @@ -76,7 +81,6 @@ indentation on multiple lines. } } \examples{ - lyt <- basic_table() \%>\% analyze("AGE", afun = mean) diff --git a/man/build_table.Rd b/man/build_table.Rd index 353a35a4d..31c83fa1f 100644 --- a/man/build_table.Rd +++ b/man/build_table.Rd @@ -71,7 +71,6 @@ column counts at all (even implicitly) is the only way to ensure overridden counts are fully respected. } \examples{ - lyt <- basic_table() \%>\% split_cols_by("Species") \%>\% analyze("Sepal.Length", afun = function(x) { @@ -122,6 +121,7 @@ tbl5 tbl6 <- build_table(lyt3, DM, col_counts = 1:3) tbl6 + } \author{ Gabriel Becker diff --git a/man/section_div.Rd b/man/section_div.Rd index acaf5a750..1d10c7102 100644 --- a/man/section_div.Rd +++ b/man/section_div.Rd @@ -17,6 +17,10 @@ \alias{header_section_div<-} \alias{header_section_div<-,PreDataTableLayouts-method} \alias{header_section_div<-,VTableTree-method} +\alias{top_level_section_div} +\alias{top_level_section_div,PreDataTableLayouts-method} +\alias{top_level_section_div<-} +\alias{top_level_section_div<-,PreDataTableLayouts-method} \title{Section dividers getter and setter} \usage{ section_div(obj) @@ -48,6 +52,14 @@ header_section_div(obj) <- value \S4method{header_section_div}{PreDataTableLayouts}(obj) <- value \S4method{header_section_div}{VTableTree}(obj) <- value + +top_level_section_div(obj) + +\S4method{top_level_section_div}{PreDataTableLayouts}(obj) + +top_level_section_div(obj) <- value + +\S4method{top_level_section_div}{PreDataTableLayouts}(obj) <- value } \arguments{ \item{obj}{Table object. This can be of any class that inherits from \code{VTableTree} @@ -120,5 +132,6 @@ tbl } \seealso{ -\code{\link[=basic_table]{basic_table()}} parameter \code{header_section_div} for a global section divider. +\code{\link[=basic_table]{basic_table()}} parameter \code{header_section_div} and \code{top_level_section_div} for global +section dividers. } diff --git a/tests/testthat/test-accessors.R b/tests/testthat/test-accessors.R index e334e9982..512b733b9 100644 --- a/tests/testthat/test-accessors.R +++ b/tests/testthat/test-accessors.R @@ -405,3 +405,20 @@ test_that("header_section_div works", { expect_true(check_pattern(header_sdiv, "+", nchar(header_sdiv))) }) + +test_that("top_level_section_div works", { + lyt <- basic_table(top_level_section_div = "a") %>% + split_cols_by("ARM") %>% + split_rows_by("SEX", split_fun = drop_split_levels) %>% + analyze("AGE") %>% + split_rows_by("RACE", split_fun = drop_split_levels) %>% + split_rows_by("SEX", split_fun = drop_split_levels) %>% + analyze("AGE") + tbl <- build_table(lyt, DM) + expect_identical(top_level_section_div(lyt), "a") + top_level_section_div(lyt) <- "=" + expect_identical(top_level_section_div(lyt), "=") + tbl <- build_table(lyt, DM) + top_lev_div_str <- strsplit(toString(tbl), "\n")[[1]][7] + expect_true(check_pattern(top_lev_div_str, "=", nchar(top_lev_div_str))) +}) diff --git a/tests/testthat/test-printing.R b/tests/testthat/test-printing.R index 0ab5f8dd0..d673ee837 100644 --- a/tests/testthat/test-printing.R +++ b/tests/testthat/test-printing.R @@ -319,9 +319,10 @@ test_that("Decimal alignment works", { "c10 1111.11% 1111.11% 1111.11% ", "c11 1111.111% 1111.111% 1111.111% ", "c12 (N=11.11111) (N=11.11111) (N=11.11111)", - "c13 11.1 11.1 11.1 ", - "c14 11.11 11.11 11.11 ", - "c15 11.1111 11.1111 11.1111 " + "c13 N=11.11111 N=11.11111 N=11.11111 ", + "c14 11.1 11.1 11.1 ", + "c15 11.11 11.11 11.11 ", + "c16 11.1111 11.1111 11.1111 " ) expect_identical(res, expected) }) From 25e762d6493adad35d5f6c15babbb5e8031892f3 Mon Sep 17 00:00:00 2001 From: Melkiades Date: Mon, 8 Jan 2024 17:26:29 +0000 Subject: [PATCH 2/4] [skip actions] Bump version to 0.6.6.9002 --- DESCRIPTION | 4 ++-- NEWS.md | 2 +- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index fe63e730a..643c99b44 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,7 +1,7 @@ Package: rtables Title: Reporting Tables -Version: 0.6.6.9001 -Date: 2023-12-11 +Version: 0.6.6.9002 +Date: 2024-01-08 Authors@R: c( person("Gabriel", "Becker", , "gabembecker@gmail.com", role = "aut", comment = "Original creator of the package"), diff --git a/NEWS.md b/NEWS.md index 181c3fe3f..2100556d8 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,4 +1,4 @@ -## rtables 0.6.6.9001 +## rtables 0.6.6.9002 ### New Features * Added `top_level_section_div` for `basic_table` to set section dividers for top level rows. From c5ef380a0c4184189063145ebb26575f8d4105f5 Mon Sep 17 00:00:00 2001 From: Davide Garolini Date: Wed, 10 Jan 2024 20:38:03 +0100 Subject: [PATCH 3/4] doc expansions (#811) --- R/tree_accessors.R | 11 +++++++---- R/tt_toString.R | 8 ++++++-- man/table_shell.Rd | 6 +++++- man/value_formats.Rd | 7 +++++-- vignettes/introspecting_tables.Rmd | 14 ++++++++++++++ 5 files changed, 37 insertions(+), 9 deletions(-) diff --git a/R/tree_accessors.R b/R/tree_accessors.R index 09c786fd0..10ef009e6 100644 --- a/R/tree_accessors.R +++ b/R/tree_accessors.R @@ -1173,18 +1173,22 @@ setMethod("content_na_str<-", "Split", function(obj, value) { #' Returns a matrix of formats for the cells in a table #' @param obj A table or row object. #' @param default `FormatSpec`. -#' @export +#' #' @return Matrix (storage mode list) containing the effective format for each #' cell position in the table (including 'virtual' cells implied by label rows, -#' whose formats are always `NULL`) -#' @examples +#' whose formats are always `NULL`). +#' +#' @seealso [table_shell()] and [table_shell_str()] for information on the table format structure. #' +#' @examples #' lyt <- basic_table() %>% #' split_rows_by("RACE", split_fun = keep_split_levels(c("ASIAN", "WHITE"))) %>% #' analyze("AGE") #' #' tbl <- build_table(lyt, DM) #' value_formats(tbl) +#' +#' @export setGeneric("value_formats", function(obj, default = obj_format(obj)) standardGeneric("value_formats")) #' @rdname value_formats setMethod( @@ -1193,7 +1197,6 @@ setMethod( obj_format(obj) %||% default } ) - #' @rdname value_formats setMethod( "value_formats", "TableRow", diff --git a/R/tt_toString.R b/R/tt_toString.R index 2f46d5510..3658c32f2 100644 --- a/R/tt_toString.R +++ b/R/tt_toString.R @@ -72,8 +72,10 @@ setMethod("toString", "VTableTree", function(x, #' @inheritParams tostring #' @inheritParams gen_args #' @return for `table_shell_str` the string representing the table shell, for `table_shell`, -#' `NULL`, as the function is called for the side effect of printing the shell to the console -#' @export +#' `NULL`, as the function is called for the side effect of printing the shell to the console. +#' +#' @seealso [value_formats()] for a matrix of formats for each cell in a table. +#' #' @examples #' library(dplyr) #' @@ -89,6 +91,8 @@ setMethod("toString", "VTableTree", function(x, #' #' tbl <- build_table(lyt, iris2) #' table_shell(tbl) +#' +#' @export table_shell <- function(tt, widths = NULL, col_gap = 3, hsep = default_hsep(), tf_wrap = FALSE, max_width = NULL) { cat(table_shell_str( diff --git a/man/table_shell.Rd b/man/table_shell.Rd index 31fa94f06..891298d14 100644 --- a/man/table_shell.Rd +++ b/man/table_shell.Rd @@ -51,7 +51,7 @@ completely if \code{tf_wrap} is \code{FALSE}.} } \value{ for \code{table_shell_str} the string representing the table shell, for \code{table_shell}, -\code{NULL}, as the function is called for the side effect of printing the shell to the console +\code{NULL}, as the function is called for the side effect of printing the shell to the console. } \description{ A table shell is a rendering of the table which maintains the structure, but does not @@ -72,4 +72,8 @@ lyt <- basic_table() \%>\% tbl <- build_table(lyt, iris2) table_shell(tbl) + +} +\seealso{ +\code{\link[=value_formats]{value_formats()}} for a matrix of formats for each cell in a table. } diff --git a/man/value_formats.Rd b/man/value_formats.Rd index 69160fc6a..0671439c5 100644 --- a/man/value_formats.Rd +++ b/man/value_formats.Rd @@ -26,17 +26,20 @@ value_formats(obj, default = obj_format(obj)) \value{ Matrix (storage mode list) containing the effective format for each cell position in the table (including 'virtual' cells implied by label rows, -whose formats are always \code{NULL}) +whose formats are always \code{NULL}). } \description{ Returns a matrix of formats for the cells in a table } \examples{ - lyt <- basic_table() \%>\% split_rows_by("RACE", split_fun = keep_split_levels(c("ASIAN", "WHITE"))) \%>\% analyze("AGE") tbl <- build_table(lyt, DM) value_formats(tbl) + +} +\seealso{ +\code{\link[=table_shell]{table_shell()}} and \code{\link[=table_shell_str]{table_shell_str()}} for information on the table format structure. } diff --git a/vignettes/introspecting_tables.Rmd b/vignettes/introspecting_tables.Rmd index 567ffc091..d924142d3 100644 --- a/vignettes/introspecting_tables.Rmd +++ b/vignettes/introspecting_tables.Rmd @@ -120,6 +120,20 @@ row_paths_summary(tbl) col_paths_summary(tbl) ``` +## Insights on Value Format Structure + +We can gain insight into the value formatting structure of a table using `table_shell()`, which returns a table with the same output as `print()` but with the cell values replaced by their underlying format strings (e.g. instead of `40.0`, `xx.x` is displayed, and so on). This is useful for understanding the structure of the table, and for debugging purposes. Another useful tool is the `value_formats()` function which instead of a table returns a matrix of the format strings for each cell value in the table. + +See below the printout for the above examples: + +```{r} +table_shell(tbl) +``` + +```{r} +value_formats(tbl) +``` + ## Applications Knowing the structure of an `rtable` object is helpful for retrieving specific values from the table. From 39b5fd501c04bd54f09007c8a3961586fea6def9 Mon Sep 17 00:00:00 2001 From: Melkiades Date: Wed, 10 Jan 2024 19:39:16 +0000 Subject: [PATCH 4/4] [skip actions] Bump version to 0.6.6.9003 --- DESCRIPTION | 4 ++-- NEWS.md | 2 +- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 643c99b44..feac7c0e5 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,7 +1,7 @@ Package: rtables Title: Reporting Tables -Version: 0.6.6.9002 -Date: 2024-01-08 +Version: 0.6.6.9003 +Date: 2024-01-10 Authors@R: c( person("Gabriel", "Becker", , "gabembecker@gmail.com", role = "aut", comment = "Original creator of the package"), diff --git a/NEWS.md b/NEWS.md index 2100556d8..a8c15fe08 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,4 +1,4 @@ -## rtables 0.6.6.9002 +## rtables 0.6.6.9003 ### New Features * Added `top_level_section_div` for `basic_table` to set section dividers for top level rows.