From 4b597c52b7caa081ca18a8e72248a06e6d89f8ff Mon Sep 17 00:00:00 2001 From: Emily de la Rua Date: Tue, 30 Jul 2024 18:34:04 -0400 Subject: [PATCH 1/7] Add option to include arm var labels in table header --- R/tm_t_summary.R | 76 ++++++++++++++++++++++++++++------------- man/template_summary.Rd | 9 +++-- man/tm_t_summary.Rd | 3 ++ 3 files changed, 62 insertions(+), 26 deletions(-) diff --git a/R/tm_t_summary.R b/R/tm_t_summary.R index 8a2941f993..fcf53ec954 100644 --- a/R/tm_t_summary.R +++ b/R/tm_t_summary.R @@ -3,8 +3,9 @@ #' Creates a valid expression to generate a table to summarize variables. #' #' @inheritParams template_arguments -#' @param show_labels (`character`)\cr defines whether variable labels should be displayed. Options are -#' `"default"`, `"visible"`, and `"hidden"`. +#' @param show_labels `r lifecycle::badge("deprecated")` +#' @param arm_var_labels (`character` or `NULL`)\cr vector of column variable labels to display, of the same length as +#' `arm_var`. If `NULL`, no labels will be displayed. #' #' @inherit template_arguments return #' @@ -15,10 +16,11 @@ template_summary <- function(dataname, parentname, arm_var, sum_vars, - show_labels = c("default", "visible", "hidden"), + show_labels = lifecycle::deprecated(), add_total = TRUE, total_label = default_total_label(), var_labels = character(), + arm_var_labels = NULL, na.rm = FALSE, # nolint: object_name. na_level = default_na_str(), numeric_stats = c( @@ -27,16 +29,25 @@ template_summary <- function(dataname, denominator = c("N", "n", "omit"), drop_arm_levels = TRUE, basic_table_args = teal.widgets::basic_table_args()) { + if (lifecycle::is_present(show_labels)) { + warning( + "The `show_labels` argument of `template_summary` is deprecated as of teal.modules.clinical 0.9.1.9013 ", + "as it is has no effect on the module.", + call. = FALSE + ) + } + checkmate::assert_string(dataname) checkmate::assert_string(parentname) + checkmate::assert_character(arm_var, min.len = 1, max.len = 2) checkmate::assert_character(sum_vars) checkmate::assert_flag(add_total) checkmate::assert_string(total_label) checkmate::assert_character(var_labels) + checkmate::assert_character(arm_var_labels, len = length(arm_var), null.ok = TRUE) checkmate::assert_flag(na.rm) checkmate::assert_string(na_level) checkmate::assert_flag(drop_arm_levels) - checkmate::assert_character(arm_var, min.len = 1, max.len = 2) checkmate::assert_character(numeric_stats, min.len = 1) checkmate::assert_subset( numeric_stats, @@ -44,7 +55,6 @@ template_summary <- function(dataname, ) denominator <- match.arg(denominator) - show_labels <- match.arg(show_labels) y <- list() @@ -105,17 +115,10 @@ template_summary <- function(dataname, # Build layout split_cols_call <- lapply(arm_var, function(x) { - if (drop_arm_levels) { - substitute( - expr = rtables::split_cols_by(x, split_fun = drop_split_levels), - env = list(x = x) - ) - } else { - substitute( - expr = rtables::split_cols_by(x), - env = list(x = x) - ) - } + substitute( + expr = rtables::split_cols_by(x, split_fun = if (drop_arm_levels) drop_split_levels else NULL), + env = list(x = x, drop_arm_levels = drop_arm_levels) + ) }) layout_list <- Reduce(add_expr, split_cols_call, init = layout_list) @@ -136,7 +139,6 @@ template_summary <- function(dataname, env_sum_vars <- list( sum_vars = sum_vars, sum_var_labels = var_labels[sum_vars], - show_labels = show_labels, na.rm = na.rm, na_level = na_level, denom = ifelse(denominator == "n", "n", "N_col"), @@ -153,7 +155,7 @@ template_summary <- function(dataname, expr = analyze_vars( vars = sum_vars, var_labels = sum_var_labels, - show_labels = show_labels, + show_labels = "visible", na.rm = na.rm, na_str = na_level, denom = denom, @@ -165,7 +167,7 @@ template_summary <- function(dataname, substitute( expr = analyze_vars( vars = sum_vars, - show_labels = show_labels, + show_labels = "visible", na.rm = na.rm, na_str = na_level, denom = denom, @@ -176,6 +178,22 @@ template_summary <- function(dataname, } ) + if (!is.null(arm_var_labels)) { + if (length(arm_var_labels) > 1) { + arm_var_labels <- sapply( + seq_along(arm_var_labels), + \(x) paste(strrep(" ", x - 1), arm_var_labels[x], sep = "") + ) + } + layout_list <- add_expr( + layout_list, + substitute( + expr = append_topleft(arm_var_labels), + env = list(arm_var_labels = c(arm_var_labels, "")) + ) + ) + } + y$layout <- substitute( expr = lyt <- layout_pipe, env = list(layout_pipe = pipe_expr(layout_list)) @@ -203,6 +221,7 @@ template_summary <- function(dataname, #' It defines the grouping variable(s) in the results table. #' If there are two elements selected for `arm_var`, #' second variable will be nested under the first variable. +#' @param show_arm_var_labels (`flag`)\cr whether arm variable label(s) should be displayed. Defaults to `TRUE`. #' #' @inherit module_arguments return seealso #' @@ -249,6 +268,7 @@ tm_t_summary <- function(label, summarize_vars, add_total = TRUE, total_label = default_total_label(), + show_arm_var_labels = TRUE, useNA = c("ifany", "no"), # nolint: object_name. na_level = default_na_str(), numeric_stats = c( @@ -267,15 +287,16 @@ tm_t_summary <- function(label, checkmate::assert_class(summarize_vars, "choices_selected") checkmate::assert_string(na_level) checkmate::assert_character(numeric_stats, min.len = 1) - useNA <- match.arg(useNA) # nolint: object_name. - denominator <- match.arg(denominator) checkmate::assert_flag(drop_arm_levels) checkmate::assert_class(pre_output, classes = "shiny.tag", null.ok = TRUE) checkmate::assert_class(post_output, classes = "shiny.tag", null.ok = TRUE) checkmate::assert_class(basic_table_args, "basic_table_args") - checkmate::assertFlag(add_total) + checkmate::assert_flag(add_total) + checkmate::assert_flag(show_arm_var_labels) checkmate::assert_string(total_label) + useNA <- match.arg(useNA) # nolint: object_name. + denominator <- match.arg(denominator) numeric_stats <- match.arg(numeric_stats, several.ok = TRUE) args <- as.list(environment()) @@ -296,6 +317,7 @@ tm_t_summary <- function(label, dataname = dataname, parentname = parentname, label = label, + show_arm_var_labels = show_arm_var_labels, total_label = total_label, na_level = na_level, basic_table_args = basic_table_args @@ -399,6 +421,7 @@ srv_summary <- function(id, arm_var, summarize_vars, add_total, + show_arm_var_labels, total_label, na_level, drop_arm_levels, @@ -519,15 +542,22 @@ srv_summary <- function(id, summarize_vars <- merged$anl_input_r()$columns_source$summarize_vars var_labels <- teal.data::col_labels(data()[[dataname]][, summarize_vars, drop = FALSE]) + + if (show_arm_var_labels) { + arm_vars <- merged$anl_input_r()$columns_source$arm_var + arm_var_labels <- teal.data::col_labels(data()[[dataname]][, arm_vars, drop = FALSE]) + } else { + arm_var_labels = NULL + } my_calls <- template_summary( dataname = "ANL", parentname = "ANL_ADSL", arm_var = merged$anl_input_r()$columns_source$arm_var, sum_vars = summarize_vars, - show_labels = "visible", add_total = input$add_total, total_label = total_label, var_labels = var_labels, + arm_var_labels = arm_var_labels, na.rm = ifelse(input$useNA == "ifany", FALSE, TRUE), na_level = na_level, numeric_stats = input$numeric_stats, diff --git a/man/template_summary.Rd b/man/template_summary.Rd index 44edd0a68d..da83f075e4 100644 --- a/man/template_summary.Rd +++ b/man/template_summary.Rd @@ -9,10 +9,11 @@ template_summary( parentname, arm_var, sum_vars, - show_labels = c("default", "visible", "hidden"), + show_labels = lifecycle::deprecated(), add_total = TRUE, total_label = default_total_label(), var_labels = character(), + arm_var_labels = NULL, na.rm = FALSE, na_level = default_na_str(), numeric_stats = c("n", "mean_sd", "mean_ci", "median", "median_ci", "quantiles", @@ -31,8 +32,7 @@ template_summary( \item{sum_vars}{(\code{character})\cr names of the variables that should be summarized.} -\item{show_labels}{(\code{character})\cr defines whether variable labels should be displayed. Options are -\code{"default"}, \code{"visible"}, and \code{"hidden"}.} +\item{show_labels}{\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#deprecated}{\figure{lifecycle-deprecated.svg}{options: alt='[Deprecated]'}}}{\strong{[Deprecated]}}} \item{add_total}{(\code{logical})\cr whether to include column with total number of patients.} @@ -42,6 +42,9 @@ apply in all modules, run \code{set_default_total_label("new_default")}.} \item{var_labels}{(named \code{character}) optional\cr variable labels for relabeling the analysis variables.} +\item{arm_var_labels}{(\code{character} or \code{NULL})\cr vector of column variable labels to display, of the same length as +\code{arm_var}. If \code{NULL}, no labels will be displayed.} + \item{na.rm}{(\code{logical})\cr whether \code{NA} values should be removed prior to analysis.} \item{na_level}{(\code{string})\cr used to replace all \code{NA} or empty values diff --git a/man/tm_t_summary.Rd b/man/tm_t_summary.Rd index f8a35bc3ba..3c20c13bd1 100644 --- a/man/tm_t_summary.Rd +++ b/man/tm_t_summary.Rd @@ -13,6 +13,7 @@ tm_t_summary( summarize_vars, add_total = TRUE, total_label = default_total_label(), + show_arm_var_labels = TRUE, useNA = c("ifany", "no"), na_level = default_na_str(), numeric_stats = c("n", "mean_sd", "mean_ci", "median", "median_ci", "quantiles", @@ -46,6 +47,8 @@ the variables that should be summarized.} enabled (see \code{add_total}). Defaults to \code{"All Patients"}. To set a new default \code{total_label} to apply in all modules, run \code{set_default_total_label("new_default")}.} +\item{show_arm_var_labels}{(\code{flag})\cr whether arm variable label(s) should be displayed. Defaults to \code{TRUE}.} + \item{useNA}{(\code{character})\cr whether missing data (\code{NA}) should be displayed as a level.} \item{na_level}{(\code{string})\cr used to replace all \code{NA} or empty values From 9c71e4647a8770465c8bdacc3d3bd44a6458d1f4 Mon Sep 17 00:00:00 2001 From: Emily de la Rua Date: Tue, 30 Jul 2024 18:40:43 -0400 Subject: [PATCH 2/7] Update NEWS --- NEWS.md | 2 ++ 1 file changed, 2 insertions(+) diff --git a/NEWS.md b/NEWS.md index 785f10b0bd..a4692112f4 100644 --- a/NEWS.md +++ b/NEWS.md @@ -4,10 +4,12 @@ * Added `teal.logger` functionality for logging changes in shiny inputs in all modules. * Introduced `ylim` parameter for `tm_g_km` module that controls width of y-axis. * Added functionality to `tm_t_events_patyear` to split columns by multiple (nested) variables via the `arm_var` argument. +* Added arguments `arm_var_labels` to `template_summary` and `show_arm_var_labels` to `tm_t_summary` to allow user to display arm variable (`arm_var`) labels in table header. ### Miscellaneous * Removed `Show Warnings` modals from modules. * Clarified the documentation specifying whether multiple values can be selected in the `arm_var` argument for each module. +* Began deprecation cycle for the `show_labels` argument of `template_summary` which has no effect on the `tm_t_summary` module. # teal.modules.clinical 0.9.1 From 8090a3c1a5f222254a4f245c42b994d85ad96a87 Mon Sep 17 00:00:00 2001 From: Emily de la Rua Date: Tue, 30 Jul 2024 19:02:25 -0400 Subject: [PATCH 3/7] Clean up --- R/tm_t_summary.R | 12 +++++------- 1 file changed, 5 insertions(+), 7 deletions(-) diff --git a/R/tm_t_summary.R b/R/tm_t_summary.R index fcf53ec954..e9b045c994 100644 --- a/R/tm_t_summary.R +++ b/R/tm_t_summary.R @@ -179,12 +179,10 @@ template_summary <- function(dataname, ) if (!is.null(arm_var_labels)) { - if (length(arm_var_labels) > 1) { - arm_var_labels <- sapply( - seq_along(arm_var_labels), - \(x) paste(strrep(" ", x - 1), arm_var_labels[x], sep = "") - ) - } + arm_var_labels <- sapply( + seq_along(arm_var_labels), + \(x) paste(strrep(" ", x - 1), arm_var_labels[x], sep = "") + ) layout_list <- add_expr( layout_list, substitute( @@ -545,7 +543,7 @@ srv_summary <- function(id, if (show_arm_var_labels) { arm_vars <- merged$anl_input_r()$columns_source$arm_var - arm_var_labels <- teal.data::col_labels(data()[[dataname]][, arm_vars, drop = FALSE]) + arm_var_labels <- teal.data::col_labels(data()[[dataname]][, arm_vars, drop = FALSE], fill = TRUE) } else { arm_var_labels = NULL } From 2a2043c3c9e33af1c5bb2832454c98859e3c0cae Mon Sep 17 00:00:00 2001 From: Emily de la Rua Date: Tue, 30 Jul 2024 20:36:12 -0400 Subject: [PATCH 4/7] Add test --- R/tm_t_summary.R | 15 ++++++++--- tests/testthat/_snaps/tm_t_summary.md | 38 +++++++++++++++++++++++++++ tests/testthat/test-tm_t_summary.R | 18 +++++++++---- 3 files changed, 62 insertions(+), 9 deletions(-) diff --git a/R/tm_t_summary.R b/R/tm_t_summary.R index e9b045c994..32c2a1f978 100644 --- a/R/tm_t_summary.R +++ b/R/tm_t_summary.R @@ -115,10 +115,17 @@ template_summary <- function(dataname, # Build layout split_cols_call <- lapply(arm_var, function(x) { - substitute( - expr = rtables::split_cols_by(x, split_fun = if (drop_arm_levels) drop_split_levels else NULL), - env = list(x = x, drop_arm_levels = drop_arm_levels) - ) + if (drop_arm_levels) { + substitute( + expr = rtables::split_cols_by(x, split_fun = drop_split_levels), + env = list(x = x) + ) + } else { + substitute( + expr = rtables::split_cols_by(x), + env = list(x = x) + ) + } }) layout_list <- Reduce(add_expr, split_cols_call, init = layout_list) diff --git a/tests/testthat/_snaps/tm_t_summary.md b/tests/testthat/_snaps/tm_t_summary.md index a9d1ca5fdb..a94731d933 100644 --- a/tests/testthat/_snaps/tm_t_summary.md +++ b/tests/testthat/_snaps/tm_t_summary.md @@ -170,3 +170,41 @@ } +# template_summary generates correct expressions when arm variable labels are added + + Code + res + Output + $data + { + anl <- adrs %>% df_explicit_na(omit_columns = setdiff(names(adrs), + c(c("RACE", "COUNTRY", "AGE"))), na_level = "") + anl <- anl %>% dplyr::mutate(ARM = droplevels(ARM)) + arm_levels <- levels(anl[["ARM"]]) + adsl <- adsl %>% dplyr::filter(ARM %in% arm_levels) + adsl <- adsl %>% dplyr::mutate(ARM = droplevels(ARM)) + anl <- anl %>% dplyr::mutate(SEX = droplevels(SEX)) + arm_levels <- levels(anl[["SEX"]]) + adsl <- adsl %>% dplyr::filter(SEX %in% arm_levels) + adsl <- adsl %>% dplyr::mutate(SEX = droplevels(SEX)) + adsl <- df_explicit_na(adsl, na_level = "") + } + + $layout + lyt <- rtables::basic_table(main_footer = "n represents the number of unique subject IDs such that the variable has non-NA values.") %>% + rtables::split_cols_by("ARM", split_fun = drop_split_levels) %>% + rtables::split_cols_by("SEX", split_fun = drop_split_levels) %>% + rtables::add_overall_col("All Patients") %>% rtables::add_colcounts() %>% + analyze_vars(vars = c("RACE", "COUNTRY", "AGE"), show_labels = "visible", + na.rm = FALSE, na_str = "", denom = "N_col", + .stats = c("n", "mean_sd", "mean_ci", "median", "median_ci", + "quantiles", "range", "geom_mean", "count_fraction")) %>% + append_topleft(c("Arm", " Sex", "")) + + $table + { + result <- rtables::build_table(lyt = lyt, df = anl, alt_counts_df = adsl) + result + } + + diff --git a/tests/testthat/test-tm_t_summary.R b/tests/testthat/test-tm_t_summary.R index 2dffb0c4ea..3aabdfb2e7 100644 --- a/tests/testthat/test-tm_t_summary.R +++ b/tests/testthat/test-tm_t_summary.R @@ -4,7 +4,6 @@ testthat::test_that("template_summary generates correct expressions", { parentname = "adsl", arm_var = "ARM", sum_vars = c("RACE", "COUNTRY", "AGE"), - show_labels = "visible", add_total = FALSE, var_labels = character(), na.rm = FALSE, @@ -22,7 +21,6 @@ testthat::test_that("template_summary can generate customized table", { parentname = "adsl", arm_var = "ARMCD", sum_vars = "RACE", - show_labels = "visible", add_total = TRUE, var_labels = c(RACE = "Race"), na.rm = TRUE, @@ -40,7 +38,6 @@ testthat::test_that("template_summary generates correct expressions for multiple parentname = "adsl", arm_var = c("ARM", "STRATA1"), sum_vars = c("RACE", "COUNTRY", "AGE"), - show_labels = "visible", add_total = FALSE, var_labels = character(), na.rm = FALSE, @@ -60,7 +57,6 @@ testthat::test_that( parentname = "adsl", arm_var = c("ARM", "STRATA1"), sum_vars = c("RACE", "COUNTRY", "AGE"), - show_labels = "visible", add_total = TRUE, var_labels = character(), na.rm = FALSE, @@ -79,7 +75,6 @@ testthat::test_that("template_summary generates correct expressions for customiz parentname = "adsl", arm_var = c("ARM", "STRATA1"), sum_vars = c("RACE", "COUNTRY", "AGE"), - show_labels = "visible", add_total = FALSE, var_labels = character(), na.rm = FALSE, @@ -91,3 +86,16 @@ testthat::test_that("template_summary generates correct expressions for customiz res <- testthat::expect_silent(result) testthat::expect_snapshot(res) }) + +testthat::test_that("template_summary generates correct expressions when arm variable labels are added", { + result <- template_summary( + dataname = "adrs", + parentname = "adsl", + arm_var = c("ARM", "SEX"), + sum_vars = c("RACE", "COUNTRY", "AGE"), + arm_var_labels = c("Arm", "Sex") + ) + + res <- testthat::expect_silent(result) + testthat::expect_snapshot(res) +}) From 5fe83aac4ae24a1b56cfe0f69e55fd4723aad099 Mon Sep 17 00:00:00 2001 From: Emily de la Rua Date: Tue, 30 Jul 2024 20:40:19 -0400 Subject: [PATCH 5/7] Clean up --- R/tm_t_summary.R | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/R/tm_t_summary.R b/R/tm_t_summary.R index 32c2a1f978..9f4f61c9f0 100644 --- a/R/tm_t_summary.R +++ b/R/tm_t_summary.R @@ -548,12 +548,12 @@ srv_summary <- function(id, summarize_vars <- merged$anl_input_r()$columns_source$summarize_vars var_labels <- teal.data::col_labels(data()[[dataname]][, summarize_vars, drop = FALSE]) + arm_var_labels <- NULL if (show_arm_var_labels) { arm_vars <- merged$anl_input_r()$columns_source$arm_var arm_var_labels <- teal.data::col_labels(data()[[dataname]][, arm_vars, drop = FALSE], fill = TRUE) - } else { - arm_var_labels = NULL } + my_calls <- template_summary( dataname = "ANL", parentname = "ANL_ADSL", From 112dd774f4ed0779e2a0213758dfb339f85ecd00 Mon Sep 17 00:00:00 2001 From: Emily de la Rua Date: Wed, 31 Jul 2024 16:26:44 -0400 Subject: [PATCH 6/7] Remove indentation from col labels --- R/tm_t_summary.R | 4 ---- 1 file changed, 4 deletions(-) diff --git a/R/tm_t_summary.R b/R/tm_t_summary.R index 9f4f61c9f0..3aed13bdba 100644 --- a/R/tm_t_summary.R +++ b/R/tm_t_summary.R @@ -186,10 +186,6 @@ template_summary <- function(dataname, ) if (!is.null(arm_var_labels)) { - arm_var_labels <- sapply( - seq_along(arm_var_labels), - \(x) paste(strrep(" ", x - 1), arm_var_labels[x], sep = "") - ) layout_list <- add_expr( layout_list, substitute( From 22b0522030f38b35a827ee327bb9303c9196adda Mon Sep 17 00:00:00 2001 From: Emily de la Rua Date: Wed, 31 Jul 2024 16:39:23 -0400 Subject: [PATCH 7/7] Update snap --- tests/testthat/_snaps/tm_t_summary.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tests/testthat/_snaps/tm_t_summary.md b/tests/testthat/_snaps/tm_t_summary.md index a94731d933..05d4ccccc4 100644 --- a/tests/testthat/_snaps/tm_t_summary.md +++ b/tests/testthat/_snaps/tm_t_summary.md @@ -199,7 +199,7 @@ na.rm = FALSE, na_str = "", denom = "N_col", .stats = c("n", "mean_sd", "mean_ci", "median", "median_ci", "quantiles", "range", "geom_mean", "count_fraction")) %>% - append_topleft(c("Arm", " Sex", "")) + append_topleft(c("Arm", "Sex", "")) $table {