Adding stat_names and support for row/col splits and ContentRow (#958)

#950 #947 #949 # NEWS * Completed `make_ard = TRUE` support for `as_result_df()`. * Added `stat_names` to `rcell()` to be used by `as_result_df(make_ard = TRUE)`. --------- Signed-off-by: Davide Garolini <[email protected]> Co-authored-by: github-actions <41898282+github-actions[bot]@users.noreply.github.com> Co-authored-by: Emily de la Rua <[email protected]> Co-authored-by: Emily de la Rua <[email protected]>
insightsengineering · Nov 29, 2024 · f87f1ef · f87f1ef
1 parent 1514d7c
commit f87f1ef
Show file tree

Hide file tree

Showing 15 changed files with 585 additions and 67 deletions.
diff --git a/NAMESPACE b/NAMESPACE
@@ -20,6 +20,7 @@ export("header_section_div<-")
 export("horizontal_sep<-")
 export("indent_mod<-")
 export("label_at_path<-")
+export("obj_stat_names<-")
 export("ref_index<-")
 export("ref_symbol<-")
 export("row_footnotes<-")
@@ -125,6 +126,7 @@ export(manual_cols)
 export(no_colinfo)
 export(non_ref_rcell)
 export(obj_avar)
+export(obj_stat_names)
 export(pag_tt_indices)
 export(paginate_table)
 export(path_enriched_df)
@@ -221,6 +223,7 @@ exportMethods("obj_format<-")
 exportMethods("obj_label<-")
 exportMethods("obj_na_str<-")
 exportMethods("obj_name<-")
+exportMethods("obj_stat_names<-")
 exportMethods("prov_footer<-")
 exportMethods("ref_index<-")
 exportMethods("ref_symbol<-")
@@ -267,6 +270,7 @@ exportMethods(obj_format)
 exportMethods(obj_label)
 exportMethods(obj_na_str)
 exportMethods(obj_name)
+exportMethods(obj_stat_names)
 exportMethods(prov_footer)
 exportMethods(rbind)
 exportMethods(rbind2)

diff --git a/NEWS.md b/NEWS.md
@@ -4,7 +4,8 @@
  * Experimental pagination is now possible in `tt_as_flextable()` and `export_as_docx()`.
  * Added handling of widths in `tt_as_flextable()`. Now it is possible to change column widths for `.docx` exports.
  * Initialized vignette about quality control outputs of `as_result_df()`.
- * Initialized parameter `make_ard` output for single-line statistical outputs.
+ * Completed parameter `make_ard` output for single-line statistical outputs.
+ * Added `stat_names` to `rcell()` to be used by `as_result_df(make_ard = TRUE)`.
 
 ### Miscellaneous
  * Split `docx` document generation to the new package [`rtables.officer`](https://github.com/insightsengineering/rtables.officer).

diff --git a/R/00tabletrees.R b/R/00tabletrees.R
@@ -1933,7 +1933,7 @@ RefFootnote <- function(note, index = NA_integer_, symbol = NA_character_) {
 ## indent_mod: indent modifier to be used for parent row
 CellValue <- function(val, format = NULL, colspan = 1L, label = NULL,
                       indent_mod = NULL, footnotes = NULL,
-                      align = NULL, format_na_str = NULL) {
+                      align = NULL, format_na_str = NULL, stat_names = NA_character_) {
   if (is.null(colspan)) {
     colspan <- 1L
   }
@@ -1957,6 +1957,7 @@ CellValue <- function(val, format = NULL, colspan = 1L, label = NULL,
     indent_mod = indent_mod, footnotes = footnotes,
     align = align,
     format_na_str = format_na_str,
+    stat_names = stat_names,
     class = "CellValue"
   )
   ret

diff --git a/R/colby_constructors.R b/R/colby_constructors.R
@@ -1492,7 +1492,8 @@ setMethod(
     }
     ret <- rcell(cnt,
       format = format,
-      label = label
+      label = label,
+      stat_names = "n"
     )
     ret
   }
@@ -1515,11 +1516,11 @@ setMethod(
       cnt <- sum(!is.na(df))
     }
     ## the formatter does the *100 so we don't here.
-    ## TODO name elements of this so that ARD generation has access to them
-    ## ret <- rcell(c(n = cnt, pct = cnt / .N_col),
+    ## Elements are named with stat_names so that ARD generation has access to them
     ret <- rcell(c(cnt, cnt / .N_col),
       format = format,
-      label = label
+      label = label,
+      stat_names = c("n", "p")
     )
     ret
   }

diff --git a/R/tree_accessors.R b/R/tree_accessors.R
@@ -4322,3 +4322,31 @@ setMethod(
     obj
   }
 )
+
+# stat_names for ARD -----------------------------------------------------------
+#
+#' @rdname int_methods
+#' @export
+setGeneric("obj_stat_names", function(obj) standardGeneric("obj_stat_names"))
+#
+#' @rdname int_methods
+#' @export
+setGeneric("obj_stat_names<-", function(obj, value) standardGeneric("obj_stat_names<-"))
+
+#' @rdname int_methods
+#' @export
+setMethod("obj_stat_names<-", "CellValue", function(obj, value) {
+  attr(obj, "stat_names") <- value
+  obj
+})
+
+#' @rdname int_methods
+#' @export
+setMethod("obj_stat_names", "CellValue", function(obj) attr(obj, "stat_names"))
+
+#' @rdname int_methods
+#' @export
+setMethod(
+  "obj_stat_names", "RowsVerticalSection",
+  function(obj) lapply(obj, obj_stat_names)
+)
diff --git a/R/tt_afun_utils.R b/R/tt_afun_utils.R
@@ -10,11 +10,18 @@
 #' @param label (`string` or `NULL`)\cr label. If non-`NULL`, it will be looked at when determining row labels.
 #' @param colspan (`integer(1)`)\cr column span value.
 #' @param footnotes (`list` or `NULL`)\cr referential footnote messages for the cell.
+#' @param stat_names (`character` or `NA`)\cr names for the statistics in the cell. It can be a vector of strings.
+#'   If `NA`, statistic names are not specified.
 #'
 #' @inherit CellValue return
 #'
 #' @note Currently column spanning is only supported for defining header structure.
 #'
+#' @examples
+#' rcell(1, format = "xx.x")
+#' rcell(c(1, 2), format = c("xx - xx"))
+#' rcell(c(1, 2), stat_names = c("Rand1", "Rand2"))
+#'
 #' @rdname rcell
 #' @export
 rcell <- function(x,
@@ -24,7 +31,9 @@ rcell <- function(x,
                   indent_mod = NULL,
                   footnotes = NULL,
                   align = NULL,
-                  format_na_str = NULL) {
+                  format_na_str = NULL,
+                  stat_names = NULL) {
+  checkmate::assert_character(stat_names, null.ok = TRUE)
   if (!is.null(align)) {
     check_aligns(align)
   }
@@ -47,6 +56,9 @@ rcell <- function(x,
     if (!is.null(format_na_str)) {
       obj_na_str(x) <- format_na_str
     }
+    if (!is.null(stat_names)) {
+      obj_stat_names(x) <- stat_names
+    }
     ret <- x
   } else {
     if (is.null(label)) {
@@ -66,7 +78,8 @@ rcell <- function(x,
       label = label,
       indent_mod = indent_mod,
       footnotes = footnotes,
-      format_na_str = format_na_str
+      format_na_str = format_na_str,
+      stat_names = stat_names %||% NA_character_
     ) # RefFootnote(footnote))
   }
   if (!is.null(align)) {
@@ -113,6 +126,9 @@ non_ref_rcell <- function(x, is_ref, format = NULL, colspan = 1L,
 #' @param .aligns (`character` or `NULL`)\cr alignments for the cells. Standard for `NULL` is `"center"`.
 #'   See [formatters::list_valid_aligns()] for currently supported alignments.
 #' @param .format_na_strs (`character` or `NULL`)\cr NA strings for the cells.
+#' @param .stat_names (`list`)\cr names for the statistics in the cells.
+#'   It can be a vector of values. If `list(NULL)`, statistic names are not specified and will
+#'   appear as `NA`.
 #'
 #' @note In post-processing, referential footnotes can also be added using row and column
 #'   paths with [`fnotes_at_path<-`].
@@ -126,6 +142,12 @@ non_ref_rcell <- function(x, is_ref, format = NULL, colspan = 1L,
 #' in_rows(1, 2, 3, .names = c("a", "b", "c"))
 #' in_rows(1, 2, 3, .labels = c("a", "b", "c"))
 #' in_rows(1, 2, 3, .names = c("a", "b", "c"), .labels = c("AAA", "BBB", "CCC"))
+#' in_rows(
+#'   .list = list(a = c(NA, NA)),
+#'   .formats = "xx - xx",
+#'   .format_na_strs = list(c("asda", "lkjklj"))
+#' )
+#' in_rows(.list = list(a = c(NA, NA)), .format_na_strs = c("asda", "lkjklj"))
 #'
 #' in_rows(.list = list(a = 1, b = 2, c = 3))
 #' in_rows(1, 2, .list = list(3), .names = c("a", "b", "c"))
@@ -150,7 +172,8 @@ in_rows <- function(..., .list = NULL, .names = NULL,
                     .cell_footnotes = list(NULL),
                     .row_footnotes = list(NULL),
                     .aligns = NULL,
-                    .format_na_strs = NULL) {
+                    .format_na_strs = NULL,
+                    .stat_names = list(NULL)) {
   if (is.function(.formats)) {
     .formats <- list(.formats)
   }
@@ -172,11 +195,12 @@ in_rows <- function(..., .list = NULL, .names = NULL,
         length(.formats) > 0 ||
         length(.names) > 0 ||
         length(.indent_mods) > 0 ||
-        length(.format_na_strs) > 0
+        length(.format_na_strs) > 0 ||
+        (!all(is.na(.stat_names)) && length(.stat_names) > 0)
     ) {
       stop(
         "in_rows got 0 rows but length >0 of at least one of ",
-        ".labels, .formats, .names, .indent_mods, .format_na_strs. ",
+        ".labels, .formats, .names, .indent_mods, .format_na_strs, .stat_names. ",
         "Does your analysis/summary function handle the 0 row ",
         "df/length 0 x case?"
       )
@@ -208,11 +232,13 @@ in_rows <- function(..., .list = NULL, .names = NULL,
     if (is.null(.aligns)) {
       .aligns <- list(NULL)
     }
+
     l2 <- mapply(rcell,
       x = l, format = .formats,
       footnotes = .cell_footnotes %||% list(NULL),
       align = .aligns,
       format_na_str = .format_na_strs %||% list(NULL),
+      stat_names = .stat_names %||% list(NULL),
       SIMPLIFY = FALSE
     )
   }