Skip to content

Commit

Permalink
Adds decorators to tm_a_mmrm (#1300)
Browse files Browse the repository at this point in the history 
Part of insightsengineering/teal#1371

<details>
<summary>Working example</summary>

```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()
```

</details>

---------

Co-authored-by: Marcin <[email protected]>
  • Loading branch information
@averissimo @m7pr
averissimo and m7pr authored Dec 12, 2024
1 parent 00c8c0b commit a855989
Show file tree
Hide file tree
Showing 2 changed files with 177 additions and 31 deletions.
163 changes: 133 additions & 30 deletions R/tm_a_mmrm.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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),
Expand All @@ -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),
Expand All @@ -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),
Expand All @@ -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),
Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -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)
Expand Down Expand Up @@ -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(
Expand Down Expand Up @@ -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)
Expand Down Expand Up @@ -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'", " || ",
Expand Down Expand Up @@ -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")
Expand Down Expand Up @@ -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(
Expand All @@ -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"
)
Expand Down Expand Up @@ -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)
Expand Down
45 changes: 44 additions & 1 deletion man/tm_a_mmrm.Rd
View file

Some generated files are not rendered by default. Learn more about how customized files appear on GitHub.

0 comments on commit a855989

Please sign in to comment.