Skip to content

Commit

Permalink
Merge branch '1187_decorate_output@main' into tm_outliers@1187_decora…
Browse files Browse the repository at this point in the history 
…te_output@main
  • Loading branch information
@m7pr
m7pr authored Nov 25, 2024
2 parents 6a36fe5 + 9ef1032 commit c657134
Show file tree
Hide file tree
Showing 19 changed files with 552 additions and 168 deletions.
49 changes: 31 additions & 18 deletions R/tm_a_pca.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -18,11 +18,21 @@
#'
#' @inherit shared_params return
#'
#' @section Decorating `tm_a_pca`:
#'
#' This module generates the following objects, which can be modified in place using decorators:
#' - `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 @@ -58,6 +68,7 @@
#' interactive <- function() TRUE
#' {{ next_example }}
#' @examples
#'
#' # CDISC data example
#' data <- teal_data()
#' data <- within(data, {
Expand Down Expand Up @@ -102,7 +113,8 @@ tm_a_pca <- function(label = "Principal Component Analysis",
alpha = c(1, 0, 1),
size = c(2, 1, 8),
pre_output = NULL,
post_output = NULL) {
post_output = NULL,
decorators = NULL) {
message("Initializing tm_a_pca")

# Normalize the parameters
Expand Down Expand Up @@ -152,6 +164,8 @@ tm_a_pca <- function(label = "Principal Component Analysis",

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 @@ -169,7 +183,8 @@ tm_a_pca <- function(label = "Principal Component Analysis",
list(
plot_height = plot_height,
plot_width = plot_width,
ggplot2_args = ggplot2_args
ggplot2_args = ggplot2_args,
decorators = decorators
)
),
datanames = teal.transform::get_extract_datanames(data_extract_list)
Expand Down Expand Up @@ -224,7 +239,8 @@ ui_a_pca <- function(id, ...) {
label = "Plot type",
choices = args$plot_choices,
selected = args$plot_choices[1]
)
),
ui_transform_teal_data(ns("decorate"), transformators = args$decorators)
),
teal.widgets::panel_item(
title = "Pre-processing",
Expand Down Expand Up @@ -289,7 +305,7 @@ ui_a_pca <- function(id, ...) {
}

# Server function for the PCA module
srv_a_pca <- function(id, data, reporter, filter_panel_api, dat, plot_height, plot_width, ggplot2_args) {
srv_a_pca <- function(id, data, reporter, filter_panel_api, dat, 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 @@ -549,7 +565,7 @@ srv_a_pca <- function(id, data, reporter, filter_panel_api, dat, plot_height, pl
)

cols <- c(getOption("ggplot2.discrete.colour"), c("lightblue", "darkred", "black"))[1:3]
g <- ggplot(mapping = aes_string(x = "component", y = "value")) +
plot <- ggplot(mapping = aes_string(x = "component", y = "value")) +
geom_bar(
aes(fill = "Single variance"),
data = dplyr::filter(elb_dat, metric == "Proportion of Variance"),
Expand All @@ -569,8 +585,6 @@ srv_a_pca <- function(id, data, reporter, filter_panel_api, dat, plot_height, pl
scale_fill_manual(values = c("Cumulative variance" = cols[2], "Single variance" = cols[1])) +
ggthemes +
themes

print(g)
},
env = list(
ggthemes = parsed_ggplot2_args$ggtheme,
Expand Down Expand Up @@ -628,7 +642,7 @@ srv_a_pca <- function(id, data, reporter, filter_panel_api, dat, plot_height, pl
y = sin(seq(0, 2 * pi, length.out = 100))
)

g <- ggplot(pca_rot) +
plot <- ggplot(pca_rot) +
geom_point(aes_string(x = x_axis, y = y_axis)) +
geom_label(
aes_string(x = x_axis, y = y_axis, label = "label"),
Expand All @@ -640,7 +654,6 @@ srv_a_pca <- function(id, data, reporter, filter_panel_api, dat, plot_height, pl
labs +
ggthemes +
themes
print(g)
},
env = list(
x_axis = x_axis,
Expand Down Expand Up @@ -861,8 +874,7 @@ srv_a_pca <- function(id, data, reporter, filter_panel_api, dat, plot_height, pl
qenv,
substitute(
expr = {
g <- plot_call
print(g)
plot <- plot_call
},
env = list(
plot_call = Reduce(function(x, y) call("+", x, y), pca_plot_biplot_expr)
Expand Down Expand Up @@ -938,10 +950,7 @@ srv_a_pca <- function(id, data, reporter, filter_panel_api, dat, plot_height, pl
expr = {
pca_rot <- pca$rotation[, pc, drop = FALSE] %>%
dplyr::as_tibble(rownames = "Variable")

g <- plot_call

print(g)
plot <- plot_call
},
env = list(
pc = pc,
Expand All @@ -966,8 +975,12 @@ srv_a_pca <- function(id, data, reporter, filter_panel_api, dat, plot_height, pl
)
})

decorated_output_q_no_print <- srv_transform_teal_data("decorate", data = output_q, transformators = decorators)
decorated_output_q <- reactive(within(decorated_output_q_no_print(), expr = print(plot)))

plot_r <- reactive({
output_q()[["g"]]
req(output_q())
decorated_output_q()[["plot"]]
})

pws <- teal.widgets::plot_with_settings_srv(
Expand Down Expand Up @@ -1034,7 +1047,7 @@ srv_a_pca <- function(id, data, reporter, filter_panel_api, dat, plot_height, pl

teal.widgets::verbatim_popup_srv(
id = "rcode",
verbatim_content = reactive(teal.code::get_code(output_q())),
verbatim_content = reactive(teal.code::get_code(req(decorated_output_q()))),
title = "R Code for PCA"
)

Expand All @@ -1057,7 +1070,7 @@ srv_a_pca <- function(id, data, reporter, filter_panel_api, dat, plot_height, pl
card$append_text("Comment", "header3")
card$append_text(comment)
}
card$append_src(teal.code::get_code(output_q()))
card$append_src(teal.code::get_code(req(decorated_output_q())))
card
}
teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
Expand Down
28 changes: 14 additions & 14 deletions R/tm_a_regression.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -292,37 +292,37 @@ ui_a_regression <- function(id, ...) {
conditionalPanel(
condition = "input.plot_type == 'Response vs Regressor'",
ns = ns,
ui_teal_transform_data(ns("d_0"), transformators = args$decorators[[1]])
ui_transform_teal_data(ns("d_0"), transformators = args$decorators)
),
conditionalPanel(
condition = "input.plot_type == 'Residuals vs Fitted'",
ns = ns,
ui_teal_transform_data(ns("d_1"), transformators = args$decorators[[1]])
ui_transform_teal_data(ns("d_1"), transformators = args$decorators)
),
conditionalPanel(
condition = "input.plot_type == 'Normal Q-Q'",
ns = ns,
ui_teal_transform_data(ns("d_2"), transformators = args$decorators[[1]])
ui_transform_teal_data(ns("d_2"), transformators = args$decorators)
),
conditionalPanel(
condition = "input.plot_type == 'Scale-Location'",
ns = ns,
ui_teal_transform_data(ns("d_3"), transformators = args$decorators[[1]])
ui_transform_teal_data(ns("d_3"), transformators = args$decorators)
),
conditionalPanel(
condition = "input.plot_type == 'Cook\\'s distance'",
ns = ns,
ui_teal_transform_data(ns("d_4"), transformators = args$decorators[[1]])
ui_transform_teal_data(ns("d_4"), transformators = args$decorators)
),
conditionalPanel(
condition = "input.plot_type == 'Residuals vs Leverage'",
ns = ns,
ui_teal_transform_data(ns("d_5"), transformators = args$decorators[[1]])
ui_transform_teal_data(ns("d_5"), transformators = args$decorators)
),
conditionalPanel(
condition = "input.plot_type == 'Cook\\'s dist vs Leverage'",
ns = ns,
ui_teal_transform_data(ns("d_6"), transformators = args$decorators[[1]])
ui_transform_teal_data(ns("d_6"), transformators = args$decorators)
),
),
checkboxInput(ns("show_outlier"), label = "Display outlier labels", value = TRUE),
Expand Down Expand Up @@ -1000,13 +1000,13 @@ srv_a_regression <- function(id,
)
})

decorated_output_0 <- srv_teal_transform_data(id = "d_0", data = output_plot_0, transformators = decorators[[1]])
decorated_output_1 <- srv_teal_transform_data(id = "d_1", data = output_plot_1, transformators = decorators[[1]])
decorated_output_2 <- srv_teal_transform_data(id = "d_2", data = output_plot_2, transformators = decorators[[1]])
decorated_output_3 <- srv_teal_transform_data(id = "d_3", data = output_plot_3, transformators = decorators[[1]])
decorated_output_4 <- srv_teal_transform_data(id = "d_4", data = output_plot_4, transformators = decorators[[1]])
decorated_output_5 <- srv_teal_transform_data(id = "d_5", data = output_plot_5, transformators = decorators[[1]])
decorated_output_6 <- srv_teal_transform_data(id = "d_6", data = output_plot_6, transformators = decorators[[1]])
decorated_output_0 <- srv_transform_teal_data(id = "d_0", data = output_plot_0, transformators = decorators)
decorated_output_1 <- srv_transform_teal_data(id = "d_1", data = output_plot_1, transformators = decorators)
decorated_output_2 <- srv_transform_teal_data(id = "d_2", data = output_plot_2, transformators = decorators)
decorated_output_3 <- srv_transform_teal_data(id = "d_3", data = output_plot_3, transformators = decorators)
decorated_output_4 <- srv_transform_teal_data(id = "d_4", data = output_plot_4, transformators = decorators)
decorated_output_5 <- srv_transform_teal_data(id = "d_5", data = output_plot_5, transformators = decorators)
decorated_output_6 <- srv_transform_teal_data(id = "d_6", data = output_plot_6, transformators = decorators)


output_q <- reactive({
Expand Down
Loading

0 comments on commit c657134

Please sign in to comment.