From cca419348a30d4122068d9abef4ac474ddb9c590 Mon Sep 17 00:00:00 2001 From: m7pr Date: Fri, 22 Nov 2024 13:21:47 +0100 Subject: [PATCH 1/7] this is not there yet! --- R/tm_missing_data.R | 144 ++++++++++++++++++++++++++++++-------------- 1 file changed, 99 insertions(+), 45 deletions(-) diff --git a/R/tm_missing_data.R b/R/tm_missing_data.R index d57c616bd..8f4db233d 100644 --- a/R/tm_missing_data.R +++ b/R/tm_missing_data.R @@ -17,6 +17,18 @@ #' #' @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_top` (`ggplot2`) +#' - `summary_plot_bottom` (`ggplot2`) +#' - `combination_plot_top` (`ggplot2`) +#' - `combination_plot_bottom` (`ggplot2`) +#' - `table` ([DT::datatable()]) +#' +#' 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 @@ -87,7 +99,8 @@ tm_missing_data <- function(label = "Missing data", "Combinations Main" = teal.widgets::ggplot2_args(labs = list(title = NULL)) ), pre_output = NULL, - post_output = NULL) { + post_output = NULL, + decorators = NULL) { message("Initializing tm_missing_data") # Requires Suggested packages @@ -121,14 +134,19 @@ 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) + checkmate::assert_list(decorators, "teal_transform_module", null.ok = TRUE) # End of assertions ans <- module( label, server = srv_page_missing_data, server_args = list( - parent_dataname = parent_dataname, plot_height = plot_height, - plot_width = plot_width, ggplot2_args = ggplot2_args, ggtheme = ggtheme + parent_dataname = parent_dataname, + plot_height = plot_height, + plot_width = plot_width, + ggplot2_args = ggplot2_args, + ggtheme = ggtheme, + decorators = decorators ), ui = ui_page_missing_data, datanames = "all", @@ -165,7 +183,7 @@ ui_page_missing_data <- function(id, pre_output = NULL, post_output = NULL) { # Server function for the missing data module (all datasets) srv_page_missing_data <- function(id, data, reporter, filter_panel_api, parent_dataname, - plot_height, plot_width, ggplot2_args, ggtheme) { + plot_height, plot_width, ggplot2_args, ggtheme, decorators) { with_reporter <- !missing(reporter) && inherits(reporter, "Reporter") with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI") moduleServer(id, function(input, output, session) { @@ -215,7 +233,8 @@ srv_page_missing_data <- function(id, data, reporter, filter_panel_api, parent_d id = ns(x), summary_per_patient = if_subject_plot, ggtheme = ggtheme, - datanames = datanames + datanames = datanames, + decorators = decorators ) ) } @@ -248,7 +267,8 @@ srv_page_missing_data <- function(id, data, reporter, filter_panel_api, parent_d parent_dataname = parent_dataname, plot_height = plot_height, plot_width = plot_width, - ggplot2_args = ggplot2_args + ggplot2_args = ggplot2_args, + decorators = decorators ) } ) @@ -326,7 +346,7 @@ ui_missing_data <- function(id, by_subject_plot = FALSE) { } # UI encoding for the missing data module (all datasets) -encoding_missing_data <- function(id, summary_per_patient = FALSE, ggtheme, datanames) { +encoding_missing_data <- function(id, summary_per_patient = FALSE, ggtheme, datanames, decorators) { ns <- NS(id) tagList( @@ -401,6 +421,7 @@ encoding_missing_data <- function(id, summary_per_patient = FALSE, ggtheme, data ) ) ), + ui_teal_transform_data(ns("decorator"), transformators = decorators), teal.widgets::panel_item( title = "Plot settings", selectInput( @@ -416,7 +437,7 @@ encoding_missing_data <- function(id, summary_per_patient = FALSE, ggtheme, data # Server function for the missing data (single dataset) srv_missing_data <- function(id, data, reporter, filter_panel_api, dataname, parent_dataname, - plot_height, plot_width, ggplot2_args) { + 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") @@ -718,7 +739,7 @@ srv_missing_data <- function(id, data, reporter, filter_panel_api, dataname, par qenv <- teal.code::eval_code( qenv, substitute( - p1 <- summary_plot_obs %>% + summary_plot_top <- summary_plot_obs %>% ggplot() + aes( x = factor(create_cols_labels(col), levels = x_levels), @@ -800,7 +821,7 @@ srv_missing_data <- function(id, data, reporter, filter_panel_api, dataname, par qenv <- teal.code::eval_code( qenv, substitute( - p2 <- summary_plot_patients %>% + summary_plot_bottom <- summary_plot_patients %>% ggplot() + aes_( x = ~ factor(create_cols_labels(col), levels = x_levels), @@ -833,33 +854,44 @@ srv_missing_data <- function(id, data, reporter, filter_panel_api, dataname, par ggthemes = parsed_ggplot2_args$ggtheme ) ) - ) %>% - teal.code::eval_code( - quote({ - g1 <- ggplotGrob(p1) - g2 <- ggplotGrob(p2) - g <- gridExtra::gtable_cbind(g1, g2, size = "first") - g$heights <- grid::unit.pmax(g1$heights, g2$heights) - grid::grid.newpage() - }) - ) + ) + } + qenv + }) + + + decorated_summary_plot_q <- srv_teal_transform_data(id = "decorator", data = summary_plot_q, transformators = decorators) + decorated_summary_plot_grob_q <- reactive({ + q <- if (isTRUE(input$if_patients_plot)) { + within( + decorated_summary_plot_q(), + { + g1 <- ggplotGrob(summary_plot_top) + g2 <- ggplotGrob(summary_plot_bottom) + g <- gridExtra::gtable_cbind(g1, g2, size = "first") + g$heights <- grid::unit.pmax(g1$heights, g2$heights) + grid::grid.newpage() + } + ) } else { - qenv <- teal.code::eval_code( - qenv, - quote({ - g <- ggplotGrob(p1) + within( + decorated_summary_plot_q(), + { + g <- ggplotGrob(summary_plot_top) grid::grid.newpage() - }) + } ) } - teal.code::eval_code( - qenv, + q, quote(grid::grid.draw(g)) ) }) - summary_plot_r <- reactive(summary_plot_q()[["g"]]) + summary_plot_r <- reactive({ + req(summary_plot_q()) + decorated_summary_plot_grob_q()[["g"]] + }) combination_cutoff_q <- reactive({ req(common_code_q()) @@ -976,7 +1008,7 @@ srv_missing_data <- function(id, data, reporter, filter_panel_api, dataname, par qenv, substitute( expr = { - p1 <- data_combination_plot_cutoff %>% + combination_plot_top <- data_combination_plot_cutoff %>% dplyr::select(id, n) %>% dplyr::distinct() %>% ggplot(aes(x = id, y = n)) + @@ -994,7 +1026,7 @@ srv_missing_data <- function(id, data, reporter, filter_panel_api, dataname, par graph_number_rows <- length(unique(data_combination_plot_cutoff$id)) graph_number_cols <- nrow(data_combination_plot_cutoff) / graph_number_rows - p2 <- data_combination_plot_cutoff %>% ggplot() + + combination_plot_bottom <- data_combination_plot_cutoff %>% ggplot() + aes(x = create_cols_labels(key), y = id - 0.5, fill = value) + geom_tile(alpha = 0.85, height = 0.95) + scale_fill_manual( @@ -1009,13 +1041,6 @@ srv_missing_data <- function(id, data, reporter, filter_panel_api, dataname, par ggthemes2 + themes2 - g1 <- ggplotGrob(p1) - g2 <- ggplotGrob(p2) - - g <- gridExtra::gtable_rbind(g1, g2, size = "last") - g$heights[7] <- grid::unit(0.2, "null") # rescale to get the bar chart smaller - grid::grid.newpage() - grid::grid.draw(g) }, env = list( labs1 = parsed_ggplot2_args1$labs, @@ -1029,7 +1054,26 @@ srv_missing_data <- function(id, data, reporter, filter_panel_api, dataname, par ) }) - combination_plot_r <- reactive(combination_plot_q()[["g"]]) + decorated_combination_plot_q <- srv_teal_transform_data(id = "decorator", data = combination_plot_q, transformators = decorators) + decorated_combination_plot_grob_q <- reactive({ + within( + decorated_combination_plot_q(), + { + g1 <- ggplotGrob(combination_plot_top) + g2 <- ggplotGrob(combination_plot_bottom) + + g <- gridExtra::gtable_rbind(g1, g2, size = "last") + g$heights[7] <- grid::unit(0.2, "null") # rescale to get the bar chart smaller + grid::grid.newpage() + grid::grid.draw(g) + } + ) + }) + + combination_plot_r <- reactive({ + req(combination_plot_q()) + decorated_combination_plot_grob_q()[["g"]] + }) summary_table_q <- reactive({ req( @@ -1108,10 +1152,15 @@ srv_missing_data <- function(id, data, reporter, filter_panel_api, dataname, par ) } - teal.code::eval_code(qenv, quote(summary_data)) + teal.code::eval_code(qenv, quote(table <- DT::datatable(summary_data))) }) - summary_table_r <- reactive(summary_table_q()[["summary_data"]]) + decorated_summary_table_q <- + srv_teal_transform_data(id = "decorator", data = summary_table_q, transformators = decorators) + summary_table_r <- reactive({ + req(summary_table_q()) + decorated_summary_table_q()[["table"]] + }) by_subject_plot_q <- reactive({ # needed to trigger show r code update on tab change @@ -1188,7 +1237,7 @@ srv_missing_data <- function(id, data, reporter, filter_panel_api, dataname, par teal.code::eval_code( substitute( expr = { - g <- ggplot(summary_plot_patients, aes( + plot <- ggplot(summary_plot_patients, aes( x = factor(id, levels = order_subjects), y = factor(col, levels = ordered_columns[["column"]]), fill = isna @@ -1209,7 +1258,6 @@ srv_missing_data <- function(id, data, reporter, filter_panel_api, dataname, par labs + ggthemes + themes - print(g) }, env = list( labs = parsed_ggplot2_args$labs, @@ -1220,7 +1268,13 @@ srv_missing_data <- function(id, data, reporter, filter_panel_api, dataname, par ) }) - by_subject_plot_r <- reactive(by_subject_plot_q()[["g"]]) + decorated_by_subject_plot_q <- srv_teal_transform_data(id = "decorator", data = by_subject_plot_q, transformators = decorators) + decorated_by_subject_plot_print_q <- reactive(within(decorated_by_subject_plot_q(), print(plot))) + + by_subject_plot_r <- reactive({ + req(by_subject_plot_q()) # Ensure original errors are displayed + decorated_by_subject_plot_print_q()[["plot"]] + }) output$levels_table <- DT::renderDataTable( expr = { @@ -1272,7 +1326,7 @@ srv_missing_data <- function(id, data, reporter, filter_panel_api, dataname, par teal.widgets::verbatim_popup_srv( id = "rcode", - verbatim_content = reactive(teal.code::get_code(final_q())), + verbatim_content = reactive(teal.code::get_code(req(final_q()))), title = "Show R Code for Missing Data" ) @@ -1308,7 +1362,7 @@ srv_missing_data <- function(id, data, reporter, filter_panel_api, dataname, par 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(final_q()))) card } teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun) From 8f0687b77b734ae56ab385a601a1af6a12167d78 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andr=C3=A9=20Ver=C3=ADssimo?= <211358+averissimo@users.noreply.github.com> Date: Fri, 22 Nov 2024 14:34:50 +0000 Subject: [PATCH 2/7] chore: rename ui/srv_teal_transform_data to ui/srv_transform_teal_data --- R/tm_missing_data.R | 35 +++++++++++++++++------------------ man/tm_a_pca.Rd | 8 ++++---- man/tm_a_regression.Rd | 8 ++++---- man/tm_data_table.Rd | 8 ++++---- man/tm_file_viewer.Rd | 4 ++-- man/tm_front_page.Rd | 4 ++-- man/tm_g_association.Rd | 8 ++++---- man/tm_g_bivariate.Rd | 8 ++++---- man/tm_g_distribution.Rd | 8 ++++---- man/tm_g_response.Rd | 8 ++++---- man/tm_g_scatterplot.Rd | 8 ++++---- man/tm_g_scatterplotmatrix.Rd | 8 ++++---- man/tm_missing_data.Rd | 30 +++++++++++++++++++++++++----- man/tm_outliers.Rd | 8 ++++---- man/tm_t_crosstable.Rd | 8 ++++---- man/tm_variable_browser.Rd | 8 ++++---- 16 files changed, 94 insertions(+), 75 deletions(-) diff --git a/R/tm_missing_data.R b/R/tm_missing_data.R index 8f4db233d..ab46c7ab1 100644 --- a/R/tm_missing_data.R +++ b/R/tm_missing_data.R @@ -421,7 +421,7 @@ encoding_missing_data <- function(id, summary_per_patient = FALSE, ggtheme, data ) ) ), - ui_teal_transform_data(ns("decorator"), transformators = decorators), + ui_transform_teal_data(ns("decorator"), transformators = decorators), teal.widgets::panel_item( title = "Plot settings", selectInput( @@ -860,7 +860,7 @@ srv_missing_data <- function(id, data, reporter, filter_panel_api, dataname, par }) - decorated_summary_plot_q <- srv_teal_transform_data(id = "decorator", data = summary_plot_q, transformators = decorators) + decorated_summary_plot_q <- srv_transform_teal_data(id = "decorator", data = summary_plot_q, transformators = decorators) decorated_summary_plot_grob_q <- reactive({ q <- if (isTRUE(input$if_patients_plot)) { within( @@ -1040,7 +1040,6 @@ srv_missing_data <- function(id, data, reporter, filter_panel_api, dataname, par labs2 + ggthemes2 + themes2 - }, env = list( labs1 = parsed_ggplot2_args1$labs, @@ -1054,20 +1053,20 @@ srv_missing_data <- function(id, data, reporter, filter_panel_api, dataname, par ) }) - decorated_combination_plot_q <- srv_teal_transform_data(id = "decorator", data = combination_plot_q, transformators = decorators) + decorated_combination_plot_q <- srv_transform_teal_data(id = "decorator", data = combination_plot_q, transformators = decorators) decorated_combination_plot_grob_q <- reactive({ - within( - decorated_combination_plot_q(), - { - g1 <- ggplotGrob(combination_plot_top) - g2 <- ggplotGrob(combination_plot_bottom) - - g <- gridExtra::gtable_rbind(g1, g2, size = "last") - g$heights[7] <- grid::unit(0.2, "null") # rescale to get the bar chart smaller - grid::grid.newpage() - grid::grid.draw(g) - } - ) + within( + decorated_combination_plot_q(), + { + g1 <- ggplotGrob(combination_plot_top) + g2 <- ggplotGrob(combination_plot_bottom) + + g <- gridExtra::gtable_rbind(g1, g2, size = "last") + g$heights[7] <- grid::unit(0.2, "null") # rescale to get the bar chart smaller + grid::grid.newpage() + grid::grid.draw(g) + } + ) }) combination_plot_r <- reactive({ @@ -1156,7 +1155,7 @@ srv_missing_data <- function(id, data, reporter, filter_panel_api, dataname, par }) decorated_summary_table_q <- - srv_teal_transform_data(id = "decorator", data = summary_table_q, transformators = decorators) + srv_transform_teal_data(id = "decorator", data = summary_table_q, transformators = decorators) summary_table_r <- reactive({ req(summary_table_q()) decorated_summary_table_q()[["table"]] @@ -1268,7 +1267,7 @@ srv_missing_data <- function(id, data, reporter, filter_panel_api, dataname, par ) }) - decorated_by_subject_plot_q <- srv_teal_transform_data(id = "decorator", data = by_subject_plot_q, transformators = decorators) + decorated_by_subject_plot_q <- srv_transform_teal_data(id = "decorator", data = by_subject_plot_q, transformators = decorators) decorated_by_subject_plot_print_q <- reactive(within(decorated_by_subject_plot_q(), print(plot))) by_subject_plot_r <- reactive({ diff --git a/man/tm_a_pca.Rd b/man/tm_a_pca.Rd index 5ed58485a..f5d2d052c 100644 --- a/man/tm_a_pca.Rd +++ b/man/tm_a_pca.Rd @@ -167,13 +167,13 @@ if (interactive()) { \describe{ \item{example-1}{ \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAokrcQAxLqkQ11XfxQpFC6cAAesKgiSoHBBsZc1AD6sVA2MUEhRroA7rSkABYq7Km4uiBKurqMcACOgrQ17L6ipMTURIyKEFWOAMoAgow1raLxuv1DI6SiSgC+3UpoqOMq+eyVAZm6ALxbwbibfEIiY3vHwmIbPVW6pDBJUEmoBGmbt7oKYAAKAMIDX0ONw+sV2+ye4VIzA0SVEqDgBGuHxBmWg8DBX0mwzEM0B72RojgIg0YMJxNIsPhiPxyN0BAKRFoBDEYK0LFoUHoIiS9MZzNESNpyNSYNSwGAmMG2NGXwAurKytSwABZQSMfgyQGfMADUSiKDCUhazGMehQCDfIioY1gLBoOBfbpC25yIHOqpkhHkfhgpWq9WavDa3X6w2Ot3umCG2hRPR7BwuGkuiO0ky0ajkRhggByjgAMnmk06XZtut1aCZdOwVJn1JodDZbBUbqIihBWAN0OxlgASBplXuExg6LrzJRgOayoA}{Open in Shinylive} - \if{html}{\out{}} - \if{html}{\out{}} + \if{html}{\out{}} + \if{html}{\out{}} } \item{example-2}{ \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAokrcQAxLoDCAEQCSAMreuvxQpFC6cAAesKgiSmERBsZc1AD6SVA2ieGRRroA7rSkABYq7Fm4uiBKurqMcACOgrSN7BBipMTURIyKEPUAgr6BADIpDSPjSgC+AwBWRCrpANZwrKKVebYF-HAmUMKk6QT8tKIE6Usr65vA0PBbWXIAuu5oqJMqJex1oXldABeAERXD-PhCESiYG6SHCMR-Qb1XSkGDpKDpVAEbL-FG6BRgAAK3iGhPByPxSVhWXSMVIzA06VEqDgBCR+KpeUeehBhOmY3JeM5ojgIg0sNF4pOLLZHM5+IIpWWBDEsK0LFoUHoIlOytoqq2woV9SyNLywGA-NGgrAr1e1XZhIAQgBZLAAaSwAEZyQSwEMAOKuPD+5wAeUCvgAmoSBiaUXIKQn6lK2eR+LCnWA3Z6fX7+cG48mUzBjrR4rz7E5XJTOUnjSiTLRqORGLCAHKOMaCuv1eOJ-4DAa0Ey6dgqNvqTQ6Gy2WrI0TlCCsIbodifAAkrWqW9FjB0-TmSjAs1eQA}{Open in Shinylive} - \if{html}{\out{}} - \if{html}{\out{}} + \if{html}{\out{}} + \if{html}{\out{}} } } } diff --git a/man/tm_a_regression.Rd b/man/tm_a_regression.Rd index 29399feae..868e6562a 100644 --- a/man/tm_a_regression.Rd +++ b/man/tm_a_regression.Rd @@ -212,13 +212,13 @@ if (interactive()) { \describe{ \item{example-1}{ \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAokrcQAxLqkQ11XfxQpFC6cAAesKgiSoHBBsZc1AD6sVA2MUEhRroA7rSkABYq7Km4uiBKurqMcACOgrQ17L6ipMTURIyKEFUAwgDyAEzxugODSgC+3UpoqCMq+eyVAZm6ALwrwbjLfEIiouu6u8JiSz1VuqQwSVBJNRI1oqJWEGcXF9RQ9HD+GwpgWDgDzEzxI-2253ej1QJFEeg2qSS4VIzA0SVEqDgBDe7wuqWg8EO-zG4OWuN0cJEGkOlKxpHRmOxZPJuk+31+un+AGUfnTdFoWLQviJEKTISyCAUiLQCGIiWBBKhggBrOBilkXWkaOD8eWKlVqvDM8kwYSaKLw3QAMQAggAZLnOCEaqomWhhHWHBwuY0XbrkuTO3H3R6iTqHRHI1H0jFYnHk-GwS3Eobqlla0g03lo2NM8Xktk-eU8qmZgWMIX0faio353GS6Wyg4bcuVkRJBsy06pYDAFPjMAAXUHZSZhBIBHBnLAdhqQXgZH+ckDvveGc9f3HFjTGtN1HNIi9Tidq4ubo9uo2todrjrVX9uIf9+W3W6tBMunYKnI0e0cBstgVOcohFBArA2ug7CzAAJA0ZQwXCjA6F0kxKGAEyDkAA}{Open in Shinylive} - \if{html}{\out{}} - \if{html}{\out{}} + \if{html}{\out{}} + \if{html}{\out{}} } \item{example-2}{ \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAokqUBiXQGEAIgEkAZS9dfihSKF04AA9YVBElUPCDYy5qAH1EqBsEsIijXQB3WlIACxV2TNxdECVdXUY4AEdBWgb2CDFSYmoiRkUIOoBBHwCAGWT64bGlAF9+gCsiFTSAazhWUQrc23z+OBMoYVI0gn5aUQI0xeW1jeBoeE3MuQBdN2h0CZVi9lqQ3N0AF5-uFcH8+EIRKIgboIcIxL8BnVdKQYGkoGkGhIGqJRFYIIjkcjqFB6HBqDCFGAsHBsWI8SQqWCkUScagSKI9MDMmloqRmBo0qJUHACISicjMg8uboqVNRky-hLdJyRBoYarRcdhaLxcq6iSyRTgVSAuStbotCxaKSRIhFSz9QQSksCGJKWAAEIAWSwAGksABGB365GajRwfgen3+oMh0Owo60OIygBig1GAWczITploUUjMIcLiVEv6yrkOYlWJxol6MJ5fIF2pFYtLRKlsBlcpGCrw7bD5vVwPDLd1A6JhvJHrNatIluttrE9v7juVztd7uBVsYNvoIhOLtobqeuWAwB70zALxeVTbYEGAHFXHhZWAswANJlvrCDLwvuRKwnQc50LE0H2feNQxgJMUyLJxs2AuoTHzMDdHTTNXDXZFyzLUtcP6fpaBMXR2BUchm20OAbFsGokVEMoIFYQZ0HYNBUAAEhaKp2I4zlGB0PpZiUMAZheIA}{Open in Shinylive} - \if{html}{\out{}} - \if{html}{\out{}} + \if{html}{\out{}} + \if{html}{\out{}} } } } diff --git a/man/tm_data_table.Rd b/man/tm_data_table.Rd index 24a713d2b..3d105c6c0 100644 --- a/man/tm_data_table.Rd +++ b/man/tm_data_table.Rd @@ -110,13 +110,13 @@ if (interactive()) { \describe{ \item{example-1}{ \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAokqUBiXVIhrqu-lCkULpwAB6wqCJKAUEGxlzUAPoxUDbRgcFGugDutKQAFirsKbi6IEq6uoxwAI6CtNXsPqKkxNREjIoQlQ20onG6vaJKAL5dSmioAyp57BX+GboAvAtBuPN8QiL9K5vCYnPdlbqkMMkZiUH0IofHx1ostFDXYomicCIacPzLunQttzuxyGvwIczAAGU4KhuBgADIUCQFBR4XQoqEwngAdVo-GRqJRAAU4EEeAiIEj8ijSkSSbCcXiqQTIag4ARaGIUV0gbo5Osjnc8YkWBIdn8+qR2AQ0JoSL8UQBJLAKiH2Z4iXQAYRlVggXPmlW5vKUXVoJl07BU5GYlh0Nls5SOokKEFYAEF0OxJgASeqlH3vRg6TqjJRgEYAXSAA}{Open in Shinylive} - \if{html}{\out{}} - \if{html}{\out{}} + \if{html}{\out{}} + \if{html}{\out{}} } \item{example-2}{ \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAokqUBiXQGEAIgEkAZS9dfihSKF04AA9YVBElUPCDYy5qAH1EqBsEsIijXQB3WlIACxV2TNxdECVdXUY4AEdBWgb2CDFSYmoiRkUIOoBBHwCAGWT64bGlAF9+gCsiFTSAazhWUQrc23z+OBMoYVI0gn5aUQI0xeW1jeBoeE3MuQBdN2h0CZVi9lqQ3N0AF5-uFcH8+EIRKIgboIcIxL8BnVdKQYBlcmlwvQRIjkcitCxaFBsWI0qI4CINHB+DC6KJSOwpuNgQRfmAAnZHD4AJp+HwKPC6AWOAKOABCACk+QKqgLRZLpYK5X47M5FbKwIMAOKuJXs5wADQFcjkYKReP4xxYEmhwLpDIIaE0JBhAqZ9mJIm8TqsEGNfzq-UDSn6tBMunYKnIzEsOhsthqSNEZQgrEG6HYaFQABIWlUs9nyYwdH1ZkowDMXkA}{Open in Shinylive} - \if{html}{\out{}} - \if{html}{\out{}} + \if{html}{\out{}} + \if{html}{\out{}} } } } diff --git a/man/tm_file_viewer.Rd b/man/tm_file_viewer.Rd index a1617b9db..cf3b5cdd3 100644 --- a/man/tm_file_viewer.Rd +++ b/man/tm_file_viewer.Rd @@ -54,8 +54,8 @@ if (interactive()) { \describe{ \item{example-1}{ \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAokqX8opKAeNdqAfQ8vG3dPbyNdAHdaUgALFXYgqFxdECVdXSSfTLCME2Z4dgBGRQgAX1KlNFRslRj2dJyvXQBeJuTGviERUVbdLuExBogMjNIYfxNaEX8tWjhImWHR0ZVUQVJ-VE9YvrpRUmWV0ZMian4ZPtFWA7gYPOm4BrBRWFQZqZ6FPF1tggBrKBSPrfPy8ASDcRSCBqajfOS4RrHX4QCRXG7ke6fJ7fV4wd5wSaPUQAejxBKJIgwqFR3xSf0BwLaoLg3HB3TEkmksnhiJGyN0pAAHqR0bcsY9nuSPsSyW8ZVThaQ6b91Iy9MywGCBj0uTCeWAEUjjoJGNQQWBYqRSKhRIgSSSTB5JEQtI7ZfxGIIJKT1vR9rE4PwSQAFIiMLz+uCGAAiRAIgngZEMADFwzBPIYAMqoOAEWhTAieKwQcSofgmb7GjKlFa13SlUoF3TsFTkZiWHQ2WxpfmieIQVgAQXQ7GqABJBLQUhPRDIdIxSmUlGAygBdIA}{Open in Shinylive} - \if{html}{\out{}} - \if{html}{\out{}} + \if{html}{\out{}} + \if{html}{\out{}} } } } diff --git a/man/tm_front_page.Rd b/man/tm_front_page.Rd index 7da5acb05..35b1c3e9d 100644 --- a/man/tm_front_page.Rd +++ b/man/tm_front_page.Rd @@ -85,8 +85,8 @@ if (interactive()) { \describe{ \item{example-1}{ \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAokqX8opKAeNdqAfQ8vG3dPbyNdAHdaUgALFXYgqFxdECVdXUY4AEdBWiz2CDFSYmoiRkUIDIBBABEAZQAZH0y6pvTdT1JGdjbGlIUweC8kwdsIulFSdkHqwTjywd0AXl1BgDlnertdLhhBgbAk-1EiQUYCOCXVwdFWMli4TQJdUbBKgF9KgCsiFX8ANZwViiRJhcbGfhwExQYSkfwEfi0UQEfy-f5AkHAaDwUFJOQAXTcZCg9BE-gAjC0khgTMx4OwAJIQExEFa6AgzMDVA5rMAAITGKTscAAHqR2ZzZrzBoL3pUvGS4P4AEzUsK0+lwdgAAwAwkRqIIYFUKTrJVy9TKwLUhbp9YbjVUVebVpyAKwYd0pABsGB9chSDqNJt0AGZXRyuTy8Hy5XIFaTyWH1V5NbBtczWRbBq5Y4MAGJ2kXinNgADi1oAEmNKkpFeSVKh5i1JtMOoM7Em9BTrrtu5TcB2wF2lboVX2G8qVUOqnzRyJw5OB2GlHXoOgWioYjM50l2UlZxk+EIRKJ2SfhGJdxkMqQYP46SR4agoFIb7eMo8oFDGP5yKWbofp+GSDIyMCoOUXhkLoKisowMCeFYEB9mBEoEFAVQSGyjxZBgBwdCBfIAPJxDIsEsuUiGaCQqFgHqmG6Nhui4XA+FgIRt6Bpxd7dueqxTv4TbzEeIE-kiNHQAEXgSPxuhVnYACyjTRvwEnIdw8lKc05S6KI8QQKw-ayUxOEyHo+hMAAfEKPGmEQRCkBAjliGWAAadHIrsjymPkUz2Y5znkNaACasHnmRelwMQED8AFTkubZc6fvpRCRP4ww-mE7IOC4nGVBk3Fzt+v7sjJogACSxBSXL1LAqCLtU6B0BhklJRkrIuYwZVvpVqDRs1tCtch8UyEl660CYujsCo5DMJYOg2LYaRzvpKisE1-VoKgFV5Ck20VaIMg6BUSgfEoYAfASQA}{Open in Shinylive} - \if{html}{\out{}} - \if{html}{\out{}} + \if{html}{\out{}} + \if{html}{\out{}} } } } diff --git a/man/tm_g_association.Rd b/man/tm_g_association.Rd index c6a64f695..c239f6051 100644 --- a/man/tm_g_association.Rd +++ b/man/tm_g_association.Rd @@ -159,13 +159,13 @@ if (interactive()) { \describe{ \item{example-1}{ \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAokqUBiXVIhrqu-lCkULpwAB6wqCJKAUEGxlzUAPoxUDbRgcFGugDutKQAFirsKbi6IEq6uoxwAI6CtNXsPqKkxNREjIoQlQDCAPIATHG6-QMVpuqkHaLD0PCi7ABitNTkjOy0og4upVpokRyjpZsYJpMdpe0StATc7ACMADJyL129g8BnGtMAusPU+2ohw+XymjFEP1KUHEBHyLEmMi6AF8ukp9sMVHl2OMUroALz+DK4cZ8IQiGYE0nCMTY7qVXSkGCJCSJaGiIgEWiBKwQWn0+nVEz4wlBRJhUjMDSJUSoOAEPn8+kpOZ6AkKMCjdXEumK3SiOAiDTC-WG0jS2Xy8a6yoA+gG4XqgDKBrlpF0e0YXPoIkQWqt1thRBuYmFHq9IkSgeDCxSwGA6s1YB+kN0lrAAAUAWQtbp1XZWLKc3nqoF4NmwC9tdb6SbXXB+A6M1nSH6ddaTLRQvXhYsAIKPR2uNv8t6KuRVxUeikiqBi0ISybmuUK3XK2Cq3Mawat6u1o0EvdmmXL-26232tVgZ2m90scNiX14U+KqMEEMEsNQb1wSP5INvmMMjjBNtyTFM00zKBy1KPMCzgIswDsEtGQoFsK3HZ9+UPbtLyQuBS1Qndq10GBhE0SIN22ZwJ2rDsuwbAk+wHIdq1HEd-VHLouloIUNlUSVNB0GxbHKOlREKCBWF7dB2H2AASeooXQOT9UYHROiUJElDAJEfiAA}{Open in Shinylive} - \if{html}{\out{}} - \if{html}{\out{}} + \if{html}{\out{}} + \if{html}{\out{}} } \item{example-2}{ \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAokqUBiXQGEAIgEkAZS9dfihSKF04AA9YVBElUPCDYy5qAH1EqBsEsIijXQB3WlIACxV2TNxdECVdXUY4AEdBWgb2CDFSYmoiRkUIOoBBHwCAGWT64bGlAF9+gCsiFTSAazhWUQrc23z+OBMoYVI0gn5aUQI0xeW1jeBoeE3MuQBdN2h0CZVi9lqQ3N0AF5-uFcH8+EIRKIgboIcIxL8BnVdKQYGkJGkoKJREQCLQwlYIIjkciGiYYZk0tFSMwNGlRKg4ARiSTkZkHnpgQowFNRtywUjWbpRHARBoYSKxccGUyWUK6tQoPRRTDuQFRUzSLotCx8fQRIh+X95boCCUlgQxDCdYw9SITubaJbNsaTSCoMBgNzedyXi8BW7kcy1c4ABr83TcrCDLyuPCRsBeADyjgAcg4AJoR71YACy2bAAQcgzsgwAjAWi9HSwAmAt+Ox2ABifPj3IAQrmsABpLB1sD9QNyANuyWauD8VVgaOxo2C+UmWhRCcwpuDUYBVzzkmD1nD111G3Q4GU6m06WM4Pbtm5DlTn14A-Isfi4Evi+yp8kxXK6hT9VStqupKlChqPteJJmhaVrAjadpwA60EuhBrKZJ63ojK2fojoGwaFmGBYznGVTcsmaaZgWgx5pWxalhWbaFrRgz9iRYANs2rasZ2PZ9tyu4mvuKF1O+K5cmA3G9ixX7IjARy0HEnL2E4zg4QuS6iboa4bluAlPvxui7v0-S0OS7AqOQ57aHANi2DUSKiGUECsIM6DsGgqAACQtFU7keSKjA6H0sxKGAMwvEAA}{Open in Shinylive} - \if{html}{\out{}} - \if{html}{\out{}} + \if{html}{\out{}} + \if{html}{\out{}} } } } diff --git a/man/tm_g_bivariate.Rd b/man/tm_g_bivariate.Rd index ad90d451b..c8ad47e15 100644 --- a/man/tm_g_bivariate.Rd +++ b/man/tm_g_bivariate.Rd @@ -244,13 +244,13 @@ if (interactive()) { \describe{ \item{example-1}{ \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAokqUBiXVIhrqu-lCkULpwAB6wqCJKAUEGxlzUAPoxUDbRgcFGugDutKQAFirsKbi6IEq6uoxwAI6CtNXsPqKkxNREjIoQlQDCAPIATHH+GRgmzPDs-QNdAL5dSmiowyp57BUjsQC8m1C4G3xCIqK6O6QwiRKJ9NostIFw692VuqGnu4lhpMwaiaKocAITxeLxS0Hg7wUYGmUP2zxBojgIg070RyNIfwBQI2IMq1Cg9CRkLAAGUkYDSLotHcCSJELCcbiCPkiLQCGJ3tTGPd6CJEszWezRMUMsBgFCYWAALpSuRw3EvNEUuD8YnECwM+G4ky0UIq94AMQAggAZEmuLWVLoguWM1jvFKfULfdQY-6A4G4sGwPQ7CWDTUKpUonbBt1Yz0K-GEvx+0nklFcnl0wMK3QCtkcnZJ2lwfkszPClJi-0DKEy22WxUJ8iquOCVBBADWcFTCpgwk0kV9umNZuc8rTOr1dd7pvNjKtjMrIMYRGyiRM6jglJ2jq+P3DHsnu3BPdLber6NRNcx26reIJRLjZOPOd5cHpeB3lQzQs5NIf+cFYhFQRL0IBtKsqDkGNb6nGdisACh4gsOEFjv2O7Wi8M4vG0i7LquHwbq6Z7YlW3oQnGkqgUeFInui+GRri0bXroUK3hR94ps+F7pgW77Zp+fJvr+xbioBZbAWhYHoghUJ2NUgTwGQsEvPBo59hOVYoVOzxdF0tAmLo7AqOQm7aI8ci2OUzyiIUECsEa6DsEsAAk9SlA5iKMDonRKLMShgLMUpAA}{Open in Shinylive} - \if{html}{\out{}} - \if{html}{\out{}} + \if{html}{\out{}} + \if{html}{\out{}} } \item{example-2}{ \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAokqUBiXQGEAIgEkAZS9dfihSKF04AA9YVBElUPCDYy5qAH1EqBsEsIijXQB3WlIACxV2TNxdECVdXUY4AEdBWgb2CDFSYmoiRkUIOoBBHwCAGWT64bGlAF9+gCsiFTSAazhWUQrc23z+OBMoYVI0gn5aUQI0xeW1jeBoeE3MuQBdN2h0CZVi9lqQ3N0AF5-uFcH8+EIRKIgbpSDA0hI0vRtCxaGE4L8BnVdFEYZk0tFSMwNGlRKg4ARMdjsZkHnpgQowFNRoywVjqaI4CINDDOdzjmSKVTqdjqFB6FyYYyAlyKaRdFpUeKRIhWX8RboCCUlgQxDDFYw0fQRCdtbRdU9csBgIzmYyXi85GyNXU+XK4PwpUyAOKuPDqkUmWhRD0wgBig1GAVc7Ox-WpToDrDxuQJUSJ6gF5MpAbqtNg9N0tpGLP9sddsp5wLdJMFOfLovFkoZYBl-IVSuNcFVZZdmrNFv1nZNWp1Yi24WtxemYAdiYbFf5oZb0YAGmqF7oYEdaHFCxGo85nS6gyHPcCD9Hc7p43Hj3VGEQCmkDrr5cD8YTiVmhdf8-AvTtXsRRrd9dFA0ls2FDUxQlagvTbOUO0NZVuw3PtR3NPVgQNI0RwHcdMinJkS3tR17xAytyHPIsmSwABZdCT2DZddEvGMNVvOp52pboX3UOAwM-dNv0g38G3-Qtp1LCjFyQ6sqLE+s+1g5taMQnlcNQntZOxTDBxw4c4FNMdLUnG0SJnOddLkjRWMZLwAHlHAAOQcABNJiNVPVj2OvLibz+fp+loExdHYFRyG-bQMTkWwaixUQyggVhBnQdg0FQAASFoqkyrLOUYHQ+lmJQwBmF4gA}{Open in Shinylive} - \if{html}{\out{}} - \if{html}{\out{}} + \if{html}{\out{}} + \if{html}{\out{}} } } } diff --git a/man/tm_g_distribution.Rd b/man/tm_g_distribution.Rd index 4bac76283..dfbc4292f 100644 --- a/man/tm_g_distribution.Rd +++ b/man/tm_g_distribution.Rd @@ -166,13 +166,13 @@ if (interactive()) { \describe{ \item{example-1}{ \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAoksZwAjoNrv2CsBISqDC0ogT+uLpetHCk1Ky6ALz2Ts62AGTpuu7Rvv6B6BFR3rHxSSkuGVk53nkBRCbkoqRF0aUJyQ6VupnZnrVwfmAAsgCCAMrjrSVxHRVpPdX9PoP+TEREMNMxs+VdaUoAxLpSEGrUuvxQpFC6cAAesKgiSlc3BsZc1AD6b1A2r2utyMugA7rRSAALFTsP6REBKXS6HyhD7IxihJQAX0UECUaFQaJUEL8ECRf3KcMRuj4QhEonKdGapKRSNIMG+El+oVIGPogk01mprMuPO+WhYlKB3wevPUpG+olQcAILJFrL+0Hg5X8KNEEWF6tEcBEGnKxtNCqVKvYEoxUHoIm+BEhRFoBDEQz1-jkkX8AAVYtwMAAZCgSKE+w1I3Ei2O6XG42gmXTsFTkZiWHQ2WwIsm6UTQiCsUbodgEgAk3kileNjB0jFxWKUYCxAF0gA}{Open in Shinylive} - \if{html}{\out{}} - \if{html}{\out{}} + \if{html}{\out{}} + \if{html}{\out{}} } \item{example-2}{ \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAoksZwAjoNrv2CsBISqDC0ogT+uLpetHCk1Ky6ALz2Ts62AGTpuu7Rvv6B6BFR3rHxSSkuGVk53nkBRCbkoqRF0aUJyQ6VupnZnrVwfmAAsgCCAMrjrSVxHRVpPdX9PoP+TEREMNMxs+VdaUoAxLoAwgAiAJLjJ7r8UKRQunAAHrCoIkp3DwbGXNQA+l8oDZPvdHkZdAB3WikAAWKnYQMiICUul0ozO4wAMj9shjsUoAL6KCAAKyIKn+AGs4KxRIiwbYIfw4CYoMJSP8CPxQgR-uTKTS6cBoPB6UC5ABdJRKLQsUQARlxBFhFIIYn+ojgIg0cH4fggaLljFoUHoIi5qto6vFYOAwH8+Kx-klksiBCGoywwyK-hOAHlHAA5BwATV9YHGzgAGv45HJcKjdFqdeR+OUg44sc6ICSlGhULiVDCDWigeUkUm+EIRKJytXhGJS2jdKQYP8JIDQqQTfRBJprEmW7du-9jRWwf8Xj31JzRKg4B6h8PbmDRXpko7Mc68MvhynF6RygeNJqF0vDSvhyq1WJysbTea4Jbb7aHvatwSwK73Z6AOKuHguj+AAQsMWAANJYAqcYJnuK4nmm5SgeBUEwbul5XmiMAcrQ7wbroABioxYlGiaYVhJi0M8erlMRpGuBRw4klecFMcmM4PGOLATlx07MKe86Ls2V5AuuyFgE6ETwWiVHUOQjDlHJClnsJMktsadbJJpCrkVhLY4fJeEiHsqTqSxK5sVeEiMEQgioNxinJECU7PDOgnniJK5ibABGfjuemUbQ8kyEpwUqUJF76Ua8r3vKunqdhuH4aZLjmfBFlohZJIkrQJi6OwKgKbO2iDPGugopeojwhArCjOg7AFgAJN4kTNVqjA6IwJKEkoYCEpKQA}{Open in Shinylive} - \if{html}{\out{}} - \if{html}{\out{}} + \if{html}{\out{}} + \if{html}{\out{}} } } } diff --git a/man/tm_g_response.Rd b/man/tm_g_response.Rd index 478e393a2..4dd5e9d33 100644 --- a/man/tm_g_response.Rd +++ b/man/tm_g_response.Rd @@ -200,13 +200,13 @@ if (interactive()) { \describe{ \item{example-1}{ \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAokqUBiXVIhrqu-lCkULpwAB6wqCJKAUEGxlzUAPoxUDbRgcFGugDutKQAFirsKbi6IEq6uoxwAI6CtNXsPqKkxNREjIoQlTCtLKJxur0E-RWmHbrsWroqugTsCoSs1Iuli1qiq7qLsFuLUiyLcrbl3ZVDfYyiwMBaALp3g1DiJuqkHezD-Tf3d12VAF8lACuko0KhBio8gszildABefwZXBjPhCEQDRFo4RiGHnXSkGCJCSJaqiVAkURwPH43TUKD0OB+RGLLBiCkQKm6AAK7VImzwY3xZI5XMRKUSYVIzA0iXJcHmQtpKWg8AR2zAXyuqyV+KpIg06v1CtIctQCpptPO9MZzI1AGUmSbdFoWLQGSJEDqzlbKgR8kRaAQxOrXYx3fQRIl-YHg6JihkbostQKHqVFUsVngNQdGEc5Cifb7jRo4Px1YsCMtvb7zjBhJpInpEQAxACCABl7c5C7XKiZaKEy+r213XEX8f9aQXdbpQuqJVKZab5YqJ+cVbBmxqUzXi07DYiSyvzWu+3SGUyK2BHQbSC63R64F7Bev8TGgyHEWGI1GP3GEyCJNNUuVM7nTBYwA2PYUBgfNez7Y9hxZKCBQQ2t62oRsRBHTtu3Q30ByHctWzw8daynSclSnLouloExJhUchl20aljjKMZREKCBWDbdB2HBAASepSiEqlGB0TpgSUMAATuIA}{Open in Shinylive} - \if{html}{\out{}} - \if{html}{\out{}} + \if{html}{\out{}} + \if{html}{\out{}} } \item{example-2}{ \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAokqUBiXQGEAIgEkAZS9dfihSKF04AA9YVBElUPCDYy5qAH1EqBsEsIijXQB3WlIACxV2TNxdECVdXUY4AEdBWgb2CDFSYmoiRkUIOoBBHwCAGWT64bGlAF9+gCsiFTSAazhWUQrc23z+OBMoYVI0gn5aUQI0xeW1jeBoeE3MuQBdN2h0CZVi9lqQ3N0AF5-uFcH8+EIRKIgboIcIxL8BnVdKQYGkJGkGqJUCRRHBEcjkdQoPQ4NQYQowFgxDiIHjdAAFHqkUSUsFIwlY2n04GZNLRUjMDRpbFwAgEwnIzIPPTAylTUZsv6S3R4kQaGFqsXHUXi5Uq3TE0nkuVgAJk7W6LQsWgkkSIJUcg0EEpLAhiGHWxi2+giE6u2jup65YDAeUjRVgF4vKp6sAAIQAslgANJYABMbN0lK8AHlHAA5BwATUpcjk7INyK1Gjg-ApCeTaczeH1KpgR1ocVlugAYoNRgFnJWq6ZaFE6zD+4PXE7Cf0VRW27oojC+QKhTrUGKJSrpbAe+Hpq259WLRrgTWtzvl4SjWSG+b1aQrTa7XAHSfR7oXW6PcCvR9P1f0DBFMlDI9I2jWNfjNZwAA0s0pLBBi8VwwHLEcqyvSdTRQtDHW-DtqE0bspwHIcsINExx1wvsKNnKsF0lZi6mY-p+loExdHYFRyE3bR8XLao-lEMoIFYQZ0HYNBUAAEhaKpZLkvFGB0PpZiUMAZheIA}{Open in Shinylive} - \if{html}{\out{}} - \if{html}{\out{}} + \if{html}{\out{}} + \if{html}{\out{}} } } } diff --git a/man/tm_g_scatterplot.Rd b/man/tm_g_scatterplot.Rd index ae01d8861..5c1c306f7 100644 --- a/man/tm_g_scatterplot.Rd +++ b/man/tm_g_scatterplot.Rd @@ -280,13 +280,13 @@ if (interactive()) { \describe{ \item{example-1}{ \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAoksZwAjoNrv2CsBISqDC0ogT+uLpetHCk1Ky6ALz2Ts62AGTpuu7Rvv6BzgAepMwRUd6x8UkpLhlZOd55hETURIKMqLQEANYyZdGVCckOtUoAxLpSEGrUuvxQpFC6cIWwqCJK84sGxlzUAPpbUDabC0tGugDutKQAFirsR5EgSrrZno1w7NOipMStjEUEDeAGEAPIAJh2unBEKUAF8gUo0KhoSobn5gXMztUnq9dHwhCJRNVCcIxJi3m9SDB9hJ9mEFuQOq1SJSqW9qFB6HBZsl-ABlAhMmTrIikGG3IhdMQRfEcwq4s77FYldSkBmoOAEdkct5HaDwar+WFyrF63SiXnaiXJK0iDSa7W6i26Lk8vm6QXWjS6LQsWjckSIM2uqkEKUyknJf2MQP0ET7CPSggUo7AYAmyH+AC6OciOv8xAsZX8glQi16-jkclw8td9ptcH4xuaJbw9YtMGEmnWemSADEAIIAGQFzjr5tdJlohWb1WHY9cU45QIttc7uiG2MWKuKzEdoi1hZXVINsH7XrApo7p7ejd9dp9GqPzs3HPdvNbAuffoDQbgENbzDN5kyjapY3jRMwNTURHjODMszhMA8wLPw23CPAr3LSs4GrDc7ypB9yBbfkwBwqAq2AkDu2oXsRAXUdx0nEDTFnedByY5cwzXPUCItf4iEYfZ6G3I49zVQ9jxdDlzyNMibxYhtfyfB0X2k98qU-T1vTUv84wAoClLDGCxAg-8EzgJNI1gmTXXTTNr2zFD800jlCzAAAFLkyFLMA7FYLU-LsdwFngXysKLEhMMiMsK0ovCwF4njjOUtSON0AA5RwRxHVKux7Wg+0Ypd8r1Gc51I3RF3HTTkqpfi9VEWgAC8rNEpVd1VA91LfQi5MvJDQzSm1qmIp0T1Y7Tv1-SDDOGkybLMmMLOgpa4IcoaXLQqL21i8j4qomsyo5YiMri3CFtdWj6MvGqJzctjKpK2rCPqt5Go5RgiEufYTHUWJOqgCSeomuz9TOQ1Bqc5CTstFT4bUsHHumsifz0ubLKMx7TOjfSoKs3H4MWRCYdzfNdA87yoAi-aAqCyL-NCmkKFIfC4fvZ8Muy3KOYJQris40rHoqjL7rqzdPvDFo-oB20d2B7r1WR-rIYvVtFM04ixufFWpu5L80dm1bAKugT1vMgzLOslM0wQxyb1Qyn0Op2mr3pxK6eZ8K2aSqWLTOqqebyx6bqKhiheYkX2Kq8W3sl+teKBIFaBMXR2BUZl1W0L4a10F4sVEe4IFYId0HYFEABJvEiKurUYHRAQRJQwHhHMgA}{Open in Shinylive} - \if{html}{\out{}} - \if{html}{\out{}} + \if{html}{\out{}} + \if{html}{\out{}} } \item{example-2}{ \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAoksZwAjoNrv2CsBISqDC0ogT+uLpetHCk1Ky6ALz2Ts62AGTpuu7Rvv6BzgAepMwRUd6x8UkpLhlZOd55hETURIKMqLQEANYyZdGVCckOtUoAxLoAwgAiAJIAypO6-FCkULpwhbCoIkorawbGXNQA+vtQNnur60a6AO60pAAWKuznkSBKutmejXDsEDEpGIrUYigg3wAgtN5gAZQ7ZaFwpQAX3BACsiCoTr1WKI3tdbLd+HATFBhKQTgR+KECCdMdjcaJgNB4PjznIALpKJRoVAIlSPPwQ5bXarvL66PhCESiarS4RiYXfb6kGAnCQnMKrcgdVqkZUq77UKD0ODUar+eYEHUyHZEUhTJ5YghiCKSo2FcXXE6bErqSmiVBwAiGo3fc6svTJfxI2HukXh3Sic0hx3JFMiDRa4Ohj1J3Qms0WmNgeapjS6LQsWimkSIBMFlUEZ1dMTVauMWv0ERU1uu9nXYDAWMw+NgTmcyJ5sCQgDirjwun8ACEALJYADSWAAjGVVxvtwAmfxyOS4fNJzNpuD8S2zheNptSim0HbR3QAMUhsPmzgviYFiYtCFLe1Tfr+riAUa4JJuel66EMoprL6xTMNmQYhmG4aRrAH6jsieAId816VhmFaBrm2FJkW5r3uWWaOp23b1k+TYti67bJMxdZwH2nGDmsw4EeOk7Tn4D6LpEB5bru+5gOusknmAZ4Ac+yYUWBpaKdue5EdB4YwK+77gT+f5qc+wGgXeyQQX+xG6LB4bwQZIJEIwJz0Eh5yof6GFUQ5uHwPecZseGpHphpjE5lhDnGqadGlgxaZVjWvENvp6kcW2crcWlPZ8dlA7UQW5zCbOY7+GJcXNhJ85ScuCmHnJS4yce8lYJCkwNf4WDOHOswAPIAHJ6U5TYuepEVabow2OLCsIWU2RnUJoJm2WZ-41VZM12VBE0IZN4W0AAXnxXneihfroZRsUGRG1xRiFlWZQWEXVBFMV5vdKq0SWjXJZWPEFRlS0FkVXGpV2vH8TlBJCSOFWEWJugzvV8k6S1qk1dNNmNejr3LcZIimZBYNJjteN7Q540qkdRqMEQdwnGSrqRT510Bl9JUPWsT2lqFhPhRRH0UdzNV-fRIvA6xQtJhDuVQyxhX9kqZWI4LKMzpjynSWAnXdR1-VDaNp7029ml43NC3k4ZxMfntttGpTpP2T9tPfOb3wgiz6ixJdUC+Td4s-UF+FI+OTtRSl5HRZh33qZLSXS-lstR97quKzLKsCfDUDlZrU6oxJOsdV1PX68bI1jV7wuMTN1uLTVK1rSTG1k9tIG7ZtNOHfmTnguCtAmLo7AqLqAbaP8Z66J8IqiC8ECsJC6DsHyAAk3iRBvKaMDoYKokoYAopyQA}{Open in Shinylive} - \if{html}{\out{}} - \if{html}{\out{}} + \if{html}{\out{}} + \if{html}{\out{}} } } } diff --git a/man/tm_g_scatterplotmatrix.Rd b/man/tm_g_scatterplotmatrix.Rd index ecd6434f4..ec2645a59 100644 --- a/man/tm_g_scatterplotmatrix.Rd +++ b/man/tm_g_scatterplotmatrix.Rd @@ -188,13 +188,13 @@ if (interactive()) { \describe{ \item{example-1}{ \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAoksZwAjoNrv2CmlCkmgRw-ri6XrRwpNSsugC89k7OihAAxLpSEGrUuvyBULpwAB6wqCJK+aSFRrpc1AD6VVA2lQUGxgDutKQAFirszeEgSrq6xOakjFGiHXkFGCbM8H4QY2O0-AnjfmAAIq54uv4AYlhhx2AAknYX-s4AyndgAAq3R-4A4ucfYAByABlngAhQ7hfwAxzPACC7zkuFG6wkRB0jAg8DI2xM6lIREYq3W6wI7AATOEyboKQBGcm03Q0+nhBkk+GIwnUKD0ODUWaJYn+ACyJBYBF6rGeWDgqEE9DoBH8qUJrLW6w5EAkgigUga2JgtFiWJxeIJhJ2DIAzOFLbprdbqUyrUzlabdByuTztvywJ8ZDAoMp5b8ABLckQBiVEP0WUJgRXrZ3rVBEaUczQkT3sAAc1oAbAB2cI5gAM4QALAX6SX6QyqRWqQyixgc+EAJwJsYsOCFPnsc0AVgrfb7FqLDL7Rb7rep5oppZH5Kb4Wz7cy-FQGfNGFLC4rJIwNa34Ub1sbFMbFcbk90jYbW5X-Dg9FIGb3zIwdsPlMXX4-25-C7-PdfzjONRG4MQ5maRZljgE0Ni2RIqUQccERVMYJjINgGk2bYwJgcpYLZIldgOZ4zmeG5nkeZ43meb5nkBEEwUuSEYThVCXVEWgAC89ESFCiLGdxynUPikhcIiV1YLtGFwvFSHYPCCNJUci0QEkiw08IUN0YSORCbYHBcOQVx0CBBDEpSRHYL1RD9ahqGeeB+FoQQYGeDlGCkZ4SDobIFW0qs9NEwzkhXAh-RCBy4AQ3QrNg4kjOccITmhAEHhSQLwmCgzEiSlcvH9TRSDiRI0TxGB2B0qkiyrDTwqIURSF5XSIAqqqq0zOqixXVBGCIEwem2crGEqnStMrEClAAX1SAArIgVAaABrOBWFEQYClsWoFqW1b1pNXaIBWtbdgwqYZmec7pjEZ5NgCxEjpOjh-DAkRRGeN7bt+e7Yw43Qnv2s6iEmG6Pt+L7wfCL1fu2fxrtYbD+AVVJUiUNB11qFQehNZptiGRE+CEd7tiJ4QxDguoYAaCQGlECKghkcoiFIP0LuKSmxjdbk4bAB4GfIRhmefNnpmKMJBN0LQWFoTkScSOgms59ZmgaEophxOnUDgfk0JdeZqmgeBeeuy68ElwlRG5HXn0SK2RA0LWdeVl1udyRJ-Aea2NClmW5bERAJb1-Xxl6RaQha6Xpn9hpRXDinmmAYB4ZBzCzYAXXTlcQ-tm2YozfxOygZ4JDXZ4HyfB7g-1mBhE0AjQpcf6Q7GPEH3cWKkublvBuKfPElS9LXGrpULd0bOVYKNXig1x3RG13WW4N-1YDE17wKhsexkG6hBaxfVBadxel9dTkeY9vnvefKPZdlOBA-NkfTSjlqU9BxHfu7kO49oCPtml6gFlY5h1-gnAoSd17vX8JncEhBU5TA-sjP6W91i5w0P3HY-hSK-HIr8SivxqK-For8eivxGK-FBM8VivxYRVxProWuu9aANzyskFBE9LZX1wlfI+LtTRu15l7B218-Z31EA-L++sf5-0SDfGO0iwHVAgWASG0D07Q12IVMgPRxS-GIE1KGlw+oDR6CjSRnEr4YK9Fo4qujYH6Oas8Yxg1SB0JPow+uIhG7JRQa3Rg7cMFd18aYWgfdYqDwyuwsecZR56ymhAVItATC6HYCoQWOJtCwRMroEYKpRD9AgKwaE6B2AYwACTeHCOUq2jBUSpGmkoMA0105AA}{Open in Shinylive} - \if{html}{\out{}} - \if{html}{\out{}} + \if{html}{\out{}} + \if{html}{\out{}} } \item{example-2}{ \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAoksZwAjoNrv2CmlCkmgRw-ri6XrRwpNSsugC89k7OihAAxLoAwgAiAJIAypm6-IFQunAAHrCoIkolpGVGulzUAPr1UDZ1pQbGAO60pAAWKuwd4SBKuroAgtn5ADK9uoxzi1Oz2Vj5y6tb+UoAvqkAVkQqrQDWcKyiY6W2TfxwJlDCpK0E-LSiBK1nF2ut2A0Hgdw6cgAukolGhUMsVIM-BBph0EsVSrgNnwhCJROiccIxMjptNSDBWhJWr9AuRGDUiOTAoxaBUSaTptQoPQ4NR0f58gRaTIGaRdDBmaywhsOVoWLRuXj0XRRKR2RzUaVWpVSMwNNTUHACOqNZqGqC9Il-GsFtKUabSaJeUaxYknSJ9aJDcaZQ7OdzefywPlnRpdHKWYqxIg7X6OQQhucQvjEhGFfQRJ9E7Rk-cGsBgNb5rawJDIXIsfa47p3S64Px0T6wDMAOKuPC6fxYGaZdvhAXOAAa-grvr9MHetBqlqSLkr1emREYz3cDcSDjnY4dJlZ9fRADEZgt8q4qw7Un7R2eOR1tRVdeoPl6jSbTR0LUG5ttY3Gd9Q6eif50gaL5bqaXI8nyVrBqGYoUPwqDnGQogxngYEahGKa6E2AAKMzdgAsjkYSds2ABqBS5HYI7zguCZJmI6JytQghwFmDHgqUBZFt+paQuEuH4TMRHZCR1oUfkVE0dhfhgHhhFieRlHUWAchXguNawXu0G5AAcmRzh2LoxjOLp2S6AA8vuuh6dkjiZHYuQWbpP7VhO-5TiI6Ibqe1bqXGtZhm6sEgT614OhBgbQSGHpimmUYoa5cb0TmjGpvKUbsalnH5oWzb7P4Zb+dWgXkGuMnWm2ikzGRR7VdkACaNHoRy7maNO3nJLR1ZLiu2mzs43W-ru5WHsevlxhe55blN0xTakqS0CYujsCodKPtocA2LYkz2qIIwQKwMzoOwcIACTeOE51OowOiMKkhxKGAhyQkAA}{Open in Shinylive} - \if{html}{\out{}} - \if{html}{\out{}} + \if{html}{\out{}} + \if{html}{\out{}} } } } diff --git a/man/tm_missing_data.Rd b/man/tm_missing_data.Rd index 42a0303c7..ca70d2f69 100644 --- a/man/tm_missing_data.Rd +++ b/man/tm_missing_data.Rd @@ -14,7 +14,8 @@ tm_missing_data( list(caption = NULL)), `Combinations Main` = teal.widgets::ggplot2_args(labs = list(title = NULL))), pre_output = NULL, - post_output = NULL + post_output = NULL, + decorators = NULL ) } \arguments{ @@ -47,6 +48,9 @@ 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.} } \value{ Object of class \code{teal_module} to be used in \code{teal} applications. @@ -57,6 +61,22 @@ gain insights into the completeness of their data. It is useful for clinical data analysis within the context of \code{CDISC} standards and adaptable for general data analysis purposes. } +\section{Decorating \code{tm_missing_data}}{ + + +This module generates the following objects, which can be modified in place using decorators: +\itemize{ +\item \code{summary_plot_top} (\code{ggplot2}) +\item \code{summary_plot_bottom} (\code{ggplot2}) +\item \code{combination_plot_top} (\code{ggplot2}) +\item \code{combination_plot_bottom} (\code{ggplot2}) +\item \code{table} (\code{\link[DT:datatable]{DT::datatable()}}) +} + +For additional details and examples of decorators, refer to the vignette +\code{vignette("decorate-modules-output", package = "teal")} or the \code{\link[=teal_transform_module]{teal_transform_module()}} documentation. +} + \examples{ \dontshow{if (require("gridExtra", quietly = TRUE) && require("rlang", quietly = TRUE)) (if (getRversion() >= "3.4") withAutoprint else force)(\{ # examplesIf} # general example data @@ -113,13 +133,13 @@ if (interactive()) { \describe{ \item{example-1}{ \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAoksZwAjoNrv2CsBKMtPzOAB6kzP64ul60cKTUrLoAvPZOzrYAZJm67rG+-ozUUBASUTHe8YkpaS6KEADEulIQatS6cKGwqCK6-FCkUEr9gwbGXNQA+iNQNsMDUGO6AO60pAAWKuwz0SBKurme3r6toqTE1ESM9fu6UPz8k9CiS2YWmtahtnsQBwehwFE3RE7FEnkm3BIEnYX2iJkuV3YIlKGxhtgAVLlzLQTOwAIzRDAABgArIS8QB2OTUgC6SwAcgBBW7-W4AXyUtx8tBeRl03NEtxg5xYvOMwoIos5v35QVEwDpfOK6ES7AF0Xuj2e9QOEtFCqWyp6HD1jFEGoeTygoh1ulN8uA-gIrGo-hpiuM1owJnUpER9uAjsILrdNNtAaDUhYoaWXp9Gn9IrNgf8UcYofqbJu0HQSxUaz8MpmNR2QoEwjENT4QhEokLf10pBgkxgPNEKgk0wWcxl9XqON0atUzEsOhs31uok2EFYjPQ7DQqAAJN4Negl2DGDprkoORAwGyaUA}{Open in Shinylive} - \if{html}{\out{}} - \if{html}{\out{}} + \if{html}{\out{}} + \if{html}{\out{}} } \item{example-2}{ \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAoksZwAjoNrv2CsBKMtPzOAB6kzP64ul60cKTUrLoAvPZOzrYAZJm67rG+-ozUUBASUTHe8YkpaS6KEADEugDCACIAkgDKzbpwobCoIrr8UKRQSiNjBsZc1AD6k1A2E6NQ07oA7rSkABYq7IvRIEq6uZ7evhBipMTURIz1pwCCrZ0AMuuML+8nui9YnU+-06SgAvvUAFZEFRzADWcFYogOq1sRmGcBMUGEpDmBH4tFEBDmUJh8MRwGg8CRizkAF0lEo0Kh1iptn4IKdFjVDr8+EIRKIanzhGJ2adTqQYHMYATRCoJAtVssObp6vVaCZdOwVORmJYdDZbMcVaI9hBWE90OwmQASbzRW2iGQ6B5gpRgUG0oA}{Open in Shinylive} - \if{html}{\out{}} - \if{html}{\out{}} + \if{html}{\out{}} + \if{html}{\out{}} } } } diff --git a/man/tm_outliers.Rd b/man/tm_outliers.Rd index 194a8f14f..ff738de8d 100644 --- a/man/tm_outliers.Rd +++ b/man/tm_outliers.Rd @@ -151,13 +151,13 @@ if (interactive()) { \describe{ \item{example-1}{ \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAokqUBiXVIhrqu-lCkULpwAB6wqCJKAUEGxlzUAPoxUDbRgcFGugDutKQAFirsKbi6IEq6ugDCAPIATHHV9RVNdcDACmCojLQwLKyJANZwrJ0AumONonAAjokiEOwQjETZ7LV1cooQAL7bAFZEKkMjosUZtlmHx8OsZ9cQJxydG52lL814up3dvf1PnS2bggWhYokaBHyRwIYkS0xEGjg-HYoJ6UHoIkSkOhYnOQXaHzq4zGpQI7E6AAVqFAyG9vmA7KxUHA6Z07Iw4IF4LSwFttko0KhGio8uSIJUUroALz+DK4Fp8IQicEyxXCXEtSqkGCJIiCUh0GRnTWVXR6g20GSJVHS3R0USkMWm52yoKJMKkZgaOHMskml2ummwPQywlvf0u+FwDS2qPe0S+p0Bl3U+hwPyhsAAZXT0dIulRtHRIkQ4fFyed2NoMJVBZYRYxcCxUOruJSBLArzAE1J5MIJAIrLAglQQWGgLk8vLFcqcfI-FtnRHY5ZeAjAZgwk0kRDugAYgBBAAyWecU5nppMtFCSNth5Prmnye2FZfLsnEYIgTgEiIPS-SQ2jK9qOuugbuqEnrqKQPrRkmFYpNA8CLp2nznjOV7UOQjC2ph2GwX6T4VqitYkehF5VjWtqgtQghNpRbYZB2XY9nWjCiAAJHOSIfkRybcQuMo0XRzY4mc7YdKhRLdiSbGcQJvEXpUm5YbQO62g4LhgZUb4Brppr6W+2zbLQJi6OwKjYdB2hwDYtjlOWoiFBArAHug7CChxgi0KUnnTIwOiMNsOxKGAOxjEAA}{Open in Shinylive} - \if{html}{\out{}} - \if{html}{\out{}} + \if{html}{\out{}} + \if{html}{\out{}} } \item{example-2}{ \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAokqUBiXQGEAIgEkAZS9dfihSKF04AA9YVBElUPCDYy5qAH1EqBsEsIijXQB3WlIACxV2TNxdECVdXQBBHwCAGWTdRkaWpQBfRQgAKyIVNIBrOFZRCtzbfP44EyhhUjSCflpRAjTB4bGJ4Gh4Scy5AF03CAWNNK0WUTSoflFqNoOxdgAxWmpyRnZ1hxcVVEaDiHEywGACjAnWaUJOJyq6wwl1IREYcgxShujFEbQIJSGBDEaVEcBEGjg-HY2NoUHoIhWBNoRKOuQhUJhcIRpnUy2xdweT0xECUILaKmK7FqIVyugAvDLwrhpXwhCJcQrVcI3tK6qQYGkiIJSHQZJNdXVdEaTbQZNcWPLdHRRKQpRBLR7FVA0tFSMwrqJUHACG7PZ7Mq9HRymrC8Baw6TyaRHYng8tA8HQ2HPdQ6WSo2AAmS07oaXSRIgocr3dmPfjCWJHWX6XBGQ3WeF2dCY1yqiGOQBxVx4XRQgBCAFksABpLAARihGOrtY9qYp-AL9SHVfj2ZgS1ocT0Cve9WaAWcy5XdRMtCilMdp-Prhrtb6b93civdbCcAkaOZbh7UYR1nVdXc6kyH0oj9XkSSDftX2zCNYGPUduy6OMkLDW9vhkR1cJ+eDMwgz1+SbW5vxXetmUbBUbmoQRWxolkpk7SEMNjeEqn5AASNdyH4L9SNXYt1woxjmKZVjwQ4zkwG40tbn4sTBOE7C9wPI9HQBF9r3fbMDI9IzdAMvo+loExdD+VR-U0HQbFsGoa1EMoIFYep0HYEFeMEWgqh80lGB0dEeiUMBuhOIA}{Open in Shinylive} - \if{html}{\out{}} - \if{html}{\out{}} + \if{html}{\out{}} + \if{html}{\out{}} } } } diff --git a/man/tm_t_crosstable.Rd b/man/tm_t_crosstable.Rd index f4e4953e9..23ef6d6e2 100644 --- a/man/tm_t_crosstable.Rd +++ b/man/tm_t_crosstable.Rd @@ -175,13 +175,13 @@ if (interactive()) { \describe{ \item{example-1}{ \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAoksZwAjoNrv2CsIykUPQiov64ul60cKTUrLoAvPZOzooQAMS6UhBq1Lr8UEG6cAAesKgiSgVFRrpc1AD61VA2VYVQBsYA7rSkABYq7M0RIEq6ujCkBCyinRNTM2OmRIy67Fq6KroEfoSs1OG6-lpheEcoMIf+Uiz+crajEOPjk9OMosDAWgC633NQ4hM6lIK3Yrxmnx+3zS4wAvktwe9Pv5UIxaDAWKwGgBrOCsfy-OaiTwNEQQdgQRhELpghbve5KWFpABWRBUOLxoiG7VstVZ7NxrC5-IgHI4-kRpwiErpUvOqPRmLFdzSSjQqDmKl6fie+XaiT1QVwCIEwjEBr4QlCOuedRgDVIDQIVNEoiCITgNttumowTgeSS-gAwi7ZnZgpU8EtbSUDc0GqVSMwNA1RKg4Dto97mtB4AaZW8pVnbcSRBoDaWM460xmvd7nr76P782AAMr+qu6LQsWgRuCIcLF70EPpsgjmpLdtF9p2j2jjrnNZFgSUE74RTN7A5nY5y-ywK5gG6MFXG3X18aVjRwfgGzcEfaH493M8X54wYSaCp6JIOFyvt9dBWfgZBvA0-2cAC3xMWgSjApIADEAEEABlW1cc9vRhLCoOeeIknjRNk2rdNM0w20c1gH9zlXKNyOeK9SArDsUxrMjAJ9P0A3OdsyyYqdew9Ac6I4kcxwnLsexnMT5zEbkgmXWjfg3XYH23aUwBOQ8Dx3I84FuMB7lw+tGPg84tJEwCP2oL8RANZC0MgodbRguDb0Q1D0Oc3RsNtXyfKWNI0loEw1hUchiO0T17l0R5LwGCBWCQ9B2HVAASbwInS4lGB0Rg0nhCAwFhb4gA}{Open in Shinylive} - \if{html}{\out{}} - \if{html}{\out{}} + \if{html}{\out{}} + \if{html}{\out{}} } \item{example-2}{ \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAoksZwAjoNrv2CsIykUPQiov64ul60cKTUrLoAvPZOzooQAMS6AMIAIgCSAMpZuvxQQbpwAB6wqCJKpeVGulzUAPoNUDb1ZVAGxgDutKQAFirsHREgSrq6AII5BQAyfbqM80tKAL5pAFZEKq0A1nCsouM9tk38cCZQwqStBPy0ogStewfHp8DQ8GcdcgAukolGhUCsVEM-BAZh1EiUerhpro+EJQvDUcIxNCZjNSDBWg8CIwiKJREEQnAcbiZtRgnBqPD-FkSWT7ME6nhkTTKvCOq0qqRmBpWqJUHACNSabCer89El-OtFuFudLRAyJaR4eqRCKxRKpdLafTGQqwAUNRpdFoWLQOXBECqYUbcQRhvsCGJ4TbGHbKY93bRPf8esBgIqFsqwIDARFRIJ6OqtUkzBZNNYAbops6XbjaPxeU0AIQ29Bxc5BCIqYYyIaiCLUIgSIPcdgARjkEUl-hyZTg4V0-gACgB5Ap5AAaGgHw7Hk+opH8cjSuZp7lIgkYEHYcpDQTkwHzlUBK9X2yROZdOs1cH4TLAWRHjgAcg4AJpO1co+60Wry5IuBeX5EIw1zuHeSQOIBqpGiYtCVLe8IAGKzIsBSuJeNKnlhQHSvEST8oKwoPPq3aYbiHRyveSqflelrJro156uKZFfnS9AMveFq6lqPp+iIjpcuRNJuh6XpJHx9oBmJe5QGGEYbNGsaMQmSbwqmlgZhcWYwS6R4rKWtQcBMugvBgtwaCBDZNi21DtsuulGuum7bruFZQAeR4no5uLnj5MxMeQEGDuazgTrRuYwD+f7Iah6G4bmcEIcFKFoRhubYbimWnmkaS0CYujsCo5DEdoVLLjpzqiKMECsLM6DsGCAAk3gRM16qMDojBpJsShgJsgJAA}{Open in Shinylive} - \if{html}{\out{}} - \if{html}{\out{}} + \if{html}{\out{}} + \if{html}{\out{}} } } } diff --git a/man/tm_variable_browser.Rd b/man/tm_variable_browser.Rd index 752c4c83d..b36911ed4 100644 --- a/man/tm_variable_browser.Rd +++ b/man/tm_variable_browser.Rd @@ -104,13 +104,13 @@ if (interactive()) { \describe{ \item{example-1}{ \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAoksZwAjoNrv2CsKKoLADWdBBw-ri6XrRwpNSsugC89k7OtgBkGbruMb7+ABakMNQA7rT8UqSikdHecQnJqS6Z2bne+WAAVqIkdOS1MQ2JKQ4tSgDEulLhsrr8UKRQunAAHrCoIkoLSwbGXNQA+jtQNtuLy0a65aQFKuwnUSBKuro+tKJ7b4wfL7owpAILE+VwBQMYNQgr1KRHgUKuMLhfxMUFotzM1C+KLRBQxfwAwgB5ABMXyJxKUAF9FBAlGhUF8VGi-FD5hcmo8-nwhCJPilucIxCzXq9ioctCxaFB6CJDkwiKVRDJhSLXtRpXBMSl-AA1SXSkS6eWKmT+P6vGkWpQ02gmXTsFTkZiWHQ2WzPVmiO4QVgAQXQ7HpABJvFFg0rGDpGDTKUowJSALpAA}{Open in Shinylive} - \if{html}{\out{}} - \if{html}{\out{}} + \if{html}{\out{}} + \if{html}{\out{}} } \item{example-2}{ \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAoksZwAjoNrv2CsKKoLADWdBBw-ri6XrRwpNSsugC89k7OtgBkGbruMb7+ABakMNQA7rT8UqSikdHecQnJqS6Z2bne+WAAVqIkdOS1MQ2JKQ4tSgDEugDCACIAkgDK07pwAB6wqCK6-FCkUEp0TCwcgSFhcIoQu-sGxlzUAPo3UDZKL3e65aQFKuwvURASl0ugAgrNFgAZT6McFQ4Fg2Z2OzOGHg5GuCAAXyuXSIKkewTgrFE-z2UFsRh2cBMUGEpEeBH4tFEBEeeIJRJJwGg8FJLzkAF0lEo0KhPipaKQ-BAQR8UgCEXwhCJRE1lcIxDKQSDio8tCxaFB6CJHkwiKVRDJtTqQdRjXBqE1-AA1Q3G7bmy0yfwIkFXf1KK60Ey6dgqcjMSw6Gy2IGy3SiX4QVig9DsMUAEm8USzVsYOkYVyxSjAWMFQA}{Open in Shinylive} - \if{html}{\out{}} - \if{html}{\out{}} + \if{html}{\out{}} + \if{html}{\out{}} } } } From 2c3c2978351eced9b0ee578b9744afbbd3cc731a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andr=C3=A9=20Ver=C3=ADssimo?= <211358+averissimo@users.noreply.github.com> Date: Fri, 22 Nov 2024 16:59:57 +0000 Subject: [PATCH 3/7] fix: move all decoration to 1 chunk and fix problems --- R/tm_missing_data.R | 156 ++++++++++++++++++++++++-------------------- 1 file changed, 87 insertions(+), 69 deletions(-) diff --git a/R/tm_missing_data.R b/R/tm_missing_data.R index ab46c7ab1..e8b98d697 100644 --- a/R/tm_missing_data.R +++ b/R/tm_missing_data.R @@ -859,40 +859,6 @@ srv_missing_data <- function(id, data, reporter, filter_panel_api, dataname, par qenv }) - - decorated_summary_plot_q <- srv_transform_teal_data(id = "decorator", data = summary_plot_q, transformators = decorators) - decorated_summary_plot_grob_q <- reactive({ - q <- if (isTRUE(input$if_patients_plot)) { - within( - decorated_summary_plot_q(), - { - g1 <- ggplotGrob(summary_plot_top) - g2 <- ggplotGrob(summary_plot_bottom) - g <- gridExtra::gtable_cbind(g1, g2, size = "first") - g$heights <- grid::unit.pmax(g1$heights, g2$heights) - grid::grid.newpage() - } - ) - } else { - within( - decorated_summary_plot_q(), - { - g <- ggplotGrob(summary_plot_top) - grid::grid.newpage() - } - ) - } - teal.code::eval_code( - q, - quote(grid::grid.draw(g)) - ) - }) - - summary_plot_r <- reactive({ - req(summary_plot_q()) - decorated_summary_plot_grob_q()[["g"]] - }) - combination_cutoff_q <- reactive({ req(common_code_q()) teal.code::eval_code( @@ -1053,27 +1019,6 @@ srv_missing_data <- function(id, data, reporter, filter_panel_api, dataname, par ) }) - decorated_combination_plot_q <- srv_transform_teal_data(id = "decorator", data = combination_plot_q, transformators = decorators) - decorated_combination_plot_grob_q <- reactive({ - within( - decorated_combination_plot_q(), - { - g1 <- ggplotGrob(combination_plot_top) - g2 <- ggplotGrob(combination_plot_bottom) - - g <- gridExtra::gtable_rbind(g1, g2, size = "last") - g$heights[7] <- grid::unit(0.2, "null") # rescale to get the bar chart smaller - grid::grid.newpage() - grid::grid.draw(g) - } - ) - }) - - combination_plot_r <- reactive({ - req(combination_plot_q()) - decorated_combination_plot_grob_q()[["g"]] - }) - summary_table_q <- reactive({ req( input$summary_type == "By Variable Levels", # needed to trigger show r code update on tab change @@ -1117,14 +1062,14 @@ srv_missing_data <- function(id, data, reporter, filter_panel_api, dataname, par qenv, substitute( expr = { - summary_data <- ANL %>% + table <- ANL %>% dplyr::mutate(group_var_name := forcats::fct_na_value_to_level(as.factor(group_var_name), "NA")) %>% dplyr::group_by_at(group_var) %>% dplyr::filter(group_var_name %in% group_vals) - count_data <- dplyr::summarise(summary_data, n = dplyr::n()) + count_data <- dplyr::summarise(table, n = dplyr::n()) - summary_data <- dplyr::summarise_all(summary_data, summ_fn) %>% + table <- dplyr::summarise_all(table, summ_fn) %>% dplyr::mutate(group_var_name := paste0(group_var, ":", group_var_name, "(N=", count_data$n, ")")) %>% tidyr::pivot_longer(!dplyr::all_of(group_var), names_to = "Variable", values_to = "out") %>% tidyr::pivot_wider(names_from = group_var, values_from = "out") %>% @@ -1151,14 +1096,7 @@ srv_missing_data <- function(id, data, reporter, filter_panel_api, dataname, par ) } - teal.code::eval_code(qenv, quote(table <- DT::datatable(summary_data))) - }) - - decorated_summary_table_q <- - srv_transform_teal_data(id = "decorator", data = summary_table_q, transformators = decorators) - summary_table_r <- reactive({ - req(summary_table_q()) - decorated_summary_table_q()[["table"]] + within(qenv, quote(table <- DT::datatable(summary_data))) }) by_subject_plot_q <- reactive({ @@ -1267,12 +1205,92 @@ srv_missing_data <- function(id, data, reporter, filter_panel_api, dataname, par ) }) - decorated_by_subject_plot_q <- srv_transform_teal_data(id = "decorator", data = by_subject_plot_q, transformators = decorators) - decorated_by_subject_plot_print_q <- reactive(within(decorated_by_subject_plot_q(), print(plot))) + # Start decoration of objects + + # summary_plot_q + decorated_summary_plot_q_no_print <- srv_transform_teal_data( + id = "decorator", + data = summary_plot_q, + transformators = decorators + ) + decorated_summary_plot_q <- reactive({ + expr <- if (isTRUE(input$if_patients_plot)) { + quote({ + g1 <- ggplotGrob(summary_plot_top) + g2 <- ggplotGrob(summary_plot_bottom) + plot <- gridExtra::gtable_cbind(g1, g2, size = "first") + plot$heights <- grid::unit.pmax(g1$heights, g2$heights) + }) + } else { + quote({ + g1 <- ggplotGrob(summary_plot_top) + plot <- g1 + }) + } + # browser() + decorated_summary_plot_q_no_print() %>% + eval_code(expr) %>% + within({ + grid::grid.newpage() + grid::grid.draw(plot) + }) + }) + + # combination_plot_q + decorated_combination_plot_q_no_print <- srv_transform_teal_data( + id = "decorator", + data = combination_plot_q, + transformators = decorators + ) + decorated_combination_plot_q <- reactive({ + within( + decorated_combination_plot_q_no_print(), + { + g1 <- ggplotGrob(combination_plot_top) + g2 <- ggplotGrob(combination_plot_bottom) + + plot <- gridExtra::gtable_rbind(g1, g2, size = "last") + plot$heights[7] <- grid::unit(0.2, "null") # rescale to get the bar chart smaller + grid::grid.newpage() + grid::grid.draw(plot) + } + ) + }) + + # summary_table_q + decorated_summary_table_q <- srv_transform_teal_data( + id = "decorator", + data = summary_table_q, + transformators = decorators + ) + + # by_subject_plot_q + decorated_by_subject_plot_q_no_print <- srv_transform_teal_data( + id = "decorator", + data = by_subject_plot_q, + transformators = decorators + ) + decorated_by_subject_plot_q <- reactive(within(decorated_by_subject_plot_q_no_print(), print(plot))) + + # Output objects for use in widgets + summary_plot_r <- reactive({ + req(summary_plot_q()) + decorated_summary_plot_q()[["plot"]] + }) + + combination_plot_r <- reactive({ + req(combination_plot_q()) + decorated_combination_plot_q()[["plot"]] + }) + + summary_table_r <- reactive({ + req(summary_table_q()) + decorated_summary_table_q()[["table"]] + }) by_subject_plot_r <- reactive({ req(by_subject_plot_q()) # Ensure original errors are displayed - decorated_by_subject_plot_print_q()[["plot"]] + decorated_by_subject_plot_q()[["plot"]] }) output$levels_table <- DT::renderDataTable( From 314e06c778d32ebc833e55293edcfd2159d6f038 Mon Sep 17 00:00:00 2001 From: m7pr Date: Mon, 25 Nov 2024 12:28:22 +0100 Subject: [PATCH 4/7] remove browser --- R/tm_missing_data.R | 1 - 1 file changed, 1 deletion(-) diff --git a/R/tm_missing_data.R b/R/tm_missing_data.R index e8b98d697..6ab89d929 100644 --- a/R/tm_missing_data.R +++ b/R/tm_missing_data.R @@ -1227,7 +1227,6 @@ srv_missing_data <- function(id, data, reporter, filter_panel_api, dataname, par plot <- g1 }) } - # browser() decorated_summary_plot_q_no_print() %>% eval_code(expr) %>% within({ From 524da4c94255a78571e73c6befd164b067b2635b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andr=C3=A9=20Ver=C3=ADssimo?= <211358+averissimo@users.noreply.github.com> Date: Fri, 22 Nov 2024 17:17:52 +0000 Subject: [PATCH 5/7] chore: cleanup and remove warning --- R/tm_missing_data.R | 51 +++++++++++++++++++++++++-------------------- 1 file changed, 28 insertions(+), 23 deletions(-) diff --git a/R/tm_missing_data.R b/R/tm_missing_data.R index 6ab89d929..dcefced28 100644 --- a/R/tm_missing_data.R +++ b/R/tm_missing_data.R @@ -1055,21 +1055,19 @@ srv_missing_data <- function(id, data, reporter, filter_panel_api, dataname, par function(x) round(sum(is.na(x)) / length(x), 4) } - qenv <- common_code_q() - - if (!is.null(group_var)) { - qenv <- teal.code::eval_code( - qenv, + qenv <- if (!is.null(group_var)) { + teal.code::eval_code( + common_code_q(), substitute( expr = { - table <- ANL %>% + summary_data <- ANL %>% dplyr::mutate(group_var_name := forcats::fct_na_value_to_level(as.factor(group_var_name), "NA")) %>% dplyr::group_by_at(group_var) %>% dplyr::filter(group_var_name %in% group_vals) - count_data <- dplyr::summarise(table, n = dplyr::n()) + count_data <- dplyr::summarise(summary_data, n = dplyr::n()) - table <- dplyr::summarise_all(table, summ_fn) %>% + summary_data <- dplyr::summarise_all(summary_data, summ_fn) %>% dplyr::mutate(group_var_name := paste0(group_var, ":", group_var_name, "(N=", count_data$n, ")")) %>% tidyr::pivot_longer(!dplyr::all_of(group_var), names_to = "Variable", values_to = "out") %>% tidyr::pivot_wider(names_from = group_var, values_from = "out") %>% @@ -1081,8 +1079,8 @@ srv_missing_data <- function(id, data, reporter, filter_panel_api, dataname, par ) ) } else { - qenv <- teal.code::eval_code( - qenv, + teal.code::eval_code( + common_code_q(), substitute( expr = summary_data <- ANL %>% dplyr::summarise_all(summ_fn) %>% @@ -1096,7 +1094,7 @@ srv_missing_data <- function(id, data, reporter, filter_panel_api, dataname, par ) } - within(qenv, quote(table <- DT::datatable(summary_data))) + within(qenv, table <- DT::datatable(summary_data)) }) by_subject_plot_q <- reactive({ @@ -1257,11 +1255,14 @@ srv_missing_data <- function(id, data, reporter, filter_panel_api, dataname, par }) # summary_table_q - decorated_summary_table_q <- srv_transform_teal_data( + decorated_summary_table_q_no_print <- srv_transform_teal_data( id = "decorator", data = summary_table_q, transformators = decorators ) + decorated_summary_table_q <- reactive( + within(decorated_summary_table_q_no_print(), expr = table) + ) # by_subject_plot_q decorated_by_subject_plot_q_no_print <- srv_transform_teal_data( @@ -1269,7 +1270,9 @@ srv_missing_data <- function(id, data, reporter, filter_panel_api, dataname, par data = by_subject_plot_q, transformators = decorators ) - decorated_by_subject_plot_q <- reactive(within(decorated_by_subject_plot_q_no_print(), print(plot))) + decorated_by_subject_plot_q <- reactive( + within(decorated_by_subject_plot_q_no_print(), print(plot)) + ) # Output objects for use in widgets summary_plot_r <- reactive({ @@ -1297,12 +1300,14 @@ srv_missing_data <- function(id, data, reporter, filter_panel_api, dataname, par if (length(input$variables_select) == 0) { # so that zeroRecords message gets printed # using tibble as it supports weird column names, such as " " - tibble::tibble(` ` = logical(0)) + DT::datatable( + tibble::tibble(` ` = logical(0)), + options = list(language = list(zeroRecords = "No variable selected."), pageLength = input$levels_table_rows) + ) } else { summary_table_r() } - }, - options = list(language = list(zeroRecords = "No variable selected"), pageLength = input$levels_table_rows) + } ) pws1 <- teal.widgets::plot_with_settings_srv( @@ -1326,23 +1331,23 @@ srv_missing_data <- function(id, data, reporter, filter_panel_api, dataname, par width = plot_width ) - final_q <- reactive({ + decorated_final_q <- reactive({ req(input$summary_type) sum_type <- input$summary_type if (sum_type == "Summary") { - summary_plot_q() + decorated_summary_plot_q() } else if (sum_type == "Combinations") { - combination_plot_q() + decorated_combination_plot_q() } else if (sum_type == "By Variable Levels") { - summary_table_q() + decorated_summary_table_q() } else if (sum_type == "Grouped by Subject") { - by_subject_plot_q() + decorated_by_subject_plot_q() } }) teal.widgets::verbatim_popup_srv( id = "rcode", - verbatim_content = reactive(teal.code::get_code(req(final_q()))), + verbatim_content = reactive(teal.code::get_code(req(decorated_final_q()))), title = "Show R Code for Missing Data" ) @@ -1378,7 +1383,7 @@ srv_missing_data <- function(id, data, reporter, filter_panel_api, dataname, par card$append_text("Comment", "header3") card$append_text(comment) } - card$append_src(teal.code::get_code(req(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) From 1368c2cd3b9b949915bd720dabf206ec7c80a0de Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andr=C3=A9=20Ver=C3=ADssimo?= <211358+averissimo@users.noreply.github.com> Date: Mon, 25 Nov 2024 14:31:14 +0000 Subject: [PATCH 6/7] feat: add wrapper function --- R/utils.R | 32 ++++++++++++++++++++++++++++++++ 1 file changed, 32 insertions(+) diff --git a/R/utils.R b/R/utils.R index ec83a41ee..021efd610 100644 --- a/R/utils.R +++ b/R/utils.R @@ -280,3 +280,35 @@ assert_single_selection <- function(x, } invisible(TRUE) } + +#' Wrappers around `srv_transform_teal_data` that allows to decorate the data +#' @inheritParams teal::srv_transform_teal_data +#' @param expr (`expression`) to evaluate on the output of the decoration. +#' Must be inline code. See [within()] +#' Default is `NULL` which won't append any expression. +#' @details +#' `srv_decorate_teal_data` is a wrapper around `srv_transform_teal_data` that +#' allows to decorate the data with additional reactive expressions. +#' When original `teal_data` object is in error state, it will show that error +#' first. +#' +#' @keywords internal +srv_decorate_teal_data <- function(id, data, decorators, expr = NULL) { + expr_quosure <- rlang::enexpr(expr) + decorated_output <- srv_transform_teal_data(id, data = data, transformators = decorators) + + reactive({ + req(data(), decorated_output()) # ensure original errors are displayed + if (is.null(expr_quosure)) { + decorated_output() + } else { + eval_code(decorated_output(), expr_quosure) + } + }) +} + +#' @rdname srv_decorate_teal_data +#' @details +#' `ui_decorate_teal_data` is a wrapper around `ui_transform_teal_data`. +#' @keywords internal +ui_decorate_teal_data <- teal::ui_transform_teal_data From 4243950443854c262e6f6c6f624817f14701cb6c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andr=C3=A9=20Ver=C3=ADssimo?= <211358+averissimo@users.noreply.github.com> Date: Tue, 26 Nov 2024 07:41:57 +0000 Subject: [PATCH 7/7] fix: error on module and add subset_decorator --- R/tm_missing_data.R | 887 +++++++++++++++++++--------------- R/utils.R | 109 ++++- man/srv_decorate_teal_data.Rd | 32 ++ man/subset_decorators.Rd | 22 + man/tm_missing_data.Rd | 7 +- 5 files changed, 651 insertions(+), 406 deletions(-) create mode 100644 man/srv_decorate_teal_data.Rd create mode 100644 man/subset_decorators.Rd diff --git a/R/tm_missing_data.R b/R/tm_missing_data.R index dcefced28..71e9cad50 100644 --- a/R/tm_missing_data.R +++ b/R/tm_missing_data.R @@ -20,10 +20,9 @@ #' @section Decorating `tm_missing_data`: #' #' This module generates the following objects, which can be modified in place using decorators: -#' - `summary_plot_top` (`ggplot2`) -#' - `summary_plot_bottom` (`ggplot2`) -#' - `combination_plot_top` (`ggplot2`) -#' - `combination_plot_bottom` (`ggplot2`) +#' - `summary_plot` (`ggplot2 plot grob`) +#' - `combination_plot` (`ggplot2 plot grob`) +#' - `by_subject_plot` (`ggplot2`) #' - `table` ([DT::datatable()]) #' #' For additional details and examples of decorators, refer to the vignette @@ -134,7 +133,16 @@ 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) - checkmate::assert_list(decorators, "teal_transform_module", 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)) # End of assertions ans <- module( @@ -401,27 +409,31 @@ 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)) ), conditionalPanel( is_tab_active_js(ns("summary_type"), "Combinations"), - uiOutput(ns("cutoff")) + uiOutput(ns("cutoff")), + ui_decorate_teal_data(ns("dec_combination_plot"), decorators = subset_decorators("combination_plot", decorators)) + ), + 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)) ), conditionalPanel( is_tab_active_js(ns("summary_type"), "By Variable Levels"), - tagList( - uiOutput(ns("group_by_var_ui")), - uiOutput(ns("group_by_vals_ui")), - radioButtons( - ns("count_type"), - label = "Display missing as", - choices = c("counts", "proportions"), - selected = "counts", - inline = TRUE - ) - ) + uiOutput(ns("group_by_var_ui")), + uiOutput(ns("group_by_vals_ui")), + radioButtons( + ns("count_type"), + label = "Display missing as", + choices = c("counts", "proportions"), + selected = "counts", + inline = TRUE + ), + ui_decorate_teal_data(ns("dec_summary_table"), decorators = subset_decorators("summary_table", decorators)) ), - ui_transform_teal_data(ns("decorator"), transformators = decorators), teal.widgets::panel_item( title = "Plot settings", selectInput( @@ -435,241 +447,24 @@ encoding_missing_data <- function(id, summary_per_patient = FALSE, ggtheme, data ) } -# Server function for the missing data (single dataset) -srv_missing_data <- function(id, data, reporter, filter_panel_api, dataname, parent_dataname, - 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") - checkmate::assert_class(isolate(data()), "teal_data") +srv_summary_plot <- function(id, + data_r, + data_keys, + common_code_q, + data_parent_keys, + ggplot2_args, + # inputs + summary_type_r, + any_na_r, + ggtheme_r, + if_patients_plot_r) { moduleServer(id, function(input, output, session) { - ns <- session$ns - - prev_group_by_var <- reactiveVal("") - data_r <- reactive(data()[[dataname]]) - data_keys <- reactive(unlist(teal.data::join_keys(data())[[dataname]])) - - iv_r <- reactive({ - iv <- shinyvalidate::InputValidator$new() - iv$add_rule( - "variables_select", - shinyvalidate::sv_required("At least one reference variable needs to be selected.") - ) - iv$add_rule( - "variables_select", - ~ if (length(setdiff((.), data_keys())) < 1) "Please also select non-key columns." - ) - iv_summary_table <- shinyvalidate::InputValidator$new() - iv_summary_table$condition(~ isTRUE(input$summary_type == "By Variable Levels")) - iv_summary_table$add_rule("count_type", shinyvalidate::sv_required("Please select type of counts")) - iv_summary_table$add_rule( - "group_by_vals", - shinyvalidate::sv_required("Please select both group-by variable and values") - ) - iv_summary_table$add_rule( - "group_by_var", - ~ if (length(.) > 0 && length(input$variables_select) == 1 && (.) == input$variables_select) { - "If only one reference variable is selected it must not be the grouping variable." - } - ) - iv_summary_table$add_rule( - "variables_select", - ~ if (length(input$group_by_var) > 0 && length(.) == 1 && (.) == input$group_by_var) { - "If only one reference variable is selected it must not be the grouping variable." - } - ) - iv$add_validator(iv_summary_table) - iv$enable() - iv - }) - - - data_parent_keys <- reactive({ - if (length(parent_dataname) > 0 && parent_dataname %in% names(data())) { - keys <- teal.data::join_keys(data())[[dataname]] - if (parent_dataname %in% names(keys)) { - keys[[parent_dataname]] - } else { - keys[[dataname]] - } - } else { - NULL - } - }) - - common_code_q <- reactive({ - teal::validate_inputs(iv_r()) - - group_var <- input$group_by_var - anl <- data_r() - - qenv <- if (!is.null(selected_vars()) && length(selected_vars()) != ncol(anl)) { - teal.code::eval_code( - data(), - substitute( - expr = ANL <- anl_name[, selected_vars, drop = FALSE], - env = list(anl_name = as.name(dataname), selected_vars = selected_vars()) - ) - ) - } else { - teal.code::eval_code( - data(), - substitute(expr = ANL <- anl_name, env = list(anl_name = as.name(dataname))) - ) - } - - if (input$summary_type == "By Variable Levels" && !is.null(group_var) && !(group_var %in% selected_vars())) { - qenv <- teal.code::eval_code( - qenv, - substitute( - expr = ANL[[group_var]] <- anl_name[[group_var]], - env = list(group_var = group_var, anl_name = as.name(dataname)) - ) - ) - } - - new_col_name <- "**anyna**" - - qenv <- teal.code::eval_code( - qenv, - substitute( - expr = - create_cols_labels <- function(cols, just_label = FALSE) { - column_labels <- column_labels_value - column_labels[is.na(column_labels) | length(column_labels) == 0] <- "" - if (just_label) { - labels <- column_labels[cols] - } else { - labels <- ifelse(cols == new_col_name | cols == "", cols, paste0(column_labels[cols], " [", cols, "]")) - } - labels - }, - env = list( - new_col_name = new_col_name, - column_labels_value = c(teal.data::col_labels(data_r())[selected_vars()], - new_col_name = new_col_name - ) - ) - ) - ) - qenv - }) - - selected_vars <- reactive({ - req(input$variables_select) - keys <- data_keys() - vars <- unique(c(keys, input$variables_select)) - vars - }) - - vars_summary <- reactive({ - na_count <- data_r() %>% - sapply(function(x) mean(is.na(x)), USE.NAMES = TRUE) %>% - sort(decreasing = TRUE) - - tibble::tibble( - key = names(na_count), - value = unname(na_count), - label = cut(na_count, breaks = seq(from = 0, to = 1, by = 0.1), include.lowest = TRUE) - ) - }) - - output$variables <- renderUI({ - choices <- split(x = vars_summary()$key, f = vars_summary()$label, drop = TRUE) %>% rev() - selected <- choices <- unname(unlist(choices)) - - teal.widgets::optionalSelectInput( - ns("variables_select"), - label = "Select variables", - label_help = HTML(paste0("Dataset: ", tags$code(dataname))), - choices = teal.transform::variable_choices(data_r(), choices), - selected = selected, - multiple = TRUE - ) - }) - - observeEvent(input$filter_na, { - choices <- vars_summary() %>% - dplyr::select(!!as.name("key")) %>% - getElement(name = 1) - - selected <- vars_summary() %>% - dplyr::filter(!!as.name("value") > 0) %>% - dplyr::select(!!as.name("key")) %>% - getElement(name = 1) - - teal.widgets::updateOptionalSelectInput( - session = session, - inputId = "variables_select", - choices = teal.transform::variable_choices(data_r()), - selected = restoreInput(ns("variables_select"), selected) - ) - }) - - output$group_by_var_ui <- renderUI({ - all_choices <- teal.transform::variable_choices(data_r()) - cat_choices <- all_choices[!sapply(data_r(), function(x) is.numeric(x) || inherits(x, "POSIXct"))] - validate( - need(cat_choices, "Dataset does not have any non-numeric or non-datetime variables to use to group data with") - ) - teal.widgets::optionalSelectInput( - ns("group_by_var"), - label = "Group by variable", - choices = cat_choices, - selected = `if`( - is.null(isolate(input$group_by_var)), - cat_choices[1], - isolate(input$group_by_var) - ), - multiple = FALSE, - label_help = paste0("Dataset: ", dataname) - ) - }) - - output$group_by_vals_ui <- renderUI({ - req(input$group_by_var) - - choices <- teal.transform::value_choices(data_r(), input$group_by_var, input$group_by_var) - prev_choices <- isolate(input$group_by_vals) - - # determine selected value based on filtered data - # display those previously selected values that are still available - selected <- if (!is.null(prev_choices) && any(prev_choices %in% choices)) { - prev_choices[match(choices[choices %in% prev_choices], prev_choices)] - } else if ( - !is.null(prev_choices) && - !any(prev_choices %in% choices) && - isolate(prev_group_by_var()) == input$group_by_var - ) { - # if not any previously selected value is available and the grouping variable is the same, - # then display NULL - NULL - } else { - # if new grouping variable (i.e. not any previously selected value is available), - # then display all choices - choices - } - - prev_group_by_var(input$group_by_var) # set current group_by_var - validate(need(length(choices) < 100, "Please select group-by variable with fewer than 100 unique values")) - - teal.widgets::optionalSelectInput( - ns("group_by_vals"), - label = "Filter levels", - choices = choices, - selected = selected, - multiple = TRUE, - label_help = paste0("Dataset: ", dataname) - ) - }) - summary_plot_q <- reactive({ - req(input$summary_type == "Summary") # needed to trigger show r code update on tab change + req(summary_type_r() == "Summary") # needed to trigger show r code update on tab change teal::validate_has_data(data_r(), 1) qenv <- common_code_q() - - if (input$any_na) { + if (any_na_r()) { new_col_name <- "**anyna**" qenv <- teal.code::eval_code( qenv, @@ -713,7 +508,7 @@ srv_missing_data <- function(id, data, reporter, filter_panel_api, dataname, par ) # always set "**anyna**" level as the last one - if (isolate(input$any_na)) { + if (isolate(any_na_r())) { qenv <- teal.code::eval_code( qenv, quote(x_levels <- c(setdiff(x_levels, "**anyna**"), "**anyna**")) @@ -733,7 +528,7 @@ srv_missing_data <- function(id, data, reporter, filter_panel_api, dataname, par parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args( all_ggplot2_args, - ggtheme = input$ggtheme + ggtheme = ggtheme_r() ) qenv <- teal.code::eval_code( @@ -774,7 +569,7 @@ srv_missing_data <- function(id, data, reporter, filter_panel_api, dataname, par ) ) - if (isTRUE(input$if_patients_plot)) { + if (isTRUE(if_patients_plot_r())) { qenv <- teal.code::eval_code( qenv, substitute( @@ -815,7 +610,7 @@ srv_missing_data <- function(id, data, reporter, filter_panel_api, dataname, par parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args( all_ggplot2_args, - ggtheme = input$ggtheme + ggtheme = ggtheme_r() ) qenv <- teal.code::eval_code( @@ -856,44 +651,40 @@ srv_missing_data <- function(id, data, reporter, filter_panel_api, dataname, par ) ) } - qenv - }) - - combination_cutoff_q <- reactive({ - req(common_code_q()) - teal.code::eval_code( - common_code_q(), - quote( - combination_cutoff <- ANL %>% - dplyr::mutate_all(is.na) %>% - dplyr::group_by_all() %>% - dplyr::tally() %>% - dplyr::ungroup() - ) - ) - }) - - output$cutoff <- renderUI({ - x <- combination_cutoff_q()[["combination_cutoff"]]$n - - # select 10-th from the top - n <- length(x) - idx <- max(1, n - 10) - prev_value <- isolate(input$combination_cutoff) - value <- `if`( - is.null(prev_value) || prev_value > max(x) || prev_value < min(x), - sort(x, partial = idx)[idx], prev_value - ) - - teal.widgets::optionalSliderInputValMinMax( - ns("combination_cutoff"), - "Combination cut-off", - c(value, range(x)) - ) + + arrange_expr <- if (isTRUE(if_patients_plot_r())) { + quote({ + g1 <- ggplotGrob(summary_plot_top) + g2 <- ggplotGrob(summary_plot_bottom) + summary_plot <- gridExtra::gtable_cbind(g1, g2, size = "first") + summary_plot$heights <- grid::unit.pmax(g1$heights, g2$heights) + }) + } else { + quote({ + g1 <- ggplotGrob(summary_plot_top) + summary_plot <- g1 + }) + } + teal.code::eval_code(qenv, arrange_expr) }) + }) +} +srv_combination_plot <- function(id, + data_r, + common_code_q, + data_keys, + data_parent_keys, + combination_cutoff_q, + ggplot2_args, + # inputs + summary_type_r, + combination_cutoff_r, + ggtheme_r, + variables_select_r) { + moduleServer(id, function(input, output, session) { combination_plot_q <- reactive({ - req(input$summary_type == "Combinations", input$combination_cutoff, combination_cutoff_q()) + req(summary_type_r() == "Combinations", combination_cutoff_r(), combination_cutoff_q()) teal::validate_has_data(data_r(), 1) qenv <- teal.code::eval_code( @@ -904,12 +695,12 @@ srv_missing_data <- function(id, data, reporter, filter_panel_api, dataname, par dplyr::mutate(id = rank(-n, ties.method = "first")) %>% tidyr::pivot_longer(-c(n, id), names_to = "key", values_to = "value") %>% dplyr::arrange(n), - env = list(combination_cutoff_value = input$combination_cutoff) + env = list(combination_cutoff_value = combination_cutoff_r()) ) ) # find keys in dataset not selected in the UI and remove them from dataset - keys_not_selected <- setdiff(data_keys(), input$variables_select) + keys_not_selected <- setdiff(data_keys(), variables_select_r()) if (length(keys_not_selected) > 0) { qenv <- teal.code::eval_code( qenv, @@ -967,10 +758,10 @@ srv_missing_data <- function(id, data, reporter, filter_panel_api, dataname, par parsed_ggplot2_args2 <- teal.widgets::parse_ggplot2_args( all_ggplot2_args2, - ggtheme = input$ggtheme + ggtheme = ggtheme_r() ) - teal.code::eval_code( + qenv <- teal.code::eval_code( qenv, substitute( expr = { @@ -1017,11 +808,34 @@ srv_missing_data <- function(id, data, reporter, filter_panel_api, dataname, par ) ) ) + + within(qenv, { + g1 <- ggplotGrob(combination_plot_top) + g2 <- ggplotGrob(combination_plot_bottom) + + combination_plot <- gridExtra::gtable_rbind(g1, g2, size = "last") + combination_plot$heights[7] <- grid::unit(0.2, "null") # rescale to get the bar chart smaller + }) }) + }) +} - summary_table_q <- reactive({ +srv_summary_table <- function(id, + data_r, + common_code_q, + data_keys, + data_parent_keys, + selected_vars, + # inputs + summary_type_r, + group_by_var_r, + group_by_vals_r, + variables_select_r, + count_type_r) { + moduleServer(id, function(input, output, session) { + summary_table_q_r <- reactive({ req( - input$summary_type == "By Variable Levels", # needed to trigger show r code update on tab change + summary_type_r() == "By Variable Levels", # needed to trigger show r code update on tab change common_code_q() ) teal::validate_has_data(data_r(), 1) @@ -1029,7 +843,7 @@ srv_missing_data <- function(id, data, reporter, filter_panel_api, dataname, par # extract the ANL dataset for use in further validation anl <- common_code_q()[["ANL"]] - group_var <- input$group_by_var + group_var <- group_by_var_r() validate( need( is.null(group_var) || @@ -1038,10 +852,10 @@ srv_missing_data <- function(id, data, reporter, filter_panel_api, dataname, par ) ) - group_vals <- input$group_by_vals - variables_select <- input$variables_select + group_vals <- group_by_vals_r() + variables_select <- variables_select_r() vars <- unique(variables_select, group_var) - count_type <- input$count_type + count_type <- count_type_r() if (!is.null(selected_vars()) && length(selected_vars()) != ncol(anl)) { variables <- selected_vars() @@ -1049,7 +863,7 @@ srv_missing_data <- function(id, data, reporter, filter_panel_api, dataname, par variables <- colnames(anl) } - summ_fn <- if (input$count_type == "counts") { + summ_fn <- if (count_type == "counts") { function(x) sum(is.na(x)) } else { function(x) round(sum(is.na(x)) / length(x), 4) @@ -1084,7 +898,8 @@ srv_missing_data <- function(id, data, reporter, filter_panel_api, dataname, par substitute( expr = summary_data <- ANL %>% dplyr::summarise_all(summ_fn) %>% - tidyr::pivot_longer(dplyr::everything(), + tidyr::pivot_longer( + dplyr::everything(), names_to = "Variable", values_to = paste0("Missing (N=", nrow(ANL), ")") ) %>% @@ -1096,10 +911,22 @@ srv_missing_data <- function(id, data, reporter, filter_panel_api, dataname, par within(qenv, table <- DT::datatable(summary_data)) }) + }) +} +srv_by_subject_plot <- function(id, + data_r, + common_code_q, + data_keys, + data_parent_keys, + ggplot2_args, + # inputs + summary_type_r, + ggtheme_r) { + moduleServer(id, function(input, output, session) { by_subject_plot_q <- reactive({ # needed to trigger show r code update on tab change - req(input$summary_type == "Grouped by Subject", common_code_q()) + req(summary_type_r() == "Grouped by Subject", common_code_q()) teal::validate_has_data(data_r(), 1) @@ -1116,7 +943,7 @@ srv_missing_data <- function(id, data, reporter, filter_panel_api, dataname, par parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args( all_ggplot2_args, - ggtheme = input$ggtheme + ggtheme = ggtheme_r() ) teal.code::eval_code( @@ -1172,7 +999,7 @@ srv_missing_data <- function(id, data, reporter, filter_panel_api, dataname, par teal.code::eval_code( substitute( expr = { - plot <- ggplot(summary_plot_patients, aes( + by_subject_plot <- ggplot(summary_plot_patients, aes( x = factor(id, levels = order_subjects), y = factor(col, levels = ordered_columns[["column"]]), fill = isna @@ -1202,114 +1029,401 @@ srv_missing_data <- function(id, data, reporter, filter_panel_api, dataname, par ) ) }) + }) +} + +# Server function for the missing data (single dataset) +srv_missing_data <- function(id, + data, + reporter, + filter_panel_api, + dataname, + parent_dataname, + 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") + checkmate::assert_class(isolate(data()), "teal_data") + moduleServer(id, function(input, output, session) { + ns <- session$ns - # Start decoration of objects + prev_group_by_var <- reactiveVal("") + data_r <- reactive(data()[[dataname]]) + data_keys <- reactive(unlist(teal.data::join_keys(data())[[dataname]])) - # summary_plot_q - decorated_summary_plot_q_no_print <- srv_transform_teal_data( - id = "decorator", - data = summary_plot_q, - transformators = decorators - ) - decorated_summary_plot_q <- reactive({ - expr <- if (isTRUE(input$if_patients_plot)) { - quote({ - g1 <- ggplotGrob(summary_plot_top) - g2 <- ggplotGrob(summary_plot_bottom) - plot <- gridExtra::gtable_cbind(g1, g2, size = "first") - plot$heights <- grid::unit.pmax(g1$heights, g2$heights) - }) + iv_r <- reactive({ + iv <- shinyvalidate::InputValidator$new() + iv$add_rule( + "variables_select", + shinyvalidate::sv_required("At least one reference variable needs to be selected.") + ) + iv$add_rule( + "variables_select", + ~ if (length(setdiff((.), data_keys())) < 1) "Please also select non-key columns." + ) + iv_summary_table <- shinyvalidate::InputValidator$new() + iv_summary_table$condition(~ isTRUE(input$summary_type == "By Variable Levels")) + iv_summary_table$add_rule("count_type", shinyvalidate::sv_required("Please select type of counts")) + iv_summary_table$add_rule( + "group_by_vals", + shinyvalidate::sv_required("Please select both group-by variable and values") + ) + iv_summary_table$add_rule( + "group_by_var", + ~ if (length(.) > 0 && length(input$variables_select) == 1 && (.) == input$variables_select) { + "If only one reference variable is selected it must not be the grouping variable." + } + ) + iv_summary_table$add_rule( + "variables_select", + ~ if (length(input$group_by_var) > 0 && length(.) == 1 && (.) == input$group_by_var) { + "If only one reference variable is selected it must not be the grouping variable." + } + ) + iv$add_validator(iv_summary_table) + iv$enable() + iv + }) + + data_parent_keys <- reactive({ + if (length(parent_dataname) > 0 && parent_dataname %in% names(data())) { + keys <- teal.data::join_keys(data())[[dataname]] + if (parent_dataname %in% names(keys)) { + keys[[parent_dataname]] + } else { + keys[[dataname]] + } } else { - quote({ - g1 <- ggplotGrob(summary_plot_top) - plot <- g1 - }) + NULL } - decorated_summary_plot_q_no_print() %>% - eval_code(expr) %>% - within({ - grid::grid.newpage() - grid::grid.draw(plot) - }) }) - # combination_plot_q - decorated_combination_plot_q_no_print <- srv_transform_teal_data( - id = "decorator", - data = combination_plot_q, - transformators = decorators - ) - decorated_combination_plot_q <- reactive({ - within( - decorated_combination_plot_q_no_print(), - { - g1 <- ggplotGrob(combination_plot_top) - g2 <- ggplotGrob(combination_plot_bottom) - - plot <- gridExtra::gtable_rbind(g1, g2, size = "last") - plot$heights[7] <- grid::unit(0.2, "null") # rescale to get the bar chart smaller - grid::grid.newpage() - grid::grid.draw(plot) - } + common_code_q <- reactive({ + teal::validate_inputs(iv_r()) + + group_var <- input$group_by_var + anl <- data_r() + + qenv <- if (!is.null(selected_vars()) && length(selected_vars()) != ncol(anl)) { + teal.code::eval_code( + data(), + substitute( + expr = ANL <- anl_name[, selected_vars, drop = FALSE], + env = list(anl_name = as.name(dataname), selected_vars = selected_vars()) + ) + ) + } else { + teal.code::eval_code( + data(), + substitute(expr = ANL <- anl_name, env = list(anl_name = as.name(dataname))) + ) + } + + if (input$summary_type == "By Variable Levels" && !is.null(group_var) && !(group_var %in% selected_vars())) { + qenv <- teal.code::eval_code( + qenv, + substitute( + expr = ANL[[group_var]] <- anl_name[[group_var]], + env = list(group_var = group_var, anl_name = as.name(dataname)) + ) + ) + } + + new_col_name <- "**anyna**" + + qenv <- teal.code::eval_code( + qenv, + substitute( + expr = + create_cols_labels <- function(cols, just_label = FALSE) { + column_labels <- column_labels_value + column_labels[is.na(column_labels) | length(column_labels) == 0] <- "" + if (just_label) { + labels <- column_labels[cols] + } else { + labels <- ifelse(cols == new_col_name | cols == "", cols, paste0(column_labels[cols], " [", cols, "]")) + } + labels + }, + env = list( + new_col_name = new_col_name, + column_labels_value = c(teal.data::col_labels(data_r())[selected_vars()], + new_col_name = new_col_name + ) + ) + ) ) + qenv }) - # summary_table_q - decorated_summary_table_q_no_print <- srv_transform_teal_data( - id = "decorator", - data = summary_table_q, - transformators = decorators + selected_vars <- reactive({ + req(input$variables_select) + keys <- data_keys() + vars <- unique(c(keys, input$variables_select)) + vars + }) + + vars_summary <- reactive({ + na_count <- data_r() %>% + sapply(function(x) mean(is.na(x)), USE.NAMES = TRUE) %>% + sort(decreasing = TRUE) + + tibble::tibble( + key = names(na_count), + value = unname(na_count), + label = cut(na_count, breaks = seq(from = 0, to = 1, by = 0.1), include.lowest = TRUE) + ) + }) + + # Keep encoding panel up-to-date + output$variables <- renderUI({ + choices <- split(x = vars_summary()$key, f = vars_summary()$label, drop = TRUE) %>% rev() + selected <- choices <- unname(unlist(choices)) + + teal.widgets::optionalSelectInput( + ns("variables_select"), + label = "Select variables", + label_help = HTML(paste0("Dataset: ", tags$code(dataname))), + choices = teal.transform::variable_choices(data_r(), choices), + selected = selected, + multiple = TRUE + ) + }) + + observeEvent(input$filter_na, { + choices <- vars_summary() %>% + dplyr::select(!!as.name("key")) %>% + getElement(name = 1) + + selected <- vars_summary() %>% + dplyr::filter(!!as.name("value") > 0) %>% + dplyr::select(!!as.name("key")) %>% + getElement(name = 1) + + teal.widgets::updateOptionalSelectInput( + session = session, + inputId = "variables_select", + choices = teal.transform::variable_choices(data_r()), + selected = restoreInput(ns("variables_select"), selected) + ) + }) + + output$group_by_var_ui <- renderUI({ + all_choices <- teal.transform::variable_choices(data_r()) + cat_choices <- all_choices[!sapply(data_r(), function(x) is.numeric(x) || inherits(x, "POSIXct"))] + validate( + need(cat_choices, "Dataset does not have any non-numeric or non-datetime variables to use to group data with") + ) + teal.widgets::optionalSelectInput( + ns("group_by_var"), + label = "Group by variable", + choices = cat_choices, + selected = `if`( + is.null(isolate(input$group_by_var)), + cat_choices[1], + isolate(input$group_by_var) + ), + multiple = FALSE, + label_help = paste0("Dataset: ", dataname) + ) + }) + + output$group_by_vals_ui <- renderUI({ + req(input$group_by_var) + + choices <- teal.transform::value_choices(data_r(), input$group_by_var, input$group_by_var) + prev_choices <- isolate(input$group_by_vals) + + # determine selected value based on filtered data + # display those previously selected values that are still available + selected <- if (!is.null(prev_choices) && any(prev_choices %in% choices)) { + prev_choices[match(choices[choices %in% prev_choices], prev_choices)] + } else if ( + !is.null(prev_choices) && + !any(prev_choices %in% choices) && + isolate(prev_group_by_var()) == input$group_by_var + ) { + # if not any previously selected value is available and the grouping variable is the same, + # then display NULL + NULL + } else { + # if new grouping variable (i.e. not any previously selected value is available), + # then display all choices + choices + } + + prev_group_by_var(input$group_by_var) # set current group_by_var + validate(need(length(choices) < 100, "Please select group-by variable with fewer than 100 unique values")) + teal.widgets::optionalSelectInput( + ns("group_by_vals"), + label = "Filter levels", + choices = choices, + selected = selected, + multiple = TRUE, + label_help = paste0("Dataset: ", dataname) + ) + }) + + combination_cutoff_q <- reactive({ + req(common_code_q()) + teal.code::eval_code( + common_code_q(), + quote( + combination_cutoff <- ANL %>% + dplyr::mutate_all(is.na) %>% + dplyr::group_by_all() %>% + dplyr::tally() %>% + dplyr::ungroup() + ) + ) + }) + + output$cutoff <- renderUI({ + x <- combination_cutoff_q()[["combination_cutoff"]]$n + + # select 10-th from the top + n <- length(x) + idx <- max(1, n - 10) + prev_value <- isolate(input$combination_cutoff) + value <- `if`( + is.null(prev_value) || prev_value > max(x) || prev_value < min(x), + sort(x, partial = idx)[idx], prev_value + ) + + teal.widgets::optionalSliderInputValMinMax( + ns("combination_cutoff"), + "Combination cut-off", + c(value, range(x)) + ) + }) + + # Common inputs in build functions + summary_type_r <- reactive(input$summary_type) + ggtheme_r <- reactive(input$ggtheme) + + # Building qenvs + summary_plot_q <- srv_summary_plot( + "summary_plot", + data_r, + data_keys, + common_code_q, + data_parent_keys, + ggplot2_args, + summary_type_r, + reactive(input$any_na), + ggtheme_r, + reactive(input$if_patients_plot) ) - decorated_summary_table_q <- reactive( - within(decorated_summary_table_q_no_print(), expr = table) + + combination_plot_q <- srv_combination_plot( + "combination_plot", + data_r, + common_code_q, + data_keys, + data_parent_keys, + combination_cutoff_q, + ggplot2_args, + summary_type_r, + reactive(input$combination_cutoff), + ggtheme_r, + reactive(input$variables_select) ) - # by_subject_plot_q - decorated_by_subject_plot_q_no_print <- srv_transform_teal_data( - id = "decorator", - data = by_subject_plot_q, - transformators = decorators + summary_table_q <- srv_summary_table( + "summary_table", + data_r, + common_code_q, + data_keys, + data_parent_keys, + selected_vars, + summary_type_r, + reactive(input$group_by_var), + reactive(input$group_by_vals), + reactive(input$variables_select), + reactive(input$count_type) + ) + + by_subject_plot_q <- srv_by_subject_plot( + "by_subject_plot", + data_r, + common_code_q, + data_keys, + data_parent_keys, + ggplot2_args, + summary_type_r, + ggtheme_r + ) + + # Decorated outputs + + # Summary_plot_q + decorated_summary_plot_q <- srv_decorate_teal_data( + id = "dec_summary_plot", + data = summary_plot_q, + decorators = subset_decorators("summary_plot", decorators), + expr = { + grid::grid.newpage() + grid::grid.draw(summary_plot) + } + ) + + decorated_combination_plot_q <- srv_decorate_teal_data( + id = "dec_combination_plot", + data = combination_plot_q, + decorators = subset_decorators("combination_plot", decorators), + expr = { + grid::grid.newpage() + grid::grid.draw(combination_plot) + } ) - decorated_by_subject_plot_q <- reactive( - within(decorated_by_subject_plot_q_no_print(), print(plot)) + + decorated_summary_table_q <- srv_decorate_teal_data( + id = "dec_summary_table", + data = summary_table_q, + decorators = subset_decorators("summary_table", decorators), + expr = table ) - # Output objects for use in widgets + 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), + expr = print(by_subject_plot) + ) + + # Plots & tables reactives + summary_plot_r <- reactive({ - req(summary_plot_q()) - decorated_summary_plot_q()[["plot"]] + req(decorated_summary_plot_q())[["summary_plot"]] }) combination_plot_r <- reactive({ - req(combination_plot_q()) - decorated_combination_plot_q()[["plot"]] + req(decorated_combination_plot_q())[["combination_plot"]] }) summary_table_r <- reactive({ - req(summary_table_q()) - decorated_summary_table_q()[["table"]] + req(decorated_summary_table_q()) + + if (length(input$variables_select) == 0) { + # so that zeroRecords message gets printed + # using tibble as it supports weird column names, such as " " + DT::datatable( + tibble::tibble(` ` = logical(0)), + options = list(language = list(zeroRecords = "No variable selected."), pageLength = input$levels_table_rows) + ) + } else { + decorated_summary_table_q()[["table"]] + } }) by_subject_plot_r <- reactive({ - req(by_subject_plot_q()) # Ensure original errors are displayed - decorated_by_subject_plot_q()[["plot"]] + req(decorated_by_subject_plot_q()[["by_subject_plot"]]) }) - output$levels_table <- DT::renderDataTable( - expr = { - if (length(input$variables_select) == 0) { - # so that zeroRecords message gets printed - # using tibble as it supports weird column names, such as " " - DT::datatable( - tibble::tibble(` ` = logical(0)), - options = list(language = list(zeroRecords = "No variable selected."), pageLength = input$levels_table_rows) - ) - } else { - summary_table_r() - } - } - ) - + # Generate output pws1 <- teal.widgets::plot_with_settings_srv( id = "summary_plot", plot_r = summary_plot_r, @@ -1324,6 +1438,8 @@ srv_missing_data <- function(id, data, reporter, filter_panel_api, dataname, par width = plot_width ) + output$levels_table <- DT::renderDataTable(summary_table_r()) + pws3 <- teal.widgets::plot_with_settings_srv( id = "by_subject_plot", plot_r = by_subject_plot_r, @@ -1332,8 +1448,7 @@ srv_missing_data <- function(id, data, reporter, filter_panel_api, dataname, par ) decorated_final_q <- reactive({ - req(input$summary_type) - sum_type <- input$summary_type + sum_type <- req(input$summary_type) if (sum_type == "Summary") { decorated_summary_plot_q() } else if (sum_type == "Combinations") { diff --git a/R/utils.R b/R/utils.R index 021efd610..750911a6a 100644 --- a/R/utils.R +++ b/R/utils.R @@ -283,27 +283,37 @@ assert_single_selection <- function(x, #' Wrappers around `srv_transform_teal_data` that allows to decorate the data #' @inheritParams teal::srv_transform_teal_data -#' @param expr (`expression`) to evaluate on the output of the decoration. -#' Must be inline code. See [within()] -#' Default is `NULL` which won't append any expression. +#' @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. #' @details #' `srv_decorate_teal_data` is a wrapper around `srv_transform_teal_data` that -#' allows to decorate the data with additional reactive expressions. +#' allows to decorate the data with additional expressions. #' When original `teal_data` object is in error state, it will show that error #' first. #' #' @keywords internal -srv_decorate_teal_data <- function(id, data, decorators, expr = NULL) { - expr_quosure <- rlang::enexpr(expr) - decorated_output <- srv_transform_teal_data(id, data = data, transformators = decorators) - - reactive({ - req(data(), decorated_output()) # ensure original errors are displayed - if (is.null(expr_quosure)) { - decorated_output() - } else { - eval_code(decorated_output(), expr_quosure) - } +srv_decorate_teal_data <- function(id, data, decorators, expr) { + assert_reactive(data) + checkmate::assert_list(decorators, "teal_transform_module") + + missing_expr <- missing(expr) + if (!missing_expr) { + expr <- rlang::enexpr(expr) + } + + moduleServer(id, function(input, output, session) { + decorated_output <- srv_transform_teal_data("inner", data = data, transformators = decorators) + + reactive({ + # ensure original errors are displayed and `eval_code` is never executed with NULL + req(data(), decorated_output()) + if (missing_expr) { + decorated_output() + } else { + eval_code(decorated_output(), expr) + } + }) }) } @@ -311,4 +321,71 @@ srv_decorate_teal_data <- function(id, data, decorators, expr = NULL) { #' @details #' `ui_decorate_teal_data` is a wrapper around `ui_transform_teal_data`. #' @keywords internal -ui_decorate_teal_data <- teal::ui_transform_teal_data +ui_decorate_teal_data <- function(id, decorators, ...) { + teal::ui_transform_teal_data(NS(id, "inner"), transformators = decorators, ...) +} + +#' Internal function to check if decorators is a valid object +#' @noRd +check_decorators <- function(x, names = NULL, null.ok = FALSE) { + checkmate::qassert(null.ok, "B1") + + check_message <- checkmate::check_list( + x, + null.ok = null.ok, + names = "named" + ) + + if (!is.null(names)) { + check_message <- if (isTRUE(check_message)) { + out_message <- checkmate::check_names(names(x), subset.of = c("default", names)) + # see https://github.com/insightsengineering/teal.logger/issues/101 + if (isTRUE(out_message)) { + out_message + } else { + gsub("\\{", "(", gsub("\\}", ")", out_message)) + } + } else { + check_message + } + } + + if (!isTRUE(check_message)) { + return(check_message) + } + + valid_elements <- vapply( + x, + checkmate::test_list, + types = "teal_transform_module", + null.ok = TRUE, + FUN.VALUE = logical(1L) + ) + + if (all(valid_elements)) { + return(TRUE) + } + + "May only contain the type 'teal_transform_module' or a named list of 'teal_transform_module'." +} + +#' Internal assertion on decorators +#' @noRd +assert_decorators <- checkmate::makeAssertionFunction(check_decorators) + +#' Subset decorators based on the scope +#' +#' `default` is a protected decorator name that is always included in the output, +#' if it exists +#' +#' @param scope (`character`) a character vector of decorator names to include. +#' @param decorators (named `list`) of list decorators to subset. +#' +#' @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) + scope <- intersect(union("default", scope), names(decorators)) + c(list(), unlist(decorators[scope], recursive = FALSE)) +} diff --git a/man/srv_decorate_teal_data.Rd b/man/srv_decorate_teal_data.Rd new file mode 100644 index 000000000..6d6845aca --- /dev/null +++ b/man/srv_decorate_teal_data.Rd @@ -0,0 +1,32 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/utils.R +\name{srv_decorate_teal_data} +\alias{srv_decorate_teal_data} +\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) + +ui_decorate_teal_data(id, decorators, ...) +} +\arguments{ +\item{id}{(\code{character(1)}) Module id} + +\item{data}{(\verb{reactive teal_data})} + +\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.} +} +\description{ +Wrappers around \code{srv_transform_teal_data} that allows to decorate the data +} +\details{ +\code{srv_decorate_teal_data} is a wrapper around \code{srv_transform_teal_data} that +allows to decorate the data with additional expressions. +When original \code{teal_data} object is in error state, it will show that error +first. + +\code{ui_decorate_teal_data} is a wrapper around \code{ui_transform_teal_data}. +} +\keyword{internal} diff --git a/man/subset_decorators.Rd b/man/subset_decorators.Rd new file mode 100644 index 000000000..9b229dffe --- /dev/null +++ b/man/subset_decorators.Rd @@ -0,0 +1,22 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/utils.R +\name{subset_decorators} +\alias{subset_decorators} +\title{Subset decorators based on the scope} +\usage{ +subset_decorators(scope, decorators) +} +\arguments{ +\item{scope}{(\code{character}) a character vector of decorator names to include.} + +\item{decorators}{(named \code{list}) of list decorators to subset.} +} +\value{ +A flat list with all decorators to include. +It can be an empty list if none of the scope exists in \code{decorators} argument. +} +\description{ +\code{default} is a protected decorator name that is always included in the output, +if it exists +} +\keyword{internal} diff --git a/man/tm_missing_data.Rd b/man/tm_missing_data.Rd index ca70d2f69..d5b1e919b 100644 --- a/man/tm_missing_data.Rd +++ b/man/tm_missing_data.Rd @@ -66,10 +66,9 @@ adaptable for general data analysis purposes. This module generates the following objects, which can be modified in place using decorators: \itemize{ -\item \code{summary_plot_top} (\code{ggplot2}) -\item \code{summary_plot_bottom} (\code{ggplot2}) -\item \code{combination_plot_top} (\code{ggplot2}) -\item \code{combination_plot_bottom} (\code{ggplot2}) +\item \code{summary_plot} (\verb{ggplot2 plot grob}) +\item \code{combination_plot} (\verb{ggplot2 plot grob}) +\item \code{by_subject_plot} (\code{ggplot2}) \item \code{table} (\code{\link[DT:datatable]{DT::datatable()}}) }