From fea3bcff4ba5500875a7b49c102a9c6856c4b2c4 Mon Sep 17 00:00:00 2001 From: Davide Garolini Date: Tue, 12 Mar 2024 09:33:49 +0100 Subject: [PATCH] Fix `section_div` in case of multiple var analyzed (`AnalyzeMultiVars`) (#836) * Fixing section div * [skip style] [skip vbump] Restyle files * other test * [skip style] [skip vbump] Restyle files * empty --------- Co-authored-by: github-actions <41898282+github-actions[bot]@users.noreply.github.com> --- NEWS.md | 1 + R/00tabletrees.R | 3 ++- R/tt_dotabulation.R | 2 ++ R/utils.R | 2 +- tests/testthat/setup-fakedata.R | 7 +++++++ tests/testthat/test-accessors.R | 6 ------ tests/testthat/test-exporters.R | 2 +- tests/testthat/test-printing.R | 28 ++++++++++++++++++++++++++++ 8 files changed, 42 insertions(+), 9 deletions(-) diff --git a/NEWS.md b/NEWS.md index 941820ea3..75553504a 100644 --- a/NEWS.md +++ b/NEWS.md @@ -9,6 +9,7 @@ * 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. + * Fixed `section_div` for analysis of multiple variables (`AnalyzeMultiVars`). ## rtables 0.6.6 ### New Features diff --git a/R/00tabletrees.R b/R/00tabletrees.R index 18419f95c..40e0ef901 100644 --- a/R/00tabletrees.R +++ b/R/00tabletrees.R @@ -814,6 +814,7 @@ AnalyzeMultiVars <- function(var, cformat <- .repoutlst(cformat, nv) ## split_format = .repoutlst(split_format, nv) inclNAs <- .repoutlst(inclNAs, nv) + section_div_if_multivar <- if (length(var) > 1) NA_character_ else section_div pld <- mapply(AnalyzeVarSplit, var = var, split_name = child_names, @@ -830,7 +831,7 @@ AnalyzeMultiVars <- function(var, label_pos = show_kidlabs, split_format = split_format, split_na_str = split_na_str, - section_div = section_div + section_div = section_div_if_multivar ), ## rvis), SIMPLIFY = FALSE ) diff --git a/R/tt_dotabulation.R b/R/tt_dotabulation.R index 06d4f9de7..cdafe5b7d 100644 --- a/R/tt_dotabulation.R +++ b/R/tt_dotabulation.R @@ -692,6 +692,8 @@ setMethod( ... )) + kids <- .set_kids_section_div(kids, spl_section_div(spl), "VTableTree") + ## XXX this seems like it should be identical not !identical ## TODO FIXME if (!identical(make_lrow, FALSE) && !have_controws && length(kids) == 1) { diff --git a/R/utils.R b/R/utils.R index 5f347ef99..0b93413a2 100644 --- a/R/utils.R +++ b/R/utils.R @@ -108,7 +108,7 @@ paste_vec <- function(vec) { # Utility for checking if a package is installed check_required_packages <- function(pkgs) { for (pkgi in pkgs) { - if (!requireNamespace(pkgi)) { + if (!requireNamespace(pkgi, quietly = TRUE)) { stop( "This function requires the ", pkgi, " package. ", "Please install it if you wish to use it" diff --git a/tests/testthat/setup-fakedata.R b/tests/testthat/setup-fakedata.R index c39215679..f22111193 100644 --- a/tests/testthat/setup-fakedata.R +++ b/tests/testthat/setup-fakedata.R @@ -223,3 +223,10 @@ tt_for_nl <- tt_to_test_newline_chars() nchar(str) - nchar(gsub(chr, "", str, fixed = TRUE)) } } + +# Utility function for section_div tests +check_pattern <- function(element, letter, len) { + # Regular expression to match exactly len of the same letter + regex <- paste0(rep(letter, len), collapse = "") + return(grepl(regex, element, fixed = TRUE)) +} diff --git a/tests/testthat/test-accessors.R b/tests/testthat/test-accessors.R index 479cf1907..1512d86b6 100644 --- a/tests/testthat/test-accessors.R +++ b/tests/testthat/test-accessors.R @@ -225,12 +225,6 @@ test_that("header sep setting works", { }) # section_div tests ------------------------------------------------------------ -check_pattern <- function(element, letter, len) { - # Regular expression to match exactly len of the same letter - regex <- paste0(rep(letter, len), collapse = "") - return(grepl(regex, element, fixed = TRUE)) -} - test_structure_with_a_getter <- function(tbl, getter, val_per_lev) { # Main table obj expect_identical(tbl %>% getter(), val_per_lev$global) diff --git a/tests/testthat/test-exporters.R b/tests/testthat/test-exporters.R index dd5f5a93f..ec10f6793 100644 --- a/tests/testthat/test-exporters.R +++ b/tests/testthat/test-exporters.R @@ -390,7 +390,7 @@ test_that("Can create flextable object that works with different styles", { # internal package check not_a_pkg <- "bwrereloakdosirabttjtaeerr" - suppressMessages(expect_error(check_required_packages(c("flextable", not_a_pkg)), not_a_pkg)) + expect_error(check_required_packages(c("flextable", not_a_pkg)), not_a_pkg) }) test_that("export_as_doc works thanks to tt_to_flextable", { diff --git a/tests/testthat/test-printing.R b/tests/testthat/test-printing.R index 2488c43c5..15de7d526 100644 --- a/tests/testthat/test-printing.R +++ b/tests/testthat/test-printing.R @@ -397,6 +397,34 @@ test_that("section_div works throughout", { expect_identical(length(mylns), 31L) ## sect div not printed for last one }) +test_that("section_div works when analyzing multiple variables", { + # Regression test for #835 + lyt <- basic_table() %>% + split_rows_by("Species", section_div = "|") %>% + analyze(c("Petal.Width", "Petal.Length"), + afun = function(x) list("m" = mean(x), "sd" = sd(x)), section_div = "-" + ) + + tbl <- build_table(lyt, iris) + out <- strsplit(toString(tbl), "\n")[[1]] + + expect_true(check_pattern(out[11], "|", length(out[1]))) + expect_true(check_pattern(out[16], "-", length(out[1]))) + + # One-var still works + lyt <- basic_table() %>% + split_rows_by("Species", section_div = "|") %>% + analyze("Petal.Width", + afun = function(x) list("m" = mean(x), "sd" = sd(x)), section_div = "-" + ) + + tbl <- build_table(lyt, iris) + out <- strsplit(toString(tbl), "\n")[[1]] + + expect_true(check_pattern(out[7], "|", length(out[1]))) + expect_true(check_pattern(out[10], "-", length(out[1]))) +}) + test_that("Inset works for table, ref_footnotes, and main footer", { general_inset <- 3