From 191af9bd267f3864c7003b9cf3848c7464d0162c Mon Sep 17 00:00:00 2001 From: Davide Garolini Date: Thu, 22 Feb 2024 21:25:50 +0100 Subject: [PATCH 1/4] fix (#829) --- NEWS.md | 1 + R/tt_export.R | 10 +++- tests/testthat/test-result_data_frame.R | 80 +++++++++++++++---------- 3 files changed, 58 insertions(+), 33 deletions(-) diff --git a/NEWS.md b/NEWS.md index 3dff60be1..5203e6fc3 100644 --- a/NEWS.md +++ b/NEWS.md @@ -6,6 +6,7 @@ ### Bug Fixes * Fixed `rlistings` decoration (e.g. titles and footers) expansion when there are new lines. Moved relevant handling from `rtables`' `matrix_form` function to `formatters`' dedicated `mform_handle_newlines` function. * Fixed issue with `rtables_root` not being removed when using `as_result_df`. + * Fixed edge case bug in `as_result_df` where rows of the table have only `"root"` as path index. ## rtables 0.6.6 ### New Features diff --git a/R/tt_export.R b/R/tt_export.R index 1b8aaae1f..5ae85292a 100644 --- a/R/tt_export.R +++ b/R/tt_export.R @@ -428,11 +428,11 @@ do_data_row <- function(rdfrow, maxlen) { } .remove_root_elems_from_path <- function(path, which_root_name = c("root", "rbind_root"), all = TRUE) { - any_root_paths <- path[1] %in% c("root", "rbind_root") + any_root_paths <- path[1] %in% which_root_name if (any_root_paths) { if (isTRUE(all)) { # Selecting the header grouping of root and rbind_root (we do not want to remove other root labels-path later) - root_indices <- which(path %in% c("root", "rbind_root")) + root_indices <- which(path %in% which_root_name) if (any(diff(root_indices) > 1)) { # integer(0) for diff means FALSE end_point_root_headers <- which(diff(root_indices) > 1)[1] } else { @@ -444,6 +444,12 @@ do_data_row <- function(rdfrow, maxlen) { } path <- path[-root_path_to_remove] } + + # Fix for very edge case where we have only root elements + if (length(path) == 0) { + path <- which_root_name[1] + } + path } diff --git a/tests/testthat/test-result_data_frame.R b/tests/testthat/test-result_data_frame.R index 0944331ab..9a806e206 100644 --- a/tests/testthat/test-result_data_frame.R +++ b/tests/testthat/test-result_data_frame.R @@ -102,30 +102,30 @@ test_that("as_result_df works with visual output (as_viewer)", { ) expect_equal(as_result_df(tbl, expand_colnames = TRUE)$`all obs`[2], "356") expect_equal(as_result_df(tbl, expand_colnames = TRUE, as_strings = TRUE)$`all obs`[2], "(N=356)") - - + + # Test for integer extraction and ranges lyt <- basic_table() %>% split_cols_by("ARM") %>% split_rows_by("STRATA1") %>% analyze("AGE", afun = function(x) list(a = mean(x), b = range(x))) - + tbl <- build_table(lyt, ex_adsl) expect_equal(as_result_df(tbl, simplify = TRUE, as_viewer = TRUE)[2, 2][[1]], c(24, 46)) - + # Test for tables with less than 3 rows tbl <- rtable( header = rheader(rrow("", "c1", "c2")), rrow("row 1", 1, c(.8, 1.2)) ) expect_equal( - as_result_df(tbl)[, 1:6], + as_result_df(tbl)[, 1:6], data.frame( - "avar_name" = "row 1", - "row_name" = "row 1", - "label_name" = "row 1", - "row_num" = 1, - "is_group_summary" = FALSE, + "avar_name" = "row 1", + "row_name" = "row 1", + "label_name" = "row 1", + "row_num" = 1, + "is_group_summary" = FALSE, "node_class" = "DataRow" ) ) @@ -137,14 +137,14 @@ test_that("as_result_df works fine also with multiple rbind_root", { split_cols_by("ARM") %>% split_rows_by("STRATA1") %>% analyze(c("AGE", "BMRKR2")) - + tbl <- build_table(lyt, ex_adsl) - + mega_rbind_tbl <- rbind(tbl, rbind(tbl, tbl, rbind(tbl, tbl))) - + out <- expect_silent(as_result_df(mega_rbind_tbl)) - - expect_true(all(out[,1] == "STRATA1")) + + expect_true(all(out[, 1] == "STRATA1")) }) test_that("as_result_df keeps label rows", { @@ -154,37 +154,37 @@ test_that("as_result_df keeps label rows", { split_cols_by("STRATA2") %>% split_rows_by("STRATA1") %>% analyze(c("AGE", "BMRKR2")) - + tbl <- build_table(lyt, ex_adsl) - + rd1 <- as_result_df(tbl, keep_label_rows = TRUE) rd2 <- as_result_df(tbl, keep_label_rows = TRUE, expand_colnames = TRUE) rd3 <- as_result_df(tbl, keep_label_rows = TRUE, expand_colnames = TRUE, as_strings = TRUE) rd4 <- as_result_df(tbl, keep_label_rows = TRUE, expand_colnames = TRUE, as_viewer = TRUE) - + expect_equal(nrow(rd1), nrow(rd2) - 2) expect_equal(nrow(rd1), nrow(rd3) - 2) expect_equal(nrow(rd1), nrow(rd4) - 2) expect_identical(ncol(rd1), ncol(rd2)) expect_identical(ncol(rd1), ncol(rd3)) expect_identical(ncol(rd1), ncol(rd4)) - + expect_identical(as.character(rd1[3, ]), as.character(rd2[5, ])) expect_identical(rd2[is.na(rd2[, ncol(rd2)]), ], rd4[is.na(rd4[, ncol(rd4)]), ]) - + # More challenging labels lyt <- make_big_lyt() tbl <- build_table(lyt, rawdat) - + ard_out <- as_result_df(tbl, keep_label_rows = TRUE) mf_tbl <- matrix_form(tbl) - + # Label works expect_identical( ard_out$label_name, mf_strings(mf_tbl)[-seq_len(mf_nrheader(mf_tbl)), 1] ) - + # Row names respects path pths <- make_row_df(tbl)$path expect_identical( @@ -197,26 +197,44 @@ test_that("as_result_df as_is is producing a data.frame that is compatible with # More challenging labels lyt <- make_big_lyt() tbl <- build_table(lyt, rawdat) - + ard_out <- as_result_df(tbl, as_is = TRUE) mf_tbl <- matrix_form(tbl) - + # Label works expect_identical( ard_out$label_name, mf_strings(mf_tbl)[-seq_len(mf_nrheader(mf_tbl)), 1] ) - + expect_identical( ard_out$label_name, df_to_tt(ard_out) %>% row.names() ) - - init_tbl <- df_to_tt(mtcars) - end_tbl <- init_tbl %>% as_result_df(as_is = TRUE) %>% df_to_tt() - + + init_tbl <- df_to_tt(mtcars) + end_tbl <- init_tbl %>% + as_result_df(as_is = TRUE) %>% + df_to_tt() + expect_equal( - matrix_form(init_tbl)$strings, + matrix_form(init_tbl)$strings, matrix_form(end_tbl)$strings ) }) + +test_that("as_result_df works fine with empty tables and no character(0) is allowed", { + tbl <- basic_table() %>% + build_table(mtcars) + + expect_silent(as_result_df(tbl)) + + expect_equal( + .remove_root_elems_from_path( + c("a", "b", "c"), + which_root_name = c("a", "b", "c"), + all = TRUE + ), + "a" + ) +}) From 2177e1587292807f5cad81c0ab4c6474fac77f95 Mon Sep 17 00:00:00 2001 From: edelarua Date: Thu, 22 Feb 2024 20:26:57 +0000 Subject: [PATCH 2/4] [skip actions] Bump version to 0.6.6.9009 --- DESCRIPTION | 4 ++-- NEWS.md | 2 +- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 0c9f70857..7e2952622 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,7 +1,7 @@ Package: rtables Title: Reporting Tables -Version: 0.6.6.9008 -Date: 2024-02-21 +Version: 0.6.6.9009 +Date: 2024-02-22 Authors@R: c( person("Gabriel", "Becker", , "gabembecker@gmail.com", role = "aut", comment = "Original creator of the package"), diff --git a/NEWS.md b/NEWS.md index 5203e6fc3..76d3baf54 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,4 +1,4 @@ -## rtables 0.6.6.9008 +## rtables 0.6.6.9009 ### New Features * Added `top_level_section_div` for `basic_table` to set section dividers for top level rows. * Added `keep_label_rows` to `as_result_df` to have these lines visible. From 0db02995dd05c58b096897ce16dfd835d550ecdf Mon Sep 17 00:00:00 2001 From: Gabe Becker Date: Fri, 23 Feb 2024 00:16:17 -0800 Subject: [PATCH 3/4] fix sort behavior for root, add useful error, docs and tests (#817) * fix sort behavior for root, add useful error, docs and tests * roxygen rerun with 7.2.0 * redocument with roxygen2 7.3.1 --------- Signed-off-by: Davide Garolini Co-authored-by: Davide Garolini Co-authored-by: Emily de la Rua --- NEWS.md | 2 ++ R/tt_sort.R | 44 +++++++++++++++++++++++++++++--- man/sort_at_path.Rd | 26 +++++++++++++++++-- tests/testthat/test-sort-prune.R | 23 +++++++++++++++++ 4 files changed, 90 insertions(+), 5 deletions(-) diff --git a/NEWS.md b/NEWS.md index 76d3baf54..e72700416 100644 --- a/NEWS.md +++ b/NEWS.md @@ -2,11 +2,13 @@ ### New Features * Added `top_level_section_div` for `basic_table` to set section dividers for top level rows. * Added `keep_label_rows` to `as_result_df` to have these lines visible. + * `sort_at_path` now gives informative error messages when the given path does not exist. ### Bug Fixes * Fixed `rlistings` decoration (e.g. titles and footers) expansion when there are new lines. Moved relevant handling from `rtables`' `matrix_form` function to `formatters`' dedicated `mform_handle_newlines` function. * Fixed issue with `rtables_root` not being removed when using `as_result_df`. * Fixed edge case bug in `as_result_df` where rows of the table have only `"root"` as path index. + * Fixed `sort_at_path` pathing to ignore leading `"root"` element (regardless of actual root element name) to match current `tt_at_path` behavior. ## rtables 0.6.6 ### New Features diff --git a/R/tt_sort.R b/R/tt_sort.R index 7ffa3461f..6e762283f 100644 --- a/R/tt_sort.R +++ b/R/tt_sort.R @@ -66,12 +66,34 @@ cont_n_onecol <- function(j) { #' @return A `TableTree` with the same structure as \code{tt} with the exception #' that the requested sorting has been done at \code{path}. #' -#' @details The \code{path} here can include the "wildcard" \code{"*"} as a step, +#' @details +#' +#' `sort_at_path`, given a path, locates the (sub)table(s) described +#' by the path (see below for handling of the `"*"` wildcard). For +#' each such subtable, it then calls `scorefun` on each direct +#' child of the table, using the resulting scores to determine +#' their sorted order. `tt` is then modified to reflect each of +#' these one or more sorting operations. +#' +#' In `path`, a leading `"root"` element will be ignored, regardless +#' of whether this matches the object name (and thus actual root +#' path name) of `tt`. Including `"root"` in paths where it does not +#' match the name of `tt` may mask deeper misunderstandings of how +#' valid paths within a `TableTree` object correspond to the layout +#' used to originally declare it, which we encourage users to +#' avoid. +#' +#' `path` can include the "wildcard" \code{"*"} as a step, #' which translates roughly to *any* node/branching element and means #' that each child at that step will be \emph{separately} sorted based on #' \code{scorefun} and the remaining \code{path} entries. This can occur #' multiple times in a path. #' +#' A list of valid (non-wildcard) paths can be seen in the `path` column +#' of the data.frame created by [make_row_df()] with the `visible_only` +#' argument set to `FALSE`. It can also be inferred from the summary +#' given by [table_structure()]. +#' #' Note that sorting needs a deeper understanding of table structure in #' `rtables`. Please consider reading related vignette #' ([Sorting and Pruning](https://insightsengineering.github.io/rtables/main/articles/sorting_pruning.html)) @@ -98,7 +120,9 @@ cont_n_onecol <- function(j) { #' (either subtables, rows or possibly a mix thereof, though that #' should not happen in practice). #' -#' @seealso [cont_n_allcols()] and [cont_n_onecol()] +#' @seealso score functions [cont_n_allcols()] and [cont_n_onecol()]; +#' [make_row_df()] and [table_structure()] for pathing information; +#' [tt_at_path()] to select a table's (sub)structure at a given path. #' #' @examples #' # Creating a table to sort @@ -156,7 +180,16 @@ sort_at_path <- function(tt, } ## XXX hacky fix this!!! + ## tt_at_path removes root even if actual root table isn't named root, we need to match that behavior + if(path[1] == "root") { + ## always remove first root element but only add it to + ## .prev_path (used for error reporting) if it actually matched the name + if(obj_name(tt) == "root") + .prev_path <- c(.prev_path, path[1]) + path <- path[-1] + } if (identical(obj_name(tt), path[1])) { + .prev_path <- c(.prev_path, path[1]) path <- path[-1] } @@ -166,10 +199,10 @@ sort_at_path <- function(tt, count <- 0 while (length(curpath) > 0) { curname <- curpath[1] + oldkids <- tree_children(subtree) ## we sort each child separately based on the score function ## and the remaining path if (curname == "*") { - oldkids <- tree_children(subtree) oldnames <- vapply(oldkids, obj_name, "") newkids <- lapply( seq_along(oldkids), @@ -194,6 +227,11 @@ sort_at_path <- function(tt, ret <- newtab } return(ret) + } else if(!(curname %in% names(oldkids))) { + stop("Unable to find child(ren) '", + curname, "'\n\t occurred at path: ", + paste(c(.prev_path, path[seq_len(count)]), collapse = " -> "), + "\n Use 'make_row_df(obj, visible_only = TRUE)[, c(\"label\", \"path\", \"node_class\")]' or\n\ 'table_structure(obj)' to explore valid paths.") } subtree <- tree_children(subtree)[[curname]] backpath <- c(backpath, curpath[1]) diff --git a/man/sort_at_path.Rd b/man/sort_at_path.Rd index 47eb5150b..519cf238d 100644 --- a/man/sort_at_path.Rd +++ b/man/sort_at_path.Rd @@ -47,12 +47,32 @@ Main sorting function to order the substructure of a \code{TableTree} at a particular Path in the table tree. } \details{ -The \code{path} here can include the "wildcard" \code{"*"} as a step, +\code{sort_at_path}, given a path, locates the (sub)table(s) described +by the path (see below for handling of the \code{"*"} wildcard). For +each such subtable, it then calls \code{scorefun} on each direct +child of the table, using the resulting scores to determine +their sorted order. \code{tt} is then modified to reflect each of +these one or more sorting operations. + +In \code{path}, a leading \code{"root"} element will be ignored, regardless +of whether this matches the object name (and thus actual root +path name) of \code{tt}. Including \code{"root"} in paths where it does not +match the name of \code{tt} may mask deeper misunderstandings of how +valid paths within a \code{TableTree} object correspond to the layout +used to originally declare it, which we encourage users to +avoid. + +\code{path} can include the "wildcard" \code{"*"} as a step, which translates roughly to \emph{any} node/branching element and means that each child at that step will be \emph{separately} sorted based on \code{scorefun} and the remaining \code{path} entries. This can occur multiple times in a path. +A list of valid (non-wildcard) paths can be seen in the \code{path} column +of the data.frame created by \code{\link[=make_row_df]{make_row_df()}} with the \code{visible_only} +argument set to \code{FALSE}. It can also be inferred from the summary +given by \code{\link[=table_structure]{table_structure()}}. + Note that sorting needs a deeper understanding of table structure in \code{rtables}. Please consider reading related vignette (\href{https://insightsengineering.github.io/rtables/main/articles/sorting_pruning.html}{Sorting and Pruning}) @@ -127,5 +147,7 @@ sort_at_path(tbl, c("RACE", "*", "STRATA1", "*", "AGE"), scorefun) } \seealso{ -\code{\link[=cont_n_allcols]{cont_n_allcols()}} and \code{\link[=cont_n_onecol]{cont_n_onecol()}} +score functions \code{\link[=cont_n_allcols]{cont_n_allcols()}} and \code{\link[=cont_n_onecol]{cont_n_onecol()}}; +\code{\link[=make_row_df]{make_row_df()}} and \code{\link[=table_structure]{table_structure()}} for pathing information; +\code{\link[=tt_at_path]{tt_at_path()}} to select a table's (sub)structure at a given path. } diff --git a/tests/testthat/test-sort-prune.R b/tests/testthat/test-sort-prune.R index f89c91470..5842de38a 100644 --- a/tests/testthat/test-sort-prune.R +++ b/tests/testthat/test-sort-prune.R @@ -258,6 +258,16 @@ test_that("provided score functions throw informative errors when invalid and * ) }) + ## leading "root" doesn't bother it #816 + expect_silent({ + stbl2 <- sort_at_path(raw_tbl, + path = c("root", "AEBODSYS", "*", "AEDECOD"), + scorefun = real_scorefun, # cont_n_allcols, + decreasing = TRUE + ) + }) + expect_identical(cell_values(stbl), cell_values(stbl2)) + ## spot check that things were reordered as we expect expect_identical( row_paths(raw_tbl)[63:71], ## "cl B.2" -> "dcd B.2.1.2.1" old position @@ -285,6 +295,19 @@ test_that("provided score functions throw informative errors when invalid and * "occurred at path: AEBODSYS -> * (cl A.1) -> AEDECOD -> dcd A.1.1.1.1", fixed = TRUE ) + ## paths that are entirely wrong (don't exist at all) work out ok. + expect_error( + { + sort_at_path(raw_tbl, + path = c("AEBODSYS", "*", "WRONG"), + scorefun = cont_n_onecol(1), + decreasing = TRUE + ) + }, + "occurred at path: AEBODSYS -> * (cl A.1)", + fixed = TRUE + ) + }) test_that("paths come out correct when sorting with '*'", { From edcfb82d9d2de752d68f54301a9daeca1727f706 Mon Sep 17 00:00:00 2001 From: Melkiades Date: Fri, 23 Feb 2024 08:17:36 +0000 Subject: [PATCH 4/4] [skip actions] Bump version to 0.6.6.9010 --- DESCRIPTION | 4 ++-- NEWS.md | 2 +- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 7e2952622..39b4a9714 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,7 +1,7 @@ Package: rtables Title: Reporting Tables -Version: 0.6.6.9009 -Date: 2024-02-22 +Version: 0.6.6.9010 +Date: 2024-02-23 Authors@R: c( person("Gabriel", "Becker", , "gabembecker@gmail.com", role = "aut", comment = "Original creator of the package"), diff --git a/NEWS.md b/NEWS.md index e72700416..40ed6b76d 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,4 +1,4 @@ -## rtables 0.6.6.9009 +## rtables 0.6.6.9010 ### New Features * Added `top_level_section_div` for `basic_table` to set section dividers for top level rows. * Added `keep_label_rows` to `as_result_df` to have these lines visible.