Skip to content

Commit

Permalink
enable decorators for tm_a_pca
Browse files Browse the repository at this point in the history
  • Loading branch information
@m7pr
m7pr committed Nov 19, 2024
1 parent bf0af48 commit 1afa6e4
Showing 1 changed file with 46 additions and 16 deletions.
62 changes: 46 additions & 16 deletions R/tm_a_pca.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -18,11 +18,25 @@
#'
#' @inherit shared_params return
#'
#' @inheritSection tm_a_regression Decorating Module Outputs
#' @section Decorating `tm_a_pca`:
#'
#' This module creates below objects that can be modified with decorators:
#' - `plot` (`ggplot2`)
#'
#'
#' @examplesShinylive
#' library(teal.modules.general)
#' interactive <- function() TRUE
#' {{ next_example }}
#' @examples
#'
#' plot_title <- teal_transform_module(
#' server = make_teal_transform_server(expression(
#' plot <- plot + ggtilte("Custom title")
#' ))
#' )
#'
#' # general data example
#' data <- teal_data()
#' data <- within(data, {
Expand All @@ -45,7 +59,8 @@
#' multiple = TRUE
#' ),
#' filter = NULL
#' )
#' ),
#' decorators = list(plot_title)
#' )
#' )
#' )
Expand All @@ -58,6 +73,13 @@
#' interactive <- function() TRUE
#' {{ next_example }}
#' @examples
#'
#' plot_title <- teal_transform_module(
#' server = make_teal_transform_server(expression(
#' plot <- plot + ggtilte("Custom title")
#' ))
#' )
#'
#' # CDISC data example
#' data <- teal_data()
#' data <- within(data, {
Expand All @@ -81,7 +103,8 @@
#' multiple = TRUE
#' ),
#' filter = NULL
#' )
#' ),
#' decorators = list(plot_title)
#' )
#' )
#' )
Expand All @@ -102,7 +125,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 = list(default = teal_transform_module())) {
message("Initializing tm_a_pca")

# Normalize the parameters
Expand Down Expand Up @@ -152,6 +176,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")
# End of assertions

# Make UI args
Expand All @@ -169,7 +195,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 +251,8 @@ ui_a_pca <- function(id, ...) {
label = "Plot type",
choices = args$plot_choices,
selected = args$plot_choices[1]
)
),
ui_teal_transform_data(ns("decorator"), transformators = args$decorators)
),
teal.widgets::panel_item(
title = "Pre-processing",
Expand Down Expand Up @@ -289,7 +317,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 +577,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 @@ -570,7 +598,7 @@ srv_a_pca <- function(id, data, reporter, filter_panel_api, dat, plot_height, pl
ggthemes +
themes

print(g)
print(plot)
},
env = list(
ggthemes = parsed_ggplot2_args$ggtheme,
Expand Down Expand Up @@ -628,7 +656,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 +668,7 @@ srv_a_pca <- function(id, data, reporter, filter_panel_api, dat, plot_height, pl
labs +
ggthemes +
themes
print(g)
print(plot)
},
env = list(
x_axis = x_axis,
Expand Down Expand Up @@ -861,8 +889,8 @@ 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
print(plot)
},
env = list(
plot_call = Reduce(function(x, y) call("+", x, y), pca_plot_biplot_expr)
Expand Down Expand Up @@ -939,9 +967,9 @@ srv_a_pca <- function(id, data, reporter, filter_panel_api, dat, plot_height, pl
pca_rot <- pca$rotation[, pc, drop = FALSE] %>%
dplyr::as_tibble(rownames = "Variable")

g <- plot_call
plot <- plot_call

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

decorated_output_q <- srv_teal_transform_data("decorate", data = output_q, transformators = decorators)

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

pws <- teal.widgets::plot_with_settings_srv(
Expand Down Expand Up @@ -1034,7 +1064,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 Down

0 comments on commit 1afa6e4

Please sign in to comment.