Fixes and testing extreme templates (#968)

Fixes #959 #964 #963 #960 #961

---------

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]>

NEWS.md

@@ -18,6 +18,7 @@
  * Fixed bug that was keeping indentation space characters in top left information when making a `flextable` from a `TableTree` object.
  * Fixed bug in `analyze` that was causing an error when passing a single `NA` value to the
 `var_labels` parameter.
+ * Fixed bugs for multiple `analyze` calls in `as_result_df`.
 
 ## rtables 0.6.10
 

R/tt_as_df.R

@@ -99,7 +99,12 @@ as_result_df <- function(tt, spec = NULL,
       which_root_name = c("root", "rbind_root"),
       all = TRUE
     )
+
+    # Correcting maxlen for even number of paths (only multianalysis diff table names)
     maxlen <- max(lengths(df$path))
+    if (maxlen %% 2 != 0) {
+      maxlen <- maxlen + 1
+    }
 
     # Loop for metadata (path and details from make_row_df)
     metadf <- do.call(
@@ -174,6 +179,7 @@ as_result_df <- function(tt, spec = NULL,
       ret <- rbind(header_colnames_matrix, ret)
     }
 
+    # make_ard -----------------------------------------------------------------
     # ARD part for one stat per row
     if (make_ard) {
       cinfo_df <- col_info(tt)
@@ -238,11 +244,13 @@ as_result_df <- function(tt, spec = NULL,
         stat_name <- setNames(cell_stat_names[, col_i - min(only_col_indexes) + 1, drop = TRUE], NULL)
         stat <- setNames(ret_tmp[!col_label_rows, col_i, drop = TRUE], NULL)
         necessary_stat_lengths <- sapply(stat, length)
+        stat[sapply(stat, is.null)] <- NA
 
         # Truncating or adding NA if stat names has more or less elements than stats
         stat_name <- lapply(seq_along(stat_name), function(sn_i) {
           stat_name[[sn_i]][seq_len(necessary_stat_lengths[sn_i])]
         })
+        stat_name[!nzchar(stat_name)] <- NA
 
         # unnesting stat_name and stat
         tmp_ret_by_col_i <- NULL
@@ -322,7 +330,15 @@ as_result_df <- function(tt, spec = NULL,
     kids <- tree_children(ci_coltree)
     return(lapply(kids, .get_column_split_name))
   }
-  sapply(pos_splits(tree_pos(ci_coltree)), spl_payload)
+
+  lapply(pos_splits(tree_pos(ci_coltree)), function(x) {
+    pl <- spl_payload(x)
+    if (!is.null(pl)) { # it is null when all obs (1 column)
+      return(pl)
+    } else {
+      return(x@name)
+    }
+  })
 }
 
 # Function that selects specific outputs from the result data frame
@@ -378,6 +394,9 @@ do_label_row <- function(rdfrow, maxlen) {
   # Special cases with hidden labels
   if (length(pth) %% 2 == 1) {
     extra_nas_from_splits <- extra_nas_from_splits + 1
+  } else {
+    pth <- c("<analysis_spl_tbl_name>", pth)
+    extra_nas_from_splits <- extra_nas_from_splits - 1
   }
 
   c(
@@ -415,15 +434,19 @@ do_content_row <- function(rdfrow, maxlen) {
 do_data_row <- function(rdfrow, maxlen) {
   pth <- rdfrow$path[[1]]
   pthlen <- length(pth)
-  ## odd means we have a multi-analsysis step in the path, we dont' want that in the result data frame
-  if (pthlen %% 2 == 1) {
-    pth <- pth[-1 * (pthlen - 2)]
+  ## odd means we have a multi-analsysis step in the path, we do not want this in the result
+  if (pthlen %% 2 == 1 && pthlen > 1) {
+    # we remove the last element, as it is a fake split (tbl_name from analyse)
+    # pth <- pth[-1 * (pthlen - 2)]
+    pth <- c("<analysis_spl_tbl_name>", pth)
   }
   pthlen_new <- length(pth)
-  if (maxlen == 1) pthlen_new <- 3
+  if (pthlen_new == 1) {
+    pthlen_new <- 3 # why?
+  }
   c(
     as.list(pth[seq_len(pthlen_new - 2)]),
-    replicate(maxlen - pthlen, list(NA_character_)),
+    replicate(ifelse((maxlen - pthlen_new) > 0, maxlen - pthlen_new, 0), list(NA_character_)),
     as.list(tail(pth, 2)),
     list(
       label_name = rdfrow$label,

tests/testthat/test-result_data_frame.R

@@ -59,6 +59,7 @@ test_that("Result Data Frame generation works v0", {
   expect_identical(
     names(result_df4),
     c(
+      "group1", "group1_level",
       "avar_name", "row_name", "label_name", "row_num", "is_group_summary",
       "node_class", "A: Drug X", "B: Placebo", "C: Combination"
     )
@@ -239,6 +240,16 @@ test_that("as_result_df works fine with empty tables and no character(0) is allo
   )
 })
 
+test_that("as_result_df works with analyze-only tables (odd num of path elements)", {
+  tbl <- basic_table() %>%
+    analyze("cyl", table_names = "a") %>%
+    analyze("mpg") %>%
+    build_table(mtcars)
+
+  expect_equal(as_result_df(tbl)$group1[[1]], "<analysis_spl_tbl_name>")
+  expect_equal(as_result_df(tbl, make_ard = TRUE)$group1[[1]], "<analysis_spl_tbl_name>")
+})
+
 test_that("make_ard produces realistic ARD output with as_result_df", {
   # Testing fundamental getters/setters
   rc <- rcell(c(1, 2), stat_names = c("Rand1", "Rand2"))
@@ -290,8 +301,10 @@ test_that("make_ard produces realistic ARD output with as_result_df", {
   expect_equal(
     ard_out[2, , drop = TRUE],
     list(
-      group1 = "ARM",
-      group1_level = "A: Drug X",
+      group1 = "<analysis_spl_tbl_name>",
+      group1_level = "ma_AGE_SEX",
+      group2 = "ARM",
+      group2_level = "A: Drug X",
       variable = "AGE",
       variable_level = "Mean (SD)",
       variable_label = "Mean (SD)",
@@ -305,8 +318,10 @@ test_that("make_ard produces realistic ARD output with as_result_df", {
   expect_equal(
     ard_out[14, , drop = TRUE],
     list(
-      group1 = "ARM",
-      group1_level = "B: Placebo",
+      group1 = "<analysis_spl_tbl_name>",
+      group1_level = "ma_AGE_SEX",
+      group2 = "ARM",
+      group2_level = "B: Placebo",
       variable = "SEX",
       variable_level = "F",
       variable_label = "F",