fix tt_at_path and adding test coverage to error in sorting (#994)

Fixes #864 but not sorting. That would need a similar handling as now in `tt_at_path` --------- Signed-off-by: Davide Garolini <[email protected]> Co-authored-by: github-actions <41898282+github-actions[bot]@users.noreply.github.com>
insightsengineering · Feb 28, 2025 · 0e9abc1 · 0e9abc1
1 parent c1e6f05
commit 0e9abc1
Show file tree

Hide file tree

Showing 4 changed files with 97 additions and 14 deletions.
diff --git a/NEWS.md b/NEWS.md
@@ -6,6 +6,7 @@
 
 ### 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 a bug with `tt_at_path()` caused by the impossibility to solve multiple branches with identical names. 
  * 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.
  * `section_div` argument to `analyze` no longer sometimes applies dividers between each generated row in some cases. by @gmbecker
  * Fixed bug in `[<-` causing information to be stripped from other cells if a new `rcell` is set within a table row.

diff --git a/R/tt_pos_and_access.R b/R/tt_pos_and_access.R
@@ -295,23 +295,43 @@ setMethod(
     if (obj_name(tt) == path[1]) {
       path <- path[-1]
     }
-    cur <- tt
-    curpath <- path
-    while (length(curpath > 0)) {
-      kids <- tree_children(cur)
-      curname <- curpath[1]
-      if (curname == "@content") {
-        cur <- content_table(cur)
-      } else if (curname %in% names(kids)) {
-        cur <- kids[[curname]]
+
+    # Extract sub-tables from the tree
+    .extract_through_path(tt, path)
+  }
+)
+
+# Recursive helper function to retrieve sub-tables from the tree
+.extract_through_path <- function(cur_tbl, cur_path, no_stop = FALSE) {
+  while (length(cur_path > 0)) {
+    kids <- tree_children(cur_tbl)
+    curname <- cur_path[1]
+    if (curname == "@content") {
+      cur_tbl <- content_table(cur_tbl)
+    } else if (curname %in% names(kids)) {
+      cur_tbl <- kids[names(kids) == curname]
+
+      # Case where there are more than one tree sub node with identical names
+      if (length(cur_tbl) > 1 && length(cur_path) > 1) {
+        cur_tbl <- sapply(cur_tbl, function(cti) .extract_through_path(cti, cur_path[-1], no_stop = TRUE))
+        found_values <- !sapply(cur_tbl, is.null)
+        cur_tbl <- cur_tbl[found_values]
+        if (sum(found_values) == 1) {
+          cur_tbl <- cur_tbl[[1]]
+        }
+        cur_path <- cur_path[1]
       } else {
-        stop("Path appears invalid for this tree at step ", curname)
+        cur_tbl <- cur_tbl[[1]] # Usual case (only one matching value)
       }
-      curpath <- curpath[-1]
+    } else if (!no_stop) {
+      stop("Path appears invalid for this tree at step ", curname)
+    } else {
+      return(NULL)
     }
-    cur
+    cur_path <- cur_path[-1]
   }
-)
+  cur_tbl
+}
 
 #' @note Setting `NULL` at a defined path removes the corresponding sub-table.
 #'

diff --git a/tests/testthat/test-sort-prune.R b/tests/testthat/test-sort-prune.R
@@ -121,7 +121,7 @@ test_that("provided score functions work", {
 ## contributed by daniel
 test_that("sort_at_path just returns an empty input table", {
   silly_prune_condition <- function(tt) {
-    return(TRUE)
+    TRUE
   }
   emptytable <- trim_rows(rawtable, silly_prune_condition)
   expect_identical(dim(emptytable), c(0L, ncol(rawtable)))
@@ -297,3 +297,28 @@ test_that("paths come out correct when sorting with '*'", {
     list("A: Drug X" = 12)
   )
 })
+
+test_that("sort_at_path throws an error when trying to sort a table with identical branching names", {
+  # Related to regression test #864
+  adsl <- ex_adsl
+  adsl$flag <- sample(c("Y", "N"), nrow(adsl), replace = TRUE)
+
+  lyt <- basic_table() %>%
+    split_rows_by("flag", split_fun = keep_split_levels("Y")) %>%
+    split_rows_by("SEX") %>%
+    analyze("BMRKR1") %>%
+    split_rows_by("flag", split_fun = keep_split_levels("Y")) %>%
+    split_rows_by("SEX") %>%
+    analyze("AGE")
+
+  tbl <- build_table(lyt, adsl)
+
+  scorefun <- function(tt) {
+    unlist(cell_values(tt))
+  }
+
+  expect_error(
+    sort_at_path(tbl, c("root", "flag", "Y", "SEX"), scorefun),
+    "position element flag appears more than once, not currently supported"
+  )
+})
diff --git a/tests/testthat/test-subset-access.R b/tests/testthat/test-subset-access.R
@@ -588,3 +588,40 @@ test_that("tt_at_path and cell_values work with values even if they differ in na
   names(rdf$path[[2]]) <- c("a", "b")
   expect_silent(tt_at_path(tbl, rdf$path[[2]]))
 })
+
+test_that("tt_at_path works with identical split names", {
+  # Regression test #864
+  adsl <- ex_adsl
+  adsl$flag <- sample(c("Y", "N"), nrow(adsl), replace = TRUE)
+
+  afun <- function(x, ...) rcell(label = "Flagged Pop. Count", sum(x == "Y"))
+
+  lyt <- basic_table() %>%
+    analyze("flag", afun = afun) %>%
+    split_rows_by("flag", split_fun = keep_split_levels("Y"), child_labels = "hidden") %>%
+    split_rows_by("SEX") %>%
+    analyze("BMRKR1")
+
+  tbl <- build_table(lyt, adsl)
+
+  expect_equal(
+    tt_at_path(tbl, c("root", "flag", "Y")),
+    tree_children(tree_children(tbl)[[2]])[[1]]
+  )
+
+  # Even with deeper branching
+  lyt <- basic_table() %>%
+    split_rows_by("flag", split_fun = keep_split_levels("Y"), child_labels = "hidden") %>%
+    split_rows_by("SEX", split_fun = keep_split_levels("U")) %>%
+    analyze("BMRKR1") %>%
+    split_rows_by("flag", split_fun = keep_split_levels("Y"), child_labels = "hidden") %>%
+    split_rows_by("SEX", split_fun = keep_split_levels("U")) %>%
+    analyze("AGE")
+
+  tbl <- build_table(lyt, adsl)
+
+  expect_equal(
+    names(tt_at_path(tbl, c("root", "flag", "Y", "SEX", "U"))),
+    rep("flag", 2)
+  )
+})