Combine duplicate ref footnotes (#781)

Closes #779

DESCRIPTION

@@ -29,7 +29,7 @@ URL: https://github.com/insightsengineering/rtables,
     https://insightsengineering.github.io/rtables/
 BugReports: https://github.com/insightsengineering/rtables/issues
 Depends:
-    formatters (>= 0.5.4),
+    formatters (>= 0.5.4.9003),
     magrittr (>= 1.5),
     methods,
     R (>= 2.10)

NAMESPACE

@@ -6,6 +6,7 @@ export("cell_footnotes<-")
 export("clayout<-")
 export("col_counts<-")
 export("col_fnotes_here<-")
+export("col_footnotes<-")
 export("col_info<-")
 export("col_total<-")
 export("colcount_format<-")
@@ -64,6 +65,7 @@ export(clear_indent_mods)
 export(col_counts)
 export(col_exprs)
 export(col_fnotes_here)
+export(col_footnotes)
 export(col_info)
 export(col_paths)
 export(col_paths_summary)
@@ -198,6 +200,7 @@ exportMethods("cell_footnotes<-")
 exportMethods("clayout<-")
 exportMethods("col_counts<-")
 exportMethods("col_fnotes_here<-")
+exportMethods("col_footnotes<-")
 exportMethods("col_info<-")
 exportMethods("col_total<-")
 exportMethods("colcount_format<-")
@@ -228,6 +231,7 @@ exportMethods(clayout)
 exportMethods(clear_indent_mods)
 exportMethods(col_counts)
 exportMethods(col_fnotes_here)
+exportMethods(col_footnotes)
 exportMethods(col_info)
 exportMethods(col_total)
 exportMethods(colcount_format)

NEWS.md

@@ -2,12 +2,13 @@
 ### New Features
  * Removed `ref_group` reordering in column splits so not to change the order.
  * Added `bold` argument to `as_html` to bold specified elements, and `header_sep_line` argument to print a horizontal line under the table header in rendered HTML output.
-
+ * Duplicate referential footnotes are consolidated when tables are rendered.
 
 ### Miscellaneous
  * Applied `styler` and resolved package lint. Changed default indentation from 4 spaces to 2.
  * Added Developer Guide to pkgdown site with Debugging, Split Machinery, and Tabulation sections.
  * Whitespace is not trimmed when rendering tables with `as_html`.
+ * Started deprecation cycle for `col_fnotes_here` to be replaced with `col_footnotes`.
 
 ## rtables 0.6.5
 ### New Features

R/index_footnotes.R

@@ -9,7 +9,7 @@
     ## to begin with
     idx <- ref_index(refi)
     if (is.na(idx) || !is.na(as.integer(idx))) {
-      ref_index(refi) <- cur_idx_fun()
+      ref_index(refi) <- cur_idx_fun(refi)
     }
     refi
   })
