diff --git a/NEWS.md b/NEWS.md index 410bf4c68..a830e150a 100644 --- 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 index 629e3d4df..955b5dc7e 100644 --- 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 index bb3d3e262..2d1f9dbd7 100644 --- 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 index 02f196c2e..05787cbc0 100644 --- 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) + ) +})