diff --git a/NEWS.md b/NEWS.md index 71e701ee5..4f59a6de7 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 df1727fe3..c79ba4f3a 100644 --- a/R/tt_as_df.R +++ b/R/tt_as_df.R @@ -99,7 +99,12 @@ 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( @@ -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[!nzchar(stat_name)] <- 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,19 @@ 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 - if (pthlen %% 2 == 1) { - pth <- pth[-1 * (pthlen - 2)] + ## odd means we have a multi-analsysis step in the path, we do not want this in the result + 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 + if (pthlen_new == 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..bbc0a641d 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" ) @@ -239,6 +240,16 @@ test_that("as_result_df works fine with empty tables and no character(0) is allo ) }) +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") %>% + 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")) @@ -290,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)", @@ -305,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",