From 137b19bbb8da5d5ebc132dde91a671be8249aef0 Mon Sep 17 00:00:00 2001 From: Melkiades Date: Tue, 3 Dec 2024 18:09:42 +0100 Subject: [PATCH 1/5] fixes --- R/tt_as_df.R | 33 ++++++++++++++++++++----- tests/testthat/test-result_data_frame.R | 10 ++++++++ 2 files changed, 37 insertions(+), 6 deletions(-) diff --git a/R/tt_as_df.R b/R/tt_as_df.R index df1727fe3..214d10ec3 100644 --- a/R/tt_as_df.R +++ b/R/tt_as_df.R @@ -99,8 +99,13 @@ as_result_df <- function(tt, spec = NULL, which_root_name = c("root", "rbind_root"), all = TRUE ) + + # Correcting maxlen for even number of paths (only multianalysis diff table names) maxlen <- max(lengths(df$path)) - + if (maxlen %% 2 != 0) { + maxlen <- maxlen + 1 + } + # Loop for metadata (path and details from make_row_df) metadf <- do.call( rbind.data.frame, @@ -174,6 +179,7 @@ as_result_df <- function(tt, spec = NULL, ret <- rbind(header_colnames_matrix, ret) } + # make_ard ----------------------------------------------------------------- # ARD part for one stat per row if (make_ard) { cinfo_df <- col_info(tt) @@ -238,11 +244,13 @@ as_result_df <- function(tt, spec = NULL, stat_name <- setNames(cell_stat_names[, col_i - min(only_col_indexes) + 1, drop = TRUE], NULL) stat <- setNames(ret_tmp[!col_label_rows, col_i, drop = TRUE], NULL) necessary_stat_lengths <- sapply(stat, length) + stat[sapply(stat, is.null)] <- NA # Truncating or adding NA if stat names has more or less elements than stats stat_name <- lapply(seq_along(stat_name), function(sn_i) { stat_name[[sn_i]][seq_len(necessary_stat_lengths[sn_i])] }) + stat_name[sapply(stat_name, function(x) length(x) == 0)] <- NA # unnesting stat_name and stat tmp_ret_by_col_i <- NULL @@ -322,7 +330,15 @@ as_result_df <- function(tt, spec = NULL, kids <- tree_children(ci_coltree) return(lapply(kids, .get_column_split_name)) } - sapply(pos_splits(tree_pos(ci_coltree)), spl_payload) + + lapply(pos_splits(tree_pos(ci_coltree)), function(x) { + pl <- spl_payload(x) + if (!is.null(pl)) { # it is null when all obs (1 column) + return(pl) + } else { + return(x@name) + } + }) } # Function that selects specific outputs from the result data frame @@ -378,6 +394,9 @@ do_label_row <- function(rdfrow, maxlen) { # Special cases with hidden labels if (length(pth) %% 2 == 1) { extra_nas_from_splits <- extra_nas_from_splits + 1 + } else { + pth <- c("", pth) + extra_nas_from_splits <- extra_nas_from_splits - 1 } c( @@ -415,15 +434,17 @@ do_content_row <- function(rdfrow, maxlen) { do_data_row <- function(rdfrow, maxlen) { pth <- rdfrow$path[[1]] pthlen <- length(pth) - ## odd means we have a multi-analsysis step in the path, we dont' want that in the result data frame + ## odd means we have a multi-analsysis step in the path, we do not want this in the result if (pthlen %% 2 == 1) { - pth <- pth[-1 * (pthlen - 2)] + # we remove the last element, as it is a fake split (tbl_name from analyse) + # pth <- pth[-1 * (pthlen - 2)] + pth <- c("", pth) } pthlen_new <- length(pth) - if (maxlen == 1) pthlen_new <- 3 + if (maxlen == 1) pthlen_new <- 3 # why? c( as.list(pth[seq_len(pthlen_new - 2)]), - replicate(maxlen - pthlen, list(NA_character_)), + replicate(ifelse((maxlen - pthlen_new) > 0, maxlen - pthlen_new, 0), list(NA_character_)), as.list(tail(pth, 2)), list( label_name = rdfrow$label, diff --git a/tests/testthat/test-result_data_frame.R b/tests/testthat/test-result_data_frame.R index 01889620d..5c23c7db3 100644 --- a/tests/testthat/test-result_data_frame.R +++ b/tests/testthat/test-result_data_frame.R @@ -239,6 +239,16 @@ test_that("as_result_df works fine with empty tables and no character(0) is allo ) }) +test_that("as_result_df works with only analyze tables (odd num of path elements)", { + tbl <- basic_table() %>% + analyze("cyl", table_names = "a") %>% + analyze("mpg") %>% + build_table(mtcars) + + expect_equal(as_result_df(tbl)$group1[[1]], "") + expect_equal(as_result_df(tbl, make_ard = TRUE)$group1[[1]], "") +}) + test_that("make_ard produces realistic ARD output with as_result_df", { # Testing fundamental getters/setters rc <- rcell(c(1, 2), stat_names = c("Rand1", "Rand2")) From 7187c7ebb8679cc104ccb62fa91bbced9c30c38f Mon Sep 17 00:00:00 2001 From: github-actions <41898282+github-actions[bot]@users.noreply.github.com> Date: Wed, 4 Dec 2024 09:48:31 +0000 Subject: [PATCH 2/5] [skip style] [skip vbump] Restyle files --- R/tt_as_df.R | 8 ++++---- tests/testthat/test-result_data_frame.R | 6 +++--- 2 files changed, 7 insertions(+), 7 deletions(-) diff --git a/R/tt_as_df.R b/R/tt_as_df.R index 214d10ec3..fcbb235a1 100644 --- a/R/tt_as_df.R +++ b/R/tt_as_df.R @@ -99,13 +99,13 @@ as_result_df <- function(tt, spec = NULL, which_root_name = c("root", "rbind_root"), all = TRUE ) - - # Correcting maxlen for even number of paths (only multianalysis diff table names) + + # Correcting maxlen for even number of paths (only multianalysis diff table names) maxlen <- max(lengths(df$path)) if (maxlen %% 2 != 0) { maxlen <- maxlen + 1 } - + # Loop for metadata (path and details from make_row_df) metadf <- do.call( rbind.data.frame, @@ -330,7 +330,7 @@ as_result_df <- function(tt, spec = NULL, kids <- tree_children(ci_coltree) return(lapply(kids, .get_column_split_name)) } - + lapply(pos_splits(tree_pos(ci_coltree)), function(x) { pl <- spl_payload(x) if (!is.null(pl)) { # it is null when all obs (1 column) diff --git a/tests/testthat/test-result_data_frame.R b/tests/testthat/test-result_data_frame.R index 5c23c7db3..cf4177a60 100644 --- a/tests/testthat/test-result_data_frame.R +++ b/tests/testthat/test-result_data_frame.R @@ -241,10 +241,10 @@ test_that("as_result_df works fine with empty tables and no character(0) is allo test_that("as_result_df works with only analyze tables (odd num of path elements)", { tbl <- basic_table() %>% - analyze("cyl", table_names = "a") %>% - analyze("mpg") %>% + analyze("cyl", table_names = "a") %>% + analyze("mpg") %>% build_table(mtcars) - + expect_equal(as_result_df(tbl)$group1[[1]], "") expect_equal(as_result_df(tbl, make_ard = TRUE)$group1[[1]], "") }) From d1317bf7f4a0005d7d883a4bc5925123b27329b3 Mon Sep 17 00:00:00 2001 From: Davide Garolini Date: Thu, 5 Dec 2024 09:34:43 +0100 Subject: [PATCH 3/5] Update R/tt_as_df.R Co-authored-by: Emily de la Rua <59304861+edelarua@users.noreply.github.com> Signed-off-by: Davide Garolini --- R/tt_as_df.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/tt_as_df.R b/R/tt_as_df.R index fcbb235a1..3a29fe99a 100644 --- a/R/tt_as_df.R +++ b/R/tt_as_df.R @@ -250,7 +250,7 @@ as_result_df <- function(tt, spec = NULL, stat_name <- lapply(seq_along(stat_name), function(sn_i) { stat_name[[sn_i]][seq_len(necessary_stat_lengths[sn_i])] }) - stat_name[sapply(stat_name, function(x) length(x) == 0)] <- NA + stat_name[!nzchar(stat_name)] <- NA # unnesting stat_name and stat tmp_ret_by_col_i <- NULL From 4ce30a9cd97b8629dc4568c1b3f4a08d18bc972d Mon Sep 17 00:00:00 2001 From: Davide Garolini Date: Thu, 5 Dec 2024 09:34:54 +0100 Subject: [PATCH 4/5] Update tests/testthat/test-result_data_frame.R Co-authored-by: Emily de la Rua <59304861+edelarua@users.noreply.github.com> Signed-off-by: Davide Garolini --- tests/testthat/test-result_data_frame.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tests/testthat/test-result_data_frame.R b/tests/testthat/test-result_data_frame.R index cf4177a60..1a4b53c90 100644 --- a/tests/testthat/test-result_data_frame.R +++ b/tests/testthat/test-result_data_frame.R @@ -239,7 +239,7 @@ test_that("as_result_df works fine with empty tables and no character(0) is allo ) }) -test_that("as_result_df works with only analyze tables (odd num of path elements)", { +test_that("as_result_df works with analyze-only tables (odd num of path elements)", { tbl <- basic_table() %>% analyze("cyl", table_names = "a") %>% analyze("mpg") %>% From 9e2115f40e61dec5e97b40a3a23f194afff0cdd8 Mon Sep 17 00:00:00 2001 From: Melkiades Date: Fri, 6 Dec 2024 09:25:15 +0100 Subject: [PATCH 5/5] fixes --- NEWS.md | 1 + R/tt_as_df.R | 6 ++++-- tests/testthat/test-result_data_frame.R | 13 +++++++++---- 3 files changed, 14 insertions(+), 6 deletions(-) diff --git a/NEWS.md b/NEWS.md index 4eb5514c4..fb462942b 100644 --- a/NEWS.md +++ b/NEWS.md @@ -18,6 +18,7 @@ * Fixed bug that was keeping indentation space characters in top left information when making a `flextable` from a `TableTree` object. * Fixed bug in `analyze` that was causing an error when passing a single `NA` value to the `var_labels` parameter. + * Fixed bugs for multiple `analyze` calls in `as_result_df`. ## rtables 0.6.10 diff --git a/R/tt_as_df.R b/R/tt_as_df.R index fcbb235a1..3cd69c5e3 100644 --- a/R/tt_as_df.R +++ b/R/tt_as_df.R @@ -435,13 +435,15 @@ do_data_row <- function(rdfrow, maxlen) { pth <- rdfrow$path[[1]] pthlen <- length(pth) ## odd means we have a multi-analsysis step in the path, we do not want this in the result - if (pthlen %% 2 == 1) { + if (pthlen %% 2 == 1 && pthlen > 1) { # we remove the last element, as it is a fake split (tbl_name from analyse) # pth <- pth[-1 * (pthlen - 2)] pth <- c("", pth) } pthlen_new <- length(pth) - if (maxlen == 1) pthlen_new <- 3 # why? + if (pthlen_new == 1) { + pthlen_new <- 3 # why? + } c( as.list(pth[seq_len(pthlen_new - 2)]), replicate(ifelse((maxlen - pthlen_new) > 0, maxlen - pthlen_new, 0), list(NA_character_)), diff --git a/tests/testthat/test-result_data_frame.R b/tests/testthat/test-result_data_frame.R index cf4177a60..4eb09ce6f 100644 --- a/tests/testthat/test-result_data_frame.R +++ b/tests/testthat/test-result_data_frame.R @@ -59,6 +59,7 @@ test_that("Result Data Frame generation works v0", { expect_identical( names(result_df4), c( + "group1", "group1_level", "avar_name", "row_name", "label_name", "row_num", "is_group_summary", "node_class", "A: Drug X", "B: Placebo", "C: Combination" ) @@ -300,8 +301,10 @@ test_that("make_ard produces realistic ARD output with as_result_df", { expect_equal( ard_out[2, , drop = TRUE], list( - group1 = "ARM", - group1_level = "A: Drug X", + group1 = "", + group1_level = "ma_AGE_SEX", + group2 = "ARM", + group2_level = "A: Drug X", variable = "AGE", variable_level = "Mean (SD)", variable_label = "Mean (SD)", @@ -315,8 +318,10 @@ test_that("make_ard produces realistic ARD output with as_result_df", { expect_equal( ard_out[14, , drop = TRUE], list( - group1 = "ARM", - group1_level = "B: Placebo", + group1 = "", + group1_level = "ma_AGE_SEX", + group2 = "ARM", + group2_level = "B: Placebo", variable = "SEX", variable_level = "F", variable_label = "F",