diff --git a/NEWS.md b/NEWS.md index 006cd7070d..ddf77a49b4 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,12 +1,12 @@ # teal.modules.clinical 0.9.1.9013 -* Removed `Show Warnings` modals from modules. - ### Enhancements * 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. ### 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. # teal.modules.clinical 0.9.1 diff --git a/R/tm_t_events_patyear.R b/R/tm_t_events_patyear.R index cde3284d86..a72765e79c 100644 --- a/R/tm_t_events_patyear.R +++ b/R/tm_t_events_patyear.R @@ -23,6 +23,8 @@ template_events_patyear <- function(dataname, control = control_incidence_rate(), drop_arm_levels = TRUE, basic_table_args = teal.widgets::basic_table_args()) { + checkmate::assert_character(arm_var, min.len = 1, max.len = 2) + # initialize y <- list() # data @@ -39,10 +41,21 @@ template_events_patyear <- function(dataname, prepare_arm_levels( dataname = "anl", parentname = parentname, - arm_var = arm_var, + arm_var = arm_var[[1]], drop_arm_levels = drop_arm_levels ) ) + if (length(arm_var) == 2) { + data_list <- add_expr( + data_list, + prepare_arm_levels( + dataname = "anl", + parentname = parentname, + arm_var = arm_var[[2]], + drop_arm_levels = drop_arm_levels + ) + ) + } data_list <- add_expr( data_list, @@ -94,9 +107,27 @@ template_events_patyear <- function(dataname, expr = expr_basic_table_args %>% rtables::split_cols_by(var = arm_var) %>% rtables::add_colcounts(), - env = list(arm_var = arm_var, expr_basic_table_args = parsed_basic_table_args) + env = list(arm_var = arm_var[[1]], expr_basic_table_args = parsed_basic_table_args) ) ) + + if (length(arm_var) == 2) { + layout_list <- add_expr( + layout_list, + if (drop_arm_levels) { + substitute( + expr = rtables::split_cols_by(nested_col, split_fun = drop_split_levels), + env = list(nested_col = arm_var[[2]]) + ) + } else { + substitute( + expr = rtables::split_cols_by(nested_col), + env = list(nested_col = arm_var[[2]]) + ) + } + ) + } + if (add_total) { layout_list <- add_expr( layout_list, @@ -152,6 +183,11 @@ template_events_patyear <- function(dataname, #' #' @inheritParams module_arguments #' @inheritParams template_events_patyear +#' @param arm_var ([teal.transform::choices_selected()])\cr object with all +#' available choices and preselected option for variable names that can be used as `arm_var`. +#' 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 events_var ([teal.transform::choices_selected()])\cr object with #' all available choices and preselected option for the variable with all event counts. #' @@ -159,12 +195,15 @@ template_events_patyear <- function(dataname, #' #' @examples #' library(dplyr) +#' #' ADSL <- tmc_ex_adsl #' ADAETTE <- tmc_ex_adaette %>% #' filter(PARAMCD %in% c("AETTE1", "AETTE2", "AETTE3")) %>% #' mutate(is_event = CNSR == 0) %>% #' mutate(n_events = as.integer(is_event)) #' +#' # 1. Basic Example +#' #' app <- init( #' data = cdisc_data( #' ADSL = ADSL, @@ -202,6 +241,45 @@ template_events_patyear <- function(dataname, #' shinyApp(app$ui, app$server) #' } #' +#' # 2. Example with table split on 2 arm_var variables +#' +#' app <- init( +#' data = cdisc_data( +#' ADSL = ADSL, +#' ADAETTE = ADAETTE, +#' code = " +#' ADSL <- tmc_ex_adsl +#' ADAETTE <- tmc_ex_adaette %>% +#' filter(PARAMCD %in% c(\"AETTE1\", \"AETTE2\", \"AETTE3\")) %>% +#' mutate(is_event = CNSR == 0) %>% +#' mutate(n_events = as.integer(is_event)) +#' " +#' ), +#' modules = modules( +#' tm_t_events_patyear( +#' label = "AE Rate Adjusted for Patient-Years At Risk Table", +#' dataname = "ADAETTE", +#' arm_var = choices_selected( +#' choices = variable_choices(ADSL, c("ARM", "ARMCD", "SEX")), +#' selected = c("ARM", "SEX") +#' ), +#' add_total = TRUE, +#' events_var = choices_selected( +#' choices = variable_choices(ADAETTE, "n_events"), +#' selected = "n_events", +#' fixed = TRUE +#' ), +#' paramcd = choices_selected( +#' choices = value_choices(ADAETTE, "PARAMCD", "PARAM"), +#' selected = "AETTE1" +#' ) +#' ) +#' ) +#' ) +#' if (interactive()) { +#' shinyApp(app$ui, app$server) +#' } +#' #' @export tm_t_events_patyear <- function(label, dataname, @@ -253,7 +331,7 @@ tm_t_events_patyear <- function(label, args <- c(as.list(environment())) data_extract_list <- list( - arm_var = cs_to_des_select(arm_var, dataname = parentname), + arm_var = cs_to_des_select(arm_var, dataname = parentname, multiple = TRUE, ordered = TRUE), paramcd = cs_to_des_filter(paramcd, dataname = dataname), aval_var = cs_to_des_select(aval_var, dataname = dataname), avalu_var = cs_to_des_select(avalu_var, dataname = dataname), @@ -495,7 +573,7 @@ srv_events_patyear <- function(id, adslvars = c("USUBJID", "STUDYID", input_arm_var), anl = anl_filtered, anlvars = c("USUBJID", "STUDYID", input_paramcd, input_events_var, input_aval_var, input_avalu_var), - arm_var = input_arm_var + arm_var = input_arm_var[[1]] ) validate( diff --git a/man/tm_t_events_patyear.Rd b/man/tm_t_events_patyear.Rd index b466449910..5fe61d029b 100644 --- a/man/tm_t_events_patyear.Rd +++ b/man/tm_t_events_patyear.Rd @@ -36,7 +36,9 @@ tm_t_events_patyear( \item{arm_var}{(\code{\link[teal.transform:choices_selected]{teal.transform::choices_selected()}})\cr object with all available choices and preselected option for variable names that can be used as \code{arm_var}. -It defines the grouping variable in the results table.} +It defines the grouping variable(s) in the results table. +If there are two elements selected for \code{arm_var}, +second variable will be nested under the first variable.} \item{events_var}{(\code{\link[teal.transform:choices_selected]{teal.transform::choices_selected()}})\cr object with all available choices and preselected option for the variable with all event counts.} @@ -87,12 +89,15 @@ This module produces a table of event rates adjusted for patient-years. } \examples{ library(dplyr) + ADSL <- tmc_ex_adsl ADAETTE <- tmc_ex_adaette \%>\% filter(PARAMCD \%in\% c("AETTE1", "AETTE2", "AETTE3")) \%>\% mutate(is_event = CNSR == 0) \%>\% mutate(n_events = as.integer(is_event)) +# 1. Basic Example + app <- init( data = cdisc_data( ADSL = ADSL, @@ -130,6 +135,45 @@ if (interactive()) { shinyApp(app$ui, app$server) } +# 2. Example with table split on 2 arm_var variables + +app <- init( + data = cdisc_data( + ADSL = ADSL, + ADAETTE = ADAETTE, + code = " + ADSL <- tmc_ex_adsl + ADAETTE <- tmc_ex_adaette \%>\% + filter(PARAMCD \%in\% c(\"AETTE1\", \"AETTE2\", \"AETTE3\")) \%>\% + mutate(is_event = CNSR == 0) \%>\% + mutate(n_events = as.integer(is_event)) + " + ), + modules = modules( + tm_t_events_patyear( + label = "AE Rate Adjusted for Patient-Years At Risk Table", + dataname = "ADAETTE", + arm_var = choices_selected( + choices = variable_choices(ADSL, c("ARM", "ARMCD", "SEX")), + selected = c("ARM", "SEX") + ), + add_total = TRUE, + events_var = choices_selected( + choices = variable_choices(ADAETTE, "n_events"), + selected = "n_events", + fixed = TRUE + ), + paramcd = choices_selected( + choices = value_choices(ADAETTE, "PARAMCD", "PARAM"), + selected = "AETTE1" + ) + ) + ) +) +if (interactive()) { + shinyApp(app$ui, app$server) +} + } \seealso{ The \href{https://insightsengineering.github.io/tlg-catalog/stable/}{TLG Catalog} where additional example diff --git a/tests/testthat/_snaps/tm_t_events_patyear.md b/tests/testthat/_snaps/tm_t_events_patyear.md index f4fc8e4962..1f87e7cd7d 100644 --- a/tests/testthat/_snaps/tm_t_events_patyear.md +++ b/tests/testthat/_snaps/tm_t_events_patyear.md @@ -66,18 +66,23 @@ $data { anl <- adaette - anl <- anl %>% dplyr::mutate(ARMCD = droplevels(ARMCD)) - arm_levels <- levels(anl[["ARMCD"]]) - adsl <- adsl %>% dplyr::filter(ARMCD %in% arm_levels) - adsl <- adsl %>% dplyr::mutate(ARMCD = droplevels(ARMCD)) + 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)) anl <- df_explicit_na(anl, na_level = "") adsl <- df_explicit_na(adsl, na_level = "") } $layout lyt <- rtables::basic_table(title = "Event Rates Adjusted for Patient-Years by Time to First Occurrence of any Adverse Event", - main_footer = "CI Method: Exact") %>% rtables::split_cols_by(var = "ARMCD") %>% - rtables::add_colcounts() %>% rtables::add_overall_col(label = "All Patients") %>% + main_footer = "CI Method: Exact") %>% rtables::split_cols_by(var = "ARM") %>% + rtables::add_colcounts() %>% rtables::split_cols_by("SEX", + split_fun = drop_split_levels) %>% rtables::add_overall_col(label = "All Patients") %>% estimate_incidence_rate(vars = "AVAL", n_events = "n_events", control = control_incidence_rate(conf_level = 0.9, conf_type = "exact", input_time_unit = "month", num_pt_year = 80)) diff --git a/tests/testthat/test-shinytest2-tm_t_events_patyear.R b/tests/testthat/test-shinytest2-tm_t_events_patyear.R index ccd6e7f01f..b8d5b471dd 100644 --- a/tests/testthat/test-shinytest2-tm_t_events_patyear.R +++ b/tests/testthat/test-shinytest2-tm_t_events_patyear.R @@ -20,7 +20,7 @@ app_driver_tm_t_events_patyear <- function() { dataname = "ADAETTE", parentname = "ADSL", arm_var = teal.transform::choices_selected( - choices = teal.transform::variable_choices(data[["ADSL"]], c("ARM", "ARMCD")), + choices = teal.transform::variable_choices(data[["ADSL"]], c("ARM", "ARMCD", "SEX")), selected = "ARMCD" ), add_total = TRUE, @@ -175,3 +175,21 @@ testthat::test_that("e2e - tm_t_events_patyear: Deselection of arm_var throws va ) app_driver$stop() }) + +testthat::test_that( + "e2e - tm_t_events_patyear: Selecting 2 variables as arm_var changes the table and does not throw validation errors.", + { + skip_if_too_deep(5) + app_driver <- app_driver_tm_t_events_patyear() + table_before <- app_driver$get_active_module_table_output("patyear_table-table-with-settings") + app_driver$set_active_module_input("arm_var-dataset_ADSL_singleextract-select", c("ARM", "SEX")) + testthat::expect_false( + identical( + table_before, + app_driver$get_active_module_table_output("patyear_table-table-with-settings") + ) + ) + app_driver$expect_no_validation_error() + app_driver$stop() + } +) diff --git a/tests/testthat/test-tm_t_events_patyear.R b/tests/testthat/test-tm_t_events_patyear.R index b789d0fcf5..5cbc7d32e9 100644 --- a/tests/testthat/test-tm_t_events_patyear.R +++ b/tests/testthat/test-tm_t_events_patyear.R @@ -36,7 +36,7 @@ testthat::test_that("template_events_patyear generates right expressions with no result <- template_events_patyear( dataname = "adaette", parentname = "adsl", - arm_var = "ARMCD", + arm_var = c("ARM", "SEX"), aval_var = "AVAL", events_var = "n_events", label_paramcd = "Time to first occurrence of any adverse event",