Merge branch 'main' into remove_decoration_nl_matrix_form@243_fix_nl_…

…expansion@main
insightsengineering · Jan 9, 2024 · 9f8c8dc · 9f8c8dc
2 parents 082b739 + 25e762d
commit 9f8c8dc
Show file tree

Hide file tree

Showing 12 changed files with 109 additions and 28 deletions.
diff --git 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", , "[email protected]", role = "aut",
            comment = "Original creator of the package"),

diff --git 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
@@ -1,4 +1,6 @@
-## 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.
 
 ### Bug Fixes
  * Fixed `rlistings` decoration (e.g. titles and footers) expansion when there are new lines. Moved relevant handling from `rtables`' `matrix_form` function to `formatters`' dedicated `mform_handle_newlines` function.

diff --git 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
@@ -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
@@ -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
@@ -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
diff --git a/man/build_table.Rd b/man/build_table.Rd
diff --git a/man/section_div.Rd b/man/section_div.Rd
diff --git 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
@@ -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)
 })