Merge branch 'main' into 785_colsubsetexpr_refactor

DESCRIPTION

@@ -1,7 +1,7 @@
 Package: rtables
 Title: Reporting Tables
-Version: 0.6.6.9008
-Date: 2024-02-21
+Version: 0.6.6.9010
+Date: 2024-02-23
 Authors@R: c(
     person("Gabriel", "Becker", , "[email protected]", role = "aut",
            comment = "Original creator of the package"),

NEWS.md

@@ -1,11 +1,14 @@
-## rtables 0.6.6.9008
+## 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.
+ * `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

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
 }
 

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

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"
+  )
+})

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 '*'", {