@@ -63,8 +63,8 @@ index_col_refs <- function(tt, cur_idx_fun) {
 
 
 .index_col_refs_inner <- function(ctree, cur_idx_fun) {
-  col_fnotes_here(ctree) <- .reindex_one_pos(
-    col_fnotes_here(ctree),
+  col_footnotes(ctree) <- .reindex_one_pos(
+    col_footnotes(ctree),
     cur_idx_fun
   )
 
@@ -75,9 +75,9 @@ index_col_refs <- function(tt, cur_idx_fun) {
     )
   }
   ctree
-  ## cfs <- col_fnotes_here(ctree)
+  ## cfs <- col_footnotes(ctree)
   ## if(length(unlist(cfs)) > 0) {
-  ##     col_fnotes_here(ctree) <- .reindex_one_pos(lapply(cfs,
+  ##     col_footnotes(ctree) <- .reindex_one_pos(lapply(cfs,
   ##                                      function(refs) lapply(refs, function(refi) {
 }
 
@@ -95,11 +95,17 @@ index_col_refs <- function(tt, cur_idx_fun) {
 #' manually.
 #' @export
 update_ref_indexing <- function(tt) {
-  curind <- 0L
-  cur_index <- function() {
-    curind <<- curind + 1L
-    curind
+  col_fnotes <- c(list(row_fnotes = list()), col_footnotes(tt))
+  row_fnotes <- row_footnotes(tt)
+  cell_fnotes <- cell_footnotes(tt)
+  all_fns <- rbind(col_fnotes, cbind(row_fnotes, cell_fnotes))
+  all_fns <- unlist(t(all_fns))
+  unique_fnotes <- unique(sapply(all_fns, ref_msg))
+
+  cur_index <- function(ref_fn) {
+    match(ref_msg(ref_fn), unique_fnotes)
   }
+
   if (ncol(tt) > 0) {
     tt <- index_col_refs(tt, cur_index)
   } ## col_info(tt) <- index_col_refs(col_info(tt), cur_index)

R/tree_accessors.R

@@ -2877,33 +2877,83 @@ setMethod("cell_footnotes<-", "ContentRow",
   definition = .cfn_set_helper
 )
 
+# Deprecated methods
 #' @export
 #' @rdname ref_fnotes
 setGeneric("col_fnotes_here", function(obj) standardGeneric("col_fnotes_here"))
 #' @export
+#' @rdname ref_fnotes
+setMethod("col_fnotes_here", "ANY", function(obj) {
+  .Deprecated(
+    new = "col_footnotes",
+    old = "col_fnotes_here",
+    msg = "col_fnotes_here was deprecated in {rtables} version 0.6.5.9011. Please use col_footnotes instead."
+  )
+  col_footnotes(obj)
+})
+#' @export
+#' @rdname ref_fnotes
+setGeneric("col_fnotes_here<-", function(obj, value) standardGeneric("col_fnotes_here<-"))
+#' @export
 #' @rdname int_methods
-setMethod("col_fnotes_here", c("LayoutColTree"), function(obj) obj@col_footnotes)
+setMethod("col_fnotes_here<-", "ANY", function(obj, value) {
+  .Deprecated(
+    new = "col_footnotes<-",
+    old = "col_fnotes_here<-",
+    msg = "col_fnotes_here<- was deprecated in {rtables} version 0.6.5.9011. Please use col_footnotes<- instead."
+  )
+  col_footnotes(obj) <- value
+})
+
+#' @export
+#' @rdname ref_fnotes
+setGeneric("col_footnotes", function(obj) standardGeneric("col_footnotes"))
+
 #' @export
 #' @rdname int_methods
-setMethod("col_fnotes_here", c("LayoutColLeaf"), function(obj) obj@col_footnotes)
+setMethod("col_footnotes", "LayoutColTree", function(obj) obj@col_footnotes)
+
+#' @export
+#' @rdname int_methods
+setMethod("col_footnotes", "LayoutColLeaf", function(obj) obj@col_footnotes)
 
 #' @export
 #' @rdname ref_fnotes
-setGeneric("col_fnotes_here<-", function(obj, value) standardGeneric("col_fnotes_here<-"))
+setGeneric("col_footnotes<-", function(obj, value) standardGeneric("col_footnotes<-"))
+
 #' @export
 #' @rdname int_methods
-setMethod("col_fnotes_here<-", "LayoutColTree", function(obj, value) {
+setMethod("col_footnotes<-", "LayoutColTree", function(obj, value) {
   obj@col_footnotes <- make_ref_value(value)
   obj
 })
 
 #' @export
 #' @rdname int_methods
-setMethod("col_fnotes_here<-", "LayoutColLeaf", function(obj, value) {
+setMethod("col_footnotes<-", "LayoutColLeaf", function(obj, value) {
   obj@col_footnotes <- make_ref_value(value)
   obj
 })
 
+#' @export
+#' @rdname int_methods
+setMethod(
+  "col_footnotes", "VTableTree",
+  function(obj) {
+    ctree <- coltree(obj)
+    cols <- tree_children(ctree)
+    while (all(sapply(cols, is, "LayoutColTree"))) {
+      cols <- lapply(cols, tree_children)
+      cols <- unlist(cols, recursive = FALSE)
+    }
+    all_col_fnotes <- lapply(cols, col_footnotes)
+    if (is.null(unlist(all_col_fnotes))) {
+      return(NULL)
+    }
+
+    return(all_col_fnotes)
+  }
+)
 
 #' @export
 #' @rdname ref_fnotes

R/tt_paginate.R

@@ -444,7 +444,7 @@ setMethod(
       sibpos = sibpos,
       nsibs = nsibs,
       leaf_indices = colnum,
-      col_fnotes = col_fnotes_here(ct)
+      col_fnotes = col_footnotes(ct)
     ))
   }
 )
@@ -484,7 +484,7 @@ setMethod(
           sibpos = sibpos,
           nsibs = nsibs,
           pth = thispth,
-          col_fnotes = col_fnotes_here(ct)
+          col_fnotes = col_footnotes(ct)
         ))
         ret <- c(thisone, ret)
       }

R/tt_pos_and_access.R

@@ -96,7 +96,7 @@ coltree_split <- function(ctree) ctree@split
 
 col_fnotes_at_path <- function(ctree, path, fnotes) {
   if (length(path) == 0) {
-    col_fnotes_here(ctree) <- fnotes
+    col_footnotes(ctree) <- fnotes
     return(ctree)
   }
 

R/tt_toString.R

@@ -435,13 +435,12 @@ get_formatted_fnotes <- function(tt) {
   )
 
   inds <- vapply(lst, ref_index, 1L)
-  stopifnot(all(is.na(inds)) || !is.unsorted(inds))
+  ord <- order(inds)
+  lst <- lst[ord]
   syms <- vapply(lst, ref_symbol, "")
   keep <- is.na(syms) | !duplicated(syms)
-  inds <- inds[keep]
   lst <- lst[keep]
-  syms <- syms[keep]
-  vapply(lst, format_fnote_note, "")
+  unique(vapply(lst, format_fnote_note, ""))
 
 
 

tests/testthat/test-exporters.R

@@ -333,7 +333,7 @@ test_that("Can create flextable object that works with different styles", {
   expect_equal(sum(unlist(nrow(ft))), 20)
 
   ft2 <- tt_to_flextable(tbl, paginate = TRUE, lpp = 20, verbose = TRUE)
-  expect_equal(length(ft2), 6)
+  expect_equal(length(ft2), 2)
 
   expect_silent(ft3 <- tt_to_flextable(tbl, theme = NULL))
 

tests/testthat/test-pagination.R

@@ -497,3 +497,76 @@ test_that("Pagination works with wrapped titles/footers", {
   expect_equal(nchar(res2_str2_spl[nrow_res2 - 1]), 58)
   expect_equal(nchar(res2_str2_spl[nrow_res2]), 7)
 })
+
+test_that("Pagination works with referential footnotes", {
+  lyt <- basic_table(
+    title = "main title",
+    subtitles = "subtitle",
+    main_footer = "main footer",
+    prov_footer = "provenance footer"
+  ) %>%
+    split_cols_by("ARM") %>%
+    split_cols_by("SEX", split_fun = keep_split_levels(c("F", "M"))) %>%
+    split_rows_by("STRATA1", split_fun = keep_split_levels(c("A", "B")), page_by = TRUE, page_prefix = "Stratum") %>%
+    split_rows_by("RACE", split_fun = keep_split_levels(c("ASIAN", "WHITE"))) %>%
+    summarize_row_groups() %>%
+    analyze("AGE", afun = function(x, ...) {
+      in_rows(
+        "mean (sd)" = rcell(
+          c(mean(x), sd(x)),
+          format = "xx.x (xx.x)"
+        ),
+        "range" = rcell(range(x), format = "xx.x - xx.x")
+      )
+    })
+
+  tt <- build_table(lyt, ex_adsl)
+
+  fnotes_at_path(tt, rowpath = c("STRATA1", "B", "RACE", "WHITE")) <- "3 Row footnote"
+  fnotes_at_path(
+    tt,
+    rowpath = c("STRATA1", "A", "RACE", "WHITE", "AGE", "range"),
+    colpath = c("ARM", "C: Combination", "SEX", "M")
+  ) <- "2 Cell footnote"
+  fnotes_at_path(tt, rowpath = c("STRATA1", "A", "RACE", "ASIAN")) <- "1 Row footnote"
+  fnotes_at_path(
+    tt,
+    rowpath = c("STRATA1", "B", "RACE", "WHITE", "AGE", "mean (sd)"),
+    colpath = c("ARM", "B: Placebo", "SEX", "F")
+  ) <- "2 Cell footnote"
+
+  main_title(tt) <- "title with a\nnewline"
+  main_footer(tt) <- "wrapped footer with\nnewline"
+
+  res <- expect_silent(paginate_table(tt, cpp = 60, tf_wrap = TRUE))
+  expect_identical(main_title(res[[1]]), main_title(res[[2]]))
+  expect_identical(main_title(res[[1]]), main_title(tt))
+  expect_identical(main_footer(res[[1]]), main_footer(res[[2]]))
+  expect_identical(main_footer(res[[1]]), main_footer(tt))
+
+  main_title(tt) <- "this is a long long table title that should be wrapped to a new line"
+  main_footer(tt) <- "this is an extra long table main footer and should also be wrapped"
+
+  res <- expect_silent(paginate_table(tt, cpp = 60, tf_wrap = TRUE))
+  expect_equal(length(res), 4)
+
+  ref_fn_res1 <- matrix_form(res[[1]])$ref_fnote_df
+  expect_equal(ref_fn_res1$msg, "1 Row footnote")
+  expect_equal(ref_fn_res1$ref_index, 1)
+  expect_equal(ref_fn_res1$symbol, "1")
+
+  ref_fn_res2 <- matrix_form(res[[2]])$ref_fnote_df
+  expect_equal(ref_fn_res2$msg, c("1 Row footnote", "2 Cell footnote"))
+  expect_equal(ref_fn_res2$ref_index, 1:2)
+  expect_equal(ref_fn_res2$symbol, c("1", "2"))
+
+  ref_fn_res3 <- matrix_form(res[[3]])$ref_fnote_df
+  expect_equal(ref_fn_res3$msg, c("3 Row footnote", "2 Cell footnote"))
+  expect_equal(ref_fn_res3$ref_index, 1:2)
+  expect_equal(ref_fn_res3$symbol, c("3", "2"))
+
+  ref_fn_res4 <- matrix_form(res[[4]])$ref_fnote_df
+  expect_equal(ref_fn_res4$msg, "3 Row footnote")
+  expect_equal(ref_fn_res4$ref_index, 1)
+  expect_equal(ref_fn_res4$symbol, "3")
+})