From a855989138b5cc5e4ca11697e32da763e0a1b246 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andr=C3=A9=20Ver=C3=ADssimo?= <211358+averissimo@users.noreply.github.com> Date: Thu, 12 Dec 2024 14:10:20 +0000 Subject: [PATCH] Adds decorators to `tm_a_mmrm` (#1300) Part of https://github.com/insightsengineering/teal/issues/1371
Working example ```r # Load packages pkgload::load_all("../teal.modules.clinical", export_all = FALSE) # Example below insert_rrow_decorator <- function(default_caption = "I am a good new row", .var_to_replace = "table") { teal_transform_module( label = "New row", ui = function(id) shiny::textInput(shiny::NS(id, "new_row"), "New row", value = default_caption), server = make_teal_transform_server( substitute({ .var_to_replace <- rtables::insert_rrow(.var_to_replace, rtables::rrow(new_row)) }, env = list(.var_to_replace = as.name(.var_to_replace))) ) ) } add_title_decorator <- function(default_check = TRUE, .var_to_replace = "plot") { teal_transform_module( label = "Theme", ui = function(id) shiny::checkboxInput(NS(id, "flag"), "Add title?", TRUE), server = make_teal_transform_server( substitute({ if (flag) .var_to_replace <- .var_to_replace + ggplot2::ggtitle("Title added by decorator") }, env = list(.var_to_replace = as.name(.var_to_replace)) ) ) ) } library(dplyr) arm_ref_comp <- list( ARMCD = list( ref = "ARM B", comp = c("ARM A", "ARM C") ) ) data <- teal_data() data <- within(data, { ADSL <- tmc_ex_adsl ADQS <- tmc_ex_adqs %>% filter(ABLFL != "Y" & ABLFL2 != "Y") %>% filter(AVISIT %in% c("WEEK 1 DAY 8", "WEEK 2 DAY 15", "WEEK 3 DAY 22")) %>% mutate( AVISIT = as.factor(AVISIT), AVISITN = rank(AVISITN) %>% as.factor() %>% as.numeric() %>% as.factor() #' making consecutive numeric factor ) }) join_keys(data) <- default_cdisc_join_keys[names(data)] init( data = data, modules = modules( tm_a_mmrm( label = "MMRM", dataname = "ADQS", aval_var = choices_selected(c("AVAL", "CHG"), "AVAL"), id_var = choices_selected(c("USUBJID", "SUBJID"), "USUBJID"), arm_var = choices_selected(c("ARM", "ARMCD"), "ARM"), visit_var = choices_selected(c("AVISIT", "AVISITN"), "AVISIT"), arm_ref_comp = arm_ref_comp, paramcd = choices_selected( choices = value_choices(data[["ADQS"]], "PARAMCD", "PARAM"), selected = "FKSI-FWB" ), cov_var = choices_selected(c("BASE", "AGE", "SEX", "BASE:AVISIT"), NULL), decorators = list( lsmeans_table = insert_rrow_decorator("A", .var_to_replace = "lsmeans_table") , lsmeans_plot = add_title_decorator("B", .var_to_replace = "lsmeans_plot") , covariance_table = insert_rrow_decorator("C", .var_to_replace = "covariance_table") , fixed_effects_table = insert_rrow_decorator("D", .var_to_replace = "fixed_effects_table") , diagnostic_table = insert_rrow_decorator(.var_to_replace = "diagnostic_table") , diagnostic_plot = add_title_decorator(.var_to_replace = "diagnostic_plot") ) ) ) ) |> shiny::runApp() ```
--------- Co-authored-by: Marcin <133694481+m7pr@users.noreply.github.com> --- R/tm_a_mmrm.R | 163 ++++++++++++++++++++++++++++++++++++++--------- man/tm_a_mmrm.Rd | 45 ++++++++++++- 2 files changed, 177 insertions(+), 31 deletions(-) diff --git a/R/tm_a_mmrm.R b/R/tm_a_mmrm.R index 59039b41c..02b18b96f 100644 --- a/R/tm_a_mmrm.R +++ b/R/tm_a_mmrm.R @@ -273,7 +273,6 @@ template_mmrm_tables <- function(parentname, df = df_explicit_na(broom::tidy(fit_mmrm), na_level = default_na_str()), alt_counts_df = parentname ) - lsmeans_table }, env = list( parentname = as.name(parentname), @@ -284,9 +283,8 @@ template_mmrm_tables <- function(parentname, t_mmrm_cov = { y$cov_matrix <- substitute( expr = { - cov_matrix <- tern.mmrm::as.rtable(fit_mmrm, type = "cov") - subtitles(cov_matrix) <- st - cov_matrix + covariance_table <- tern.mmrm::as.rtable(fit_mmrm, type = "cov") + subtitles(covariance_table) <- st }, env = list( fit_mmrm = as.name(fit_name), @@ -297,9 +295,8 @@ template_mmrm_tables <- function(parentname, t_mmrm_fixed = { y$fixed_effects <- substitute( expr = { - fixed_effects <- tern.mmrm::as.rtable(fit_mmrm, type = "fixed") - subtitles(fixed_effects) <- st - fixed_effects + fixed_effects_table <- tern.mmrm::as.rtable(fit_mmrm, type = "fixed") + subtitles(fixed_effects_table) <- st }, env = list( fit_mmrm = as.name(fit_name), @@ -312,7 +309,6 @@ template_mmrm_tables <- function(parentname, expr = { diagnostic_table <- tern.mmrm::as.rtable(fit_mmrm, type = "diagnostic") subtitles(diagnostic_table) <- st - diagnostic_table }, env = list( fit_mmrm = as.name(fit_name), @@ -462,6 +458,35 @@ template_mmrm_plots <- function(fit_name, #' #' @inherit module_arguments return seealso #' +#' @section Decorating Module: +#' +#' This module generates the following objects, which can be modified in place using decorators: +#' - `lsmeans_plot` (`ggplot2`) +#' - `diagnostic_plot` (`TableTree`- output from `rtables::build_table`) +#' - `lsmeans_table` (`TableTree`- output from `rtables::build_table`) +#' - `covariance_table` (`TableTree`- output from `rtables::build_table`) +#' - `fixed_effects_table` (`TableTree`- output from `rtables::build_table`) +#' - `diagnostic_table` (`TableTree`- output from `rtables::build_table`) +#' +#' Decorators can be applied to all outputs or only to specific objects using a +#' named list of `teal_transform_module` objects. +#' The `"default"` name is reserved for decorators that are applied to all outputs. +#' See code snippet below: +#' +#' ``` +#' tm_a_mrmm( +#' ..., # arguments for module +#' decorators = list( +#' default = list(teal_transform_module(...)), # applied to all outputs +#' lsmeans_plot = list(teal_transform_module(...)) # applied only to `lsmeans_plot` output +#' diagnostic_plot = list(teal_transform_module(...)) # applied only to `diagnostic_plot` output +#' lsmeans_table = list(teal_transform_module(...)) # applied only to `lsmeans_table` output +#' covariance_table = list(teal_transform_module(...)) # applied only to `covariance_table` output +#' fixed_effects_table = list(teal_transform_module(...)) # applied only to `fixed_effects_table` output +#' diagnostic_table = list(teal_transform_module(...)) # applied only to `diagnostic_table` output +#' ) +#' ) +#' ``` #' @examplesShinylive #' library(teal.modules.clinical) #' interactive <- function() TRUE @@ -543,7 +568,8 @@ tm_a_mmrm <- function(label, pre_output = NULL, post_output = NULL, basic_table_args = teal.widgets::basic_table_args(), - ggplot2_args = teal.widgets::ggplot2_args()) { + ggplot2_args = teal.widgets::ggplot2_args(), + decorators = NULL) { message("Initializing tm_a_mmrm") cov_var <- teal.transform::add_no_selected_choices(cov_var, multiple = TRUE) checkmate::assert_string(label) @@ -572,6 +598,20 @@ tm_a_mmrm <- function(label, checkmate::assert_list(ggplot2_args, types = "ggplot2_args") checkmate::assert_subset(names(ggplot2_args), c("default", plot_choices)) + decorators <- normalize_decorators(decorators) + assert_decorators( + decorators, + c( + "lsmeans_table", + "lsmeans_plot", + "covariance_table", + "fixed_effects_table", + "diagnostic_table", + "diagnostic_plot" + ), + null.ok = TRUE + ) + args <- as.list(environment()) data_extract_list <- list( @@ -600,7 +640,8 @@ tm_a_mmrm <- function(label, plot_height = plot_height, plot_width = plot_width, basic_table_args = basic_table_args, - ggplot2_args = ggplot2_args + ggplot2_args = ggplot2_args, + decorators = decorators ) ), datanames = teal.transform::get_extract_datanames(data_extract_list) @@ -754,6 +795,32 @@ ui_mmrm <- function(id, ...) { ), selected = "t_mmrm_lsmeans" ), + # Decorators --- + conditionalPanel( + condition = sprintf("input['%s'] == '%s'", ns("output_function"), "t_mmrm_lsmeans"), + ui_decorate_teal_data(ns("d_lsmeans_table"), select_decorators(a$decorators, "lsmeans_table")) + ), + conditionalPanel( + condition = sprintf("input['%s'] == '%s'", ns("output_function"), "g_mmrm_lsmeans"), + ui_decorate_teal_data(ns("d_lsmeans_plot"), select_decorators(a$decorators, "lsmeans_plot")) + ), + conditionalPanel( + condition = sprintf("input['%s'] == '%s'", ns("output_function"), "t_mmrm_cov"), + ui_decorate_teal_data(ns("d_covariance_table"), select_decorators(a$decorators, "covariance_table")) + ), + conditionalPanel( + condition = sprintf("input['%s'] == '%s'", ns("output_function"), "t_mmrm_fixed"), + ui_decorate_teal_data(ns("d_fixed_effects_table"), select_decorators(a$decorators, "fixed_effects_table")) + ), + conditionalPanel( + condition = sprintf("input['%s'] == '%s'", ns("output_function"), "t_mmrm_diagnostic"), + ui_decorate_teal_data(ns("d_diagnostic_table"), select_decorators(a$decorators, "diagnostic_table")) + ), + conditionalPanel( + condition = sprintf("input['%s'] == '%s'", ns("output_function"), "g_mmrm_diagnostic"), + ui_decorate_teal_data(ns("d_diagnostic_plot"), select_decorators(a$decorators, "diagnostic_plot")) + ), + # End of Decorators --- conditionalPanel( condition = paste0( "input['", ns("output_function"), "'] == 't_mmrm_lsmeans'", " || ", @@ -843,7 +910,8 @@ srv_mmrm <- function(id, plot_height, plot_width, basic_table_args, - ggplot2_args) { + ggplot2_args, + decorators) { with_reporter <- !missing(reporter) && inherits(reporter, "Reporter") with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI") checkmate::assert_class(data, "reactive") @@ -1399,30 +1467,62 @@ srv_mmrm <- function(id, teal.code::eval_code(qenv, as.expression(mmrm_plot_expr)) }) - all_q <- reactive({ - if (!is.null(plot_q()) && !is.null(table_q())) { - c(plot_q(), table_q()) - } else if (!is.null(plot_q())) { - plot_q() - } else { - table_q() + decorated_tables_q <- lapply( + rlang::set_names( + c("lsmeans_table", "diagnostic_table", "fixed_effects_table", "covariance_table") + ), + function(output_function) { + srv_decorate_teal_data( + id = sprintf("d_%s", output_function), + data = table_q, + decorators = select_decorators(decorators, output_function), + expr = reactive(bquote(.(as.name(output_function)))), + expr_is_reactive = TRUE + ) } - }) + ) - table_r <- reactive({ + decorated_objs_q <- c( + decorated_tables_q, + lapply( + rlang::set_names(c("lsmeans_plot", "diagnostic_plot")), + function(output_function) { + srv_decorate_teal_data( + id = sprintf("d_%s", output_function), + data = plot_q, + decorators = select_decorators(decorators, output_function), + expr = reactive(bquote(.(as.name(output_function)))), + expr_is_reactive = TRUE + ) + } + ) + ) + + obj_ix_r <- reactive({ switch(input$output_function, - t_mmrm_lsmeans = table_q()[["lsmeans_table"]], - t_mmrm_diagnostic = table_q()[["diagnostic_table"]], - t_mmrm_fixed = table_q()[["fixed_effects"]], - t_mmrm_cov = table_q()[["cov_matrix"]] + t_mmrm_lsmeans = "lsmeans_table", + t_mmrm_diagnostic = "diagnostic_table", + t_mmrm_fixed = "fixed_effects_table", + t_mmrm_cov = "covariance_table", + g_mmrm_lsmeans = "lsmeans_plot", + g_mmrm_diagnostic = "diagnostic_plot" ) }) plot_r <- reactive({ - switch(input$output_function, - g_mmrm_lsmeans = plot_q()[["lsmeans_plot"]], - g_mmrm_diagnostic = plot_q()[["diagnostic_plot"]] - ) + if (is.null(plot_q())) { + NULL + } else { + decorated_objs_q[[obj_ix_r()]]()[[obj_ix_r()]] + } + }) + + table_r <- reactive({ + if (is.null(table_q())) { + NULL + } else { + decorated_objs_q[[obj_ix_r()]]()[[obj_ix_r()]] + } }) pws <- teal.widgets::plot_with_settings_srv( @@ -1440,9 +1540,12 @@ srv_mmrm <- function(id, ) # Show R code once button is pressed. + source_code_r <- reactive( + teal.code::get_code(req(decorated_objs_q[[obj_ix_r()]]())) + ) teal.widgets::verbatim_popup_srv( id = "rcode", - verbatim_content = reactive(teal.code::get_code(all_q())), + verbatim_content = source_code_r, disabled = disable_r_code, title = "R Code for the Current MMRM Analysis" ) @@ -1472,7 +1575,7 @@ srv_mmrm <- function(id, card$append_text("Comment", "header3") card$append_text(comment) } - card$append_src(teal.code::get_code(all_q())) + card$append_src(source_code_r()) card } teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun) diff --git a/man/tm_a_mmrm.Rd b/man/tm_a_mmrm.Rd index 58225572c..24a9ba960 100644 --- a/man/tm_a_mmrm.Rd +++ b/man/tm_a_mmrm.Rd @@ -26,7 +26,8 @@ tm_a_mmrm( pre_output = NULL, post_output = NULL, basic_table_args = teal.widgets::basic_table_args(), - ggplot2_args = teal.widgets::ggplot2_args() + ggplot2_args = teal.widgets::ggplot2_args(), + decorators = NULL ) } \arguments{ @@ -94,6 +95,15 @@ with settings for all the plots or named list of \code{ggplot2_args} objects for List names should match the following: \code{c("default", "lsmeans", "diagnostic")}. The argument is merged with option \code{teal.ggplot2_args} and with default module arguments (hard coded in the module body). For more details, see the help vignette: \code{vignette("custom-ggplot2-arguments", package = "teal.widgets")}.} + +\item{decorators}{\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}} +" (\code{list} of \code{teal_transform_module}, named \code{list} of \code{teal_transform_module} or" \code{NULL}) optional, +if not \code{NULL}, decorator for tables or plots included in the module. +When a named list of \code{teal_transform_module}, the decorators are applied to the respective output objects. + +Otherwise, the decorators are applied to all objects, which is equivalent as using the name \code{default}. + +See section "Decorating Module" below for more details.} } \value{ a \code{teal_module} object. @@ -107,6 +117,39 @@ different convergence behavior. This is a known observation with the used packag \code{lme4}. However, once convergence is achieved, the results are reliable up to numerical precision. } +\section{Decorating Module}{ + + +This module generates the following objects, which can be modified in place using decorators: +\itemize{ +\item \code{lsmeans_plot} (\code{ggplot2}) +\item \code{diagnostic_plot} (\code{TableTree}- output from \code{rtables::build_table}) +\item \code{lsmeans_table} (\code{TableTree}- output from \code{rtables::build_table}) +\item \code{covariance_table} (\code{TableTree}- output from \code{rtables::build_table}) +\item \code{fixed_effects_table} (\code{TableTree}- output from \code{rtables::build_table}) +\item \code{diagnostic_table} (\code{TableTree}- output from \code{rtables::build_table}) +} + +Decorators can be applied to all outputs or only to specific objects using a +named list of \code{teal_transform_module} objects. +The \code{"default"} name is reserved for decorators that are applied to all outputs. +See code snippet below: + +\if{html}{\out{
}}\preformatted{tm_a_mrmm( + ..., # arguments for module + decorators = list( + default = list(teal_transform_module(...)), # applied to all outputs + lsmeans_plot = list(teal_transform_module(...)) # applied only to `lsmeans_plot` output + diagnostic_plot = list(teal_transform_module(...)) # applied only to `diagnostic_plot` output + lsmeans_table = list(teal_transform_module(...)) # applied only to `lsmeans_table` output + covariance_table = list(teal_transform_module(...)) # applied only to `covariance_table` output + fixed_effects_table = list(teal_transform_module(...)) # applied only to `fixed_effects_table` output + diagnostic_table = list(teal_transform_module(...)) # applied only to `diagnostic_table` output + ) +) +}\if{html}{\out{
}} +} + \examples{ library(dplyr)