From 571904a602e81b4f7a9ac10ab0f431841a7a9111 Mon Sep 17 00:00:00 2001 From: Melkiades Date: Tue, 23 Jan 2024 14:27:32 +0100 Subject: [PATCH 1/7] main fix --- R/tt_export.R | 54 +++++++++++++++++++++++++++++++++++++-------------- 1 file changed, 39 insertions(+), 15 deletions(-) diff --git a/R/tt_export.R b/R/tt_export.R index 16216fbfe..93bc9d3e9 100644 --- a/R/tt_export.R +++ b/R/tt_export.R @@ -195,6 +195,7 @@ result_df_v0_experimental <- function(tt, raw_cvals <- list(raw_cvals) } + # Flatten the list of lists (rows) of cell values into a data frame cellvals <- as.data.frame(do.call(rbind, raw_cvals)) row.names(cellvals) <- NULL @@ -237,7 +238,14 @@ result_df_v0_experimental <- function(tt, cellvals ) + # Removing initial root elements from path (out of the loop -> right maxlen) + df$path <- lapply(df$path, .remove_root_elems_from_path, + which_root_name = c("root", "rbind_root"), + all = TRUE + ) maxlen <- max(lengths(df$path)) + + # Loop for metadata (path and details from make_row_df) metadf <- do.call( rbind.data.frame, lapply( @@ -308,16 +316,8 @@ result_df_v0_experimental <- function(tt, as.numeric ) }) - - do.call(cbind, ret) -} -do_label_row <- function(rdfrow, maxlen) { - pth <- rdfrow$path[[1]] - c( - as.list(pth), replicate(maxlen - length(pth), list(NA_character_)), - list(row_num = rdfrow$abs_rownumber, content = FALSE, node_class = rdfrow$node_class) - ) + do.call(cbind, ret) } make_result_df_md_colnames <- function(maxlen) { @@ -329,9 +329,16 @@ make_result_df_md_colnames <- function(maxlen) { ret <- c(ret, c("avar_name", "row_name", "row_num", "is_group_summary", "node_class")) } -do_content_row <- function(rdfrow, maxlen) { +do_label_row <- function(rdfrow, maxlen) { pth <- rdfrow$path[[1]] + c( + as.list(pth), replicate(maxlen - length(pth), list(NA_character_)), + list(row_num = rdfrow$abs_rownumber, content = FALSE, node_class = rdfrow$node_class) + ) +} +do_content_row <- function(rdfrow, maxlen) { + pth <- rdfrow$path[[1]] contpos <- which(pth == "@content") seq_before <- seq_len(contpos - 1) @@ -351,7 +358,7 @@ do_data_row <- function(rdfrow, maxlen) { pth <- pth[-1 * (pthlen - 2)] } pthlen_new <- length(pth) - if (maxlen == 1) pthlen_new <- 3 + if (maxlen == 1) pthlen_new <- 3 c( as.list(pth[seq_len(pthlen_new - 2)]), replicate(maxlen - pthlen, list(NA_character_)), @@ -360,12 +367,29 @@ 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") + 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")) + if (any(diff(root_indices) > 1)) { # integer(0) for diff means FALSE + end_point_root_headers <- which(diff(root_indices) > 1)[1] + } else { + end_point_root_headers <- length(root_indices) + } + root_path_to_remove <- seq_len(end_point_root_headers) + } else { + root_path_to_remove <- 1 + } + path <- path[-root_path_to_remove] + } + path +} + handle_rdf_row <- function(rdfrow, maxlen) { nclass <- rdfrow$node_class - if (rdfrow$path[[1]][1] == "root") { - rdfrow$path[[1]] <- rdfrow$path[[1]][-1] - maxlen <- maxlen - 1 - } + ret <- switch(nclass, LabelRow = do_label_row(rdfrow, maxlen), ContentRow = do_content_row(rdfrow, maxlen), From 1b81b106e208a298b9ff0daef5b5bd471436eeb7 Mon Sep 17 00:00:00 2001 From: Melkiades Date: Tue, 23 Jan 2024 14:28:28 +0100 Subject: [PATCH 2/7] errors and news --- NEWS.md | 1 + tests/testthat/test-result_data_frame.R | 16 ++++++++++++++++ 2 files changed, 17 insertions(+) diff --git a/NEWS.md b/NEWS.md index 0628c5199..b9eefb786 100644 --- a/NEWS.md +++ b/NEWS.md @@ -4,6 +4,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`. ## rtables 0.6.6 ### New Features diff --git a/tests/testthat/test-result_data_frame.R b/tests/testthat/test-result_data_frame.R index a67619447..b756994ff 100644 --- a/tests/testthat/test-result_data_frame.R +++ b/tests/testthat/test-result_data_frame.R @@ -129,3 +129,19 @@ test_that("as_result_df works with visual output (as_viewer)", { ) ) }) + +test_that("as_result_df works fine also with multiple rbind_root", { + # regression test for rtables#815 + lyt <- basic_table() %>% + 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")) +}) From dd9f891ad42c57a26d52595c06532dfa457e1a8f Mon Sep 17 00:00:00 2001 From: Melkiades Date: Wed, 24 Jan 2024 12:12:24 +0100 Subject: [PATCH 3/7] fix + addition of keep_label_rows --- DESCRIPTION | 2 +- R/tt_export.R | 37 +++++++++++++++---------- man/int_methods.Rd | 14 +++++----- man/rheader.Rd | 2 +- man/rtable.Rd | 4 +-- tests/testthat/test-result_data_frame.R | 26 +++++++++++++++++ 6 files changed, 59 insertions(+), 26 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 9267b8bb3..177aa5f59 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -62,7 +62,7 @@ Encoding: UTF-8 Language: en-US LazyData: true Roxygen: list(markdown = TRUE) -RoxygenNote: 7.2.3 +RoxygenNote: 7.3.1 Collate: '00tabletrees.R' 'Viewer.R' diff --git a/R/tt_export.R b/R/tt_export.R index 93bc9d3e9..ef7b76c63 100644 --- a/R/tt_export.R +++ b/R/tt_export.R @@ -93,6 +93,8 @@ formatters::export_as_txt #' column counts if `expand_colnames = TRUE`. #' - `as_viewer`: when `TRUE`, the result data frame will have all values as they appear in the final table, #' i.e. with the same precision and numbers, but in easy-to-use numeric form. +#' - `keep_label_rows`: when `TRUE`, the result data frame will have all labels as they appear in the +#' final table. #' #' @details `as_result_df()`: Result data frame specifications may differ in the exact information #' they include and the form in which they represent it. Specifications whose names end in "_experimental" @@ -182,10 +184,12 @@ lookup_result_df_specfun <- function(spec) { result_df_v0_experimental <- function(tt, as_viewer = FALSE, as_strings = FALSE, - expand_colnames = FALSE) { + expand_colnames = FALSE, + keep_label_rows = FALSE) { checkmate::assert_flag(as_viewer) checkmate::assert_flag(as_strings) checkmate::assert_flag(expand_colnames) + checkmate::assert_flag(keep_label_rows) raw_cvals <- cell_values(tt) ## if the table has one row and multiple columns, sometimes the cell values returns a list of the cell values @@ -229,15 +233,8 @@ result_df_v0_experimental <- function(tt, } rdf <- make_row_df(tt) - - df <- cbind( - rdf[ - rdf$node_class != "LabelRow", - c("name", "label", "abs_rownumber", "path", "reprint_inds", "node_class") - ], - cellvals - ) - + + df <- rdf[, c("name", "label", "abs_rownumber", "path", "reprint_inds", "node_class")] # Removing initial root elements from path (out of the loop -> right maxlen) df$path <- lapply(df$path, .remove_root_elems_from_path, which_root_name = c("root", "rbind_root"), @@ -255,11 +252,21 @@ result_df_v0_experimental <- function(tt, } ) ) - - ret <- cbind( - metadf[metadf$node_class != "LabelRow", ], - cellvals - ) + + # Should we keep label rows with NAs instead of values? + if (keep_label_rows) { + cellvals_mat_struct <- as.data.frame( + matrix(NA, nrow = nrow(rdf), ncol = ncol(cellvals)) + ) + colnames(cellvals_mat_struct) <- colnames(cellvals) + cellvals_mat_struct[metadf$node_class != "LabelRow", ] <- cellvals + ret <- cbind(metadf, cellvals_mat_struct) + } else { + ret <- cbind( + metadf[metadf$node_class != "LabelRow", ], + cellvals + ) + } # If we want to expand colnames if (expand_colnames) { diff --git a/man/int_methods.Rd b/man/int_methods.Rd index e5d1fd063..15928d246 100644 --- a/man/int_methods.Rd +++ b/man/int_methods.Rd @@ -357,7 +357,7 @@ split_rows(lyt = NULL, spl, pos, cmpnd_fun = AnalyzeMultiVars) -\S4method{split_rows}{`NULL`}(lyt = NULL, spl, pos, cmpnd_fun = AnalyzeMultiVars) +\S4method{split_rows}{NULL}(lyt = NULL, spl, pos, cmpnd_fun = AnalyzeMultiVars) \S4method{split_rows}{PreDataRowLayout}(lyt = NULL, spl, pos, cmpnd_fun = AnalyzeMultiVars) @@ -369,7 +369,7 @@ split_rows(lyt = NULL, spl, pos, cmpnd_fun = AnalyzeMultiVars) cmpnd_last_rowsplit(lyt, spl, constructor) -\S4method{cmpnd_last_rowsplit}{`NULL`}(lyt, spl, constructor) +\S4method{cmpnd_last_rowsplit}{NULL}(lyt, spl, constructor) \S4method{cmpnd_last_rowsplit}{PreDataRowLayout}(lyt, spl, constructor) @@ -381,7 +381,7 @@ cmpnd_last_rowsplit(lyt, spl, constructor) split_cols(lyt = NULL, spl, pos) -\S4method{split_cols}{`NULL`}(lyt = NULL, spl, pos) +\S4method{split_cols}{NULL}(lyt = NULL, spl, pos) \S4method{split_cols}{PreDataColLayout}(lyt = NULL, spl, pos) @@ -533,7 +533,7 @@ next_cpos(obj, nested = TRUE) last_rowsplit(obj) -\S4method{last_rowsplit}{`NULL`}(obj) +\S4method{last_rowsplit}{NULL}(obj) \S4method{last_rowsplit}{SplitVector}(obj) @@ -773,7 +773,7 @@ content_na_str(obj) <- value \S4method{collect_leaves}{VLeaf}(tt, incl.cont = TRUE, add.labrows = FALSE) -\S4method{collect_leaves}{`NULL`}(tt, incl.cont = TRUE, add.labrows = FALSE) +\S4method{collect_leaves}{NULL}(tt, incl.cont = TRUE, add.labrows = FALSE) \S4method{collect_leaves}{ANY}(tt, incl.cont = TRUE, add.labrows = FALSE) @@ -1049,7 +1049,7 @@ spl_varnames(object) <- value \S4method{fnotes_at_path}{VTableTree,character}(obj, rowpath = NULL, colpath = NULL, reset_idx = TRUE) <- value -\S4method{fnotes_at_path}{VTableTree,`NULL`}(obj, rowpath = NULL, colpath = NULL, reset_idx = TRUE) <- value +\S4method{fnotes_at_path}{VTableTree,NULL}(obj, rowpath = NULL, colpath = NULL, reset_idx = TRUE) <- value \S4method{rbind2}{VTableNodeInfo,missing}(x, y) @@ -1057,7 +1057,7 @@ spl_varnames(object) <- value \S4method{tt_at_path}{VTableTree,ANY,VTableTree}(tt, path, ...) <- value -\S4method{tt_at_path}{VTableTree,ANY,`NULL`}(tt, path, ...) <- value +\S4method{tt_at_path}{VTableTree,ANY,NULL}(tt, path, ...) <- value \S4method{tt_at_path}{VTableTree,ANY,TableRow}(tt, path, ...) <- value diff --git a/man/rheader.Rd b/man/rheader.Rd index fc7cb0d4b..c0372d1bc 100644 --- a/man/rheader.Rd +++ b/man/rheader.Rd @@ -42,8 +42,8 @@ h2 } \seealso{ Other compatibility: -\code{\link{rrowl}()}, \code{\link{rrow}()}, +\code{\link{rrowl}()}, \code{\link{rtable}()} } \concept{compatibility} diff --git a/man/rtable.Rd b/man/rtable.Rd index 5a8e402ab..531de8c72 100644 --- a/man/rtable.Rd +++ b/man/rtable.Rd @@ -124,7 +124,7 @@ tbl2 \seealso{ Other compatibility: \code{\link{rheader}()}, -\code{\link{rrowl}()}, -\code{\link{rrow}()} +\code{\link{rrow}()}, +\code{\link{rrowl}()} } \concept{compatibility} diff --git a/tests/testthat/test-result_data_frame.R b/tests/testthat/test-result_data_frame.R index b756994ff..669633382 100644 --- a/tests/testthat/test-result_data_frame.R +++ b/tests/testthat/test-result_data_frame.R @@ -145,3 +145,29 @@ test_that("as_result_df works fine also with multiple rbind_root", { expect_true(all(out[,1] == "STRATA1")) }) + +test_that("as_result_df keeps label rows", { + # regression test for rtables#815 + lyt <- basic_table() %>% + split_cols_by("ARM") %>% + 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)]), ]) +}) From 4ec17ba514af9a428cc0938ec14741af45feb6e8 Mon Sep 17 00:00:00 2001 From: Melkiades Date: Wed, 24 Jan 2024 12:13:47 +0100 Subject: [PATCH 4/7] NEWS --- NEWS.md | 1 + man/data.frame_export.Rd | 2 ++ 2 files changed, 3 insertions(+) diff --git a/NEWS.md b/NEWS.md index b9eefb786..1899ae3ec 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,6 +1,7 @@ ## rtables 0.6.6.9005 ### 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. ### 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. diff --git a/man/data.frame_export.Rd b/man/data.frame_export.Rd index 97d0011aa..7b280b1f9 100644 --- a/man/data.frame_export.Rd +++ b/man/data.frame_export.Rd @@ -34,6 +34,8 @@ in the final table (it can also be retrieved from \code{matrix_form(tt)$strings} column counts if \code{expand_colnames = TRUE}. \item \code{as_viewer}: when \code{TRUE}, the result data frame will have all values as they appear in the final table, i.e. with the same precision and numbers, but in easy-to-use numeric form. +\item \code{keep_label_rows}: when \code{TRUE}, the result data frame will have all labels as they appear in the +final table. }} \item{path_fun}{function. Function to transform paths into single-string From 16325563bc8c7ac8bffd2d741779d9b74b546b6e Mon Sep 17 00:00:00 2001 From: Melkiades Date: Wed, 24 Jan 2024 12:36:52 +0100 Subject: [PATCH 5/7] styling --- R/tt_export.R | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/R/tt_export.R b/R/tt_export.R index ef7b76c63..4005911c5 100644 --- a/R/tt_export.R +++ b/R/tt_export.R @@ -93,7 +93,7 @@ formatters::export_as_txt #' column counts if `expand_colnames = TRUE`. #' - `as_viewer`: when `TRUE`, the result data frame will have all values as they appear in the final table, #' i.e. with the same precision and numbers, but in easy-to-use numeric form. -#' - `keep_label_rows`: when `TRUE`, the result data frame will have all labels as they appear in the +#' - `keep_label_rows`: when `TRUE`, the result data frame will have all labels as they appear in the #' final table. #' #' @details `as_result_df()`: Result data frame specifications may differ in the exact information @@ -233,7 +233,7 @@ result_df_v0_experimental <- function(tt, } rdf <- make_row_df(tt) - + df <- rdf[, c("name", "label", "abs_rownumber", "path", "reprint_inds", "node_class")] # Removing initial root elements from path (out of the loop -> right maxlen) df$path <- lapply(df$path, .remove_root_elems_from_path, @@ -252,7 +252,7 @@ result_df_v0_experimental <- function(tt, } ) ) - + # Should we keep label rows with NAs instead of values? if (keep_label_rows) { cellvals_mat_struct <- as.data.frame( @@ -299,6 +299,7 @@ result_df_v0_experimental <- function(tt, } ret <- rbind(header_colnames_matrix, ret) } + rownames(ret) <- NULL ret } From c760e99bfd6a6c8e260dabcaef482b177e1a8e17 Mon Sep 17 00:00:00 2001 From: Melkiades Date: Fri, 26 Jan 2024 18:26:42 +0100 Subject: [PATCH 6/7] almost there --- R/tt_export.R | 62 +++++++++++++++++++++---- man/data.frame_export.Rd | 7 +++ tests/testthat/test-result_data_frame.R | 40 +++++++++++++++- 3 files changed, 99 insertions(+), 10 deletions(-) diff --git a/R/tt_export.R b/R/tt_export.R index 4005911c5..2265eea2a 100644 --- a/R/tt_export.R +++ b/R/tt_export.R @@ -95,11 +95,17 @@ formatters::export_as_txt #' i.e. with the same precision and numbers, but in easy-to-use numeric form. #' - `keep_label_rows`: when `TRUE`, the result data frame will have all labels as they appear in the #' final table. +#' - `as_is`: when `TRUE`, the result data frame will have all the values as they appear in the final table, +#' but without information about the row structure. Row labels will be assigned to rows so to work well +#' with [df_to_tt()]. #' #' @details `as_result_df()`: Result data frame specifications may differ in the exact information #' they include and the form in which they represent it. Specifications whose names end in "_experimental" #' are subject to change without notice, but specifications without the "_experimental" #' suffix will remain available \emph{including any bugs in their construction} indefinitely. +#' +#' @seealso [df_to_tt()] when using `as_is = TRUE` and [make_row_df()] to have a comprehensive view of the +#' hierarchical structure of the rows. #' #' @examples #' lyt <- basic_table() %>% @@ -185,11 +191,18 @@ result_df_v0_experimental <- function(tt, as_viewer = FALSE, as_strings = FALSE, expand_colnames = FALSE, - keep_label_rows = FALSE) { + keep_label_rows = FALSE, + as_is = FALSE) { checkmate::assert_flag(as_viewer) checkmate::assert_flag(as_strings) checkmate::assert_flag(expand_colnames) checkmate::assert_flag(keep_label_rows) + checkmate::assert_flag(as_is) + + if (as_is) { + keep_label_rows <- TRUE + expand_colnames <- FALSE + } raw_cvals <- cell_values(tt) ## if the table has one row and multiple columns, sometimes the cell values returns a list of the cell values @@ -299,7 +312,14 @@ result_df_v0_experimental <- function(tt, } ret <- rbind(header_colnames_matrix, ret) } - rownames(ret) <- NULL + + # Using only labels for row names and losing information about paths + if (as_is) { + rownames(ret) <- ret$label_name + ret <- ret[, -seq_len(which(colnames(ret) == "node_class"))] + } else { + rownames(ret) <- NULL + } ret } @@ -334,14 +354,29 @@ make_result_df_md_colnames <- function(maxlen) { if (spllen > 0) { ret <- paste(c("spl_var", "spl_value"), rep(seq_len(spllen), rep(2, spllen)), sep = "_") } - ret <- c(ret, c("avar_name", "row_name", "row_num", "is_group_summary", "node_class")) + ret <- c(ret, c("avar_name", "row_name", "label_name", "row_num", "is_group_summary", "node_class")) } do_label_row <- function(rdfrow, maxlen) { pth <- rdfrow$path[[1]] + # Adjusting for the fact that we have two columns for each split + extra_nas_from_splits <- floor((maxlen - length(pth)) / 2) * 2 + + # Special cases with hidden labels + if (length(pth) %% 2 == 1) { + extra_nas_from_splits <- extra_nas_from_splits + 1 + } + c( - as.list(pth), replicate(maxlen - length(pth), list(NA_character_)), - list(row_num = rdfrow$abs_rownumber, content = FALSE, node_class = rdfrow$node_class) + as.list(pth[seq_len(length(pth) - 1)]), + as.list(replicate(extra_nas_from_splits, list(NA_character_))), + as.list(tail(pth, 1)), + list( + label_name = rdfrow$label, + row_num = rdfrow$abs_rownumber, + content = FALSE, + node_class = rdfrow$node_class + ) ) } @@ -352,9 +387,15 @@ do_content_row <- function(rdfrow, maxlen) { seq_before <- seq_len(contpos - 1) c( - as.list(pth[seq_before]), replicate(maxlen - contpos, list(NA_character_)), + as.list(pth[seq_before]), + as.list(replicate(maxlen - contpos, list(NA_character_))), list(tail(pth, 1)), - list(row_num = rdfrow$abs_rownumber, content = TRUE, node_class = rdfrow$node_class) + list( + label_name = rdfrow$label, + row_num = rdfrow$abs_rownumber, + content = TRUE, + node_class = rdfrow$node_class + ) ) } @@ -371,7 +412,12 @@ do_data_row <- function(rdfrow, maxlen) { as.list(pth[seq_len(pthlen_new - 2)]), replicate(maxlen - pthlen, list(NA_character_)), as.list(tail(pth, 2)), - list(row_num = rdfrow$abs_rownumber, content = FALSE, node_class = rdfrow$node_class) + list( + label_name = rdfrow$label, + row_num = rdfrow$abs_rownumber, + content = FALSE, + node_class = rdfrow$node_class + ) ) } diff --git a/man/data.frame_export.Rd b/man/data.frame_export.Rd index 7b280b1f9..45060c175 100644 --- a/man/data.frame_export.Rd +++ b/man/data.frame_export.Rd @@ -36,6 +36,9 @@ column counts if \code{expand_colnames = TRUE}. i.e. with the same precision and numbers, but in easy-to-use numeric form. \item \code{keep_label_rows}: when \code{TRUE}, the result data frame will have all labels as they appear in the final table. +\item \code{as_is}: when \code{TRUE}, the result data frame will have all the values as they appear in the final table, +but without information about the row structure. Row labels will be assigned to rows so to work well +with \code{\link[=df_to_tt]{df_to_tt()}}. }} \item{path_fun}{function. Function to transform paths into single-string @@ -88,3 +91,7 @@ tbl <- build_table(lyt, ex_adsl) path_enriched_df(tbl) } +\seealso{ +\code{\link[=df_to_tt]{df_to_tt()}} when using \code{as_is = TRUE} and \code{\link[=make_row_df]{make_row_df()}} to have a comprehensive view of the +hierarchical structure of the rows. +} diff --git a/tests/testthat/test-result_data_frame.R b/tests/testthat/test-result_data_frame.R index 669633382..34188413d 100644 --- a/tests/testthat/test-result_data_frame.R +++ b/tests/testthat/test-result_data_frame.R @@ -61,7 +61,7 @@ test_that("Result Data Frame generation works v0", { expect_identical( names(result_df4), c( - "avar_name", "row_name", "row_num", "is_group_summary", + "avar_name", "row_name", "label_name", "row_num", "is_group_summary", "node_class", "A: Drug X", "B: Placebo", "C: Combination" ) ) @@ -119,10 +119,11 @@ test_that("as_result_df works with visual output (as_viewer)", { rrow("row 1", 1, c(.8, 1.2)) ) expect_equal( - as_result_df(tbl)[, 1:5], + 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, "node_class" = "DataRow" @@ -170,4 +171,39 @@ test_that("as_result_df keeps label rows", { 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( + ard_out$row_name, + sapply(pths, tail, 1) + ) +}) + +test_that("as_result_df as_is is producing a data.frame that is compatible with df_to_tt", { + # 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] + # ) }) From 8e2740898ac0cd778ee8e71f7d4cb2699694054d Mon Sep 17 00:00:00 2001 From: Melkiades Date: Mon, 29 Jan 2024 16:01:43 +0100 Subject: [PATCH 7/7] fantastic as_is --- R/tt_export.R | 8 ++++++- R/tt_from_df.R | 30 ++++++++++++++++++++----- man/df_to_tt.Rd | 11 ++++++++- tests/testthat/test-result_data_frame.R | 25 ++++++++++++++++----- 4 files changed, 60 insertions(+), 14 deletions(-) diff --git a/R/tt_export.R b/R/tt_export.R index 2265eea2a..1b8aaae1f 100644 --- a/R/tt_export.R +++ b/R/tt_export.R @@ -315,8 +315,14 @@ result_df_v0_experimental <- function(tt, # Using only labels for row names and losing information about paths if (as_is) { - rownames(ret) <- ret$label_name + tmp_rownames <- ret$label_name ret <- ret[, -seq_len(which(colnames(ret) == "node_class"))] + if (length(unique(tmp_rownames)) == length(tmp_rownames)) { + rownames(ret) <- tmp_rownames + } else { + ret <- cbind("label_name" = tmp_rownames, ret) + rownames(ret) <- NULL + } } else { rownames(ret) <- NULL } diff --git a/R/tt_from_df.R b/R/tt_from_df.R index 111255c7a..8cee6cc3b 100644 --- a/R/tt_from_df.R +++ b/R/tt_from_df.R @@ -1,23 +1,41 @@ #' Create `ElementaryTable` from data.frame -#' +#' #' @param df data.frame. -#' +#' #' @return an \code{ElementaryTable} object with unnested columns corresponding to -#' \code{names(df)} and row labels corresponding to \code{row.names(df)} -#' +#' \code{names(df)} and row labels corresponding to \code{row.names(df)}. +#' +#' @details +#' If row names are not defined in `df` (or they are simple numbers), then the +#' row names are taken from the column `label_name`, if exists. If `label_name` exists, +#' then it is also removed from the original data. Remember that this behavior is +#' compatible with [as_result_df()], when `as_is = TRUE` and the row names are not unique. +#' +#' @seealso [as_result_df()] for the inverse operation. +#' #' @examples #' df_to_tt(mtcars) -#' +#' #' @export df_to_tt <- function(df) { colnms <- colnames(df) cinfo <- manual_cols(colnms) rnames <- rownames(df) havern <- !is.null(rnames) + + if ((!havern || all(grepl("[0-9]+", rnames))) && + "label_name" %in% colnms) { + rnames <- df$label_name + df <- df[, -match("label_name", colnms)] + colnms <- colnames(df) + cinfo <- manual_cols(colnms) + havern <- TRUE + } + kids <- lapply(seq_len(nrow(df)), function(i) { rni <- if (havern) rnames[i] else "" do.call(rrow, c(list(row.name = rni), unclass(df[i, ]))) }) - + ElementaryTable(kids = kids, cinfo = cinfo) } diff --git a/man/df_to_tt.Rd b/man/df_to_tt.Rd index 6911d128c..a2f7518c7 100644 --- a/man/df_to_tt.Rd +++ b/man/df_to_tt.Rd @@ -11,12 +11,21 @@ df_to_tt(df) } \value{ an \code{ElementaryTable} object with unnested columns corresponding to -\code{names(df)} and row labels corresponding to \code{row.names(df)} +\code{names(df)} and row labels corresponding to \code{row.names(df)}. } \description{ Create \code{ElementaryTable} from data.frame } +\details{ +If row names are not defined in \code{df} (or they are simple numbers), then the +row names are taken from the column \code{label_name}, if exists. If \code{label_name} exists, +then it is also removed from the original data. Remember that this behavior is +compatible with \code{\link[=as_result_df]{as_result_df()}}, when \code{as_is = TRUE} and the row names are not unique. +} \examples{ df_to_tt(mtcars) } +\seealso{ +\code{\link[=as_result_df]{as_result_df()}} for the inverse operation. +} diff --git a/tests/testthat/test-result_data_frame.R b/tests/testthat/test-result_data_frame.R index 34188413d..0944331ab 100644 --- a/tests/testthat/test-result_data_frame.R +++ b/tests/testthat/test-result_data_frame.R @@ -198,12 +198,25 @@ test_that("as_result_df as_is is producing a data.frame that is compatible with lyt <- make_big_lyt() tbl <- build_table(lyt, rawdat) - # ard_out <- as_result_df(tbl, as_is = TRUE) - # mf_tbl <- matrix_form(tbl) + 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, + 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() + + expect_equal( + matrix_form(init_tbl)$strings, + matrix_form(end_tbl)$strings + ) })