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)