diff --git a/DESCRIPTION b/DESCRIPTION index 886ba3c1d..7ba3e4dea 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -48,6 +48,7 @@ Imports: lattice (>= 0.18-4), lifecycle (>= 0.2.0), MASS (>= 7.3-60), + rlang, rtables (>= 0.6.11), scales (>= 1.3.0), shinyjs (>= 2.1.0), @@ -72,8 +73,6 @@ Suggests: logger (>= 0.4.0), nestcolor (>= 0.1.0), pkgload, - rlang (>= 1.0.0), - rmarkdown (>= 2.23), roxy.shinylive, rvest, shinytest2, @@ -83,8 +82,8 @@ VignetteBuilder: knitr, rmarkdown Remotes: - insightsengineering/teal, - insightsengineering/teal.reporter + insightsengineering/teal@redesign_extraction@main, + insightsengineering/teal.transform@redesign_extraction@main Config/Needs/verdepcheck: haleyjeppson/ggmosaic, tidyverse/ggplot2, rstudio/shiny, insightsengineering/teal, insightsengineering/teal.transform, mllg/checkmate, tidyverse/dplyr, diff --git a/NAMESPACE b/NAMESPACE index 302a2f68e..a400bd6c3 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -8,6 +8,24 @@ S3method(create_sparklines,default) S3method(create_sparklines,factor) S3method(create_sparklines,logical) S3method(create_sparklines,numeric) +S3method(tm_a_pca,default) +S3method(tm_a_pca,picks) +S3method(tm_a_regression,default) +S3method(tm_a_regression,picks) +S3method(tm_g_association,default) +S3method(tm_g_association,picks) +S3method(tm_g_bivariate,default) +S3method(tm_g_bivariate,picks) +S3method(tm_g_distribution,default) +S3method(tm_g_distribution,picks) +S3method(tm_g_response,default) +S3method(tm_g_response,picks) +S3method(tm_g_scatterplot,default) +S3method(tm_g_scatterplot,picks) +S3method(tm_g_scatterplotmatrix,default) +S3method(tm_g_scatterplotmatrix,picks) +S3method(tm_t_crosstable,default) +S3method(tm_t_crosstable,picks) export(add_facet_labels) export(get_scatterplotmatrix_stats) export(tm_a_pca) @@ -31,3 +49,4 @@ import(teal) import(teal.transform) importFrom(dplyr,"%>%") importFrom(lifecycle,deprecated) +importFrom(rlang,":=") diff --git a/R/picks-datanames.R b/R/picks-datanames.R new file mode 100644 index 000000000..10a58fe54 --- /dev/null +++ b/R/picks-datanames.R @@ -0,0 +1,16 @@ +.picks_datanames <- function(x) { + checkmate::assert_list(x, c("picks", "NULL")) + datanames_list <- lapply(x, function(x) { + if (is.character(x$datasets$choices)) { + x$datasets$choices + } else { + NULL + } + }) + + if (any(vapply(datanames_list, is.null, logical(1)))) { + "all" + } else { + unique(unlist(datanames_list)) + } +} diff --git a/R/tm_a_pca.R b/R/tm_a_pca.R index 21e9dc339..ca2f0db06 100644 --- a/R/tm_a_pca.R +++ b/R/tm_a_pca.R @@ -7,8 +7,7 @@ #' #' @inheritParams teal::module #' @inheritParams shared_params -#' @param dat (`data_extract_spec` or `list` of multiple `data_extract_spec`) -#' specifying columns used to compute PCA. +#' @param dat (`picks`) specifying columns used to compute PCA. #' @param font_size (`numeric`) optional, specifies font size. #' It controls the font size for plot titles, axis labels, and legends. #' - If vector of `length == 1` then the font sizes will have a fixed size. @@ -67,16 +66,13 @@ #' modules = modules( #' tm_a_pca( #' "PCA", -#' dat = data_extract_spec( -#' dataname = "USArrests", -#' select = select_spec( -#' choices = variable_choices( -#' data = data[["USArrests"]], c("Murder", "Assault", "UrbanPop", "Rape") -#' ), +#' dat = teal.transform::picks( +#' datasets("USArrests"), +#' teal.transform::variables( +#' choices = c("Murder", "Assault", "UrbanPop", "Rape"), #' selected = c("Murder", "Assault"), #' multiple = TRUE -#' ), -#' filter = NULL +#' ) #' ) #' ) #' ) @@ -103,17 +99,13 @@ #' data = data, #' modules = modules( #' tm_a_pca( -#' "PCA", -#' dat = data_extract_spec( -#' dataname = "ADSL", -#' select = select_spec( -#' choices = variable_choices( -#' data = data[["ADSL"]], c("BMRKR1", "AGE", "EOSDY") -#' ), +#' dat = teal.transform::picks( +#' datasets("ADSL"), +#' teal.transform::variables( +#' choices = c("BMRKR1", "AGE", "EOSDY"), #' selected = c("BMRKR1", "AGE"), #' multiple = TRUE -#' ), -#' filter = NULL +#' ) #' ) #' ) #' ) @@ -125,7 +117,14 @@ #' @export #' tm_a_pca <- function(label = "Principal Component Analysis", - dat, + dat = teal.transform::picks( + teal.transform::datasets(), + teal.transform::variables( + choices = tidyselect::where(~ is.numeric(.x) && all(!is.na(.x))), + selected = tidyselect::everything(), + multiple = TRUE + ) + ), plot_height = c(600, 200, 2000), plot_width = NULL, ggtheme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void"), @@ -138,6 +137,24 @@ tm_a_pca <- function(label = "Principal Component Analysis", post_output = NULL, transformators = list(), decorators = list()) { + UseMethod("tm_a_pca", dat) +} + +#' @export +tm_a_pca.default <- function(label = "Principal Component Analysis", + dat, + plot_height = c(600, 200, 2000), + plot_width = NULL, + ggtheme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void"), + ggplot2_args = teal.widgets::ggplot2_args(), + rotate_xaxis_labels = FALSE, + font_size = c(12, 8, 20), + alpha = c(1, 0, 1), + size = c(2, 1, 8), + pre_output = NULL, + post_output = NULL, + transformators = list(), + decorators = list()) { message("Initializing tm_a_pca") # Normalize the parameters @@ -198,8 +215,8 @@ tm_a_pca <- function(label = "Principal Component Analysis", ans <- module( label = label, - server = srv_a_pca, - ui = ui_a_pca, + server = srv_a_pca.default, + ui = ui_a_pca.default, ui_args = args, server_args = c( data_extract_list, @@ -218,7 +235,7 @@ tm_a_pca <- function(label = "Principal Component Analysis", } # UI function for the PCA module -ui_a_pca <- function(id, ...) { +ui_a_pca.default <- function(id, ...) { ns <- NS(id) args <- list(...) is_single_dataset_value <- teal.transform::is_single_dataset(args$dat) @@ -347,7 +364,7 @@ ui_a_pca <- function(id, ...) { } # Server function for the PCA module -srv_a_pca <- function(id, data, dat, plot_height, plot_width, ggplot2_args, decorators) { +srv_a_pca.default <- function(id, data, dat, plot_height, plot_width, ggplot2_args, decorators) { checkmate::assert_class(data, "reactive") checkmate::assert_class(isolate(data()), "teal_data") moduleServer(id, function(input, output, session) { diff --git a/R/tm_a_pca_picks.R b/R/tm_a_pca_picks.R new file mode 100644 index 000000000..ec0fdd65e --- /dev/null +++ b/R/tm_a_pca_picks.R @@ -0,0 +1,920 @@ +#' @export +tm_a_pca.picks <- function(label = "Principal Component Analysis", + dat = teal.transform::picks( + teal.transform::datasets(), + teal.transform::variables( + choices = tidyselect::where(~ is.numeric(.x) && all(!is.na(.x))), + selected = tidyselect::everything(), + multiple = TRUE + ) + ), + plot_height = c(600, 200, 2000), + plot_width = NULL, + ggtheme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void"), + ggplot2_args = teal.widgets::ggplot2_args(), + rotate_xaxis_labels = FALSE, + font_size = c(12, 8, 20), + alpha = c(1, 0, 1), + size = c(2, 1, 8), + pre_output = NULL, + post_output = NULL, + transformators = list(), + decorators = list()) { + message("Initializing tm_a_pca") + + # Normalize the parameters + if (inherits(ggplot2_args, "ggplot2_args")) ggplot2_args <- list(default = ggplot2_args) + + # Start of assertions + checkmate::assert_string(label) + checkmate::assert_class(dat, "picks") + + checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE) + checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height") + checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE) + checkmate::assert_numeric( + plot_width[1], + lower = plot_width[2], upper = plot_width[3], null.ok = TRUE, .var.name = "plot_width" + ) + + ggtheme <- match.arg(ggtheme) + + plot_choices <- c("Elbow plot", "Circle plot", "Biplot", "Eigenvector plot") + checkmate::assert_list(ggplot2_args, types = "ggplot2_args") + checkmate::assert_subset(names(ggplot2_args), c("default", plot_choices)) + + checkmate::assert_flag(rotate_xaxis_labels) + + if (length(font_size) == 1) { + checkmate::assert_numeric(font_size, any.missing = FALSE, finite = TRUE, lower = 8, upper = 20) + } else { + checkmate::assert_numeric(font_size, len = 3, any.missing = FALSE, finite = TRUE, lower = 8, upper = 20) + checkmate::assert_numeric(font_size[1], lower = font_size[2], upper = font_size[3], .var.name = "font_size") + } + + if (length(alpha) == 1) { + checkmate::assert_numeric(alpha, any.missing = FALSE, finite = TRUE, lower = 0, upper = 1) + } else { + checkmate::assert_numeric(alpha, len = 3, any.missing = FALSE, finite = TRUE, lower = 0, upper = 1) + checkmate::assert_numeric(alpha[1], lower = alpha[2], upper = alpha[3], .var.name = "alpha") + } + + if (length(size) == 1) { + checkmate::assert_numeric(size, any.missing = FALSE, finite = TRUE, lower = 1, upper = 8) + } else { + checkmate::assert_numeric(size, len = 3, any.missing = FALSE, finite = TRUE, lower = 1, upper = 8) + checkmate::assert_numeric(size[1], lower = size[2], upper = size[3], .var.name = "size") + } + + checkmate::assert_multi_class(pre_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE) + checkmate::assert_multi_class(post_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE) + + available_decorators <- c("elbow_plot", "circle_plot", "biplot", "eigenvector_plot") + assert_decorators(decorators, available_decorators) + + # Make UI args + args <- as.list(environment()) + + ans <- module( + label = label, + ui = ui_a_pca.picks, + server = srv_a_pca.picks, + ui_args = args[names(args) %in% names(formals(ui_a_pca.picks))], + server_args = args[names(args) %in% names(formals(srv_a_pca.picks))], + transformators = transformators, + datanames = .picks_datanames(list(dat)) + ) + attr(ans, "teal_bookmarkable") <- FALSE + ans +} + +# UI function for the PCA module +ui_a_pca.picks <- function(id, + dat, + plot_choices, + ggtheme, + rotate_xaxis_labels, + font_size, + alpha, + size, + pre_output, + post_output, + decorators) { + ns <- NS(id) + tagList( + teal.widgets::standard_layout( + output = teal.widgets::white_small_well( + tags$div( + tags$div( + align = "center", + tags$h4("Principal components importance"), + tableOutput(ns("tbl_importance")), + tags$hr() + ), + tags$div( + align = "center", + tags$h4("Eigenvectors"), + tableOutput(ns("tbl_eigenvector")), + tags$hr() + ), + teal.widgets::plot_with_settings_ui(id = ns("pca_plot")) + ) + ), + encoding = tags$div( + tags$label("Encodings", class = "text-primary"), + tags$div( + tags$strong("Data selection"), + teal.transform::picks_ui(id = ns("dat"), picks = dat) + ), + bslib::accordion( + open = TRUE, + bslib::accordion_panel( + title = "Display", + checkboxGroupInput( + ns("tables_display"), + "Tables display", + choices = c("PC importance" = "importance", "Eigenvectors" = "eigenvector"), + selected = c("importance", "eigenvector") + ), + radioButtons( + ns("plot_type"), + label = "Plot type", + choices = plot_choices, + selected = plot_choices[1] + ), + conditionalPanel( + condition = sprintf("input['%s'] == 'Elbow plot'", ns("plot_type")), + ui_decorate_teal_data( + ns("d_elbow_plot"), + decorators = select_decorators(decorators, "elbow_plot") + ) + ), + conditionalPanel( + condition = sprintf("input['%s'] == 'Circle plot'", ns("plot_type")), + ui_decorate_teal_data( + ns("d_circle_plot"), + decorators = select_decorators(decorators, "circle_plot") + ) + ), + conditionalPanel( + condition = sprintf("input['%s'] == 'Biplot'", ns("plot_type")), + ui_decorate_teal_data( + ns("d_biplot"), + decorators = select_decorators(decorators, "biplot") + ) + ), + conditionalPanel( + condition = sprintf("input['%s'] == 'Eigenvector plot'", ns("plot_type")), + ui_decorate_teal_data( + ns("d_eigenvector_plot"), + decorators = select_decorators(decorators, "eigenvector_plot") + ) + ) + ), + bslib::accordion_panel( + title = "Pre-processing", + radioButtons( + ns("standardization"), "Standardization", + choices = c("None" = "none", "Center" = "center", "Center & Scale" = "center_scale"), + selected = "center_scale" + ), + radioButtons( + ns("na_action"), "NA action", + choices = c("None" = "none", "Drop" = "drop"), + selected = "none" + ) + ), + bslib::accordion_panel( + title = "Selected plot specific settings", + uiOutput(ns("plot_settings")), + conditionalPanel( + condition = sprintf("input['%s'] == 'Biplot'", ns("plot_type")), + list( + shinyWidgets::pickerInput(inputId = ns("response"), label = "Color by", choices = NULL), + teal.widgets::optionalSliderInputValMinMax(ns("alpha"), "Opacity:", alpha, ticks = FALSE), + teal.widgets::optionalSliderInputValMinMax(ns("size"), "Points size:", size, ticks = FALSE) + ) + ) + ), + bslib::accordion_panel( + title = "Plot settings", + collapsed = TRUE, + conditionalPanel( + condition = sprintf( + "input['%1$s'] == 'Elbow plot' || input['%1$s'] == 'Eigenvector plot'", ns("plot_type") + ), + list(checkboxInput(ns("rotate_xaxis_labels"), "Rotate X axis labels", value = rotate_xaxis_labels)) + ), + selectInput( + inputId = ns("ggtheme"), + label = "Theme (by ggplot):", + choices = ggplot_themes, + selected = ggtheme, + multiple = FALSE + ), + teal.widgets::optionalSliderInputValMinMax(ns("font_size"), "Font Size", font_size, ticks = FALSE) + ) + ) + ), + pre_output = pre_output, + post_output = post_output + ) + ) +} + +# Server function for the PCA module +srv_a_pca.picks <- function(id, data, dat, plot_height, plot_width, ggplot2_args, decorators) { + checkmate::assert_class(data, "reactive") + checkmate::assert_class(isolate(data()), "teal_data") + moduleServer(id, function(input, output, session) { + teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.general") + + selectors <- teal.transform::picks_srv(picks = list(dat = dat), data = data) + + qenv <- reactive({ + validate_input( + "dat-variables-selected", + length(selectors$dat()$variables$selected) > 1, + "Please select more than 1 variable to perform PCA." + ) + obj <- req(data()) + teal.reporter::teal_card(obj) <- + c( + teal.reporter::teal_card("# Principal Component Analysis"), + teal.reporter::teal_card(obj), + teal.reporter::teal_card("## Module's code") + ) + teal.code::eval_code(obj, 'library("ggplot2");library("dplyr");library("tidyr")') + }) + + merged <- merge_srv("merge", data = qenv, selectors = selectors, output_name = "anl") + anl_merged_q <- merged$data + selected_vars <- reactive(merged$variables()$dat) + + validate_data <- reactive({ + obj <- req(anl_merged_q()) + anl <- obj[["anl"]] + validate_input( + "dat-variables-selected", + condition = sum(stats::complete.cases(anl[selected_vars()])) > 10, + message = "Number of complete cases is less than 10" + ) + validate_input( + "na_action", + condition = input$na_action != "none" | !anyNA(anl[selected_vars()]), + message = paste( + "There are NAs in the dataset. Please deal with them in preprocessing", + "or select \"Drop\" in the NA actions." + ) + ) + standardization <- input$standardization + scale <- standardization == "center_scale" + + if (scale) { + not_single <- vapply( + anl[selected_vars()], + function(column) length(unique(column)) != 1, + FUN.VALUE = logical(1) + ) + validate_input( + "standarization", + condition = all(not_single), + message = paste0( + "You have selected `Center & Scale` under `Standardization` in the `Pre-processing` panel, ", + "but one or more of your columns has/have a variance value of zero, indicating all values are identical" + ) + ) + } + }) + + validate_xy_axis <- reactive({ + validate_input( + "x_axis", + condition = input$x_axis != input$y_axis, + message = "Please choose different X and Y axes." + ) + }) + + observeEvent(selected_vars(), { + shinyWidgets::updatePickerInput( + inputId = "response", + choices = selected_vars(), + selected = input$response + ) + }) + + computation <- reactive({ + validate_data() + # inputs + anl_cols <- selected_vars() + na_action <- input$na_action + standardization <- input$standardization + center <- standardization %in% c("center", "center_scale") + scale <- standardization == "center_scale" + anl <- anl_merged_q()[["anl"]] + + qenv <- within(anl_merged_q(), anl_cols <- cols, cols = unname(anl_cols)) + + if (na_action == "drop") { + qenv <- within(qenv, anl <- tidyr::drop_na(anl, any_of(anl_cols))) + } + + qenv <- within( + qenv, + pca <- summary(stats::prcomp(anl[anl_cols], center = center, scale. = scale, retx = TRUE)), + center = center, scale = scale + ) + + teal.reporter::teal_card(qenv) <- c(teal.reporter::teal_card(qenv), "## Principal Components Table") + + qenv <- within(qenv, { + tbl_importance <- dplyr::as_tibble(pca$importance, rownames = "Metric") + tbl_importance + }) + + teal.reporter::teal_card(qenv) <- c(teal.reporter::teal_card(qenv), "## Eigenvectors Table") + + within(qenv, { + tbl_eigenvector <- dplyr::as_tibble(pca$rotation, rownames = "Variable") + tbl_eigenvector + }) + }) + + output$plot_settings <- renderUI({ + # reactivity triggers + req(computation()) + qenv <- computation() + + ns <- session$ns + pca <- qenv[["pca"]] + chcs_pcs <- colnames(pca$rotation) + chcs_vars <- qenv$anl_cols + + tagList( + conditionalPanel( + condition = sprintf("input['%1$s'] == 'Biplot' || input['%1$s'] == 'Circle plot'", ns("plot_type")), + list( + shinyWidgets::pickerInput(ns("x_axis"), "X axis", choices = chcs_pcs, selected = chcs_pcs[1]), + shinyWidgets::pickerInput(ns("y_axis"), "Y axis", choices = chcs_pcs, selected = chcs_pcs[2]), + shinyWidgets::pickerInput( + ns("variables"), "Original coordinates", + choices = chcs_vars, selected = chcs_vars, + multiple = TRUE + ) + ) + ), + conditionalPanel( + condition = sprintf("input['%s'] == 'Elbow plot'", ns("plot_type")), + helpText("No plot specific settings available.") + ), + conditionalPanel( + condition = paste0("input['", ns("plot_type"), "'] == 'Eigenvector plot'"), + shinyWidgets::pickerInput(ns("pc"), "PC", choices = chcs_pcs, selected = chcs_pcs[1]) + ) + ) + }) + + plot_elbow <- function(base_q) { + logger::log_debug("srv_a_pca recalculate plot_elbow") + ggtheme <- input$ggtheme + rotate_xaxis_labels <- input$rotate_xaxis_labels + font_size <- input$font_size + + angle_value <- ifelse(isTRUE(rotate_xaxis_labels), 45, 0) + hjust_value <- ifelse(isTRUE(rotate_xaxis_labels), 1, 0.5) + + dev_ggplot2_args <- teal.widgets::ggplot2_args( + labs = list(x = "Principal component", y = "Proportion of variance explained", color = "", fill = "Legend"), + theme = list( + legend.position = "right", + legend.spacing.y = quote(grid::unit(-5, "pt")), + legend.title = quote(ggplot2::element_text(vjust = 25)), + axis.text.x = substitute( + ggplot2::element_text(angle = angle_value, hjust = hjust_value), + list(angle_value = angle_value, hjust_value = hjust_value) + ), + text = substitute(ggplot2::element_text(size = font_size), list(font_size = font_size)) + ) + ) + + parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args( + teal.widgets::resolve_ggplot2_args( + user_plot = ggplot2_args[["Elbow plot"]], + user_default = ggplot2_args$default, + module_plot = dev_ggplot2_args + ), + ggtheme = ggtheme + ) + teal.reporter::teal_card(base_q) <- c(teal.reporter::teal_card(base_q), "## Elbow plot") + teal.code::eval_code( + base_q, + substitute( + expr = { + elb_dat <- pca$importance[c("Proportion of Variance", "Cumulative Proportion"), ] %>% + dplyr::as_tibble(rownames = "metric") %>% + tidyr::gather("component", "value", -metric) %>% + dplyr::mutate( + component = factor(component, levels = unique(stringr::str_sort(component, numeric = TRUE))) + ) + + cols <- c(getOption("ggplot2.discrete.colour"), c("lightblue", "darkred", "black"))[1:3] + elbow_plot <- ggplot2::ggplot(mapping = ggplot2::aes_string(x = "component", y = "value")) + + ggplot2::geom_bar( + ggplot2::aes(fill = "Single variance"), + data = dplyr::filter(elb_dat, metric == "Proportion of Variance"), + color = "black", + stat = "identity" + ) + + ggplot2::geom_point( + ggplot2::aes(color = "Cumulative variance"), + data = dplyr::filter(elb_dat, metric == "Cumulative Proportion") + ) + + ggplot2::geom_line( + ggplot2::aes(group = 1, color = "Cumulative variance"), + data = dplyr::filter(elb_dat, metric == "Cumulative Proportion") + ) + + labs + + ggplot2::scale_color_manual(values = c("Cumulative variance" = cols[2], "Single variance" = cols[3])) + + ggplot2::scale_fill_manual(values = c("Cumulative variance" = cols[2], "Single variance" = cols[1])) + + ggthemes + + themes + }, + env = list( + ggthemes = parsed_ggplot2_args$ggtheme, + labs = parsed_ggplot2_args$labs, + themes = parsed_ggplot2_args$theme + ) + ) + ) + } + + plot_circle <- function(base_q) { + logger::log_debug("srv_a_pca recalculate plot_circle") + validate_xy_axis() + validate_input( + "variables", + condition = length(input$variables) > 0, + message = "Please select Original Coordinates for this visualization." + ) + x_axis <- input$x_axis + y_axis <- input$y_axis + variables <- input$variables + ggtheme <- input$ggtheme + + rotate_xaxis_labels <- input$rotate_xaxis_labels + font_size <- input$font_size + + angle <- ifelse(isTRUE(rotate_xaxis_labels), 45, 0) + hjust <- ifelse(isTRUE(rotate_xaxis_labels), 1, 0.5) + + dev_ggplot2_args <- teal.widgets::ggplot2_args( + theme = list( + text = substitute(ggplot2::element_text(size = font_size), list(font_size = font_size)), + axis.text.x = substitute( + ggplot2::element_text(angle = angle_val, hjust = hjust_val), + list(angle_val = angle, hjust_val = hjust) + ) + ) + ) + + all_ggplot2_args <- teal.widgets::resolve_ggplot2_args( + user_plot = ggplot2_args[["Circle plot"]], + user_default = ggplot2_args$default, + module_plot = dev_ggplot2_args + ) + + parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args( + all_ggplot2_args, + ggtheme = ggtheme + ) + + teal.reporter::teal_card(base_q) <- c(teal.reporter::teal_card(base_q), "## Circle plot") + teal.code::eval_code( + base_q, + substitute( + expr = { + pca_rot <- pca$rotation[, c(x_axis, y_axis)] %>% + dplyr::as_tibble(rownames = "label") %>% + dplyr::filter(label %in% variables) + + circle_data <- data.frame( + x = cos(seq(0, 2 * pi, length.out = 100)), + y = sin(seq(0, 2 * pi, length.out = 100)) + ) + + circle_plot <- ggplot2::ggplot(pca_rot) + + ggplot2::geom_point(ggplot2::aes_string(x = x_axis, y = y_axis)) + + ggplot2::geom_label( + ggplot2::aes_string(x = x_axis, y = y_axis, label = "label"), + nudge_x = 0.1, nudge_y = 0.05, + fontface = "bold" + ) + + ggplot2::geom_path(ggplot2::aes(x, y, group = 1), data = circle_data) + + ggplot2::geom_point(ggplot2::aes(x = x, y = y), data = data.frame(x = 0, y = 0), shape = "x", size = 5) + + labs + + ggthemes + + themes + }, + env = list( + x_axis = x_axis, + y_axis = y_axis, + variables = variables, + ggthemes = parsed_ggplot2_args$ggtheme, + labs = `if`(is.null(parsed_ggplot2_args$labs), quote(labs()), parsed_ggplot2_args$labs), + themes = parsed_ggplot2_args$theme + ) + ) + ) + } + + plot_biplot <- function(base_q) { + logger::log_debug("srv_a_pca recalculate plot_biplot") + validate_xy_axis() + validate_input( + "response", + condition = length(input$response) == 1, + message = "Please select Response variable to see this visualization." + ) + qenv <- base_q + anl <- qenv[["anl"]] + anl_cols <- selected_vars() + + resp_col <- input$response + x_axis <- input$x_axis + y_axis <- input$y_axis + variables <- input$variables + pca <- qenv[["pca"]] + + ggtheme <- input$ggtheme + + rotate_xaxis_labels <- input$rotate_xaxis_labels + alpha <- input$alpha + size <- input$size + font_size <- input$font_size + + teal.reporter::teal_card(base_q) <- c(teal.reporter::teal_card(base_q), "## Biplot") + qenv <- teal.code::eval_code( + qenv, + substitute( + expr = pca_rot <- dplyr::as_tibble(pca$x[, c(x_axis, y_axis)]), + env = list(x_axis = x_axis, y_axis = y_axis) + ) + ) + + # rot_vars = data frame that displays arrows in the plot, need to be scaled to data + if (!is.null(input$variables)) { + qenv <- teal.code::eval_code( + qenv, + substitute( + expr = { + r <- sqrt(qchisq(0.69, df = 2)) * prod(colMeans(pca_rot ^ 2)) ^ (1 / 4) # styler: off + v_scale <- rowSums(pca$rotation ^ 2) # styler: off + + rot_vars <- pca$rotation[, c(x_axis, y_axis)] %>% + dplyr::as_tibble(rownames = "label") %>% + dplyr::mutate_at(vars(c(x_axis, y_axis)), function(x) r * x / sqrt(max(v_scale))) + }, + env = list(x_axis = x_axis, y_axis = y_axis) + ) + ) %>% + teal.code::eval_code( + if (is.logical(pca$center) && !pca$center) { + substitute( + expr = { + rot_vars <- rot_vars %>% + tibble::column_to_rownames("label") %>% + sweep(1, apply(anl[anl_cols], 2, mean, na.rm = TRUE)) %>% + tibble::rownames_to_column("label") %>% + dplyr::mutate( + xstart = mean(pca$x[, x_axis], na.rm = TRUE), + ystart = mean(pca$x[, y_axis], na.rm = TRUE) + ) + }, + env = list(x_axis = x_axis, y_axis = y_axis) + ) + } else { + quote(rot_vars <- rot_vars %>% dplyr::mutate(xstart = 0, ystart = 0)) + } + ) %>% + teal.code::eval_code( + substitute( + expr = rot_vars <- rot_vars %>% dplyr::filter(label %in% variables), + env = list(variables = variables) + ) + ) + } + + pca_plot_biplot_expr <- list(quote(ggplot())) + + if (length(resp_col) == 0) { + pca_plot_biplot_expr <- c( + pca_plot_biplot_expr, + substitute( + ggplot2::geom_point(ggplot2::aes_string(x = x_axis, y = y_axis), + data = pca_rot, alpha = alpha, size = size + ), + list(x_axis = input$x_axis, y_axis = input$y_axis, alpha = input$alpha, size = input$size) + ) + ) + dev_labs <- list() + } else { + response <- anl[[resp_col]] + + aes_biplot <- substitute( + ggplot2::aes_string(x = x_axis, y = y_axis, color = "response"), + env = list(x_axis = x_axis, y_axis = y_axis) + ) + + qenv <- teal.code::eval_code( + qenv, + substitute(response <- anl[[resp_col]], env = list(resp_col = resp_col)) + ) + + dev_labs <- list(color = varname_w_label(resp_col, anl)) + + scales_biplot <- + if ( + is.character(response) || + is.factor(response) || + (is.numeric(response) && length(unique(response)) <= 6) + ) { + qenv <- teal.code::eval_code( + qenv, + quote(pca_rot$response <- as.factor(response)) + ) + quote(ggplot2::scale_color_brewer(palette = "Dark2")) + } else if (inherits(response, "Date")) { + qenv <- teal.code::eval_code( + qenv, + quote(pca_rot$response <- numeric(response)) + ) + + quote( + ggplot2::scale_color_gradient( + low = c(getOption("ggplot2.discrete.colour")[2], "darkred")[1], + high = c(getOption("ggplot2.discrete.colour"), "lightblue")[1], + labels = function(x) as.Date(x, origin = "1970-01-01") + ) + ) + } else { + qenv <- teal.code::eval_code( + qenv, + quote(pca_rot$response <- response) + ) + quote(ggplot2::scale_color_gradient( + low = c(getOption("ggplot2.discrete.colour")[2], "darkred")[1], + high = c(getOption("ggplot2.discrete.colour"), "lightblue")[1] + )) + } + + pca_plot_biplot_expr <- c( + pca_plot_biplot_expr, + substitute( + ggplot2::geom_point(aes_biplot, data = pca_rot, alpha = alpha, size = size), + env = list(aes_biplot = aes_biplot, alpha = alpha, size = size) + ), + scales_biplot + ) + } + + if (!is.null(input$variables)) { + pca_plot_biplot_expr <- c( + pca_plot_biplot_expr, + substitute( + ggplot2::geom_segment( + ggplot2::aes_string(x = "xstart", y = "ystart", xend = x_axis, yend = y_axis), + data = rot_vars, + lineend = "round", linejoin = "round", + arrow = grid::arrow(length = grid::unit(0.5, "cm")) + ), + env = list(x_axis = x_axis, y_axis = y_axis) + ), + substitute( + ggplot2::geom_label( + ggplot2::aes_string( + x = x_axis, + y = y_axis, + label = "label" + ), + data = rot_vars, + nudge_y = 0.1, + fontface = "bold" + ), + env = list(x_axis = x_axis, y_axis = y_axis) + ), + quote(ggplot2::geom_point(ggplot2::aes(x = xstart, y = ystart), data = rot_vars, shape = "x", size = 5)) + ) + } + + angle <- ifelse(isTRUE(rotate_xaxis_labels), 45, 0) + hjust <- ifelse(isTRUE(rotate_xaxis_labels), 1, 0.5) + + dev_ggplot2_args <- teal.widgets::ggplot2_args( + labs = dev_labs, + theme = list( + text = substitute(ggplot2::element_text(size = font_size), list(font_size = font_size)), + axis.text.x = substitute( + ggplot2::element_text(angle = angle_val, hjust = hjust_val), + list(angle_val = angle, hjust_val = hjust) + ) + ) + ) + + all_ggplot2_args <- teal.widgets::resolve_ggplot2_args( + user_plot = ggplot2_args[["Biplot"]], + user_default = ggplot2_args$default, + module_plot = dev_ggplot2_args + ) + + parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args( + all_ggplot2_args, + ggtheme = ggtheme + ) + + pca_plot_biplot_expr <- c( + pca_plot_biplot_expr, + parsed_ggplot2_args + ) + + teal.code::eval_code( + qenv, + substitute( + expr = { + biplot <- plot_call + }, + env = list( + plot_call = Reduce(function(x, y) call("+", x, y), pca_plot_biplot_expr) + ) + ) + ) + } + + plot_eigenvector <- function(base_q) { + logger::log_debug("srv_a_pca recalculate plot_eigenvector") + validate_input( + "pc", + condition = length(input$pc) > 0, + "Please select a Principal Component for this visualization" + ) + req(input$pc) + pc <- input$pc + ggtheme <- input$ggtheme + + rotate_xaxis_labels <- input$rotate_xaxis_labels + font_size <- input$font_size + + angle <- ifelse(rotate_xaxis_labels, 45, 0) + hjust <- ifelse(rotate_xaxis_labels, 1, 0.5) + + dev_ggplot2_args <- teal.widgets::ggplot2_args( + theme = list( + text = substitute(ggplot2::element_text(size = font_size), list(font_size = font_size)), + axis.text.x = substitute( + ggplot2::element_text(angle = angle_val, hjust = hjust_val), + list(angle_val = angle, hjust_val = hjust) + ) + ) + ) + + all_ggplot2_args <- teal.widgets::resolve_ggplot2_args( + user_plot = ggplot2_args[["Eigenvector plot"]], + user_default = ggplot2_args$default, + module_plot = dev_ggplot2_args + ) + + parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args( + all_ggplot2_args, + ggtheme = ggtheme + ) + + ggplot_exprs <- c( + list( + quote(ggplot(pca_rot)), + substitute( + ggplot2::geom_bar( + ggplot2::aes_string(x = "Variable", y = pc), + stat = "identity", + color = "black", + fill = c(getOption("ggplot2.discrete.colour"), "lightblue")[1] + ), + env = list(pc = pc) + ), + substitute( + ggplot2::geom_text( + ggplot2::aes( + x = Variable, + y = pc_name, + label = round(pc_name, 3), + vjust = ifelse(pc_name > 0, -0.5, 1.3) + ) + ), + env = list(pc_name = as.name(pc)) + ) + ), + parsed_ggplot2_args$labs, + parsed_ggplot2_args$ggtheme, + parsed_ggplot2_args$theme + ) + + teal.reporter::teal_card(base_q) <- c(teal.reporter::teal_card(base_q), "## Eigenvector plot") + teal.code::eval_code( + base_q, + substitute( + expr = { + pca_rot <- pca$rotation[, pc, drop = FALSE] %>% + dplyr::as_tibble(rownames = "Variable") + eigenvector_plot <- plot_call + }, + env = list( + pc = pc, + plot_call = Reduce(function(x, y) call("+", x, y), ggplot_exprs) + ) + ) + ) + } + + # qenvs --- + output_q <- lapply( + list( + elbow_plot = plot_elbow, + circle_plot = plot_circle, + biplot = plot_biplot, + eigenvector_plot = plot_eigenvector + ), + function(fun) { + reactive({ + req(computation()) + fun(computation()) + }) + } + ) + + decorated_q <- mapply( + function(obj_name, q) { + srv_decorate_teal_data( + id = sprintf("d_%s", obj_name), + data = q, + decorators = select_decorators(decorators, obj_name), + expr = reactive({ + substitute(.plot, env = list(.plot = as.name(obj_name))) + }) + ) + }, + names(output_q), + output_q + ) + + # plot final ---- + decorated_output_q <- reactive({ + switch(req(input$plot_type), + "Elbow plot" = decorated_q$elbow_plot(), + "Circle plot" = decorated_q$circle_plot(), + "Biplot" = decorated_q$biplot(), + "Eigenvector plot" = decorated_q$eigenvector_plot(), + stop("Unknown plot") + ) + }) + + plot_r <- reactive({ + plot_name <- gsub(" ", "_", tolower(req(input$plot_type))) + req(decorated_output_q())[[plot_name]] + }) + + pws <- teal.widgets::plot_with_settings_srv( + id = "pca_plot", + plot_r = plot_r, + height = plot_height, + width = plot_width, + graph_align = "center" + ) + + # tables ---- + output$tbl_importance <- renderTable( + expr = { + req("importance" %in% input$tables_display, computation()) + logger::log_debug("srv_a_pca rerender tbl_importance") + computation()[["tbl_importance"]] + }, + bordered = TRUE, + align = "c", + digits = 3 + ) + + output$tbl_eigenvector <- renderTable( + expr = { + req("eigenvector" %in% input$tables_display, req(computation())) + logger::log_debug("srv_a_pca rerender tbl_eigenvector") + computation()[["tbl_eigenvector"]] + }, + bordered = TRUE, + align = "c", + digits = 3 + ) + + output$tbl_eigenvector_ui <- renderUI({ + req("eigenvector" %in% input$tables_display) + }) + + set_chunk_dims(pws, decorated_output_q) + }) +} diff --git a/R/tm_a_regression.R b/R/tm_a_regression.R index d0ce394b3..2ec52c996 100644 --- a/R/tm_a_regression.R +++ b/R/tm_a_regression.R @@ -10,11 +10,15 @@ #' #' @inheritParams teal::module #' @inheritParams shared_params -#' @param regressor (`data_extract_spec` or `list` of multiple `data_extract_spec`) -#' Regressor variables from an incoming dataset with filtering and selecting. -#' @param response (`data_extract_spec` or `list` of multiple `data_extract_spec`) -#' Response variables from an incoming dataset with filtering and selecting. -#' @param default_outlier_label (`character`) optional, default column selected to label outliers. +#' @param regressor (`picks`) Specification for regressor variables selection. +#' Created using [teal.transform::picks()], which allows selecting variables +#' to use as regressors in the regression model. `teal.transform::variables(multiple = TRUE)` allowed. +#' @param response (`picks`) Specification for response variable selection. +#' Created using [teal.transform::picks()], which allows selecting a single numeric variable +#' to use as the response in the regression model. `teal.transform::variables(multiple = TRUE)` not allowed. +#' @param outlier (`picks`) Optional specification for outlier label variable selection. +#' Created using [teal.transform::picks()], which allows selecting a factor or character variable +#' to label outlier points on the plots. #' @param default_plot_type (`numeric`) optional, defaults to "Response vs Regressor". #' 1. Response vs Regressor #' 2. Residuals vs Fitted @@ -87,25 +91,13 @@ #' modules = modules( #' tm_a_regression( #' label = "Regression", -#' response = data_extract_spec( -#' dataname = "CO2", -#' select = select_spec( -#' label = "Select variable:", -#' choices = "uptake", -#' selected = "uptake", -#' multiple = FALSE, -#' fixed = TRUE -#' ) +#' response = teal.transform::picks( +#' datasets("CO2"), +#' teal.transform::variables(choices = "uptake", selected = "uptake") #' ), -#' regressor = data_extract_spec( -#' dataname = "CO2", -#' select = select_spec( -#' label = "Select variables:", -#' choices = variable_choices(data[["CO2"]], c("conc", "Treatment")), -#' selected = "conc", -#' multiple = TRUE, -#' fixed = FALSE -#' ) +#' regressor = teal.transform::picks( +#' datasets("CO2"), +#' teal.transform::variables(choices = c("conc", "Treatment"), selected = "conc", multiple = TRUE) #' ) #' ) #' ) @@ -132,25 +124,13 @@ #' modules = modules( #' tm_a_regression( #' label = "Regression", -#' response = data_extract_spec( -#' dataname = "ADSL", -#' select = select_spec( -#' label = "Select variable:", -#' choices = "BMRKR1", -#' selected = "BMRKR1", -#' multiple = FALSE, -#' fixed = TRUE -#' ) +#' response = teal.transform::picks( +#' datasets("ADSL"), +#' teal.transform::variables(choices = "BMRKR1", selected = "BMRKR1") #' ), -#' regressor = data_extract_spec( -#' dataname = "ADSL", -#' select = select_spec( -#' label = "Select variables:", -#' choices = variable_choices(data[["ADSL"]], c("AGE", "SEX", "RACE")), -#' selected = "AGE", -#' multiple = TRUE, -#' fixed = FALSE -#' ) +#' regressor = teal.transform::picks( +#' datasets("ADSL"), +#' teal.transform::variables(choices = c("AGE", "SEX", "RACE"), selected = "AGE", multiple = TRUE) #' ) #' ) #' ) @@ -162,7 +142,14 @@ #' @export #' tm_a_regression <- function(label = "Regression Analysis", - regressor, + regressor = teal.transform::picks( + teal.transform::datasets(), + teal.transform::variables( + choices = is.numeric, + selected = tidyselect::last_col(), + multiple = TRUE + ) + ), response, plot_height = c(600, 200, 2000), plot_width = NULL, @@ -177,6 +164,26 @@ tm_a_regression <- function(label = "Regression Analysis", label_segment_threshold = c(0.5, 0, 10), transformators = list(), decorators = list()) { + UseMethod("tm_a_regression", regressor) +} + +#' @export +tm_a_regression.default <- function(label = "Regression Analysis", + regressor, + response, + plot_height = c(600, 200, 2000), + plot_width = NULL, + alpha = c(1, 0, 1), + size = c(2, 1, 8), + ggtheme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void"), + ggplot2_args = teal.widgets::ggplot2_args(), + pre_output = NULL, + post_output = NULL, + default_plot_type = 1, + default_outlier_label = "USUBJID", + label_segment_threshold = c(0.5, 0, 10), + transformators = list(), + decorators = list()) { message("Initializing tm_a_regression") # Normalize the parameters @@ -256,8 +263,8 @@ tm_a_regression <- function(label = "Regression Analysis", ans <- module( label = label, - server = srv_a_regression, - ui = ui_a_regression, + server = srv_a_regression.default, + ui = ui_a_regression.default, ui_args = args, server_args = c( data_extract_list, @@ -277,7 +284,7 @@ tm_a_regression <- function(label = "Regression Analysis", } # UI function for the regression module -ui_a_regression <- function(id, ...) { +ui_a_regression.default <- function(id, ...) { ns <- NS(id) args <- list(...) is_single_dataset_value <- teal.transform::is_single_dataset(args$regressor, args$response) @@ -380,15 +387,15 @@ ui_a_regression <- function(id, ...) { } # Server function for the regression module -srv_a_regression <- function(id, - data, - response, - regressor, - plot_height, - plot_width, - ggplot2_args, - default_outlier_label, - decorators) { +srv_a_regression.default <- function(id, + data, + response, + regressor, + plot_height, + plot_width, + ggplot2_args, + default_outlier_label, + decorators) { checkmate::assert_class(data, "reactive") checkmate::assert_class(isolate(data()), "teal_data") moduleServer(id, function(input, output, session) { diff --git a/R/tm_a_regression_picks.R b/R/tm_a_regression_picks.R new file mode 100644 index 000000000..23d5d5f83 --- /dev/null +++ b/R/tm_a_regression_picks.R @@ -0,0 +1,789 @@ +#' @export +tm_a_regression.picks <- function(label = "Regression Analysis", + regressor = teal.transform::picks( + teal.transform::datasets(), + teal.transform::variables( + choices = is.numeric, + selected = tidyselect::last_col(), + multiple = TRUE + ) + ), + response = teal.transform::picks( + teal.transform::datasets(), + teal.transform::variables(choices = is.numeric), + teal.transform::values() + ), + outlier = teal.transform::picks( + regressor$datasets, + teal.transform::variables(choices = tidyselect::where(~ is.factor(.) || is.character(.))), + teal.transform::values() + ), # default should be teal.transform::picks(datasets(), teal.transform::variables(primary_keys()) + plot_height = c(600, 200, 2000), + plot_width = NULL, + alpha = c(1, 0, 1), + size = c(2, 1, 8), + ggtheme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void"), + ggplot2_args = teal.widgets::ggplot2_args(), + pre_output = NULL, + post_output = NULL, + default_plot_type = 1, + default_outlier_label, + label_segment_threshold = c(0.5, 0, 10), + transformators = list(), + decorators = list()) { + message("Initializing tm_a_regression") + + # Start of assertions + checkmate::assert_string(label) + checkmate::assert_class(regressor, "picks") + + checkmate::assert_class(response, "picks") + if (isTRUE(attr(response$variables, "multiple"))) { + warning("`response` accepts only a single variable selection. Forcing `teal.transform::variables(multiple) to FALSE`") + attr(response$variables, "multiple") <- FALSE + } + checkmate::assert_class(outlier, "picks", null.ok = TRUE) + if (isTRUE(attr(outlier$variables, "multiple"))) { + warning("`outlier` accepts only a single variable selection. Forcing `teal.transform::variables(multiple) to FALSE`") + attr(outlier$variables, "multiple") <- FALSE + } + + checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE) + checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height") + + checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE) + checkmate::assert_numeric( + plot_width[1], + lower = plot_width[2], + upper = plot_width[3], + null.ok = TRUE, + .var.name = "plot_width" + ) + + if (length(alpha) == 1) { + checkmate::assert_numeric(alpha, any.missing = FALSE, finite = TRUE) + } else { + checkmate::assert_numeric(alpha, len = 3, any.missing = FALSE, finite = TRUE) + checkmate::assert_numeric(alpha[1], lower = alpha[2], upper = alpha[3], .var.name = "alpha") + } + + if (length(size) == 1) { + checkmate::assert_numeric(size, any.missing = FALSE, finite = TRUE) + } else { + checkmate::assert_numeric(size, len = 3, any.missing = FALSE, finite = TRUE) + checkmate::assert_numeric(size[1], lower = size[2], upper = size[3], .var.name = "size") + } + + ggtheme <- match.arg(ggtheme) + + if (inherits(ggplot2_args, "ggplot2_args")) ggplot2_args <- list(default = ggplot2_args) + plot_choices <- c( + "Response vs Regressor", "Residuals vs Fitted", "Normal Q-Q", "Scale-Location", + "Cook's distance", "Residuals vs Leverage", "Cook's dist vs Leverage" + ) + checkmate::assert_list(ggplot2_args, types = "ggplot2_args") + checkmate::assert_subset(names(ggplot2_args), c("default", plot_choices)) + + 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_choice(default_plot_type, seq.int(1L, length(plot_choices))) + if (!missing(default_outlier_label)) { + warning("`default_outlier_label` is not supported when using picks. Please use `outlier` argument.") + } + checkmate::assert_list(decorators, "teal_transform_module") + + if (length(label_segment_threshold) == 1) { + checkmate::assert_numeric(label_segment_threshold, any.missing = FALSE, finite = TRUE) + } else { + checkmate::assert_numeric(label_segment_threshold, len = 3, any.missing = FALSE, finite = TRUE) + checkmate::assert_numeric( + label_segment_threshold[1], + lower = label_segment_threshold[2], + upper = label_segment_threshold[3], + .var.name = "label_segment_threshold" + ) + } + assert_decorators(decorators, "plot") + # End of assertions + + # Make UI args + args <- as.list(environment()) + + ans <- module( + label = label, + server = srv_a_regression.picks, + ui = ui_a_regression.picks, + ui_args = args[names(args) %in% names(formals(ui_a_regression.picks))], + server_args = args[names(args) %in% names(formals(srv_a_regression.picks))], , + transformators = transformators, + datanames = .picks_datanames(list(regressor, response)) + ) + attr(ans, "teal_bookmarkable") <- FALSE + ans +} + +# UI function for the regression module +ui_a_regression.picks <- function(id, + response, + regressor, + outlier, + plot_choices, + default_plot_type, + alpha, + size, + label_segment_threshold, + ggtheme, + pre_output, + post_output, + decorators) { + ns <- NS(id) + teal.widgets::standard_layout( + output = teal.widgets::white_small_well(tags$div( + teal.widgets::plot_with_settings_ui(id = ns("myplot")), + tags$div(verbatimTextOutput(ns("text"))) + )), + encoding = tags$div( + tags$label("Encodings", class = "text-primary"), tags$br(), + tags$div( + tags$strong("Response variable"), + teal.transform::picks_ui(id = ns("response"), picks = response) + ), + tags$div( + tags$strong("Regressor variables"), + teal.transform::picks_ui(id = ns("regressor"), picks = regressor) + ), + radioButtons( + ns("plot_type"), + label = "Plot type:", + choices = plot_choices, + selected = plot_choices[default_plot_type] + ), + checkboxInput(ns("show_outlier"), label = "Display outlier labels", value = FALSE), + conditionalPanel( + condition = "input['show_outlier']", + ns = ns, + teal.widgets::optionalSliderInput( + ns("outlier_cutoff"), + tags$div( + tagList( + "Outlier definition:", + bslib::tooltip( + icon("fas fa-circle-info"), + paste( + "Use the slider to choose the cut-off value to define outliers.", + "Points with a Cook's distance greater than", + "the value on the slider times the mean of the Cook's distance of the dataset will have labels." + ) + ) + ) + ), + min = 1, max = 10, value = 9, ticks = FALSE, step = .1 + ), + teal.transform::picks_ui(id = ns("outlier"), picks = outlier) + ), + ui_decorate_teal_data(ns("decorator"), decorators = select_decorators(decorators, "plot")), + bslib::accordion( + open = TRUE, + bslib::accordion_panel( + title = "Plot settings", + teal.widgets::optionalSliderInputValMinMax(ns("alpha"), "Opacity:", alpha, ticks = FALSE), + teal.widgets::optionalSliderInputValMinMax(ns("size"), "Points size:", size, ticks = FALSE), + teal.widgets::optionalSliderInputValMinMax( + inputId = ns("label_min_segment"), + label = tags$div( + tagList( + "Label min. segment:", + bslib::tooltip( + icon("circle-info"), + tags$span( + paste( + "Use the slider to choose the cut-off value to define minimum distance between label and point", + "that generates a line segment.", + "It's only valid when 'Display outlier labels' is checked." + ) + ) + ) + ) + ), + value_min_max = label_segment_threshold, + # Extra parameters to sliderInput + ticks = FALSE, + step = .1, + round = FALSE + ), + selectInput( + inputId = ns("ggtheme"), + label = "Theme (by ggplot):", + choices = ggplot_themes, + selected = ggtheme, + multiple = FALSE + ) + ) + ) + ), + pre_output = pre_output, + post_output = post_output + ) +} + +# Server function for the regression module +srv_a_regression.picks <- function(id, + data, + response, + regressor, + outlier, + plot_height, + plot_width, + ggplot2_args, + decorators) { + checkmate::assert_class(data, "reactive") + checkmate::assert_class(isolate(data()), "teal_data") + moduleServer(id, function(input, output, session) { + teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.general") + ns <- session$ns + + selectors <- teal.transform::picks_srv( + picks = list(response = response, regressor = regressor, outlier = outlier), + data = data + ) + + validated_q <- reactive({ + req(data()) + validate_input( + inputId = "response-variables-selected", + condition = is.numeric( + data()[[selectors$response()$datasets$selected]][[selectors$response()$variables$selected]] + ), + message = "A response variable needs to be numeric." + ) + validate_input( + inputId = "regressor-variables-selected", + condition = length(selectors$regressor()$variables$selected) > 0, + message = "A regressor variables need to be selected." + ) + validate_input( + inputId = c("regressor-variables-selected", "response-variables-selected"), + condition = !any(selectors$regressor()$variables$selected %in% selectors$response()$variables$selected), + message = "Response and Regressor must be different." + ) + validate_input( + inputId = c("show_outlier", "outlier-variables-selected"), + condition = !(isTRUE(input$show_outlier) && length(selectors$outlier()$variables$selected) == 0), + message = "Please provide an `Outlier label` variable" + ) + + obj <- data() + teal.reporter::teal_card(obj) <- c( + teal.reporter::teal_card("# Linear Regression Plot"), + teal.reporter::teal_card(obj), + teal.reporter::teal_card("## Module's code") + ) + teal.code::eval_code(obj, 'library("ggplot2");library("dplyr")') + }) + + merged <- teal.transform::merge_srv("merge", data = validated_q, selectors = selectors, output_name = "anl") + + # sets qenv object and populates it with data merge call and fit expression + fit_r <- reactive({ + obj <- req(merged$data()) + anl <- obj[["anl"]] + teal::validate_has_data(anl, 10) + + teal::validate_has_data( + anl[, c(merged$variables()$response, merged$variables()$regressor)], 10, + complete = TRUE, allow_inf = FALSE + ) + + form <- stats::as.formula( + paste( + merged$variables()$response, + paste( + merged$variables()$regressor, + collapse = " + " + ), + sep = " ~ " + ) + ) + + anl_fit <- within(obj, form = form, { + fit <- stats::lm(form, data = anl) + for (regressor in names(fit$contrasts)) { + alts <- paste0(levels(anl[[regressor]]), collapse = "|") + names(fit$coefficients) <- gsub( + paste0("^(", regressor, ")(", alts, ")$"), paste0("\\1", ": ", "\\2"), names(fit$coefficients) + ) + } + fit_summary <- summary(fit) + fit_summary + }) + teal.reporter::teal_card(anl_fit) <- c(teal.reporter::teal_card(anl_fit), "## Plot") + anl_fit + }) + + outlier_label_call <- reactive({ + substitute( + expr = dplyr::if_else( + data$.cooksd > outlier_cutoff * mean(data$.cooksd, na.rm = TRUE), + as.character(stats::na.omit(anl)[[label_var]]), + "" + ) %>% + dplyr::if_else(is.na(.), "cooksd == NaN", .), + env = list(outlier_cutoff = input$outlier_cutoff, label_var = merged$variables()$outlier) + ) + }) + + outlier_label_geom <- reactive({ + substitute( + expr = ggrepel::geom_text_repel( + label = label_col, + color = "red", + hjust = 0, + vjust = 1, + max.overlaps = Inf, + min.segment.length = label_min_segment, + segment.alpha = 0.5, + seed = 123 + ), + env = list(label_col = outlier_label_call(), label_min_segment = input$label_min_segment) + ) + }) + + output_plot_base <- reactive({ + obj <- fit_r() + teal.code::eval_code( + obj, + quote({ + class(fit$residuals) <- NULL + + data <- ggplot2::fortify(fit) + + smooth <- function(x, y) { + as.data.frame(stats::lowess(x, y, f = 2 / 3, iter = 3)) + } + + smoothy_aes <- ggplot2::aes_string(x = "x", y = "y") + + reg_form <- deparse(fit$call[[2]]) + }) + ) + }) + + output_plot_0 <- reactive({ + obj <- req(fit_r()) + fit <- obj[["fit"]] + anl <- obj[["anl"]] + + if (!is.factor(anl[[merged$variables()$regressor]])) { + shinyjs::show("size") + shinyjs::show("alpha") + plot <- substitute( + expr = ggplot2::ggplot(fit$model[, 2:1], ggplot2::aes_string(regressor, response)) + + ggplot2::geom_point(size = size, alpha = alpha) + + ggplot2::stat_smooth(method = "lm", formula = y ~ x, se = FALSE), + env = list( + regressor = merged$variables()$regressor, + response = merged$variables()$response, + size = input$size, + alpha = input$alpha + ) + ) + if (input$show_outlier) { + plot <- substitute( + expr = plot + outlier_label, + env = list(plot = plot, outlier_label = outlier_label_geom()) + ) + } + } else { + shinyjs::hide("size") + shinyjs::hide("alpha") + plot <- substitute( + expr = ggplot2::ggplot(fit$model[, 2:1], ggplot2::aes_string(regressor, response)) + + ggplot2::geom_boxplot(), + env = list(regressor = merged$variables()$regressor, response = merged$variables()$response) + ) + if (input$show_outlier) { + plot <- substitute( + expr = plot + outlier_label, + env = list(plot = plot, outlier_label = outlier_label_geom()) + ) + } + } + + parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args( + teal.widgets::resolve_ggplot2_args( + user_plot = ggplot2_args[["Response vs Regressor"]], + user_default = ggplot2_args$default, + module_plot = teal.widgets::ggplot2_args( + labs = list( + title = "Response vs Regressor", + x = varname_w_label(merged$variables()$regressor, anl), + y = varname_w_label(merged$variables()$response, anl) + ), + theme = list() + ) + ), + ggtheme = input$ggtheme + ) + + teal.code::eval_code( + obj, + substitute( + expr = { + class(fit$residuals) <- NULL + data <- ggplot2::fortify(fit) + plot <- graph + }, + env = list( + graph = Reduce(function(x, y) call("+", x, y), c(plot, parsed_ggplot2_args)) + ) + ) + ) + }) + + output_plot_1 <- reactive({ + obj <- req(output_plot_base()) + shinyjs::show("size") + shinyjs::show("alpha") + plot <- substitute( + expr = ggplot2::ggplot(data = data, ggplot2::aes(.fitted, .resid)) + + ggplot2::geom_point(size = size, alpha = alpha) + + ggplot2::geom_hline(yintercept = 0, linetype = "dashed", size = 1) + + ggplot2::geom_line(data = smoothy, mapping = smoothy_aes), + env = list(size = input$size, alpha = input$alpha) + ) + if (input$show_outlier) { + plot <- substitute( + expr = plot + outlier_label, + env = list(plot = plot, outlier_label = outlier_label_geom()) + ) + } + + parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args( + teal.widgets::resolve_ggplot2_args( + user_plot = ggplot2_args[["Residuals vs Fitted"]], + user_default = ggplot2_args$default, + module_plot = teal.widgets::ggplot2_args( + labs = list( + x = quote(paste0("Fitted values\nlm(", reg_form, ")")), + y = "Residuals", + title = "Residuals vs Fitted" + ) + ) + ), + ggtheme = input$ggtheme + ) + + within( + obj, + expr = { + smoothy <- smooth(data$.fitted, data$.resid) + plot <- graph + }, + graph = Reduce(function(x, y) call("+", x, y), c(plot, parsed_ggplot2_args)) + ) + }) + + output_plot_2 <- reactive({ + obj <- req(output_plot_base()) + shinyjs::show("size") + shinyjs::show("alpha") + plot <- substitute( + expr = ggplot2::ggplot(data = data, ggplot2::aes(sample = .stdresid)) + + ggplot2::stat_qq(size = size, alpha = alpha) + + ggplot2::geom_abline(linetype = "dashed"), + env = list(size = input$size, alpha = input$alpha) + ) + if (input$show_outlier) { + plot <- substitute( + expr = plot + + ggplot2::stat_qq( + geom = ggrepel::GeomTextRepel, + label = label_col, + color = "red", + hjust = 0, + vjust = 0, + max.overlaps = Inf, + min.segment.length = label_min_segment, + segment.alpha = .5, + seed = 123 + ), + env = list(plot = plot, label_col = outlier_label_call(), label_min_segment = input$label_min_segment) + ) + } + + parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args( + teal.widgets::resolve_ggplot2_args( + user_plot = ggplot2_args[["Normal Q-Q"]], + user_default = ggplot2_args$default, + module_plot = teal.widgets::ggplot2_args( + labs = list( + x = quote(paste0("Theoretical Quantiles\nlm(", reg_form, ")")), + y = "Standardized residuals", + title = "Normal Q-Q" + ) + ) + ), + ggtheme = input$ggtheme + ) + + within( + obj, + expr = plot <- graph, + graph = Reduce(function(x, y) call("+", x, y), c(plot, parsed_ggplot2_args)) + ) + }) + + output_plot_3 <- reactive({ + obj <- req(output_plot_base()) + shinyjs::show("size") + shinyjs::show("alpha") + plot <- substitute( + expr = ggplot2::ggplot(data = data, ggplot2::aes(.fitted, sqrt(abs(.stdresid)))) + + ggplot2::geom_point(size = size, alpha = alpha) + + ggplot2::geom_line(data = smoothy, mapping = smoothy_aes), + env = list(size = input$size, alpha = input$alpha) + ) + if (input$show_outlier) { + plot <- substitute( + expr = plot + outlier_label, + env = list(plot = plot, outlier_label = outlier_label_geom()) + ) + } + + parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args( + teal.widgets::resolve_ggplot2_args( + user_plot = ggplot2_args[["Scale-Location"]], + user_default = ggplot2_args$default, + module_plot = teal.widgets::ggplot2_args( + labs = list( + x = quote(paste0("Fitted values\nlm(", reg_form, ")")), + y = quote(expression(sqrt(abs(`Standardized residuals`)))), + title = "Scale-Location" + ) + ) + ), + ggtheme = input$ggtheme + ) + + within( + obj, + expr = { + smoothy <- smooth(data$.fitted, sqrt(abs(data$.stdresid))) + plot <- graph + }, + graph = Reduce(function(x, y) call("+", x, y), c(plot, parsed_ggplot2_args)) + ) + }) + + output_plot_4 <- reactive({ + obj <- output_plot_base() + shinyjs::hide("size") + shinyjs::show("alpha") + plot <- substitute( + expr = ggplot2::ggplot(data = data, ggplot2::aes(seq_along(.cooksd), .cooksd)) + + ggplot2::geom_col(alpha = alpha), + env = list(alpha = input$alpha) + ) + if (input$show_outlier) { + plot <- substitute( + expr = plot + + ggplot2::geom_hline( + yintercept = c( + outlier * mean(data$.cooksd, na.rm = TRUE), + mean(data$.cooksd, na.rm = TRUE) + ), + color = "red", + linetype = "dashed" + ) + + ggplot2::annotate( + geom = "text", + x = 0, + y = mean(data$.cooksd, na.rm = TRUE), + label = paste("mu", "=", round(mean(data$.cooksd, na.rm = TRUE), 4)), + vjust = -1, + hjust = 0, + color = "red", + angle = 90 + ) + + outlier_label, + env = list(plot = plot, outlier = input$outlier_cutoff, outlier_label = outlier_label_geom()) + ) + } + + parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args( + teal.widgets::resolve_ggplot2_args( + user_plot = ggplot2_args[["Cook's distance"]], + user_default = ggplot2_args$default, + module_plot = teal.widgets::ggplot2_args( + labs = list( + x = quote(paste0("Obs. number\nlm(", reg_form, ")")), + y = "Cook's distance", + title = "Cook's distance" + ) + ) + ), + ggtheme = input$ggtheme + ) + + within( + obj, + expr = plot <- graph, + graph = Reduce(function(x, y) call("+", x, y), c(plot, parsed_ggplot2_args)) + ) + }) + + output_plot_5 <- reactive({ + obj <- output_plot_base() + shinyjs::show("size") + shinyjs::show("alpha") + plot <- substitute( + expr = ggplot2::ggplot(data = data, ggplot2::aes(.hat, .stdresid)) + + ggplot2::geom_vline( + size = 1, + colour = "black", + linetype = "dashed", + xintercept = 0 + ) + + ggplot2::geom_hline( + size = 1, + colour = "black", + linetype = "dashed", + yintercept = 0 + ) + + ggplot2::geom_point(size = size, alpha = alpha) + + ggplot2::geom_line(data = smoothy, mapping = smoothy_aes), + env = list(size = input$size, alpha = input$alpha) + ) + if (input$show_outlier) { + plot <- substitute( + expr = plot + outlier_label, + env = list(plot = plot, outlier_label = outlier_label_geom()) + ) + } + + parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args( + teal.widgets::resolve_ggplot2_args( + user_plot = ggplot2_args[["Residuals vs Leverage"]], + user_default = ggplot2_args$default, + module_plot = teal.widgets::ggplot2_args( + labs = list( + x = quote(paste0("Standardized residuals\nlm(", reg_form, ")")), + y = "Leverage", + title = "Residuals vs Leverage" + ) + ) + ), + ggtheme = input$ggtheme + ) + + within( + obj, + expr = { + smoothy <- smooth(data$.hat, data$.stdresid) + plot <- graph + }, + graph = Reduce(function(x, y) call("+", x, y), c(plot, parsed_ggplot2_args)) + ) + }) + + output_plot_6 <- reactive({ + obj <- output_plot_base() + shinyjs::show("size") + shinyjs::show("alpha") + plot <- substitute( + expr = ggplot2::ggplot(data = data, ggplot2::aes(.hat, .cooksd)) + + ggplot2::geom_vline(xintercept = 0, colour = NA) + + ggplot2::geom_abline( + slope = seq(0, 3, by = 0.5), + colour = "black", + linetype = "dashed", + size = 1 + ) + + ggplot2::geom_line(data = smoothy, mapping = smoothy_aes) + + ggplot2::geom_point(size = size, alpha = alpha), + env = list(size = input$size, alpha = input$alpha) + ) + if (input$show_outlier) { + plot <- substitute( + expr = plot + outlier_label, + env = list(plot = plot, outlier_label = outlier_label_geom()) + ) + } + + parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args( + teal.widgets::resolve_ggplot2_args( + user_plot = ggplot2_args[["Cook's dist vs Leverage"]], + user_default = ggplot2_args$default, + module_plot = teal.widgets::ggplot2_args( + labs = list( + x = quote(paste0("Leverage\nlm(", reg_form, ")")), + y = "Cooks's distance", + title = "Cook's dist vs Leverage" + ) + ) + ), + ggtheme = input$ggtheme + ) + + within( + obj, + expr = { + smoothy <- smooth(data$.hat, data$.cooksd) + plot <- graph + }, + graph = Reduce(function(x, y) call("+", x, y), c(plot, parsed_ggplot2_args)) + ) + }) + + output_q <- reactive({ + req(input$plot_type) + validate_input( + inputId = c("plot_type", "regressor-variables-selected"), + condition = !( + identical(input$plot_type, "Response vs Regressor") && length(selectors$regressor()$variables$selected) > 1 + ), + message = "This plot works only with single Regressor variable" + ) + + switch(input$plot_type, + "Response vs Regressor" = req(output_plot_0()), + "Residuals vs Fitted" = req(output_plot_1()), + "Normal Q-Q" = req(output_plot_2()), + "Scale-Location" = req(output_plot_3()), + "Cook's distance" = req(output_plot_4()), + "Residuals vs Leverage" = req(output_plot_5()), + "Cook's dist vs Leverage" = req(output_plot_6()) + ) + }) + + decorated_output_q <- srv_decorate_teal_data( + "decorator", + data = output_q, + decorators = select_decorators(decorators, "plot"), + expr = quote(plot) + ) + + fitted <- reactive({ + req(decorated_output_q()) + decorated_output_q()[["fit"]] + }) + plot_r <- reactive({ + req(decorated_output_q()) + decorated_output_q()[["plot"]] + }) + + # Insert the plot into a plot_with_settings module from teal.widgets + pws <- teal.widgets::plot_with_settings_srv( + id = "myplot", + plot_r = plot_r, + height = plot_height, + width = plot_width + ) + + output$text <- renderText({ + paste(utils::capture.output(summary(fitted()))[-1], collapse = "\n") + }) + + set_chunk_dims(pws, decorated_output_q) + }) +} diff --git a/R/tm_data_table.R b/R/tm_data_table.R index 6fcfe4325..63c015d20 100644 --- a/R/tm_data_table.R +++ b/R/tm_data_table.R @@ -130,11 +130,10 @@ tm_data_table <- function(label = "Data Table", checkmate::assert_multi_class(post_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE) # End of assertions - ans <- module( label, - server = srv_page_data_table, - ui = ui_page_data_table, + server = srv_data_table, + ui = ui_data_table, datanames = datanames, server_args = list( datanames = if (is.null(datanames)) "all" else datanames, @@ -154,22 +153,13 @@ tm_data_table <- function(label = "Data Table", } # UI page module -ui_page_data_table <- function(id, pre_output = NULL, post_output = NULL) { +ui_data_table <- function(id, pre_output = NULL, post_output = NULL) { ns <- NS(id) - - tagList( + bslib::page_fluid( teal.widgets::standard_layout( - output = teal.widgets::white_small_well( - bslib::page_fluid( - checkboxInput( - ns("if_distinct"), - "Show only distinct rows:", - value = FALSE - ) - ), - bslib::page_fluid( - uiOutput(ns("dataset_table")) - ) + output = bslib::page_fluid( + div(checkboxInput(ns("if_distinct"), "Show only distinct rows:", value = FALSE)), + uiOutput(ns("data_tables")) ), pre_output = pre_output, post_output = post_output @@ -178,13 +168,19 @@ ui_page_data_table <- function(id, pre_output = NULL, post_output = NULL) { } # Server page module -srv_page_data_table <- function(id, - data, - datanames, - variables_selected, - dt_args, - dt_options, - server_rendering) { +srv_data_table <- function(id, + data, + datanames, + variables_selected = list(), + dt_args = list(), + dt_options = list( + searching = FALSE, + pageLength = 30, + lengthMenu = c(5, 15, 30, 100), + scrollX = TRUE + ), + server_rendering = FALSE, + filter_panel_api) { checkmate::assert_class(data, "reactive") checkmate::assert_class(isolate(data()), "teal_data") moduleServer(id, function(input, output, session) { @@ -193,24 +189,27 @@ srv_page_data_table <- function(id, if_filtered <- reactive(as.logical(input$if_filtered)) if_distinct <- reactive(as.logical(input$if_distinct)) - datanames <- Filter(function(name) { - is.data.frame(isolate(data())[[name]]) - }, if (identical(datanames, "all")) names(isolate(data())) else datanames) - + datanames_r <- reactive({ + Filter( + function(name) is.data.frame(data()[[name]]), + if (identical(datanames, "all")) names(data()) else datanames + ) + }) - output$dataset_table <- renderUI({ + output$data_tables <- renderUI({ + req(datanames_r()) do.call( tabsetPanel, c( - list(id = session$ns("dataname_tab")), + list(id = session$ns("tabs_selected"), selected = datanames_r()[1]), lapply( - datanames, - function(x) { - dataset <- isolate(data()[[x]]) + datanames_r(), + function(dataname) { + dataset <- isolate(data()[[dataname]]) choices <- names(dataset) labels <- vapply( dataset, - function(x) ifelse(is.null(attr(x, "label")), "", attr(x, "label")), + function(column) ifelse(is.null(attr(column, "label")), "", attr(column, "label")), character(1) ) names(choices) <- ifelse( @@ -218,17 +217,17 @@ srv_page_data_table <- function(id, choices, paste(choices, labels, sep = ": ") ) - variables_selected <- if (!is.null(variables_selected[[x]])) { - variables_selected[[x]] + variables_selected <- if (!is.null(variables_selected[[dataname]])) { + variables_selected[[dataname]] } else { utils::head(choices) } tabPanel( - title = x, + title = dataname, bslib::layout_columns( col_widths = 12, - ui_data_table( - id = session$ns(x), + ui_dataset_table( + id = session$ns(dataname), choices = choices, selected = variables_selected ) @@ -238,30 +237,39 @@ srv_page_data_table <- function(id, ) ) ) - }) + }) |> + bindCache(datanames_r()) |> + bindEvent(datanames_r()) - lapply( - datanames, - function(x) { - srv_data_table( - id = x, - data = data, - dataname = x, - if_filtered = if_filtered, - if_distinct = if_distinct, - dt_args = dt_args, - dt_options = dt_options, - server_rendering = server_rendering - ) - } - ) + + # server should be run only once + modules_run <- reactiveVal() + modules_to_run <- reactive(setdiff(datanames_r(), isolate(modules_run()))) + observeEvent(modules_to_run(), { + lapply( + modules_to_run(), + function(dataname) { + srv_dataset_table( + id = dataname, + data = data, + dataname = dataname, + if_filtered = if_filtered, + if_distinct = if_distinct, + dt_args = dt_args, + dt_options = dt_options, + server_rendering = server_rendering, + filter_panel_api = filter_panel_api + ) + } + ) + modules_run(union(modules_run(), modules_to_run())) + }) }) } # UI function for the data_table module -ui_data_table <- function(id, choices, selected) { +ui_dataset_table <- function(id, choices, selected) { ns <- NS(id) - if (!is.null(selected)) { all_choices <- choices choices <- c(selected, setdiff(choices, selected)) @@ -287,14 +295,15 @@ ui_data_table <- function(id, choices, selected) { } # Server function for the data_table module -srv_data_table <- function(id, - data, - dataname, - if_filtered, - if_distinct, - dt_args, - dt_options, - server_rendering) { +srv_dataset_table <- function(id, + data, + dataname, + if_filtered, + if_distinct, + dt_args, + dt_options, + server_rendering, + filter_panel_api) { moduleServer(id, function(input, output, session) { iv <- shinyvalidate::InputValidator$new() iv$add_rule("variables", shinyvalidate::sv_required("Please select valid variable names")) @@ -314,6 +323,14 @@ srv_data_table <- function(id, teal.code::eval_code( qenv, substitute( + env = list( + dataname = as.name(dataname), + if_distinct = if_distinct(), + vars = input$variables, + args = dt_args, + dt_options = dt_options, + dt_rows = input$dt_rows + ), expr = { variables <- vars dataframe_selected <- if (if_distinct) { @@ -328,15 +345,7 @@ srv_data_table <- function(id, } dt_args$data <- dataframe_selected table <- do.call(DT::datatable, dt_args) - }, - env = list( - dataname = as.name(dataname), - if_distinct = if_distinct(), - vars = input$variables, - args = dt_args, - dt_options = dt_options, - dt_rows = input$dt_rows - ) + } ) ) }) diff --git a/R/tm_g_association.R b/R/tm_g_association.R index 8516efc9b..d80f35b02 100644 --- a/R/tm_g_association.R +++ b/R/tm_g_association.R @@ -10,11 +10,10 @@ #' #' @inheritParams teal::module #' @inheritParams shared_params -#' @param ref (`data_extract_spec` or `list` of multiple `data_extract_spec`) -#' Reference variable, must accepts a `data_extract_spec` with `select_spec(multiple = FALSE)` -#' to ensure single selection option. -#' @param vars (`data_extract_spec` or `list` of multiple `data_extract_spec`) -#' Variables to be associated with the reference variable. +#' @param ref (`picks`) +#' Reference variable specification created using `teal.transform::picks()`. +#' @param vars (`picks`) +#' Variables to be associated with the reference variable, specified using `teal.transform::picks()`. #' @param show_association (`logical`) optional, whether show association of `vars` #' with reference variable. Defaults to `TRUE`. #' @param distribution_theme,association_theme (`character`) optional, `ggplot2` themes to be used by default. @@ -68,23 +67,19 @@ #' data = data, #' modules = modules( #' tm_g_association( -#' ref = data_extract_spec( -#' dataname = "CO2", -#' select = select_spec( -#' label = "Select variable:", -#' choices = variable_choices(data[["CO2"]], c("Plant", "Type", "Treatment")), -#' selected = "Plant", -#' fixed = FALSE +#' ref = teal.transform::picks( +#' datasets("CO2"), +#' teal.transform::variables( +#' choices = c("Plant", "Type", "Treatment"), +#' selected = "Plant" #' ) #' ), -#' vars = data_extract_spec( -#' dataname = "CO2", -#' select = select_spec( -#' label = "Select variables:", -#' choices = variable_choices(data[["CO2"]], c("Plant", "Type", "Treatment")), +#' vars = teal.transform::picks( +#' datasets("CO2"), +#' teal.transform::variables( +#' choices = c("Plant", "Type", "Treatment"), #' selected = "Treatment", -#' multiple = TRUE, -#' fixed = FALSE +#' multiple = TRUE #' ) #' ) #' ) @@ -111,29 +106,19 @@ #' data = data, #' modules = modules( #' tm_g_association( -#' ref = data_extract_spec( -#' dataname = "ADSL", -#' select = select_spec( -#' label = "Select variable:", -#' choices = variable_choices( -#' data[["ADSL"]], -#' c("SEX", "RACE", "COUNTRY", "ARM", "STRATA1", "STRATA2", "ITTFL", "BMRKR2") -#' ), -#' selected = "RACE", -#' fixed = FALSE +#' ref = teal.transform::picks( +#' datasets("ADSL"), +#' teal.transform::variables( +#' choices = c("SEX", "RACE", "COUNTRY", "ARM", "STRATA1", "STRATA2", "ITTFL", "BMRKR2"), +#' selected = "RACE" #' ) #' ), -#' vars = data_extract_spec( -#' dataname = "ADSL", -#' select = select_spec( -#' label = "Select variables:", -#' choices = variable_choices( -#' data[["ADSL"]], -#' c("SEX", "RACE", "COUNTRY", "ARM", "STRATA1", "STRATA2", "ITTFL", "BMRKR2") -#' ), +#' vars = teal.transform::picks( +#' datasets("ADSL"), +#' teal.transform::variables( +#' choices = c("SEX", "RACE", "COUNTRY", "ARM", "STRATA1", "STRATA2", "ITTFL", "BMRKR2"), #' selected = "BMRKR2", -#' multiple = TRUE, -#' fixed = FALSE +#' multiple = TRUE #' ) #' ) #' ) @@ -144,9 +129,16 @@ #' } #' #' @export -#' tm_g_association <- function(label = "Association", - ref, + ref = teal.transform::picks( + teal.transform::datasets(), + teal.transform::variables( + choices = is.numeric | + teal.transform::is_categorical(min.len = 2, max.len = 10), + selected = 1L + ), + teal.transform::values() + ), vars, show_association = TRUE, plot_height = c(600, 400, 5000), @@ -158,6 +150,23 @@ tm_g_association <- function(label = "Association", ggplot2_args = teal.widgets::ggplot2_args(), transformators = list(), decorators = list()) { + UseMethod("tm_g_association", ref) +} + +#' @export +tm_g_association.default <- function(label = "Association", + ref, + vars, + show_association = TRUE, + plot_height = c(600, 400, 5000), + plot_width = NULL, + distribution_theme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void"), # nolint: line_length. + association_theme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void"), # nolint: line_length. + pre_output = NULL, + post_output = NULL, + ggplot2_args = teal.widgets::ggplot2_args(), + transformators = list(), + decorators = list()) { message("Initializing tm_g_association") # Normalize the parameters @@ -207,8 +216,8 @@ tm_g_association <- function(label = "Association", ans <- module( label = label, - server = srv_tm_g_association, - ui = ui_tm_g_association, + server = srv_tm_g_association.default, + ui = ui_tm_g_association.default, ui_args = args, server_args = c( data_extract_list, @@ -222,7 +231,7 @@ tm_g_association <- function(label = "Association", } # UI function for the association module -ui_tm_g_association <- function(id, ...) { +ui_tm_g_association.default <- function(id, ...) { ns <- NS(id) args <- list(...) is_single_dataset_value <- teal.transform::is_single_dataset(args$ref, args$vars) @@ -295,14 +304,14 @@ ui_tm_g_association <- function(id, ...) { } # Server function for the association module -srv_tm_g_association <- function(id, - data, - ref, - vars, - plot_height, - plot_width, - ggplot2_args, - decorators) { +srv_tm_g_association.default <- function(id, + data, + ref, + vars, + plot_height, + plot_width, + ggplot2_args, + decorators) { checkmate::assert_class(data, "reactive") checkmate::assert_class(isolate(data()), "teal_data") diff --git a/R/tm_g_association_picks.R b/R/tm_g_association_picks.R new file mode 100644 index 000000000..4ba372ca7 --- /dev/null +++ b/R/tm_g_association_picks.R @@ -0,0 +1,363 @@ +#' @export +tm_g_association.picks <- function(label = "Association", + ref = teal.transform::picks( + teal.transform::datasets(), + teal.transform::variables( + choices = is.numeric | + teal.transform::is_categorical(min.len = 2, max.len = 10), + selected = 1L + ), + teal.transform::values() + ), + vars = teal.transform::picks( + teal.transform::datasets(), + teal.transform::variables( + choices = is.numeric | + teal.transform::is_categorical(min.len = 2, max.len = 10), + selected = 2L, + multiple = TRUE + ) + ), + show_association = TRUE, + plot_height = c(600, 400, 5000), + plot_width = NULL, + distribution_theme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void"), # nolint: line_length. + association_theme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void"), # nolint: line_length. + pre_output = NULL, + post_output = NULL, + ggplot2_args = teal.widgets::ggplot2_args(), + transformators = list(), + decorators = list()) { + message("Initializing tm_g_association") + + # Normalize the parameters + if (inherits(ggplot2_args, "ggplot2_args")) ggplot2_args <- list(default = ggplot2_args) + + # Start of assertions + checkmate::assert_string(label) + checkmate::assert_class(ref, "picks") + if (isTRUE(attr(ref$variables, "multiple"))) { + warning("`ref` accepts only a single variable selection. Forcing `teal.transform::variables(multiple) to FALSE`") + attr(ref$variables, "multiple") <- FALSE + } + checkmate::assert_class(vars, "picks") + checkmate::assert_flag(show_association) + checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE) + checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height") + checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE) + checkmate::assert_numeric( + plot_width[1], + lower = plot_width[2], upper = plot_width[3], null.ok = TRUE, .var.name = "plot_width" + ) + + distribution_theme <- match.arg(distribution_theme) + association_theme <- match.arg(association_theme) + + 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) + + plot_choices <- c("Bivariate1", "Bivariate2") + checkmate::assert_list(ggplot2_args, types = "ggplot2_args") + checkmate::assert_subset(names(ggplot2_args), c("default", plot_choices)) + + assert_decorators(decorators, "plot") + # End of assertions + + args <- as.list(environment()) + ans <- module( + label = label, + ui = ui_g_association.picks, + server = srv_g_association.picks, + ui_args = args[names(args) %in% names(formals(ui_g_association.picks))], + server_args = args[names(args) %in% names(formals(srv_g_association.picks))], + transformators = transformators, + datanames = .picks_datanames(list(ref = ref, vars = vars)) + ) + attr(ans, "teal_bookmarkable") <- TRUE + ans +} + +# UI function for the association module +ui_g_association.picks <- function(id, + ref, + vars, + show_association, + distribution_theme, + association_theme, + pre_output, + post_output, + decorators) { + ns <- NS(id) + + teal.widgets::standard_layout( + output = teal.widgets::white_small_well( + textOutput(ns("title")), + tags$br(), + teal.widgets::plot_with_settings_ui(id = ns("myplot")) + ), + encoding = tags$div( + tags$label("Encodings", class = "text-primary"), + tags$div( + tags$strong("Reference variable"), + teal.transform::picks_ui(id = ns("ref"), picks = ref) + ), + tags$div( + tags$strong("Associated variables"), + teal.transform::picks_ui(id = ns("vars"), picks = vars) + ), + checkboxInput(ns("association"), "Association with reference variable", value = show_association), + checkboxInput(ns("show_dist"), "Scaled frequencies", value = FALSE), + checkboxInput(ns("log_transformation"), "Log transformed", value = FALSE), + ui_decorate_teal_data(ns("decorator"), decorators = select_decorators(decorators, "plot")), + bslib::accordion( + open = TRUE, + bslib::accordion_panel( + title = "Plot settings", + teal.widgets::optionalSliderInputValMinMax(ns("alpha"), "Scatterplot opacity:", c(0.5, 0, 1), ticks = FALSE), + teal.widgets::optionalSliderInputValMinMax(ns("size"), "Scatterplot points size:", c(2, 1, 8), ticks = FALSE), + checkboxInput(ns("swap_axes"), "Swap axes", value = FALSE), + checkboxInput(ns("rotate_xaxis_labels"), "Rotate X axis labels", value = FALSE), + selectInput( + inputId = ns("distribution_theme"), + label = "Distribution theme (by ggplot):", + choices = ggplot_themes, + selected = distribution_theme, + multiple = FALSE + ), + selectInput( + inputId = ns("association_theme"), + label = "Association theme (by ggplot):", + choices = ggplot_themes, + selected = association_theme, + multiple = FALSE + ) + ) + ) + ), + pre_output = pre_output, + post_output = post_output + ) +} + +# Server function for the association module +srv_g_association.picks <- function(id, + data, + ref, + vars, + plot_height, + plot_width, + ggplot2_args, + decorators) { + checkmate::assert_class(data, "reactive") + checkmate::assert_class(isolate(data()), "teal_data") + + moduleServer(id, function(input, output, session) { + teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.general") + + selectors <- teal.transform::picks_srv(picks = list(ref = ref, vars = vars), data = data) + + validated_q <- reactive({ + obj <- req(data()) + validate_input( + inputId = "ref-variables-selected", + condition = !is.null(selectors$ref()$variables$selected), + message = "A reference variable must be selected." + ) + validate_input( + inputId = "vars-variables-selected", + condition = !is.null(selectors$vars()$variables$selected), + message = "A associated variables must be selected." + ) + validate_input( + inputId = c("ref-variables-selected", "vars-variables-selected"), + condition = !any(selectors$ref()$variables$selected %in% selectors$vars()$variables$selected), + message = "Associated variables and reference variable cannot overlap" + ) + teal.reporter::teal_card(obj) <- + c( + teal.reporter::teal_card("# Association Plot"), + teal.reporter::teal_card(obj), + teal.reporter::teal_card("## Module's code") + ) + teal.code::eval_code(obj, 'library("ggplot2");library("dplyr");library("tern");library("ggmosaic")') + }) + + merged <- teal.transform::merge_srv("merge", data = validated_q, selectors = selectors, output_name = "anl") + + output_q <- reactive({ + req(merged$data()) + logger::log_debug("srv_g_association@1 recalculating a plot") + anl <- merged$data()[["anl"]] + ref_name <- merged$variables()$ref + vars_names <- merged$variables()$vars + teal::validate_has_data(anl, 3) + teal::validate_has_data(anl[, c(ref_name, vars_names)], 3, complete = TRUE, allow_inf = FALSE) + + association <- input$association + show_dist <- input$show_dist + log_transformation <- input$log_transformation + rotate_xaxis_labels <- input$rotate_xaxis_labels + swap_axes <- input$swap_axes + distribution_theme <- input$distribution_theme + association_theme <- input$association_theme + + is_scatterplot <- is.numeric(anl[[ref_name]]) && any(vapply(anl[vars_names], is.numeric, logical(1))) + if (is_scatterplot) { + shinyjs::show("alpha") + shinyjs::show("size") + alpha <- input$alpha + size <- input$size + } else { + shinyjs::hide("alpha") + shinyjs::hide("size") + alpha <- 0.5 + size <- 2 + } + + # reference + ref_class <- class(anl[[ref_name]])[1] + if (is.numeric(anl[[ref_name]]) && log_transformation) { + # works for both integers and doubles + ref_cl_name <- call("log", as.name(ref_name)) + ref_cl_lbl <- varname_w_label(ref_name, anl, prefix = "Log of ") + } else { + # silently ignore when non-numeric even if `log` is selected because some + # variables may be numeric and others not + ref_cl_name <- as.name(ref_name) + ref_cl_lbl <- varname_w_label(ref_name, anl) + } + + user_ggplot2_args <- teal.widgets::resolve_ggplot2_args( + user_plot = ggplot2_args[["Bivariate1"]], + user_default = ggplot2_args$default + ) + + ref_call <- bivariate_plot_call( + data_name = "anl", + x = ref_cl_name, + x_class = ref_class, + x_label = ref_cl_lbl, + freq = !show_dist, + theme = distribution_theme, + rotate_xaxis_labels = rotate_xaxis_labels, + swap_axes = FALSE, + size = size, + alpha = alpha, + ggplot2_args = user_ggplot2_args + ) + + # association + ref_class_cov <- ifelse(association, ref_class, "NULL") + + var_calls <- lapply(vars_names, function(var_i) { + if (is.numeric(anl[[var_i]]) && log_transformation) { + # works for both integers and doubles + var_cl_name <- call("log", as.name(var_i)) + var_cl_lbl <- varname_w_label(var_i, anl, prefix = "Log of ") + } else { + # silently ignore when non-numeric even if `log` is selected because some + # variables may be numeric and others not + var_cl_name <- as.name(var_i) + var_cl_lbl <- varname_w_label(var_i, anl) + } + + user_ggplot2_args <- teal.widgets::resolve_ggplot2_args( + user_plot = ggplot2_args[["Bivariate2"]], + user_default = ggplot2_args$default + ) + + bivariate_plot_call( + data_name = "anl", + x = ref_cl_name, + y = var_cl_name, + x_class = ref_class_cov, + y_class = class(anl[[var_i]])[1], + x_label = ref_cl_lbl, + y_label = var_cl_lbl, + theme = association_theme, + freq = !show_dist, + rotate_xaxis_labels = rotate_xaxis_labels, + swap_axes = swap_axes, + alpha = alpha, + size = size, + ggplot2_args = user_ggplot2_args + ) + }) + + # helper function to format variable name + format_varnames <- function(x) { + if (is.numeric(anl[[x]]) && log_transformation) { + varname_w_label(x, anl, prefix = "Log of ") + } else { + varname_w_label(x, anl) + } + } + new_title <- + if (association) { + switch(as.character(length(vars_names)), + "0" = sprintf("Value distribution for %s", ref_cl_lbl), + "1" = sprintf( + "Association between %s and %s", + ref_cl_lbl, + format_varnames(vars_names) + ), + sprintf( + "Associations between %s and: %s", + ref_cl_lbl, + paste(lapply(vars_names, format_varnames), collapse = ", ") + ) + ) + } else { + switch(as.character(length(vars_names)), + "0" = sprintf("Value distribution for %s", ref_cl_lbl), + sprintf( + "Value distributions for %s and %s", + ref_cl_lbl, + paste(lapply(vars_names, format_varnames), collapse = ", ") + ) + ) + } + obj <- merged$data() + + teal.reporter::teal_card(obj) <- c(teal.reporter::teal_card(obj), "## Plot") + within( + obj, + expr = { + title <- new_title + ref_plot <- plot1 + var_plot <- plot2 + plot <- gridExtra::arrangeGrob(ref_plot, var_plot, ncol = 1) + }, + new_title = new_title, + plot1 = ref_call, + plot2 = var_calls[[1]] + ) + }) + + decorated_output_grob_q <- srv_decorate_teal_data( + id = "decorator", + data = output_q, + decorators = select_decorators(decorators, "plot"), + expr = quote({ + grid::grid.newpage() + grid::grid.draw(plot) + }) + ) + + plot_r <- reactive({ + req(decorated_output_grob_q())[["plot"]] + }) + + pws <- teal.widgets::plot_with_settings_srv( + id = "myplot", + plot_r = plot_r, + height = plot_height, + width = plot_width + ) + + + output$title <- renderText(output_q()[["title"]]) + + set_chunk_dims(pws, decorated_output_grob_q) + }) +} diff --git a/R/tm_g_bivariate.R b/R/tm_g_bivariate.R index 4bb60d406..f14d53f36 100644 --- a/R/tm_g_bivariate.R +++ b/R/tm_g_bivariate.R @@ -11,33 +11,30 @@ #' #' @inheritParams teal::module #' @inheritParams shared_params -#' @param x (`data_extract_spec` or `list` of multiple `data_extract_spec`) -#' Variable names selected to plot along the x-axis by default. -#' Can be numeric, factor or character. -#' No empty selections are allowed. -#' @param y (`data_extract_spec` or `list` of multiple `data_extract_spec`) -#' Variable names selected to plot along the y-axis by default. +#' @param x (`picks`) Variable specification for the x-axis. Created using [teal.transform::picks()]. +#' Can be numeric, factor or character. No empty selections are allowed. +#' @param y (`picks`) Variable specification for the y-axis. Created using [teal.transform::picks()]. #' Can be numeric, factor or character. #' @param use_density (`logical`) optional, indicates whether to plot density (`TRUE`) or frequency (`FALSE`). #' Defaults to frequency (`FALSE`). -#' @param row_facet (`data_extract_spec` or `list` of multiple `data_extract_spec`) optional, -#' specification of the data variable(s) to use for faceting rows. -#' @param col_facet (`data_extract_spec` or `list` of multiple `data_extract_spec`) optional, -#' specification of the data variable(s) to use for faceting columns. +#' @param row_facet (`picks`) optional, specification of the data variable(s) to use for faceting rows. +#' Created using [teal.transform::picks()]. +#' @param col_facet (`picks`) optional, specification of the data variable(s) to use for faceting columns. +#' Created using [teal.transform::picks()]. #' @param facet (`logical`) optional, specifies whether the facet encodings `ui` elements are toggled #' on and shown to the user by default. Defaults to `TRUE` if either `row_facet` or `column_facet` #' are supplied. #' @param color_settings (`logical`) Whether coloring, filling and size should be applied #' and `UI` tool offered to the user. -#' @param color (`data_extract_spec` or `list` of multiple `data_extract_spec`) optional, -#' specification of the data variable(s) selected for the outline color inside the coloring settings. -#' It will be applied when `color_settings` is set to `TRUE`. -#' @param fill (`data_extract_spec` or `list` of multiple `data_extract_spec`) optional, -#' specification of the data variable(s) selected for the fill color inside the coloring settings. -#' It will be applied when `color_settings` is set to `TRUE`. -#' @param size (`data_extract_spec` or `list` of multiple `data_extract_spec`) optional, -#' specification of the data variable(s) selected for the size of `geom_point` plots inside the coloring settings. -#' It will be applied when `color_settings` is set to `TRUE`. +#' @param color (`picks`) optional, specification of the data variable(s) selected for the outline color +#' inside the coloring settings. It will be applied when `color_settings` is set to `TRUE`. +#' Created using [teal.transform::picks()]. +#' @param fill (`picks`) optional, specification of the data variable(s) selected for the fill color +#' inside the coloring settings. It will be applied when `color_settings` is set to `TRUE`. +#' Created using [teal.transform::picks()]. +#' @param size (`picks`) optional, specification of the data variable(s) selected for the size of +#' `geom_point` plots inside the coloring settings. It will be applied when `color_settings` is set to `TRUE`. +#' Created using [teal.transform::picks()]. #' @param free_x_scales (`logical`) optional, whether X scaling shall be changeable. #' Does not allow scaling to be changed by default (`FALSE`). #' @param free_y_scales (`logical`) optional, whether Y scaling shall be changeable. @@ -87,42 +84,22 @@ #' app <- init( #' data = data, #' modules = tm_g_bivariate( -#' x = data_extract_spec( -#' dataname = "CO2", -#' select = select_spec( -#' label = "Select variable:", -#' choices = variable_choices(data[["CO2"]]), -#' selected = "conc", -#' fixed = FALSE -#' ) +#' label = "Bivariate Plots", +#' x = teal.transform::picks( +#' datasets("CO2"), +#' teal.transform::variables(selected = "conc") #' ), -#' y = data_extract_spec( -#' dataname = "CO2", -#' select = select_spec( -#' label = "Select variable:", -#' choices = variable_choices(data[["CO2"]]), -#' selected = "uptake", -#' multiple = FALSE, -#' fixed = FALSE -#' ) +#' y = teal.transform::picks( +#' datasets("CO2"), +#' teal.transform::variables(selected = "uptake") #' ), -#' row_facet = data_extract_spec( -#' dataname = "CO2", -#' select = select_spec( -#' label = "Select variable:", -#' choices = variable_choices(data[["CO2"]]), -#' selected = "Type", -#' fixed = FALSE -#' ) +#' row_facet = teal.transform::picks( +#' datasets("CO2"), +#' teal.transform::variables(selected = "Type") #' ), -#' col_facet = data_extract_spec( -#' dataname = "CO2", -#' select = select_spec( -#' label = "Select variable:", -#' choices = variable_choices(data[["CO2"]]), -#' selected = "Treatment", -#' fixed = FALSE -#' ) +#' col_facet = teal.transform::picks( +#' datasets("CO2"), +#' teal.transform::variables(selected = "Treatment") #' ) #' ) #' ) @@ -146,42 +123,22 @@ #' app <- init( #' data = data, #' modules = tm_g_bivariate( -#' x = data_extract_spec( -#' dataname = "ADSL", -#' select = select_spec( -#' label = "Select variable:", -#' choices = variable_choices(data[["ADSL"]]), -#' selected = "AGE", -#' fixed = FALSE -#' ) +#' label = "Bivariate Plots", +#' x = teal.transform::picks( +#' datasets("ADSL"), +#' teal.transform::variables(selected = "AGE") #' ), -#' y = data_extract_spec( -#' dataname = "ADSL", -#' select = select_spec( -#' label = "Select variable:", -#' choices = variable_choices(data[["ADSL"]]), -#' selected = "SEX", -#' multiple = FALSE, -#' fixed = FALSE -#' ) +#' y = teal.transform::picks( +#' datasets("ADSL"), +#' teal.transform::variables(selected = "SEX") #' ), -#' row_facet = data_extract_spec( -#' dataname = "ADSL", -#' select = select_spec( -#' label = "Select variable:", -#' choices = variable_choices(data[["ADSL"]]), -#' selected = "ARM", -#' fixed = FALSE -#' ) +#' row_facet = teal.transform::picks( +#' datasets("ADSL"), +#' teal.transform::variables(selected = "ARM") #' ), -#' col_facet = data_extract_spec( -#' dataname = "ADSL", -#' select = select_spec( -#' label = "Select variable:", -#' choices = variable_choices(data[["ADSL"]]), -#' selected = "COUNTRY", -#' fixed = FALSE -#' ) +#' col_facet = teal.transform::picks( +#' datasets("ADSL"), +#' teal.transform::variables(selected = "COUNTRY") #' ) #' ) #' ) @@ -192,11 +149,19 @@ #' @export #' tm_g_bivariate <- function(label = "Bivariate Plots", - x, + x = teal.transform::picks( + teal.transform::datasets(), + teal.transform::variables( + choices = is.numeric | + teal.transform::is_categorical(min.len = 2, max.len = 10), + selected = 1L + ), + teal.transform::values() + ), y, - row_facet = NULL, - col_facet = NULL, - facet = !is.null(row_facet) || !is.null(col_facet), + row_facet, + col_facet, + facet, color = NULL, fill = NULL, size = NULL, @@ -214,6 +179,33 @@ tm_g_bivariate <- function(label = "Bivariate Plots", post_output = NULL, transformators = list(), decorators = list()) { + UseMethod("tm_g_bivariate", x) +} + +#' @export +tm_g_bivariate.default <- function(label = "Bivariate Plots", + x, + y, + row_facet = NULL, + col_facet = NULL, + facet = !is.null(row_facet) || !is.null(col_facet), + color = NULL, + fill = NULL, + size = NULL, + use_density = FALSE, + color_settings = FALSE, + free_x_scales = FALSE, + free_y_scales = FALSE, + plot_height = c(600, 200, 2000), + plot_width = NULL, + rotate_xaxis_labels = FALSE, + swap_axes = FALSE, + ggtheme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void"), + ggplot2_args = teal.widgets::ggplot2_args(), + pre_output = NULL, + post_output = NULL, + transformators = list(), + decorators = list()) { message("Initializing tm_g_bivariate") # Normalize the parameters @@ -313,8 +305,8 @@ tm_g_bivariate <- function(label = "Bivariate Plots", ans <- module( label = label, - server = srv_g_bivariate, - ui = ui_g_bivariate, + server = srv_g_bivariate.default, + ui = ui_g_bivariate.default, ui_args = args, server_args = c( data_extract_list, @@ -328,7 +320,7 @@ tm_g_bivariate <- function(label = "Bivariate Plots", } # UI function for the bivariate module -ui_g_bivariate <- function(id, ...) { +ui_g_bivariate.default <- function(id, ...) { args <- list(...) is_single_dataset_value <- teal.transform::is_single_dataset( args$x, args$y, args$row_facet, args$col_facet, args$color, args$fill, args$size @@ -472,20 +464,20 @@ ui_g_bivariate <- function(id, ...) { } # Server function for the bivariate module -srv_g_bivariate <- function(id, - data, - x, - y, - row_facet, - col_facet, - color_settings = FALSE, - color, - fill, - size, - plot_height, - plot_width, - ggplot2_args, - decorators) { +srv_g_bivariate.default <- function(id, + data, + x, + y, + row_facet, + col_facet, + color_settings = FALSE, + color, + fill, + size, + plot_height, + plot_width, + ggplot2_args, + decorators) { checkmate::assert_class(data, "reactive") checkmate::assert_class(isolate(data()), "teal_data") moduleServer(id, function(input, output, session) { @@ -739,8 +731,8 @@ srv_g_bivariate <- function(id, # Get Substituted ggplot call bivariate_plot_call <- function(data_name, - x = character(0), - y = character(0), + x = NULL, + y = NULL, x_class = "NULL", y_class = "NULL", x_label = NULL, @@ -752,17 +744,12 @@ bivariate_plot_call <- function(data_name, alpha = double(0), size = 2, ggplot2_args = teal.widgets::ggplot2_args()) { - supported_types <- c("NULL", "numeric", "integer", "factor", "character", "logical", "ordered") - validate(need(x_class %in% supported_types, paste0("Data type '", x_class, "' is not supported."))) - validate(need(y_class %in% supported_types, paste0("Data type '", y_class, "' is not supported."))) - - - if (identical(x, character(0))) { + if (is.null(x)) { x <- x_label <- "-" } else { x <- if (is.call(x)) x else as.name(x) } - if (identical(y, character(0))) { + if (is.null(y)) { y <- y_label <- "-" } else { y <- if (is.call(y)) y else as.name(y) diff --git a/R/tm_g_bivariate_picks.R b/R/tm_g_bivariate_picks.R new file mode 100644 index 000000000..103411b93 --- /dev/null +++ b/R/tm_g_bivariate_picks.R @@ -0,0 +1,490 @@ +#' @export +tm_g_bivariate.picks <- function(label = "Bivariate Plots", + x = teal.transform::picks( + teal.transform::datasets(), + teal.transform::variables( + choices = is.numeric | + teal.transform::is_categorical(min.len = 2, max.len = 10), + selected = 1L + ), + teal.transform::values() + ), + y = teal.transform::picks( + teal.transform::datasets(), + teal.transform::variables( + choices = is.numeric | + teal.transform::is_categorical(min.len = 2, max.len = 10), + selected = 2L + ), + teal.transform::values() + ), + row_facet = teal.transform::picks( + teal.transform::datasets(), + teal.transform::variables( + choices = teal.transform::is_categorical(min.len = 2, max.len = 10), + selected = NULL + ), + teal.transform::values() + ), + col_facet = teal.transform::picks( + teal.transform::datasets(), + teal.transform::variables( + choices = teal.transform::is_categorical(min.len = 2, max.len = 10), + selected = NULL + ), + teal.transform::values() + ), + facet = !is.null(row_facet) || !is.null(col_facet), + color = NULL, + fill = NULL, + size = NULL, + use_density = FALSE, + color_settings = FALSE, + free_x_scales = FALSE, + free_y_scales = FALSE, + plot_height = c(600, 200, 2000), + plot_width = NULL, + rotate_xaxis_labels = FALSE, + swap_axes = FALSE, + ggtheme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void"), + ggplot2_args = teal.widgets::ggplot2_args(), + pre_output = NULL, + post_output = NULL, + transformators = list(), + decorators = list()) { + message("Initializing tm_g_bivariate") + + # Start of assertions + checkmate::assert_class(x, "picks") + checkmate::assert_class(y, "picks") + if (isTRUE(attr(x$variables, "multiple"))) { + warning("`x`-axis doesn't accept multiple variables. Changing automatically.") + attr(x$variables, "multiple") <- FALSE + } + if (isTRUE(attr(y$variables, "multiple"))) { + warning("`y`-axis doesn't accept multiple variables. Changing automatically.") + attr(x$variables, "multiple") <- FALSE + } + checkmate::assert_class(col_facet, "picks", null.ok = TRUE) + checkmate::assert_class(row_facet, "picks", null.ok = TRUE) + checkmate::assert_class(color, "picks", null.ok = TRUE) + checkmate::assert_class(size, "picks", null.ok = TRUE) + checkmate::assert_string(label) + checkmate::assert_flag(use_density) + + # Determines color, fill & size if they are not explicitly set + checkmate::assert_flag(color_settings) + if (color_settings) { + if (is.null(color)) { + color <- x + color$selected <- NULL + } + if (is.null(fill)) { + fill <- x + fill$selected <- NULL + } + if (is.null(size)) { + size <- x + size$selected <- NULL + } + } else { + if (!is.null(c(color, fill, size))) { + stop("'color_settings' argument needs to be set to TRUE if 'color', 'fill', and/or 'size' is/are supplied.") + } + } + + checkmate::assert_flag(free_x_scales) + checkmate::assert_flag(free_y_scales) + + checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE) + checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height") + checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE) + checkmate::assert_numeric( + plot_width[1], + lower = plot_width[2], upper = plot_width[3], null.ok = TRUE, .var.name = "plot_width" + ) + + checkmate::assert_flag(rotate_xaxis_labels) + checkmate::assert_flag(swap_axes) + + ggtheme <- match.arg(ggtheme) + checkmate::assert_class(ggplot2_args, "ggplot2_args") + + 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) + + assert_decorators(decorators, "plot") + # End of assertions + + # Make UI args + args <- as.list(environment()) + + ans <- module( + label = label, + server = srv_g_bivariate.picks, + ui = ui_g_bivariate.picks, + ui_args = args[names(args) %in% names(formals(ui_g_bivariate.picks))], + server_args = args[names(args) %in% names(formals(srv_g_bivariate.picks))], + transformators = transformators, + datanames = .picks_datanames(list(x, y, row_facet, col_facet, color, fill, size)) + ) + attr(ans, "teal_bookmarkable") <- TRUE + ans +} + +# UI function for the bivariate module +ui_g_bivariate.picks <- function(id, + x, + y, + row_facet = NULL, + col_facet = NULL, + facet = !is.null(row_facet) || !is.null(col_facet), + color = NULL, + fill = NULL, + size = NULL, + use_density = FALSE, + color_settings = FALSE, + free_x_scales = FALSE, + free_y_scales = FALSE, + rotate_xaxis_labels = FALSE, + swap_axes = FALSE, + ggtheme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void"), + ggplot2_args = teal.widgets::ggplot2_args(), + pre_output = NULL, + post_output = NULL, + decorators = list()) { + ns <- NS(id) + teal.widgets::standard_layout( + output = bslib::card( + teal.widgets::plot_with_settings_ui(id = ns("myplot")), + full_screen = TRUE + ), + encoding = shiny::tagList( + tags$div( + tags$strong("X variable"), + teal.transform::picks_ui(id = ns("x"), picks = x) + ), + tags$div( + tags$strong("Y variable"), + teal.transform::picks_ui(id = ns("y"), picks = y) + ), + conditionalPanel( + condition = + "$(\"button[data-id*='-x-dataset'][data-id$='-select']\").text() == '- Nothing selected - ' || + $(\"button[data-id*='-y-dataset'][data-id$='-select']\").text() == '- Nothing selected - ' ", + tags$div( + shinyWidgets::radioGroupButtons( + inputId = ns("use_density"), + label = NULL, + choices = c("frequency", "density"), + selected = ifelse(use_density, "density", "frequency"), + justified = TRUE + ) + ) + ), + if (!is.null(row_facet)) { + tags$div( + tags$div( + tags$strong("Row facetting variable"), + teal.transform::picks_ui(id = ns("row_facet"), picks = row_facet), + checkboxInput(ns("free_x_scales"), "free x scales", value = free_x_scales) + ) + ) + }, + if (!is.null(col_facet)) { + tags$div( + tags$div( + tags$strong("Column facetting variable"), + teal.transform::picks_ui(id = ns("col_facet"), picks = col_facet), + checkboxInput(ns("free_y_scales"), "free y scales", value = free_y_scales) + ) + ) + }, + if (color_settings) { + # Put a grey border around the coloring settings + tags$div( + tags$strong("Color settings"), + tags$div( + bslib::input_switch(id = ns("coloring"), label = "Color settings", value = TRUE), + conditionalPanel( + condition = paste0("input['", ns("coloring"), "']"), + tags$div( + teal.transform::picks_ui(id = ns("color"), picks = color), # label = "Outline color by variable" + teal.transform::picks_ui(id = ns("fill"), picks = fill), # label = "Outline color by variable" + tags$div( + id = ns("size_settings"), + teal.transform::picks_ui(id = ns("size"), picks = size) # label = "Size of points by variable (only if x and y are numeric)" + ) + ) + ) + ) + ) + }, + tags$div( + NULL, + teal:::.teal_navbar_menu( + id = ns("plot_settings"), + label = "Plot settings", + icon = "gear", + tags$div( + checkboxInput(ns("rotate_xaxis_labels"), "Rotate X axis labels", value = rotate_xaxis_labels), + checkboxInput(ns("swap_axes"), "Swap axes", value = swap_axes), + selectInput( + inputId = ns("ggtheme"), + label = "Theme (by ggplot):", + choices = ggplot_themes, + selected = ggtheme, + multiple = FALSE + ), + sliderInput( + ns("alpha"), "Opacity Scatterplot:", + min = 0, max = 1, + step = .05, value = .5, ticks = FALSE + ), + sliderInput( + ns("fixed_size"), "Scatterplot point size:", + min = 1, max = 8, + step = 1, value = 2, ticks = FALSE + ), + checkboxInput(ns("add_lines"), "Add lines") + ) + ) + ), + tags$div( + ui_decorate_teal_data(ns("decorator"), decorators = select_decorators(decorators, "plot")) + ) + ), + pre_output = pre_output, + post_output = post_output + ) +} + +# Server function for the bivariate module +srv_g_bivariate.picks <- function(id, + data, + x, + y, + row_facet, + col_facet, + color_settings = FALSE, + color, + fill, + size, + plot_height, + plot_width, + ggplot2_args, + decorators) { + checkmate::assert_class(data, "reactive") + checkmate::assert_class(isolate(data()), "teal_data") + moduleServer(id, function(input, output, session) { + teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.general") + + ns <- session$ns + selectors <- teal.transform::picks_srv( + picks = list( + x = x, + y = y, + row_facet = row_facet, + col_facet = col_facet, + color = color, + fill = fill, + size = size + ), + data = data + ) + + validated_q <- reactive({ + validate_input( + inputId = c("x-variables-selected", "y-variables-selected"), + condition = length(selectors$x()$variables$selected) && length(selectors$y()$variables$selected), + message = "Please select at least one of x-variable or y-variable" + ) + if (!is.null(col_facet) && !is.null(row_facet)) { + validate_input( + inputId = c("row_facet-variables-selected", "col_facet-variables-selected"), + condition = is.null(selectors$row_facet()$variables$selected) || + is.null(selectors$col_facet()$variables$selected) || + !identical(selectors$row_facet()$variables$selected, selectors$col_facet()$variables$selected), + message = "Row and column facetting variables must be different." + ) + } + + obj <- req(data()) + teal.reporter::teal_card(obj) <- c( + teal.reporter::teal_card("# Bivariate Plot"), + teal.reporter::teal_card(obj), + teal.reporter::teal_card("## Module's code") + ) + teal.code::eval_code(obj, 'library("ggplot2");library("dplyr")') + }) + + merged <- teal.transform::merge_srv("merge", data = validated_q, selectors = selectors, output_name = "anl") + + output_q <- reactive(label = "make bivariateplot", { + req(merged$data()) + logger::log_debug("Plotting bivariate") + anl <- merged$data()[["anl"]] + teal::validate_has_data(anl, 3) + + + x_name <- merged$variables()$x + y_name <- merged$variables()$y + row_facet_name <- merged$variables()$row_facet + col_facet_name <- merged$variables()$col_facet + color_name <- merged$variables()$color + fill_name <- merged$variables()$fill + size_name <- merged$variables()$size + + use_density <- input$use_density == "density" + free_x_scales <- input$free_x_scales + free_y_scales <- input$free_y_scales + ggtheme <- input$ggtheme + rotate_xaxis_labels <- input$rotate_xaxis_labels + swap_axes <- input$swap_axes + + + supported_types <- c("NULL", "numeric", "integer", "factor", "character", "logical", "ordered") + x_class <- class(anl[[x_name]])[1] + validate_input( + "x-variables-selected", + condition = x_class %in% supported_types, + message = paste0("Data type '", x_class, "' is not supported.") + ) + y_class <- class(anl[[y_name]])[[1]] + validate_input( + "x-variables-selected", + condition = y_class %in% supported_types, + message = paste0("Data type '", y_class, "' is not supported.") + ) + + is_scatterplot <- all(vapply(anl[c(x_name, y_name)], is.numeric, logical(1))) && + length(x_name) > 0 && length(y_name) > 0 + + if (is_scatterplot) { + shinyjs::show("alpha") + alpha <- input$alpha + shinyjs::show("add_lines") + + if (color_settings && input$coloring) { + shinyjs::hide("fixed_size") + shinyjs::show("size_settings") + size <- NULL + } else { + shinyjs::show("fixed_size") + size <- input$fixed_size + } + } else { + shinyjs::hide("add_lines") + updateCheckboxInput(session, "add_lines", value = restoreInput(ns("add_lines"), FALSE)) + shinyjs::hide("alpha") + shinyjs::hide("fixed_size") + shinyjs::hide("size_settings") + alpha <- 1 + size <- NULL + } + + teal::validate_has_data(anl[, c(x_name, y_name), drop = FALSE], 3, complete = TRUE, allow_inf = FALSE) + + + cl <- bivariate_plot_call( + data_name = "anl", + x = x_name, + y = y_name, + x_class = ifelse(length(x_name), class(anl[[x_name]]), "NULL"), + y_class = ifelse(length(y_name), class(anl[[y_name]]), "NULL"), + x_label = varname_w_label(x_name, anl), + y_label = varname_w_label(y_name, anl), + freq = !use_density, + theme = ggtheme, + rotate_xaxis_labels = rotate_xaxis_labels, + swap_axes = swap_axes, + alpha = alpha, + size = size, + ggplot2_args = ggplot2_args + ) + + if (!is.null(row_facet_name) || !is.null(col_facet_name)) { + facet_cl <- facet_ggplot_call(row_facet_name, col_facet_name, free_x_scales, free_y_scales) + + if (!is.null(facet_cl)) { + cl <- call("+", cl, facet_cl) + } + } + + if (input$add_lines) { + cl <- call("+", cl, quote(geom_line(size = 1))) + } + + coloring_cl <- NULL + if (color_settings) { + if (input$coloring) { + coloring_cl <- coloring_ggplot_call( + colour = color_name, + fill = fill_name, + size = size_name, + is_point = any(grepl("geom_point", cl %>% deparse())) + ) + legend_lbls <- substitute( + expr = labs(color = color_name, fill = fill_name, size = size_name), + env = list( + color_name = varname_w_label(color_name, ANL), + fill_name = varname_w_label(fill_name, ANL), + size_name = varname_w_label(size_name, ANL) + ) + ) + } + if (!is.null(coloring_cl)) { + cl <- call("+", call("+", cl, coloring_cl), legend_lbls) + } + } + + obj <- merged$data() + teal.reporter::teal_card(obj) <- c(teal.reporter::teal_card(obj), "## Plot") + teal.code::eval_code(obj, substitute(expr = plot <- cl, env = list(cl = cl))) + }) + + decorated_output_q_facets <- srv_decorate_teal_data( + "decorator", + data = output_q, + decorators = select_decorators(decorators, "plot"), + expr = reactive({ + anl <- merged$data()[["anl"]] + row_facet_name <- merged$variables()$row_facet + col_facet_name <- merged$variables()$col_facet + + # Add labels to facets + nulled_row_facet_name <- varname_w_label(row_facet_name, anl) + nulled_col_facet_name <- varname_w_label(col_facet_name, anl) + facetting <- (isTRUE(input$facetting) && (!is.null(row_facet_name) || !is.null(col_facet_name))) + without_facet <- (is.null(nulled_row_facet_name) && is.null(nulled_col_facet_name)) || !facetting + + print_call <- if (without_facet) { + quote(plot) + } else { + substitute( + expr = { + teal.modules.general::add_facet_labels( + plot, + xfacet_label = nulled_col_facet_name, + yfacet_label = nulled_row_facet_name + ) + }, + env = list(nulled_col_facet_name = nulled_col_facet_name, nulled_row_facet_name = nulled_row_facet_name) + ) + } + print_call + }) + ) + + plot_r <- reactive(req(decorated_output_q_facets())[["plot"]]) + + pws <- teal.widgets::plot_with_settings_srv( + id = "myplot", + plot_r = plot_r, + height = plot_height, + width = plot_width + ) + + set_chunk_dims(pws, decorated_output_q_facets) + }) +} diff --git a/R/tm_g_distribution.R b/R/tm_g_distribution.R index 5fda712e6..de88ffc91 100644 --- a/R/tm_g_distribution.R +++ b/R/tm_g_distribution.R @@ -8,11 +8,11 @@ #' @inheritParams teal.widgets::standard_layout #' @inheritParams shared_params #' -#' @param dist_var (`data_extract_spec` or `list` of multiple `data_extract_spec`) +#' @param dist_var (`picks` or `list` of multiple `picks`) #' Variable(s) for which the distribution will be analyzed. -#' @param strata_var (`data_extract_spec` or `list` of multiple `data_extract_spec`) +#' @param strata_var (`picks` or `list` of multiple `picks`) #' Categorical variable used to split the distribution analysis. -#' @param group_var (`data_extract_spec` or `list` of multiple `data_extract_spec`) +#' @param group_var (`picks` or `list` of multiple `picks`) #' Variable used for faceting plot into multiple panels. #' @param freq (`logical`) optional, whether to display frequency (`TRUE`) or density (`FALSE`). #' Defaults to density (`FALSE`). @@ -71,9 +71,10 @@ #' data = data, #' modules = list( #' tm_g_distribution( -#' dist_var = data_extract_spec( -#' dataname = "iris", -#' select = select_spec(variable_choices("iris"), "Petal.Length") +#' dist_var = teal.transform::picks( +#' datasets("iris"), +#' teal.transform::variables(is.numeric), +#' teal.transform::values() #' ) #' ) #' ) @@ -96,39 +97,22 @@ #' }) #' join_keys(data) <- default_cdisc_join_keys[names(data)] #' -#' #' app <- init( #' data = data, #' modules = modules( #' tm_g_distribution( -#' dist_var = data_extract_spec( -#' dataname = "ADSL", -#' select = select_spec( -#' choices = variable_choices("ADSL", c("AGE", "BMRKR1")), -#' selected = "BMRKR1", -#' multiple = FALSE, -#' fixed = FALSE -#' ) +#' dist_var = teal.transform::picks( +#' datasets("ADSL"), +#' teal.transform::variables(c("BMRKR1", "AGE")), +#' values(multiple = FALSE) #' ), -#' strata_var = data_extract_spec( -#' dataname = "ADSL", -#' filter = filter_spec( -#' vars = choices_selected( -#' variable_choices("ADSL", c("ARM", "COUNTRY", "SEX")), -#' selected = NULL -#' ), -#' multiple = TRUE -#' ) +#' strata_var = teal.transform::picks( +#' datasets("ADSL"), +#' teal.transform::variables(c("ARM", "COUNTRY", "SEX"), selected = NULL) #' ), -#' group_var = data_extract_spec( -#' dataname = "ADSL", -#' filter = filter_spec( -#' vars = choices_selected( -#' variable_choices("ADSL", c("ARM", "COUNTRY", "SEX")), -#' selected = "ARM" -#' ), -#' multiple = TRUE -#' ) +#' group_var = teal.transform::picks( +#' datasets("ADSL"), +#' teal.transform::variables(c("ARM", "COUNTRY", "SEX"), selected = NULL) #' ) #' ) #' ) @@ -140,7 +124,11 @@ #' @export #' tm_g_distribution <- function(label = "Distribution Module", - dist_var, + dist_var = teal.transform::picks( + teal.transform::datasets(), + teal.transform::variables(is.numeric), + teal.transform::values() + ), strata_var = NULL, group_var = NULL, freq = FALSE, @@ -153,6 +141,24 @@ tm_g_distribution <- function(label = "Distribution Module", post_output = NULL, transformators = list(), decorators = list()) { + UseMethod("tm_g_distribution", dist_var) +} + +#' @export +tm_g_distribution.default <- function(label = "Distribution Module", + dist_var, + strata_var = NULL, + group_var = NULL, + freq = FALSE, + ggtheme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void"), + ggplot2_args = teal.widgets::ggplot2_args(), + bins = c(30L, 1L, 100L), + plot_height = c(600, 200, 2000), + plot_width = NULL, + pre_output = NULL, + post_output = NULL, + transformators = list(), + decorators = list()) { message("Initializing tm_g_distribution") # Normalize the parameters @@ -209,7 +215,9 @@ tm_g_distribution <- function(label = "Distribution Module", ans <- module( label = label, - server = srv_distribution, + ui = ui_g_distribution.default, + server = srv_g_distribution.default, + ui_args = args, server_args = c( data_extract_list, list( @@ -219,8 +227,6 @@ tm_g_distribution <- function(label = "Distribution Module", decorators = decorators ) ), - ui = ui_distribution, - ui_args = args, transformators = transformators, datanames = teal.transform::get_extract_datanames(data_extract_list) ) @@ -229,7 +235,7 @@ tm_g_distribution <- function(label = "Distribution Module", } # UI function for the distribution module -ui_distribution <- function(id, ...) { +ui_g_distribution.default <- function(id, ...) { args <- list(...) ns <- NS(id) is_single_dataset_value <- teal.transform::is_single_dataset(args$dist_var, args$strata_var, args$group_var) @@ -385,15 +391,15 @@ ui_distribution <- function(id, ...) { } # Server function for the distribution module -srv_distribution <- function(id, - data, - dist_var, - strata_var, - group_var, - plot_height, - plot_width, - ggplot2_args, - decorators) { +srv_g_distribution.default <- function(id, + data, + dist_var, + strata_var, + group_var, + plot_height, + plot_width, + ggplot2_args, + decorators) { checkmate::assert_class(data, "reactive") checkmate::assert_class(isolate(data()), "teal_data") moduleServer(id, function(input, output, session) { @@ -570,7 +576,7 @@ srv_distribution <- function(id, } ANL <- merged$anl_q_r()[["ANL"]] - round(get_dist_params(as.numeric(stats::na.omit(ANL[[merge_vars()$dist_var]])), input$t_dist), 2) + round(get_dist_params(as.numeric(stats::na.omit(ANL[[variables()$dist_var]])), input$t_dist), 2) } else { c("param1" = NA_real_, "param2" = NA_real_) } @@ -640,13 +646,13 @@ srv_distribution <- function(id, ) ANL <- obj[["ANL"]] - dist_var <- merge_vars()$dist_var - s_var <- merge_vars()$s_var - g_var <- merge_vars()$g_var + dist_var <- variables()$dist_var + s_var <- variables()$s_var + g_var <- variables()$g_var - dist_var_name <- merge_vars()$dist_var_name - s_var_name <- merge_vars()$s_var_name - g_var_name <- merge_vars()$g_var_name + dist_var_name <- variables()$dist_var_name + s_var_name <- variables()$s_var_name + g_var_name <- variables()$g_var_name roundn <- input$roundn dist_param1 <- input$dist_param1 @@ -778,12 +784,12 @@ srv_distribution <- function(id, is.null(input$ggtheme) }, valueExpr = { - dist_var <- merge_vars()$dist_var - s_var <- merge_vars()$s_var - g_var <- merge_vars()$g_var - dist_var_name <- merge_vars()$dist_var_name - s_var_name <- merge_vars()$s_var_name - g_var_name <- merge_vars()$g_var_name + dist_var <- variables()$dist_var + s_var <- variables()$s_var + g_var <- variables()$g_var + dist_var_name <- variables()$dist_var_name + s_var_name <- variables()$s_var_name + g_var_name <- variables()$g_var_name t_dist <- input$t_dist dist_param1 <- input$dist_param1 dist_param2 <- input$dist_param2 @@ -974,12 +980,12 @@ srv_distribution <- function(id, input$tabs }, valueExpr = { - dist_var <- merge_vars()$dist_var - s_var <- merge_vars()$s_var - g_var <- merge_vars()$g_var - dist_var_name <- merge_vars()$dist_var_name - s_var_name <- merge_vars()$s_var_name - g_var_name <- merge_vars()$g_var_name + dist_var <- variables()$dist_var + s_var <- variables()$s_var + g_var <- variables()$g_var + dist_var_name <- variables()$dist_var_name + s_var_name <- variables()$s_var_name + g_var_name <- variables()$g_var_name dist_param1 <- input$dist_param1 dist_param2 <- input$dist_param2 @@ -1108,13 +1114,13 @@ srv_distribution <- function(id, # Create a private stack for this function only. ANL <- common_q()[["ANL"]] - dist_var <- merge_vars()$dist_var - s_var <- merge_vars()$s_var - g_var <- merge_vars()$g_var + dist_var <- variables()$dist_var + s_var <- variables()$s_var + g_var <- variables()$g_var - dist_var_name <- merge_vars()$dist_var_name - s_var_name <- merge_vars()$s_var_name - g_var_name <- merge_vars()$g_var_name + dist_var_name <- variables()$dist_var_name + s_var_name <- variables()$s_var_name + g_var_name <- variables()$g_var_name dist_param1 <- input$dist_param1 dist_param2 <- input$dist_param2 diff --git a/R/tm_g_distribution_picks.R b/R/tm_g_distribution_picks.R new file mode 100644 index 000000000..242019bef --- /dev/null +++ b/R/tm_g_distribution_picks.R @@ -0,0 +1,1169 @@ +#' @export +tm_g_distribution.picks <- function(label = "Distribution Module", + dist_var = teal.transform::picks( + teal.transform::datasets(), + teal.transform::variables(is.numeric), + teal.transform::values() + ), + strata_var = teal.transform::picks( + teal.transform::datasets(), + teal.transform::variables( + choices = teal.transform::is_categorical(min.len = 2, max.len = 10), + selected = NULL + ), + teal.transform::values() + ), + group_var = teal.transform::picks( + teal.transform::datasets(), + teal.transform::variables( + choices = teal.transform::is_categorical(min.len = 2, max.len = 10), + selected = NULL + ), + teal.transform::values() + ), + freq = FALSE, + ggtheme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void"), + ggplot2_args = teal.widgets::ggplot2_args(), + bins = c(30L, 1L, 100L), + plot_height = c(600, 200, 2000), + plot_width = NULL, + pre_output = NULL, + post_output = NULL, + transformators = list(), + decorators = list()) { + message("Initializing tm_g_distribution") + + # Start of assertions + checkmate::assert_string(label) + + checkmate::assert_class(dist_var, "picks") + if (isTRUE(attr(dist_var$variables, "multiple"))) { + warning("dist_var accepts only a single variable selection. Forcing `teal.transform::variables(multiple) to FALSE`") + attr(dist_var$variables, "multiple") <- FALSE + } + checkmate::assert_class(strata_var, "picks", null.ok = TRUE) + checkmate::assert_class(group_var, "picks", null.ok = TRUE) + + checkmate::assert_flag(freq) + ggtheme <- match.arg(ggtheme) + + plot_choices <- c("Histogram", "QQplot") + + if (inherits(ggplot2_args, "ggplot2_args")) ggplot2_args <- list(default = ggplot2_args) + checkmate::assert_list(ggplot2_args, types = "ggplot2_args") + checkmate::assert_subset(names(ggplot2_args), c("default", plot_choices)) + + if (length(bins) == 1) { + checkmate::assert_numeric(bins, any.missing = FALSE, lower = 1) + } else { + checkmate::assert_numeric(bins, len = 3, any.missing = FALSE, lower = 1) + checkmate::assert_numeric(bins[1], lower = bins[2], upper = bins[3], .var.name = "bins") + } + + checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE) + checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height") + checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE) + checkmate::assert_numeric( + plot_width[1], + lower = plot_width[2], upper = plot_width[3], null.ok = TRUE, .var.name = "plot_width" + ) + + 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) + + assert_decorators(decorators, names = c("histogram_plot", "qq_plot")) + + # End of assertions + + # Make UI args + args <- as.list(environment()) + + ans <- module( + label = label, + server = srv_g_distribution.picks, + ui = ui_g_distribution.picks, + ui_args = args[names(args) %in% names(formals(ui_g_distribution.picks))], + server_args = args[names(args) %in% names(formals(srv_g_distribution.picks))], , + transformators = transformators, + datanames = .picks_datanames(list(dist_var, strata_var, group_var)) + ) + attr(ans, "teal_bookmarkable") <- TRUE + ans +} + + +# UI function for the distribution module +ui_g_distribution.picks <- function(id, + strata_var, + dist_var, + group_var, + freq, + bins, + ggtheme, + pre_output, + post_output, + decorators) { + ns <- NS(id) + + hist_elem <- .ui_hist( + ns("histogram_plot"), + bins = bins, + freq = freq, + decorators = select_decorators(decorators, "histogram_plot") + ) + qq_elem <- .ui_qq(ns("qq_plot"), decorators = select_decorators(decorators, "qq_plot")) + summary_table_elem <- .ui_summary_table(ns("summary_table"), select_decorators(decorators, "Statistics Table")) + test_table_elem <- .ui_test_table(ns("test_table"), + is_stratified = !is.null(strata_var), + decorators = select_decorators(decorators, "Test Table") + ) + + teal.widgets::standard_layout( + output = teal.widgets::white_small_well( + tabsetPanel( + id = ns("tabs"), + tabPanel("Histogram", hist_elem$output), + tabPanel("QQplot", qq_elem$output) + ), + bslib::card(summary_table_elem$output), + bslib::card(test_table_elem$output) + ), + encoding = tags$div( + tags$label("Encodings", class = "text-primary"), + tags$div( + tags$strong("Variable"), + teal.transform::picks_ui(id = ns("dist_var"), picks = dist_var) + ), + if (!is.null(group_var)) { + tagList( + tags$div( + tags$strong("Group by:"), + teal.transform::picks_ui(id = ns("group_var"), picks = group_var) + ), + uiOutput(ns("scales_types_ui")) + ) + }, + if (!is.null(strata_var)) { + tagList( + tags$div( + tags$strong("Stratify by:"), + teal.transform::picks_ui(id = ns("strata_var"), picks = strata_var) + ) + ) + }, + bslib::accordion( + conditionalPanel( + condition = paste0("input['", ns("tabs"), "'] == 'Histogram'"), + bslib::accordion_panel(title = "Histogram", hist_elem$encodings, collapsed = FALSE) + ), + conditionalPanel( + condition = paste0("input['", ns("tabs"), "'] == 'QQplot'"), + bslib::accordion_panel(title = "QQ Plot", qq_elem$encodings, collapsed = FALSE) + ), + bslib::accordion_panel( # todo: hide ONLY when frequency is selected for histogram + "Theoretical Distribution", + teal.widgets::optionalSelectInput( + ns("t_dist"), + tags$div( + tagList( + "Distribution:", + bslib::tooltip( + icon("circle-info"), + tags$span("Default parameters are optimized with MASS::fitdistr function.") + ) + ) + ), + choices = c("normal", "lognormal", "gamma", "unif"), + selected = NULL, + multiple = FALSE + ), + conditionalPanel( + condition = paste0("input['", ns("t_dist"), "'] != null && input['", ns("t_dist"), "'] != ''"), + numericInput(ns("dist_param1"), label = "param1", value = NULL), + numericInput(ns("dist_param2"), label = "param2", value = NULL), + tags$span(actionButton(ns("params_reset"), "Default params")) + ), + collapsed = FALSE + ), + bslib::accordion_panel(title = "Tests", test_table_elem$encodings), + bslib::accordion_panel(title = "Statistics Table", summary_table_elem$encodings), + bslib::accordion_panel( + title = "Plot settings", + selectInput( + inputId = ns("ggtheme"), + label = "Theme (by ggplot):", + choices = ggplot_themes, + selected = ggtheme, + multiple = FALSE + ) + ) + ) + ), + pre_output = pre_output, + post_output = post_output + ) +} + +# Server function for the distribution module +srv_g_distribution.picks <- function(id, + data, + dist_var, + strata_var, + group_var, + plot_height, + plot_width, + ggplot2_args, + decorators) { + checkmate::assert_class(data, "reactive") + checkmate::assert_class(isolate(data()), "teal_data") + moduleServer(id, function(input, output, session) { + teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.general") + + setBookmarkExclude("params_reset") + ns <- session$ns + + + selectors <- teal.transform::picks_srv( + picks = list(dist_var = dist_var, strata_var = strata_var, group_var = group_var), + data = data + ) + + qenv <- reactive({ + validate_input( + inputId = "dist_var-variables-selected", + condition = length(selectors$dist_var()$variables$selected) == 1, + message = "Distribution variable must be selected." + ) + + obj <- req(data()) + teal.reporter::teal_card(obj) <- c( + teal.reporter::teal_card("# Distribution Plot"), + teal.reporter::teal_card(obj), + teal.reporter::teal_card("## Module's code") + ) + teal.code::eval_code(obj, 'library("ggplot2");library("dplyr")') + }) + + merged <- teal.transform::merge_srv("merge", data = qenv, selectors = selectors, output_name = "anl") + + validate_merged <- reactive({ + obj <- merged$data() + anl <- obj[["anl"]] + + validate_input( + inputId = "dist_var-variables-selected", + condition = is.numeric(anl[[merged$variables()$dist_var]]), + message = "Distribution variable must be numeric." + ) + + if (length(merged$variables()$group_var) > 0) { + validate_input( + "group_var-variables-selected", + condition = inherits(anl[[merged$variables()$group_var]], c("integer", "factor", "character")), + message = "Group by variable must be `factor`, `character`, or `integer`" + ) + obj <- within(obj, library("forcats")) + obj <- within( + obj, + expr = anl[[group_var]] <- forcats::fct_na_value_to_level(as.factor(anl[[group_var]]), "NA"), + group_var = merged$variables()$group_var + ) + } + + if (length(merged$variables()$strata_var) > 0) { + validate_input( + "strata_var-variables-selected", + condition = inherits(anl[[merged$variables()$strata_var]], c("integer", "factor", "character")), + message = "Stratify by variable must be `factor`, `character`, or `integer`" + ) + + obj <- within(obj, library("forcats")) + obj <- within( + obj, + expr = anl[[strata_var]] <- forcats::fct_na_value_to_level(as.factor(anl[[strata_var]]), "NA"), + strata_var = merged$variables()$strata_var + ) + } + + teal::validate_has_data(anl, 1, complete = TRUE) + + obj + }) + + output$scales_types_ui <- renderUI({ + validate_merged() + if (length(merged$variables()$group_var) > 0) { + shinyWidgets::prettyRadioButtons( + ns("scales_type"), + label = "Scales:", + choices = c("Fixed", "Free"), + selected = "Fixed", + bigger = FALSE, + inline = TRUE + ) + } + }) + + observeEvent( + eventExpr = { + input$t_dist + input$params_reset + merged$variables()$dist_var + }, + handlerExpr = { + params <- if (length(input$t_dist)) { + validate_merged() + req(merged$data()) + anl <- merged$data()[["anl"]] + round( + .calc_dist_params( + x = as.numeric(stats::na.omit(anl[[merged$variables()$dist_var]])), + dist = input$t_dist + ), + 2 + ) + } else { + c("param1" = NA_real_, "param2" = NA_real_) + } + + updateNumericInput( + inputId = "dist_param1", + label = names(params)[1], + value = restoreInput(ns("dist_param1"), params[[1]]) + ) + updateNumericInput( + inputId = "dist_param2", + label = names(params)[2], + value = restoreInput(ns("dist_param1"), params[[2]]) + ) + }, + ignoreInit = TRUE + ) + + observeEvent(input$params_reset, { + updateActionButton(inputId = "params_reset", label = "Reset params") + }) + + validate_dist <- reactive({ + # Validate dist_param1 + if (!is.null(input$t_dist) && input$t_dist == "normal") { + validate_input( + "dist_param1", + condition = !is.null(input$dist_param1) && !is.na(input$dist_param1), + message = "mean is required" + ) + validate_input( + "dist_param2", + condition = !is.null(input$dist_param2) && !is.na(input$dist_param2), + message = "sd is required" + ) + validate_input( + "dist_param2", + condition = is.null(input$dist_param2) || is.na(input$dist_param2) || input$dist_param2 >= 0, + message = "sd must be non-negative" + ) + } + if (!is.null(input$t_dist) && input$t_dist == "lognormal") { + validate_input( + "dist_param1", + condition = !is.null(input$dist_param1) && !is.na(input$dist_param1), + message = "meanlog is required" + ) + validate_input( + "dist_param2", + condition = !is.null(input$dist_param2) && !is.na(input$dist_param2), + message = "sdlog is required" + ) + validate_input( + "dist_param2", + condition = is.null(input$dist_param2) || is.na(input$dist_param2) || input$dist_param2 >= 0, + message = "sdlog must be non-negative" + ) + } + if (!is.null(input$t_dist) && input$t_dist == "gamma") { + validate_input( + "dist_param1", + condition = !is.null(input$dist_param1) && !is.na(input$dist_param1), + message = "shape is required" + ) + validate_input( + "dist_param1", + condition = is.null(input$dist_param1) || is.na(input$dist_param1) || input$dist_param1 > 0, + message = "shape must be positive" + ) + validate_input( + "dist_param2", + condition = !is.null(input$dist_param2) && !is.na(input$dist_param2), + message = "rate is required" + ) + validate_input( + "dist_param2", + condition = is.null(input$dist_param2) || is.na(input$dist_param2) || input$dist_param2 > 0, + message = "rate must be positive" + ) + } + }) + + # outputs ---- + hist_output <- .srv_hist( + "histogram_plot", + data = reactive({ + validate_merged() + validate_dist() + merged$data() + }), + variables = merged$variables, + t_dist = reactive(input$t_dist), + dist_param1 = reactive(input$dist_param1), + dist_param2 = reactive(input$dist_param2), + scales_type = reactive(input$scales_type), + ggtheme = reactive(input$ggtheme), + plot_height = plot_height, + plot_width = plot_width, + ggplot2_args = teal.widgets::resolve_ggplot2_args( + user_plot = ggplot2_args[["Histogram"]], + user_default = ggplot2_args$default, + module_plot = teal.widgets::ggplot2_args(labs = list(x = "theoretical", y = "sample")) + ), + decorators = select_decorators(decorators, "histogram_plot") + ) + + qq_output <- .srv_qq( + "qq_plot", + data = reactive({ + validate_merged() + validate_input( + "t_dist", + condition = !is.null(input$t_dist), + message = "QQ Plot requires Theoretical Distribution to be selected" + ) + validate_dist() + merged$data() + }), + variables = merged$variables, + t_dist = reactive(input$t_dist), + dist_param1 = reactive(input$dist_param1), + dist_param2 = reactive(input$dist_param2), + scales_type = reactive(input$scales_type), + ggtheme = reactive(input$ggtheme), + plot_height = plot_height, + plot_width = plot_width, + ggplot2_args = teal.widgets::resolve_ggplot2_args( + user_plot = ggplot2_args[["QQplot"]], + user_default = ggplot2_args$default, + module_plot = teal.widgets::ggplot2_args(labs = list(x = "theoretical", y = "sample")) + ), + decorators = select_decorators(decorators, "qq_plot") + ) + + summary_table_output <- .srv_summary_table( + "summary_table", + data = reactive({ + validate_merged() + merged$data() + }), + variables = merged$variables, + decorators = select_decorators(decorators, "Statistics Table") + ) + + test_q <- reactive({ + validate_merged() + obj <- merged$data() + anl <- obj[["anl"]] + s_var <- merged$variables()$strata_var + g_var <- merged$variables()$group_var + dist_test <- input$`test_table-dist_test` + + if (identical(dist_test, "Fligner-Killeen")) { + validate_input( + "strata_var-variables-selected", + condition = !isTRUE(s_var == g_var), + message = "Please select different variables for strata and group." + ) + } + + if (!is.null(dist_test) && dist_test %in% c( + "Fligner-Killeen", + "t-test (two-samples, not paired)", + "F-test", + "Kolmogorov-Smirnov (two-samples)", + "one-way ANOVA" + )) { + if (length(g_var) == 0 && length(s_var) > 0) { + validate_input( + "strata_var-variables-selected", + condition = length(unique(anl[[s_var]])) == 2, + message = "Please select stratify variable with 2 levels." + ) + } else if (length(g_var) > 0 && length(s_var) > 0) { + validate_input( + "strata_var-variables-selected", + condition = all(stats::na.omit(as.vector( + tapply(anl[[s_var]], list(anl[[g_var]]), function(x) length(unique(x))) == 2 + ))), + message = "Please select stratify variable with 2 levels, per each group." + ) + } + } + validate_dist() + obj + }) + test_output <- .srv_test_table( + "test_table", + data = test_q, + variables = merged$variables, + t_dist = reactive(input$t_dist), + decorators = select_decorators(decorators, "Test Table") + ) + + # decorated_output_q <- reactive({ + # req(input$tabs, hist_output(), qq_output(), summary_table_output(), output_test_q()) + # test_q_out <- output_test_q() + + # # return everything except switch + # out_q <- switch(input$tabs, + # Histogram = hist_output(), + # QQplot = qq_output() + # ) + # out_q + # }) + NULL + }) +} + + +.ui_hist <- function(id, bins, freq, decorators) { + ns <- NS(id) + tagList( + encodings = tagList( + teal.widgets::optionalSliderInputValMinMax(ns("bins"), "Bins", bins, ticks = FALSE, step = 1), + shinyWidgets::prettyRadioButtons( + ns("statistic"), + label = "Plot Type:", + choices = c("Density", "Frequency"), + selected = if (!freq) "Density" else "Frequency", + bigger = FALSE, + inline = TRUE + ), + checkboxInput(ns("add_density"), label = "Overlay Density", value = TRUE), + ui_decorate_teal_data(ns("decorators"), decorators = decorators) + ), + output = teal.widgets::plot_with_settings_ui(id = ns("plot")) + ) +} + +.srv_hist <- function(id, + data, + variables, + ggtheme, + scales_type, + t_dist, + dist_param1, + dist_param2, + plot_height, + plot_width, + ggplot2_args, + decorators) { + moduleServer(id, function(input, output, session) { + output_q <- eventReactive( + list( + data(), + input$bins, + input$statistic, + input$add_density, + dist_param1(), # don't observe t_dist as dist_param1 is changed by t_dist + dist_param2(), # don't observe t_dist as dist_param2 is changed by t_dist + scales_type() + ), + { + obj <- req(data()) + bins <- req(input$bins) + statistic <- if (req(input$statistic) == "Density") "density" else "count" + logger::log_debug(".srv_hist@1 Recalculating Histogram") + add_density <- input$add_density + d_var <- variables()$dist_var + s_var <- variables()$strata_var + g_var <- variables()$group_var + ndensity <- 512 + + teal.reporter::teal_card(obj) <- c(teal.reporter::teal_card(obj), "## Histogram Plot") + + plot_call <- substitute( + expr = ggplot2::ggplot(anl, mapping = ggplot2::aes(d_var_name)) + + ggplot2::geom_histogram( + ggplot2::aes(y = ggplot2::after_stat(stat)), + position = "identity", bins = bins, alpha = 0.3 + ), + env = list(stat = as.name(statistic), bins = bins, d_var_name = as.name(d_var)) + ) + + if (length(s_var)) { + plot_call[[2]]$mapping$col <- as.name(s_var) + plot_call[[2]]$mapping$fill <- as.name(s_var) + } + + if (length(g_var)) { + req(scales_type()) + plot_call <- call( + "+", + plot_call, + substitute( + ggplot2::facet_wrap(~g_var_name, ncol = 1, scales = scales), + list(g_var_name = as.name(g_var), scales = tolower(scales_type())) + ) + ) + } + + if (add_density) { + plot_call <- substitute( + expr = plot_call + + ggplot2::stat_density( + ggplot2::aes(y = ggplot2::after_stat(const * stat)), + geom = "line", + position = "identity", + alpha = 0.5, + size = 2, + n = ndensity + ), + env = list( + plot_call = plot_call, + const = if (statistic == "density") { + 1 + } else { + diff(range(obj[["anl"]][[d_var]], na.rm = TRUE)) / bins + }, + stat = as.name(statistic), + ndensity = ndensity + ) + ) + } + + if (length(s_var) == 0 && length(g_var) == 0 && statistic == "density" && length(t_dist()) != 0) { + req(dist_param1(), dist_param2()) + obj <- teal.code::eval_code(obj, 'library("ggpp")') # nolint quotes + param_list <- .dist_param_list(t_dist(), dist_param1(), dist_param2()) + map_dist <- c(normal = "dnorm", lognormal = "dlnorm", gamma = "dgamma", unif = "dunif") + + plot_call <- substitute( + expr = plot_call + + ggpp::geom_table_npc( + data = data.frame(x = .7, y = 1, tb = I(list(nested_df))), + ggplot2::aes(npcx = x, npcy = y, label = tb), + hjust = 0, vjust = 1, size = 4 + ) + + stat_function( + data = data.frame(x = range(anl[[d_var]]), color = density_dist), + ggplot2::aes(x, color = color), + fun = density_dist_name, + n = ndensity, + size = 2, + args = param_list + ) + + ggplot2::scale_color_manual(values = stats::setNames("blue", density_dist), aesthetics = "color"), + env = list( + plot_call = plot_call, + d_var = d_var, + density_dist = unname(map_dist[t_dist()]), + density_dist_name = as.name(unname(map_dist[t_dist()])), + ndensity = ndensity, + nested_df = as.call( + c( + as.name("data.frame"), + param_list, + list(distribution = t_dist()) + ) + ), + param_list = param_list + ) + ) + } + + parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(ggplot2_args, ggtheme = ggtheme()) + + teal.code::eval_code( + obj, + substitute( + expr = histogram_plot <- plot_call, + env = list(plot_call = Reduce(function(x, y) call("+", x, y), c(plot_call, parsed_ggplot2_args))) + ) + ) + } + ) + + decorated_output_q <- srv_decorate_teal_data( + "decorators", + data = output_q, + decorators = decorators, + expr = quote(histogram_plot) + ) + + output_r <- reactive(req(decorated_output_q())[["histogram_plot"]]) + + pws <- teal.widgets::plot_with_settings_srv( + id = "plot", + plot_r = output_r, + height = plot_height, + width = plot_width, + brushing = FALSE + ) + + set_chunk_dims(pws, decorated_output_q) + }) +} + +.ui_qq <- function(id, decorators) { + ns <- NS(id) + tagList( + encodings = tagList( + checkboxInput(ns("qq_line"), label = "Add diagonal line(s)", TRUE), + ui_decorate_teal_data(ns("decorators"), decorators = decorators) + ), + output = teal.widgets::plot_with_settings_ui(id = ns("plot")) + ) +} + +.srv_qq <- function(id, + data, + variables, + t_dist, + dist_param1, + dist_param2, + scales_type, + ggtheme, + plot_height, + plot_width, + ggplot2_args, + decorators) { + moduleServer(id, function(input, output, session) { + output_q <- eventReactive( + { + data() + t_dist() + dist_param1() + dist_param2() + input$qq_line + ggtheme() + }, + { + req(data(), variables(), ggtheme(), t_dist()) + logger::log_debug(".srv_qq@1 Recalculating QQ Plot...") + obj <- data() + d_var <- variables()$dist_var + s_var <- variables()$strata_var + g_var <- variables()$group_var + + teal.reporter::teal_card(obj) <- c(teal.reporter::teal_card(obj), "## QQ Plot") + + plot_call <- substitute( + expr = ggplot2::ggplot(dataname, mapping = ggplot2::aes(sample = d_var_name)), + env = list( + dataname = if (length(g_var)) { + bquote(anl[anl[[.(g_var)]] != "NA", ]) + } else { + quote(anl) + }, + d_var_name = as.name(d_var) + ) + ) + if (length(s_var)) plot_call$mapping$color <- as.name(s_var) + if (length(g_var)) { + plot_call <- substitute( + plot_call + ggplot2::facet_wrap(~g_var_name, ncol = 1, scales = scales_raw), + list( + plot_call = plot_call, + g_var_name = as.name(g_var), + scales_raw = tolower(scales_type()) + ) + ) + } + + map_quantile_fun <- c(normal = "qnorm", lognormal = "qlnorm", gamma = "qgamma", unif = "qunif") + + plot_call <- substitute( + expr = plot_call + ggplot2::stat_qq(distribution = quantile_fun, dparams = dparams), + env = list( + plot_call = plot_call, + quantile_fun = as.name(unname(map_quantile_fun[t_dist()])), + dparams = list(dist_param1(), dist_param2()) + ) + ) + + if (isTRUE(input$qq_line)) { + plot_call <- substitute( + expr = plot_call + ggplot2::stat_qq_line(distribution = quantile_fun, dparams = dparams), + env = list( + plot_call = plot_call, + quantile_fun = as.name(unname(map_quantile_fun[t_dist()])), + dparams = list(dist_param1(), dist_param2()) + ) + ) + } + + if (length(s_var) == 0 && length(g_var) == 0) { + req(dist_param1(), dist_param2()) + obj <- teal.code::eval_code(obj, 'library("ggpp")') # nolint quotes + plot_call <- substitute( + expr = plot_call + + ggpp::geom_table_npc( + data = data.frame(x = .7, y = 1, tb = I(list(nested_df))), + ggplot2::aes(npcx = x, npcy = y, label = tb), + hjust = 0, vjust = 1, size = 4 + ), + env = list( + plot_call = plot_call, + nested_df = as.call( + c( + as.name("data.frame"), + .dist_param_list(t_dist(), dist_param1(), dist_param2()), + list(distribution = t_dist()) + ) + ) + ) + ) + } + + parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(ggplot2_args, ggtheme = ggtheme()) + teal.code::eval_code( + obj, + substitute( + expr = qq_plot <- plot_call, + env = list(plot_call = Reduce(function(x, y) call("+", x, y), c(plot_call, parsed_ggplot2_args))) + ) + ) + } + ) + + decorated_output_q <- srv_decorate_teal_data( + "decorators", + decorators = decorators, + data = output_q, + expr = quote(qq_plot) + ) + + output_r <- reactive(req(decorated_output_q())[["qq_plot"]]) + + + pws <- teal.widgets::plot_with_settings_srv( + id = "plot", + plot_r = output_r, + height = plot_height, + width = plot_width, + brushing = FALSE + ) + + # set_chunk_dims(pws, decorated_output_q) + }) +} + +.ui_summary_table <- function(id, decorators) { + ns <- NS(id) + tagList( + encodings = tagList( + sliderInput(ns("roundn"), "Round to n digits", min = 0, max = 10, value = 2), + ui_decorate_teal_data(ns("decorators"), decorators = decorators) + ), + output = tags$div( + tags$h3("Statistics Table"), + DT::dataTableOutput(ns("summary_table")) + ) + ) +} + +.srv_summary_table <- function(id, data, variables, decorators) { + moduleServer(id, function(input, output, session) { + output_q <- reactive({ + obj <- req(data()) + roundn <- input$roundn + teal.reporter::teal_card(obj) <- c(teal.reporter::teal_card(obj), "## Statistics table") + + obj <- if (length(variables()$strata_var) == 0 && length(variables()$group_var) == 0) { + within( + obj, + expr = { + summary_table_data <- anl %>% + dplyr::summarise( + min = round(min(d_var_name, na.rm = TRUE), roundn), + median = round(stats::median(d_var_name, na.rm = TRUE), roundn), + mean = round(mean(d_var_name, na.rm = TRUE), roundn), + max = round(max(d_var_name, na.rm = TRUE), roundn), + sd = round(stats::sd(d_var_name, na.rm = TRUE), roundn), + count = dplyr::n() + ) + }, + d_var_name = as.name(variables()$dist_var), + roundn = roundn + ) + } else { + within( + obj, + expr = { + summary_table_data <- anl %>% + dplyr::group_by_at(dplyr::vars(dplyr::any_of(strata_vars))) %>% + dplyr::summarise( + min = round(min(d_var_name, na.rm = TRUE), roundn), + median = round(stats::median(d_var_name, na.rm = TRUE), roundn), + mean = round(mean(d_var_name, na.rm = TRUE), roundn), + max = round(max(d_var_name, na.rm = TRUE), roundn), + sd = round(stats::sd(d_var_name, na.rm = TRUE), roundn), + count = dplyr::n() + ) + }, + d_var_name = as.name(variables()$dist_var), + strata_vars = c(variables()$group_var, variables()$strata_var), + roundn = roundn + ) + } + + within(obj, summary_table <- rtables::df_to_tt(summary_table_data)) + # if (iv_r()$is_valid()) { + + # } else { + # within( + # q_common, + # summary_table <- rtables::rtable(header = rtables::rheader(colnames(summary_table_data))) + # ) + # } + }) + + decorated_output_q <- srv_decorate_teal_data( + "decorators", + data = output_q, + decorators = decorators, + expr = quote(summary_table) + ) + + output_r <- reactive({ + obj <- req(decorated_output_q()) + + # todo: why summary_table_data is returned while summary_table is printed in a code? + DT::datatable( + obj[["summary_table_data"]], + options = list( + autoWidth = TRUE, + columnDefs = list(list(width = "200px", targets = "_all")) + ), + rownames = FALSE + ) + }) + + output$summary_table <- DT::renderDataTable(output_r()) + + decorated_output_q + }) +} + +.ui_test_table <- function(id, is_stratified, decorators) { + ns <- NS(id) + tagList( + encodings = tagList( + shinyWidgets::pickerInput( + ns("dist_test"), + "Tests:", + choices = c( + "Shapiro-Wilk", + if (is_stratified) "Kolmogorov-Smirnov (two-samples)", + if (is_stratified) "one-way ANOVA", + if (is_stratified) "Fligner-Killeen", + if (is_stratified) "F-test", + "Kolmogorov-Smirnov (one-sample)", + "Anderson-Darling (one-sample)", + "Cramer-von Mises (one-sample)", + if (is_stratified) "t-test (two-samples, not paired)" + ), + selected = NULL, + options = list( + `allow-clear` = TRUE, + "none-selected-text" = "- Nothing selected -" + ) + ), + ui_decorate_teal_data(ns("decorators"), decorators = decorators) + ), + output = tagList( + tags$h3("Tests"), + DT::dataTableOutput(ns("table")) + ) + ) +} + +.srv_test_table <- function(id, data, variables, t_dist, decorators) { + moduleServer(id, function(input, output, session) { + output_q <- eventReactive( + ignoreNULL = FALSE, + eventExpr = { + data() + input$dist_test + }, + valueExpr = { + obj <- data() + anl <- obj[["anl"]] + d_var <- variables()$dist_var + s_var <- variables()$strata_var + g_var <- variables()$group_var + d_var_name <- as.name(d_var) + s_var_name <- if (!is.null(s_var)) as.name(s_var) + g_var_name <- if (!is.null(g_var)) as.name(g_var) + + dist_test <- input$dist_test + validate(need(length(dist_test) > 0, "Please select a test")) + + if (length(s_var) > 0 || length(g_var) > 0) { + counts <- anl %>% + dplyr::group_by_at(dplyr::vars(dplyr::any_of(c(s_var, g_var)))) %>% + dplyr::summarise(n = dplyr::n()) + validate(need(all(counts$n > 5), "Please select strata*group with at least 5 observation each.")) + } + + map_dist <- c(normal = "dnorm", lognormal = "dlnorm", gamma = "dgamma", unif = "dunif") + sks_args <- list( + test = quote(stats::ks.test), + args = bquote(append(list(.[[.(d_var)]], .(map_dist[t_dist()])), params)), + groups = c(g_var, s_var) + ) + ssw_args <- list( + test = quote(stats::shapiro.test), + args = bquote(list(.[[.(d_var)]])), + groups = c(g_var, s_var) + ) + mfil_args <- list( + test = quote(stats::fligner.test), + args = bquote(list(.[[.(d_var)]], .[[.(s_var)]])), + groups = c(g_var) + ) + sad_args <- list( + test = quote(goftest::ad.test), + args = bquote(append(list(.[[.(d_var)]], .(map_dist[t_dist()])), params)), + groups = c(g_var, s_var) + ) + scvm_args <- list( + test = quote(goftest::cvm.test), + args = bquote(append(list(.[[.(d_var)]], .(map_dist[t_dist()])), params)), + groups = c(g_var, s_var) + ) + manov_args <- list( + test = quote(stats::aov), + args = bquote(list(stats::formula(.(d_var_name) ~ .(s_var_name)), .)), + groups = c(g_var) + ) + mt_args <- list( + test = quote(stats::t.test), + args = bquote(unname(split(.[[.(d_var)]], .[[.(s_var)]], drop = TRUE))), + groups = c(g_var) + ) + mv_args <- list( + test = quote(stats::var.test), + args = bquote(unname(split(.[[.(d_var)]], .[[.(s_var)]], drop = TRUE))), + groups = c(g_var) + ) + mks_args <- list( + test = quote(stats::ks.test), + args = bquote(unname(split(.[[.(d_var)]], .[[.(s_var)]], drop = TRUE))), + groups = c(g_var) + ) + + tests_base <- switch(dist_test, + "Kolmogorov-Smirnov (one-sample)" = sks_args, + "Shapiro-Wilk" = ssw_args, + "Fligner-Killeen" = mfil_args, + "one-way ANOVA" = manov_args, + "t-test (two-samples, not paired)" = mt_args, + "F-test" = mv_args, + "Kolmogorov-Smirnov (two-samples)" = mks_args, + "Anderson-Darling (one-sample)" = sad_args, + "Cramer-von Mises (one-sample)" = scvm_args + ) + + env <- list( + t_test = t_dist(), + d_var = d_var, + g_var = g_var, + s_var = s_var, + args = tests_base$args, + groups = tests_base$groups, + test = tests_base$test, + d_var_name = d_var_name, + g_var_name = g_var_name, + s_var_name = s_var_name + ) + + + teal.reporter::teal_card(obj) <- c(teal.reporter::teal_card(obj), "## Distribution Tests table") + + obj <- if (length(s_var) == 0 && length(g_var) == 0) { + obj <- teal.code::eval_code(obj, 'library("generics")') # nolint quotes + teal.code::eval_code( + obj, + substitute( + expr = { + test_table_data <- anl %>% + dplyr::select(d_var) %>% + with(., generics::glance(do.call(test, args))) %>% + dplyr::mutate_if(is.numeric, round, 3) + }, + env = env + ) + ) + } else { + # todo: why there is a `library` call when `tidyr::unnest` is prefixed, same for `generics` + obj <- teal.code::eval_code(obj, 'library("tidyr")') # nolint quotes + teal.code::eval_code( + obj, + substitute( + expr = { + test_table_data <- anl %>% + dplyr::select(d_var, s_var, g_var) %>% + dplyr::group_by_at(dplyr::vars(dplyr::any_of(groups))) %>% + dplyr::do(tests = generics::glance(do.call(test, args))) %>% + tidyr::unnest(tests) %>% + dplyr::mutate_if(is.numeric, round, 3) + }, + env = env + ) + ) + } + + within(obj, { + test_table <- rtables::df_to_tt(test_table_data) + }) + } + ) + + decorated_output_q <- srv_decorate_teal_data( + "decorators", + data = output_q, + decorators = decorators, + expr = quote(test_table) + ) + + output_r <- reactive({ + obj <- req(decorated_output_q()) + DT::datatable(obj[["test_table_data"]]) + }) + + output$table <- DT::renderDataTable(output_r()) + + decorated_output_q + }) +} + +.calc_dist_params <- function(x, dist) { + if (dist == "unif") { + return(stats::setNames(range(x, na.rm = TRUE), c("min", "max"))) + } + tryCatch( + MASS::fitdistr(x, densfun = dist)$estimate, + error = function(e) c(param1 = NA_real_, param2 = NA_real_) + ) +} + +.dist_param_list <- function(dist, param1, param2) { + dist_param_names <- list( + normal = c("mean", "sd"), + lognormal = c("meanlog", "sdlog"), + gamma = c("shape", "rate"), + unif = c("min", "max") + ) + + params <- list(param1, param2) + names(params) <- dist_param_names[[dist]] + params +} diff --git a/R/tm_g_response.R b/R/tm_g_response.R index 12c0a96b9..a83c434e3 100644 --- a/R/tm_g_response.R +++ b/R/tm_g_response.R @@ -9,19 +9,15 @@ #' #' @inheritParams teal::module #' @inheritParams shared_params -#' @param response (`data_extract_spec` or `list` of multiple `data_extract_spec`) +#' @param response (`picks`) #' Which variable to use as the response. -#' You can define one fixed column by setting `fixed = TRUE` inside the `select_spec`. -#' -#' The `data_extract_spec` must not allow multiple selection in this case. -#' @param x (`data_extract_spec` or `list` of multiple `data_extract_spec`) +#' The `picks` must not allow multiple variable selection in this case. +#' @param x (`picks` ) #' Specifies which variable to use on the X-axis of the response plot. -#' Allow the user to select multiple columns from the `data` allowed in teal. -#' -#' The `data_extract_spec` must not allow multiple selection in this case. -#' @param row_facet (`data_extract_spec` or `list` of multiple `data_extract_spec`) +#' The `picks` must not allow multiple selection in this case. +#' @param row_facet (`picks`) #' optional specification of the data variable(s) to use for faceting rows. -#' @param col_facet (`data_extract_spec` or `list` of multiple `data_extract_spec`) +#' @param col_facet (`picks`) #' optional specification of the data variable(s) to use for faceting columns. #' @param coord_flip (`logical(1)`) #' Indicates whether to flip coordinates between `x` and `response`. @@ -85,25 +81,25 @@ #' modules = modules( #' tm_g_response( #' label = "Response Plots", -#' response = data_extract_spec( -#' dataname = "mtcars", -#' select = select_spec( -#' label = "Select variable:", -#' choices = variable_choices(data[["mtcars"]], c("cyl", "gear")), +#' response = picks( +#' datasets("mtcars"), +#' variables( +#' choices = c("cyl", "gear"), #' selected = "cyl", #' multiple = FALSE, #' fixed = FALSE -#' ) +#' ), +#' teal.transform::values() #' ), -#' x = data_extract_spec( -#' dataname = "mtcars", -#' select = select_spec( -#' label = "Select variable:", -#' choices = variable_choices(data[["mtcars"]], c("vs", "am")), +#' x = teal.transform::picks( +#' datasets("mtcars"), +#' teal.transform::variables( +#' choices = c("vs", "am"), #' selected = "vs", #' multiple = FALSE, #' fixed = FALSE -#' ) +#' ), +#' teal.transform::values() #' ) #' ) #' ) @@ -130,25 +126,21 @@ #' modules = modules( #' tm_g_response( #' label = "Response Plots", -#' response = data_extract_spec( -#' dataname = "ADSL", -#' select = select_spec( -#' label = "Select variable:", -#' choices = variable_choices(data[["ADSL"]], c("BMRKR2", "COUNTRY")), -#' selected = "BMRKR2", -#' multiple = FALSE, -#' fixed = FALSE -#' ) +#' response = teal.transform::picks( +#' datasets("ADSL"), +#' teal.transform::variables( +#' choices = c("BMRKR2", "COUNTRY"), +#' selected = "BMRKR2" +#' ), +#' teal.transform::values() #' ), -#' x = data_extract_spec( -#' dataname = "ADSL", -#' select = select_spec( -#' label = "Select variable:", -#' choices = variable_choices(data[["ADSL"]], c("SEX", "RACE")), -#' selected = "RACE", -#' multiple = FALSE, -#' fixed = FALSE -#' ) +#' x = teal.transform::picks( +#' datasets("ADSL"), +#' teal.transform::variables( +#' choices = c("SEX", "RACE"), +#' selected = "RACE" +#' ), +#' teal.transform::values() #' ) #' ) #' ) @@ -160,7 +152,11 @@ #' @export #' tm_g_response <- function(label = "Response Plot", - response, + response = teal.transform::picks( + teal.transform::datasets(), + teal.transform::variables(choices = teal.transform::is_categorical(min.len = 2, max.len = 10)), + teal.transform::values() + ), x, row_facet = NULL, col_facet = NULL, @@ -176,6 +172,27 @@ tm_g_response <- function(label = "Response Plot", post_output = NULL, transformators = list(), decorators = list()) { + UseMethod("tm_g_response", response) +} + +#' @export +tm_g_response.default <- function(label = "Response Plot", + response, + x, + row_facet = NULL, + col_facet = NULL, + coord_flip = FALSE, + count_labels = TRUE, + rotate_xaxis_labels = FALSE, + freq = FALSE, + plot_height = c(600, 400, 5000), + plot_width = NULL, + ggtheme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void"), + ggplot2_args = teal.widgets::ggplot2_args(), + pre_output = NULL, + post_output = NULL, + transformators = list(), + decorators = list()) { message("Initializing tm_g_response") # Normalize the parameters @@ -235,8 +252,8 @@ tm_g_response <- function(label = "Response Plot", ans <- module( label = label, - server = srv_g_response, - ui = ui_g_response, + server = srv_g_response.default, + ui = ui_g_response.default, ui_args = args, server_args = c( data_extract_list, @@ -255,7 +272,7 @@ tm_g_response <- function(label = "Response Plot", } # UI function for the response module -ui_g_response <- function(id, ...) { +ui_g_response.default <- function(id, ...) { ns <- NS(id) args <- list(...) is_single_dataset_value <- teal.transform::is_single_dataset(args$response, args$x, args$row_facet, args$col_facet) @@ -326,16 +343,16 @@ ui_g_response <- function(id, ...) { } # Server function for the response module -srv_g_response <- function(id, - data, - response, - x, - row_facet, - col_facet, - plot_height, - plot_width, - ggplot2_args, - decorators) { +srv_g_response.default <- function(id, + data, + response, + x, + row_facet, + col_facet, + plot_height, + plot_width, + ggplot2_args, + decorators) { checkmate::assert_class(data, "reactive") checkmate::assert_class(isolate(data()), "teal_data") moduleServer(id, function(input, output, session) { diff --git a/R/tm_g_response_picks.R b/R/tm_g_response_picks.R new file mode 100644 index 000000000..0166b0784 --- /dev/null +++ b/R/tm_g_response_picks.R @@ -0,0 +1,416 @@ +#' @export +tm_g_response.picks <- function(label = "Response Plot", + response = teal.transform::picks( + teal.transform::datasets(), + teal.transform::variables( + choices = teal.transform::is_categorical(min.len = 2, max.len = 10) + ), + teal.transform::values() + ), + x = teal.transform::picks( + teal.transform::datasets(), + teal.transform::variables( + choices = teal.transform::is_categorical(min.len = 2, max.len = 10), + selected = 2L + ), + teal.transform::values() + ), + row_facet = teal.transform::picks( + teal.transform::datasets(), + teal.transform::variables( + choices = teal.transform::is_categorical(min.len = 2, max.len = 10), + selected = NULL + ), + teal.transform::values() + ), + col_facet = teal.transform::picks( + teal.transform::datasets(), + teal.transform::variables( + choices = teal.transform::is_categorical(min.len = 2, max.len = 10), + selected = NULL + ), + teal.transform::values() + ), + coord_flip = FALSE, + count_labels = TRUE, + rotate_xaxis_labels = FALSE, + freq = FALSE, + plot_height = c(600, 400, 5000), + plot_width = NULL, + ggtheme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void"), + ggplot2_args = teal.widgets::ggplot2_args(), + pre_output = NULL, + post_output = NULL, + transformators = list(), + decorators = list()) { + message("Initializing tm_g_response") + + # Start of assertions + checkmate::assert_string(label) + + checkmate::assert_class(response, "picks") + if (isTRUE(attr(response$variables, "multiple"))) { + warning("`response` accepts only a single variable selection. Forcing `teal.transform::variables(multiple) to FALSE`") + attr(response$variables, "multiple") <- FALSE + } + + checkmate::assert_class(x, "picks") + if (isTRUE(attr(x$variables, "multiple"))) { + warning("`x` accepts only a single variable selection. Forcing `teal.transform::variables(multiple) to FALSE`") + attr(x$variables, "multiple") <- FALSE + } + + checkmate::assert_class(row_facet, "picks", null.ok = TRUE) + checkmate::assert_class(col_facet, "picks", null.ok = TRUE) + checkmate::assert_flag(coord_flip) + checkmate::assert_flag(count_labels) + checkmate::assert_flag(rotate_xaxis_labels) + checkmate::assert_flag(freq) + + checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE) + checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height") + checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE) + checkmate::assert_numeric( + plot_width[1], + lower = plot_width[2], upper = plot_width[3], null.ok = TRUE, .var.name = "plot_width" + ) + + ggtheme <- match.arg(ggtheme) + checkmate::assert_class(ggplot2_args, "ggplot2_args") + + 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) + + assert_decorators(decorators, "plot") + # End of assertions + + + args <- as.list(environment()) + ans <- module( + label = label, + ui = ui_g_response.picks, + server = srv_g_response.picks, + ui_args = args[names(args) %in% names(formals(ui_g_response.picks))], + server_args = args[names(args) %in% names(formals(srv_g_response.picks))], + transformators = transformators, + datanames = .picks_datanames(list(response, x, row_facet, col_facet)) + ) + attr(ans, "teal_bookmarkable") <- TRUE + ans +} + +# UI function for the response module +ui_g_response.picks <- function(id, + response, + x, + row_facet, + col_facet, + freq, + count_labels, + rotate_xaxis_labels, + coord_flip, + ggtheme, + pre_output, + post_output, + decorators) { + ns <- NS(id) + teal.widgets::standard_layout( + output = teal.widgets::white_small_well( + teal.widgets::plot_with_settings_ui(id = ns("myplot")) + ), + encoding = tags$div( + tags$label("Encodings", class = "text-primary"), + tags$div( + tags$strong("Response variable"), + teal.transform::picks_ui(id = ns("response"), picks = response) + ), + tags$div( + tags$strong("X variable"), + teal.transform::picks_ui(id = ns("x"), picks = x) + ), + if (!is.null(row_facet)) { + tags$div( + tags$strong("Row facetting"), + teal.transform::picks_ui(id = ns("row_facet"), picks = row_facet) + ) + }, + if (!is.null(col_facet)) { + tags$div( + tags$strong("Column facetting"), + teal.transform::picks_ui(id = ns("col_facet"), picks = col_facet) + ) + }, + shinyWidgets::radioGroupButtons( + inputId = ns("freq"), + label = NULL, + choices = c("frequency", "density"), + selected = ifelse(freq, "frequency", "density"), + justified = TRUE + ), + ui_decorate_teal_data(ns("decorator"), decorators = select_decorators(decorators, "plot")), + bslib::accordion( + open = TRUE, + bslib::accordion_panel( + title = "Plot settings", + checkboxInput(ns("count_labels"), "Add count labels", value = count_labels), + checkboxInput(ns("coord_flip"), "Swap axes", value = coord_flip), + checkboxInput(ns("rotate_xaxis_labels"), "Rotate X axis labels", value = rotate_xaxis_labels), + selectInput( + inputId = ns("ggtheme"), + label = "Theme (by ggplot):", + choices = ggplot_themes, + selected = ggtheme, + multiple = FALSE + ) + ) + ) + ), + pre_output = pre_output, + post_output = post_output + ) +} + +# Server function for the response module +srv_g_response.picks <- function(id, + data, + response, + x, + row_facet, + col_facet, + plot_height, + plot_width, + ggplot2_args, + decorators) { + checkmate::assert_class(data, "reactive") + checkmate::assert_class(isolate(data()), "teal_data") + moduleServer(id, function(input, output, session) { + teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.general") + + selectors <- teal.transform::picks_srv( + picks = list( + response = response, + x = x, + row_facet = row_facet, + col_facet = col_facet + ), + data = data + ) + + validated_q <- reactive({ + validate_input( + inputId = "response-variables-selected", + condition = !is.null(selectors$response()$variables$selected), + message = "A `response` variable needs to be selected." + ) + validate_input( + inputId = "x-variables-selected", + condition = !is.null(selectors$x()$variables$selected), + message = "A `x` variable needs to be selected." + ) + validate_input( + inputId = c("response-variables-selected", "x-variables-selected"), + condition = !any(selectors$response()$variables$selected %in% selectors$x()$variables$selected), + message = "Response and X variables must be different." + ) + validate_input( + inputId = "row_facet-variables-selected", + condition = is.null(row_facet) || length(selectors$row_facet()$variables$selected) < 2, + message = "Only single Row Facetting variable is allowed." + ) + validate_input( + inputId = "col_facet-variables-selected", + condition = is.null(col_facet) || length(selectors$col_facet()$variables$selected) < 2, + message = "Only single Column Facetting variable is allowed." + ) + validate_input( + inputId = c("row_facet-variables-selected", "col_facet-variables-selected"), + condition = is.null(row_facet) || is.null(col_facet) || + !any(selectors$row_facet()$variables$selected %in% selectors$col_facet()$variables$selected), + message = "Row and Column Facetting variables must be different." + ) + + obj <- req(data()) + teal.reporter::teal_card(obj) <- + c( + teal.reporter::teal_card("# Response Plot"), + teal.reporter::teal_card(obj), + teal.reporter::teal_card("## Module's code") + ) + teal.code::eval_code(obj, 'library("ggplot2");library("dplyr");') + }) + + merged <- teal.transform::merge_srv("merge", data = validated_q, selectors = selectors, output_name = "anl") + + + output_q <- reactive({ + validate_input( + inputId = "ggtheme", + condition = length(input$ggtheme) > 0, + message = "Row and Col Facetting variables must be different." + ) + + qenv <- merged$data() + anl <- qenv[["anl"]] + response_var <- merged$variables()$response + x_var <- merged$variables()$x + + validate(need(is.factor(anl[[response_var]]), "Please select a factor variable as the response.")) + validate(need(is.factor(anl[[x_var]]), "Please select a factor variable as the X-Variable.")) + teal::validate_has_data(anl, 10) + teal::validate_has_data(anl[, c(response_var, x_var)], 10, complete = TRUE, allow_inf = FALSE) + + row_facet_var <- merged$variables()$row_facet + col_facet_var <- merged$variables()$col_facet + + freq <- input$freq == "frequency" + swap_axes <- input$coord_flip + counts <- input$count_labels + rotate_xaxis_labels <- input$rotate_xaxis_labels + ggtheme <- input$ggtheme + + arg_position <- if (freq) "stack" else "fill" + + if (swap_axes) { + qenv <- within( + qenv, + expr = anl[[x_var]] <- with(anl, forcats::fct_rev(x_cl)), + x_var = x_var, + x_cl = as.name(x_var) + ) + } + + qenv <- within( + qenv, + expr = { + anl[[response_var]] <- factor(anl[[response_var]]) + + anl2 <- anl %>% + dplyr::group_by_at(dplyr::vars(x_cl, response_cl, row_facet_cl, col_facet_cl)) %>% + dplyr::summarise(ns = dplyr::n()) %>% + dplyr::group_by_at(dplyr::vars(x_cl, row_facet_cl, col_facet_cl)) %>% + dplyr::mutate(sums = sum(ns), percent = round(ns / sums * 100, 1)) + + anl3 <- anl %>% + dplyr::group_by_at(dplyr::vars(x_cl, row_facet_cl, col_facet_cl)) %>% + dplyr::summarise(ns = dplyr::n()) + }, + response_var = response_var, + response_cl = as.name(response_var), + x_cl = as.name(x_var), + row_facet_cl = if (length(row_facet_var)) as.name(row_facet_var), + col_facet_cl = if (length(col_facet_var)) as.name(col_facet_var) + ) + + plot_call <- substitute( + expr = ggplot2::ggplot(anl2, ggplot2::aes(x = x_cl, y = ns)) + + ggplot2::geom_bar(ggplot2::aes(fill = response_cl), stat = "identity", position = arg_position), + env = list( + x_cl = as.name(x_var), + response_cl = as.name(response_var), + arg_position = arg_position + ) + ) + + if (!freq) { + plot_call <- substitute( + plot_call + ggplot2::expand_limits(y = c(0, 1.1)), + env = list(plot_call = plot_call) + ) + } + + if (counts) { + plot_call <- substitute( + expr = plot_call + + ggplot2::geom_text( + data = anl2, + ggplot2::aes(label = ns, x = x_cl, y = ns, group = response_cl), + col = "white", + vjust = "middle", + hjust = "middle", + position = position_anl2_value + ) + + ggplot2::geom_text( + data = anl3, ggplot2::aes(label = ns, x = x_cl, y = anl3_y), + hjust = hjust_value, + vjust = vjust_value, + position = position_anl3_value + ), + env = list( + plot_call = plot_call, + x_cl = as.name(x_var), + response_cl = as.name(response_var), + hjust_value = if (swap_axes) "left" else "middle", + vjust_value = if (swap_axes) "middle" else -1, + position_anl2_value = if (!freq) quote(position_fill(0.5)) else quote(position_stack(0.5)), # nolint: line_length. + anl3_y = if (!freq) 1.1 else as.name("ns"), + position_anl3_value = if (!freq) "fill" else "stack" + ) + ) + } + + if (swap_axes) { + plot_call <- substitute(plot_call + coord_flip(), env = list(plot_call = plot_call)) + } + + facet_cl <- facet_ggplot_call(row_facet_var, col_facet_var) + + if (!is.null(facet_cl)) { + plot_call <- substitute(expr = plot_call + facet_cl, env = list(plot_call = plot_call, facet_cl = facet_cl)) + } + + dev_ggplot2_args <- teal.widgets::ggplot2_args( + labs = list( + x = varname_w_label(x_var, anl), + y = varname_w_label(response_var, anl, prefix = "Proportion of "), + fill = varname_w_label(response_var, anl) + ), + theme = list(legend.position = "bottom") + ) + + if (rotate_xaxis_labels) { + dev_ggplot2_args$theme[["axis.text.x"]] <- quote(ggplot2::element_text(angle = 45, hjust = 1)) + } + + all_ggplot2_args <- teal.widgets::resolve_ggplot2_args( + user_plot = ggplot2_args, + module_plot = dev_ggplot2_args + ) + + parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args( + all_ggplot2_args, + ggtheme = ggtheme + ) + + plot_call <- substitute(expr = { + plot <- plot_call + labs + ggthemes + themes + }, env = list( + plot_call = plot_call, + labs = parsed_ggplot2_args$labs, + themes = parsed_ggplot2_args$theme, + ggthemes = parsed_ggplot2_args$ggtheme + )) + + teal.reporter::teal_card(qenv) <- c(teal.reporter::teal_card(qenv), "## Plot") + teal.code::eval_code(qenv, plot_call) + }) + + decorated_output_plot_q <- srv_decorate_teal_data( + id = "decorator", + data = output_q, + decorators = select_decorators(decorators, "plot"), + expr = quote(plot) + ) + + plot_r <- reactive(req(decorated_output_plot_q())[["plot"]]) + + # Insert the plot into a plot_with_settings module from teal.widgets + pws <- teal.widgets::plot_with_settings_srv( + id = "myplot", + plot_r = plot_r, + height = plot_height, + width = plot_width + ) + + set_chunk_dims(pws, decorated_output_plot_q) + }) +} diff --git a/R/tm_g_scatterplot.R b/R/tm_g_scatterplot.R index acb5c4890..a99b0cbb9 100644 --- a/R/tm_g_scatterplot.R +++ b/R/tm_g_scatterplot.R @@ -10,17 +10,17 @@ #' #' @inheritParams teal::module #' @inheritParams shared_params -#' @param x (`data_extract_spec` or `list` of multiple `data_extract_spec`) Specifies +#' @param x (`picks` or `list` of multiple `picks`) Specifies #' variable names selected to plot along the x-axis by default. -#' @param y (`data_extract_spec` or `list` of multiple `data_extract_spec`) Specifies +#' @param y (`picks` or `list` of multiple `picks`) Specifies #' variable names selected to plot along the y-axis by default. -#' @param color_by (`data_extract_spec` or `list` of multiple `data_extract_spec`) optional, +#' @param color_by (`picks` or `list` of multiple `picks`) optional, #' defines the color encoding. If `NULL` then no color encoding option will be displayed. -#' @param size_by (`data_extract_spec` or `list` of multiple `data_extract_spec`) optional, +#' @param size_by (`picks` or `list` of multiple `picks`) optional, #' defines the point size encoding. If `NULL` then no size encoding option will be displayed. -#' @param row_facet (`data_extract_spec` or `list` of multiple `data_extract_spec`) optional, +#' @param row_facet (`picks` or `list` of multiple `picks`) optional, #' specifies the variable(s) for faceting rows. -#' @param col_facet (`data_extract_spec` or `list` of multiple `data_extract_spec`) optional, +#' @param col_facet (`picks` or `list` of multiple `picks`) optional, #' specifies the variable(s) for faceting columns. #' @param shape (`character`) optional, character vector with the names of the #' shape, e.g. `c("triangle", "square", "circle")`. It defaults to `shape_names`. This is a complete list from @@ -75,68 +75,47 @@ #' modules = modules( #' tm_g_scatterplot( #' label = "Scatterplot Choices", -#' x = data_extract_spec( -#' dataname = "CO2", -#' select = select_spec( -#' label = "Select variable:", -#' choices = variable_choices(data[["CO2"]], c("conc", "uptake")), -#' selected = "conc", -#' multiple = FALSE, -#' fixed = FALSE -#' ) +#' x = teal.transform::picks( +#' datasets("CO2"), +#' teal.transform::variables( +#' choices = c("conc", "uptake"), +#' selected = "conc" +#' ), +#' teal.transform::values() #' ), -#' y = data_extract_spec( -#' dataname = "CO2", -#' select = select_spec( -#' label = "Select variable:", -#' choices = variable_choices(data[["CO2"]], c("conc", "uptake")), -#' selected = "uptake", -#' multiple = FALSE, -#' fixed = FALSE -#' ) +#' y = teal.transform::picks( +#' datasets("CO2"), +#' teal.transform::variables( +#' choices = c("conc", "uptake"), +#' selected = "uptake" +#' ), +#' teal.transform::values() #' ), -#' color_by = data_extract_spec( -#' dataname = "CO2", -#' select = select_spec( -#' label = "Select variable:", -#' choices = variable_choices( -#' data[["CO2"]], -#' c("Plant", "Type", "Treatment", "conc", "uptake") -#' ), -#' selected = NULL, -#' multiple = FALSE, -#' fixed = FALSE -#' ) +#' color_by = teal.transform::picks( +#' datasets("CO2"), +#' teal.transform::variables( +#' choices = c("Plant", "Type", "Treatment", "conc", "uptake"), +#' selected = NULL +#' ), +#' teal.transform::values() #' ), -#' size_by = data_extract_spec( -#' dataname = "CO2", -#' select = select_spec( -#' label = "Select variable:", -#' choices = variable_choices(data[["CO2"]], c("conc", "uptake")), -#' selected = "uptake", -#' multiple = FALSE, -#' fixed = FALSE -#' ) +#' size_by = teal.transform::picks( +#' datasets("CO2"), +#' teal.transform::variables(choices = c("conc", "uptake"), selected = "uptake"), +#' teal.transform::values() #' ), -#' row_facet = data_extract_spec( -#' dataname = "CO2", -#' select = select_spec( -#' label = "Select variable:", -#' choices = variable_choices(data[["CO2"]], c("Plant", "Type", "Treatment")), -#' selected = NULL, -#' multiple = FALSE, -#' fixed = FALSE -#' ) +#' row_facet = teal.transform::picks( +#' datasets("CO2"), +#' teal.transform::variables( +#' choices = c("Plant", "Type", "Treatment"), +#' selected = NULL +#' ), +#' teal.transform::values() #' ), -#' col_facet = data_extract_spec( -#' dataname = "CO2", -#' select = select_spec( -#' label = "Select variable:", -#' choices = variable_choices(data[["CO2"]], c("Plant", "Type", "Treatment")), -#' selected = NULL, -#' multiple = FALSE, -#' fixed = FALSE -#' ) +#' col_facet = teal.transform::picks( +#' datasets("CO2"), +#' teal.transform::variables(choices = c("Plant", "Type", "Treatment"), selected = NULL), +#' teal.transform::values() #' ) #' ) #' ) @@ -165,68 +144,35 @@ #' modules = modules( #' tm_g_scatterplot( #' label = "Scatterplot Choices", -#' x = data_extract_spec( -#' dataname = "ADSL", -#' select = select_spec( -#' label = "Select variable:", -#' choices = variable_choices(data[["ADSL"]], c("AGE", "BMRKR1", "BMRKR2")), -#' selected = "AGE", -#' multiple = FALSE, -#' fixed = FALSE -#' ) +#' x = teal.transform::picks( +#' datasets("ADSL"), +#' teal.transform::variables(choices = c("AGE", "BMRKR1", "BMRKR2"), selected = "AGE"), +#' teal.transform::values() #' ), -#' y = data_extract_spec( -#' dataname = "ADSL", -#' select = select_spec( -#' label = "Select variable:", -#' choices = variable_choices(data[["ADSL"]], c("AGE", "BMRKR1", "BMRKR2")), -#' selected = "BMRKR1", -#' multiple = FALSE, -#' fixed = FALSE -#' ) +#' y = teal.transform::picks( +#' datasets("ADSL"), +#' teal.transform::variables(choices = c("AGE", "BMRKR1", "BMRKR2"), selected = "BMRKR1"), +#' teal.transform::values() #' ), -#' color_by = data_extract_spec( -#' dataname = "ADSL", -#' select = select_spec( -#' label = "Select variable:", -#' choices = variable_choices( -#' data[["ADSL"]], -#' c("AGE", "BMRKR1", "BMRKR2", "RACE", "REGION1") -#' ), -#' selected = NULL, -#' multiple = FALSE, -#' fixed = FALSE -#' ) +#' color_by = teal.transform::picks( +#' datasets("ADSL"), +#' teal.transform::variables(c("AGE", "BMRKR1", "BMRKR2", "RACE", "REGION1"), selected = NULL), +#' teal.transform::values() #' ), -#' size_by = data_extract_spec( -#' dataname = "ADSL", -#' select = select_spec( -#' label = "Select variable:", -#' choices = variable_choices(data[["ADSL"]], c("AGE", "BMRKR1")), -#' selected = "AGE", -#' multiple = FALSE, -#' fixed = FALSE -#' ) +#' size_by = teal.transform::picks( +#' datasets("ADSL"), +#' teal.transform::variables(choices = c("AGE", "BMRKR1"), selected = "AGE"), +#' teal.transform::values() #' ), -#' row_facet = data_extract_spec( -#' dataname = "ADSL", -#' select = select_spec( -#' label = "Select variable:", -#' choices = variable_choices(data[["ADSL"]], c("BMRKR2", "RACE", "REGION1")), -#' selected = NULL, -#' multiple = FALSE, -#' fixed = FALSE -#' ) +#' row_facet = teal.transform::picks( +#' datasets("ADSL"), +#' teal.transform::variables(choices = c("BMRKR2", "RACE", "REGION1"), selected = NULL), +#' teal.transform::values() #' ), -#' col_facet = data_extract_spec( -#' dataname = "ADSL", -#' select = select_spec( -#' label = "Select variable:", -#' choices = variable_choices(data[["ADSL"]], c("BMRKR2", "RACE", "REGION1")), -#' selected = NULL, -#' multiple = FALSE, -#' fixed = FALSE -#' ) +#' col_facet = teal.transform::picks( +#' datasets("ADSL"), +#' teal.transform::variables(choices = c("BMRKR2", "RACE", "REGION1"), selected = NULL), +#' teal.transform::values() #' ) #' ) #' ) @@ -238,7 +184,11 @@ #' @export #' tm_g_scatterplot <- function(label = "Scatterplot", - x, + x = teal.transform::picks( + teal.transform::datasets(), + teal.transform::variables(is.numeric), + teal.transform::values() + ), y, color_by = NULL, size_by = NULL, @@ -258,6 +208,31 @@ tm_g_scatterplot <- function(label = "Scatterplot", ggplot2_args = teal.widgets::ggplot2_args(), transformators = list(), decorators = list()) { + UseMethod("tm_g_scatterplot", x) +} + +#' @export +tm_g_scatterplot.default <- function(label = "Scatterplot", + x, + y, + color_by = NULL, + size_by = NULL, + row_facet = NULL, + col_facet = NULL, + plot_height = c(600, 200, 2000), + plot_width = NULL, + alpha = c(1, 0, 1), + shape = shape_names, + size = c(5, 1, 15), + max_deg = 5L, + rotate_xaxis_labels = FALSE, + ggtheme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void"), + pre_output = NULL, + post_output = NULL, + table_dec = 4, + ggplot2_args = teal.widgets::ggplot2_args(), + transformators = list(), + decorators = list()) { message("Initializing tm_g_scatterplot") # Normalize the parameters @@ -334,8 +309,8 @@ tm_g_scatterplot <- function(label = "Scatterplot", ans <- module( label = label, - server = srv_g_scatterplot, - ui = ui_g_scatterplot, + server = srv_g_scatterplot.default, + ui = ui_g_scatterplot.default, ui_args = args, server_args = c( data_extract_list, @@ -355,7 +330,7 @@ tm_g_scatterplot <- function(label = "Scatterplot", } # UI function for the scatterplot module -ui_g_scatterplot <- function(id, ...) { +ui_g_scatterplot.default <- function(id, ...) { args <- list(...) ns <- NS(id) is_single_dataset_value <- teal.transform::is_single_dataset( @@ -502,19 +477,19 @@ ui_g_scatterplot <- function(id, ...) { } # Server function for the scatterplot module -srv_g_scatterplot <- function(id, - data, - x, - y, - color_by, - size_by, - row_facet, - col_facet, - plot_height, - plot_width, - table_dec, - ggplot2_args, - decorators) { +srv_g_scatterplot.default <- function(id, + data, + x, + y, + color_by, + size_by, + row_facet, + col_facet, + plot_height, + plot_width, + table_dec, + ggplot2_args, + decorators) { checkmate::assert_class(data, "reactive") checkmate::assert_class(isolate(data()), "teal_data") moduleServer(id, function(input, output, session) { @@ -1030,7 +1005,8 @@ srv_g_scatterplot <- function(id, plot_r = plot_r, height = plot_height, width = plot_width, - brushing = TRUE + brushing = TRUE, + click = TRUE ) output$data_table <- DT::renderDataTable({ diff --git a/R/tm_g_scatterplot_picks.R b/R/tm_g_scatterplot_picks.R new file mode 100644 index 000000000..2f87ec128 --- /dev/null +++ b/R/tm_g_scatterplot_picks.R @@ -0,0 +1,813 @@ +#' @export +tm_g_scatterplot.picks <- function(label = "Scatterplot", + x = teal.transform::picks( + teal.transform::datasets(), + teal.transform::variables(is.numeric), + teal.transform::values() + ), + y = teal.transform::picks( + teal.transform::datasets(), + teal.transform::variables(is.numeric, selected = 2L), + teal.transform::values() + ), + color_by = teal.transform::picks( + teal.transform::datasets(), + teal.transform::variables( + choices = teal.transform::is_categorical(min.len = 2, max.len = 10), + selected = NULL, + multiple = TRUE + ) + ), + size_by = teal.transform::picks( + teal.transform::datasets(), + teal.transform::variables( + choices = is.numeric, + selected = NULL, + multiple = TRUE + ) + ), + row_facet = teal.transform::picks( + teal.transform::datasets(), + teal.transform::variables( + choices = teal.transform::is_categorical(min.len = 2, max.len = 10), + selected = NULL + ), + teal.transform::values() + ), + col_facet = teal.transform::picks( + teal.transform::datasets(), + teal.transform::variables( + choices = teal.transform::is_categorical(min.len = 2, max.len = 10), + selected = NULL + ), + teal.transform::values() + ), + plot_height = c(600, 200, 2000), + plot_width = NULL, + alpha = c(1, 0, 1), + shape = shape_names, + size = c(5, 1, 15), + max_deg = 5L, + rotate_xaxis_labels = FALSE, + ggtheme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void"), + pre_output = NULL, + post_output = NULL, + table_dec = 4, + ggplot2_args = teal.widgets::ggplot2_args(), + transformators = list(), + decorators = list()) { + message("Initializing tm_g_scatterplot") + + # Start of assertions + checkmate::assert_string(label) + checkmate::assert_class(x, "picks") + checkmate::assert_class(y, "picks") + checkmate::assert_class(color_by, "picks", null.ok = TRUE) + checkmate::assert_class(size_by, "picks", null.ok = TRUE) + + checkmate::assert_class(row_facet, "picks", null.ok = TRUE) + if (isTRUE(attr(row_facet$variables, "multiple"))) { + warning("`row_facet` accepts only a single variable selection. Forcing `teal.transform::variables(multiple) to FALSE`") + attr(row_facet$variables, "multiple") <- FALSE + } + + checkmate::assert_class(col_facet, "picks", null.ok = TRUE) + if (isTRUE(attr(col_facet$variables, "multiple"))) { + warning("`col_facet` accepts only a single variable selection. Forcing `teal.transform::variables(multiple) to FALSE`") + attr(col_facet$variables, "multiple") <- FALSE + } + + checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE) + checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height") + checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE) + checkmate::assert_numeric( + plot_width[1], + lower = plot_width[2], upper = plot_width[3], null.ok = TRUE, .var.name = "plot_width" + ) + + if (length(alpha) == 1) { + checkmate::assert_numeric(alpha, any.missing = FALSE, finite = TRUE) + } else { + checkmate::assert_numeric(alpha, len = 3, any.missing = FALSE, finite = TRUE) + checkmate::assert_numeric(alpha[1], lower = alpha[2], upper = alpha[3], .var.name = "alpha") + } + + checkmate::assert_character(shape) + + if (length(size) == 1) { + checkmate::assert_numeric(size, any.missing = FALSE, finite = TRUE) + } else { + checkmate::assert_numeric(size, len = 3, any.missing = FALSE, finite = TRUE) + checkmate::assert_numeric(size[1], lower = size[2], upper = size[3], .var.name = "size") + } + + checkmate::assert_int(max_deg, lower = 1L) + checkmate::assert_flag(rotate_xaxis_labels) + ggtheme <- match.arg(ggtheme) + + 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_scalar(table_dec) + checkmate::assert_class(ggplot2_args, "ggplot2_args") + + assert_decorators(decorators, "plot") + + # End of assertions + + # Make UI args + args <- as.list(environment()) + ans <- module( + label = label, + server = srv_g_scatterplot.picks, + ui = ui_g_scatterplot.picks, + ui_args = args[names(args) %in% names(formals(ui_g_scatterplot.picks))], + server_args = args[names(args) %in% names(formals(srv_g_scatterplot.picks))], + transformators = transformators, + datanames = .picks_datanames(list(x, y, color_by, size_by, row_facet, col_facet)) + ) + attr(ans, "teal_bookmarkable") <- TRUE + ans +} + +# UI function for the scatterplot module +ui_g_scatterplot.picks <- function(id, + x, + y, + color_by, + size_by, + row_facet, + col_facet, + alpha, + shape, + color, + size, + rotate_xaxis_labels, + max_deg, + ggtheme, + pre_output, + post_output, + decorators) { + ns <- NS(id) + tagList( + teal.widgets::standard_layout( + output = teal.widgets::white_small_well( + teal.widgets::plot_with_settings_ui(id = ns("scatter_plot")), + tags$br(), + tags$h1(tags$strong("Selected points:"), style = "font-size: 150%;"), + teal.widgets::get_dt_rows(ns("data_table"), ns("data_table_rows")), + DT::dataTableOutput(ns("data_table"), width = "100%") + ), + encoding = tags$div( + tags$label("Encodings", class = "text-primary"), + tags$div( + tags$strong("X variable"), + teal.transform::picks_ui(id = ns("x"), picks = x), + checkboxInput(ns("log_x"), "Use log transformation", value = FALSE), + conditionalPanel( + condition = paste0("input['", ns("log_x"), "'] == true"), + radioButtons( + ns("log_x_base"), + label = NULL, + inline = TRUE, + choices = c("Natural" = "log", "Base 10" = "log10", "Base 2" = "log2") + ) + ) + ), + tags$div( + tags$strong("Y variable"), + teal.transform::picks_ui(id = ns("y"), picks = y), + checkboxInput(ns("log_y"), "Use log transformation", value = FALSE), + conditionalPanel( + condition = paste0("input['", ns("log_y"), "'] == true"), + radioButtons( + ns("log_y_base"), + label = NULL, + inline = TRUE, + choices = c("Natural" = "log", "Base 10" = "log10", "Base 2" = "log2") + ) + ) + ), + if (!is.null(color_by)) { + tags$div( + tags$strong("Color by:"), + teal.transform::picks_ui(id = ns("color_by"), picks = color_by) + ) + }, + if (!is.null(size_by)) { + tags$div( + tags$strong("Size by:"), + teal.transform::picks_ui(id = ns("size_by"), picks = size_by) + ) + }, + if (!is.null(row_facet)) { + tags$div( + tags$strong("Row facetting"), + teal.transform::picks_ui(id = ns("row_facet"), picks = row_facet) + ) + }, + if (!is.null(col_facet)) { + tags$div( + tags$strong("Column facetting"), + teal.transform::picks_ui(id = ns("col_facet"), picks = col_facet) + ) + }, + ui_decorate_teal_data(ns("decorator"), decorators = select_decorators(decorators, "plot")), + bslib::accordion( + open = TRUE, + bslib::accordion_panel( + title = "Plot settings", + teal.widgets::optionalSliderInputValMinMax(ns("alpha"), "Opacity:", alpha, ticks = FALSE), + teal.widgets::optionalSelectInput( + inputId = ns("shape"), + label = "Points shape:", + choices = shape, + selected = shape[1], + multiple = FALSE + ), + colourpicker::colourInput(ns("color"), "Points color:", "black"), + teal.widgets::optionalSliderInputValMinMax(ns("size"), "Points size:", size, ticks = FALSE, step = .1), + checkboxInput(ns("rotate_xaxis_labels"), "Rotate X axis labels", value = rotate_xaxis_labels), + checkboxInput(ns("add_density"), "Add marginal density", value = FALSE), + checkboxInput(ns("rug_plot"), "Include rug plot", value = FALSE), + checkboxInput(ns("show_count"), "Show N (number of observations)", value = FALSE), + shinyjs::hidden(helpText(id = ns("line_msg"), "Trendline needs numeric X and Y variables")), + teal.widgets::optionalSelectInput(ns("smoothing_degree"), "Smoothing degree", seq_len(max_deg)), + shinyjs::hidden(teal.widgets::optionalSelectInput(ns("color_sub"), label = "", multiple = TRUE)), + teal.widgets::optionalSliderInputValMinMax(ns("ci"), "Confidence", c(.95, .8, .99), ticks = FALSE), + shinyjs::hidden(checkboxInput(ns("show_form"), "Show formula", value = TRUE)), + shinyjs::hidden(checkboxInput(ns("show_r2"), "Show adj-R Squared", value = TRUE)), + uiOutput(ns("num_na_removed")), + tags$div( + id = ns("label_pos"), + tags$div(tags$strong("Stats position")), + tags$div(style = "display: inline-block; width: 70%;", helpText("Left")), + tags$div( + style = "display: inline-block; width: 70%;", + teal.widgets::optionalSliderInput( + ns("pos"), + label = NULL, + min = 0, max = 1, value = .99, ticks = FALSE, step = .01 + ) + ), + tags$div(style = "display: inline-block; width: 10%;", helpText("Right")) + ), + teal.widgets::optionalSliderInput( + ns("label_size"), "Stats font size", + min = 3, max = 10, value = 5, ticks = FALSE, step = .1 + ), + if (!is.null(row_facet) || !is.null(col_facet)) { + checkboxInput(ns("free_scales"), "Free scales", value = FALSE) + }, + selectInput( + inputId = ns("ggtheme"), + label = "Theme (by ggplot):", + choices = ggplot_themes, + selected = ggtheme, + multiple = FALSE + ) + ) + ) + ), + pre_output = pre_output, + post_output = post_output + ) + ) +} + +# Server function for the scatterplot module +srv_g_scatterplot.picks <- function(id, + data, + x, + y, + color_by, + size_by, + row_facet, + col_facet, + plot_height, + plot_width, + table_dec, + ggplot2_args, + decorators) { + checkmate::assert_class(data, "reactive") + checkmate::assert_class(isolate(data()), "teal_data") + moduleServer(id, function(input, output, session) { + teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.general") + + + selectors <- teal.transform::picks_srv( + picks = list(x = x, y = y, color_by = color_by, size_by = size_by, row_facet = row_facet, col_facet = col_facet), + data = data + ) + + + validated_q <- reactive({ + validate_input( + inputId = "x-variables-selected", + condition = length(selectors$x()$variables$selected) == 1, + message = "Please select exactly one x var." + ) + validate_input( + inputId = "y-variables-selected", + condition = length(selectors$y()$variables$selected) == 1, + message = "Please select exactly one y var." + ) + validate_input( + inputId = c("x-variables-selected", "y-variables-selected"), + condition = !any(selectors$x()$variables$selected %in% selectors$y()$variables$selected), + message = "X and Y variables must be different." + ) + validate_input( + inputId = "row_facet-variables-selected", + condition = is.null(row_facet) || length(selectors$row_facet()$variables$selected) < 2, + message = "Only single Row Facetting variable is allowed." + ) + validate_input( + inputId = "col_facet-variables-selected", + condition = is.null(col_facet) || length(selectors$col_facet()$variables$selected) < 2, + message = "Only single Column Facetting variable is allowed." + ) + validate_input( + inputId = c("row_facet-variables-selected", "col_facet-variables-selected"), + condition = is.null(row_facet) || !is.null(col_facet) || + !any(selectors$row_facet()$variables$selected %in% selectors$col_facet()$variables$selected), + message = "Row and Column Facetting variables must be different." + ) + validate_input( + "add_density", + condition = !(is.null(input$add_density) && + (length(selectors$row_facet()$variables$selected) || length(selectors$col_facet()$variables$selected)) + ), + message = "Cannot add marginal density when Row or Column facetting has been selected" + ) + obj <- req(data()) + teal.reporter::teal_card(obj) <- + c( + teal.reporter::teal_card("# Scatter Plot"), + teal.reporter::teal_card(obj), + teal.reporter::teal_card("## Module's code") + ) + teal.code::eval_code(obj, 'library("ggplot2");library("dplyr");') + }) + + merged <- teal.transform::merge_srv("merge", data = validated_q, selectors = selectors, output_name = "anl") + + trend_line_is_applicable <- reactive({ + anl <- merged$data()[["anl"]] + x_var <- merged$variables()$x + y_var <- merged$variables()$y + length(x_var) > 0 && length(y_var) > 0 && is.numeric(anl[[x_var]]) && is.numeric(anl[[y_var]]) + }) + + add_trend_line <- reactive({ + smoothing_degree <- as.integer(input$smoothing_degree) + trend_line_is_applicable() && length(smoothing_degree) > 0 + }) + + observeEvent( + eventExpr = selectors$color_by(), + handlerExpr = { + color_by_var <- merged$variables()$color_by + if (length(color_by_var) > 0) { + shinyjs::hide("color") + } else { + shinyjs::show("color") + } + } + ) + + output$num_na_removed <- renderUI({ + if (add_trend_line()) { + anl <- merged$data()[["anl"]] + x_var <- merged$variables()$x + y_var <- merged$variables()$y + if ((num_total_na <- nrow(anl) - nrow(stats::na.omit(anl[, c(x_var, y_var)]))) > 0) { + tags$div(paste(num_total_na, "row(s) with missing values were removed"), tags$hr()) + } + } + }) + + observeEvent( + eventExpr = list(selectors$row_facet(), selectors$col_facet()), + handlerExpr = { + if ( + length(merged$variables()$row_facet) == 0 && + length(merged$variables()$col_facet) == 0 + ) { + shinyjs::hide("free_scales") + } else { + shinyjs::show("free_scales") + } + } + ) + + output_q <- reactive({ + req(merged$data()) + anl <- merged$data()[["anl"]] + x_var <- merged$variables()$x + y_var <- merged$variables()$y + color_by_var <- merged$variables()$color_by + size_by_var <- merged$variables()$size_by + row_facet_var <- merged$variables()$row_facet + col_facet_var <- merged$variables()$col_facet + alpha <- input$alpha + size <- input$size + rotate_xaxis_labels <- input$rotate_xaxis_labels + add_density <- input$add_density + ggtheme <- input$ggtheme + rug_plot <- input$rug_plot + color <- input$color + shape <- `if`(is.null(input$shape) || identical(input$shape, ""), "circle", input$shape) + smoothing_degree <- as.integer(input$smoothing_degree) + ci <- input$ci + + log_x <- input$log_x + log_y <- input$log_y + + validate_input( + inputId = "row_facet-variables-selected", + condition = length(col_facet_var) == 0 || + inherits(anl[[row_facet_var]], c("character", "factor", "Date", "integer")), + message = "`Row facetting` variable must be of class `character`, `factor`, `Date`, or `integer`" + ) + validate_input( + inputId = "col_facet-variables-selected", + condition = length(col_facet_var) == 0 || + inherits(anl[[col_facet_var]], c("character", "factor", "Date", "integer")), + message = "`Column facetting` variable must be of class `character`, `factor`, `Date`, or `integer`" + ) + + + if (add_density && length(color_by_var) > 0) { + validate_input( + inputId = "col_facet-variables-selected", + condition = !is.numeric(anl[[color_by_var]]), + message = paste0( + "Marginal plots cannot be produced when the points are colored by numeric variables.", + "\nUncheck the 'Add marginal density' checkbox to display the plot." + ) + ) + validate_input( + "color_by-variables-selected", + condition = !( + inherits(anl[[color_by_var]], "Date") || + inherits(anl[[color_by_var]], "POSIXct") || + inherits(anl[[color_by_var]], "POSIXlt") + ), + message = paste0( + "Marginal plots cannot be produced when the points are colored by Date or POSIX variables.", + "\n Uncheck the 'Add marginal density' checkbox to display the plot." + ) + ) + } + + teal::validate_has_data(anl[, c(x_var, y_var)], 1, complete = TRUE, allow_inf = FALSE) + + if (log_x) { + validate_input( + "x-variables-selected", + condition = is.numeric(anl[[x_var]]) && all(anl[[x_var]] > 0 | is.na(anl[[x_var]])), + nessage = "X variable can only be log transformed if variable is numeric and all values are positive." + ) + } + if (log_y) { + validate_input( + "y-variables-selected", + condition = is.numeric(anl[[y_var]]) && all(anl[[y_var]] > 0 | is.na(anl[[y_var]])), + message = "Y variable can only be log transformed if variable is numeric and all values are positive." + ) + } + + point_sizes <- if (length(size_by_var) > 0) { + validate(need(is.numeric(anl[[size_by_var]]), "Variable to size by must be numeric")) + substitute( + expr = size * anl[[size_by_var]] / max(anl[[size_by_var]], na.rm = TRUE), + env = list(size = size, size_by_var = size_by_var) + ) + } else { + size + } + + plot_q <- merged$data() + + if (log_x) { + log_x_fn <- input$log_x_base + plot_q <- teal.code::eval_code( + object = plot_q, + code = substitute( + expr = anl[, log_x_var] <- log_x_fn(anl[, x_var]), + env = list( + x_var = x_var, + log_x_fn = as.name(log_x_fn), + log_x_var = paste0(log_x_fn, "_", x_var) + ) + ) + ) + } + + if (log_y) { + log_y_fn <- input$log_y_base + plot_q <- teal.code::eval_code( + object = plot_q, + code = substitute( + expr = anl[, log_y_var] <- log_y_fn(anl[, y_var]), + env = list( + y_var = y_var, + log_y_fn = as.name(log_y_fn), + log_y_var = paste0(log_y_fn, "_", y_var) + ) + ) + ) + } + + group_anl_call <- if (input$show_count) { + paste0( + "anl %>% dplyr::group_by(", + paste( + c( + if (length(color_by_var) > 0 && inherits(anl[[color_by_var]], c("factor", "character"))) color_by_var, + row_facet_var, + col_facet_var + ), + collapse = ", " + ), + ") %>% dplyr::mutate(n = dplyr::n()) %>% dplyr::ungroup()" + ) + } else { + "anl" + } + + plot_call <- substitute( + expr = group_anl_call %>% ggplot2::ggplot(), + env = list(group_anl_call = str2lang(group_anl_call)) + ) + + plot_call <- if (length(color_by_var) == 0) { + substitute( + expr = plot_call + + ggplot2::aes(x = x_name, y = y_name) + + ggplot2::geom_point(alpha = alpha_value, size = point_sizes, shape = shape_value, color = color_value), + env = list( + plot_call = plot_call, + x_name = if (log_x) as.name(paste0(log_x_fn, "_", x_var)) else as.name(x_var), + y_name = if (log_y) as.name(paste0(log_y_fn, "_", y_var)) else as.name(y_var), + alpha_value = alpha, + point_sizes = point_sizes, + shape_value = shape, + color_value = color + ) + ) + } else { + substitute( + expr = plot_call + + ggplot2::aes(x = x_name, y = y_name, color = color_by_var_name) + + ggplot2::geom_point(alpha = alpha_value, size = point_sizes, shape = shape_value), + env = list( + plot_call = plot_call, + x_name = if (log_x) as.name(paste0(log_x_fn, "_", x_var)) else as.name(x_var), + y_name = if (log_y) as.name(paste0(log_y_fn, "_", y_var)) else as.name(y_var), + color_by_var_name = as.name(color_by_var), + alpha_value = alpha, + point_sizes = point_sizes, + shape_value = shape + ) + ) + } + + if (rug_plot) plot_call <- substitute(expr = plot_call + geom_rug(), env = list(plot_call = plot_call)) + + plot_label_generator <- function(rhs_formula = quote(y ~ 1), + show_form = input$show_form, + show_r2 = input$show_r2, + show_count = input$show_count, + pos = input$pos, + label_size = input$label_size) { + stopifnot(sum(show_form, show_r2, show_count) >= 1) + aes_label <- paste0( + "aes(", + if (show_count) "n = n, ", + "label = ", + if (sum(show_form, show_r2, show_count) > 1) "paste(", + paste( + c( + if (show_form) "stat(eq.label)", + if (show_r2) "stat(adj.rr.label)", + if (show_count) "paste('N ~`=`~', n)" + ), + collapse = ", " + ), + if (sum(show_form, show_r2, show_count) > 1) ", sep = '*\", \"*'))" else ")" + ) + label_geom <- substitute( + expr = ggpmisc::stat_poly_eq( + mapping = aes_label, + formula = rhs_formula, + parse = TRUE, + label.x = pos, + size = label_size + ), + env = list( + rhs_formula = rhs_formula, + pos = pos, + aes_label = str2lang(aes_label), + label_size = label_size + ) + ) + substitute( + expr = plot_call + label_geom, + env = list( + plot_call = plot_call, + label_geom = label_geom + ) + ) + } + + if (trend_line_is_applicable()) { + shinyjs::hide("line_msg") + shinyjs::show("smoothing_degree") + if (!add_trend_line()) { + shinyjs::hide("ci") + shinyjs::hide("color_sub") + shinyjs::hide("show_form") + shinyjs::hide("show_r2") + if (input$show_count) { + plot_call <- plot_label_generator(show_form = FALSE, show_r2 = FALSE) + shinyjs::show("label_pos") + shinyjs::show("label_size") + } else { + shinyjs::hide("label_pos") + shinyjs::hide("label_size") + } + } else { + shinyjs::show("ci") + shinyjs::show("show_form") + shinyjs::show("show_r2") + if (nrow(anl) - nrow(stats::na.omit(anl[, c(x_var, y_var)])) > 0) { + plot_q <- teal.code::eval_code( + plot_q, + substitute( + expr = anl <- dplyr::filter(anl, !is.na(x_var) & !is.na(y_var)), + env = list(x_var = as.name(x_var), y_var = as.name(y_var)) + ) + ) + } + rhs_formula <- substitute( + expr = y ~ poly(x, smoothing_degree, raw = TRUE), + env = list(smoothing_degree = smoothing_degree) + ) + if (input$show_form || input$show_r2 || input$show_count) { + plot_call <- plot_label_generator(rhs_formula = rhs_formula) + shinyjs::show("label_pos") + shinyjs::show("label_size") + } else { + shinyjs::hide("label_pos") + shinyjs::hide("label_size") + } + plot_call <- substitute( + expr = plot_call + ggplot2::geom_smooth(formula = rhs_formula, se = TRUE, level = ci, method = "lm"), + env = list(plot_call = plot_call, rhs_formula = rhs_formula, ci = ci) + ) + } + } else { + shinyjs::hide("smoothing_degree") + shinyjs::hide("ci") + shinyjs::hide("color_sub") + shinyjs::hide("show_form") + shinyjs::hide("show_r2") + if (input$show_count) { + plot_call <- plot_label_generator(show_form = FALSE, show_r2 = FALSE) + shinyjs::show("label_pos") + shinyjs::show("label_size") + } else { + shinyjs::hide("label_pos") + shinyjs::hide("label_size") + } + shinyjs::show("line_msg") + } + + if (length(row_facet_var) || length(col_facet_var)) { + facet_cl <- facet_ggplot_call( + row_facet_var, + col_facet_var, + free_x_scales = isTRUE(input$free_scales), + free_y_scales = isTRUE(input$free_scales) + ) + plot_call <- substitute(expr = plot_call + facet_cl, env = list(plot_call = plot_call, facet_cl = facet_cl)) + } + + y_label <- varname_w_label( + y_var, + anl, + prefix = if (log_y) paste(log_y_fn, "(") else NULL, + suffix = if (log_y) ")" else NULL + ) + x_label <- varname_w_label( + x_var, + anl, + prefix = if (log_x) paste(log_x_fn, "(") else NULL, + suffix = if (log_x) ")" else NULL + ) + + dev_ggplot2_args <- teal.widgets::ggplot2_args( + labs = list(y = y_label, x = x_label), + theme = list(legend.position = "bottom") + ) + + if (rotate_xaxis_labels) { + dev_ggplot2_args$theme[["axis.text.x"]] <- quote(ggplot2::element_text(angle = 45, hjust = 1)) + } + + all_ggplot2_args <- teal.widgets::resolve_ggplot2_args( + user_plot = ggplot2_args, + module_plot = dev_ggplot2_args + ) + + parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(all_ggplot2_args, ggtheme = ggtheme) + + + if (add_density) { + plot_call <- substitute( + expr = ggExtra::ggMarginal( + plot_call + labs + ggthemes + themes, + type = "density", + groupColour = group_colour + ), + env = list( + plot_call = plot_call, + group_colour = if (length(color_by_var) > 0) TRUE else FALSE, + labs = parsed_ggplot2_args$labs, + ggthemes = parsed_ggplot2_args$ggtheme, + themes = parsed_ggplot2_args$theme + ) + ) + } else { + plot_call <- substitute( + expr = plot_call + + labs + + ggthemes + + themes, + env = list( + plot_call = plot_call, + labs = parsed_ggplot2_args$labs, + ggthemes = parsed_ggplot2_args$ggtheme, + themes = parsed_ggplot2_args$theme + ) + ) + } + + plot_call <- substitute(expr = plot <- plot_call, env = list(plot_call = plot_call)) + + teal.reporter::teal_card(plot_q) <- c(teal.reporter::teal_card(plot_q), "## Plot") + teal.code::eval_code(plot_q, plot_call) + }) + + decorated_output_plot_q <- srv_decorate_teal_data( + id = "decorator", + data = output_q, + decorators = select_decorators(decorators, "plot"), + expr = quote(plot) + ) + + plot_r <- reactive(req(decorated_output_plot_q())[["plot"]]) + + # Insert the plot into a plot_with_settings module from teal.widgets + pws <- teal.widgets::plot_with_settings_srv( + id = "scatter_plot", + plot_r = plot_r, + height = plot_height, + width = plot_width, + brushing = TRUE, + click = TRUE + ) + + output$data_table <- DT::renderDataTable({ + plot_brush <- pws$brush() + + if (!is.null(plot_brush)) { + validate(need(!input$add_density, "Brushing feature is currently not supported when plot has marginal density")) + } + + merged_data <- isolate(output_q()[["anl"]]) + + brushed_df <- teal.widgets::clean_brushedPoints(merged_data, plot_brush) + numeric_cols <- names(brushed_df)[ + vapply(brushed_df, function(x) is.numeric(x) && !is.integer(x), FUN.VALUE = logical(1)) + ] + + if (length(numeric_cols) > 0) { + DT::formatRound( + DT::datatable(brushed_df, + rownames = FALSE, + options = list(scrollX = TRUE, pageLength = input$data_table_rows) + ), + numeric_cols, + table_dec + ) + } else { + DT::datatable(brushed_df, rownames = FALSE, options = list(scrollX = TRUE, pageLength = input$data_table_rows)) + } + }) + + set_chunk_dims(pws, decorated_output_plot_q) + }) +} diff --git a/R/tm_g_scatterplotmatrix.R b/R/tm_g_scatterplotmatrix.R index 1d7a2eb08..421ab2179 100644 --- a/R/tm_g_scatterplotmatrix.R +++ b/R/tm_g_scatterplotmatrix.R @@ -11,9 +11,9 @@ #' @inheritParams tm_g_scatterplot #' @inheritParams shared_params #' -#' @param variables (`data_extract_spec` or `list` of multiple `data_extract_spec`) +#' @param variables (`picks` or `list` of `picks`) #' Specifies plotting variables from an incoming dataset with filtering and selecting. In case of -#' `data_extract_spec` use `select_spec(..., ordered = TRUE)` if plot elements should be +#' `picks` use `teal.transform::variables(..., ordered = TRUE)` if plot elements should be #' rendered according to selection order. #' #' @inherit shared_params return @@ -94,33 +94,32 @@ #' tm_g_scatterplotmatrix( #' label = "Scatterplot matrix", #' variables = list( -#' data_extract_spec( -#' dataname = "countries", -#' select = select_spec( -#' label = "Select variables:", -#' choices = variable_choices(data[["countries"]]), +#' teal.transform::picks( +#' datasets("countries"), +#' teal.transform::variables( +#' choices = tidyselect::everything(), #' selected = c("area", "gdp", "debt"), #' multiple = TRUE, -#' ordered = TRUE, -#' fixed = FALSE -#' ) -#' ), -#' data_extract_spec( -#' dataname = "sales", -#' filter = filter_spec( -#' label = "Select variable:", -#' vars = "country_id", -#' choices = value_choices(data[["sales"]], "country_id"), -#' selected = c("DE", "FR", "IT", "PT", "GR", "NL", "BE", "LU", "AT"), -#' multiple = TRUE +#' ordered = TRUE #' ), -#' select = select_spec( -#' label = "Select variables:", -#' choices = variable_choices(data[["sales"]], c("quantity", "costs", "profit")), +#' teal.transform::values() +#' ), +#' teal.transform::picks( +#' datasets("sales"), +#' teal.transform::variables( +#' choices = c("quantity", "costs", "profit"), #' selected = c("quantity", "costs", "profit"), #' multiple = TRUE, -#' ordered = TRUE, -#' fixed = FALSE +#' ordered = TRUE +#' ) +#' ) +#' ), +#' transformators = list( +#' teal_transform_filter( +#' teal.transform::picks( +#' datasets("sales"), +#' teal.transform::variables("country_id"), +#' teal.transform::values() #' ) #' ) #' ) @@ -150,35 +149,30 @@ #' tm_g_scatterplotmatrix( #' label = "Scatterplot matrix", #' variables = list( -#' data_extract_spec( -#' dataname = "ADSL", -#' select = select_spec( -#' label = "Select variables:", -#' choices = variable_choices(data[["ADSL"]]), +#' teal.transform::picks( +#' datasets("ADSL"), +#' teal.transform::variables( +#' choices = tidyselect::everything(), #' selected = c("AGE", "RACE", "SEX"), #' multiple = TRUE, #' ordered = TRUE, #' fixed = FALSE -#' ) -#' ), -#' data_extract_spec( -#' dataname = "ADRS", -#' filter = filter_spec( -#' label = "Select endpoints:", -#' vars = c("PARAMCD", "AVISIT"), -#' choices = value_choices(data[["ADRS"]], c("PARAMCD", "AVISIT"), c("PARAM", "AVISIT")), -#' selected = "INVET - END OF INDUCTION", -#' multiple = TRUE #' ), -#' select = select_spec( -#' label = "Select variables:", -#' choices = variable_choices(data[["ADRS"]]), +#' teal.transform::values() +#' ), +#' teal.transform::picks( +#' datasets("ADRS"), +#' teal.transform::variables( +#' choices = tidyselect::everything(), #' selected = c("AGE", "AVAL", "ADY"), #' multiple = TRUE, #' ordered = TRUE, #' fixed = FALSE #' ) #' ) +#' ), +#' transformators = list( +#' teal_transform_filter(teal.transform::picks(datasets("ADRS"), teal.transform::variables("PARAMCD"), values(selected = "BESRSPI"))) #' ) #' ) #' ) @@ -188,15 +182,31 @@ #' } #' #' @export -#' tm_g_scatterplotmatrix <- function(label = "Scatterplot Matrix", - variables, + variables = list( + teal.transform::picks( + teal.transform::datasets(), + teal.transform::variables(selected = seq(1L, 5L), multiple = TRUE) + ) + ), plot_height = c(600, 200, 2000), plot_width = NULL, pre_output = NULL, post_output = NULL, transformators = list(), decorators = list()) { + UseMethod("tm_g_scatterplotmatrix", variables[[1]]) +} + +#' @export +tm_g_scatterplotmatrix.default <- function(label = "Scatterplot Matrix", + variables, + plot_height = c(600, 200, 2000), + plot_width = NULL, + pre_output = NULL, + post_output = NULL, + transformators = list(), + decorators = list()) { message("Initializing tm_g_scatterplotmatrix") # Normalize the parameters @@ -225,8 +235,8 @@ tm_g_scatterplotmatrix <- function(label = "Scatterplot Matrix", ans <- module( label = label, - server = srv_g_scatterplotmatrix, - ui = ui_g_scatterplotmatrix, + server = srv_g_scatterplotmatrix.default, + ui = ui_g_scatterplotmatrix.default, ui_args = args, server_args = list( variables = variables, @@ -242,7 +252,7 @@ tm_g_scatterplotmatrix <- function(label = "Scatterplot Matrix", } # UI function for the scatterplot matrix module -ui_g_scatterplotmatrix <- function(id, ...) { +ui_g_scatterplotmatrix.default <- function(id, ...) { args <- list(...) is_single_dataset_value <- teal.transform::is_single_dataset(args$variables) ns <- NS(id) @@ -294,12 +304,12 @@ ui_g_scatterplotmatrix <- function(id, ...) { } # Server function for the scatterplot matrix module -srv_g_scatterplotmatrix <- function(id, - data, - variables, - plot_height, - plot_width, - decorators) { +srv_g_scatterplotmatrix.default <- function(id, + data, + variables, + plot_height, + plot_width, + decorators) { checkmate::assert_class(data, "reactive") checkmate::assert_class(isolate(data()), "teal_data") moduleServer(id, function(input, output, session) { diff --git a/R/tm_g_scatterplotmatrix_picks.R b/R/tm_g_scatterplotmatrix_picks.R new file mode 100644 index 000000000..e4112820c --- /dev/null +++ b/R/tm_g_scatterplotmatrix_picks.R @@ -0,0 +1,377 @@ +#' @export +tm_g_scatterplotmatrix.picks <- function(label = "Scatterplot Matrix", + variables = list( + teal.transform::picks( + teal.transform::datasets(), + teal.transform::variables(selected = seq(1L, 5L), multiple = TRUE) + ) + ), + plot_height = c(600, 200, 2000), + plot_width = NULL, + pre_output = NULL, + post_output = NULL, + transformators = list(), + decorators = list()) { + message("Initializing tm_g_scatterplotmatrix") + if (is.null(names(variables))) { + names(variables) <- sprintf("pick_%s", seq_along(variables)) + } + + # Start of assertions + checkmate::assert_string(label) + checkmate::assert_list(variables, types = "picks", names = "named") + + checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE) + checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height") + checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE) + checkmate::assert_numeric( + plot_width[1], + lower = plot_width[2], upper = plot_width[3], null.ok = TRUE, .var.name = "plot_width" + ) + + 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) + + assert_decorators(decorators, "plot") + # End of assertions + + args <- as.list(environment()) + ans <- module( + label = label, + ui = ui_g_scatterplotmatrix.picks, + server = srv_g_scatterplotmatrix.picks, + ui_args = args[names(args) %in% names(formals(ui_g_scatterplotmatrix.picks))], + server_args = args[names(args) %in% names(formals(srv_g_scatterplotmatrix.picks))], + transformators = transformators, + datanames = .picks_datanames(variables) + ) + attr(ans, "teal_bookmarkable") <- TRUE + ans +} + +# UI function for the scatterplot matrix module +ui_g_scatterplotmatrix.picks <- function(id, + variables, + pre_output, + post_output, + decorators) { + checkmate::assert_list(variables, "picks", names = "named") + ns <- NS(id) + teal.widgets::standard_layout( + output = teal.widgets::white_small_well( + textOutput(ns("message")), + tags$br(), + teal.widgets::plot_with_settings_ui(id = ns("myplot")) + ), + encoding = tags$div( + tags$label("Encodings", class = "text-primary"), + tagList( + lapply(names(variables), function(id) { + tags$div( + teal.transform::picks_ui(id = ns(id), picks = variables[[id]]) + ) + }) + ), + tags$hr(), + ui_decorate_teal_data(ns("decorator"), decorators = select_decorators(decorators, "plot")), + bslib::accordion( + open = TRUE, + bslib::accordion_panel( + title = "Plot settings", + sliderInput( + ns("alpha"), "Opacity:", + min = 0, max = 1, + step = .05, value = .5, ticks = FALSE + ), + sliderInput( + ns("cex"), "Points size:", + min = 0.2, max = 3, + step = .05, value = .65, ticks = FALSE + ), + checkboxInput(ns("cor"), "Add Correlation", value = FALSE), + radioButtons( + ns("cor_method"), "Select Correlation Method", + choiceNames = c("Pearson", "Kendall", "Spearman"), + choiceValues = c("pearson", "kendall", "spearman"), + inline = TRUE + ), + checkboxInput(ns("cor_na_omit"), "Omit Missing Values", value = TRUE) + ) + ) + ), + pre_output = pre_output, + post_output = post_output + ) +} + +# Server function for the scatterplot matrix module +srv_g_scatterplotmatrix.picks <- function(id, + data, + variables, + plot_height, + plot_width, + decorators) { + checkmate::assert_class(data, "reactive") + checkmate::assert_class(isolate(data()), "teal_data") + checkmate::assert_list(variables, "picks", names = "named") + + moduleServer(id, function(input, output, session) { + teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.general") + + selectors <- teal.transform::picks_srv( + picks = variables, + data = data + ) + + validated_q <- reactive({ + obj <- req(data()) + input_ids <- sprintf("%s-variables-selected", names(variables)) + selected_variables <- unname(unlist(lapply(selectors, function(selector) selector()$variables$selected))) + validate_input( + inputId = input_ids, # validate all inputs where variable can be selected + condition = length(selected_variables) > 1, + message = "Please select at least 2 columns" + ) + + teal.reporter::teal_card(obj) <- c( + teal.reporter::teal_card("# Scatter Plot Matrix"), + teal.reporter::teal_card(obj), + teal.reporter::teal_card("## Module's code") + ) + teal.code::eval_code(obj, 'library("ggplot2");library("dplyr");') + }) + + merged <- teal.transform::merge_srv("merge", data = validated_q, selectors = selectors, output_name = "anl") + + # plot + output_q <- reactive({ + qenv <- req(merged$data()) + anl <- qenv[["anl"]] + cols_names <- unname(unlist(merged$variables())) + alpha <- input$alpha + cex <- input$cex + add_cor <- input$cor + cor_method <- input$cor_method + cor_na_omit <- input$cor_na_omit + + cor_na_action <- if (isTruthy(cor_na_omit)) { + "na.omit" + } else { + "na.fail" + } + + teal::validate_has_data(anl, 10) + teal::validate_has_data(anl[, cols_names, drop = FALSE], 10, complete = TRUE, allow_inf = FALSE) + + # get labels and proper variable names + varnames <- varname_w_label(cols_names, anl, wrap_width = 20) + + # check character columns. If any, then those are converted to factors + check_char <- vapply(anl[, cols_names], is.character, logical(1)) + if (any(check_char)) { + qenv <- teal.code::eval_code( + qenv, + substitute( + expr = anl <- anl[, cols_names] %>% + dplyr::mutate_if(is.character, as.factor) %>% + droplevels(), + env = list(cols_names = cols_names) + ) + ) + } else { + qenv <- teal.code::eval_code( + qenv, + substitute( + expr = anl <- anl[, cols_names] %>% + droplevels(), + env = list(cols_names = cols_names) + ) + ) + } + + + # create plot + teal.reporter::teal_card(qenv) <- c(teal.reporter::teal_card(qenv), "## Plot") + + if (add_cor) { + shinyjs::show("cor_method") + shinyjs::show("cor_use") + shinyjs::show("cor_na_omit") + + qenv <- teal.code::eval_code( + qenv, + substitute( + expr = { + plot <- lattice::splom( + anl, + varnames = varnames_value, + panel = function(x, y, ...) { + lattice::panel.splom(x = x, y = y, ...) + cpl <- lattice::current.panel.limits() + lattice::panel.text( + mean(cpl$xlim), + mean(cpl$ylim), + get_scatterplotmatrix_stats( + x, + y, + .f = stats::cor.test, + .f_args = list(method = cor_method, na.action = cor_na_action) + ), + alpha = 0.6, + fontsize = 18, + fontface = "bold" + ) + }, + pch = 16, + alpha = alpha_value, + cex = cex_value + ) + }, + env = list( + varnames_value = varnames, + cor_method = cor_method, + cor_na_action = cor_na_action, + alpha_value = alpha, + cex_value = cex + ) + ) + ) + } else { + shinyjs::hide("cor_method") + shinyjs::hide("cor_use") + shinyjs::hide("cor_na_omit") + qenv <- teal.code::eval_code( + qenv, + substitute( + expr = { + plot <- lattice::splom( + anl, + varnames = varnames_value, + pch = 16, + alpha = alpha_value, + cex = cex_value + ) + }, + env = list(varnames_value = varnames, alpha_value = alpha, cex_value = cex) + ) + ) + } + qenv + }) + + decorated_output_q <- srv_decorate_teal_data( + id = "decorator", + data = output_q, + decorators = select_decorators(decorators, "plot"), + expr = quote(plot) + ) + + plot_r <- reactive(req(decorated_output_q())[["plot"]]) + + # Insert the plot into a plot_with_settings module + pws <- teal.widgets::plot_with_settings_srv( + id = "myplot", + plot_r = plot_r, + height = plot_height, + width = plot_width + ) + + # show a message if conversion to factors took place + output$message <- renderText({ + cols_names <- req(unname(unlist(merged$variables()))) + anl <- merged$data()[["anl"]] + check_char <- vapply(anl[, cols_names], is.character, logical(1)) + if (any(check_char)) { + is_single <- sum(check_char) == 1 + paste( + "Character", + ifelse(is_single, "variable", "variables"), + paste0("(", paste(cols_names[check_char], collapse = ", "), ")"), + ifelse(is_single, "was", "were"), + "converted to", + ifelse(is_single, "factor.", "factors.") + ) + } else { + "" + } + }) + + set_chunk_dims(pws, decorated_output_q) + }) +} + +#' Get stats for x-y pairs in scatterplot matrix +#' +#' Uses [stats::cor.test()] per default for all numerical input variables and converts results +#' to character vector. +#' Could be extended if different stats for different variable types are needed. +#' Meant to be called from [lattice::panel.text()]. +#' +#' Presently we need to use a formula input for `stats::cor.test` because +#' `na.fail` only gets evaluated when a formula is passed (see below). +#' ``` +#' x = c(1,3,5,7,NA) +#' y = c(3,6,7,8,1) +#' stats::cor.test(x, y, na.action = "na.fail") +#' stats::cor.test(~ x + y, na.action = "na.fail") +#' ``` +#' +#' @param x,y (`numeric`) vectors of data values. `x` and `y` must have the same length. +#' @param .f (`function`) function that accepts x and y as formula input `~ x + y`. +#' Default `stats::cor.test`. +#' @param .f_args (`list`) of arguments to be passed to `.f`. +#' @param round_stat (`integer(1)`) optional, number of decimal places to use when rounding the estimate. +#' @param round_pval (`integer(1)`) optional, number of decimal places to use when rounding the p-value. +#' +#' @return Character with stats. For [stats::cor.test()] correlation coefficient and p-value. +#' +#' @examples +#' set.seed(1) +#' x <- runif(25, 0, 1) +#' y <- runif(25, 0, 1) +#' x[c(3, 10, 18)] <- NA +#' +#' get_scatterplotmatrix_stats(x, y, .f = stats::cor.test, .f_args = list(method = "pearson")) +#' get_scatterplotmatrix_stats(x, y, .f = stats::cor.test, .f_args = list( +#' method = "pearson", +#' na.action = na.fail +#' )) +#' +#' @export +#' +get_scatterplotmatrix_stats <- function(x, y, + .f = stats::cor.test, + .f_args = list(), + round_stat = 2, + round_pval = 4) { + if (is.numeric(x) && is.numeric(y)) { + stat <- tryCatch(do.call(.f, c(list(~ x + y), .f_args)), error = function(e) NA) + + if (anyNA(stat)) { + return("NA") + } else if (all(c("estimate", "p.value") %in% names(stat))) { + return(paste( + c( + paste0(names(stat$estimate), ":", round(stat$estimate, round_stat)), + paste0("P:", round(stat$p.value, round_pval)) + ), + collapse = "\n" + )) + } else { + stop("function not supported") + } + } else { + if ("method" %in% names(.f_args)) { + if (.f_args$method == "pearson") { + return("cor:-") + } + if (.f_args$method == "kendall") { + return("tau:-") + } + if (.f_args$method == "spearman") { + return("rho:-") + } + } + return("-") + } +} diff --git a/R/tm_outliers.R b/R/tm_outliers.R index 5c6113c7c..e8e4ec560 100644 --- a/R/tm_outliers.R +++ b/R/tm_outliers.R @@ -7,9 +7,9 @@ #' @inheritParams teal::module #' @inheritParams shared_params #' -#' @param outlier_var (`data_extract_spec` or `list` of multiple `data_extract_spec`) +#' @param outlier_var (`picks` or `list` of multiple `picks`) #' Specifies variable(s) to be analyzed for outliers. -#' @param categorical_var (`data_extract_spec` or `list` of multiple `data_extract_spec`) optional, +#' @param categorical_var (`picks` or `list` of multiple `picks`) optional, #' specifies the categorical variable(s) to split the selected outlier variables on. #' @param ggplot2_args `r roxygen_ggplot2_args_param("Boxplot", "Density Plot", "Cumulative Distribution Plot")` #' @@ -66,21 +66,22 @@ #' modules = modules( #' tm_outliers( #' outlier_var = list( -#' data_extract_spec( -#' dataname = "CO2", -#' select = select_spec( -#' label = "Select variable:", +#' teal.transform::picks( +#' datasets("CO2"), +#' teal.transform::variables( #' choices = variable_choices(data[["CO2"]], c("conc", "uptake")), #' selected = "uptake", #' multiple = FALSE, #' fixed = FALSE -#' ) +#' ), +#' teal.transform::values() #' ) #' ), #' categorical_var = list( -#' data_extract_spec( -#' dataname = "CO2", -#' filter = filter_spec( +#' teal.transform::picks( +#' datasets("CO2"), +#' teal.transform::variables(), +#' values( #' vars = vars, #' choices = value_choices(data[["CO2"]], vars$selected), #' selected = value_choices(data[["CO2"]], vars$selected), @@ -117,21 +118,22 @@ #' modules = modules( #' tm_outliers( #' outlier_var = list( -#' data_extract_spec( -#' dataname = "ADSL", -#' select = select_spec( -#' label = "Select variable:", +#' teal.transform::picks( +#' datasets("ADSL"), +#' teal.transform::variables( #' choices = variable_choices(data[["ADSL"]], c("AGE", "BMRKR1")), #' selected = "AGE", #' multiple = FALSE, #' fixed = FALSE -#' ) +#' ), +#' teal.transform::values() #' ) #' ), #' categorical_var = list( -#' data_extract_spec( -#' dataname = "ADSL", -#' filter = filter_spec( +#' teal.transform::picks( +#' datasets("ADSL"), +#' teal.transform::variables(), +#' values( #' vars = vars, #' choices = value_choices(data[["ADSL"]], vars$selected), #' selected = value_choices(data[["ADSL"]], vars$selected), diff --git a/R/tm_t_crosstable.R b/R/tm_t_crosstable.R index 344326741..1f20965be 100644 --- a/R/tm_t_crosstable.R +++ b/R/tm_t_crosstable.R @@ -5,14 +5,14 @@ #' #' @inheritParams teal::module #' @inheritParams shared_params -#' @param x (`data_extract_spec` or `list` of multiple `data_extract_spec`) +#' @param x (`picks` or `list` of `picks`) #' Object with all available choices with pre-selected option for variable X - row values. -#' In case of `data_extract_spec` use `select_spec(..., ordered = TRUE)` if table elements should be +#' In case of `picks` use `teal.transform::variables(..., ordered = TRUE)` if table elements should be #' rendered according to selection order. -#' @param y (`data_extract_spec` or `list` of multiple `data_extract_spec`) +#' @param y (`picks` or `list` of multiple `picks`) #' Object with all available choices with pre-selected option for variable Y - column values. #' -#' `data_extract_spec` must not allow multiple selection in this case. +#' `picks` must not allow multiple selection in this case. #' @param show_percentage (`logical(1)`) #' Indicates whether to show percentages (relevant only when `x` is a `factor`). #' Defaults to `TRUE`. @@ -82,26 +82,26 @@ #' modules = modules( #' tm_t_crosstable( #' label = "Cross Table", -#' x = data_extract_spec( -#' dataname = "mtcars", -#' select = select_spec( -#' label = "Select variable:", +#' x = teal.transform::picks( +#' datasets("mtcars"), +#' teal.transform::variables( #' choices = variable_choices(data[["mtcars"]], c("cyl", "vs", "am", "gear")), #' selected = c("cyl", "gear"), #' multiple = TRUE, #' ordered = TRUE, #' fixed = FALSE -#' ) +#' ), +#' teal.transform::values() #' ), -#' y = data_extract_spec( -#' dataname = "mtcars", -#' select = select_spec( -#' label = "Select variable:", +#' y = teal.transform::picks( +#' datasets("mtcars"), +#' teal.transform::variables( #' choices = variable_choices(data[["mtcars"]], c("cyl", "vs", "am", "gear")), #' selected = "vs", #' multiple = FALSE, #' fixed = FALSE -#' ) +#' ), +#' teal.transform::values() #' ) #' ) #' ) @@ -127,10 +127,9 @@ #' modules = modules( #' tm_t_crosstable( #' label = "Cross Table", -#' x = data_extract_spec( -#' dataname = "ADSL", -#' select = select_spec( -#' label = "Select variable:", +#' x = teal.transform::picks( +#' datasets("ADSL"), +#' teal.transform::variables( #' choices = variable_choices(data[["ADSL"]], subset = function(data) { #' idx <- !vapply(data, inherits, logical(1), c("Date", "POSIXct", "POSIXlt")) #' return(names(data)[idx]) @@ -139,12 +138,12 @@ #' multiple = TRUE, #' ordered = TRUE, #' fixed = FALSE -#' ) +#' ), +#' teal.transform::values() #' ), -#' y = data_extract_spec( -#' dataname = "ADSL", -#' select = select_spec( -#' label = "Select variable:", +#' y = teal.transform::picks( +#' datasets("ADSL"), +#' teal.transform::variables( #' choices = variable_choices(data[["ADSL"]], subset = function(data) { #' idx <- vapply(data, is.factor, logical(1)) #' return(names(data)[idx]) @@ -152,7 +151,8 @@ #' selected = "SEX", #' multiple = FALSE, #' fixed = FALSE -#' ) +#' ), +#' teal.transform::values() #' ) #' ) #' ) @@ -164,7 +164,13 @@ #' @export #' tm_t_crosstable <- function(label = "Cross Table", - x, + x = teal.transform::picks( + teal.transform::datasets(), + teal.transform::variables( + choices = teal.transform::is_categorical(min.len = 2, max.len = 10), + selected = 1L, multiple = TRUE, ordered = TRUE + ) + ), y, show_percentage = TRUE, show_total = TRUE, @@ -174,6 +180,21 @@ tm_t_crosstable <- function(label = "Cross Table", basic_table_args = teal.widgets::basic_table_args(), transformators = list(), decorators = list()) { + UseMethod("tm_t_crosstable", x) +} + +#' @export +tm_t_crosstable.default <- function(label = "Cross Table", + x, + y, + show_percentage = TRUE, + show_total = TRUE, + remove_zero_columns = FALSE, + pre_output = NULL, + post_output = NULL, + basic_table_args = teal.widgets::basic_table_args(), + transformators = list(), + decorators = list()) { message("Initializing tm_t_crosstable") # Normalize the parameters @@ -211,8 +232,8 @@ tm_t_crosstable <- function(label = "Cross Table", ans <- module( label = label, - server = srv_t_crosstable, - ui = ui_t_crosstable, + server = srv_t_crosstable.default, + ui = ui_t_crosstable.default, ui_args = ui_args, server_args = server_args, transformators = transformators, @@ -223,7 +244,7 @@ tm_t_crosstable <- function(label = "Cross Table", } # UI function for the cross-table module -ui_t_crosstable <- function(id, x, y, show_percentage, show_total, remove_zero_columns, pre_output, post_output, ...) { +ui_t_crosstable.default <- function(id, x, y, show_percentage, show_total, remove_zero_columns, pre_output, post_output, ...) { args <- list(...) ns <- NS(id) is_single_dataset <- teal.transform::is_single_dataset(x, y) @@ -270,7 +291,7 @@ ui_t_crosstable <- function(id, x, y, show_percentage, show_total, remove_zero_c } # Server function for the cross-table module -srv_t_crosstable <- function(id, data, label, x, y, remove_zero_columns, basic_table_args, decorators) { +srv_t_crosstable.default <- function(id, data, label, x, y, remove_zero_columns, basic_table_args, decorators) { checkmate::assert_class(data, "reactive") checkmate::assert_class(isolate(data()), "teal_data") moduleServer(id, function(input, output, session) { diff --git a/R/tm_t_crosstable_picks.R b/R/tm_t_crosstable_picks.R new file mode 100644 index 000000000..91bd86516 --- /dev/null +++ b/R/tm_t_crosstable_picks.R @@ -0,0 +1,277 @@ +#' @export +tm_t_crosstable.picks <- function(label = "Cross Table", + x = teal.transform::picks( + teal.transform::datasets(), + teal.transform::variables( + choices = teal.transform::is_categorical(min.len = 2, max.len = 10), + selected = 1L, multiple = TRUE, ordered = TRUE + ) + ), + y = teal.transform::picks( + teal.transform::datasets(), + teal.transform::variables( + choices = teal.transform::is_categorical(min.len = 2, max.len = 10), + selected = 2L, ordered = TRUE + ), + teal.transform::values() + ), + show_percentage = TRUE, + show_total = TRUE, + remove_zero_columns = FALSE, + pre_output = NULL, + post_output = NULL, + basic_table_args = teal.widgets::basic_table_args(), + transformators = list(), + decorators = list()) { + message("Initializing tm_t_crosstable") + + # Start of assertions + checkmate::assert_string(label) + checkmate::assert_class(x, "picks") + + checkmate::assert_class(y, "picks") + if (isTRUE(attr(y$variables, "multiple"))) { + warning("`y` accepts only a single variable selection. Forcing `teal.transform::variables(multiple) to FALSE`") + attr(y$variables, "multiple") <- FALSE + } + + checkmate::assert_flag(show_percentage) + checkmate::assert_flag(show_total) + checkmate::assert_flag(remove_zero_columns) + checkmate::assert_multi_class(pre_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE) + checkmate::assert_multi_class(post_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE) + checkmate::assert_class(basic_table_args, classes = "basic_table_args") + + assert_decorators(decorators, "table") + # End of assertions + + args <- as.list(environment()) + ans <- module( + label = label, + server = srv_t_crosstable.picks, + ui = ui_t_crosstable.picks, + ui_args = args[names(args) %in% names(formals(ui_t_crosstable.picks))], + server_args = args[names(args) %in% names(formals(srv_t_crosstable.picks))], + transformators = transformators, + datanames = .picks_datanames(list(x, y)) + ) + + attr(ans, "teal_bookmarkable") <- TRUE + ans +} + +# UI function for the cross-table module +ui_t_crosstable.picks <- function(id, x, y, show_percentage, show_total, remove_zero_columns, pre_output, post_output, decorators) { + ns <- NS(id) + + join_default_options <- c( + "Full Join" = "dplyr::full_join", + "Inner Join" = "dplyr::inner_join", + "Left Join" = "dplyr::left_join", + "Right Join" = "dplyr::right_join" + ) + + teal.widgets::standard_layout( + output = teal.widgets::white_small_well( + textOutput(ns("title")), + teal.widgets::table_with_settings_ui(ns("table")) + ), + encoding = tags$div( + tags$label("Encodings", class = "text-primary"), + tags$div( + tags$strong("Row values"), + teal.transform::picks_ui(id = ns("x"), picks = x) + ), + tags$div( + tags$strong("Column values"), + teal.transform::picks_ui(id = ns("y"), picks = y) + ), + shinyWidgets::pickerInput( + ns("join_fun"), + label = "Row to Column type of join", + choices = join_default_options, + selected = join_default_options[1] + ), + tags$hr(), + bslib::accordion( + open = TRUE, + bslib::accordion_panel( + title = "Table settings", + checkboxInput(ns("show_percentage"), "Show column percentage", value = show_percentage), + checkboxInput(ns("show_total"), "Show total column", value = show_total), + checkboxInput(ns("remove_zero_columns"), "Remove zero-only columns", value = remove_zero_columns) + ) + ), + ui_decorate_teal_data(ns("decorator"), decorators = select_decorators(decorators, "table")) + ), + pre_output = pre_output, + post_output = post_output + ) +} + +# Server function for the cross-table module +srv_t_crosstable.picks <- function(id, data, label, x, y, remove_zero_columns, basic_table_args, decorators) { + checkmate::assert_class(data, "reactive") + checkmate::assert_class(isolate(data()), "teal_data") + moduleServer(id, function(input, output, session) { + teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.general") + + selectors <- teal.transform::picks_srv(picks = list(x = x, y = y), data = data) + + validated_q <- reactive({ + validate_input( + inputId = "x-variables-selected", + condition = length(selectors$x()$variables$selected) > 0, + message = "Please define column(s) for row variables." + ) + validate_input( + inputId = "y-variables-selected", + condition = length(selectors$y()$variables$selected) == 1, + message = "Please define column for column variable." + ) + + obj <- data() + teal.reporter::teal_card(obj) <- + c( + teal.reporter::teal_card("# Cross Table"), + teal.reporter::teal_card(obj), + teal.reporter::teal_card("## Module's code") + ) + teal.code::eval_code(obj, 'library("rtables");library("tern");library("dplyr")') # nolint quotes + }) + + observeEvent( + eventExpr = { + selectors$x() + selectors$y() + }, + handlerExpr = { + if (identical(selectors$x()$datasets$selected, selectors$y()$datasets$selected)) { + shinyjs::hide("join_fun") + } else { + shinyjs::show("join_fun") + } + } + ) + + merged <- teal.transform::merge_srv( + "merge", + data = validated_q, + selectors = selectors, + output_name = "anl", + join_fun = isolate(input$join_fun) # todo: make reactive + ) + + output_q <- reactive({ + anl <- merged$data()[["anl"]] + + # As this is a summary + x_name <- merged$variables()$x + y_name <- merged$variables()$y + + teal::validate_has_data(anl, 3) + teal::validate_has_data(anl[, c(x_name, y_name)], 3, complete = TRUE, allow_inf = FALSE) + + is_allowed_class <- function(x) is.numeric(x) || is.factor(x) || is.character(x) || is.logical(x) + validate(need( + all(vapply(anl[x_name], is_allowed_class, logical(1))), + "Selected row variable has an unsupported data type." + )) + validate(need( + is_allowed_class(anl[[y_name]]), + "Selected column variable has an unsupported data type." + )) + + show_percentage <- input$show_percentage + show_total <- input$show_total + remove_zero_columns <- input$remove_zero_columns + + plot_title <- paste( + "Cross-Table of", + paste0(varname_w_label(x_name, anl), collapse = ", "), + "(rows)", "vs.", + varname_w_label(y_name, anl), + "(columns)" + ) + + labels_vec <- vapply(x_name, varname_w_label, character(1), anl) + + obj <- merged$data() + teal.reporter::teal_card(obj) <- c(teal.reporter::teal_card(obj), "# Table") + obj <- within( + obj, + expr = title <- plot_title, + plot_title = plot_title + ) %>% + within( + expr = { + table <- basic_tables %>% + split_call %>% # styler: off + rtables::add_colcounts() %>% + tern::analyze_vars( + vars = x_name, + var_labels = labels_vec, + na.rm = FALSE, + denom = "N_col", + .stats = c("mean_sd", "median", "range", count_value) + ) + }, + basic_tables = teal.widgets::parse_basic_table_args( + basic_table_args = teal.widgets::resolve_basic_table_args(basic_table_args) + ), + split_call = if (show_total) { + substitute( + expr = rtables::split_cols_by( + y_name, + split_fun = rtables::add_overall_level(label = "Total", first = FALSE) + ), + env = list(y_name = y_name) + ) + } else { + substitute(rtables::split_cols_by(y_name), env = list(y_name = y_name)) + }, + x_name = x_name, + labels_vec = labels_vec, + count_value = ifelse(show_percentage, "count_fraction", "count") + ) %>% + within(anl <- tern::df_explicit_na(anl)) + + obj <- if (remove_zero_columns) { + within( + obj, + { + anl[[y_name]] <- droplevels(anl[[y_name]]) + table <- rtables::build_table(lyt = table, df = anl[order(anl[[y_name]]), ]) + }, + y_name = y_name + ) + } else { + within( + obj, + table <- rtables::build_table(lyt = table, df = anl[order(anl[[y_name]]), ]), + y_name = y_name + ) + } + obj + }) + + decorated_output_q <- srv_decorate_teal_data( + id = "decorator", + data = output_q, + decorators = select_decorators(decorators, "table"), + expr = quote(table) + ) + + output$title <- renderText(req(decorated_output_q())[["title"]]) + + table_r <- reactive({ + obj <- req(decorated_output_q()) + tail(teal.code::get_outputs(obj), 1)[[1]] + }) + + teal.widgets::table_with_settings_srv(id = "table", table_r = table_r) + + + decorated_output_q + }) +} diff --git a/R/tm_variable_browser.R b/R/tm_variable_browser.R index 687b6c059..d77faa2af 100644 --- a/R/tm_variable_browser.R +++ b/R/tm_variable_browser.R @@ -262,7 +262,18 @@ srv_variable_browser <- function(id, establish_updating_selection(datanames, input, plot_var, columns_names) # validations - validation_checks <- validate_input(req(input), req(plot_var), data) + validation_checks <- reactive({ + dataset_name <- req(input$tabset_panel) + varname <- plot_var$variable[[dataset_name]] + + validate(need(dataset_name, "No data selected")) + validate(need(varname, "No variable selected")) + df <- data()[[dataset_name]] + teal::validate_has_data(df, 1) + teal::validate_has_variable(varname = varname, data = df, "Variable not available") + + TRUE + }) # data_for_analysis is a list with two elements: a column from a dataset and the column label plotted_data <- reactive({ @@ -854,29 +865,6 @@ is_num_var_short <- function(.unique_records_for_factor, input, data_for_analysi length(unique(data_for_analysis()$data)) < .unique_records_for_factor && !is.null(input$numeric_as_factor) } -#' Validates the variable browser inputs -#' -#' @param input (`session$input`) the `shiny` session input -#' @param plot_var (`list`) list of a data frame and an array of variable names -#' @param data (`teal_data`) the datasets passed to the module -#' -#' @returns `logical` TRUE if validations pass; a `shiny` validation error otherwise -#' @keywords internal -validate_input <- function(input, plot_var, data) { - reactive({ - dataset_name <- req(input$tabset_panel) - varname <- plot_var$variable[[dataset_name]] - - validate(need(dataset_name, "No data selected")) - validate(need(varname, "No variable selected")) - df <- data()[[dataset_name]] - teal::validate_has_data(df, 1) - teal::validate_has_variable(varname = varname, data = df, "Variable not available") - - TRUE - }) -} - get_plotted_data <- function(input, plot_var, data) { dataset_name <- req(input$tabset_panel) varname <- plot_var$variable[[dataset_name]] @@ -889,7 +877,7 @@ get_plotted_data <- function(input, plot_var, data) { teal.code::eval_code(obj, "library(ggplot2)") |> within( { - ANL <- select(dataset_name, varname) + ANL <- dplyr::select(dataset_name, varname) }, dataset_name = as.name(dataset_name), varname = as.name(varname) @@ -977,7 +965,6 @@ render_tab_table <- function(dataset_name, parent_dataname, output, data, input, output[[table_ui_id]] <- DT::renderDataTable({ df <- data()[[dataset_name]] - get_vars_df <- function(input, dataset_name, parent_name, data) { data_cols <- colnames(df) if (isTRUE(input$show_parent_vars)) { diff --git a/R/utils.R b/R/utils.R index 5f462ba0d..6c7f8365b 100644 --- a/R/utils.R +++ b/R/utils.R @@ -38,6 +38,10 @@ #' decorator for tables or plots included in the module output reported. #' The decorators are applied to the respective output objects. #' +#' @param table_datanames (`character`) names of the datasets which should be listed below the plot +#' when some data points are selected. Objects named after `table_datanames` will be pulled from +#' `data` so it is important that data actually contains these datasets. Please be aware that +#' table datasets must be linked with `plot_dataname` by the relevant [join_keys()]. #' See section "Decorating Module" below for more details. #' #' @return Object of class `teal_module` to be used in `teal` applications. @@ -234,13 +238,12 @@ variable_type_icons <- function(var_type) { )) } -#' #' @param id (`character(1)`) the id of the tab panel with tabs. #' @param name (`character(1)`) the name of the tab. #' @return JavaScript expression to be used in `shiny::conditionalPanel()` to determine #' if the specified tab is active. +#' @noRd #' @keywords internal -#' is_tab_active_js <- function(id, name) { # supporting the bs3 and higher version at the same time sprintf( diff --git a/R/zzz.R b/R/zzz.R index 2ccb87747..f1d610505 100644 --- a/R/zzz.R +++ b/R/zzz.R @@ -7,4 +7,8 @@ ggplot_themes <- c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void") #' @importFrom lifecycle deprecated +#' @importFrom rlang := interactive <- NULL + + +validate_input <- getFromNamespace("validate_input", "teal") diff --git a/man/get_scatterplotmatrix_stats.Rd b/man/get_scatterplotmatrix_stats.Rd index 176b24cb1..bd4c71f38 100644 --- a/man/get_scatterplotmatrix_stats.Rd +++ b/man/get_scatterplotmatrix_stats.Rd @@ -1,9 +1,19 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/tm_g_scatterplotmatrix.R +% Please edit documentation in R/tm_g_scatterplotmatrix.R, +% R/tm_g_scatterplotmatrix_picks.R \name{get_scatterplotmatrix_stats} \alias{get_scatterplotmatrix_stats} \title{Get stats for x-y pairs in scatterplot matrix} \usage{ +get_scatterplotmatrix_stats( + x, + y, + .f = stats::cor.test, + .f_args = list(), + round_stat = 2, + round_pval = 4 +) + get_scatterplotmatrix_stats( x, y, @@ -26,9 +36,16 @@ Default \code{stats::cor.test}.} \item{round_pval}{(\code{integer(1)}) optional, number of decimal places to use when rounding the p-value.} } \value{ +Character with stats. For \code{\link[stats:cor.test]{stats::cor.test()}} correlation coefficient and p-value. + Character with stats. For \code{\link[stats:cor.test]{stats::cor.test()}} correlation coefficient and p-value. } \description{ +Uses \code{\link[stats:cor.test]{stats::cor.test()}} per default for all numerical input variables and converts results +to character vector. +Could be extended if different stats for different variable types are needed. +Meant to be called from \code{\link[lattice:llines]{lattice::panel.text()}}. + Uses \code{\link[stats:cor.test]{stats::cor.test()}} per default for all numerical input variables and converts results to character vector. Could be extended if different stats for different variable types are needed. @@ -38,6 +55,15 @@ Meant to be called from \code{\link[lattice:llines]{lattice::panel.text()}}. Presently we need to use a formula input for \code{stats::cor.test} because \code{na.fail} only gets evaluated when a formula is passed (see below). +\if{html}{\out{
}}\preformatted{x = c(1,3,5,7,NA) +y = c(3,6,7,8,1) +stats::cor.test(x, y, na.action = "na.fail") +stats::cor.test(~ x + y, na.action = "na.fail") +}\if{html}{\out{
}} + +Presently we need to use a formula input for \code{stats::cor.test} because +\code{na.fail} only gets evaluated when a formula is passed (see below). + \if{html}{\out{
}}\preformatted{x = c(1,3,5,7,NA) y = c(3,6,7,8,1) stats::cor.test(x, y, na.action = "na.fail") @@ -56,4 +82,15 @@ get_scatterplotmatrix_stats(x, y, .f = stats::cor.test, .f_args = list( na.action = na.fail )) +set.seed(1) +x <- runif(25, 0, 1) +y <- runif(25, 0, 1) +x[c(3, 10, 18)] <- NA + +get_scatterplotmatrix_stats(x, y, .f = stats::cor.test, .f_args = list(method = "pearson")) +get_scatterplotmatrix_stats(x, y, .f = stats::cor.test, .f_args = list( + method = "pearson", + na.action = na.fail +)) + } diff --git a/man/shared_params.Rd b/man/shared_params.Rd index 5e27ea0dc..1b0299286 100644 --- a/man/shared_params.Rd +++ b/man/shared_params.Rd @@ -51,8 +51,12 @@ vector of \code{value}, \code{min}, and \code{max}. \item{decorators}{\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}} (named \code{list} of lists of \code{teal_transform_module}) optional, decorator for tables or plots included in the module output reported. -The decorators are applied to the respective output objects. +The decorators are applied to the respective output objects.} +\item{table_datanames}{(\code{character}) names of the datasets which should be listed below the plot +when some data points are selected. Objects named after \code{table_datanames} will be pulled from +\code{data} so it is important that data actually contains these datasets. Please be aware that +table datasets must be linked with \code{plot_dataname} by the relevant \code{\link[teal.data:join_keys]{teal.data::join_keys()}}. See section "Decorating Module" below for more details.} } \value{ diff --git a/man/tm_a_pca.Rd b/man/tm_a_pca.Rd index 2fdfdf650..6b1c1068d 100644 --- a/man/tm_a_pca.Rd +++ b/man/tm_a_pca.Rd @@ -6,7 +6,9 @@ \usage{ tm_a_pca( label = "Principal Component Analysis", - dat, + dat = teal.transform::picks(teal.transform::datasets(), + teal.transform::variables(choices = tidyselect::where(~is.numeric(.x) && + all(!is.na(.x))), selected = tidyselect::everything(), multiple = TRUE)), plot_height = c(600, 200, 2000), plot_width = NULL, ggtheme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void"), @@ -25,8 +27,7 @@ tm_a_pca( \item{label}{(\code{character(1)}) Label shown in the navigation item for the module or module group. For \code{modules()} defaults to \code{"root"}. See \code{Details}.} -\item{dat}{(\code{data_extract_spec} or \code{list} of multiple \code{data_extract_spec}) -specifying columns used to compute PCA.} +\item{dat}{(\code{picks}) specifying columns used to compute PCA.} \item{plot_height}{(\code{numeric}) optional, specifies the plot height as a three-element vector of \code{value}, \code{min}, and \code{max} intended for use with a slider UI element.} @@ -79,9 +80,7 @@ To learn more check \code{vignette("transform-input-data", package = "teal")}.} \item{decorators}{\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}} (named \code{list} of lists of \code{teal_transform_module}) optional, decorator for tables or plots included in the module output reported. -The decorators are applied to the respective output objects. - -See section "Decorating Module" below for more details.} +The decorators are applied to the respective output objects.} } \value{ Object of class \code{teal_module} to be used in \code{teal} applications. @@ -139,16 +138,13 @@ app <- init( modules = modules( tm_a_pca( "PCA", - dat = data_extract_spec( - dataname = "USArrests", - select = select_spec( - choices = variable_choices( - data = data[["USArrests"]], c("Murder", "Assault", "UrbanPop", "Rape") - ), + dat = teal.transform::picks( + datasets("USArrests"), + teal.transform::variables( + choices = c("Murder", "Assault", "UrbanPop", "Rape"), selected = c("Murder", "Assault"), multiple = TRUE - ), - filter = NULL + ) ) ) ) @@ -170,17 +166,13 @@ app <- init( data = data, modules = modules( tm_a_pca( - "PCA", - dat = data_extract_spec( - dataname = "ADSL", - select = select_spec( - choices = variable_choices( - data = data[["ADSL"]], c("BMRKR1", "AGE", "EOSDY") - ), + dat = teal.transform::picks( + datasets("ADSL"), + teal.transform::variables( + choices = c("BMRKR1", "AGE", "EOSDY"), selected = c("BMRKR1", "AGE"), multiple = TRUE - ), - filter = NULL + ) ) ) ) @@ -193,13 +185,13 @@ if (interactive()) { \section{Examples in Shinylive}{ \describe{ \item{example-1}{ - \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAokrcQAxLqkQ11XfxQpFC6cAAesKgiSoHBBsZc1AD6sVA2MUEhRroA7rSkABYq7Km4uiBKurqMcACOgrQ17L6ipMTURIyKEFWOAMoAgow1raLxuv1DI6SiSgC+3UpoqOMq+eyVAZm6ALxbwbibfEIiY3vHwmIbPVW6pDBJUEmoBGmbt7oKYAAKAMIDX0ONw+sV2+ye4VIzA0SVEqDgBGuHxBmWg8DBX0mwzEM0B72RojgIg0YMJxNIsPhiPxyN0BAKRFoBDEYK0LFoUHoIiS9MZzNESNpyNSYNSwGAmMG2NGXwAurKytSwABZQSMfgyQGfMADUSiKDCUhazGMehQCDfIioY1gLBoOBfbpC25yIHOqpkhHkfhgpWq9WavDa3X6w2Ot3umCG2hRPR7BwuGkuiO0ky0ajkRhggByjgAMnmk06XZtut1aCZdOwVJn1JodDZbBUbqIihBWAN0OxlgASBplXuExg6LrzJRgOayoA}{Open in Shinylive} - \if{html}{\out{}} + \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAokrcQAxLqkQ11XfxQpFC6cAAesKgiSoHBBsZc1AD6sVA2MUEhRroA7rSkABYq7Km4uiBKurqMcACOgrQ17L6ipMTURIyKEFWOAMoAgow1raLxuv1DI6SiSgC+3UpoqOMq+eyVAZm6ALxbwbibfEIiY3vHwmIbPVW6pDBJUEmoBGmbt7oKYAAKAMIDX0ONw+sV2dzg3AwpGYEFEJk6MEQiFQtAIAGtRNcPiDMqI4DMNmBJsMxDMvnIgdjbokoTC4QikVoWLQoPRTliqbcCAUiKixGCCISALKCRj8GSAz5gAaiURQYSkSVfRyMehQCDfIioJVgLBoODkymcqp4kQaOD8AXC0Xixg6mVyhWG96cmAK2hRPR7BwuF0fbpUgO3IPdbq0Ey6dgqcjMSw6Gy2Co3URFCCsAbodjLAAkDTKObxjB0XXmSjAcwAukA}{Open in Shinylive} + \if{html}{\out{}} \if{html}{\out{}} } \item{example-2}{ - \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAokrcQAxLoDCAEQCSAMreuvxQpFC6cAAesKgiSmERBsZc1AD6SVA2ieGRRroA7rSkABYq7Fm4uiBKurqMcACOgrSN7BBipMTURIyKEPUAgr6BADIpumkYWYiIjCPjSgC+AwBWRCrpANZwrKKVebYF-HAmUMKk6QT8tKIE6Rtbu-vA0PAHWXIAuu5oqJMVCV2HVQnldABeMERXCgvhCESiSG6eHCMQgwb1KYwdJQdKoAjZUFY3QKMAABW8QzJsMxJKSyKy6RipGYGnSolQcAIGJJ9Ly7z0ULJizGNOJfNEcBEGmRUplV053N5fJJBFKmwIYmRWhYtCg9BE1w1tC1BwlqvqWUZeWAwBFozFYG+32qPLJACEALJYADSWAAjDTSWAhgBxVx4EPOADygV8AE0yQNLVi5LTU-V5dzyPxke6wN6-YHgyKI8mM5mYJdaPEhfYnK46Xz0xasSZaNRyIxkQA5RxjMXN+optOggYDWgmXTsFTd9SaHQ2Wy1TGicoQVhDdDsf4AEla1X3UsYOn6KyUYGW3yAA}{Open in Shinylive} - \if{html}{\out{}} + \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAokrcQAxLoDCAEQCSAMreuvxQpFC6cAAesKgiSmERBsZc1AD6SVA2ieGRRroA7rSkABYq7Fm4uiBKurqMcACOgrSN7BBipMTURIyKEPUAgr6BADIpumkYWYiIjCPjSgC+AwBWRCrpANZwrKKVebYF-HAmUMKk6QT8tKIE6Rtbu-vA0PAHWXIAuu5oqJMVCV2HVQnldABeMERXCgvhCESiSG6eHCMQgwb1KYwdJQdKoAjZUFY6HI6akZgQUQmPowOaoWgEbYHYkk6FQURwUgssCLMYKMByWGYtlTODcDAUqBUmmMOmILQsWhQeiIjGikkEUqbAhiZEEEFgABCAFksABpLAARgF1QFQwA4q48LoBc4APKBXwATQFQtZos5Ig0cH4+sNpot1ttrt5Tr9wo1WJgl1o8T0UIcLgDWIGorzudBAwGtBMunYKnIzEsOhstlqmNE5QgrCG6HY-wAJK1ql3OYwdP0VkowMtvkA}{Open in Shinylive} + \if{html}{\out{}} \if{html}{\out{}} } } diff --git a/man/tm_a_regression.Rd b/man/tm_a_regression.Rd index 37a215e71..5ebd6b175 100644 --- a/man/tm_a_regression.Rd +++ b/man/tm_a_regression.Rd @@ -6,7 +6,9 @@ \usage{ tm_a_regression( label = "Regression Analysis", - regressor, + regressor = teal.transform::picks(teal.transform::datasets(), + teal.transform::variables(choices = is.numeric, selected = tidyselect::last_col(), + multiple = TRUE)), response, plot_height = c(600, 200, 2000), plot_width = NULL, @@ -27,11 +29,13 @@ tm_a_regression( \item{label}{(\code{character(1)}) Label shown in the navigation item for the module or module group. For \code{modules()} defaults to \code{"root"}. See \code{Details}.} -\item{regressor}{(\code{data_extract_spec} or \code{list} of multiple \code{data_extract_spec}) -Regressor variables from an incoming dataset with filtering and selecting.} +\item{regressor}{(\code{picks}) Specification for regressor variables selection. +Created using \code{\link[teal.transform:picks]{teal.transform::picks()}}, which allows selecting variables +to use as regressors in the regression model. \code{teal.transform::variables(multiple = TRUE)} allowed.} -\item{response}{(\code{data_extract_spec} or \code{list} of multiple \code{data_extract_spec}) -Response variables from an incoming dataset with filtering and selecting.} +\item{response}{(\code{picks}) Specification for response variable selection. +Created using \code{\link[teal.transform:picks]{teal.transform::picks()}}, which allows selecting a single numeric variable +to use as the response in the regression model. \code{teal.transform::variables(multiple = TRUE)} not allowed.} \item{plot_height}{(\code{numeric}) optional, specifies the plot height as a three-element vector of \code{value}, \code{min}, and \code{max} intended for use with a slider UI element.} @@ -79,8 +83,6 @@ adding context or further instructions. Elements like \code{shiny::helpText()} a \item Cook's dist vs Leverage }} -\item{default_outlier_label}{(\code{character}) optional, default column selected to label outliers.} - \item{label_segment_threshold}{(\code{numeric(1)} or \code{numeric(3)}) Minimum distance between label and point on the plot that triggers the creation of a line segment between the two. @@ -103,9 +105,11 @@ To learn more check \code{vignette("transform-input-data", package = "teal")}.} \item{decorators}{\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}} (named \code{list} of lists of \code{teal_transform_module}) optional, decorator for tables or plots included in the module output reported. -The decorators are applied to the respective output objects. +The decorators are applied to the respective output objects.} -See section "Decorating Module" below for more details.} +\item{outlier}{(\code{picks}) Optional specification for outlier label variable selection. +Created using \code{\link[teal.transform:picks]{teal.transform::picks()}}, which allows selecting a factor or character variable +to label outlier points on the plots.} } \value{ Object of class \code{teal_module} to be used in \code{teal} applications. @@ -161,25 +165,13 @@ app <- init( modules = modules( tm_a_regression( label = "Regression", - response = data_extract_spec( - dataname = "CO2", - select = select_spec( - label = "Select variable:", - choices = "uptake", - selected = "uptake", - multiple = FALSE, - fixed = TRUE - ) + response = teal.transform::picks( + datasets("CO2"), + teal.transform::variables(choices = "uptake", selected = "uptake") ), - regressor = data_extract_spec( - dataname = "CO2", - select = select_spec( - label = "Select variables:", - choices = variable_choices(data[["CO2"]], c("conc", "Treatment")), - selected = "conc", - multiple = TRUE, - fixed = FALSE - ) + regressor = teal.transform::picks( + datasets("CO2"), + teal.transform::variables(choices = c("conc", "Treatment"), selected = "conc", multiple = TRUE) ) ) ) @@ -201,25 +193,13 @@ app <- init( modules = modules( tm_a_regression( label = "Regression", - response = data_extract_spec( - dataname = "ADSL", - select = select_spec( - label = "Select variable:", - choices = "BMRKR1", - selected = "BMRKR1", - multiple = FALSE, - fixed = TRUE - ) + response = teal.transform::picks( + datasets("ADSL"), + teal.transform::variables(choices = "BMRKR1", selected = "BMRKR1") ), - regressor = data_extract_spec( - dataname = "ADSL", - select = select_spec( - label = "Select variables:", - choices = variable_choices(data[["ADSL"]], c("AGE", "SEX", "RACE")), - selected = "AGE", - multiple = TRUE, - fixed = FALSE - ) + regressor = teal.transform::picks( + datasets("ADSL"), + teal.transform::variables(choices = c("AGE", "SEX", "RACE"), selected = "AGE", multiple = TRUE) ) ) ) @@ -232,13 +212,13 @@ if (interactive()) { \section{Examples in Shinylive}{ \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{}} + \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAokrcQAxLqkQ11XfxQpFC6cAAesKgiSoHBBsZc1AD6sVA2MUEhRroA7rSkABYq7Km4uiBKurqMcACOgrQ17L6ipMTURIyKEFUAwgDyAEzxugODSgC+3UpoqCMq+eyVAZm6ALwrwbjLfEIiouu6u8JiSz1VuqQwSVBJNRI1oqJWEGcXF9RQ9HD+GwpgWDgDzEzxI-2253ej1QJFEeg2iQwpGYEFEJk6MEQiFQtAIAGtRG93hdUnDSIT-mN-nIIcSLojkVBUejGJjEFoWLQvvt2AQCkRcWJDv9BKhgni4ODdHCRBo4PxhWBReLJWBunSacsoUDHqJOocGSi0RisTj8RTIcTSXByUswFS1bS6Zc4NwkUaWWyOYwufQeXyBQQhRsCHbiBYpf87DUgvAyNSyjK4HKFX9CCQCFKYMJNFF4fYnM51cTi1Vi91urQTLp2CpyMxLDobLYKudREUIKwAILodizAAkDTKA7hjB0XUmSjAEwAukA}{Open in Shinylive} + \if{html}{\out{}} \if{html}{\out{}} } \item{example-2}{ - \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAokqUBiXQGEAIgEkAZS9dfihSKF04AA9YVBElUPCDYy5qAH1EqBsEsIijXQB3WlIACxV2TNxdECVdXUY4AEdBWgb2CDFSYmoiRkUIOoBBHwCAGWTdVIxMxERGYbGlAF9+gCsiFTSAazhWUQrc23z+OBMoYVI0gn5aUQI09c2dveBoeH3MuQBdN2h0CZUxXYtRCuV0AF5QeFcCC+EIRKIIbo4cIxMCBnVJjA0lA0g0JA1RKIrBB0ZjMdQoPQ4NQkQowFg4ASxMSSPSYRjyYTUCRRHpIZk0tFSMwNGlRKg4AQyeTMZk3vzdPSFqN2SDZbo+SINEitVLLhKpTKNXVKdTaZD6QEafrdFoWLQqSJEGrOSaCCUNgQxHSwAAhACyWAA0lgAIyuk2YvUaOD8X2BkPhyNR5EXWhxRUAMUGowCzg5qdMtCicaRDhc6tl-Q1ckLsvxhNEvSRguFooNkulVfJ8tgiuVI1VeB70ZtOshMc7RtH5LNNN91u1pDtDqdYhdI7dGo9Xp9kPtjEd9BEV09tG9H1ywGAg8WYC+Xyq3bAgwA4q48EqwPmABrs78sEGLxPzkOtZzHZcy0tV8PxTKMYHTTNyycAsILqEwS2g3QczzVxt0xGtqyrIj+n6WgTF0dgVHIDttDgGxbBqDFRDKCBWEGdB2DQVAABIWiqHjeL5RgdD6ZYlDAJYviAA}{Open in Shinylive} - \if{html}{\out{}} + \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAokqUBiXQGEAIgEkAZS9dfihSKF04AA9YVBElUPCDYy5qAH1EqBsEsIijXQB3WlIACxV2TNxdECVdXUY4AEdBWgb2CDFSYmoiRkUIOoBBHwCAGWTdVIxMxERGYbGlAF9+gCsiFTSAazhWUQrc23z+OBMoYVI0gn5aUQI09c2dveBoeH3MuQBdN2h0CZUxXYtRCuV0AF5QeFcCC+EIRKIIbo4cIxMCBnVJjA0lA0g0JA1RKIrBB0ZjMdQoPQ4NQkQowFg4ASxMSSPSYRjyYTUCRRHpIVNSMwIKITL0YLNULQCFt9iDyXVMnzSHKwAtRvS5ByFZjBcLReLZloWLQqQj2AQShsCGI6WAAEIAWSwAGksABGdm6PkiDRwfh2p2uj2a+WYrVhur4wmiXpIvVQEVixgSxBSmVyzkKpVwFXAtUjDVgCNZ8kJpOGxDGxim+jmy3W22Qgj5wYAcVceF09ICzgAGl76VhBl5O1rvTS4H6A5D6e3O1UYBdaHF+fYnM5+jqt+GQf1+rQTLp2CpyMxLDobLYahjRGUIKxBuh2GhUAASFpVV9vvmMHR9ZYlDAJYviAA}{Open in Shinylive} + \if{html}{\out{}} \if{html}{\out{}} } } diff --git a/man/tm_g_association.Rd b/man/tm_g_association.Rd index 9e651dc70..b9332a587 100644 --- a/man/tm_g_association.Rd +++ b/man/tm_g_association.Rd @@ -6,7 +6,10 @@ \usage{ tm_g_association( label = "Association", - ref, + ref = teal.transform::picks(teal.transform::datasets(), + teal.transform::variables(choices = is.numeric | + teal.transform::is_categorical(min.len = 2, max.len = 10), selected = 1L), + teal.transform::values()), vars, show_association = TRUE, plot_height = c(600, 400, 5000), @@ -26,12 +29,11 @@ tm_g_association( \item{label}{(\code{character(1)}) Label shown in the navigation item for the module or module group. For \code{modules()} defaults to \code{"root"}. See \code{Details}.} -\item{ref}{(\code{data_extract_spec} or \code{list} of multiple \code{data_extract_spec}) -Reference variable, must accepts a \code{data_extract_spec} with \code{select_spec(multiple = FALSE)} -to ensure single selection option.} +\item{ref}{(\code{picks}) +Reference variable specification created using \code{teal.transform::picks()}.} -\item{vars}{(\code{data_extract_spec} or \code{list} of multiple \code{data_extract_spec}) -Variables to be associated with the reference variable.} +\item{vars}{(\code{picks}) +Variables to be associated with the reference variable, specified using \code{teal.transform::picks()}.} \item{show_association}{(\code{logical}) optional, whether show association of \code{vars} with reference variable. Defaults to \code{TRUE}.} @@ -64,9 +66,7 @@ To learn more check \code{vignette("transform-input-data", package = "teal")}.} \item{decorators}{\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}} (named \code{list} of lists of \code{teal_transform_module}) optional, decorator for tables or plots included in the module output reported. -The decorators are applied to the respective output objects. - -See section "Decorating Module" below for more details.} +The decorators are applied to the respective output objects.} } \value{ Object of class \code{teal_module} to be used in \code{teal} applications. @@ -121,23 +121,19 @@ app <- init( data = data, modules = modules( tm_g_association( - ref = data_extract_spec( - dataname = "CO2", - select = select_spec( - label = "Select variable:", - choices = variable_choices(data[["CO2"]], c("Plant", "Type", "Treatment")), - selected = "Plant", - fixed = FALSE + ref = teal.transform::picks( + datasets("CO2"), + teal.transform::variables( + choices = c("Plant", "Type", "Treatment"), + selected = "Plant" ) ), - vars = data_extract_spec( - dataname = "CO2", - select = select_spec( - label = "Select variables:", - choices = variable_choices(data[["CO2"]], c("Plant", "Type", "Treatment")), + vars = teal.transform::picks( + datasets("CO2"), + teal.transform::variables( + choices = c("Plant", "Type", "Treatment"), selected = "Treatment", - multiple = TRUE, - fixed = FALSE + multiple = TRUE ) ) ) @@ -159,29 +155,19 @@ app <- init( data = data, modules = modules( tm_g_association( - ref = data_extract_spec( - dataname = "ADSL", - select = select_spec( - label = "Select variable:", - choices = variable_choices( - data[["ADSL"]], - c("SEX", "RACE", "COUNTRY", "ARM", "STRATA1", "STRATA2", "ITTFL", "BMRKR2") - ), - selected = "RACE", - fixed = FALSE + ref = teal.transform::picks( + datasets("ADSL"), + teal.transform::variables( + choices = c("SEX", "RACE", "COUNTRY", "ARM", "STRATA1", "STRATA2", "ITTFL", "BMRKR2"), + selected = "RACE" ) ), - vars = data_extract_spec( - dataname = "ADSL", - select = select_spec( - label = "Select variables:", - choices = variable_choices( - data[["ADSL"]], - c("SEX", "RACE", "COUNTRY", "ARM", "STRATA1", "STRATA2", "ITTFL", "BMRKR2") - ), + vars = teal.transform::picks( + datasets("ADSL"), + teal.transform::variables( + choices = c("SEX", "RACE", "COUNTRY", "ARM", "STRATA1", "STRATA2", "ITTFL", "BMRKR2"), selected = "BMRKR2", - multiple = TRUE, - fixed = FALSE + multiple = TRUE ) ) ) @@ -195,13 +181,13 @@ if (interactive()) { \section{Examples in Shinylive}{ \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{}} + \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAokqUBiXVIhrqu-lCkULpwAB6wqCJKAUEGxlzUAPoxUDbRgcFGugDutKQAFirsKbi6IEq6uoxwAI6CtNXsPqKkxNREjIoQlQDCAPIATHG6-QMVpuqkHaLD0PCi7ABitNTkjOy0og4upVpokRyjpZsYJpMdpe0StATc7ACMADJyL129g8BnGtMAusPU+2ohw+XymjFEP1KUHEBHyLEmMi6AF8ukp9sMVHl2OMUroALz+DK4cZ8IQiGYE0nCMTY7qVXSkGCJCSJaGiIgEWiBKwQWn0+nVEz4hlwbgYUjMCCiEwdGCIRCoG4AawW435lRSojgpFVYFGCjAcmJdPVIrFEqgUpljDliD2jC59HJfNN9NhRBuYmFBGxYAACgCyAbSga7KxUHBg7pQ9VAvAg4bja76VqRBo4PxhQaA5bSAa1eq3oWk+r7RSzTwLVbZfLFQQVS7TZrtbr9YmC-yEuLJdKa3aWI7nR31e7PeWfdnA3m8NGwGGI1GY6LGRRp0bh-zU3B05mCUu46vgxv6TBhJpInoCdtXCbC8Oi5Ui10urQhRtVMxLDobLZynTRIUECsAAgug7D7AAJPUULoBBWqMDonRKEiShgEiPxAA}{Open in Shinylive} + \if{html}{\out{}} \if{html}{\out{}} } \item{example-2}{ - \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAokqUBiXQGEAIgEkAZS9dfihSKF04AA9YVBElUPCDYy5qAH1EqBsEsIijXQB3WlIACxV2TNxdECVdXUY4AEdBWgb2CDFSYmoiRkUIOoBBHwCAGWTdVIxMxERGYbGlAF9+gCsiFTSAazhWUQrc23z+OBMoYVI0gn5aUQI09c2dveBoeH3MuQBdN2h0CZUxXYtRCuV0AF5QeFcCC+EIRKIIbo4cIxMCBnVJjA0hI0lBRKIiARaGErBB0ZjMQ0TEjMmloqRmBo0qJUHACBTKZjMm89JCFGAFqMBTCMVzdKI4CINEjJdLLqz2ZzxXVqFB6FKkQKAlL2aRdFoWCT6CJECKQSrdAQShsCGIkYbGMaRFcbbQ7fsLZaoVBgMABUKBV8vqLvZiOdrnAANEW6AVYQZeVx4ONgLwAeUcADkHABNWMBrAAWQLYACDkGdkGAEZS+WE1WAEylvx2OwAMWFKYFACEi1gANJYZtgfphuSh71yvVwfhasAJpPmsUqky0KKzpHtwajAKuFeUsdcideuqOxGQukMpkKtkRg-c3K8+eBvCnzHTmWQz+3pXvylqhq1Dzjq8oGka6oImab4PpS1q2vakKOs6cCughnqwVymR+gGIxdsGk5hhGZbRqWi7JlUAoZtmealoMxZ1hWVa1t2ZZMYMI6UWArYdl2XF9oOw4CkelonphdQ-pu-JgAJQ6cf+mIwBctBxHy9hOM4hGruuUm6Nuu77qJ74iboR79P0tA0uwKjkDe2hwDYtg1BiohlBArCDOg7BoKgAAkLRVD5vmSowOh9MsShgEsXxAA}{Open in Shinylive} - \if{html}{\out{}} + \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAokqUBiXQGEAIgEkAZS9dfihSKF04AA9YVBElUPCDYy5qAH1EqBsEsIijXQB3WlIACxV2TNxdECVdXUY4AEdBWgb2CDFSYmoiRkUIOoBBHwCAGWTdVIxMxERGYbGlAF9+gCsiFTSAazhWUQrc23z+OBMoYVI0gn5aUQI09c2dveBoeH3MuQBdN2h0CZUxXYtRCuV0AF5QeFcCC+EIRKIIbo4cIxMCBnVJjA0hI0lBRKIiARaGErBB0ZjMQ0TEipqRmBBRCZejBZqhaAQtvsQZS6plRHBSNywAtRgowHIYRjeZM4NwMPSoIzmYxWYgtCwSfQERSZZiCCUNgQxEiCMCwAFnAANcVVcVYQZeVx4XTirwAeUcADkHABNW2ukVYACyAfFAQcgzsgwAjGGLZHowAmeN+Ox2ABiYpd4oAQsGsABpLApiVSvWYgUiDRwfhI+2O5083n9GWS5t1DWMRGQukMpkstkcrm6mX8wXC0Xi9vS3l9pUD1WzLtanUd3kGo0myFm8PW+MOp3xj3ev3xwYh+MRh3RuM5hM3walu1gNOZ7Mv-NFkvT8sV3RVnANZ1pCeYFsWz7rpSMAXLQcR6JCDguFBuiti2zZof0-S0DS7AqOQzCWDoNi2DUGKiGUECsIM6DsGgqAACQtFU9EMQKjA6H0yxKGASxfEAA}{Open in Shinylive} + \if{html}{\out{}} \if{html}{\out{}} } } diff --git a/man/tm_g_bivariate.Rd b/man/tm_g_bivariate.Rd index 09fd2e2d2..e583af210 100644 --- a/man/tm_g_bivariate.Rd +++ b/man/tm_g_bivariate.Rd @@ -6,11 +6,13 @@ \usage{ tm_g_bivariate( label = "Bivariate Plots", - x, + x = teal.transform::picks(teal.transform::datasets(), teal.transform::variables(choices + = is.numeric | teal.transform::is_categorical(min.len = 2, max.len = 10), selected = + 1L), teal.transform::values()), y, - row_facet = NULL, - col_facet = NULL, - facet = !is.null(row_facet) || !is.null(col_facet), + row_facet, + col_facet, + facet, color = NULL, fill = NULL, size = NULL, @@ -34,36 +36,33 @@ tm_g_bivariate( \item{label}{(\code{character(1)}) Label shown in the navigation item for the module or module group. For \code{modules()} defaults to \code{"root"}. See \code{Details}.} -\item{x}{(\code{data_extract_spec} or \code{list} of multiple \code{data_extract_spec}) -Variable names selected to plot along the x-axis by default. -Can be numeric, factor or character. -No empty selections are allowed.} +\item{x}{(\code{picks}) Variable specification for the x-axis. Created using \code{\link[teal.transform:picks]{teal.transform::picks()}}. +Can be numeric, factor or character. No empty selections are allowed.} -\item{y}{(\code{data_extract_spec} or \code{list} of multiple \code{data_extract_spec}) -Variable names selected to plot along the y-axis by default. +\item{y}{(\code{picks}) Variable specification for the y-axis. Created using \code{\link[teal.transform:picks]{teal.transform::picks()}}. Can be numeric, factor or character.} -\item{row_facet}{(\code{data_extract_spec} or \code{list} of multiple \code{data_extract_spec}) optional, -specification of the data variable(s) to use for faceting rows.} +\item{row_facet}{(\code{picks}) optional, specification of the data variable(s) to use for faceting rows. +Created using \code{\link[teal.transform:picks]{teal.transform::picks()}}.} -\item{col_facet}{(\code{data_extract_spec} or \code{list} of multiple \code{data_extract_spec}) optional, -specification of the data variable(s) to use for faceting columns.} +\item{col_facet}{(\code{picks}) optional, specification of the data variable(s) to use for faceting columns. +Created using \code{\link[teal.transform:picks]{teal.transform::picks()}}.} \item{facet}{(\code{logical}) optional, specifies whether the facet encodings \code{ui} elements are toggled on and shown to the user by default. Defaults to \code{TRUE} if either \code{row_facet} or \code{column_facet} are supplied.} -\item{color}{(\code{data_extract_spec} or \code{list} of multiple \code{data_extract_spec}) optional, -specification of the data variable(s) selected for the outline color inside the coloring settings. -It will be applied when \code{color_settings} is set to \code{TRUE}.} +\item{color}{(\code{picks}) optional, specification of the data variable(s) selected for the outline color +inside the coloring settings. It will be applied when \code{color_settings} is set to \code{TRUE}. +Created using \code{\link[teal.transform:picks]{teal.transform::picks()}}.} -\item{fill}{(\code{data_extract_spec} or \code{list} of multiple \code{data_extract_spec}) optional, -specification of the data variable(s) selected for the fill color inside the coloring settings. -It will be applied when \code{color_settings} is set to \code{TRUE}.} +\item{fill}{(\code{picks}) optional, specification of the data variable(s) selected for the fill color +inside the coloring settings. It will be applied when \code{color_settings} is set to \code{TRUE}. +Created using \code{\link[teal.transform:picks]{teal.transform::picks()}}.} -\item{size}{(\code{data_extract_spec} or \code{list} of multiple \code{data_extract_spec}) optional, -specification of the data variable(s) selected for the size of \code{geom_point} plots inside the coloring settings. -It will be applied when \code{color_settings} is set to \code{TRUE}.} +\item{size}{(\code{picks}) optional, specification of the data variable(s) selected for the size of +\code{geom_point} plots inside the coloring settings. It will be applied when \code{color_settings} is set to \code{TRUE}. +Created using \code{\link[teal.transform:picks]{teal.transform::picks()}}.} \item{use_density}{(\code{logical}) optional, indicates whether to plot density (\code{TRUE}) or frequency (\code{FALSE}). Defaults to frequency (\code{FALSE}).} @@ -109,9 +108,7 @@ To learn more check \code{vignette("transform-input-data", package = "teal")}.} \item{decorators}{\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}} (named \code{list} of lists of \code{teal_transform_module}) optional, decorator for tables or plots included in the module output reported. -The decorators are applied to the respective output objects. - -See section "Decorating Module" below for more details.} +The decorators are applied to the respective output objects.} } \value{ Object of class \code{teal_module} to be used in \code{teal} applications. @@ -165,42 +162,22 @@ data <- within(data, { app <- init( data = data, modules = tm_g_bivariate( - x = data_extract_spec( - dataname = "CO2", - select = select_spec( - label = "Select variable:", - choices = variable_choices(data[["CO2"]]), - selected = "conc", - fixed = FALSE - ) + label = "Bivariate Plots", + x = teal.transform::picks( + datasets("CO2"), + teal.transform::variables(selected = "conc") ), - y = data_extract_spec( - dataname = "CO2", - select = select_spec( - label = "Select variable:", - choices = variable_choices(data[["CO2"]]), - selected = "uptake", - multiple = FALSE, - fixed = FALSE - ) + y = teal.transform::picks( + datasets("CO2"), + teal.transform::variables(selected = "uptake") ), - row_facet = data_extract_spec( - dataname = "CO2", - select = select_spec( - label = "Select variable:", - choices = variable_choices(data[["CO2"]]), - selected = "Type", - fixed = FALSE - ) + row_facet = teal.transform::picks( + datasets("CO2"), + teal.transform::variables(selected = "Type") ), - col_facet = data_extract_spec( - dataname = "CO2", - select = select_spec( - label = "Select variable:", - choices = variable_choices(data[["CO2"]]), - selected = "Treatment", - fixed = FALSE - ) + col_facet = teal.transform::picks( + datasets("CO2"), + teal.transform::variables(selected = "Treatment") ) ) ) @@ -219,42 +196,22 @@ join_keys(data) <- default_cdisc_join_keys[names(data)] app <- init( data = data, modules = tm_g_bivariate( - x = data_extract_spec( - dataname = "ADSL", - select = select_spec( - label = "Select variable:", - choices = variable_choices(data[["ADSL"]]), - selected = "AGE", - fixed = FALSE - ) + label = "Bivariate Plots", + x = teal.transform::picks( + datasets("ADSL"), + teal.transform::variables(selected = "AGE") ), - y = data_extract_spec( - dataname = "ADSL", - select = select_spec( - label = "Select variable:", - choices = variable_choices(data[["ADSL"]]), - selected = "SEX", - multiple = FALSE, - fixed = FALSE - ) + y = teal.transform::picks( + datasets("ADSL"), + teal.transform::variables(selected = "SEX") ), - row_facet = data_extract_spec( - dataname = "ADSL", - select = select_spec( - label = "Select variable:", - choices = variable_choices(data[["ADSL"]]), - selected = "ARM", - fixed = FALSE - ) + row_facet = teal.transform::picks( + datasets("ADSL"), + teal.transform::variables(selected = "ARM") ), - col_facet = data_extract_spec( - dataname = "ADSL", - select = select_spec( - label = "Select variable:", - choices = variable_choices(data[["ADSL"]]), - selected = "COUNTRY", - fixed = FALSE - ) + col_facet = teal.transform::picks( + datasets("ADSL"), + teal.transform::variables(selected = "COUNTRY") ) ) ) @@ -266,13 +223,13 @@ if (interactive()) { \section{Examples in Shinylive}{ \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{}} + \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAokqUBiXVIhrqu-lCkULpwAB6wqCJKAUEGxlzUAPoxUDbRgcFGugDutKQAFirsKbi6IEq6uoxwAI6CtNXsPqKkxNREjIoQlQDCAPIATHH+GRgmzPDs-QNdAL5dSmiowyp57BUjsQC8m1C4G3xCIqK6O6QwiRKJ9NostIFw692VutRQ9HB+OwpgAEK3jHu5F0AAV2qRRD99s9KqFTroEhhSMwIKITB0YIhEKhaAQANaiJ4vF4pURwCHrMDTH5yaHEyqI5FQVHoxiYxBaO7vY7sMkiDRwfjwn7ECw0jaVWkS3SseGMlFojFYnH4wnSyqk8lqqmDGl0+ny5mKtlYzmA7liXmfOACoXfMCCVBBPFwcUw3RS92MIjZRImdTkuVwbhIhWs9kqglE+maik-algT30hHBnhMllKjlc+g8vk28h23Q-OysVCuxPSpMvNp+gOkIMh9PGiO4qPq3ZkuM6gZ69uGjMmrPmnOWvO24VgOzVQLwMhu4ldSVKLq0Ey6dgqcjMSw6Gy2crPUSFCCsACC6HYSwAJPVSteyYwdJ0lLMlGBZgBdIA}{Open in Shinylive} + \if{html}{\out{}} \if{html}{\out{}} } \item{example-2}{ - \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAokqUBiXQGEAIgEkAZS9dfihSKF04AA9YVBElUPCDYy5qAH1EqBsEsIijXQB3WlIACxV2TNxdECVdXUY4AEdBWgb2CDFSYmoiRkUIOoBBHwCAGWTdVIxMxERGYbGlAF9+gCsiFTSAazhWUQrc23z+OBMoYVI0gn5aUQI09c2dveBoeH3MuQBdN2h0CZUxXYtRCuV0AF5QeFcCC+EIRKIIZMYGkJGl6NoWLQwnBgQM6rookjMmloqRmBo0qJUHACHiCQTMm89JCFGAFqM2TD8QzRHARBokXyBZdqbT6QyCdQoPR+Ui2QF+bTSLotFiZSJEFyQZLdAQShsCGIkWrGNj6CIrgbaEaPrlgMA2Ry2V8vnJubq6sLlXB+PL2QBxVx4HWSky0KK+pEAMUGowCrh5BP6DPdodYxNypKi5PUoppdNDdSZsBZuidI05IaTXqVgsh3spYsLNalMrlrLAipFqvVFrgWurnr11ttJr7lv1hrEB3CDorizArrTrdrIqjnYTAA1tavdDALrQ4mXY-HnB7PeHI37IaeE0XdCnkxe6owiAU0mcjSrISSyRT83FB8S3gf1nSHSVGx-XQoKpAsJV1aVZWof1u2VXszQ1Add2HKcbWNSFTXNSdRxnTJ53ZSsXTdF9ILrcgb3LdksAAWRwy8Iw3XQ70TXUnzqFcGW6T91DgaC-xzAC4KA1sQLLBcq1otd0IbejpJbYckI7Ji0MFIisMHJSCTwsdCInOArWnO050dSjF2XIzlI0Li2S8AB5RwADkHAATXY3Ury4niH34x8QX6fpaBMXR2BUcgAO0XE5FsGp8VEMoIFYQZ0HYNBUAAEhaKo8vyvlGB0PpliUMAli+IA}{Open in Shinylive} - \if{html}{\out{}} + \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAokqUBiXQGEAIgEkAZS9dfihSKF04AA9YVBElUPCDYy5qAH1EqBsEsIijXQB3WlIACxV2TNxdECVdXUY4AEdBWgb2CDFSYmoiRkUIOoBBHwCAGWTdVIxMxERGYbGlAF9+gCsiFTSAazhWUQrc23z+OBMoYVI0gn5aUQI09c2dveBoeH3MuQBdN2h0CZUxXYtRCuV0AF5QeFcCC+EIRKIIZMYGkJGl6NoWLQwnBgQM6rpqFB6HBqEiFGAAEKYxjY8i6AAKPVIogpMPxdSiSKmpGYEFEJl6MFmqFoBC2+xBBKhUFEcBZwLAC1GFLk7OldR5fIFQtmWixxIR7DlIg0cH45KVAHFXGB+tK1VLdKxuXBuBheVB+YLGMLEKLxZKOQTMnKFRTlar1RqtV6db69Qb6EaTXAzRbIRSAs4ABqqp2O4OMIgFNJnAjy13uz3e3X+sUSvEamVhyVKkYqu3R6Wx2sJxD62mGsTG0lp8gZ3QRrAAWXzwcL0u6ZfUlchvfjfoDjaddVD8rbka7u8mbp4Nc3iaHyZHqfTlq8AHlHAA5BwATXnDpB-X6tBMujsCo5DMJYOg2LYNT4qIZQQKwgzoOwaCoAAJC0VTIShcqMDofTLEoYBLF8QA}{Open in Shinylive} + \if{html}{\out{}} \if{html}{\out{}} } } diff --git a/man/tm_g_distribution.Rd b/man/tm_g_distribution.Rd index 5f5058bf2..ad3391d66 100644 --- a/man/tm_g_distribution.Rd +++ b/man/tm_g_distribution.Rd @@ -6,7 +6,8 @@ \usage{ tm_g_distribution( label = "Distribution Module", - dist_var, + dist_var = teal.transform::picks(teal.transform::datasets(), + teal.transform::variables(is.numeric), teal.transform::values()), strata_var = NULL, group_var = NULL, freq = FALSE, @@ -25,13 +26,13 @@ tm_g_distribution( \item{label}{(\code{character(1)}) Label shown in the navigation item for the module or module group. For \code{modules()} defaults to \code{"root"}. See \code{Details}.} -\item{dist_var}{(\code{data_extract_spec} or \code{list} of multiple \code{data_extract_spec}) +\item{dist_var}{(\code{picks} or \code{list} of multiple \code{picks}) Variable(s) for which the distribution will be analyzed.} -\item{strata_var}{(\code{data_extract_spec} or \code{list} of multiple \code{data_extract_spec}) +\item{strata_var}{(\code{picks} or \code{list} of multiple \code{picks}) Categorical variable used to split the distribution analysis.} -\item{group_var}{(\code{data_extract_spec} or \code{list} of multiple \code{data_extract_spec}) +\item{group_var}{(\code{picks} or \code{list} of multiple \code{picks}) Variable used for faceting plot into multiple panels.} \item{freq}{(\code{logical}) optional, whether to display frequency (\code{TRUE}) or density (\code{FALSE}). @@ -71,9 +72,7 @@ To learn more check \code{vignette("transform-input-data", package = "teal")}.} \item{decorators}{\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}} (named \code{list} of lists of \code{teal_transform_module}) optional, decorator for tables or plots included in the module output reported. -The decorators are applied to the respective output objects. - -See section "Decorating Module" below for more details.} +The decorators are applied to the respective output objects.} } \value{ Object of class \code{teal_module} to be used in \code{teal} applications. @@ -123,9 +122,10 @@ app <- init( data = data, modules = list( tm_g_distribution( - dist_var = data_extract_spec( - dataname = "iris", - select = select_spec(variable_choices("iris"), "Petal.Length") + dist_var = teal.transform::picks( + datasets("iris"), + teal.transform::variables(is.numeric), + teal.transform::values() ) ) ) @@ -141,39 +141,22 @@ data <- within(data, { }) join_keys(data) <- default_cdisc_join_keys[names(data)] - app <- init( data = data, modules = modules( tm_g_distribution( - dist_var = data_extract_spec( - dataname = "ADSL", - select = select_spec( - choices = variable_choices("ADSL", c("AGE", "BMRKR1")), - selected = "BMRKR1", - multiple = FALSE, - fixed = FALSE - ) + dist_var = teal.transform::picks( + datasets("ADSL"), + teal.transform::variables(c("BMRKR1", "AGE")), + values(multiple = FALSE) ), - strata_var = data_extract_spec( - dataname = "ADSL", - filter = filter_spec( - vars = choices_selected( - variable_choices("ADSL", c("ARM", "COUNTRY", "SEX")), - selected = NULL - ), - multiple = TRUE - ) + strata_var = teal.transform::picks( + datasets("ADSL"), + teal.transform::variables(c("ARM", "COUNTRY", "SEX"), selected = NULL) ), - group_var = data_extract_spec( - dataname = "ADSL", - filter = filter_spec( - vars = choices_selected( - variable_choices("ADSL", c("ARM", "COUNTRY", "SEX")), - selected = "ARM" - ), - multiple = TRUE - ) + group_var = teal.transform::picks( + datasets("ADSL"), + teal.transform::variables(c("ARM", "COUNTRY", "SEX"), selected = NULL) ) ) ) @@ -186,13 +169,13 @@ if (interactive()) { \section{Examples in Shinylive}{ \describe{ \item{example-1}{ - \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAokqUBiXVIhrqu-lCkULpwAB6wqCJKAUEGxlzUAPoxUDbRgcFGugDutKQAFirsKbi6IEq6urSMtKJxVTWiSgC+ihBKaKj1KnnsFf4ZugC8A0G4-XxCInUjdKKkfRCVlaQwiRLJtaQ19IKa1v3L-luJWizDo1CJYdvqpImiqHAEi0dHKdDwFwpg1bU-4yWb0qojgIg0F1B4Puj2e7DONSg9BEiQI+SItAIYj6v0aPzkpR+AAU4EEeAAZCgSAr4w7LNpHBm6NptWgmXTsFTkZiWHQ2WzlIGiQoQVgAQXQ7E6ABJBLRSjLQYwdIw2s0lGBmgBdIA}{Open in Shinylive} - \if{html}{\out{}} + \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAokqUBiXVIhrqu-lCkULpwAB6wqCJKAUEGxlzUAPoxUDbRgcFGugDutKQAFirsKbi6IEq6urSMtKJxVTWiSgC+ihBKaKj1KnnsFf4ZugC8A0G4-XxCInUjdKKkfRCVlaQwiRLJtaQ19IKa1v3L-luJWizDugkY21AQoiZEjDCIiKi0BADWootHRymicFI3wUYGqtRBcnGS1+Kzg3GuzDuDyeLzONSg9Gm7FqGAggngNQIkMOvyuNyRj2eiDO1EEYjS0KObSZ-TabVoJl02NUzEsOhstnK0NEhQgrAAguh2J0ACSCWilWUAxg6RhtZpKMDNAC6QA}{Open in Shinylive} + \if{html}{\out{}} \if{html}{\out{}} } \item{example-2}{ - \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAokqUBiXQGEAIgEkAZS9dfihSKF04AA9YVBElUPCDYy5qAH1EqBsEsIijXQB3WlIACxV2TNxdECVdXQBBHwCAGWTdVIxMxERGRpalAF9FCAArIhU0gGs4VlEK3Nt8-jgTKGFSNIJ+WlECNLGJ6dngaHg5zLkAXTcIJTRUNpVi9lqQ3N0AXjfw3Fe+IREok+un+wjELwgdTqpBgaQkGR2pEYDEEmmsryhIURaS0LGBmTS0SR6g2olQcAIEMxmMypz0XwUYD6zUZv0h1LqojgIg0wK5PNJ5MpGI5ugIJXGBDEwNxyKg9BEmwltClc0ZzNZYpeTIA4q48LpGQAhACyWAA0lgAIyMuRyNmiqH8inkfjA41my02vAijkwda0OL03QAMXqzQCzgdjtMtCicDdXzDEdc7I5w3T0cxomJ4RxeK+BKJzA0aTJFKpotpsGD6qaLJ9aepJlo1HIjGBLbbMjLQsrjtlQK+4slYjL3JdCf7MdltHlipHKvBdf6BuFTKwJs1jK8AHlHAA5BwATW3YEjAA1bfbfaLnRoE8CD45miym5nb5j-W3AyJgQ4XE-XQM2pG9310CRGCIQRUHzDtC1yQkomJUty2FcC6mreB3SZetWSArt207Vt217CsgLqQdgUXVVxwFKcKKhWd5zgJVRzVXDVyqdd6k3M890PE8z0va8sxje9XRw3itzARiwJjEEAyDf8nFTR0QMxDTgNeYZhloExdHYFR2xJbQ4BsWwanZUQyggVh6nQdh7gAEkEWgqhcrlGB0RhhgGJQwAGS4gA}{Open in Shinylive} - \if{html}{\out{}} + \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAokqUBiXQGEAIgEkAZS9dfihSKF04AA9YVBElUPCDYy5qAH1EqBsEsIijXQB3WlIACxV2TNxdECVdXQBBHwCAGWTdVIxMxERGRpalAF9FCAArIhU0gGs4VlEK3Nt8-jgTKGFSNIJ+WlECNLGJ6dngaHg5zLkAXTdodDaVYvZakNzdAF4X8NxnviERUXeul+wjETwgdTqpBgaQkGR2pEYDEEmmszwhIXhaS0LEBHQRUAgohMREYMG6qFoBEmczR6M+UFEcFINLAfWaCjAcm+4LpkLg3Aw+MJxNJ3WxiKg9H+7AITzAACEALJYADSWAAjByqhz6gBxVycrm09HY6iCUEwda0OJ6D4AMXqzQCzmGvKNPPRonx4SxOI+eOYwpJZMQFKpNI9dMyjOZcrZHPdvL5AqFRODYpYtEl0tlOqwiq1ug5XgA8o4AHIOACahY5zoAGgmqoyRBo4PxAeXHM1mq66Ym6RJGERBKhfYxcfyeKmRSGw9SwUn6TGWfHOdylwGCWnRYhxVmpaDc6z87WwKWK9Wzw2m7oW3A2x2Pl2e330W-dH3hsNaCZdOwVHIZhLB0GxbBqHlRDKCBWHqdB2DQVAABJBFoKpEKQxlGB0RhhgGJQwAGS4gA}{Open in Shinylive} + \if{html}{\out{}} \if{html}{\out{}} } } diff --git a/man/tm_g_response.Rd b/man/tm_g_response.Rd index 2a617112a..dae81ab32 100644 --- a/man/tm_g_response.Rd +++ b/man/tm_g_response.Rd @@ -6,7 +6,9 @@ \usage{ tm_g_response( label = "Response Plot", - response, + response = teal.transform::picks(teal.transform::datasets(), + teal.transform::variables(choices = teal.transform::is_categorical(min.len = 2, + max.len = 10)), teal.transform::values()), x, row_facet = NULL, col_facet = NULL, @@ -28,22 +30,18 @@ tm_g_response( \item{label}{(\code{character(1)}) Label shown in the navigation item for the module or module group. For \code{modules()} defaults to \code{"root"}. See \code{Details}.} -\item{response}{(\code{data_extract_spec} or \code{list} of multiple \code{data_extract_spec}) +\item{response}{(\code{picks}) Which variable to use as the response. -You can define one fixed column by setting \code{fixed = TRUE} inside the \code{select_spec}. +The \code{picks} must not allow multiple variable selection in this case.} -The \code{data_extract_spec} must not allow multiple selection in this case.} - -\item{x}{(\code{data_extract_spec} or \code{list} of multiple \code{data_extract_spec}) +\item{x}{(\code{picks} ) Specifies which variable to use on the X-axis of the response plot. -Allow the user to select multiple columns from the \code{data} allowed in teal. - -The \code{data_extract_spec} must not allow multiple selection in this case.} +The \code{picks} must not allow multiple selection in this case.} -\item{row_facet}{(\code{data_extract_spec} or \code{list} of multiple \code{data_extract_spec}) +\item{row_facet}{(\code{picks}) optional specification of the data variable(s) to use for faceting rows.} -\item{col_facet}{(\code{data_extract_spec} or \code{list} of multiple \code{data_extract_spec}) +\item{col_facet}{(\code{picks}) optional specification of the data variable(s) to use for faceting columns.} \item{coord_flip}{(\code{logical(1)}) @@ -89,9 +87,7 @@ To learn more check \code{vignette("transform-input-data", package = "teal")}.} \item{decorators}{\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}} (named \code{list} of lists of \code{teal_transform_module}) optional, decorator for tables or plots included in the module output reported. -The decorators are applied to the respective output objects. - -See section "Decorating Module" below for more details.} +The decorators are applied to the respective output objects.} } \value{ Object of class \code{teal_module} to be used in \code{teal} applications. @@ -151,25 +147,25 @@ app <- init( modules = modules( tm_g_response( label = "Response Plots", - response = data_extract_spec( - dataname = "mtcars", - select = select_spec( - label = "Select variable:", - choices = variable_choices(data[["mtcars"]], c("cyl", "gear")), + response = picks( + datasets("mtcars"), + variables( + choices = c("cyl", "gear"), selected = "cyl", multiple = FALSE, fixed = FALSE - ) + ), + teal.transform::values() ), - x = data_extract_spec( - dataname = "mtcars", - select = select_spec( - label = "Select variable:", - choices = variable_choices(data[["mtcars"]], c("vs", "am")), + x = teal.transform::picks( + datasets("mtcars"), + teal.transform::variables( + choices = c("vs", "am"), selected = "vs", multiple = FALSE, fixed = FALSE - ) + ), + teal.transform::values() ) ) ) @@ -191,25 +187,21 @@ app <- init( modules = modules( tm_g_response( label = "Response Plots", - response = data_extract_spec( - dataname = "ADSL", - select = select_spec( - label = "Select variable:", - choices = variable_choices(data[["ADSL"]], c("BMRKR2", "COUNTRY")), - selected = "BMRKR2", - multiple = FALSE, - fixed = FALSE - ) + response = teal.transform::picks( + datasets("ADSL"), + teal.transform::variables( + choices = c("BMRKR2", "COUNTRY"), + selected = "BMRKR2" + ), + teal.transform::values() ), - x = data_extract_spec( - dataname = "ADSL", - select = select_spec( - label = "Select variable:", - choices = variable_choices(data[["ADSL"]], c("SEX", "RACE")), - selected = "RACE", - multiple = FALSE, - fixed = FALSE - ) + x = teal.transform::picks( + datasets("ADSL"), + teal.transform::variables( + choices = c("SEX", "RACE"), + selected = "RACE" + ), + teal.transform::values() ) ) ) @@ -222,13 +214,13 @@ if (interactive()) { \section{Examples in Shinylive}{ \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{}} + \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAokqUBiXVIhrqu-lCkULpwAB6wqCJKAUEGxlzUAPoxUDbRgcFGugDutKQAFirsKbi6IEq6uoxwAI6CtNXsPqKkxNREjIoQlTCtLKJxur0E-RWmHbrsWroqugTsCoSs1Iuli1qiq7qLsFuLUiyLcrbl3ZVDfYyiwMBaALp3g1DiJuqkHezD-Tf3d12VAF8lACuko0KhBio8gszildABefwZXBjPhCEQDRFo4RiGHnXSkGCJCSJaqiVAkURwPH43TUKD0OB+RGLLBiCkQKm6AAK7VImzwY3xZI5XMRqFoBAA1qIabSkUEqfyFmAvlcjiizvKtCxaAyMXL5XN8kRJWIEXMVQRlnswAdGBqhUaqSINHB+BbFtaVoKtUaYMJNJE9IiAGIAQQAMgBlZyao3nEy0ULui0RmOuP34uTxo0JDCkZickwdGCIRA66iCXH-Wk5p2VUIW-OFqDF0vliXS2UN84pJU91WXAX1rPnFtF0Qlxhliu6-W43v4ggms2Yy3rAVrFAwR1j-EuuBuj0ssAbVZL84B6hBkRpqOx3MJpMpk+6dOxy+jhMTttTjtzlWNa9rWlS1l0XS0CYkwqOQzCWDoNgnGMoiFBArDhug7DggAJPUpS4VSjA6J0wJKGAAJ3EAA}{Open in Shinylive} + \if{html}{\out{}} \if{html}{\out{}} } \item{example-2}{ - \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAokqUBiXQGEAIgEkAZS9dfihSKF04AA9YVBElUPCDYy5qAH1EqBsEsIijXQB3WlIACxV2TNxdECVdXUY4AEdBWgb2CDFSYmoiRkUIOoBBHwCAGWTdVIxMxERGYbGlAF9+gCsiFTSAazhWUQrc23z+OBMoYVI0gn5aUQI09c2dveBoeH3MuQBdN2h0CZUxXYtRCuV0AF5QeFcCC+EIRKIIbo4cIxMCBnVJjA0hI0g1RKgSKI4OjMZjqFB6HBqEiFGAsGJCRBiboAAo9UiiOkwjFk-FMlmQzJpaKkZgaNIEuAEUlkzGZN56SF0hajbkguW6YkiDRI7XSy5SmUazW6ClUmnKsABakG3RaFi0SkiRDq3mmgglDYEMRIh2MJ30ERXL20H0fXLAYAqkZqsBfL5VY1gABCAFksABpLAAJm5ujpXgA8o4AHIOACadLkch5psx+o0cH4tNTGezebwJs1MAutDiSt0ADFBqMAs46-XTLQos2kSOx653WT+pra93dFEkcLReLDahpbLNQrYIOY4su8uG7bdZDG-vDxuyebqa2bTrSPbHc64K7L1PdE9b1fUhf1A2DICwzRTIo3POMEyTYFrWcAANfM6SwQYvFcMAa0net7znK1MOwt0AN7ahNAHedR3HfDTRMGciOHWil3rVc5Q4uoOP6fpaBMXR2BUcg920Eka2qEFRDKCBWEGdB2DQVAABIWiqJTlOJRgdD6ZYlDAJYviAA}{Open in Shinylive} - \if{html}{\out{}} + \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAokqUBiXQGEAIgEkAZS9dfihSKF04AA9YVBElUPCDYy5qAH1EqBsEsIijXQB3WlIACxV2TNxdECVdXUY4AEdBWgb2CDFSYmoiRkUIOoBBHwCAGWTdVIxMxERGYbGlAF9+gCsiFTSAazhWUQrc23z+OBMoYVI0gn5aUQI09c2dveBoeH3MuQBdN2h0CZUxXYtRCuV0AF5QeFcCC+EIRKIIbo4cIxMCBnVJjA0hI0g1RKgSKI4OjMZjqFB6HBqEiFGAsGJCRBiboAAo9UiiOkwjFk-FMlmQqakZjMky9GCzVC0AhbfYgsl1TLEznAsALUZ0uQ8xWY4Wi0TixiSxBaFi0SkI0m6zEEEobAhiJEENUAIQAslgANJYABM3N0dK8AHlHAA5BwATS1OptdWJIg0cH4tLAHu9frpCsV2uzZP1UDFEtmZuogjR-V1ud5mKiSILReNUplcutuuVcFVdI1Mbzerg3AwIsLhuLpvNlrRfbJdodTshLrpAWcAA0A3SsIMvK4wNW4-HqXAkynIRutzvp7o9zaG6Om+OyxW+5XMS-+v1aCZdOwVORmJYdBsWwagxUQyggVhBnQdg0FQAASFoqlguDiUYHQ+mWJQwCWL4gA}{Open in Shinylive} + \if{html}{\out{}} \if{html}{\out{}} } } diff --git a/man/tm_g_scatterplot.Rd b/man/tm_g_scatterplot.Rd index 556c87b34..0327ff83b 100644 --- a/man/tm_g_scatterplot.Rd +++ b/man/tm_g_scatterplot.Rd @@ -6,7 +6,8 @@ \usage{ tm_g_scatterplot( label = "Scatterplot", - x, + x = teal.transform::picks(teal.transform::datasets(), + teal.transform::variables(is.numeric), teal.transform::values()), y, color_by = NULL, size_by = NULL, @@ -32,22 +33,22 @@ tm_g_scatterplot( \item{label}{(\code{character(1)}) Label shown in the navigation item for the module or module group. For \code{modules()} defaults to \code{"root"}. See \code{Details}.} -\item{x}{(\code{data_extract_spec} or \code{list} of multiple \code{data_extract_spec}) Specifies +\item{x}{(\code{picks} or \code{list} of multiple \code{picks}) Specifies variable names selected to plot along the x-axis by default.} -\item{y}{(\code{data_extract_spec} or \code{list} of multiple \code{data_extract_spec}) Specifies +\item{y}{(\code{picks} or \code{list} of multiple \code{picks}) Specifies variable names selected to plot along the y-axis by default.} -\item{color_by}{(\code{data_extract_spec} or \code{list} of multiple \code{data_extract_spec}) optional, +\item{color_by}{(\code{picks} or \code{list} of multiple \code{picks}) optional, defines the color encoding. If \code{NULL} then no color encoding option will be displayed.} -\item{size_by}{(\code{data_extract_spec} or \code{list} of multiple \code{data_extract_spec}) optional, +\item{size_by}{(\code{picks} or \code{list} of multiple \code{picks}) optional, defines the point size encoding. If \code{NULL} then no size encoding option will be displayed.} -\item{row_facet}{(\code{data_extract_spec} or \code{list} of multiple \code{data_extract_spec}) optional, +\item{row_facet}{(\code{picks} or \code{list} of multiple \code{picks}) optional, specifies the variable(s) for faceting rows.} -\item{col_facet}{(\code{data_extract_spec} or \code{list} of multiple \code{data_extract_spec}) optional, +\item{col_facet}{(\code{picks} or \code{list} of multiple \code{picks}) optional, specifies the variable(s) for faceting columns.} \item{plot_height}{(\code{numeric}) optional, specifies the plot height as a three-element vector of @@ -102,9 +103,7 @@ To learn more check \code{vignette("transform-input-data", package = "teal")}.} \item{decorators}{\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}} (named \code{list} of lists of \code{teal_transform_module}) optional, decorator for tables or plots included in the module output reported. -The decorators are applied to the respective output objects. - -See section "Decorating Module" below for more details.} +The decorators are applied to the respective output objects.} } \value{ Object of class \code{teal_module} to be used in \code{teal} applications. @@ -159,68 +158,47 @@ app <- init( modules = modules( tm_g_scatterplot( label = "Scatterplot Choices", - x = data_extract_spec( - dataname = "CO2", - select = select_spec( - label = "Select variable:", - choices = variable_choices(data[["CO2"]], c("conc", "uptake")), - selected = "conc", - multiple = FALSE, - fixed = FALSE - ) + x = teal.transform::picks( + datasets("CO2"), + teal.transform::variables( + choices = c("conc", "uptake"), + selected = "conc" + ), + teal.transform::values() ), - y = data_extract_spec( - dataname = "CO2", - select = select_spec( - label = "Select variable:", - choices = variable_choices(data[["CO2"]], c("conc", "uptake")), - selected = "uptake", - multiple = FALSE, - fixed = FALSE - ) + y = teal.transform::picks( + datasets("CO2"), + teal.transform::variables( + choices = c("conc", "uptake"), + selected = "uptake" + ), + teal.transform::values() ), - color_by = data_extract_spec( - dataname = "CO2", - select = select_spec( - label = "Select variable:", - choices = variable_choices( - data[["CO2"]], - c("Plant", "Type", "Treatment", "conc", "uptake") - ), - selected = NULL, - multiple = FALSE, - fixed = FALSE - ) + color_by = teal.transform::picks( + datasets("CO2"), + teal.transform::variables( + choices = c("Plant", "Type", "Treatment", "conc", "uptake"), + selected = NULL + ), + teal.transform::values() ), - size_by = data_extract_spec( - dataname = "CO2", - select = select_spec( - label = "Select variable:", - choices = variable_choices(data[["CO2"]], c("conc", "uptake")), - selected = "uptake", - multiple = FALSE, - fixed = FALSE - ) + size_by = teal.transform::picks( + datasets("CO2"), + teal.transform::variables(choices = c("conc", "uptake"), selected = "uptake"), + teal.transform::values() ), - row_facet = data_extract_spec( - dataname = "CO2", - select = select_spec( - label = "Select variable:", - choices = variable_choices(data[["CO2"]], c("Plant", "Type", "Treatment")), - selected = NULL, - multiple = FALSE, - fixed = FALSE - ) + row_facet = teal.transform::picks( + datasets("CO2"), + teal.transform::variables( + choices = c("Plant", "Type", "Treatment"), + selected = NULL + ), + teal.transform::values() ), - col_facet = data_extract_spec( - dataname = "CO2", - select = select_spec( - label = "Select variable:", - choices = variable_choices(data[["CO2"]], c("Plant", "Type", "Treatment")), - selected = NULL, - multiple = FALSE, - fixed = FALSE - ) + col_facet = teal.transform::picks( + datasets("CO2"), + teal.transform::variables(choices = c("Plant", "Type", "Treatment"), selected = NULL), + teal.transform::values() ) ) ) @@ -242,68 +220,35 @@ app <- init( modules = modules( tm_g_scatterplot( label = "Scatterplot Choices", - x = data_extract_spec( - dataname = "ADSL", - select = select_spec( - label = "Select variable:", - choices = variable_choices(data[["ADSL"]], c("AGE", "BMRKR1", "BMRKR2")), - selected = "AGE", - multiple = FALSE, - fixed = FALSE - ) + x = teal.transform::picks( + datasets("ADSL"), + teal.transform::variables(choices = c("AGE", "BMRKR1", "BMRKR2"), selected = "AGE"), + teal.transform::values() ), - y = data_extract_spec( - dataname = "ADSL", - select = select_spec( - label = "Select variable:", - choices = variable_choices(data[["ADSL"]], c("AGE", "BMRKR1", "BMRKR2")), - selected = "BMRKR1", - multiple = FALSE, - fixed = FALSE - ) + y = teal.transform::picks( + datasets("ADSL"), + teal.transform::variables(choices = c("AGE", "BMRKR1", "BMRKR2"), selected = "BMRKR1"), + teal.transform::values() ), - color_by = data_extract_spec( - dataname = "ADSL", - select = select_spec( - label = "Select variable:", - choices = variable_choices( - data[["ADSL"]], - c("AGE", "BMRKR1", "BMRKR2", "RACE", "REGION1") - ), - selected = NULL, - multiple = FALSE, - fixed = FALSE - ) + color_by = teal.transform::picks( + datasets("ADSL"), + teal.transform::variables(c("AGE", "BMRKR1", "BMRKR2", "RACE", "REGION1"), selected = NULL), + teal.transform::values() ), - size_by = data_extract_spec( - dataname = "ADSL", - select = select_spec( - label = "Select variable:", - choices = variable_choices(data[["ADSL"]], c("AGE", "BMRKR1")), - selected = "AGE", - multiple = FALSE, - fixed = FALSE - ) + size_by = teal.transform::picks( + datasets("ADSL"), + teal.transform::variables(choices = c("AGE", "BMRKR1"), selected = "AGE"), + teal.transform::values() ), - row_facet = data_extract_spec( - dataname = "ADSL", - select = select_spec( - label = "Select variable:", - choices = variable_choices(data[["ADSL"]], c("BMRKR2", "RACE", "REGION1")), - selected = NULL, - multiple = FALSE, - fixed = FALSE - ) + row_facet = teal.transform::picks( + datasets("ADSL"), + teal.transform::variables(choices = c("BMRKR2", "RACE", "REGION1"), selected = NULL), + teal.transform::values() ), - col_facet = data_extract_spec( - dataname = "ADSL", - select = select_spec( - label = "Select variable:", - choices = variable_choices(data[["ADSL"]], c("BMRKR2", "RACE", "REGION1")), - selected = NULL, - multiple = FALSE, - fixed = FALSE - ) + col_facet = teal.transform::picks( + datasets("ADSL"), + teal.transform::variables(choices = c("BMRKR2", "RACE", "REGION1"), selected = NULL), + teal.transform::values() ) ) ) @@ -316,13 +261,13 @@ if (interactive()) { \section{Examples in Shinylive}{ \describe{ \item{example-1}{ - \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAokqUBiXVIhrqu-lCkULpwAB6wqCJKAUEGxlzUAPoxUDbRgcFGugDutKQAFirsKbi6IEq6uoxwAI6CtNXsPqKkxNREjIoQlQDCAPIATHG6-QNKAL5dSmiowyp57BX+GboAvMtBuEt8QiKia7o7wmKL3ZW6pDCJEomiBIHkjJFEpKfn59RQ9HB+6wpgAGV7qRHs9SCN8kRaAQxP8tmd3qEDilEmFSMwNLdUHACG93ucUtB4Ad-qM4Ut8bpRD8ceD1tSRJjRNjcRTKbpPt9frp-gCaRpdFoWLQviJEOSEeyCJDoWIDkLGCL6CJEtKoTDRMUMsBgKTBv8ALoG0qswgkAhwnlgQSoIIAazg-zkcnh7PODNpcH4JLNFglbsqMGEmkienWADEAIIAGQBzldAZMtFCXoOUdjrkl7y6lJdbMqrGRGVRoXR6lIWJxeMphNgYatZLw+fd-LpVNbldZWfxnJ+Pr5jPBCqVYv9AbVsv262HorgqplGq1QR1erGYCNJsWvoteCtNvtjrAzoTbo9GlTf2ttqgDrHbqD1BDIjTMbjJ-ZSZT3ojr8zbpz+J5t2bQdIk9CFusKJohiFbMlWzaVLWxKXo277vGebYYZ21bsr23K8q2grCrO4pNt27wThq8rEcqc6UScCH4ikK5gI2G6MRRW4AAqfGQlr-HYrDYvxYB2NUgTwHxu7-MQfrSVeB5OhxuhAQG7aDheugAHKONG0ZofiD5PvW6Zvspn6aaZf7sgB2YGaItAAF5zuBRZBCWZZMiyOHvEh9arne+IYQcWFwV2al4f2hEzrRpEGRRC5ytONEqvRmrMbqrH6uuxq6Kask7qU-z7jeh7HspGGacV163mRalGbQoYvhm8XnBZ366FZjG2ecqn4owRDZIkJjqHAbZQaWMHYYxfk+qhjHBfSHZhT5PZfH2l4DrSRGKiRgWUml1G7bR87qicGUBTlm7-DxUBSUVolCYeD1iXAEkUKQTp9aeraaTpemtYGwaNc+P4teZyaWb+3XNt95xtMNo3jcW0HltN5EbHddZzdlrWLeptLoxF634YC0UpXAcXKYdyXHaliXpdqmVsblpq3fdVqCcJ8mve9UnlRjlSVR1-36cpDVNWDZmC6YkMdV1GM9ZUPUAV0XS0CYujsCojzltocA2LY5RnKIhQQKwkboOwMwACT1KUtvUowOidBMShgOMBpAA}{Open in Shinylive} - \if{html}{\out{}} + \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAokqUBiXVIhrqu-lCkULpwAB6wqCJKAUEGxlzUAPoxUDbRgcFGugDutKQAFirsKbi6IEq6uoxwAI6CtNXsPqKkxNREjIoQlQDCAPIATHG6-QNKAL5dSmiowyp57BX+GboAvMtBuEt8QiKia7o7wmKL3ZW6pDCJEomiBIHkjJFEpKfn59RQ9HB+6wpgAGV7qRHs9SCN8kRaAQxP8tmd3qEDgkMKRmBBRCYOjBEIhUNCANaiN7vc4pURwUjE-6jf5yeGk84otFQDFYxg4xBaFi0L57EmMyoESHQsQHAiLQgkAhw3T-QSoIIEuB0hmCyoUkQaOD8A7-YgWf5LRn042k5nozHY3Hc6iCE5dE1q96sZFwbioy3szn4ghEgWk8mU6lgWlgU0I83ungstnWrk8vknM2M4VQmH7dYS-XS2XyxVQZWqlOkzVwbW6v5gBVKlVgEuVCPqi2sq0cm3ce3Ex2kpuktodRL0V3rFtx9t4wnUyPvINUyVhvuMsdtzncxi8+j8hvnNOizO6bNgAAKnzIebAdlYqDrpX+dmqgXg57wcqlhtf+drxZnpZ+5fIStdAAOUcAAZMCdyXKMPVjVcOztB0S2gjVaAALzgIcRwuaNPVbb1cV9f0dznENF2dGCYy9eN103fk9wzcVJQNGVP2rAsi3DUoywrPV2O-LidxXAiE0Q7tkIoypGCIbJEhMdRKTdWDqInIjp3VUiF0GH9m1wuCRNopN1PVQ8RUYrNJVPVlSAvK8b1sx9LgoGzBN-d4eMAg5QIgqDJKZPSVLXTskN-FDDyIJJ5JhcFRwC-D4zUgNZwyCl5xpbTXN05T4onQytxOBixQs-4rJfO9L2vW83wfd0nJfeldA8nUvPAsCwsqYSaOC8TQrNHsui6WgTF0dgVEedRNB0GxbHKM5REKCBWAAQXQdgZgAEnqUoNopRgdE6CYlDAcYAF0gA}{Open in Shinylive} + \if{html}{\out{}} \if{html}{\out{}} } \item{example-2}{ - \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAokqUBiXQGEAIgEkAZS9dfihSKF04AA9YVBElUPCDYy5qAH1EqBsEsIijXQB3WlIACxV2TNxdECVdXUY4AEdBWgb2CDFSYmoiRkUIOoBBHwCAGWTdVIxMxERGYbGlAF9+gCsiFTSAazhWUQrc23z+OBMoYVI0gn5aUQI09c2dveBoeH3MuQBdN2h0CZUxXYtRCuV0AF5QeFcCC+EIRKIIbo4cIxMCBnVJjA0hI0ncwuRGHEiKR0ZjMdQoPQ4NQkQowAECASZMTSN4ShsCGJ6TCMeSokjMmloqRmBo8ag4AQyeTMZk3npIfSFqMeSDZbpRDSpWzIVqROLRJLpeqNbpKdTaUqGdqNLotCxaFSRIg1XyzQQObQuYjIQ7GE76CIrl6fQdwsBgMqRqqwF8vlUTWBBgBxVx4XT0gBCAFksABpLAARh5mbAuYLWAATPS5HJeWbMfqdXB+HTk2m3Y26jALrQ4ordAAxQajALOBvdky0KKtpEjseud3k-oa+umuqsQW5YVRUXqS5GqUyjXy2CD6OLPAbpu23Wau8S4838kWmntgJ3+2O51wV3X5dZU9TkxCRf1A2DYDvTRTJI0vWN40TYEO3TKpszzQsSwzdDKxrMA60nRtmw0OdrQrTCu27XtqE0Ad51HcdCLNadZzbSEF3HF9dFXWV10A7pejSegt0hIURTFQ9jRPWUz3gdsVUojViPvZSnxNQDXypd9rU-A02XA39-yYjUoJ9MCfyDOAQxA-YuPJWCo2TGN6UQuzMSTVNULLcji1LHDCzwtCwCwQYvC8+ksGcFM-AAeQAOSwnjGz47sHz00jdDixxRlGYzZWo2iRHoxc8vJFiMo4pdkpvFLZVEWgAC8rOE7dwl3fdDSkrjZIvJyr1KtKdSRVSj3U1K3ytMtdKGgzLKMtzTNAv0LMg0MYNyOC+oQhNdA8ztsPLDDfPw2qiLvDLlX2gaez7Oj2IYic3PKtjhweriksxU7MUYIgCjSM4uXvMS9wktTpPs3IFXk5yALOvThsfUbwdlCaPy-WaXUUj01t9b8A1-azoI+DbHIUuMdqTHzArLEKwr84KotihLay+pTzperKcuu5FbqK+6SqemcKrejTuJqvLun+9Q4CBndxIPMHush89of6rjlIRvTFdFupUZ09GVr-LGTJx8z8cswmwwc+CXIp5Cqfp2nwoZ6L4sS1m6vZpFOdytyCv7PnXoFnXTCFl7KvemrTR4-p+loExdHYFRCQPbQ4BsWwagxUQyggVhBnQdg0FQAASFoqmLkutUYHQ+mWJQwCWL4gA}{Open in Shinylive} - \if{html}{\out{}} + \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAokqUBiXQGEAIgEkAZS9dfihSKF04AA9YVBElUPCDYy5qAH1EqBsEsIijXQB3WlIACxV2TNxdECVdXUY4AEdBWgb2CDFSYmoiRkUIOoBBHwCAGWTdVIxMxERGYbGlAF9+gCsiFTSAazhWUQrc23z+OBMoYVI0gn5aUQI09c2dveBoeH3MuQBdN2h0CZUxXYtRCuV0AF5QeFcCC+EIRKIIbo4cIxMCBnVJjA0hI0ncwuRGHEiKR0ZjMdQoPQ4NQkQowAECASZMTSN4ShsCGJ6TCMeSokipqRmBBRCZejBZqhaAQtvsQeS6plRHBSPKwAtRvS5LzFZihSKxRLZloWLQqQj2AQOTKxEiCMCNQBxVx4XT0gBCAFksABpLAARh57rA3r9WAATNqqiqRBo4Pw6c7XTqFYqDVBReLGJLEKbqII0f09am+ZjWIK4NwMMLM0ac1KZXKyXqoVAVWrHZro2nyRms8a82aLWjrZy7ZCHfTBi7g56ff6g275+Go2AdbpY3B44nISvFz2y32qzxawOG0OC0Xe7pS3rur00vQK5D+-Xc9LZfKj5jlar1d2666q2b7ZrmpqMOa9CWlOyZzqGC6BvBYb+muVT0lggxeK66FgFgzhOn4ADyAByS4bluO5IiRjijKMd4gSeNaGmBJrcIW+zFoqDHkqItAAF5wE+L6TExZ7vo2X4tnqf6dtOIxakBN51KBg4QVBME2lyiKTl2s7Lgh4bkTGNLbuQu4hjOKbAXqqkXvmHHZD+PGYowRAFGkZxcmyr5iSxg6fs2ylth2AEKYeraidW4msUOkEjvsY62jpuiwShkbwZh2GZQRxFkdGm6mVRkI0XRLnHtF-n2ex17OTZmLdJ56iqpWlV1rFgXfpFslhYsSk-ipfntWpw7QaOWkTqljrpWhIZZThc25aRxmFXG5nUbR9H1RVp5VeBNWcTeXF1Fx-T9LQJi6OwKiEuomg6DYtg1BiohlBArCDOg7BoKgAAkLRVD9v0qowOh9MsShgEsXxAA}{Open in Shinylive} + \if{html}{\out{}} \if{html}{\out{}} } } diff --git a/man/tm_g_scatterplotmatrix.Rd b/man/tm_g_scatterplotmatrix.Rd index f90d7cf52..7d56ea982 100644 --- a/man/tm_g_scatterplotmatrix.Rd +++ b/man/tm_g_scatterplotmatrix.Rd @@ -6,7 +6,8 @@ \usage{ tm_g_scatterplotmatrix( label = "Scatterplot Matrix", - variables, + variables = list(teal.transform::picks(teal.transform::datasets(), + teal.transform::variables(selected = seq(1L, 5L), multiple = TRUE))), plot_height = c(600, 200, 2000), plot_width = NULL, pre_output = NULL, @@ -19,9 +20,9 @@ tm_g_scatterplotmatrix( \item{label}{(\code{character(1)}) Label shown in the navigation item for the module or module group. For \code{modules()} defaults to \code{"root"}. See \code{Details}.} -\item{variables}{(\code{data_extract_spec} or \code{list} of multiple \code{data_extract_spec}) +\item{variables}{(\code{picks} or \code{list} of \code{picks}) Specifies plotting variables from an incoming dataset with filtering and selecting. In case of -\code{data_extract_spec} use \code{select_spec(..., ordered = TRUE)} if plot elements should be +\code{picks} use \code{teal.transform::variables(..., ordered = TRUE)} if plot elements should be rendered according to selection order.} \item{plot_height}{(\code{numeric}) optional, specifies the plot height as a three-element vector of @@ -43,9 +44,7 @@ To learn more check \code{vignette("transform-input-data", package = "teal")}.} \item{decorators}{\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}} (named \code{list} of lists of \code{teal_transform_module}) optional, decorator for tables or plots included in the module output reported. -The decorators are applied to the respective output objects. - -See section "Decorating Module" below for more details.} +The decorators are applied to the respective output objects.} } \value{ Object of class \code{teal_module} to be used in \code{teal} applications. @@ -132,33 +131,32 @@ app <- init( tm_g_scatterplotmatrix( label = "Scatterplot matrix", variables = list( - data_extract_spec( - dataname = "countries", - select = select_spec( - label = "Select variables:", - choices = variable_choices(data[["countries"]]), + teal.transform::picks( + datasets("countries"), + teal.transform::variables( + choices = tidyselect::everything(), selected = c("area", "gdp", "debt"), multiple = TRUE, - ordered = TRUE, - fixed = FALSE - ) - ), - data_extract_spec( - dataname = "sales", - filter = filter_spec( - label = "Select variable:", - vars = "country_id", - choices = value_choices(data[["sales"]], "country_id"), - selected = c("DE", "FR", "IT", "PT", "GR", "NL", "BE", "LU", "AT"), - multiple = TRUE + ordered = TRUE ), - select = select_spec( - label = "Select variables:", - choices = variable_choices(data[["sales"]], c("quantity", "costs", "profit")), + teal.transform::values() + ), + teal.transform::picks( + datasets("sales"), + teal.transform::variables( + choices = c("quantity", "costs", "profit"), selected = c("quantity", "costs", "profit"), multiple = TRUE, - ordered = TRUE, - fixed = FALSE + ordered = TRUE + ) + ) + ), + transformators = list( + teal_transform_filter( + teal.transform::picks( + datasets("sales"), + teal.transform::variables("country_id"), + teal.transform::values() ) ) ) @@ -183,35 +181,30 @@ app <- init( tm_g_scatterplotmatrix( label = "Scatterplot matrix", variables = list( - data_extract_spec( - dataname = "ADSL", - select = select_spec( - label = "Select variables:", - choices = variable_choices(data[["ADSL"]]), + teal.transform::picks( + datasets("ADSL"), + teal.transform::variables( + choices = tidyselect::everything(), selected = c("AGE", "RACE", "SEX"), multiple = TRUE, ordered = TRUE, fixed = FALSE - ) - ), - data_extract_spec( - dataname = "ADRS", - filter = filter_spec( - label = "Select endpoints:", - vars = c("PARAMCD", "AVISIT"), - choices = value_choices(data[["ADRS"]], c("PARAMCD", "AVISIT"), c("PARAM", "AVISIT")), - selected = "INVET - END OF INDUCTION", - multiple = TRUE ), - select = select_spec( - label = "Select variables:", - choices = variable_choices(data[["ADRS"]]), + teal.transform::values() + ), + teal.transform::picks( + datasets("ADRS"), + teal.transform::variables( + choices = tidyselect::everything(), selected = c("AGE", "AVAL", "ADY"), multiple = TRUE, ordered = TRUE, fixed = FALSE ) ) + ), + transformators = list( + teal_transform_filter(teal.transform::picks(datasets("ADRS"), teal.transform::variables("PARAMCD"), values(selected = "BESRSPI"))) ) ) ) @@ -224,13 +217,13 @@ if (interactive()) { \section{Examples in Shinylive}{ \describe{ \item{example-1}{ - \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAokqUBiXVIhrqu-lCkULpwAB6wqCJKAUEGxlzUAPoxUDbRgcFGugDutKQAFirsKbi6IEq6usTmpIy0YnH+GRgmzPDsFZW6tPy6ALxVHWAAIq54ugpgAGJYk6WTAJJ2cxNgzgDKK5MACsvjkwDis-tgAHIAMltgAEJj82DnjlcAgntyuJ2VEkQ6jBDwZH6pnUpCIjA6EC6XQI7AATKV4bpEQBGBFo3SojGlTGw96fLrUKD0ODUURAmGTACyJBYBHyrCuWDgqEE9DoBEmikhXTx3MqhIgEkEUCkiRMsFo1FYQPFGjBEKhlRhmIAzKU1boNRqUdj1djeYrdITiaTyUMDjIYFBlByTgAJEkiG2MohWixwTn4g1dVBEFmEzQkM0ADg1ADYAOylMMABlKABYoxi4xjMcik8jMTGMGHSgBOb2VFhwYIDGEqgCsSYrFdVMcxFZjFfzKJViPjdYROdKocLXn4qDNKow8a7SdhGDTI9K2Y12cR2aT2ebumzWZHff4cHopDNE5xGG106R3ZPR9HZ67F4n565lTvulE3AaWRSLTacAVXR6QORiEbHx8lURA1GwiQ-gMT4wJEn74kqQyjFcMxXEsVwbFcuxXEcVwXFctxXI8LxvIBhqiLQABeegDABcG6IwzKEgQVH2E4rhAX2rAlowQKiGCpDsFBMFwvWMaILCMbiaUAF0Qx6jMQ4LhyH2OgQIIzGCSI7AUmAohWtQ1BXPA-C0IIMBXISjBSFcJB0D4nJSSm9GRHJQIKc4fYENaTH6XAvSQREmkwm5pRTM85zrO5DmlE5jHyaxfYAI7CmQeTSgMfxgjA7DSciMYpuJHlEKIpBkulECZdlKbBvlMZ9qgjBECYeRAhljBZdJknJg+XIAL5cgAVkQKiJAA1nArCiMUGS2Fkg3DWNE1fnNECjeNQzVGQdRiFcG21PUohXD09mdMtq0cJMT4iAdJyXdtJxHWA3qnQt60gZt+1XLd12lNpD1ApMu1gQ9SlKFyShoIOWQqHkX4pECJSdHwQhXUCSPCGIX6VKQMCJBIiSiJ5pDkIwkRENjgR1KEmMEkSJL-WA6yE8TpO7lae2hHMtFaCwtBEijAx0MV1NQikiRhLUIL46gcAUkBhopNA8D04DH14LRUKiCSMu7pBWsaFLMvC4aRq034AyTOseu7tzdR82IiCc3Lxt0kNTGlboNu82ycCJC7tBu1NQTAMAANvXtd0ALoR32xuPlbvlmpMxZQFcEgDlcW47sdTuGjAwiaDBrmsSRsddGCW70X5LEuCXpemLQoQJwMoXhWxdcPoaMddKL4vMProjS7LdcK7AzEXc+33q10TXUMTMqSsTBtD3XJsmvTlsiBoHs83bDtqznio2+7oegaw4H8I7K9VPkrsNAM3PUGpvs3-7GMpMH49XZMUf3IDZ-A7XUumtN7kCrtpRCJxkInFQicTCJxsInFwicfCJxCInFeNnK+edZ60ELgMNyU97yANIlbHiVsl5G0NMaOm5sGakM9nbUQe9iHOxfm7IEDDvbP1vpNd+IcdIT2-hHH6QwkrWk0KQBkJxiDFW+qseqjU8ici7iQkBTdBiTDESlSRO0iolSuAopqpBMEr2wQXEQRca6ELLowCu6jgrWMqE1RuVcW4RWsR3RUnj7xek6FyLktATC6HYCoYmIJtCfiUmUToohCgQFYM8dA7AIYABJBC0FKKkzWjBfi9SUGAHqEcgA}{Open in Shinylive} - \if{html}{\out{}} + \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAokqUBiXVIhrqu-lCkULpwAB6wqCJKAUEGxlzUAPoxUDbRgcFGugDutKQAFirsKbi6IEq6usTmpIy0YnH+GRgmzPDsFZW6tPy6ALxVHWAAIq54ugpgAGJYk6WTAJJ2cxNgzgDKK5MACsvjkwDis-tgAHIAMltgAEJj82DnjlcAgntyuJ2VEkQ6jBDwZH6pnUpCIjA6EC6XQI7AATKV4bpEQBGBFo3SojGlTGw96fLrUKD0ODUURAmGTACyJBYBHyrCuWDgqEE9DoBEmikhXTx3MqhIgEkEUCkiRMsFo1FYQPFGjBEKhlRhmIAzKU1boNRqUdj1djeYrdITiaTyUMDjIYFBlByTgAJEkiG2MohWixwTn4g1dVBEFmEzQkM0ADg1ADYAOylMMABlKABYoxi4xjMcik8jMTGMGHSgBOb2VFhwYIDGEqgCsSYrFdVMcxFZjFfzKJViPjdYROdKocLXn4qDNKow8a7SdhGDTI9K2Y12cR2aT2ebumzWZHff4cHopDNE5xGG106R3ZPR9HZ67F4n565lTvulE3AaWRSLTacAVXR6QORiEbHx8lURA1GwiQ-gMT4wJEn74kqQyjFcMxXEsVwbFcuxXEcVwXFctxXI8LxvIBhqiLQABeegDABcG6IwzKEgQVH2E4rhAX2rAlowQKiGCpDsFBMFwvWMaILCMbiaUAF0Qx6jMQ4LhyH2OgQIIzGCSI7AUmAohWtQ1BXPA-C0IIMBXISjBSFcJB0D4nJSSm9GRHJQIKc4fYENaTH6XAvSQREmkwm5pRTM85zrO5DmlE5jHyaxfYAI7CmQeTSgMfxgjA7DSciMYpuJHlEKIpBkulECZdlKbBvlMZ9qgjBECYeRAhljBZdJknJg+XIAL5cgAVkQKiJAA1nArCiMUGS2Fkg3DWNE1fnNECjeNQzVGQdRiFcG21PUohXD09mdMtq0cJMT4iAdJyXdtJxHWA3qnQt60gZt+1XLd12lNpD1ApMu1gQ9SlKFyShoIOWQqHkX4pECJSdHwQhXUCSPCGIX6VKQMCJBIiSiJ5pDkIwkRENjgR1KEmMEkSJL-WA6yE8TpO7lae2hHMtFaCwtBEijAx0MV1NQgkGC1NaogmJliCIKgtAECNk20VCKSiHAJWvaBH2PSRhpdKL4sQJL0uINzdR8xjyuKnSQ1MaVuiaPwE0knAGgy3AvysAUKgSDYut610asiBovlmpMxZQFcEgDlcW47sdQEBzAwiaDBrmsf7Ae6GCW70X5LEuFb96Z4aBvMEbUttTL3PUGpk0PoafYiyWPCG8bVey-LivC4qqvq0rOnPtdTeKmXEuVzA1c8xbSuJ3rNvyw0ZZDEl1qaKQDInMQxXfas9WNXkCdZ4HLsh-n2mrylG87UVJVXPvTWkEfx+6Mn1CpyI6cuCXes5zIocDDckXXQDdFSgOLrRNuE9AhgntoLfiVsEiJCgZlMUkpiY92btwMW5d26T07grWeL8mhBDVhrC6Q9n7HzHhXE2ZteZsktoQN6tRWDgX4FQrONC8FT1rhjcBYCrYCNAd1UGShaAmF0OwFQxMQTaE-EpMonRRCFAgKwZ46B2AQwACSCFoKUHRatGC-F6koMAPUAC6QA}{Open in Shinylive} + \if{html}{\out{}} \if{html}{\out{}} } \item{example-2}{ - \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAokqUBiXQGEAIgEkAZS9dfihSKF04AA9YVBElUPCDYy5qAH1EqBsEsIijXQB3WlIACxV2TNxdECVdXQBBHwCAGWTdVIxMxERGRpbahp8sALaOrp7G4aUAX0UIACsiFTSAazhWUQrc23z+OBMoYVI0gn5aUQI0xeW1jeBoeE3MuQBdN2h0NpVi9gHM3QAvCFcrgBnwhCJRIDdODhGJfhA6nVSDA0hI0hcwuRGHEiCiwoxaFEEUikdQoPQ4NRoQowAECFiZLjSDCCUTaaDEaTdFoWLQKZDoXRRKQSdy6pk0tFSMwNBjUHACGLxRLcg89EDaX1mhyBirdKIqYqWUDDSI5aIFUq9frdOTKdTNXSjRoeXyBWJELqubbdAQSksCGJobzCR6TgHaEGnrlgMAtU0dWAXi85JzfXUzca4PxodawPUAOKuPC6WlYepeEtVWkBZwADVpaZt+pgR1ocQ19icznTGaIjD2jBz0IcLj7vpMRJHQIAYvVmnWW9y5vrmz7uZLpbLjpbFcqVZl1TSC0MAt7J7RqNjoVPrzJ5fvl+L7VSTwEXSyKPxUEsyKIvTwZ9uVDKEgXzAAFeoKwAWV8DkywLAA1QI-DsJsJ1tf1A2DIFeWoQQ4AjHCY3COMEymZMXiqSDoPqOCfAQrUUICNCML9X4wCg2CmOQ1D0LAOR1wzA1PxnRC-AAOSQ5w7F0YxnEknxdAAeVnXQpJ8RwvDsPwVMki8Mzba8OxEUce2AuphNtLNXVNT9H2tDd9VfR1EI-c0WVDfl6EhQDMP1bCo1wt0w18oigujLYyPjU9KJTazfVs8hc3Azii2rRD6iQhdeMaABNDDLKRYzNE7czx2KuoByHcSx17KrTGnVLdHnRdXGcldgNXLqNx6uY5loExdHYFRsXUTQdBsWwai5UQyggVh6nQdg0FQAASQRaCqNb1sNRgdEYOZpiUMBpheIA}{Open in Shinylive} - \if{html}{\out{}} + \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAokqUBiXQGEAIgEkAZS9dfihSKF04AA9YVBElUPCDYy5qAH1EqBsEsIijXQB3WlIACxV2TNxdECVdXQBBHwCAGWTdVIxMxERGRpbahp8sALaOrp7G4aUAX0UIACsiFTSAazhWUQrc23z+OBMoYVI0gn5aUQI0xeW1jeBoeE3MuQBdN2h0NpVi9gHM3QAvCFcrgBnwhCJRIDdODhGJfhA6nVSDA0hI0hcwuRGHEiCiwoxaFEEUikdQoPQ4NRoQowAECFiZLjSDCCUTaaDEaTdFoWLQKZDoXRRKQSdzkXBuBhSMwIKITERGDBuqhaAQVpsBuK6plRHBSJqwH1mrS5JztUiOjKoHKFUrurzCQL4VqLboCCUlgQxNDNPwNlS4BpunAdGxSioJDZzW66nqRBo4PxoQRfkaAOKuPC6WlYepeLNVWkBZwADVNMdjMCOtDieiBDhclbdir2jCT0MbzmbFpMRI7QIAYvVmiXXeKzePuVbZfLFcrELzqIJ4XMLZOueKZza5-bEKr1ZrN9rdfrDZMAhWp6Tt7b5w6+c6j7G6h6vT6gX6AwnSCGw6wIwgKMNxfXR4yDchkyBVNaXqTMORzI0ADURwQ2CfAATSvY8LWrahNDrTsnG7a9uVbGQB3sYie21Psoko4dR1cHDuTXbU2NJEDp1nO0YDCRUoSBYVRVI1I0mtO8lTSPt8JkThJR4CTdwXA8NS2cI9QNNMLwrdoFOlHj70XR96EhNMAAV6jzABZXxdKXFdNnAxMoMQgAhZwAmGcy-FNOQOKRAK2LmOZaBMXR2BUbF1E0HQbFsGouVEMoIFYep0HYNBUAAEkEWgqiy7K9UYMM5mmJQwGmF4gA}{Open in Shinylive} + \if{html}{\out{}} \if{html}{\out{}} } } diff --git a/man/tm_missing_data.Rd b/man/tm_missing_data.Rd index 25244f9c6..ef6abaf03 100644 --- a/man/tm_missing_data.Rd +++ b/man/tm_missing_data.Rd @@ -64,9 +64,7 @@ To learn more check \code{vignette("transform-input-data", package = "teal")}.} \item{decorators}{\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}} (named \code{list} of lists of \code{teal_transform_module}) optional, decorator for tables or plots included in the module output reported. -The decorators are applied to the respective output objects. - -See section "Decorating Module" below for more details.} +The decorators are applied to the respective output objects.} } \value{ Object of class \code{teal_module} to be used in \code{teal} applications. diff --git a/man/tm_outliers.Rd b/man/tm_outliers.Rd index a355b1d97..7978df5cc 100644 --- a/man/tm_outliers.Rd +++ b/man/tm_outliers.Rd @@ -22,10 +22,10 @@ tm_outliers( \item{label}{(\code{character(1)}) Label shown in the navigation item for the module or module group. For \code{modules()} defaults to \code{"root"}. See \code{Details}.} -\item{outlier_var}{(\code{data_extract_spec} or \code{list} of multiple \code{data_extract_spec}) +\item{outlier_var}{(\code{picks} or \code{list} of multiple \code{picks}) Specifies variable(s) to be analyzed for outliers.} -\item{categorical_var}{(\code{data_extract_spec} or \code{list} of multiple \code{data_extract_spec}) optional, +\item{categorical_var}{(\code{picks} or \code{list} of multiple \code{picks}) optional, specifies the categorical variable(s) to split the selected outlier variables on.} \item{ggtheme}{(\code{character}) optional, \code{ggplot2} theme to be used by default. Defaults to \code{"gray"}.} @@ -55,9 +55,7 @@ To learn more check \code{vignette("transform-input-data", package = "teal")}.} \item{decorators}{\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}} (named \code{list} of lists of \code{teal_transform_module}) optional, decorator for tables or plots included in the module output reported. -The decorators are applied to the respective output objects. - -See section "Decorating Module" below for more details.} +The decorators are applied to the respective output objects.} } \value{ Object of class \code{teal_module} to be used in \code{teal} applications. @@ -115,21 +113,22 @@ app <- init( modules = modules( tm_outliers( outlier_var = list( - data_extract_spec( - dataname = "CO2", - select = select_spec( - label = "Select variable:", + teal.transform::picks( + datasets("CO2"), + teal.transform::variables( choices = variable_choices(data[["CO2"]], c("conc", "uptake")), selected = "uptake", multiple = FALSE, fixed = FALSE - ) + ), + teal.transform::values() ) ), categorical_var = list( - data_extract_spec( - dataname = "CO2", - filter = filter_spec( + teal.transform::picks( + datasets("CO2"), + teal.transform::variables(), + values( vars = vars, choices = value_choices(data[["CO2"]], vars$selected), selected = value_choices(data[["CO2"]], vars$selected), @@ -161,21 +160,22 @@ app <- init( modules = modules( tm_outliers( outlier_var = list( - data_extract_spec( - dataname = "ADSL", - select = select_spec( - label = "Select variable:", + teal.transform::picks( + datasets("ADSL"), + teal.transform::variables( choices = variable_choices(data[["ADSL"]], c("AGE", "BMRKR1")), selected = "AGE", multiple = FALSE, fixed = FALSE - ) + ), + teal.transform::values() ) ), categorical_var = list( - data_extract_spec( - dataname = "ADSL", - filter = filter_spec( + teal.transform::picks( + datasets("ADSL"), + teal.transform::variables(), + values( vars = vars, choices = value_choices(data[["ADSL"]], vars$selected), selected = value_choices(data[["ADSL"]], vars$selected), @@ -194,13 +194,13 @@ if (interactive()) { \section{Examples in Shinylive}{ \describe{ \item{example-1}{ - \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAokrcQAxLqkQ11XfxQpFC6cAAesKgiSoHBBsZc1AD6sVA2MUEhRroA7rSkABYq7Km4uiBKuroAwgDyAEzxNQ2VzfXAwApgqIy0MCysSQDWcKxdALrjTaJwAI5JIhDsEIxEOex19XKKEAC+OwBWRCrDo6IlmbbZRycjrOc3EKccXZtdZa8teLpdPX0Dzy623cWhYoiaBAKxwIYiSMxEGjg-HYoN6UHoIiSkOhYguwQ6n3qE3GZQI7C6AAVqFAyO8fmA7KxUHA6V07Iw4EF4LSwNsdko0Kgmip8uSIFVUroALwBTK4Vp8IQicEyxXCXGtKqkGBJIiCUh0GTnTVVXR6g20GRJVHS3R0USkMWm52y4JJcKkZgaOHMskml2ummwPQywnvf0u+FwDS2qPe0S+p0Bl3U+hwfyhsAAZXT0dIulRtHRIkQ4fFyed2NoMJVBZYRYxcCxUOruNSBLAbzAk1J5MIJAIrLAglQwRGQLk8vLFaqcfI-FtXRHY5ZeAjAZgwk0URDugAYgBBAAyWecU5nppMtDCSNth5PrmnyZ2FZfLsnEYIQTgEiIvS-yQ2jK9qOuugbumEnrqKQPrRkmFapNA8CLp2XznjOV7UOQjC2ph2GwX6T4VqitYkehF5VjWtqgtQghNpRbaZB2XY9nWjCiAAJHOSIfkRybcQuMo0XRzY4uc7adKhRLdiSbGcQJvEXlUm5YbQO62g4LhgVUb4Brppr6W+Ow7LQJi6OwKjYdB2hwDYtgVOWohFBArAHug7CChxgi0GUnkzIwOiMDsuxKGAuzjEAA}{Open in Shinylive} - \if{html}{\out{}} + \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAokrcQAxLqkQ11XfxQpFC6cAAesKgiSoHBBsZc1AD6sVA2MUEhRroA7rSkABYq7Km4uiBKuroAwgDyAEzxNQ2VzfXAwApgqIy0MCysSQDWcKxdALrjTaJwAI5JIhDsEIxEOex19XKKEAC+OwBWRCrDo6IlmbbZRycjrOc3EKccXZtdZa8teLpdPX0Dzy623cWhYoiaBAKxwIYiSMxEGjg-HYoN6UHoIiSkOhYguwQ6n3qE3GZQI7C6AAVqFAyO8fmA7KxUHA6V07Iw4EF4LSwNsdko0Kgmip8uSIFVUroALwBTK4Vp8IQicEyxXCXGtKqkGBJIiCUh0GTnTVVXR6g20GRJVHS3R0USkMWm526RIYUjMCCiExERgwRCIVC0AhDY3il3O1IzUjGsBvXny8MRrWcngemne33+xCo2jo5VO5PO7HBsS23P5uBYqGl86pAlxr6TUnkwgkAissCCVDBEZAuSJovO+FwRH8W1dbu9ll4E1FmDCTRRPQygBiAEEADIAZWcg6HVRMtDCSNtG53riTyYHc5dbvTXp9foDoOoglxOyLn5dN6vVQIQRwBIvrBtw1osLa9qOreKbcO6nqZs+gbBqGhZFlGcAxq28a-ge94IU+2YVhiH77kWr7vmGB5VKiKq6LRZFDiWMJ0RRVbMbi9adI2RJgM29FggAJCOY64dRInkOOMpsdWOJ1pkDbxvxtHCXACKSWJB4LtQS4iLaDguDBprfhGJnGSa347DstAmLo7AqOQzCWDoNi2BU4aiEUECsOu6DsIKgmCLQZQBTMjA6IwOy7EoYC7OMQA}{Open in Shinylive} + \if{html}{\out{}} \if{html}{\out{}} } \item{example-2}{ - \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAokrcQAxLoDCAEQCSAMreuvxQpFC6cAAesKgiSmERBsZc1AD6SVA2ieGRRroA7rSkABYq7Fm4uiBKuroAgr6BADIpumkYWYiIjE2tSgC+ihAAVkQq6QDWcKyilXm2BfxwJlDCpOkE-LSiBOnjkzNzwNDw81lyALruaxrpWiyi6VD8otTtZ2LsAGK01ORGOxdg4XNVRGh4hwssBgAowP0WvCrldqrsMHdSERGHJcUpHoxRO0CKUJgQxOlRHARBo4Px2ATaFB6CItqTaOSLnlYfDEcjUaZ1JsCc9Xu88RB3JD2ioSuw6qE8roALyKiK4BV8IQiImqrXCb4K+qkGDpIiCUh0GTzI31XTmy20GQPFgq3R0USkeUQO2+tVQdIxUjMe6iVBwAjev1+rJfN285pIvC26NUmmkN1piObMMRqPRv3UZnU+NgQLU7O6RnMkSIeEan0F30ksliN3VllwNmtrkRHkIxP86qR3kAcVceF08IAQgBZLAAaSwAEZ4biG03fVnafxSw1x-WUwWYBtaPE9Kqfg0WoFnBvN-UTLRonS3Veb65G02Rt+j3J7824RwBI2IctwLqMG6Hpeke9RZIG0TBkKlLhiOX4FrGsAXlOA4DMm6HRk+AIyG6RGAiheawX6Irtk8AGbi2HJtqqjzUIIXaMZyCx9nCuFJii1QigAJNu5D8P+VFbhWO60WxHHslxMK8XyYACVWTwidJYkSQRx6nuebqgp+D4-gWpm+uZuimSMIy0CYujAqoIaaDoNi2LUjaiOUECsA06DsJCQmCLQ1SBVSjA6DiQxKGAgxXEAA}{Open in Shinylive} - \if{html}{\out{}} + \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAokrcQAxLoDCAEQCSAMreuvxQpFC6cAAesKgiSmERBsZc1AD6SVA2ieGRRroA7rSkABYq7Fm4uiBKuroAgr6BADIpumkYWYiIjE2tSgC+ihAAVkQq6QDWcKyilXm2BfxwJlDCpOkE-LSiBOnjkzNzwNDw81lyALruaxrpWiyi6VD8otTtZ2LsAGK01ORGOxdg4XNVRGh4hwssBgAowP0WvCrldqrsMHdSERGHJcUpHoxRO0CKUJgQxOlRHARBo4Px2ATaFB6CItqTaOSLnlYfDEcjUaZ1JsCc9Xu88RB3JD2ioSuw6qE8roALyKiK4BV8IQiImqrXCb4K+qkGDpIiCUh0GTzI31XTmy20GQPFgq3R0USkeUQO2+jpwbgYUjMCCiEzYmA9VAcqY2n1+31ZKmkG0I5pIsByDXxhPGgM8YNQUPhxiRxCM5k6725v0ksliN0VllwNn1rkRHlpgZgFHVAjyhEAcVceF08IAQgBZLAAaSwAEZ4bjszXfVSaeR+G7ecP4SvV-UYBtaPE9Kqfg0WoFnPuDyZaNE6W6L1fXDnc1nbQnOoXixGeo81CCN8Iw1qBfqfu+9QEOEcASNiHLcC6jBuh6XpfnaP4hmG-6INGBCxtWq5JnAKYDnyma3rmWFFjhpYASwTLNvMkEHoBwFxge9Qio2TxUTWdYcg2qrsS2gmcgsHZwl2Ga9roIoACTrnAtL8KxXHKapvFAWJ7ISTC0kUXJimaZu6kHkeAIniIbqgm+B7gQmjl2s54EjCMtAmLowKqMwlg6DYti1PGojlBArANOg7CQgpgi0NUMVUowOg4kMShgIMVxAA}{Open in Shinylive} + \if{html}{\out{}} \if{html}{\out{}} } } diff --git a/man/tm_t_crosstable.Rd b/man/tm_t_crosstable.Rd index 0682c348b..9f7f3f48c 100644 --- a/man/tm_t_crosstable.Rd +++ b/man/tm_t_crosstable.Rd @@ -6,7 +6,9 @@ \usage{ tm_t_crosstable( label = "Cross Table", - x, + x = teal.transform::picks(teal.transform::datasets(), teal.transform::variables(choices + = teal.transform::is_categorical(min.len = 2, max.len = 10), selected = 1L, multiple + = TRUE, ordered = TRUE)), y, show_percentage = TRUE, show_total = TRUE, @@ -22,15 +24,15 @@ tm_t_crosstable( \item{label}{(\code{character(1)}) Label shown in the navigation item for the module or module group. For \code{modules()} defaults to \code{"root"}. See \code{Details}.} -\item{x}{(\code{data_extract_spec} or \code{list} of multiple \code{data_extract_spec}) +\item{x}{(\code{picks} or \code{list} of \code{picks}) Object with all available choices with pre-selected option for variable X - row values. -In case of \code{data_extract_spec} use \code{select_spec(..., ordered = TRUE)} if table elements should be +In case of \code{picks} use \code{teal.transform::variables(..., ordered = TRUE)} if table elements should be rendered according to selection order.} -\item{y}{(\code{data_extract_spec} or \code{list} of multiple \code{data_extract_spec}) +\item{y}{(\code{picks} or \code{list} of multiple \code{picks}) Object with all available choices with pre-selected option for variable Y - column values. -\code{data_extract_spec} must not allow multiple selection in this case.} +\code{picks} must not allow multiple selection in this case.} \item{show_percentage}{(\code{logical(1)}) Indicates whether to show percentages (relevant only when \code{x} is a \code{factor}). @@ -63,9 +65,7 @@ To learn more check \code{vignette("transform-input-data", package = "teal")}.} \item{decorators}{\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}} (named \code{list} of lists of \code{teal_transform_module}) optional, decorator for tables or plots included in the module output reported. -The decorators are applied to the respective output objects. - -See section "Decorating Module" below for more details.} +The decorators are applied to the respective output objects.} } \value{ Object of class \code{teal_module} to be used in \code{teal} applications. @@ -132,26 +132,26 @@ app <- init( modules = modules( tm_t_crosstable( label = "Cross Table", - x = data_extract_spec( - dataname = "mtcars", - select = select_spec( - label = "Select variable:", + x = teal.transform::picks( + datasets("mtcars"), + teal.transform::variables( choices = variable_choices(data[["mtcars"]], c("cyl", "vs", "am", "gear")), selected = c("cyl", "gear"), multiple = TRUE, ordered = TRUE, fixed = FALSE - ) + ), + teal.transform::values() ), - y = data_extract_spec( - dataname = "mtcars", - select = select_spec( - label = "Select variable:", + y = teal.transform::picks( + datasets("mtcars"), + teal.transform::variables( choices = variable_choices(data[["mtcars"]], c("cyl", "vs", "am", "gear")), selected = "vs", multiple = FALSE, fixed = FALSE - ) + ), + teal.transform::values() ) ) ) @@ -172,10 +172,9 @@ app <- init( modules = modules( tm_t_crosstable( label = "Cross Table", - x = data_extract_spec( - dataname = "ADSL", - select = select_spec( - label = "Select variable:", + x = teal.transform::picks( + datasets("ADSL"), + teal.transform::variables( choices = variable_choices(data[["ADSL"]], subset = function(data) { idx <- !vapply(data, inherits, logical(1), c("Date", "POSIXct", "POSIXlt")) return(names(data)[idx]) @@ -184,12 +183,12 @@ app <- init( multiple = TRUE, ordered = TRUE, fixed = FALSE - ) + ), + teal.transform::values() ), - y = data_extract_spec( - dataname = "ADSL", - select = select_spec( - label = "Select variable:", + y = teal.transform::picks( + datasets("ADSL"), + teal.transform::variables( choices = variable_choices(data[["ADSL"]], subset = function(data) { idx <- vapply(data, is.factor, logical(1)) return(names(data)[idx]) @@ -197,7 +196,8 @@ app <- init( selected = "SEX", multiple = FALSE, fixed = FALSE - ) + ), + teal.transform::values() ) ) ) @@ -210,13 +210,13 @@ if (interactive()) { \section{Examples in Shinylive}{ \describe{ \item{example-1}{ - \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAokqUBiXVIhrqu-lCkULpwAB6wqCJKAUEGxlzUAPoxUDbRgcFGugDutKQAFirsKbi6IEq6ujCkBCyicVU1dRWmRIy67Fq6KroE7AqErNQDpQNaoiO6A7CTA1IsA3K25RCVldW1jKLAwFoAunsNUOIm6qRt7Bt1O-t7iqu6AL4tV1s7A6iMtDAsrIkA1nBWAMDg1RHAAI6JEQQdgQRhEbKXJpbJZKR73ABWRBUAKBomKGVsWWxuMBrAJpIgeI4A1eEzwUzA9NmYE+31+NMW9yUaFQDRUeX6DxSugAvP4MrgXgJhGJxVVZSICS1KqQYIlSIkCAjRKIgvQRMK1mtqFB6HA-BKBgBhXX1OzmqJ4VVrUIKlKJMKkZgaRKiVBwPquk0paDwBV0lEM6UPE2VcEiDQKxNBrUBoPG+Mms0Wq1MgDKlrTui0LFoTrgiBGIfjBHyOII8olZa+le1DdoTYJKXezOjIL2pWDg2GjLGMaZM3HYHmjG5sezJtTGjg-AVI4IQ1Zc8Wi6X62EmkieglDhc+4PbX4MjXCvPzkvS5MtFCd4lADEAIIAGQLrjjeN7mzOQn0qVgPQyL1Qh9M5-UDYNANDDJw1PJkWRdJC1hXUgU2LP0M0Qg9KlzS1IzAIsk1w1sK0NKsaywk160bZtS3LdtmK7MRCSCPsMIOYd+lHVlxlZadRlnOAFjAJYwPjHD3yZUTMOIqoj1oE8FW-P9H1rE0XzfddP1-f89N0YCgNdCz7nuWgTA6FRyF9TQdBsZYWlEQoIFYL90HYPkABJBFoUpAvBRgdEYe5nggMBHj2IA}{Open in Shinylive} - \if{html}{\out{}} + \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAokqUBiXVIhrqu-lCkULpwAB6wqCJKAUEGxlzUAPoxUDbRgcFGugDutKQAFirsKbi6IEq6ujCkBCyicVU1dRWmRIy67Fq6KroE7AqErNQDpQNaoiO6A7CTA1IsA3K25RCVldW1jKLAwFoAunsNUOIm6qRt7Bt1O-t7iqu6AL4tV1s7A6iMtDAsrIkA1nBWAMDg1RHAAI6JEQQdgQRhEbKXJpbJZKR73ABWRBUAKBomKGVsWWxuMBrAJpIgeI4A1eEzwUzA9NmYE+31+NMW9yUaFQDRUeX6DxSugAvP4MrgXgJhGJxVVZSICS1KqQYIlSIkCAjRKIgvQRMK1mtqFB6HA-BKBgBhXX1OzmqJ4VVrUIKhIYUjMCCiExtGCIRCoWgEf4qh4myopcGkFXMlEMuTSyNRz3eqC+-2MQOILQsWhOsTGqMmgj5HEEeUS-NfIvaiuh4spd4JzYMg6lPoDAhDVnjVkzRlzOALMBLFOlk3gkQaOD8BXdwbDYdgeaMRaTqfrYSaSJ6CUOFxb7dtfgyecKo-OE9Tky0UKXiUAMQAggAZADKrlTJuTrpNdMfT9AMg3zahBGLe5S3-X9dFYD1Rx4DMs1A4NQ3DEtSxjOA436NtmnHW9AKQr1gOzXNa0LQ1iwAqNy0ratdCo+sGKbAkW2AOlExBPYu3w3sV1GMAB1XIdhPXbliKjGc4DnBdrREhlpJNGBd1ofcFTfL8bzok170fBTdG0789N0WDtyAzMQJzMDuEggloKjJzKic+57loEwOhUchmEsHQbGWFpREKCBWFfdB2D5AASQRaFKGLwUYHRGHuZ4IDAR49iAA}{Open in Shinylive} + \if{html}{\out{}} \if{html}{\out{}} } \item{example-2}{ - \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAokqUBiXQGEAIgEkAZS9dfihSKF04AA9YVBElUPCDYy5qAH1EqBsEsIijXQB3WlIACxV2TNxdECVdXQBBHwCAGWTdVIxMxERGRpalAF9FCAArIhU0gGs4VlEK3Nt8-jgTKGFSNIJ+WlECNLGJ6dngaHg5zLkAXTdodDaVYvZakNzdAF4X8NxnviERUXeul+wjETwgdTqpBgaQ2BEYRFEonC9BEYIhEOoUHocGogIUYC88MR9ix8Twz3RUUBmTS0VIzA0aVEqDgBDR6IhmVOeg++L6zXx33BHLqohxrNIgLFIkZzNZ7JFdUx2NxvLAAXFGl0WhYtFJcEQgopioIJXGBDEgJ1jD1KLgmzNtAt51ywGAfKaArAl0uVVEgnoYslHzMFk01gu1WNit0tH4VPyAEIdehqBxKrGICUZMVRFVqEQJE7uOwAIxyKps-E+MJwQW6fEABQA8gE-AANDT1putjvUUj4uTDGPoxhwUiCRgQdjcl3hOTAONRS7DkdDIUj3TSiVwfh4gnNxwAOQcAE0jcKYzB1rQ4jz7E5nBuR0RGMsx3uPg4XM+YyZaFEu6AgAYvUzQBK4l4cqu6IVtGuisNSuS0lE9LqBscpVlB6JcrA94ev05LYRC25ah8pEYSyWGbsqOL7hqMqStatoiIaRGbqa5qWh8zH6g6XFzlAboEV6Pp+gGQaAqGlgRgsUbESKS5tCmcTprkVQ7BgqwaK++aFsW1BlkO8EimOE5TjOeGCQuS4riZELrvZoqauQn4Nuqzjthem7Xv2t4iCBYEQb+ir-oBbmgeBkExjBEKxauwzDLQJi6OwKjkAymg6DYtg1MKohlBArD1Og7BoKgAAkgi0FU5UVWKjA6IwwwDEoYADJcQA}{Open in Shinylive} - \if{html}{\out{}} + \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAokqUBiXQGEAIgEkAZS9dfihSKF04AA9YVBElUPCDYy5qAH1EqBsEsIijXQB3WlIACxV2TNxdECVdXQBBHwCAGWTdVIxMxERGRpalAF9FCAArIhU0gGs4VlEK3Nt8-jgTKGFSNIJ+WlECNLGJ6dngaHg5zLkAXTdodDaVYvZakNzdAF4X8NxnviERUXeul+wjETwgdTqpBgaQ2BEYRFEonC9BEYIhEOoUHocGogIUYC88MR9ix8Twz3RUUBHVIzAgohMREYMG6qFoBEmcwp6M+UFEcFIXLAfWa+Lk33BPMhcG4GFpUHpjOZ3S0LFopNB3KlBBK4wIYkBqsY6pRcE2uvZoMywGA+JF+MulyqokE9H5pEBZgsmmsF2qWqlulo-Cp+QAhKr0NQOJUgxASjJiqIqtQiBJ2dx2ABGcW6AhPMA+MJwfFVfEABQA8gE-AANDSl3QV6t16ikMXDQM8xgCwSMCDsU5WhbAYNRS6dru6IYSqe6fkiDRwfh4gmVxwAOQcAE1SwH0TB1rQ4noPg4XLOp0zlj2V2enM5L12TLQosvAQAxerNAKuSVS8V93aGUeHlRUmRZRBVWoQRQUndFAP-CFWGpEC5TpBkINZdlOTRQNMndIV7TARCuxpDClUgo0TX+PCux1PUDQ+aiNXNRjzlyG07SaUUwEdZ1XXdT1zEsX0Fn9JCuzHNpIziGNciqHYMFWDQmRTNMM2obM5Hgqce1IPsByHDjwjkUcQwnIC6hnKz5xxOAlzvJswF-Ws90knlDzbY8RE-b9fyfQMXzfJyvx-P8u1IwNyIVTDlSg7hYLmXS6l0ydhmGWgTF0dgVHIZhLB0GxbBqSVRDKCBWHqdB2DQVAABJBFoKo6vq-lGB0RhhgGJQwAGS4gA}{Open in Shinylive} + \if{html}{\out{}} \if{html}{\out{}} } } diff --git a/man/validate_input.Rd b/man/validate_input.Rd deleted file mode 100644 index e9c21581e..000000000 --- a/man/validate_input.Rd +++ /dev/null @@ -1,22 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/tm_variable_browser.R -\name{validate_input} -\alias{validate_input} -\title{Validates the variable browser inputs} -\usage{ -validate_input(input, plot_var, data) -} -\arguments{ -\item{input}{(\code{session$input}) the \code{shiny} session input} - -\item{plot_var}{(\code{list}) list of a data frame and an array of variable names} - -\item{data}{(\code{teal_data}) the datasets passed to the module} -} -\value{ -\code{logical} TRUE if validations pass; a \code{shiny} validation error otherwise -} -\description{ -Validates the variable browser inputs -} -\keyword{internal} diff --git a/tests/testthat/helper-testing-depth.R b/tests/testthat/helper-testing-depth.R index 3aa6cf3ec..818394ee8 100644 --- a/tests/testthat/helper-testing-depth.R +++ b/tests/testthat/helper-testing-depth.R @@ -8,7 +8,7 @@ #' @return `numeric(1)` the testing depth. #' get_testing_depth <- function() { - default_depth <- 3 + default_depth <- 5 depth <- getOption("TESTING_DEPTH", Sys.getenv("TESTING_DEPTH", default_depth)) depth <- tryCatch( as.numeric(depth),