Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

introduce decorators for tm_a_pca #798

Merged
merged 11 commits into from
Nov 22, 2024
Merged

introduce decorators for tm_a_pca #798

Changes from 10 commits
Commits
Show all changes
11 commits
Select commit Hold shift + click to select a range
1afa6e4
enable decorators for tm_a_pca
m7pr Nov 19, 2024
764c55f
Merge branch '1187_decorate_output@main' into tm_pca@1187_decorate_ou…
m7pr Nov 19, 2024
c37c2ad
remove decorators from examples
m7pr Nov 19, 2024
fd889ec
Update R/tm_a_pca.R
m7pr Nov 20, 2024
4dc4035
Merge branch '1187_decorate_output@main' into tm_pca@1187_decorate_ou…
m7pr Nov 20, 2024
4034445
update reported and change documentation
m7pr Nov 20, 2024
ddbc5a0
Merge branch '1187_decorate_output@main' into tm_pca@1187_decorate_ou…
m7pr Nov 21, 2024
2c661ea
add req statement so that when srv_teal_transform_data returns NULL y…
m7pr Nov 21, 2024
f9d93c0
remove print from the code, and add after the decorator
m7pr Nov 21, 2024
c7192de
Merge branch '1187_decorate_output@main' into tm_pca@1187_decorate_ou…
averissimo Nov 22, 2024
5f91224
Merge branch '1187_decorate_output@main' into tm_pca@1187_decorate_ou…
averissimo Nov 22, 2024
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
51 changes: 33 additions & 18 deletions R/tm_a_pca.R
View file
Open in desktop
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_teal_transform_data(ns("decorate"), transformators = args$decorators)
averissimo marked this conversation as resolved.
Show resolved Hide resolved
),
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,14 @@ srv_a_pca <- function(id, data, reporter, filter_panel_api, dat, plot_height, pl
)
})

decorated_output_q_no_print <- srv_teal_transform_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 +1049,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 +1072,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
Loading