Skip to content

Commit

Permalink
introduce decorators for tm_outliers (#805)
Browse files Browse the repository at this point in the history 
Partner to insightsengineering/teal#1357

<details><summary>Working Example </summary>

```r
devtools::load_all('../teal')
devtools::load_all('.')
# general data example
data <- teal_data()
data <- within(data, {
  CO2 <- CO2
  CO2[["primary_key"]] <- seq_len(nrow(CO2))
})
join_keys(data) <- join_keys(join_key("CO2", "CO2", "primary_key"))

vars <- choices_selected(variable_choices(data[["CO2"]], c("Plant", "Type", "Treatment")))


boxplot_decorator <- teal_transform_module(
  label = "Footnote",
  ui = function(id) shiny::textInput(shiny::NS(id, "footnote"), "Box plot Footnote", value = "BOX PLOT I am a good decorator"),
  server = function(id, data) {
    moduleServer(id, function(input, output, session) {
      logger::log_info("🟢 Footnote called to action!", namespace = "teal.modules.general")
      reactive(
        within(
          data(),
          {
            if (exists("box_plot")) {
              footnote_str <- footnote
              box_plot <- box_plot + ggplot2::labs(caption = footnote_str)
            }
          },
          footnote = input$footnote
        )
      )
    })
  }
)

cum_dist_decorator <- teal_transform_module(
  label = "Footnote",
  ui = function(id) shiny::textInput(shiny::NS(id, "footnote"), "Cum dist Footnote", value = "CUM DIST I am a good decorator"),
  server = function(id, data) {
    moduleServer(id, function(input, output, session) {
      logger::log_info("🟢 Footnote called to action!", namespace = "teal.modules.general")
      reactive(
        within(
          data(),
          {
            if (exists("cum_dist_plot")) {
              footnote_str <- footnote
              cum_dist_plot <- cum_dist_plot + ggplot2::labs(caption = footnote_str)
            }
          },
          footnote = input$footnote
        )
      )
    })
  }
)

app <- init(
  data = data,
  modules = modules(
    tm_outliers(
      outlier_var = list(
        data_extract_spec(
          dataname = "CO2",
          select = select_spec(
            label = "Select variable:",
            choices = variable_choices(data[["CO2"]], c("conc", "uptake")),
            selected = "uptake",
            multiple = FALSE,
            fixed = FALSE
          )
        )
      ),
      categorical_var = list(
        data_extract_spec(
          dataname = "CO2",
          filter = filter_spec(
            vars = vars,
            choices = value_choices(data[["CO2"]], vars$selected),
            selected = value_choices(data[["CO2"]], vars$selected),
            multiple = TRUE
          )
        )
      ),
      decorators = list(boxplot_decorator, cum_dist_decorator)
    )
  )
)
if (interactive()) {
  shinyApp(app$ui, app$server)
}

```

<details>

---------

Signed-off-by: André Veríssimo <[email protected]>
Co-authored-by: André Veríssimo <[email protected]>
  • Loading branch information
@m7pr @averissimo
m7pr and averissimo authored Nov 26, 2024
1 parent 18f1618 commit 817123a
Showing 1 changed file with 44 additions and 17 deletions.
61 changes: 44 additions & 17 deletions R/tm_outliers.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -17,11 +17,22 @@
#'
#' @inherit shared_params return
#'
#' @section Decorating `tm_outliers`:
#'
#' This module generates the following objects, which can be modified in place using decorators:
#' - `box_plot` (`ggplot2`)
#' - `density_plot` (`ggplot2`)
#' - `cum_dist_plot` (`ggplot2`)
#'
#' For additional details and examples of decorators, refer to the vignette
#' `vignette("decorate-modules-output", package = "teal")` or the [`teal_transform_module()`] documentation.
#'
#' @examplesShinylive
#' library(teal.modules.general)
#' interactive <- function() TRUE
#' {{ next_example }}
#' @examples
#'
#' # general data example
#' data <- teal_data()
#' data <- within(data, {
Expand Down Expand Up @@ -71,6 +82,7 @@
#' interactive <- function() TRUE
#' {{ next_example }}
#' @examples
#'
#' # CDISC data example
#' data <- teal_data()
#' data <- within(data, {
Expand All @@ -81,6 +93,8 @@
#' fact_vars_adsl <- names(Filter(isTRUE, sapply(data[["ADSL"]], is.factor)))
#' vars <- choices_selected(variable_choices(data[["ADSL"]], fact_vars_adsl))
#'
#'
#'
#' app <- init(
#' data = data,
#' modules = modules(
Expand Down Expand Up @@ -125,7 +139,8 @@ tm_outliers <- function(label = "Outliers Module",
plot_height = c(600, 200, 2000),
plot_width = NULL,
pre_output = NULL,
post_output = NULL) {
post_output = NULL,
decorators = NULL) {
message("Initializing tm_outliers")

# Normalize the parameters
Expand Down Expand Up @@ -162,6 +177,9 @@ tm_outliers <- function(label = "Outliers Module",

checkmate::assert_multi_class(pre_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
checkmate::assert_multi_class(post_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)

checkmate::assert_list(decorators, "teal_transform_module", null.ok = TRUE)

# End of assertions

# Make UI args
Expand All @@ -172,12 +190,16 @@ tm_outliers <- function(label = "Outliers Module",
categorical_var = categorical_var
)


ans <- module(
label = label,
server = srv_outliers,
server_args = c(
data_extract_list,
list(plot_height = plot_height, plot_width = plot_width, ggplot2_args = ggplot2_args)
list(
plot_height = plot_height, plot_width = plot_width, ggplot2_args = ggplot2_args,
decorators = decorators
)
),
ui = ui_outliers,
ui_args = args,
Expand All @@ -197,6 +219,7 @@ ui_outliers <- function(id, ...) {
output = teal.widgets::white_small_well(
uiOutput(ns("total_outliers")),
DT::dataTableOutput(ns("summary_table")),

uiOutput(ns("total_missing")),
tags$br(), tags$hr(),
tabsetPanel(
Expand Down Expand Up @@ -300,6 +323,7 @@ ui_outliers <- function(id, ...) {
uiOutput(ns("ui_outlier_help"))
)
),
ui_transform_teal_data(ns("decorate"), transformators = args$decorators),
teal.widgets::panel_item(
title = "Plot settings",
selectInput(
Expand All @@ -319,9 +343,10 @@ ui_outliers <- function(id, ...) {
)
}

# Server function for the outliers module
# Server function for the outliers module
srv_outliers <- function(id, data, reporter, filter_panel_api, outlier_var,
categorical_var, plot_height, plot_width, ggplot2_args) {
categorical_var, plot_height, plot_width, 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 @@ -761,7 +786,7 @@ srv_outliers <- function(id, data, reporter, filter_panel_api, outlier_var,
teal.code::eval_code(
common_code_q(),
substitute(
expr = g <- plot_call +
expr = box_plot <- plot_call +
scale_color_manual(values = c("TRUE" = "red", "FALSE" = "black")) +
labs + ggthemes + themes,
env = list(
Expand All @@ -771,8 +796,7 @@ srv_outliers <- function(id, data, reporter, filter_panel_api, outlier_var,
themes = parsed_ggplot2_args$theme
)
)
) %>%
teal.code::eval_code(quote(print(g)))
)
})

# density plot
Expand Down Expand Up @@ -823,16 +847,15 @@ srv_outliers <- function(id, data, reporter, filter_panel_api, outlier_var,
teal.code::eval_code(
common_code_q(),
substitute(
expr = g <- plot_call + labs + ggthemes + themes,
expr = density_plot <- plot_call + labs + ggthemes + themes,
env = list(
plot_call = plot_call,
labs = parsed_ggplot2_args$labs,
themes = parsed_ggplot2_args$theme,
ggthemes = parsed_ggplot2_args$ggtheme
)
)
) %>%
teal.code::eval_code(quote(print(g)))
)
})

# Cumulative distribution plot
Expand Down Expand Up @@ -925,7 +948,7 @@ srv_outliers <- function(id, data, reporter, filter_panel_api, outlier_var,
teal.code::eval_code(
qenv,
substitute(
expr = g <- plot_call +
expr = cum_dist_plot <- plot_call +
geom_point(data = outlier_points, aes(x = outlier_var_name, y = y, color = is_outlier_selected)) +
scale_color_manual(values = c("TRUE" = "red", "FALSE" = "black")) +
labs + ggthemes + themes,
Expand All @@ -937,8 +960,7 @@ srv_outliers <- function(id, data, reporter, filter_panel_api, outlier_var,
ggthemes = parsed_ggplot2_args$ggtheme
)
)
) %>%
teal.code::eval_code(quote(print(g)))
)
})

final_q <- reactive({
Expand Down Expand Up @@ -971,6 +993,8 @@ srv_outliers <- function(id, data, reporter, filter_panel_api, outlier_var,
)
})

decorated_final_q <- srv_transform_teal_data("decorate", data = final_q, transformators = decorators)

# slider text
output$ui_outlier_help <- renderUI({
req(input$method)
Expand Down Expand Up @@ -1021,15 +1045,18 @@ srv_outliers <- function(id, data, reporter, filter_panel_api, outlier_var,

boxplot_r <- reactive({
teal::validate_inputs(iv_r())
boxplot_q()[["g"]]
req(boxplot_q())
decorated_final_q()[["box_plot"]]
})
density_plot_r <- reactive({
teal::validate_inputs(iv_r())
density_plot_q()[["g"]]
req(density_plot_q())
decorated_final_q()[["density_plot"]]
})
cumulative_plot_r <- reactive({
teal::validate_inputs(iv_r())
cumulative_plot_q()[["g"]]
req(cumulative_plot_q())
decorated_final_q()[["cum_dist_plot"]]
})

box_pws <- teal.widgets::plot_with_settings_srv(
Expand Down Expand Up @@ -1217,7 +1244,7 @@ srv_outliers <- function(id, data, reporter, filter_panel_api, outlier_var,

teal.widgets::verbatim_popup_srv(
id = "rcode",
verbatim_content = reactive(teal.code::get_code(final_q())),
verbatim_content = reactive(teal.code::get_code(req(decorated_final_q()))),
title = "Show R Code for Outlier"
)

Expand Down Expand Up @@ -1249,7 +1276,7 @@ srv_outliers <- function(id, data, reporter, filter_panel_api, outlier_var,
card$append_text("Comment", "header3")
card$append_text(comment)
}
card$append_src(teal.code::get_code(final_q()))
card$append_src(teal.code::get_code(req(decorated_final_q())))
card
}
teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
Expand Down

0 comments on commit 817123a

Please sign in to comment.