if (shiny::isRunning()) logger::log_shiny_input_changes(input, namespace = "teal.modules.general")+
teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.general")
| 1 |
- #' `teal` module: File viewer+ #' `teal` module: Scatterplot matrix |
||
| 3 |
- #' The file viewer module provides a tool to view static files.+ #' Generates a scatterplot matrix from selected `variables` from datasets. |
||
| 4 |
- #' Supported formats include text formats, `PDF`, `PNG` `APNG`,+ #' Each plot within the matrix represents the relationship between two variables, |
||
| 5 |
- #' `JPEG` `SVG`, `WEBP`, `GIF` and `BMP`.+ #' providing the overview of correlations and distributions across selected data. |
||
| 7 |
- #' @inheritParams teal::module+ #' @note For more examples, please see the vignette "Using scatterplot matrix" via |
||
| 8 |
- #' @inheritParams shared_params+ #' `vignette("using-scatterplot-matrix", package = "teal.modules.general")`.
|
||
| 9 |
- #' @param input_path (`list`) of the input paths, optional. Each element can be:+ #' |
||
| 10 |
- #'+ #' @inheritParams teal::module |
||
| 11 |
- #' Paths can be specified as absolute paths or relative to the running directory of the application.+ #' @inheritParams tm_g_scatterplot |
||
| 12 |
- #' Default to the current working directory if not supplied.+ #' @inheritParams shared_params |
||
| 14 |
- #' @inherit shared_params return+ #' @param variables (`data_extract_spec` or `list` of multiple `data_extract_spec`) |
||
| 15 |
- #'+ #' Specifies plotting variables from an incoming dataset with filtering and selecting. In case of |
||
| 16 |
- #' @examples+ #' `data_extract_spec` use `select_spec(..., ordered = TRUE)` if plot elements should be |
||
| 17 |
- #' data <- teal_data()+ #' rendered according to selection order. |
||
| 18 |
- #' data <- within(data, {
+ #' |
||
| 19 |
- #' data <- data.frame(1)+ #' @inherit shared_params return |
||
| 20 |
- #' })+ #' |
||
| 21 |
- #' datanames(data) <- c("data")
+ #' @examples |
||
| 22 |
- #'+ #' # general data example |
||
| 23 |
- #' app <- init(+ #' data <- teal_data() |
||
| 24 |
- #' data = data,+ #' data <- within(data, {
|
||
| 25 |
- #' modules = modules(+ #' countries <- data.frame( |
||
| 26 |
- #' tm_file_viewer(+ #' id = c("DE", "FR", "IT", "ES", "PT", "GR", "NL", "BE", "LU", "AT"),
|
||
| 27 |
- #' input_path = list(+ #' government = factor( |
||
| 28 |
- #' folder = system.file("sample_files", package = "teal.modules.general"),
+ #' c(2, 2, 2, 1, 2, 2, 1, 1, 1, 2), |
||
| 29 |
- #' png = system.file("sample_files/sample_file.png", package = "teal.modules.general"),
+ #' labels = c("Monarchy", "Republic")
|
||
| 30 |
- #' txt = system.file("sample_files/sample_file.txt", package = "teal.modules.general"),
+ #' ), |
||
| 31 |
- #' url = "https://fda.gov/files/drugs/published/Portable-Document-Format-Specifications.pdf"+ #' language_family = factor( |
||
| 32 |
- #' )+ #' c(1, 3, 3, 3, 3, 2, 1, 1, 3, 1), |
||
| 33 |
- #' )+ #' labels = c("Germanic", "Hellenic", "Romance")
|
||
| 34 |
- #' )+ #' ), |
||
| 35 |
- #' )+ #' population = c(83, 67, 60, 47, 10, 11, 17, 11, 0.6, 9), |
||
| 36 |
- #' if (interactive()) {
+ #' area = c(357, 551, 301, 505, 92, 132, 41, 30, 2.6, 83), |
||
| 37 |
- #' shinyApp(app$ui, app$server)+ #' gdp = c(3.4, 2.7, 2.1, 1.4, 0.3, 0.2, 0.7, 0.5, 0.1, 0.4), |
||
| 38 |
- #' }+ #' debt = c(2.1, 2.3, 2.4, 2.6, 2.3, 2.4, 2.3, 2.4, 2.3, 2.4) |
||
| 39 |
- #'+ #' ) |
||
| 40 |
- #' @export+ #' sales <- data.frame( |
||
| 41 |
- #'+ #' id = 1:50, |
||
| 42 |
- tm_file_viewer <- function(label = "File Viewer Module",+ #' country_id = sample( |
||
| 43 |
- input_path = list("Current Working Directory" = ".")) {
+ #' c("DE", "FR", "IT", "ES", "PT", "GR", "NL", "BE", "LU", "AT"),
|
||
| 44 | -! | +
- message("Initializing tm_file_viewer")
+ #' size = 50, |
|
| 45 |
-
+ #' replace = TRUE |
||
| 46 |
- # Normalize the parameters+ #' ), |
||
| 47 | -! | +
- if (length(label) == 0 || identical(label, "")) label <- " "+ #' year = sort(sample(2010:2020, 50, replace = TRUE)), |
|
| 48 | -! | +
- if (length(input_path) == 0 || identical(input_path, "")) input_path <- list()+ #' venue = sample(c("small", "medium", "large", "online"), 50, replace = TRUE),
|
|
| 49 |
-
+ #' cancelled = sample(c(TRUE, FALSE), 50, replace = TRUE), |
||
| 50 |
- # Start of assertions+ #' quantity = rnorm(50, 100, 20), |
||
| 51 | -! | +
- checkmate::assert_string(label)+ #' costs = rnorm(50, 80, 20), |
|
| 52 |
-
+ #' profit = rnorm(50, 20, 10) |
||
| 53 | -! | +
- checkmate::assert(+ #' ) |
|
| 54 | -! | +
- checkmate::check_list(input_path, types = "character", min.len = 0),+ #' }) |
|
| 55 | -! | +
- checkmate::check_character(input_path, min.len = 1)+ #' datanames(data) <- c("countries", "sales")
|
|
| 56 |
- )+ #' join_keys(data) <- join_keys( |
||
| 57 | -! | +
- if (length(input_path) > 0) {
+ #' join_key("countries", "countries", "id"),
|
|
| 58 | -! | +
- valid_url <- function(url_input, timeout = 2) {
+ #' join_key("sales", "sales", "id"),
|
|
| 59 | -! | +
- con <- try(url(url_input), silent = TRUE)+ #' join_key("countries", "sales", c("id" = "country_id"))
|
|
| 60 | -! | +
- check <- suppressWarnings(try(open.connection(con, open = "rt", timeout = timeout), silent = TRUE)[1])+ #' ) |
|
| 61 | -! | +
- try(close.connection(con), silent = TRUE)+ #' |
|
| 62 | -! | +
- is.null(check)+ #' app <- init( |
|
| 63 |
- }+ #' data = data, |
||
| 64 | -! | +
- idx <- vapply(input_path, function(x) file.exists(x) || valid_url(x), logical(1))+ #' modules = modules( |
|
| 65 |
-
+ #' tm_g_scatterplotmatrix( |
||
| 66 | -! | +
- if (!all(idx)) {
+ #' label = "Scatterplot matrix", |
|
| 67 | -! | +
- warning(+ #' variables = list( |
|
| 68 | -! | +
- paste0(+ #' data_extract_spec( |
|
| 69 | -! | +
- "Non-existent file or url path. Please provide valid paths for:\n",+ #' dataname = "countries", |
|
| 70 | -! | +
- paste0(input_path[!idx], collapse = "\n")+ #' select = select_spec( |
|
| 71 |
- )+ #' label = "Select variables:", |
||
| 72 |
- )+ #' choices = variable_choices(data[["countries"]]), |
||
| 73 |
- }+ #' selected = c("area", "gdp", "debt"),
|
||
| 74 | -! | +
- input_path <- input_path[idx]+ #' multiple = TRUE, |
|
| 75 |
- } else {
+ #' ordered = TRUE, |
||
| 76 | -! | +
- warning(+ #' fixed = FALSE |
|
| 77 | -! | +
- "No file or url paths were provided."+ #' ) |
|
| 78 |
- )+ #' ), |
||
| 79 |
- }+ #' data_extract_spec( |
||
| 80 |
- # End of assertions+ #' dataname = "sales", |
||
| 81 |
-
+ #' filter = filter_spec( |
||
| 82 |
- # Make UI args+ #' label = "Select variable:", |
||
| 83 | -! | +
- args <- as.list(environment())+ #' vars = "country_id", |
|
| 84 |
-
+ #' choices = value_choices(data[["sales"]], "country_id"), |
||
| 85 | -! | +
- ans <- module(+ #' selected = c("DE", "FR", "IT", "ES", "PT", "GR", "NL", "BE", "LU", "AT"),
|
|
| 86 | -! | +
- label = label,+ #' multiple = TRUE |
|
| 87 | -! | +
- server = srv_viewer,+ #' ), |
|
| 88 | -! | +
- server_args = list(input_path = input_path),+ #' select = select_spec( |
|
| 89 | -! | +
- ui = ui_viewer,+ #' label = "Select variables:", |
|
| 90 | -! | +
- ui_args = args,+ #' choices = variable_choices(data[["sales"]], c("quantity", "costs", "profit")),
|
|
| 91 | -! | +
- datanames = NULL+ #' selected = c("quantity", "costs", "profit"),
|
|
| 92 |
- )+ #' multiple = TRUE, |
||
| 93 | -! | +
- attr(ans, "teal_bookmarkable") <- FALSE+ #' ordered = TRUE, |
|
| 94 | -! | +
- ans+ #' fixed = FALSE |
|
| 95 |
- }+ #' ) |
||
| 96 |
-
+ #' ) |
||
| 97 |
- # UI function for the file viewer module+ #' ) |
||
| 98 |
- ui_viewer <- function(id, ...) {
+ #' ) |
||
| 99 | -! | +
- args <- list(...)+ #' ) |
|
| 100 | -! | +
- ns <- NS(id)+ #' ) |
|
| 101 |
-
+ #' if (interactive()) {
|
||
| 102 | -! | +
- tagList(+ #' shinyApp(app$ui, app$server) |
|
| 103 | -! | +
- include_css_files("custom"),
+ #' } |
|
| 104 | -! | +
- teal.widgets::standard_layout(+ #' |
|
| 105 | -! | +
- output = tags$div(+ #' # CDISC data example |
|
| 106 | -! | +
- uiOutput(ns("output"))
+ #' data <- teal_data() |
|
| 107 |
- ),+ #' data <- within(data, {
|
||
| 108 | -! | +
- encoding = tags$div(+ #' ADSL <- rADSL |
|
| 109 | -! | +
- class = "file_viewer_encoding",+ #' ADRS <- rADRS |
|
| 110 | -! | +
- tags$label("Encodings", class = "text-primary"),
+ #' }) |
|
| 111 | -! | +
- shinyTree::shinyTree(+ #' datanames(data) <- c("ADSL", "ADRS")
|
|
| 112 | -! | +
- ns("tree"),
+ #' join_keys(data) <- default_cdisc_join_keys[datanames(data)] |
|
| 113 | -! | +
- dragAndDrop = FALSE,+ #' |
|
| 114 | -! | +
- sort = FALSE,+ #' app <- init( |
|
| 115 | -! | +
- wholerow = TRUE,+ #' data = data, |
|
| 116 | -! | +
- theme = "proton",+ #' modules = modules( |
|
| 117 | -! | +
- multiple = FALSE+ #' tm_g_scatterplotmatrix( |
|
| 118 |
- )+ #' label = "Scatterplot matrix", |
||
| 119 |
- )+ #' variables = list( |
||
| 120 |
- )+ #' data_extract_spec( |
||
| 121 |
- )+ #' dataname = "ADSL", |
||
| 122 |
- }+ #' select = select_spec( |
||
| 123 |
-
+ #' label = "Select variables:", |
||
| 124 |
- # Server function for the file viewer module+ #' choices = variable_choices(data[["ADSL"]]), |
||
| 125 |
- srv_viewer <- function(id, input_path) {
+ #' selected = c("AGE", "RACE", "SEX"),
|
||
| 126 | -! | +
- moduleServer(id, function(input, output, session) {
+ #' multiple = TRUE, |
|
| 127 | -! | +
- if (shiny::isRunning()) logger::log_shiny_input_changes(input, namespace = "teal.modules.general")+ #' ordered = TRUE, |
|
| 128 |
-
+ #' fixed = FALSE |
||
| 129 | -! | +
- temp_dir <- tempfile()+ #' ) |
|
| 130 | -! | +
- if (!dir.exists(temp_dir)) {
+ #' ), |
|
| 131 | -! | +
- dir.create(temp_dir, recursive = TRUE)+ #' data_extract_spec( |
|
| 132 |
- }+ #' dataname = "ADRS", |
||
| 133 | -! | +
- addResourcePath(basename(temp_dir), temp_dir)+ #' filter = filter_spec( |
|
| 134 |
-
+ #' label = "Select endpoints:", |
||
| 135 | -! | +
- test_path_text <- function(selected_path, type) {
+ #' vars = c("PARAMCD", "AVISIT"),
|
|
| 136 | -! | +
- out <- tryCatch(+ #' choices = value_choices(data[["ADRS"]], c("PARAMCD", "AVISIT"), c("PARAM", "AVISIT")),
|
|
| 137 | -! | +
- expr = {
+ #' selected = "INVET - END OF INDUCTION", |
|
| 138 | -! | +
- if (type != "url") {
+ #' multiple = TRUE |
|
| 139 | -! | +
- selected_path <- normalizePath(selected_path, winslash = "/")+ #' ), |
|
| 140 |
- }+ #' select = select_spec( |
||
| 141 | -! | +
- readLines(con = selected_path)+ #' label = "Select variables:", |
|
| 142 |
- },+ #' choices = variable_choices(data[["ADRS"]]), |
||
| 143 | -! | +
- error = function(cond) FALSE,+ #' selected = c("AGE", "AVAL", "ADY"),
|
|
| 144 | -! | +
- warning = function(cond) {
+ #' multiple = TRUE, |
|
| 145 | -! | +
- `if`(grepl("^incomplete final line found on", cond[[1]]), suppressWarnings(eval(cond[[2]])), FALSE)
+ #' ordered = TRUE, |
|
| 146 |
- }+ #' fixed = FALSE |
||
| 147 |
- )+ #' ) |
||
| 148 |
- }+ #' ) |
||
| 149 |
-
+ #' ) |
||
| 150 | -! | +
- handle_connection_type <- function(selected_path) {
+ #' ) |
|
| 151 | -! | +
- file_extension <- tools::file_ext(selected_path)+ #' ) |
|
| 152 | -! | +
- file_class <- suppressWarnings(file(selected_path))+ #' ) |
|
| 153 | -! | +
- close(file_class)+ #' if (interactive()) {
|
|
| 154 |
-
+ #' shinyApp(app$ui, app$server) |
||
| 155 | -! | +
- output_text <- test_path_text(selected_path, type = class(file_class)[1])+ #' } |
|
| 156 |
-
+ #' |
||
| 157 | -! | +
- if (class(file_class)[1] == "url") {
+ #' @export |
|
| 158 | -! | +
- list(selected_path = selected_path, output_text = output_text)+ #' |
|
| 159 |
- } else {
+ tm_g_scatterplotmatrix <- function(label = "Scatterplot Matrix", |
||
| 160 | -! | +
- file.copy(normalizePath(selected_path, winslash = "/"), temp_dir)+ variables, |
|
| 161 | -! | +
- selected_path <- file.path(basename(temp_dir), basename(selected_path))+ plot_height = c(600, 200, 2000), |
|
| 162 | -! | +
- list(selected_path = selected_path, output_text = output_text)+ plot_width = NULL, |
|
| 163 |
- }+ pre_output = NULL, |
||
| 164 |
- }+ post_output = NULL) {
|
||
| 165 | -+ | ! |
-
+ message("Initializing tm_g_scatterplotmatrix")
|
| 166 | -! | +
- display_file <- function(selected_path) {
+
|
|
| 167 | -! | +
- con_type <- handle_connection_type(selected_path)+ # Requires Suggested packages |
|
| 168 | ! |
- file_extension <- tools::file_ext(selected_path)+ if (!requireNamespace("lattice", quietly = TRUE)) {
|
|
| 169 | ! |
- if (file_extension %in% c("png", "apng", "jpg", "jpeg", "svg", "gif", "webp", "bmp")) {
+ stop("Cannot load lattice - please install the package or restart your session.")
|
|
| 170 | -! | +
- tags$img(src = con_type$selected_path, alt = "file does not exist")+ } |
|
| 171 | -! | +
- } else if (file_extension == "pdf") {
+
|
|
| 172 | -! | +
- tags$embed(+ # Normalize the parameters |
|
| 173 | ! |
- class = "embed_pdf",+ if (inherits(variables, "data_extract_spec")) variables <- list(variables) |
|
| 174 | -! | +
- src = con_type$selected_path+ |
|
| 175 |
- )+ # Start of assertions |
||
| 176 | ! |
- } else if (!isFALSE(con_type$output_text[1])) {
+ checkmate::assert_string(label) |
|
| 177 | ! |
- tags$pre(paste0(con_type$output_text, collapse = "\n"))+ checkmate::assert_list(variables, types = "data_extract_spec") |
|
| 178 |
- } else {
+
|
||
| 179 | ! |
- tags$p("Please select a supported format.")
+ checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE) |
|
| 180 | -+ | ! |
- }+ checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height") |
| 181 | -+ | ! |
- }+ checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE) |
| 182 | -+ | ! |
-
+ checkmate::assert_numeric( |
| 183 | ! |
- tree_list <- function(file_or_dir) {
+ plot_width[1], |
|
| 184 | ! |
- nested_list <- lapply(file_or_dir, function(path) {
+ lower = plot_width[2], upper = plot_width[3], null.ok = TRUE, .var.name = "plot_width" |
|
| 185 | -! | +
- file_class <- suppressWarnings(file(path))+ ) |
|
| 186 | -! | +
- close(file_class)+ |
|
| 187 | ! |
- if (class(file_class)[[1]] != "url") {
+ checkmate::assert_multi_class(pre_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
|
|
| 188 | ! |
- isdir <- file.info(path)$isdir+ checkmate::assert_multi_class(post_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
|
|
| 189 | -! | +
- if (!isdir) {
+ # End of assertions |
|
| 190 | -! | +
- structure(path, ancestry = path, sticon = "file")+ |
|
| 191 |
- } else {
+ # Make UI args |
||
| 192 | ! |
- files <- list.files(path, full.names = TRUE, include.dirs = TRUE)+ args <- as.list(environment()) |
|
| 193 | -! | +
- out <- lapply(files, function(x) tree_list(x))+ |
|
| 194 | ! |
- out <- unlist(out, recursive = FALSE)+ ans <- module( |
|
| 195 | ! |
- if (length(files) > 0) names(out) <- basename(files)+ label = label, |
|
| 196 | ! |
- out+ server = srv_g_scatterplotmatrix, |
|
| 197 | -+ | ! |
- }+ ui = ui_g_scatterplotmatrix, |
| 198 | -+ | ! |
- } else {
+ ui_args = args, |
| 199 | ! |
- structure(path, ancestry = path, sticon = "file")+ server_args = list(variables = variables, plot_height = plot_height, plot_width = plot_width), |
|
| 200 | -+ | ! |
- }+ datanames = teal.transform::get_extract_datanames(variables) |
| 201 |
- })+ ) |
||
| 202 | -+ | ! |
-
+ attr(ans, "teal_bookmarkable") <- TRUE |
| 203 | ! |
- missing_labels <- if (is.null(names(nested_list))) seq_along(nested_list) else which(names(nested_list) == "")+ ans |
|
| 204 | -! | +
- names(nested_list)[missing_labels] <- file_or_dir[missing_labels]+ } |
|
| 205 | -! | +
- nested_list+ |
|
| 206 |
- }+ # UI function for the scatterplot matrix module |
||
| 207 |
-
+ ui_g_scatterplotmatrix <- function(id, ...) {
|
||
| 208 | ! |
- output$tree <- shinyTree::renderTree({
+ args <- list(...) |
|
| 209 | ! |
- if (length(input_path) > 0) {
+ is_single_dataset_value <- teal.transform::is_single_dataset(args$variables) |
|
| 210 | ! |
- tree_list(input_path)+ ns <- NS(id) |
|
| 211 | -+ | ! |
- } else {
+ teal.widgets::standard_layout( |
| 212 | ! |
- list("Empty Path" = NULL)
+ output = teal.widgets::white_small_well( |
|
| 213 | -+ | ! |
- }+ textOutput(ns("message")),
|
| 214 | -+ | ! |
- })+ tags$br(), |
| 215 | -+ | ! |
-
+ teal.widgets::plot_with_settings_ui(id = ns("myplot"))
|
| 216 | -! | +
- output$output <- renderUI({
+ ), |
|
| 217 | ! |
- validate(+ encoding = tags$div( |
|
| 218 | -! | +
- need(+ ### Reporter |
|
| 219 | ! |
- length(shinyTree::get_selected(input$tree)) > 0,+ teal.reporter::simple_reporter_ui(ns("simple_reporter")),
|
|
| 220 | -! | +
- "Please select a file."+ ### |
|
| 221 | -+ | ! |
- )+ tags$label("Encodings", class = "text-primary"),
|
| 222 | -+ | ! |
- )+ teal.transform::datanames_input(args$variables), |
| 223 | -+ | ! |
-
+ teal.transform::data_extract_ui( |
| 224 | ! |
- obj <- shinyTree::get_selected(input$tree, format = "names")[[1]]+ id = ns("variables"),
|
|
| 225 | ! |
- repo <- attr(obj, "ancestry")+ label = "Variables", |
|
| 226 | ! |
- repo_collapsed <- if (length(repo) > 1) paste0(repo, collapse = "/") else repo+ data_extract_spec = args$variables, |
|
| 227 | ! |
- is_not_named <- file.exists(file.path(c(repo_collapsed, obj[1])))[1]+ is_single_dataset = is_single_dataset_value |
|
| 228 |
-
+ ), |
||
| 229 | ! |
- if (is_not_named) {
+ tags$hr(), |
|
| 230 | ! |
- selected_path <- do.call("file.path", as.list(c(repo, obj[1])))
+ teal.widgets::panel_group( |
|
| 231 | -+ | ! |
- } else {
+ teal.widgets::panel_item( |
| 232 | ! |
- if (length(repo) == 0) {
+ title = "Plot settings", |
|
| 233 | ! |
- selected_path <- do.call("file.path", as.list(attr(input$tree[[obj[1]]], "ancestry")))
+ sliderInput( |
|
| 234 | -+ | ! |
- } else {
+ ns("alpha"), "Opacity:",
|
| 235 | ! |
- selected_path <- do.call("file.path", as.list(attr(input$tree[[repo]][[obj[1]]], "ancestry")))
+ min = 0, max = 1, |
|
| 236 | -+ | ! |
- }+ step = .05, value = .5, ticks = FALSE |
| 237 |
- }+ ), |
||
| 238 | -+ | ! |
-
+ sliderInput( |
| 239 | ! |
- validate(+ ns("cex"), "Points size:",
|
|
| 240 | ! |
- need(+ min = 0.2, max = 3, |
|
| 241 | ! |
- !isTRUE(file.info(selected_path)$isdir) && length(selected_path) > 0,+ step = .05, value = .65, ticks = FALSE |
|
| 242 | -! | +
- "Please select a single file."+ ), |
|
| 243 | -+ | ! |
- )+ checkboxInput(ns("cor"), "Add Correlation", value = FALSE),
|
| 244 | -+ | ! |
- )+ radioButtons( |
| 245 | ! |
- display_file(selected_path)+ ns("cor_method"), "Select Correlation Method",
|
|
| 246 | -+ | ! |
- })+ choiceNames = c("Pearson", "Kendall", "Spearman"),
|
| 247 | -+ | ! |
-
+ choiceValues = c("pearson", "kendall", "spearman"),
|
| 248 | ! |
- onStop(function() {
+ inline = TRUE |
|
| 249 | -! | +
- removeResourcePath(basename(temp_dir))+ ), |
|
| 250 | ! |
- unlink(temp_dir)+ checkboxInput(ns("cor_na_omit"), "Omit Missing Values", value = TRUE)
|
|
| 251 |
- })+ ) |
||
| 252 |
- })+ ) |
||
| 253 |
- }+ ), |
| 1 | -+ | ||
| 254 | +! |
- #' `teal` module: Scatterplot matrix+ forms = tagList( |
|
| 2 | -+ | ||
| 255 | +! |
- #'+ teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code")
|
|
| 3 | +256 |
- #' Generates a scatterplot matrix from selected `variables` from datasets.+ ), |
|
| 4 | -+ | ||
| 257 | +! |
- #' Each plot within the matrix represents the relationship between two variables,+ pre_output = args$pre_output, |
|
| 5 | -+ | ||
| 258 | +! |
- #' providing the overview of correlations and distributions across selected data.+ post_output = args$post_output |
|
| 6 | +259 |
- #'+ ) |
|
| 7 | +260 |
- #' @note For more examples, please see the vignette "Using scatterplot matrix" via+ } |
|
| 8 | +261 |
- #' `vignette("using-scatterplot-matrix", package = "teal.modules.general")`.
+
|
|
| 9 | +262 |
- #'+ # Server function for the scatterplot matrix module |
|
| 10 | +263 |
- #' @inheritParams teal::module+ srv_g_scatterplotmatrix <- function(id, data, reporter, filter_panel_api, variables, plot_height, plot_width) {
|
|
| 11 | -+ | ||
| 264 | +! |
- #' @inheritParams tm_g_scatterplot+ with_reporter <- !missing(reporter) && inherits(reporter, "Reporter") |
|
| 12 | -+ | ||
| 265 | +! |
- #' @inheritParams shared_params+ with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI") |
|
| 13 | -+ | ||
| 266 | +! |
- #'+ checkmate::assert_class(data, "reactive") |
|
| 14 | -+ | ||
| 267 | +! |
- #' @param variables (`data_extract_spec` or `list` of multiple `data_extract_spec`)+ checkmate::assert_class(isolate(data()), "teal_data") |
|
| 15 | -+ | ||
| 268 | +! |
- #' Specifies plotting variables from an incoming dataset with filtering and selecting. In case of+ moduleServer(id, function(input, output, session) {
|
|
| 16 | -+ | ||
| 269 | +! |
- #' `data_extract_spec` use `select_spec(..., ordered = TRUE)` if plot elements should be+ teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.general") |
|
| 17 | +270 |
- #' rendered according to selection order.+ |
|
| 18 | -+ | ||
| 271 | +! |
- #'+ selector_list <- teal.transform::data_extract_multiple_srv( |
|
| 19 | -+ | ||
| 272 | +! |
- #' @inherit shared_params return+ data_extract = list(variables = variables), |
|
| 20 | -+ | ||
| 273 | +! |
- #'+ datasets = data, |
|
| 21 | -+ | ||
| 274 | +! |
- #' @examples+ select_validation_rule = list( |
|
| 22 | -+ | ||
| 275 | +! |
- #' # general data example+ variables = ~ if (length(.) <= 1) "Please select at least 2 columns." |
|
| 23 | +276 |
- #' data <- teal_data()+ ) |
|
| 24 | +277 |
- #' data <- within(data, {
+ ) |
|
| 25 | +278 |
- #' countries <- data.frame(+ |
|
| 26 | -+ | ||
| 279 | +! |
- #' id = c("DE", "FR", "IT", "ES", "PT", "GR", "NL", "BE", "LU", "AT"),
+ iv_r <- reactive({
|
|
| 27 | -+ | ||
| 280 | +! |
- #' government = factor(+ iv <- shinyvalidate::InputValidator$new() |
|
| 28 | -+ | ||
| 281 | +! |
- #' c(2, 2, 2, 1, 2, 2, 1, 1, 1, 2),+ teal.transform::compose_and_enable_validators(iv, selector_list) |
|
| 29 | +282 |
- #' labels = c("Monarchy", "Republic")
+ }) |
|
| 30 | +283 |
- #' ),+ |
|
| 31 | -+ | ||
| 284 | +! |
- #' language_family = factor(+ anl_merged_input <- teal.transform::merge_expression_srv( |
|
| 32 | -+ | ||
| 285 | +! |
- #' c(1, 3, 3, 3, 3, 2, 1, 1, 3, 1),+ datasets = data, |
|
| 33 | -+ | ||
| 286 | +! |
- #' labels = c("Germanic", "Hellenic", "Romance")
+ selector_list = selector_list |
|
| 34 | +287 |
- #' ),+ ) |
|
| 35 | +288 |
- #' population = c(83, 67, 60, 47, 10, 11, 17, 11, 0.6, 9),+ |
|
| 36 | -+ | ||
| 289 | +! |
- #' area = c(357, 551, 301, 505, 92, 132, 41, 30, 2.6, 83),+ anl_merged_q <- reactive({
|
|
| 37 | -+ | ||
| 290 | +! |
- #' gdp = c(3.4, 2.7, 2.1, 1.4, 0.3, 0.2, 0.7, 0.5, 0.1, 0.4),+ req(anl_merged_input()) |
|
| 38 | -+ | ||
| 291 | +! |
- #' debt = c(2.1, 2.3, 2.4, 2.6, 2.3, 2.4, 2.3, 2.4, 2.3, 2.4)+ data() %>% |
|
| 39 | -+ | ||
| 292 | +! |
- #' )+ teal.code::eval_code(as.expression(anl_merged_input()$expr)) |
|
| 40 | +293 |
- #' sales <- data.frame(+ }) |
|
| 41 | +294 |
- #' id = 1:50,+ |
|
| 42 | -+ | ||
| 295 | +! |
- #' country_id = sample(+ merged <- list( |
|
| 43 | -+ | ||
| 296 | +! |
- #' c("DE", "FR", "IT", "ES", "PT", "GR", "NL", "BE", "LU", "AT"),
+ anl_input_r = anl_merged_input, |
|
| 44 | -+ | ||
| 297 | +! |
- #' size = 50,+ anl_q_r = anl_merged_q |
|
| 45 | +298 |
- #' replace = TRUE+ ) |
|
| 46 | +299 |
- #' ),+ |
|
| 47 | +300 |
- #' year = sort(sample(2010:2020, 50, replace = TRUE)),+ # plot |
|
| 48 | -+ | ||
| 301 | +! |
- #' venue = sample(c("small", "medium", "large", "online"), 50, replace = TRUE),
+ output_q <- reactive({
|
|
| 49 | -+ | ||
| 302 | +! |
- #' cancelled = sample(c(TRUE, FALSE), 50, replace = TRUE),+ teal::validate_inputs(iv_r()) |
|
| 50 | +303 |
- #' quantity = rnorm(50, 100, 20),+ |
|
| 51 | -+ | ||
| 304 | +! |
- #' costs = rnorm(50, 80, 20),+ qenv <- merged$anl_q_r() |
|
| 52 | -+ | ||
| 305 | +! |
- #' profit = rnorm(50, 20, 10)+ ANL <- qenv[["ANL"]] |
|
| 53 | +306 |
- #' )+ |
|
| 54 | -+ | ||
| 307 | +! |
- #' })+ cols_names <- merged$anl_input_r()$columns_source$variables |
|
| 55 | -+ | ||
| 308 | +! |
- #' datanames(data) <- c("countries", "sales")
+ alpha <- input$alpha |
|
| 56 | -+ | ||
| 309 | +! |
- #' join_keys(data) <- join_keys(+ cex <- input$cex |
|
| 57 | -+ | ||
| 310 | +! |
- #' join_key("countries", "countries", "id"),
+ add_cor <- input$cor |
|
| 58 | -+ | ||
| 311 | +! |
- #' join_key("sales", "sales", "id"),
+ cor_method <- input$cor_method |
|
| 59 | -+ | ||
| 312 | +! |
- #' join_key("countries", "sales", c("id" = "country_id"))
+ cor_na_omit <- input$cor_na_omit |
|
| 60 | +313 |
- #' )+ |
|
| 61 | -+ | ||
| 314 | +! |
- #'+ cor_na_action <- if (isTruthy(cor_na_omit)) {
|
|
| 62 | -+ | ||
| 315 | +! |
- #' app <- init(+ "na.omit" |
|
| 63 | +316 |
- #' data = data,+ } else {
|
|
| 64 | -+ | ||
| 317 | +! |
- #' modules = modules(+ "na.fail" |
|
| 65 | +318 |
- #' tm_g_scatterplotmatrix(+ } |
|
| 66 | +319 |
- #' label = "Scatterplot matrix",+ |
|
| 67 | -+ | ||
| 320 | +! |
- #' variables = list(+ teal::validate_has_data(ANL, 10) |
|
| 68 | -+ | ||
| 321 | +! |
- #' data_extract_spec(+ teal::validate_has_data(ANL[, cols_names, drop = FALSE], 10, complete = TRUE, allow_inf = FALSE) |
|
| 69 | +322 |
- #' dataname = "countries",+ |
|
| 70 | +323 |
- #' select = select_spec(+ # get labels and proper variable names |
|
| 71 | -+ | ||
| 324 | +! |
- #' label = "Select variables:",+ varnames <- varname_w_label(cols_names, ANL, wrap_width = 20) |
|
| 72 | +325 |
- #' choices = variable_choices(data[["countries"]]),+ |
|
| 73 | +326 |
- #' selected = c("area", "gdp", "debt"),
+ # check character columns. If any, then those are converted to factors |
|
| 74 | -+ | ||
| 327 | +! |
- #' multiple = TRUE,+ check_char <- vapply(ANL[, cols_names], is.character, logical(1)) |
|
| 75 | -+ | ||
| 328 | +! |
- #' ordered = TRUE,+ if (any(check_char)) {
|
|
| 76 | -+ | ||
| 329 | +! |
- #' fixed = FALSE+ qenv <- teal.code::eval_code( |
|
| 77 | -+ | ||
| 330 | +! |
- #' )+ qenv, |
|
| 78 | -+ | ||
| 331 | +! |
- #' ),+ substitute( |
|
| 79 | -+ | ||
| 332 | +! |
- #' data_extract_spec(+ expr = ANL <- ANL[, cols_names] %>% |
|
| 80 | -+ | ||
| 333 | +! |
- #' dataname = "sales",+ dplyr::mutate_if(is.character, as.factor) %>% |
|
| 81 | -+ | ||
| 334 | +! |
- #' filter = filter_spec(+ droplevels(), |
|
| 82 | -+ | ||
| 335 | +! |
- #' label = "Select variable:",+ env = list(cols_names = cols_names) |
|
| 83 | +336 |
- #' vars = "country_id",+ ) |
|
| 84 | +337 |
- #' choices = value_choices(data[["sales"]], "country_id"),+ ) |
|
| 85 | +338 |
- #' selected = c("DE", "FR", "IT", "ES", "PT", "GR", "NL", "BE", "LU", "AT"),
+ } else {
|
|
| 86 | -+ | ||
| 339 | +! |
- #' multiple = TRUE+ qenv <- teal.code::eval_code( |
|
| 87 | -+ | ||
| 340 | +! |
- #' ),+ qenv, |
|
| 88 | -+ | ||
| 341 | +! |
- #' select = select_spec(+ substitute( |
|
| 89 | -+ | ||
| 342 | +! |
- #' label = "Select variables:",+ expr = ANL <- ANL[, cols_names] %>% |
|
| 90 | -+ | ||
| 343 | +! |
- #' choices = variable_choices(data[["sales"]], c("quantity", "costs", "profit")),
+ droplevels(), |
|
| 91 | -+ | ||
| 344 | +! |
- #' selected = c("quantity", "costs", "profit"),
+ env = list(cols_names = cols_names) |
|
| 92 | +345 |
- #' multiple = TRUE,+ ) |
|
| 93 | +346 |
- #' ordered = TRUE,+ ) |
|
| 94 | +347 |
- #' fixed = FALSE+ } |
|
| 95 | +348 |
- #' )+ |
|
| 96 | +349 |
- #' )+ |
|
| 97 | +350 |
- #' )+ # create plot |
|
| 98 | -+ | ||
| 351 | +! |
- #' )+ if (add_cor) {
|
|
| 99 | -+ | ||
| 352 | +! |
- #' )+ shinyjs::show("cor_method")
|
|
| 100 | -+ | ||
| 353 | +! |
- #' )+ shinyjs::show("cor_use")
|
|
| 101 | -+ | ||
| 354 | +! |
- #' if (interactive()) {
+ shinyjs::show("cor_na_omit")
|
|
| 102 | +355 |
- #' shinyApp(app$ui, app$server)+ |
|
| 103 | -+ | ||
| 356 | +! |
- #' }+ qenv <- teal.code::eval_code( |
|
| 104 | -+ | ||
| 357 | +! |
- #'+ qenv, |
|
| 105 | -+ | ||
| 358 | +! |
- #' # CDISC data example+ substitute( |
|
| 106 | -+ | ||
| 359 | +! |
- #' data <- teal_data()+ expr = {
|
|
| 107 | -+ | ||
| 360 | +! |
- #' data <- within(data, {
+ g <- lattice::splom( |
|
| 108 | -+ | ||
| 361 | +! |
- #' ADSL <- rADSL+ ANL, |
|
| 109 | -+ | ||
| 362 | +! |
- #' ADRS <- rADRS+ varnames = varnames_value, |
|
| 110 | -+ | ||
| 363 | +! |
- #' })+ panel = function(x, y, ...) {
|
|
| 111 | -+ | ||
| 364 | +! |
- #' datanames(data) <- c("ADSL", "ADRS")
+ lattice::panel.splom(x = x, y = y, ...) |
|
| 112 | -+ | ||
| 365 | +! |
- #' join_keys(data) <- default_cdisc_join_keys[datanames(data)]+ cpl <- lattice::current.panel.limits() |
|
| 113 | -+ | ||
| 366 | +! |
- #'+ lattice::panel.text( |
|
| 114 | -+ | ||
| 367 | +! |
- #' app <- init(+ mean(cpl$xlim), |
|
| 115 | -+ | ||
| 368 | +! |
- #' data = data,+ mean(cpl$ylim), |
|
| 116 | -+ | ||
| 369 | +! |
- #' modules = modules(+ get_scatterplotmatrix_stats( |
|
| 117 | -+ | ||
| 370 | +! |
- #' tm_g_scatterplotmatrix(+ x, |
|
| 118 | -+ | ||
| 371 | +! |
- #' label = "Scatterplot matrix",+ y, |
|
| 119 | -+ | ||
| 372 | +! |
- #' variables = list(+ .f = stats::cor.test, |
|
| 120 | -+ | ||
| 373 | +! |
- #' data_extract_spec(+ .f_args = list(method = cor_method, na.action = cor_na_action) |
|
| 121 | +374 |
- #' dataname = "ADSL",+ ), |
|
| 122 | -+ | ||
| 375 | +! |
- #' select = select_spec(+ alpha = 0.6, |
|
| 123 | -+ | ||
| 376 | +! |
- #' label = "Select variables:",+ fontsize = 18, |
|
| 124 | -+ | ||
| 377 | +! |
- #' choices = variable_choices(data[["ADSL"]]),+ fontface = "bold" |
|
| 125 | +378 |
- #' selected = c("AGE", "RACE", "SEX"),
+ ) |
|
| 126 | +379 |
- #' multiple = TRUE,+ }, |
|
| 127 | -+ | ||
| 380 | +! |
- #' ordered = TRUE,+ pch = 16, |
|
| 128 | -+ | ||
| 381 | +! |
- #' fixed = FALSE+ alpha = alpha_value, |
|
| 129 | -+ | ||
| 382 | +! |
- #' )+ cex = cex_value |
|
| 130 | +383 |
- #' ),+ ) |
|
| 131 | -+ | ||
| 384 | +! |
- #' data_extract_spec(+ print(g) |
|
| 132 | +385 |
- #' dataname = "ADRS",+ }, |
|
| 133 | -+ | ||
| 386 | +! |
- #' filter = filter_spec(+ env = list( |
|
| 134 | -+ | ||
| 387 | +! |
- #' label = "Select endpoints:",+ varnames_value = varnames, |
|
| 135 | -+ | ||
| 388 | +! |
- #' vars = c("PARAMCD", "AVISIT"),
+ cor_method = cor_method, |
|
| 136 | -+ | ||
| 389 | +! |
- #' choices = value_choices(data[["ADRS"]], c("PARAMCD", "AVISIT"), c("PARAM", "AVISIT")),
+ cor_na_action = cor_na_action, |
|
| 137 | -+ | ||
| 390 | +! |
- #' selected = "INVET - END OF INDUCTION",+ alpha_value = alpha, |
|
| 138 | -+ | ||
| 391 | +! |
- #' multiple = TRUE+ cex_value = cex |
|
| 139 | +392 |
- #' ),+ ) |
|
| 140 | +393 |
- #' select = select_spec(+ ) |
|
| 141 | +394 |
- #' label = "Select variables:",+ ) |
|
| 142 | +395 |
- #' choices = variable_choices(data[["ADRS"]]),+ } else {
|
|
| 143 | -+ | ||
| 396 | +! |
- #' selected = c("AGE", "AVAL", "ADY"),
+ shinyjs::hide("cor_method")
|
|
| 144 | -+ | ||
| 397 | +! |
- #' multiple = TRUE,+ shinyjs::hide("cor_use")
|
|
| 145 | -+ | ||
| 398 | +! |
- #' ordered = TRUE,+ shinyjs::hide("cor_na_omit")
|
|
| 146 | -+ | ||
| 399 | +! |
- #' fixed = FALSE+ qenv <- teal.code::eval_code( |
|
| 147 | -+ | ||
| 400 | +! |
- #' )+ qenv, |
|
| 148 | -+ | ||
| 401 | +! |
- #' )+ substitute( |
|
| 149 | -+ | ||
| 402 | +! |
- #' )+ expr = {
|
|
| 150 | -+ | ||
| 403 | +! |
- #' )+ g <- lattice::splom(ANL, varnames = varnames_value, pch = 16, alpha = alpha_value, cex = cex_value) |
|
| 151 | -+ | ||
| 404 | +! |
- #' )+ g |
|
| 152 | +405 |
- #' )+ }, |
|
| 153 | -+ | ||
| 406 | +! |
- #' if (interactive()) {
+ env = list(varnames_value = varnames, alpha_value = alpha, cex_value = cex) |
|
| 154 | +407 |
- #' shinyApp(app$ui, app$server)+ ) |
|
| 155 | +408 |
- #' }+ ) |
|
| 156 | +409 |
- #'+ } |
|
| 157 | -+ | ||
| 410 | +! |
- #' @export+ qenv |
|
| 158 | +411 |
- #'+ }) |
|
| 159 | +412 |
- tm_g_scatterplotmatrix <- function(label = "Scatterplot Matrix",+ |
|
| 160 | -+ | ||
| 413 | +! |
- variables,+ plot_r <- reactive(output_q()[["g"]]) |
|
| 161 | +414 |
- plot_height = c(600, 200, 2000),+ |
|
| 162 | +415 |
- plot_width = NULL,+ # Insert the plot into a plot_with_settings module |
|
| 163 | -+ | ||
| 416 | +! |
- pre_output = NULL,- |
- |
| 164 | -- |
- post_output = NULL) {
+ pws <- teal.widgets::plot_with_settings_srv( |
|
| 165 | +417 | ! |
- message("Initializing tm_g_scatterplotmatrix")
- |
-
| 166 | -- |
-
+ id = "myplot", |
|
| 167 | -+ | ||
| 418 | +! |
- # Requires Suggested packages+ plot_r = plot_r, |
|
| 168 | +419 | ! |
- if (!requireNamespace("lattice", quietly = TRUE)) {
+ height = plot_height, |
| 169 | +420 | ! |
- stop("Cannot load lattice - please install the package or restart your session.")
+ width = plot_width |
| 170 | +421 |
- }+ ) |
|
| 171 | +422 | ||
| 172 | +423 |
- # Normalize the parameters+ # show a message if conversion to factors took place |
|
| 173 | +424 | ! |
- if (inherits(variables, "data_extract_spec")) variables <- list(variables)- |
-
| 174 | -- |
-
+ output$message <- renderText({
|
|
| 175 | -+ | ||
| 425 | +! |
- # Start of assertions+ req(iv_r()$is_valid()) |
|
| 176 | +426 | ! |
- checkmate::assert_string(label)+ req(selector_list()$variables()) |
| 177 | +427 | ! |
- checkmate::assert_list(variables, types = "data_extract_spec")+ ANL <- merged$anl_q_r()[["ANL"]] |
| 178 | -+ | ||
| 428 | +! |
-
+ cols_names <- unique(unname(do.call(c, merged$anl_input_r()$columns_source))) |
|
| 179 | +429 | ! |
- checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE)+ check_char <- vapply(ANL[, cols_names], is.character, logical(1)) |
| 180 | +430 | ! |
- checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height")+ if (any(check_char)) {
|
| 181 | +431 | ! |
- checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE)+ is_single <- sum(check_char) == 1 |
| 182 | +432 | ! |
- checkmate::assert_numeric(+ paste( |
| 183 | +433 | ! |
- plot_width[1],+ "Character", |
| 184 | +434 | ! |
- lower = plot_width[2], upper = plot_width[3], null.ok = TRUE, .var.name = "plot_width"+ ifelse(is_single, "variable", "variables"), |
| 185 | -+ | ||
| 435 | +! |
- )+ paste0("(", paste(cols_names[check_char], collapse = ", "), ")"),
|
|
| 186 | -+ | ||
| 436 | +! |
-
+ ifelse(is_single, "was", "were"), |
|
| 187 | +437 | ! |
- checkmate::assert_multi_class(pre_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
+ "converted to", |
| 188 | +438 | ! |
- checkmate::assert_multi_class(post_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
+ ifelse(is_single, "factor.", "factors.") |
| 189 | +439 |
- # End of assertions+ ) |
|
| 190 | +440 |
-
+ } else {
|
|
| 191 | +441 |
- # Make UI args- |
- |
| 192 | -! | -
- args <- as.list(environment())+ "" |
|
| 193 | +442 | - - | -|
| 194 | -! | -
- ans <- module(- |
- |
| 195 | -! | -
- label = label,- |
- |
| 196 | -! | -
- server = srv_g_scatterplotmatrix,+ } |
|
| 197 | -! | +||
| 443 | +
- ui = ui_g_scatterplotmatrix,+ }) |
||
| 198 | -! | +||
| 444 | +
- ui_args = args,+ |
||
| 199 | +445 | ! |
- server_args = list(variables = variables, plot_height = plot_height, plot_width = plot_width),+ teal.widgets::verbatim_popup_srv( |
| 200 | +446 | ! |
- datanames = teal.transform::get_extract_datanames(variables)- |
-
| 201 | -- |
- )+ id = "rcode", |
|
| 202 | +447 | ! |
- attr(ans, "teal_bookmarkable") <- TRUE+ verbatim_content = reactive(teal.code::get_code(output_q())), |
| 203 | +448 | ! |
- ans+ title = "Show R Code for Scatterplotmatrix" |
| 204 | +449 |
- }+ ) |
|
| 205 | +450 | ||
| 206 | -- |
- # UI function for the scatterplot matrix module- |
- |
| 207 | +451 |
- ui_g_scatterplotmatrix <- function(id, ...) {
- |
- |
| 208 | -! | -
- args <- list(...)+ ### REPORTER |
|
| 209 | +452 | ! |
- is_single_dataset_value <- teal.transform::is_single_dataset(args$variables)+ if (with_reporter) {
|
| 210 | +453 | ! |
- ns <- NS(id)+ card_fun <- function(comment, label) {
|
| 211 | +454 | ! |
- teal.widgets::standard_layout(+ card <- teal::report_card_template( |
| 212 | +455 | ! |
- output = teal.widgets::white_small_well(+ title = "Scatter Plot Matrix", |
| 213 | +456 | ! |
- textOutput(ns("message")),
+ label = label, |
| 214 | +457 | ! |
- tags$br(),+ with_filter = with_filter, |
| 215 | +458 | ! |
- teal.widgets::plot_with_settings_ui(id = ns("myplot"))
+ filter_panel_api = filter_panel_api |
| 216 | +459 |
- ),+ ) |
|
| 217 | +460 | ! |
- encoding = tags$div(- |
-
| 218 | -- |
- ### Reporter+ card$append_text("Plot", "header3")
|
|
| 219 | +461 | ! |
- teal.reporter::simple_reporter_ui(ns("simple_reporter")),
+ card$append_plot(plot_r(), dim = pws$dim()) |
| 220 | -+ | ||
| 462 | +! |
- ###+ if (!comment == "") {
|
|
| 221 | +463 | ! |
- tags$label("Encodings", class = "text-primary"),
+ card$append_text("Comment", "header3")
|
| 222 | +464 | ! |
- teal.transform::datanames_input(args$variables),+ card$append_text(comment) |
| 223 | -! | +||
| 465 | +
- teal.transform::data_extract_ui(+ } |
||
| 224 | +466 | ! |
- id = ns("variables"),
+ card$append_src(teal.code::get_code(output_q())) |
| 225 | +467 | ! |
- label = "Variables",+ card |
| 226 | -! | +||
| 468 | +
- data_extract_spec = args$variables,+ } |
||
| 227 | +469 | ! |
- is_single_dataset = is_single_dataset_value+ teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
|
| 228 | +470 |
- ),+ } |
|
| 229 | -! | +||
| 471 | +
- tags$hr(),+ ### |
||
| 230 | -! | +||
| 472 | +
- teal.widgets::panel_group(+ }) |
||
| 231 | -! | +||
| 473 | +
- teal.widgets::panel_item(+ } |
||
| 232 | -! | +||
| 474 | +
- title = "Plot settings",+ |
||
| 233 | -! | +||
| 475 | +
- sliderInput(+ #' Get stats for x-y pairs in scatterplot matrix |
||
| 234 | -! | +||
| 476 | +
- ns("alpha"), "Opacity:",
+ #' |
||
| 235 | -! | +||
| 477 | +
- min = 0, max = 1,+ #' Uses [stats::cor.test()] per default for all numerical input variables and converts results |
||
| 236 | -! | +||
| 478 | +
- step = .05, value = .5, ticks = FALSE+ #' to character vector. |
||
| 237 | +479 |
- ),+ #' Could be extended if different stats for different variable types are needed. |
|
| 238 | -! | +||
| 480 | +
- sliderInput(+ #' Meant to be called from [lattice::panel.text()]. |
||
| 239 | -! | +||
| 481 | +
- ns("cex"), "Points size:",
+ #' |
||
| 240 | -! | +||
| 482 | +
- min = 0.2, max = 3,+ #' Presently we need to use a formula input for `stats::cor.test` because |
||
| 241 | -! | +||
| 483 | +
- step = .05, value = .65, ticks = FALSE+ #' `na.fail` only gets evaluated when a formula is passed (see below). |
||
| 242 | +484 |
- ),+ #' ``` |
|
| 243 | -! | +||
| 485 | +
- checkboxInput(ns("cor"), "Add Correlation", value = FALSE),
+ #' x = c(1,3,5,7,NA) |
||
| 244 | -! | +||
| 486 | +
- radioButtons(+ #' y = c(3,6,7,8,1) |
||
| 245 | -! | +||
| 487 | +
- ns("cor_method"), "Select Correlation Method",
+ #' stats::cor.test(x, y, na.action = "na.fail") |
||
| 246 | -! | +||
| 488 | +
- choiceNames = c("Pearson", "Kendall", "Spearman"),
+ #' stats::cor.test(~ x + y, na.action = "na.fail") |
||
| 247 | -! | +||
| 489 | +
- choiceValues = c("pearson", "kendall", "spearman"),
+ #' ``` |
||
| 248 | -! | +||
| 490 | +
- inline = TRUE+ #' |
||
| 249 | +491 |
- ),+ #' @param x,y (`numeric`) vectors of data values. `x` and `y` must have the same length. |
|
| 250 | -! | +||
| 492 | +
- checkboxInput(ns("cor_na_omit"), "Omit Missing Values", value = TRUE)
+ #' @param .f (`function`) function that accepts x and y as formula input `~ x + y`. |
||
| 251 | +493 |
- )+ #' Default `stats::cor.test`. |
|
| 252 | +494 |
- )+ #' @param .f_args (`list`) of arguments to be passed to `.f`. |
|
| 253 | +495 |
- ),+ #' @param round_stat (`integer(1)`) optional, number of decimal places to use when rounding the estimate. |
|
| 254 | -! | +||
| 496 | +
- forms = tagList(- |
- ||
| 255 | -! | -
- teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code")
+ #' @param round_pval (`integer(1)`) optional, number of decimal places to use when rounding the p-value. |
|
| 256 | +497 |
- ),+ #' |
|
| 257 | -! | +||
| 498 | +
- pre_output = args$pre_output,+ #' @return Character with stats. For [stats::cor.test()] correlation coefficient and p-value. |
||
| 258 | -! | +||
| 499 | +
- post_output = args$post_output+ #' |
||
| 259 | +500 |
- )+ #' @examples |
|
| 260 | +501 |
- }+ #' set.seed(1) |
|
| 261 | +502 |
-
+ #' x <- runif(25, 0, 1) |
|
| 262 | +503 |
- # Server function for the scatterplot matrix module+ #' y <- runif(25, 0, 1) |
|
| 263 | +504 |
- srv_g_scatterplotmatrix <- function(id, data, reporter, filter_panel_api, variables, plot_height, plot_width) {
+ #' x[c(3, 10, 18)] <- NA |
|
| 264 | -! | +||
| 505 | +
- with_reporter <- !missing(reporter) && inherits(reporter, "Reporter")+ #' |
||
| 265 | -! | +||
| 506 | +
- with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI")+ #' get_scatterplotmatrix_stats(x, y, .f = stats::cor.test, .f_args = list(method = "pearson")) |
||
| 266 | -! | +||
| 507 | +
- checkmate::assert_class(data, "reactive")+ #' get_scatterplotmatrix_stats(x, y, .f = stats::cor.test, .f_args = list( |
||
| 267 | -! | +||
| 508 | +
- checkmate::assert_class(isolate(data()), "teal_data")+ #' method = "pearson", |
||
| 268 | -! | +||
| 509 | +
- moduleServer(id, function(input, output, session) {
+ #' na.action = na.fail |
||
| 269 | -! | +||
| 510 | +
- if (shiny::isRunning()) logger::log_shiny_input_changes(input, namespace = "teal.modules.general")+ #' )) |
||
| 270 | +511 |
-
+ #' |
|
| 271 | -! | +||
| 512 | +
- selector_list <- teal.transform::data_extract_multiple_srv(+ #' @export |
||
| 272 | -! | +||
| 513 | +
- data_extract = list(variables = variables),+ #' |
||
| 273 | -! | +||
| 514 | +
- datasets = data,+ get_scatterplotmatrix_stats <- function(x, y, |
||
| 274 | -! | +||
| 515 | +
- select_validation_rule = list(+ .f = stats::cor.test, |
||
| 275 | -! | +||
| 516 | +
- variables = ~ if (length(.) <= 1) "Please select at least 2 columns."+ .f_args = list(), |
||
| 276 | +517 |
- )+ round_stat = 2, |
|
| 277 | +518 |
- )+ round_pval = 4) {
|
|
| 278 | -+ | ||
| 519 | +6x |
-
+ if (is.numeric(x) && is.numeric(y)) {
|
|
| 279 | -! | +||
| 520 | +3x |
- iv_r <- reactive({
+ stat <- tryCatch(do.call(.f, c(list(~ x + y), .f_args)), error = function(e) NA) |
|
| 280 | -! | +||
| 521 | +
- iv <- shinyvalidate::InputValidator$new()+ |
||
| 281 | -! | +||
| 522 | +3x |
- teal.transform::compose_and_enable_validators(iv, selector_list)+ if (anyNA(stat)) {
|
|
| 282 | -+ | ||
| 523 | +1x |
- })+ return("NA")
|
|
| 283 | -+ | ||
| 524 | +2x |
-
+ } else if (all(c("estimate", "p.value") %in% names(stat))) {
|
|
| 284 | -! | +||
| 525 | +2x |
- anl_merged_input <- teal.transform::merge_expression_srv(+ return(paste( |
|
| 285 | -! | +||
| 526 | +2x |
- datasets = data,+ c( |
|
| 286 | -! | +||
| 527 | +2x |
- selector_list = selector_list+ paste0(names(stat$estimate), ":", round(stat$estimate, round_stat)), |
|
| 287 | -+ | ||
| 528 | +2x |
- )+ paste0("P:", round(stat$p.value, round_pval))
|
|
| 288 | +529 |
-
+ ), |
|
| 289 | -! | +||
| 530 | +2x |
- anl_merged_q <- reactive({
+ collapse = "\n" |
|
| 290 | -! | +||
| 531 | +
- req(anl_merged_input())+ )) |
||
| 291 | -! | +||
| 532 | +
- data() %>%+ } else {
|
||
| 292 | +533 | ! |
- teal.code::eval_code(as.expression(anl_merged_input()$expr))+ stop("function not supported")
|
| 293 | +534 |
- })+ } |
|
| 294 | +535 |
-
+ } else {
|
|
| 295 | -! | +||
| 536 | +3x |
- merged <- list(+ if ("method" %in% names(.f_args)) {
|
|
| 296 | -! | +||
| 537 | +3x |
- anl_input_r = anl_merged_input,+ if (.f_args$method == "pearson") {
|
|
| 297 | -! | +||
| 538 | +1x |
- anl_q_r = anl_merged_q+ return("cor:-")
|
|
| 298 | +539 |
- )+ } |
|
| 299 | -+ | ||
| 540 | +2x |
-
+ if (.f_args$method == "kendall") {
+ |
+ |
| 541 | +1x | +
+ return("tau:-")
|
|
| 300 | +542 |
- # plot+ } |
|
| 301 | -! | +||
| 543 | +1x |
- output_q <- reactive({
+ if (.f_args$method == "spearman") {
|
|
| 302 | -! | +||
| 544 | +1x |
- teal::validate_inputs(iv_r())+ return("rho:-")
|
|
| 303 | +545 |
-
+ } |
|
| 304 | -! | +||
| 546 | +
- qenv <- merged$anl_q_r()+ } |
||
| 305 | +547 | ! |
- ANL <- qenv[["ANL"]]+ return("-")
|
| 306 | +548 |
-
+ } |
|
| 307 | -! | +||
| 549 | +
- cols_names <- merged$anl_input_r()$columns_source$variables+ } |
||
| 308 | -! | +
| 1 | +
- alpha <- input$alpha+ #' `teal` module: Distribution analysis |
||
| 309 | -! | +||
| 2 | +
- cex <- input$cex+ #' |
||
| 310 | -! | +||
| 3 | +
- add_cor <- input$cor+ #' Module is designed to explore the distribution of a single variable within a given dataset. |
||
| 311 | -! | +||
| 4 | +
- cor_method <- input$cor_method+ #' It offers several tools, such as histograms, Q-Q plots, and various statistical tests to |
||
| 312 | -! | +||
| 5 | +
- cor_na_omit <- input$cor_na_omit+ #' visually and statistically analyze the variable's distribution. |
||
| 313 | +6 |
-
+ #' |
|
| 314 | -! | +||
| 7 | +
- cor_na_action <- if (isTruthy(cor_na_omit)) {
+ #' @inheritParams teal::module |
||
| 315 | -! | +||
| 8 | +
- "na.omit"+ #' @inheritParams teal.widgets::standard_layout |
||
| 316 | +9 |
- } else {
+ #' @inheritParams shared_params |
|
| 317 | -! | +||
| 10 | +
- "na.fail"+ #' |
||
| 318 | +11 |
- }+ #' @param dist_var (`data_extract_spec` or `list` of multiple `data_extract_spec`) |
|
| 319 | +12 |
-
+ #' Variable(s) for which the distribution will be analyzed. |
|
| 320 | -! | +||
| 13 | +
- teal::validate_has_data(ANL, 10)+ #' @param strata_var (`data_extract_spec` or `list` of multiple `data_extract_spec`) |
||
| 321 | -! | +||
| 14 | +
- teal::validate_has_data(ANL[, cols_names, drop = FALSE], 10, complete = TRUE, allow_inf = FALSE)+ #' Categorical variable used to split the distribution analysis. |
||
| 322 | +15 |
-
+ #' @param group_var (`data_extract_spec` or `list` of multiple `data_extract_spec`) |
|
| 323 | +16 |
- # get labels and proper variable names+ #' Variable used for faceting plot into multiple panels. |
|
| 324 | -! | +||
| 17 | +
- varnames <- varname_w_label(cols_names, ANL, wrap_width = 20)+ #' @param freq (`logical`) optional, whether to display frequency (`TRUE`) or density (`FALSE`). |
||
| 325 | +18 |
-
+ #' Defaults to density (`FALSE`). |
|
| 326 | +19 |
- # check character columns. If any, then those are converted to factors+ #' @param bins (`integer(1)` or `integer(3)`) optional, specifies the number of bins for the histogram. |
|
| 327 | -! | +||
| 20 | +
- check_char <- vapply(ANL[, cols_names], is.character, logical(1))+ #' - When the length of `bins` is one: The histogram bins will have a fixed size based on the `bins` provided. |
||
| 328 | -! | +||
| 21 | +
- if (any(check_char)) {
+ #' - When the length of `bins` is three: The histogram bins are dynamically adjusted based on vector of `value`, `min`, |
||
| 329 | -! | +||
| 22 | +
- qenv <- teal.code::eval_code(+ #' and `max`. |
||
| 330 | -! | +||
| 23 | +
- qenv,+ #' Defaults to `c(30L, 1L, 100L)`. |
||
| 331 | -! | +||
| 24 | +
- substitute(+ #' |
||
| 332 | -! | +||
| 25 | +
- expr = ANL <- ANL[, cols_names] %>%+ #' @templateVar ggnames "Histogram", "QQplot" |
||
| 333 | -! | +||
| 26 | +
- dplyr::mutate_if(is.character, as.factor) %>%+ #' @template ggplot2_args_multi |
||
| 334 | -! | +||
| 27 | +
- droplevels(),+ #' |
||
| 335 | -! | +||
| 28 | +
- env = list(cols_names = cols_names)+ #' @inherit shared_params return |
||
| 336 | +29 |
- )+ #' |
|
| 337 | +30 |
- )+ #' @examples |
|
| 338 | +31 |
- } else {
+ #' library(teal.widgets) |
|
| 339 | -! | +||
| 32 | +
- qenv <- teal.code::eval_code(+ #' |
||
| 340 | -! | +||
| 33 | +
- qenv,+ #' # general data example |
||
| 341 | -! | +||
| 34 | +
- substitute(+ #' data <- teal_data() |
||
| 342 | -! | +||
| 35 | +
- expr = ANL <- ANL[, cols_names] %>%+ #' data <- within(data, {
|
||
| 343 | -! | +||
| 36 | +
- droplevels(),+ #' iris <- iris |
||
| 344 | -! | +||
| 37 | +
- env = list(cols_names = cols_names)+ #' }) |
||
| 345 | +38 |
- )+ #' datanames(data) <- "iris" |
|
| 346 | +39 |
- )+ #' |
|
| 347 | +40 |
- }+ #' app <- init( |
|
| 348 | +41 |
-
+ #' data = data, |
|
| 349 | +42 |
-
+ #' modules = list( |
|
| 350 | +43 |
- # create plot+ #' tm_g_distribution( |
|
| 351 | -! | +||
| 44 | +
- if (add_cor) {
+ #' dist_var = data_extract_spec( |
||
| 352 | -! | +||
| 45 | +
- shinyjs::show("cor_method")
+ #' dataname = "iris", |
||
| 353 | -! | +||
| 46 | +
- shinyjs::show("cor_use")
+ #' select = select_spec(variable_choices("iris"), "Petal.Length")
|
||
| 354 | -! | +||
| 47 | +
- shinyjs::show("cor_na_omit")
+ #' ), |
||
| 355 | +48 |
-
+ #' ggplot2_args = ggplot2_args( |
|
| 356 | -! | +||
| 49 | +
- qenv <- teal.code::eval_code(+ #' labs = list(subtitle = "Plot generated by Distribution Module") |
||
| 357 | -! | +||
| 50 | +
- qenv,+ #' ) |
||
| 358 | -! | +||
| 51 | +
- substitute(+ #' ) |
||
| 359 | -! | +||
| 52 | +
- expr = {
+ #' ) |
||
| 360 | -! | +||
| 53 | +
- g <- lattice::splom(+ #' ) |
||
| 361 | -! | +||
| 54 | +
- ANL,+ #' if (interactive()) {
|
||
| 362 | -! | +||
| 55 | +
- varnames = varnames_value,+ #' shinyApp(app$ui, app$server) |
||
| 363 | -! | +||
| 56 | +
- panel = function(x, y, ...) {
+ #' } |
||
| 364 | -! | +||
| 57 | +
- lattice::panel.splom(x = x, y = y, ...)+ #' |
||
| 365 | -! | +||
| 58 | +
- cpl <- lattice::current.panel.limits()+ #' # CDISC data example |
||
| 366 | -! | +||
| 59 | +
- lattice::panel.text(+ #' data <- teal_data() |
||
| 367 | -! | +||
| 60 | +
- mean(cpl$xlim),+ #' data <- within(data, {
|
||
| 368 | -! | +||
| 61 | +
- mean(cpl$ylim),+ #' ADSL <- rADSL |
||
| 369 | -! | +||
| 62 | +
- get_scatterplotmatrix_stats(+ #' }) |
||
| 370 | -! | +||
| 63 | +
- x,+ #' datanames(data) <- c("ADSL")
|
||
| 371 | -! | +||
| 64 | +
- y,+ #' join_keys(data) <- default_cdisc_join_keys[datanames(data)] |
||
| 372 | -! | +||
| 65 | +
- .f = stats::cor.test,+ #' |
||
| 373 | -! | +||
| 66 | +
- .f_args = list(method = cor_method, na.action = cor_na_action)+ #' vars1 <- choices_selected( |
||
| 374 | +67 |
- ),+ #' variable_choices(data[["ADSL"]], c("ARM", "COUNTRY", "SEX")),
|
|
| 375 | -! | +||
| 68 | +
- alpha = 0.6,+ #' selected = NULL |
||
| 376 | -! | +||
| 69 | +
- fontsize = 18,+ #' ) |
||
| 377 | -! | +||
| 70 | +
- fontface = "bold"+ #' |
||
| 378 | +71 |
- )+ #' app <- init( |
|
| 379 | +72 |
- },+ #' data = data, |
|
| 380 | -! | +||
| 73 | +
- pch = 16,+ #' modules = modules( |
||
| 381 | -! | +||
| 74 | +
- alpha = alpha_value,+ #' tm_g_distribution( |
||
| 382 | -! | +||
| 75 | +
- cex = cex_value+ #' dist_var = data_extract_spec( |
||
| 383 | +76 |
- )+ #' dataname = "ADSL", |
|
| 384 | -! | +||
| 77 | +
- print(g)+ #' select = select_spec( |
||
| 385 | +78 |
- },+ #' choices = variable_choices(data[["ADSL"]], c("AGE", "BMRKR1")),
|
|
| 386 | -! | +||
| 79 | +
- env = list(+ #' selected = "BMRKR1", |
||
| 387 | -! | +||
| 80 | +
- varnames_value = varnames,+ #' multiple = FALSE, |
||
| 388 | -! | +||
| 81 | +
- cor_method = cor_method,+ #' fixed = FALSE |
||
| 389 | -! | +||
| 82 | +
- cor_na_action = cor_na_action,+ #' ) |
||
| 390 | -! | +||
| 83 | +
- alpha_value = alpha,+ #' ), |
||
| 391 | -! | +||
| 84 | +
- cex_value = cex+ #' strata_var = data_extract_spec( |
||
| 392 | +85 |
- )+ #' dataname = "ADSL", |
|
| 393 | +86 |
- )+ #' filter = filter_spec( |
|
| 394 | +87 |
- )+ #' vars = vars1, |
|
| 395 | +88 |
- } else {
+ #' multiple = TRUE |
|
| 396 | -! | +||
| 89 | +
- shinyjs::hide("cor_method")
+ #' ) |
||
| 397 | -! | +||
| 90 | +
- shinyjs::hide("cor_use")
+ #' ), |
||
| 398 | -! | +||
| 91 | +
- shinyjs::hide("cor_na_omit")
+ #' group_var = data_extract_spec( |
||
| 399 | -! | +||
| 92 | +
- qenv <- teal.code::eval_code(+ #' dataname = "ADSL", |
||
| 400 | -! | +||
| 93 | +
- qenv,+ #' filter = filter_spec( |
||
| 401 | -! | +||
| 94 | +
- substitute(+ #' vars = vars1, |
||
| 402 | -! | +||
| 95 | +
- expr = {
+ #' multiple = TRUE |
||
| 403 | -! | +||
| 96 | +
- g <- lattice::splom(ANL, varnames = varnames_value, pch = 16, alpha = alpha_value, cex = cex_value)- |
- ||
| 404 | -! | -
- g+ #' ) |
|
| 405 | +97 |
- },+ #' ), |
|
| 406 | -! | +||
| 98 | +
- env = list(varnames_value = varnames, alpha_value = alpha, cex_value = cex)+ #' ggplot2_args = ggplot2_args( |
||
| 407 | +99 |
- )+ #' labs = list(subtitle = "Plot generated by Distribution Module") |
|
| 408 | +100 |
- )+ #' ) |
|
| 409 | +101 |
- }+ #' ) |
|
| 410 | -! | +||
| 102 | +
- qenv+ #' ) |
||
| 411 | +103 |
- })+ #' ) |
|
| 412 | +104 |
-
+ #' if (interactive()) {
|
|
| 413 | -! | +||
| 105 | +
- plot_r <- reactive(output_q()[["g"]])+ #' shinyApp(app$ui, app$server) |
||
| 414 | +106 |
-
+ #' } |
|
| 415 | +107 |
- # Insert the plot into a plot_with_settings module+ #' |
|
| 416 | -! | +||
| 108 | +
- pws <- teal.widgets::plot_with_settings_srv(+ #' @export |
||
| 417 | -! | +||
| 109 | +
- id = "myplot",+ #' |
||
| 418 | -! | +||
| 110 | +
- plot_r = plot_r,+ tm_g_distribution <- function(label = "Distribution Module", |
||
| 419 | -! | +||
| 111 | +
- height = plot_height,+ dist_var, |
||
| 420 | -! | +||
| 112 | +
- width = plot_width+ strata_var = NULL, |
||
| 421 | +113 |
- )+ group_var = NULL, |
|
| 422 | +114 |
-
+ freq = FALSE, |
|
| 423 | +115 |
- # show a message if conversion to factors took place+ ggtheme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void"),
|
|
| 424 | -! | +||
| 116 | +
- output$message <- renderText({
+ ggplot2_args = teal.widgets::ggplot2_args(), |
||
| 425 | -! | +||
| 117 | +
- req(iv_r()$is_valid())+ bins = c(30L, 1L, 100L), |
||
| 426 | -! | +||
| 118 | +
- req(selector_list()$variables())+ plot_height = c(600, 200, 2000), |
||
| 427 | -! | +||
| 119 | +
- ANL <- merged$anl_q_r()[["ANL"]]+ plot_width = NULL, |
||
| 428 | -! | +||
| 120 | +
- cols_names <- unique(unname(do.call(c, merged$anl_input_r()$columns_source)))+ pre_output = NULL, |
||
| 429 | -! | +||
| 121 | +
- check_char <- vapply(ANL[, cols_names], is.character, logical(1))+ post_output = NULL) {
|
||
| 430 | +122 | ! |
- if (any(check_char)) {
+ message("Initializing tm_g_distribution")
|
| 431 | -! | +||
| 123 | +
- is_single <- sum(check_char) == 1+ |
||
| 432 | -! | +||
| 124 | +
- paste(+ # Requires Suggested packages |
||
| 433 | +125 | ! |
- "Character",+ extra_packages <- c("ggpmisc", "ggpp", "goftest", "MASS", "broom")
|
| 434 | +126 | ! |
- ifelse(is_single, "variable", "variables"),+ missing_packages <- Filter(function(x) !requireNamespace(x, quietly = TRUE), extra_packages) |
| 435 | +127 | ! |
- paste0("(", paste(cols_names[check_char], collapse = ", "), ")"),
+ if (length(missing_packages) > 0L) {
|
| 436 | +128 | ! |
- ifelse(is_single, "was", "were"),+ stop(sprintf( |
| 437 | +129 | ! |
- "converted to",+ "Cannot load package(s): %s.\nInstall or restart your session.", |
| 438 | +130 | ! |
- ifelse(is_single, "factor.", "factors.")- |
-
| 439 | -- |
- )- |
- |
| 440 | -- |
- } else {
+ toString(missing_packages) |
|
| 441 | +131 |
- ""+ )) |
|
| 442 | +132 |
- }+ } |
|
| 443 | +133 |
- })+ |
|
| 444 | +134 |
-
+ # Normalize the parameters |
|
| 445 | +135 | ! |
- teal.widgets::verbatim_popup_srv(+ if (inherits(dist_var, "data_extract_spec")) dist_var <- list(dist_var) |
| 446 | +136 | ! |
- id = "rcode",+ if (inherits(strata_var, "data_extract_spec")) strata_var <- list(strata_var) |
| 447 | +137 | ! |
- verbatim_content = reactive(teal.code::get_code(output_q())),+ if (inherits(group_var, "data_extract_spec")) group_var <- list(group_var) |
| 448 | +138 | ! |
- title = "Show R Code for Scatterplotmatrix"- |
-
| 449 | -- |
- )+ if (inherits(ggplot2_args, "ggplot2_args")) ggplot2_args <- list(default = ggplot2_args) |
|
| 450 | +139 | ||
| 451 | +140 |
- ### REPORTER+ # Start of assertions |
|
| 452 | +141 | ! |
- if (with_reporter) {
+ checkmate::assert_string(label) |
| 453 | -! | +||
| 142 | +
- card_fun <- function(comment, label) {
+
|
||
| 454 | +143 | ! |
- card <- teal::report_card_template(+ checkmate::assert_list(dist_var, "data_extract_spec") |
| 455 | +144 | ! |
- title = "Scatter Plot Matrix",+ checkmate::assert_false(dist_var[[1L]]$select$multiple) |
| 456 | -! | +||
| 145 | +
- label = label,+ |
||
| 457 | +146 | ! |
- with_filter = with_filter,+ checkmate::assert_list(strata_var, types = "data_extract_spec", null.ok = TRUE) |
| 458 | +147 | ! |
- filter_panel_api = filter_panel_api+ checkmate::assert_list(group_var, types = "data_extract_spec", null.ok = TRUE) |
| 459 | -+ | ||
| 148 | +! |
- )+ checkmate::assert_flag(freq) |
|
| 460 | +149 | ! |
- card$append_text("Plot", "header3")
+ ggtheme <- match.arg(ggtheme) |
| 461 | -! | +||
| 150 | +
- card$append_plot(plot_r(), dim = pws$dim())+ |
||
| 462 | +151 | ! |
- if (!comment == "") {
+ plot_choices <- c("Histogram", "QQplot")
|
| 463 | +152 | ! |
- card$append_text("Comment", "header3")
+ checkmate::assert_list(ggplot2_args, types = "ggplot2_args") |
| 464 | +153 | ! |
- card$append_text(comment)+ checkmate::assert_subset(names(ggplot2_args), c("default", plot_choices))
|
| 465 | +154 |
- }+ |
|
| 466 | +155 | ! |
- card$append_src(teal.code::get_code(output_q()))+ if (length(bins) == 1) {
|
| 467 | +156 | ! |
- card+ checkmate::assert_numeric(bins, any.missing = FALSE, lower = 1) |
| 468 | +157 |
- }+ } else {
|
|
| 469 | +158 | ! |
- teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
+ checkmate::assert_numeric(bins, len = 3, any.missing = FALSE, lower = 1) |
| 470 | -+ | ||
| 159 | +! |
- }+ checkmate::assert_numeric(bins[1], lower = bins[2], upper = bins[3], .var.name = "bins") |
|
| 471 | +160 |
- ###+ } |
|
| 472 | +161 |
- })+ |
|
| 473 | -+ | ||
| 162 | +! |
- }+ checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE) |
|
| 474 | -+ | ||
| 163 | +! |
-
+ checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height") |
|
| 475 | -+ | ||
| 164 | +! |
- #' Get stats for x-y pairs in scatterplot matrix+ checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE) |
|
| 476 | -+ | ||
| 165 | +! |
- #'+ checkmate::assert_numeric( |
|
| 477 | -+ | ||
| 166 | +! |
- #' Uses [stats::cor.test()] per default for all numerical input variables and converts results+ plot_width[1], |
|
| 478 | -+ | ||
| 167 | +! |
- #' to character vector.+ lower = plot_width[2], upper = plot_width[3], null.ok = TRUE, .var.name = "plot_width" |
|
| 479 | +168 |
- #' Could be extended if different stats for different variable types are needed.+ ) |
|
| 480 | +169 |
- #' Meant to be called from [lattice::panel.text()].+ |
|
| 481 | -+ | ||
| 170 | +! |
- #'+ checkmate::assert_multi_class(pre_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
|
|
| 482 | -+ | ||
| 171 | +! |
- #' Presently we need to use a formula input for `stats::cor.test` because+ checkmate::assert_multi_class(post_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
|
|
| 483 | +172 |
- #' `na.fail` only gets evaluated when a formula is passed (see below).+ # End of assertions |
|
| 484 | +173 |
- #' ```+ |
|
| 485 | +174 |
- #' x = c(1,3,5,7,NA)+ # Make UI args |
|
| 486 | -+ | ||
| 175 | +! |
- #' y = c(3,6,7,8,1)+ args <- as.list(environment()) |
|
| 487 | +176 |
- #' stats::cor.test(x, y, na.action = "na.fail")+ |
|
| 488 | -+ | ||
| 177 | +! |
- #' stats::cor.test(~ x + y, na.action = "na.fail")+ data_extract_list <- list( |
|
| 489 | -+ | ||
| 178 | +! |
- #' ```+ dist_var = dist_var, |
|
| 490 | -+ | ||
| 179 | +! |
- #'+ strata_var = strata_var, |
|
| 491 | -+ | ||
| 180 | +! |
- #' @param x,y (`numeric`) vectors of data values. `x` and `y` must have the same length.+ group_var = group_var |
|
| 492 | +181 |
- #' @param .f (`function`) function that accepts x and y as formula input `~ x + y`.+ ) |
|
| 493 | +182 |
- #' Default `stats::cor.test`.+ |
|
| 494 | -+ | ||
| 183 | +! |
- #' @param .f_args (`list`) of arguments to be passed to `.f`.+ ans <- module( |
|
| 495 | -+ | ||
| 184 | +! |
- #' @param round_stat (`integer(1)`) optional, number of decimal places to use when rounding the estimate.+ label = label, |
|
| 496 | -+ | ||
| 185 | +! |
- #' @param round_pval (`integer(1)`) optional, number of decimal places to use when rounding the p-value.+ server = srv_distribution, |
|
| 497 | -+ | ||
| 186 | +! |
- #'+ server_args = c( |
|
| 498 | -+ | ||
| 187 | +! |
- #' @return Character with stats. For [stats::cor.test()] correlation coefficient and p-value.+ data_extract_list, |
|
| 499 | -+ | ||
| 188 | +! |
- #'+ list(plot_height = plot_height, plot_width = plot_width, ggplot2_args = ggplot2_args) |
|
| 500 | +189 |
- #' @examples+ ), |
|
| 501 | -+ | ||
| 190 | +! |
- #' set.seed(1)+ ui = ui_distribution, |
|
| 502 | -+ | ||
| 191 | +! |
- #' x <- runif(25, 0, 1)+ ui_args = args, |
|
| 503 | -+ | ||
| 192 | +! |
- #' y <- runif(25, 0, 1)+ datanames = teal.transform::get_extract_datanames(data_extract_list) |
|
| 504 | +193 |
- #' x[c(3, 10, 18)] <- NA+ ) |
|
| 505 | -+ | ||
| 194 | +! |
- #'+ attr(ans, "teal_bookmarkable") <- TRUE |
|
| 506 | -+ | ||
| 195 | +! |
- #' get_scatterplotmatrix_stats(x, y, .f = stats::cor.test, .f_args = list(method = "pearson"))+ ans |
|
| 507 | +196 |
- #' get_scatterplotmatrix_stats(x, y, .f = stats::cor.test, .f_args = list(+ } |
|
| 508 | +197 |
- #' method = "pearson",+ |
|
| 509 | +198 |
- #' na.action = na.fail+ # UI function for the distribution module |
|
| 510 | +199 |
- #' ))+ ui_distribution <- function(id, ...) {
|
|
| 511 | -+ | ||
| 200 | +! |
- #'+ args <- list(...) |
|
| 512 | -+ | ||
| 201 | +! |
- #' @export+ ns <- NS(id) |
|
| 513 | -+ | ||
| 202 | +! |
- #'+ is_single_dataset_value <- teal.transform::is_single_dataset(args$dist_var, args$strata_var, args$group_var) |
|
| 514 | +203 |
- get_scatterplotmatrix_stats <- function(x, y,+ |
|
| 515 | -+ | ||
| 204 | +! |
- .f = stats::cor.test,+ teal.widgets::standard_layout( |
|
| 516 | -+ | ||
| 205 | +! |
- .f_args = list(),+ output = teal.widgets::white_small_well( |
|
| 517 | -+ | ||
| 206 | +! |
- round_stat = 2,+ tabsetPanel( |
|
| 518 | -+ | ||
| 207 | +! |
- round_pval = 4) {
+ id = ns("tabs"),
|
|
| 519 | -6x | +||
| 208 | +! |
- if (is.numeric(x) && is.numeric(y)) {
+ tabPanel("Histogram", teal.widgets::plot_with_settings_ui(id = ns("hist_plot"))),
|
|
| 520 | -3x | +||
| 209 | +! |
- stat <- tryCatch(do.call(.f, c(list(~ x + y), .f_args)), error = function(e) NA)+ tabPanel("QQplot", teal.widgets::plot_with_settings_ui(id = ns("qq_plot")))
|
|
| 521 | +210 | - - | -|
| 522 | -3x | -
- if (anyNA(stat)) {
- |
- |
| 523 | -1x | -
- return("NA")
- |
- |
| 524 | -2x | -
- } else if (all(c("estimate", "p.value") %in% names(stat))) {
+ ), |
|
| 525 | -2x | +||
| 211 | +! |
- return(paste(+ tags$h3("Statistics Table"),
|
|
| 526 | -2x | +||
| 212 | +! |
- c(+ DT::dataTableOutput(ns("summary_table")),
|
|
| 527 | -2x | +||
| 213 | +! |
- paste0(names(stat$estimate), ":", round(stat$estimate, round_stat)),+ tags$h3("Tests"),
|
|
| 528 | -2x | +||
| 214 | +! |
- paste0("P:", round(stat$p.value, round_pval))
+ DT::dataTableOutput(ns("t_stats"))
|
|
| 529 | +215 |
- ),- |
- |
| 530 | -2x | -
- collapse = "\n"+ ), |
|
| 531 | -+ | ||
| 216 | +! |
- ))+ encoding = tags$div( |
|
| 532 | +217 |
- } else {
+ ### Reporter |
|
| 533 | +218 | ! |
- stop("function not supported")
- |
-
| 534 | -- |
- }+ teal.reporter::simple_reporter_ui(ns("simple_reporter")),
|
|
| 535 | +219 |
- } else {
- |
- |
| 536 | -3x | -
- if ("method" %in% names(.f_args)) {
- |
- |
| 537 | -3x | -
- if (.f_args$method == "pearson") {
- |
- |
| 538 | -1x | -
- return("cor:-")
+ ### |
|
| 539 | -+ | ||
| 220 | +! |
- }+ tags$label("Encodings", class = "text-primary"),
|
|
| 540 | -2x | +||
| 221 | +! |
- if (.f_args$method == "kendall") {
+ teal.transform::datanames_input(args[c("dist_var", "strata_var")]),
|
|
| 541 | -1x | +||
| 222 | +! |
- return("tau:-")
+ teal.transform::data_extract_ui( |
|
| 542 | -+ | ||
| 223 | +! |
- }+ id = ns("dist_i"),
|
|
| 543 | -1x | +||
| 224 | +! |
- if (.f_args$method == "spearman") {
+ label = "Variable", |
|
| 544 | -1x | +||
| 225 | +! |
- return("rho:-")
+ data_extract_spec = args$dist_var, |
|
| 545 | -+ | ||
| 226 | +! |
- }+ is_single_dataset = is_single_dataset_value |
|
| 546 | +227 |
- }+ ), |
|
| 547 | +228 | ! |
- return("-")
- |
-
| 548 | -- |
- }+ if (!is.null(args$group_var)) {
|
|
| 549 | -+ | ||
| 229 | +! |
- }+ tagList( |
| 1 | -+ | ||
| 230 | +! |
- #' `teal` module: Distribution analysis+ teal.transform::data_extract_ui( |
|
| 2 | -+ | ||
| 231 | +! |
- #'+ id = ns("group_i"),
|
|
| 3 | -+ | ||
| 232 | +! |
- #' Module is designed to explore the distribution of a single variable within a given dataset.+ label = "Group by", |
|
| 4 | -+ | ||
| 233 | +! |
- #' It offers several tools, such as histograms, Q-Q plots, and various statistical tests to+ data_extract_spec = args$group_var, |
|
| 5 | -+ | ||
| 234 | +! |
- #' visually and statistically analyze the variable's distribution.+ is_single_dataset = is_single_dataset_value |
|
| 6 | +235 |
- #'+ ), |
|
| 7 | -+ | ||
| 236 | +! |
- #' @inheritParams teal::module+ uiOutput(ns("scales_types_ui"))
|
|
| 8 | +237 |
- #' @inheritParams teal.widgets::standard_layout+ ) |
|
| 9 | +238 |
- #' @inheritParams shared_params+ }, |
|
| 10 | -+ | ||
| 239 | +! |
- #'+ if (!is.null(args$strata_var)) {
|
|
| 11 | -+ | ||
| 240 | +! |
- #' @param dist_var (`data_extract_spec` or `list` of multiple `data_extract_spec`)+ teal.transform::data_extract_ui( |
|
| 12 | -+ | ||
| 241 | +! |
- #' Variable(s) for which the distribution will be analyzed.+ id = ns("strata_i"),
|
|
| 13 | -+ | ||
| 242 | +! |
- #' @param strata_var (`data_extract_spec` or `list` of multiple `data_extract_spec`)+ label = "Stratify by", |
|
| 14 | -+ | ||
| 243 | +! |
- #' Categorical variable used to split the distribution analysis.+ data_extract_spec = args$strata_var, |
|
| 15 | -+ | ||
| 244 | +! |
- #' @param group_var (`data_extract_spec` or `list` of multiple `data_extract_spec`)+ is_single_dataset = is_single_dataset_value |
|
| 16 | +245 |
- #' Variable used for faceting plot into multiple panels.+ ) |
|
| 17 | +246 |
- #' @param freq (`logical`) optional, whether to display frequency (`TRUE`) or density (`FALSE`).+ }, |
|
| 18 | -+ | ||
| 247 | +! |
- #' Defaults to density (`FALSE`).+ teal.widgets::panel_group( |
|
| 19 | -+ | ||
| 248 | +! |
- #' @param bins (`integer(1)` or `integer(3)`) optional, specifies the number of bins for the histogram.+ conditionalPanel( |
|
| 20 | -+ | ||
| 249 | +! |
- #' - When the length of `bins` is one: The histogram bins will have a fixed size based on the `bins` provided.+ condition = paste0("input['", ns("tabs"), "'] == 'Histogram'"),
|
|
| 21 | -+ | ||
| 250 | +! |
- #' - When the length of `bins` is three: The histogram bins are dynamically adjusted based on vector of `value`, `min`,+ teal.widgets::panel_item( |
|
| 22 | -+ | ||
| 251 | +! |
- #' and `max`.+ "Histogram", |
|
| 23 | -+ | ||
| 252 | +! |
- #' Defaults to `c(30L, 1L, 100L)`.+ teal.widgets::optionalSliderInputValMinMax(ns("bins"), "Bins", args$bins, ticks = FALSE, step = 1),
|
|
| 24 | -+ | ||
| 253 | +! |
- #'+ shinyWidgets::prettyRadioButtons( |
|
| 25 | -+ | ||
| 254 | +! |
- #' @templateVar ggnames "Histogram", "QQplot"+ ns("main_type"),
|
|
| 26 | -+ | ||
| 255 | +! |
- #' @template ggplot2_args_multi+ label = "Plot Type:", |
|
| 27 | -+ | ||
| 256 | +! |
- #'+ choices = c("Density", "Frequency"),
|
|
| 28 | -+ | ||
| 257 | +! |
- #' @inherit shared_params return+ selected = if (!args$freq) "Density" else "Frequency", |
|
| 29 | -+ | ||
| 258 | +! |
- #'+ bigger = FALSE, |
|
| 30 | -+ | ||
| 259 | +! |
- #' @examples+ inline = TRUE |
|
| 31 | +260 |
- #' library(teal.widgets)+ ), |
|
| 32 | -+ | ||
| 261 | +! |
- #'+ checkboxInput(ns("add_dens"), label = "Overlay Density", value = TRUE),
|
|
| 33 | -+ | ||
| 262 | +! |
- #' # general data example+ collapsed = FALSE |
|
| 34 | +263 |
- #' data <- teal_data()+ ) |
|
| 35 | +264 |
- #' data <- within(data, {
+ ), |
|
| 36 | -+ | ||
| 265 | +! |
- #' iris <- iris+ conditionalPanel( |
|
| 37 | -+ | ||
| 266 | +! |
- #' })+ condition = paste0("input['", ns("tabs"), "'] == 'QQplot'"),
|
|
| 38 | -+ | ||
| 267 | +! |
- #' datanames(data) <- "iris"+ teal.widgets::panel_item( |
|
| 39 | -+ | ||
| 268 | +! |
- #'+ "QQ Plot", |
|
| 40 | -+ | ||
| 269 | +! |
- #' app <- init(+ checkboxInput(ns("qq_line"), label = "Add diagonal line(s)", TRUE),
|
|
| 41 | -+ | ||
| 270 | +! |
- #' data = data,+ collapsed = FALSE |
|
| 42 | +271 |
- #' modules = list(+ ) |
|
| 43 | +272 |
- #' tm_g_distribution(+ ), |
|
| 44 | -+ | ||
| 273 | +! |
- #' dist_var = data_extract_spec(+ conditionalPanel( |
|
| 45 | -+ | ||
| 274 | +! |
- #' dataname = "iris",+ condition = paste0("input['", ns("main_type"), "'] == 'Density'"),
|
|
| 46 | -+ | ||
| 275 | +! |
- #' select = select_spec(variable_choices("iris"), "Petal.Length")
+ teal.widgets::panel_item( |
|
| 47 | -+ | ||
| 276 | +! |
- #' ),+ "Theoretical Distribution", |
|
| 48 | -+ | ||
| 277 | +! |
- #' ggplot2_args = ggplot2_args(+ teal.widgets::optionalSelectInput( |
|
| 49 | -+ | ||
| 278 | +! |
- #' labs = list(subtitle = "Plot generated by Distribution Module")+ ns("t_dist"),
|
|
| 50 | -+ | ||
| 279 | +! |
- #' )+ tags$div( |
|
| 51 | -+ | ||
| 280 | +! |
- #' )+ class = "teal-tooltip", |
|
| 52 | -+ | ||
| 281 | +! |
- #' )+ tagList( |
|
| 53 | -+ | ||
| 282 | +! |
- #' )+ "Distribution:", |
|
| 54 | -+ | ||
| 283 | +! |
- #' if (interactive()) {
+ icon("circle-info"),
|
|
| 55 | -+ | ||
| 284 | +! |
- #' shinyApp(app$ui, app$server)+ tags$span( |
|
| 56 | -+ | ||
| 285 | +! |
- #' }+ class = "tooltiptext", |
|
| 57 | -+ | ||
| 286 | +! |
- #'+ "Default parameters are optimized with MASS::fitdistr function." |
|
| 58 | +287 |
- #' # CDISC data example+ ) |
|
| 59 | +288 |
- #' data <- teal_data()+ ) |
|
| 60 | +289 |
- #' data <- within(data, {
+ ), |
|
| 61 | -+ | ||
| 290 | +! |
- #' ADSL <- rADSL+ choices = c("normal", "lognormal", "gamma", "unif"),
|
|
| 62 | -+ | ||
| 291 | +! |
- #' })+ selected = NULL, |
|
| 63 | -+ | ||
| 292 | +! |
- #' datanames(data) <- c("ADSL")
+ multiple = FALSE |
|
| 64 | +293 |
- #' join_keys(data) <- default_cdisc_join_keys[datanames(data)]+ ), |
|
| 65 | -+ | ||
| 294 | +! |
- #'+ numericInput(ns("dist_param1"), label = "param1", value = NULL),
|
|
| 66 | -+ | ||
| 295 | +! |
- #' vars1 <- choices_selected(+ numericInput(ns("dist_param2"), label = "param2", value = NULL),
|
|
| 67 | -+ | ||
| 296 | +! |
- #' variable_choices(data[["ADSL"]], c("ARM", "COUNTRY", "SEX")),
+ tags$span(actionButton(ns("params_reset"), "Default params")),
|
|
| 68 | -+ | ||
| 297 | +! |
- #' selected = NULL+ collapsed = FALSE |
|
| 69 | +298 |
- #' )+ ) |
|
| 70 | +299 |
- #'+ ) |
|
| 71 | +300 |
- #' app <- init(+ ), |
|
| 72 | -+ | ||
| 301 | +! |
- #' data = data,+ teal.widgets::panel_item( |
|
| 73 | -+ | ||
| 302 | +! |
- #' modules = modules(+ "Tests", |
|
| 74 | -+ | ||
| 303 | +! |
- #' tm_g_distribution(+ teal.widgets::optionalSelectInput( |
|
| 75 | -+ | ||
| 304 | +! |
- #' dist_var = data_extract_spec(+ ns("dist_tests"),
|
|
| 76 | -+ | ||
| 305 | +! |
- #' dataname = "ADSL",+ "Tests:", |
|
| 77 | -+ | ||
| 306 | +! |
- #' select = select_spec(+ choices = c( |
|
| 78 | -+ | ||
| 307 | +! |
- #' choices = variable_choices(data[["ADSL"]], c("AGE", "BMRKR1")),
+ "Shapiro-Wilk", |
|
| 79 | -+ | ||
| 308 | +! |
- #' selected = "BMRKR1",+ if (!is.null(args$strata_var)) "t-test (two-samples, not paired)", |
|
| 80 | -+ | ||
| 309 | +! |
- #' multiple = FALSE,+ if (!is.null(args$strata_var)) "one-way ANOVA", |
|
| 81 | -+ | ||
| 310 | +! |
- #' fixed = FALSE+ if (!is.null(args$strata_var)) "Fligner-Killeen", |
|
| 82 | -+ | ||
| 311 | +! |
- #' )+ if (!is.null(args$strata_var)) "F-test", |
|
| 83 | -+ | ||
| 312 | +! |
- #' ),+ "Kolmogorov-Smirnov (one-sample)", |
|
| 84 | -+ | ||
| 313 | +! |
- #' strata_var = data_extract_spec(+ "Anderson-Darling (one-sample)", |
|
| 85 | -+ | ||
| 314 | +! |
- #' dataname = "ADSL",+ "Cramer-von Mises (one-sample)", |
|
| 86 | -+ | ||
| 315 | +! |
- #' filter = filter_spec(+ if (!is.null(args$strata_var)) "Kolmogorov-Smirnov (two-samples)" |
|
| 87 | +316 |
- #' vars = vars1,+ ), |
|
| 88 | -+ | ||
| 317 | +! |
- #' multiple = TRUE+ selected = NULL |
|
| 89 | +318 |
- #' )+ ) |
|
| 90 | +319 |
- #' ),+ ), |
|
| 91 | -+ | ||
| 320 | +! |
- #' group_var = data_extract_spec(+ teal.widgets::panel_item( |
|
| 92 | -+ | ||
| 321 | +! |
- #' dataname = "ADSL",+ "Statistics Table", |
|
| 93 | -+ | ||
| 322 | +! |
- #' filter = filter_spec(+ sliderInput(ns("roundn"), "Round to n digits", min = 0, max = 10, value = 2)
|
|
| 94 | +323 |
- #' vars = vars1,+ ), |
|
| 95 | -+ | ||
| 324 | +! |
- #' multiple = TRUE+ teal.widgets::panel_item( |
|
| 96 | -+ | ||
| 325 | +! |
- #' )+ title = "Plot settings", |
|
| 97 | -+ | ||
| 326 | +! |
- #' ),+ selectInput( |
|
| 98 | -+ | ||
| 327 | +! |
- #' ggplot2_args = ggplot2_args(+ inputId = ns("ggtheme"),
|
|
| 99 | -+ | ||
| 328 | +! |
- #' labs = list(subtitle = "Plot generated by Distribution Module")+ label = "Theme (by ggplot):", |
|
| 100 | -+ | ||
| 329 | +! |
- #' )+ choices = ggplot_themes, |
|
| 101 | -+ | ||
| 330 | +! |
- #' )+ selected = args$ggtheme, |
|
| 102 | -+ | ||
| 331 | +! |
- #' )+ multiple = FALSE |
|
| 103 | +332 |
- #' )+ ) |
|
| 104 | +333 |
- #' if (interactive()) {
+ ) |
|
| 105 | +334 |
- #' shinyApp(app$ui, app$server)+ ), |
|
| 106 | -+ | ||
| 335 | +! |
- #' }+ forms = tagList( |
|
| 107 | -+ | ||
| 336 | +! |
- #'+ teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code")
|
|
| 108 | +337 |
- #' @export+ ), |
|
| 109 | -+ | ||
| 338 | +! |
- #'+ pre_output = args$pre_output, |
|
| 110 | -+ | ||
| 339 | +! |
- tm_g_distribution <- function(label = "Distribution Module",+ post_output = args$post_output |
|
| 111 | +340 |
- dist_var,+ ) |
|
| 112 | +341 |
- strata_var = NULL,+ } |
|
| 113 | +342 |
- group_var = NULL,+ |
|
| 114 | +343 |
- freq = FALSE,+ # Server function for the distribution module |
|
| 115 | +344 |
- ggtheme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void"),
+ srv_distribution <- function(id, |
|
| 116 | +345 |
- ggplot2_args = teal.widgets::ggplot2_args(),+ data, |
|
| 117 | +346 |
- bins = c(30L, 1L, 100L),+ reporter, |
|
| 118 | +347 |
- plot_height = c(600, 200, 2000),+ filter_panel_api, |
|
| 119 | +348 |
- plot_width = NULL,+ dist_var, |
|
| 120 | +349 |
- pre_output = NULL,+ strata_var, |
|
| 121 | +350 |
- post_output = NULL) {
+ group_var, |
|
| 122 | -! | +||
| 351 | +
- message("Initializing tm_g_distribution")
+ plot_height, |
||
| 123 | +352 |
-
+ plot_width, |
|
| 124 | +353 |
- # Requires Suggested packages+ ggplot2_args) {
|
|
| 125 | +354 | ! |
- extra_packages <- c("ggpmisc", "ggpp", "goftest", "MASS", "broom")
+ with_reporter <- !missing(reporter) && inherits(reporter, "Reporter") |
| 126 | +355 | ! |
- missing_packages <- Filter(function(x) !requireNamespace(x, quietly = TRUE), extra_packages)+ with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI") |
| 127 | +356 | ! |
- if (length(missing_packages) > 0L) {
+ checkmate::assert_class(data, "reactive") |
| 128 | +357 | ! |
- stop(sprintf(+ checkmate::assert_class(isolate(data()), "teal_data") |
| 129 | +358 | ! |
- "Cannot load package(s): %s.\nInstall or restart your session.",+ moduleServer(id, function(input, output, session) {
|
| 130 | +359 | ! |
- toString(missing_packages)+ teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.general") |
| 131 | +360 |
- ))+ |
|
| 132 | -+ | ||
| 361 | +! |
- }+ setBookmarkExclude("params_reset")
|
|
| 133 | +362 | ||
| 363 | +! | +
+ ns <- session$ns+ |
+ |
| 134 | +364 |
- # Normalize the parameters+ |
|
| 135 | +365 | ! |
- if (inherits(dist_var, "data_extract_spec")) dist_var <- list(dist_var)+ rule_req <- function(value) {
|
| 136 | +366 | ! |
- if (inherits(strata_var, "data_extract_spec")) strata_var <- list(strata_var)+ if (isTRUE(input$dist_tests %in% c( |
| 137 | +367 | ! |
- if (inherits(group_var, "data_extract_spec")) group_var <- list(group_var)+ "Fligner-Killeen", |
| 138 | +368 | ! |
- if (inherits(ggplot2_args, "ggplot2_args")) ggplot2_args <- list(default = ggplot2_args)- |
-
| 139 | -- | - - | -|
| 140 | -- |
- # Start of assertions+ "t-test (two-samples, not paired)", |
|
| 141 | +369 | ! |
- checkmate::assert_string(label)- |
-
| 142 | -- |
-
+ "F-test", |
|
| 143 | +370 | ! |
- checkmate::assert_list(dist_var, "data_extract_spec")+ "Kolmogorov-Smirnov (two-samples)", |
| 144 | +371 | ! |
- checkmate::assert_false(dist_var[[1L]]$select$multiple)+ "one-way ANOVA" |
| 145 | +372 |
-
+ ))) {
|
|
| 146 | +373 | ! |
- checkmate::assert_list(strata_var, types = "data_extract_spec", null.ok = TRUE)+ if (!shinyvalidate::input_provided(value)) {
|
| 147 | +374 | ! |
- checkmate::assert_list(group_var, types = "data_extract_spec", null.ok = TRUE)+ "Please select stratify variable." |
| 148 | -! | +||
| 375 | +
- checkmate::assert_flag(freq)+ } |
||
| 149 | -! | +||
| 376 | +
- ggtheme <- match.arg(ggtheme)+ } |
||
| 150 | +377 |
-
+ } |
|
| 151 | +378 | ! |
- plot_choices <- c("Histogram", "QQplot")
+ rule_dupl <- function(...) {
|
| 152 | +379 | ! |
- checkmate::assert_list(ggplot2_args, types = "ggplot2_args")+ if (identical(input$dist_tests, "Fligner-Killeen")) {
|
| 153 | +380 | ! |
- checkmate::assert_subset(names(ggplot2_args), c("default", plot_choices))
+ strata <- selector_list()$strata_i()$select |
| 154 | -+ | ||
| 381 | +! |
-
+ group <- selector_list()$group_i()$select |
|
| 155 | +382 | ! |
- if (length(bins) == 1) {
+ if (isTRUE(strata == group)) {
|
| 156 | +383 | ! |
- checkmate::assert_numeric(bins, any.missing = FALSE, lower = 1)+ "Please select different variables for strata and group." |
| 157 | +384 |
- } else {
- |
- |
| 158 | -! | -
- checkmate::assert_numeric(bins, len = 3, any.missing = FALSE, lower = 1)+ } |
|
| 159 | -! | +||
| 385 | +
- checkmate::assert_numeric(bins[1], lower = bins[2], upper = bins[3], .var.name = "bins")+ } |
||
| 160 | +386 |
- }+ } |
|
| 161 | +387 | ||
| 162 | +388 | ! |
- checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE)+ selector_list <- teal.transform::data_extract_multiple_srv( |
| 163 | +389 | ! |
- checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height")+ data_extract = list( |
| 164 | +390 | ! |
- checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE)+ dist_i = dist_var, |
| 165 | +391 | ! |
- checkmate::assert_numeric(+ strata_i = strata_var, |
| 166 | +392 | ! |
- plot_width[1],+ group_i = group_var+ |
+
| 393 | ++ |
+ ), |
|
| 167 | +394 | ! |
- lower = plot_width[2], upper = plot_width[3], null.ok = TRUE, .var.name = "plot_width"+ data, |
| 168 | -+ | ||
| 395 | +! |
- )+ select_validation_rule = list(+ |
+ |
| 396 | +! | +
+ dist_i = shinyvalidate::sv_required("Please select a variable")
|
|
| 169 | +397 |
-
+ ), |
|
| 170 | +398 | ! |
- checkmate::assert_multi_class(pre_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
+ filter_validation_rule = list( |
| 171 | +399 | ! |
- checkmate::assert_multi_class(post_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
+ strata_i = shinyvalidate::compose_rules( |
| 172 | -+ | ||
| 400 | +! |
- # End of assertions+ rule_req, |
|
| 173 | -+ | ||
| 401 | +! |
-
+ rule_dupl |
|
| 174 | +402 |
- # Make UI args+ ), |
|
| 175 | +403 | ! |
- args <- as.list(environment())+ group_i = rule_dupl |
| 176 | +404 |
-
+ ) |
|
| 177 | -! | +||
| 405 | +
- data_extract_list <- list(+ )+ |
+ ||
| 406 | ++ | + | |
| 178 | +407 | ! |
- dist_var = dist_var,+ iv_r <- reactive({
|
| 179 | +408 | ! |
- strata_var = strata_var,+ iv <- shinyvalidate::InputValidator$new() |
| 180 | +409 | ! |
- group_var = group_var+ teal.transform::compose_and_enable_validators(iv, selector_list, validator_names = "dist_i") |
| 181 | +410 |
- )+ }) |
|
| 182 | +411 | ||
| 183 | +412 | ! |
- ans <- module(+ iv_r_dist <- reactive({
|
| 184 | +413 | ! |
- label = label,+ iv <- shinyvalidate::InputValidator$new() |
| 185 | +414 | ! |
- server = srv_distribution,+ teal.transform::compose_and_enable_validators( |
| 186 | +415 | ! |
- server_args = c(+ iv, selector_list, |
| 187 | +416 | ! |
- data_extract_list,+ validator_names = c("strata_i", "group_i")
|
| 188 | -! | +||
| 417 | +
- list(plot_height = plot_height, plot_width = plot_width, ggplot2_args = ggplot2_args)+ ) |
||
| 189 | +418 |
- ),+ }) |
|
| 190 | +419 | ! |
- ui = ui_distribution,+ rule_dist_1 <- function(value) {
|
| 191 | +420 | ! |
- ui_args = args,+ if (!is.null(input$t_dist)) {
|
| 192 | +421 | ! |
- datanames = teal.transform::get_extract_datanames(data_extract_list)+ switch(input$t_dist, |
| 193 | -+ | ||
| 422 | +! |
- )+ "normal" = if (!shinyvalidate::input_provided(value)) "mean is required", |
|
| 194 | +423 | ! |
- attr(ans, "teal_bookmarkable") <- TRUE+ "lognormal" = if (!shinyvalidate::input_provided(value)) "meanlog is required", |
| 195 | +424 | ! |
- ans+ "gamma" = {
+ |
+
| 425 | +! | +
+ if (!shinyvalidate::input_provided(value)) "shape is required" else if (value <= 0) "shape must be positive" |
|
| 196 | +426 |
- }+ },+ |
+ |
| 427 | +! | +
+ "unif" = NULL |
|
| 197 | +428 |
-
+ ) |
|
| 198 | +429 |
- # UI function for the distribution module+ } |
|
| 199 | +430 |
- ui_distribution <- function(id, ...) {
+ } |
|
| 200 | +431 | ! |
- args <- list(...)+ rule_dist_2 <- function(value) {
|
| 201 | +432 | ! |
- ns <- NS(id)+ if (!is.null(input$t_dist)) {
|
| 202 | +433 | ! |
- is_single_dataset_value <- teal.transform::is_single_dataset(args$dist_var, args$strata_var, args$group_var)- |
-
| 203 | -- |
-
+ switch(input$t_dist, |
|
| 204 | +434 | ! |
- teal.widgets::standard_layout(+ "normal" = {
|
| 205 | +435 | ! |
- output = teal.widgets::white_small_well(+ if (!shinyvalidate::input_provided(value)) {
|
| 206 | +436 | ! |
- tabsetPanel(+ "sd is required" |
| 207 | +437 | ! |
- id = ns("tabs"),
+ } else if (value < 0) {
|
| 208 | +438 | ! |
- tabPanel("Histogram", teal.widgets::plot_with_settings_ui(id = ns("hist_plot"))),
+ "sd must be non-negative" |
| 209 | -! | +||
| 439 | +
- tabPanel("QQplot", teal.widgets::plot_with_settings_ui(id = ns("qq_plot")))
+ } |
||
| 210 | +440 |
- ),+ }, |
|
| 211 | +441 | ! |
- tags$h3("Statistics Table"),
+ "lognormal" = {
|
| 212 | +442 | ! |
- DT::dataTableOutput(ns("summary_table")),
+ if (!shinyvalidate::input_provided(value)) {
|
| 213 | +443 | ! |
- tags$h3("Tests"),
+ "sdlog is required" |
| 214 | +444 | ! |
- DT::dataTableOutput(ns("t_stats"))
- |
-
| 215 | -- |
- ),+ } else if (value < 0) {
|
|
| 216 | +445 | ! |
- encoding = tags$div(+ "sdlog must be non-negative" |
| 217 | +446 |
- ### Reporter- |
- |
| 218 | -! | -
- teal.reporter::simple_reporter_ui(ns("simple_reporter")),
+ } |
|
| 219 | +447 |
- ###+ }, |
|
| 220 | +448 | ! |
- tags$label("Encodings", class = "text-primary"),
+ "gamma" = {
|
| 221 | +449 | ! |
- teal.transform::datanames_input(args[c("dist_var", "strata_var")]),
+ if (!shinyvalidate::input_provided(value)) {
|
| 222 | +450 | ! |
- teal.transform::data_extract_ui(+ "rate is required" |
| 223 | +451 | ! |
- id = ns("dist_i"),
+ } else if (value <= 0) {
|
| 224 | +452 | ! |
- label = "Variable",+ "rate must be positive" |
| 225 | -! | +||
| 453 | +
- data_extract_spec = args$dist_var,+ }+ |
+ ||
| 454 | ++ |
+ }, |
|
| 226 | +455 | ! |
- is_single_dataset = is_single_dataset_value+ "unif" = NULL |
| 227 | +456 |
- ),+ ) |
|
| 228 | -! | +||
| 457 | +
- if (!is.null(args$group_var)) {
+ }+ |
+ ||
| 458 | ++ |
+ } |
|
| 229 | +459 | ! |
- tagList(+ rule_dist <- function(value) {
|
| 230 | +460 | ! |
- teal.transform::data_extract_ui(+ if (isTRUE(input$tabs == "QQplot" || |
| 231 | +461 | ! |
- id = ns("group_i"),
+ input$dist_tests %in% c( |
| 232 | +462 | ! |
- label = "Group by",+ "Kolmogorov-Smirnov (one-sample)", |
| 233 | +463 | ! |
- data_extract_spec = args$group_var,+ "Anderson-Darling (one-sample)", |
| 234 | +464 | ! |
- is_single_dataset = is_single_dataset_value+ "Cramer-von Mises (one-sample)" |
| 235 | +465 |
- ),+ ))) {
|
|
| 236 | +466 | ! |
- uiOutput(ns("scales_types_ui"))
+ if (!shinyvalidate::input_provided(value)) {
+ |
+
| 467 | +! | +
+ "Please select the theoretical distribution." |
|
| 237 | +468 |
- )+ } |
|
| 238 | +469 |
- },+ } |
|
| 239 | -! | +||
| 470 | +
- if (!is.null(args$strata_var)) {
+ } |
||
| 240 | +471 | ! |
- teal.transform::data_extract_ui(+ iv_dist <- shinyvalidate::InputValidator$new() |
| 241 | +472 | ! |
- id = ns("strata_i"),
+ iv_dist$add_rule("t_dist", rule_dist)
|
| 242 | +473 | ! |
- label = "Stratify by",+ iv_dist$add_rule("dist_param1", rule_dist_1)
|
| 243 | +474 | ! |
- data_extract_spec = args$strata_var,+ iv_dist$add_rule("dist_param2", rule_dist_2)
|
| 244 | +475 | ! |
- is_single_dataset = is_single_dataset_value+ iv_dist$enable() |
| 245 | +476 |
- )+ |
|
| 246 | -+ | ||
| 477 | +! |
- },+ anl_merged_input <- teal.transform::merge_expression_srv( |
|
| 247 | +478 | ! |
- teal.widgets::panel_group(+ selector_list = selector_list, |
| 248 | +479 | ! |
- conditionalPanel(+ datasets = data |
| 249 | -! | +||
| 480 | +
- condition = paste0("input['", ns("tabs"), "'] == 'Histogram'"),
+ ) |
||
| 250 | -! | +||
| 481 | +
- teal.widgets::panel_item(+ |
||
| 251 | +482 | ! |
- "Histogram",+ anl_merged_q <- reactive({
|
| 252 | +483 | ! |
- teal.widgets::optionalSliderInputValMinMax(ns("bins"), "Bins", args$bins, ticks = FALSE, step = 1),
+ req(anl_merged_input()) |
| 253 | +484 | ! |
- shinyWidgets::prettyRadioButtons(+ data() %>% |
| 254 | +485 | ! |
- ns("main_type"),
+ teal.code::eval_code(as.expression(anl_merged_input()$expr)) |
| 255 | -! | +||
| 486 | +
- label = "Plot Type:",+ }) |
||
| 256 | -! | +||
| 487 | +
- choices = c("Density", "Frequency"),
+
|
||
| 257 | +488 | ! |
- selected = if (!args$freq) "Density" else "Frequency",+ merged <- list( |
| 258 | +489 | ! |
- bigger = FALSE,+ anl_input_r = anl_merged_input, |
| 259 | +490 | ! |
- inline = TRUE+ anl_q_r = anl_merged_q |
| 260 | +491 |
- ),+ ) |
|
| 261 | -! | +||
| 492 | +
- checkboxInput(ns("add_dens"), label = "Overlay Density", value = TRUE),
+
|
||
| 262 | +493 | ! |
- collapsed = FALSE+ output$scales_types_ui <- renderUI({
|
| 263 | -+ | ||
| 494 | +! |
- )+ if ("group_i" %in% names(selector_list()) && length(selector_list()$group_i()$filters[[1]]$selected) > 0) {
|
|
| 264 | -+ | ||
| 495 | +! |
- ),+ shinyWidgets::prettyRadioButtons( |
|
| 265 | +496 | ! |
- conditionalPanel(+ ns("scales_type"),
|
| 266 | +497 | ! |
- condition = paste0("input['", ns("tabs"), "'] == 'QQplot'"),
+ label = "Scales:", |
| 267 | +498 | ! |
- teal.widgets::panel_item(+ choices = c("Fixed", "Free"),
|
| 268 | +499 | ! |
- "QQ Plot",+ selected = "Fixed", |
| 269 | +500 | ! |
- checkboxInput(ns("qq_line"), label = "Add diagonal line(s)", TRUE),
+ bigger = FALSE, |
| 270 | +501 | ! |
- collapsed = FALSE+ inline = TRUE |
| 271 | +502 |
- )+ ) |
|
| 272 | +503 |
- ),+ } |
|
| 273 | -! | +||
| 504 | +
- conditionalPanel(+ }) |
||
| 274 | -! | +||
| 505 | +
- condition = paste0("input['", ns("main_type"), "'] == 'Density'"),
+
|
||
| 275 | +506 | ! |
- teal.widgets::panel_item(+ observeEvent( |
| 276 | +507 | ! |
- "Theoretical Distribution",+ eventExpr = list( |
| 277 | +508 | ! |
- teal.widgets::optionalSelectInput(+ input$t_dist, |
| 278 | +509 | ! |
- ns("t_dist"),
+ input$params_reset, |
| 279 | +510 | ! |
- tags$div(+ selector_list()$dist_i()$select |
| 280 | -! | +||
| 511 | +
- class = "teal-tooltip",+ ), |
||
| 281 | +512 | ! |
- tagList(+ handlerExpr = {
|
| 282 | +513 | ! |
- "Distribution:",+ req(input$params_reset) |
| 283 | +514 | ! |
- icon("circle-info"),
+ params <- |
| 284 | +515 | ! |
- tags$span(+ if (length(input$t_dist) != 0) {
|
| 285 | +516 | ! |
- class = "tooltiptext",+ dist_var2 <- as.vector(merged$anl_input_r()$columns_source$dist_i)+ |
+
| 517 | ++ | + | |
| 286 | +518 | ! |
- "Default parameters are optimized with MASS::fitdistr function."+ get_dist_params <- function(x, dist) {
|
| 287 | -+ | ||
| 519 | +! |
- )+ if (dist == "unif") {
|
|
| 288 | -+ | ||
| 520 | +! |
- )+ return(stats::setNames(range(x, na.rm = TRUE), c("min", "max")))
|
|
| 289 | +521 |
- ),+ } |
|
| 290 | +522 | ! |
- choices = c("normal", "lognormal", "gamma", "unif"),
+ tryCatch( |
| 291 | +523 | ! |
- selected = NULL,+ MASS::fitdistr(x, densfun = dist)$estimate, |
| 292 | +524 | ! |
- multiple = FALSE+ error = function(e) c(param1 = NA_real_, param2 = NA_real_) |
| 293 | +525 |
- ),+ ) |
|
| 294 | -! | +||
| 526 | +
- numericInput(ns("dist_param1"), label = "param1", value = NULL),
+ } |
||
| 295 | -! | +||
| 527 | +
- numericInput(ns("dist_param2"), label = "param2", value = NULL),
+
|
||
| 296 | +528 | ! |
- tags$span(actionButton(ns("params_reset"), "Default params")),
+ ANL <- merged$anl_q_r()[[as.character(dist_var[[1]]$dataname)]] |
| 297 | +529 | ! |
- collapsed = FALSE+ round(get_dist_params(as.numeric(stats::na.omit(ANL[[dist_var2]])), input$t_dist), 2) |
| 298 | +530 |
- )+ } else {
|
|
| 299 | -+ | ||
| 531 | +! |
- )+ c("param1" = NA_real_, "param2" = NA_real_)
|
|
| 300 | +532 |
- ),- |
- |
| 301 | -! | -
- teal.widgets::panel_item(+ } |
|
| 302 | -! | +||
| 533 | +
- "Tests",+ |
||
| 303 | +534 | ! |
- teal.widgets::optionalSelectInput(+ params_vals <- unname(params) |
| 304 | +535 | ! |
- ns("dist_tests"),
+ params_names <- names(params) |
| 305 | -! | +||
| 536 | +
- "Tests:",+ |
||
| 306 | +537 | ! |
- choices = c(+ updateNumericInput( |
| 307 | +538 | ! |
- "Shapiro-Wilk",+ inputId = "dist_param1", |
| 308 | +539 | ! |
- if (!is.null(args$strata_var)) "t-test (two-samples, not paired)",+ label = params_names[1], |
| 309 | +540 | ! |
- if (!is.null(args$strata_var)) "one-way ANOVA",+ value = restoreInput(ns("dist_param1"), params_vals[1])
|
| 310 | -! | +||
| 541 | +
- if (!is.null(args$strata_var)) "Fligner-Killeen",+ ) |
||
| 311 | +542 | ! |
- if (!is.null(args$strata_var)) "F-test",+ updateNumericInput( |
| 312 | +543 | ! |
- "Kolmogorov-Smirnov (one-sample)",+ inputId = "dist_param2", |
| 313 | +544 | ! |
- "Anderson-Darling (one-sample)",+ label = params_names[2], |
| 314 | +545 | ! |
- "Cramer-von Mises (one-sample)",+ value = restoreInput(ns("dist_param1"), params_vals[2])
|
| 315 | -! | +||
| 546 | +
- if (!is.null(args$strata_var)) "Kolmogorov-Smirnov (two-samples)"+ ) |
||
| 316 | +547 |
- ),+ }, |
|
| 317 | +548 | ! |
- selected = NULL+ ignoreInit = TRUE |
| 318 | +549 |
- )+ ) |
|
| 319 | +550 |
- ),+ |
|
| 320 | +551 | ! |
- teal.widgets::panel_item(+ observeEvent(input$params_reset, {
|
| 321 | +552 | ! |
- "Statistics Table",+ updateActionButton(inputId = "params_reset", label = "Reset params") |
| 322 | -! | +||
| 553 | +
- sliderInput(ns("roundn"), "Round to n digits", min = 0, max = 10, value = 2)
+ }) |
||
| 323 | +554 |
- ),+ |
|
| 324 | +555 | ! |
- teal.widgets::panel_item(+ merge_vars <- reactive({
|
| 325 | +556 | ! |
- title = "Plot settings",+ teal::validate_inputs(iv_r()) |
| 326 | -! | +||
| 557 | +
- selectInput(+ |
||
| 327 | +558 | ! |
- inputId = ns("ggtheme"),
+ dist_var <- as.vector(merged$anl_input_r()$columns_source$dist_i) |
| 328 | +559 | ! |
- label = "Theme (by ggplot):",+ s_var <- as.vector(merged$anl_input_r()$columns_source$strata_i) |
| 329 | +560 | ! |
- choices = ggplot_themes,+ g_var <- as.vector(merged$anl_input_r()$columns_source$group_i) |
| 330 | -! | +||
| 561 | +
- selected = args$ggtheme,+ |
||
| 331 | +562 | ! |
- multiple = FALSE+ dist_var_name <- if (length(dist_var)) as.name(dist_var) else NULL |
| 332 | -+ | ||
| 563 | +! |
- )+ s_var_name <- if (length(s_var)) as.name(s_var) else NULL |
|
| 333 | -+ | ||
| 564 | +! |
- )+ g_var_name <- if (length(g_var)) as.name(g_var) else NULL |
|
| 334 | +565 |
- ),+ |
|
| 335 | +566 | ! |
- forms = tagList(+ list( |
| 336 | +567 | ! |
- teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code")
+ dist_var = dist_var, |
| 337 | -+ | ||
| 568 | +! |
- ),+ s_var = s_var, |
|
| 338 | +569 | ! |
- pre_output = args$pre_output,+ g_var = g_var, |
| 339 | +570 | ! |
- post_output = args$post_output+ dist_var_name = dist_var_name, |
| 340 | -+ | ||
| 571 | +! |
- )+ s_var_name = s_var_name, |
|
| 341 | -+ | ||
| 572 | +! |
- }+ g_var_name = g_var_name |
|
| 342 | +573 |
-
+ ) |
|
| 343 | +574 |
- # Server function for the distribution module+ }) |
|
| 344 | +575 |
- srv_distribution <- function(id,+ |
|
| 345 | +576 |
- data,+ # common qenv |
|
| 346 | -+ | ||
| 577 | +! |
- reporter,+ common_q <- reactive({
|
|
| 347 | +578 |
- filter_panel_api,+ # Create a private stack for this function only. |
|
| 348 | +579 |
- dist_var,+ |
|
| 349 | -+ | ||
| 580 | +! |
- strata_var,+ ANL <- merged$anl_q_r()[["ANL"]] |
|
| 350 | -+ | ||
| 581 | +! |
- group_var,+ dist_var <- merge_vars()$dist_var |
|
| 351 | -+ | ||
| 582 | +! |
- plot_height,+ s_var <- merge_vars()$s_var |
|
| 352 | -+ | ||
| 583 | +! |
- plot_width,+ g_var <- merge_vars()$g_var |
|
| 353 | +584 |
- ggplot2_args) {
+
|
|
| 354 | +585 | ! |
- with_reporter <- !missing(reporter) && inherits(reporter, "Reporter")+ dist_var_name <- merge_vars()$dist_var_name |
| 355 | +586 | ! |
- with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI")+ s_var_name <- merge_vars()$s_var_name |
| 356 | +587 | ! |
- checkmate::assert_class(data, "reactive")+ g_var_name <- merge_vars()$g_var_name+ |
+
| 588 | ++ | + | |
| 357 | +589 | ! |
- checkmate::assert_class(isolate(data()), "teal_data")+ roundn <- input$roundn |
| 358 | +590 | ! |
- moduleServer(id, function(input, output, session) {
+ dist_param1 <- input$dist_param1 |
| 359 | +591 | ! |
- if (shiny::isRunning()) logger::log_shiny_input_changes(input, namespace = "teal.modules.general")+ dist_param2 <- input$dist_param2 |
| 360 | +592 |
-
+ # isolated as dist_param1/dist_param2 already triggered the reactivity |
|
| 361 | +593 | ! |
- setBookmarkExclude("params_reset")
+ t_dist <- isolate(input$t_dist) |
| 362 | +594 | ||
| 363 | +595 | ! |
- ns <- session$ns+ qenv <- merged$anl_q_r() |
| 364 | +596 | ||
| 365 | +597 | ! |
- rule_req <- function(value) {
+ if (length(g_var) > 0) {
|
| 366 | +598 | ! |
- if (isTRUE(input$dist_tests %in% c(+ validate( |
| 367 | +599 | ! |
- "Fligner-Killeen",+ need( |
| 368 | +600 | ! |
- "t-test (two-samples, not paired)",+ inherits(ANL[[g_var]], c("integer", "factor", "character")),
|
| 369 | +601 | ! |
- "F-test",+ "Group by variable must be `factor`, `character`, or `integer`"+ |
+
| 602 | ++ |
+ )+ |
+ |
| 603 | ++ |
+ ) |
|
| 370 | +604 | ! |
- "Kolmogorov-Smirnov (two-samples)",+ qenv <- teal.code::eval_code( |
| 371 | +605 | ! |
- "one-way ANOVA"+ qenv, |
| 372 | -+ | ||
| 606 | +! |
- ))) {
+ substitute( |
|
| 373 | +607 | ! |
- if (!shinyvalidate::input_provided(value)) {
+ expr = ANL[[g_var]] <- forcats::fct_na_value_to_level(as.factor(ANL[[g_var]]), "NA"), |
| 374 | +608 | ! |
- "Please select stratify variable."+ env = list(g_var = g_var) |
| 375 | +609 |
- }+ ) |
|
| 376 | +610 |
- }+ ) |
|
| 377 | +611 |
- }+ } |
|
| 378 | -! | +||
| 612 | +
- rule_dupl <- function(...) {
+
|
||
| 379 | +613 | ! |
- if (identical(input$dist_tests, "Fligner-Killeen")) {
+ if (length(s_var) > 0) {
|
| 380 | +614 | ! |
- strata <- selector_list()$strata_i()$select+ validate( |
| 381 | +615 | ! |
- group <- selector_list()$group_i()$select+ need( |
| 382 | +616 | ! |
- if (isTRUE(strata == group)) {
+ inherits(ANL[[s_var]], c("integer", "factor", "character")),
|
| 383 | +617 | ! |
- "Please select different variables for strata and group."+ "Stratify by variable must be `factor`, `character`, or `integer`" |
| 384 | +618 |
- }+ ) |
|
| 385 | +619 |
- }+ ) |
|
| 386 | -+ | ||
| 620 | +! |
- }+ qenv <- teal.code::eval_code( |
|
| 387 | -+ | ||
| 621 | +! |
-
+ qenv, |
|
| 388 | +622 | ! |
- selector_list <- teal.transform::data_extract_multiple_srv(+ substitute( |
| 389 | +623 | ! |
- data_extract = list(+ expr = ANL[[s_var]] <- forcats::fct_na_value_to_level(as.factor(ANL[[s_var]]), "NA"), |
| 390 | +624 | ! |
- dist_i = dist_var,+ env = list(s_var = s_var) |
| 391 | -! | +||
| 625 | +
- strata_i = strata_var,+ ) |
||
| 392 | -! | +||
| 626 | +
- group_i = group_var+ ) |
||
| 393 | +627 |
- ),+ } |
|
| 394 | -! | +||
| 628 | +
- data,+ |
||
| 395 | +629 | ! |
- select_validation_rule = list(+ validate(need(is.numeric(ANL[[dist_var]]), "Please select a numeric variable.")) |
| 396 | +630 | ! |
- dist_i = shinyvalidate::sv_required("Please select a variable")
+ teal::validate_has_data(ANL, 1, complete = TRUE) |
| 397 | +631 |
- ),+ |
|
| 398 | +632 | ! |
- filter_validation_rule = list(+ if (length(t_dist) != 0) {
|
| 399 | +633 | ! |
- strata_i = shinyvalidate::compose_rules(+ map_distr_nams <- list( |
| 400 | +634 | ! |
- rule_req,+ normal = c("mean", "sd"),
|
| 401 | +635 | ! |
- rule_dupl+ lognormal = c("meanlog", "sdlog"),
|
| 402 | -+ | ||
| 636 | +! |
- ),+ gamma = c("shape", "rate"),
|
|
| 403 | +637 | ! |
- group_i = rule_dupl+ unif = c("min", "max")
|
| 404 | +638 |
- )+ ) |
|
| 405 | -+ | ||
| 639 | +! |
- )+ params_names_raw <- map_distr_nams[[t_dist]] |
|
| 406 | +640 | ||
| 407 | +641 | ! |
- iv_r <- reactive({
+ qenv <- teal.code::eval_code( |
| 408 | +642 | ! |
- iv <- shinyvalidate::InputValidator$new()+ qenv, |
| 409 | +643 | ! |
- teal.transform::compose_and_enable_validators(iv, selector_list, validator_names = "dist_i")+ substitute( |
| 410 | -+ | ||
| 644 | +! |
- })+ expr = {
|
|
| 411 | -+ | ||
| 645 | +! |
-
+ params <- as.list(c(dist_param1, dist_param2)) |
|
| 412 | +646 | ! |
- iv_r_dist <- reactive({
+ names(params) <- params_names_raw+ |
+
| 647 | ++ |
+ }, |
|
| 413 | +648 | ! |
- iv <- shinyvalidate::InputValidator$new()+ env = list( |
| 414 | +649 | ! |
- teal.transform::compose_and_enable_validators(+ dist_param1 = dist_param1, |
| 415 | +650 | ! |
- iv, selector_list,+ dist_param2 = dist_param2, |
| 416 | +651 | ! |
- validator_names = c("strata_i", "group_i")
+ params_names_raw = params_names_raw |
| 417 | +652 |
- )+ ) |
|
| 418 | +653 |
- })+ ) |
|
| 419 | -! | +||
| 654 | +
- rule_dist_1 <- function(value) {
+ ) |
||
| 420 | -! | +||
| 655 | +
- if (!is.null(input$t_dist)) {
+ } |
||
| 421 | -! | +||
| 656 | +
- switch(input$t_dist,+ |
||
| 422 | +657 | ! |
- "normal" = if (!shinyvalidate::input_provided(value)) "mean is required",+ if (length(s_var) == 0 && length(g_var) == 0) {
|
| 423 | +658 | ! |
- "lognormal" = if (!shinyvalidate::input_provided(value)) "meanlog is required",+ qenv <- teal.code::eval_code( |
| 424 | +659 | ! |
- "gamma" = {
+ qenv, |
| 425 | +660 | ! |
- if (!shinyvalidate::input_provided(value)) "shape is required" else if (value <= 0) "shape must be positive"+ substitute( |
| 426 | -+ | ||
| 661 | +! |
- },+ expr = {
|
|
| 427 | +662 | ! |
- "unif" = NULL+ summary_table <- ANL %>% |
| 428 | -+ | ||
| 663 | +! |
- )+ dplyr::summarise( |
|
| 429 | -+ | ||
| 664 | +! |
- }+ min = round(min(dist_var_name, na.rm = TRUE), roundn), |
|
| 430 | -+ | ||
| 665 | +! |
- }+ median = round(stats::median(dist_var_name, na.rm = TRUE), roundn), |
|
| 431 | +666 | ! |
- rule_dist_2 <- function(value) {
+ mean = round(mean(dist_var_name, na.rm = TRUE), roundn), |
| 432 | +667 | ! |
- if (!is.null(input$t_dist)) {
+ max = round(max(dist_var_name, na.rm = TRUE), roundn), |
| 433 | +668 | ! |
- switch(input$t_dist,+ sd = round(stats::sd(dist_var_name, na.rm = TRUE), roundn), |
| 434 | +669 | ! |
- "normal" = {
+ count = dplyr::n() |
| 435 | -! | +||
| 670 | +
- if (!shinyvalidate::input_provided(value)) {
+ )+ |
+ ||
| 671 | ++ |
+ }, |
|
| 436 | +672 | ! |
- "sd is required"+ env = list( |
| 437 | +673 | ! |
- } else if (value < 0) {
+ dist_var_name = as.name(dist_var), |
| 438 | +674 | ! |
- "sd must be non-negative"+ roundn = roundn |
| 439 | +675 |
- }+ ) |
|
| 440 | +676 |
- },+ ) |
|
| 441 | -! | +||
| 677 | +
- "lognormal" = {
+ )+ |
+ ||
| 678 | ++ |
+ } else {
|
|
| 442 | +679 | ! |
- if (!shinyvalidate::input_provided(value)) {
+ qenv <- teal.code::eval_code( |
| 443 | +680 | ! |
- "sdlog is required"+ qenv, |
| 444 | +681 | ! |
- } else if (value < 0) {
+ substitute( |
| 445 | +682 | ! |
- "sdlog must be non-negative"+ expr = {
|
| 446 | -+ | ||
| 683 | +! |
- }+ strata_vars <- strata_vars_raw |
|
| 447 | -+ | ||
| 684 | +! |
- },+ summary_table <- ANL %>% |
|
| 448 | +685 | ! |
- "gamma" = {
+ dplyr::group_by_at(dplyr::vars(dplyr::any_of(strata_vars))) %>% |
| 449 | +686 | ! |
- if (!shinyvalidate::input_provided(value)) {
+ dplyr::summarise( |
| 450 | +687 | ! |
- "rate is required"+ min = round(min(dist_var_name, na.rm = TRUE), roundn), |
| 451 | +688 | ! |
- } else if (value <= 0) {
+ median = round(stats::median(dist_var_name, na.rm = TRUE), roundn), |
| 452 | +689 | ! |
- "rate must be positive"+ mean = round(mean(dist_var_name, na.rm = TRUE), roundn), |
| 453 | -+ | ||
| 690 | +! |
- }+ max = round(max(dist_var_name, na.rm = TRUE), roundn), |
|
| 454 | -+ | ||
| 691 | +! |
- },+ sd = round(stats::sd(dist_var_name, na.rm = TRUE), roundn), |
|
| 455 | +692 | ! |
- "unif" = NULL+ count = dplyr::n() |
| 456 | +693 |
- )+ ) |
|
| 457 | -+ | ||
| 694 | +! |
- }+ summary_table # used to display table when running show-r-code code |
|
| 458 | +695 |
- }- |
- |
| 459 | -! | -
- rule_dist <- function(value) {
+ }, |
|
| 460 | +696 | ! |
- if (isTRUE(input$tabs == "QQplot" ||+ env = list( |
| 461 | +697 | ! |
- input$dist_tests %in% c(+ dist_var_name = dist_var_name, |
| 462 | +698 | ! |
- "Kolmogorov-Smirnov (one-sample)",+ strata_vars_raw = c(g_var, s_var), |
| 463 | +699 | ! |
- "Anderson-Darling (one-sample)",+ roundn = roundn |
| 464 | -! | +||
| 700 | +
- "Cramer-von Mises (one-sample)"+ ) |
||
| 465 | +701 |
- ))) {
+ ) |
|
| 466 | -! | +||
| 702 | +
- if (!shinyvalidate::input_provided(value)) {
+ ) |
||
| 467 | -! | +||
| 703 | +
- "Please select the theoretical distribution."+ } |
||
| 468 | +704 |
- }+ }) |
|
| 469 | +705 |
- }+ |
|
| 470 | +706 |
- }+ # distplot qenv ---- |
|
| 471 | +707 | ! |
- iv_dist <- shinyvalidate::InputValidator$new()+ dist_q <- eventReactive( |
| 472 | +708 | ! |
- iv_dist$add_rule("t_dist", rule_dist)
+ eventExpr = {
|
| 473 | +709 | ! |
- iv_dist$add_rule("dist_param1", rule_dist_1)
+ common_q() |
| 474 | +710 | ! |
- iv_dist$add_rule("dist_param2", rule_dist_2)
+ input$scales_type |
| 475 | +711 | ! |
- iv_dist$enable()- |
-
| 476 | -- |
-
+ input$main_type |
|
| 477 | +712 | ! |
- anl_merged_input <- teal.transform::merge_expression_srv(+ input$bins |
| 478 | +713 | ! |
- selector_list = selector_list,+ input$add_dens |
| 479 | +714 | ! |
- datasets = data- |
-
| 480 | -- |
- )+ is.null(input$ggtheme) |
|
| 481 | +715 |
-
+ }, |
|
| 482 | +716 | ! |
- anl_merged_q <- reactive({
+ valueExpr = {
|
| 483 | +717 | ! |
- req(anl_merged_input())+ dist_var <- merge_vars()$dist_var |
| 484 | +718 | ! |
- data() %>%+ s_var <- merge_vars()$s_var |
| 485 | +719 | ! |
- teal.code::eval_code(as.expression(anl_merged_input()$expr))+ g_var <- merge_vars()$g_var |
| 486 | -+ | ||
| 720 | +! |
- })+ dist_var_name <- merge_vars()$dist_var_name |
|
| 487 | -+ | ||
| 721 | +! |
-
+ s_var_name <- merge_vars()$s_var_name |
|
| 488 | +722 | ! |
- merged <- list(+ g_var_name <- merge_vars()$g_var_name |
| 489 | +723 | ! |
- anl_input_r = anl_merged_input,+ t_dist <- input$t_dist |
| 490 | +724 | ! |
- anl_q_r = anl_merged_q+ dist_param1 <- input$dist_param1 |
| 491 | -+ | ||
| 725 | +! |
- )+ dist_param2 <- input$dist_param2 |
|
| 492 | +726 | ||
| 493 | +727 | ! |
- output$scales_types_ui <- renderUI({
+ scales_type <- input$scales_type |
| 494 | -! | +||
| 728 | +
- if ("group_i" %in% names(selector_list()) && length(selector_list()$group_i()$filters[[1]]$selected) > 0) {
+
|
||
| 495 | +729 | ! |
- shinyWidgets::prettyRadioButtons(+ ndensity <- 512 |
| 496 | +730 | ! |
- ns("scales_type"),
+ main_type_var <- input$main_type |
| 497 | +731 | ! |
- label = "Scales:",+ bins_var <- input$bins |
| 498 | +732 | ! |
- choices = c("Fixed", "Free"),
+ add_dens_var <- input$add_dens |
| 499 | +733 | ! |
- selected = "Fixed",+ ggtheme <- input$ggtheme |
| 500 | -! | +||
| 734 | +
- bigger = FALSE,+ |
||
| 501 | +735 | ! |
- inline = TRUE+ teal::validate_inputs(iv_dist) |
| 502 | +736 |
- )+ |
|
| 503 | -+ | ||
| 737 | +! |
- }+ qenv <- common_q() |
|
| 504 | +738 |
- })+ + |
+ |
| 739 | +! | +
+ m_type <- if (main_type_var == "Density") "density" else "count" |
|
| 505 | +740 | ||
| 506 | +741 | ! |
- observeEvent(+ plot_call <- if (length(s_var) == 0 && length(g_var) == 0) {
|
| 507 | +742 | ! |
- eventExpr = list(+ substitute( |
| 508 | +743 | ! |
- input$t_dist,+ expr = ggplot(ANL, aes(dist_var_name)) + |
| 509 | +744 | ! |
- input$params_reset,+ geom_histogram( |
| 510 | +745 | ! |
- selector_list()$dist_i()$select+ position = "identity", aes(y = after_stat(m_type)), bins = bins_var, alpha = 0.3 |
| 511 | +746 |
- ),+ ), |
|
| 512 | +747 | ! |
- handlerExpr = {
+ env = list( |
| 513 | +748 | ! |
- req(input$params_reset)+ m_type = as.name(m_type), bins_var = bins_var, dist_var_name = as.name(dist_var) |
| 514 | -! | +||
| 749 | +
- params <-+ ) |
||
| 515 | -! | +||
| 750 | +
- if (length(input$t_dist) != 0) {
+ ) |
||
| 516 | +751 | ! |
- dist_var2 <- as.vector(merged$anl_input_r()$columns_source$dist_i)+ } else if (length(s_var) != 0 && length(g_var) == 0) {
|
| 517 | -+ | ||
| 752 | +! |
-
+ substitute( |
|
| 518 | +753 | ! |
- get_dist_params <- function(x, dist) {
+ expr = ggplot(ANL, aes(dist_var_name, col = s_var_name)) + |
| 519 | +754 | ! |
- if (dist == "unif") {
+ geom_histogram( |
| 520 | +755 | ! |
- return(stats::setNames(range(x, na.rm = TRUE), c("min", "max")))
+ position = "identity", aes(y = after_stat(m_type), fill = s_var), bins = bins_var, alpha = 0.3 |
| 521 | +756 |
- }+ ), |
|
| 522 | +757 | ! |
- tryCatch(+ env = list( |
| 523 | +758 | ! |
- MASS::fitdistr(x, densfun = dist)$estimate,+ m_type = as.name(m_type), |
| 524 | +759 | ! |
- error = function(e) c(param1 = NA_real_, param2 = NA_real_)- |
-
| 525 | -- |
- )- |
- |
| 526 | -- |
- }- |
- |
| 527 | -- |
-
+ bins_var = bins_var, |
|
| 528 | +760 | ! |
- ANL <- merged$anl_q_r()[[as.character(dist_var[[1]]$dataname)]]+ dist_var_name = dist_var_name, |
| 529 | +761 | ! |
- round(get_dist_params(as.numeric(stats::na.omit(ANL[[dist_var2]])), input$t_dist), 2)- |
-
| 530 | -- |
- } else {
+ s_var = as.name(s_var), |
|
| 531 | +762 | ! |
- c("param1" = NA_real_, "param2" = NA_real_)
+ s_var_name = s_var_name |
| 532 | +763 |
- }+ ) |
|
| 533 | +764 |
-
+ ) |
|
| 534 | +765 | ! |
- params_vals <- unname(params)+ } else if (length(s_var) == 0 && length(g_var) != 0) {
|
| 535 | +766 | ! |
- params_names <- names(params)- |
-
| 536 | -- |
-
+ req(scales_type) |
|
| 537 | +767 | ! |
- updateNumericInput(+ substitute( |
| 538 | +768 | ! |
- inputId = "dist_param1",+ expr = ggplot(ANL[ANL[[g_var]] != "NA", ], aes(dist_var_name)) + |
| 539 | +769 | ! |
- label = params_names[1],+ geom_histogram( |
| 540 | +770 | ! |
- value = restoreInput(ns("dist_param1"), params_vals[1])
+ position = "identity", aes(y = after_stat(m_type)), bins = bins_var, alpha = 0.3 |
| 541 | +771 |
- )+ ) + |
|
| 542 | +772 | ! |
- updateNumericInput(+ facet_wrap(~g_var_name, ncol = 1, scales = scales_raw), |
| 543 | +773 | ! |
- inputId = "dist_param2",+ env = list( |
| 544 | +774 | ! |
- label = params_names[2],+ m_type = as.name(m_type), |
| 545 | +775 | ! |
- value = restoreInput(ns("dist_param1"), params_vals[2])
- |
-
| 546 | -- |
- )- |
- |
| 547 | -- |
- },+ bins_var = bins_var, |
|
| 548 | +776 | ! |
- ignoreInit = TRUE+ dist_var_name = dist_var_name, |
| 549 | -+ | ||
| 777 | +! |
- )+ g_var = g_var, |
|
| 550 | -+ | ||
| 778 | +! |
-
+ g_var_name = g_var_name, |
|
| 551 | +779 | ! |
- observeEvent(input$params_reset, {
+ scales_raw = tolower(scales_type) |
| 552 | -! | +||
| 780 | +
- updateActionButton(inputId = "params_reset", label = "Reset params")+ ) |
||
| 553 | +781 |
- })+ ) |
|
| 554 | +782 |
-
+ } else {
|
|
| 555 | +783 | ! |
- merge_vars <- reactive({
+ req(scales_type) |
| 556 | +784 | ! |
- teal::validate_inputs(iv_r())+ substitute( |
| 557 | -+ | ||
| 785 | +! |
-
+ expr = ggplot(ANL[ANL[[g_var]] != "NA", ], aes(dist_var_name, col = s_var_name)) + |
|
| 558 | +786 | ! |
- dist_var <- as.vector(merged$anl_input_r()$columns_source$dist_i)+ geom_histogram( |
| 559 | +787 | ! |
- s_var <- as.vector(merged$anl_input_r()$columns_source$strata_i)+ position = "identity", |
| 560 | +788 | ! |
- g_var <- as.vector(merged$anl_input_r()$columns_source$group_i)+ aes(y = after_stat(m_type), fill = s_var), bins = bins_var, alpha = 0.3 |
| 561 | +789 |
-
+ ) + |
|
| 562 | +790 | ! |
- dist_var_name <- if (length(dist_var)) as.name(dist_var) else NULL+ facet_wrap(~g_var_name, ncol = 1, scales = scales_raw), |
| 563 | +791 | ! |
- s_var_name <- if (length(s_var)) as.name(s_var) else NULL+ env = list( |
| 564 | +792 | ! |
- g_var_name <- if (length(g_var)) as.name(g_var) else NULL- |
-
| 565 | -- |
-
+ m_type = as.name(m_type), |
|
| 566 | +793 | ! |
- list(+ bins_var = bins_var, |
| 567 | +794 | ! |
- dist_var = dist_var,+ dist_var_name = dist_var_name, |
| 568 | +795 | ! |
- s_var = s_var,+ g_var = g_var, |
| 569 | +796 | ! |
- g_var = g_var,+ s_var = as.name(s_var), |
| 570 | +797 | ! |
- dist_var_name = dist_var_name,+ g_var_name = g_var_name, |
| 571 | +798 | ! |
- s_var_name = s_var_name,+ s_var_name = s_var_name, |
| 572 | +799 | ! |
- g_var_name = g_var_name+ scales_raw = tolower(scales_type) |
| 573 | +800 |
- )+ ) |
|
| 574 | +801 |
- })+ ) |
|
| 575 | +802 |
-
+ } |
|
| 576 | +803 |
- # common qenv+ |
|
| 577 | +804 | ! |
- common_q <- reactive({
- |
-
| 578 | -- |
- # Create a private stack for this function only.+ if (add_dens_var) {
|
|
| 579 | -+ | ||
| 805 | +! |
-
+ plot_call <- substitute( |
|
| 580 | +806 | ! |
- ANL <- merged$anl_q_r()[["ANL"]]+ expr = plot_call + |
| 581 | +807 | ! |
- dist_var <- merge_vars()$dist_var+ stat_density( |
| 582 | +808 | ! |
- s_var <- merge_vars()$s_var+ aes(y = after_stat(const * m_type2)), |
| 583 | +809 | ! |
- g_var <- merge_vars()$g_var+ geom = "line", |
| 584 | -+ | ||
| 810 | +! |
-
+ position = "identity", |
|
| 585 | +811 | ! |
- dist_var_name <- merge_vars()$dist_var_name+ alpha = 0.5, |
| 586 | +812 | ! |
- s_var_name <- merge_vars()$s_var_name+ size = 2, |
| 587 | +813 | ! |
- g_var_name <- merge_vars()$g_var_name+ n = ndensity |
| 588 | +814 |
-
+ ), |
|
| 589 | +815 | ! |
- roundn <- input$roundn+ env = list( |
| 590 | +816 | ! |
- dist_param1 <- input$dist_param1+ plot_call = plot_call, |
| 591 | +817 | ! |
- dist_param2 <- input$dist_param2- |
-
| 592 | -- |
- # isolated as dist_param1/dist_param2 already triggered the reactivity+ const = if (main_type_var == "Density") {
|
|
| 593 | +818 | ! |
- t_dist <- isolate(input$t_dist)+ 1 |
| 594 | +819 |
-
+ } else {
|
|
| 595 | +820 | ! |
- qenv <- merged$anl_q_r()+ diff(range(qenv[["ANL"]][[dist_var]], na.rm = TRUE)) / bins_var |
| 596 | +821 |
-
+ }, |
|
| 597 | +822 | ! |
- if (length(g_var) > 0) {
+ m_type2 = if (main_type_var == "Density") as.name("density") else as.name("count"),
|
| 598 | +823 | ! |
- validate(+ ndensity = ndensity |
| 599 | -! | +||
| 824 | +
- need(+ ) |
||
| 600 | -! | +||
| 825 | +
- inherits(ANL[[g_var]], c("integer", "factor", "character")),
+ ) |
||
| 601 | -! | +||
| 826 | +
- "Group by variable must be `factor`, `character`, or `integer`"+ } |
||
| 602 | +827 |
- )+ |
|
| 603 | -+ | ||
| 828 | +! |
- )+ if (length(t_dist) != 0 && main_type_var == "Density" && length(g_var) == 0 && length(s_var) == 0) {
|
|
| 604 | +829 | ! |
- qenv <- teal.code::eval_code(+ qenv <- teal.code::eval_code( |
| 605 | +830 | ! |
- qenv,+ qenv, |
| 606 | +831 | ! |
- substitute(+ substitute( |
| 607 | +832 | ! |
- expr = ANL[[g_var]] <- forcats::fct_na_value_to_level(as.factor(ANL[[g_var]]), "NA"),+ df_params <- as.data.frame(append(params, list(name = t_dist))), |
| 608 | +833 | ! |
- env = list(g_var = g_var)+ env = list(t_dist = t_dist) |
| 609 | +834 |
- )+ ) |
|
| 610 | +835 |
- )+ ) |
|
| 611 | -+ | ||
| 836 | +! |
- }+ datas <- quote(data.frame(x = 0.7, y = 1, tb = I(list(df_params = df_params))))+ |
+ |
| 837 | +! | +
+ label <- quote(tb) |
|
| 612 | +838 | ||
| 613 | +839 | ! |
- if (length(s_var) > 0) {
+ plot_call <- substitute( |
| 614 | +840 | ! |
- validate(+ expr = plot_call + ggpp::geom_table_npc( |
| 615 | +841 | ! |
- need(+ data = data, |
| 616 | +842 | ! |
- inherits(ANL[[s_var]], c("integer", "factor", "character")),
+ aes(npcx = x, npcy = y, label = label), |
| 617 | +843 | ! |
- "Stratify by variable must be `factor`, `character`, or `integer`"+ hjust = 0, vjust = 1, size = 4 |
| 618 | +844 | ++ |
+ ),+ |
+
| 845 | +! | +
+ env = list(plot_call = plot_call, data = datas, label = label)+ |
+ |
| 846 |
) |
||
| 619 | +847 |
- )+ } |
|
| 620 | -! | +||
| 848 | +
- qenv <- teal.code::eval_code(+ |
||
| 621 | +849 | ! |
- qenv,+ if ( |
| 622 | +850 | ! |
- substitute(+ length(s_var) == 0 && |
| 623 | +851 | ! |
- expr = ANL[[s_var]] <- forcats::fct_na_value_to_level(as.factor(ANL[[s_var]]), "NA"),+ length(g_var) == 0 && |
| 624 | +852 | ! |
- env = list(s_var = s_var)+ main_type_var == "Density" && |
| 625 | -+ | ||
| 853 | +! |
- )+ length(t_dist) != 0 && |
|
| 626 | -+ | ||
| 854 | +! |
- )+ main_type_var == "Density" |
|
| 627 | +855 |
- }+ ) {
|
|
| 628 | -+ | ||
| 856 | +! |
-
+ map_dist <- stats::setNames( |
|
| 629 | +857 | ! |
- validate(need(is.numeric(ANL[[dist_var]]), "Please select a numeric variable."))+ c("dnorm", "dlnorm", "dgamma", "dunif"),
|
| 630 | +858 | ! |
- teal::validate_has_data(ANL, 1, complete = TRUE)+ c("normal", "lognormal", "gamma", "unif")
|
| 631 | +859 |
-
+ ) |
|
| 632 | +860 | ! |
- if (length(t_dist) != 0) {
+ plot_call <- substitute( |
| 633 | +861 | ! |
- map_distr_nams <- list(+ expr = plot_call + stat_function( |
| 634 | +862 | ! |
- normal = c("mean", "sd"),
+ data = data.frame(x = range(ANL[[dist_var]]), color = mapped_dist), |
| 635 | +863 | ! |
- lognormal = c("meanlog", "sdlog"),
+ aes(x, color = color), |
| 636 | +864 | ! |
- gamma = c("shape", "rate"),
+ fun = mapped_dist_name, |
| 637 | +865 | ! |
- unif = c("min", "max")
+ n = ndensity, |
| 638 | -+ | ||
| 866 | +! |
- )+ size = 2, |
|
| 639 | +867 | ! |
- params_names_raw <- map_distr_nams[[t_dist]]+ args = params |
| 640 | +868 |
-
+ ) ++ |
+ |
| 869 | +! | +
+ scale_color_manual(values = stats::setNames("blue", mapped_dist), aesthetics = "color"),
|
|
| 641 | +870 | ! |
- qenv <- teal.code::eval_code(+ env = list( |
| 642 | +871 | ! |
- qenv,+ plot_call = plot_call, |
| 643 | +872 | ! |
- substitute(+ dist_var = dist_var, |
| 644 | +873 | ! |
- expr = {
+ ndensity = ndensity, |
| 645 | +874 | ! |
- params <- as.list(c(dist_param1, dist_param2))+ mapped_dist = unname(map_dist[t_dist]), |
| 646 | +875 | ! |
- names(params) <- params_names_raw+ mapped_dist_name = as.name(unname(map_dist[t_dist])) |
| 647 | +876 |
- },+ ) |
|
| 648 | -! | +||
| 877 | +
- env = list(+ )+ |
+ ||
| 878 | ++ |
+ }+ |
+ |
| 879 | ++ | + | |
| 649 | +880 | ! |
- dist_param1 = dist_param1,+ all_ggplot2_args <- teal.widgets::resolve_ggplot2_args( |
| 650 | +881 | ! |
- dist_param2 = dist_param2,+ user_plot = ggplot2_args[["Histogram"]], |
| 651 | +882 | ! |
- params_names_raw = params_names_raw+ user_default = ggplot2_args$default |
| 652 | +883 |
- )+ ) |
|
| 653 | +884 |
- )+ |
|
| 654 | -+ | ||
| 885 | +! |
- )+ parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args( |
|
| 655 | -+ | ||
| 886 | +! |
- }+ all_ggplot2_args,+ |
+ |
| 887 | +! | +
+ ggtheme = ggtheme |
|
| 656 | +888 |
-
+ ) |
|
| 657 | -! | +||
| 889 | +
- if (length(s_var) == 0 && length(g_var) == 0) {
+
|
||
| 658 | +890 | ! |
- qenv <- teal.code::eval_code(+ teal.code::eval_code( |
| 659 | +891 | ! |
qenv, |
| 660 | +892 | ! |
substitute( |
| 661 | +893 | ! |
expr = {
|
| 662 | +894 | ! |
- summary_table <- ANL %>%+ g <- plot_call |
| 663 | +895 | ! |
- dplyr::summarise(+ print(g) |
| 664 | -! | +||
| 896 | +
- min = round(min(dist_var_name, na.rm = TRUE), roundn),+ }, |
||
| 665 | +897 | ! |
- median = round(stats::median(dist_var_name, na.rm = TRUE), roundn),+ env = list(plot_call = Reduce(function(x, y) call("+", x, y), c(plot_call, parsed_ggplot2_args)))
|
| 666 | -! | +||
| 898 | +
- mean = round(mean(dist_var_name, na.rm = TRUE), roundn),+ ) |
||
| 667 | -! | +||
| 899 | +
- max = round(max(dist_var_name, na.rm = TRUE), roundn),+ ) |
||
| 668 | -! | +||
| 900 | +
- sd = round(stats::sd(dist_var_name, na.rm = TRUE), roundn),+ } |
||
| 669 | -! | +||
| 901 | +
- count = dplyr::n()+ ) |
||
| 670 | +902 |
- )+ |
|
| 671 | +903 |
- },+ # qqplot qenv ---- |
|
| 672 | +904 | ! |
- env = list(+ qq_q <- eventReactive( |
| 673 | +905 | ! |
- dist_var_name = as.name(dist_var),+ eventExpr = {
|
| 674 | +906 | ! |
- roundn = roundn+ common_q() |
| 675 | -+ | ||
| 907 | +! |
- )+ input$scales_type |
|
| 676 | -+ | ||
| 908 | +! |
- )+ input$qq_line |
|
| 677 | -+ | ||
| 909 | +! |
- )+ is.null(input$ggtheme) |
|
| 678 | +910 |
- } else {
+ }, |
|
| 679 | +911 | ! |
- qenv <- teal.code::eval_code(+ valueExpr = {
|
| 680 | +912 | ! |
- qenv,+ dist_var <- merge_vars()$dist_var |
| 681 | +913 | ! |
- substitute(+ s_var <- merge_vars()$s_var |
| 682 | +914 | ! |
- expr = {
+ g_var <- merge_vars()$g_var |
| 683 | +915 | ! |
- strata_vars <- strata_vars_raw+ dist_var_name <- merge_vars()$dist_var_name |
| 684 | +916 | ! |
- summary_table <- ANL %>%+ s_var_name <- merge_vars()$s_var_name |
| 685 | +917 | ! |
- dplyr::group_by_at(dplyr::vars(dplyr::any_of(strata_vars))) %>%+ g_var_name <- merge_vars()$g_var_name |
| 686 | +918 | ! |
- dplyr::summarise(+ t_dist <- input$t_dist |
| 687 | +919 | ! |
- min = round(min(dist_var_name, na.rm = TRUE), roundn),+ dist_param1 <- input$dist_param1 |
| 688 | +920 | ! |
- median = round(stats::median(dist_var_name, na.rm = TRUE), roundn),+ dist_param2 <- input$dist_param2 |
| 689 | -! | +||
| 921 | +
- mean = round(mean(dist_var_name, na.rm = TRUE), roundn),+ |
||
| 690 | +922 | ! |
- max = round(max(dist_var_name, na.rm = TRUE), roundn),+ scales_type <- input$scales_type |
| 691 | +923 | ! |
- sd = round(stats::sd(dist_var_name, na.rm = TRUE), roundn),+ ggtheme <- input$ggtheme+ |
+
| 924 | ++ | + | |
| 692 | +925 | ! |
- count = dplyr::n()+ teal::validate_inputs(iv_r_dist(), iv_dist) |
| 693 | +926 |
- )+ |
|
| 694 | +927 | ! |
- summary_table # used to display table when running show-r-code code+ qenv <- common_q() |
| 695 | +928 |
- },+ |
|
| 696 | +929 | ! |
- env = list(+ plot_call <- if (length(s_var) == 0 && length(g_var) == 0) {
|
| 697 | +930 | ! |
- dist_var_name = dist_var_name,+ substitute( |
| 698 | +931 | ! |
- strata_vars_raw = c(g_var, s_var),+ expr = ggplot(ANL, aes_string(sample = dist_var)), |
| 699 | +932 | ! |
- roundn = roundn+ env = list(dist_var = dist_var) |
| 700 | +933 |
- )+ ) |
|
| 701 | -+ | ||
| 934 | +! |
- )+ } else if (length(s_var) != 0 && length(g_var) == 0) {
|
|
| 702 | -+ | ||
| 935 | +! |
- )+ substitute( |
|
| 703 | -+ | ||
| 936 | +! |
- }+ expr = ggplot(ANL, aes_string(sample = dist_var, color = s_var)), |
|
| 704 | -+ | ||
| 937 | +! |
- })+ env = list(dist_var = dist_var, s_var = s_var) |
|
| 705 | +938 |
-
+ ) |
|
| 706 | -+ | ||
| 939 | +! |
- # distplot qenv ----+ } else if (length(s_var) == 0 && length(g_var) != 0) {
|
|
| 707 | +940 | ! |
- dist_q <- eventReactive(+ substitute( |
| 708 | +941 | ! |
- eventExpr = {
+ expr = ggplot(ANL[ANL[[g_var]] != "NA", ], aes_string(sample = dist_var)) + |
| 709 | +942 | ! |
- common_q()+ facet_wrap(~g_var_name, ncol = 1, scales = scales_raw), |
| 710 | +943 | ! |
- input$scales_type+ env = list( |
| 711 | +944 | ! |
- input$main_type+ dist_var = dist_var, |
| 712 | +945 | ! |
- input$bins+ g_var = g_var, |
| 713 | +946 | ! |
- input$add_dens+ g_var_name = g_var_name, |
| 714 | +947 | ! |
- is.null(input$ggtheme)+ scales_raw = tolower(scales_type) |
| 715 | +948 |
- },+ ) |
|
| 716 | -! | +||
| 949 | +
- valueExpr = {
+ )+ |
+ ||
| 950 | ++ |
+ } else {
|
|
| 717 | +951 | ! |
- dist_var <- merge_vars()$dist_var+ substitute( |
| 718 | +952 | ! |
- s_var <- merge_vars()$s_var+ expr = ggplot(ANL[ANL[[g_var]] != "NA", ], aes_string(sample = dist_var, color = s_var)) + |
| 719 | +953 | ! |
- g_var <- merge_vars()$g_var+ facet_wrap(~g_var_name, ncol = 1, scales = scales_raw), |
| 720 | +954 | ! |
- dist_var_name <- merge_vars()$dist_var_name+ env = list( |
| 721 | +955 | ! |
- s_var_name <- merge_vars()$s_var_name+ dist_var = dist_var, |
| 722 | +956 | ! |
- g_var_name <- merge_vars()$g_var_name+ g_var = g_var, |
| 723 | +957 | ! |
- t_dist <- input$t_dist+ s_var = s_var, |
| 724 | +958 | ! |
- dist_param1 <- input$dist_param1+ g_var_name = g_var_name, |
| 725 | +959 | ! |
- dist_param2 <- input$dist_param2+ scales_raw = tolower(scales_type) |
| 726 | +960 |
-
+ ) |
|
| 727 | -! | +||
| 961 | +
- scales_type <- input$scales_type+ ) |
||
| 728 | +962 |
-
+ } |
|
| 729 | -! | +||
| 963 | +
- ndensity <- 512+ |
||
| 730 | +964 | ! |
- main_type_var <- input$main_type+ map_dist <- stats::setNames( |
| 731 | +965 | ! |
- bins_var <- input$bins+ c("qnorm", "qlnorm", "qgamma", "qunif"),
|
| 732 | +966 | ! |
- add_dens_var <- input$add_dens+ c("normal", "lognormal", "gamma", "unif")
|
| 733 | -! | +||
| 967 | +
- ggtheme <- input$ggtheme+ ) |
||
| 734 | +968 | ||
| 735 | +969 | ! |
- teal::validate_inputs(iv_dist)- |
-
| 736 | -- |
-
+ plot_call <- substitute( |
|
| 737 | +970 | ! |
- qenv <- common_q()- |
-
| 738 | -+ | ||
| 971 | +! |
-
+ stat_qq(distribution = mapped_dist, dparams = params), |
|
| 739 | +972 | ! |
- m_type <- if (main_type_var == "Density") "density" else "count"+ env = list(plot_call = plot_call, mapped_dist = as.name(unname(map_dist[t_dist]))) |
| 740 | +973 |
-
+ ) |
|
| 741 | -! | +||
| 974 | +
- plot_call <- if (length(s_var) == 0 && length(g_var) == 0) {
+
|
||
| 742 | +975 | ! |
- substitute(+ if (length(t_dist) != 0 && length(g_var) == 0 && length(s_var) == 0) {
|
| 743 | +976 | ! |
- expr = ggplot(ANL, aes(dist_var_name)) ++ qenv <- teal.code::eval_code( |
| 744 | +977 | ! |
- geom_histogram(+ qenv, |
| 745 | +978 | ! |
- position = "identity", aes(y = after_stat(m_type)), bins = bins_var, alpha = 0.3- |
-
| 746 | -- |
- ),+ substitute( |
|
| 747 | +979 | ! |
- env = list(+ df_params <- as.data.frame(append(params, list(name = t_dist))), |
| 748 | +980 | ! |
- m_type = as.name(m_type), bins_var = bins_var, dist_var_name = as.name(dist_var)+ env = list(t_dist = t_dist) |
| 749 | +981 |
) |
|
| 750 | +982 |
) |
|
| 751 | +983 | ! |
- } else if (length(s_var) != 0 && length(g_var) == 0) {
+ datas <- quote(data.frame(x = 0.7, y = 1, tb = I(list(df_params = df_params)))) |
| 752 | +984 | ! |
- substitute(+ label <- quote(tb) |
| 753 | -! | +||
| 985 | +
- expr = ggplot(ANL, aes(dist_var_name, col = s_var_name)) ++ |
||
| 754 | +986 | ! |
- geom_histogram(+ plot_call <- substitute( |
| 755 | +987 | ! |
- position = "identity", aes(y = after_stat(m_type), fill = s_var), bins = bins_var, alpha = 0.3- |
-
| 756 | -- |
- ),+ expr = plot_call + |
|
| 757 | +988 | ! |
- env = list(+ ggpp::geom_table_npc( |
| 758 | +989 | ! |
- m_type = as.name(m_type),+ data = data, |
| 759 | +990 | ! |
- bins_var = bins_var,+ aes(npcx = x, npcy = y, label = label), |
| 760 | +991 | ! |
- dist_var_name = dist_var_name,+ hjust = 0, |
| 761 | +992 | ! |
- s_var = as.name(s_var),+ vjust = 1, |
| 762 | +993 | ! |
- s_var_name = s_var_name- |
-
| 763 | -- |
- )+ size = 4 |
|
| 764 | +994 |
- )- |
- |
| 765 | -! | -
- } else if (length(s_var) == 0 && length(g_var) != 0) {
+ ), |
|
| 766 | +995 | ! |
- req(scales_type)+ env = list( |
| 767 | +996 | ! |
- substitute(+ plot_call = plot_call, |
| 768 | +997 | ! |
- expr = ggplot(ANL[ANL[[g_var]] != "NA", ], aes(dist_var_name)) ++ data = datas, |
| 769 | +998 | ! |
- geom_histogram(+ label = label |
| 770 | -! | +||
| 999 | +
- position = "identity", aes(y = after_stat(m_type)), bins = bins_var, alpha = 0.3+ ) |
||
| 771 | +1000 |
- ) ++ ) |
|
| 772 | -! | +||
| 1001 | +
- facet_wrap(~g_var_name, ncol = 1, scales = scales_raw),+ } |
||
| 773 | -! | +||
| 1002 | +
- env = list(+ |
||
| 774 | +1003 | ! |
- m_type = as.name(m_type),+ if (isTRUE(input$qq_line)) {
|
| 775 | +1004 | ! |
- bins_var = bins_var,+ plot_call <- substitute( |
| 776 | +1005 | ! |
- dist_var_name = dist_var_name,+ expr = plot_call + |
| 777 | +1006 | ! |
- g_var = g_var,+ stat_qq_line(distribution = mapped_dist, dparams = params), |
| 778 | +1007 | ! |
- g_var_name = g_var_name,+ env = list(plot_call = plot_call, mapped_dist = as.name(unname(map_dist[t_dist]))) |
| 779 | -! | +||
| 1008 | +
- scales_raw = tolower(scales_type)+ ) |
||
| 780 | +1009 |
- )+ } |
|
| 781 | +1010 |
- )+ |
|
| 782 | -+ | ||
| 1011 | +! |
- } else {
+ all_ggplot2_args <- teal.widgets::resolve_ggplot2_args( |
|
| 783 | +1012 | ! |
- req(scales_type)+ user_plot = ggplot2_args[["QQplot"]], |
| 784 | +1013 | ! |
- substitute(+ user_default = ggplot2_args$default, |
| 785 | +1014 | ! |
- expr = ggplot(ANL[ANL[[g_var]] != "NA", ], aes(dist_var_name, col = s_var_name)) ++ module_plot = teal.widgets::ggplot2_args(labs = list(x = "theoretical", y = "sample"))+ |
+
| 1015 | ++ |
+ )+ |
+ |
| 1016 | ++ | + | |
| 786 | +1017 | ! |
- geom_histogram(+ parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args( |
| 787 | +1018 | ! |
- position = "identity",+ all_ggplot2_args, |
| 788 | +1019 | ! |
- aes(y = after_stat(m_type), fill = s_var), bins = bins_var, alpha = 0.3+ ggtheme = ggtheme |
| 789 | +1020 |
- ) ++ ) |
|
| 790 | -! | +||
| 1021 | +
- facet_wrap(~g_var_name, ncol = 1, scales = scales_raw),+ |
||
| 791 | +1022 | ! |
- env = list(+ teal.code::eval_code( |
| 792 | +1023 | ! |
- m_type = as.name(m_type),+ qenv, |
| 793 | +1024 | ! |
- bins_var = bins_var,+ substitute( |
| 794 | +1025 | ! |
- dist_var_name = dist_var_name,+ expr = {
|
| 795 | +1026 | ! |
- g_var = g_var,+ g <- plot_call |
| 796 | +1027 | ! |
- s_var = as.name(s_var),+ print(g) |
| 797 | -! | +||
| 1028 | +
- g_var_name = g_var_name,+ }, |
||
| 798 | +1029 | ! |
- s_var_name = s_var_name,+ env = list(plot_call = Reduce(function(x, y) call("+", x, y), c(plot_call, parsed_ggplot2_args)))
|
| 799 | -! | +||
| 1030 | +
- scales_raw = tolower(scales_type)+ ) |
||
| 800 | +1031 |
- )+ ) |
|
| 801 | +1032 |
- )+ } |
|
| 802 | +1033 |
- }+ ) |
|
| 803 | +1034 | ||
| 804 | -! | +||
| 1035 | +
- if (add_dens_var) {
+ # test qenv ---- |
||
| 805 | +1036 | ! |
- plot_call <- substitute(+ test_q <- eventReactive( |
| 806 | +1037 | ! |
- expr = plot_call ++ ignoreNULL = FALSE, |
| 807 | +1038 | ! |
- stat_density(+ eventExpr = {
|
| 808 | +1039 | ! |
- aes(y = after_stat(const * m_type2)),+ common_q() |
| 809 | +1040 | ! |
- geom = "line",+ input$dist_param1 |
| 810 | +1041 | ! |
- position = "identity",+ input$dist_param2 |
| 811 | +1042 | ! |
- alpha = 0.5,+ input$dist_tests |
| 812 | -! | +||
| 1043 | +
- size = 2,+ }, |
||
| 813 | +1044 | ! |
- n = ndensity+ valueExpr = {
|
| 814 | +1045 |
- ),+ # Create a private stack for this function only. |
|
| 815 | +1046 | ! |
- env = list(+ ANL <- common_q()[["ANL"]]+ |
+
| 1047 | ++ | + | |
| 816 | +1048 | ! |
- plot_call = plot_call,+ dist_var <- merge_vars()$dist_var |
| 817 | +1049 | ! |
- const = if (main_type_var == "Density") {
+ s_var <- merge_vars()$s_var |
| 818 | +1050 | ! |
- 1+ g_var <- merge_vars()$g_var |
| 819 | +1051 |
- } else {
+
|
|
| 820 | +1052 | ! |
- diff(range(qenv[["ANL"]][[dist_var]], na.rm = TRUE)) / bins_var+ dist_var_name <- merge_vars()$dist_var_name+ |
+
| 1053 | +! | +
+ s_var_name <- merge_vars()$s_var_name+ |
+ |
| 1054 | +! | +
+ g_var_name <- merge_vars()$g_var_name |
|
| 821 | +1055 |
- },+ |
|
| 822 | +1056 | ! |
- m_type2 = if (main_type_var == "Density") as.name("density") else as.name("count"),
+ dist_param1 <- input$dist_param1 |
| 823 | +1057 | ! |
- ndensity = ndensity+ dist_param2 <- input$dist_param2 |
| 824 | -+ | ||
| 1058 | +! |
- )+ dist_tests <- input$dist_tests |
|
| 825 | -+ | ||
| 1059 | +! |
- )+ t_dist <- input$t_dist |
|
| 826 | +1060 |
- }+ + |
+ |
| 1061 | +! | +
+ validate(need(dist_tests, "Please select a test")) |
|
| 827 | +1062 | ||
| 828 | +1063 | ! |
- if (length(t_dist) != 0 && main_type_var == "Density" && length(g_var) == 0 && length(s_var) == 0) {
+ teal::validate_inputs(iv_dist) |
| 829 | -! | +||
| 1064 | +
- qenv <- teal.code::eval_code(+ |
||
| 830 | +1065 | ! |
- qenv,+ if (length(s_var) > 0 || length(g_var) > 0) {
|
| 831 | +1066 | ! |
- substitute(+ counts <- ANL %>% |
| 832 | +1067 | ! |
- df_params <- as.data.frame(append(params, list(name = t_dist))),+ dplyr::group_by_at(dplyr::vars(dplyr::any_of(c(s_var, g_var)))) %>% |
| 833 | +1068 | ! |
- env = list(t_dist = t_dist)+ dplyr::summarise(n = dplyr::n()) |
| 834 | +1069 |
- )+ |
|
| 835 | -+ | ||
| 1070 | +! |
- )+ validate(need(all(counts$n > 5), "Please select strata*group with at least 5 observation each.")) |
|
| 836 | -! | +||
| 1071 | +
- datas <- quote(data.frame(x = 0.7, y = 1, tb = I(list(df_params = df_params))))+ } |
||
| 837 | -! | +||
| 1072 | +
- label <- quote(tb)+ |
||
| 838 | +1073 | ||
| 839 | +1074 | ! |
- plot_call <- substitute(+ if (dist_tests %in% c( |
| 840 | +1075 | ! |
- expr = plot_call + ggpp::geom_table_npc(+ "t-test (two-samples, not paired)", |
| 841 | +1076 | ! |
- data = data,+ "F-test", |
| 842 | +1077 | ! |
- aes(npcx = x, npcy = y, label = label),+ "Kolmogorov-Smirnov (two-samples)"+ |
+
| 1078 | ++ |
+ )) {
|
|
| 843 | +1079 | ! |
- hjust = 0, vjust = 1, size = 4+ if (length(g_var) == 0 && length(s_var) > 0) {
|
| 844 | -+ | ||
| 1080 | +! |
- ),+ validate(need( |
|
| 845 | +1081 | ! |
- env = list(plot_call = plot_call, data = datas, label = label)+ length(unique(ANL[[s_var]])) == 2, |
| 846 | -+ | ||
| 1082 | +! |
- )+ "Please select stratify variable with 2 levels." |
|
| 847 | +1083 |
- }+ )) |
|
| 848 | +1084 |
-
+ } |
|
| 849 | +1085 | ! |
- if (+ if (length(g_var) > 0 && length(s_var) > 0) {
|
| 850 | +1086 | ! |
- length(s_var) == 0 &&+ validate(need( |
| 851 | +1087 | ! |
- length(g_var) == 0 &&+ all(stats::na.omit(as.vector( |
| 852 | +1088 | ! |
- main_type_var == "Density" &&+ tapply(ANL[[s_var]], list(ANL[[g_var]]), function(x) length(unique(x))) == 2 |
| 853 | -! | +||
| 1089 | +
- length(t_dist) != 0 &&+ ))), |
||
| 854 | +1090 | ! |
- main_type_var == "Density"+ "Please select stratify variable with 2 levels, per each group." |
| 855 | +1091 |
- ) {
- |
- |
| 856 | -! | -
- map_dist <- stats::setNames(+ )) |
|
| 857 | -! | +||
| 1092 | +
- c("dnorm", "dlnorm", "dgamma", "dunif"),
+ } |
||
| 858 | -! | +||
| 1093 | +
- c("normal", "lognormal", "gamma", "unif")
+ } |
||
| 859 | +1094 |
- )+ |
|
| 860 | +1095 | ! |
- plot_call <- substitute(+ map_dist <- stats::setNames( |
| 861 | +1096 | ! |
- expr = plot_call + stat_function(+ c("pnorm", "plnorm", "pgamma", "punif"),
|
| 862 | +1097 | ! |
- data = data.frame(x = range(ANL[[dist_var]]), color = mapped_dist),+ c("normal", "lognormal", "gamma", "unif")
|
| 863 | -! | +||
| 1098 | +
- aes(x, color = color),+ ) |
||
| 864 | +1099 | ! |
- fun = mapped_dist_name,+ sks_args <- list( |
| 865 | +1100 | ! |
- n = ndensity,+ test = quote(stats::ks.test), |
| 866 | +1101 | ! |
- size = 2,+ args = bquote(append(list(.[[.(dist_var)]], .(map_dist[t_dist])), params)), |
| 867 | +1102 | ! |
- args = params+ groups = c(g_var, s_var) |
| 868 | +1103 |
- ) ++ ) |
|
| 869 | +1104 | ! |
- scale_color_manual(values = stats::setNames("blue", mapped_dist), aesthetics = "color"),
+ ssw_args <- list( |
| 870 | +1105 | ! |
- env = list(+ test = quote(stats::shapiro.test), |
| 871 | +1106 | ! |
- plot_call = plot_call,+ args = bquote(list(.[[.(dist_var)]])), |
| 872 | +1107 | ! |
- dist_var = dist_var,+ groups = c(g_var, s_var) |
| 873 | -! | +||
| 1108 | +
- ndensity = ndensity,+ ) |
||
| 874 | +1109 | ! |
- mapped_dist = unname(map_dist[t_dist]),+ mfil_args <- list( |
| 875 | +1110 | ! |
- mapped_dist_name = as.name(unname(map_dist[t_dist]))+ test = quote(stats::fligner.test), |
| 876 | -+ | ||
| 1111 | +! |
- )+ args = bquote(list(.[[.(dist_var)]], .[[.(s_var)]])), |
|
| 877 | -+ | ||
| 1112 | +! |
- )+ groups = c(g_var) |
|
| 878 | +1113 |
- }+ ) |
|
| 879 | -+ | ||
| 1114 | +! |
-
+ sad_args <- list( |
|
| 880 | +1115 | ! |
- all_ggplot2_args <- teal.widgets::resolve_ggplot2_args(+ test = quote(goftest::ad.test), |
| 881 | +1116 | ! |
- user_plot = ggplot2_args[["Histogram"]],+ args = bquote(append(list(.[[.(dist_var)]], .(map_dist[t_dist])), params)), |
| 882 | +1117 | ! |
- user_default = ggplot2_args$default+ groups = c(g_var, s_var) |
| 883 | +1118 |
) |
|
| 884 | -+ | ||
| 1119 | +! |
-
+ scvm_args <- list( |
|
| 885 | +1120 | ! |
- parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(+ test = quote(goftest::cvm.test), |
| 886 | +1121 | ! |
- all_ggplot2_args,+ args = bquote(append(list(.[[.(dist_var)]], .(map_dist[t_dist])), params)), |
| 887 | +1122 | ! |
- ggtheme = ggtheme+ groups = c(g_var, s_var) |
| 888 | +1123 |
) |
|
| 889 | -+ | ||
| 1124 | +! |
-
+ manov_args <- list( |
|
| 890 | +1125 | ! |
- teal.code::eval_code(+ test = quote(stats::aov), |
| 891 | +1126 | ! |
- qenv,+ args = bquote(list(stats::formula(.(dist_var_name) ~ .(s_var_name)), .)), |
| 892 | +1127 | ! |
- substitute(+ groups = c(g_var) |
| 893 | -! | +||
| 1128 | +
- expr = {
+ ) |
||
| 894 | +1129 | ! |
- g <- plot_call+ mt_args <- list( |
| 895 | +1130 | ! |
- print(g)+ test = quote(stats::t.test), |
| 896 | -+ | ||
| 1131 | +! |
- },+ args = bquote(unname(split(.[[.(dist_var)]], .[[.(s_var)]], drop = TRUE))), |
|
| 897 | +1132 | ! |
- env = list(plot_call = Reduce(function(x, y) call("+", x, y), c(plot_call, parsed_ggplot2_args)))
+ groups = c(g_var) |
| 898 | +1133 |
- )+ ) |
|
| 899 | -+ | ||
| 1134 | +! |
- )+ mv_args <- list( |
|
| 900 | -+ | ||
| 1135 | +! |
- }+ test = quote(stats::var.test), |
|
| 901 | -+ | ||
| 1136 | +! |
- )+ args = bquote(unname(split(.[[.(dist_var)]], .[[.(s_var)]], drop = TRUE))), |
|
| 902 | -+ | ||
| 1137 | +! |
-
+ groups = c(g_var) |
|
| 903 | +1138 |
- # qqplot qenv ----- |
- |
| 904 | -! | -
- qq_q <- eventReactive(+ ) |
|
| 905 | +1139 | ! |
- eventExpr = {
+ mks_args <- list( |
| 906 | +1140 | ! |
- common_q()+ test = quote(stats::ks.test), |
| 907 | +1141 | ! |
- input$scales_type+ args = bquote(unname(split(.[[.(dist_var)]], .[[.(s_var)]], drop = TRUE))), |
| 908 | +1142 | ! |
- input$qq_line+ groups = c(g_var) |
| 909 | -! | +||
| 1143 | +
- is.null(input$ggtheme)+ ) |
||
| 910 | +1144 |
- },+ |
|
| 911 | +1145 | ! |
- valueExpr = {
+ tests_base <- switch(dist_tests, |
| 912 | +1146 | ! |
- dist_var <- merge_vars()$dist_var+ "Kolmogorov-Smirnov (one-sample)" = sks_args, |
| 913 | +1147 | ! |
- s_var <- merge_vars()$s_var+ "Shapiro-Wilk" = ssw_args, |
| 914 | +1148 | ! |
- g_var <- merge_vars()$g_var+ "Fligner-Killeen" = mfil_args, |
| 915 | +1149 | ! |
- dist_var_name <- merge_vars()$dist_var_name+ "one-way ANOVA" = manov_args, |
| 916 | +1150 | ! |
- s_var_name <- merge_vars()$s_var_name+ "t-test (two-samples, not paired)" = mt_args, |
| 917 | +1151 | ! |
- g_var_name <- merge_vars()$g_var_name+ "F-test" = mv_args, |
| 918 | +1152 | ! |
- t_dist <- input$t_dist+ "Kolmogorov-Smirnov (two-samples)" = mks_args, |
| 919 | +1153 | ! |
- dist_param1 <- input$dist_param1+ "Anderson-Darling (one-sample)" = sad_args, |
| 920 | +1154 | ! |
- dist_param2 <- input$dist_param2+ "Cramer-von Mises (one-sample)" = scvm_args |
| 921 | +1155 | ++ |
+ )+ |
+
| 1156 | |||
| 922 | +1157 | ! |
- scales_type <- input$scales_type+ env <- list( |
| 923 | +1158 | ! |
- ggtheme <- input$ggtheme+ t_test = t_dist, |
| 924 | -+ | ||
| 1159 | +! |
-
+ dist_var = dist_var, |
|
| 925 | +1160 | ! |
- teal::validate_inputs(iv_r_dist(), iv_dist)+ g_var = g_var, |
| 926 | -+ | ||
| 1161 | +! |
-
+ s_var = s_var, |
|
| 927 | +1162 | ! |
- qenv <- common_q()+ args = tests_base$args, |
| 928 | -+ | ||
| 1163 | +! |
-
+ groups = tests_base$groups, |
|
| 929 | +1164 | ! |
- plot_call <- if (length(s_var) == 0 && length(g_var) == 0) {
+ test = tests_base$test, |
| 930 | +1165 | ! |
- substitute(+ dist_var_name = dist_var_name, |
| 931 | +1166 | ! |
- expr = ggplot(ANL, aes_string(sample = dist_var)),+ g_var_name = g_var_name, |
| 932 | +1167 | ! |
- env = list(dist_var = dist_var)+ s_var_name = s_var_name |
| 933 | +1168 |
- )+ ) |
|
| 934 | -! | +||
| 1169 | +
- } else if (length(s_var) != 0 && length(g_var) == 0) {
+
|
||
| 935 | +1170 | ! |
- substitute(+ qenv <- common_q()+ |
+
| 1171 | ++ | + | |
| 936 | +1172 | ! |
- expr = ggplot(ANL, aes_string(sample = dist_var, color = s_var)),+ if (length(s_var) == 0 && length(g_var) == 0) {
|
| 937 | +1173 | ! |
- env = list(dist_var = dist_var, s_var = s_var)- |
-
| 938 | -- |
- )+ qenv <- teal.code::eval_code( |
|
| 939 | +1174 | ! |
- } else if (length(s_var) == 0 && length(g_var) != 0) {
+ qenv, |
| 940 | +1175 | ! |
- substitute(+ substitute( |
| 941 | +1176 | ! |
- expr = ggplot(ANL[ANL[[g_var]] != "NA", ], aes_string(sample = dist_var)) ++ expr = {
|
| 942 | +1177 | ! |
- facet_wrap(~g_var_name, ncol = 1, scales = scales_raw),+ test_stats <- ANL %>% |
| 943 | +1178 | ! |
- env = list(+ dplyr::select(dist_var) %>% |
| 944 | +1179 | ! |
- dist_var = dist_var,+ with(., broom::glance(do.call(test, args))) %>% |
| 945 | +1180 | ! |
- g_var = g_var,+ dplyr::mutate_if(is.numeric, round, 3) |
| 946 | -! | +||
| 1181 | +
- g_var_name = g_var_name,+ }, |
||
| 947 | +1182 | ! |
- scales_raw = tolower(scales_type)+ env = env |
| 948 | +1183 |
) |
|
| 949 | +1184 |
) |
|
| 950 | +1185 |
} else {
|
|
| 951 | +1186 | ! |
- substitute(+ qenv <- teal.code::eval_code( |
| 952 | +1187 | ! |
- expr = ggplot(ANL[ANL[[g_var]] != "NA", ], aes_string(sample = dist_var, color = s_var)) ++ qenv, |
| 953 | +1188 | ! |
- facet_wrap(~g_var_name, ncol = 1, scales = scales_raw),+ substitute( |
| 954 | +1189 | ! |
- env = list(+ expr = {
|
| 955 | +1190 | ! |
- dist_var = dist_var,+ test_stats <- ANL %>% |
| 956 | +1191 | ! |
- g_var = g_var,+ dplyr::select(dist_var, s_var, g_var) %>% |
| 957 | +1192 | ! |
- s_var = s_var,+ dplyr::group_by_at(dplyr::vars(dplyr::any_of(groups))) %>% |
| 958 | +1193 | ! |
- g_var_name = g_var_name,+ dplyr::do(tests = broom::glance(do.call(test, args))) %>% |
| 959 | +1194 | ! |
- scales_raw = tolower(scales_type)+ tidyr::unnest(tests) %>%+ |
+
| 1195 | +! | +
+ dplyr::mutate_if(is.numeric, round, 3) |
|
| 960 | +1196 | ++ |
+ },+ |
+
| 1197 | +! | +
+ env = env+ |
+ |
| 1198 |
) |
||
| 961 | +1199 |
) |
|
| 962 | +1200 |
} |
|
| 1201 | +! | +
+ qenv %>%+ |
+ |
| 963 | +1202 |
-
+ # used to display table when running show-r-code code |
|
| 964 | +1203 | ! |
- map_dist <- stats::setNames(+ teal.code::eval_code(quote(test_stats))+ |
+
| 1204 | ++ |
+ }+ |
+ |
| 1205 | ++ |
+ )+ |
+ |
| 1206 | ++ | + + | +|
| 1207 | ++ |
+ # outputs ----+ |
+ |
| 1208 | ++ |
+ ## building main qenv |
|
| 965 | +1209 | ! |
- c("qnorm", "qlnorm", "qgamma", "qunif"),
+ output_q <- reactive({
|
| 966 | +1210 | ! |
- c("normal", "lognormal", "gamma", "unif")
+ tab <- input$tabs |
| 967 | -+ | ||
| 1211 | +! |
- )+ req(tab) # tab is NULL upon app launch, hence will crash without this statement |
|
| 968 | +1212 | ||
| 969 | +1213 | ! |
- plot_call <- substitute(+ qenv_final <- common_q()+ |
+
| 1214 | ++ |
+ # wrapped in if since could lead into validate error - we do want to continue |
|
| 970 | +1215 | ! |
- expr = plot_call ++ test_r_qenv_out <- try(test_q(), silent = TRUE) |
| 971 | +1216 | ! |
- stat_qq(distribution = mapped_dist, dparams = params),+ if (!inherits(test_r_qenv_out, c("try-error", "error"))) {
|
| 972 | +1217 | ! |
- env = list(plot_call = plot_call, mapped_dist = as.name(unname(map_dist[t_dist])))+ qenv_final <- teal.code::join(qenv_final, test_q()) |
| 973 | +1218 |
- )+ } |
|
| 974 | +1219 | ||
| 975 | +1220 | ! |
- if (length(t_dist) != 0 && length(g_var) == 0 && length(s_var) == 0) {
+ qenv_final <- if (tab == "Histogram") {
|
| 976 | +1221 | ! |
- qenv <- teal.code::eval_code(+ req(dist_q()) |
| 977 | +1222 | ! |
- qenv,+ teal.code::join(qenv_final, dist_q()) |
| 978 | +1223 | ! |
- substitute(+ } else if (tab == "QQplot") {
|
| 979 | +1224 | ! |
- df_params <- as.data.frame(append(params, list(name = t_dist))),+ req(qq_q()) |
| 980 | +1225 | ! |
- env = list(t_dist = t_dist)+ teal.code::join(qenv_final, qq_q()) |
| 981 | +1226 |
- )+ }+ |
+ |
| 1227 | +! | +
+ qenv_final |
|
| 982 | +1228 |
- )+ }) |
|
| 983 | -! | +||
| 1229 | +
- datas <- quote(data.frame(x = 0.7, y = 1, tb = I(list(df_params = df_params))))+ |
||
| 984 | +1230 | ! |
- label <- quote(tb)+ dist_r <- reactive(dist_q()[["g"]]) |
| 985 | +1231 | ||
| 986 | +1232 | ! |
- plot_call <- substitute(+ qq_r <- reactive(qq_q()[["g"]]) |
| 987 | -! | +||
| 1233 | +
- expr = plot_call ++ |
||
| 988 | +1234 | ! |
- ggpp::geom_table_npc(+ output$summary_table <- DT::renderDataTable( |
| 989 | +1235 | ! |
- data = data,+ expr = if (iv_r()$is_valid()) common_q()[["summary_table"]] else NULL, |
| 990 | +1236 | ! |
- aes(npcx = x, npcy = y, label = label),+ options = list( |
| 991 | +1237 | ! |
- hjust = 0,+ autoWidth = TRUE, |
| 992 | +1238 | ! |
- vjust = 1,+ columnDefs = list(list(width = "200px", targets = "_all"))+ |
+
| 1239 | ++ |
+ ), |
|
| 993 | +1240 | ! |
- size = 4+ rownames = FALSE |
| 994 | +1241 |
- ),+ ) |
|
| 995 | -! | +||
| 1242 | +
- env = list(+ |
||
| 996 | +1243 | ! |
- plot_call = plot_call,+ tests_r <- reactive({
|
| 997 | +1244 | ! |
- data = datas,+ req(iv_r()$is_valid()) |
| 998 | +1245 | ! |
- label = label+ teal::validate_inputs(iv_r_dist()) |
| 999 | -+ | ||
| 1246 | +! |
- )+ test_q()[["test_stats"]] |
|
| 1000 | +1247 |
- )+ }) |
|
| 1001 | +1248 |
- }+ |
|
| 1002 | -+ | ||
| 1249 | +! |
-
+ pws1 <- teal.widgets::plot_with_settings_srv( |
|
| 1003 | +1250 | ! |
- if (isTRUE(input$qq_line)) {
+ id = "hist_plot", |
| 1004 | +1251 | ! |
- plot_call <- substitute(+ plot_r = dist_r, |
| 1005 | +1252 | ! |
- expr = plot_call ++ height = plot_height, |
| 1006 | +1253 | ! |
- stat_qq_line(distribution = mapped_dist, dparams = params),+ width = plot_width, |
| 1007 | +1254 | ! |
- env = list(plot_call = plot_call, mapped_dist = as.name(unname(map_dist[t_dist])))+ brushing = FALSE |
| 1008 | +1255 |
- )+ ) |
|
| 1009 | +1256 |
- }+ |
|
| 1010 | -+ | ||
| 1257 | +! |
-
+ pws2 <- teal.widgets::plot_with_settings_srv( |
|
| 1011 | +1258 | ! |
- all_ggplot2_args <- teal.widgets::resolve_ggplot2_args(+ id = "qq_plot", |
| 1012 | +1259 | ! |
- user_plot = ggplot2_args[["QQplot"]],+ plot_r = qq_r, |
| 1013 | +1260 | ! |
- user_default = ggplot2_args$default,+ height = plot_height, |
| 1014 | +1261 | ! |
- module_plot = teal.widgets::ggplot2_args(labs = list(x = "theoretical", y = "sample"))+ width = plot_width,+ |
+
| 1262 | +! | +
+ brushing = FALSE |
|
| 1015 | +1263 |
- )+ ) |
|
| 1016 | +1264 | ||
| 1017 | +1265 | ! |
- parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(+ output$t_stats <- DT::renderDataTable( |
| 1018 | +1266 | ! |
- all_ggplot2_args,+ expr = tests_r(), |
| 1019 | +1267 | ! |
- ggtheme = ggtheme+ options = list(scrollX = TRUE), |
| 1020 | -+ | ||
| 1268 | +! |
- )+ rownames = FALSE |
|
| 1021 | +1269 | - - | -|
| 1022 | -! | -
- teal.code::eval_code(+ ) |
|
| 1023 | -! | +||
| 1270 | +
- qenv,+ |
||
| 1024 | +1271 | ! |
- substitute(+ teal.widgets::verbatim_popup_srv( |
| 1025 | +1272 | ! |
- expr = {
+ id = "rcode", |
| 1026 | +1273 | ! |
- g <- plot_call+ verbatim_content = reactive(teal.code::get_code(output_q())), |
| 1027 | +1274 | ! |
- print(g)+ title = "R Code for distribution" |
| 1028 | +1275 |
- },+ ) |
|
| 1029 | -! | +||
| 1276 | +
- env = list(plot_call = Reduce(function(x, y) call("+", x, y), c(plot_call, parsed_ggplot2_args)))
+
|
||
| 1030 | +1277 |
- )+ ### REPORTER |
|
| 1031 | -+ | ||
| 1278 | +! |
- )+ if (with_reporter) {
|
|
| 1032 | -+ | ||
| 1279 | +! |
- }+ card_fun <- function(comment, label) {
|
|
| 1033 | -+ | ||
| 1280 | +! |
- )+ card <- teal::report_card_template( |
|
| 1034 | -+ | ||
| 1281 | +! |
-
+ title = "Distribution Plot", |
|
| 1035 | -+ | ||
| 1282 | +! |
- # test qenv ----+ label = label, |
|
| 1036 | +1283 | ! |
- test_q <- eventReactive(+ with_filter = with_filter, |
| 1037 | +1284 | ! |
- ignoreNULL = FALSE,+ filter_panel_api = filter_panel_api+ |
+
| 1285 | ++ |
+ ) |
|
| 1038 | +1286 | ! |
- eventExpr = {
+ card$append_text("Plot", "header3")
|
| 1039 | +1287 | ! |
- common_q()+ if (input$tabs == "Histogram") {
|
| 1040 | +1288 | ! |
- input$dist_param1+ card$append_plot(dist_r(), dim = pws1$dim()) |
| 1041 | +1289 | ! |
- input$dist_param2+ } else if (input$tabs == "QQplot") {
|
| 1042 | +1290 | ! |
- input$dist_tests+ card$append_plot(qq_r(), dim = pws2$dim()) |
| 1043 | +1291 |
- },+ } |
|
| 1044 | +1292 | ! |
- valueExpr = {
+ card$append_text("Statistics table", "header3")
|
| 1045 | +1293 |
- # Create a private stack for this function only.+ |
|
| 1046 | +1294 | ! |
- ANL <- common_q()[["ANL"]]+ card$append_table(common_q()[["summary_table"]]) |
| 1047 | -+ | ||
| 1295 | +! |
-
+ tests_error <- tryCatch(expr = tests_r(), error = function(e) "error") |
|
| 1048 | +1296 | ! |
- dist_var <- merge_vars()$dist_var+ if (inherits(tests_error, "data.frame")) {
|
| 1049 | +1297 | ! |
- s_var <- merge_vars()$s_var+ card$append_text("Tests table", "header3")
|
| 1050 | +1298 | ! |
- g_var <- merge_vars()$g_var+ card$append_table(tests_r()) |
| 1051 | +1299 | ++ |
+ }+ |
+
| 1300 | |||
| 1052 | +1301 | ! |
- dist_var_name <- merge_vars()$dist_var_name+ if (!comment == "") {
|
| 1053 | +1302 | ! |
- s_var_name <- merge_vars()$s_var_name+ card$append_text("Comment", "header3")
|
| 1054 | +1303 | ! |
- g_var_name <- merge_vars()$g_var_name+ card$append_text(comment) |
| 1055 | +1304 |
-
+ } |
|
| 1056 | +1305 | ! |
- dist_param1 <- input$dist_param1+ card$append_src(teal.code::get_code(output_q())) |
| 1057 | +1306 | ! |
- dist_param2 <- input$dist_param2+ card |
| 1058 | -! | +||
| 1307 | +
- dist_tests <- input$dist_tests+ } |
||
| 1059 | +1308 | ! |
- t_dist <- input$t_dist+ teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
|
| 1060 | +1309 |
-
+ } |
|
| 1061 | -! | +||
| 1310 | +
- validate(need(dist_tests, "Please select a test"))+ ### |
||
| 1062 | +1311 |
-
+ }) |
|
| 1063 | -! | +||
| 1312 | +
- teal::validate_inputs(iv_dist)+ } |
| 1064 | +1 |
-
+ #' `teal` module: File viewer |
||||
| 1065 | -! | +|||||
| 2 | +
- if (length(s_var) > 0 || length(g_var) > 0) {
+ #' |
|||||
| 1066 | -! | +|||||
| 3 | +
- counts <- ANL %>%+ #' The file viewer module provides a tool to view static files. |
|||||
| 1067 | -! | +|||||
| 4 | +
- dplyr::group_by_at(dplyr::vars(dplyr::any_of(c(s_var, g_var)))) %>%+ #' Supported formats include text formats, `PDF`, `PNG` `APNG`, |
|||||
| 1068 | -! | +|||||
| 5 | +
- dplyr::summarise(n = dplyr::n())+ #' `JPEG` `SVG`, `WEBP`, `GIF` and `BMP`. |
|||||
| 1069 | +6 |
-
+ #' |
||||
| 1070 | -! | +|||||
| 7 | +
- validate(need(all(counts$n > 5), "Please select strata*group with at least 5 observation each."))+ #' @inheritParams teal::module |
|||||
| 1071 | +8 |
- }+ #' @inheritParams shared_params |
||||
| 1072 | +9 |
-
+ #' @param input_path (`list`) of the input paths, optional. Each element can be: |
||||
| 1073 | +10 |
-
+ #' |
||||
| 1074 | -! | +|||||
| 11 | +
- if (dist_tests %in% c(+ #' Paths can be specified as absolute paths or relative to the running directory of the application. |
|||||
| 1075 | -! | +|||||
| 12 | +
- "t-test (two-samples, not paired)",+ #' Default to the current working directory if not supplied. |
|||||
| 1076 | -! | +|||||
| 13 | +
- "F-test",+ #' |
|||||
| 1077 | -! | +|||||
| 14 | +
- "Kolmogorov-Smirnov (two-samples)"+ #' @inherit shared_params return |
|||||
| 1078 | +15 |
- )) {
+ #' |
||||
| 1079 | -! | +|||||
| 16 | +
- if (length(g_var) == 0 && length(s_var) > 0) {
+ #' @examples |
|||||
| 1080 | -! | +|||||
| 17 | +
- validate(need(+ #' data <- teal_data() |
|||||
| 1081 | -! | +|||||
| 18 | +
- length(unique(ANL[[s_var]])) == 2,+ #' data <- within(data, {
|
|||||
| 1082 | -! | +|||||
| 19 | +
- "Please select stratify variable with 2 levels."+ #' data <- data.frame(1) |
|||||
| 1083 | +20 |
- ))+ #' }) |
||||
| 1084 | +21 |
- }+ #' datanames(data) <- c("data")
|
||||
| 1085 | -! | +|||||
| 22 | +
- if (length(g_var) > 0 && length(s_var) > 0) {
+ #' |
|||||
| 1086 | -! | +|||||
| 23 | +
- validate(need(+ #' app <- init( |
|||||
| 1087 | -! | +|||||
| 24 | +
- all(stats::na.omit(as.vector(+ #' data = data, |
|||||
| 1088 | -! | +|||||
| 25 | +
- tapply(ANL[[s_var]], list(ANL[[g_var]]), function(x) length(unique(x))) == 2+ #' modules = modules( |
|||||
| 1089 | +26 |
- ))),+ #' tm_file_viewer( |
||||
| 1090 | -! | +|||||
| 27 | +
- "Please select stratify variable with 2 levels, per each group."+ #' input_path = list( |
|||||
| 1091 | +28 |
- ))+ #' folder = system.file("sample_files", package = "teal.modules.general"),
|
||||
| 1092 | +29 |
- }+ #' png = system.file("sample_files/sample_file.png", package = "teal.modules.general"),
|
||||
| 1093 | +30 |
- }+ #' txt = system.file("sample_files/sample_file.txt", package = "teal.modules.general"),
|
||||
| 1094 | +31 |
-
+ #' url = "https://fda.gov/files/drugs/published/Portable-Document-Format-Specifications.pdf" |
||||
| 1095 | -! | +|||||
| 32 | +
- map_dist <- stats::setNames(+ #' ) |
|||||
| 1096 | -! | +|||||
| 33 | +
- c("pnorm", "plnorm", "pgamma", "punif"),
+ #' ) |
|||||
| 1097 | -! | +|||||
| 34 | +
- c("normal", "lognormal", "gamma", "unif")
+ #' ) |
|||||
| 1098 | +35 |
- )+ #' ) |
||||
| 1099 | -! | +|||||
| 36 | +
- sks_args <- list(+ #' if (interactive()) {
|
|||||
| 1100 | -! | +|||||
| 37 | +
- test = quote(stats::ks.test),+ #' shinyApp(app$ui, app$server) |
|||||
| 1101 | -! | +|||||
| 38 | +
- args = bquote(append(list(.[[.(dist_var)]], .(map_dist[t_dist])), params)),+ #' } |
|||||
| 1102 | -! | +|||||
| 39 | +
- groups = c(g_var, s_var)+ #' |
|||||
| 1103 | +40 |
- )+ #' @export |
||||
| 1104 | -! | +|||||
| 41 | +
- ssw_args <- list(+ #' |
|||||
| 1105 | -! | +|||||
| 42 | +
- test = quote(stats::shapiro.test),+ tm_file_viewer <- function(label = "File Viewer Module", |
|||||
| 1106 | -! | +|||||
| 43 | +
- args = bquote(list(.[[.(dist_var)]])),+ input_path = list("Current Working Directory" = ".")) {
|
|||||
| 1107 | +44 | ! |
- groups = c(g_var, s_var)+ message("Initializing tm_file_viewer")
|
|||
| 1108 | +45 |
- )+ |
||||
| 1109 | -! | +|||||
| 46 | +
- mfil_args <- list(+ # Normalize the parameters |
|||||
| 1110 | +47 | ! |
- test = quote(stats::fligner.test),+ if (length(label) == 0 || identical(label, "")) label <- " " |
|||
| 1111 | +48 | ! |
- args = bquote(list(.[[.(dist_var)]], .[[.(s_var)]])),+ if (length(input_path) == 0 || identical(input_path, "")) input_path <- list() |
|||
| 1112 | -! | +|||||
| 49 | +
- groups = c(g_var)+ |
|||||
| 1113 | +50 |
- )+ # Start of assertions |
||||
| 1114 | +51 | ! |
- sad_args <- list(+ checkmate::assert_string(label)+ |
+ |||
| 52 | ++ | + | ||||
| 1115 | +53 | ! |
- test = quote(goftest::ad.test),+ checkmate::assert( |
|||
| 1116 | +54 | ! |
- args = bquote(append(list(.[[.(dist_var)]], .(map_dist[t_dist])), params)),+ checkmate::check_list(input_path, types = "character", min.len = 0), |
|||
| 1117 | +55 | ! |
- groups = c(g_var, s_var)+ checkmate::check_character(input_path, min.len = 1) |
|||
| 1118 | +56 |
- )+ ) |
||||
| 1119 | +57 | ! |
- scvm_args <- list(+ if (length(input_path) > 0) {
|
|||
| 1120 | +58 | ! |
- test = quote(goftest::cvm.test),+ valid_url <- function(url_input, timeout = 2) {
|
|||
| 1121 | +59 | ! |
- args = bquote(append(list(.[[.(dist_var)]], .(map_dist[t_dist])), params)),+ con <- try(url(url_input), silent = TRUE) |
|||
| 1122 | +60 | ! |
- groups = c(g_var, s_var)- |
- |||
| 1123 | -- |
- )+ check <- suppressWarnings(try(open.connection(con, open = "rt", timeout = timeout), silent = TRUE)[1]) |
||||
| 1124 | +61 | ! |
- manov_args <- list(+ try(close.connection(con), silent = TRUE) |
|||
| 1125 | +62 | ! |
- test = quote(stats::aov),+ is.null(check) |
|||
| 1126 | -! | +|||||
| 63 | +
- args = bquote(list(stats::formula(.(dist_var_name) ~ .(s_var_name)), .)),+ } |
|||||
| 1127 | +64 | ! |
- groups = c(g_var)+ idx <- vapply(input_path, function(x) file.exists(x) || valid_url(x), logical(1)) |
|||
| 1128 | +65 |
- )+ |
||||
| 1129 | +66 | ! |
- mt_args <- list(+ if (!all(idx)) {
|
|||
| 1130 | +67 | ! |
- test = quote(stats::t.test),+ warning( |
|||
| 1131 | +68 | ! |
- args = bquote(unname(split(.[[.(dist_var)]], .[[.(s_var)]], drop = TRUE))),+ paste0( |
|||
| 1132 | +69 | ! |
- groups = c(g_var)+ "Non-existent file or url path. Please provide valid paths for:\n", |
|||
| 1133 | -+ | |||||
| 70 | +! |
- )+ paste0(input_path[!idx], collapse = "\n") |
||||
| 1134 | -! | +|||||
| 71 | +
- mv_args <- list(+ ) |
|||||
| 1135 | -! | +|||||
| 72 | +
- test = quote(stats::var.test),+ ) |
|||||
| 1136 | -! | +|||||
| 73 | +
- args = bquote(unname(split(.[[.(dist_var)]], .[[.(s_var)]], drop = TRUE))),+ } |
|||||
| 1137 | +74 | ! |
- groups = c(g_var)+ input_path <- input_path[idx] |
|||
| 1138 | +75 |
- )+ } else {
|
||||
| 1139 | +76 | ! |
- mks_args <- list(+ warning( |
|||
| 1140 | +77 | ! |
- test = quote(stats::ks.test),+ "No file or url paths were provided." |
|||
| 1141 | -! | +|||||
| 78 | +
- args = bquote(unname(split(.[[.(dist_var)]], .[[.(s_var)]], drop = TRUE))),+ ) |
|||||
| 1142 | -! | +|||||
| 79 | +
- groups = c(g_var)+ } |
|||||
| 1143 | +80 |
- )+ # End of assertions |
||||
| 1144 | +81 | |||||
| 82 | ++ |
+ # Make UI args+ |
+ ||||
| 1145 | +83 | ! |
- tests_base <- switch(dist_tests,+ args <- as.list(environment())+ |
+ |||
| 84 | ++ | + | ||||
| 1146 | +85 | ! |
- "Kolmogorov-Smirnov (one-sample)" = sks_args,+ ans <- module( |
|||
| 1147 | +86 | ! |
- "Shapiro-Wilk" = ssw_args,+ label = label, |
|||
| 1148 | +87 | ! |
- "Fligner-Killeen" = mfil_args,+ server = srv_viewer, |
|||
| 1149 | +88 | ! |
- "one-way ANOVA" = manov_args,+ server_args = list(input_path = input_path), |
|||
| 1150 | +89 | ! |
- "t-test (two-samples, not paired)" = mt_args,+ ui = ui_viewer, |
|||
| 1151 | +90 | ! |
- "F-test" = mv_args,+ ui_args = args, |
|||
| 1152 | +91 | ! |
- "Kolmogorov-Smirnov (two-samples)" = mks_args,+ datanames = NULL+ |
+ |||
| 92 | ++ |
+ ) |
||||
| 1153 | +93 | ! |
- "Anderson-Darling (one-sample)" = sad_args,+ attr(ans, "teal_bookmarkable") <- FALSE |
|||
| 1154 | +94 | ! |
- "Cramer-von Mises (one-sample)" = scvm_args+ ans |
|||
| 1155 | +95 |
- )+ } |
||||
| 1156 | +96 | |||||
| 1157 | -! | -
- env <- list(- |
- ||||
| 1158 | -! | +|||||
| 97 | +
- t_test = t_dist,+ # UI function for the file viewer module |
|||||
| 1159 | -! | +|||||
| 98 | +
- dist_var = dist_var,+ ui_viewer <- function(id, ...) {
|
|||||
| 1160 | +99 | ! |
- g_var = g_var,+ args <- list(...) |
|||
| 1161 | +100 | ! |
- s_var = s_var,+ ns <- NS(id) |
|||
| 1162 | -! | +|||||
| 101 | +
- args = tests_base$args,+ |
|||||
| 1163 | +102 | ! |
- groups = tests_base$groups,+ tagList( |
|||
| 1164 | +103 | ! |
- test = tests_base$test,+ include_css_files("custom"),
|
|||
| 1165 | +104 | ! |
- dist_var_name = dist_var_name,+ teal.widgets::standard_layout( |
|||
| 1166 | +105 | ! |
- g_var_name = g_var_name,+ output = tags$div( |
|||
| 1167 | +106 | ! |
- s_var_name = s_var_name- |
- |||
| 1168 | -- |
- )+ uiOutput(ns("output"))
|
||||
| 1169 | +107 |
-
+ ), |
||||
| 1170 | +108 | ! |
- qenv <- common_q()+ encoding = tags$div( |
|||
| 1171 | -+ | |||||
| 109 | +! |
-
+ class = "file_viewer_encoding", |
||||
| 1172 | +110 | ! |
- if (length(s_var) == 0 && length(g_var) == 0) {
+ tags$label("Encodings", class = "text-primary"),
|
|||
| 1173 | +111 | ! |
- qenv <- teal.code::eval_code(+ shinyTree::shinyTree( |
|||
| 1174 | +112 | ! |
- qenv,+ ns("tree"),
|
|||
| 1175 | +113 | ! |
- substitute(+ dragAndDrop = FALSE, |
|||
| 1176 | +114 | ! |
- expr = {
+ sort = FALSE, |
|||
| 1177 | +115 | ! |
- test_stats <- ANL %>%+ wholerow = TRUE, |
|||
| 1178 | +116 | ! |
- dplyr::select(dist_var) %>%+ theme = "proton", |
|||
| 1179 | +117 | ! |
- with(., broom::glance(do.call(test, args))) %>%+ multiple = FALSE |
|||
| 1180 | -! | +|||||
| 118 | +
- dplyr::mutate_if(is.numeric, round, 3)+ ) |
|||||
| 1181 | +119 |
- },+ ) |
||||
| 1182 | -! | +|||||
| 120 | +
- env = env+ ) |
|||||
| 1183 | +121 |
- )+ ) |
||||
| 1184 | +122 |
- )+ } |
||||
| 1185 | +123 |
- } else {
+
|
||||
| 1186 | -! | +|||||
| 124 | +
- qenv <- teal.code::eval_code(+ # Server function for the file viewer module |
|||||
| 1187 | -! | +|||||
| 125 | +
- qenv,+ srv_viewer <- function(id, input_path) {
|
|||||
| 1188 | +126 | ! |
- substitute(+ moduleServer(id, function(input, output, session) {
|
|||
| 1189 | +127 | ! |
- expr = {
+ teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.general") |
|||
| 1190 | -! | +|||||
| 128 | +
- test_stats <- ANL %>%+ |
|||||
| 1191 | +129 | ! |
- dplyr::select(dist_var, s_var, g_var) %>%+ temp_dir <- tempfile() |
|||
| 1192 | +130 | ! |
- dplyr::group_by_at(dplyr::vars(dplyr::any_of(groups))) %>%+ if (!dir.exists(temp_dir)) {
|
|||
| 1193 | +131 | ! |
- dplyr::do(tests = broom::glance(do.call(test, args))) %>%+ dir.create(temp_dir, recursive = TRUE) |
|||
| 1194 | -! | +|||||
| 132 | +
- tidyr::unnest(tests) %>%+ } |
|||||
| 1195 | +133 | ! |
- dplyr::mutate_if(is.numeric, round, 3)+ addResourcePath(basename(temp_dir), temp_dir) |
|||
| 1196 | +134 |
- },+ |
||||
| 1197 | +135 | ! |
- env = env+ test_path_text <- function(selected_path, type) {
|
|||
| 1198 | -+ | |||||
| 136 | +! |
- )+ out <- tryCatch( |
||||
| 1199 | -+ | |||||
| 137 | +! |
- )+ expr = {
|
||||
| 1200 | -+ | |||||
| 138 | +! |
- }+ if (type != "url") {
|
||||
| 1201 | +139 | ! |
- qenv %>%+ selected_path <- normalizePath(selected_path, winslash = "/") |
|||
| 1202 | +140 |
- # used to display table when running show-r-code code+ } |
||||
| 1203 | +141 | ! |
- teal.code::eval_code(quote(test_stats))+ readLines(con = selected_path) |
|||
| 1204 | +142 |
- }+ }, |
||||
| 1205 | -+ | |||||
| 143 | +! |
- )+ error = function(cond) FALSE, |
||||
| 1206 | -+ | |||||
| 144 | +! |
-
+ warning = function(cond) {
|
||||
| 1207 | -+ | |||||
| 145 | +! |
- # outputs ----+ `if`(grepl("^incomplete final line found on", cond[[1]]), suppressWarnings(eval(cond[[2]])), FALSE)
|
||||
| 1208 | +146 |
- ## building main qenv- |
- ||||
| 1209 | -! | -
- output_q <- reactive({
+ } |
||||
| 1210 | -! | +|||||
| 147 | +
- tab <- input$tabs+ ) |
|||||
| 1211 | -! | +|||||
| 148 | +
- req(tab) # tab is NULL upon app launch, hence will crash without this statement+ } |
|||||
| 1212 | +149 | |||||
| 1213 | +150 | ! |
- qenv_final <- common_q()- |
- |||
| 1214 | -- |
- # wrapped in if since could lead into validate error - we do want to continue+ handle_connection_type <- function(selected_path) {
|
||||
| 1215 | +151 | ! |
- test_r_qenv_out <- try(test_q(), silent = TRUE)+ file_extension <- tools::file_ext(selected_path) |
|||
| 1216 | +152 | ! |
- if (!inherits(test_r_qenv_out, c("try-error", "error"))) {
+ file_class <- suppressWarnings(file(selected_path)) |
|||
| 1217 | +153 | ! |
- qenv_final <- teal.code::join(qenv_final, test_q())+ close(file_class) |
|||
| 1218 | +154 |
- }+ + |
+ ||||
| 155 | +! | +
+ output_text <- test_path_text(selected_path, type = class(file_class)[1]) |
||||
| 1219 | +156 | |||||
| 1220 | +157 | ! |
- qenv_final <- if (tab == "Histogram") {
+ if (class(file_class)[1] == "url") {
|
|||
| 1221 | +158 | ! |
- req(dist_q())+ list(selected_path = selected_path, output_text = output_text) |
|||
| 1222 | -! | +|||||
| 159 | +
- teal.code::join(qenv_final, dist_q())+ } else {
|
|||||
| 1223 | +160 | ! |
- } else if (tab == "QQplot") {
+ file.copy(normalizePath(selected_path, winslash = "/"), temp_dir) |
|||
| 1224 | +161 | ! |
- req(qq_q())+ selected_path <- file.path(basename(temp_dir), basename(selected_path)) |
|||
| 1225 | +162 | ! |
- teal.code::join(qenv_final, qq_q())+ list(selected_path = selected_path, output_text = output_text) |
|||
| 1226 | +163 |
} |
||||
| 1227 | -! | -
- qenv_final- |
- ||||
| 1228 | +164 |
- })+ } |
||||
| 1229 | +165 | |||||
| 1230 | +166 | ! |
- dist_r <- reactive(dist_q()[["g"]])- |
- |||
| 1231 | -- |
-
+ display_file <- function(selected_path) {
|
||||
| 1232 | +167 | ! |
- qq_r <- reactive(qq_q()[["g"]])- |
- |||
| 1233 | -- |
-
+ con_type <- handle_connection_type(selected_path) |
||||
| 1234 | +168 | ! |
- output$summary_table <- DT::renderDataTable(+ file_extension <- tools::file_ext(selected_path) |
|||
| 1235 | +169 | ! |
- expr = if (iv_r()$is_valid()) common_q()[["summary_table"]] else NULL,+ if (file_extension %in% c("png", "apng", "jpg", "jpeg", "svg", "gif", "webp", "bmp")) {
|
|||
| 1236 | +170 | ! |
- options = list(+ tags$img(src = con_type$selected_path, alt = "file does not exist") |
|||
| 1237 | +171 | ! |
- autoWidth = TRUE,+ } else if (file_extension == "pdf") {
|
|||
| 1238 | +172 | ! |
- columnDefs = list(list(width = "200px", targets = "_all"))+ tags$embed( |
|||
| 1239 | -+ | |||||
| 173 | +! |
- ),+ class = "embed_pdf", |
||||
| 1240 | +174 | ! |
- rownames = FALSE+ src = con_type$selected_path |
|||
| 1241 | +175 |
- )+ ) |
||||
| 1242 | -+ | |||||
| 176 | +! |
-
+ } else if (!isFALSE(con_type$output_text[1])) {
|
||||
| 1243 | +177 | ! |
- tests_r <- reactive({
+ tags$pre(paste0(con_type$output_text, collapse = "\n")) |
|||
| 1244 | -! | +|||||
| 178 | +
- req(iv_r()$is_valid())+ } else {
|
|||||
| 1245 | +179 | ! |
- teal::validate_inputs(iv_r_dist())+ tags$p("Please select a supported format.")
|
|||
| 1246 | -! | +|||||
| 180 | +
- test_q()[["test_stats"]]+ } |
|||||
| 1247 | +181 |
- })+ } |
||||
| 1248 | +182 | |||||
| 1249 | +183 | ! |
- pws1 <- teal.widgets::plot_with_settings_srv(+ tree_list <- function(file_or_dir) {
|
|||
| 1250 | +184 | ! |
- id = "hist_plot",+ nested_list <- lapply(file_or_dir, function(path) {
|
|||
| 1251 | +185 | ! |
- plot_r = dist_r,+ file_class <- suppressWarnings(file(path)) |
|||
| 1252 | +186 | ! |
- height = plot_height,+ close(file_class) |
|||
| 1253 | +187 | ! |
- width = plot_width,+ if (class(file_class)[[1]] != "url") {
|
|||
| 1254 | +188 | ! |
- brushing = FALSE+ isdir <- file.info(path)$isdir |
|||
| 1255 | -+ | |||||
| 189 | +! |
- )+ if (!isdir) {
+ |
+ ||||
| 190 | +! | +
+ structure(path, ancestry = path, sticon = "file") |
||||
| 1256 | +191 |
-
+ } else {
|
||||
| 1257 | +192 | ! |
- pws2 <- teal.widgets::plot_with_settings_srv(+ files <- list.files(path, full.names = TRUE, include.dirs = TRUE) |
|||
| 1258 | +193 | ! |
- id = "qq_plot",+ out <- lapply(files, function(x) tree_list(x)) |
|||
| 1259 | +194 | ! |
- plot_r = qq_r,+ out <- unlist(out, recursive = FALSE) |
|||
| 1260 | +195 | ! |
- height = plot_height,+ if (length(files) > 0) names(out) <- basename(files) |
|||
| 1261 | +196 | ! |
- width = plot_width,+ out+ |
+ |||
| 197 | ++ |
+ }+ |
+ ||||
| 198 | ++ |
+ } else {
|
||||
| 1262 | +199 | ! |
- brushing = FALSE+ structure(path, ancestry = path, sticon = "file") |
|||
| 1263 | +200 |
- )+ } |
||||
| 1264 | +201 |
-
+ }) |
||||
| 1265 | -! | +|||||
| 202 | +
- output$t_stats <- DT::renderDataTable(+ |
|||||
| 1266 | +203 | ! |
- expr = tests_r(),+ missing_labels <- if (is.null(names(nested_list))) seq_along(nested_list) else which(names(nested_list) == "") |
|||
| 1267 | +204 | ! |
- options = list(scrollX = TRUE),+ names(nested_list)[missing_labels] <- file_or_dir[missing_labels] |
|||
| 1268 | +205 | ! |
- rownames = FALSE+ nested_list |
|||
| 1269 | +206 |
- )+ } |
||||
| 1270 | +207 | |||||
| 1271 | +208 | ! |
- teal.widgets::verbatim_popup_srv(+ output$tree <- shinyTree::renderTree({
|
|||
| 1272 | +209 | ! |
- id = "rcode",+ if (length(input_path) > 0) {
|
|||
| 1273 | +210 | ! |
- verbatim_content = reactive(teal.code::get_code(output_q())),+ tree_list(input_path)+ |
+ |||
| 211 | ++ |
+ } else {
|
||||
| 1274 | +212 | ! |
- title = "R Code for distribution"+ list("Empty Path" = NULL)
|
|||
| 1275 | +213 |
- )+ } |
||||
| 1276 | +214 |
-
+ }) |
||||
| 1277 | +215 |
- ### REPORTER+ |
||||
| 1278 | +216 | ! |
- if (with_reporter) {
+ output$output <- renderUI({
|
|||
| 1279 | +217 | ! |
- card_fun <- function(comment, label) {
+ validate( |
|||
| 1280 | +218 | ! |
- card <- teal::report_card_template(+ need( |
|||
| 1281 | +219 | ! |
- title = "Distribution Plot",+ length(shinyTree::get_selected(input$tree)) > 0, |
|||
| 1282 | +220 | ! |
- label = label,+ "Please select a file." |
|||
| 1283 | -! | +|||||
| 221 | +
- with_filter = with_filter,+ ) |
|||||
| 1284 | -! | +|||||
| 222 | +
- filter_panel_api = filter_panel_api+ ) |
|||||
| 1285 | +223 |
- )+ |
||||
| 1286 | +224 | ! |
- card$append_text("Plot", "header3")
+ obj <- shinyTree::get_selected(input$tree, format = "names")[[1]] |
|||
| 1287 | +225 | ! |
- if (input$tabs == "Histogram") {
+ repo <- attr(obj, "ancestry") |
|||
| 1288 | +226 | ! |
- card$append_plot(dist_r(), dim = pws1$dim())+ repo_collapsed <- if (length(repo) > 1) paste0(repo, collapse = "/") else repo |
|||
| 1289 | +227 | ! |
- } else if (input$tabs == "QQplot") {
+ is_not_named <- file.exists(file.path(c(repo_collapsed, obj[1])))[1] |
|||
| 1290 | -! | +|||||
| 228 | +
- card$append_plot(qq_r(), dim = pws2$dim())+ |
|||||
| 1291 | -+ | |||||
| 229 | +! |
- }+ if (is_not_named) {
|
||||
| 1292 | +230 | ! |
- card$append_text("Statistics table", "header3")
+ selected_path <- do.call("file.path", as.list(c(repo, obj[1])))
|
|||
| 1293 | +231 |
-
+ } else {
|
||||
| 1294 | +232 | ! |
- card$append_table(common_q()[["summary_table"]])+ if (length(repo) == 0) {
|
|||
| 1295 | +233 | ! |
- tests_error <- tryCatch(expr = tests_r(), error = function(e) "error")+ selected_path <- do.call("file.path", as.list(attr(input$tree[[obj[1]]], "ancestry")))
|
|||
| 1296 | -! | +|||||
| 234 | +
- if (inherits(tests_error, "data.frame")) {
+ } else {
|
|||||
| 1297 | +235 | ! |
- card$append_text("Tests table", "header3")
+ selected_path <- do.call("file.path", as.list(attr(input$tree[[repo]][[obj[1]]], "ancestry")))
|
|||
| 1298 | -! | +|||||
| 236 | +
- card$append_table(tests_r())+ } |
|||||
| 1299 | +237 |
- }+ } |
||||
| 1300 | +238 | |||||
| 1301 | +239 | ! |
- if (!comment == "") {
+ validate( |
|||
| 1302 | +240 | ! |
- card$append_text("Comment", "header3")
+ need( |
|||
| 1303 | +241 | ! |
- card$append_text(comment)+ !isTRUE(file.info(selected_path)$isdir) && length(selected_path) > 0,+ |
+ |||
| 242 | +! | +
+ "Please select a single file." |
||||
| 1304 | +243 |
- }+ ) |
||||
| 1305 | -! | +|||||
| 244 | +
- card$append_src(teal.code::get_code(output_q()))+ ) |
|||||
| 1306 | +245 | ! |
- card+ display_file(selected_path) |
|||
| 1307 | +246 |
- }+ })+ |
+ ||||
| 247 | ++ | + | ||||
| 1308 | +248 | ! |
- teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
+ onStop(function() {
|
|||
| 1309 | -+ | |||||
| 249 | +! |
- }+ removeResourcePath(basename(temp_dir))+ |
+ ||||
| 250 | +! | +
+ unlink(temp_dir) |
||||
| 1310 | +251 |
- ###+ }) |
||||
| 1311 | +252 |
}) |
||||
| 1312 | +253 |
}@@ -25427,7 +25427,7 @@ teal.modules.general coverage - 3.44% | 462 | ! |
- if (shiny::isRunning()) logger::log_shiny_input_changes(input, namespace = "teal.modules.general")+ teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.general") |
|
| 335 | ! |
- if (shiny::isRunning()) logger::log_shiny_input_changes(input, namespace = "teal.modules.general")+ teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.general") |
||||
| 300 | ! |
- if (shiny::isRunning()) logger::log_shiny_input_changes(input, namespace = "teal.modules.general")+ teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.general") |
||||
| 204 | ! |
- if (shiny::isRunning()) logger::log_shiny_input_changes(input, namespace = "teal.modules.general")+ teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.general") |
||||
| 173 | ! |
- if (shiny::isRunning()) logger::log_shiny_input_changes(input, namespace = "teal.modules.general")+ teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.general") |
||||
| 185 | ! |
- if (shiny::isRunning()) logger::log_shiny_input_changes(input, namespace = "teal.modules.general")+ teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.general") |
||||
| 244 | ! |
- if (shiny::isRunning()) logger::log_shiny_input_changes(input, namespace = "teal.modules.general")+ teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.general") |
||||
| 497 | ! |
- if (shiny::isRunning()) logger::log_shiny_input_changes(input, namespace = "teal.modules.general")+ teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.general") |
||||
| 1017 | -- |
- ),- |
- ||||
| 1018 | -! | -
- numeric_cols,- |
- ||||
| 1019 | -! | -
- table_dec- |
- ||||
| 1020 | -- |
- )- |
- ||||
| 1021 | -- |
- } else {
- |
- ||||
| 1022 | -! | -
- DT::datatable(brushed_df, rownames = FALSE, options = list(scrollX = TRUE, pageLength = input$data_table_rows))- |
- ||||
| 1023 | -- |
- }- |
- ||||
| 1024 | -- |
- })- |
- ||||
| 1025 | -- | - - | -||||
| 1026 | -! | -
- teal.widgets::verbatim_popup_srv(- |
- ||||
| 1027 | -! | -
- id = "rcode",- |
- ||||
| 1028 | -! | -
- verbatim_content = reactive(teal.code::get_code(output_q())),- |
- ||||
| 1029 | -! | -
- title = "R Code for scatterplot"- |
- ||||
| 1030 | -- |
- )- |
- ||||
| 1031 | -- | - - | -||||
| 1032 | -- |
- ### REPORTER- |
- ||||
| 1033 | -! | -
- if (with_reporter) {
- |
- ||||
| 1034 | -! | -
- card_fun <- function(comment, label) {
- |
- ||||
| 1035 | -! | -
- card <- teal::report_card_template(- |
- ||||
| 1036 | -! | -
- title = "Scatter Plot",- |
- ||||
| 1037 | -! | -
- label = label,- |
- ||||
| 1038 | -! | -
- with_filter = with_filter,- |
- ||||
| 1039 | -! | -
- filter_panel_api = filter_panel_api- |
- ||||
| 1040 | -- |
- )- |
- ||||
| 1041 | -! | -
- card$append_text("Plot", "header3")
- |
- ||||
| 1042 | -! | -
- card$append_plot(plot_r(), dim = pws$dim())- |
- ||||
| 1043 | -! | -
- if (!comment == "") {
- |
- ||||
| 1044 | -! | -
- card$append_text("Comment", "header3")
- |
- ||||
| 1045 | -! | -
- card$append_text(comment)- |
- ||||
| 1046 | -- |
- }- |
- ||||
| 1047 | -! | -
- card$append_src(teal.code::get_code(output_q()))- |
- ||||
| 1048 | -! | -
- card- |
- ||||
| 1049 | -- |
- }- |
- ||||
| 1050 | -! | -
- teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
- |
- ||||
| 1051 | -- |
- }- |
- ||||
| 1052 | -- |
- ###- |
- ||||
| 1053 | -- |
- })- |
- ||||
| 1054 | -- |
- }- |
-
| 1 | -- |
- #' `teal` module: Response plot- |
- |
| 2 | -- |
- #'- |
- |
| 3 | -- |
- #' Generates a response plot for a given `response` and `x` variables.- |
- |
| 4 | -- |
- #' This module allows users customize and add annotations to the plot depending- |
- |
| 5 | -- |
- #' on the module's arguments.- |
- |
| 6 | -- |
- #' It supports showing the counts grouped by other variable facets (by row / column),- |
- |
| 7 | -- |
- #' swapping the coordinates, show count annotations and displaying the response plot- |
- |
| 8 | -- |
- #' as frequency or density.- |
- |
| 9 | -- |
- #'- |
- |
| 10 | -- |
- #' @inheritParams teal::module- |
- |
| 11 | -- |
- #' @inheritParams shared_params- |
- |
| 12 | -- |
- #' @param response (`data_extract_spec` or `list` of multiple `data_extract_spec`)- |
- |
| 13 | -- |
- #' Which variable to use as the response.- |
- |
| 14 | -- |
- #' You can define one fixed column by setting `fixed = TRUE` inside the `select_spec`.- |
- |
| 15 | -- |
- #'- |
- |
| 16 | -- |
- #' The `data_extract_spec` must not allow multiple selection in this case.- |
- |
| 17 | -- |
- #' @param x (`data_extract_spec` or `list` of multiple `data_extract_spec`)- |
- |
| 18 | -- |
- #' Specifies which variable to use on the X-axis of the response plot.- |
- |
| 19 | -- |
- #' Allow the user to select multiple columns from the `data` allowed in teal.- |
- |
| 20 | -- |
- #'- |
- |
| 21 | -- |
- #' The `data_extract_spec` must not allow multiple selection in this case.- |
- |
| 22 | -- |
- #' @param row_facet (`data_extract_spec` or `list` of multiple `data_extract_spec`)- |
- |
| 23 | -- |
- #' optional specification of the data variable(s) to use for faceting rows.- |
- |
| 24 | -- |
- #' @param col_facet (`data_extract_spec` or `list` of multiple `data_extract_spec`)- |
- |
| 25 | -- |
- #' optional specification of the data variable(s) to use for faceting columns.- |
- |
| 26 | -- |
- #' @param coord_flip (`logical(1)`)- |
- |
| 27 | -- |
- #' Indicates whether to flip coordinates between `x` and `response`.- |
- |
| 28 | -- |
- #' The default value is `FALSE` and it will show the `x` variable on the x-axis- |
- |
| 29 | -- |
- #' and the `response` variable on the y-axis.- |
- |
| 30 | -- |
- #' @param count_labels (`logical(1)`)- |
- |
| 31 | -- |
- #' Indicates whether to show count labels.- |
- |
| 32 | -- |
- #' Defaults to `TRUE`.- |
- |
| 33 | -- |
- #' @param freq (`logical(1)`)- |
- |
| 34 | -- |
- #' Indicates whether to display frequency (`TRUE`) or density (`FALSE`).- |
- |
| 35 | +1017 |
- #' Defaults to density (`FALSE`).+ ), |
|
| 36 | -+ | ||
| 1018 | +! |
- #'+ numeric_cols, |
|
| 37 | -+ | ||
| 1019 | +! |
- #' @inherit shared_params return+ table_dec |
|
| 38 | +1020 |
- #'+ ) |
|
| 39 | +1021 |
- #' @note For more examples, please see the vignette "Using response plot" via+ } else {
|
|
| 40 | -+ | ||
| 1022 | +! |
- #' `vignette("using-response-plot", package = "teal.modules.general")`.
+ DT::datatable(brushed_df, rownames = FALSE, options = list(scrollX = TRUE, pageLength = input$data_table_rows)) |
|
| 41 | +1023 |
- #'+ } |
|
| 42 | +1024 |
- #' @examples+ }) |
|
| 43 | +1025 |
- #' # general data example+ |
|
| 44 | -+ | ||
| 1026 | +! |
- #' library(teal.widgets)+ teal.widgets::verbatim_popup_srv( |
|
| 45 | -+ | ||
| 1027 | +! |
- #'+ id = "rcode", |
|
| 46 | -+ | ||
| 1028 | +! |
- #' data <- teal_data()+ verbatim_content = reactive(teal.code::get_code(output_q())), |
|
| 47 | -+ | ||
| 1029 | +! |
- #' data <- within(data, {
+ title = "R Code for scatterplot" |
|
| 48 | +1030 |
- #' require(nestcolor)+ ) |
|
| 49 | +1031 |
- #' mtcars <- mtcars+ |
|
| 50 | +1032 |
- #' for (v in c("cyl", "vs", "am", "gear")) {
+ ### REPORTER |
|
| 51 | -+ | ||
| 1033 | +! |
- #' mtcars[[v]] <- as.factor(mtcars[[v]])+ if (with_reporter) {
|
|
| 52 | -+ | ||
| 1034 | +! |
- #' }+ card_fun <- function(comment, label) {
|
|
| 53 | -+ | ||
| 1035 | +! |
- #' })+ card <- teal::report_card_template( |
|
| 54 | -+ | ||
| 1036 | +! |
- #' datanames(data) <- "mtcars"+ title = "Scatter Plot", |
|
| 55 | -+ | ||
| 1037 | +! |
- #'+ label = label, |
|
| 56 | -+ | ||
| 1038 | +! |
- #' app <- init(+ with_filter = with_filter, |
|
| 57 | -+ | ||
| 1039 | +! |
- #' data = data,+ filter_panel_api = filter_panel_api |
|
| 58 | +1040 |
- #' modules = modules(+ ) |
|
| 59 | -+ | ||
| 1041 | +! |
- #' tm_g_response(+ card$append_text("Plot", "header3")
|
|
| 60 | -+ | ||
| 1042 | +! |
- #' label = "Response Plots",+ card$append_plot(plot_r(), dim = pws$dim()) |
|
| 61 | -+ | ||
| 1043 | +! |
- #' response = data_extract_spec(+ if (!comment == "") {
|
|
| 62 | -+ | ||
| 1044 | +! |
- #' dataname = "mtcars",+ card$append_text("Comment", "header3")
|
|
| 63 | -+ | ||
| 1045 | +! |
- #' select = select_spec(+ card$append_text(comment) |
|
| 64 | +1046 |
- #' label = "Select variable:",+ } |
|
| 65 | -+ | ||
| 1047 | +! |
- #' choices = variable_choices(data[["mtcars"]], c("cyl", "gear")),
+ card$append_src(teal.code::get_code(output_q())) |
|
| 66 | -+ | ||
| 1048 | +! |
- #' selected = "cyl",+ card |
|
| 67 | +1049 |
- #' multiple = FALSE,+ } |
|
| 68 | -+ | ||
| 1050 | +! |
- #' fixed = FALSE+ teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
|
|
| 69 | +1051 |
- #' )+ } |
|
| 70 | +1052 |
- #' ),+ ### |
|
| 71 | +1053 |
- #' x = data_extract_spec(+ }) |
|
| 72 | +1054 |
- #' dataname = "mtcars",+ } |
| 73 | +1 |
- #' select = select_spec(+ #' Shared parameters documentation |
|
| 74 | +2 |
- #' label = "Select variable:",+ #' |
|
| 75 | +3 |
- #' choices = variable_choices(data[["mtcars"]], c("vs", "am")),
+ #' Defines common arguments shared across multiple functions in the package |
|
| 76 | +4 |
- #' selected = "vs",+ #' to avoid repetition by using `inheritParams`. |
|
| 77 | +5 |
- #' multiple = FALSE,+ #' |
|
| 78 | +6 |
- #' fixed = FALSE+ #' @param plot_height (`numeric`) optional, specifies the plot height as a three-element vector of |
|
| 79 | +7 |
- #' )+ #' `value`, `min`, and `max` intended for use with a slider UI element. |
|
| 80 | +8 |
- #' ),+ #' @param plot_width (`numeric`) optional, specifies the plot width as a three-element vector of |
|
| 81 | +9 |
- #' ggplot2_args = ggplot2_args(+ #' `value`, `min`, and `max` for a slider encoding the plot width. |
|
| 82 | +10 |
- #' labs = list(subtitle = "Plot generated by Response Module")+ #' @param rotate_xaxis_labels (`logical`) optional, whether to rotate plot X axis labels. Does not |
|
| 83 | +11 |
- #' )+ #' rotate by default (`FALSE`). |
|
| 84 | +12 |
- #' )+ #' @param ggtheme (`character`) optional, `ggplot2` theme to be used by default. Defaults to `"gray"`. |
|
| 85 | +13 |
- #' )+ #' @param ggplot2_args (`ggplot2_args`) object created by [teal.widgets::ggplot2_args()] |
|
| 86 | +14 |
- #' )+ #' with settings for the module plot. |
|
| 87 | +15 |
- #' if (interactive()) {
+ #' The argument is merged with options variable `teal.ggplot2_args` and default module setup. |
|
| 88 | +16 |
- #' shinyApp(app$ui, app$server)+ #' |
|
| 89 | +17 |
- #' }+ #' For more details see the vignette: `vignette("custom-ggplot2-arguments", package = "teal.widgets")`
|
|
| 90 | +18 |
- #'+ #' @param basic_table_args (`basic_table_args`) object created by [teal.widgets::basic_table_args()] |
|
| 91 | +19 |
- #' # CDISC data example+ #' with settings for the module table. |
|
| 92 | +20 |
- #' library(teal.widgets)+ #' The argument is merged with options variable `teal.basic_table_args` and default module setup. |
|
| 93 | +21 |
#' |
|
| 94 | +22 |
- #' data <- teal_data()+ #' For more details see the vignette: `vignette("custom-basic-table-arguments", package = "teal.widgets")`
|
|
| 95 | +23 |
- #' data <- within(data, {
+ #' @param pre_output (`shiny.tag`) optional, text or UI element to be displayed before the module's output, |
|
| 96 | +24 |
- #' require(nestcolor)+ #' providing context or a title. |
|
| 97 | +25 |
- #' ADSL <- rADSL+ #' with text placed before the output to put the output into context. For example a title. |
|
| 98 | +26 |
- #' })+ #' @param post_output (`shiny.tag`) optional, text or UI element to be displayed after the module's output, |
|
| 99 | +27 |
- #' datanames(data) <- c("ADSL")
+ #' adding context or further instructions. Elements like `shiny::helpText()` are useful. |
|
| 100 | +28 |
- #' join_keys(data) <- default_cdisc_join_keys[datanames(data)]+ #' |
|
| 101 | +29 |
- #'+ #' @param alpha (`integer(1)` or `integer(3)`) optional, specifies point opacity. |
|
| 102 | +30 |
- #' app <- init(+ #' - When the length of `alpha` is one: the plot points will have a fixed opacity. |
|
| 103 | +31 |
- #' data = data,+ #' - When the length of `alpha` is three: the plot points opacity are dynamically adjusted based on |
|
| 104 | +32 |
- #' modules = modules(+ #' vector of `value`, `min`, and `max`. |
|
| 105 | +33 |
- #' tm_g_response(+ #' @param size (`integer(1)` or `integer(3)`) optional, specifies point size. |
|
| 106 | +34 |
- #' label = "Response Plots",+ #' - When the length of `size` is one: the plot point sizes will have a fixed size. |
|
| 107 | +35 |
- #' response = data_extract_spec(+ #' - When the length of `size` is three: the plot points size are dynamically adjusted based on |
|
| 108 | +36 |
- #' dataname = "ADSL",+ #' vector of `value`, `min`, and `max`. |
|
| 109 | +37 |
- #' select = select_spec(+ #' |
|
| 110 | +38 |
- #' label = "Select variable:",+ #' @return Object of class `teal_module` to be used in `teal` applications. |
|
| 111 | +39 |
- #' choices = variable_choices(data[["ADSL"]], c("BMRKR2", "COUNTRY")),
+ #' |
|
| 112 | +40 |
- #' selected = "BMRKR2",+ #' @name shared_params |
|
| 113 | +41 |
- #' multiple = FALSE,+ #' @keywords internal |
|
| 114 | +42 |
- #' fixed = FALSE+ NULL |
|
| 115 | +43 |
- #' )+ |
|
| 116 | +44 |
- #' ),+ #' Add labels for facets to a `ggplot2` object |
|
| 117 | +45 |
- #' x = data_extract_spec(+ #' |
|
| 118 | +46 |
- #' dataname = "ADSL",+ #' Enhances a `ggplot2` plot by adding labels that describe |
|
| 119 | +47 |
- #' select = select_spec(+ #' the faceting variables along the x and y axes. |
|
| 120 | +48 |
- #' label = "Select variable:",+ #' |
|
| 121 | +49 |
- #' choices = variable_choices(data[["ADSL"]], c("SEX", "RACE")),
+ #' @param p (`ggplot2`) object to which facet labels will be added. |
|
| 122 | +50 |
- #' selected = "RACE",+ #' @param xfacet_label (`character`) Label for the facet along the x-axis. |
|
| 123 | +51 |
- #' multiple = FALSE,+ #' If `NULL`, no label is added. If a vector, labels are joined with " & ". |
|
| 124 | +52 |
- #' fixed = FALSE+ #' @param yfacet_label (`character`) Label for the facet along the y-axis. |
|
| 125 | +53 |
- #' )+ #' Similar behavior to `xfacet_label`. |
|
| 126 | +54 |
- #' ),+ #' |
|
| 127 | +55 |
- #' ggplot2_args = ggplot2_args(+ #' @return Returns `grid` or `grob` object (to be drawn with `grid.draw`) |
|
| 128 | +56 |
- #' labs = list(subtitle = "Plot generated by Response Module")+ #' |
|
| 129 | +57 |
- #' )+ #' @examples |
|
| 130 | +58 |
- #' )+ #' library(ggplot2) |
|
| 131 | +59 |
- #' )+ #' library(grid) |
|
| 132 | +60 |
- #' )+ #' |
|
| 133 | +61 |
- #' if (interactive()) {
+ #' p <- ggplot(mtcars) + |
|
| 134 | +62 |
- #' shinyApp(app$ui, app$server)+ #' aes(x = mpg, y = disp) + |
|
| 135 | +63 |
- #' }+ #' geom_point() + |
|
| 136 | +64 |
- #'+ #' facet_grid(gear ~ cyl) |
|
| 137 | +65 |
- #' @export+ #' |
|
| 138 | +66 |
- #'+ #' xfacet_label <- "cylinders" |
|
| 139 | +67 |
- tm_g_response <- function(label = "Response Plot",+ #' yfacet_label <- "gear" |
|
| 140 | +68 |
- response,+ #' res <- add_facet_labels(p, xfacet_label, yfacet_label) |
|
| 141 | +69 |
- x,+ #' grid.newpage() |
|
| 142 | +70 |
- row_facet = NULL,+ #' grid.draw(res) |
|
| 143 | +71 |
- col_facet = NULL,+ #' |
|
| 144 | +72 |
- coord_flip = FALSE,+ #' grid.newpage() |
|
| 145 | +73 |
- count_labels = TRUE,+ #' grid.draw(add_facet_labels(p, xfacet_label = NULL, yfacet_label)) |
|
| 146 | +74 |
- rotate_xaxis_labels = FALSE,+ #' grid.newpage() |
|
| 147 | +75 |
- freq = FALSE,+ #' grid.draw(add_facet_labels(p, xfacet_label, yfacet_label = NULL)) |
|
| 148 | +76 |
- plot_height = c(600, 400, 5000),+ #' grid.newpage() |
|
| 149 | +77 |
- plot_width = NULL,+ #' grid.draw(add_facet_labels(p, xfacet_label = NULL, yfacet_label = NULL)) |
|
| 150 | +78 |
- ggtheme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void"),
+ #' |
|
| 151 | +79 |
- ggplot2_args = teal.widgets::ggplot2_args(),+ #' @export |
|
| 152 | +80 |
- pre_output = NULL,+ #' |
|
| 153 | +81 |
- post_output = NULL) {
+ add_facet_labels <- function(p, xfacet_label = NULL, yfacet_label = NULL) {
|
|
| 154 | +82 | ! |
- message("Initializing tm_g_response")
+ checkmate::assert_class(p, classes = "ggplot") |
| 155 | -+ | ||
| 83 | +! |
-
+ checkmate::assert_character(xfacet_label, null.ok = TRUE, min.len = 1) |
|
| 156 | -+ | ||
| 84 | +! |
- # Normalize the parameters+ checkmate::assert_character(yfacet_label, null.ok = TRUE, min.len = 1) |
|
| 157 | +85 | ! |
- if (inherits(response, "data_extract_spec")) response <- list(response)+ if (is.null(xfacet_label) && is.null(yfacet_label)) {
|
| 158 | +86 | ! |
- if (inherits(x, "data_extract_spec")) x <- list(x)+ return(ggplotGrob(p))+ |
+
| 87 | ++ |
+ } |
|
| 159 | +88 | ! |
- if (inherits(row_facet, "data_extract_spec")) row_facet <- list(row_facet)+ grid::grid.grabExpr({
|
| 160 | +89 | ! |
- if (inherits(col_facet, "data_extract_spec")) col_facet <- list(col_facet)+ g <- ggplotGrob(p) |
| 161 | +90 | ||
| 162 | +91 |
- # Start of assertions+ # we are going to replace these, so we make sure they have nothing in them |
|
| 163 | +92 | ! |
- checkmate::assert_string(label)+ checkmate::assert_class(g$grobs[[grep("xlab-t", g$layout$name, fixed = TRUE)]], "zeroGrob")
+ |
+
| 93 | +! | +
+ checkmate::assert_class(g$grobs[[grep("ylab-r", g$layout$name, fixed = TRUE)]], "zeroGrob")
|
|
| 164 | +94 | ||
| 165 | +95 | ! |
- checkmate::assert_list(response, types = "data_extract_spec")+ xaxis_label_grob <- g$grobs[[grep("xlab-b", g$layout$name, fixed = TRUE)]]
|
| 166 | +96 | ! |
- if (!all(vapply(response, function(x) !("" %in% x$select$choices), logical(1)))) {
+ xaxis_label_grob$children[[1]]$label <- paste(xfacet_label, collapse = " & ") |
| 167 | +97 | ! |
- stop("'response' should not allow empty values")
+ yaxis_label_grob <- g$grobs[[grep("ylab-l", g$layout$name, fixed = TRUE)]]
|
| 168 | -+ | ||
| 98 | +! |
- }+ yaxis_label_grob$children[[1]]$label <- paste(yfacet_label, collapse = " & ") |
|
| 169 | +99 | ! |
- assert_single_selection(response)+ yaxis_label_grob$children[[1]]$rot <- 270 |
| 170 | +100 | ||
| 171 | +101 | ! |
- checkmate::assert_list(x, types = "data_extract_spec")+ top_height <- if (is.null(xfacet_label)) 0 else grid::unit(2, "line") |
| 172 | +102 | ! |
- if (!all(vapply(x, function(x) !("" %in% x$select$choices), logical(1)))) {
+ right_width <- if (is.null(yfacet_label)) 0 else grid::unit(2, "line")+ |
+
| 103 | ++ | + | |
| 173 | +104 | ! |
- stop("'x' should not allow empty values")
+ grid::grid.newpage() |
| 174 | -+ | ||
| 105 | +! |
- }+ grid::pushViewport(grid::plotViewport(margins = c(0, 0, top_height, right_width), name = "ggplot")) |
|
| 175 | +106 | ! |
- assert_single_selection(x)+ grid::grid.draw(g)+ |
+
| 107 | +! | +
+ grid::upViewport(1) |
|
| 176 | +108 | ||
| 109 | ++ |
+ # draw x facet+ |
+ |
| 177 | +110 | ! |
- checkmate::assert_list(row_facet, types = "data_extract_spec", null.ok = TRUE)+ if (!is.null(xfacet_label)) {
|
| 178 | +111 | ! |
- checkmate::assert_list(col_facet, types = "data_extract_spec", null.ok = TRUE)+ grid::pushViewport(grid::viewport( |
| 179 | +112 | ! |
- checkmate::assert_flag(coord_flip)+ x = 0, y = grid::unit(1, "npc") - top_height, width = grid::unit(1, "npc"), |
| 180 | +113 | ! |
- checkmate::assert_flag(count_labels)+ height = top_height, just = c("left", "bottom"), name = "topxaxis"
+ |
+
| 114 | ++ |
+ )) |
|
| 181 | +115 | ! |
- checkmate::assert_flag(rotate_xaxis_labels)+ grid::grid.draw(xaxis_label_grob) |
| 182 | +116 | ! |
- checkmate::assert_flag(freq)+ grid::upViewport(1) |
| 183 | +117 | ++ |
+ }+ |
+
| 118 | |||
| 119 | ++ |
+ # draw y facet+ |
+ |
| 184 | +120 | ! |
- checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE)+ if (!is.null(yfacet_label)) {
|
| 185 | +121 | ! |
- checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height")+ grid::pushViewport(grid::viewport( |
| 186 | +122 | ! |
- checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE)+ x = grid::unit(1, "npc") - grid::unit(as.numeric(right_width) / 2, "line"), y = 0, width = right_width, |
| 187 | +123 | ! |
- checkmate::assert_numeric(+ height = grid::unit(1, "npc"), just = c("left", "bottom"), name = "rightyaxis"
+ |
+
| 124 | ++ |
+ )) |
|
| 188 | +125 | ! |
- plot_width[1],+ grid::grid.draw(yaxis_label_grob) |
| 189 | +126 | ! |
- lower = plot_width[2], upper = plot_width[3], null.ok = TRUE, .var.name = "plot_width"+ grid::upViewport(1) |
| 190 | +127 |
- )+ } |
|
| 191 | +128 | ++ |
+ })+ |
+
| 129 | ++ |
+ }+ |
+ |
| 130 | |||
| 192 | -! | +||
| 131 | +
- ggtheme <- match.arg(ggtheme)+ #' Call a function with a character vector for the `...` argument |
||
| 193 | -! | +||
| 132 | +
- checkmate::assert_class(ggplot2_args, "ggplot2_args")+ #' |
||
| 194 | +133 |
-
+ #' @param fun (`character`) Name of a function where the `...` argument shall be replaced by values from `str_args`. |
|
| 195 | -! | +||
| 134 | +
- checkmate::assert_multi_class(pre_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
+ #' @param str_args (`character`) A character vector that the function shall be executed with |
||
| 196 | -! | +||
| 135 | +
- checkmate::assert_multi_class(post_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
+ #' |
||
| 197 | +136 |
- # End of assertions+ #' @return |
|
| 198 | +137 |
-
+ #' Value of call to `fun` with arguments specified in `str_args`. |
|
| 199 | +138 |
- # Make UI args+ #'+ |
+ |
| 139 | ++ |
+ #' @keywords internal+ |
+ |
| 140 | ++ |
+ call_fun_dots <- function(fun, str_args) {
|
|
| 200 | +141 | ! |
- args <- as.list(environment())+ do.call("call", c(list(fun), lapply(str_args, as.name)), quote = TRUE)
|
| 201 | +142 | ++ |
+ }+ |
+
| 143 | |||
| 202 | -! | +||
| 144 | +
- data_extract_list <- list(+ #' Generate a string for a variable including its label |
||
| 203 | -! | +||
| 145 | +
- response = response,+ #' |
||
| 204 | -! | +||
| 146 | +
- x = x,+ #' @param var_names (`character`) Name of variable to extract labels from. |
||
| 205 | -! | +||
| 147 | +
- row_facet = row_facet,+ #' @param dataset (`dataset`) Name of analysis dataset. |
||
| 206 | -! | +||
| 148 | +
- col_facet = col_facet+ #' @param prefix,suffix (`character`) String to paste to the beginning/end of the variable name with label. |
||
| 207 | +149 |
- )+ #' @param wrap_width (`numeric`) Number of characters to wrap original label to. Defaults to 80. |
|
| 208 | +150 |
-
+ #' |
|
| 209 | -! | +||
| 151 | +
- ans <- module(+ #' @return (`character`) String with variable name and label. |
||
| 210 | -! | +||
| 152 | +
- label = label,+ #' |
||
| 211 | -! | +||
| 153 | +
- server = srv_g_response,+ #' @keywords internal+ |
+ ||
| 154 | ++ |
+ #'+ |
+ |
| 155 | ++ |
+ varname_w_label <- function(var_names,+ |
+ |
| 156 | ++ |
+ dataset,+ |
+ |
| 157 | ++ |
+ wrap_width = 80,+ |
+ |
| 158 | ++ |
+ prefix = NULL,+ |
+ |
| 159 | ++ |
+ suffix = NULL) {
|
|
| 212 | +160 | ! |
- ui = ui_g_response,+ add_label <- function(var_names) {
|
| 213 | +161 | ! |
- ui_args = args,+ label <- vapply( |
| 214 | +162 | ! |
- server_args = c(+ dataset[var_names], function(x) {
|
| 215 | +163 | ! |
- data_extract_list,+ attr_label <- attr(x, "label") |
| 216 | +164 | ! |
- list(plot_height = plot_height, plot_width = plot_width, ggplot2_args = ggplot2_args)+ `if`(is.null(attr_label), "", attr_label) |
| 217 | +165 |
- ),+ }, |
|
| 218 | +166 | ! |
- datanames = teal.transform::get_extract_datanames(data_extract_list)+ character(1)+ |
+
| 167 | ++ |
+ ) |
|
| 219 | +168 |
- )+ |
|
| 220 | +169 | ! |
- attr(ans, "teal_bookmarkable") <- TRUE+ if (length(label) == 1 && !is.na(label) && !identical(label, "")) {
|
| 221 | +170 | ! |
- ans+ paste0(prefix, label, " [", var_names, "]", suffix) |
| 222 | +171 |
- }+ } else {
+ |
+ |
| 172 | +! | +
+ var_names |
|
| 223 | +173 |
-
+ } |
|
| 224 | +174 |
- # UI function for the response module+ } |
|
| 225 | +175 |
- ui_g_response <- function(id, ...) {
+
|
|
| 226 | +176 | ! |
- ns <- NS(id)+ if (length(var_names) < 1) {
|
| 227 | +177 | ! |
- args <- list(...)+ NULL |
| 228 | +178 | ! |
- is_single_dataset_value <- teal.transform::is_single_dataset(args$response, args$x, args$row_facet, args$col_facet)- |
-
| 229 | -- |
-
+ } else if (length(var_names) == 1) {
|
|
| 230 | +179 | ! |
- teal.widgets::standard_layout(+ stringr::str_wrap(add_label(var_names), width = wrap_width) |
| 231 | +180 | ! |
- output = teal.widgets::white_small_well(+ } else if (length(var_names) > 1) {
|
| 232 | +181 | ! |
- teal.widgets::plot_with_settings_ui(id = ns("myplot"))
+ stringr::str_wrap(vapply(var_names, add_label, character(1)), width = wrap_width) |
| 233 | +182 |
- ),+ } |
|
| 234 | -! | +||
| 183 | +
- encoding = tags$div(+ } |
||
| 235 | +184 |
- ### Reporter+ |
|
| 236 | -! | +||
| 185 | +
- teal.reporter::simple_reporter_ui(ns("simple_reporter")),
+ # see vignette("ggplot2-specs", package="ggplot2")
|
||
| 237 | +186 |
- ###+ shape_names <- c( |
|
| 238 | -! | +||
| 187 | +
- tags$label("Encodings", class = "text-primary"),
+ "circle", paste("circle", c("open", "filled", "cross", "plus", "small")), "bullet",
|
||
| 239 | -! | +||
| 188 | +
- teal.transform::datanames_input(args[c("response", "x", "row_facet", "col_facet")]),
+ "square", paste("square", c("open", "filled", "cross", "plus", "triangle")),
|
||
| 240 | -! | +||
| 189 | +
- teal.transform::data_extract_ui(+ "diamond", paste("diamond", c("open", "filled", "plus")),
|
||
| 241 | -! | +||
| 190 | +
- id = ns("response"),
+ "triangle", paste("triangle", c("open", "filled", "square")),
|
||
| 242 | -! | +||
| 191 | +
- label = "Response variable",+ paste("triangle down", c("open", "filled")),
|
||
| 243 | -! | +||
| 192 | +
- data_extract_spec = args$response,+ "plus", "cross", "asterisk" |
||
| 244 | -! | +||
| 193 | +
- is_single_dataset = is_single_dataset_value+ ) |
||
| 245 | +194 |
- ),+ |
|
| 246 | -! | +||
| 195 | +
- teal.transform::data_extract_ui(+ #' Get icons to represent variable types in dataset |
||
| 247 | -! | +||
| 196 | +
- id = ns("x"),
+ #' |
||
| 248 | -! | +||
| 197 | +
- label = "X variable",+ #' @param var_type (`character`) of R internal types (classes). |
||
| 249 | -! | +||
| 198 | +
- data_extract_spec = args$x,+ #' @return (`character`) vector of HTML icons corresponding to data type in each column. |
||
| 250 | -! | +||
| 199 | +
- is_single_dataset = is_single_dataset_value+ #' @keywords internal |
||
| 251 | +200 |
- ),+ variable_type_icons <- function(var_type) {
|
|
| 252 | +201 | ! |
- if (!is.null(args$row_facet)) {
+ checkmate::assert_character(var_type, any.missing = FALSE) |
| 253 | -! | +||
| 202 | +
- teal.transform::data_extract_ui(+ |
||
| 254 | +203 | ! |
- id = ns("row_facet"),
+ class_to_icon <- list( |
| 255 | +204 | ! |
- label = "Row facetting",+ numeric = "arrow-up-1-9", |
| 256 | +205 | ! |
- data_extract_spec = args$row_facet,+ integer = "arrow-up-1-9", |
| 257 | +206 | ! |
- is_single_dataset = is_single_dataset_value- |
-
| 258 | -- |
- )+ logical = "pause", |
|
| 259 | -+ | ||
| 207 | +! |
- },+ Date = "calendar", |
|
| 260 | +208 | ! |
- if (!is.null(args$col_facet)) {
+ POSIXct = "calendar", |
| 261 | +209 | ! |
- teal.transform::data_extract_ui(+ POSIXlt = "calendar", |
| 262 | +210 | ! |
- id = ns("col_facet"),
+ factor = "chart-bar", |
| 263 | +211 | ! |
- label = "Column facetting",+ character = "keyboard", |
| 264 | +212 | ! |
- data_extract_spec = args$col_facet,+ primary_key = "key", |
| 265 | +213 | ! |
- is_single_dataset = is_single_dataset_value+ unknown = "circle-question" |
| 266 | +214 |
- )+ )+ |
+ |
| 215 | +! | +
+ class_to_icon <- lapply(class_to_icon, function(icon_name) toString(icon(icon_name, lib = "font-awesome"))) |
|
| 267 | +216 |
- },+ |
|
| 268 | +217 | ! |
- shinyWidgets::radioGroupButtons(+ unname(vapply( |
| 269 | +218 | ! |
- inputId = ns("freq"),
+ var_type, |
| 270 | +219 | ! |
- label = NULL,+ FUN.VALUE = character(1), |
| 271 | +220 | ! |
- choices = c("frequency", "density"),
+ FUN = function(class) {
|
| 272 | +221 | ! |
- selected = ifelse(args$freq, "frequency", "density"),+ if (class == "") {
|
| 273 | +222 | ! |
- justified = TRUE+ class |
| 274 | -+ | ||
| 223 | +! |
- ),+ } else if (is.null(class_to_icon[[class]])) {
|
|
| 275 | +224 | ! |
- teal.widgets::panel_group(+ class_to_icon[["unknown"]] |
| 276 | -! | +||
| 225 | +
- teal.widgets::panel_item(+ } else {
|
||
| 277 | +226 | ! |
- title = "Plot settings",+ class_to_icon[[class]] |
| 278 | -! | +||
| 227 | +
- checkboxInput(ns("count_labels"), "Add count labels", value = args$count_labels),
+ } |
||
| 279 | -! | +||
| 228 | +
- checkboxInput(ns("coord_flip"), "Swap axes", value = args$coord_flip),
+ } |
||
| 280 | -! | +||
| 229 | +
- checkboxInput(ns("rotate_xaxis_labels"), "Rotate X axis labels", value = args$rotate_xaxis_labels),
+ )) |
||
| 281 | -! | +||
| 230 | +
- selectInput(+ } |
||
| 282 | -! | +||
| 231 | +
- inputId = ns("ggtheme"),
+
|
||
| 283 | -! | +||
| 232 | +
- label = "Theme (by ggplot):",+ #' Include `CSS` files from `/inst/css/` package directory to application header |
||
| 284 | -! | +||
| 233 | +
- choices = ggplot_themes,+ #' |
||
| 285 | -! | +||
| 234 | +
- selected = args$ggtheme,+ #' `system.file` should not be used to access files in other packages, it does |
||
| 286 | -! | +||
| 235 | +
- multiple = FALSE+ #' not work with `devtools`. Therefore, we redefine this method in each package |
||
| 287 | +236 |
- )+ #' as needed. Thus, we do not export this method |
|
| 288 | +237 |
- )+ #' |
|
| 289 | +238 |
- )+ #' @param pattern (`character`) optional, regular expression to match the file names to be included. |
|
| 290 | +239 |
- ),+ #' |
|
| 291 | -! | +||
| 240 | +
- forms = tagList(+ #' @return HTML code that includes `CSS` files. |
||
| 292 | -! | +||
| 241 | +
- teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code")
+ #' @keywords internal |
||
| 293 | +242 |
- ),+ #'+ |
+ |
| 243 | ++ |
+ include_css_files <- function(pattern = "*") {
|
|
| 294 | +244 | ! |
- pre_output = args$pre_output,+ css_files <- list.files( |
| 295 | +245 | ! |
- post_output = args$post_output+ system.file("css", package = "teal.modules.general", mustWork = TRUE),
+ |
+
| 246 | +! | +
+ pattern = pattern, full.names = TRUE |
|
| 296 | +247 |
) |
|
| 297 | -+ | ||
| 248 | +! |
- }+ if (length(css_files) == 0) {
+ |
+ |
| 249 | +! | +
+ return(NULL) |
|
| 298 | +250 |
-
+ }+ |
+ |
| 251 | +! | +
+ singleton(tags$head(lapply(css_files, includeCSS))) |
|
| 299 | +252 |
- # Server function for the response module+ } |
|
| 300 | +253 |
- srv_g_response <- function(id,+ |
|
| 301 | +254 |
- data,+ #' JavaScript condition to check if a specific tab is active |
|
| 302 | +255 |
- reporter,+ #' |
|
| 303 | +256 |
- filter_panel_api,+ #' @param id (`character(1)`) the id of the tab panel with tabs. |
|
| 304 | +257 |
- response,+ #' @param name (`character(1)`) the name of the tab. |
|
| 305 | +258 |
- x,+ #' @return JavaScript expression to be used in `shiny::conditionalPanel()` to determine |
|
| 306 | +259 |
- row_facet,+ #' if the specified tab is active. |
|
| 307 | +260 |
- col_facet,+ #' @keywords internal |
|
| 308 | +261 |
- plot_height,+ #' |
|
| 309 | +262 |
- plot_width,+ is_tab_active_js <- function(id, name) {
|
|
| 310 | +263 |
- ggplot2_args) {
+ # supporting the bs3 and higher version at the same time |
|
| 311 | +264 | ! |
- with_reporter <- !missing(reporter) && inherits(reporter, "Reporter")+ sprintf( |
| 312 | +265 | ! |
- with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI")+ "$(\"#%1$s > li.active\").text().trim() == '%2$s' || $(\"#%1$s > li a.active\").text().trim() == '%2$s'", |
| 313 | +266 | ! |
- checkmate::assert_class(data, "reactive")+ id, name |
| 314 | -! | +||
| 267 | +
- checkmate::assert_class(isolate(data()), "teal_data")+ ) |
||
| 315 | -! | +||
| 268 | +
- moduleServer(id, function(input, output, session) {
+ } |
||
| 316 | -! | +||
| 269 | +
- if (shiny::isRunning()) logger::log_shiny_input_changes(input, namespace = "teal.modules.general")+ |
||
| 317 | +270 |
-
+ #' Assert single selection on `data_extract_spec` object |
|
| 318 | -! | +||
| 271 | +
- data_extract <- list(response = response, x = x, row_facet = row_facet, col_facet = col_facet)+ #' Helper to reduce code in assertions |
||
| 319 | +272 |
-
+ #' @noRd |
|
| 320 | -! | +||
| 273 | +
- rule_diff <- function(other) {
+ #' |
||
| 321 | -! | +||
| 274 | +
- function(value) {
+ assert_single_selection <- function(x, |
||
| 322 | -! | +||
| 275 | +
- if (other %in% names(selector_list())) {
+ .var.name = checkmate::vname(x)) { # nolint: object_name.
|
||
| 323 | -! | +||
| 276 | +104x |
- othervalue <- selector_list()[[other]]()[["select"]]+ if (any(vapply(x, function(.x) .x$select$multiple, logical(1)))) {
|
|
| 324 | -! | +||
| 277 | +4x |
- if (!is.null(othervalue)) {
+ stop("'", .var.name, "' should not allow multiple selection")
|
|
| 325 | -! | +||
| 278 | +
- if (identical(value, othervalue)) {
+ } |
||
| 326 | -! | +||
| 279 | +100x |
- "Row and column facetting variables must be different."+ invisible(TRUE) |
|
| 327 | +280 |
- }+ } |
| 328 | +1 |
- }+ #' `teal` module: Stack plots of variables and show association with reference variable |
|
| 329 | +2 |
- }+ #' |
|
| 330 | +3 |
- }+ #' Module provides functionality for visualizing the distribution of variables and |
|
| 331 | +4 |
- }+ #' their association with a reference variable. |
|
| 332 | +5 |
-
+ #' It supports configuring the appearance of the plots, including themes and whether to show associations. |
|
| 333 | -! | +||
| 6 | +
- selector_list <- teal.transform::data_extract_multiple_srv(+ #' |
||
| 334 | -! | +||
| 7 | +
- data_extract = data_extract,+ #' |
||
| 335 | -! | +||
| 8 | +
- datasets = data,+ #' @note For more examples, please see the vignette "Using association plot" via |
||
| 336 | -! | +||
| 9 | +
- select_validation_rule = list(+ #' `vignette("using-association-plot", package = "teal.modules.general")`.
|
||
| 337 | -! | +||
| 10 | +
- response = shinyvalidate::sv_required("Please define a column for the response variable"),
+ #' |
||
| 338 | -! | +||
| 11 | +
- x = shinyvalidate::sv_required("Please define a column for X variable"),
+ #' @inheritParams teal::module |
||
| 339 | -! | +||
| 12 | +
- row_facet = shinyvalidate::compose_rules(+ #' @inheritParams shared_params |
||
| 340 | -! | +||
| 13 | +
- shinyvalidate::sv_optional(),+ #' @param ref (`data_extract_spec` or `list` of multiple `data_extract_spec`) |
||
| 341 | -! | +||
| 14 | +
- ~ if (length(.) > 1) "There must be 1 or no row facetting variable.",+ #' Reference variable, must accepts a `data_extract_spec` with `select_spec(multiple = FALSE)` |
||
| 342 | -! | +||
| 15 | +
- rule_diff("col_facet")
+ #' to ensure single selection option. |
||
| 343 | +16 |
- ),+ #' @param vars (`data_extract_spec` or `list` of multiple `data_extract_spec`) |
|
| 344 | -! | +||
| 17 | +
- col_facet = shinyvalidate::compose_rules(+ #' Variables to be associated with the reference variable. |
||
| 345 | -! | +||
| 18 | +
- shinyvalidate::sv_optional(),+ #' @param show_association (`logical`) optional, whether show association of `vars` |
||
| 346 | -! | +||
| 19 | +
- ~ if (length(.) > 1) "There must be 1 or no column facetting variable.",+ #' with reference variable. Defaults to `TRUE`. |
||
| 347 | -! | +||
| 20 | +
- rule_diff("row_facet")
+ #' @param distribution_theme,association_theme (`character`) optional, `ggplot2` themes to be used by default. |
||
| 348 | +21 |
- )+ #' Default to `"gray"`. |
|
| 349 | +22 |
- )+ #' |
|
| 350 | +23 |
- )+ #' @templateVar ggnames "Bivariate1", "Bivariate2" |
|
| 351 | +24 |
-
+ #' @template ggplot2_args_multi |
|
| 352 | -! | +||
| 25 | +
- iv_r <- reactive({
+ #' |
||
| 353 | -! | +||
| 26 | +
- iv <- shinyvalidate::InputValidator$new()+ #' @inherit shared_params return |
||
| 354 | -! | +||
| 27 | +
- iv$add_rule("ggtheme", shinyvalidate::sv_required("Please select a theme"))
+ #' |
||
| 355 | -! | +||
| 28 | +
- teal.transform::compose_and_enable_validators(iv, selector_list)+ #' @examples |
||
| 356 | +29 |
- })+ #' library(teal.widgets) |
|
| 357 | +30 |
-
+ #' |
|
| 358 | -! | +||
| 31 | +
- anl_merged_input <- teal.transform::merge_expression_srv(+ #' # general data example |
||
| 359 | -! | +||
| 32 | +
- selector_list = selector_list,+ #' data <- teal_data() |
||
| 360 | -! | +||
| 33 | +
- datasets = data+ #' data <- within(data, {
|
||
| 361 | +34 |
- )+ #' require(nestcolor) |
|
| 362 | +35 |
-
+ #' CO2 <- CO2 |
|
| 363 | -! | +||
| 36 | +
- anl_merged_q <- reactive({
+ #' factors <- names(Filter(isTRUE, vapply(CO2, is.factor, logical(1L)))) |
||
| 364 | -! | +||
| 37 | +
- req(anl_merged_input())+ #' CO2[factors] <- lapply(CO2[factors], as.character) |
||
| 365 | -! | +||
| 38 | +
- data() %>%+ #' }) |
||
| 366 | -! | +||
| 39 | +
- teal.code::eval_code(as.expression(anl_merged_input()$expr))+ #' datanames(data) <- c("CO2")
|
||
| 367 | +40 |
- })+ #' |
|
| 368 | +41 |
-
+ #' app <- init( |
|
| 369 | -! | +||
| 42 | +
- merged <- list(+ #' data = data, |
||
| 370 | -! | +||
| 43 | +
- anl_input_r = anl_merged_input,+ #' modules = modules( |
||
| 371 | -! | +||
| 44 | +
- anl_q_r = anl_merged_q+ #' tm_g_association( |
||
| 372 | +45 |
- )+ #' ref = data_extract_spec( |
|
| 373 | +46 |
-
+ #' dataname = "CO2", |
|
| 374 | -! | +||
| 47 | +
- output_q <- reactive({
+ #' select = select_spec( |
||
| 375 | -! | +||
| 48 | +
- teal::validate_inputs(iv_r())+ #' label = "Select variable:", |
||
| 376 | +49 |
-
+ #' choices = variable_choices(data[["CO2"]], c("Plant", "Type", "Treatment")),
|
|
| 377 | -! | +||
| 50 | +
- qenv <- merged$anl_q_r()+ #' selected = "Plant", |
||
| 378 | -! | +||
| 51 | +
- ANL <- qenv[["ANL"]]+ #' fixed = FALSE |
||
| 379 | -! | +||
| 52 | ++ |
+ #' )+ |
+ |
| 53 | ++ |
+ #' ),+ |
+ |
| 54 | ++ |
+ #' vars = data_extract_spec(+ |
+ |
| 55 | ++ |
+ #' dataname = "CO2",+ |
+ |
| 56 | ++ |
+ #' select = select_spec(+ |
+ |
| 57 | +
- resp_var <- as.vector(merged$anl_input_r()$columns_source$response)+ #' label = "Select variables:", |
||
| 380 | -! | +||
| 58 | +
- x <- as.vector(merged$anl_input_r()$columns_source$x)+ #' choices = variable_choices(data[["CO2"]], c("Plant", "Type", "Treatment")),
|
||
| 381 | +59 |
-
+ #' selected = "Treatment", |
|
| 382 | -! | +||
| 60 | +
- validate(need(is.factor(ANL[[resp_var]]), "Please select a factor variable as the response."))+ #' multiple = TRUE, |
||
| 383 | -! | +||
| 61 | +
- validate(need(is.factor(ANL[[x]]), "Please select a factor variable as the X-Variable."))+ #' fixed = FALSE |
||
| 384 | -! | +||
| 62 | +
- teal::validate_has_data(ANL, 10)+ #' ) |
||
| 385 | -! | +||
| 63 | +
- teal::validate_has_data(ANL[, c(resp_var, x)], 10, complete = TRUE, allow_inf = FALSE)+ #' ), |
||
| 386 | +64 |
-
+ #' ggplot2_args = ggplot2_args( |
|
| 387 | -! | +||
| 65 | +
- row_facet_name <- if (length(merged$anl_input_r()$columns_source$row_facet) == 0) {
+ #' labs = list(subtitle = "Plot generated by Association Module") |
||
| 388 | -! | +||
| 66 | +
- character(0)+ #' ) |
||
| 389 | +67 |
- } else {
+ #' ) |
|
| 390 | -! | +||
| 68 | +
- as.vector(merged$anl_input_r()$columns_source$row_facet)+ #' ) |
||
| 391 | +69 |
- }+ #' ) |
|
| 392 | -! | +||
| 70 | +
- col_facet_name <- if (length(merged$anl_input_r()$columns_source$col_facet) == 0) {
+ #' if (interactive()) {
|
||
| 393 | -! | +||
| 71 | +
- character(0)+ #' shinyApp(app$ui, app$server) |
||
| 394 | +72 |
- } else {
+ #' } |
|
| 395 | -! | +||
| 73 | +
- as.vector(merged$anl_input_r()$columns_source$col_facet)+ #' |
||
| 396 | +74 |
- }+ #' # CDISC data example |
|
| 397 | +75 |
-
+ #' data <- teal_data() |
|
| 398 | -! | +||
| 76 | +
- freq <- input$freq == "frequency"+ #' data <- within(data, {
|
||
| 399 | -! | +||
| 77 | +
- swap_axes <- input$coord_flip+ #' require(nestcolor) |
||
| 400 | -! | +||
| 78 | +
- counts <- input$count_labels+ #' ADSL <- rADSL |
||
| 401 | -! | +||
| 79 | +
- rotate_xaxis_labels <- input$rotate_xaxis_labels+ #' }) |
||
| 402 | -! | +||
| 80 | +
- ggtheme <- input$ggtheme+ #' datanames(data) <- "ADSL" |
||
| 403 | +81 |
-
+ #' join_keys(data) <- default_cdisc_join_keys[datanames(data)] |
|
| 404 | -! | +||
| 82 | +
- arg_position <- if (freq) "stack" else "fill"+ #' |
||
| 405 | +83 |
-
+ #' app <- init( |
|
| 406 | -! | +||
| 84 | +
- rowf <- if (length(row_facet_name) != 0) as.name(row_facet_name)+ #' data = data, |
||
| 407 | -! | +||
| 85 | +
- colf <- if (length(col_facet_name) != 0) as.name(col_facet_name)+ #' modules = modules( |
||
| 408 | -! | +||
| 86 | +
- resp_cl <- as.name(resp_var)+ #' tm_g_association( |
||
| 409 | -! | +||
| 87 | +
- x_cl <- as.name(x)+ #' ref = data_extract_spec( |
||
| 410 | +88 |
-
+ #' dataname = "ADSL", |
|
| 411 | -! | +||
| 89 | +
- if (swap_axes) {
+ #' select = select_spec( |
||
| 412 | -! | +||
| 90 | +
- qenv <- teal.code::eval_code(+ #' label = "Select variable:", |
||
| 413 | -! | +||
| 91 | +
- qenv,+ #' choices = variable_choices( |
||
| 414 | -! | +||
| 92 | +
- substitute(+ #' data[["ADSL"]], |
||
| 415 | -! | +||
| 93 | +
- expr = ANL[[x]] <- with(ANL, forcats::fct_rev(x_cl)),+ #' c("SEX", "RACE", "COUNTRY", "ARM", "STRATA1", "STRATA2", "ITTFL", "BMRKR2")
|
||
| 416 | -! | +||
| 94 | +
- env = list(x = x, x_cl = x_cl)+ #' ), |
||
| 417 | +95 |
- )+ #' selected = "RACE", |
|
| 418 | +96 |
- )+ #' fixed = FALSE |
|
| 419 | +97 |
- }+ #' ) |
|
| 420 | +98 |
-
+ #' ), |
|
| 421 | -! | +||
| 99 | +
- qenv <- teal.code::eval_code(+ #' vars = data_extract_spec( |
||
| 422 | -! | +||
| 100 | +
- qenv,+ #' dataname = "ADSL", |
||
| 423 | -! | +||
| 101 | +
- substitute(+ #' select = select_spec( |
||
| 424 | -! | +||
| 102 | +
- expr = ANL[[resp_var]] <- factor(ANL[[resp_var]]),+ #' label = "Select variables:", |
||
| 425 | -! | +||
| 103 | +
- env = list(resp_var = resp_var)+ #' choices = variable_choices( |
||
| 426 | +104 |
- )+ #' data[["ADSL"]], |
|
| 427 | +105 |
- ) %>%+ #' c("SEX", "RACE", "COUNTRY", "ARM", "STRATA1", "STRATA2", "ITTFL", "BMRKR2")
|
|
| 428 | +106 |
- # rowf and colf will be a NULL if not set by a user+ #' ), |
|
| 429 | -! | +||
| 107 | +
- teal.code::eval_code(+ #' selected = "BMRKR2", |
||
| 430 | -! | +||
| 108 | +
- substitute(+ #' multiple = TRUE, |
||
| 431 | -! | +||
| 109 | +
- expr = ANL2 <- ANL %>%+ #' fixed = FALSE |
||
| 432 | -! | +||
| 110 | +
- dplyr::group_by_at(dplyr::vars(x_cl, resp_cl, rowf, colf)) %>%+ #' ) |
||
| 433 | -! | +||
| 111 | +
- dplyr::summarise(ns = dplyr::n()) %>%+ #' ), |
||
| 434 | -! | +||
| 112 | +
- dplyr::group_by_at(dplyr::vars(x_cl, rowf, colf)) %>%+ #' ggplot2_args = ggplot2_args( |
||
| 435 | -! | +||
| 113 | +
- dplyr::mutate(sums = sum(ns), percent = round(ns / sums * 100, 1)),+ #' labs = list(subtitle = "Plot generated by Association Module") |
||
| 436 | -! | +||
| 114 | +
- env = list(x_cl = x_cl, resp_cl = resp_cl, rowf = rowf, colf = colf)+ #' ) |
||
| 437 | +115 |
- )+ #' ) |
|
| 438 | +116 |
- ) %>%+ #' ) |
|
| 439 | -! | +||
| 117 | +
- teal.code::eval_code(+ #' ) |
||
| 440 | -! | +||
| 118 | +
- substitute(+ #' if (interactive()) {
|
||
| 441 | -! | +||
| 119 | +
- expr = ANL3 <- ANL %>%+ #' shinyApp(app$ui, app$server) |
||
| 442 | -! | +||
| 120 | +
- dplyr::group_by_at(dplyr::vars(x_cl, rowf, colf)) %>%+ #' } |
||
| 443 | -! | +||
| 121 | +
- dplyr::summarise(ns = dplyr::n()),+ #' |
||
| 444 | -! | +||
| 122 | +
- env = list(x_cl = x_cl, rowf = rowf, colf = colf)+ #' @export |
||
| 445 | +123 |
- )+ #' |
|
| 446 | +124 |
- )+ tm_g_association <- function(label = "Association", |
|
| 447 | +125 |
-
+ ref, |
|
| 448 | -! | +||
| 126 | +
- plot_call <- substitute(+ vars, |
||
| 449 | -! | +||
| 127 | +
- expr = ggplot(ANL2, aes(x = x_cl, y = ns)) ++ show_association = TRUE, |
||
| 450 | -! | +||
| 128 | +
- geom_bar(aes(fill = resp_cl), stat = "identity", position = arg_position),+ plot_height = c(600, 400, 5000), |
||
| 451 | -! | +||
| 129 | +
- env = list(+ plot_width = NULL, |
||
| 452 | -! | +||
| 130 | +
- x_cl = x_cl,+ distribution_theme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void"), # nolint: line_length.
|
||
| 453 | -! | +||
| 131 | +
- resp_cl = resp_cl,+ association_theme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void"), # nolint: line_length.
|
||
| 454 | -! | +||
| 132 | +
- arg_position = arg_position+ pre_output = NULL, |
||
| 455 | +133 |
- )+ post_output = NULL, |
|
| 456 | +134 |
- )+ ggplot2_args = teal.widgets::ggplot2_args()) {
+ |
+ |
| 135 | +! | +
+ message("Initializing tm_g_association")
|
|
| 457 | +136 | ||
| 458 | -! | +||
| 137 | +
- if (!freq) {
+ # Normalize the parameters |
||
| 459 | +138 | ! |
- plot_call <- substitute(+ if (inherits(ref, "data_extract_spec")) ref <- list(ref) |
| 460 | +139 | ! |
- plot_call + expand_limits(y = c(0, 1.1)),+ if (inherits(vars, "data_extract_spec")) vars <- list(vars) |
| 461 | +140 | ! |
- env = list(plot_call = plot_call)+ if (inherits(ggplot2_args, "ggplot2_args")) ggplot2_args <- list(default = ggplot2_args) |
| 462 | +141 |
- )+ |
|
| 463 | +142 |
- }+ # Start of assertions+ |
+ |
| 143 | +! | +
+ checkmate::assert_string(label) |
|
| 464 | +144 | ||
| 465 | +145 | ! |
- if (counts) {
+ checkmate::assert_list(ref, types = "data_extract_spec") |
| 466 | +146 | ! |
- plot_call <- substitute(+ if (!all(vapply(ref, function(x) !x$select$multiple, logical(1)))) {
|
| 467 | +147 | ! |
- expr = plot_call ++ stop("'ref' should not allow multiple selection")
|
| 468 | -! | +||
| 148 | +
- geom_text(+ } |
||
| 469 | -! | +||
| 149 | +
- data = ANL2,+ |
||
| 470 | +150 | ! |
- aes(label = ns, x = x_cl, y = ns, group = resp_cl),+ checkmate::assert_list(vars, types = "data_extract_spec") |
| 471 | +151 | ! |
- col = "white",+ checkmate::assert_flag(show_association) |
| 472 | -! | +||
| 152 | +
- vjust = "middle",+ |
||
| 473 | +153 | ! |
- hjust = "middle",+ checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE) |
| 474 | +154 | ! |
- position = position_anl2_value- |
-
| 475 | -- |
- ) ++ checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height") |
|
| 476 | +155 | ! |
- geom_text(+ checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE) |
| 477 | +156 | ! |
- data = ANL3, aes(label = ns, x = x_cl, y = anl3_y),+ checkmate::assert_numeric( |
| 478 | +157 | ! |
- hjust = hjust_value,+ plot_width[1], |
| 479 | +158 | ! |
- vjust = vjust_value,+ lower = plot_width[2], upper = plot_width[3], null.ok = TRUE, .var.name = "plot_width" |
| 480 | -! | +||
| 159 | +
- position = position_anl3_value+ ) |
||
| 481 | +160 |
- ),+ |
|
| 482 | +161 | ! |
- env = list(+ distribution_theme <- match.arg(distribution_theme) |
| 483 | +162 | ! |
- plot_call = plot_call,+ association_theme <- match.arg(association_theme) |
| 484 | -! | +||
| 163 | +
- x_cl = x_cl,+ |
||
| 485 | +164 | ! |
- resp_cl = resp_cl,+ checkmate::assert_multi_class(pre_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
|
| 486 | +165 | ! |
- hjust_value = if (swap_axes) "left" else "middle",+ checkmate::assert_multi_class(post_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
|
| 487 | -! | +||
| 166 | +
- vjust_value = if (swap_axes) "middle" else -1,+ |
||
| 488 | +167 | ! |
- position_anl2_value = if (!freq) quote(position_fill(0.5)) else quote(position_stack(0.5)), # nolint: line_length.+ plot_choices <- c("Bivariate1", "Bivariate2")
|
| 489 | +168 | ! |
- anl3_y = if (!freq) 1.1 else as.name("ns"),
+ checkmate::assert_list(ggplot2_args, types = "ggplot2_args") |
| 490 | +169 | ! |
- position_anl3_value = if (!freq) "fill" else "stack"+ checkmate::assert_subset(names(ggplot2_args), c("default", plot_choices))
|
| 491 | +170 |
- )+ # End of assertions |
|
| 492 | +171 |
- )+ |
|
| 493 | +172 |
- }+ # Make UI args+ |
+ |
| 173 | +! | +
+ args <- as.list(environment()) |
|
| 494 | +174 | ||
| 495 | +175 | ! |
- if (swap_axes) {
+ data_extract_list <- list( |
| 496 | +176 | ! |
- plot_call <- substitute(plot_call + coord_flip(), env = list(plot_call = plot_call))+ ref = ref, |
| 497 | -+ | ||
| 177 | +! |
- }+ vars = vars |
|
| 498 | +178 | - - | -|
| 499 | -! | -
- facet_cl <- facet_ggplot_call(row_facet_name, col_facet_name)+ ) |
|
| 500 | +179 | ||
| 501 | +180 | ! |
- if (!is.null(facet_cl)) {
+ ans <- module( |
| 502 | +181 | ! |
- plot_call <- substitute(expr = plot_call + facet_cl, env = list(plot_call = plot_call, facet_cl = facet_cl))- |
-
| 503 | -- |
- }+ label = label, |
|
| 504 | -+ | ||
| 182 | +! |
-
+ server = srv_tm_g_association, |
|
| 505 | +183 | ! |
- dev_ggplot2_args <- teal.widgets::ggplot2_args(+ ui = ui_tm_g_association, |
| 506 | +184 | ! |
- labs = list(+ ui_args = args, |
| 507 | +185 | ! |
- x = varname_w_label(x, ANL),+ server_args = c( |
| 508 | +186 | ! |
- y = varname_w_label(resp_var, ANL, prefix = "Proportion of "),+ data_extract_list, |
| 509 | +187 | ! |
- fill = varname_w_label(resp_var, ANL)+ list(plot_height = plot_height, plot_width = plot_width, ggplot2_args = ggplot2_args) |
| 510 | +188 |
- ),+ ), |
|
| 511 | +189 | ! |
- theme = list(legend.position = "bottom")- |
-
| 512 | -- |
- )+ datanames = teal.transform::get_extract_datanames(data_extract_list) |
|
| 513 | +190 |
-
+ ) |
|
| 514 | +191 | ! |
- if (rotate_xaxis_labels) {
+ attr(ans, "teal_bookmarkable") <- TRUE |
| 515 | +192 | ! |
- dev_ggplot2_args$theme[["axis.text.x"]] <- quote(element_text(angle = 45, hjust = 1))+ ans |
| 516 | +193 |
- }+ } |
|
| 517 | +194 | ||
| 195 | ++ |
+ # UI function for the association module+ |
+ |
| 196 | ++ |
+ ui_tm_g_association <- function(id, ...) {
+ |
+ |
| 518 | +197 | ! |
- all_ggplot2_args <- teal.widgets::resolve_ggplot2_args(+ ns <- NS(id) |
| 519 | +198 | ! |
- user_plot = ggplot2_args,+ args <- list(...) |
| 520 | +199 | ! |
- module_plot = dev_ggplot2_args+ is_single_dataset_value <- teal.transform::is_single_dataset(args$ref, args$vars) |
| 521 | +200 |
- )+ |
|
| 522 | -+ | ||
| 201 | +! |
-
+ teal.widgets::standard_layout( |
|
| 523 | +202 | ! |
- parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(+ output = teal.widgets::white_small_well( |
| 524 | +203 | ! |
- all_ggplot2_args,+ textOutput(ns("title")),
|
| 525 | +204 | ! |
- ggtheme = ggtheme+ tags$br(), |
| 526 | -+ | ||
| 205 | +! |
- )+ teal.widgets::plot_with_settings_ui(id = ns("myplot"))
|
|
| 527 | +206 |
-
+ ), |
|
| 528 | +207 | ! |
- plot_call <- substitute(expr = {
+ encoding = tags$div( |
| 529 | -! | +||
| 208 | +
- p <- plot_call + labs + ggthemes + themes+ ### Reporter |
||
| 530 | +209 | ! |
- print(p)+ teal.reporter::simple_reporter_ui(ns("simple_reporter")),
|
| 531 | -! | +||
| 210 | +
- }, env = list(+ ### |
||
| 532 | +211 | ! |
- plot_call = plot_call,+ tags$label("Encodings", class = "text-primary"),
|
| 533 | +212 | ! |
- labs = parsed_ggplot2_args$labs,+ teal.transform::datanames_input(args[c("ref", "vars")]),
|
| 534 | +213 | ! |
- themes = parsed_ggplot2_args$theme,+ teal.transform::data_extract_ui( |
| 535 | +214 | ! |
- ggthemes = parsed_ggplot2_args$ggtheme+ id = ns("ref"),
|
| 536 | -+ | ||
| 215 | +! |
- ))+ label = "Reference variable", |
|
| 537 | -+ | ||
| 216 | +! |
-
+ data_extract_spec = args$ref, |
|
| 538 | +217 | ! |
- teal.code::eval_code(qenv, plot_call)+ is_single_dataset = is_single_dataset_value |
| 539 | +218 |
- })+ ), |
|
| 540 | -+ | ||
| 219 | +! |
-
+ teal.transform::data_extract_ui( |
|
| 541 | +220 | ! |
- plot_r <- reactive(output_q()[["p"]])+ id = ns("vars"),
|
| 542 | -+ | ||
| 221 | +! |
-
+ label = "Associated variables", |
|
| 543 | -+ | ||
| 222 | +! |
- # Insert the plot into a plot_with_settings module from teal.widgets+ data_extract_spec = args$vars, |
|
| 544 | +223 | ! |
- pws <- teal.widgets::plot_with_settings_srv(+ is_single_dataset = is_single_dataset_value |
| 545 | -! | +||
| 224 | +
- id = "myplot",+ ), |
||
| 546 | +225 | ! |
- plot_r = plot_r,+ checkboxInput( |
| 547 | +226 | ! |
- height = plot_height,+ ns("association"),
|
| 548 | +227 | ! |
- width = plot_width+ "Association with reference variable", |
| 549 | -+ | ||
| 228 | +! |
- )+ value = args$show_association |
|
| 550 | +229 |
-
+ ), |
|
| 551 | +230 | ! |
- teal.widgets::verbatim_popup_srv(+ checkboxInput( |
| 552 | +231 | ! |
- id = "rcode",+ ns("show_dist"),
|
| 553 | +232 | ! |
- verbatim_content = reactive(teal.code::get_code(output_q())),+ "Scaled frequencies", |
| 554 | +233 | ! |
- title = "Show R Code for Response"+ value = FALSE |
| 555 | +234 |
- )+ ), |
|
| 556 | -+ | ||
| 235 | +! |
-
+ checkboxInput( |
|
| 557 | -+ | ||
| 236 | +! |
- ### REPORTER+ ns("log_transformation"),
|
|
| 558 | +237 | ! |
- if (with_reporter) {
+ "Log transformed", |
| 559 | +238 | ! |
- card_fun <- function(comment, label) {
+ value = FALSE |
| 560 | -! | +||
| 239 | +
- card <- teal::report_card_template(+ ), |
||
| 561 | +240 | ! |
- title = "Response Plot",+ teal.widgets::panel_group( |
| 562 | +241 | ! |
- label = label,+ teal.widgets::panel_item( |
| 563 | +242 | ! |
- with_filter = with_filter,+ title = "Plot settings", |
| 564 | +243 | ! |
- filter_panel_api = filter_panel_api+ teal.widgets::optionalSliderInputValMinMax(ns("alpha"), "Scatterplot opacity:", c(0.5, 0, 1), ticks = FALSE),
|
| 565 | -+ | ||
| 244 | +! |
- )+ teal.widgets::optionalSliderInputValMinMax(ns("size"), "Scatterplot points size:", c(2, 1, 8), ticks = FALSE),
|
|
| 566 | +245 | ! |
- card$append_text("Plot", "header3")
+ checkboxInput(ns("swap_axes"), "Swap axes", value = FALSE),
|
| 567 | +246 | ! |
- card$append_plot(plot_r(), dim = pws$dim())+ checkboxInput(ns("rotate_xaxis_labels"), "Rotate X axis labels", value = FALSE),
|
| 568 | +247 | ! |
- if (!comment == "") {
+ selectInput( |
| 569 | +248 | ! |
- card$append_text("Comment", "header3")
+ inputId = ns("distribution_theme"),
|
| 570 | +249 | ! |
- card$append_text(comment)+ label = "Distribution theme (by ggplot):", |
| 571 | -+ | ||
| 250 | +! |
- }+ choices = ggplot_themes, |
|
| 572 | +251 | ! |
- card$append_src(teal.code::get_code(output_q()))+ selected = args$distribution_theme, |
| 573 | +252 | ! |
- card+ multiple = FALSE |
| 574 | +253 |
- }+ ), |
|
| 575 | +254 | ! |
- teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
+ selectInput( |
| 576 | -+ | ||
| 255 | +! |
- }+ inputId = ns("association_theme"),
|
|
| 577 | -+ | ||
| 256 | +! |
- ###+ label = "Association theme (by ggplot):", |
|
| 578 | -+ | ||
| 257 | +! |
- })+ choices = ggplot_themes, |
|
| 579 | -+ | ||
| 258 | +! |
- }+ selected = args$association_theme, |
| 1 | -+ | ||
| 259 | +! |
- #' Shared parameters documentation+ multiple = FALSE |
|
| 2 | +260 |
- #'+ ) |
|
| 3 | +261 |
- #' Defines common arguments shared across multiple functions in the package+ ) |
|
| 4 | +262 |
- #' to avoid repetition by using `inheritParams`.+ ) |
|
| 5 | +263 |
- #'+ ), |
|
| 6 | -+ | ||
| 264 | +! |
- #' @param plot_height (`numeric`) optional, specifies the plot height as a three-element vector of+ forms = tagList( |
|
| 7 | -+ | ||
| 265 | +! |
- #' `value`, `min`, and `max` intended for use with a slider UI element.+ teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code")
|
|
| 8 | +266 |
- #' @param plot_width (`numeric`) optional, specifies the plot width as a three-element vector of+ ), |
|
| 9 | -+ | ||
| 267 | +! |
- #' `value`, `min`, and `max` for a slider encoding the plot width.+ pre_output = args$pre_output, |
|
| 10 | -+ | ||
| 268 | +! |
- #' @param rotate_xaxis_labels (`logical`) optional, whether to rotate plot X axis labels. Does not+ post_output = args$post_output |
|
| 11 | +269 |
- #' rotate by default (`FALSE`).+ ) |
|
| 12 | +270 |
- #' @param ggtheme (`character`) optional, `ggplot2` theme to be used by default. Defaults to `"gray"`.+ } |
|
| 13 | +271 |
- #' @param ggplot2_args (`ggplot2_args`) object created by [teal.widgets::ggplot2_args()]+ |
|
| 14 | +272 |
- #' with settings for the module plot.+ # Server function for the association module |
|
| 15 | +273 |
- #' The argument is merged with options variable `teal.ggplot2_args` and default module setup.+ srv_tm_g_association <- function(id, |
|
| 16 | +274 |
- #'+ data, |
|
| 17 | +275 |
- #' For more details see the vignette: `vignette("custom-ggplot2-arguments", package = "teal.widgets")`
+ reporter, |
|
| 18 | +276 |
- #' @param basic_table_args (`basic_table_args`) object created by [teal.widgets::basic_table_args()]+ filter_panel_api, |
|
| 19 | +277 |
- #' with settings for the module table.+ ref, |
|
| 20 | +278 |
- #' The argument is merged with options variable `teal.basic_table_args` and default module setup.+ vars, |
|
| 21 | +279 |
- #'+ plot_height, |
|
| 22 | +280 |
- #' For more details see the vignette: `vignette("custom-basic-table-arguments", package = "teal.widgets")`
+ plot_width, |
|
| 23 | +281 |
- #' @param pre_output (`shiny.tag`) optional, text or UI element to be displayed before the module's output,+ ggplot2_args) {
|
|
| 24 | -+ | ||
| 282 | +! |
- #' providing context or a title.+ with_reporter <- !missing(reporter) && inherits(reporter, "Reporter") |
|
| 25 | -+ | ||
| 283 | +! |
- #' with text placed before the output to put the output into context. For example a title.+ with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI") |
|
| 26 | -+ | ||
| 284 | +! |
- #' @param post_output (`shiny.tag`) optional, text or UI element to be displayed after the module's output,+ checkmate::assert_class(data, "reactive") |
|
| 27 | -+ | ||
| 285 | +! |
- #' adding context or further instructions. Elements like `shiny::helpText()` are useful.+ checkmate::assert_class(isolate(data()), "teal_data") |
|
| 28 | +286 |
- #'+ |
|
| 29 | -+ | ||
| 287 | +! |
- #' @param alpha (`integer(1)` or `integer(3)`) optional, specifies point opacity.+ moduleServer(id, function(input, output, session) {
|
|
| 30 | -+ | ||
| 288 | +! |
- #' - When the length of `alpha` is one: the plot points will have a fixed opacity.+ teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.general") |
|
| 31 | +289 |
- #' - When the length of `alpha` is three: the plot points opacity are dynamically adjusted based on+ |
|
| 32 | -+ | ||
| 290 | +! |
- #' vector of `value`, `min`, and `max`.+ selector_list <- teal.transform::data_extract_multiple_srv( |
|
| 33 | -+ | ||
| 291 | +! |
- #' @param size (`integer(1)` or `integer(3)`) optional, specifies point size.+ data_extract = list(ref = ref, vars = vars), |
|
| 34 | -+ | ||
| 292 | +! |
- #' - When the length of `size` is one: the plot point sizes will have a fixed size.+ datasets = data, |
|
| 35 | -+ | ||
| 293 | +! |
- #' - When the length of `size` is three: the plot points size are dynamically adjusted based on+ select_validation_rule = list( |
|
| 36 | -+ | ||
| 294 | +! |
- #' vector of `value`, `min`, and `max`.+ ref = shinyvalidate::compose_rules( |
|
| 37 | -+ | ||
| 295 | +! |
- #'+ shinyvalidate::sv_required("A reference variable needs to be selected."),
|
|
| 38 | -+ | ||
| 296 | +! |
- #' @return Object of class `teal_module` to be used in `teal` applications.+ ~ if ((.) %in% selector_list()$vars()$select) {
|
|
| 39 | -+ | ||
| 297 | +! |
- #'+ "Associated variables and reference variable cannot overlap" |
|
| 40 | +298 |
- #' @name shared_params+ } |
|
| 41 | +299 |
- #' @keywords internal+ ), |
|
| 42 | -+ | ||
| 300 | +! |
- NULL+ vars = shinyvalidate::compose_rules( |
|
| 43 | -+ | ||
| 301 | +! |
-
+ shinyvalidate::sv_required("An associated variable needs to be selected."),
|
|
| 44 | -+ | ||
| 302 | +! |
- #' Add labels for facets to a `ggplot2` object+ ~ if (length(selector_list()$ref()$select) != 0 && selector_list()$ref()$select %in% (.)) {
|
|
| 45 | -+ | ||
| 303 | +! |
- #'+ "Associated variables and reference variable cannot overlap" |
|
| 46 | +304 |
- #' Enhances a `ggplot2` plot by adding labels that describe+ } |
|
| 47 | +305 |
- #' the faceting variables along the x and y axes.+ ) |
|
| 48 | +306 |
- #'+ ) |
|
| 49 | +307 |
- #' @param p (`ggplot2`) object to which facet labels will be added.+ ) |
|
| 50 | +308 |
- #' @param xfacet_label (`character`) Label for the facet along the x-axis.+ |
|
| 51 | -+ | ||
| 309 | +! |
- #' If `NULL`, no label is added. If a vector, labels are joined with " & ".+ iv_r <- reactive({
|
|
| 52 | -+ | ||
| 310 | +! |
- #' @param yfacet_label (`character`) Label for the facet along the y-axis.+ iv <- shinyvalidate::InputValidator$new() |
|
| 53 | -+ | ||
| 311 | +! |
- #' Similar behavior to `xfacet_label`.+ teal.transform::compose_and_enable_validators(iv, selector_list) |
|
| 54 | +312 |
- #'+ }) |
|
| 55 | +313 |
- #' @return Returns `grid` or `grob` object (to be drawn with `grid.draw`)+ |
|
| 56 | -+ | ||
| 314 | +! |
- #'+ anl_merged_input <- teal.transform::merge_expression_srv( |
|
| 57 | -+ | ||
| 315 | +! |
- #' @examples+ datasets = data, |
|
| 58 | -+ | ||
| 316 | +! |
- #' library(ggplot2)+ selector_list = selector_list |
|
| 59 | +317 |
- #' library(grid)+ ) |
|
| 60 | +318 |
- #'+ |
|
| 61 | -+ | ||
| 319 | +! |
- #' p <- ggplot(mtcars) ++ anl_merged_q <- reactive({
|
|
| 62 | -+ | ||
| 320 | +! |
- #' aes(x = mpg, y = disp) ++ req(anl_merged_input()) |
|
| 63 | -+ | ||
| 321 | +! |
- #' geom_point() ++ data() %>% teal.code::eval_code(as.expression(anl_merged_input()$expr)) |
|
| 64 | +322 |
- #' facet_grid(gear ~ cyl)+ }) |
|
| 65 | +323 |
- #'+ |
|
| 66 | -+ | ||
| 324 | +! |
- #' xfacet_label <- "cylinders"+ merged <- list( |
|
| 67 | -+ | ||
| 325 | +! |
- #' yfacet_label <- "gear"+ anl_input_r = anl_merged_input, |
|
| 68 | -+ | ||
| 326 | +! |
- #' res <- add_facet_labels(p, xfacet_label, yfacet_label)+ anl_q_r = anl_merged_q |
|
| 69 | +327 |
- #' grid.newpage()+ ) |
|
| 70 | +328 |
- #' grid.draw(res)+ |
|
| 71 | -+ | ||
| 329 | +! |
- #'+ output_q <- reactive({
|
|
| 72 | -+ | ||
| 330 | +! |
- #' grid.newpage()+ teal::validate_inputs(iv_r()) |
|
| 73 | +331 |
- #' grid.draw(add_facet_labels(p, xfacet_label = NULL, yfacet_label))+ |
|
| 74 | -+ | ||
| 332 | +! |
- #' grid.newpage()+ ANL <- merged$anl_q_r()[["ANL"]] |
|
| 75 | -+ | ||
| 333 | +! |
- #' grid.draw(add_facet_labels(p, xfacet_label, yfacet_label = NULL))+ teal::validate_has_data(ANL, 3) |
|
| 76 | +334 |
- #' grid.newpage()+ |
|
| 77 | -+ | ||
| 335 | +! |
- #' grid.draw(add_facet_labels(p, xfacet_label = NULL, yfacet_label = NULL))+ vars_names <- merged$anl_input_r()$columns_source$vars |
|
| 78 | +336 |
- #'+ |
|
| 79 | -+ | ||
| 337 | +! |
- #' @export+ ref_name <- as.vector(merged$anl_input_r()$columns_source$ref) |
|
| 80 | -+ | ||
| 338 | +! |
- #'+ association <- input$association |
|
| 81 | -+ | ||
| 339 | +! |
- add_facet_labels <- function(p, xfacet_label = NULL, yfacet_label = NULL) {
+ show_dist <- input$show_dist |
|
| 82 | +340 | ! |
- checkmate::assert_class(p, classes = "ggplot")+ log_transformation <- input$log_transformation |
| 83 | +341 | ! |
- checkmate::assert_character(xfacet_label, null.ok = TRUE, min.len = 1)+ rotate_xaxis_labels <- input$rotate_xaxis_labels |
| 84 | +342 | ! |
- checkmate::assert_character(yfacet_label, null.ok = TRUE, min.len = 1)+ swap_axes <- input$swap_axes |
| 85 | +343 | ! |
- if (is.null(xfacet_label) && is.null(yfacet_label)) {
+ distribution_theme <- input$distribution_theme |
| 86 | +344 | ! |
- return(ggplotGrob(p))+ association_theme <- input$association_theme |
| 87 | +345 |
- }+ |
|
| 88 | +346 | ! |
- grid::grid.grabExpr({
+ is_scatterplot <- is.numeric(ANL[[ref_name]]) && any(vapply(ANL[vars_names], is.numeric, logical(1))) |
| 89 | +347 | ! |
- g <- ggplotGrob(p)+ if (is_scatterplot) {
|
| 90 | -+ | ||
| 348 | +! |
-
+ shinyjs::show("alpha")
|
|
| 91 | -+ | ||
| 349 | +! |
- # we are going to replace these, so we make sure they have nothing in them+ shinyjs::show("size")
|
|
| 92 | +350 | ! |
- checkmate::assert_class(g$grobs[[grep("xlab-t", g$layout$name, fixed = TRUE)]], "zeroGrob")
+ alpha <- input$alpha |
| 93 | +351 | ! |
- checkmate::assert_class(g$grobs[[grep("ylab-r", g$layout$name, fixed = TRUE)]], "zeroGrob")
+ size <- input$size |
| 94 | +352 |
-
+ } else {
|
|
| 95 | +353 | ! |
- xaxis_label_grob <- g$grobs[[grep("xlab-b", g$layout$name, fixed = TRUE)]]
+ shinyjs::hide("alpha")
|
| 96 | +354 | ! |
- xaxis_label_grob$children[[1]]$label <- paste(xfacet_label, collapse = " & ")+ shinyjs::hide("size")
|
| 97 | +355 | ! |
- yaxis_label_grob <- g$grobs[[grep("ylab-l", g$layout$name, fixed = TRUE)]]
+ alpha <- 0.5 |
| 98 | +356 | ! |
- yaxis_label_grob$children[[1]]$label <- paste(yfacet_label, collapse = " & ")+ size <- 2 |
| 99 | -! | +||
| 357 | +
- yaxis_label_grob$children[[1]]$rot <- 270+ } |
||
| 100 | +358 | ||
| 101 | +359 | ! |
- top_height <- if (is.null(xfacet_label)) 0 else grid::unit(2, "line")+ teal::validate_has_data(ANL[, c(ref_name, vars_names)], 3, complete = TRUE, allow_inf = FALSE) |
| 102 | -! | +||
| 360 | +
- right_width <- if (is.null(yfacet_label)) 0 else grid::unit(2, "line")+ |
||
| 103 | +361 |
-
+ # reference |
|
| 104 | +362 | ! |
- grid::grid.newpage()+ ref_class <- class(ANL[[ref_name]])[1] |
| 105 | +363 | ! |
- grid::pushViewport(grid::plotViewport(margins = c(0, 0, top_height, right_width), name = "ggplot"))+ if (is.numeric(ANL[[ref_name]]) && log_transformation) {
+ |
+
| 364 | ++ |
+ # works for both integers and doubles |
|
| 106 | +365 | ! |
- grid::grid.draw(g)+ ref_cl_name <- call("log", as.name(ref_name))
|
| 107 | +366 | ! |
- grid::upViewport(1)+ ref_cl_lbl <- varname_w_label(ref_name, ANL, prefix = "Log of ") |
| 108 | +367 |
-
+ } else {
|
|
| 109 | +368 |
- # draw x facet+ # silently ignore when non-numeric even if `log` is selected because some |
|
| 110 | -! | +||
| 369 | +
- if (!is.null(xfacet_label)) {
+ # variables may be numeric and others not |
||
| 111 | +370 | ! |
- grid::pushViewport(grid::viewport(+ ref_cl_name <- as.name(ref_name) |
| 112 | +371 | ! |
- x = 0, y = grid::unit(1, "npc") - top_height, width = grid::unit(1, "npc"),+ ref_cl_lbl <- varname_w_label(ref_name, ANL) |
| 113 | -! | +||
| 372 | +
- height = top_height, just = c("left", "bottom"), name = "topxaxis"
+ } |
||
| 114 | +373 |
- ))+ |
|
| 115 | +374 | ! |
- grid::grid.draw(xaxis_label_grob)+ user_ggplot2_args <- teal.widgets::resolve_ggplot2_args( |
| 116 | +375 | ! |
- grid::upViewport(1)+ user_plot = ggplot2_args[["Bivariate1"]], |
| 117 | -+ | ||
| 376 | +! |
- }+ user_default = ggplot2_args$default |
|
| 118 | +377 |
-
+ ) |
|
| 119 | +378 |
- # draw y facet+ |
|
| 120 | +379 | ! |
- if (!is.null(yfacet_label)) {
+ ref_call <- bivariate_plot_call( |
| 121 | +380 | ! |
- grid::pushViewport(grid::viewport(+ data_name = "ANL", |
| 122 | +381 | ! |
- x = grid::unit(1, "npc") - grid::unit(as.numeric(right_width) / 2, "line"), y = 0, width = right_width,+ x = ref_cl_name, |
| 123 | +382 | ! |
- height = grid::unit(1, "npc"), just = c("left", "bottom"), name = "rightyaxis"
- |
-
| 124 | -- |
- ))+ x_class = ref_class, |
|
| 125 | +383 | ! |
- grid::grid.draw(yaxis_label_grob)+ x_label = ref_cl_lbl, |
| 126 | +384 | ! |
- grid::upViewport(1)+ freq = !show_dist, |
| 127 | -+ | ||
| 385 | +! |
- }+ theme = distribution_theme, |
|
| 128 | -+ | ||
| 386 | +! |
- })+ rotate_xaxis_labels = rotate_xaxis_labels, |
|
| 129 | -+ | ||
| 387 | +! |
- }+ swap_axes = FALSE, |
|
| 130 | -+ | ||
| 388 | +! |
-
+ size = size, |
|
| 131 | -+ | ||
| 389 | +! |
- #' Call a function with a character vector for the `...` argument+ alpha = alpha, |
|
| 132 | -+ | ||
| 390 | +! |
- #'+ ggplot2_args = user_ggplot2_args |
|
| 133 | +391 |
- #' @param fun (`character`) Name of a function where the `...` argument shall be replaced by values from `str_args`.+ ) |
|
| 134 | +392 |
- #' @param str_args (`character`) A character vector that the function shall be executed with+ |
|
| 135 | +393 |
- #'+ # association |
|
| 136 | -+ | ||
| 394 | +! |
- #' @return+ ref_class_cov <- ifelse(association, ref_class, "NULL") |
|
| 137 | +395 |
- #' Value of call to `fun` with arguments specified in `str_args`.+ |
|
| 138 | -+ | ||
| 396 | +! |
- #'+ print_call <- quote(print(p)) |
|
| 139 | +397 |
- #' @keywords internal+ |
|
| 140 | -+ | ||
| 398 | +! |
- call_fun_dots <- function(fun, str_args) {
+ var_calls <- lapply(vars_names, function(var_i) {
|
|
| 141 | +399 | ! |
- do.call("call", c(list(fun), lapply(str_args, as.name)), quote = TRUE)
+ var_class <- class(ANL[[var_i]])[1] |
| 142 | -+ | ||
| 400 | +! |
- }+ if (is.numeric(ANL[[var_i]]) && log_transformation) {
|
|
| 143 | +401 |
-
+ # works for both integers and doubles |
|
| 144 | -+ | ||
| 402 | +! |
- #' Generate a string for a variable including its label+ var_cl_name <- call("log", as.name(var_i))
|
|
| 145 | -+ | ||
| 403 | +! |
- #'+ var_cl_lbl <- varname_w_label(var_i, ANL, prefix = "Log of ") |
|
| 146 | +404 |
- #' @param var_names (`character`) Name of variable to extract labels from.+ } else {
|
|
| 147 | +405 |
- #' @param dataset (`dataset`) Name of analysis dataset.+ # silently ignore when non-numeric even if `log` is selected because some |
|
| 148 | +406 |
- #' @param prefix,suffix (`character`) String to paste to the beginning/end of the variable name with label.+ # variables may be numeric and others not |
|
| 149 | -+ | ||
| 407 | +! |
- #' @param wrap_width (`numeric`) Number of characters to wrap original label to. Defaults to 80.+ var_cl_name <- as.name(var_i) |
|
| 150 | -+ | ||
| 408 | +! |
- #'+ var_cl_lbl <- varname_w_label(var_i, ANL) |
|
| 151 | +409 |
- #' @return (`character`) String with variable name and label.+ } |
|
| 152 | +410 |
- #'+ |
|
| 153 | -+ | ||
| 411 | +! |
- #' @keywords internal+ user_ggplot2_args <- teal.widgets::resolve_ggplot2_args( |
|
| 154 | -+ | ||
| 412 | +! |
- #'+ user_plot = ggplot2_args[["Bivariate2"]], |
|
| 155 | -+ | ||
| 413 | +! |
- varname_w_label <- function(var_names,+ user_default = ggplot2_args$default |
|
| 156 | +414 |
- dataset,+ ) |
|
| 157 | +415 |
- wrap_width = 80,+ |
|
| 158 | -+ | ||
| 416 | +! |
- prefix = NULL,+ bivariate_plot_call( |
|
| 159 | -+ | ||
| 417 | +! |
- suffix = NULL) {
+ data_name = "ANL", |
|
| 160 | +418 | ! |
- add_label <- function(var_names) {
+ x = ref_cl_name, |
| 161 | +419 | ! |
- label <- vapply(+ y = var_cl_name, |
| 162 | +420 | ! |
- dataset[var_names], function(x) {
+ x_class = ref_class_cov, |
| 163 | +421 | ! |
- attr_label <- attr(x, "label")+ y_class = var_class, |
| 164 | +422 | ! |
- `if`(is.null(attr_label), "", attr_label)+ x_label = ref_cl_lbl, |
| 165 | -+ | ||
| 423 | +! |
- },+ y_label = var_cl_lbl, |
|
| 166 | +424 | ! |
- character(1)+ theme = association_theme, |
| 167 | -+ | ||
| 425 | +! |
- )+ freq = !show_dist, |
|
| 168 | -+ | ||
| 426 | +! |
-
+ rotate_xaxis_labels = rotate_xaxis_labels, |
|
| 169 | +427 | ! |
- if (length(label) == 1 && !is.na(label) && !identical(label, "")) {
+ swap_axes = swap_axes, |
| 170 | +428 | ! |
- paste0(prefix, label, " [", var_names, "]", suffix)+ alpha = alpha, |
| 171 | -+ | ||
| 429 | +! |
- } else {
+ size = size, |
|
| 172 | +430 | ! |
- var_names+ ggplot2_args = user_ggplot2_args |
| 173 | +431 |
- }+ ) |
|
| 174 | +432 |
- }+ }) |
|
| 175 | +433 | ||
| 176 | -! | +||
| 434 | +
- if (length(var_names) < 1) {
+ # helper function to format variable name |
||
| 177 | +435 | ! |
- NULL+ format_varnames <- function(x) {
|
| 178 | +436 | ! |
- } else if (length(var_names) == 1) {
+ if (is.numeric(ANL[[x]]) && log_transformation) {
|
| 179 | +437 | ! |
- stringr::str_wrap(add_label(var_names), width = wrap_width)+ varname_w_label(x, ANL, prefix = "Log of ") |
| 180 | -! | +||
| 438 | +
- } else if (length(var_names) > 1) {
+ } else {
|
||
| 181 | +439 | ! |
- stringr::str_wrap(vapply(var_names, add_label, character(1)), width = wrap_width)+ varname_w_label(x, ANL) |
| 182 | +440 |
- }+ } |
|
| 183 | +441 |
- }+ } |
|
| 184 | -+ | ||
| 442 | +! |
-
+ new_title <- |
|
| 185 | -+ | ||
| 443 | +! |
- # see vignette("ggplot2-specs", package="ggplot2")
+ if (association) {
|
|
| 186 | -+ | ||
| 444 | +! |
- shape_names <- c(+ switch(as.character(length(vars_names)), |
|
| 187 | -+ | ||
| 445 | +! |
- "circle", paste("circle", c("open", "filled", "cross", "plus", "small")), "bullet",
+ "0" = sprintf("Value distribution for %s", ref_cl_lbl),
|
|
| 188 | -+ | ||
| 446 | +! |
- "square", paste("square", c("open", "filled", "cross", "plus", "triangle")),
+ "1" = sprintf( |
|
| 189 | -+ | ||
| 447 | +! |
- "diamond", paste("diamond", c("open", "filled", "plus")),
+ "Association between %s and %s", |
|
| 190 | -+ | ||
| 448 | +! |
- "triangle", paste("triangle", c("open", "filled", "square")),
+ ref_cl_lbl, |
|
| 191 | -+ | ||
| 449 | +! |
- paste("triangle down", c("open", "filled")),
+ format_varnames(vars_names) |
|
| 192 | +450 |
- "plus", "cross", "asterisk"+ ), |
|
| 193 | -+ | ||
| 451 | +! |
- )+ sprintf( |
|
| 194 | -+ | ||
| 452 | +! |
-
+ "Associations between %s and: %s", |
|
| 195 | -+ | ||
| 453 | +! |
- #' Get icons to represent variable types in dataset+ ref_cl_lbl, |
|
| 196 | -+ | ||
| 454 | +! |
- #'+ paste(lapply(vars_names, format_varnames), collapse = ", ") |
|
| 197 | +455 |
- #' @param var_type (`character`) of R internal types (classes).+ ) |
|
| 198 | +456 |
- #' @return (`character`) vector of HTML icons corresponding to data type in each column.+ ) |
|
| 199 | +457 |
- #' @keywords internal+ } else {
|
|
| 200 | -+ | ||
| 458 | +! |
- variable_type_icons <- function(var_type) {
+ switch(as.character(length(vars_names)), |
|
| 201 | +459 | ! |
- checkmate::assert_character(var_type, any.missing = FALSE)+ "0" = sprintf("Value distribution for %s", ref_cl_lbl),
|
| 202 | -+ | ||
| 460 | +! |
-
+ sprintf( |
|
| 203 | +461 | ! |
- class_to_icon <- list(+ "Value distributions for %s and %s", |
| 204 | +462 | ! |
- numeric = "arrow-up-1-9",+ ref_cl_lbl, |
| 205 | +463 | ! |
- integer = "arrow-up-1-9",+ paste(lapply(vars_names, format_varnames), collapse = ", ") |
| 206 | -! | +||
| 464 | +
- logical = "pause",+ ) |
||
| 207 | -! | +||
| 465 | +
- Date = "calendar",+ ) |
||
| 208 | -! | +||
| 466 | +
- POSIXct = "calendar",+ }+ |
+ ||
| 467 | ++ | + | |
| 209 | +468 | ! |
- POSIXlt = "calendar",+ teal.code::eval_code( |
| 210 | +469 | ! |
- factor = "chart-bar",+ merged$anl_q_r(), |
| 211 | +470 | ! |
- character = "keyboard",+ substitute( |
| 212 | +471 | ! |
- primary_key = "key",+ expr = title <- new_title, |
| 213 | +472 | ! |
- unknown = "circle-question"+ env = list(new_title = new_title) |
| 214 | +473 |
- )+ )+ |
+ |
| 474 | ++ |
+ ) %>% |
|
| 215 | +475 | ! |
- class_to_icon <- lapply(class_to_icon, function(icon_name) toString(icon(icon_name, lib = "font-awesome")))+ teal.code::eval_code( |
| 216 | -+ | ||
| 476 | +! |
-
+ substitute( |
|
| 217 | +477 | ! |
- unname(vapply(+ expr = {
|
| 218 | +478 | ! |
- var_type,+ plots <- plot_calls |
| 219 | +479 | ! |
- FUN.VALUE = character(1),+ p <- tern::stack_grobs(grobs = lapply(plots, ggplotGrob)) |
| 220 | +480 | ! |
- FUN = function(class) {
+ grid::grid.newpage() |
| 221 | +481 | ! |
- if (class == "") {
+ grid::grid.draw(p)+ |
+
| 482 | ++ |
+ }, |
|
| 222 | +483 | ! |
- class+ env = list( |
| 223 | +484 | ! |
- } else if (is.null(class_to_icon[[class]])) {
+ plot_calls = do.call( |
| 224 | +485 | ! |
- class_to_icon[["unknown"]]+ "call", |
| 225 | -+ | ||
| 486 | +! |
- } else {
+ c(list("list", ref_call), var_calls),
|
|
| 226 | +487 | ! |
- class_to_icon[[class]]+ quote = TRUE |
| 227 | +488 |
- }+ ) |
|
| 228 | +489 |
- }+ ) |
|
| 229 | +490 |
- ))+ ) |
|
| 230 | +491 |
- }+ ) |
|
| 231 | +492 |
-
+ }) |
|
| 232 | +493 |
- #' Include `CSS` files from `/inst/css/` package directory to application header+ |
|
| 233 | -+ | ||
| 494 | +! |
- #'+ plot_r <- reactive({
|
|
| 234 | -+ | ||
| 495 | +! |
- #' `system.file` should not be used to access files in other packages, it does+ req(iv_r()$is_valid()) |
|
| 235 | -+ | ||
| 496 | +! |
- #' not work with `devtools`. Therefore, we redefine this method in each package+ output_q()[["p"]] |
|
| 236 | +497 |
- #' as needed. Thus, we do not export this method+ }) |
|
| 237 | +498 |
- #'+ |
|
| 238 | -+ | ||
| 499 | +! |
- #' @param pattern (`character`) optional, regular expression to match the file names to be included.+ pws <- teal.widgets::plot_with_settings_srv( |
|
| 239 | -+ | ||
| 500 | +! |
- #'+ id = "myplot", |
|
| 240 | -+ | ||
| 501 | +! | +
+ plot_r = plot_r,+ |
+ |
| 502 | +! |
- #' @return HTML code that includes `CSS` files.+ height = plot_height, |
|
| 241 | -+ | ||
| 503 | +! |
- #' @keywords internal+ width = plot_width |
|
| 242 | +504 |
- #'+ ) |
|
| 243 | +505 |
- include_css_files <- function(pattern = "*") {
+
|
|
| 244 | +506 | ! |
- css_files <- list.files(+ output$title <- renderText({
|
| 245 | +507 | ! |
- system.file("css", package = "teal.modules.general", mustWork = TRUE),
+ teal.code::dev_suppress(output_q()[["title"]]) |
| 246 | -! | +||
| 508 | +
- pattern = pattern, full.names = TRUE+ }) |
||
| 247 | +509 |
- )+ |
|
| 248 | +510 | ! |
- if (length(css_files) == 0) {
+ teal.widgets::verbatim_popup_srv( |
| 249 | +511 | ! |
- return(NULL)+ id = "rcode", |
| 250 | -+ | ||
| 512 | +! |
- }+ verbatim_content = reactive(teal.code::get_code(output_q())), |
|
| 251 | +513 | ! |
- singleton(tags$head(lapply(css_files, includeCSS)))+ title = "Association Plot" |
| 252 | +514 |
- }+ ) |
|
| 253 | +515 | ||
| 254 | -- |
- #' JavaScript condition to check if a specific tab is active- |
- |
| 255 | +516 |
- #'+ ### REPORTER |
|
| 256 | -+ | ||
| 517 | +! |
- #' @param id (`character(1)`) the id of the tab panel with tabs.+ if (with_reporter) {
|
|
| 257 | -+ | ||
| 518 | +! |
- #' @param name (`character(1)`) the name of the tab.+ card_fun <- function(comment, label) {
|
|
| 258 | -+ | ||
| 519 | +! |
- #' @return JavaScript expression to be used in `shiny::conditionalPanel()` to determine+ card <- teal::report_card_template( |
|
| 259 | -+ | ||
| 520 | +! |
- #' if the specified tab is active.+ title = "Association Plot", |
|
| 260 | -+ | ||
| 521 | +! |
- #' @keywords internal+ label = label, |
|
| 261 | -+ | ||
| 522 | +! |
- #'+ with_filter = with_filter, |
|
| 262 | -+ | ||
| 523 | +! |
- is_tab_active_js <- function(id, name) {
+ filter_panel_api = filter_panel_api |
|
| 263 | +524 |
- # supporting the bs3 and higher version at the same time+ ) |
|
| 264 | +525 | ! |
- sprintf(+ card$append_text("Plot", "header3")
|
| 265 | +526 | ! |
- "$(\"#%1$s > li.active\").text().trim() == '%2$s' || $(\"#%1$s > li a.active\").text().trim() == '%2$s'",+ card$append_plot(plot_r(), dim = pws$dim()) |
| 266 | +527 | ! |
- id, name+ if (!comment == "") {
|
| 267 | -+ | ||
| 528 | +! |
- )+ card$append_text("Comment", "header3")
|
|
| 268 | -+ | ||
| 529 | +! |
- }+ card$append_text(comment) |
|
| 269 | +530 |
-
+ } |
|
| 270 | -+ | ||
| 531 | +! |
- #' Assert single selection on `data_extract_spec` object+ card$append_src(teal.code::get_code(output_q())) |
|
| 271 | -+ | ||
| 532 | +! |
- #' Helper to reduce code in assertions+ card |
|
| 272 | +533 |
- #' @noRd+ } |
|
| 273 | -+ | ||
| 534 | +! |
- #'+ teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
|
|
| 274 | +535 |
- assert_single_selection <- function(x,+ } |
|
| 275 | +536 |
- .var.name = checkmate::vname(x)) { # nolint: object_name.
- |
- |
| 276 | -104x | -
- if (any(vapply(x, function(.x) .x$select$multiple, logical(1)))) {
- |
- |
| 277 | -4x | -
- stop("'", .var.name, "' should not allow multiple selection")
+ ### |
|
| 278 | +537 |
- }- |
- |
| 279 | -100x | -
- invisible(TRUE)+ }) |
|
| 280 | +538 |
}@@ -83132,14 +82845,14 @@ teal.modules.general coverage - 3.44% |
| 1 |
- #' `teal` module: Stack plots of variables and show association with reference variable+ #' `teal` module: Response plot |
|||||
| 3 |
- #' Module provides functionality for visualizing the distribution of variables and+ #' Generates a response plot for a given `response` and `x` variables. |
|||||
| 4 |
- #' their association with a reference variable.+ #' This module allows users customize and add annotations to the plot depending |
|||||
| 5 |
- #' It supports configuring the appearance of the plots, including themes and whether to show associations.+ #' on the module's arguments. |
|||||
| 6 |
- #'+ #' It supports showing the counts grouped by other variable facets (by row / column), |
|||||
| 7 |
- #'+ #' swapping the coordinates, show count annotations and displaying the response plot |
|||||
| 8 |
- #' @note For more examples, please see the vignette "Using association plot" via+ #' as frequency or density. |
|||||
| 9 |
- #' `vignette("using-association-plot", package = "teal.modules.general")`.
+ #' |
|||||
| 10 |
- #'+ #' @inheritParams teal::module |
|||||
| 11 |
- #' @inheritParams teal::module+ #' @inheritParams shared_params |
|||||
| 12 |
- #' @inheritParams shared_params+ #' @param response (`data_extract_spec` or `list` of multiple `data_extract_spec`) |
|||||
| 13 |
- #' @param ref (`data_extract_spec` or `list` of multiple `data_extract_spec`)+ #' Which variable to use as the response. |
|||||
| 14 |
- #' Reference variable, must accepts a `data_extract_spec` with `select_spec(multiple = FALSE)`+ #' You can define one fixed column by setting `fixed = TRUE` inside the `select_spec`. |
|||||
| 15 |
- #' to ensure single selection option.+ #' |
|||||
| 16 |
- #' @param vars (`data_extract_spec` or `list` of multiple `data_extract_spec`)+ #' The `data_extract_spec` must not allow multiple selection in this case. |
|||||
| 17 |
- #' Variables to be associated with the reference variable.+ #' @param x (`data_extract_spec` or `list` of multiple `data_extract_spec`) |
|||||
| 18 |
- #' @param show_association (`logical`) optional, whether show association of `vars`+ #' Specifies which variable to use on the X-axis of the response plot. |
|||||
| 19 |
- #' with reference variable. Defaults to `TRUE`.+ #' Allow the user to select multiple columns from the `data` allowed in teal. |
|||||
| 20 |
- #' @param distribution_theme,association_theme (`character`) optional, `ggplot2` themes to be used by default.+ #' |
|||||
| 21 |
- #' Default to `"gray"`.+ #' The `data_extract_spec` must not allow multiple selection in this case. |
|||||
| 22 |
- #'+ #' @param row_facet (`data_extract_spec` or `list` of multiple `data_extract_spec`) |
|||||
| 23 |
- #' @templateVar ggnames "Bivariate1", "Bivariate2"+ #' optional specification of the data variable(s) to use for faceting rows. |
|||||
| 24 |
- #' @template ggplot2_args_multi+ #' @param col_facet (`data_extract_spec` or `list` of multiple `data_extract_spec`) |
|||||
| 25 |
- #'+ #' optional specification of the data variable(s) to use for faceting columns. |
|||||
| 26 |
- #' @inherit shared_params return+ #' @param coord_flip (`logical(1)`) |
|||||
| 27 |
- #'+ #' Indicates whether to flip coordinates between `x` and `response`. |
|||||
| 28 |
- #' @examples+ #' The default value is `FALSE` and it will show the `x` variable on the x-axis |
|||||
| 29 |
- #' library(teal.widgets)+ #' and the `response` variable on the y-axis. |
|||||
| 30 |
- #'+ #' @param count_labels (`logical(1)`) |
|||||
| 31 |
- #' # general data example+ #' Indicates whether to show count labels. |
|||||
| 32 |
- #' data <- teal_data()+ #' Defaults to `TRUE`. |
|||||
| 33 |
- #' data <- within(data, {
+ #' @param freq (`logical(1)`) |
|||||
| 34 |
- #' require(nestcolor)+ #' Indicates whether to display frequency (`TRUE`) or density (`FALSE`). |
|||||
| 35 |
- #' CO2 <- CO2+ #' Defaults to density (`FALSE`). |
|||||
| 36 |
- #' factors <- names(Filter(isTRUE, vapply(CO2, is.factor, logical(1L))))+ #' |
|||||
| 37 |
- #' CO2[factors] <- lapply(CO2[factors], as.character)+ #' @inherit shared_params return |
|||||
| 38 |
- #' })+ #' |
|||||
| 39 |
- #' datanames(data) <- c("CO2")
+ #' @note For more examples, please see the vignette "Using response plot" via |
|||||
| 40 |
- #'+ #' `vignette("using-response-plot", package = "teal.modules.general")`.
|
|||||
| 41 |
- #' app <- init(+ #' |
|||||
| 42 |
- #' data = data,+ #' @examples |
|||||
| 43 |
- #' modules = modules(+ #' # general data example |
|||||
| 44 |
- #' tm_g_association(+ #' library(teal.widgets) |
|||||
| 45 |
- #' ref = data_extract_spec(+ #' |
|||||
| 46 |
- #' dataname = "CO2",+ #' data <- teal_data() |
|||||
| 47 |
- #' select = select_spec(+ #' data <- within(data, {
|
|||||
| 48 |
- #' label = "Select variable:",+ #' require(nestcolor) |
|||||
| 49 |
- #' choices = variable_choices(data[["CO2"]], c("Plant", "Type", "Treatment")),
+ #' mtcars <- mtcars |
|||||
| 50 |
- #' selected = "Plant",+ #' for (v in c("cyl", "vs", "am", "gear")) {
|
|||||
| 51 |
- #' fixed = FALSE+ #' mtcars[[v]] <- as.factor(mtcars[[v]]) |
|||||
| 52 |
- #' )+ #' } |
|||||
| 53 |
- #' ),+ #' }) |
|||||
| 54 |
- #' vars = data_extract_spec(+ #' datanames(data) <- "mtcars" |
|||||
| 55 |
- #' dataname = "CO2",+ #' |
|||||
| 56 |
- #' select = select_spec(+ #' app <- init( |
|||||
| 57 |
- #' label = "Select variables:",+ #' data = data, |
|||||
| 58 |
- #' choices = variable_choices(data[["CO2"]], c("Plant", "Type", "Treatment")),
+ #' modules = modules( |
|||||
| 59 |
- #' selected = "Treatment",+ #' tm_g_response( |
|||||
| 60 |
- #' multiple = TRUE,+ #' label = "Response Plots", |
|||||
| 61 |
- #' fixed = FALSE+ #' response = data_extract_spec( |
|||||
| 62 |
- #' )+ #' dataname = "mtcars", |
|||||
| 63 |
- #' ),+ #' select = select_spec( |
|||||
| 64 |
- #' ggplot2_args = ggplot2_args(+ #' label = "Select variable:", |
|||||
| 65 |
- #' labs = list(subtitle = "Plot generated by Association Module")+ #' choices = variable_choices(data[["mtcars"]], c("cyl", "gear")),
|
|||||
| 66 |
- #' )+ #' selected = "cyl", |
|||||
| 67 |
- #' )+ #' multiple = FALSE, |
|||||
| 68 |
- #' )+ #' fixed = FALSE |
|||||
| 69 |
- #' )+ #' ) |
|||||
| 70 |
- #' if (interactive()) {
+ #' ), |
|||||
| 71 |
- #' shinyApp(app$ui, app$server)+ #' x = data_extract_spec( |
|||||
| 72 |
- #' }+ #' dataname = "mtcars", |
|||||
| 73 | + |
+ #' select = select_spec(+ |
+ ||||
| 74 | ++ |
+ #' label = "Select variable:",+ |
+ ||||
| 75 | ++ |
+ #' choices = variable_choices(data[["mtcars"]], c("vs", "am")),
+ |
+ ||||
| 76 | ++ |
+ #' selected = "vs",+ |
+ ||||
| 77 | ++ |
+ #' multiple = FALSE,+ |
+ ||||
| 78 | ++ |
+ #' fixed = FALSE+ |
+ ||||
| 79 | ++ |
+ #' )+ |
+ ||||
| 80 | ++ |
+ #' ),+ |
+ ||||
| 81 | ++ |
+ #' ggplot2_args = ggplot2_args(+ |
+ ||||
| 82 | ++ |
+ #' labs = list(subtitle = "Plot generated by Response Module")+ |
+ ||||
| 83 | ++ |
+ #' )+ |
+ ||||
| 84 | ++ |
+ #' )+ |
+ ||||
| 85 | ++ |
+ #' )+ |
+ ||||
| 86 | ++ |
+ #' )+ |
+ ||||
| 87 | ++ |
+ #' if (interactive()) {
+ |
+ ||||
| 88 | ++ |
+ #' shinyApp(app$ui, app$server)+ |
+ ||||
| 89 | ++ |
+ #' }+ |
+ ||||
| 90 | +
#' |
|||||
| 74 | +91 | ++ |
+ #' # CDISC data example+ |
+ |||
| 92 | ++ |
+ #' library(teal.widgets)+ |
+ ||||
| 93 |
- #' # CDISC data example+ #' |
|||||
| 75 | +94 |
#' data <- teal_data() |
||||
| 76 | +95 |
#' data <- within(data, {
|
||||
| 77 | +96 |
#' require(nestcolor) |
||||
| 78 | +97 |
#' ADSL <- rADSL |
||||
| 79 | +98 |
#' }) |
||||
| 80 | +99 |
- #' datanames(data) <- "ADSL"+ #' datanames(data) <- c("ADSL")
|
||||
| 81 | +100 |
#' join_keys(data) <- default_cdisc_join_keys[datanames(data)] |
||||
| 82 | +101 |
#' |
||||
| 83 | +102 |
#' app <- init( |
||||
| 84 | +103 |
#' data = data, |
||||
| 85 | +104 |
#' modules = modules( |
||||
| 86 | -- |
- #' tm_g_association(- |
- ||||
| 87 | +105 |
- #' ref = data_extract_spec(+ #' tm_g_response( |
||||
| 88 | +106 |
- #' dataname = "ADSL",+ #' label = "Response Plots", |
||||
| 89 | +107 |
- #' select = select_spec(+ #' response = data_extract_spec( |
||||
| 90 | +108 |
- #' label = "Select variable:",+ #' dataname = "ADSL", |
||||
| 91 | +109 |
- #' choices = variable_choices(+ #' select = select_spec( |
||||
| 92 | +110 |
- #' data[["ADSL"]],+ #' label = "Select variable:", |
||||
| 93 | +111 |
- #' c("SEX", "RACE", "COUNTRY", "ARM", "STRATA1", "STRATA2", "ITTFL", "BMRKR2")
+ #' choices = variable_choices(data[["ADSL"]], c("BMRKR2", "COUNTRY")),
|
||||
| 94 | +112 |
- #' ),+ #' selected = "BMRKR2", |
||||
| 95 | +113 |
- #' selected = "RACE",+ #' multiple = FALSE, |
||||
| 96 | +114 |
#' fixed = FALSE |
||||
| 97 | +115 |
#' ) |
||||
| 98 | +116 |
#' ), |
||||
| 99 | +117 |
- #' vars = data_extract_spec(+ #' x = data_extract_spec( |
||||
| 100 | +118 |
#' dataname = "ADSL", |
||||
| 101 | +119 |
#' select = select_spec( |
||||
| 102 | +120 |
- #' label = "Select variables:",+ #' label = "Select variable:", |
||||
| 103 | +121 |
- #' choices = variable_choices(+ #' choices = variable_choices(data[["ADSL"]], c("SEX", "RACE")),
|
||||
| 104 | +122 |
- #' data[["ADSL"]],+ #' selected = "RACE", |
||||
| 105 | +123 |
- #' c("SEX", "RACE", "COUNTRY", "ARM", "STRATA1", "STRATA2", "ITTFL", "BMRKR2")
+ #' multiple = FALSE, |
||||
| 106 | +124 |
- #' ),+ #' fixed = FALSE |
||||
| 107 | +125 |
- #' selected = "BMRKR2",+ #' ) |
||||
| 108 | +126 |
- #' multiple = TRUE,+ #' ), |
||||
| 109 | +127 |
- #' fixed = FALSE+ #' ggplot2_args = ggplot2_args( |
||||
| 110 | +128 |
- #' )+ #' labs = list(subtitle = "Plot generated by Response Module") |
||||
| 111 | +129 |
- #' ),+ #' ) |
||||
| 112 | +130 |
- #' ggplot2_args = ggplot2_args(+ #' ) |
||||
| 113 | +131 |
- #' labs = list(subtitle = "Plot generated by Association Module")+ #' ) |
||||
| 114 | +132 |
- #' )+ #' ) |
||||
| 115 | +133 |
- #' )+ #' if (interactive()) {
|
||||
| 116 | +134 |
- #' )+ #' shinyApp(app$ui, app$server) |
||||
| 117 | +135 |
- #' )+ #' } |
||||
| 118 | +136 |
- #' if (interactive()) {
+ #' |
||||
| 119 | +137 |
- #' shinyApp(app$ui, app$server)+ #' @export |
||||
| 120 | +138 |
- #' }+ #' |
||||
| 121 | +139 |
- #'+ tm_g_response <- function(label = "Response Plot", |
||||
| 122 | +140 |
- #' @export+ response, |
||||
| 123 | +141 |
- #'+ x, |
||||
| 124 | +142 |
- tm_g_association <- function(label = "Association",+ row_facet = NULL, |
||||
| 125 | +143 |
- ref,+ col_facet = NULL, |
||||
| 126 | +144 |
- vars,+ coord_flip = FALSE, |
||||
| 127 | +145 |
- show_association = TRUE,+ count_labels = TRUE, |
||||
| 128 | +146 |
- plot_height = c(600, 400, 5000),+ rotate_xaxis_labels = FALSE, |
||||
| 129 | +147 |
- plot_width = NULL,+ freq = FALSE, |
||||
| 130 | +148 |
- distribution_theme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void"), # nolint: line_length.
+ plot_height = c(600, 400, 5000), |
||||
| 131 | +149 |
- association_theme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void"), # nolint: line_length.
+ plot_width = NULL, |
||||
| 132 | +150 |
- pre_output = NULL,+ ggtheme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void"),
|
||||
| 133 | +151 |
- post_output = NULL,+ ggplot2_args = teal.widgets::ggplot2_args(), |
||||
| 134 | +152 |
- ggplot2_args = teal.widgets::ggplot2_args()) {
+ pre_output = NULL,+ |
+ ||||
| 153 | ++ |
+ post_output = NULL) {
|
||||
| 135 | +154 | ! |
- message("Initializing tm_g_association")
+ message("Initializing tm_g_response")
|
|||
| 136 | +155 | |||||
| 137 | +156 |
# Normalize the parameters |
||||
| 138 | +157 | ! |
- if (inherits(ref, "data_extract_spec")) ref <- list(ref)+ if (inherits(response, "data_extract_spec")) response <- list(response) |
|||
| 139 | +158 | ! |
- if (inherits(vars, "data_extract_spec")) vars <- list(vars)+ if (inherits(x, "data_extract_spec")) x <- list(x) |
|||
| 140 | +159 | ! |
- if (inherits(ggplot2_args, "ggplot2_args")) ggplot2_args <- list(default = ggplot2_args)+ if (inherits(row_facet, "data_extract_spec")) row_facet <- list(row_facet)+ |
+ |||
| 160 | +! | +
+ if (inherits(col_facet, "data_extract_spec")) col_facet <- list(col_facet) |
||||
| 141 | +161 | |||||
| 142 | +162 |
# Start of assertions |
||||
| 143 | +163 | ! |
checkmate::assert_string(label) |
|||
| 144 | +164 | |||||
| 145 | +165 | ! |
- checkmate::assert_list(ref, types = "data_extract_spec")+ checkmate::assert_list(response, types = "data_extract_spec") |
|||
| 146 | +166 | ! |
- if (!all(vapply(ref, function(x) !x$select$multiple, logical(1)))) {
+ if (!all(vapply(response, function(x) !("" %in% x$select$choices), logical(1)))) {
|
|||
| 147 | +167 | ! |
- stop("'ref' should not allow multiple selection")
+ stop("'response' should not allow empty values")
|
|||
| 148 | +168 |
} |
||||
| 169 | +! | +
+ assert_single_selection(response)+ |
+ ||||
| 149 | +170 | |||||
| 150 | +171 | ! |
- checkmate::assert_list(vars, types = "data_extract_spec")+ checkmate::assert_list(x, types = "data_extract_spec") |
|||
| 151 | +172 | ! |
- checkmate::assert_flag(show_association)+ if (!all(vapply(x, function(x) !("" %in% x$select$choices), logical(1)))) {
+ |
+ |||
| 173 | +! | +
+ stop("'x' should not allow empty values")
|
||||
| 152 | +174 |
-
+ } |
||||
| 153 | +175 | ! |
- checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE)+ assert_single_selection(x)+ |
+ |||
| 176 | ++ | + | ||||
| 154 | +177 | ! |
- checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height")+ checkmate::assert_list(row_facet, types = "data_extract_spec", null.ok = TRUE) |
|||
| 155 | +178 | ! |
- checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE)+ checkmate::assert_list(col_facet, types = "data_extract_spec", null.ok = TRUE) |
|||
| 156 | +179 | ! |
- checkmate::assert_numeric(+ checkmate::assert_flag(coord_flip) |
|||
| 157 | +180 | ! |
- plot_width[1],+ checkmate::assert_flag(count_labels) |
|||
| 158 | +181 | ! |
- lower = plot_width[2], upper = plot_width[3], null.ok = TRUE, .var.name = "plot_width"+ checkmate::assert_flag(rotate_xaxis_labels) |
|||
| 159 | -+ | |||||
| 182 | +! |
- )+ checkmate::assert_flag(freq) |
||||
| 160 | +183 | |||||
| 161 | +184 | ! |
- distribution_theme <- match.arg(distribution_theme)+ checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE) |
|||
| 162 | +185 | ! |
- association_theme <- match.arg(association_theme)+ checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height") |
|||
| 163 | -+ | |||||
| 186 | +! |
-
+ checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE) |
||||
| 164 | +187 | ! |
- checkmate::assert_multi_class(pre_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
+ checkmate::assert_numeric( |
|||
| 165 | +188 | ! |
- checkmate::assert_multi_class(post_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
+ plot_width[1],+ |
+ |||
| 189 | +! | +
+ lower = plot_width[2], upper = plot_width[3], null.ok = TRUE, .var.name = "plot_width" |
||||
| 166 | +190 | ++ |
+ )+ |
+ |||
| 191 | ||||||
| 167 | +192 | ! |
- plot_choices <- c("Bivariate1", "Bivariate2")
+ ggtheme <- match.arg(ggtheme) |
|||
| 168 | +193 | ! |
- checkmate::assert_list(ggplot2_args, types = "ggplot2_args")+ checkmate::assert_class(ggplot2_args, "ggplot2_args")+ |
+ |||
| 194 | ++ | + | ||||
| 169 | +195 | ! |
- 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)
+ |
+ |||
| 196 | +! | +
+ checkmate::assert_multi_class(post_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
|
||||
| 170 | +197 |
# End of assertions |
||||
| 171 | +198 | |||||
| 172 | +199 |
# Make UI args |
||||
| 173 | +200 | ! |
args <- as.list(environment()) |
|||
| 174 | +201 | |||||
| 175 | +202 | ! |
data_extract_list <- list( |
|||
| 176 | +203 | ! |
- ref = ref,+ response = response, |
|||
| 177 | +204 | ! |
- vars = vars+ x = x,+ |
+ |||
| 205 | +! | +
+ row_facet = row_facet,+ |
+ ||||
| 206 | +! | +
+ col_facet = col_facet |
||||
| 178 | +207 |
) |
||||
| 179 | +208 | |||||
| 180 | +209 | ! |
ans <- module( |
|||
| 181 | +210 | ! |
label = label, |
|||
| 182 | +211 | ! |
- server = srv_tm_g_association,+ server = srv_g_response, |
|||
| 183 | +212 | ! |
- ui = ui_tm_g_association,+ ui = ui_g_response, |
|||
| 184 | +213 | ! |
ui_args = args, |
|||
| 185 | +214 | ! |
server_args = c( |
|||
| 186 | +215 | ! |
data_extract_list, |
|||
| 187 | +216 | ! |
list(plot_height = plot_height, plot_width = plot_width, ggplot2_args = ggplot2_args) |
|||
| 188 | +217 |
), |
||||
| 189 | +218 | ! |
datanames = teal.transform::get_extract_datanames(data_extract_list) |
|||
| 190 | +219 |
) |
||||
| 191 | +220 | ! |
attr(ans, "teal_bookmarkable") <- TRUE |
|||
| 192 | +221 | ! |
ans |
|||
| 193 | +222 |
} |
||||
| 194 | +223 | |||||
| 195 | +224 |
- # UI function for the association module+ # UI function for the response module |
||||
| 196 | +225 |
- ui_tm_g_association <- function(id, ...) {
+ ui_g_response <- function(id, ...) {
|
||||
| 197 | +226 | ! |
ns <- NS(id) |
|||
| 198 | +227 | ! |
args <- list(...) |
|||
| 199 | +228 | ! |
- is_single_dataset_value <- teal.transform::is_single_dataset(args$ref, args$vars)+ is_single_dataset_value <- teal.transform::is_single_dataset(args$response, args$x, args$row_facet, args$col_facet) |
|||
| 200 | +229 | |||||
| 201 | -! | -
- teal.widgets::standard_layout(- |
- ||||
| 202 | -! | -
- output = teal.widgets::white_small_well(- |
- ||||
| 203 | +230 | ! |
- textOutput(ns("title")),
+ teal.widgets::standard_layout( |
|||
| 204 | +231 | ! |
- tags$br(),+ output = teal.widgets::white_small_well( |
|||
| 205 | +232 | ! |
teal.widgets::plot_with_settings_ui(id = ns("myplot"))
|
|||
| 206 | +233 |
), |
||||
| 207 | +234 | ! |
encoding = tags$div( |
|||
| 208 | +235 |
### Reporter |
||||
| 209 | +236 | ! |
teal.reporter::simple_reporter_ui(ns("simple_reporter")),
|
|||
| 210 | +237 |
### |
||||
| 211 | +238 | ! |
tags$label("Encodings", class = "text-primary"),
|
|||
| 212 | +239 | ! |
- teal.transform::datanames_input(args[c("ref", "vars")]),
+ teal.transform::datanames_input(args[c("response", "x", "row_facet", "col_facet")]),
|
|||
| 213 | +240 | ! |
teal.transform::data_extract_ui( |
|||
| 214 | +241 | ! |
- id = ns("ref"),
+ id = ns("response"),
|
|||
| 215 | +242 | ! |
- label = "Reference variable",+ label = "Response variable", |
|||
| 216 | +243 | ! |
- data_extract_spec = args$ref,+ data_extract_spec = args$response, |
|||
| 217 | +244 | ! |
is_single_dataset = is_single_dataset_value |
|||
| 218 | +245 |
), |
||||
| 219 | +246 | ! |
teal.transform::data_extract_ui( |
|||
| 220 | +247 | ! |
- id = ns("vars"),
+ id = ns("x"),
|
|||
| 221 | +248 | ! |
- label = "Associated variables",+ label = "X variable", |
|||
| 222 | +249 | ! |
- data_extract_spec = args$vars,+ data_extract_spec = args$x, |
|||
| 223 | +250 | ! |
is_single_dataset = is_single_dataset_value |
|||
| 224 | +251 |
), |
||||
| 225 | +252 | ! |
- checkboxInput(+ if (!is.null(args$row_facet)) {
|
|||
| 226 | +253 | ! |
- ns("association"),
+ teal.transform::data_extract_ui( |
|||
| 227 | +254 | ! |
- "Association with reference variable",+ id = ns("row_facet"),
|
|||
| 228 | +255 | ! |
- value = args$show_association+ label = "Row facetting", |
|||
| 229 | -+ | |||||
| 256 | +! |
- ),+ data_extract_spec = args$row_facet, |
||||
| 230 | +257 | ! |
- checkboxInput(+ is_single_dataset = is_single_dataset_value |
|||
| 231 | -! | +|||||
| 258 | +
- ns("show_dist"),
+ ) |
|||||
| 232 | -! | +|||||
| 259 | +
- "Scaled frequencies",+ }, |
|||||
| 233 | +260 | ! |
- value = FALSE+ if (!is.null(args$col_facet)) {
|
|||
| 234 | -+ | |||||
| 261 | +! |
- ),+ teal.transform::data_extract_ui( |
||||
| 235 | +262 | ! |
- checkboxInput(+ id = ns("col_facet"),
|
|||
| 236 | +263 | ! |
- ns("log_transformation"),
+ label = "Column facetting", |
|||
| 237 | +264 | ! |
- "Log transformed",+ data_extract_spec = args$col_facet, |
|||
| 238 | +265 | ! |
- value = FALSE+ is_single_dataset = is_single_dataset_value |
|||
| 239 | +266 |
- ),+ ) |
||||
| 240 | -! | +|||||
| 267 | +
- teal.widgets::panel_group(+ }, |
|||||
| 241 | +268 | ! |
- teal.widgets::panel_item(+ shinyWidgets::radioGroupButtons( |
|||
| 242 | +269 | ! |
- title = "Plot settings",+ inputId = ns("freq"),
|
|||
| 243 | +270 | ! |
- teal.widgets::optionalSliderInputValMinMax(ns("alpha"), "Scatterplot opacity:", c(0.5, 0, 1), ticks = FALSE),
+ label = NULL, |
|||
| 244 | +271 | ! |
- teal.widgets::optionalSliderInputValMinMax(ns("size"), "Scatterplot points size:", c(2, 1, 8), ticks = FALSE),
+ choices = c("frequency", "density"),
|
|||
| 245 | +272 | ! |
- checkboxInput(ns("swap_axes"), "Swap axes", value = FALSE),
+ selected = ifelse(args$freq, "frequency", "density"), |
|||
| 246 | +273 | ! |
- checkboxInput(ns("rotate_xaxis_labels"), "Rotate X axis labels", value = FALSE),
+ justified = TRUE |
|||
| 247 | -! | +|||||
| 274 | +
- selectInput(+ ), |
|||||
| 248 | +275 | ! |
- inputId = ns("distribution_theme"),
+ teal.widgets::panel_group( |
|||
| 249 | +276 | ! |
- label = "Distribution theme (by ggplot):",+ teal.widgets::panel_item( |
|||
| 250 | +277 | ! |
- choices = ggplot_themes,+ title = "Plot settings", |
|||
| 251 | +278 | ! |
- selected = args$distribution_theme,+ checkboxInput(ns("count_labels"), "Add count labels", value = args$count_labels),
|
|||
| 252 | +279 | ! |
- multiple = FALSE+ checkboxInput(ns("coord_flip"), "Swap axes", value = args$coord_flip),
|
|||
| 253 | -+ | |||||
| 280 | +! |
- ),+ checkboxInput(ns("rotate_xaxis_labels"), "Rotate X axis labels", value = args$rotate_xaxis_labels),
|
||||
| 254 | +281 | ! |
selectInput( |
|||
| 255 | +282 | ! |
- inputId = ns("association_theme"),
+ inputId = ns("ggtheme"),
|
|||
| 256 | +283 | ! |
- label = "Association theme (by ggplot):",+ label = "Theme (by ggplot):", |
|||
| 257 | +284 | ! |
choices = ggplot_themes, |
|||
| 258 | +285 | ! |
- selected = args$association_theme,+ selected = args$ggtheme, |
|||
| 259 | +286 | ! |
multiple = FALSE |
|||
| 260 | +287 |
) |
||||
| 261 | +288 |
) |
||||
| 262 | +289 |
) |
||||
| 263 | +290 |
), |
||||
| 264 | +291 | ! |
forms = tagList( |
|||
| 265 | +292 | ! |
teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code")
|
|||
| 266 | +293 |
), |
||||
| 267 | +294 | ! |
pre_output = args$pre_output, |
|||
| 268 | +295 | ! |
post_output = args$post_output |
|||
| 269 | +296 |
) |
||||
| 270 | +297 |
} |
||||
| 271 | +298 | |||||
| 272 | +299 |
- # Server function for the association module+ # Server function for the response module |
||||
| 273 | +300 |
- srv_tm_g_association <- function(id,+ srv_g_response <- function(id, |
||||
| 274 | +301 |
- data,+ data, |
||||
| 275 | +302 |
- reporter,+ reporter, |
||||
| 276 | +303 |
- filter_panel_api,+ filter_panel_api, |
||||
| 277 | +304 |
- ref,+ response, |
||||
| 278 | +305 |
- vars,+ x, |
||||
| 279 | +306 |
- plot_height,+ row_facet, |
||||
| 280 | +307 |
- plot_width,+ col_facet, |
||||
| 281 | +308 |
- ggplot2_args) {
+ plot_height,+ |
+ ||||
| 309 | ++ |
+ plot_width,+ |
+ ||||
| 310 | ++ |
+ ggplot2_args) {
|
||||
| 282 | +311 | ! |
with_reporter <- !missing(reporter) && inherits(reporter, "Reporter") |
|||
| 283 | +312 | ! |
with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI") |
|||
| 284 | +313 | ! |
checkmate::assert_class(data, "reactive") |
|||
| 285 | +314 | ! |
checkmate::assert_class(isolate(data()), "teal_data") |
|||
| 315 | +! | +
+ moduleServer(id, function(input, output, session) {
+ |
+ ||||
| 316 | +! | +
+ teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.general")+ |
+ ||||
| 286 | +317 | |||||
| 287 | +318 | ! |
- moduleServer(id, function(input, output, session) {
+ data_extract <- list(response = response, x = x, row_facet = row_facet, col_facet = col_facet)+ |
+ |||
| 319 | ++ | + | ||||
| 288 | +320 | +! | +
+ rule_diff <- function(other) {
+ |
+ |||
| 321 | +! | +
+ function(value) {
+ |
+ ||||
| 322 | ! |
- if (shiny::isRunning()) logger::log_shiny_input_changes(input, namespace = "teal.modules.general")+ if (other %in% names(selector_list())) {
+ |
+ ||||
| 323 | +! | +
+ othervalue <- selector_list()[[other]]()[["select"]]+ |
+ ||||
| 324 | +! | +
+ if (!is.null(othervalue)) {
+ |
+ ||||
| 325 | +! | +
+ if (identical(value, othervalue)) {
+ |
+ ||||
| 326 | +! | +
+ "Row and column facetting variables must be different." |
||||
| 289 | +327 | ++ |
+ }+ |
+ |||
| 328 | ++ |
+ }+ |
+ ||||
| 329 | ++ |
+ }+ |
+ ||||
| 330 | ++ |
+ }+ |
+ ||||
| 331 | ++ |
+ }+ |
+ ||||
| 332 | ||||||
| 290 | +333 | ! |
selector_list <- teal.transform::data_extract_multiple_srv( |
|||
| 291 | +334 | ! |
- data_extract = list(ref = ref, vars = vars),+ data_extract = data_extract, |
|||
| 292 | +335 | ! |
datasets = data, |
|||
| 293 | +336 | ! |
select_validation_rule = list( |
|||
| 294 | +337 | ! |
- ref = shinyvalidate::compose_rules(+ response = shinyvalidate::sv_required("Please define a column for the response variable"),
|
|||
| 295 | +338 | ! |
- shinyvalidate::sv_required("A reference variable needs to be selected."),
+ x = shinyvalidate::sv_required("Please define a column for X variable"),
|
|||
| 296 | +339 | ! |
- ~ if ((.) %in% selector_list()$vars()$select) {
+ row_facet = shinyvalidate::compose_rules( |
|||
| 297 | +340 | ! |
- "Associated variables and reference variable cannot overlap"+ shinyvalidate::sv_optional(), |
|||
| 298 | -+ | |||||
| 341 | +! |
- }+ ~ if (length(.) > 1) "There must be 1 or no row facetting variable.",+ |
+ ||||
| 342 | +! | +
+ rule_diff("col_facet")
|
||||
| 299 | +343 |
), |
||||
| 300 | +344 | ! |
- vars = shinyvalidate::compose_rules(+ col_facet = shinyvalidate::compose_rules( |
|||
| 301 | +345 | ! |
- shinyvalidate::sv_required("An associated variable needs to be selected."),
+ shinyvalidate::sv_optional(), |
|||
| 302 | +346 | ! |
- ~ if (length(selector_list()$ref()$select) != 0 && selector_list()$ref()$select %in% (.)) {
+ ~ if (length(.) > 1) "There must be 1 or no column facetting variable.", |
|||
| 303 | +347 | ! |
- "Associated variables and reference variable cannot overlap"- |
- |||
| 304 | -- |
- }+ rule_diff("row_facet")
|
||||
| 305 | +348 |
) |
||||
| 306 | +349 |
) |
||||
| 307 | +350 |
) |
||||
| 308 | +351 | |||||
| 309 | +352 | ! |
iv_r <- reactive({
|
|||
| 310 | +353 | ! |
iv <- shinyvalidate::InputValidator$new() |
|||
| 311 | +354 | +! | +
+ iv$add_rule("ggtheme", shinyvalidate::sv_required("Please select a theme"))
+ |
+ |||
| 355 | ! |
teal.transform::compose_and_enable_validators(iv, selector_list) |
||||
| 312 | +356 |
}) |
||||
| 313 | +357 | |||||
| 314 | +358 | ! |
anl_merged_input <- teal.transform::merge_expression_srv( |
|||
| 315 | +359 | ! |
- datasets = data,+ selector_list = selector_list, |
|||
| 316 | +360 | ! |
- selector_list = selector_list+ datasets = data |
|||
| 317 | +361 |
) |
||||
| 318 | +362 | |||||
| 319 | +363 | ! |
anl_merged_q <- reactive({
|
|||
| 320 | +364 | ! |
req(anl_merged_input()) |
|||
| 321 | +365 | ! |
- data() %>% teal.code::eval_code(as.expression(anl_merged_input()$expr))+ data() %>%+ |
+ |||
| 366 | +! | +
+ teal.code::eval_code(as.expression(anl_merged_input()$expr)) |
||||
| 322 | +367 |
}) |
||||
| 323 | +368 | |||||
| 324 | +369 | ! |
merged <- list( |
|||
| 325 | +370 | ! |
anl_input_r = anl_merged_input, |
|||
| 326 | +371 | ! |
anl_q_r = anl_merged_q |
|||
| 327 | +372 |
) |
||||
| 328 | +373 | |||||
| 329 | +374 | ! |
output_q <- reactive({
|
|||
| 330 | +375 | ! |
teal::validate_inputs(iv_r()) |
|||
| 331 | +376 | |||||
| 332 | +377 | ! |
- ANL <- merged$anl_q_r()[["ANL"]]+ qenv <- merged$anl_q_r() |
|||
| 333 | +378 | ! |
- teal::validate_has_data(ANL, 3)+ ANL <- qenv[["ANL"]] |
|||
| 334 | -+ | |||||
| 379 | +! |
-
+ resp_var <- as.vector(merged$anl_input_r()$columns_source$response) |
||||
| 335 | +380 | ! |
- vars_names <- merged$anl_input_r()$columns_source$vars+ x <- as.vector(merged$anl_input_r()$columns_source$x) |
|||
| 336 | +381 | |||||
| 337 | -! | -
- ref_name <- as.vector(merged$anl_input_r()$columns_source$ref)- |
- ||||
| 338 | +382 | ! |
- association <- input$association+ validate(need(is.factor(ANL[[resp_var]]), "Please select a factor variable as the response.")) |
|||
| 339 | +383 | ! |
- show_dist <- input$show_dist+ validate(need(is.factor(ANL[[x]]), "Please select a factor variable as the X-Variable.")) |
|||
| 340 | +384 | ! |
- log_transformation <- input$log_transformation+ teal::validate_has_data(ANL, 10) |
|||
| 341 | +385 | ! |
- rotate_xaxis_labels <- input$rotate_xaxis_labels+ teal::validate_has_data(ANL[, c(resp_var, x)], 10, complete = TRUE, allow_inf = FALSE) |
|||
| 342 | -! | +|||||
| 386 | +
- swap_axes <- input$swap_axes+ |
|||||
| 343 | +387 | ! |
- distribution_theme <- input$distribution_theme+ row_facet_name <- if (length(merged$anl_input_r()$columns_source$row_facet) == 0) {
|
|||
| 344 | +388 | ! |
- association_theme <- input$association_theme+ character(0) |
|||
| 345 | +389 |
-
+ } else {
|
||||
| 346 | +390 | ! |
- is_scatterplot <- is.numeric(ANL[[ref_name]]) && any(vapply(ANL[vars_names], is.numeric, logical(1)))+ as.vector(merged$anl_input_r()$columns_source$row_facet) |
|||
| 347 | -! | +|||||
| 391 | +
- if (is_scatterplot) {
+ } |
|||||
| 348 | +392 | ! |
- shinyjs::show("alpha")
+ col_facet_name <- if (length(merged$anl_input_r()$columns_source$col_facet) == 0) {
|
|||
| 349 | +393 | ! |
- shinyjs::show("size")
+ character(0) |
|||
| 350 | -! | +|||||
| 394 | +
- alpha <- input$alpha+ } else {
|
|||||
| 351 | +395 | ! |
- size <- input$size+ as.vector(merged$anl_input_r()$columns_source$col_facet) |
|||
| 352 | +396 |
- } else {
+ }+ |
+ ||||
| 397 | ++ | + | ||||
| 353 | +398 | ! |
- shinyjs::hide("alpha")
+ freq <- input$freq == "frequency" |
|||
| 354 | +399 | ! |
- shinyjs::hide("size")
+ swap_axes <- input$coord_flip |
|||
| 355 | +400 | ! |
- alpha <- 0.5+ counts <- input$count_labels |
|||
| 356 | +401 | ! |
- size <- 2+ rotate_xaxis_labels <- input$rotate_xaxis_labels |
|||
| 357 | -+ | |||||
| 402 | +! |
- }+ ggtheme <- input$ggtheme |
||||
| 358 | +403 | |||||
| 359 | +404 | ! |
- teal::validate_has_data(ANL[, c(ref_name, vars_names)], 3, complete = TRUE, allow_inf = FALSE)+ arg_position <- if (freq) "stack" else "fill" |
|||
| 360 | +405 | |||||
| 361 | -- |
- # reference- |
- ||||
| 362 | +406 | ! |
- ref_class <- class(ANL[[ref_name]])[1]+ rowf <- if (length(row_facet_name) != 0) as.name(row_facet_name) |
|||
| 363 | +407 | ! |
- if (is.numeric(ANL[[ref_name]]) && log_transformation) {
- |
- |||
| 364 | -- |
- # works for both integers and doubles+ colf <- if (length(col_facet_name) != 0) as.name(col_facet_name) |
||||
| 365 | +408 | ! |
- ref_cl_name <- call("log", as.name(ref_name))
+ resp_cl <- as.name(resp_var) |
|||
| 366 | +409 | ! |
- ref_cl_lbl <- varname_w_label(ref_name, ANL, prefix = "Log of ")- |
- |||
| 367 | -- |
- } else {
+ x_cl <- as.name(x) |
||||
| 368 | +410 |
- # silently ignore when non-numeric even if `log` is selected because some+ |
||||
| 369 | -+ | |||||
| 411 | +! |
- # variables may be numeric and others not+ if (swap_axes) {
|
||||
| 370 | +412 | ! |
- ref_cl_name <- as.name(ref_name)+ qenv <- teal.code::eval_code( |
|||
| 371 | +413 | ! |
- ref_cl_lbl <- varname_w_label(ref_name, ANL)+ qenv, |
|||
| 372 | -+ | |||||
| 414 | +! |
- }+ substitute( |
||||
| 373 | -+ | |||||
| 415 | +! |
-
+ expr = ANL[[x]] <- with(ANL, forcats::fct_rev(x_cl)), |
||||
| 374 | +416 | ! |
- user_ggplot2_args <- teal.widgets::resolve_ggplot2_args(+ env = list(x = x, x_cl = x_cl) |
|||
| 375 | -! | +|||||
| 417 | +
- user_plot = ggplot2_args[["Bivariate1"]],+ ) |
|||||
| 376 | -! | +|||||
| 418 | +
- user_default = ggplot2_args$default+ ) |
|||||
| 377 | +419 |
- )+ } |
||||
| 378 | +420 | |||||
| 379 | +421 | ! |
- ref_call <- bivariate_plot_call(+ qenv <- teal.code::eval_code( |
|||
| 380 | +422 | ! |
- data_name = "ANL",+ qenv, |
|||
| 381 | +423 | ! |
- x = ref_cl_name,+ substitute( |
|||
| 382 | +424 | ! |
- x_class = ref_class,+ expr = ANL[[resp_var]] <- factor(ANL[[resp_var]]), |
|||
| 383 | +425 | ! |
- x_label = ref_cl_lbl,+ env = list(resp_var = resp_var) |
|||
| 384 | -! | +|||||
| 426 | +
- freq = !show_dist,+ ) |
|||||
| 385 | -! | +|||||
| 427 | +
- theme = distribution_theme,+ ) %>% |
|||||
| 386 | -! | +|||||
| 428 | +
- rotate_xaxis_labels = rotate_xaxis_labels,+ # rowf and colf will be a NULL if not set by a user |
|||||
| 387 | +429 | ! |
- swap_axes = FALSE,+ teal.code::eval_code( |
|||
| 388 | +430 | ! |
- size = size,+ substitute( |
|||
| 389 | +431 | ! |
- alpha = alpha,+ expr = ANL2 <- ANL %>% |
|||
| 390 | +432 | ! |
- ggplot2_args = user_ggplot2_args+ dplyr::group_by_at(dplyr::vars(x_cl, resp_cl, rowf, colf)) %>% |
|||
| 391 | -+ | |||||
| 433 | +! |
- )+ dplyr::summarise(ns = dplyr::n()) %>% |
||||
| 392 | -+ | |||||
| 434 | +! |
-
+ dplyr::group_by_at(dplyr::vars(x_cl, rowf, colf)) %>% |
||||
| 393 | -+ | |||||
| 435 | +! |
- # association+ dplyr::mutate(sums = sum(ns), percent = round(ns / sums * 100, 1)), |
||||
| 394 | +436 | ! |
- ref_class_cov <- ifelse(association, ref_class, "NULL")+ env = list(x_cl = x_cl, resp_cl = resp_cl, rowf = rowf, colf = colf) |
|||
| 395 | +437 | - - | -||||
| 396 | -! | -
- print_call <- quote(print(p))+ ) |
||||
| 397 | +438 |
-
+ ) %>% |
||||
| 398 | +439 | ! |
- var_calls <- lapply(vars_names, function(var_i) {
+ teal.code::eval_code( |
|||
| 399 | +440 | ! |
- var_class <- class(ANL[[var_i]])[1]+ substitute( |
|||
| 400 | +441 | ! |
- if (is.numeric(ANL[[var_i]]) && log_transformation) {
+ expr = ANL3 <- ANL %>% |
|||
| 401 | -+ | |||||
| 442 | +! |
- # works for both integers and doubles+ dplyr::group_by_at(dplyr::vars(x_cl, rowf, colf)) %>% |
||||
| 402 | +443 | ! |
- var_cl_name <- call("log", as.name(var_i))
+ dplyr::summarise(ns = dplyr::n()), |
|||
| 403 | +444 | ! |
- var_cl_lbl <- varname_w_label(var_i, ANL, prefix = "Log of ")+ env = list(x_cl = x_cl, rowf = rowf, colf = colf) |
|||
| 404 | +445 |
- } else {
+ ) |
||||
| 405 | +446 |
- # silently ignore when non-numeric even if `log` is selected because some+ ) |
||||
| 406 | +447 |
- # variables may be numeric and others not+ |
||||
| 407 | +448 | ! |
- var_cl_name <- as.name(var_i)+ plot_call <- substitute( |
|||
| 408 | +449 | ! |
- var_cl_lbl <- varname_w_label(var_i, ANL)+ expr = ggplot(ANL2, aes(x = x_cl, y = ns)) + |
|||
| 409 | -+ | |||||
| 450 | +! |
- }+ geom_bar(aes(fill = resp_cl), stat = "identity", position = arg_position), |
||||
| 410 | -+ | |||||
| 451 | +! |
-
+ env = list( |
||||
| 411 | +452 | ! |
- user_ggplot2_args <- teal.widgets::resolve_ggplot2_args(+ x_cl = x_cl, |
|||
| 412 | +453 | ! |
- user_plot = ggplot2_args[["Bivariate2"]],+ resp_cl = resp_cl, |
|||
| 413 | +454 | ! |
- user_default = ggplot2_args$default+ arg_position = arg_position |
|||
| 414 | +455 |
) |
||||
| 415 | +456 | ++ |
+ )+ |
+ |||
| 457 | ||||||
| 416 | +458 | ! |
- bivariate_plot_call(+ if (!freq) {
|
|||
| 417 | +459 | ! |
- data_name = "ANL",+ plot_call <- substitute( |
|||
| 418 | +460 | ! |
- x = ref_cl_name,+ plot_call + expand_limits(y = c(0, 1.1)), |
|||
| 419 | +461 | ! |
- y = var_cl_name,+ env = list(plot_call = plot_call) |
|||
| 420 | -! | +|||||
| 462 | +
- x_class = ref_class_cov,+ )+ |
+ |||||
| 463 | ++ |
+ }+ |
+ ||||
| 464 | ++ | + | ||||
| 421 | +465 | ! |
- y_class = var_class,+ if (counts) {
|
|||
| 422 | +466 | ! |
- x_label = ref_cl_lbl,+ plot_call <- substitute( |
|||
| 423 | +467 | ! |
- y_label = var_cl_lbl,+ expr = plot_call + |
|||
| 424 | +468 | ! |
- theme = association_theme,+ geom_text( |
|||
| 425 | +469 | ! |
- freq = !show_dist,+ data = ANL2, |
|||
| 426 | +470 | ! |
- rotate_xaxis_labels = rotate_xaxis_labels,+ aes(label = ns, x = x_cl, y = ns, group = resp_cl), |
|||
| 427 | +471 | ! |
- swap_axes = swap_axes,+ col = "white", |
|||
| 428 | +472 | ! |
- alpha = alpha,+ vjust = "middle", |
|||
| 429 | +473 | ! |
- size = size,+ hjust = "middle", |
|||
| 430 | +474 | ! |
- ggplot2_args = user_ggplot2_args- |
- |||
| 431 | -- |
- )+ position = position_anl2_value |
||||
| 432 | +475 |
- })+ ) + |
||||
| 433 | -+ | |||||
| 476 | +! |
-
+ geom_text( |
||||
| 434 | -+ | |||||
| 477 | +! |
- # helper function to format variable name+ data = ANL3, aes(label = ns, x = x_cl, y = anl3_y), |
||||
| 435 | +478 | ! |
- format_varnames <- function(x) {
+ hjust = hjust_value, |
|||
| 436 | +479 | ! |
- if (is.numeric(ANL[[x]]) && log_transformation) {
+ vjust = vjust_value, |
|||
| 437 | +480 | ! |
- varname_w_label(x, ANL, prefix = "Log of ")+ position = position_anl3_value |
|||
| 438 | +481 |
- } else {
+ ), |
||||
| 439 | +482 | ! |
- varname_w_label(x, ANL)- |
- |||
| 440 | -- |
- }+ env = list( |
||||
| 441 | -+ | |||||
| 483 | +! |
- }+ plot_call = plot_call, |
||||
| 442 | +484 | ! |
- new_title <-+ x_cl = x_cl, |
|||
| 443 | +485 | ! |
- if (association) {
+ resp_cl = resp_cl, |
|||
| 444 | +486 | ! |
- switch(as.character(length(vars_names)),+ hjust_value = if (swap_axes) "left" else "middle", |
|||
| 445 | +487 | ! |
- "0" = sprintf("Value distribution for %s", ref_cl_lbl),
+ vjust_value = if (swap_axes) "middle" else -1, |
|||
| 446 | +488 | ! |
- "1" = sprintf(+ position_anl2_value = if (!freq) quote(position_fill(0.5)) else quote(position_stack(0.5)), # nolint: line_length. |
|||
| 447 | +489 | ! |
- "Association between %s and %s",+ anl3_y = if (!freq) 1.1 else as.name("ns"),
|
|||
| 448 | +490 | ! |
- ref_cl_lbl,+ position_anl3_value = if (!freq) "fill" else "stack" |
|||
| 449 | -! | +|||||
| 491 | +
- format_varnames(vars_names)+ ) |
|||||
| 450 | +492 |
- ),+ ) |
||||
| 451 | -! | +|||||
| 493 | +
- sprintf(+ } |
|||||
| 452 | -! | +|||||
| 494 | +
- "Associations between %s and: %s",+ |
|||||
| 453 | +495 | ! |
- ref_cl_lbl,+ if (swap_axes) {
|
|||
| 454 | +496 | ! |
- paste(lapply(vars_names, format_varnames), collapse = ", ")+ plot_call <- substitute(plot_call + coord_flip(), env = list(plot_call = plot_call)) |
|||
| 455 | +497 |
- )+ } |
||||
| 456 | +498 |
- )+ + |
+ ||||
| 499 | +! | +
+ facet_cl <- facet_ggplot_call(row_facet_name, col_facet_name) |
||||
| 457 | +500 |
- } else {
+
|
||||
| 458 | +501 | ! |
- switch(as.character(length(vars_names)),+ if (!is.null(facet_cl)) {
|
|||
| 459 | +502 | ! |
- "0" = sprintf("Value distribution for %s", ref_cl_lbl),
+ plot_call <- substitute(expr = plot_call + facet_cl, env = list(plot_call = plot_call, facet_cl = facet_cl))+ |
+ |||
| 503 | ++ |
+ }+ |
+ ||||
| 504 | ++ | + | ||||
| 460 | +505 | ! |
- sprintf(+ dev_ggplot2_args <- teal.widgets::ggplot2_args( |
|||
| 461 | +506 | ! |
- "Value distributions for %s and %s",+ labs = list( |
|||
| 462 | +507 | ! |
- ref_cl_lbl,+ x = varname_w_label(x, ANL), |
|||
| 463 | +508 | ! |
- paste(lapply(vars_names, format_varnames), collapse = ", ")+ y = varname_w_label(resp_var, ANL, prefix = "Proportion of "), |
|||
| 464 | -+ | |||||
| 509 | +! |
- )+ fill = varname_w_label(resp_var, ANL) |
||||
| 465 | +510 |
- )+ ),+ |
+ ||||
| 511 | +! | +
+ theme = list(legend.position = "bottom") |
||||
| 466 | +512 |
- }+ ) |
||||
| 467 | +513 | |||||
| 468 | +514 | ! |
- teal.code::eval_code(+ if (rotate_xaxis_labels) {
|
|||
| 469 | +515 | ! |
- merged$anl_q_r(),+ dev_ggplot2_args$theme[["axis.text.x"]] <- quote(element_text(angle = 45, hjust = 1))+ |
+ |||
| 516 | ++ |
+ }+ |
+ ||||
| 517 | ++ | + | ||||
| 470 | +518 | ! |
- substitute(+ all_ggplot2_args <- teal.widgets::resolve_ggplot2_args( |
|||
| 471 | +519 | ! |
- expr = title <- new_title,+ user_plot = ggplot2_args, |
|||
| 472 | +520 | ! |
- env = list(new_title = new_title)+ module_plot = dev_ggplot2_args |
|||
| 473 | +521 |
- )+ ) |
||||
| 474 | +522 |
- ) %>%+ |
||||
| 475 | +523 | ! |
- teal.code::eval_code(+ parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args( |
|||
| 476 | +524 | ! |
- substitute(+ all_ggplot2_args, |
|||
| 477 | +525 | ! |
- expr = {
+ ggtheme = ggtheme |
|||
| 478 | -! | +|||||
| 526 | +
- plots <- plot_calls+ ) |
|||||
| 479 | -! | +|||||
| 527 | +
- p <- tern::stack_grobs(grobs = lapply(plots, ggplotGrob))+ |
|||||
| 480 | +528 | ! |
- grid::grid.newpage()+ plot_call <- substitute(expr = {
|
|||
| 481 | +529 | ! |
- grid::grid.draw(p)- |
- |||
| 482 | -- |
- },+ p <- plot_call + labs + ggthemes + themes |
||||
| 483 | +530 | ! |
- env = list(+ print(p) |
|||
| 484 | +531 | ! |
- plot_calls = do.call(+ }, env = list( |
|||
| 485 | +532 | ! |
- "call",+ plot_call = plot_call, |
|||
| 486 | +533 | ! |
- c(list("list", ref_call), var_calls),
+ labs = parsed_ggplot2_args$labs, |
|||
| 487 | +534 | ! |
- quote = TRUE+ themes = parsed_ggplot2_args$theme, |
|||
| 488 | -+ | |||||
| 535 | +! |
- )+ ggthemes = parsed_ggplot2_args$ggtheme |
||||
| 489 | +536 |
- )+ )) |
||||
| 490 | +537 |
- )+ |
||||
| 491 | -+ | |||||
| 538 | +! |
- )+ teal.code::eval_code(qenv, plot_call) |
||||
| 492 | +539 |
}) |
||||
| 493 | +540 | |||||
| 494 | -! | -
- plot_r <- reactive({
- |
- ||||
| 495 | -! | -
- req(iv_r()$is_valid())- |
- ||||
| 496 | +541 | ! |
- output_q()[["p"]]+ plot_r <- reactive(output_q()[["p"]]) |
|||
| 497 | +542 |
- })+ |
||||
| 498 | +543 |
-
+ # Insert the plot into a plot_with_settings module from teal.widgets |
||||
| 499 | +544 | ! |
pws <- teal.widgets::plot_with_settings_srv( |
|||
| 500 | +545 | ! |
id = "myplot", |
|||
| 501 | +546 | ! |
plot_r = plot_r, |
|||
| 502 | +547 | ! |
height = plot_height, |
|||
| 503 | +548 | ! |
width = plot_width |
|||
| 504 | +549 |
) |
||||
| 505 | -- | - - | -||||
| 506 | -! | -
- output$title <- renderText({
- |
- ||||
| 507 | -! | -
- teal.code::dev_suppress(output_q()[["title"]])- |
- ||||
| 508 | -- |
- })- |
- ||||
| 509 | +550 | |||||
| 510 | +551 | ! |
teal.widgets::verbatim_popup_srv( |
|||
| 511 | +552 | ! |
id = "rcode", |
|||
| 512 | +553 | ! |
verbatim_content = reactive(teal.code::get_code(output_q())), |
|||
| 513 | +554 | ! |
- title = "Association Plot"+ title = "Show R Code for Response" |
|||
| 514 | +555 |
) |
||||
| 515 | +556 | |||||
| 516 | +557 |
### REPORTER |
||||
| 517 | +558 | ! |
if (with_reporter) {
|
|||
| 518 | +559 | ! |
card_fun <- function(comment, label) {
|
|||
| 519 | +560 | ! |
card <- teal::report_card_template( |
|||
| 520 | +561 | ! |
- title = "Association Plot",+ title = "Response Plot", |
|||
| 521 | +562 | ! |
label = label, |
|||
| 522 | +563 | ! |
with_filter = with_filter, |
|||
| 523 | +564 | ! |
filter_panel_api = filter_panel_api |
|||
| 524 | +565 |
) |
||||
| 525 | +566 | ! |
card$append_text("Plot", "header3")
|
|||
| 526 | +567 | ! |
card$append_plot(plot_r(), dim = pws$dim()) |
|||
| 527 | +568 | ! |
if (!comment == "") {
|
|||
| 528 | +569 | ! |
card$append_text("Comment", "header3")
|
|||
| 529 | +570 | ! |
card$append_text(comment) |
|||
| 530 | +571 |
} |
||||
| 531 | +572 | ! |
card$append_src(teal.code::get_code(output_q())) |
|||
| 532 | +573 | ! |
card |
|||
| 533 | +574 |
} |
||||
| 534 | +575 | ! |
teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
|
|||
| 535 | +576 |
} |
||||
| 536 | +577 |
### |
||||
| 537 | +578 |
}) |
||||
| 538 | +579 |
}@@ -87884,7 +87884,7 @@ teal.modules.general coverage - 3.44% | 140 | ! |
- if (shiny::isRunning()) logger::log_shiny_input_changes(input, namespace = "teal.modules.general")+ teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.general") |
|