diff --git a/R/roxygen2_templates.R b/R/roxygen2_templates.R new file mode 100644 index 000000000..d55c2aef4 --- /dev/null +++ b/R/roxygen2_templates.R @@ -0,0 +1,30 @@ +# nocov start +roxygen_decorators_param <- function(module_name) { + paste( + sep = " ", + lifecycle::badge("experimental"), + " (`list` of `teal_transform_module`, named `list` of `teal_transform_module` or", + "`NULL`) optional, if not `NULL`, decorator for tables or plots included in the module.", + "When a named list of `teal_transform_module`, the decorators are applied to the", + "respective output objects.\n\n", + "Otherwise, the decorators are applied to all objects, which is equivalent as using the name `default`.\n\n", + sprintf("See section \"Decorating `%s`\"", module_name), + "below for more details." + ) +} + +roxygen_ggplot2_args_param <- function(...) { + paste( + sep = " ", + "(`ggplot2_args`) optional, object created by [`teal.widgets::ggplot2_args()`]", + "with settings for all the plots or named list of `ggplot2_args` objects for plot-specific settings.", + "The argument is merged with options variable `teal.ggplot2_args` and default module setup.\n\n", + sprintf( + "List names should match the following: `c(\"default\", %s)`.\n\n", + paste("\"", unlist(rlang::list2(...)), "\"", collapse = ", ", sep = "") + ), + "For more details see the vignette: `vignette(\"custom-ggplot2-arguments\", package = \"teal.widgets\")`." + ) +} + +# nocov end diff --git a/R/tm_a_pca.R b/R/tm_a_pca.R index 9cccffe02..c6a7fb55e 100644 --- a/R/tm_a_pca.R +++ b/R/tm_a_pca.R @@ -13,20 +13,40 @@ #' It controls the font size for plot titles, axis labels, and legends. #' - If vector of `length == 1` then the font sizes will have a fixed size. #' - while vector of `value`, `min`, and `max` allows dynamic adjustment. -#' @templateVar ggnames "Elbow plot", "Circle plot", "Biplot", "Eigenvector plot" -#' @template ggplot2_args_multi +#' @param ggplot2_args `r roxygen_ggplot2_args_param("Elbow plot", "Circle plot", "Biplot", "Eigenvector plot")` +#' @param decorators `r roxygen_decorators_param("tm_a_pca")` #' #' @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`) +#' - `elbow_plot` (`ggplot2`) +#' - `circle_plot` (`ggplot2`) +#' - `biplot` (`ggplot2`) +#' - `eigenvector_plot` (`ggplot2`) +#' +#' 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_pca( +#' ..., # arguments for module +#' decorators = list( +#' default = list(teal_transform_module(...)), # applied to all outputs +#' elbow_plot = list(teal_transform_module(...)), # applied only to `elbow_plot` output +#' circle_plot = list(teal_transform_module(...)) # applied only to `circle_plot` output +#' biplot = list(teal_transform_module(...)) # applied only to `biplot` output +#' eigenvector_plot = list(teal_transform_module(...)) # applied only to `eigenvector_plot` output +#' ) +#' ) +#' ``` #' #' 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 @@ -165,7 +185,9 @@ 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) + available_decorators <- c("elbow_plot", "circle_plot", "biplot", "eigenvector_plot") + decorators <- normalize_decorators(decorators) + assert_decorators(decorators, null.ok = TRUE, available_decorators) # End of assertions # Make UI args @@ -240,7 +262,34 @@ ui_a_pca <- function(id, ...) { choices = args$plot_choices, selected = args$plot_choices[1] ), - ui_transform_teal_data(ns("decorate"), transformators = args$decorators) + conditionalPanel( + condition = sprintf("input['%s'] == 'Elbow plot'", ns("plot_type")), + ui_decorate_teal_data( + ns("d_elbow_plot"), + decorators = select_decorators(args$decorators, "elbow_plot") + ) + ), + conditionalPanel( + condition = sprintf("input['%s'] == 'Circle plot'", ns("plot_type")), + ui_decorate_teal_data( + ns("d_circle_plot"), + decorators = select_decorators(args$decorators, "circle_plot") + ) + ), + conditionalPanel( + condition = sprintf("input['%s'] == 'Biplot'", ns("plot_type")), + ui_decorate_teal_data( + ns("d_biplot"), + decorators = select_decorators(args$decorators, "biplot") + ) + ), + conditionalPanel( + condition = sprintf("input['%s'] == 'Eigenvector plot'", ns("plot_type")), + ui_decorate_teal_data( + ns("d_eigenvector_plot"), + decorators = select_decorators(args$decorators, "eigenvector_plot") + ) + ) ), teal.widgets::panel_item( title = "Pre-processing", @@ -565,7 +614,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] - plot <- ggplot(mapping = aes_string(x = "component", y = "value")) + + elbow_plot <- ggplot(mapping = aes_string(x = "component", y = "value")) + geom_bar( aes(fill = "Single variance"), data = dplyr::filter(elb_dat, metric == "Proportion of Variance"), @@ -642,7 +691,7 @@ srv_a_pca <- function(id, data, reporter, filter_panel_api, dat, plot_height, pl y = sin(seq(0, 2 * pi, length.out = 100)) ) - plot <- ggplot(pca_rot) + + circle_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"), @@ -874,7 +923,7 @@ srv_a_pca <- function(id, data, reporter, filter_panel_api, dat, plot_height, pl qenv, substitute( expr = { - plot <- plot_call + biplot <- plot_call }, env = list( plot_call = Reduce(function(x, y) call("+", x, y), pca_plot_biplot_expr) @@ -883,8 +932,8 @@ srv_a_pca <- function(id, data, reporter, filter_panel_api, dat, plot_height, pl ) } - # plot pc_var ---- - plot_pc_var <- function(base_q) { + # plot eigenvector_plot ---- + plot_eigenvector <- function(base_q) { pc <- input$pc ggtheme <- input$ggtheme @@ -950,7 +999,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") - plot <- plot_call + eigenvector_plot <- plot_call }, env = list( pc = pc, @@ -960,27 +1009,54 @@ srv_a_pca <- function(id, data, reporter, filter_panel_api, dat, plot_height, pl ) } - # plot final ---- - output_q <- reactive({ - req(computation()) - teal::validate_inputs(iv_r()) - teal::validate_inputs(iv_extra, header = "Plot settings are required") + # qenvs --- + output_q <- lapply( + list( + elbow_plot = plot_elbow, + circle_plot = plot_circle, + biplot = plot_biplot, + eigenvector_plot = plot_eigenvector + ), + function(fun) { + reactive({ + req(computation()) + teal::validate_inputs(iv_r()) + teal::validate_inputs(iv_extra, header = "Plot settings are required") + fun(computation()) + }) + } + ) + + decorated_q <- mapply( + function(obj_name, q) { + srv_decorate_teal_data( + id = sprintf("d_%s", obj_name), + data = q, + decorators = select_decorators(decorators, obj_name), + expr = reactive({ + substitute(print(.plot), env = list(.plot = as.name(obj_name))) + }), + expr_is_reactive = TRUE + ) + }, + names(output_q), + output_q + ) - switch(input$plot_type, - "Elbow plot" = plot_elbow(computation()), - "Circle plot" = plot_circle(computation()), - "Biplot" = plot_biplot(computation()), - "Eigenvector plot" = plot_pc_var(computation()), + # plot final ---- + decorated_output_q <- reactive({ + switch(req(input$plot_type), + "Elbow plot" = decorated_q$elbow_plot(), + "Circle plot" = decorated_q$circle_plot(), + "Biplot" = decorated_q$biplot(), + "Eigenvector plot" = decorated_q$eigenvector_plot(), stop("Unknown plot") ) }) - 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({ - req(output_q()) - decorated_output_q()[["plot"]] + plot_name <- gsub(" ", "_", tolower(req(input$plot_type))) + req(decorated_output_q())[[plot_name]] }) pws <- teal.widgets::plot_with_settings_srv( diff --git a/R/tm_a_regression.R b/R/tm_a_regression.R index b0e4d49ec..4c5368243 100644 --- a/R/tm_a_regression.R +++ b/R/tm_a_regression.R @@ -37,8 +37,10 @@ #' It takes the form of `c(value, min, max)` and it is passed to the `value_min_max` #' argument in `teal.widgets::optionalSliderInputValMinMax`. #' -#' @templateVar ggnames `r regression_names` -#' @template ggplot2_args_multi +# nolint start: line_length. +#' @param ggplot2_args `r roxygen_ggplot2_args_param("Response vs Regressor", "Residuals vs Fitted", "Scale-Location", "Cook's distance", "Residuals vs Leverage", "Cook's dist vs Leverage")` +# nolint end: line_length. +#' @param decorators `r roxygen_decorators_param("tm_a_regression")` #' #' @inherit shared_params return #' @@ -1034,8 +1036,3 @@ srv_a_regression <- function(id, ### }) } - -regression_names <- paste0( - '"Response vs Regressor", "Residuals vs Fitted", ', - '"Scale-Location", "Cook\'s distance", "Residuals vs Leverage"", "Cook\'s dist vs Leverage"' -) diff --git a/R/tm_data_table.R b/R/tm_data_table.R index 657d5bf6d..0adbcccdc 100644 --- a/R/tm_data_table.R +++ b/R/tm_data_table.R @@ -131,7 +131,8 @@ tm_data_table <- function(label = "Data Table", 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) + decorators <- normalize_decorators(decorators) + assert_decorators(decorators, null.ok = TRUE, "table") # End of assertions ans <- module( @@ -296,7 +297,7 @@ ui_data_table <- function(id, tagList( teal.widgets::get_dt_rows(ns("data_table"), ns("dt_rows")), fluidRow( - ui_transform_teal_data(ns("decorate"), transformators = decorators), + ui_decorate_teal_data(ns("decorator"), decorators = select_decorators(decorators, "table")), teal.widgets::optionalSelectInput( ns("variables"), "Select variables:", @@ -365,13 +366,15 @@ srv_data_table <- function(id, ) }) - decorated_data_table_data <- - srv_transform_teal_data("decorate", data = data_table_data, transformators = decorators) + decorated_data_table_data <- srv_decorate_teal_data( + id = "decorator", + data = data_table_data, + decorators = select_decorators(decorators, "table") + ) output$data_table <- DT::renderDataTable(server = server_rendering, { - req(data_table_data()) teal::validate_inputs(iv) - decorated_data_table_data()[["table"]] + req(decorated_data_table_data())[["table"]] }) }) } diff --git a/R/tm_g_association.R b/R/tm_g_association.R index faa79ce1c..9110cc182 100644 --- a/R/tm_g_association.R +++ b/R/tm_g_association.R @@ -20,16 +20,15 @@ #' @param distribution_theme,association_theme (`character`) optional, `ggplot2` themes to be used by default. #' Default to `"gray"`. #' -#' @templateVar ggnames "Bivariate1", "Bivariate2" -#' @template ggplot2_args_multi +#' @param ggplot2_args `r roxygen_ggplot2_args_param("Bivariate1", "Bivariate2")` +#' @param decorators `r roxygen_decorators_param("tm_")` #' #' @inherit shared_params return #' #' @section Decorating `tm_g_association`: #' #' This module generates the following objects, which can be modified in place using decorators: -#' - `plot_top` (`ggplot2`) -#' - `plot_bottom` (`ggplot2`) +#' - `plot` (`grob` created with [ggplot2::ggplotGrob()]) #' #' For additional details and examples of decorators, refer to the vignette #' `vignette("decorate-modules-output", package = "teal")` or the [`teal_transform_module()`] documentation. @@ -176,7 +175,10 @@ tm_g_association <- function(label = "Association", plot_choices <- c("Bivariate1", "Bivariate2") checkmate::assert_list(ggplot2_args, types = "ggplot2_args") checkmate::assert_subset(names(ggplot2_args), c("default", plot_choices)) - checkmate::assert_list(decorators, "teal_transform_module", null.ok = TRUE) + + decorators <- normalize_decorators(decorators) + assert_decorators(decorators, null.ok = TRUE, "plot") + # End of assertions # Make UI args @@ -247,7 +249,7 @@ ui_tm_g_association <- function(id, ...) { "Log transformed", value = FALSE ), - ui_transform_teal_data(ns("decorate"), transformators = args$decorators), + ui_decorate_teal_data(ns("decorator"), decorators = select_decorators(args$decorators, "plot")), teal.widgets::panel_group( teal.widgets::panel_item( title = "Plot settings", @@ -405,8 +407,6 @@ srv_tm_g_association <- function(id, # association ref_class_cov <- ifelse(association, ref_class, "NULL") - print_call <- quote(print(p)) - var_calls <- lapply(vars_names, function(var_i) { var_class <- class(ANL[[var_i]])[1] if (is.numeric(ANL[[var_i]]) && log_transformation) { @@ -488,6 +488,7 @@ srv_tm_g_association <- function(id, expr = { plot_top <- plot_calls[[1]] plot_bottom <- plot_calls[[1]] + plot <- tern::stack_grobs(grobs = lapply(list(plot_top, plot_bottom), ggplotGrob)) }, env = list( plot_calls = do.call( @@ -500,23 +501,19 @@ srv_tm_g_association <- function(id, ) }) - decorated_output_q <- srv_transform_teal_data("decorate", data = output_q, transformators = decorators) - decorated_output_grob_q <- reactive({ - within( - decorated_output_q(), - { - plot <- tern::stack_grobs(grobs = lapply(list(plot_top, plot_bottom), ggplotGrob)) - grid::grid.newpage() - grid::grid.draw(plot) - } - ) - }) - + decorated_output_grob_q <- srv_decorate_teal_data( + id = "decorator", + data = output_q, + decorators = select_decorators(decorators, "plot"), + expr = { + grid::grid.newpage() + grid::grid.draw(plot) + } + ) plot_r <- reactive({ req(iv_r()$is_valid()) - req(output_q()) - decorated_output_grob_q()[["plot"]] + req(decorated_output_grob_q())[["plot"]] }) pws <- teal.widgets::plot_with_settings_srv( diff --git a/R/tm_g_bivariate.R b/R/tm_g_bivariate.R index 390640dd6..447a574d8 100644 --- a/R/tm_g_bivariate.R +++ b/R/tm_g_bivariate.R @@ -276,7 +276,8 @@ tm_g_bivariate <- function(label = "Bivariate Plots", 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) + decorators <- normalize_decorators(decorators) + assert_decorators(decorators, null.ok = TRUE, "plot") # End of assertions # Make UI args @@ -350,7 +351,7 @@ ui_g_bivariate <- function(id, ...) { justified = TRUE ) ), - ui_transform_teal_data(ns("decorate"), transformators = args$decorators), + ui_decorate_teal_data(ns("decorator"), decorators = select_decorators(args$decorators, "plot")), if (!is.null(args$row_facet) || !is.null(args$col_facet)) { tags$div( class = "data-extract-box", @@ -665,47 +666,46 @@ srv_g_bivariate <- function(id, teal.code::eval_code(merged$anl_q_r(), substitute(expr = plot <- cl, env = list(cl = cl))) }) - decorated_output_q <- srv_transform_teal_data("decorate", data = output_q, transformators = decorators) - - decorated_output_q_facets <- reactive({ - ANL <- merged$anl_q_r()[["ANL"]] - row_facet_name <- as.vector(merged$anl_input_r()$columns_source$row_facet) - col_facet_name <- as.vector(merged$anl_input_r()$columns_source$col_facet) - - # Add labels to facets - nulled_row_facet_name <- varname_w_label(row_facet_name, ANL) - nulled_col_facet_name <- varname_w_label(col_facet_name, ANL) - facetting <- (isTRUE(input$facetting) && (!is.null(row_facet_name) || !is.null(col_facet_name))) - without_facet <- (is.null(nulled_row_facet_name) && is.null(nulled_col_facet_name)) || !facetting - - print_call <- if (without_facet) { - quote(print(plot)) - } else { - substitute( - expr = { - # Add facetting labels - # optional: grid.newpage() # nolint: commented_code. - # Prefixed with teal.modules.general as its usage will appear in "Show R code" - plot <- teal.modules.general::add_facet_labels( - plot, - xfacet_label = nulled_col_facet_name, - yfacet_label = nulled_row_facet_name - ) - grid::grid.newpage() - grid::grid.draw(plot) - }, - env = list(nulled_col_facet_name = nulled_col_facet_name, nulled_row_facet_name = nulled_row_facet_name) - ) - } - decorated_output_q() %>% - teal.code::eval_code(print_call) - }) - + decorated_output_q_facets <- srv_decorate_teal_data( + "decorator", + data = output_q, + decorators = select_decorators(decorators, "plot"), + expr = reactive({ + ANL <- merged$anl_q_r()[["ANL"]] + row_facet_name <- as.vector(merged$anl_input_r()$columns_source$row_facet) + col_facet_name <- as.vector(merged$anl_input_r()$columns_source$col_facet) + + # Add labels to facets + nulled_row_facet_name <- varname_w_label(row_facet_name, ANL) + nulled_col_facet_name <- varname_w_label(col_facet_name, ANL) + facetting <- (isTRUE(input$facetting) && (!is.null(row_facet_name) || !is.null(col_facet_name))) + without_facet <- (is.null(nulled_row_facet_name) && is.null(nulled_col_facet_name)) || !facetting + + print_call <- if (without_facet) { + quote(print(plot)) + } else { + substitute( + expr = { + # Add facetting labels + # optional: grid.newpage() # nolint: commented_code. + # Prefixed with teal.modules.general as its usage will appear in "Show R code" + plot <- teal.modules.general::add_facet_labels( + plot, + xfacet_label = nulled_col_facet_name, + yfacet_label = nulled_row_facet_name + ) + grid::grid.newpage() + grid::grid.draw(plot) + }, + env = list(nulled_col_facet_name = nulled_col_facet_name, nulled_row_facet_name = nulled_row_facet_name) + ) + } + print_call + }), + expr_is_reactive = TRUE + ) - plot_r <- reactive({ - req(output_q()) - decorated_output_q_facets()[["plot"]] - }) + plot_r <- reactive(req(decorated_output_q_facets())[["plot"]]) pws <- teal.widgets::plot_with_settings_srv( id = "myplot", diff --git a/R/tm_g_distribution.R b/R/tm_g_distribution.R index 8dc670d03..099c2dcfd 100644 --- a/R/tm_g_distribution.R +++ b/R/tm_g_distribution.R @@ -22,17 +22,36 @@ #' and `max`. #' Defaults to `c(30L, 1L, 100L)`. #' -#' @templateVar ggnames "Histogram", "QQplot" -#' @template ggplot2_args_multi +#' @param ggplot2_args `r roxygen_ggplot2_args_param("Histogram", "QQplot")` +#' @param decorators `r roxygen_decorators_param("tm_g_distribution")` #' #' @inherit shared_params return #' #' @section Decorating `tm_outliers`: #' -#' This module generates the following objects, which can be modified in place using decorators: -#' - `plot` (`ggplot2`) -#' - `test_table` (`data.frame`) +#' This module generates the following objects, which can be modified in place using decorators:: +#' - `histogram_plot` (`ggplot2`) +#' - `qq_plot` (`data.frame`) #' - `summary_table` (`data.frame`) +#' - `test_table` (`data.frame`) +#' +#' 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_g_distribution( +#' ..., # arguments for module +#' decorators = list( +#' default = list(teal_transform_module(...)), # applied to all outputs +#' histogram_plot = list(teal_transform_module(...)), # applied only to `histogram_plot` output +#' qq_plot = list(teal_transform_module(...)) # applied only to `qq_plot` output +#' summary_table = list(teal_transform_module(...)) # applied only to `summary_table` output +#' test_table = list(teal_transform_module(...)) # applied only to `test_table` output +#' ) +#' ) +#' ``` #' #' For additional details and examples of decorators, refer to the vignette #' `vignette("decorate-modules-output", package = "teal")` or the [`teal_transform_module()`] documentation. @@ -184,7 +203,10 @@ tm_g_distribution <- function(label = "Distribution 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) + available_decorators <- c("histogram_plot", "qq_plot", "test_table", "summary_table") + decorators <- normalize_decorators(decorators) + assert_decorators(decorators, null.ok = TRUE, names = available_decorators) + # End of assertions # Make UI args @@ -280,7 +302,10 @@ ui_distribution <- function(id, ...) { inline = TRUE ), checkboxInput(ns("add_dens"), label = "Overlay Density", value = TRUE), - ui_transform_teal_data(ns("d_dist"), transformators = args$decorators), + ui_decorate_teal_data( + ns("d_density"), + decorators = select_decorators(args$decorators, "histogram_plot") + ), collapsed = FALSE ) ), @@ -289,10 +314,21 @@ ui_distribution <- function(id, ...) { teal.widgets::panel_item( "QQ Plot", checkboxInput(ns("qq_line"), label = "Add diagonal line(s)", TRUE), - ui_transform_teal_data(ns("d_qq"), transformators = args$decorators), + ui_decorate_teal_data( + ns("d_qq"), + decorators = select_decorators(args$decorators, "qq_plot") + ), collapsed = FALSE ) ), + ui_decorate_teal_data( + ns("d_summary"), + decorators = select_decorators(args$decorators, "summary_table") + ), + ui_decorate_teal_data( + ns("d_test"), + decorators = select_decorators(args$decorators, "test_table") + ), conditionalPanel( condition = paste0("input['", ns("main_type"), "'] == 'Density'"), teal.widgets::panel_item( @@ -677,12 +713,12 @@ srv_distribution <- function(id, ) } - if (length(s_var) == 0 && length(g_var) == 0) { - qenv <- teal.code::eval_code( + qenv <- if (length(s_var) == 0 && length(g_var) == 0) { + teal.code::eval_code( qenv, substitute( expr = { - summary_table <- ANL %>% + summary_table_data <- ANL %>% dplyr::summarise( min = round(min(dist_var_name, na.rm = TRUE), roundn), median = round(stats::median(dist_var_name, na.rm = TRUE), roundn), @@ -699,12 +735,12 @@ srv_distribution <- function(id, ) ) } else { - qenv <- teal.code::eval_code( + teal.code::eval_code( qenv, substitute( expr = { strata_vars <- strata_vars_raw - summary_table <- ANL %>% + summary_table_data <- ANL %>% dplyr::group_by_at(dplyr::vars(dplyr::any_of(strata_vars))) %>% dplyr::summarise( min = round(min(dist_var_name, na.rm = TRUE), roundn), @@ -714,7 +750,6 @@ srv_distribution <- function(id, sd = round(stats::sd(dist_var_name, na.rm = TRUE), roundn), count = dplyr::n() ) - summary_table # used to display table when running show-r-code code }, env = list( dist_var_name = dist_var_name, @@ -724,6 +759,20 @@ srv_distribution <- function(id, ) ) } + if (iv_r()$is_valid()) { + within(qenv, { + summary_table <- DT::datatable( + summary_table_data, + options = list( + autoWidth = TRUE, + columnDefs = list(list(width = "200px", targets = "_all")) + ), + rownames = FALSE + ) + }) + } else { + within(qenv, summary_table <- NULL) + } }) # distplot qenv ---- @@ -913,7 +962,7 @@ srv_distribution <- function(id, teal.code::eval_code( qenv, substitute( - expr = plot <- plot_call, + expr = histogram_plot <- plot_call, env = list(plot_call = Reduce(function(x, y) call("+", x, y), c(plot_call, parsed_ggplot2_args))) ) ) @@ -1042,7 +1091,7 @@ srv_distribution <- function(id, teal.code::eval_code( qenv, substitute( - expr = plot <- plot_call, + expr = qq_plot <- plot_call, env = list(plot_call = Reduce(function(x, y) call("+", x, y), c(plot_call, parsed_ggplot2_args))) ) ) @@ -1191,7 +1240,7 @@ srv_distribution <- function(id, qenv, substitute( expr = { - test_table <- ANL %>% + test_table_data <- ANL %>% dplyr::select(dist_var) %>% with(., broom::glance(do.call(test, args))) %>% dplyr::mutate_if(is.numeric, round, 3) @@ -1204,7 +1253,7 @@ srv_distribution <- function(id, qenv, substitute( expr = { - test_table <- ANL %>% + test_table_data <- ANL %>% dplyr::select(dist_var, s_var, g_var) %>% dplyr::group_by_at(dplyr::vars(dplyr::any_of(groups))) %>% dplyr::do(tests = broom::glance(do.call(test, args))) %>% @@ -1215,9 +1264,6 @@ srv_distribution <- function(id, ) ) } - qenv %>% - # used to display table when running show-r-code code - teal.code::eval_code(quote(test_table)) } ) @@ -1227,32 +1273,39 @@ srv_distribution <- function(id, # wrapped in if since could lead into validate error - we do want to continue test_q_out <- try(test_q(), silent = TRUE) if (!inherits(test_q_out, c("try-error", "error"))) { - c(common_q(), test_q_out) + c( + common_q(), + within(test_q_out, { + test_table <- DT::datatable( + test_table_data, + options = list(scrollX = TRUE), + rownames = FALSE + ) + }) + ) } else { - common_q() + within(common_q(), test_table <- NULL) } }) output_dist_q <- reactive(c(output_common_q(), req(dist_q()))) output_qq_q <- reactive(c(output_common_q(), req(qq_q()))) - decorated_output_dist_q_no_print <- srv_transform_teal_data( - "d_dist", + decorated_output_dist_q <- srv_decorate_teal_data( + "d_density", data = output_dist_q, - transformators = decorators + decorators = select_decorators(decorators, "histogram_plot"), + expr = print(histogram_plot) ) - decorated_output_dist_q <- reactive(within(req(decorated_output_dist_q_no_print()), expr = print(plot))) - - decorated_output_qq_q_no_print <- srv_transform_teal_data( + decorated_output_qq_q <- srv_decorate_teal_data( "d_qq", data = output_qq_q, - transformators = decorators + decorators = select_decorators(decorators, "qq_plot"), + expr = print(qq_plot) ) - decorated_output_qq_q <- reactive(within(req(decorated_output_qq_q_no_print()), expr = print(plot))) - - decorated_output_q <- reactive({ + decorated_output_q_base <- reactive({ tab <- req(input$tabs) # tab is NULL upon app launch, hence will crash without this statement if (tab == "Histogram") { decorated_output_dist_q() @@ -1261,30 +1314,31 @@ srv_distribution <- function(id, } }) - dist_r <- reactive({ - req(output_dist_q()) # Ensure original errors are displayed - decorated_output_dist_q()[["plot"]] - }) - - qq_r <- reactive({ - req(output_qq_q()) # Ensure original errors are displayed - decorated_output_qq_q()[["plot"]] - }) + decorated_output_q_summary <- srv_decorate_teal_data( + "d_summary", + data = decorated_output_q_base, + decorators = select_decorators(decorators, "summary_table"), + expr = summary_table + ) - output$summary_table <- DT::renderDataTable( - expr = if (iv_r()$is_valid()) decorated_output_dist_q()[["summary_table"]] else NULL, - options = list( - autoWidth = TRUE, - columnDefs = list(list(width = "200px", targets = "_all")) - ), - rownames = FALSE + decorated_output_q <- srv_decorate_teal_data( + "d_test", + data = decorated_output_q_summary, + decorators = select_decorators(decorators, "test_table"), + expr = test_table ) + dist_r <- reactive(req(decorated_output_dist_q())[["histogram_plot"]]) + + qq_r <- reactive(req(decorated_output_qq_q())[["qq_plot"]]) + + output$summary_table <- DT::renderDataTable(expr = decorated_output_q()[["summary_table"]]) + tests_r <- reactive({ req(iv_r()$is_valid()) teal::validate_inputs(iv_r_dist()) req(test_q()) # Ensure original errors are displayed - decorated_output_dist_q()[["test_table"]] + decorated_output_q()[["test_table"]] }) pws1 <- teal.widgets::plot_with_settings_srv( @@ -1304,9 +1358,7 @@ srv_distribution <- function(id, ) output$t_stats <- DT::renderDataTable( - expr = tests_r(), - options = list(scrollX = TRUE), - rownames = FALSE + expr = tests_r() ) teal.widgets::verbatim_popup_srv( diff --git a/R/tm_g_response.R b/R/tm_g_response.R index 18f8d6d6d..c765de9ea 100644 --- a/R/tm_g_response.R +++ b/R/tm_g_response.R @@ -201,7 +201,8 @@ tm_g_response <- function(label = "Response Plot", 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) + decorators <- normalize_decorators(decorators) + assert_decorators(decorators, null.ok = TRUE, "plot") # End of assertions # Make UI args @@ -285,7 +286,7 @@ ui_g_response <- function(id, ...) { selected = ifelse(args$freq, "frequency", "density"), justified = TRUE ), - ui_transform_teal_data(ns("decorator"), transformators = args$decorators), + ui_decorate_teal_data(ns("decorator"), decorators = select_decorators(args$decorators, "plot")), teal.widgets::panel_group( teal.widgets::panel_item( title = "Plot settings", @@ -552,13 +553,14 @@ srv_g_response <- function(id, teal.code::eval_code(qenv, plot_call) }) - decorated_output_q <- srv_transform_teal_data(id = "decorator", data = output_q, transformators = decorators) + decorated_output_plot_q <- srv_decorate_teal_data( + id = "decorator", + data = output_q, + decorators = select_decorators(decorators, "plot"), + expr = print(plot) + ) - decorated_output_plot_q <- reactive(within(decorated_output_q(), print(plot))) - plot_r <- reactive({ - req(output_q()) # Ensure original errors are displayed - decorated_output_plot_q()[["plot"]] - }) + plot_r <- reactive(req(decorated_output_plot_q())[["plot"]]) # Insert the plot into a plot_with_settings module from teal.widgets pws <- teal.widgets::plot_with_settings_srv( diff --git a/R/tm_g_scatterplot.R b/R/tm_g_scatterplot.R index 3e3f69de4..f87adb13d 100644 --- a/R/tm_g_scatterplot.R +++ b/R/tm_g_scatterplot.R @@ -307,7 +307,10 @@ tm_g_scatterplot <- function(label = "Scatterplot", checkmate::assert_scalar(table_dec) checkmate::assert_class(ggplot2_args, "ggplot2_args") - checkmate::assert_list(decorators, "teal_transform_module", null.ok = TRUE) + + decorators <- normalize_decorators(decorators) + assert_decorators(decorators, null.ok = TRUE, "plot") + # End of assertions # Make UI args @@ -430,7 +433,7 @@ ui_g_scatterplot <- function(id, ...) { is_single_dataset = is_single_dataset_value ) }, - ui_transform_teal_data(ns("decorator"), transformators = args$decorators), + ui_decorate_teal_data(ns("decorator"), decorators = select_decorators(args$decorators, "plot")), teal.widgets::panel_group( teal.widgets::panel_item( title = "Plot settings", @@ -1005,12 +1008,14 @@ srv_g_scatterplot <- function(id, teal.code::eval_code(plot_q, plot_call) }) - decorated_output_q <- srv_transform_teal_data(id = "decorator", data = output_q, transformators = decorators) - decorated_output_plot_q <- reactive(within(decorated_output_q(), print(plot))) - plot_r <- reactive({ - req(output_q()) # Ensure original errors are displayed - decorated_output_plot_q()[["plot"]] - }) + decorated_output_plot_q <- srv_decorate_teal_data( + id = "decorator", + data = output_q, + decorators = select_decorators(decorators, "plot"), + expr = print(plot) + ) + + plot_r <- reactive(req(decorated_output_plot_q())[["plot"]]) # Insert the plot into a plot_with_settings module from teal.widgets pws <- teal.widgets::plot_with_settings_srv( diff --git a/R/tm_g_scatterplotmatrix.R b/R/tm_g_scatterplotmatrix.R index 0c2a563e1..64942a0f2 100644 --- a/R/tm_g_scatterplotmatrix.R +++ b/R/tm_g_scatterplotmatrix.R @@ -202,7 +202,9 @@ tm_g_scatterplotmatrix <- function(label = "Scatterplot Matrix", 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) + + decorators <- normalize_decorators(decorators) + assert_decorators(decorators, null.ok = TRUE, "plot") # End of assertions # Make UI args @@ -249,7 +251,7 @@ ui_g_scatterplotmatrix <- function(id, ...) { is_single_dataset = is_single_dataset_value ), tags$hr(), - ui_transform_teal_data(ns("decorator"), transformators = args$decorators), + ui_decorate_teal_data(ns("decorator"), decorators = select_decorators(args$decorators, "plot")), teal.widgets::panel_group( teal.widgets::panel_item( title = "Plot settings", @@ -444,12 +446,14 @@ srv_g_scatterplotmatrix <- function(id, qenv }) - decorated_output_q_no_print <- srv_transform_teal_data(id = "decorator", data = output_q, transformators = decorators) - decorated_output_q <- reactive(within(decorated_output_q_no_print(), print(plot))) - plot_r <- reactive({ - req(output_q()) # Ensure original errors are displayed - decorated_output_q()[["plot"]] - }) + decorated_output_q <- srv_decorate_teal_data( + id = "decorator", + data = output_q, + decorators = select_decorators(decorators, "plot"), + expr = print(plot) + ) + + plot_r <- reactive(req(decorated_output_q())[["plot"]]) # Insert the plot into a plot_with_settings module pws <- teal.widgets::plot_with_settings_srv( diff --git a/R/tm_missing_data.R b/R/tm_missing_data.R index 027ba182b..34f41d61c 100644 --- a/R/tm_missing_data.R +++ b/R/tm_missing_data.R @@ -10,21 +10,41 @@ #' @param parent_dataname (`character(1)`) Specifies the parent dataset name. Default is `ADSL` for `CDISC` data. #' If provided and exists, enables additional analysis "by subject". For non-`CDISC` data, this parameter can be #' ignored. +# nolint start: line_length. #' @param ggtheme (`character`) optional, specifies the default `ggplot2` theme for plots. Defaults to `classic`. +# nolint end: line_length. #' -#' @templateVar ggnames "Summary Obs", "Summary Patients", "Combinations Main", "Combinations Hist", "By Subject" -#' @template ggplot2_args_multi +#' @param ggplot2_args `r roxygen_ggplot2_args_param("Summary Obs", "Summary Patients", "Combinations Main", "Combinations Hist", "By Subject")` +#' @param decorators `r roxygen_decorators_param("tm_missing_data")` #' #' @inherit shared_params return #' #' @section Decorating `tm_missing_data`: #' #' This module generates the following objects, which can be modified in place using decorators: -#' - `summary_plot` (`ggplot2 plot grob`) -#' - `combination_plot` (`ggplot2 plot grob`) +#' - `summary_plot` (`grob` created with [ggplot2::ggplotGrob()]) +#' - `combination_plot` (`grob` created with [ggplot2::ggplotGrob()]) #' - `by_subject_plot` (`ggplot2`) #' - `table` ([DT::datatable()]) #' +#' 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_missing_data( +#' ..., # arguments for module +#' decorators = list( +#' default = list(teal_transform_module(...)), # applied to all outputs +#' summary_plot = list(teal_transform_module(...)), # applied only to `summary_plot` output +#' combination_plot = list(teal_transform_module(...)) # applied only to `combination_plot` output +#' by_subject_plot = list(teal_transform_module(...)) # applied only to `by_subject_plot` output +#' table = list(teal_transform_module(...)) # applied only to `table` output +#' ) +#' ) +#' ``` +#' #' For additional details and examples of decorators, refer to the vignette #' `vignette("decorate-modules-output", package = "teal")` or the [`teal_transform_module()`] documentation. #' @@ -134,15 +154,9 @@ tm_missing_data <- function(label = "Missing data", 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) - available_decorators <- c("summary_plot", "summary_plot", "combination_plot", "by_subject_plot", "summary_table") - if (checkmate::test_list(decorators, "teal_transform_module", null.ok = TRUE)) { - decorators <- if (checkmate::test_names(names(decorators), subset.of = c("default", available_decorators))) { - lapply(decorators, list) - } else { - list(default = decorators) - } - } - assert_decorators(decorators, null.ok = TRUE, names = c("default", available_decorators)) + available_decorators <- c("summary_plot", "combination_plot", "by_subject_plot", "summary_table") + decorators <- normalize_decorators(decorators) + assert_decorators(decorators, null.ok = TRUE, names = available_decorators) # End of assertions ans <- module( @@ -410,16 +424,16 @@ encoding_missing_data <- function(id, summary_per_patient = FALSE, ggtheme, data value = FALSE ) }, - ui_decorate_teal_data(ns("dec_summary_plot"), decorators = subset_decorators("summary_plot", decorators)) + ui_decorate_teal_data(ns("dec_summary_plot"), decorators = select_decorators(decorators, "summary_plot")) ), conditionalPanel( is_tab_active_js(ns("summary_type"), "Combinations"), uiOutput(ns("cutoff")), - ui_decorate_teal_data(ns("dec_combination_plot"), decorators = subset_decorators("combination_plot", decorators)) + ui_decorate_teal_data(ns("dec_combination_plot"), decorators = select_decorators(decorators, "combination_plot")) ), conditionalPanel( is_tab_active_js(ns("summary_type"), "Grouped by Subject"), - ui_decorate_teal_data(ns("dec_by_subject_plot"), decorators = subset_decorators("by_subject_plot", decorators)) + ui_decorate_teal_data(ns("dec_by_subject_plot"), decorators = select_decorators(decorators, "by_subject_plot")) ), conditionalPanel( is_tab_active_js(ns("summary_type"), "By Variable Levels"), @@ -432,7 +446,7 @@ encoding_missing_data <- function(id, summary_per_patient = FALSE, ggtheme, data selected = "counts", inline = TRUE ), - ui_decorate_teal_data(ns("dec_summary_table"), decorators = subset_decorators("summary_table", decorators)) + ui_decorate_teal_data(ns("dec_summary_table"), decorators = select_decorators(decorators, "summary_table")) ), teal.widgets::panel_item( title = "Plot settings", @@ -1250,7 +1264,7 @@ srv_missing_data <- function(id, decorated_summary_plot_q <- srv_decorate_teal_data( id = "dec_summary_plot", data = summary_plot_q, - decorators = subset_decorators("summary_plot", decorators), + decorators = select_decorators(decorators, "summary_plot"), expr = { grid::grid.newpage() grid::grid.draw(summary_plot) @@ -1260,7 +1274,7 @@ srv_missing_data <- function(id, decorated_combination_plot_q <- srv_decorate_teal_data( id = "dec_combination_plot", data = combination_plot_q, - decorators = subset_decorators("combination_plot", decorators), + decorators = select_decorators(decorators, "combination_plot"), expr = { grid::grid.newpage() grid::grid.draw(combination_plot) @@ -1270,14 +1284,14 @@ srv_missing_data <- function(id, decorated_summary_table_q <- srv_decorate_teal_data( id = "dec_summary_table", data = summary_table_q, - decorators = subset_decorators("summary_table", decorators), + decorators = select_decorators(decorators, "summary_table"), expr = table ) decorated_by_subject_plot_q <- srv_decorate_teal_data( id = "dec_by_subject_plot", data = by_subject_plot_q, - decorators = subset_decorators("by_subject_plot", decorators), + decorators = select_decorators(decorators, "by_subject_plot"), expr = print(by_subject_plot) ) diff --git a/R/tm_outliers.R b/R/tm_outliers.R index be3cc51f0..55ba7ad23 100644 --- a/R/tm_outliers.R +++ b/R/tm_outliers.R @@ -11,9 +11,8 @@ #' Specifies variable(s) to be analyzed for outliers. #' @param categorical_var (`data_extract_spec` or `list` of multiple `data_extract_spec`) optional, #' specifies the categorical variable(s) to split the selected outlier variables on. -#' -#' @templateVar ggnames "Boxplot","Density Plot","Cumulative Distribution Plot" -#' @template ggplot2_args_multi +#' @param decorators `r roxygen_decorators_param("tm_outliers")` +#' @param ggplot2_args `r roxygen_ggplot2_args_param("Boxplot", "Density Plot", "Cumulative Distribution Plot")` #' #' @inherit shared_params return #' @@ -22,7 +21,26 @@ #' This module generates the following objects, which can be modified in place using decorators: #' - `box_plot` (`ggplot2`) #' - `density_plot` (`ggplot2`) -#' - `cum_dist_plot` (`ggplot2`) +#' - `cumulative_plot` (`ggplot2`) +#' - `table` ([DT::datatable()]) +#' +#' 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_outliers( +#' ..., # arguments for module +#' decorators = list( +#' default = list(teal_transform_module(...)), # applied to all outputs +#' box_plot = list(teal_transform_module(...)), # applied only to `box_plot` output +#' density_plot = list(teal_transform_module(...)) # applied only to `density_plot` output +#' cumulative_plot = list(teal_transform_module(...)) # applied only to `cumulative_plot` output +#' table = list(teal_transform_module(...)) # applied only to `table` output +#' ) +#' ) +#' ``` #' #' For additional details and examples of decorators, refer to the vignette #' `vignette("decorate-modules-output", package = "teal")` or the [`teal_transform_module()`] documentation. @@ -178,8 +196,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) - + available_decorators <- c("box_plot", "density_plot", "cumulative_plot", "table") + decorators <- normalize_decorators(decorators) + assert_decorators(decorators, null.ok = TRUE, names = available_decorators) # End of assertions # Make UI args @@ -322,7 +341,28 @@ ui_outliers <- function(id, ...) { uiOutput(ns("ui_outlier_help")) ) ), - ui_transform_teal_data(ns("decorate"), transformators = args$decorators), + conditionalPanel( + condition = paste0("input['", ns("tabs"), "'] == 'Boxplot'"), + ui_decorate_teal_data( + ns("d_box_plot"), + decorators = select_decorators(args$decorators, "box_plot") + ) + ), + conditionalPanel( + condition = paste0("input['", ns("tabs"), "'] == 'Density Plot'"), + ui_decorate_teal_data( + ns("d_density_plot"), + decorators = select_decorators(args$decorators, "density_plot") + ) + ), + conditionalPanel( + condition = paste0("input['", ns("tabs"), "'] == 'Cumulative Distribution Plot'"), + ui_decorate_teal_data( + ns("d_cumulative_plot"), + decorators = select_decorators(args$decorators, "cumulative_plot") + ) + ), + ui_decorate_teal_data(ns("d_table"), decorators = select_decorators(args$decorators, "table")), teal.widgets::panel_item( title = "Plot settings", selectInput( @@ -585,7 +625,7 @@ srv_outliers <- function(id, data, reporter, filter_panel_api, outlier_var, ) ) - if (length(categorical_var) > 0) { + qenv <- if (length(categorical_var) > 0) { qenv <- teal.code::eval_code( qenv, substitute( @@ -641,7 +681,7 @@ srv_outliers <- function(id, data, reporter, filter_panel_api, outlier_var, ) } - qenv <- teal.code::eval_code( + teal.code::eval_code( qenv, substitute( expr = { @@ -669,7 +709,6 @@ srv_outliers <- function(id, data, reporter, filter_panel_api, outlier_var, tidyr::pivot_longer(-categorical_var_name) %>% tidyr::pivot_wider(names_from = categorical_var, values_from = value) %>% tibble::column_to_rownames("name") - summary_table }, env = list( categorical_var = categorical_var, @@ -677,8 +716,22 @@ srv_outliers <- function(id, data, reporter, filter_panel_api, outlier_var, ) ) ) + } else { + within(qenv, summary_table <- data.frame()) } + # Datatable is generated in qenv to allow for output decoration + qenv <- within(qenv, { + table <- DT::datatable( + summary_table, + options = list( + dom = "t", + autoWidth = TRUE, + columnDefs = list(list(width = "200px", targets = "_all")) + ) + ) + }) + if (length(categorical_var) > 0 && nrow(qenv[["ANL_OUTLIER"]]) > 0) { shinyjs::show("order_by_outlier") } else { @@ -688,26 +741,8 @@ srv_outliers <- function(id, data, reporter, filter_panel_api, outlier_var, qenv }) - output$summary_table <- DT::renderDataTable( - expr = { - if (iv_r()$is_valid()) { - categorical_var <- as.vector(merged$anl_input_r()$columns_source$categorical_var) - if (!is.null(categorical_var)) { - DT::datatable( - common_code_q()[["summary_table"]], - options = list( - dom = "t", - autoWidth = TRUE, - columnDefs = list(list(width = "200px", targets = "_all")) - ) - ) - } - } - } - ) - # boxplot/violinplot # nolint commented_code - boxplot_q <- reactive({ + box_plot_q <- reactive({ req(common_code_q()) ANL <- common_code_q()[["ANL"]] ANL_OUTLIER <- common_code_q()[["ANL_OUTLIER"]] @@ -947,7 +982,7 @@ srv_outliers <- function(id, data, reporter, filter_panel_api, outlier_var, teal.code::eval_code( qenv, substitute( - expr = cum_dist_plot <- plot_call + + expr = cumulative_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, @@ -962,37 +997,59 @@ srv_outliers <- function(id, data, reporter, filter_panel_api, outlier_var, ) }) - final_q <- reactive({ - req(input$tabs) - tab_type <- input$tabs - result_q <- if (tab_type == "Boxplot") { - boxplot_q() - } else if (tab_type == "Density Plot") { - density_plot_q() - } else if (tab_type == "Cumulative Distribution Plot") { - cumulative_plot_q() - } - # used to display table when running show-r-code code - # added after the plots so that a change in selected columns doesn't affect - # brush selection. - teal.code::eval_code( - result_q, - substitute( - expr = { - columns_index <- union( - setdiff(names(ANL_OUTLIER), c("is_outlier_selected", "order")), - table_columns - ) - ANL_OUTLIER_EXTENDED[ANL_OUTLIER_EXTENDED$is_outlier_selected, columns_index] - }, - env = list( - table_columns = input$table_ui_columns - ) - ) + current_tab_r <- reactive({ + switch(req(input$tabs), + "Boxplot" = "box_plot", + "Density Plot" = "density_plot", + "Cumulative Distribution Plot" = "cumulative_plot" ) }) - decorated_final_q <- srv_transform_teal_data("decorate", data = final_q, transformators = decorators) + decorated_q <- mapply( + function(obj_name, q) { + srv_decorate_teal_data( + id = sprintf("d_%s", obj_name), + data = q, + decorators = select_decorators(decorators, obj_name), + expr = reactive({ + substitute( + expr = { + columns_index <- union( + setdiff(names(ANL_OUTLIER), c("is_outlier_selected", "order")), + table_columns + ) + ANL_OUTLIER_EXTENDED[ANL_OUTLIER_EXTENDED$is_outlier_selected, columns_index] + print(.plot) + }, + env = list(table_columns = input$table_ui_columns, .plot = as.name(obj_name)) + ) + }), + expr_is_reactive = TRUE + ) + }, + rlang::set_names(c("box_plot", "density_plot", "cumulative_plot")), + c(box_plot_q, density_plot_q, cumulative_plot_q) + ) + + decorated_final_q_no_table <- reactive(decorated_q[[req(current_tab_r())]]()) + + decorated_final_q <- srv_decorate_teal_data( + "d_table", + data = decorated_final_q_no_table, + decorators = select_decorators(decorators, "table"), + expr = table + ) + + output$summary_table <- DT::renderDataTable( + expr = { + if (iv_r()$is_valid()) { + categorical_var <- as.vector(merged$anl_input_r()$columns_source$categorical_var) + if (!is.null(categorical_var)) { + decorated_final_q()[["table"]] + } + } + } + ) # slider text output$ui_outlier_help <- renderUI({ @@ -1042,25 +1099,22 @@ srv_outliers <- function(id, data, reporter, filter_panel_api, outlier_var, } }) - boxplot_r <- reactive({ + box_plot_r <- reactive({ teal::validate_inputs(iv_r()) - req(boxplot_q()) - decorated_final_q()[["box_plot"]] + req(decorated_q$box_plot())[["box_plot"]] }) density_plot_r <- reactive({ teal::validate_inputs(iv_r()) - req(density_plot_q()) - decorated_final_q()[["density_plot"]] + req(decorated_q$density_plot())[["density_plot"]] }) cumulative_plot_r <- reactive({ teal::validate_inputs(iv_r()) - req(cumulative_plot_q()) - decorated_final_q()[["cum_dist_plot"]] + req(decorated_q$cumulative_plot())[["cumulative_plot"]] }) box_pws <- teal.widgets::plot_with_settings_srv( id = "box_plot", - plot_r = boxplot_r, + plot_r = box_plot_r, height = plot_height, width = plot_width, brushing = TRUE @@ -1106,16 +1160,20 @@ srv_outliers <- function(id, data, reporter, filter_panel_api, outlier_var, ANL_OUTLIER_EXTENDED <- common_code_q()[["ANL_OUTLIER_EXTENDED"]] ANL <- common_code_q()[["ANL"]] - plot_brush <- if (tab == "Boxplot") { - boxplot_r() - box_pws$brush() - } else if (tab == "Density Plot") { - density_plot_r() - density_pws$brush() - } else if (tab == "Cumulative Distribution Plot") { - cumulative_plot_r() - cum_density_pws$brush() - } + plot_brush <- switch(current_tab_r(), + box_plot = { + box_plot_r() + box_pws$brush() + }, + density_plot = { + density_plot_r() + density_pws$brush() + }, + cumulative_plot = { + cumulative_plot_r() + cum_density_pws$brush() + } + ) # removing unused column ASAP ANL_OUTLIER$order <- ANL$order <- NULL diff --git a/R/tm_t_crosstable.R b/R/tm_t_crosstable.R index 549fde366..3043181a1 100644 --- a/R/tm_t_crosstable.R +++ b/R/tm_t_crosstable.R @@ -167,7 +167,9 @@ tm_t_crosstable <- function(label = "Cross Table", 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_class(basic_table_args, classes = "basic_table_args") - checkmate::assert_list(decorators, "teal_transform_module", null.ok = TRUE) + + decorators <- normalize_decorators(decorators) + assert_decorators(decorators, null.ok = TRUE, "plot") # End of assertions # Make UI args @@ -234,7 +236,7 @@ ui_t_crosstable <- function(id, x, y, show_percentage, show_total, pre_output, p checkboxInput(ns("show_total"), "Show total column", value = show_total) ) ), - ui_transform_teal_data(ns("decorate"), transformators = args$decorators) + ui_decorate_teal_data(ns("decorator"), decorators = select_decorators(args$decorators, "plot")) ), forms = tagList( teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code") @@ -407,15 +409,18 @@ srv_t_crosstable <- function(id, data, reporter, filter_panel_api, label, x, y, ) }) - 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 = table)) + decorated_output_q <- srv_decorate_teal_data( + id = "decorator", + data = output_q, + decorators = select_decorators(decorators, "plot"), + expr = table + ) - output$title <- renderText(output_q()[["title"]]) + output$title <- renderText(req(decorated_output_q())[["title"]]) table_r <- reactive({ req(iv_r()$is_valid()) - req(output_q()) - decorated_output_q()[["table"]] + req(decorated_output_q())[["table"]] }) teal.widgets::table_with_settings_srv( diff --git a/R/utils.R b/R/utils.R index 750911a6a..556a977d5 100644 --- a/R/utils.R +++ b/R/utils.R @@ -25,9 +25,6 @@ #' with text placed before the output to put the output into context. For example a title. #' @param post_output (`shiny.tag`) optional, text or UI element to be displayed after the module's output, #' adding context or further instructions. Elements like `shiny::helpText()` are useful. -#' @param decorators `r lifecycle::badge("experimental")` (`list` of `teal_transform_module` or `NULL`) optional, -#' if not `NULL`, decorator for tables or plots included in the module. -#' #' @param alpha (`integer(1)` or `integer(3)`) optional, specifies point opacity. #' - When the length of `alpha` is one: the plot points will have a fixed opacity. #' - When the length of `alpha` is three: the plot points opacity are dynamically adjusted based on @@ -286,6 +283,8 @@ assert_single_selection <- function(x, #' @param expr (`expression` or `reactive`) to evaluate on the output of the decoration. #' When an expression it must be inline code. See [within()] #' Default is `NULL` which won't evaluate any appending code. +#' @param expr_is_reactive (`logical(1)`) whether `expr` is a reactive expression +#' that skips defusing the argument. #' @details #' `srv_decorate_teal_data` is a wrapper around `srv_transform_teal_data` that #' allows to decorate the data with additional expressions. @@ -293,12 +292,13 @@ assert_single_selection <- function(x, #' first. #' #' @keywords internal -srv_decorate_teal_data <- function(id, data, decorators, expr) { +srv_decorate_teal_data <- function(id, data, decorators, expr, expr_is_reactive = FALSE) { assert_reactive(data) checkmate::assert_list(decorators, "teal_transform_module") + checkmate::assert_flag(expr_is_reactive) missing_expr <- missing(expr) - if (!missing_expr) { + if (!missing_expr && !expr_is_reactive) { expr <- rlang::enexpr(expr) } @@ -310,6 +310,8 @@ srv_decorate_teal_data <- function(id, data, decorators, expr) { req(data(), decorated_output()) if (missing_expr) { decorated_output() + } else if (expr_is_reactive) { + eval_code(decorated_output(), expr()) } else { eval_code(decorated_output(), expr) } @@ -327,7 +329,7 @@ ui_decorate_teal_data <- function(id, decorators, ...) { #' Internal function to check if decorators is a valid object #' @noRd -check_decorators <- function(x, names = NULL, null.ok = FALSE) { +check_decorators <- function(x, names = NULL, null.ok = FALSE) { # nolint: object_name. checkmate::qassert(null.ok, "B1") check_message <- checkmate::check_list( @@ -384,8 +386,25 @@ assert_decorators <- checkmate::makeAssertionFunction(check_decorators) #' @return A flat list with all decorators to include. #' It can be an empty list if none of the scope exists in `decorators` argument. #' @keywords internal -subset_decorators <- function(scope, decorators) { - checkmate::assert_character(scope) +select_decorators <- function(decorators, scope) { + checkmate::assert_character(scope, null.ok = TRUE) scope <- intersect(union("default", scope), names(decorators)) c(list(), unlist(decorators[scope], recursive = FALSE)) } + +#' Convert flat list of `teal_transform_module` to named lists +#' +#' @param decorators (list of `teal_transformodules`) to normalize. +#' @return A named list of lists with `teal_transform_module` objects. +#' @keywords internal +normalize_decorators <- function(decorators) { + if (checkmate::test_list(decorators, "teal_transform_module", null.ok = TRUE)) { + if (checkmate::test_names(names(decorators))) { + lapply(decorators, list) + } else { + list(default = decorators) + } + } else { + decorators + } +} diff --git a/man-roxygen/ggplot2_args_multi.R b/man-roxygen/ggplot2_args_multi.R deleted file mode 100644 index dc0497942..000000000 --- a/man-roxygen/ggplot2_args_multi.R +++ /dev/null @@ -1,7 +0,0 @@ -#' @param ggplot2_args (`ggplot2_args`) optional, object created by [`teal.widgets::ggplot2_args()`] -#' with settings for all the plots or named list of `ggplot2_args` objects for plot-specific settings. -#' The argument is merged with options variable `teal.ggplot2_args` and default module setup. -#' -#' List names should match the following: `c("default", <%=ggnames%>)`. -#' -#' For more details see the vignette: `vignette("custom-ggplot2-arguments", package = "teal.widgets")`. diff --git a/man/normalize_decorators.Rd b/man/normalize_decorators.Rd new file mode 100644 index 000000000..a58207f16 --- /dev/null +++ b/man/normalize_decorators.Rd @@ -0,0 +1,18 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/utils.R +\name{normalize_decorators} +\alias{normalize_decorators} +\title{Convert flat list of \code{teal_transform_module} to named lists} +\usage{ +normalize_decorators(decorators) +} +\arguments{ +\item{decorators}{(list of \code{teal_transformodules}) to normalize.} +} +\value{ +A named list of lists with \code{teal_transform_module} objects. +} +\description{ +Convert flat list of \code{teal_transform_module} to named lists +} +\keyword{internal} diff --git a/man/subset_decorators.Rd b/man/select_decorators.Rd similarity index 86% rename from man/subset_decorators.Rd rename to man/select_decorators.Rd index 9b229dffe..2c7403dca 100644 --- a/man/subset_decorators.Rd +++ b/man/select_decorators.Rd @@ -1,15 +1,15 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/utils.R -\name{subset_decorators} -\alias{subset_decorators} +\name{select_decorators} +\alias{select_decorators} \title{Subset decorators based on the scope} \usage{ -subset_decorators(scope, decorators) +select_decorators(decorators, scope) } \arguments{ -\item{scope}{(\code{character}) a character vector of decorator names to include.} - \item{decorators}{(named \code{list}) of list decorators to subset.} + +\item{scope}{(\code{character}) a character vector of decorator names to include.} } \value{ A flat list with all decorators to include. diff --git a/man/shared_params.Rd b/man/shared_params.Rd index 1cf943565..1ea6b7094 100644 --- a/man/shared_params.Rd +++ b/man/shared_params.Rd @@ -34,9 +34,6 @@ with text placed before the output to put the output into context. For example a \item{post_output}{(\code{shiny.tag}) optional, text or UI element to be displayed after the module's output, adding context or further instructions. Elements like \code{shiny::helpText()} are useful.} -\item{decorators}{\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}} (\code{list} of \code{teal_transform_module} or \code{NULL}) optional, -if not \code{NULL}, decorator for tables or plots included in the module.} - \item{alpha}{(\code{integer(1)} or \code{integer(3)}) optional, specifies point opacity. \itemize{ \item When the length of \code{alpha} is one: the plot points will have a fixed opacity. diff --git a/man/srv_decorate_teal_data.Rd b/man/srv_decorate_teal_data.Rd index 6d6845aca..18201124e 100644 --- a/man/srv_decorate_teal_data.Rd +++ b/man/srv_decorate_teal_data.Rd @@ -5,7 +5,7 @@ \alias{ui_decorate_teal_data} \title{Wrappers around \code{srv_transform_teal_data} that allows to decorate the data} \usage{ -srv_decorate_teal_data(id, data, decorators, expr) +srv_decorate_teal_data(id, data, decorators, expr, expr_is_reactive = FALSE) ui_decorate_teal_data(id, decorators, ...) } @@ -17,6 +17,9 @@ ui_decorate_teal_data(id, decorators, ...) \item{expr}{(\code{expression} or \code{reactive}) to evaluate on the output of the decoration. When an expression it must be inline code. See \code{\link[=within]{within()}} Default is \code{NULL} which won't evaluate any appending code.} + +\item{expr_is_reactive}{(\code{logical(1)}) whether \code{expr} is a reactive expression +that skips defusing the argument.} } \description{ Wrappers around \code{srv_transform_teal_data} that allows to decorate the data diff --git a/man/tm_a_pca.Rd b/man/tm_a_pca.Rd index 5ed58485a..54de83bdb 100644 --- a/man/tm_a_pca.Rd +++ b/man/tm_a_pca.Rd @@ -35,9 +35,7 @@ specifying columns used to compute PCA.} \item{ggtheme}{(\code{character}) optional, \code{ggplot2} theme to be used by default. Defaults to \code{"gray"}.} -\item{ggplot2_args}{(\code{ggplot2_args}) optional, object created by \code{\link[teal.widgets:ggplot2_args]{teal.widgets::ggplot2_args()}} -with settings for all the plots or named list of \code{ggplot2_args} objects for plot-specific settings. -The argument is merged with options variable \code{teal.ggplot2_args} and default module setup. +\item{ggplot2_args}{(\code{ggplot2_args}) optional, object created by \code{\link[teal.widgets:ggplot2_args]{teal.widgets::ggplot2_args()}} with settings for all the plots or named list of \code{ggplot2_args} objects for plot-specific settings. The argument is merged with options variable \code{teal.ggplot2_args} and default module setup. List names should match the following: \code{c("default", "Elbow plot", "Circle plot", "Biplot", "Eigenvector plot")}. @@ -74,8 +72,11 @@ with text placed before the output to put the output into context. For example a \item{post_output}{(\code{shiny.tag}) optional, text or UI element to be displayed after the module's output, adding context or further instructions. Elements like \code{shiny::helpText()} are useful.} -\item{decorators}{\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}} (\code{list} of \code{teal_transform_module} or \code{NULL}) optional, -if not \code{NULL}, decorator for tables or plots included in the module.} +\item{decorators}{\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}} (\code{list} of \code{teal_transform_module}, named \code{list} of \code{teal_transform_module} or \code{NULL}) optional, if not \code{NULL}, decorator for tables or plots included in the module. When a named list of \code{teal_transform_module}, the decorators are applied to the respective output objects. + +Otherwise, the decorators are applied to all objects, which is equivalent as using the name \code{default}. + +See section "Decorating \code{tm_a_pca}" below for more details.} } \value{ Object of class \code{teal_module} to be used in \code{teal} applications. @@ -91,9 +92,29 @@ font size, through UI inputs. This module generates the following objects, which can be modified in place using decorators: \itemize{ -\item \code{plot} (\code{ggplot2}) +\item \code{elbow_plot} (\code{ggplot2}) +\item \code{circle_plot} (\code{ggplot2}) +\item \code{biplot} (\code{ggplot2}) +\item \code{eigenvector_plot} (\code{ggplot2}) } +Decorators can be applied to all outputs or only to specific objects using a +named list of \code{teal_transform_module} objects. +The \code{"default"} name is reserved for decorators that are applied to all outputs. +See code snippet below: + +\if{html}{\out{