Merge branch 'main' into remove_lookups@main

Author: llrs-roche

DESCRIPTION

@@ -1,7 +1,7 @@
 Package: rtables
 Title: Reporting Tables
-Version: 0.6.11.9002
-Date: 2025-01-27
+Version: 0.6.11.9004
+Date: 2025-02-06
 Authors@R: c(
     person("Gabriel", "Becker", , "[email protected]", role = "aut",
            comment = "Original creator of the package"),

NEWS.md

@@ -1,11 +1,12 @@
-## rtables 0.6.11.9002
+## rtables 0.6.11.9004
 
 ### New Features
  * Added `stat_string` to `as_result_df(make_ard = TRUE)` to preserve the original string representation of the statistics.
  * Added `add_tbl_name_split` to `as_result_df()` to handle split levels constituted by different table names.
 
 ### Bug Fixes
  * Fixed issue with `split_cols_by_multivar()` when having more than one value. Now `as_result_df(make_ard = TRUE)` adds a predefined split name for each of the `multivar` splits.
+ * Fixed bug happening when format functions were changing the number of printed values. Now `as_result_df(make_ard = TRUE)` uses the cell values for `stat_strings` for these exceptions.
 
 ## rtables 0.6.11
 

R/tt_as_df.R

@@ -20,6 +20,8 @@
 #' @param add_tbl_name_split (`flag`)\cr when `TRUE` and when the table has more than one
 #'   `analyze(table_names = "<diff_names>")`, the table names will be present as a group split named
 #'   `"<analysis_spl_tbl_name>"`.
+#' @param verbose (`flag`)\cr when `TRUE`, the function will print additional information for
+#'   `data_format != "full_precision"`.
 #' @param ... additional arguments passed to spec-specific result data frame function (`spec`).
 #'
 #' @return
@@ -46,6 +48,7 @@ as_result_df <- function(tt, spec = NULL,
                          keep_label_rows = FALSE,
                          add_tbl_name_split = FALSE,
                          simplify = FALSE,
+                         verbose = FALSE,
                          ...) {
   data_format <- data_format[[1]]
   checkmate::assert_class(tt, "VTableTree")
@@ -56,6 +59,7 @@ as_result_df <- function(tt, spec = NULL,
   checkmate::assert_flag(keep_label_rows)
   checkmate::assert_flag(simplify)
   checkmate::assert_flag(add_tbl_name_split)
+  checkmate::assert_flag(verbose)
 
   if (nrow(tt) == 0) {
     return(sanitize_table_struct(tt))
@@ -70,7 +74,7 @@ as_result_df <- function(tt, spec = NULL,
   if (is.null(spec)) {
     # raw values
     rawvals <- cell_values(tt)
-    cellvals <- .make_df_from_raw_data(rawvals, nr = nrow(tt), nc = ncol(tt))
+    cellvals_init <- .make_df_from_raw_data(rawvals, nr = nrow(tt), nc = ncol(tt))
 
     if (data_format %in% c("strings", "numeric")) {
       # we keep previous calculations to check the format of the data
@@ -80,15 +84,17 @@ as_result_df <- function(tt, spec = NULL,
       mf_result_numeric <- .make_numeric_char_mf(mf_result_chars)
       mf_result_chars <- as.data.frame(mf_result_chars)
       mf_result_numeric <- as.data.frame(mf_result_numeric)
-      if (!setequal(dim(mf_result_numeric), dim(cellvals)) || !setequal(dim(mf_result_chars), dim(cellvals))) {
+      cond1 <- !setequal(dim(mf_result_chars), dim(cellvals_init))
+      cond2 <- !setequal(dim(mf_result_numeric), dim(cellvals_init))
+      if (cond1 || cond2) {
         stop(
           "The extracted numeric data.frame does not have the same dimension of the",
           " cell values extracted with cell_values(). This is a bug. Please report it."
         ) # nocov
       }
 
-      colnames(mf_result_chars) <- colnames(cellvals)
-      colnames(mf_result_numeric) <- colnames(cellvals)
+      colnames(mf_result_chars) <- colnames(cellvals_init)
+      colnames(mf_result_numeric) <- colnames(cellvals_init)
       if (data_format == "strings") {
         cellvals <- mf_result_chars
         if (isTRUE(make_ard)) {
@@ -101,6 +107,41 @@ as_result_df <- function(tt, spec = NULL,
           cellvals <- mf_result_numeric
         }
       }
+
+      diff_in_cellvals <- length(unlist(cellvals_init)) - length(unlist(cellvals))
+      if (make_ard && abs(diff_in_cellvals) > 0) {
+        warning_msg <- paste0(
+          "Found ", abs(diff_in_cellvals), " cell values that differ from ",
+          "printed values. This is possibly related to conditional formatting. "
+        )
+
+        # number of values difference mask between cellvals and cellvals_init (TRUE if different)
+        dmc <- lengths(unlist(cellvals, recursive = FALSE)) != lengths(unlist(cellvals_init, recursive = FALSE))
+        dmc <- matrix(dmc, nrow = nrow(cellvals), ncol = ncol(cellvals))
+
+        # Mainly used for debugging
+        selected_rows_to_print <- mf_strings(mf_tt)[-seq_len(mf_nlheader(mf_tt)), , drop = FALSE]
+        selected_rows_to_print <- cbind(
+          which(apply(dmc, 1, any, simplify = TRUE)),
+          as.data.frame(selected_rows_to_print[apply(dmc, 1, any), , drop = FALSE])
+        )
+        colnames(selected_rows_to_print) <- c("row_number", "row_name", colnames(cellvals_init))
+        warning_msg <- if (verbose) {
+          paste0(
+            warning_msg,
+            "\n",
+            "The following row names were modified: ",
+            paste(selected_rows_to_print$row_name, sep = ", ", collapse = ", "),
+            "\n"
+          )
+        } else {
+          paste0(warning_msg, "To see the affected row names use `verbose = TRUE`.")
+        }
+        warning(warning_msg)
+        cellvals[dmc] <- cellvals_init[dmc]
+      }
+    } else {
+      cellvals <- cellvals_init
     }
 
     rdf <- make_row_df(tt)
@@ -115,7 +156,11 @@ as_result_df <- function(tt, spec = NULL,
     # Correcting maxlen for even number of paths (only multianalysis diff table names)
     maxlen <- max(lengths(df$path))
     if (maxlen %% 2 != 0) {
-      maxlen <- maxlen + 1
+      maxlen <- if (add_tbl_name_split) {
+        maxlen + 1
+      } else {
+        maxlen - 1
+      }
     }
 
     # Loop for metadata (path and details from make_row_df)
@@ -299,7 +344,7 @@ as_result_df <- function(tt, spec = NULL,
       if (!"already_done" %in% names(list(...))) {
         stat_string_ret <- as_result_df(
           tt = tt, spec = spec, data_format = "numeric",
-          make_ard = TRUE, already_done = TRUE, ...
+          make_ard = TRUE, already_done = TRUE, verbose = verbose, ...
         )
         ret_w_cols <- cbind(ret_w_cols, "stat_string" = stat_string_ret$stat)
       }

man/data.frame_export.Rd

@@ -54,7 +54,7 @@ test_that("Result Data Frame generation works v0", {
     analyze(c("AGE", "SEX"))
 
   tbl4 <- build_table(lyt4, DM)
-  result_df4 <- as_result_df(tbl4)
+  result_df4 <- as_result_df(tbl4, add_tbl_name_split = TRUE)
 
   expect_identical(
     names(result_df4),
@@ -533,6 +533,9 @@ test_that("make_ard works if string precision is needed", {
 })
 
 test_that("make_ard works with split_cols_by_multivar", {
+  skip_if_not_installed("dplyr")
+  require(dplyr, quietly = TRUE)
+
   # Regression test #970
   n <- 400
 
@@ -563,3 +566,27 @@ test_that("make_ard works with split_cols_by_multivar", {
   expect_silent(out <- as_result_df(tbl, make_ard = TRUE))
   expect_true(all(out$group3 == "multivar_split1"))
 })
+test_that("make_ard works when printed format differs from cell values", {
+  mean_sd_custom <- function(x, ...) {
+    rcell(c(1, 2),
+      label = "Mean (SD)", format = function(xf, ...) {
+        return(as.character(xf[1]))
+      }
+    )
+  }
+
+  test_out <- basic_table() %>%
+    split_rows_by("ARM") %>%
+    split_cols_by("ARM") %>%
+    analyze(vars = "AGE", afun = mean_sd_custom) %>%
+    build_table(DM)
+
+  expect_warning(
+    out <- as_result_df(test_out, make_ard = TRUE, verbose = TRUE),
+    "Found 9 cell"
+  )
+  expect_equal(
+    out$stat,
+    out$stat_string
+  )
+})