Merge branch 'main' into 600_cheatsheet@main

DESCRIPTION

@@ -1,7 +1,7 @@
 Package: rtables
 Title: Reporting Tables
-Version: 0.6.6.9001
-Date: 2023-12-11
+Version: 0.6.6.9003
+Date: 2024-01-10
 Authors@R: c(
     person("Gabriel", "Becker", , "[email protected]", role = "aut",
            comment = "Original creator of the package"),

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)

NEWS.md

@@ -1,4 +1,6 @@
-## rtables 0.6.6.9001
+## rtables 0.6.6.9003
+### New Features
+ * Added `top_level_section_div` for `basic_table` to set section dividers for top level rows.
 
 ## rtables 0.6.6
 ### New Features

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
   )
 }

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) {

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",
@@ -3280,7 +3283,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 +3518,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

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)

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(