| 1 |
- #' `teal` module: Distribution analysis+ #' `teal` module: Scatterplot |
||
| 3 |
- #' Module is designed to explore the distribution of a single variable within a given dataset.+ #' Generates a customizable scatterplot using `ggplot2`. |
||
| 4 |
- #' It offers several tools, such as histograms, Q-Q plots, and various statistical tests to+ #' This module allows users to select variables for the x and y axes, |
||
| 5 |
- #' visually and statistically analyze the variable's distribution.+ #' color and size encodings, faceting options, and more. It supports log transformations, |
||
| 6 |
- #'+ #' trend line additions, and dynamic adjustments of point opacity and size through UI controls. |
||
| 7 |
- #' @inheritParams teal::module+ #' |
||
| 8 |
- #' @inheritParams teal.widgets::standard_layout+ #' @note For more examples, please see the vignette "Using scatterplot" via |
||
| 9 |
- #' @inheritParams shared_params+ #' `vignette("using-scatterplot", package = "teal.modules.general")`.
|
||
| 11 |
- #' @param dist_var (`data_extract_spec` or `list` of multiple `data_extract_spec`)+ #' @inheritParams teal::module |
||
| 12 |
- #' Variable(s) for which the distribution will be analyzed.+ #' @inheritParams shared_params |
||
| 13 |
- #' @param strata_var (`data_extract_spec` or `list` of multiple `data_extract_spec`)+ #' @param x (`data_extract_spec` or `list` of multiple `data_extract_spec`) Specifies |
||
| 14 |
- #' Categorical variable used to split the distribution analysis.+ #' variable names selected to plot along the x-axis by default. |
||
| 15 |
- #' @param group_var (`data_extract_spec` or `list` of multiple `data_extract_spec`)+ #' @param y (`data_extract_spec` or `list` of multiple `data_extract_spec`) Specifies |
||
| 16 |
- #' Variable used for faceting plot into multiple panels.+ #' variable names selected to plot along the y-axis by default. |
||
| 17 |
- #' @param freq (`logical`) optional, whether to display frequency (`TRUE`) or density (`FALSE`).+ #' @param color_by (`data_extract_spec` or `list` of multiple `data_extract_spec`) optional, |
||
| 18 |
- #' Defaults to density (`FALSE`).+ #' defines the color encoding. If `NULL` then no color encoding option will be displayed. |
||
| 19 |
- #' @param bins (`integer(1)` or `integer(3)`) optional, specifies the number of bins for the histogram.+ #' @param size_by (`data_extract_spec` or `list` of multiple `data_extract_spec`) optional, |
||
| 20 |
- #' - When the length of `bins` is one: The histogram bins will have a fixed size based on the `bins` provided.+ #' defines the point size encoding. If `NULL` then no size encoding option will be displayed. |
||
| 21 |
- #' - When the length of `bins` is three: The histogram bins are dynamically adjusted based on vector of `value`, `min`,+ #' @param row_facet (`data_extract_spec` or `list` of multiple `data_extract_spec`) optional, |
||
| 22 |
- #' and `max`.+ #' specifies the variable(s) for faceting rows. |
||
| 23 |
- #' Defaults to `c(30L, 1L, 100L)`.+ #' @param col_facet (`data_extract_spec` or `list` of multiple `data_extract_spec`) optional, |
||
| 24 |
- #'+ #' specifies the variable(s) for faceting columns. |
||
| 25 |
- #' @templateVar ggnames "Histogram", "QQplot"+ #' @param shape (`character`) optional, character vector with the names of the |
||
| 26 |
- #' @template ggplot2_args_multi+ #' shape, e.g. `c("triangle", "square", "circle")`. It defaults to `shape_names`. This is a complete list from
|
||
| 27 |
- #'+ #' `vignette("ggplot2-specs", package="ggplot2")`.
|
||
| 28 |
- #' @inherit shared_params return+ #' @param max_deg (`integer`) optional, maximum degree for the polynomial trend line. Must not be less than 1. |
||
| 29 |
- #'+ #' @param table_dec (`integer`) optional, number of decimal places used to round numeric values in the table. |
||
| 30 |
- #' @examplesShinylive+ #' |
||
| 31 |
- #' library(teal.modules.general)+ #' @inherit shared_params return |
||
| 32 |
- #' interactive <- function() TRUE+ #' |
||
| 33 |
- #' {{ next_example }}
+ #' @examplesShinylive |
||
| 34 |
- # nolint start: line_length_linter.+ #' library(teal.modules.general) |
||
| 35 |
- #' @examplesIf require("ggpmisc", quietly = TRUE) && require("ggpp", quietly = TRUE) && require("goftest", quietly = TRUE) && require("MASS", quietly = TRUE) && require("broom", quietly = TRUE)
+ #' interactive <- function() TRUE |
||
| 36 |
- # nolint end: line_length_linter.+ #' {{ next_example }}
|
||
| 37 |
- #' # general data example+ # nolint start: line_length_linter. |
||
| 38 |
- #' data <- teal_data()+ #' @examplesIf require("ggpmisc", quietly = TRUE) && require("ggExtra", quietly = TRUE) && require("colourpicker", quietly = TRUE)
|
||
| 39 |
- #' data <- within(data, {
+ # nolint end: line_length_linter. |
||
| 40 |
- #' iris <- iris+ #' # general data example |
||
| 41 |
- #' })+ #' data <- teal_data() |
||
| 42 |
- #' datanames(data) <- "iris"+ #' data <- within(data, {
|
||
| 43 |
- #'+ #' require(nestcolor) |
||
| 44 |
- #' app <- init(+ #' CO2 <- CO2 |
||
| 45 |
- #' data = data,+ #' }) |
||
| 46 |
- #' modules = list(+ #' |
||
| 47 |
- #' tm_g_distribution(+ #' app <- init( |
||
| 48 |
- #' dist_var = data_extract_spec(+ #' data = data, |
||
| 49 |
- #' dataname = "iris",+ #' modules = modules( |
||
| 50 |
- #' select = select_spec(variable_choices("iris"), "Petal.Length")
+ #' tm_g_scatterplot( |
||
| 51 |
- #' )+ #' label = "Scatterplot Choices", |
||
| 52 |
- #' )+ #' x = data_extract_spec( |
||
| 53 |
- #' )+ #' dataname = "CO2", |
||
| 54 |
- #' )+ #' select = select_spec( |
||
| 55 |
- #' if (interactive()) {
+ #' label = "Select variable:", |
||
| 56 |
- #' shinyApp(app$ui, app$server)+ #' choices = variable_choices(data[["CO2"]], c("conc", "uptake")),
|
||
| 57 |
- #' }+ #' selected = "conc", |
||
| 58 |
- #'+ #' multiple = FALSE, |
||
| 59 |
- #' @examplesShinylive+ #' fixed = FALSE |
||
| 60 |
- #' library(teal.modules.general)+ #' ) |
||
| 61 |
- #' interactive <- function() TRUE+ #' ), |
||
| 62 |
- #' {{ next_example }}
+ #' y = data_extract_spec( |
||
| 63 |
- # nolint start: line_length_linter.+ #' dataname = "CO2", |
||
| 64 |
- #' @examplesIf require("ggpmisc", quietly = TRUE) && require("ggpp", quietly = TRUE) && require("goftest", quietly = TRUE) && require("MASS", quietly = TRUE) && require("broom", quietly = TRUE)
+ #' select = select_spec( |
||
| 65 |
- # nolint end: line_length_linter.+ #' label = "Select variable:", |
||
| 66 |
- #' # CDISC data example+ #' choices = variable_choices(data[["CO2"]], c("conc", "uptake")),
|
||
| 67 |
- #' data <- teal_data()+ #' selected = "uptake", |
||
| 68 |
- #' data <- within(data, {
+ #' multiple = FALSE, |
||
| 69 |
- #' ADSL <- rADSL+ #' fixed = FALSE |
||
| 70 |
- #' })+ #' ) |
||
| 71 |
- #' datanames(data) <- c("ADSL")
+ #' ), |
||
| 72 |
- #' join_keys(data) <- default_cdisc_join_keys[datanames(data)]+ #' color_by = data_extract_spec( |
||
| 73 |
- #'+ #' dataname = "CO2", |
||
| 74 |
- #' vars1 <- choices_selected(+ #' select = select_spec( |
||
| 75 |
- #' variable_choices(data[["ADSL"]], c("ARM", "COUNTRY", "SEX")),
+ #' label = "Select variable:", |
||
| 76 |
- #' selected = NULL+ #' choices = variable_choices( |
||
| 77 |
- #' )+ #' data[["CO2"]], |
||
| 78 |
- #'+ #' c("Plant", "Type", "Treatment", "conc", "uptake")
|
||
| 79 |
- #' app <- init(+ #' ), |
||
| 80 |
- #' data = data,+ #' selected = NULL, |
||
| 81 |
- #' modules = modules(+ #' multiple = FALSE, |
||
| 82 |
- #' tm_g_distribution(+ #' fixed = FALSE |
||
| 83 |
- #' dist_var = data_extract_spec(+ #' ) |
||
| 84 |
- #' dataname = "ADSL",+ #' ), |
||
| 85 |
- #' select = select_spec(+ #' size_by = data_extract_spec( |
||
| 86 |
- #' choices = variable_choices(data[["ADSL"]], c("AGE", "BMRKR1")),
+ #' dataname = "CO2", |
||
| 87 |
- #' selected = "BMRKR1",+ #' select = select_spec( |
||
| 88 |
- #' multiple = FALSE,+ #' label = "Select variable:", |
||
| 89 |
- #' fixed = FALSE+ #' choices = variable_choices(data[["CO2"]], c("conc", "uptake")),
|
||
| 90 |
- #' )+ #' selected = "uptake", |
||
| 91 |
- #' ),+ #' multiple = FALSE, |
||
| 92 |
- #' strata_var = data_extract_spec(+ #' fixed = FALSE |
||
| 93 |
- #' dataname = "ADSL",+ #' ) |
||
| 94 |
- #' filter = filter_spec(+ #' ), |
||
| 95 |
- #' vars = vars1,+ #' row_facet = data_extract_spec( |
||
| 96 |
- #' multiple = TRUE+ #' dataname = "CO2", |
||
| 97 |
- #' )+ #' select = select_spec( |
||
| 98 |
- #' ),+ #' label = "Select variable:", |
||
| 99 |
- #' group_var = data_extract_spec(+ #' choices = variable_choices(data[["CO2"]], c("Plant", "Type", "Treatment")),
|
||
| 100 |
- #' dataname = "ADSL",+ #' selected = NULL, |
||
| 101 |
- #' filter = filter_spec(+ #' multiple = FALSE, |
||
| 102 |
- #' vars = vars1,+ #' fixed = FALSE |
||
| 103 |
- #' multiple = TRUE+ #' ) |
||
| 104 |
- #' )+ #' ), |
||
| 105 |
- #' )+ #' col_facet = data_extract_spec( |
||
| 106 |
- #' )+ #' dataname = "CO2", |
||
| 107 |
- #' )+ #' select = select_spec( |
||
| 108 |
- #' )+ #' label = "Select variable:", |
||
| 109 |
- #' if (interactive()) {
+ #' choices = variable_choices(data[["CO2"]], c("Plant", "Type", "Treatment")),
|
||
| 110 |
- #' shinyApp(app$ui, app$server)+ #' selected = NULL, |
||
| 111 |
- #' }+ #' multiple = FALSE, |
||
| 112 |
- #'+ #' fixed = FALSE |
||
| 113 |
- #' @export+ #' ) |
||
| 114 |
- #'+ #' ) |
||
| 115 |
- tm_g_distribution <- function(label = "Distribution Module",+ #' ) |
||
| 116 |
- dist_var,+ #' ) |
||
| 117 |
- strata_var = NULL,+ #' ) |
||
| 118 |
- group_var = NULL,+ #' if (interactive()) {
|
||
| 119 |
- freq = FALSE,+ #' shinyApp(app$ui, app$server) |
||
| 120 |
- ggtheme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void"),
+ #' } |
||
| 121 |
- ggplot2_args = teal.widgets::ggplot2_args(),+ #' |
||
| 122 |
- bins = c(30L, 1L, 100L),+ #' @examplesShinylive |
||
| 123 |
- plot_height = c(600, 200, 2000),+ #' library(teal.modules.general) |
||
| 124 |
- plot_width = NULL,+ #' interactive <- function() TRUE |
||
| 125 |
- pre_output = NULL,+ #' {{ next_example }}
|
||
| 126 |
- post_output = NULL) {
+ # nolint start: line_length_linter. |
||
| 127 | -! | +
- message("Initializing tm_g_distribution")
+ #' @examplesIf require("ggpmisc", quietly = TRUE) && require("ggExtra", quietly = TRUE) && require("colourpicker", quietly = TRUE)
|
|
| 128 |
-
+ # nolint end: line_length_linter. |
||
| 129 |
- # Requires Suggested packages+ #' # CDISC data example |
||
| 130 | -! | +
- extra_packages <- c("ggpmisc", "ggpp", "goftest", "MASS", "broom")
+ #' data <- teal_data() |
|
| 131 | -! | +
- missing_packages <- Filter(function(x) !requireNamespace(x, quietly = TRUE), extra_packages)+ #' data <- within(data, {
|
|
| 132 | -! | +
- if (length(missing_packages) > 0L) {
+ #' require(nestcolor) |
|
| 133 | -! | +
- stop(sprintf(+ #' ADSL <- rADSL |
|
| 134 | -! | +
- "Cannot load package(s): %s.\nInstall or restart your session.",+ #' }) |
|
| 135 | -! | +
- toString(missing_packages)+ #' join_keys(data) <- default_cdisc_join_keys[names(data)] |
|
| 136 |
- ))+ #' |
||
| 137 |
- }+ #' app <- init( |
||
| 138 |
-
+ #' data = data, |
||
| 139 |
- # Normalize the parameters+ #' modules = modules( |
||
| 140 | -! | +
- if (inherits(dist_var, "data_extract_spec")) dist_var <- list(dist_var)+ #' tm_g_scatterplot( |
|
| 141 | -! | +
- if (inherits(strata_var, "data_extract_spec")) strata_var <- list(strata_var)+ #' label = "Scatterplot Choices", |
|
| 142 | -! | +
- if (inherits(group_var, "data_extract_spec")) group_var <- list(group_var)+ #' x = data_extract_spec( |
|
| 143 | -! | +
- if (inherits(ggplot2_args, "ggplot2_args")) ggplot2_args <- list(default = ggplot2_args)+ #' dataname = "ADSL", |
|
| 144 |
-
+ #' select = select_spec( |
||
| 145 |
- # Start of assertions+ #' label = "Select variable:", |
||
| 146 | -! | +
- checkmate::assert_string(label)+ #' choices = variable_choices(data[["ADSL"]], c("AGE", "BMRKR1", "BMRKR2")),
|
|
| 147 |
-
+ #' selected = "AGE", |
||
| 148 | -! | +
- checkmate::assert_list(dist_var, "data_extract_spec")+ #' multiple = FALSE, |
|
| 149 | -! | +
- checkmate::assert_false(dist_var[[1L]]$select$multiple)+ #' fixed = FALSE |
|
| 150 |
-
+ #' ) |
||
| 151 | -! | +
- checkmate::assert_list(strata_var, types = "data_extract_spec", null.ok = TRUE)+ #' ), |
|
| 152 | -! | +
- checkmate::assert_list(group_var, types = "data_extract_spec", null.ok = TRUE)+ #' y = data_extract_spec( |
|
| 153 | -! | +
- checkmate::assert_flag(freq)+ #' dataname = "ADSL", |
|
| 154 | -! | +
- ggtheme <- match.arg(ggtheme)+ #' select = select_spec( |
|
| 155 |
-
+ #' label = "Select variable:", |
||
| 156 | -! | +
- plot_choices <- c("Histogram", "QQplot")
+ #' choices = variable_choices(data[["ADSL"]], c("AGE", "BMRKR1", "BMRKR2")),
|
|
| 157 | -! | +
- checkmate::assert_list(ggplot2_args, types = "ggplot2_args")+ #' selected = "BMRKR1", |
|
| 158 | -! | +
- checkmate::assert_subset(names(ggplot2_args), c("default", plot_choices))
+ #' multiple = FALSE, |
|
| 159 |
-
+ #' fixed = FALSE |
||
| 160 | -! | +
- if (length(bins) == 1) {
+ #' ) |
|
| 161 | -! | +
- checkmate::assert_numeric(bins, any.missing = FALSE, lower = 1)+ #' ), |
|
| 162 |
- } else {
+ #' color_by = data_extract_spec( |
||
| 163 | -! | +
- checkmate::assert_numeric(bins, len = 3, any.missing = FALSE, lower = 1)+ #' dataname = "ADSL", |
|
| 164 | -! | +
- checkmate::assert_numeric(bins[1], lower = bins[2], upper = bins[3], .var.name = "bins")+ #' select = select_spec( |
|
| 165 |
- }+ #' label = "Select variable:", |
||
| 166 |
-
+ #' choices = variable_choices( |
||
| 167 | -! | +
- checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE)+ #' data[["ADSL"]], |
|
| 168 | -! | +
- checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height")+ #' c("AGE", "BMRKR1", "BMRKR2", "RACE", "REGION1")
|
|
| 169 | -! | +
- checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE)+ #' ), |
|
| 170 | -! | +
- checkmate::assert_numeric(+ #' selected = NULL, |
|
| 171 | -! | +
- plot_width[1],+ #' multiple = FALSE, |
|
| 172 | -! | +
- lower = plot_width[2], upper = plot_width[3], null.ok = TRUE, .var.name = "plot_width"+ #' fixed = FALSE |
|
| 173 |
- )+ #' ) |
||
| 174 |
-
+ #' ), |
||
| 175 | -! | +
- checkmate::assert_multi_class(pre_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
+ #' size_by = data_extract_spec( |
|
| 176 | -! | +
- checkmate::assert_multi_class(post_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
+ #' dataname = "ADSL", |
|
| 177 |
- # End of assertions+ #' select = select_spec( |
||
| 178 |
-
+ #' label = "Select variable:", |
||
| 179 |
- # Make UI args+ #' choices = variable_choices(data[["ADSL"]], c("AGE", "BMRKR1")),
|
||
| 180 | -! | +
- args <- as.list(environment())+ #' selected = "AGE", |
|
| 181 |
-
+ #' multiple = FALSE, |
||
| 182 | -! | +
- data_extract_list <- list(+ #' fixed = FALSE |
|
| 183 | -! | +
- dist_var = dist_var,+ #' ) |
|
| 184 | -! | +
- strata_var = strata_var,+ #' ), |
|
| 185 | -! | +
- group_var = group_var+ #' row_facet = data_extract_spec( |
|
| 186 |
- )+ #' dataname = "ADSL", |
||
| 187 |
-
+ #' select = select_spec( |
||
| 188 | -! | +
- ans <- module(+ #' label = "Select variable:", |
|
| 189 | -! | +
- label = label,+ #' choices = variable_choices(data[["ADSL"]], c("BMRKR2", "RACE", "REGION1")),
|
|
| 190 | -! | +
- server = srv_distribution,+ #' selected = NULL, |
|
| 191 | -! | +
- server_args = c(+ #' multiple = FALSE, |
|
| 192 | -! | +
- data_extract_list,+ #' fixed = FALSE |
|
| 193 | -! | +
- list(plot_height = plot_height, plot_width = plot_width, ggplot2_args = ggplot2_args)+ #' ) |
|
| 194 |
- ),+ #' ), |
||
| 195 | -! | +
- ui = ui_distribution,+ #' col_facet = data_extract_spec( |
|
| 196 | -! | +
- ui_args = args,+ #' dataname = "ADSL", |
|
| 197 | -! | +
- datanames = teal.transform::get_extract_datanames(data_extract_list)+ #' select = select_spec( |
|
| 198 |
- )+ #' label = "Select variable:", |
||
| 199 | -! | +
- attr(ans, "teal_bookmarkable") <- TRUE+ #' choices = variable_choices(data[["ADSL"]], c("BMRKR2", "RACE", "REGION1")),
|
|
| 200 | -! | +
- ans+ #' selected = NULL, |
|
| 201 |
- }+ #' multiple = FALSE, |
||
| 202 |
-
+ #' fixed = FALSE |
||
| 203 |
- # UI function for the distribution module+ #' ) |
||
| 204 |
- ui_distribution <- function(id, ...) {
+ #' ) |
||
| 205 | -! | +
- args <- list(...)+ #' ) |
|
| 206 | -! | +
- ns <- NS(id)+ #' ) |
|
| 207 | -! | +
- is_single_dataset_value <- teal.transform::is_single_dataset(args$dist_var, args$strata_var, args$group_var)+ #' ) |
|
| 208 |
-
+ #' if (interactive()) {
|
||
| 209 | -! | +
- teal.widgets::standard_layout(+ #' shinyApp(app$ui, app$server) |
|
| 210 | -! | +
- output = teal.widgets::white_small_well(+ #' } |
|
| 211 | -! | +
- tabsetPanel(+ #' |
|
| 212 | -! | +
- id = ns("tabs"),
+ #' @export |
|
| 213 | -! | +
- tabPanel("Histogram", teal.widgets::plot_with_settings_ui(id = ns("hist_plot"))),
+ #' |
|
| 214 | -! | +
- tabPanel("QQplot", teal.widgets::plot_with_settings_ui(id = ns("qq_plot")))
+ tm_g_scatterplot <- function(label = "Scatterplot", |
|
| 215 |
- ),+ x, |
||
| 216 | -! | +
- tags$h3("Statistics Table"),
+ y, |
|
| 217 | -! | +
- DT::dataTableOutput(ns("summary_table")),
+ color_by = NULL, |
|
| 218 | -! | +
- tags$h3("Tests"),
+ size_by = NULL, |
|
| 219 | -! | +
- DT::dataTableOutput(ns("t_stats"))
+ row_facet = NULL, |
|
| 220 |
- ),+ col_facet = NULL, |
||
| 221 | -! | +
- encoding = tags$div(+ plot_height = c(600, 200, 2000), |
|
| 222 |
- ### Reporter+ plot_width = NULL, |
||
| 223 | -! | +
- teal.reporter::simple_reporter_ui(ns("simple_reporter")),
+ alpha = c(1, 0, 1), |
|
| 224 |
- ###+ shape = shape_names, |
||
| 225 | -! | +
- tags$label("Encodings", class = "text-primary"),
+ size = c(5, 1, 15), |
|
| 226 | -! | +
- teal.transform::datanames_input(args[c("dist_var", "strata_var")]),
+ max_deg = 5L, |
|
| 227 | -! | +
- teal.transform::data_extract_ui(+ rotate_xaxis_labels = FALSE, |
|
| 228 | -! | +
- id = ns("dist_i"),
+ ggtheme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void"),
|
|
| 229 | -! | +
- label = "Variable",+ pre_output = NULL, |
|
| 230 | -! | +
- data_extract_spec = args$dist_var,+ post_output = NULL, |
|
| 231 | -! | +
- is_single_dataset = is_single_dataset_value+ table_dec = 4, |
|
| 232 |
- ),+ ggplot2_args = teal.widgets::ggplot2_args()) {
|
||
| 233 | ! |
- if (!is.null(args$group_var)) {
+ message("Initializing tm_g_scatterplot")
|
|
| 234 | -! | +
- tagList(+ |
|
| 235 | -! | +
- teal.transform::data_extract_ui(+ # Requires Suggested packages |
|
| 236 | ! |
- id = ns("group_i"),
+ extra_packages <- c("ggpmisc", "ggExtra", "colourpicker")
|
|
| 237 | ! |
- label = "Group by",+ missing_packages <- Filter(function(x) !requireNamespace(x, quietly = TRUE), extra_packages) |
|
| 238 | ! |
- data_extract_spec = args$group_var,+ if (length(missing_packages) > 0L) {
|
|
| 239 | ! |
- is_single_dataset = is_single_dataset_value+ stop(sprintf( |
|
| 240 | -+ | ! |
- ),+ "Cannot load package(s): %s.\nInstall or restart your session.", |
| 241 | ! |
- uiOutput(ns("scales_types_ui"))
+ toString(missing_packages) |
|
| 242 |
- )+ )) |
||
| 243 |
- },+ } |
||
| 244 | -! | +
- if (!is.null(args$strata_var)) {
+
|
|
| 245 | -! | +
- teal.transform::data_extract_ui(+ # Normalize the parameters |
|
| 246 | ! |
- id = ns("strata_i"),
+ if (inherits(x, "data_extract_spec")) x <- list(x) |
|
| 247 | ! |
- label = "Stratify by",+ if (inherits(y, "data_extract_spec")) y <- list(y) |
|
| 248 | ! |
- data_extract_spec = args$strata_var,+ if (inherits(color_by, "data_extract_spec")) color_by <- list(color_by) |
|
| 249 | ! |
- is_single_dataset = is_single_dataset_value+ if (inherits(size_by, "data_extract_spec")) size_by <- list(size_by) |
|
| 250 | -+ | ! |
- )+ if (inherits(row_facet, "data_extract_spec")) row_facet <- list(row_facet) |
| 251 | -+ | ! |
- },+ if (inherits(col_facet, "data_extract_spec")) col_facet <- list(col_facet) |
| 252 | ! |
- teal.widgets::panel_group(+ if (is.double(max_deg)) max_deg <- as.integer(max_deg) |
|
| 253 | -! | +
- conditionalPanel(+ |
|
| 254 | -! | +
- condition = paste0("input['", ns("tabs"), "'] == 'Histogram'"),
+ # Start of assertions |
|
| 255 | ! |
- teal.widgets::panel_item(+ checkmate::assert_string(label) |
|
| 256 | ! |
- "Histogram",+ checkmate::assert_list(x, types = "data_extract_spec") |
|
| 257 | ! |
- teal.widgets::optionalSliderInputValMinMax(ns("bins"), "Bins", args$bins, ticks = FALSE, step = 1),
+ checkmate::assert_list(y, types = "data_extract_spec") |
|
| 258 | ! |
- shinyWidgets::prettyRadioButtons(+ checkmate::assert_list(color_by, types = "data_extract_spec", null.ok = TRUE) |
|
| 259 | ! |
- ns("main_type"),
+ checkmate::assert_list(size_by, types = "data_extract_spec", null.ok = TRUE) |
|
| 260 | -! | +
- label = "Plot Type:",+ |
|
| 261 | ! |
- choices = c("Density", "Frequency"),
+ checkmate::assert_list(row_facet, types = "data_extract_spec", null.ok = TRUE) |
|
| 262 | ! |
- selected = if (!args$freq) "Density" else "Frequency",+ assert_single_selection(row_facet) |
|
| 263 | -! | +
- bigger = FALSE,+ |
|
| 264 | ! |
- inline = TRUE+ checkmate::assert_list(col_facet, types = "data_extract_spec", null.ok = TRUE) |
|
| 265 | -+ | ! |
- ),+ assert_single_selection(col_facet) |
| 266 | -! | +
- checkboxInput(ns("add_dens"), label = "Overlay Density", value = TRUE),
+
|
|
| 267 | ! |
- collapsed = FALSE+ checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE) |
|
| 268 | -+ | ! |
- )+ checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height") |
| 269 | -+ | ! |
- ),+ checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE) |
| 270 | ! |
- conditionalPanel(+ checkmate::assert_numeric( |
|
| 271 | ! |
- condition = paste0("input['", ns("tabs"), "'] == 'QQplot'"),
+ plot_width[1], |
|
| 272 | ! |
- teal.widgets::panel_item(+ lower = plot_width[2], upper = plot_width[3], null.ok = TRUE, .var.name = "plot_width" |
|
| 273 | -! | +
- "QQ Plot",+ ) |
|
| 274 | -! | +
- checkboxInput(ns("qq_line"), label = "Add diagonal line(s)", TRUE),
+
|
|
| 275 | ! |
- collapsed = FALSE+ if (length(alpha) == 1) {
|
|
| 276 | -+ | ! |
- )+ checkmate::assert_numeric(alpha, any.missing = FALSE, finite = TRUE) |
| 277 |
- ),+ } else {
|
||
| 278 | ! |
- conditionalPanel(+ checkmate::assert_numeric(alpha, len = 3, any.missing = FALSE, finite = TRUE) |
|
| 279 | ! |
- condition = paste0("input['", ns("main_type"), "'] == 'Density'"),
+ checkmate::assert_numeric(alpha[1], lower = alpha[2], upper = alpha[3], .var.name = "alpha") |
|
| 280 | -! | +
- teal.widgets::panel_item(+ } |
|
| 281 | -! | +
- "Theoretical Distribution",+ |
|
| 282 | ! |
- teal.widgets::optionalSelectInput(+ checkmate::assert_character(shape) |
|
| 283 | -! | +
- ns("t_dist"),
+
|
|
| 284 | ! |
- tags$div(+ if (length(size) == 1) {
|
|
| 285 | ! |
- class = "teal-tooltip",+ checkmate::assert_numeric(size, any.missing = FALSE, finite = TRUE) |
|
| 286 | -! | +
- tagList(+ } else {
|
|
| 287 | ! |
- "Distribution:",+ checkmate::assert_numeric(size, len = 3, any.missing = FALSE, finite = TRUE) |
|
| 288 | ! |
- icon("circle-info"),
+ checkmate::assert_numeric(size[1], lower = size[2], upper = size[3], .var.name = "size") |
|
| 289 | -! | +
- tags$span(+ } |
|
| 290 | -! | +
- class = "tooltiptext",+ |
|
| 291 | ! |
- "Default parameters are optimized with MASS::fitdistr function."+ checkmate::assert_int(max_deg, lower = 1L) |
|
| 292 | -+ | ! |
- )+ checkmate::assert_flag(rotate_xaxis_labels) |
| 293 | -+ | ! |
- )+ ggtheme <- match.arg(ggtheme) |
| 294 |
- ),+ |
||
| 295 | ! |
- choices = c("normal", "lognormal", "gamma", "unif"),
+ checkmate::assert_multi_class(pre_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
|
|
| 296 | ! |
- selected = NULL,+ checkmate::assert_multi_class(post_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
|
|
| 297 | -! | +
- multiple = FALSE+ |
|
| 298 | -+ | ! |
- ),+ checkmate::assert_scalar(table_dec) |
| 299 | ! |
- numericInput(ns("dist_param1"), label = "param1", value = NULL),
+ checkmate::assert_class(ggplot2_args, "ggplot2_args") |
|
| 300 | -! | +
- numericInput(ns("dist_param2"), label = "param2", value = NULL),
+ # End of assertions |
|
| 301 | -! | +
- tags$span(actionButton(ns("params_reset"), "Default params")),
+
|
|
| 302 | -! | +
- collapsed = FALSE+ # Make UI args |
|
| 303 | -+ | ! |
- )+ args <- as.list(environment()) |
| 304 |
- )+ |
||
| 305 | -+ | ! |
- ),+ data_extract_list <- list( |
| 306 | ! |
- teal.widgets::panel_item(+ x = x, |
|
| 307 | ! |
- "Tests",+ y = y, |
|
| 308 | ! |
- teal.widgets::optionalSelectInput(+ color_by = color_by, |
|
| 309 | ! |
- ns("dist_tests"),
+ size_by = size_by, |
|
| 310 | ! |
- "Tests:",+ row_facet = row_facet, |
|
| 311 | ! |
- choices = c(+ col_facet = col_facet |
|
| 312 | -! | +
- "Shapiro-Wilk",+ ) |
|
| 313 | -! | +
- if (!is.null(args$strata_var)) "t-test (two-samples, not paired)",+ |
|
| 314 | ! |
- if (!is.null(args$strata_var)) "one-way ANOVA",+ ans <- module( |
|
| 315 | ! |
- if (!is.null(args$strata_var)) "Fligner-Killeen",+ label = label, |
|
| 316 | ! |
- if (!is.null(args$strata_var)) "F-test",+ server = srv_g_scatterplot, |
|
| 317 | ! |
- "Kolmogorov-Smirnov (one-sample)",+ ui = ui_g_scatterplot, |
|
| 318 | ! |
- "Anderson-Darling (one-sample)",+ ui_args = args, |
|
| 319 | ! |
- "Cramer-von Mises (one-sample)",+ server_args = c( |
|
| 320 | ! |
- if (!is.null(args$strata_var)) "Kolmogorov-Smirnov (two-samples)"+ data_extract_list, |
|
| 321 | -+ | ! |
- ),+ list(plot_height = plot_height, plot_width = plot_width, table_dec = table_dec, ggplot2_args = ggplot2_args) |
| 322 | -! | +
- selected = NULL+ ), |
|
| 323 | -+ | ! |
- )+ datanames = teal.transform::get_extract_datanames(data_extract_list) |
| 324 |
- ),+ ) |
||
| 325 | ! |
- teal.widgets::panel_item(+ attr(ans, "teal_bookmarkable") <- TRUE |
|
| 326 | ! |
- "Statistics Table",+ ans |
|
| 327 | -! | +
- sliderInput(ns("roundn"), "Round to n digits", min = 0, max = 10, value = 2)
+ } |
|
| 328 |
- ),+ |
||
| 329 | -! | +
- teal.widgets::panel_item(+ # UI function for the scatterplot module |
|
| 330 | -! | +
- title = "Plot settings",+ ui_g_scatterplot <- function(id, ...) {
|
|
| 331 | ! |
- selectInput(+ args <- list(...) |
|
| 332 | ! |
- inputId = ns("ggtheme"),
+ ns <- NS(id) |
|
| 333 | ! |
- label = "Theme (by ggplot):",+ is_single_dataset_value <- teal.transform::is_single_dataset( |
|
| 334 | ! |
- choices = ggplot_themes,+ args$x, args$y, args$color_by, args$size_by, args$row_facet, args$col_facet |
|
| 335 | -! | +
- selected = args$ggtheme,+ ) |
|
| 336 | -! | +
- multiple = FALSE+ |
|
| 337 | -+ | ! |
- )+ tagList( |
| 338 | -+ | ! |
- )+ include_css_files("custom"),
|
| 339 | -+ | ! |
- ),+ teal.widgets::standard_layout( |
| 340 | ! |
- forms = tagList(+ output = teal.widgets::white_small_well( |
|
| 341 | ! |
- teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code")
+ teal.widgets::plot_with_settings_ui(id = ns("scatter_plot")),
|
|
| 342 | -+ | ! |
- ),+ tags$h1(tags$strong("Selected points:"), class = "text-center font-150p"),
|
| 343 | ! |
- pre_output = args$pre_output,+ teal.widgets::get_dt_rows(ns("data_table"), ns("data_table_rows")),
|
|
| 344 | ! |
- post_output = args$post_output+ DT::dataTableOutput(ns("data_table"), width = "100%")
|
|
| 345 |
- )+ ), |
||
| 346 | -+ | ! |
- }+ encoding = tags$div( |
| 347 |
-
+ ### Reporter |
||
| 348 | -+ | ! |
- # Server function for the distribution module+ teal.reporter::simple_reporter_ui(ns("simple_reporter")),
|
| 349 |
- srv_distribution <- function(id,+ ### |
||
| 350 | -+ | ! |
- data,+ tags$label("Encodings", class = "text-primary"),
|
| 351 | -+ | ! |
- reporter,+ teal.transform::datanames_input(args[c("x", "y", "color_by", "size_by", "row_facet", "col_facet")]),
|
| 352 | -+ | ! |
- filter_panel_api,+ teal.transform::data_extract_ui( |
| 353 | -+ | ! |
- dist_var,+ id = ns("x"),
|
| 354 | -+ | ! |
- strata_var,+ label = "X variable", |
| 355 | -+ | ! |
- group_var,+ data_extract_spec = args$x, |
| 356 | -+ | ! |
- plot_height,+ is_single_dataset = is_single_dataset_value |
| 357 |
- plot_width,+ ), |
||
| 358 | -+ | ! |
- ggplot2_args) {
+ checkboxInput(ns("log_x"), "Use log transformation", value = FALSE),
|
| 359 | ! |
- with_reporter <- !missing(reporter) && inherits(reporter, "Reporter")+ conditionalPanel( |
|
| 360 | ! |
- with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI")+ condition = paste0("input['", ns("log_x"), "'] == true"),
|
|
| 361 | ! |
- checkmate::assert_class(data, "reactive")+ radioButtons( |
|
| 362 | ! |
- checkmate::assert_class(isolate(data()), "teal_data")+ ns("log_x_base"),
|
|
| 363 | ! |
- moduleServer(id, function(input, output, session) {
+ label = NULL, |
|
| 364 | ! |
- teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.general")+ inline = TRUE, |
|
| 365 | -+ | ! |
-
+ choices = c("Natural" = "log", "Base 10" = "log10", "Base 2" = "log2")
|
| 366 | -! | +
- setBookmarkExclude("params_reset")
+ ) |
|
| 367 |
-
+ ), |
||
| 368 | ! |
- ns <- session$ns+ teal.transform::data_extract_ui( |
|
| 369 | -+ | ! |
-
+ id = ns("y"),
|
| 370 | ! |
- rule_req <- function(value) {
+ label = "Y variable", |
|
| 371 | ! |
- if (isTRUE(input$dist_tests %in% c(+ data_extract_spec = args$y, |
|
| 372 | ! |
- "Fligner-Killeen",+ is_single_dataset = is_single_dataset_value |
|
| 373 | -! | +
- "t-test (two-samples, not paired)",+ ), |
|
| 374 | ! |
- "F-test",+ checkboxInput(ns("log_y"), "Use log transformation", value = FALSE),
|
|
| 375 | ! |
- "Kolmogorov-Smirnov (two-samples)",+ conditionalPanel( |
|
| 376 | ! |
- "one-way ANOVA"+ condition = paste0("input['", ns("log_y"), "'] == true"),
|
|
| 377 | -+ | ! |
- ))) {
+ radioButtons( |
| 378 | ! |
- if (!shinyvalidate::input_provided(value)) {
+ ns("log_y_base"),
|
|
| 379 | ! |
- "Please select stratify variable."+ label = NULL, |
|
| 380 | -+ | ! |
- }+ inline = TRUE, |
| 381 | -+ | ! |
- }+ choices = c("Natural" = "log", "Base 10" = "log10", "Base 2" = "log2")
|
| 382 |
- }+ ) |
||
| 383 | -! | +
- rule_dupl <- function(...) {
+ ), |
|
| 384 | ! |
- if (identical(input$dist_tests, "Fligner-Killeen")) {
+ if (!is.null(args$color_by)) {
|
|
| 385 | ! |
- strata <- selector_list()$strata_i()$select+ teal.transform::data_extract_ui( |
|
| 386 | ! |
- group <- selector_list()$group_i()$select+ id = ns("color_by"),
|
|
| 387 | ! |
- if (isTRUE(strata == group)) {
+ label = "Color by variable", |
|
| 388 | ! |
- "Please select different variables for strata and group."+ data_extract_spec = args$color_by, |
|
| 389 | -+ | ! |
- }+ is_single_dataset = is_single_dataset_value |
| 390 |
- }+ ) |
||
| 391 |
- }+ }, |
||
| 392 | -+ | ! |
-
+ if (!is.null(args$size_by)) {
|
| 393 | ! |
- selector_list <- teal.transform::data_extract_multiple_srv(+ teal.transform::data_extract_ui( |
|
| 394 | ! |
- data_extract = list(+ id = ns("size_by"),
|
|
| 395 | ! |
- dist_i = dist_var,+ label = "Size by variable", |
|
| 396 | ! |
- strata_i = strata_var,+ data_extract_spec = args$size_by, |
|
| 397 | ! |
- group_i = group_var+ is_single_dataset = is_single_dataset_value |
|
| 398 |
- ),+ ) |
||
| 399 | -! | +
- data,+ }, |
|
| 400 | ! |
- select_validation_rule = list(+ if (!is.null(args$row_facet)) {
|
|
| 401 | ! |
- dist_i = shinyvalidate::sv_required("Please select a variable")
+ teal.transform::data_extract_ui( |
|
| 402 | -+ | ! |
- ),+ id = ns("row_facet"),
|
| 403 | ! |
- filter_validation_rule = list(+ label = "Row facetting", |
|
| 404 | ! |
- strata_i = shinyvalidate::compose_rules(+ data_extract_spec = args$row_facet, |
|
| 405 | ! |
- rule_req,+ is_single_dataset = is_single_dataset_value |
|
| 406 | -! | +
- rule_dupl+ ) |
|
| 407 |
- ),+ }, |
||
| 408 | ! |
- group_i = rule_dupl+ if (!is.null(args$col_facet)) {
|
|
| 409 | -+ | ! |
- )+ teal.transform::data_extract_ui( |
| 410 | -+ | ! |
- )+ id = ns("col_facet"),
|
| 411 | -+ | ! |
-
+ label = "Column facetting", |
| 412 | ! |
- iv_r <- reactive({
+ data_extract_spec = args$col_facet, |
|
| 413 | ! |
- iv <- shinyvalidate::InputValidator$new()+ is_single_dataset = is_single_dataset_value |
|
| 414 | -! | +
- teal.transform::compose_and_enable_validators(iv, selector_list, validator_names = "dist_i")+ ) |
|
| 415 |
- })+ }, |
||
| 416 | -+ | ! |
-
+ teal.widgets::panel_group( |
| 417 | ! |
- iv_r_dist <- reactive({
+ teal.widgets::panel_item( |
|
| 418 | ! |
- iv <- shinyvalidate::InputValidator$new()+ title = "Plot settings", |
|
| 419 | ! |
- teal.transform::compose_and_enable_validators(+ teal.widgets::optionalSliderInputValMinMax(ns("alpha"), "Opacity:", args$alpha, ticks = FALSE),
|
|
| 420 | ! |
- iv, selector_list,+ teal.widgets::optionalSelectInput( |
|
| 421 | ! |
- validator_names = c("strata_i", "group_i")
+ inputId = ns("shape"),
|
|
| 422 | -+ | ! |
- )+ label = "Points shape:", |
| 423 | -+ | ! |
- })+ choices = args$shape, |
| 424 | ! |
- rule_dist_1 <- function(value) {
+ selected = args$shape[1], |
|
| 425 | ! |
- if (!is.null(input$t_dist)) {
+ multiple = FALSE |
|
| 426 | -! | +
- switch(input$t_dist,+ ), |
|
| 427 | ! |
- "normal" = if (!shinyvalidate::input_provided(value)) "mean is required",+ colourpicker::colourInput(ns("color"), "Points color:", "black"),
|
|
| 428 | ! |
- "lognormal" = if (!shinyvalidate::input_provided(value)) "meanlog is required",+ teal.widgets::optionalSliderInputValMinMax(ns("size"), "Points size:", args$size, ticks = FALSE, step = .1),
|
|
| 429 | ! |
- "gamma" = {
+ checkboxInput(ns("rotate_xaxis_labels"), "Rotate X axis labels", value = args$rotate_xaxis_labels),
|
|
| 430 | ! |
- if (!shinyvalidate::input_provided(value)) "shape is required" else if (value <= 0) "shape must be positive"+ checkboxInput(ns("add_density"), "Add marginal density", value = FALSE),
|
|
| 431 | -+ | ! |
- },+ checkboxInput(ns("rug_plot"), "Include rug plot", value = FALSE),
|
| 432 | ! |
- "unif" = NULL+ checkboxInput(ns("show_count"), "Show N (number of observations)", value = FALSE),
|
|
| 433 | -+ | ! |
- )+ shinyjs::hidden(helpText(id = ns("line_msg"), "Trendline needs numeric X and Y variables")),
|
| 434 | -+ | ! |
- }+ teal.widgets::optionalSelectInput(ns("smoothing_degree"), "Smoothing degree", seq_len(args$max_deg)),
|
| 435 | -+ | ! |
- }+ shinyjs::hidden(teal.widgets::optionalSelectInput(ns("color_sub"), label = "", multiple = TRUE)),
|
| 436 | ! |
- rule_dist_2 <- function(value) {
+ teal.widgets::optionalSliderInputValMinMax(ns("ci"), "Confidence", c(.95, .8, .99), ticks = FALSE),
|
|
| 437 | ! |
- if (!is.null(input$t_dist)) {
+ shinyjs::hidden(checkboxInput(ns("show_form"), "Show formula", value = TRUE)),
|
|
| 438 | ! |
- switch(input$t_dist,+ shinyjs::hidden(checkboxInput(ns("show_r2"), "Show adj-R Squared", value = TRUE)),
|
|
| 439 | ! |
- "normal" = {
+ uiOutput(ns("num_na_removed")),
|
|
| 440 | ! |
- if (!shinyvalidate::input_provided(value)) {
+ tags$div( |
|
| 441 | ! |
- "sd is required"+ id = ns("label_pos"),
|
|
| 442 | ! |
- } else if (value < 0) {
+ tags$div(tags$strong("Stats position")),
|
|
| 443 | ! |
- "sd must be non-negative"+ tags$div(class = "inline-block w-10", helpText("Left")),
|
|
| 444 | -+ | ! |
- }+ tags$div( |
| 445 | -+ | ! |
- },+ class = "inline-block w-70", |
| 446 | ! |
- "lognormal" = {
+ teal.widgets::optionalSliderInput( |
|
| 447 | ! |
- if (!shinyvalidate::input_provided(value)) {
+ ns("pos"),
|
|
| 448 | ! |
- "sdlog is required"+ label = NULL, |
|
| 449 | ! |
- } else if (value < 0) {
+ min = 0, max = 1, value = .99, ticks = FALSE, step = .01 |
|
| 450 | -! | +
- "sdlog must be non-negative"+ ) |
|
| 451 |
- }+ ), |
||
| 452 | -+ | ! |
- },+ tags$div(class = "inline-block w-10", helpText("Right"))
|
| 453 | -! | +
- "gamma" = {
+ ), |
|
| 454 | ! |
- if (!shinyvalidate::input_provided(value)) {
+ teal.widgets::optionalSliderInput( |
|
| 455 | ! |
- "rate is required"+ ns("label_size"), "Stats font size",
|
|
| 456 | ! |
- } else if (value <= 0) {
+ min = 3, max = 10, value = 5, ticks = FALSE, step = .1 |
|
| 457 | -! | +
- "rate must be positive"+ ), |
|
| 458 | -+ | ! |
- }+ if (!is.null(args$row_facet) || !is.null(args$col_facet)) {
|
| 459 | -+ | ! |
- },+ checkboxInput(ns("free_scales"), "Free scales", value = FALSE)
|
| 460 | -! | +
- "unif" = NULL+ }, |
|
| 461 | -+ | ! |
- )+ selectInput( |
| 462 | -+ | ! |
- }+ inputId = ns("ggtheme"),
|
| 463 | -+ | ! |
- }+ label = "Theme (by ggplot):", |
| 464 | ! |
- rule_dist <- function(value) {
+ choices = ggplot_themes, |
|
| 465 | ! |
- if (isTRUE(input$tabs == "QQplot" ||+ selected = args$ggtheme, |
|
| 466 | ! |
- input$dist_tests %in% c(+ multiple = FALSE |
|
| 467 | -! | +
- "Kolmogorov-Smirnov (one-sample)",+ ) |
|
| 468 | -! | +
- "Anderson-Darling (one-sample)",+ ) |
|
| 469 | -! | +
- "Cramer-von Mises (one-sample)"+ ) |
|
| 470 |
- ))) {
+ ), |
||
| 471 | ! |
- if (!shinyvalidate::input_provided(value)) {
+ forms = tagList( |
|
| 472 | ! |
- "Please select the theoretical distribution."+ teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code")
|
|
| 473 |
- }+ ), |
||
| 474 | -+ | ! |
- }+ pre_output = args$pre_output, |
| 475 | -+ | ! |
- }+ post_output = args$post_output |
| 476 | -! | +
- iv_dist <- shinyvalidate::InputValidator$new()+ ) |
|
| 477 | -! | +
- iv_dist$add_rule("t_dist", rule_dist)
+ ) |
|
| 478 | -! | +
- iv_dist$add_rule("dist_param1", rule_dist_1)
+ } |
|
| 479 | -! | +
- iv_dist$add_rule("dist_param2", rule_dist_2)
+
|
|
| 480 | -! | +
- iv_dist$enable()+ # Server function for the scatterplot module |
|
| 481 |
-
+ srv_g_scatterplot <- function(id, |
||
| 482 | -! | +
- anl_merged_input <- teal.transform::merge_expression_srv(+ data, |
|
| 483 | -! | +
- selector_list = selector_list,+ reporter, |
|
| 484 | -! | +
- datasets = data+ filter_panel_api, |
|
| 485 |
- )+ x, |
||
| 486 |
-
+ y, |
||
| 487 | -! | +
- anl_merged_q <- reactive({
+ color_by, |
|
| 488 | -! | +
- req(anl_merged_input())+ size_by, |
|
| 489 | -! | +
- data() %>%+ row_facet, |
|
| 490 | -! | +
- teal.code::eval_code(as.expression(anl_merged_input()$expr))+ col_facet, |
|
| 491 |
- })+ plot_height, |
||
| 492 |
-
+ plot_width, |
||
| 493 | -! | +
- merged <- list(+ table_dec, |
|
| 494 | -! | +
- anl_input_r = anl_merged_input,+ ggplot2_args) {
|
|
| 495 | ! |
- anl_q_r = anl_merged_q+ with_reporter <- !missing(reporter) && inherits(reporter, "Reporter") |
|
| 496 | -+ | ! |
- )+ with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI") |
| 497 | -+ | ! |
-
+ checkmate::assert_class(data, "reactive") |
| 498 | ! |
- output$scales_types_ui <- renderUI({
+ checkmate::assert_class(isolate(data()), "teal_data") |
|
| 499 | ! |
- if ("group_i" %in% names(selector_list()) && length(selector_list()$group_i()$filters[[1]]$selected) > 0) {
+ moduleServer(id, function(input, output, session) {
|
|
| 500 | ! |
- shinyWidgets::prettyRadioButtons(+ teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.general") |
|
| 501 | -! | +
- ns("scales_type"),
+
|
|
| 502 | ! |
- label = "Scales:",+ data_extract <- list( |
|
| 503 | ! |
- choices = c("Fixed", "Free"),
+ x = x, |
|
| 504 | ! |
- selected = "Fixed",+ y = y, |
|
| 505 | ! |
- bigger = FALSE,+ color_by = color_by, |
|
| 506 | ! |
- inline = TRUE+ size_by = size_by, |
|
| 507 | -+ | ! |
- )+ row_facet = row_facet, |
| 508 | -+ | ! |
- }+ col_facet = col_facet |
| 509 |
- })+ ) |
||
| 511 | ! |
- observeEvent(+ rule_diff <- function(other) {
|
|
| 512 | ! |
- eventExpr = list(+ function(value) {
|
|
| 513 | ! |
- input$t_dist,+ othervalue <- selector_list()[[other]]()[["select"]] |
|
| 514 | ! |
- input$params_reset,+ if (!is.null(othervalue)) {
|
|
| 515 | ! |
- selector_list()$dist_i()$select+ if (identical(value, othervalue)) {
|
|
| 516 | -+ | ! |
- ),+ "Row and column facetting variables must be different." |
| 517 | -! | +
- handlerExpr = {
+ } |
|
| 518 | -! | +
- params <-+ } |
|
| 519 | -! | +
- if (length(input$t_dist) != 0) {
+ } |
|
| 520 | -! | +
- get_dist_params <- function(x, dist) {
+ } |
|
| 521 | -! | +
- if (dist == "unif") {
+
|
|
| 522 | ! |
- return(stats::setNames(range(x, na.rm = TRUE), c("min", "max")))
+ selector_list <- teal.transform::data_extract_multiple_srv( |
|
| 523 | -+ | ! |
- }+ data_extract = data_extract, |
| 524 | ! |
- tryCatch(+ datasets = data, |
|
| 525 | ! |
- MASS::fitdistr(x, densfun = dist)$estimate,+ select_validation_rule = list( |
|
| 526 | ! |
- error = function(e) c(param1 = NA_real_, param2 = NA_real_)+ x = ~ if (length(.) != 1) "Please select exactly one x var.", |
|
| 527 | -+ | ! |
- )+ y = ~ if (length(.) != 1) "Please select exactly one y var.", |
| 528 | -+ | ! |
- }+ color_by = ~ if (length(.) > 1) "There cannot be more than 1 color variable.", |
| 529 | -+ | ! |
-
+ size_by = ~ if (length(.) > 1) "There cannot be more than 1 size variable.", |
| 530 | ! |
- ANL <- merged$anl_q_r()[["ANL"]]+ row_facet = shinyvalidate::compose_rules( |
|
| 531 | ! |
- round(get_dist_params(as.numeric(stats::na.omit(ANL[[merge_vars()$dist_var]])), input$t_dist), 2)+ shinyvalidate::sv_optional(), |
|
| 532 | -+ | ! |
- } else {
+ rule_diff("col_facet")
|
| 533 | -! | +
- c("param1" = NA_real_, "param2" = NA_real_)
+ ), |
|
| 534 | -+ | ! |
- }+ col_facet = shinyvalidate::compose_rules( |
| 535 | -+ | ! |
-
+ shinyvalidate::sv_optional(), |
| 536 | ! |
- params_vals <- unname(params)+ rule_diff("row_facet")
|
|
| 537 | -! | +
- params_names <- names(params)+ ) |
|
| 538 |
-
+ ) |
||
| 539 | -! | +
- updateNumericInput(+ ) |
|
| 540 | -! | +
- inputId = "dist_param1",+ |
|
| 541 | ! |
- label = params_names[1],+ iv_r <- reactive({
|
|
| 542 | ! |
- value = restoreInput(ns("dist_param1"), params_vals[1])
+ iv_facet <- shinyvalidate::InputValidator$new() |
|
| 543 | -+ | ! |
- )+ iv <- shinyvalidate::InputValidator$new() |
| 544 | ! |
- updateNumericInput(+ teal.transform::compose_and_enable_validators(iv, selector_list) |
|
| 545 | -! | +
- inputId = "dist_param2",+ }) |
|
| 546 | ! |
- label = params_names[2],+ iv_facet <- shinyvalidate::InputValidator$new() |
|
| 547 | ! |
- value = restoreInput(ns("dist_param1"), params_vals[2])
+ iv_facet$add_rule("add_density", ~ if (
|
|
| 548 | -+ | ! |
- )+ isTRUE(.) && |
| 549 |
- },+ ( |
||
| 550 | ! |
- ignoreInit = TRUE+ length(selector_list()$row_facet()$select) > 0L || |
|
| 551 | -+ | ! |
- )+ length(selector_list()$col_facet()$select) > 0L |
| 552 |
-
+ ) |
||
| 553 | -! | +
- observeEvent(input$params_reset, {
+ ) {
|
|
| 554 | ! |
- updateActionButton(inputId = "params_reset", label = "Reset params")+ "Cannot add marginal density when Row or Column facetting has been selected" |
|
| 556 | -+ | ! |
-
+ iv_facet$enable() |
| 557 | -! | +
- merge_vars <- reactive({
+
|
|
| 558 | ! |
- teal::validate_inputs(iv_r())+ anl_merged_input <- teal.transform::merge_expression_srv( |
|
| 559 | -+ | ! |
-
+ selector_list = selector_list, |
| 560 | ! |
- dist_var <- as.vector(merged$anl_input_r()$columns_source$dist_i)+ datasets = data, |
|
| 561 | ! |
- s_var <- as.vector(merged$anl_input_r()$columns_source$strata_i)+ merge_function = "dplyr::inner_join" |
|
| 562 | -! | +
- g_var <- as.vector(merged$anl_input_r()$columns_source$group_i)+ ) |
|
| 564 | ! |
- dist_var_name <- if (length(dist_var)) as.name(dist_var) else NULL+ anl_merged_q <- reactive({
|
|
| 565 | ! |
- s_var_name <- if (length(s_var)) as.name(s_var) else NULL+ req(anl_merged_input()) |
|
| 566 | ! |
- g_var_name <- if (length(g_var)) as.name(g_var) else NULL+ data() %>% |
|
| 567 | -+ | ! |
-
+ teal.code::eval_code(as.expression(anl_merged_input()$expr)) %>% |
| 568 | ! |
- list(+ teal.code::eval_code(quote(ANL)) # used to display table when running show-r-code code |
|
| 569 | -! | +
- dist_var = dist_var,+ }) |
|
| 570 | -! | +
- s_var = s_var,+ |
|
| 571 | ! |
- g_var = g_var,+ merged <- list( |
|
| 572 | ! |
- dist_var_name = dist_var_name,+ anl_input_r = anl_merged_input, |
|
| 573 | ! |
- s_var_name = s_var_name,+ anl_q_r = anl_merged_q |
|
| 574 | -! | +
- g_var_name = g_var_name+ ) |
|
| 575 |
- )+ |
||
| 576 | -+ | ! |
- })+ trend_line_is_applicable <- reactive({
|
| 577 | -+ | ! |
-
+ ANL <- merged$anl_q_r()[["ANL"]] |
| 578 | -+ | ! |
- # common qenv+ x_var <- as.vector(merged$anl_input_r()$columns_source$x) |
| 579 | ! |
- common_q <- reactive({
+ y_var <- as.vector(merged$anl_input_r()$columns_source$y) |
|
| 580 | -+ | ! |
- # Create a private stack for this function only.+ length(x_var) > 0 && length(y_var) > 0 && is.numeric(ANL[[x_var]]) && is.numeric(ANL[[y_var]]) |
| 581 |
-
+ }) |
||
| 582 | -! | +
- ANL <- merged$anl_q_r()[["ANL"]]+ |
|
| 583 | ! |
- dist_var <- merge_vars()$dist_var+ add_trend_line <- reactive({
|
|
| 584 | ! |
- s_var <- merge_vars()$s_var+ smoothing_degree <- as.integer(input$smoothing_degree) |
|
| 585 | ! |
- g_var <- merge_vars()$g_var+ trend_line_is_applicable() && length(smoothing_degree) > 0 |
|
| 586 |
-
+ }) |
||
| 587 | -! | +
- dist_var_name <- merge_vars()$dist_var_name+ |
|
| 588 | ! |
- s_var_name <- merge_vars()$s_var_name+ if (!is.null(color_by)) {
|
|
| 589 | ! |
- g_var_name <- merge_vars()$g_var_name+ observeEvent( |
|
| 590 | -+ | ! |
-
+ eventExpr = merged$anl_input_r()$columns_source$color_by, |
| 591 | ! |
- roundn <- input$roundn+ handlerExpr = {
|
|
| 592 | ! |
- dist_param1 <- input$dist_param1+ color_by_var <- as.vector(merged$anl_input_r()$columns_source$color_by) |
|
| 593 | ! |
- dist_param2 <- input$dist_param2+ if (length(color_by_var) > 0) {
|
|
| 594 | -+ | ! |
- # isolated as dist_param1/dist_param2 already triggered the reactivity+ shinyjs::hide("color")
|
| 595 | -! | +
- t_dist <- isolate(input$t_dist)+ } else {
|
|
| 596 | -+ | ! |
-
+ shinyjs::show("color")
|
| 597 | -! | +
- qenv <- merged$anl_q_r()+ } |
|
| 598 |
-
+ } |
||
| 599 | -! | +
- if (length(g_var) > 0) {
+ ) |
|
| 600 | -! | +
- validate(+ } |
|
| 601 | -! | +
- need(+ |
|
| 602 | ! |
- inherits(ANL[[g_var]], c("integer", "factor", "character")),
+ output$num_na_removed <- renderUI({
|
|
| 603 | ! |
- "Group by variable must be `factor`, `character`, or `integer`"+ if (add_trend_line()) {
|
|
| 604 | -+ | ! |
- )+ ANL <- merged$anl_q_r()[["ANL"]] |
| 605 | -+ | ! |
- )+ x_var <- as.vector(merged$anl_input_r()$columns_source$x) |
| 606 | ! |
- qenv <- teal.code::eval_code(+ y_var <- as.vector(merged$anl_input_r()$columns_source$y) |
|
| 607 | ! |
- qenv,+ if ((num_total_na <- nrow(ANL) - nrow(stats::na.omit(ANL[, c(x_var, y_var)]))) > 0) {
|
|
| 608 | ! |
- substitute(+ tags$div(paste(num_total_na, "row(s) with missing values were removed"), tags$hr()) |
|
| 609 | -! | +
- expr = ANL[[g_var]] <- forcats::fct_na_value_to_level(as.factor(ANL[[g_var]]), "NA"),+ } |
|
| 610 | -! | +
- env = list(g_var = g_var)+ } |
|
| 611 |
- )+ }) |
||
| 612 |
- )+ |
||
| 613 | -+ | ! |
- }+ observeEvent( |
| 614 | -+ | ! |
-
+ eventExpr = merged$anl_input_r()$columns_source[c("col_facet", "row_facet")],
|
| 615 | ! |
- if (length(s_var) > 0) {
+ handlerExpr = {
|
|
| 616 | ! |
- validate(+ if ( |
|
| 617 | ! |
- need(+ length(merged$anl_input_r()$columns_source$col_facet) == 0 && |
|
| 618 | ! |
- inherits(ANL[[s_var]], c("integer", "factor", "character")),
+ length(merged$anl_input_r()$columns_source$row_facet) == 0 |
|
| 619 | -! | +
- "Stratify by variable must be `factor`, `character`, or `integer`"+ ) {
|
|
| 620 | -+ | ! |
- )+ shinyjs::hide("free_scales")
|
| 621 |
- )+ } else {
|
||
| 622 | ! |
- qenv <- teal.code::eval_code(+ shinyjs::show("free_scales")
|
|
| 623 | -! | +
- qenv,+ } |
|
| 624 | -! | +
- substitute(+ } |
|
| 625 | -! | +
- expr = ANL[[s_var]] <- forcats::fct_na_value_to_level(as.factor(ANL[[s_var]]), "NA"),+ ) |
|
| 626 | -! | +
- env = list(s_var = s_var)+ |
|
| 627 | -+ | ! |
- )+ output_q <- reactive({
|
| 628 | -+ | ! |
- )+ teal::validate_inputs(iv_r(), iv_facet) |
| 629 |
- }+ |
||
| 630 | -+ | ! |
-
+ ANL <- merged$anl_q_r()[["ANL"]] |
| 631 | -! | +
- validate(need(is.numeric(ANL[[dist_var]]), "Please select a numeric variable."))+ |
|
| 632 | ! |
- teal::validate_has_data(ANL, 1, complete = TRUE)+ x_var <- as.vector(merged$anl_input_r()$columns_source$x) |
|
| 633 | -+ | ! |
-
+ y_var <- as.vector(merged$anl_input_r()$columns_source$y) |
| 634 | ! |
- if (length(t_dist) != 0) {
+ color_by_var <- as.vector(merged$anl_input_r()$columns_source$color_by) |
|
| 635 | ! |
- map_distr_nams <- list(+ size_by_var <- as.vector(merged$anl_input_r()$columns_source$size_by) |
|
| 636 | ! |
- normal = c("mean", "sd"),
+ row_facet_name <- if (length(merged$anl_input_r()$columns_source$row_facet) == 0) {
|
|
| 637 | ! |
- lognormal = c("meanlog", "sdlog"),
+ character(0) |
|
| 638 | -! | +
- gamma = c("shape", "rate"),
+ } else {
|
|
| 639 | ! |
- unif = c("min", "max")
+ as.vector(merged$anl_input_r()$columns_source$row_facet) |
|
| 640 |
- )+ } |
||
| 641 | ! |
- params_names_raw <- map_distr_nams[[t_dist]]+ col_facet_name <- if (length(merged$anl_input_r()$columns_source$col_facet) == 0) {
|
|
| 642 | -+ | ! |
-
+ character(0) |
| 643 | -! | +
- qenv <- teal.code::eval_code(+ } else {
|
|
| 644 | ! |
- qenv,+ as.vector(merged$anl_input_r()$columns_source$col_facet) |
|
| 645 | -! | +
- substitute(+ } |
|
| 646 | ! |
- expr = {
+ alpha <- input$alpha |
|
| 647 | ! |
- params <- as.list(c(dist_param1, dist_param2))+ size <- input$size |
|
| 648 | ! |
- names(params) <- params_names_raw+ rotate_xaxis_labels <- input$rotate_xaxis_labels |
|
| 649 | -+ | ! |
- },+ add_density <- input$add_density |
| 650 | ! |
- env = list(+ ggtheme <- input$ggtheme |
|
| 651 | ! |
- dist_param1 = dist_param1,+ rug_plot <- input$rug_plot |
|
| 652 | ! |
- dist_param2 = dist_param2,+ color <- input$color |
|
| 653 | ! |
- params_names_raw = params_names_raw+ shape <- `if`(is.null(input$shape) || identical(input$shape, ""), "circle", input$shape) |
|
| 654 | -+ | ! |
- )+ smoothing_degree <- as.integer(input$smoothing_degree) |
| 655 | -+ | ! |
- )+ ci <- input$ci |
| 656 |
- )+ |
||
| 657 | -+ | ! |
- }+ log_x <- input$log_x |
| 658 | -+ | ! |
-
+ log_y <- input$log_y |
| 659 | -! | +
- if (length(s_var) == 0 && length(g_var) == 0) {
+
|
|
| 660 | ! |
- qenv <- teal.code::eval_code(+ validate(need( |
|
| 661 | ! |
- qenv,+ length(row_facet_name) == 0 || inherits(ANL[[row_facet_name]], c("character", "factor", "Date", "integer")),
|
|
| 662 | ! |
- substitute(+ "`Row facetting` variable must be of class `character`, `factor`, `Date`, or `integer`" |
|
| 663 | -! | +
- expr = {
+ )) |
|
| 664 | ! |
- summary_table <- ANL %>%+ validate(need( |
|
| 665 | ! |
- dplyr::summarise(+ length(col_facet_name) == 0 || inherits(ANL[[col_facet_name]], c("character", "factor", "Date", "integer")),
|
|
| 666 | ! |
- min = round(min(dist_var_name, na.rm = TRUE), roundn),+ "`Column facetting` variable must be of class `character`, `factor`, `Date`, or `integer`" |
|
| 667 | -! | +
- median = round(stats::median(dist_var_name, na.rm = TRUE), roundn),+ )) |
|
| 668 | -! | +
- mean = round(mean(dist_var_name, na.rm = TRUE), roundn),+ |
|
| 669 | ! |
- max = round(max(dist_var_name, na.rm = TRUE), roundn),+ if (add_density && length(color_by_var) > 0) {
|
|
| 670 | ! |
- sd = round(stats::sd(dist_var_name, na.rm = TRUE), roundn),+ validate(need( |
|
| 671 | ! |
- count = dplyr::n()+ !is.numeric(ANL[[color_by_var]]), |
|
| 672 | -+ | ! |
- )+ "Marginal plots cannot be produced when the points are colored by numeric variables. |
| 673 | -+ | ! |
- },+ \n Uncheck the 'Add marginal density' checkbox to display the plot." |
| 674 | -! | +
- env = list(+ )) |
|
| 675 | ! |
- dist_var_name = as.name(dist_var),+ validate(need( |
|
| 676 | -! | +
- roundn = roundn+ !( |
|
| 677 | -+ | ! |
- )+ inherits(ANL[[color_by_var]], "Date") || |
| 678 | -+ | ! |
- )+ inherits(ANL[[color_by_var]], "POSIXct") || |
| 679 | -+ | ! |
- )+ inherits(ANL[[color_by_var]], "POSIXlt") |
| 680 |
- } else {
+ ), |
||
| 681 | ! |
- qenv <- teal.code::eval_code(+ "Marginal plots cannot be produced when the points are colored by Date or POSIX variables. |
|
| 682 | ! |
- qenv,+ \n Uncheck the 'Add marginal density' checkbox to display the plot." |
|
| 683 | -! | +
- substitute(+ )) |
|
| 684 | -! | +
- expr = {
+ } |
|
| 685 | -! | +
- strata_vars <- strata_vars_raw+ |
|
| 686 | ! |
- summary_table <- ANL %>%+ teal::validate_has_data(ANL[, c(x_var, y_var)], 10, complete = TRUE, allow_inf = FALSE) |
|
| 687 | -! | +
- dplyr::group_by_at(dplyr::vars(dplyr::any_of(strata_vars))) %>%+ |
|
| 688 | ! |
- dplyr::summarise(+ if (log_x) {
|
|
| 689 | ! |
- min = round(min(dist_var_name, na.rm = TRUE), roundn),+ validate( |
|
| 690 | ! |
- median = round(stats::median(dist_var_name, na.rm = TRUE), roundn),+ need( |
|
| 691 | ! |
- mean = round(mean(dist_var_name, na.rm = TRUE), roundn),+ is.numeric(ANL[[x_var]]) && all( |
|
| 692 | ! |
- max = round(max(dist_var_name, na.rm = TRUE), roundn),+ ANL[[x_var]] > 0 | is.na(ANL[[x_var]]) |
|
| 693 | -! | +
- sd = round(stats::sd(dist_var_name, na.rm = TRUE), roundn),+ ), |
|
| 694 | ! |
- count = dplyr::n()+ "X variable can only be log transformed if variable is numeric and all values are positive." |
|
| 695 |
- )+ ) |
||
| 696 | -! | +
- summary_table # used to display table when running show-r-code code+ ) |
|
| 697 |
- },+ } |
||
| 698 | ! |
- env = list(+ if (log_y) {
|
|
| 699 | ! |
- dist_var_name = dist_var_name,+ validate( |
|
| 700 | ! |
- strata_vars_raw = c(g_var, s_var),+ need( |
|
| 701 | ! |
- roundn = roundn+ is.numeric(ANL[[y_var]]) && all( |
|
| 702 | -+ | ! |
- )+ ANL[[y_var]] > 0 | is.na(ANL[[y_var]]) |
| 703 |
- )+ ), |
||
| 704 | -+ | ! |
- )+ "Y variable can only be log transformed if variable is numeric and all values are positive." |
| 705 |
- }+ ) |
||
| 706 |
- })+ ) |
||
| 707 |
-
+ } |
||
| 708 |
- # distplot qenv ----+ |
||
| 709 | ! |
- dist_q <- eventReactive(+ facet_cl <- facet_ggplot_call( |
|
| 710 | ! |
- eventExpr = {
+ row_facet_name, |
|
| 711 | ! |
- common_q()+ col_facet_name, |
|
| 712 | ! |
- input$scales_type+ free_x_scales = isTRUE(input$free_scales), |
|
| 713 | ! |
- input$main_type+ free_y_scales = isTRUE(input$free_scales) |
|
| 714 | -! | +
- input$bins+ ) |
|
| 715 | -! | +
- input$add_dens+ |
|
| 716 | ! |
- is.null(input$ggtheme)+ point_sizes <- if (length(size_by_var) > 0) {
|
|
| 717 | -+ | ! |
- },+ validate(need(is.numeric(ANL[[size_by_var]]), "Variable to size by must be numeric")) |
| 718 | ! |
- valueExpr = {
+ substitute( |
|
| 719 | ! |
- dist_var <- merge_vars()$dist_var+ expr = size * ANL[[size_by_var]] / max(ANL[[size_by_var]], na.rm = TRUE), |
|
| 720 | ! |
- s_var <- merge_vars()$s_var+ env = list(size = size, size_by_var = size_by_var) |
|
| 721 | -! | +
- g_var <- merge_vars()$g_var+ ) |
|
| 722 | -! | +
- dist_var_name <- merge_vars()$dist_var_name+ } else {
|
|
| 723 | ! |
- s_var_name <- merge_vars()$s_var_name+ size |
|
| 724 | -! | +
- g_var_name <- merge_vars()$g_var_name+ } |
|
| 725 | -! | +
- t_dist <- input$t_dist+ |
|
| 726 | ! |
- dist_param1 <- input$dist_param1+ plot_q <- merged$anl_q_r() |
|
| 727 | -! | +
- dist_param2 <- input$dist_param2+ |
|
| 728 | -+ | ! |
-
+ if (log_x) {
|
| 729 | ! |
- scales_type <- input$scales_type+ log_x_fn <- input$log_x_base |
|
| 730 | -+ | ! |
-
+ plot_q <- teal.code::eval_code( |
| 731 | ! |
- ndensity <- 512+ object = plot_q, |
|
| 732 | ! |
- main_type_var <- input$main_type+ code = substitute( |
|
| 733 | ! |
- bins_var <- input$bins+ expr = ANL[, log_x_var] <- log_x_fn(ANL[, x_var]), |
|
| 734 | ! |
- add_dens_var <- input$add_dens+ env = list( |
|
| 735 | ! |
- ggtheme <- input$ggtheme+ x_var = x_var, |
|
| 736 | -+ | ! |
-
+ log_x_fn = as.name(log_x_fn), |
| 737 | ! |
- teal::validate_inputs(iv_dist)+ log_x_var = paste0(log_x_fn, "_", x_var) |
|
| 738 |
-
+ ) |
||
| 739 | -! | +
- qenv <- common_q()+ ) |
|
| 740 |
-
+ ) |
||
| 741 | -! | +
- m_type <- if (main_type_var == "Density") "density" else "count"+ } |
|
| 743 | ! |
- plot_call <- if (length(s_var) == 0 && length(g_var) == 0) {
+ if (log_y) {
|
|
| 744 | ! |
- substitute(+ log_y_fn <- input$log_y_base |
|
| 745 | ! |
- expr = ggplot(ANL, aes(dist_var_name)) ++ plot_q <- teal.code::eval_code( |
|
| 746 | ! |
- geom_histogram(+ object = plot_q, |
|
| 747 | ! |
- position = "identity", aes(y = after_stat(m_type)), bins = bins_var, alpha = 0.3+ code = substitute( |
|
| 748 | -+ | ! |
- ),+ expr = ANL[, log_y_var] <- log_y_fn(ANL[, y_var]), |
| 750 | ! |
- m_type = as.name(m_type), bins_var = bins_var, dist_var_name = as.name(dist_var)+ y_var = y_var, |
|
| 751 | -+ | ! |
- )+ log_y_fn = as.name(log_y_fn), |
| 752 | -+ | ! |
- )+ log_y_var = paste0(log_y_fn, "_", y_var) |
| 753 | -! | +
- } else if (length(s_var) != 0 && length(g_var) == 0) {
+ ) |
|
| 754 | -! | +
- substitute(+ ) |
|
| 755 | -! | +
- expr = ggplot(ANL, aes(dist_var_name, col = s_var_name)) ++ ) |
|
| 756 | -! | +
- geom_histogram(+ } |
|
| 757 | -! | +
- position = "identity", aes(y = after_stat(m_type), fill = s_var), bins = bins_var, alpha = 0.3+ |
|
| 758 | -+ | ! |
- ),+ pre_pro_anl <- if (input$show_count) {
|
| 759 | ! |
- env = list(+ paste0( |
|
| 760 | ! |
- m_type = as.name(m_type),+ "ANL %>% dplyr::group_by(",
|
|
| 761 | ! |
- bins_var = bins_var,+ paste( |
|
| 762 | ! |
- dist_var_name = dist_var_name,+ c( |
|
| 763 | ! |
- s_var = as.name(s_var),+ if (length(color_by_var) > 0 && inherits(ANL[[color_by_var]], c("factor", "character"))) color_by_var,
|
|
| 764 | ! |
- s_var_name = s_var_name+ row_facet_name, |
|
| 765 | -+ | ! |
- )+ col_facet_name |
| 766 |
- )+ ), |
||
| 767 | ! |
- } else if (length(s_var) == 0 && length(g_var) != 0) {
+ collapse = ", " |
|
| 768 | -! | +
- req(scales_type)+ ), |
|
| 769 | ! |
- substitute(+ ") %>% dplyr::mutate(n = dplyr::n()) %>% dplyr::ungroup()" |
|
| 770 | -! | +
- expr = ggplot(ANL[ANL[[g_var]] != "NA", ], aes(dist_var_name)) ++ ) |
|
| 771 | -! | +
- geom_histogram(+ } else {
|
|
| 772 | ! |
- position = "identity", aes(y = after_stat(m_type)), bins = bins_var, alpha = 0.3+ "ANL" |
|
| 773 |
- ) ++ } |
||
| 774 | -! | +
- facet_wrap(~g_var_name, ncol = 1, scales = scales_raw),+ |
|
| 775 | ! |
- env = list(+ plot_call <- substitute(expr = pre_pro_anl %>% ggplot(), env = list(pre_pro_anl = str2lang(pre_pro_anl))) |
|
| 776 | -! | +
- m_type = as.name(m_type),+ |
|
| 777 | ! |
- bins_var = bins_var,+ plot_call <- if (length(color_by_var) == 0) {
|
|
| 778 | ! |
- dist_var_name = dist_var_name,+ substitute( |
|
| 779 | ! |
- g_var = g_var,+ expr = plot_call + |
|
| 780 | ! |
- g_var_name = g_var_name,+ ggplot2::aes(x = x_name, y = y_name) + |
|
| 781 | ! |
- scales_raw = tolower(scales_type)+ ggplot2::geom_point(alpha = alpha_value, size = point_sizes, shape = shape_value, color = color_value), |
|
| 782 | -+ | ! |
- )+ env = list( |
| 783 | -+ | ! |
- )+ plot_call = plot_call, |
| 784 | -+ | ! |
- } else {
+ x_name = if (log_x) as.name(paste0(log_x_fn, "_", x_var)) else as.name(x_var), |
| 785 | ! |
- req(scales_type)+ y_name = if (log_y) as.name(paste0(log_y_fn, "_", y_var)) else as.name(y_var), |
|
| 786 | ! |
- substitute(+ alpha_value = alpha, |
|
| 787 | ! |
- expr = ggplot(ANL[ANL[[g_var]] != "NA", ], aes(dist_var_name, col = s_var_name)) ++ point_sizes = point_sizes, |
|
| 788 | ! |
- geom_histogram(+ shape_value = shape, |
|
| 789 | ! |
- position = "identity",+ color_value = color |
|
| 790 | -! | +
- aes(y = after_stat(m_type), fill = s_var), bins = bins_var, alpha = 0.3+ ) |
|
| 791 |
- ) ++ ) |
||
| 792 | -! | +
- facet_wrap(~g_var_name, ncol = 1, scales = scales_raw),+ } else {
|
|
| 793 | ! |
- env = list(+ substitute( |
|
| 794 | ! |
- m_type = as.name(m_type),+ expr = plot_call + |
|
| 795 | ! |
- bins_var = bins_var,+ ggplot2::aes(x = x_name, y = y_name, color = color_by_var_name) + |
|
| 796 | ! |
- dist_var_name = dist_var_name,+ ggplot2::geom_point(alpha = alpha_value, size = point_sizes, shape = shape_value), |
|
| 797 | ! |
- g_var = g_var,+ env = list( |
|
| 798 | ! |
- s_var = as.name(s_var),+ plot_call = plot_call, |
|
| 799 | ! |
- g_var_name = g_var_name,+ x_name = if (log_x) as.name(paste0(log_x_fn, "_", x_var)) else as.name(x_var), |
|
| 800 | ! |
- s_var_name = s_var_name,+ y_name = if (log_y) as.name(paste0(log_y_fn, "_", y_var)) else as.name(y_var), |
|
| 801 | ! |
- scales_raw = tolower(scales_type)+ color_by_var_name = as.name(color_by_var), |
|
| 802 | -+ | ! |
- )+ alpha_value = alpha, |
| 803 | -+ | ! |
- )+ point_sizes = point_sizes, |
| 804 | -+ | ! |
- }+ shape_value = shape |
| 805 |
-
+ ) |
||
| 806 | -! | +
- if (add_dens_var) {
+ ) |
|
| 807 | -! | +
- plot_call <- substitute(+ } |
|
| 808 | -! | +
- expr = plot_call ++ |
|
| 809 | ! |
- stat_density(+ if (rug_plot) plot_call <- substitute(expr = plot_call + geom_rug(), env = list(plot_call = plot_call)) |
|
| 810 | -! | +
- aes(y = after_stat(const * m_type2)),+ |
|
| 811 | ! |
- geom = "line",+ plot_label_generator <- function(rhs_formula = quote(y ~ 1), |
|
| 812 | ! |
- position = "identity",+ show_form = input$show_form, |
|
| 813 | ! |
- alpha = 0.5,+ show_r2 = input$show_r2, |
|
| 814 | ! |
- size = 2,+ show_count = input$show_count, |
|
| 815 | ! |
- n = ndensity+ pos = input$pos, |
|
| 816 | -+ | ! |
- ),+ label_size = input$label_size) {
|
| 817 | ! |
- env = list(+ stopifnot(sum(show_form, show_r2, show_count) >= 1) |
|
| 818 | ! |
- plot_call = plot_call,+ aes_label <- paste0( |
|
| 819 | ! |
- const = if (main_type_var == "Density") {
+ "aes(",
|
|
| 820 | ! |
- 1+ if (show_count) "n = n, ", |
|
| 821 | -+ | ! |
- } else {
+ "label = ", |
| 822 | ! |
- diff(range(qenv[["ANL"]][[dist_var]], na.rm = TRUE)) / bins_var+ if (sum(show_form, show_r2, show_count) > 1) "paste(",
|
|
| 823 | -+ | ! |
- },+ paste( |
| 824 | ! |
- m_type2 = if (main_type_var == "Density") as.name("density") else as.name("count"),
+ c( |
|
| 825 | ! |
- ndensity = ndensity+ if (show_form) "stat(eq.label)", |
|
| 826 | -+ | ! |
- )+ if (show_r2) "stat(adj.rr.label)", |
| 827 | -+ | ! |
- )+ if (show_count) "paste('N ~`=`~', n)"
|
| 828 |
- }+ ), |
||
| 829 | -+ | ! |
-
+ collapse = ", " |
| 830 | -! | +
- if (length(t_dist) != 0 && main_type_var == "Density" && length(g_var) == 0 && length(s_var) == 0) {
+ ), |
|
| 831 | ! |
- qenv <- teal.code::eval_code(+ if (sum(show_form, show_r2, show_count) > 1) ", sep = '*\", \"*'))" else ")" |
|
| 832 | -! | +
- qenv,+ ) |
|
| 833 | ! |
- substitute(+ label_geom <- substitute( |
|
| 834 | ! |
- df_params <- as.data.frame(append(params, list(name = t_dist))),+ expr = ggpmisc::stat_poly_eq( |
|
| 835 | ! |
- env = list(t_dist = t_dist)+ mapping = aes_label, |
|
| 836 | -+ | ! |
- )+ formula = rhs_formula, |
| 837 | -+ | ! |
- )+ parse = TRUE, |
| 838 | ! |
- datas <- quote(data.frame(x = 0.7, y = 1, tb = I(list(df_params = df_params))))+ label.x = pos, |
|
| 839 | ! |
- label <- quote(tb)+ size = label_size |
|
| 840 |
-
+ ), |
||
| 841 | ! |
- plot_call <- substitute(+ env = list( |
|
| 842 | ! |
- expr = plot_call + ggpp::geom_table_npc(+ rhs_formula = rhs_formula, |
|
| 843 | ! |
- data = data,+ pos = pos, |
|
| 844 | ! |
- aes(npcx = x, npcy = y, label = label),+ aes_label = str2lang(aes_label), |
|
| 845 | ! |
- hjust = 0, vjust = 1, size = 4+ label_size = label_size |
|
| 846 |
- ),+ ) |
||
| 847 | -! | +
- env = list(plot_call = plot_call, data = datas, label = label)+ ) |
|
| 848 | -+ | ! |
- )+ substitute( |
| 849 | -+ | ! |
- }+ expr = plot_call + label_geom, |
| 850 | -+ | ! |
-
+ env = list( |
| 851 | ! |
- if (+ plot_call = plot_call, |
|
| 852 | ! |
- length(s_var) == 0 &&+ label_geom = label_geom |
|
| 853 | -! | +
- length(g_var) == 0 &&+ ) |
|
| 854 | -! | +
- main_type_var == "Density" &&+ ) |
|
| 855 | -! | +
- length(t_dist) != 0 &&+ } |
|
| 856 | -! | +
- main_type_var == "Density"+ |
|
| 857 | -+ | ! |
- ) {
+ if (trend_line_is_applicable()) {
|
| 858 | ! |
- map_dist <- stats::setNames(+ shinyjs::hide("line_msg")
|
|
| 859 | ! |
- c("dnorm", "dlnorm", "dgamma", "dunif"),
+ shinyjs::show("smoothing_degree")
|
|
| 860 | ! |
- c("normal", "lognormal", "gamma", "unif")
+ if (!add_trend_line()) {
|
|
| 861 | -+ | ! |
- )+ shinyjs::hide("ci")
|
| 862 | ! |
- plot_call <- substitute(+ shinyjs::hide("color_sub")
|
|
| 863 | ! |
- expr = plot_call + stat_function(+ shinyjs::hide("show_form")
|
|
| 864 | ! |
- data = data.frame(x = range(ANL[[dist_var]]), color = mapped_dist),+ shinyjs::hide("show_r2")
|
|
| 865 | ! |
- aes(x, color = color),+ if (input$show_count) {
|
|
| 866 | ! |
- fun = mapped_dist_name,+ plot_call <- plot_label_generator(show_form = FALSE, show_r2 = FALSE) |
|
| 867 | ! |
- n = ndensity,+ shinyjs::show("label_pos")
|
|
| 868 | ! |
- size = 2,+ shinyjs::show("label_size")
|
|
| 869 | -! | +
- args = params+ } else {
|
|
| 870 | -+ | ! |
- ) ++ shinyjs::hide("label_pos")
|
| 871 | ! |
- scale_color_manual(values = stats::setNames("blue", mapped_dist), aesthetics = "color"),
+ shinyjs::hide("label_size")
|
|
| 872 | -! | +
- env = list(+ } |
|
| 873 | -! | +
- plot_call = plot_call,+ } else {
|
|
| 874 | ! |
- dist_var = dist_var,+ shinyjs::show("ci")
|
|
| 875 | ! |
- ndensity = ndensity,+ shinyjs::show("show_form")
|
|
| 876 | ! |
- mapped_dist = unname(map_dist[t_dist]),+ shinyjs::show("show_r2")
|
|
| 877 | ! |
- mapped_dist_name = as.name(unname(map_dist[t_dist]))+ if (nrow(ANL) - nrow(stats::na.omit(ANL[, c(x_var, y_var)])) > 0) {
|
|
| 878 | -+ | ! |
- )+ plot_q <- teal.code::eval_code( |
| 879 | -+ | ! |
- )+ plot_q, |
| 880 | -+ | ! |
- }+ substitute( |
| 881 | -+ | ! |
-
+ expr = ANL <- dplyr::filter(ANL, !is.na(x_var) & !is.na(y_var)), |
| 882 | ! |
- all_ggplot2_args <- teal.widgets::resolve_ggplot2_args(+ env = list(x_var = as.name(x_var), y_var = as.name(y_var)) |
|
| 883 | -! | +
- user_plot = ggplot2_args[["Histogram"]],+ ) |
|
| 884 | -! | +
- user_default = ggplot2_args$default+ ) |
|
| 885 |
- )+ } |
||
| 886 | -+ | ! |
-
+ rhs_formula <- substitute( |
| 887 | ! |
- parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(+ expr = y ~ poly(x, smoothing_degree, raw = TRUE), |
|
| 888 | ! |
- all_ggplot2_args,+ env = list(smoothing_degree = smoothing_degree) |
|
| 889 | -! | +
- ggtheme = ggtheme+ ) |
|
| 890 | -+ | ! |
- )+ if (input$show_form || input$show_r2 || input$show_count) {
|
| 891 | -+ | ! |
-
+ plot_call <- plot_label_generator(rhs_formula = rhs_formula) |
| 892 | ! |
- teal.code::eval_code(+ shinyjs::show("label_pos")
|
|
| 893 | ! |
- qenv,+ shinyjs::show("label_size")
|
|
| 894 | -! | +
- substitute(+ } else {
|
|
| 895 | ! |
- expr = {
+ shinyjs::hide("label_pos")
|
|
| 896 | ! |
- g <- plot_call+ shinyjs::hide("label_size")
|
|
| 897 | -! | +
- print(g)+ } |
|
| 898 | -+ | ! |
- },+ plot_call <- substitute( |
| 899 | ! |
- env = list(plot_call = Reduce(function(x, y) call("+", x, y), c(plot_call, parsed_ggplot2_args)))
+ expr = plot_call + ggplot2::geom_smooth(formula = rhs_formula, se = TRUE, level = ci, method = "lm"), |
|
| 900 | -+ | ! |
- )+ env = list(plot_call = plot_call, rhs_formula = rhs_formula, ci = ci) |
| 901 |
- )+ ) |
||
| 902 |
- }+ } |
||
| 903 |
- )+ } else {
|
||
| 904 | -+ | ! |
-
+ shinyjs::hide("smoothing_degree")
|
| 905 | -+ | ! |
- # qqplot qenv ----+ shinyjs::hide("ci")
|
| 906 | ! |
- qq_q <- eventReactive(+ shinyjs::hide("color_sub")
|
|
| 907 | ! |
- eventExpr = {
+ shinyjs::hide("show_form")
|
|
| 908 | ! |
- common_q()+ shinyjs::hide("show_r2")
|
|
| 909 | ! |
- input$scales_type+ if (input$show_count) {
|
|
| 910 | ! |
- input$qq_line+ plot_call <- plot_label_generator(show_form = FALSE, show_r2 = FALSE) |
|
| 911 | ! |
- is.null(input$ggtheme)+ shinyjs::show("label_pos")
|
|
| 912 | -+ | ! |
- },+ shinyjs::show("label_size")
|
| 913 | -! | +
- valueExpr = {
+ } else {
|
|
| 914 | ! |
- dist_var <- merge_vars()$dist_var+ shinyjs::hide("label_pos")
|
|
| 915 | ! |
- s_var <- merge_vars()$s_var+ shinyjs::hide("label_size")
|
|
| 916 | -! | +
- g_var <- merge_vars()$g_var+ } |
|
| 917 | ! |
- dist_var_name <- merge_vars()$dist_var_name+ shinyjs::show("line_msg")
|
|
| 918 | -! | +
- s_var_name <- merge_vars()$s_var_name+ } |
|
| 919 | -! | +
- g_var_name <- merge_vars()$g_var_name+ |
|
| 920 | ! |
- t_dist <- input$t_dist+ if (!is.null(facet_cl)) {
|
|
| 921 | ! |
- dist_param1 <- input$dist_param1+ plot_call <- substitute(expr = plot_call + facet_cl, env = list(plot_call = plot_call, facet_cl = facet_cl)) |
|
| 922 | -! | +
- dist_param2 <- input$dist_param2+ } |
|
| 924 | ! |
- scales_type <- input$scales_type+ y_label <- varname_w_label( |
|
| 925 | ! |
- ggtheme <- input$ggtheme+ y_var, |
|
| 926 | -+ | ! |
-
+ ANL, |
| 927 | ! |
- teal::validate_inputs(iv_r_dist(), iv_dist)+ prefix = if (log_y) paste(log_y_fn, "(") else NULL,
|
|
| 928 | -+ | ! |
-
+ suffix = if (log_y) ")" else NULL |
| 929 | -! | +
- qenv <- common_q()+ ) |
|
| 930 | -+ | ! |
-
+ x_label <- varname_w_label( |
| 931 | ! |
- plot_call <- if (length(s_var) == 0 && length(g_var) == 0) {
+ x_var, |
|
| 932 | ! |
- substitute(+ ANL, |
|
| 933 | ! |
- expr = ggplot(ANL, aes_string(sample = dist_var)),+ prefix = if (log_x) paste(log_x_fn, "(") else NULL,
|
|
| 934 | ! |
- env = list(dist_var = dist_var)+ suffix = if (log_x) ")" else NULL |
|
| 935 |
- )+ ) |
||
| 936 | -! | +
- } else if (length(s_var) != 0 && length(g_var) == 0) {
+
|
|
| 937 | ! |
- substitute(+ dev_ggplot2_args <- teal.widgets::ggplot2_args( |
|
| 938 | ! |
- expr = ggplot(ANL, aes_string(sample = dist_var, color = s_var)),+ labs = list(y = y_label, x = x_label), |
|
| 939 | ! |
- env = list(dist_var = dist_var, s_var = s_var)+ theme = list(legend.position = "bottom") |
|
| 940 |
- )+ ) |
||
| 941 | -! | +
- } else if (length(s_var) == 0 && length(g_var) != 0) {
+
|
|
| 942 | ! |
- substitute(+ if (rotate_xaxis_labels) {
|
|
| 943 | ! |
- expr = ggplot(ANL[ANL[[g_var]] != "NA", ], aes_string(sample = dist_var)) ++ dev_ggplot2_args$theme[["axis.text.x"]] <- quote(element_text(angle = 45, hjust = 1)) |
|
| 944 | -! | +
- facet_wrap(~g_var_name, ncol = 1, scales = scales_raw),+ } |
|
| 945 | -! | +
- env = list(+ |
|
| 946 | ! |
- dist_var = dist_var,+ all_ggplot2_args <- teal.widgets::resolve_ggplot2_args( |
|
| 947 | ! |
- g_var = g_var,+ user_plot = ggplot2_args, |
|
| 948 | ! |
- g_var_name = g_var_name,+ module_plot = dev_ggplot2_args |
|
| 949 | -! | +
- scales_raw = tolower(scales_type)+ ) |
|
| 950 |
- )+ |
||
| 951 | -+ | ! |
- )+ parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(all_ggplot2_args, ggtheme = ggtheme) |
| 952 |
- } else {
+
|
||
| 953 | -! | +
- substitute(+ |
|
| 954 | ! |
- expr = ggplot(ANL[ANL[[g_var]] != "NA", ], aes_string(sample = dist_var, color = s_var)) ++ if (add_density) {
|
|
| 955 | ! |
- facet_wrap(~g_var_name, ncol = 1, scales = scales_raw),+ plot_call <- substitute( |
|
| 956 | ! |
- env = list(+ expr = ggExtra::ggMarginal( |
|
| 957 | ! |
- dist_var = dist_var,+ plot_call + labs + ggthemes + themes, |
|
| 958 | ! |
- g_var = g_var,+ type = "density", |
|
| 959 | ! |
- s_var = s_var,+ groupColour = group_colour |
|
| 960 | -! | +
- g_var_name = g_var_name,+ ), |
|
| 961 | ! |
- scales_raw = tolower(scales_type)+ env = list( |
|
| 962 | -+ | ! |
- )+ plot_call = plot_call, |
| 963 | -+ | ! |
- )+ group_colour = if (length(color_by_var) > 0) TRUE else FALSE, |
| 964 | -+ | ! |
- }+ labs = parsed_ggplot2_args$labs, |
| 965 | -+ | ! |
-
+ ggthemes = parsed_ggplot2_args$ggtheme, |
| 966 | ! |
- map_dist <- stats::setNames(+ themes = parsed_ggplot2_args$theme |
|
| 967 | -! | +
- c("qnorm", "qlnorm", "qgamma", "qunif"),
+ ) |
|
| 968 | -! | +
- c("normal", "lognormal", "gamma", "unif")
+ ) |
|
| 969 |
- )+ } else {
|
||
| 970 | -+ | ! |
-
+ plot_call <- substitute( |
| 971 | ! |
- plot_call <- substitute(+ expr = plot_call + |
|
| 972 | ! |
- expr = plot_call ++ labs + |
|
| 973 | ! |
- stat_qq(distribution = mapped_dist, dparams = params),+ ggthemes + |
|
| 974 | ! |
- env = list(plot_call = plot_call, mapped_dist = as.name(unname(map_dist[t_dist])))+ themes, |
|
| 975 | -+ | ! |
- )+ env = list( |
| 976 | -+ | ! |
-
+ plot_call = plot_call, |
| 977 | ! |
- if (length(t_dist) != 0 && length(g_var) == 0 && length(s_var) == 0) {
+ labs = parsed_ggplot2_args$labs, |
|
| 978 | ! |
- qenv <- teal.code::eval_code(+ ggthemes = parsed_ggplot2_args$ggtheme, |
|
| 979 | ! |
- qenv,+ themes = parsed_ggplot2_args$theme |
|
| 980 | -! | +
- substitute(+ ) |
|
| 981 | -! | +
- df_params <- as.data.frame(append(params, list(name = t_dist))),+ ) |
|
| 982 | -! | +
- env = list(t_dist = t_dist)+ } |
|
| 983 |
- )+ |
||
| 984 | -+ | ! |
- )+ plot_call <- substitute(expr = p <- plot_call, env = list(plot_call = plot_call)) |
| 985 | -! | +
- datas <- quote(data.frame(x = 0.7, y = 1, tb = I(list(df_params = df_params))))+ |
|
| 986 | ! |
- label <- quote(tb)+ teal.code::eval_code(plot_q, plot_call) %>% |
|
| 987 | -+ | ! |
-
+ teal.code::eval_code(quote(print(p))) |
| 988 | -! | +
- plot_call <- substitute(+ }) |
|
| 989 | -! | +
- expr = plot_call ++ |
|
| 990 | ! |
- ggpp::geom_table_npc(+ plot_r <- reactive(output_q()[["p"]]) |
|
| 991 | -! | +
- data = data,+ |
|
| 992 | -! | +
- aes(npcx = x, npcy = y, label = label),+ # Insert the plot into a plot_with_settings module from teal.widgets |
|
| 993 | ! |
- hjust = 0,+ pws <- teal.widgets::plot_with_settings_srv( |
|
| 994 | ! |
- vjust = 1,+ id = "scatter_plot", |
|
| 995 | ! |
- size = 4+ plot_r = plot_r, |
|
| 996 | -+ | ! |
- ),+ height = plot_height, |
| 997 | ! |
- env = list(+ width = plot_width, |
|
| 998 | ! |
- plot_call = plot_call,+ brushing = TRUE |
|
| 999 | -! | +
- data = datas,+ ) |
|
| 1000 | -! | +
- label = label+ |
|
| 1001 | -+ | ! |
- )+ output$data_table <- DT::renderDataTable({
|
| 1002 | -+ | ! |
- )+ plot_brush <- pws$brush() |
| 1003 |
- }+ |
||
| 1004 | -+ | ! |
-
+ if (!is.null(plot_brush)) {
|
| 1005 | ! |
- if (isTRUE(input$qq_line)) {
+ validate(need(!input$add_density, "Brushing feature is currently not supported when plot has marginal density")) |
|
| 1006 | -! | +
- plot_call <- substitute(+ } |
|
| 1007 | -! | +
- expr = plot_call ++ |
|
| 1008 | ! |
- stat_qq_line(distribution = mapped_dist, dparams = params),+ merged_data <- isolate(teal.code::dev_suppress(output_q()[["ANL"]])) |
|
| 1009 | -! | +
- env = list(plot_call = plot_call, mapped_dist = as.name(unname(map_dist[t_dist])))+ |
|
| 1010 | -+ | ! |
- )+ brushed_df <- teal.widgets::clean_brushedPoints(merged_data, plot_brush) |
| 1011 | -+ | ! |
- }+ numeric_cols <- names(brushed_df)[ |
| 1012 | -+ | ! |
-
+ vapply(brushed_df, function(x) is.numeric(x) && !is.integer(x), FUN.VALUE = logical(1)) |
| 1013 | -! | +
- all_ggplot2_args <- teal.widgets::resolve_ggplot2_args(+ ] |
|
| 1014 | -! | +
- user_plot = ggplot2_args[["QQplot"]],+ |
|
| 1015 | ! |
- user_default = ggplot2_args$default,+ if (length(numeric_cols) > 0) {
|
|
| 1016 | ! |
- module_plot = teal.widgets::ggplot2_args(labs = list(x = "theoretical", y = "sample"))+ DT::formatRound( |
|
| 1017 | -+ | ! |
- )+ DT::datatable(brushed_df, |
| 1018 | -+ | ! |
-
+ rownames = FALSE, |
| 1019 | ! |
- parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(+ options = list(scrollX = TRUE, pageLength = input$data_table_rows) |
|
| 1020 | -! | +
- all_ggplot2_args,+ ), |
|
| 1021 | ! |
- ggtheme = ggtheme+ numeric_cols, |
|
| 1022 | -+ | ! |
- )+ table_dec |
| 1023 |
-
+ ) |
||
| 1024 | -! | +
- teal.code::eval_code(+ } else {
|
|
| 1025 | ! |
- qenv,+ DT::datatable(brushed_df, rownames = FALSE, options = list(scrollX = TRUE, pageLength = input$data_table_rows)) |
|
| 1026 | -! | +
- substitute(+ } |
|
| 1027 | -! | +
- expr = {
+ }) |
|
| 1028 | -! | +
- g <- plot_call+ |
|
| 1029 | ! |
- print(g)+ teal.widgets::verbatim_popup_srv( |
|
| 1030 | -+ | ! |
- },+ id = "rcode", |
| 1031 | ! |
- env = list(plot_call = Reduce(function(x, y) call("+", x, y), c(plot_call, parsed_ggplot2_args)))
+ verbatim_content = reactive(teal.code::get_code(output_q())), |
|
| 1032 | -+ | ! |
- )+ title = "R Code for scatterplot" |
| 1033 |
- )+ ) |
||
| 1034 |
- }+ |
||
| 1035 |
- )+ ### REPORTER |
||
| 1036 | -+ | ! |
-
+ if (with_reporter) {
|
| 1037 | -+ | ! |
- # test qenv ----+ card_fun <- function(comment, label) {
|
| 1038 | ! |
- test_q <- eventReactive(+ card <- teal::report_card_template( |
|
| 1039 | ! |
- ignoreNULL = FALSE,+ title = "Scatter Plot", |
|
| 1040 | ! |
- eventExpr = {
+ label = label, |
|
| 1041 | ! |
- common_q()+ with_filter = with_filter, |
|
| 1042 | ! |
- input$dist_param1+ filter_panel_api = filter_panel_api |
|
| 1043 | -! | +
- input$dist_param2+ ) |
|
| 1044 | ! |
- input$dist_tests+ card$append_text("Plot", "header3")
|
|
| 1045 | -+ | ! |
- },+ card$append_plot(plot_r(), dim = pws$dim()) |
| 1046 | ! |
- valueExpr = {
+ if (!comment == "") {
|
|
| 1047 | -+ | ! |
- # Create a private stack for this function only.+ card$append_text("Comment", "header3")
|
| 1048 | ! |
- ANL <- common_q()[["ANL"]]+ card$append_text(comment) |
|
| 1049 |
-
+ } |
||
| 1050 | ! |
- dist_var <- merge_vars()$dist_var+ card$append_src(teal.code::get_code(output_q())) |
|
| 1051 | ! |
- s_var <- merge_vars()$s_var+ card |
|
| 1052 | -! | +
- g_var <- merge_vars()$g_var+ } |
|
| 1053 | -+ | ! |
-
+ teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
|
| 1054 | -! | +
- dist_var_name <- merge_vars()$dist_var_name+ } |
|
| 1055 | -! | +
- s_var_name <- merge_vars()$s_var_name+ ### |
|
| 1056 | -! | +
- g_var_name <- merge_vars()$g_var_name+ }) |
|
| 1057 |
-
+ } |
||
| 1058 | -! | +
| 1 | +
- dist_param1 <- input$dist_param1+ #' `teal` module: Missing data analysis |
||
| 1059 | -! | +||
| 2 | +
- dist_param2 <- input$dist_param2+ #' |
||
| 1060 | -! | +||
| 3 | +
- dist_tests <- input$dist_tests+ #' This module analyzes missing data in `data.frame`s to help users explore missing observations and |
||
| 1061 | -! | +||
| 4 | +
- t_dist <- input$t_dist+ #' gain insights into the completeness of their data. |
||
| 1062 | +5 |
-
+ #' It is useful for clinical data analysis within the context of `CDISC` standards and |
|
| 1063 | -! | +||
| 6 | +
- validate(need(dist_tests, "Please select a test"))+ #' adaptable for general data analysis purposes. |
||
| 1064 | +7 |
-
+ #' |
|
| 1065 | -! | +||
| 8 | +
- teal::validate_inputs(iv_dist)+ #' @inheritParams teal::module |
||
| 1066 | +9 |
-
+ #' @inheritParams shared_params |
|
| 1067 | -! | +||
| 10 | +
- if (length(s_var) > 0 || length(g_var) > 0) {
+ #' @param parent_dataname (`character(1)`) Specifies the parent dataset name. Default is `ADSL` for `CDISC` data. |
||
| 1068 | -! | +||
| 11 | +
- counts <- ANL %>%+ #' If provided and exists, enables additional analysis "by subject". For non-`CDISC` data, this parameter can be |
||
| 1069 | -! | +||
| 12 | +
- dplyr::group_by_at(dplyr::vars(dplyr::any_of(c(s_var, g_var)))) %>%+ #' ignored. |
||
| 1070 | -! | +||
| 13 | +
- dplyr::summarise(n = dplyr::n())+ #' @param ggtheme (`character`) optional, specifies the default `ggplot2` theme for plots. Defaults to `classic`. |
||
| 1071 | +14 |
-
+ #' |
|
| 1072 | -! | +||
| 15 | +
- validate(need(all(counts$n > 5), "Please select strata*group with at least 5 observation each."))+ #' @templateVar ggnames "Summary Obs", "Summary Patients", "Combinations Main", "Combinations Hist", "By Subject" |
||
| 1073 | +16 |
- }+ #' @template ggplot2_args_multi |
|
| 1074 | +17 |
-
+ #' |
|
| 1075 | +18 |
-
+ #' @inherit shared_params return |
|
| 1076 | -! | +||
| 19 | +
- if (dist_tests %in% c(+ #' |
||
| 1077 | -! | +||
| 20 | +
- "t-test (two-samples, not paired)",+ #' @examplesShinylive |
||
| 1078 | -! | +||
| 21 | +
- "F-test",+ #' library(teal.modules.general) |
||
| 1079 | -! | +||
| 22 | +
- "Kolmogorov-Smirnov (two-samples)"+ #' interactive <- function() TRUE |
||
| 1080 | +23 |
- )) {
+ #' {{ next_example }}
|
|
| 1081 | -! | +||
| 24 | +
- if (length(g_var) == 0 && length(s_var) > 0) {
+ #' @examplesIf require("gridExtra", quietly = TRUE) && require("rlang", quietly = TRUE)
|
||
| 1082 | -! | +||
| 25 | +
- validate(need(+ #' # general example data |
||
| 1083 | -! | +||
| 26 | +
- length(unique(ANL[[s_var]])) == 2,+ #' data <- teal_data() |
||
| 1084 | -! | +||
| 27 | +
- "Please select stratify variable with 2 levels."+ #' data <- within(data, {
|
||
| 1085 | +28 |
- ))+ #' require(nestcolor) |
|
| 1086 | +29 |
- }+ #' |
|
| 1087 | -! | +||
| 30 | +
- if (length(g_var) > 0 && length(s_var) > 0) {
+ #' add_nas <- function(x) {
|
||
| 1088 | -! | +||
| 31 | +
- validate(need(+ #' x[sample(seq_along(x), floor(length(x) * runif(1, .05, .17)))] <- NA |
||
| 1089 | -! | +||
| 32 | +
- all(stats::na.omit(as.vector(+ #' x |
||
| 1090 | -! | +||
| 33 | +
- tapply(ANL[[s_var]], list(ANL[[g_var]]), function(x) length(unique(x))) == 2+ #' } |
||
| 1091 | +34 |
- ))),+ #' |
|
| 1092 | -! | +||
| 35 | +
- "Please select stratify variable with 2 levels, per each group."+ #' iris <- iris |
||
| 1093 | +36 |
- ))+ #' mtcars <- mtcars |
|
| 1094 | +37 |
- }+ #' |
|
| 1095 | +38 |
- }+ #' iris[] <- lapply(iris, add_nas) |
|
| 1096 | +39 |
-
+ #' mtcars[] <- lapply(mtcars, add_nas) |
|
| 1097 | -! | +||
| 40 | +
- map_dist <- stats::setNames(+ #' mtcars[["cyl"]] <- as.factor(mtcars[["cyl"]]) |
||
| 1098 | -! | +||
| 41 | +
- c("pnorm", "plnorm", "pgamma", "punif"),
+ #' mtcars[["gear"]] <- as.factor(mtcars[["gear"]]) |
||
| 1099 | -! | +||
| 42 | +
- c("normal", "lognormal", "gamma", "unif")
+ #' }) |
||
| 1100 | +43 |
- )+ #' |
|
| 1101 | -! | +||
| 44 | +
- sks_args <- list(+ #' app <- init( |
||
| 1102 | -! | +||
| 45 | +
- test = quote(stats::ks.test),+ #' data = data, |
||
| 1103 | -! | +||
| 46 | +
- args = bquote(append(list(.[[.(dist_var)]], .(map_dist[t_dist])), params)),+ #' modules = modules( |
||
| 1104 | -! | +||
| 47 | +
- groups = c(g_var, s_var)+ #' tm_missing_data() |
||
| 1105 | +48 |
- )+ #' ) |
|
| 1106 | -! | +||
| 49 | +
- ssw_args <- list(+ #' ) |
||
| 1107 | -! | +||
| 50 | +
- test = quote(stats::shapiro.test),+ #' if (interactive()) {
|
||
| 1108 | -! | +||
| 51 | +
- args = bquote(list(.[[.(dist_var)]])),+ #' shinyApp(app$ui, app$server) |
||
| 1109 | -! | +||
| 52 | +
- groups = c(g_var, s_var)+ #' } |
||
| 1110 | +53 |
- )+ #' |
|
| 1111 | -! | +||
| 54 | +
- mfil_args <- list(+ #' @examplesShinylive |
||
| 1112 | -! | +||
| 55 | +
- test = quote(stats::fligner.test),+ #' library(teal.modules.general) |
||
| 1113 | -! | +||
| 56 | +
- args = bquote(list(.[[.(dist_var)]], .[[.(s_var)]])),+ #' interactive <- function() TRUE |
||
| 1114 | -! | +||
| 57 | +
- groups = c(g_var)+ #' {{ next_example }}
|
||
| 1115 | +58 |
- )+ #' @examplesIf require("gridExtra", quietly = TRUE) && require("rlang", quietly = TRUE)
|
|
| 1116 | -! | +||
| 59 | +
- sad_args <- list(+ #' # CDISC example data |
||
| 1117 | -! | +||
| 60 | +
- test = quote(goftest::ad.test),+ #' data <- teal_data() |
||
| 1118 | -! | +||
| 61 | +
- args = bquote(append(list(.[[.(dist_var)]], .(map_dist[t_dist])), params)),+ #' data <- within(data, {
|
||
| 1119 | -! | +||
| 62 | +
- groups = c(g_var, s_var)+ #' require(nestcolor) |
||
| 1120 | +63 |
- )+ #' ADSL <- rADSL |
|
| 1121 | -! | +||
| 64 | +
- scvm_args <- list(+ #' ADRS <- rADRS |
||
| 1122 | -! | +||
| 65 | +
- test = quote(goftest::cvm.test),+ #' }) |
||
| 1123 | -! | +||
| 66 | +
- args = bquote(append(list(.[[.(dist_var)]], .(map_dist[t_dist])), params)),+ #' join_keys(data) <- default_cdisc_join_keys[names(data)] |
||
| 1124 | -! | +||
| 67 | +
- groups = c(g_var, s_var)+ #' |
||
| 1125 | +68 |
- )+ #' app <- init( |
|
| 1126 | -! | +||
| 69 | +
- manov_args <- list(+ #' data = data, |
||
| 1127 | -! | +||
| 70 | +
- test = quote(stats::aov),+ #' modules = modules( |
||
| 1128 | -! | +||
| 71 | +
- args = bquote(list(stats::formula(.(dist_var_name) ~ .(s_var_name)), .)),+ #' tm_missing_data() |
||
| 1129 | -! | +||
| 72 | +
- groups = c(g_var)+ #' ) |
||
| 1130 | +73 |
- )+ #' ) |
|
| 1131 | -! | +||
| 74 | +
- mt_args <- list(+ #' if (interactive()) {
|
||
| 1132 | -! | +||
| 75 | +
- test = quote(stats::t.test),+ #' shinyApp(app$ui, app$server) |
||
| 1133 | -! | +||
| 76 | +
- args = bquote(unname(split(.[[.(dist_var)]], .[[.(s_var)]], drop = TRUE))),+ #' } |
||
| 1134 | -! | +||
| 77 | +
- groups = c(g_var)+ #' |
||
| 1135 | +78 |
- )+ #' @export |
|
| 1136 | -! | +||
| 79 | +
- mv_args <- list(+ #' |
||
| 1137 | -! | +||
| 80 | +
- test = quote(stats::var.test),+ tm_missing_data <- function(label = "Missing data", |
||
| 1138 | -! | +||
| 81 | +
- args = bquote(unname(split(.[[.(dist_var)]], .[[.(s_var)]], drop = TRUE))),+ plot_height = c(600, 400, 5000), |
||
| 1139 | -! | +||
| 82 | +
- groups = c(g_var)+ plot_width = NULL, |
||
| 1140 | +83 |
- )+ parent_dataname = "ADSL", |
|
| 1141 | -! | +||
| 84 | +
- mks_args <- list(+ ggtheme = c("classic", "gray", "bw", "linedraw", "light", "dark", "minimal", "void"),
|
||
| 1142 | -! | +||
| 85 | +
- test = quote(stats::ks.test),+ ggplot2_args = list( |
||
| 1143 | -! | +||
| 86 | +
- args = bquote(unname(split(.[[.(dist_var)]], .[[.(s_var)]], drop = TRUE))),+ "Combinations Hist" = teal.widgets::ggplot2_args(labs = list(caption = NULL)), |
||
| 1144 | -! | +||
| 87 | +
- groups = c(g_var)+ "Combinations Main" = teal.widgets::ggplot2_args(labs = list(title = NULL)) |
||
| 1145 | +88 |
- )+ ), |
|
| 1146 | +89 |
-
+ pre_output = NULL, |
|
| 1147 | -! | +||
| 90 | +
- tests_base <- switch(dist_tests,+ post_output = NULL) {
|
||
| 1148 | +91 | ! |
- "Kolmogorov-Smirnov (one-sample)" = sks_args,+ message("Initializing tm_missing_data")
|
| 1149 | -! | +||
| 92 | +
- "Shapiro-Wilk" = ssw_args,+ |
||
| 1150 | -! | +||
| 93 | +
- "Fligner-Killeen" = mfil_args,+ # Requires Suggested packages |
||
| 1151 | +94 | ! |
- "one-way ANOVA" = manov_args,+ if (!requireNamespace("gridExtra", quietly = TRUE)) {
|
| 1152 | +95 | ! |
- "t-test (two-samples, not paired)" = mt_args,+ stop("Cannot load gridExtra - please install the package or restart your session.")
|
| 1153 | -! | +||
| 96 | +
- "F-test" = mv_args,+ } |
||
| 1154 | +97 | ! |
- "Kolmogorov-Smirnov (two-samples)" = mks_args,+ if (!requireNamespace("rlang", quietly = TRUE)) {
|
| 1155 | +98 | ! |
- "Anderson-Darling (one-sample)" = sad_args,+ stop("Cannot load rlang - please install the package or restart your session.")
|
| 1156 | -! | +||
| 99 | +
- "Cramer-von Mises (one-sample)" = scvm_args+ } |
||
| 1157 | +100 |
- )+ |
|
| 1158 | +101 |
-
+ # Normalize the parameters |
|
| 1159 | +102 | ! |
- env <- list(+ if (inherits(ggplot2_args, "ggplot2_args")) ggplot2_args <- list(default = ggplot2_args) |
| 1160 | -! | +||
| 103 | +
- t_test = t_dist,+ |
||
| 1161 | -! | +||
| 104 | +
- dist_var = dist_var,+ # Start of assertions |
||
| 1162 | +105 | ! |
- g_var = g_var,+ checkmate::assert_string(label) |
| 1163 | -! | +||
| 106 | +
- s_var = s_var,+ |
||
| 1164 | +107 | ! |
- args = tests_base$args,+ checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE) |
| 1165 | +108 | ! |
- groups = tests_base$groups,+ checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height") |
| 1166 | +109 | ! |
- test = tests_base$test,+ checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE) |
| 1167 | +110 | ! |
- dist_var_name = dist_var_name,+ checkmate::assert_numeric( |
| 1168 | +111 | ! |
- g_var_name = g_var_name,+ plot_width[1], |
| 1169 | +112 | ! |
- s_var_name = s_var_name+ lower = plot_width[2], upper = plot_width[3], null.ok = TRUE, .var.name = "plot_width" |
| 1170 | +113 |
- )+ ) |
|
| 1171 | +114 | ||
| 1172 | +115 | ! |
- qenv <- common_q()+ checkmate::assert_character(parent_dataname, min.len = 0, max.len = 1)+ |
+
| 116 | +! | +
+ ggtheme <- match.arg(ggtheme) |
|
| 1173 | +117 | ||
| 1174 | +118 | ! |
- if (length(s_var) == 0 && length(g_var) == 0) {
+ plot_choices <- c("Summary Obs", "Summary Patients", "Combinations Main", "Combinations Hist", "By Subject")
|
| 1175 | +119 | ! |
- qenv <- teal.code::eval_code(+ checkmate::assert_list(ggplot2_args, types = "ggplot2_args") |
| 1176 | +120 | ! |
- qenv,+ checkmate::assert_subset(names(ggplot2_args), c("default", plot_choices))
|
| 1177 | -! | +||
| 121 | +
- substitute(+ |
||
| 1178 | +122 | ! |
- expr = {
+ checkmate::assert_multi_class(pre_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
|
| 1179 | +123 | ! |
- test_stats <- ANL %>%+ checkmate::assert_multi_class(post_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
|
| 1180 | -! | +||
| 124 | +
- dplyr::select(dist_var) %>%- |
- ||
| 1181 | -! | -
- with(., broom::glance(do.call(test, args))) %>%- |
- |
| 1182 | -! | -
- dplyr::mutate_if(is.numeric, round, 3)- |
- |
| 1183 | -- |
- },- |
- |
| 1184 | -! | -
- env = env- |
- |
| 1185 | -- |
- )- |
- |
| 1186 | -- |
- )+ # End of assertions |
|
| 1187 | +125 |
- } else {
- |
- |
| 1188 | -! | -
- qenv <- teal.code::eval_code(+ |
|
| 1189 | +126 | ! |
- qenv,+ ans <- module( |
| 1190 | +127 | ! |
- substitute(+ label, |
| 1191 | +128 | ! |
- expr = {
+ server = srv_page_missing_data, |
| 1192 | +129 | ! |
- test_stats <- ANL %>%+ server_args = list( |
| 1193 | +130 | ! |
- dplyr::select(dist_var, s_var, g_var) %>%+ parent_dataname = parent_dataname, plot_height = plot_height, |
| 1194 | +131 | ! |
- dplyr::group_by_at(dplyr::vars(dplyr::any_of(groups))) %>%+ plot_width = plot_width, ggplot2_args = ggplot2_args, ggtheme = ggtheme |
| 1195 | -! | +||
| 132 | +
- dplyr::do(tests = broom::glance(do.call(test, args))) %>%+ ), |
||
| 1196 | +133 | ! |
- tidyr::unnest(tests) %>%+ ui = ui_page_missing_data, |
| 1197 | +134 | ! |
- dplyr::mutate_if(is.numeric, round, 3)- |
-
| 1198 | -- |
- },+ datanames = "all", |
|
| 1199 | +135 | ! |
- env = env- |
-
| 1200 | -- |
- )- |
- |
| 1201 | -- |
- )+ ui_args = list(pre_output = pre_output, post_output = post_output) |
|
| 1202 | +136 |
- }+ ) |
|
| 1203 | +137 | ! |
- qenv %>%- |
-
| 1204 | -- |
- # used to display table when running show-r-code code+ attr(ans, "teal_bookmarkable") <- TRUE |
|
| 1205 | +138 | ! |
- teal.code::eval_code(quote(test_stats))+ ans |
| 1206 | +139 |
- }+ } |
|
| 1207 | +140 |
- )+ |
|
| 1208 | +141 |
-
+ # UI function for the missing data module (all datasets) |
|
| 1209 | +142 |
- # outputs ----+ ui_page_missing_data <- function(id, pre_output = NULL, post_output = NULL) {
|
|
| 1210 | -+ | ||
| 143 | +! |
- ## building main qenv+ ns <- NS(id) |
|
| 1211 | +144 | ! |
- output_q <- reactive({
+ tagList( |
| 1212 | +145 | ! |
- tab <- input$tabs+ include_css_files("custom"),
|
| 1213 | +146 | ! |
- req(tab) # tab is NULL upon app launch, hence will crash without this statement+ teal.widgets::standard_layout( |
| 1214 | -+ | ||
| 147 | +! |
-
+ output = teal.widgets::white_small_well( |
|
| 1215 | +148 | ! |
- qenv_final <- common_q()+ tags$div( |
| 1216 | -+ | ||
| 149 | +! |
- # wrapped in if since could lead into validate error - we do want to continue+ class = "flex", |
|
| 1217 | +150 | ! |
- test_r_qenv_out <- try(test_q(), silent = TRUE)+ column( |
| 1218 | +151 | ! |
- if (!inherits(test_r_qenv_out, c("try-error", "error"))) {
+ width = 12, |
| 1219 | +152 | ! |
- qenv_final <- teal.code::join(qenv_final, test_q())+ uiOutput(ns("dataset_tabs"))
|
| 1220 | +153 |
- }+ ) |
|
| 1221 | +154 |
-
+ ) |
|
| 1222 | -! | +||
| 155 | +
- qenv_final <- if (tab == "Histogram") {
+ ), |
||
| 1223 | +156 | ! |
- req(dist_q())+ encoding = tags$div( |
| 1224 | +157 | ! |
- teal.code::join(qenv_final, dist_q())+ uiOutput(ns("dataset_encodings"))
|
| 1225 | -! | +||
| 158 | +
- } else if (tab == "QQplot") {
+ ), |
||
| 1226 | +159 | ! |
- req(qq_q())+ uiOutput(ns("dataset_reporter")),
|
| 1227 | +160 | ! |
- teal.code::join(qenv_final, qq_q())- |
-
| 1228 | -- |
- }+ pre_output = pre_output, |
|
| 1229 | +161 | ! |
- qenv_final+ post_output = post_output |
| 1230 | +162 |
- })+ ) |
|
| 1231 | +163 |
-
+ ) |
|
| 1232 | -! | +||
| 164 | +
- dist_r <- reactive(dist_q()[["g"]])+ } |
||
| 1233 | +165 | ||
| 1234 | -! | -
- qq_r <- reactive(qq_q()[["g"]])- |
- |
| 1235 | +166 |
-
+ # Server function for the missing data module (all datasets) |
|
| 1236 | -! | +||
| 167 | +
- output$summary_table <- DT::renderDataTable(+ srv_page_missing_data <- function(id, data, reporter, filter_panel_api, parent_dataname, |
||
| 1237 | -! | +||
| 168 | +
- expr = if (iv_r()$is_valid()) common_q()[["summary_table"]] else NULL,+ plot_height, plot_width, ggplot2_args, ggtheme) {
|
||
| 1238 | +169 | ! |
- options = list(+ with_reporter <- !missing(reporter) && inherits(reporter, "Reporter") |
| 1239 | +170 | ! |
- autoWidth = TRUE,+ with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI") |
| 1240 | +171 | ! |
- columnDefs = list(list(width = "200px", targets = "_all"))- |
-
| 1241 | -- |
- ),+ moduleServer(id, function(input, output, session) {
|
|
| 1242 | +172 | ! |
- rownames = FALSE- |
-
| 1243 | -- |
- )+ teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.general") |
|
| 1244 | +173 | ||
| 1245 | +174 | ! |
- tests_r <- reactive({
+ datanames <- isolate(names(data())) |
| 1246 | +175 | ! |
- req(iv_r()$is_valid())+ datanames <- Filter( |
| 1247 | +176 | ! |
- teal::validate_inputs(iv_r_dist())+ function(name) is.data.frame(isolate(data())[[name]]), |
| 1248 | +177 | ! |
- test_q()[["test_stats"]]+ datanames |
| 1249 | +178 |
- })+ )+ |
+ |
| 179 | +! | +
+ if_subject_plot <- length(parent_dataname) > 0 && parent_dataname %in% datanames |
|
| 1250 | +180 | ||
| 1251 | +181 | ! |
- pws1 <- teal.widgets::plot_with_settings_srv(+ ns <- session$ns |
| 1252 | -! | +||
| 182 | +
- id = "hist_plot",+ |
||
| 1253 | +183 | ! |
- plot_r = dist_r,+ output$dataset_tabs <- renderUI({
|
| 1254 | +184 | ! |
- height = plot_height,+ do.call( |
| 1255 | +185 | ! |
- width = plot_width,+ tabsetPanel, |
| 1256 | +186 | ! |
- brushing = FALSE- |
-
| 1257 | -- |
- )- |
- |
| 1258 | -- |
-
+ c( |
|
| 1259 | +187 | ! |
- pws2 <- teal.widgets::plot_with_settings_srv(+ id = ns("dataname_tab"),
|
| 1260 | +188 | ! |
- id = "qq_plot",+ lapply( |
| 1261 | +189 | ! |
- plot_r = qq_r,+ datanames, |
| 1262 | +190 | ! |
- height = plot_height,+ function(x) {
|
| 1263 | +191 | ! |
- width = plot_width,+ tabPanel( |
| 1264 | +192 | ! |
- brushing = FALSE- |
-
| 1265 | -- |
- )+ title = x, |
|
| 1266 | -+ | ||
| 193 | +! |
-
+ column( |
|
| 1267 | +194 | ! |
- output$t_stats <- DT::renderDataTable(+ width = 12, |
| 1268 | +195 | ! |
- expr = tests_r(),+ tags$div( |
| 1269 | +196 | ! |
- options = list(scrollX = TRUE),+ class = "mt-4", |
| 1270 | +197 | ! |
- rownames = FALSE+ ui_missing_data(id = ns(x), by_subject_plot = if_subject_plot) |
| 1271 | +198 |
- )+ ) |
|
| 1272 | +199 |
-
+ ) |
|
| 1273 | -! | +||
| 200 | +
- teal.widgets::verbatim_popup_srv(+ ) |
||
| 1274 | -! | +||
| 201 | +
- id = "rcode",+ } |
||
| 1275 | -! | +||
| 202 | +
- verbatim_content = reactive(teal.code::get_code(output_q())),+ ) |
||
| 1276 | -! | +||
| 203 | +
- title = "R Code for distribution"+ ) |
||
| 1277 | +204 |
- )+ ) |
|
| 1278 | +205 |
-
+ }) |
|
| 1279 | +206 |
- ### REPORTER+ |
|
| 1280 | +207 | ! |
- if (with_reporter) {
+ output$dataset_encodings <- renderUI({
|
| 1281 | +208 | ! |
- card_fun <- function(comment, label) {
+ tagList( |
| 1282 | +209 | ! |
- card <- teal::report_card_template(+ lapply( |
| 1283 | +210 | ! |
- title = "Distribution Plot",+ datanames, |
| 1284 | +211 | ! |
- label = label,+ function(x) {
|
| 1285 | +212 | ! |
- with_filter = with_filter,+ conditionalPanel( |
| 1286 | +213 | ! |
- filter_panel_api = filter_panel_api- |
-
| 1287 | -- |
- )+ is_tab_active_js(ns("dataname_tab"), x),
|
|
| 1288 | +214 | ! |
- card$append_text("Plot", "header3")
+ encoding_missing_data( |
| 1289 | +215 | ! |
- if (input$tabs == "Histogram") {
+ id = ns(x), |
| 1290 | +216 | ! |
- card$append_plot(dist_r(), dim = pws1$dim())+ summary_per_patient = if_subject_plot, |
| 1291 | +217 | ! |
- } else if (input$tabs == "QQplot") {
+ ggtheme = ggtheme, |
| 1292 | +218 | ! |
- card$append_plot(qq_r(), dim = pws2$dim())+ datanames = datanames |
| 1293 | +219 |
- }- |
- |
| 1294 | -! | -
- card$append_text("Statistics table", "header3")
+ ) |
|
| 1295 | +220 | - - | -|
| 1296 | -! | -
- card$append_table(common_q()[["summary_table"]])- |
- |
| 1297 | -! | -
- tests_error <- tryCatch(expr = tests_r(), error = function(e) "error")+ ) |
|
| 1298 | -! | +||
| 221 | +
- if (inherits(tests_error, "data.frame")) {
+ } |
||
| 1299 | -! | +||
| 222 | +
- card$append_text("Tests table", "header3")
+ ) |
||
| 1300 | -! | +||
| 223 | +
- card$append_table(tests_r())+ ) |
||
| 1301 | +224 |
- }+ }) |
|
| 1302 | +225 | ||
| 1303 | +226 | ! |
- if (!comment == "") {
+ output$dataset_reporter <- renderUI({
|
| 1304 | +227 | ! |
- card$append_text("Comment", "header3")
+ lapply(datanames, function(x) {
|
| 1305 | +228 | ! |
- card$append_text(comment)+ dataname_ns <- NS(ns(x)) |
| 1306 | +229 |
- }+ |
|
| 1307 | +230 | ! |
- card$append_src(teal.code::get_code(output_q()))+ conditionalPanel( |
| 1308 | +231 | ! |
- card+ is_tab_active_js(ns("dataname_tab"), x),
|
| 1309 | -+ | ||
| 232 | +! |
- }+ tagList( |
|
| 1310 | +233 | ! |
- teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
+ teal.widgets::verbatim_popup_ui(dataname_ns("rcode"), "Show R code")
|
| 1311 | +234 |
- }+ ) |
|
| 1312 | +235 |
- ###+ ) |
|
| 1313 | +236 |
- })+ }) |
|
| 1314 | +237 |
- }+ }) |
| 1 | +238 |
- #' `teal` module: Variable browser+ |
|
| 2 | -+ | ||
| 239 | +! |
- #'+ lapply( |
|
| 3 | -+ | ||
| 240 | +! |
- #' Module provides provides a detailed summary and visualization of variable distributions+ datanames, |
|
| 4 | -+ | ||
| 241 | +! |
- #' for `data.frame` objects, with interactive features to customize analysis.+ function(x) {
|
|
| 5 | -+ | ||
| 242 | +! |
- #'+ srv_missing_data( |
|
| 6 | -+ | ||
| 243 | +! |
- #' Numeric columns with fewer than 30 distinct values can be treated as either discrete+ id = x, |
|
| 7 | -+ | ||
| 244 | +! |
- #' or continuous with a checkbox allowing users to switch how they are treated(if < 6 unique values+ data = data, |
|
| 8 | -+ | ||
| 245 | +! |
- #' then the default is discrete, otherwise it is continuous).+ reporter = if (with_reporter) reporter, |
|
| 9 | -+ | ||
| 246 | +! |
- #'+ filter_panel_api = if (with_filter) filter_panel_api, |
|
| 10 | -+ | ||
| 247 | +! |
- #' @inheritParams teal::module+ dataname = x, |
|
| 11 | -+ | ||
| 248 | +! |
- #' @inheritParams shared_params+ parent_dataname = parent_dataname, |
|
| 12 | -+ | ||
| 249 | +! |
- #' @param parent_dataname (`character(1)`) string specifying a parent dataset.+ plot_height = plot_height, |
|
| 13 | -+ | ||
| 250 | +! |
- #' If it exists in `datasets_selected`then an extra checkbox will be shown to+ plot_width = plot_width, |
|
| 14 | -+ | ||
| 251 | +! |
- #' allow users to not show variables in other datasets which exist in this `dataname`.+ ggplot2_args = ggplot2_args |
|
| 15 | +252 |
- #' This is typically used to remove `ADSL` columns in `CDISC` data.+ ) |
|
| 16 | +253 |
- #' In non `CDISC` data this can be ignored. Defaults to `"ADSL"`.+ } |
|
| 17 | +254 |
- #' @param datasets_selected (`character`) vector of datasets which should be+ ) |
|
| 18 | +255 |
- #' shown, in order. Names must correspond with datasets names.+ }) |
|
| 19 | +256 |
- #' If vector of length zero (default) then all datasets are shown.+ } |
|
| 20 | +257 |
- #' Note: Only `data.frame` objects are compatible; using other types will cause an error.+ |
|
| 21 | +258 |
- #'+ # UI function for the missing data module (single dataset) |
|
| 22 | +259 |
- #' @inherit shared_params return+ ui_missing_data <- function(id, by_subject_plot = FALSE) {
|
|
| 23 | -+ | ||
| 260 | +! |
- #'+ ns <- NS(id) |
|
| 24 | +261 |
- #' @examplesShinylive+ |
|
| 25 | -+ | ||
| 262 | +! |
- #' library(teal.modules.general)+ tab_list <- list( |
|
| 26 | -+ | ||
| 263 | +! |
- #' interactive <- function() TRUE+ tabPanel( |
|
| 27 | -+ | ||
| 264 | +! |
- #' {{ next_example }}
+ "Summary", |
|
| 28 | -+ | ||
| 265 | +! |
- # nolint start: line_length_linter.+ teal.widgets::plot_with_settings_ui(id = ns("summary_plot")),
|
|
| 29 | -+ | ||
| 266 | +! |
- #' @examplesIf require("sparkline", quietly = TRUE) && require("htmlwidgets", quietly = TRUE) && require("jsonlite", quietly = TRUE)
+ helpText( |
|
| 30 | -+ | ||
| 267 | +! |
- # nolint end: line_length_linter.+ tags$p(paste( |
|
| 31 | -+ | ||
| 268 | +! |
- #' # general data example+ 'The "Summary" graph shows the number of missing values per variable (both absolute and percentage),', |
|
| 32 | -+ | ||
| 269 | +! |
- #' data <- teal_data()+ "sorted by magnitude." |
|
| 33 | +270 |
- #' data <- within(data, {
+ )), |
|
| 34 | -+ | ||
| 271 | +! |
- #' iris <- iris+ tags$p( |
|
| 35 | -+ | ||
| 272 | +! |
- #' mtcars <- mtcars+ 'The "summary per patients" graph is showing how many subjects have at least one missing observation', |
|
| 36 | -+ | ||
| 273 | +! |
- #' women <- women+ "for each variable. It will be most useful for panel datasets." |
|
| 37 | +274 |
- #' faithful <- faithful+ ) |
|
| 38 | +275 |
- #' CO2 <- CO2+ ) |
|
| 39 | +276 |
- #' })+ ), |
|
| 40 | -+ | ||
| 277 | +! |
- #' datanames(data) <- c("iris", "mtcars", "women", "faithful", "CO2")
+ tabPanel( |
|
| 41 | -+ | ||
| 278 | +! |
- #'+ "Combinations", |
|
| 42 | -+ | ||
| 279 | +! |
- #' app <- init(+ teal.widgets::plot_with_settings_ui(id = ns("combination_plot")),
|
|
| 43 | -+ | ||
| 280 | +! |
- #' data = data,+ helpText( |
|
| 44 | -+ | ||
| 281 | +! |
- #' modules = modules(+ tags$p(paste( |
|
| 45 | -+ | ||
| 282 | +! |
- #' tm_variable_browser(+ 'The "Combinations" graph is used to explore the relationship between the missing data within', |
|
| 46 | -+ | ||
| 283 | +! |
- #' label = "Variable browser"+ "different columns of the dataset.", |
|
| 47 | -+ | ||
| 284 | +! |
- #' )+ "It shows the different patterns of missingness in the rows of the data.", |
|
| 48 | -+ | ||
| 285 | +! |
- #' )+ 'For example, suppose that 70 rows of the data have exactly columns "A" and "B" missing.', |
|
| 49 | -+ | ||
| 286 | +! |
- #' )+ "In this case there would be a bar of height 70 in the top graph and", |
|
| 50 | -+ | ||
| 287 | +! |
- #' if (interactive()) {
+ 'the column below this in the second graph would have rows "A" and "B" cells shaded red.' |
|
| 51 | +288 |
- #' shinyApp(app$ui, app$server)+ )), |
|
| 52 | -- |
- #' }- |
- |
| 53 | -+ | ||
| 289 | +! |
- #'+ tags$p(paste( |
|
| 54 | -+ | ||
| 290 | +! |
- #' @examplesShinylive+ "Due to the large number of missing data patterns possible, only those with a large set of observations", |
|
| 55 | -+ | ||
| 291 | +! |
- #' library(teal.modules.general)+ 'are shown in the graph and the "Combination cut-off" slider can be used to adjust the number shown.' |
|
| 56 | +292 |
- #' interactive <- function() TRUE+ )) |
|
| 57 | +293 |
- #' {{ next_example }}
+ ) |
|
| 58 | +294 |
- # nolint start: line_length_linter.+ ), |
|
| 59 | -+ | ||
| 295 | +! |
- #' @examplesIf require("sparkline", quietly = TRUE) && require("htmlwidgets", quietly = TRUE) && require("jsonlite", quietly = TRUE)
+ tabPanel( |
|
| 60 | -+ | ||
| 296 | +! |
- # nolint end: line_length_linter.+ "By Variable Levels", |
|
| 61 | -+ | ||
| 297 | +! |
- #' # CDISC example data+ teal.widgets::get_dt_rows(ns("levels_table"), ns("levels_table_rows")),
|
|
| 62 | -+ | ||
| 298 | +! |
- #' library(sparkline)+ DT::dataTableOutput(ns("levels_table"))
|
|
| 63 | +299 |
- #' data <- teal_data()+ ) |
|
| 64 | +300 |
- #' data <- within(data, {
+ ) |
|
| 65 | -+ | ||
| 301 | +! |
- #' ADSL <- rADSL+ if (isTRUE(by_subject_plot)) {
|
|
| 66 | -+ | ||
| 302 | +! |
- #' ADTTE <- rADTTE+ tab_list <- append( |
|
| 67 | -+ | ||
| 303 | +! |
- #' })+ tab_list, |
|
| 68 | -+ | ||
| 304 | +! |
- #' datanames(data) <- c("ADSL", "ADTTE")
+ list(tabPanel( |
|
| 69 | -+ | ||
| 305 | +! |
- #' join_keys(data) <- default_cdisc_join_keys[datanames(data)]+ "Grouped by Subject", |
|
| 70 | -+ | ||
| 306 | +! |
- #'+ teal.widgets::plot_with_settings_ui(id = ns("by_subject_plot")),
|
|
| 71 | -+ | ||
| 307 | +! |
- #' app <- init(+ helpText( |
|
| 72 | -+ | ||
| 308 | +! |
- #' data = data,+ tags$p(paste( |
|
| 73 | -+ | ||
| 309 | +! |
- #' modules = modules(+ "This graph shows the missingness with respect to subjects rather than individual rows of the", |
|
| 74 | -+ | ||
| 310 | +! |
- #' tm_variable_browser(+ "dataset. Each row represents one dataset variable and each column a single subject. Only subjects", |
|
| 75 | -+ | ||
| 311 | +! |
- #' label = "Variable browser"+ "with at least one record in this dataset are shown. For a given subject, if they have any missing", |
|
| 76 | -+ | ||
| 312 | +! |
- #' )+ "values of a specific variable then the appropriate cell in the graph is marked as missing." |
|
| 77 | +313 |
- #' )+ )) |
|
| 78 | +314 |
- #' )+ ) |
|
| 79 | +315 |
- #' if (interactive()) {
+ )) |
|
| 80 | +316 |
- #' shinyApp(app$ui, app$server)+ ) |
|
| 81 | +317 |
- #' }+ } |
|
| 82 | +318 |
- #'+ |
|
| 83 | -+ | ||
| 319 | +! |
- #' @export+ do.call( |
|
| 84 | -+ | ||
| 320 | +! |
- #'+ tabsetPanel, |
|
| 85 | -+ | ||
| 321 | +! |
- tm_variable_browser <- function(label = "Variable Browser",+ c( |
|
| 86 | -+ | ||
| 322 | +! |
- datasets_selected = character(0),+ id = ns("summary_type"),
|
|
| 87 | -+ | ||
| 323 | +! |
- parent_dataname = "ADSL",+ tab_list |
|
| 88 | +324 |
- pre_output = NULL,+ ) |
|
| 89 | +325 |
- post_output = NULL,+ ) |
|
| 90 | +326 |
- ggplot2_args = teal.widgets::ggplot2_args()) {
- |
- |
| 91 | -! | -
- message("Initializing tm_variable_browser")
+ } |
|
| 92 | +327 | ||
| 93 | +328 |
- # Requires Suggested packages+ # UI encoding for the missing data module (all datasets) |
|
| 94 | -! | +||
| 329 | +
- if (!requireNamespace("sparkline", quietly = TRUE)) {
+ encoding_missing_data <- function(id, summary_per_patient = FALSE, ggtheme, datanames) {
|
||
| 95 | +330 | ! |
- stop("Cannot load sparkline - please install the package or restart your session.")
+ ns <- NS(id) |
| 96 | +331 |
- }+ |
|
| 97 | +332 | ! |
- if (!requireNamespace("htmlwidgets", quietly = TRUE)) {
+ tagList(+ |
+
| 333 | ++ |
+ ### Reporter |
|
| 98 | +334 | ! |
- stop("Cannot load htmlwidgets - please install the package or restart your session.")
+ teal.reporter::simple_reporter_ui(ns("simple_reporter")),
|
| 99 | +335 |
- }+ ### |
|
| 100 | +336 | ! |
- if (!requireNamespace("jsonlite", quietly = TRUE)) {
+ tags$label("Encodings", class = "text-primary"),
|
| 101 | +337 | ! |
- stop("Cannot load jsonlite - please install the package or restart your session.")
+ helpText( |
| 102 | -+ | ||
| 338 | +! |
- }+ paste0("Dataset", `if`(length(datanames) > 1, "s", ""), ":"),
|
|
| 103 | -+ | ||
| 339 | +! |
-
+ tags$code(paste(datanames, collapse = ", ")) |
|
| 104 | +340 |
- # Start of assertions+ ), |
|
| 105 | +341 | ! |
- checkmate::assert_string(label)+ uiOutput(ns("variables")),
|
| 106 | +342 | ! |
- checkmate::assert_character(datasets_selected)+ actionButton( |
| 107 | +343 | ! |
- checkmate::assert_character(parent_dataname, min.len = 0, max.len = 1)+ ns("filter_na"),
|
| 108 | +344 | ! |
- checkmate::assert_multi_class(pre_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
+ tags$span("Select only vars with missings", class = "whitespace-normal"),
|
| 109 | +345 | ! |
- checkmate::assert_multi_class(post_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
+ width = "100%", |
| 110 | +346 | ! |
- checkmate::assert_class(ggplot2_args, "ggplot2_args")+ class = "mb-4" |
| 111 | +347 |
- # End of assertions+ ), |
|
| 112 | -+ | ||
| 348 | +! |
-
+ conditionalPanel( |
|
| 113 | +349 | ! |
- datasets_selected <- unique(datasets_selected)+ is_tab_active_js(ns("summary_type"), "Summary"),
|
| 114 | -+ | ||
| 350 | +! |
-
+ checkboxInput( |
|
| 115 | +351 | ! |
- ans <- module(+ ns("any_na"),
|
| 116 | +352 | ! |
- label,+ tags$div( |
| 117 | +353 | ! |
- server = srv_variable_browser,+ class = "teal-tooltip", |
| 118 | +354 | ! |
- ui = ui_variable_browser,+ tagList( |
| 119 | +355 | ! |
- datanames = "all",+ "Add **anyna** variable", |
| 120 | +356 | ! |
- server_args = list(+ icon("circle-info"),
|
| 121 | +357 | ! |
- datasets_selected = datasets_selected,+ tags$span( |
| 122 | +358 | ! |
- parent_dataname = parent_dataname,+ class = "tooltiptext", |
| 123 | +359 | ! |
- ggplot2_args = ggplot2_args+ "Describes the number of observations with at least one missing value in any variable." |
| 124 | +360 |
- ),+ ) |
|
| 125 | -! | +||
| 361 | +
- ui_args = list(+ ) |
||
| 126 | -! | +||
| 362 | +
- pre_output = pre_output,+ ), |
||
| 127 | +363 | ! |
- post_output = post_output+ value = FALSE |
| 128 | +364 |
- )+ ), |
|
| 129 | -+ | ||
| 365 | +! |
- )+ if (summary_per_patient) {
|
|
| 130 | -+ | ||
| 366 | +! |
- # `shiny` inputs are stored properly but the majority of the module is state of `datatable` which is not stored.+ checkboxInput( |
|
| 131 | +367 | ! |
- attr(ans, "teal_bookmarkable") <- NULL+ ns("if_patients_plot"),
|
| 132 | +368 | ! |
- ans+ tags$div( |
| 133 | -+ | ||
| 369 | +! |
- }+ class = "teal-tooltip", |
|
| 134 | -+ | ||
| 370 | +! |
-
+ tagList( |
|
| 135 | -+ | ||
| 371 | +! |
- # UI function for the variable browser module+ "Add summary per patients", |
|
| 136 | -+ | ||
| 372 | +! |
- ui_variable_browser <- function(id,+ icon("circle-info"),
|
|
| 137 | -+ | ||
| 373 | +! |
- pre_output = NULL,+ tags$span( |
|
| 138 | -+ | ||
| 374 | +! |
- post_output = NULL) {
+ class = "tooltiptext", |
|
| 139 | +375 | ! |
- ns <- NS(id)- |
-
| 140 | -- | - - | -|
| 141 | -! | -
- tagList(- |
- |
| 142 | -! | -
- include_css_files("custom"),
- |
- |
| 143 | -! | -
- shinyjs::useShinyjs(),- |
- |
| 144 | -! | -
- teal.widgets::standard_layout(- |
- |
| 145 | -! | -
- output = fluidRow(- |
- |
| 146 | -! | -
- htmlwidgets::getDependency("sparkline"), # needed for sparklines to work
+ paste( |
|
| 147 | +376 | ! |
- column(+ "Displays the number of missing values per observation,", |
| 148 | +377 | ! |
- 6,+ "where the x-axis is sorted by observation appearance in the table." |
| 149 | +378 |
- # variable browser- |
- |
| 150 | -! | -
- teal.widgets::white_small_well(- |
- |
| 151 | -! | -
- uiOutput(ns("ui_variable_browser")),
- |
- |
| 152 | -! | -
- shinyjs::hidden({
- |
- |
| 153 | -! | -
- checkboxInput(ns("show_parent_vars"), "Show parent dataset variables", value = FALSE)
+ ) |
|
| 154 | +379 |
- })+ ) |
|
| 155 | +380 |
- )+ ) |
|
| 156 | +381 |
- ),- |
- |
| 157 | -! | -
- column(- |
- |
| 158 | -! | -
- 6,+ ), |
|
| 159 | +382 | ! |
- teal.widgets::white_small_well(+ value = FALSE |
| 160 | +383 |
- ### Reporter+ ) |
|
| 161 | -! | +||
| 384 | +
- teal.reporter::simple_reporter_ui(ns("simple_reporter")),
+ } |
||
| 162 | +385 |
- ###+ ), |
|
| 163 | +386 | ! |
- tags$div(+ conditionalPanel( |
| 164 | +387 | ! |
- class = "block",+ is_tab_active_js(ns("summary_type"), "Combinations"),
|
| 165 | +388 | ! |
- uiOutput(ns("ui_histogram_display"))
+ uiOutput(ns("cutoff"))
|
| 166 | +389 |
- ),- |
- |
| 167 | -! | -
- tags$div(+ ), |
|
| 168 | +390 | ! |
- class = "block",+ conditionalPanel( |
| 169 | +391 | ! |
- uiOutput(ns("ui_numeric_display"))
- |
-
| 170 | -- |
- ),+ is_tab_active_js(ns("summary_type"), "By Variable Levels"),
|
|
| 171 | +392 | ! |
- teal.widgets::plot_with_settings_ui(ns("variable_plot")),
+ tagList( |
| 172 | +393 | ! |
- tags$br(),- |
-
| 173 | -- |
- # input user-defined text size+ uiOutput(ns("group_by_var_ui")),
|
|
| 174 | +394 | ! |
- teal.widgets::panel_item(+ uiOutput(ns("group_by_vals_ui")),
|
| 175 | +395 | ! |
- title = "Plot settings",+ radioButtons( |
| 176 | +396 | ! |
- collapsed = TRUE,+ ns("count_type"),
|
| 177 | +397 | ! |
- selectInput(+ label = "Display missing as", |
| 178 | +398 | ! |
- inputId = ns("ggplot_theme"), label = "ggplot2 theme",
+ choices = c("counts", "proportions"),
|
| 179 | +399 | ! |
- choices = ggplot_themes,+ selected = "counts", |
| 180 | +400 | ! |
- selected = "grey"+ inline = TRUE |
| 181 | +401 |
- ),+ ) |
|
| 182 | -! | +||
| 402 | +
- fluidRow(+ ) |
||
| 183 | -! | +||
| 403 | +
- column(6, sliderInput(+ ), |
||
| 184 | +404 | ! |
- inputId = ns("font_size"), label = "font size",
+ teal.widgets::panel_item( |
| 185 | +405 | ! |
- min = 5L, max = 30L, value = 15L, step = 1L, ticks = FALSE- |
-
| 186 | -- |
- )),+ title = "Plot settings", |
|
| 187 | +406 | ! |
- column(6, sliderInput(+ selectInput( |
| 188 | +407 | ! |
- inputId = ns("label_rotation"), label = "rotate x labels",
+ inputId = ns("ggtheme"),
|
| 189 | +408 | ! |
- min = 0L, max = 90L, value = 45L, step = 1, ticks = FALSE- |
-
| 190 | -- |
- ))- |
- |
| 191 | -- |
- )- |
- |
| 192 | -- |
- ),+ label = "Theme (by ggplot):", |
|
| 193 | +409 | ! |
- tags$br(),+ choices = ggplot_themes, |
| 194 | +410 | ! |
- teal.widgets::get_dt_rows(ns("variable_summary_table"), ns("variable_summary_table_rows")),
+ selected = ggtheme, |
| 195 | +411 | ! |
- DT::dataTableOutput(ns("variable_summary_table"))
- |
-
| 196 | -- |
- )- |
- |
| 197 | -- |
- )+ multiple = FALSE |
|
| 198 | +412 |
- ),- |
- |
| 199 | -! | -
- pre_output = pre_output,- |
- |
| 200 | -! | -
- post_output = post_output+ ) |
|
| 201 | +413 |
) |
|
| 202 | +414 |
) |
|
| 203 | +415 |
} |
|
| 204 | +416 | ||
| 205 | -- |
- # Server function for the variable browser module- |
- |
| 206 | -- |
- srv_variable_browser <- function(id,- |
- |
| 207 | -- |
- data,- |
- |
| 208 | +417 |
- reporter,+ # Server function for the missing data (single dataset) |
|
| 209 | +418 |
- filter_panel_api,+ srv_missing_data <- function(id, data, reporter, filter_panel_api, dataname, parent_dataname, |
|
| 210 | +419 |
- datasets_selected, parent_dataname, ggplot2_args) {
+ plot_height, plot_width, ggplot2_args) {
|
|
| 211 | +420 | ! |
with_reporter <- !missing(reporter) && inherits(reporter, "Reporter") |
| 212 | +421 | ! |
with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI") |
| 213 | +422 | ! |
checkmate::assert_class(data, "reactive") |
| 214 | +423 | ! |
checkmate::assert_class(isolate(data()), "teal_data") |
| 215 | +424 | ! |
moduleServer(id, function(input, output, session) {
|
| 216 | +425 | ! |
- teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.general")+ ns <- session$ns |
| 217 | +426 | ||
| 218 | -- |
- # if there are < this number of unique records then a numeric- |
- |
| 219 | -+ | ||
| 427 | +! |
- # variable can be treated as a factor and all factors with < this groups+ prev_group_by_var <- reactiveVal("")
|
|
| 220 | -+ | ||
| 428 | +! |
- # have their values plotted+ data_r <- reactive(data()[[dataname]]) |
|
| 221 | +429 | ! |
- .unique_records_for_factor <- 30+ data_keys <- reactive(unlist(teal.data::join_keys(data())[[dataname]])) |
| 222 | +430 |
- # if there are < this number of unique records then a numeric+ |
|
| 223 | -+ | ||
| 431 | +! |
- # variable is by default treated as a factor+ iv_r <- reactive({
|
|
| 224 | +432 | ! |
- .unique_records_default_as_factor <- 6 # nolint: object_length.+ iv <- shinyvalidate::InputValidator$new() |
| 225 | -+ | ||
| 433 | +! |
-
+ iv$add_rule( |
|
| 226 | +434 | ! |
- varname_numeric_as_factor <- reactiveValues()+ "variables_select", |
| 227 | -+ | ||
| 435 | +! |
-
+ shinyvalidate::sv_required("At least one reference variable needs to be selected.")
|
|
| 228 | -! | +||
| 436 | +
- datanames <- isolate(teal.data::datanames(data()))+ ) |
||
| 229 | +437 | ! |
- datanames <- Filter(function(name) {
+ iv$add_rule( |
| 230 | +438 | ! |
- is.data.frame(isolate(data())[[name]])+ "variables_select", |
| 231 | +439 | ! |
- }, datanames)+ ~ if (length(setdiff((.), data_keys())) < 1) "Please also select non-key columns." |
| 232 | +440 |
-
+ ) |
|
| 233 | +441 | ! |
- checkmate::assert_character(datasets_selected)+ iv_summary_table <- shinyvalidate::InputValidator$new() |
| 234 | +442 | ! |
- checkmate::assert_subset(datasets_selected, datanames)+ iv_summary_table$condition(~ isTRUE(input$summary_type == "By Variable Levels")) |
| 235 | +443 | ! |
- if (!identical(datasets_selected, character(0))) {
+ iv_summary_table$add_rule("count_type", shinyvalidate::sv_required("Please select type of counts"))
|
| 236 | +444 | ! |
- checkmate::assert_subset(datasets_selected, datanames)+ iv_summary_table$add_rule( |
| 237 | +445 | ! |
- datanames <- datasets_selected+ "group_by_vals", |
| 238 | -+ | ||
| 446 | +! |
- }+ shinyvalidate::sv_required("Please select both group-by variable and values")
|
|
| 239 | +447 |
-
+ ) |
|
| 240 | +448 | ! |
- output$ui_variable_browser <- renderUI({
+ iv_summary_table$add_rule( |
| 241 | +449 | ! |
- ns <- session$ns+ "group_by_var", |
| 242 | +450 | ! |
- do.call(+ ~ if (length(.) > 0 && length(input$variables_select) == 1 && (.) == input$variables_select) {
|
| 243 | +451 | ! |
- tabsetPanel,+ "If only one reference variable is selected it must not be the grouping variable." |
| 244 | -! | +||
| 452 | +
- c(+ } |
||
| 245 | -! | +||
| 453 | +
- id = ns("tabset_panel"),
+ ) |
||
| 246 | +454 | ! |
- do.call(+ iv_summary_table$add_rule( |
| 247 | +455 | ! |
- tagList,+ "variables_select", |
| 248 | +456 | ! |
- lapply(datanames, function(dataname) {
+ ~ if (length(input$group_by_var) > 0 && length(.) == 1 && (.) == input$group_by_var) {
|
| 249 | +457 | ! |
- tabPanel(+ "If only one reference variable is selected it must not be the grouping variable." |
| 250 | -! | +||
| 458 | +
- dataname,+ }+ |
+ ||
| 459 | ++ |
+ ) |
|
| 251 | +460 | ! |
- tags$div(+ iv$add_validator(iv_summary_table) |
| 252 | +461 | ! |
- class = "mt-4",+ iv$enable() |
| 253 | +462 | ! |
- textOutput(ns(paste0("dataset_summary_", dataname)))
+ iv |
| 254 | +463 |
- ),+ }) |
|
| 255 | -! | +||
| 464 | +
- tags$div(+ |
||
| 256 | -! | +||
| 465 | +
- class = "mt-4",+ |
||
| 257 | +466 | ! |
- teal.widgets::get_dt_rows(+ data_parent_keys <- reactive({
|
| 258 | +467 | ! |
- ns(paste0("variable_browser_", dataname)),
+ if (length(parent_dataname) > 0 && parent_dataname %in% names(data())) {
|
| 259 | +468 | ! |
- ns(paste0("variable_browser_", dataname, "_rows"))
+ keys <- teal.data::join_keys(data())[[dataname]] |
| 260 | -+ | ||
| 469 | +! |
- ),+ if (parent_dataname %in% names(keys)) {
|
|
| 261 | +470 | ! |
- DT::dataTableOutput(ns(paste0("variable_browser_", dataname)), width = "100%")
+ keys[[parent_dataname]] |
| 262 | +471 |
- )+ } else {
|
|
| 263 | -+ | ||
| 472 | +! |
- )+ keys[[dataname]] |
|
| 264 | +473 |
- })+ } |
|
| 265 | +474 |
- )+ } else {
|
|
| 266 | -+ | ||
| 475 | +! |
- )+ NULL |
|
| 267 | +476 |
- )+ } |
|
| 268 | +477 |
}) |
|
| 269 | +478 | ||
| 270 | -- |
- # conditionally display checkbox- |
- |
| 271 | -! | -
- shinyjs::toggle(- |
- |
| 272 | +479 | ! |
- id = "show_parent_vars",+ common_code_q <- reactive({
|
| 273 | +480 | ! |
- condition = length(parent_dataname) > 0 && parent_dataname %in% datanames+ teal::validate_inputs(iv_r()) |
| 274 | +481 |
- )+ |
|
| 275 | -+ | ||
| 482 | +! |
-
+ group_var <- input$group_by_var |
|
| 276 | +483 | ! |
- columns_names <- new.env()+ anl <- data_r() |
| 277 | +484 | ||
| 278 | -+ | ||
| 485 | +! |
- # plot_var$data holds the name of the currently selected dataset+ qenv <- if (!is.null(selected_vars()) && length(selected_vars()) != ncol(anl)) {
|
|
| 279 | -+ | ||
| 486 | +! |
- # plot_var$variable[[<dataset_name>]] holds the name of the currently selected+ teal.code::eval_code( |
|
| 280 | -+ | ||
| 487 | +! |
- # variable for dataset <dataset_name>+ data(), |
|
| 281 | +488 | ! |
- plot_var <- reactiveValues(data = NULL, variable = list())+ substitute( |
| 282 | -+ | ||
| 489 | +! |
-
+ expr = ANL <- anl_name[, selected_vars, drop = FALSE], |
|
| 283 | +490 | ! |
- establish_updating_selection(datanames, input, plot_var, columns_names)+ env = list(anl_name = as.name(dataname), selected_vars = selected_vars()) |
| 284 | +491 |
-
+ ) |
|
| 285 | +492 |
- # validations- |
- |
| 286 | -! | -
- validation_checks <- validate_input(input, plot_var, data)+ ) |
|
| 287 | +493 |
-
+ } else {
|
|
| 288 | -+ | ||
| 494 | +! |
- # data_for_analysis is a list with two elements: a column from a dataset and the column label+ teal.code::eval_code( |
|
| 289 | +495 | ! |
- plotted_data <- reactive({
+ data(), |
| 290 | +496 | ! |
- validation_checks()+ substitute(expr = ANL <- anl_name, env = list(anl_name = as.name(dataname))) |
| 291 | +497 | ++ |
+ )+ |
+
| 498 | ++ |
+ }+ |
+ |
| 499 | |||
| 292 | +500 | ! |
- get_plotted_data(input, plot_var, data)+ if (input$summary_type == "By Variable Levels" && !is.null(group_var) && !(group_var %in% selected_vars())) {
|
| 293 | -+ | ||
| 501 | +! |
- })+ qenv <- teal.code::eval_code( |
|
| 294 | -+ | ||
| 502 | +! |
-
+ qenv, |
|
| 295 | +503 | ! |
- treat_numeric_as_factor <- reactive({
+ substitute( |
| 296 | +504 | ! |
- if (is_num_var_short(.unique_records_for_factor, input, plotted_data)) {
+ expr = ANL[[group_var]] <- anl_name[[group_var]], |
| 297 | +505 | ! |
- input$numeric_as_factor+ env = list(group_var = group_var, anl_name = as.name(dataname)) |
| 298 | +506 |
- } else {
+ ) |
|
| 299 | -! | +||
| 507 | +
- FALSE+ ) |
||
| 300 | +508 |
} |
|
| 301 | +509 |
- })+ + |
+ |
| 510 | +! | +
+ new_col_name <- "**anyna**" |
|
| 302 | +511 | ||
| 303 | +512 | ! |
- render_tabset_panel_content(+ qenv <- teal.code::eval_code( |
| 304 | +513 | ! |
- input = input,+ qenv, |
| 305 | +514 | ! |
- output = output,+ substitute( |
| 306 | +515 | ! |
- data = data,+ expr = |
| 307 | +516 | ! |
- datanames = datanames,+ create_cols_labels <- function(cols, just_label = FALSE) {
|
| 308 | +517 | ! |
- parent_dataname = parent_dataname,+ column_labels <- column_labels_value |
| 309 | +518 | ! |
- columns_names = columns_names,+ column_labels[is.na(column_labels) | length(column_labels) == 0] <- "" |
| 310 | +519 | ! |
- plot_var = plot_var+ if (just_label) {
+ |
+
| 520 | +! | +
+ labels <- column_labels[cols] |
|
| 311 | +521 |
- )+ } else {
+ |
+ |
| 522 | +! | +
+ labels <- ifelse(cols == new_col_name | cols == "", cols, paste0(column_labels[cols], " [", cols, "]")) |
|
| 312 | +523 |
- # add used-defined text size to ggplot arguments passed from caller frame+ } |
|
| 313 | +524 | ! |
- all_ggplot2_args <- reactive({
+ labels+ |
+
| 525 | ++ |
+ }, |
|
| 314 | +526 | ! |
- user_text <- teal.widgets::ggplot2_args(+ env = list( |
| 315 | +527 | ! |
- theme = list(+ new_col_name = new_col_name, |
| 316 | +528 | ! |
- "text" = ggplot2::element_text(size = input[["font_size"]]),+ column_labels_value = c(teal.data::col_labels(data_r())[selected_vars()], |
| 317 | +529 | ! |
- "axis.text.x" = ggplot2::element_text(angle = input[["label_rotation"]], hjust = 1)+ new_col_name = new_col_name |
| 318 | +530 |
- )+ ) |
|
| 319 | +531 |
- )- |
- |
| 320 | -! | -
- user_theme <- utils::getFromNamespace(sprintf("theme_%s", input[["ggplot_theme"]]), ns = "ggplot2")
- |
- |
| 321 | -! | -
- user_theme <- user_theme()+ ) |
|
| 322 | +532 |
- # temporary fix to circumvent assertion issue with resolve_ggplot2_args+ ) |
|
| 323 | +533 |
- # drop problematic elements+ ) |
|
| 324 | +534 | ! |
- user_theme <- user_theme[grep("strip.text.y.left", names(user_theme), fixed = TRUE, invert = TRUE)]
+ qenv |
| 325 | +535 | ++ |
+ })+ |
+
| 536 | |||
| 326 | +537 | ! |
- teal.widgets::resolve_ggplot2_args(+ selected_vars <- reactive({
|
| 327 | +538 | ! |
- user_plot = user_text,+ req(input$variables_select) |
| 328 | +539 | ! |
- user_default = teal.widgets::ggplot2_args(theme = user_theme),+ keys <- data_keys() |
| 329 | +540 | ! |
- module_plot = ggplot2_args+ vars <- unique(c(keys, input$variables_select)) |
| 330 | -+ | ||
| 541 | +! |
- )+ vars |
|
| 331 | +542 |
}) |
|
| 332 | +543 | ||
| 333 | -! | -
- output$ui_numeric_display <- renderUI({
- |
- |
| 334 | +544 | ! |
- validation_checks()+ vars_summary <- reactive({
|
| 335 | +545 | ! |
- dataname <- input$tabset_panel+ na_count <- data_r() %>% |
| 336 | +546 | ! |
- varname <- plot_var$variable[[dataname]]+ sapply(function(x) mean(is.na(x)), USE.NAMES = TRUE) %>% |
| 337 | +547 | ! |
- df <- data()[[dataname]]+ sort(decreasing = TRUE) |
| 338 | +548 | ||
| 339 | +549 | ! |
- numeric_ui <- tagList(+ tibble::tibble( |
| 340 | +550 | ! |
- fluidRow(+ key = names(na_count), |
| 341 | +551 | ! |
- tags$div(+ value = unname(na_count), |
| 342 | +552 | ! |
- class = "col-md-4",+ label = cut(na_count, breaks = seq(from = 0, to = 1, by = 0.1), include.lowest = TRUE) |
| 343 | -! | +||
| 553 | +
- tags$br(),+ ) |
||
| 344 | -! | +||
| 554 | +
- shinyWidgets::switchInput(+ }) |
||
| 345 | -! | +||
| 555 | +
- inputId = session$ns("display_density"),
+
|
||
| 346 | +556 | ! |
- label = "Show density",+ output$variables <- renderUI({
|
| 347 | +557 | ! |
- value = `if`(is.null(isolate(input$display_density)), TRUE, isolate(input$display_density)),+ choices <- split(x = vars_summary()$key, f = vars_summary()$label, drop = TRUE) %>% rev() |
| 348 | +558 | ! |
- width = "50%",+ selected <- choices <- unname(unlist(choices)) |
| 349 | -! | +||
| 559 | +
- labelWidth = "100px",+ |
||
| 350 | +560 | ! |
- handleWidth = "50px"+ teal.widgets::optionalSelectInput( |
| 351 | -+ | ||
| 561 | +! |
- )+ ns("variables_select"),
|
|
| 352 | -+ | ||
| 562 | +! |
- ),+ label = "Select variables", |
|
| 353 | +563 | ! |
- tags$div(+ label_help = HTML(paste0("Dataset: ", tags$code(dataname))),
|
| 354 | +564 | ! |
- class = "col-md-4",+ choices = teal.transform::variable_choices(data_r(), choices), |
| 355 | +565 | ! |
- tags$br(),+ selected = selected, |
| 356 | +566 | ! |
- shinyWidgets::switchInput(+ multiple = TRUE |
| 357 | -! | +||
| 567 | +
- inputId = session$ns("remove_outliers"),
+ ) |
||
| 358 | -! | +||
| 568 | +
- label = "Remove outliers",+ })+ |
+ ||
| 569 | ++ | + | |
| 359 | +570 | ! |
- value = `if`(is.null(isolate(input$remove_outliers)), FALSE, isolate(input$remove_outliers)),+ observeEvent(input$filter_na, {
|
| 360 | +571 | ! |
- width = "50%",+ choices <- vars_summary() %>% |
| 361 | +572 | ! |
- labelWidth = "100px",+ dplyr::select(!!as.name("key")) %>%
|
| 362 | +573 | ! |
- handleWidth = "50px"+ getElement(name = 1) |
| 363 | +574 |
- )+ |
|
| 364 | -+ | ||
| 575 | +! |
- ),+ selected <- vars_summary() %>% |
|
| 365 | +576 | ! |
- tags$div(+ dplyr::filter(!!as.name("value") > 0) %>%
|
| 366 | +577 | ! |
- class = "col-md-4",+ dplyr::select(!!as.name("key")) %>%
|
| 367 | +578 | ! |
- uiOutput(session$ns("outlier_definition_slider_ui"))
+ getElement(name = 1) |
| 368 | +579 |
- )+ |
|
| 369 | -+ | ||
| 580 | +! |
- ),+ teal.widgets::updateOptionalSelectInput( |
|
| 370 | +581 | ! |
- tags$div(+ session = session, |
| 371 | +582 | ! |
- class = "ml-4",+ inputId = "variables_select", |
| 372 | +583 | ! |
- uiOutput(session$ns("ui_density_help")),
+ choices = teal.transform::variable_choices(data_r()), |
| 373 | +584 | ! |
- uiOutput(session$ns("ui_outlier_help"))
+ selected = restoreInput(ns("variables_select"), selected)
|
| 374 | +585 |
- )+ ) |
|
| 375 | +586 |
- )+ }) |
|
| 376 | +587 | ||
| 377 | +588 | ! |
- observeEvent(input$numeric_as_factor, ignoreInit = TRUE, {
+ output$group_by_var_ui <- renderUI({
|
| 378 | +589 | ! |
- varname_numeric_as_factor[[plot_var$variable[[dataname]]]] <- input$numeric_as_factor+ all_choices <- teal.transform::variable_choices(data_r()) |
| 379 | -+ | ||
| 590 | +! |
- })+ cat_choices <- all_choices[!sapply(data_r(), function(x) is.numeric(x) || inherits(x, "POSIXct"))] |
|
| 380 | -+ | ||
| 591 | +! |
-
+ validate( |
|
| 381 | +592 | ! |
- if (is.numeric(df[[varname]])) {
+ need(cat_choices, "Dataset does not have any non-numeric or non-datetime variables to use to group data with")+ |
+
| 593 | ++ |
+ ) |
|
| 382 | +594 | ! |
- unique_entries <- length(unique(df[[varname]]))+ teal.widgets::optionalSelectInput( |
| 383 | +595 | ! |
- if (unique_entries < .unique_records_for_factor && unique_entries > 0) {
+ ns("group_by_var"),
|
| 384 | +596 | ! |
- list(+ label = "Group by variable", |
| 385 | +597 | ! |
- checkboxInput(+ choices = cat_choices, |
| 386 | +598 | ! |
- session$ns("numeric_as_factor"),
+ selected = `if`( |
| 387 | +599 | ! |
- "Treat variable as factor",+ is.null(isolate(input$group_by_var)), |
| 388 | +600 | ! |
- value = `if`(+ cat_choices[1], |
| 389 | +601 | ! |
- is.null(varname_numeric_as_factor[[varname]]),+ isolate(input$group_by_var)+ |
+
| 602 | ++ |
+ ), |
|
| 390 | +603 | ! |
- unique_entries < .unique_records_default_as_factor,+ multiple = FALSE, |
| 391 | +604 | ! |
- varname_numeric_as_factor[[varname]]+ label_help = paste0("Dataset: ", dataname)
|
| 392 | +605 |
- )+ ) |
|
| 393 | +606 |
- ),- |
- |
| 394 | -! | -
- conditionalPanel("!input.numeric_as_factor", ns = session$ns, numeric_ui)
+ }) |
|
| 395 | +607 |
- )+ |
|
| 396 | +608 | ! |
- } else if (unique_entries > 0) {
+ output$group_by_vals_ui <- renderUI({
|
| 397 | +609 | ! |
- numeric_ui+ req(input$group_by_var) |
| 398 | +610 |
- }+ |
|
| 399 | -+ | ||
| 611 | +! |
- } else {
+ choices <- teal.transform::value_choices(data_r(), input$group_by_var, input$group_by_var) |
|
| 400 | +612 | ! |
- NULL+ prev_choices <- isolate(input$group_by_vals) |
| 401 | +613 |
- }+ |
|
| 402 | +614 |
- })+ # determine selected value based on filtered data |
|
| 403 | +615 |
-
+ # display those previously selected values that are still available |
|
| 404 | +616 | ! |
- output$ui_histogram_display <- renderUI({
+ selected <- if (!is.null(prev_choices) && any(prev_choices %in% choices)) {
|
| 405 | +617 | ! |
- validation_checks()+ prev_choices[match(choices[choices %in% prev_choices], prev_choices)] |
| 406 | +618 | ! |
- dataname <- input$tabset_panel+ } else if ( |
| 407 | +619 | ! |
- varname <- plot_var$variable[[dataname]]+ !is.null(prev_choices) && |
| 408 | +620 | ! |
- df <- data()[[dataname]]- |
-
| 409 | -- |
-
+ !any(prev_choices %in% choices) && |
|
| 410 | +621 | ! |
- numeric_ui <- tagList(fluidRow(+ isolate(prev_group_by_var()) == input$group_by_var |
| 411 | -! | +||
| 622 | +
- tags$div(+ ) {
|
||
| 412 | -! | +||
| 623 | +
- class = "col-md-4",+ # if not any previously selected value is available and the grouping variable is the same, |
||
| 413 | -! | +||
| 624 | +
- shinyWidgets::switchInput(+ # then display NULL |
||
| 414 | +625 | ! |
- inputId = session$ns("remove_NA_hist"),
+ NULL |
| 415 | -! | +||
| 626 | +
- label = "Remove NA values",+ } else {
|
||
| 416 | -! | +||
| 627 | +
- value = FALSE,+ # if new grouping variable (i.e. not any previously selected value is available), |
||
| 417 | -! | +||
| 628 | +
- width = "50%",+ # then display all choices |
||
| 418 | +629 | ! |
- labelWidth = "100px",+ choices |
| 419 | -! | +||
| 630 | +
- handleWidth = "50px"+ } |
||
| 420 | +631 |
- )+ |
|
| 421 | -+ | ||
| 632 | +! |
- )+ prev_group_by_var(input$group_by_var) # set current group_by_var |
|
| 422 | -+ | ||
| 633 | +! |
- ))+ validate(need(length(choices) < 100, "Please select group-by variable with fewer than 100 unique values")) |
|
| 423 | +634 | ||
| 424 | +635 | ! |
- var <- df[[varname]]+ teal.widgets::optionalSelectInput( |
| 425 | +636 | ! |
- if (anyNA(var) && (is.factor(var) || is.character(var) || is.logical(var))) {
+ ns("group_by_vals"),
|
| 426 | +637 | ! |
- groups <- unique(as.character(var))+ label = "Filter levels", |
| 427 | +638 | ! |
- len_groups <- length(groups)+ choices = choices, |
| 428 | +639 | ! |
- if (len_groups >= .unique_records_for_factor) {
+ selected = selected, |
| 429 | +640 | ! |
- NULL+ multiple = TRUE, |
| 430 | -+ | ||
| 641 | +! |
- } else {
+ label_help = paste0("Dataset: ", dataname)
|
|
| 431 | -! | +||
| 642 | +
- numeric_ui+ ) |
||
| 432 | +643 |
- }+ }) |
|
| 433 | +644 |
- } else {
+
|
|
| 434 | +645 | ! |
- NULL+ summary_plot_q <- reactive({
|
| 435 | -+ | ||
| 646 | +! |
- }+ req(input$summary_type == "Summary") # needed to trigger show r code update on tab change |
|
| 436 | -+ | ||
| 647 | +! |
- })+ teal::validate_has_data(data_r(), 1) |
|
| 437 | +648 | ||
| 438 | -! | -
- output$outlier_definition_slider_ui <- renderUI({
- |
- |
| 439 | -! | -
- req(input$remove_outliers)- |
- |
| 440 | -! | -
- sliderInput(- |
- |
| 441 | -! | -
- inputId = session$ns("outlier_definition_slider"),
- |
- |
| 442 | +649 | ! |
- tags$div(+ qenv <- common_code_q() |
| 443 | -! | +||
| 650 | +
- class = "teal-tooltip",+ |
||
| 444 | +651 | ! |
- tagList(+ if (input$any_na) {
|
| 445 | +652 | ! |
- "Outlier definition:",+ new_col_name <- "**anyna**" |
| 446 | +653 | ! |
- icon("circle-info"),
+ qenv <- teal.code::eval_code( |
| 447 | +654 | ! |
- tags$span(+ qenv, |
| 448 | +655 | ! |
- class = "tooltiptext",+ substitute( |
| 449 | +656 | ! |
- paste(+ expr = ANL[[new_col_name]] <- ifelse(rowSums(is.na(ANL)) > 0, NA, FALSE), |
| 450 | +657 | ! |
- "Use the slider to choose the cut-off value to define outliers; the larger the value the",+ env = list(new_col_name = new_col_name) |
| 451 | -! | +||
| 658 | +
- "further below Q1/above Q3 points have to be in order to be classed as outliers"+ ) |
||
| 452 | +659 |
- )+ ) |
|
| 453 | +660 |
- )+ } |
|
| 454 | +661 |
- )+ |
|
| 455 | -+ | ||
| 662 | +! |
- ),+ qenv <- teal.code::eval_code( |
|
| 456 | +663 | ! |
- min = 1,+ qenv, |
| 457 | +664 | ! |
- max = 5,+ substitute( |
| 458 | +665 | ! |
- value = 3,+ expr = analysis_vars <- setdiff(colnames(ANL), data_keys), |
| 459 | +666 | ! |
- step = 0.5+ env = list(data_keys = data_keys()) |
| 460 | +667 |
- )+ ) |
|
| 461 | +668 |
- })+ ) %>% |
|
| 462 | -+ | ||
| 669 | +! |
-
+ teal.code::eval_code( |
|
| 463 | +670 | ! |
- output$ui_density_help <- renderUI({
+ substitute( |
| 464 | +671 | ! |
- req(is.logical(input$display_density))+ expr = summary_plot_obs <- data_frame_call[, analysis_vars] %>% |
| 465 | +672 | ! |
- if (input$display_density) {
+ dplyr::summarise_all(list(function(x) sum(is.na(x)))) %>% |
| 466 | +673 | ! |
- tags$small(helpText(paste(+ tidyr::pivot_longer(dplyr::everything(), names_to = "col", values_to = "n_na") %>% |
| 467 | +674 | ! |
- "Kernel density estimation with gaussian kernel",+ dplyr::mutate(n_not_na = nrow(ANL) - n_na) %>% |
| 468 | +675 | ! |
- "and bandwidth function bw.nrd0 (R default)"+ tidyr::pivot_longer(-col, names_to = "isna", values_to = "n") %>% |
| 469 | -+ | ||
| 676 | +! |
- )))+ dplyr::mutate(isna = isna == "n_na", n_pct = n / nrow(ANL) * 100), |
|
| 470 | -+ | ||
| 677 | +! |
- } else {
+ env = list(data_frame_call = if (!inherits(data_r(), "tbl_df")) {
|
|
| 471 | +678 | ! |
- NULL+ quote(tibble::as_tibble(ANL)) |
| 472 | +679 |
- }+ } else {
|
|
| 473 | -+ | ||
| 680 | +! |
- })+ quote(ANL) |
|
| 474 | +681 |
-
+ }) |
|
| 475 | -! | +||
| 682 | +
- output$ui_outlier_help <- renderUI({
+ ) |
||
| 476 | -! | +||
| 683 | +
- req(is.logical(input$remove_outliers), input$outlier_definition_slider)+ ) %>% |
||
| 477 | -! | +||
| 684 | +
- if (input$remove_outliers) {
+ # x axis ordering according to number of missing values and alphabet |
||
| 478 | +685 | ! |
- tags$small(+ teal.code::eval_code( |
| 479 | +686 | ! |
- helpText(+ quote( |
| 480 | +687 | ! |
- withMathJax(paste0(+ expr = x_levels <- dplyr::filter(summary_plot_obs, isna) %>% |
| 481 | +688 | ! |
- "Outlier data points (\\( X \\lt Q1 - ", input$outlier_definition_slider, "\\times IQR \\) or+ dplyr::arrange(n_pct, dplyr::desc(col)) %>% |
| 482 | +689 | ! |
- \\(Q3 + ", input$outlier_definition_slider, "\\times IQR \\lt X\\))+ dplyr::pull(col) %>% |
| 483 | +690 | ! |
- have not been displayed on the graph and will not be used for any kernel density estimations, ",+ create_cols_labels() |
| 484 | -! | +||
| 691 | +
- "although their values remain in the statisics table below."+ ) |
||
| 485 | +692 |
- ))+ ) |
|
| 486 | +693 |
- )+ |
|
| 487 | +694 |
- )+ # always set "**anyna**" level as the last one |
|
| 488 | -+ | ||
| 695 | +! |
- } else {
+ if (isolate(input$any_na)) {
|
|
| 489 | +696 | ! |
- NULL+ qenv <- teal.code::eval_code( |
| 490 | -+ | ||
| 697 | +! |
- }+ qenv,+ |
+ |
| 698 | +! | +
+ quote(x_levels <- c(setdiff(x_levels, "**anyna**"), "**anyna**")) |
|
| 491 | +699 |
- })+ ) |
|
| 492 | +700 |
-
+ } |
|
| 493 | +701 | ||
| 494 | +702 | ! |
- variable_plot_r <- reactive({
+ dev_ggplot2_args <- teal.widgets::ggplot2_args( |
| 495 | +703 | ! |
- display_density <- `if`(is.null(input$display_density), FALSE, input$display_density)+ labs = list(x = "Variable", y = "Missing observations"), |
| 496 | +704 | ! |
- remove_outliers <- `if`(is.null(input$remove_outliers), FALSE, input$remove_outliers)+ theme = list(legend.position = "bottom", axis.text.x = quote(element_text(angle = 45, hjust = 1))) |
| 497 | +705 |
-
+ ) |
|
| 498 | -! | +||
| 706 | +
- if (remove_outliers) {
+
|
||
| 499 | +707 | ! |
- req(input$outlier_definition_slider)+ all_ggplot2_args <- teal.widgets::resolve_ggplot2_args( |
| 500 | +708 | ! |
- outlier_definition <- as.numeric(input$outlier_definition_slider)+ user_plot = ggplot2_args[["Summary Obs"]], |
| 501 | -+ | ||
| 709 | +! |
- } else {
+ user_default = ggplot2_args$default, |
|
| 502 | +710 | ! |
- outlier_definition <- 0+ module_plot = dev_ggplot2_args |
| 503 | +711 |
- }+ ) |
|
| 504 | +712 | ||
| 505 | +713 | ! |
- plot_var_summary(+ parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args( |
| 506 | +714 | ! |
- var = plotted_data()$data,+ all_ggplot2_args, |
| 507 | +715 | ! |
- var_lab = plotted_data()$var_description,+ ggtheme = input$ggtheme+ |
+
| 716 | ++ |
+ )+ |
+ |
| 717 | ++ | + | |
| 508 | +718 | ! |
- wrap_character = 15,+ qenv <- teal.code::eval_code( |
| 509 | +719 | ! |
- numeric_as_factor = treat_numeric_as_factor(),+ qenv, |
| 510 | +720 | ! |
- remove_NA_hist = input$remove_NA_hist,+ substitute( |
| 511 | +721 | ! |
- display_density = display_density,+ p1 <- summary_plot_obs %>% |
| 512 | +722 | ! |
- outlier_definition = outlier_definition,+ ggplot() + |
| 513 | +723 | ! |
- records_for_factor = .unique_records_for_factor,+ aes( |
| 514 | +724 | ! |
- ggplot2_args = all_ggplot2_args()+ x = factor(create_cols_labels(col), levels = x_levels), |
| 515 | -+ | ||
| 725 | +! |
- )+ y = n_pct, |
|
| 516 | -+ | ||
| 726 | +! |
- })+ fill = isna |
|
| 517 | +727 |
-
+ ) + |
|
| 518 | +728 | ! |
- pws <- teal.widgets::plot_with_settings_srv(+ geom_bar(position = "fill", stat = "identity") + |
| 519 | +729 | ! |
- id = "variable_plot",+ scale_fill_manual( |
| 520 | +730 | ! |
- plot_r = variable_plot_r,+ name = "", |
| 521 | +731 | ! |
- height = c(500, 200, 2000)+ values = c("grey90", c(getOption("ggplot2.discrete.colour")[2], "#ff2951ff")[1]),
|
| 522 | -+ | ||
| 732 | +! |
- )+ labels = c("Present", "Missing")
|
|
| 523 | +733 |
-
+ ) + |
|
| 524 | +734 | ! |
- output$variable_summary_table <- DT::renderDataTable({
+ scale_y_continuous( |
| 525 | +735 | ! |
- var_summary_table(+ labels = scales::percent_format(), |
| 526 | +736 | ! |
- plotted_data()$data,+ breaks = seq(0, 1, by = 0.1), |
| 527 | +737 | ! |
- treat_numeric_as_factor(),+ expand = c(0, 0)+ |
+
| 738 | ++ |
+ ) + |
|
| 528 | +739 | ! |
- input$variable_summary_table_rows,+ geom_text( |
| 529 | +740 | ! |
- if (!is.null(input$remove_outliers) && input$remove_outliers) {
+ aes(label = ifelse(isna == TRUE, sprintf("%d [%.02f%%]", n, n_pct), ""), y = 1),
|
| 530 | +741 | ! |
- req(input$outlier_definition_slider)+ hjust = 1, |
| 531 | +742 | ! |
- as.numeric(input$outlier_definition_slider)+ color = "black" |
| 532 | +743 |
- } else {
+ ) + |
|
| 533 | +744 | ! |
- 0+ labs + |
| 534 | -+ | ||
| 745 | +! |
- }- |
- |
| 535 | -- |
- )- |
- |
| 536 | -- |
- })- |
- |
| 537 | -- | - - | -|
| 538 | -- |
- ### REPORTER+ ggthemes + |
|
| 539 | +746 | ! |
- if (with_reporter) {
+ themes + |
| 540 | +747 | ! |
- card_fun <- function(comment) {
+ coord_flip(), |
| 541 | +748 | ! |
- card <- teal::TealReportCard$new()+ env = list( |
| 542 | +749 | ! |
- card$set_name("Variable Browser Plot")
+ labs = parsed_ggplot2_args$labs, |
| 543 | +750 | ! |
- card$append_text("Variable Browser Plot", "header2")
+ themes = parsed_ggplot2_args$theme, |
| 544 | +751 | ! |
- if (with_filter) card$append_fs(filter_panel_api$get_filter_state())+ ggthemes = parsed_ggplot2_args$ggtheme |
| 545 | -! | +||
| 752 | +
- card$append_text("Plot", "header3")
+ ) |
||
| 546 | -! | +||
| 753 | +
- card$append_plot(variable_plot_r(), dim = pws$dim())+ ) |
||
| 547 | -! | +||
| 754 | +
- if (!comment == "") {
+ ) |
||
| 548 | -! | +||
| 755 | +
- card$append_text("Comment", "header3")
+
|
||
| 549 | +756 | ! |
- card$append_text(comment)- |
-
| 550 | -- |
- }+ if (isTRUE(input$if_patients_plot)) {
|
|
| 551 | +757 | ! |
- card+ qenv <- teal.code::eval_code( |
| 552 | -+ | ||
| 758 | +! |
- }+ qenv, |
|
| 553 | +759 | ! |
- teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
+ substitute( |
| 554 | -+ | ||
| 760 | +! |
- }+ expr = parent_keys <- keys, |
|
| 555 | -+ | ||
| 761 | +! |
- ###+ env = list(keys = data_parent_keys()) |
|
| 556 | +762 |
- })+ ) |
|
| 557 | +763 |
- }+ ) %>% |
|
| 558 | -+ | ||
| 764 | +! |
-
+ teal.code::eval_code(quote(ndistinct_subjects <- dplyr::n_distinct(ANL[, parent_keys]))) %>% |
|
| 559 | -+ | ||
| 765 | +! |
- #' Summarize NAs.+ teal.code::eval_code( |
|
| 560 | -+ | ||
| 766 | +! |
- #'+ quote( |
|
| 561 | -+ | ||
| 767 | +! |
- #' Summarizes occurrence of missing values in vector.+ summary_plot_patients <- ANL[, c(parent_keys, analysis_vars)] %>% |
|
| 562 | -+ | ||
| 768 | +! |
- #' @param x vector of any type and length+ dplyr::group_by_at(parent_keys) %>% |
|
| 563 | -+ | ||
| 769 | +! |
- #' @return Character string describing `NA` occurrence.+ dplyr::summarise_all(anyNA) %>% |
|
| 564 | -+ | ||
| 770 | +! |
- #' @keywords internal+ tidyr::pivot_longer(cols = !dplyr::all_of(parent_keys), names_to = "col", values_to = "anyna") %>% |
|
| 565 | -+ | ||
| 771 | +! |
- var_missings_info <- function(x) {
+ dplyr::group_by_at(c("col")) %>%
|
|
| 566 | +772 | ! |
- sprintf("%s [%s%%]", sum(is.na(x)), round(mean(is.na(x) * 100), 2))
+ dplyr::summarise(count_na = sum(anyna)) %>% |
| 567 | -+ | ||
| 773 | +! |
- }+ dplyr::mutate(count_not_na = ndistinct_subjects - count_na) %>% |
|
| 568 | -+ | ||
| 774 | +! |
-
+ tidyr::pivot_longer(-c(col), names_to = "isna", values_to = "n") %>% |
|
| 569 | -+ | ||
| 775 | +! |
- #' Summarizes variable+ dplyr::mutate(isna = isna == "count_na", n_pct = n / ndistinct_subjects * 100) %>% |
|
| 570 | -+ | ||
| 776 | +! |
- #'+ dplyr::arrange_at(c("isna", "n"), .funs = dplyr::desc)
|
|
| 571 | +777 |
- #' Creates html summary with statistics relevant to data type. For numeric values it returns central+ ) |
|
| 572 | +778 |
- #' tendency measures, for factor returns level counts, for Date date range, for other just+ ) |
|
| 573 | +779 |
- #' number of levels.+ |
|
| 574 | -+ | ||
| 780 | +! |
- #'+ dev_ggplot2_args <- teal.widgets::ggplot2_args( |
|
| 575 | -+ | ||
| 781 | +! |
- #' @param x vector of any type+ labs = list(x = "", y = "Missing patients"), |
|
| 576 | -+ | ||
| 782 | +! |
- #' @param numeric_as_factor `logical` should the numeric variable be treated as a factor+ theme = list( |
|
| 577 | -+ | ||
| 783 | +! |
- #' @param dt_rows `numeric` current/latest `DT` page length+ legend.position = "bottom", |
|
| 578 | -+ | ||
| 784 | +! |
- #' @param outlier_definition If 0 no outliers are removed, otherwise+ axis.text.x = quote(element_text(angle = 45, hjust = 1)), |
|
| 579 | -+ | ||
| 785 | +! |
- #' outliers (those more than `outlier_definition*IQR below/above Q1/Q3` be removed)+ axis.text.y = quote(element_blank()) |
|
| 580 | +786 |
- #' @return text with simple statistics.+ ) |
|
| 581 | +787 |
- #' @keywords internal+ ) |
|
| 582 | +788 |
- var_summary_table <- function(x, numeric_as_factor, dt_rows, outlier_definition) {
+
|
|
| 583 | +789 | ! |
- if (is.null(dt_rows)) {
+ all_ggplot2_args <- teal.widgets::resolve_ggplot2_args( |
| 584 | +790 | ! |
- dt_rows <- 10+ user_plot = ggplot2_args[["Summary Patients"]], |
| 585 | -+ | ||
| 791 | +! |
- }+ user_default = ggplot2_args$default, |
|
| 586 | +792 | ! |
- if (is.numeric(x) && !numeric_as_factor) {
+ module_plot = dev_ggplot2_args |
| 587 | -! | +||
| 793 | +
- req(!any(is.infinite(x)))+ ) |
||
| 588 | +794 | ||
| 589 | +795 | ! |
- x <- remove_outliers_from(x, outlier_definition)+ parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args( |
| 590 | -+ | ||
| 796 | +! |
-
+ all_ggplot2_args, |
|
| 591 | +797 | ! |
- qvals <- round(stats::quantile(x, na.rm = TRUE, probs = c(0.25, 0.5, 0.75), type = 2), 2)+ ggtheme = input$ggtheme |
| 592 | +798 |
- # classical central tendency measures+ ) |
|
| 593 | +799 | ||
| 594 | +800 | ! |
- summary <-+ qenv <- teal.code::eval_code( |
| 595 | +801 | ! |
- data.frame(+ qenv, |
| 596 | +802 | ! |
- Statistic = c("min", "Q1", "median", "mean", "Q3", "max", "sd", "n"),
+ substitute( |
| 597 | +803 | ! |
- Value = c(+ p2 <- summary_plot_patients %>% |
| 598 | +804 | ! |
- round(min(x, na.rm = TRUE), 2),+ ggplot() + |
| 599 | +805 | ! |
- qvals[1],+ aes_( |
| 600 | +806 | ! |
- qvals[2],+ x = ~ factor(create_cols_labels(col), levels = x_levels), |
| 601 | +807 | ! |
- round(mean(x, na.rm = TRUE), 2),+ y = ~n_pct, |
| 602 | +808 | ! |
- qvals[3],+ fill = ~isna+ |
+
| 809 | ++ |
+ ) + |
|
| 603 | +810 | ! |
- round(max(x, na.rm = TRUE), 2),+ geom_bar(alpha = 1, stat = "identity", position = "fill") + |
| 604 | +811 | ! |
- round(stats::sd(x, na.rm = TRUE), 2),+ scale_y_continuous( |
| 605 | +812 | ! |
- length(x[!is.na(x)])+ labels = scales::percent_format(), |
| 606 | -+ | ||
| 813 | +! |
- )+ breaks = seq(0, 1, by = 0.1), |
|
| 607 | -+ | ||
| 814 | +! |
- )+ expand = c(0, 0) |
|
| 608 | +815 |
-
+ ) + |
|
| 609 | +816 | ! |
- DT::datatable(summary, rownames = FALSE, options = list(dom = "<t>", pageLength = dt_rows))+ scale_fill_manual( |
| 610 | +817 | ! |
- } else if (is.factor(x) || is.character(x) || (is.numeric(x) && numeric_as_factor) || is.logical(x)) {
- |
-
| 611 | -- |
- # make sure factor is ordered numeric+ name = "", |
|
| 612 | +818 | ! |
- if (is.numeric(x)) {
+ values = c("grey90", c(getOption("ggplot2.discrete.colour")[2], "#ff2951ff")[1]),
|
| 613 | +819 | ! |
- x <- factor(x, levels = sort(unique(x)))+ labels = c("Present", "Missing")
|
| 614 | +820 |
- }+ ) + |
|
| 615 | -+ | ||
| 821 | +! |
-
+ geom_text( |
|
| 616 | +822 | ! |
- level_counts <- table(x)+ aes(label = ifelse(isna == TRUE, sprintf("%d [%.02f%%]", n, n_pct), ""), y = 1),
|
| 617 | +823 | ! |
- max_levels_signif <- nchar(level_counts)+ hjust = 1,+ |
+
| 824 | +! | +
+ color = "black" |
|
| 618 | +825 |
-
+ ) + |
|
| 619 | +826 | ! |
- if (!all(is.na(x))) {
+ labs + |
| 620 | +827 | ! |
- levels <- names(level_counts)+ ggthemes + |
| 621 | +828 | ! |
- counts <- sprintf(+ themes + |
| 622 | +829 | ! |
- "%s [%.2f%%]",+ coord_flip(), |
| 623 | +830 | ! |
- format(level_counts, width = max_levels_signif), prop.table(level_counts) * 100+ env = list( |
| 624 | -+ | ||
| 831 | +! |
- )+ labs = parsed_ggplot2_args$labs, |
|
| 625 | -+ | ||
| 832 | +! |
- } else {
+ themes = parsed_ggplot2_args$theme, |
|
| 626 | +833 | ! |
- levels <- character(0)+ ggthemes = parsed_ggplot2_args$ggtheme |
| 627 | -! | +||
| 834 | +
- counts <- numeric(0)+ ) |
||
| 628 | +835 |
- }+ ) |
|
| 629 | +836 |
-
+ ) %>% |
|
| 630 | +837 | ! |
- summary <- data.frame(+ teal.code::eval_code( |
| 631 | +838 | ! |
- Level = levels,+ quote({
|
| 632 | +839 | ! |
- Count = counts,+ g1 <- ggplotGrob(p1) |
| 633 | +840 | ! |
- stringsAsFactors = FALSE+ g2 <- ggplotGrob(p2)+ |
+
| 841 | +! | +
+ g <- gridExtra::gtable_cbind(g1, g2, size = "first")+ |
+ |
| 842 | +! | +
+ g$heights <- grid::unit.pmax(g1$heights, g2$heights)+ |
+ |
| 843 | +! | +
+ grid::grid.newpage() |
|
| 634 | +844 |
- )+ }) |
|
| 635 | +845 |
-
+ ) |
|
| 636 | +846 |
- # sort the dataset in decreasing order of counts (needed as character variables default to alphabetical)+ } else {
|
|
| 637 | +847 | ! |
- summary <- summary[order(summary$Count, decreasing = TRUE), ]+ qenv <- teal.code::eval_code( |
| 638 | -+ | ||
| 848 | +! |
-
+ qenv, |
|
| 639 | +849 | ! |
- dom_opts <- if (nrow(summary) <= 10) {
+ quote({
|
| 640 | +850 | ! |
- "<t>"+ g <- ggplotGrob(p1)+ |
+
| 851 | +! | +
+ grid::grid.newpage() |
|
| 641 | +852 |
- } else {
+ }) |
|
| 642 | -! | +||
| 853 | +
- "<lf<t>ip>"+ ) |
||
| 643 | +854 |
- }+ } |
|
| 644 | -! | +||
| 855 | +
- DT::datatable(summary, rownames = FALSE, options = list(dom = dom_opts, pageLength = dt_rows))+ |
||
| 645 | +856 | ! |
- } else if (inherits(x, "Date") || inherits(x, "POSIXct") || inherits(x, "POSIXlt")) {
+ teal.code::eval_code( |
| 646 | +857 | ! |
- summary <-+ qenv, |
| 647 | +858 | ! |
- data.frame(+ quote(grid::grid.draw(g)) |
| 648 | -! | +||
| 859 | +
- Statistic = c("min", "median", "max"),
+ ) |
||
| 649 | -! | +||
| 860 | +
- Value = c(+ })+ |
+ ||
| 861 | ++ | + | |
| 650 | +862 | ! |
- min(x, na.rm = TRUE),+ summary_plot_r <- reactive(summary_plot_q()[["g"]])+ |
+
| 863 | ++ | + | |
| 651 | +864 | ! |
- stats::median(x, na.rm = TRUE),+ combination_cutoff_q <- reactive({
|
| 652 | +865 | ! |
- max(x, na.rm = TRUE)+ req(common_code_q()) |
| 653 | -+ | ||
| 866 | +! |
- )+ teal.code::eval_code( |
|
| 654 | -+ | ||
| 867 | +! |
- )+ common_code_q(), |
|
| 655 | +868 | ! |
- DT::datatable(summary, rownames = FALSE, options = list(dom = "<t>", pageLength = dt_rows))+ quote( |
| 656 | -+ | ||
| 869 | +! |
- } else {
+ combination_cutoff <- ANL %>% |
|
| 657 | +870 | ! |
- NULL+ dplyr::mutate_all(is.na) %>% |
| 658 | -+ | ||
| 871 | +! |
- }+ dplyr::group_by_all() %>% |
|
| 659 | -+ | ||
| 872 | +! |
- }+ dplyr::tally() %>% |
|
| 660 | -+ | ||
| 873 | +! |
-
+ dplyr::ungroup() |
|
| 661 | +874 |
- #' Plot variable+ ) |
|
| 662 | +875 |
- #'+ ) |
|
| 663 | +876 |
- #' Creates summary plot with statistics relevant to data type.+ }) |
|
| 664 | +877 |
- #'+ |
|
| 665 | -+ | ||
| 878 | +! |
- #' @inheritParams shared_params+ output$cutoff <- renderUI({
|
|
| 666 | -+ | ||
| 879 | +! |
- #' @param var vector of any type to be plotted. For numeric variables it produces histogram with+ x <- combination_cutoff_q()[["combination_cutoff"]]$n |
|
| 667 | +880 |
- #' density line, for factors it creates frequency plot+ |
|
| 668 | +881 |
- #' @param var_lab text describing selected variable to be displayed on the plot+ # select 10-th from the top |
|
| 669 | -+ | ||
| 882 | +! |
- #' @param wrap_character (`numeric`) number of characters at which to wrap text values of `var`+ n <- length(x) |
|
| 670 | -+ | ||
| 883 | +! |
- #' @param numeric_as_factor (`logical`) should the numeric variable be treated as a factor+ idx <- max(1, n - 10) |
|
| 671 | -+ | ||
| 884 | +! |
- #' @param display_density (`logical`) should density estimation be displayed for numeric values+ prev_value <- isolate(input$combination_cutoff) |
|
| 672 | -+ | ||
| 885 | +! |
- #' @param remove_NA_hist (`logical`) should `NA` values be removed for histogram of factor like variables+ value <- `if`( |
|
| 673 | -+ | ||
| 886 | +! |
- #' @param outlier_definition if 0 no outliers are removed, otherwise+ is.null(prev_value) || prev_value > max(x) || prev_value < min(x), |
|
| 674 | -+ | ||
| 887 | +! |
- #' outliers (those more than outlier_definition*IQR below/above Q1/Q3 be removed)+ sort(x, partial = idx)[idx], prev_value |
|
| 675 | +888 |
- #' @param records_for_factor (`numeric`) if the number of factor levels is >= than this value then+ ) |
|
| 676 | +889 |
- #' a graph of the factors isn't shown, only a list of values+ |
|
| 677 | -+ | ||
| 890 | +! |
- #'+ teal.widgets::optionalSliderInputValMinMax( |
|
| 678 | -+ | ||
| 891 | +! |
- #' @return plot+ ns("combination_cutoff"),
|
|
| 679 | -+ | ||
| 892 | +! |
- #' @keywords internal+ "Combination cut-off", |
|
| 680 | -+ | ||
| 893 | +! |
- plot_var_summary <- function(var,+ c(value, range(x)) |
|
| 681 | +894 |
- var_lab,+ ) |
|
| 682 | +895 |
- wrap_character = NULL,+ }) |
|
| 683 | +896 |
- numeric_as_factor,+ |
|
| 684 | -+ | ||
| 897 | +! |
- display_density = is.numeric(var),+ combination_plot_q <- reactive({
|
|
| 685 | -+ | ||
| 898 | +! |
- remove_NA_hist = FALSE, # nolint: object_name.+ req(input$summary_type == "Combinations", input$combination_cutoff, combination_cutoff_q()) |
|
| 686 | -+ | ||
| 899 | +! |
- outlier_definition,+ teal::validate_has_data(data_r(), 1) |
|
| 687 | +900 |
- records_for_factor,+ |
|
| 688 | -+ | ||
| 901 | +! |
- ggplot2_args) {
+ qenv <- teal.code::eval_code( |
|
| 689 | +902 | ! |
- checkmate::assert_character(var_lab)+ combination_cutoff_q(), |
| 690 | +903 | ! |
- checkmate::assert_numeric(wrap_character, null.ok = TRUE)+ substitute( |
| 691 | +904 | ! |
- checkmate::assert_flag(numeric_as_factor)+ expr = data_combination_plot_cutoff <- combination_cutoff %>% |
| 692 | +905 | ! |
- checkmate::assert_flag(display_density)+ dplyr::filter(n >= combination_cutoff_value) %>% |
| 693 | +906 | ! |
- checkmate::assert_logical(remove_NA_hist, null.ok = TRUE)+ dplyr::mutate(id = rank(-n, ties.method = "first")) %>% |
| 694 | +907 | ! |
- checkmate::assert_number(outlier_definition, lower = 0, finite = TRUE)+ tidyr::pivot_longer(-c(n, id), names_to = "key", values_to = "value") %>% |
| 695 | +908 | ! |
- checkmate::assert_integerish(records_for_factor, lower = 0, len = 1, any.missing = FALSE)+ dplyr::arrange(n), |
| 696 | +909 | ! |
- checkmate::assert_class(ggplot2_args, "ggplot2_args")+ env = list(combination_cutoff_value = input$combination_cutoff) |
| 697 | +910 |
-
+ ) |
|
| 698 | -! | +||
| 911 | +
- grid::grid.newpage()+ ) |
||
| 699 | +912 | ||
| 700 | -! | +||
| 913 | +
- plot_main <- if (is.factor(var) || is.character(var) || is.logical(var)) {
+ # find keys in dataset not selected in the UI and remove them from dataset |
||
| 701 | +914 | ! |
- groups <- unique(as.character(var))+ keys_not_selected <- setdiff(data_keys(), input$variables_select) |
| 702 | +915 | ! |
- len_groups <- length(groups)+ if (length(keys_not_selected) > 0) {
|
| 703 | +916 | ! |
- if (len_groups >= records_for_factor) {
+ qenv <- teal.code::eval_code( |
| 704 | +917 | ! |
- grid::textGrob(+ qenv, |
| 705 | +918 | ! |
- sprintf(+ substitute( |
| 706 | +919 | ! |
- "%s unique values\n%s:\n %s\n ...\n %s",+ expr = data_combination_plot_cutoff <- data_combination_plot_cutoff %>% |
| 707 | +920 | ! |
- len_groups,+ dplyr::filter(!key %in% keys_not_selected), |
| 708 | +921 | ! |
- var_lab,+ env = list(keys_not_selected = keys_not_selected) |
| 709 | -! | +||
| 922 | +
- paste(utils::head(groups), collapse = ",\n "),- |
- ||
| 710 | -! | -
- paste(utils::tail(groups), collapse = ",\n ")+ ) |
|
| 711 | +923 |
- ),- |
- |
| 712 | -! | -
- x = grid::unit(1, "line"),- |
- |
| 713 | -! | -
- y = grid::unit(1, "npc") - grid::unit(1, "line"),- |
- |
| 714 | -! | -
- just = c("left", "top")
+ ) |
|
| 715 | +924 |
- )+ } |
|
| 716 | +925 |
- } else {
+
|
|
| 717 | +926 | ! |
- if (!is.null(wrap_character)) {
+ qenv <- teal.code::eval_code( |
| 718 | +927 | ! |
- var <- stringr::str_wrap(var, width = wrap_character)- |
-
| 719 | -- |
- }+ qenv, |
|
| 720 | +928 | ! |
- var <- if (isTRUE(remove_NA_hist)) as.vector(stats::na.omit(var)) else var+ quote( |
| 721 | +929 | ! |
- ggplot(data.frame(var), aes(x = forcats::fct_infreq(as.factor(var)))) ++ labels <- data_combination_plot_cutoff %>% |
| 722 | +930 | ! |
- geom_bar(+ dplyr::filter(key == key[[1]]) %>% |
| 723 | +931 | ! |
- stat = "count", aes(fill = ifelse(is.na(var), "withcolor", "")), show.legend = FALSE+ getElement(name = 1) |
| 724 | +932 |
- ) ++ ) |
|
| 725 | -! | +||
| 933 | +
- scale_fill_manual(values = c("gray50", "tan"))
+ ) |
||
| 726 | +934 |
- }+ |
|
| 727 | +935 | ! |
- } else if (is.numeric(var)) {
+ dev_ggplot2_args1 <- teal.widgets::ggplot2_args( |
| 728 | +936 | ! |
- validate(need(any(!is.na(var)), "No data left to visualize."))+ labs = list(x = "", y = ""), |
| 729 | -+ | ||
| 937 | +! |
-
+ theme = list( |
|
| 730 | -+ | ||
| 938 | +! |
- # Filter out NA+ legend.position = "bottom", |
|
| 731 | +939 | ! |
- var <- var[which(!is.na(var))]+ axis.text.x = quote(element_blank()) |
| 732 | +940 |
-
+ ) |
|
| 733 | -! | +||
| 941 | +
- validate(need(!any(is.infinite(var)), "Cannot display graph when data includes infinite values"))+ ) |
||
| 734 | +942 | ||
| 735 | +943 | ! |
- if (numeric_as_factor) {
+ all_ggplot2_args1 <- teal.widgets::resolve_ggplot2_args( |
| 736 | +944 | ! |
- var <- factor(var)+ user_plot = ggplot2_args[["Combinations Hist"]], |
| 737 | +945 | ! |
- ggplot(NULL, aes(x = var)) ++ user_default = ggplot2_args$default, |
| 738 | +946 | ! |
- geom_histogram(stat = "count")+ module_plot = dev_ggplot2_args1 |
| 739 | +947 |
- } else {
+ ) |
|
| 740 | +948 |
- # remove outliers+ |
|
| 741 | +949 | ! |
- if (outlier_definition != 0) {
+ parsed_ggplot2_args1 <- teal.widgets::parse_ggplot2_args( |
| 742 | +950 | ! |
- number_records <- length(var)+ all_ggplot2_args1, |
| 743 | +951 | ! |
- var <- remove_outliers_from(var, outlier_definition)+ ggtheme = "void" |
| 744 | -! | +||
| 952 | +
- number_outliers <- number_records - length(var)+ ) |
||
| 745 | -! | +||
| 953 | +
- outlier_text <- paste0(+ |
||
| 746 | +954 | ! |
- number_outliers, " outliers (",
+ dev_ggplot2_args2 <- teal.widgets::ggplot2_args( |
| 747 | +955 | ! |
- round(number_outliers / number_records * 100, 2),+ labs = list(x = "", y = ""), |
| 748 | +956 | ! |
- "% of non-missing records) not shown"+ theme = list( |
| 749 | -+ | ||
| 957 | +! |
- )+ legend.position = "bottom", |
|
| 750 | +958 | ! |
- validate(need(+ axis.text.x = quote(element_blank()), |
| 751 | +959 | ! |
- length(var) > 1,+ axis.ticks = quote(element_blank()), |
| 752 | +960 | ! |
- "At least two data points must remain after removing outliers for this graph to be displayed"+ panel.grid.major = quote(element_blank()) |
| 753 | +961 |
- ))+ ) |
|
| 754 | +962 |
- }+ ) |
|
| 755 | +963 |
- ## histogram+ |
|
| 756 | +964 | ! |
- binwidth <- get_bin_width(var)+ all_ggplot2_args2 <- teal.widgets::resolve_ggplot2_args( |
| 757 | +965 | ! |
- p <- ggplot(data = data.frame(var = var), aes(x = var, y = after_stat(count))) ++ user_plot = ggplot2_args[["Combinations Main"]], |
| 758 | +966 | ! |
- geom_histogram(binwidth = binwidth) ++ user_default = ggplot2_args$default, |
| 759 | +967 | ! |
- scale_y_continuous(+ module_plot = dev_ggplot2_args2 |
| 760 | -! | +||
| 968 | +
- sec.axis = sec_axis(+ ) |
||
| 761 | -! | +||
| 969 | +
- trans = ~ . / nrow(data.frame(var = var)),+ |
||
| 762 | +970 | ! |
- labels = scales::percent,+ parsed_ggplot2_args2 <- teal.widgets::parse_ggplot2_args( |
| 763 | +971 | ! |
- name = "proportion (in %)"+ all_ggplot2_args2, |
| 764 | -+ | ||
| 972 | +! |
- )+ ggtheme = input$ggtheme |
|
| 765 | +973 |
- )+ ) |
|
| 766 | +974 | ||
| 767 | +975 | ! |
- if (display_density) {
+ teal.code::eval_code( |
| 768 | +976 | ! |
- p <- p + geom_density(aes(y = after_stat(count * binwidth)))- |
-
| 769 | -- |
- }+ qenv, |
|
| 770 | -+ | ||
| 977 | +! |
-
+ substitute( |
|
| 771 | +978 | ! |
- if (outlier_definition != 0) {
+ expr = {
|
| 772 | +979 | ! |
- p <- p + annotate(+ p1 <- data_combination_plot_cutoff %>% |
| 773 | +980 | ! |
- geom = "text",+ dplyr::select(id, n) %>% |
| 774 | +981 | ! |
- label = outlier_text,+ dplyr::distinct() %>% |
| 775 | +982 | ! |
- x = Inf, y = Inf,+ ggplot(aes(x = id, y = n)) + |
| 776 | +983 | ! |
- hjust = 1.02, vjust = 1.2,+ geom_bar(stat = "identity", fill = c(getOption("ggplot2.discrete.colour")[2], "#ff2951ff")[1]) +
|
| 777 | +984 | ! |
- color = "black",+ geom_text( |
| 778 | -+ | ||
| 985 | +! |
- # explicitly modify geom text size according+ aes(label = n), |
|
| 779 | +986 | ! |
- size = ggplot2_args[["theme"]][["text"]][["size"]] / 3.5+ position = position_dodge(width = 0.9), |
| 780 | -+ | ||
| 987 | +! |
- )+ vjust = -0.25 |
|
| 781 | +988 |
- }+ ) + |
|
| 782 | +989 | ! |
- p+ ylim(c(0, max(data_combination_plot_cutoff$n) * 1.5)) + |
| 783 | -+ | ||
| 990 | +! |
- }+ labs1 + |
|
| 784 | +991 | ! |
- } else if (inherits(var, "Date") || inherits(var, "POSIXct") || inherits(var, "POSIXlt")) {
+ ggthemes1 + |
| 785 | +992 | ! |
- var_num <- as.numeric(var)+ themes1 |
| 786 | -! | +||
| 993 | +
- binwidth <- get_bin_width(var_num, 1)+ |
||
| 787 | +994 | ! |
- p <- ggplot(data = data.frame(var = var), aes(x = var, y = after_stat(count))) ++ graph_number_rows <- length(unique(data_combination_plot_cutoff$id)) |
| 788 | +995 | ! |
- geom_histogram(binwidth = binwidth)+ graph_number_cols <- nrow(data_combination_plot_cutoff) / graph_number_rows |
| 789 | +996 |
- } else {
+
|
|
| 790 | +997 | ! |
- grid::textGrob(+ p2 <- data_combination_plot_cutoff %>% ggplot() + |
| 791 | +998 | ! |
- paste(strwrap(+ aes(x = create_cols_labels(key), y = id - 0.5, fill = value) + |
| 792 | +999 | ! |
- utils::capture.output(utils::str(var)),+ geom_tile(alpha = 0.85, height = 0.95) + |
| 793 | +1000 | ! |
- width = .9 * grid::convertWidth(grid::unit(1, "npc"), "char", TRUE)+ scale_fill_manual( |
| 794 | +1001 | ! |
- ), collapse = "\n"),+ name = "", |
| 795 | +1002 | ! |
- x = grid::unit(1, "line"), y = grid::unit(1, "npc") - grid::unit(1, "line"), just = c("left", "top")
- |
-
| 796 | -- |
- )+ values = c("grey90", c(getOption("ggplot2.discrete.colour")[2], "#ff2951ff")[1]),
|
|
| 797 | -+ | ||
| 1003 | +! |
- }+ labels = c("Present", "Missing")
|
|
| 798 | +1004 |
-
+ ) + |
|
| 799 | +1005 | ! |
- dev_ggplot2_args <- teal.widgets::ggplot2_args(+ geom_hline(yintercept = seq_len(1 + graph_number_rows) - 1) + |
| 800 | +1006 | ! |
- labs = list(x = var_lab)- |
-
| 801 | -- |
- )- |
- |
| 802 | -- |
- ###+ geom_vline(xintercept = seq_len(1 + graph_number_cols) - 0.5, linetype = "dotted") + |
|
| 803 | +1007 | ! |
- all_ggplot2_args <- teal.widgets::resolve_ggplot2_args(+ coord_flip() + |
| 804 | +1008 | ! |
- ggplot2_args,+ labs2 + |
| 805 | +1009 | ! |
- module_plot = dev_ggplot2_args+ ggthemes2 + |
| 806 | -+ | ||
| 1010 | +! |
- )+ themes2 |
|
| 807 | +1011 | ||
| 808 | +1012 | ! |
- if (is.ggplot(plot_main)) {
+ g1 <- ggplotGrob(p1) |
| 809 | +1013 | ! |
- if (is.numeric(var) && !numeric_as_factor) {
+ g2 <- ggplotGrob(p2) |
| 810 | +1014 |
- # numeric not as factor+ |
|
| 811 | +1015 | ! |
- plot_main <- plot_main ++ g <- gridExtra::gtable_rbind(g1, g2, size = "last") |
| 812 | +1016 | ! |
- theme_light() ++ g$heights[7] <- grid::unit(0.2, "null") # rescale to get the bar chart smaller |
| 813 | +1017 | ! |
- list(+ grid::grid.newpage() |
| 814 | +1018 | ! |
- labs = do.call("labs", all_ggplot2_args$labs),
+ grid::grid.draw(g) |
| 815 | -! | +||
| 1019 | +
- theme = do.call("theme", all_ggplot2_args$theme)
- |
- ||
| 816 | -- |
- )- |
- |
| 817 | -- |
- } else {
- |
- |
| 818 | -- |
- # factor low number of levels OR numeric as factor OR Date+ }, |
|
| 819 | +1020 | ! |
- plot_main <- plot_main ++ env = list( |
| 820 | +1021 | ! |
- theme_light() ++ labs1 = parsed_ggplot2_args1$labs, |
| 821 | +1022 | ! |
- list(+ themes1 = parsed_ggplot2_args1$theme, |
| 822 | +1023 | ! |
- labs = do.call("labs", all_ggplot2_args$labs),
+ ggthemes1 = parsed_ggplot2_args1$ggtheme, |
| 823 | +1024 | ! |
- theme = do.call("theme", all_ggplot2_args$theme)
- |
-
| 824 | -- |
- )+ labs2 = parsed_ggplot2_args2$labs, |
|
| 825 | -+ | ||
| 1025 | +! |
- }+ themes2 = parsed_ggplot2_args2$theme, |
|
| 826 | +1026 | ! |
- plot_main <- ggplotGrob(plot_main)+ ggthemes2 = parsed_ggplot2_args2$ggtheme |
| 827 | +1027 |
- }+ ) |
|
| 828 | +1028 | - - | -|
| 829 | -! | -
- grid::grid.draw(plot_main)- |
- |
| 830 | -! | -
- plot_main+ ) |
|
| 831 | +1029 |
- }+ ) |
|
| 832 | +1030 |
-
+ }) |
|
| 833 | +1031 |
- is_num_var_short <- function(.unique_records_for_factor, input, data_for_analysis) {
+
|
|
| 834 | +1032 | ! |
- length(unique(data_for_analysis()$data)) < .unique_records_for_factor && !is.null(input$numeric_as_factor)- |
-
| 835 | -- |
- }+ combination_plot_r <- reactive(combination_plot_q()[["g"]]) |
|
| 836 | +1033 | ||
| 837 | -- |
- #' Validates the variable browser inputs- |
- |
| 838 | -+ | ||
| 1034 | +! |
- #'+ summary_table_q <- reactive({
|
|
| 839 | -+ | ||
| 1035 | +! |
- #' @param input (`session$input`) the `shiny` session input+ req( |
|
| 840 | -+ | ||
| 1036 | +! |
- #' @param plot_var (`list`) list of a data frame and an array of variable names+ input$summary_type == "By Variable Levels", # needed to trigger show r code update on tab change |
|
| 841 | -+ | ||
| 1037 | +! |
- #' @param data (`teal_data`) the datasets passed to the module+ common_code_q() |
|
| 842 | +1038 |
- #'+ ) |
|
| 843 | -+ | ||
| 1039 | +! |
- #' @returns `logical` TRUE if validations pass; a `shiny` validation error otherwise+ teal::validate_has_data(data_r(), 1) |
|
| 844 | +1040 |
- #' @keywords internal+ |
|
| 845 | +1041 |
- validate_input <- function(input, plot_var, data) {
- |
- |
| 846 | -! | -
- reactive({
- |
- |
| 847 | -! | -
- dataset_name <- req(input$tabset_panel)+ # extract the ANL dataset for use in further validation |
|
| 848 | +1042 | ! |
- varname <- plot_var$variable[[dataset_name]]+ anl <- common_code_q()[["ANL"]] |
| 849 | +1043 | ||
| 850 | +1044 | ! |
- validate(need(dataset_name, "No data selected"))+ group_var <- input$group_by_var |
| 851 | +1045 | ! |
- validate(need(varname, "No variable selected"))+ validate( |
| 852 | +1046 | ! |
- df <- data()[[dataset_name]]+ need( |
| 853 | +1047 | ! |
- teal::validate_has_data(df, 1)+ is.null(group_var) || |
| 854 | +1048 | ! |
- teal::validate_has_variable(varname = varname, data = df, "Variable not available")- |
-
| 855 | -- |
-
+ length(unique(anl[[group_var]])) < 100, |
|
| 856 | +1049 | ! |
- TRUE+ "Please select group-by variable with fewer than 100 unique values" |
| 857 | +1050 |
- })+ ) |
|
| 858 | +1051 |
- }+ ) |
|
| 859 | +1052 | ||
| 860 | -+ | ||
| 1053 | +! |
- get_plotted_data <- function(input, plot_var, data) {
+ group_vals <- input$group_by_vals |
|
| 861 | +1054 | ! |
- dataset_name <- input$tabset_panel+ variables_select <- input$variables_select |
| 862 | +1055 | ! |
- varname <- plot_var$variable[[dataset_name]]+ vars <- unique(variables_select, group_var) |
| 863 | +1056 | ! |
- df <- data()[[dataset_name]]+ count_type <- input$count_type |
| 864 | +1057 | ||
| 865 | +1058 | ! |
- var_description <- teal.data::col_labels(df)[[varname]]+ if (!is.null(selected_vars()) && length(selected_vars()) != ncol(anl)) {
|
| 866 | +1059 | ! |
- list(data = df[[varname]], var_description = var_description)+ variables <- selected_vars() |
| 867 | +1060 |
- }+ } else {
|
|
| 868 | -+ | ||
| 1061 | +! |
-
+ variables <- colnames(anl) |
|
| 869 | +1062 |
- #' Renders the left-hand side `tabset` panel of the module+ } |
|
| 870 | +1063 |
- #'+ |
|
| 871 | -+ | ||
| 1064 | +! |
- #' @param datanames (`character`) the name of the dataset+ summ_fn <- if (input$count_type == "counts") {
|
|
| 872 | -+ | ||
| 1065 | +! |
- #' @param parent_dataname (`character`) the name of a parent `dataname` to filter out variables from+ function(x) sum(is.na(x)) |
|
| 873 | +1066 |
- #' @param data (`teal_data`) the object containing all datasets+ } else {
|
|
| 874 | -+ | ||
| 1067 | +! |
- #' @param input (`session$input`) the `shiny` session input+ function(x) round(sum(is.na(x)) / length(x), 4) |
|
| 875 | +1068 |
- #' @param output (`session$output`) the `shiny` session output+ } |
|
| 876 | +1069 |
- #' @param columns_names (`environment`) the environment containing bindings for each dataset+ |
|
| 877 | -+ | ||
| 1070 | +! |
- #' @param plot_var (`list`) the list containing the currently selected dataset (tab) and its column names+ qenv <- common_code_q() |
|
| 878 | +1071 |
- #' @keywords internal+ |
|
| 879 | -+ | ||
| 1072 | +! |
- render_tabset_panel_content <- function(datanames, parent_dataname, output, data, input, columns_names, plot_var) {
+ if (!is.null(group_var)) {
|
|
| 880 | +1073 | ! |
- lapply(datanames, render_single_tab,+ qenv <- teal.code::eval_code( |
| 881 | +1074 | ! |
- input = input,+ qenv, |
| 882 | +1075 | ! |
- output = output,+ substitute( |
| 883 | +1076 | ! |
- data = data,+ expr = {
|
| 884 | +1077 | ! |
- parent_dataname = parent_dataname,+ summary_data <- ANL %>% |
| 885 | +1078 | ! |
- columns_names = columns_names,+ dplyr::mutate(group_var_name := forcats::fct_na_value_to_level(as.factor(group_var_name), "NA")) %>% |
| 886 | +1079 | ! |
- plot_var = plot_var+ dplyr::group_by_at(group_var) %>% |
| 887 | -+ | ||
| 1080 | +! |
- )+ dplyr::filter(group_var_name %in% group_vals) |
|
| 888 | +1081 |
- }+ + |
+ |
| 1082 | +! | +
+ count_data <- dplyr::summarise(summary_data, n = dplyr::n()) |
|
| 889 | +1083 | ||
| 890 | -+ | ||
| 1084 | +! |
- #' Renders a single tab in the left-hand side tabset panel+ summary_data <- dplyr::summarise_all(summary_data, summ_fn) %>% |
|
| 891 | -+ | ||
| 1085 | +! |
- #'+ dplyr::mutate(group_var_name := paste0(group_var, ":", group_var_name, "(N=", count_data$n, ")")) %>% |
|
| 892 | -+ | ||
| 1086 | +! |
- #' Renders a single tab in the left-hand side tabset panel. The rendered tab contains+ tidyr::pivot_longer(!dplyr::all_of(group_var), names_to = "Variable", values_to = "out") %>% |
|
| 893 | -+ | ||
| 1087 | +! |
- #' information about one dataset out of many presented in the module.+ tidyr::pivot_wider(names_from = group_var, values_from = "out") %>% |
|
| 894 | -+ | ||
| 1088 | +! |
- #'+ dplyr::mutate(`Variable label` = create_cols_labels(Variable, just_label = TRUE), .after = Variable) |
|
| 895 | +1089 |
- #' @param dataset_name (`character`) the name of the dataset contained in the rendered tab+ }, |
|
| 896 | -+ | ||
| 1090 | +! |
- #' @param parent_dataname (`character`) the name of a parent `dataname` to filter out variables from+ env = list( |
|
| 897 | -+ | ||
| 1091 | +! |
- #' @inheritParams render_tabset_panel_content+ group_var = group_var, group_var_name = as.name(group_var), group_vals = group_vals, summ_fn = summ_fn |
|
| 898 | +1092 |
- #' @keywords internal+ ) |
|
| 899 | +1093 |
- render_single_tab <- function(dataset_name, parent_dataname, output, data, input, columns_names, plot_var) {
+ ) |
|
| 900 | -! | +||
| 1094 | +
- render_tab_header(dataset_name, output, data)+ ) |
||
| 901 | +1095 |
-
+ } else {
|
|
| 902 | +1096 | ! |
- render_tab_table(+ qenv <- teal.code::eval_code( |
| 903 | +1097 | ! |
- dataset_name = dataset_name,+ qenv, |
| 904 | +1098 | ! |
- parent_dataname = parent_dataname,+ substitute( |
| 905 | +1099 | ! |
- output = output,+ expr = summary_data <- ANL %>% |
| 906 | +1100 | ! |
- data = data,+ dplyr::summarise_all(summ_fn) %>% |
| 907 | +1101 | ! |
- input = input,+ tidyr::pivot_longer(dplyr::everything(), |
| 908 | +1102 | ! |
- columns_names = columns_names,+ names_to = "Variable", |
| 909 | +1103 | ! |
- plot_var = plot_var+ values_to = paste0("Missing (N=", nrow(ANL), ")")
|
| 910 | +1104 |
- )+ ) %>% |
|
| 911 | -+ | ||
| 1105 | +! |
- }+ dplyr::mutate(`Variable label` = create_cols_labels(Variable), .after = Variable), |
|
| 912 | -- | - + | |
| 1106 | +! | +
+ env = list(summ_fn = summ_fn) |
|
| 913 | +1107 |
- #' Renders the text headlining a single tab in the left-hand side tabset panel+ ) |
|
| 914 | +1108 |
- #'+ ) |
|
| 915 | +1109 |
- #' @param dataset_name (`character`) the name of the dataset of the tab+ } |
|
| 916 | +1110 |
- #' @inheritParams render_tabset_panel_content+ |
|
| 917 | -+ | ||
| 1111 | +! |
- #' @keywords internal+ teal.code::eval_code(qenv, quote(summary_data)) |
|
| 918 | +1112 |
- render_tab_header <- function(dataset_name, output, data) {
+ }) |
|
| 919 | -! | +||
| 1113 | +
- dataset_ui_id <- paste0("dataset_summary_", dataset_name)
+
|
||
| 920 | +1114 | ! |
- output[[dataset_ui_id]] <- renderText({
+ summary_table_r <- reactive(summary_table_q()[["summary_data"]]) |
| 921 | -! | +||
| 1115 | +
- df <- data()[[dataset_name]]+ |
||
| 922 | +1116 | ! |
- join_keys <- teal.data::join_keys(data())+ by_subject_plot_q <- reactive({
|
| 923 | -! | +||
| 1117 | +
- if (!is.null(join_keys)) {
+ # needed to trigger show r code update on tab change |
||
| 924 | +1118 | ! |
- key <- teal.data::join_keys(data())[dataset_name, dataset_name]+ req(input$summary_type == "Grouped by Subject", common_code_q()) |
| 925 | +1119 |
- } else {
+
|
|
| 926 | +1120 | ! |
- key <- NULL+ teal::validate_has_data(data_r(), 1) |
| 927 | +1121 |
- }- |
- |
| 928 | -! | -
- sprintf(+ |
|
| 929 | +1122 | ! |
- "Dataset with %s unique key rows and %s variables",+ dev_ggplot2_args <- teal.widgets::ggplot2_args( |
| 930 | +1123 | ! |
- nrow(unique(`if`(length(key) > 0, df[, key, drop = FALSE], df))),+ labs = list(x = "", y = ""), |
| 931 | +1124 | ! |
- ncol(df)- |
-
| 932 | -- |
- )- |
- |
| 933 | -- |
- })+ theme = list(legend.position = "bottom", axis.text.x = quote(element_blank())) |
|
| 934 | +1125 |
- }+ ) |
|
| 935 | +1126 | ||
| 936 | -- |
- #' Renders the table for a single dataset in the left-hand side tabset panel- |
- |
| 937 | -- |
- #'- |
- |
| 938 | -- |
- #' The table contains column names, column labels,- |
- |
| 939 | -- |
- #' small summary about NA values and `sparkline` (if appropriate).- |
- |
| 940 | -+ | ||
| 1127 | +! |
- #'+ all_ggplot2_args <- teal.widgets::resolve_ggplot2_args( |
|
| 941 | -+ | ||
| 1128 | +! |
- #' @param dataset_name (`character`) the name of the dataset+ user_plot = ggplot2_args[["By Subject"]], |
|
| 942 | -+ | ||
| 1129 | +! |
- #' @param parent_dataname (`character`) the name of a parent `dataname` to filter out variables from+ user_default = ggplot2_args$default, |
|
| 943 | -+ | ||
| 1130 | +! |
- #' @inheritParams render_tabset_panel_content+ module_plot = dev_ggplot2_args |
|
| 944 | +1131 |
- #' @keywords internal+ ) |
|
| 945 | +1132 |
- render_tab_table <- function(dataset_name, parent_dataname, output, data, input, columns_names, plot_var) {
+
|
|
| 946 | +1133 | ! |
- table_ui_id <- paste0("variable_browser_", dataset_name)
- |
-
| 947 | -- |
-
+ parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args( |
|
| 948 | +1134 | ! |
- output[[table_ui_id]] <- DT::renderDataTable({
+ all_ggplot2_args, |
| 949 | +1135 | ! |
- df <- data()[[dataset_name]]+ ggtheme = input$ggtheme |
| 950 | +1136 | - - | -|
| 951 | -! | -
- get_vars_df <- function(input, dataset_name, parent_name, data) {
+ ) |
|
| 952 | -! | +||
| 1137 | +
- data_cols <- colnames(df)+ |
||
| 953 | +1138 | ! |
- if (isTRUE(input$show_parent_vars)) {
+ teal.code::eval_code( |
| 954 | +1139 | ! |
- data_cols+ common_code_q(), |
| 955 | +1140 | ! |
- } else if (dataset_name != parent_name && parent_name %in% names(data)) {
+ substitute( |
| 956 | +1141 | ! |
- setdiff(data_cols, colnames(data()[[parent_name]]))- |
-
| 957 | -- |
- } else {
+ expr = parent_keys <- keys, |
|
| 958 | +1142 | ! |
- data_cols+ env = list(keys = data_parent_keys()) |
| 959 | +1143 |
- }+ ) |
|
| 960 | +1144 |
- }+ ) %>% |
|
| 961 | -+ | ||
| 1145 | +! |
-
+ teal.code::eval_code( |
|
| 962 | +1146 | ! |
- if (length(parent_dataname) > 0) {
+ substitute( |
| 963 | +1147 | ! |
- df_vars <- get_vars_df(input, dataset_name, parent_dataname, data)+ expr = analysis_vars <- setdiff(colnames(ANL), data_keys), |
| 964 | +1148 | ! |
- df <- df[df_vars]+ env = list(data_keys = data_keys()) |
| 965 | +1149 |
- }+ ) |
|
| 966 | +1150 |
-
+ ) %>% |
|
| 967 | +1151 | ! |
- if (is.null(df) || ncol(df) == 0) {
+ teal.code::eval_code( |
| 968 | +1152 | ! |
- columns_names[[dataset_name]] <- character(0)+ quote({
|
| 969 | +1153 | ! |
- df_output <- data.frame(+ summary_plot_patients <- ANL[, c(parent_keys, analysis_vars)] %>% |
| 970 | +1154 | ! |
- Type = character(0),+ dplyr::group_by_at(parent_keys) %>% |
| 971 | +1155 | ! |
- Variable = character(0),+ dplyr::mutate(id = dplyr::cur_group_id()) %>% |
| 972 | +1156 | ! |
- Label = character(0),+ dplyr::ungroup() %>% |
| 973 | +1157 | ! |
- Missings = character(0),+ dplyr::group_by_at(c(parent_keys, "id")) %>% |
| 974 | +1158 | ! |
- Sparklines = character(0),+ dplyr::summarise_all(anyNA) %>% |
| 975 | +1159 | ! |
- stringsAsFactors = FALSE+ dplyr::ungroup() |
| 976 | +1160 |
- )+ |
|
| 977 | +1161 |
- } else {
+ # order subjects by decreasing number of missing and then by |
|
| 978 | +1162 |
- # extract data variable labels+ # missingness pattern (defined using sha1) |
|
| 979 | +1163 | ! |
- labels <- teal.data::col_labels(df)- |
-
| 980 | -- |
-
+ order_subjects <- summary_plot_patients %>% |
|
| 981 | +1164 | ! |
- columns_names[[dataset_name]] <- names(labels)- |
-
| 982 | -- |
-
+ dplyr::select(-"id", -dplyr::all_of(parent_keys)) %>% |
|
| 983 | -+ | ||
| 1165 | +! |
- # calculate number of missing values+ dplyr::transmute( |
|
| 984 | +1166 | ! |
- missings <- vapply(+ id = dplyr::row_number(), |
| 985 | +1167 | ! |
- df,+ number_NA = apply(., 1, sum), |
| 986 | +1168 | ! |
- var_missings_info,+ sha = apply(., 1, rlang::hash) |
| 987 | -! | +||
| 1169 | +
- FUN.VALUE = character(1),+ ) %>% |
||
| 988 | +1170 | ! |
- USE.NAMES = FALSE+ dplyr::arrange(dplyr::desc(number_NA), sha) %>% |
| 989 | -+ | ||
| 1171 | +! |
- )+ getElement(name = "id") |
|
| 990 | +1172 | ||
| 991 | +1173 |
- # get icons proper for the data types+ # order columns by decreasing percent of missing values |
|
| 992 | +1174 | ! |
- icons <- vapply(df, function(x) class(x)[1L], character(1L))- |
-
| 993 | -- |
-
+ ordered_columns <- summary_plot_patients %>% |
|
| 994 | +1175 | ! |
- join_keys <- teal.data::join_keys(data())+ dplyr::select(-"id", -dplyr::all_of(parent_keys)) %>% |
| 995 | +1176 | ! |
- if (!is.null(join_keys)) {
+ dplyr::summarise( |
| 996 | +1177 | ! |
- icons[intersect(join_keys[dataset_name, dataset_name], colnames(df))] <- "primary_key"- |
-
| 997 | -- |
- }+ column = create_cols_labels(colnames(.)), |
|
| 998 | +1178 | ! |
- icons <- variable_type_icons(icons)+ na_count = apply(., MARGIN = 2, FUN = sum), |
| 999 | -+ | ||
| 1179 | +! |
-
+ na_percent = na_count / nrow(.) * 100 |
|
| 1000 | +1180 |
- # generate sparklines+ ) %>% |
|
| 1001 | +1181 | ! |
- sparklines_html <- vapply(+ dplyr::arrange(na_percent, dplyr::desc(column)) |
| 1002 | -! | +||
| 1182 | +
- df,+ |
||
| 1003 | +1183 | ! |
- create_sparklines,+ summary_plot_patients <- summary_plot_patients %>% |
| 1004 | +1184 | ! |
- FUN.VALUE = character(1),+ tidyr::gather("col", "isna", -"id", -dplyr::all_of(parent_keys)) %>%
|
| 1005 | +1185 | ! |
- USE.NAMES = FALSE+ dplyr::mutate(col = create_cols_labels(col)) |
| 1006 | +1186 |
- )+ }) |
|
| 1007 | +1187 |
-
+ ) %>% |
|
| 1008 | +1188 | ! |
- df_output <- data.frame(+ teal.code::eval_code( |
| 1009 | +1189 | ! |
- Type = icons,+ substitute( |
| 1010 | +1190 | ! |
- Variable = names(labels),+ expr = {
|
| 1011 | +1191 | ! |
- Label = labels,+ g <- ggplot(summary_plot_patients, aes( |
| 1012 | +1192 | ! |
- Missings = missings,+ x = factor(id, levels = order_subjects), |
| 1013 | +1193 | ! |
- Sparklines = sparklines_html,+ y = factor(col, levels = ordered_columns[["column"]]), |
| 1014 | +1194 | ! |
- stringsAsFactors = FALSE+ fill = isna |
| 1015 | +1195 |
- )+ )) + |
|
| 1016 | -+ | ||
| 1196 | +! |
- }+ geom_raster() + |
|
| 1017 | -+ | ||
| 1197 | +! |
-
+ annotate( |
|
| 1018 | -+ | ||
| 1198 | +! |
- # Select row 1 as default / fallback+ "text", |
|
| 1019 | +1199 | ! |
- selected_ix <- 1+ x = length(order_subjects), |
| 1020 | -+ | ||
| 1200 | +! |
- # Define starting page index (base-0 index of the first item on page+ y = seq_len(nrow(ordered_columns)), |
|
| 1021 | -+ | ||
| 1201 | +! |
- # note: in many cases it's not the item itself+ hjust = 1, |
|
| 1022 | +1202 | ! |
- selected_page_ix <- 0+ label = sprintf("%d [%.02f%%]", ordered_columns[["na_count"]], ordered_columns[["na_percent"]])
|
| 1023 | +1203 |
-
+ ) + |
|
| 1024 | -+ | ||
| 1204 | +! |
- # Retrieve current selected variable if any+ scale_fill_manual( |
|
| 1025 | +1205 | ! |
- isolated_variable <- isolate(plot_var$variable[[dataset_name]])+ name = "", |
| 1026 | -+ | ||
| 1206 | +! |
-
+ values = c("grey90", c(getOption("ggplot2.discrete.colour")[2], "#ff2951ff")[1]),
|
|
| 1027 | +1207 | ! |
- if (!is.null(isolated_variable)) {
+ labels = c("Present", "Missing (at least one)")
|
| 1028 | -! | +||
| 1208 | +
- index <- which(columns_names[[dataset_name]] == isolated_variable)[1]+ ) + |
||
| 1029 | +1209 | ! |
- if (!is.null(index) && !is.na(index) && length(index) > 0) selected_ix <- index+ labs + |
| 1030 | -+ | ||
| 1210 | +! |
- }+ ggthemes + |
|
| 1031 | -+ | ||
| 1211 | +! |
-
+ themes |
|
| 1032 | -+ | ||
| 1212 | +! |
- # Retrieve the index of the first item of the current page+ print(g) |
|
| 1033 | +1213 |
- # it works with varying number of entries on the page (10, 25, ...)+ }, |
|
| 1034 | +1214 | ! |
- table_id_sel <- paste0("variable_browser_", dataset_name, "_state")
+ env = list( |
| 1035 | +1215 | ! |
- dt_state <- isolate(input[[table_id_sel]])+ labs = parsed_ggplot2_args$labs, |
| 1036 | +1216 | ! |
- if (selected_ix != 1 && !is.null(dt_state)) {
+ themes = parsed_ggplot2_args$theme, |
| 1037 | +1217 | ! |
- selected_page_ix <- floor(selected_ix / dt_state$length) * dt_state$length+ ggthemes = parsed_ggplot2_args$ggtheme |
| 1038 | +1218 |
- }+ ) |
|
| 1039 | +1219 | ++ |
+ )+ |
+
| 1220 | ++ |
+ )+ |
+ |
| 1221 | ++ |
+ })+ |
+ |
| 1222 | |||
| 1040 | +1223 | ! |
- DT::datatable(+ by_subject_plot_r <- reactive(by_subject_plot_q()[["g"]]) |
| 1041 | -! | +||
| 1224 | +
- df_output,+ |
||
| 1042 | +1225 | ! |
- escape = FALSE,+ output$levels_table <- DT::renderDataTable( |
| 1043 | +1226 | ! |
- rownames = FALSE,+ expr = {
|
| 1044 | +1227 | ! |
- selection = list(mode = "single", target = "row", selected = selected_ix),+ if (length(input$variables_select) == 0) {
|
| 1045 | -! | +||
| 1228 | +
- options = list(+ # so that zeroRecords message gets printed |
||
| 1046 | -! | +||
| 1229 | +
- fnDrawCallback = htmlwidgets::JS("function() { HTMLWidgets.staticRender(); }"),
+ # using tibble as it supports weird column names, such as " " |
||
| 1047 | +1230 | ! |
- pageLength = input[[paste0(table_ui_id, "_rows")]],+ tibble::tibble(` ` = logical(0))+ |
+
| 1231 | ++ |
+ } else {
|
|
| 1048 | +1232 | ! |
- displayStart = selected_page_ix+ summary_table_r() |
| 1049 | +1233 |
- )+ } |
|
| 1050 | +1234 |
- )+ }, |
|
| 1051 | -+ | ||
| 1235 | +! |
- })+ options = list(language = list(zeroRecords = "No variable selected"), pageLength = input$levels_table_rows) |
|
| 1052 | +1236 |
- }+ ) |
|
| 1053 | +1237 | ||
| 1054 | -+ | ||
| 1238 | +! |
- #' Creates observers updating the currently selected column+ pws1 <- teal.widgets::plot_with_settings_srv( |
|
| 1055 | -+ | ||
| 1239 | +! |
- #'+ id = "summary_plot", |
|
| 1056 | -+ | ||
| 1240 | +! |
- #' The created observers update the column currently selected in the left-hand side+ plot_r = summary_plot_r, |
|
| 1057 | -+ | ||
| 1241 | +! |
- #' tabset panel.+ height = plot_height, |
|
| 1058 | -+ | ||
| 1242 | +! |
- #'+ width = plot_width |
|
| 1059 | +1243 |
- #' @note+ ) |
|
| 1060 | +1244 |
- #' Creates an observer for each dataset (each tab in the tabset panel).+ |
|
| 1061 | -+ | ||
| 1245 | +! |
- #'+ pws2 <- teal.widgets::plot_with_settings_srv( |
|
| 1062 | -+ | ||
| 1246 | +! |
- #' @inheritParams render_tabset_panel_content+ id = "combination_plot", |
|
| 1063 | -+ | ||
| 1247 | +! |
- #' @keywords internal+ plot_r = combination_plot_r, |
|
| 1064 | -+ | ||
| 1248 | +! |
- establish_updating_selection <- function(datanames, input, plot_var, columns_names) {
+ height = plot_height, |
|
| 1065 | +1249 | ! |
- lapply(datanames, function(dataset_name) {
+ width = plot_width+ |
+
| 1250 | ++ |
+ )+ |
+ |
| 1251 | ++ | + | |
| 1066 | +1252 | ! |
- table_ui_id <- paste0("variable_browser_", dataset_name)
+ pws3 <- teal.widgets::plot_with_settings_srv( |
| 1067 | +1253 | ! |
- table_id_sel <- paste0(table_ui_id, "_rows_selected")+ id = "by_subject_plot", |
| 1068 | +1254 | ! |
- observeEvent(input[[table_id_sel]], {
+ plot_r = by_subject_plot_r, |
| 1069 | +1255 | ! |
- plot_var$data <- dataset_name+ height = plot_height, |
| 1070 | +1256 | ! |
- plot_var$variable[[dataset_name]] <- columns_names[[dataset_name]][input[[table_id_sel]]]+ width = plot_width |
| 1071 | +1257 |
- })+ ) |
|
| 1072 | +1258 |
- })+ |
|
| 1073 | -+ | ||
| 1259 | +! |
- }+ final_q <- reactive({
|
|
| 1074 | -+ | ||
| 1260 | +! |
-
+ req(input$summary_type) |
|
| 1075 | -+ | ||
| 1261 | +! |
- get_bin_width <- function(x_vec, scaling_factor = 2) {
+ sum_type <- input$summary_type |
|
| 1076 | +1262 | ! |
- x_vec <- x_vec[!is.na(x_vec)]+ if (sum_type == "Summary") {
|
| 1077 | +1263 | ! |
- qntls <- stats::quantile(x_vec, probs = c(0.1, 0.25, 0.75, 0.9), type = 2)+ summary_plot_q() |
| 1078 | +1264 | ! |
- iqr <- qntls[3] - qntls[2]+ } else if (sum_type == "Combinations") {
|
| 1079 | +1265 | ! |
- binwidth <- max(scaling_factor * iqr / length(x_vec) ^ (1 / 3), sqrt(qntls[4] - qntls[1])) # styler: off+ combination_plot_q() |
| 1080 | +1266 | ! |
- binwidth <- ifelse(binwidth == 0, 1, binwidth)+ } else if (sum_type == "By Variable Levels") {
|
| 1081 | -+ | ||
| 1267 | +! |
- # to ensure at least two bins when variable span is very small+ summary_table_q() |
|
| 1082 | +1268 | ! |
- x_span <- diff(range(x_vec))+ } else if (sum_type == "Grouped by Subject") {
|
| 1083 | +1269 | ! |
- if (isTRUE(x_span / binwidth >= 2)) binwidth else x_span / 2+ by_subject_plot_q() |
| 1084 | +1270 |
- }+ } |
|
| 1085 | +1271 |
-
+ }) |
|
| 1086 | +1272 |
- #' Removes the outlier observation from an array+ |
|
| 1087 | -+ | ||
| 1273 | +! |
- #'+ teal.widgets::verbatim_popup_srv( |
|
| 1088 | -+ | ||
| 1274 | +! |
- #' @param var (`numeric`) a numeric vector+ id = "rcode", |
|
| 1089 | -+ | ||
| 1275 | +! |
- #' @param outlier_definition (`numeric`) if `0` then no outliers are removed, otherwise+ verbatim_content = reactive(teal.code::get_code(final_q())), |
|
| 1090 | -+ | ||
| 1276 | +! |
- #' outliers (those more than `outlier_definition*IQR below/above Q1/Q3`) are removed+ title = "Show R Code for Missing Data" |
|
| 1091 | +1277 |
- #' @returns (`numeric`) vector without the outlier values+ ) |
|
| 1092 | +1278 |
- #' @keywords internal+ |
|
| 1093 | +1279 |
- remove_outliers_from <- function(var, outlier_definition) {
+ ### REPORTER |
|
| 1094 | -3x | +||
| 1280 | +! |
- if (outlier_definition == 0) {
+ if (with_reporter) {
|
|
| 1095 | -1x | +||
| 1281 | +! |
- return(var)+ card_fun <- function(comment, label) {
|
|
| 1096 | -+ | ||
| 1282 | +! |
- }+ card <- teal::TealReportCard$new() |
|
| 1097 | -2x | +||
| 1283 | +! |
- q1_q3 <- stats::quantile(var, probs = c(0.25, 0.75), type = 2, na.rm = TRUE)+ sum_type <- input$summary_type |
|
| 1098 | -2x | +||
| 1284 | +! |
- iqr <- q1_q3[2] - q1_q3[1]+ title <- if (sum_type == "By Variable Levels") paste0(sum_type, " Table") else paste0(sum_type, " Plot") |
|
| 1099 | -2x | +||
| 1285 | +! |
- var[var >= q1_q3[1] - outlier_definition * iqr & var <= q1_q3[2] + outlier_definition * iqr]+ title_dataname <- paste(title, dataname, sep = " - ") |
|
| 1100 | -+ | ||
| 1286 | +! |
- }+ label <- if (label == "") {
|
|
| 1101 | -+ | ||
| 1287 | +! |
-
+ paste("Missing Data", sum_type, dataname, sep = " - ")
|
|
| 1102 | +1288 |
-
+ } else {
|
|
| 1103 | -+ | ||
| 1289 | +! |
- # sparklines ----+ label |
|
| 1104 | +1290 |
-
+ } |
|
| 1105 | -+ | ||
| 1291 | +! |
- #' S3 generic for `sparkline` widget HTML+ card$set_name(label) |
|
| 1106 | -+ | ||
| 1292 | +! |
- #'+ card$append_text(title_dataname, "header2") |
|
| 1107 | -+ | ||
| 1293 | +! |
- #' Generates the `sparkline` HTML code corresponding to the input array.+ if (with_filter) card$append_fs(filter_panel_api$get_filter_state()) |
|
| 1108 | -+ | ||
| 1294 | +! |
- #' For numeric variables creates a box plot, for character and factors - bar plot.+ if (sum_type == "Summary") {
|
|
| 1109 | -+ | ||
| 1295 | +! |
- #' Produces an empty string for variables of other types.+ card$append_text("Plot", "header3")
|
|
| 1110 | -+ | ||
| 1296 | +! |
- #'+ card$append_plot(summary_plot_r(), dim = pws1$dim()) |
|
| 1111 | -+ | ||
| 1297 | +! |
- #' @param arr vector of any type and length+ } else if (sum_type == "Combinations") {
|
|
| 1112 | -+ | ||
| 1298 | +! |
- #' @param width `numeric` the width of the `sparkline` widget (pixels)+ card$append_text("Plot", "header3")
|
|
| 1113 | -+ | ||
| 1299 | +! |
- #' @param bar_spacing `numeric` the spacing between the bars (in pixels)+ card$append_plot(combination_plot_r(), dim = pws2$dim()) |
|
| 1114 | -+ | ||
| 1300 | +! |
- #' @param bar_width `numeric` the width of the bars (in pixels)+ } else if (sum_type == "By Variable Levels") {
|
|
| 1115 | -+ | ||
| 1301 | +! |
- #' @param ... `list` additional options passed to bar plots of `jquery.sparkline`;+ card$append_text("Table", "header3")
|
|
| 1116 | -+ | ||
| 1302 | +! |
- #' see [`jquery.sparkline docs`](https://omnipotent.net/jquery.sparkline/#common)+ card$append_table(summary_table_r[["summary_data"]]) |
|
| 1117 | -+ | ||
| 1303 | +! |
- #'+ } else if (sum_type == "Grouped by Subject") {
|
|
| 1118 | -+ | ||
| 1304 | +! |
- #' @return Character string containing HTML code of the `sparkline` HTML widget.+ card$append_text("Plot", "header3")
|
|
| 1119 | -+ | ||
| 1305 | +! |
- #' @keywords internal+ card$append_plot(by_subject_plot_r(), dim = pws3$dim()) |
|
| 1120 | +1306 |
- create_sparklines <- function(arr, width = 150, ...) {
+ } |
|
| 1121 | +1307 | ! |
- if (all(is.null(arr))) {
+ if (!comment == "") {
|
| 1122 | +1308 | ! |
- return("")
+ card$append_text("Comment", "header3")
+ |
+
| 1309 | +! | +
+ card$append_text(comment) |
|
| 1123 | +1310 |
- }+ } |
|
| 1124 | +1311 | ! |
- UseMethod("create_sparklines")
+ card$append_src(teal.code::get_code(final_q())) |
| 1125 | -+ | ||
| 1312 | +! |
- }+ card |
|
| 1126 | +1313 |
-
+ }+ |
+ |
| 1314 | +! | +
+ teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
|
|
| 1127 | +1315 |
- #' @rdname create_sparklines+ } |
|
| 1128 | +1316 |
- #' @keywords internal+ ### |
|
| 1129 | +1317 |
- #' @export+ }) |
|
| 1130 | +1318 |
- create_sparklines.logical <- function(arr, ...) {
+ } |
|
| 1131 | -! | +
| 1 | +
- create_sparklines(as.factor(arr))+ #' `teal` module: Principal component analysis |
||
| 1132 | +2 |
- }+ #' |
|
| 1133 | +3 |
-
+ #' Module conducts principal component analysis (PCA) on a given dataset and offers different |
|
| 1134 | +4 |
- #' @rdname create_sparklines+ #' ways of visualizing the outcomes, including elbow plot, circle plot, biplot, and eigenvector plot. |
|
| 1135 | +5 |
- #' @keywords internal+ #' Additionally, it enables dynamic customization of plot aesthetics, such as opacity, size, and |
|
| 1136 | +6 |
- #' @export+ #' font size, through UI inputs. |
|
| 1137 | +7 |
- create_sparklines.numeric <- function(arr, width = 150, ...) {
+ #' |
|
| 1138 | -! | +||
| 8 | +
- if (any(is.infinite(arr))) {
+ #' @inheritParams teal::module |
||
| 1139 | -! | +||
| 9 | +
- return(as.character(tags$code("infinite values", class = "text-blue")))
+ #' @inheritParams shared_params |
||
| 1140 | +10 |
- }+ #' @param dat (`data_extract_spec` or `list` of multiple `data_extract_spec`) |
|
| 1141 | -! | +||
| 11 | +
- if (length(arr) > 100000) {
+ #' specifying columns used to compute PCA. |
||
| 1142 | -! | +||
| 12 | +
- return(as.character(tags$code("Too many rows (>100000)", class = "text-blue")))
+ #' @param font_size (`numeric`) optional, specifies font size. |
||
| 1143 | +13 |
- }+ #' It controls the font size for plot titles, axis labels, and legends. |
|
| 1144 | +14 |
-
+ #' - If vector of `length == 1` then the font sizes will have a fixed size. |
|
| 1145 | -! | +||
| 15 | +
- arr <- arr[!is.na(arr)]+ #' - while vector of `value`, `min`, and `max` allows dynamic adjustment. |
||
| 1146 | -! | +||
| 16 | +
- sparkline::spk_chr(unname(arr), type = "box", width = width, ...)+ #' @templateVar ggnames "Elbow plot", "Circle plot", "Biplot", "Eigenvector plot" |
||
| 1147 | +17 |
- }+ #' @template ggplot2_args_multi |
|
| 1148 | +18 |
-
+ #' |
|
| 1149 | +19 |
- #' @rdname create_sparklines+ #' @inherit shared_params return |
|
| 1150 | +20 |
- #' @keywords internal+ #' |
|
| 1151 | +21 |
- #' @export+ #' @examplesShinylive |
|
| 1152 | +22 |
- create_sparklines.character <- function(arr, ...) {
+ #' library(teal.modules.general) |
|
| 1153 | -! | +||
| 23 | +
- return(create_sparklines(as.factor(arr)))+ #' interactive <- function() TRUE |
||
| 1154 | +24 |
- }+ #' {{ next_example }}
|
|
| 1155 | +25 |
-
+ #' @examples |
|
| 1156 | +26 |
-
+ #' # general data example |
|
| 1157 | +27 |
- #' @rdname create_sparklines+ #' data <- teal_data() |
|
| 1158 | +28 |
- #' @keywords internal+ #' data <- within(data, {
|
|
| 1159 | +29 |
- #' @export+ #' require(nestcolor) |
|
| 1160 | +30 |
- create_sparklines.factor <- function(arr, width = 150, bar_spacing = 5, bar_width = 20, ...) {
+ #' USArrests <- USArrests |
|
| 1161 | -! | +||
| 31 | +
- decreasing_order <- TRUE+ #' }) |
||
| 1162 | +32 |
-
+ #' |
|
| 1163 | -! | +||
| 33 | +
- counts <- table(arr)+ #' app <- init( |
||
| 1164 | -! | +||
| 34 | +
- if (length(counts) >= 100) {
+ #' data = data, |
||
| 1165 | -! | +||
| 35 | +
- return(as.character(tags$code("> 99 levels", class = "text-blue")))
+ #' modules = modules( |
||
| 1166 | -! | +||
| 36 | +
- } else if (length(counts) == 0) {
+ #' tm_a_pca( |
||
| 1167 | -! | +||
| 37 | +
- return(as.character(tags$code("no levels", class = "text-blue")))
+ #' "PCA", |
||
| 1168 | -! | +||
| 38 | +
- } else if (length(counts) == 1) {
+ #' dat = data_extract_spec( |
||
| 1169 | -! | +||
| 39 | +
- return(as.character(tags$code("one level", class = "text-blue")))
+ #' dataname = "USArrests", |
||
| 1170 | +40 |
- }+ #' select = select_spec( |
|
| 1171 | +41 |
-
+ #' choices = variable_choices( |
|
| 1172 | +42 |
- # Summarize the occurences of different levels+ #' data = data[["USArrests"]], c("Murder", "Assault", "UrbanPop", "Rape")
|
|
| 1173 | +43 |
- # and get the maximum and minimum number of occurences+ #' ), |
|
| 1174 | +44 |
- # This is needed for the sparkline to correctly display the bar plots+ #' selected = c("Murder", "Assault"),
|
|
| 1175 | +45 |
- # Otherwise they are cropped+ #' multiple = TRUE |
|
| 1176 | -! | +||
| 46 | +
- counts <- sort(counts, decreasing = decreasing_order, method = "radix")+ #' ), |
||
| 1177 | -! | +||
| 47 | +
- max_value <- if (decreasing_order) counts[1] else counts[length[counts]]+ #' filter = NULL |
||
| 1178 | -! | +||
| 48 | +
- max_value <- unname(max_value)+ #' ) |
||
| 1179 | +49 |
-
+ #' ) |
|
| 1180 | -! | -
- sparkline::spk_chr(- |
- |
| 1181 | -! | +||
| 50 | +
- unname(counts),+ #' ) |
||
| 1182 | -! | +||
| 51 | +
- type = "bar",+ #' ) |
||
| 1183 | -! | +||
| 52 | +
- chartRangeMin = 0,+ #' if (interactive()) {
|
||
| 1184 | -! | +||
| 53 | +
- chartRangeMax = max_value,+ #' shinyApp(app$ui, app$server) |
||
| 1185 | -! | +||
| 54 | +
- width = width,+ #' } |
||
| 1186 | -! | +||
| 55 | +
- barWidth = bar_width,+ #' |
||
| 1187 | -! | +||
| 56 | +
- barSpacing = bar_spacing,+ #' @examplesShinylive |
||
| 1188 | -! | +||
| 57 | +
- tooltipFormatter = custom_sparkline_formatter(names(counts), as.vector(counts))+ #' library(teal.modules.general) |
||
| 1189 | +58 |
- )+ #' interactive <- function() TRUE |
|
| 1190 | +59 |
- }+ #' {{ next_example }}
|
|
| 1191 | +60 |
-
+ #' @examples |
|
| 1192 | +61 |
- #' @rdname create_sparklines+ #' # CDISC data example |
|
| 1193 | +62 |
- #' @keywords internal+ #' data <- teal_data() |
|
| 1194 | +63 |
- #' @export+ #' data <- within(data, {
|
|
| 1195 | +64 |
- create_sparklines.Date <- function(arr, width = 150, bar_spacing = 5, bar_width = 20, ...) {
+ #' require(nestcolor) |
|
| 1196 | -! | +||
| 65 | +
- arr_num <- as.numeric(arr)+ #' ADSL <- rADSL |
||
| 1197 | -! | +||
| 66 | +
- arr_num <- sort(arr_num, decreasing = FALSE, method = "radix")+ #' }) |
||
| 1198 | -! | +||
| 67 | +
- binwidth <- get_bin_width(arr_num, 1)+ #' join_keys(data) <- default_cdisc_join_keys[names(data)] |
||
| 1199 | -! | +||
| 68 | +
- bins <- floor(diff(range(arr_num)) / binwidth) + 1+ #' |
||
| 1200 | -! | +||
| 69 | +
- if (all(is.na(bins))) {
+ #' app <- init( |
||
| 1201 | -! | +||
| 70 | +
- return(as.character(tags$code("only NA", class = "text-blue")))
+ #' data = data, |
||
| 1202 | -! | +||
| 71 | +
- } else if (bins == 1) {
+ #' modules = modules( |
||
| 1203 | -! | +||
| 72 | +
- return(as.character(tags$code("one date", class = "text-blue")))
+ #' tm_a_pca( |
||
| 1204 | +73 |
- }+ #' "PCA", |
|
| 1205 | -! | +||
| 74 | +
- counts <- as.vector(unname(base::table(cut(arr_num, breaks = bins))))+ #' dat = data_extract_spec( |
||
| 1206 | -! | +||
| 75 | +
- max_value <- max(counts)+ #' dataname = "ADSL", |
||
| 1207 | +76 |
-
+ #' select = select_spec( |
|
| 1208 | -! | +||
| 77 | +
- start_bins <- as.integer(seq(1, length(arr_num), length.out = bins))+ #' choices = variable_choices( |
||
| 1209 | -! | +||
| 78 | +
- labels_start <- as.character(as.Date(arr_num[start_bins], origin = as.Date("1970-01-01")))
+ #' data = data[["ADSL"]], c("BMRKR1", "AGE", "EOSDY")
|
||
| 1210 | -! | +||
| 79 | +
- labels <- paste("Start:", labels_start)
+ #' ), |
||
| 1211 | +80 |
-
+ #' selected = c("BMRKR1", "AGE"),
|
|
| 1212 | -! | +||
| 81 | +
- sparkline::spk_chr(+ #' multiple = TRUE |
||
| 1213 | -! | +||
| 82 | +
- unname(counts),+ #' ), |
||
| 1214 | -! | +||
| 83 | +
- type = "bar",+ #' filter = NULL |
||
| 1215 | -! | +||
| 84 | +
- chartRangeMin = 0,+ #' ) |
||
| 1216 | -! | +||
| 85 | +
- chartRangeMax = max_value,+ #' ) |
||
| 1217 | -! | +||
| 86 | +
- width = width,+ #' ) |
||
| 1218 | -! | +||
| 87 | +
- barWidth = bar_width,+ #' ) |
||
| 1219 | -! | +||
| 88 | +
- barSpacing = bar_spacing,+ #' if (interactive()) {
|
||
| 1220 | -! | +||
| 89 | +
- tooltipFormatter = custom_sparkline_formatter(labels, counts)+ #' shinyApp(app$ui, app$server) |
||
| 1221 | +90 |
- )+ #' } |
|
| 1222 | +91 |
- }+ #' |
|
| 1223 | +92 |
-
+ #' @export |
|
| 1224 | +93 |
- #' @rdname create_sparklines+ #' |
|
| 1225 | +94 |
- #' @keywords internal+ tm_a_pca <- function(label = "Principal Component Analysis", |
|
| 1226 | +95 |
- #' @export+ dat, |
|
| 1227 | +96 |
- create_sparklines.POSIXct <- function(arr, width = 150, bar_spacing = 5, bar_width = 20, ...) {
+ plot_height = c(600, 200, 2000), |
|
| 1228 | -! | +||
| 97 | +
- arr_num <- as.numeric(arr)+ plot_width = NULL, |
||
| 1229 | -! | +||
| 98 | +
- arr_num <- sort(arr_num, decreasing = FALSE, method = "radix")+ ggtheme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void"),
|
||
| 1230 | -! | +||
| 99 | +
- binwidth <- get_bin_width(arr_num, 1)+ ggplot2_args = teal.widgets::ggplot2_args(), |
||
| 1231 | -! | +||
| 100 | +
- bins <- floor(diff(range(arr_num)) / binwidth) + 1+ rotate_xaxis_labels = FALSE, |
||
| 1232 | -! | +||
| 101 | +
- if (all(is.na(bins))) {
+ font_size = c(12, 8, 20), |
||
| 1233 | -! | +||
| 102 | +
- return(as.character(tags$code("only NA", class = "text-blue")))
+ alpha = c(1, 0, 1), |
||
| 1234 | -! | +||
| 103 | +
- } else if (bins == 1) {
+ size = c(2, 1, 8), |
||
| 1235 | -! | +||
| 104 | +
- return(as.character(tags$code("one date-time", class = "text-blue")))
+ pre_output = NULL, |
||
| 1236 | +105 |
- }+ post_output = NULL) {
|
|
| 1237 | +106 | ! |
- counts <- as.vector(unname(base::table(cut(arr_num, breaks = bins))))+ message("Initializing tm_a_pca")
|
| 1238 | -! | +||
| 107 | +
- max_value <- max(counts)+ |
||
| 1239 | +108 |
-
+ # Normalize the parameters |
|
| 1240 | +109 | ! |
- start_bins <- as.integer(seq(1, length(arr_num), length.out = bins))+ if (inherits(dat, "data_extract_spec")) dat <- list(dat) |
| 1241 | +110 | ! |
- labels_start <- as.character(format(as.POSIXct(arr_num[start_bins], origin = as.Date("1970-01-01")), "%Y-%m-%d"))
+ if (inherits(ggplot2_args, "ggplot2_args")) ggplot2_args <- list(default = ggplot2_args) |
| 1242 | -! | +||
| 111 | +
- labels <- paste("Start:", labels_start)
+
|
||
| 1243 | +112 |
-
+ # Start of assertions |
|
| 1244 | +113 | ! |
- sparkline::spk_chr(+ checkmate::assert_string(label) |
| 1245 | +114 | ! |
- unname(counts),+ checkmate::assert_list(dat, types = "data_extract_spec") |
| 1246 | -! | +||
| 115 | +
- type = "bar",+ |
||
| 1247 | +116 | ! |
- chartRangeMin = 0,+ checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE) |
| 1248 | +117 | ! |
- chartRangeMax = max_value,+ checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height") |
| 1249 | +118 | ! |
- width = width,+ checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE) |
| 1250 | +119 | ! |
- barWidth = bar_width,+ checkmate::assert_numeric( |
| 1251 | +120 | ! |
- barSpacing = bar_spacing,+ plot_width[1], |
| 1252 | +121 | ! |
- tooltipFormatter = custom_sparkline_formatter(labels, counts)+ lower = plot_width[2], upper = plot_width[3], null.ok = TRUE, .var.name = "plot_width" |
| 1253 | +122 |
) |
|
| 1254 | +123 |
- }+ + |
+ |
| 124 | +! | +
+ ggtheme <- match.arg(ggtheme) |
|
| 1255 | +125 | ||
| 1256 | -+ | ||
| 126 | +! |
- #' @rdname create_sparklines+ plot_choices <- c("Elbow plot", "Circle plot", "Biplot", "Eigenvector plot")
|
|
| 1257 | -+ | ||
| 127 | +! |
- #' @keywords internal+ checkmate::assert_list(ggplot2_args, types = "ggplot2_args") |
|
| 1258 | -+ | ||
| 128 | +! |
- #' @export+ checkmate::assert_subset(names(ggplot2_args), c("default", plot_choices))
|
|
| 1259 | +129 |
- create_sparklines.POSIXlt <- function(arr, width = 150, bar_spacing = 5, bar_width = 20, ...) {
+
|
|
| 1260 | +130 | ! |
- arr_num <- as.numeric(arr)+ checkmate::assert_flag(rotate_xaxis_labels) |
| 1261 | -! | +||
| 131 | +
- arr_num <- sort(arr_num, decreasing = FALSE, method = "radix")+ |
||
| 1262 | +132 | ! |
- binwidth <- get_bin_width(arr_num, 1)+ if (length(font_size) == 1) {
|
| 1263 | +133 | ! |
- bins <- floor(diff(range(arr_num)) / binwidth) + 1+ checkmate::assert_numeric(font_size, any.missing = FALSE, finite = TRUE, lower = 8, upper = 20) |
| 1264 | -! | +||
| 134 | +
- if (all(is.na(bins))) {
+ } else {
|
||
| 1265 | +135 | ! |
- return(as.character(tags$code("only NA", class = "text-blue")))
+ checkmate::assert_numeric(font_size, len = 3, any.missing = FALSE, finite = TRUE, lower = 8, upper = 20) |
| 1266 | +136 | ! |
- } else if (bins == 1) {
+ checkmate::assert_numeric(font_size[1], lower = font_size[2], upper = font_size[3], .var.name = "font_size") |
| 1267 | -! | +||
| 137 | +
- return(as.character(tags$code("one date-time", class = "text-blue")))
+ } |
||
| 1268 | +138 |
- }+ |
|
| 1269 | +139 | ! |
- counts <- as.vector(unname(base::table(cut(arr_num, breaks = bins))))+ if (length(alpha) == 1) {
|
| 1270 | +140 | ! |
- max_value <- max(counts)+ checkmate::assert_numeric(alpha, any.missing = FALSE, finite = TRUE, lower = 0, upper = 1) |
| 1271 | +141 |
-
+ } else {
|
|
| 1272 | +142 | ! |
- start_bins <- as.integer(seq(1, length(arr_num), length.out = bins))+ checkmate::assert_numeric(alpha, len = 3, any.missing = FALSE, finite = TRUE, lower = 0, upper = 1) |
| 1273 | +143 | ! |
- labels_start <- as.character(format(as.POSIXct(arr_num[start_bins], origin = as.Date("1970-01-01")), "%Y-%m-%d"))
+ checkmate::assert_numeric(alpha[1], lower = alpha[2], upper = alpha[3], .var.name = "alpha") |
| 1274 | -! | +||
| 144 | +
- labels <- paste("Start:", labels_start)
+ } |
||
| 1275 | +145 | ||
| 1276 | +146 | ! |
- sparkline::spk_chr(+ if (length(size) == 1) {
|
| 1277 | +147 | ! |
- unname(counts),+ checkmate::assert_numeric(size, any.missing = FALSE, finite = TRUE, lower = 1, upper = 8) |
| 1278 | -! | +||
| 148 | +
- type = "bar",+ } else {
|
||
| 1279 | +149 | ! |
- chartRangeMin = 0,+ checkmate::assert_numeric(size, len = 3, any.missing = FALSE, finite = TRUE, lower = 1, upper = 8) |
| 1280 | +150 | ! |
- chartRangeMax = max_value,+ checkmate::assert_numeric(size[1], lower = size[2], upper = size[3], .var.name = "size") |
| 1281 | -! | +||
| 151 | +
- width = width,+ } |
||
| 1282 | -! | +||
| 152 | +
- barWidth = bar_width,+ |
||
| 1283 | +153 | ! |
- barSpacing = bar_spacing,+ checkmate::assert_multi_class(pre_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
|
| 1284 | +154 | ! |
- tooltipFormatter = custom_sparkline_formatter(labels, counts)+ checkmate::assert_multi_class(post_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
|
| 1285 | +155 |
- )+ # End of assertions |
|
| 1286 | +156 |
- }+ |
|
| 1287 | +157 |
-
+ # Make UI args |
|
| 1288 | -+ | ||
| 158 | +! |
- #' @rdname create_sparklines+ args <- as.list(environment()) |
|
| 1289 | +159 |
- #' @keywords internal+ |
|
| 1290 | -+ | ||
| 160 | +! |
- #' @export+ data_extract_list <- list(dat = dat) |
|
| 1291 | +161 |
- create_sparklines.default <- function(arr, width = 150, ...) {
+
|
|
| 1292 | +162 | ! |
- as.character(tags$code("unsupported variable type", class = "text-blue"))
- |
-
| 1293 | -- |
- }+ ans <- module( |
|
| 1294 | -+ | ||
| 163 | +! |
-
+ label = label, |
|
| 1295 | -+ | ||
| 164 | +! |
-
+ server = srv_a_pca, |
|
| 1296 | -+ | ||
| 165 | +! |
- custom_sparkline_formatter <- function(labels, counts) {
+ ui = ui_a_pca, |
|
| 1297 | +166 | ! |
- htmlwidgets::JS(+ ui_args = args, |
| 1298 | +167 | ! |
- sprintf(+ server_args = c( |
| 1299 | +168 | ! |
- "function(sparkline, options, field) {
+ data_extract_list, |
| 1300 | +169 | ! |
- return 'ID: ' + %s[field[0].offset] + '<br>' + 'Count: ' + %s[field[0].offset];+ list( |
| 1301 | -+ | ||
| 170 | +! |
- }",+ plot_height = plot_height, |
|
| 1302 | +171 | ! |
- jsonlite::toJSON(labels),+ plot_width = plot_width, |
| 1303 | +172 | ! |
- jsonlite::toJSON(counts)+ ggplot2_args = ggplot2_args |
| 1304 | +173 |
- )+ ) |
|
| 1305 | +174 |
- )+ ), |
|
| 1306 | -+ | ||
| 175 | +! |
- }+ datanames = teal.transform::get_extract_datanames(data_extract_list) |
| 1 | +176 |
- #' `teal` module: Outliers analysis+ ) |
|
| 2 | -+ | ||
| 177 | +! |
- #'+ attr(ans, "teal_bookmarkable") <- FALSE |
|
| 3 | -+ | ||
| 178 | +! |
- #' Module to analyze and identify outliers using different methods+ ans |
|
| 4 | +179 |
- #' such as IQR, Z-score, and Percentiles, and offers visualizations including+ } |
|
| 5 | +180 |
- #' box plots, density plots, and cumulative distribution plots to help interpret the outliers.+ |
|
| 6 | +181 |
- #'+ # UI function for the PCA module |
|
| 7 | +182 |
- #' @inheritParams teal::module+ ui_a_pca <- function(id, ...) {
|
|
| 8 | -+ | ||
| 183 | +! |
- #' @inheritParams shared_params+ ns <- NS(id) |
|
| 9 | -+ | ||
| 184 | +! |
- #'+ args <- list(...) |
|
| 10 | -+ | ||
| 185 | +! |
- #' @param outlier_var (`data_extract_spec` or `list` of multiple `data_extract_spec`)+ is_single_dataset_value <- teal.transform::is_single_dataset(args$dat) |
|
| 11 | +186 |
- #' Specifies variable(s) to be analyzed for outliers.+ |
|
| 12 | -+ | ||
| 187 | +! |
- #' @param categorical_var (`data_extract_spec` or `list` of multiple `data_extract_spec`) optional,+ color_selector <- args$dat |
|
| 13 | -+ | ||
| 188 | +! |
- #' specifies the categorical variable(s) to split the selected outlier variables on.+ for (i in seq_along(color_selector)) {
|
|
| 14 | -+ | ||
| 189 | +! |
- #'+ color_selector[[i]]$select$multiple <- FALSE |
|
| 15 | -+ | ||
| 190 | +! |
- #' @templateVar ggnames "Boxplot","Density Plot","Cumulative Distribution Plot"+ color_selector[[i]]$select$always_selected <- NULL |
|
| 16 | -+ | ||
| 191 | +! |
- #' @template ggplot2_args_multi+ color_selector[[i]]$select$selected <- NULL |
|
| 17 | +192 |
- #'+ } |
|
| 18 | +193 |
- #' @inherit shared_params return+ |
|
| 19 | -+ | ||
| 194 | +! |
- #'+ tagList( |
|
| 20 | -+ | ||
| 195 | +! |
- #' @examplesShinylive+ include_css_files("custom"),
|
|
| 21 | -+ | ||
| 196 | +! |
- #' library(teal.modules.general)+ teal.widgets::standard_layout( |
|
| 22 | -+ | ||
| 197 | +! |
- #' interactive <- function() TRUE+ output = teal.widgets::white_small_well( |
|
| 23 | -+ | ||
| 198 | +! |
- #' {{ next_example }}
+ uiOutput(ns("all_plots"))
|
|
| 24 | +199 |
- #' @examples+ ), |
|
| 25 | -+ | ||
| 200 | +! |
- #' # general data example+ encoding = tags$div( |
|
| 26 | +201 |
- #' data <- teal_data()+ ### Reporter |
|
| 27 | -+ | ||
| 202 | +! |
- #' data <- within(data, {
+ teal.reporter::simple_reporter_ui(ns("simple_reporter")),
|
|
| 28 | +203 |
- #' CO2 <- CO2+ ### |
|
| 29 | -+ | ||
| 204 | +! |
- #' CO2[["primary_key"]] <- seq_len(nrow(CO2))+ tags$label("Encodings", class = "text-primary"),
|
|
| 30 | -+ | ||
| 205 | +! |
- #' })+ teal.transform::datanames_input(args["dat"]), |
|
| 31 | -+ | ||
| 206 | +! |
- #' datanames(data) <- "CO2"+ teal.transform::data_extract_ui( |
|
| 32 | -+ | ||
| 207 | +! |
- #' join_keys(data) <- join_keys(join_key("CO2", "CO2", "primary_key"))
+ id = ns("dat"),
|
|
| 33 | -+ | ||
| 208 | +! |
- #'+ label = "Data selection", |
|
| 34 | -+ | ||
| 209 | +! |
- #' vars <- choices_selected(variable_choices(data[["CO2"]], c("Plant", "Type", "Treatment")))
+ data_extract_spec = args$dat, |
|
| 35 | -+ | ||
| 210 | +! |
- #'+ is_single_dataset = is_single_dataset_value |
|
| 36 | +211 |
- #' app <- init(+ ), |
|
| 37 | -+ | ||
| 212 | +! |
- #' data = data,+ teal.widgets::panel_group( |
|
| 38 | -+ | ||
| 213 | +! |
- #' modules = modules(+ teal.widgets::panel_item( |
|
| 39 | -+ | ||
| 214 | +! |
- #' tm_outliers(+ title = "Display", |
|
| 40 | -+ | ||
| 215 | +! |
- #' outlier_var = list(+ collapsed = FALSE, |
|
| 41 | -+ | ||
| 216 | +! |
- #' data_extract_spec(+ checkboxGroupInput( |
|
| 42 | -+ | ||
| 217 | +! |
- #' dataname = "CO2",+ ns("tables_display"),
|
|
| 43 | -+ | ||
| 218 | +! |
- #' select = select_spec(+ "Tables display", |
|
| 44 | -+ | ||
| 219 | +! |
- #' label = "Select variable:",+ choices = c("PC importance" = "importance", "Eigenvectors" = "eigenvector"),
|
|
| 45 | -+ | ||
| 220 | +! |
- #' choices = variable_choices(data[["CO2"]], c("conc", "uptake")),
+ selected = c("importance", "eigenvector")
|
|
| 46 | +221 |
- #' selected = "uptake",+ ), |
|
| 47 | -+ | ||
| 222 | +! |
- #' multiple = FALSE,+ radioButtons( |
|
| 48 | -+ | ||
| 223 | +! |
- #' fixed = FALSE+ ns("plot_type"),
|
|
| 49 | -+ | ||
| 224 | +! |
- #' )+ label = "Plot type", |
|
| 50 | -+ | ||
| 225 | +! |
- #' )+ choices = args$plot_choices, |
|
| 51 | -+ | ||
| 226 | +! |
- #' ),+ selected = args$plot_choices[1] |
|
| 52 | +227 |
- #' categorical_var = list(+ ) |
|
| 53 | +228 |
- #' data_extract_spec(+ ), |
|
| 54 | -+ | ||
| 229 | +! |
- #' dataname = "CO2",+ teal.widgets::panel_item( |
|
| 55 | -+ | ||
| 230 | +! |
- #' filter = filter_spec(+ title = "Pre-processing", |
|
| 56 | -+ | ||
| 231 | +! |
- #' vars = vars,+ radioButtons( |
|
| 57 | -+ | ||
| 232 | +! |
- #' choices = value_choices(data[["CO2"]], vars$selected),+ ns("standardization"), "Standardization",
|
|
| 58 | -+ | ||
| 233 | +! |
- #' selected = value_choices(data[["CO2"]], vars$selected),+ choices = c("None" = "none", "Center" = "center", "Center & Scale" = "center_scale"),
|
|
| 59 | -+ | ||
| 234 | +! |
- #' multiple = TRUE+ selected = "center_scale" |
|
| 60 | +235 |
- #' )+ ), |
|
| 61 | -+ | ||
| 236 | +! |
- #' )+ radioButtons( |
|
| 62 | -+ | ||
| 237 | +! |
- #' )+ ns("na_action"), "NA action",
|
|
| 63 | -+ | ||
| 238 | +! |
- #' )+ choices = c("None" = "none", "Drop" = "drop"),
|
|
| 64 | -+ | ||
| 239 | +! |
- #' )+ selected = "none" |
|
| 65 | +240 |
- #' )+ ) |
|
| 66 | +241 |
- #' if (interactive()) {
+ ), |
|
| 67 | -+ | ||
| 242 | +! |
- #' shinyApp(app$ui, app$server)+ teal.widgets::panel_item( |
|
| 68 | -+ | ||
| 243 | +! |
- #' }+ title = "Selected plot specific settings", |
|
| 69 | -+ | ||
| 244 | +! |
- #'+ collapsed = FALSE, |
|
| 70 | -+ | ||
| 245 | +! |
- #' @examplesShinylive+ uiOutput(ns("plot_settings")),
|
|
| 71 | -+ | ||
| 246 | +! |
- #' library(teal.modules.general)+ conditionalPanel( |
|
| 72 | -+ | ||
| 247 | +! |
- #' interactive <- function() TRUE+ condition = sprintf("input['%s'] == 'Biplot'", ns("plot_type")),
|
|
| 73 | -+ | ||
| 248 | +! |
- #' {{ next_example }}
+ list( |
|
| 74 | -+ | ||
| 249 | +! |
- #' @examples+ teal.transform::data_extract_ui( |
|
| 75 | -+ | ||
| 250 | +! |
- #' # CDISC data example+ id = ns("response"),
|
|
| 76 | -+ | ||
| 251 | +! |
- #' data <- teal_data()+ label = "Color by", |
|
| 77 | -+ | ||
| 252 | +! |
- #' data <- within(data, {
+ data_extract_spec = color_selector, |
|
| 78 | -+ | ||
| 253 | +! |
- #' ADSL <- rADSL+ is_single_dataset = is_single_dataset_value |
|
| 79 | +254 |
- #' })+ ), |
|
| 80 | -+ | ||
| 255 | +! |
- #' datanames(data) <- "ADSL"+ teal.widgets::optionalSliderInputValMinMax(ns("alpha"), "Opacity:", args$alpha, ticks = FALSE),
|
|
| 81 | -+ | ||
| 256 | +! |
- #' join_keys(data) <- default_cdisc_join_keys[datanames(data)]+ teal.widgets::optionalSliderInputValMinMax(ns("size"), "Points size:", args$size, ticks = FALSE)
|
|
| 82 | +257 |
- #'+ ) |
|
| 83 | +258 |
- #' fact_vars_adsl <- names(Filter(isTRUE, sapply(data[["ADSL"]], is.factor)))+ ) |
|
| 84 | +259 |
- #' vars <- choices_selected(variable_choices(data[["ADSL"]], fact_vars_adsl))+ ), |
|
| 85 | -+ | ||
| 260 | +! |
- #'+ teal.widgets::panel_item( |
|
| 86 | -+ | ||
| 261 | +! |
- #' app <- init(+ title = "Plot settings", |
|
| 87 | -+ | ||
| 262 | +! |
- #' data = data,+ collapsed = TRUE, |
|
| 88 | -+ | ||
| 263 | +! |
- #' modules = modules(+ conditionalPanel( |
|
| 89 | -+ | ||
| 264 | +! |
- #' tm_outliers(+ condition = sprintf( |
|
| 90 | -+ | ||
| 265 | +! |
- #' outlier_var = list(+ "input['%s'] == 'Elbow plot' || input['%s'] == 'Eigenvector plot'", |
|
| 91 | -+ | ||
| 266 | +! |
- #' data_extract_spec(+ ns("plot_type"),
|
|
| 92 | -+ | ||
| 267 | +! |
- #' dataname = "ADSL",+ ns("plot_type")
|
|
| 93 | +268 |
- #' select = select_spec(+ ), |
|
| 94 | -+ | ||
| 269 | +! |
- #' label = "Select variable:",+ list(checkboxInput(ns("rotate_xaxis_labels"), "Rotate X axis labels", value = args$rotate_xaxis_labels))
|
|
| 95 | +270 |
- #' choices = variable_choices(data[["ADSL"]], c("AGE", "BMRKR1")),
+ ), |
|
| 96 | -+ | ||
| 271 | +! |
- #' selected = "AGE",+ selectInput( |
|
| 97 | -+ | ||
| 272 | +! |
- #' multiple = FALSE,+ inputId = ns("ggtheme"),
|
|
| 98 | -+ | ||
| 273 | +! |
- #' fixed = FALSE+ label = "Theme (by ggplot):", |
|
| 99 | -+ | ||
| 274 | +! |
- #' )+ choices = ggplot_themes, |
|
| 100 | -+ | ||
| 275 | +! |
- #' )+ selected = args$ggtheme, |
|
| 101 | -+ | ||
| 276 | +! |
- #' ),+ multiple = FALSE |
|
| 102 | +277 |
- #' categorical_var = list(+ ), |
|
| 103 | -+ | ||
| 278 | +! |
- #' data_extract_spec(+ teal.widgets::optionalSliderInputValMinMax(ns("font_size"), "Font Size", args$font_size, ticks = FALSE)
|
|
| 104 | +279 |
- #' dataname = "ADSL",+ ) |
|
| 105 | +280 |
- #' filter = filter_spec(+ ) |
|
| 106 | +281 |
- #' vars = vars,+ ), |
|
| 107 | -+ | ||
| 282 | +! |
- #' choices = value_choices(data[["ADSL"]], vars$selected),+ forms = tagList( |
|
| 108 | -+ | ||
| 283 | +! |
- #' selected = value_choices(data[["ADSL"]], vars$selected),+ teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code")
|
|
| 109 | +284 |
- #' multiple = TRUE+ ), |
|
| 110 | -+ | ||
| 285 | +! |
- #' )+ pre_output = args$pre_output, |
|
| 111 | -+ | ||
| 286 | +! |
- #' )+ post_output = args$post_output |
|
| 112 | +287 |
- #' )+ ) |
|
| 113 | +288 |
- #' )+ ) |
|
| 114 | +289 |
- #' )+ } |
|
| 115 | +290 |
- #' )+ |
|
| 116 | -- |
- #' if (interactive()) {
- |
- |
| 117 | -- |
- #' shinyApp(app$ui, app$server)- |
- |
| 118 | +291 |
- #' }+ # Server function for the PCA module |
|
| 119 | +292 |
- #'+ srv_a_pca <- function(id, data, reporter, filter_panel_api, dat, plot_height, plot_width, ggplot2_args) {
|
|
| 120 | -+ | ||
| 293 | +! |
- #' @export+ with_reporter <- !missing(reporter) && inherits(reporter, "Reporter") |
|
| 121 | -+ | ||
| 294 | +! |
- #'+ with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI") |
|
| 122 | -+ | ||
| 295 | +! |
- tm_outliers <- function(label = "Outliers Module",+ checkmate::assert_class(data, "reactive") |
|
| 123 | -+ | ||
| 296 | +! |
- outlier_var,+ checkmate::assert_class(isolate(data()), "teal_data") |
|
| 124 | -+ | ||
| 297 | +! |
- categorical_var = NULL,+ moduleServer(id, function(input, output, session) {
|
|
| 125 | -+ | ||
| 298 | +! |
- ggtheme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void"),
+ teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.general") |
|
| 126 | +299 |
- ggplot2_args = teal.widgets::ggplot2_args(),+ |
|
| 127 | -+ | ||
| 300 | +! |
- plot_height = c(600, 200, 2000),+ response <- dat |
|
| 128 | +301 |
- plot_width = NULL,+ |
|
| 129 | -+ | ||
| 302 | +! |
- pre_output = NULL,+ for (i in seq_along(response)) {
|
|
| 130 | -+ | ||
| 303 | +! |
- post_output = NULL) {
+ response[[i]]$select$multiple <- FALSE |
|
| 131 | +304 | ! |
- message("Initializing tm_outliers")
+ response[[i]]$select$always_selected <- NULL |
| 132 | -+ | ||
| 305 | +! |
-
+ response[[i]]$select$selected <- NULL |
|
| 133 | -+ | ||
| 306 | +! |
- # Normalize the parameters+ all_cols <- teal.data::col_labels(isolate(data())[[response[[i]]$dataname]]) |
|
| 134 | +307 | ! |
- if (inherits(outlier_var, "data_extract_spec")) outlier_var <- list(outlier_var)+ ignore_cols <- unlist(teal.data::join_keys(isolate(data()))[[response[[i]]$dataname]]) |
| 135 | +308 | ! |
- if (inherits(categorical_var, "data_extract_spec")) categorical_var <- list(categorical_var)+ color_cols <- all_cols[!names(all_cols) %in% ignore_cols] |
| 136 | +309 | ! |
- if (inherits(ggplot2_args, "ggplot2_args")) ggplot2_args <- list(default = ggplot2_args)+ response[[i]]$select$choices <- teal.transform::choices_labeled(names(color_cols), color_cols) |
| 137 | +310 |
-
+ } |
|
| 138 | +311 |
- # Start of assertions+ |
|
| 139 | +312 | ! |
- checkmate::assert_string(label)+ selector_list <- teal.transform::data_extract_multiple_srv( |
| 140 | +313 | ! |
- checkmate::assert_list(outlier_var, types = "data_extract_spec")+ data_extract = list(dat = dat, response = response), |
| 141 | -+ | ||
| 314 | +! |
-
+ datasets = data, |
|
| 142 | +315 | ! |
- checkmate::assert_list(categorical_var, types = "data_extract_spec", null.ok = TRUE)+ select_validation_rule = list( |
| 143 | +316 | ! |
- if (is.list(categorical_var)) {
+ dat = ~ if (length(.) < 2L) "Please select more than 1 variable to perform PCA.", |
| 144 | +317 | ! |
- lapply(categorical_var, function(x) {
+ response = shinyvalidate::compose_rules( |
| 145 | +318 | ! |
- if (length(x$filter) > 1L) {
+ shinyvalidate::sv_optional(), |
| 146 | +319 | ! |
- stop("tm_outliers: categorical_var data_extract_specs may only specify one filter_spec", call. = FALSE)
+ ~ if (isTRUE(is.element(., selector_list()$dat()$select))) {
|
| 147 | -+ | ||
| 320 | +! |
- }+ "Response must not have been used for PCA." |
|
| 148 | +321 |
- })+ } |
|
| 149 | +322 |
- }+ ) |
|
| 150 | +323 |
-
+ ) |
|
| 151 | -! | +||
| 324 | +
- ggtheme <- match.arg(ggtheme)+ ) |
||
| 152 | +325 | ||
| 153 | +326 | ! |
- plot_choices <- c("Boxplot", "Density Plot", "Cumulative Distribution Plot")
+ iv_r <- reactive({
|
| 154 | +327 | ! |
- checkmate::assert_list(ggplot2_args, types = "ggplot2_args")+ iv <- shinyvalidate::InputValidator$new() |
| 155 | +328 | ! |
- checkmate::assert_subset(names(ggplot2_args), c("default", plot_choices))
+ teal.transform::compose_and_enable_validators(iv, selector_list) |
| 156 | +329 | ++ |
+ })+ |
+
| 330 | |||
| 157 | +331 | ! |
- checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE)+ iv_extra <- shinyvalidate::InputValidator$new() |
| 158 | +332 | ! |
- checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height")+ iv_extra$add_rule("x_axis", function(value) {
|
| 159 | +333 | ! |
- checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE)+ if (isTRUE(input$plot_type %in% c("Circle plot", "Biplot"))) {
|
| 160 | +334 | ! |
- checkmate::assert_numeric(+ if (!shinyvalidate::input_provided(value)) {
|
| 161 | +335 | ! |
- plot_width[1],+ "Need X axis" |
| 162 | -! | +||
| 336 | +
- lower = plot_width[2], upper = plot_width[3], null.ok = TRUE, .var.name = "plot_width"+ } |
||
| 163 | +337 |
- )+ } |
|
| 164 | +338 |
-
+ }) |
|
| 165 | +339 | ! |
- checkmate::assert_multi_class(pre_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
+ iv_extra$add_rule("y_axis", function(value) {
|
| 166 | +340 | ! |
- checkmate::assert_multi_class(post_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
+ if (isTRUE(input$plot_type %in% c("Circle plot", "Biplot"))) {
+ |
+
| 341 | +! | +
+ if (!shinyvalidate::input_provided(value)) {
+ |
+ |
| 342 | +! | +
+ "Need Y axis" |
|
| 167 | +343 |
- # End of assertions+ } |
|
| 168 | +344 |
-
+ } |
|
| 169 | +345 |
- # Make UI args+ }) |
|
| 170 | +346 | ! |
- args <- as.list(environment())+ rule_dupl <- function(...) {
|
| 171 | -+ | ||
| 347 | +! |
-
+ if (isTRUE(input$plot_type %in% c("Circle plot", "Biplot"))) {
|
|
| 172 | +348 | ! |
- data_extract_list <- list(+ if (isTRUE(input$x_axis == input$y_axis)) {
|
| 173 | +349 | ! |
- outlier_var = outlier_var,+ "Please choose different X and Y axes." |
| 174 | -! | +||
| 350 | +
- categorical_var = categorical_var+ } |
||
| 175 | +351 |
- )+ } |
|
| 176 | +352 |
-
+ } |
|
| 177 | +353 | ! |
- ans <- module(+ iv_extra$add_rule("x_axis", rule_dupl)
|
| 178 | +354 | ! |
- label = label,+ iv_extra$add_rule("y_axis", rule_dupl)
|
| 179 | +355 | ! |
- server = srv_outliers,+ iv_extra$add_rule("variables", function(value) {
|
| 180 | +356 | ! |
- server_args = c(+ if (identical(input$plot_type, "Circle plot")) {
|
| 181 | +357 | ! |
- data_extract_list,+ if (!shinyvalidate::input_provided(value)) {
|
| 182 | +358 | ! |
- list(plot_height = plot_height, plot_width = plot_width, ggplot2_args = ggplot2_args)+ "Need Original Coordinates" |
| 183 | +359 |
- ),+ } |
|
| 184 | -! | +||
| 360 | +
- ui = ui_outliers,+ } |
||
| 185 | -! | +||
| 361 | +
- ui_args = args,+ }) |
||
| 186 | +362 | ! |
- datanames = teal.transform::get_extract_datanames(data_extract_list)+ iv_extra$add_rule("pc", function(value) {
|
| 187 | -+ | ||
| 363 | +! |
- )+ if (identical(input$plot_type, "Eigenvector plot")) {
|
|
| 188 | +364 | ! |
- attr(ans, "teal_bookmarkable") <- TRUE+ if (!shinyvalidate::input_provided(value)) {
|
| 189 | +365 | ! |
- ans+ "Need PC" |
| 190 | +366 |
- }+ } |
|
| 191 | +367 |
-
+ } |
|
| 192 | +368 |
- # UI function for the outliers module+ })+ |
+ |
| 369 | +! | +
+ iv_extra$enable() |
|
| 193 | +370 |
- ui_outliers <- function(id, ...) {
+
|
|
| 194 | +371 | ! |
- args <- list(...)+ anl_merged_input <- teal.transform::merge_expression_srv( |
| 195 | +372 | ! |
- ns <- NS(id)+ selector_list = selector_list, |
| 196 | +373 | ! |
- is_single_dataset_value <- teal.transform::is_single_dataset(args$outlier_var, args$categorical_var)+ datasets = data |
| 197 | +374 |
-
+ ) |
|
| 198 | -! | +||
| 375 | +
- teal.widgets::standard_layout(+ |
||
| 199 | +376 | ! |
- output = teal.widgets::white_small_well(+ anl_merged_q <- reactive({
|
| 200 | +377 | ! |
- uiOutput(ns("total_outliers")),
+ req(anl_merged_input()) |
| 201 | +378 | ! |
- DT::dataTableOutput(ns("summary_table")),
+ data() %>% |
| 202 | +379 | ! |
- uiOutput(ns("total_missing")),
+ teal.code::eval_code(as.expression(anl_merged_input()$expr)) |
| 203 | -! | +||
| 380 | +
- tags$br(), tags$hr(),+ }) |
||
| 204 | -! | +||
| 381 | +
- tabsetPanel(+ |
||
| 205 | +382 | ! |
- id = ns("tabs"),
+ merged <- list( |
| 206 | +383 | ! |
- tabPanel(+ anl_input_r = anl_merged_input, |
| 207 | +384 | ! |
- "Boxplot",+ anl_q_r = anl_merged_q |
| 208 | -! | +||
| 385 | +
- teal.widgets::plot_with_settings_ui(id = ns("box_plot"))
+ ) |
||
| 209 | +386 |
- ),+ |
|
| 210 | +387 | ! |
- tabPanel(+ validation <- reactive({
|
| 211 | +388 | ! |
- "Density Plot",- |
-
| 212 | -! | -
- teal.widgets::plot_with_settings_ui(id = ns("density_plot"))
+ req(merged$anl_q_r()) |
|
| 213 | +389 |
- ),+ # inputs |
|
| 214 | +390 | ! |
- tabPanel(+ keep_cols <- as.character(merged$anl_input_r()$columns_source$dat) |
| 215 | +391 | ! |
- "Cumulative Distribution Plot",+ na_action <- input$na_action |
| 216 | +392 | ! |
- teal.widgets::plot_with_settings_ui(id = ns("cum_density_plot"))
- |
-
| 217 | -- |
- )- |
- |
| 218 | -- |
- ),+ standardization <- input$standardization |
|
| 219 | +393 | ! |
- tags$br(), tags$hr(),+ center <- standardization %in% c("center", "center_scale")
|
| 220 | +394 | ! |
- uiOutput(ns("table_ui_wrap")),
+ scale <- standardization == "center_scale" |
| 221 | +395 | ! |
- DT::dataTableOutput(ns("table_ui"))
+ ANL <- merged$anl_q_r()[["ANL"]] |
| 222 | +396 |
- ),+ |
|
| 223 | +397 | ! |
- encoding = tags$div(- |
-
| 224 | -- |
- ### Reporter+ teal::validate_has_data(ANL, 10) |
|
| 225 | +398 | ! |
- teal.reporter::simple_reporter_ui(ns("simple_reporter")),
+ validate(need( |
| 226 | -+ | ||
| 399 | +! |
- ###+ na_action != "none" | !anyNA(ANL[keep_cols]), |
|
| 227 | +400 | ! |
- tags$label("Encodings", class = "text-primary"),
+ paste( |
| 228 | +401 | ! |
- teal.transform::datanames_input(args[c("outlier_var", "categorical_var")]),
+ "There are NAs in the dataset. Please deal with them in preprocessing", |
| 229 | +402 | ! |
- teal.transform::data_extract_ui(+ "or select \"Drop\" in the NA actions inside the encodings panel (left)." |
| 230 | -! | +||
| 403 | +
- id = ns("outlier_var"),
+ ) |
||
| 231 | -! | +||
| 404 | +
- label = "Variable",+ )) |
||
| 232 | +405 | ! |
- data_extract_spec = args$outlier_var,+ if (scale) {
|
| 233 | +406 | ! |
- is_single_dataset = is_single_dataset_value+ not_single <- vapply(ANL[keep_cols], function(column) length(unique(column)) != 1, FUN.VALUE = logical(1)) |
| 234 | +407 |
- ),+ |
|
| 235 | +408 | ! |
- if (!is.null(args$categorical_var)) {
+ msg <- paste0( |
| 236 | +409 | ! |
- teal.transform::data_extract_ui(+ "You have selected `Center & Scale` under `Standardization` in the `Pre-processing` panel, ", |
| 237 | +410 | ! |
- id = ns("categorical_var"),
+ "but one or more of your columns has/have a variance value of zero, indicating all values are identical" |
| 238 | -! | +||
| 411 | +
- label = "Categorical factor",+ ) |
||
| 239 | +412 | ! |
- data_extract_spec = args$categorical_var,+ validate(need(all(not_single), msg)) |
| 240 | -! | +||
| 413 | +
- is_single_dataset = is_single_dataset_value+ } |
||
| 241 | +414 |
- )+ }) |
|
| 242 | +415 |
- },+ |
|
| 243 | -! | +||
| 416 | +
- conditionalPanel(+ # computation ---- |
||
| 244 | +417 | ! |
- condition = paste0("input['", ns("tabs"), "'] == 'Boxplot'"),
+ computation <- reactive({
|
| 245 | +418 | ! |
- teal.widgets::optionalSelectInput(+ validation()+ |
+
| 419 | ++ | + + | +|
| 420 | ++ |
+ # inputs |
|
| 246 | +421 | ! |
- inputId = ns("boxplot_alts"),
+ keep_cols <- as.character(merged$anl_input_r()$columns_source$dat) |
| 247 | +422 | ! |
- label = "Plot type",+ na_action <- input$na_action |
| 248 | +423 | ! |
- choices = c("Box plot", "Violin plot"),
+ standardization <- input$standardization |
| 249 | +424 | ! |
- selected = "Box plot",+ center <- standardization %in% c("center", "center_scale")
|
| 250 | +425 | ! |
- multiple = FALSE+ scale <- standardization == "center_scale" |
| 251 | -+ | ||
| 426 | +! |
- )+ ANL <- merged$anl_q_r()[["ANL"]] |
|
| 252 | +427 |
- ),+ |
|
| 253 | +428 | ! |
- shinyjs::hidden(checkboxInput(ns("split_outliers"), "Define outliers based on group splitting", value = FALSE)),
+ qenv <- teal.code::eval_code( |
| 254 | +429 | ! |
- shinyjs::hidden(checkboxInput(ns("order_by_outlier"), "Re-order categories by outliers [by %]", value = FALSE)),
+ merged$anl_q_r(), |
| 255 | +430 | ! |
- teal.widgets::panel_group(+ substitute( |
| 256 | +431 | ! |
- teal.widgets::panel_item(+ expr = keep_columns <- keep_cols, |
| 257 | +432 | ! |
- title = "Method parameters",+ env = list(keep_cols = keep_cols) |
| 258 | -! | +||
| 433 | +
- collapsed = FALSE,+ ) |
||
| 259 | -! | +||
| 434 | +
- teal.widgets::optionalSelectInput(+ ) |
||
| 260 | -! | +||
| 435 | +
- inputId = ns("method"),
+
|
||
| 261 | +436 | ! |
- label = "Method",+ if (na_action == "drop") {
|
| 262 | +437 | ! |
- choices = c("IQR", "Z-score", "Percentile"),
+ qenv <- teal.code::eval_code( |
| 263 | +438 | ! |
- selected = "IQR",+ qenv, |
| 264 | +439 | ! |
- multiple = FALSE+ quote(ANL <- tidyr::drop_na(ANL, keep_columns)) |
| 265 | +440 |
- ),- |
- |
| 266 | -! | -
- conditionalPanel(- |
- |
| 267 | -! | -
- condition =+ ) |
|
| 268 | -! | +||
| 441 | +
- paste0("input['", ns("method"), "'] == 'IQR'"),
+ } |
||
| 269 | -! | +||
| 442 | +
- sliderInput(+ |
||
| 270 | +443 | ! |
- ns("iqr_slider"),
+ qenv <- teal.code::eval_code( |
| 271 | +444 | ! |
- "Outlier range:",+ qenv, |
| 272 | +445 | ! |
- min = 1,+ substitute( |
| 273 | +446 | ! |
- max = 5,+ expr = pca <- summary(stats::prcomp(ANL[keep_columns], center = center, scale. = scale, retx = TRUE)), |
| 274 | +447 | ! |
- value = 3,+ env = list(center = center, scale = scale) |
| 275 | -! | +||
| 448 | +
- step = 0.5+ ) |
||
| 276 | +449 |
- )+ ) |
|
| 277 | +450 |
- ),+ |
|
| 278 | +451 | ! |
- conditionalPanel(+ qenv <- teal.code::eval_code( |
| 279 | +452 | ! |
- condition =+ qenv, |
| 280 | +453 | ! |
- paste0("input['", ns("method"), "'] == 'Z-score'"),
+ quote({
|
| 281 | +454 | ! |
- sliderInput(+ tbl_importance <- dplyr::as_tibble(pca$importance, rownames = "Metric") |
| 282 | +455 | ! |
- ns("zscore_slider"),
+ tbl_importance+ |
+
| 456 | ++ |
+ })+ |
+ |
| 457 | ++ |
+ )+ |
+ |
| 458 | ++ | + | |
| 283 | +459 | ! |
- "Outlier range:",+ teal.code::eval_code( |
| 284 | +460 | ! |
- min = 1,+ qenv, |
| 285 | +461 | ! |
- max = 5,+ quote({
|
| 286 | +462 | ! |
- value = 3,+ tbl_eigenvector <- dplyr::as_tibble(pca$rotation, rownames = "Variable") |
| 287 | +463 | ! |
- step = 0.5+ tbl_eigenvector |
| 288 | +464 |
- )+ }) |
|
| 289 | +465 |
- ),+ ) |
|
| 290 | -! | +||
| 466 | +
- conditionalPanel(+ }) |
||
| 291 | -! | +||
| 467 | +
- condition =+ |
||
| 292 | -! | +||
| 468 | +
- paste0("input['", ns("method"), "'] == 'Percentile'"),
+ # plot args ---- |
||
| 293 | +469 | ! |
- sliderInput(+ output$plot_settings <- renderUI({
|
| 294 | -! | +||
| 470 | +
- ns("percentile_slider"),
+ # reactivity triggers |
||
| 295 | +471 | ! |
- "Outlier range:",+ req(iv_r()$is_valid()) |
| 296 | +472 | ! |
- min = 0.001,+ req(computation()) |
| 297 | +473 | ! |
- max = 0.5,+ qenv <- computation() |
| 298 | -! | +||
| 474 | +
- value = 0.01,+ |
||
| 299 | +475 | ! |
- step = 0.001+ ns <- session$ns |
| 300 | +476 |
- )+ |
|
| 301 | -+ | ||
| 477 | +! |
- ),+ pca <- qenv[["pca"]] |
|
| 302 | +478 | ! |
- uiOutput(ns("ui_outlier_help"))
+ chcs_pcs <- colnames(pca$rotation) |
| 303 | -+ | ||
| 479 | +! |
- )+ chcs_vars <- qenv[["keep_columns"]] |
|
| 304 | +480 |
- ),+ |
|
| 305 | +481 | ! |
- teal.widgets::panel_item(+ tagList( |
| 306 | +482 | ! |
- title = "Plot settings",+ conditionalPanel( |
| 307 | +483 | ! |
- selectInput(+ condition = sprintf( |
| 308 | +484 | ! |
- inputId = ns("ggtheme"),
+ "input['%s'] == 'Biplot' || input['%s'] == 'Circle plot'", |
| 309 | +485 | ! |
- label = "Theme (by ggplot):",+ ns("plot_type"), ns("plot_type")
+ |
+
| 486 | ++ |
+ ), |
|
| 310 | +487 | ! |
- choices = ggplot_themes,+ list( |
| 311 | +488 | ! |
- selected = args$ggtheme,+ teal.widgets::optionalSelectInput(ns("x_axis"), "X axis", choices = chcs_pcs, selected = chcs_pcs[1]),
|
| 312 | +489 | ! |
- multiple = FALSE+ teal.widgets::optionalSelectInput(ns("y_axis"), "Y axis", choices = chcs_pcs, selected = chcs_pcs[2]),
+ |
+
| 490 | +! | +
+ teal.widgets::optionalSelectInput(+ |
+ |
| 491 | +! | +
+ ns("variables"), "Original coordinates",
+ |
+ |
| 492 | +! | +
+ choices = chcs_vars, selected = chcs_vars,+ |
+ |
| 493 | +! | +
+ multiple = TRUE |
|
| 313 | +494 |
- )+ ) |
|
| 314 | +495 |
- )+ ) |
|
| 315 | +496 |
- ),+ ), |
|
| 316 | +497 | ! |
- forms = tagList(+ conditionalPanel( |
| 317 | +498 | ! |
- teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code")
+ condition = sprintf("input['%s'] == 'Elbow plot'", ns("plot_type")),
+ |
+
| 499 | +! | +
+ helpText("No plot specific settings available.")
|
|
| 318 | +500 |
- ),+ ), |
|
| 319 | +501 | ! |
- pre_output = args$pre_output,+ conditionalPanel( |
| 320 | +502 | ! |
- post_output = args$post_output+ condition = paste0("input['", ns("plot_type"), "'] == 'Eigenvector plot'"),
|
| 321 | -+ | ||
| 503 | +! |
- )+ teal.widgets::optionalSelectInput(ns("pc"), "PC", choices = chcs_pcs, selected = chcs_pcs[1])
|
|
| 322 | +504 |
- }+ ) |
|
| 323 | +505 |
-
+ ) |
|
| 324 | +506 |
- # Server function for the outliers module+ }) |
|
| 325 | +507 |
- srv_outliers <- function(id, data, reporter, filter_panel_api, outlier_var,+ |
|
| 326 | +508 |
- categorical_var, plot_height, plot_width, ggplot2_args) {
+ # plot elbow ---- |
|
| 327 | +509 | ! |
- with_reporter <- !missing(reporter) && inherits(reporter, "Reporter")+ plot_elbow <- function(base_q) {
|
| 328 | +510 | ! |
- with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI")+ ggtheme <- input$ggtheme |
| 329 | +511 | ! |
- checkmate::assert_class(data, "reactive")+ rotate_xaxis_labels <- input$rotate_xaxis_labels |
| 330 | +512 | ! |
- checkmate::assert_class(isolate(data()), "teal_data")+ font_size <- input$font_size+ |
+
| 513 | ++ | + | |
| 331 | +514 | ! |
- moduleServer(id, function(input, output, session) {
+ angle_value <- ifelse(isTRUE(rotate_xaxis_labels), 45, 0) |
| 332 | +515 | ! |
- teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.general")+ hjust_value <- ifelse(isTRUE(rotate_xaxis_labels), 1, 0.5) |
| 333 | +516 | ||
| 334 | +517 | ! |
- ns <- session$ns+ dev_ggplot2_args <- teal.widgets::ggplot2_args( |
| 335 | -+ | ||
| 518 | +! |
-
+ labs = list(x = "Principal component", y = "Proportion of variance explained", color = "", fill = "Legend"), |
|
| 336 | +519 | ! |
- vars <- list(outlier_var = outlier_var, categorical_var = categorical_var)+ theme = list( |
| 337 | -+ | ||
| 520 | +! |
-
+ legend.position = "right", |
|
| 338 | +521 | ! |
- rule_diff <- function(other) {
+ legend.spacing.y = quote(grid::unit(-5, "pt")), |
| 339 | +522 | ! |
- function(value) {
+ legend.title = quote(element_text(vjust = 25)), |
| 340 | +523 | ! |
- othervalue <- tryCatch(selector_list()[[other]]()[["select"]], error = function(e) NULL)+ axis.text.x = substitute( |
| 341 | +524 | ! |
- if (!is.null(othervalue) && identical(othervalue, value)) {
+ element_text(angle = angle_value, hjust = hjust_value), |
| 342 | +525 | ! |
- "`Variable` and `Categorical factor` cannot be the same"+ list(angle_value = angle_value, hjust_value = hjust_value) |
| 343 | +526 |
- }+ ), |
|
| 344 | -+ | ||
| 527 | +! |
- }+ text = substitute(element_text(size = font_size), list(font_size = font_size)) |
|
| 345 | +528 |
- }+ ) |
|
| 346 | +529 | - - | -|
| 347 | -! | -
- selector_list <- teal.transform::data_extract_multiple_srv(+ ) |
|
| 348 | -! | +||
| 530 | +
- data_extract = vars,+ |
||
| 349 | +531 | ! |
- datasets = data,+ parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args( |
| 350 | +532 | ! |
- select_validation_rule = list(+ teal.widgets::resolve_ggplot2_args( |
| 351 | +533 | ! |
- outlier_var = shinyvalidate::compose_rules(+ user_plot = ggplot2_args[["Elbow plot"]], |
| 352 | +534 | ! |
- shinyvalidate::sv_required("Please select a variable"),
+ user_default = ggplot2_args$default, |
| 353 | +535 | ! |
- rule_diff("categorical_var")
+ module_plot = dev_ggplot2_args |
| 354 | +536 |
), |
|
| 355 | +537 | ! |
- categorical_var = rule_diff("outlier_var")
+ ggtheme = ggtheme |
| 356 | +538 |
) |
|
| 357 | -- |
- )- |
- |
| 358 | +539 | ||
| 359 | +540 | ! |
- iv_r <- reactive({
+ teal.code::eval_code( |
| 360 | +541 | ! |
- iv <- shinyvalidate::InputValidator$new()+ base_q, |
| 361 | +542 | ! |
- iv$add_rule("method", shinyvalidate::sv_required("Please select a method"))
+ substitute( |
| 362 | +543 | ! |
- iv$add_rule("boxplot_alts", shinyvalidate::sv_required("Please select Plot Type"))
+ expr = {
|
| 363 | +544 | ! |
- teal.transform::compose_and_enable_validators(iv, selector_list)- |
-
| 364 | -- |
- })- |
- |
| 365 | -- |
-
+ elb_dat <- pca$importance[c("Proportion of Variance", "Cumulative Proportion"), ] %>%
|
|
| 366 | +545 | ! |
- reactive_select_input <- reactive({
+ dplyr::as_tibble(rownames = "metric") %>% |
| 367 | +546 | ! |
- if (is.null(selector_list()$categorical_var) || length(selector_list()$categorical_var()$select) == 0) {
+ tidyr::gather("component", "value", -metric) %>%
|
| 368 | +547 | ! |
- selector_list()[names(selector_list()) != "categorical_var"]- |
-
| 369 | -- |
- } else {
+ dplyr::mutate( |
|
| 370 | +548 | ! |
- selector_list()- |
-
| 371 | -- |
- }+ component = factor(component, levels = unique(stringr::str_sort(component, numeric = TRUE))) |
|
| 372 | +549 |
- })+ ) |
|
| 373 | +550 | ||
| 374 | +551 | ! |
- anl_merged_input <- teal.transform::merge_expression_srv(+ cols <- c(getOption("ggplot2.discrete.colour"), c("lightblue", "darkred", "black"))[1:3]
|
| 375 | +552 | ! |
- selector_list = reactive_select_input,+ g <- ggplot(mapping = aes_string(x = "component", y = "value")) + |
| 376 | +553 | ! |
- datasets = data,+ geom_bar( |
| 377 | +554 | ! |
- merge_function = "dplyr::inner_join"+ aes(fill = "Single variance"), |
| 378 | -+ | ||
| 555 | +! |
- )+ data = dplyr::filter(elb_dat, metric == "Proportion of Variance"), |
|
| 379 | -+ | ||
| 556 | +! |
-
+ color = "black", |
|
| 380 | +557 | ! |
- anl_merged_q <- reactive({
+ stat = "identity" |
| 381 | -! | +||
| 558 | +
- req(anl_merged_input())+ ) + |
||
| 382 | +559 | ! |
- data() %>%+ geom_point( |
| 383 | +560 | ! |
- teal.code::eval_code(as.expression(anl_merged_input()$expr))+ aes(color = "Cumulative variance"), |
| 384 | -+ | ||
| 561 | +! |
- })+ data = dplyr::filter(elb_dat, metric == "Cumulative Proportion") |
|
| 385 | +562 |
-
+ ) + |
|
| 386 | +563 | ! |
- merged <- list(+ geom_line( |
| 387 | +564 | ! |
- anl_input_r = anl_merged_input,+ aes(group = 1, color = "Cumulative variance"), |
| 388 | +565 | ! |
- anl_q_r = anl_merged_q- |
-
| 389 | -- |
- )+ data = dplyr::filter(elb_dat, metric == "Cumulative Proportion") |
|
| 390 | +566 |
-
+ ) + |
|
| 391 | +567 | ! |
- n_outlier_missing <- reactive({
+ labs + |
| 392 | +568 | ! |
- req(iv_r()$is_valid())+ scale_color_manual(values = c("Cumulative variance" = cols[2], "Single variance" = cols[3])) +
|
| 393 | +569 | ! |
- outlier_var <- as.vector(merged$anl_input_r()$columns_source$outlier_var)+ scale_fill_manual(values = c("Cumulative variance" = cols[2], "Single variance" = cols[1])) +
|
| 394 | +570 | ! |
- ANL <- merged$anl_q_r()[["ANL"]]+ ggthemes + |
| 395 | +571 | ! |
- sum(is.na(ANL[[outlier_var]]))+ themes |
| 396 | +572 |
- })+ |
|
| 397 | -+ | ||
| 573 | +! |
-
+ print(g) |
|
| 398 | +574 |
- # Used to create outlier table and the dropdown with additional columns+ }, |
|
| 399 | +575 | ! |
- dataname_first <- isolate(teal.data::datanames(data())[[1]])+ env = list( |
| 400 | -+ | ||
| 576 | +! |
-
+ ggthemes = parsed_ggplot2_args$ggtheme, |
|
| 401 | +577 | ! |
- common_code_q <- reactive({
+ labs = parsed_ggplot2_args$labs, |
| 402 | +578 | ! |
- req(iv_r()$is_valid())+ themes = parsed_ggplot2_args$theme |
| 403 | +579 |
-
+ ) |
|
| 404 | -! | +||
| 580 | +
- ANL <- merged$anl_q_r()[["ANL"]]+ ) |
||
| 405 | -! | +||
| 581 | +
- qenv <- merged$anl_q_r()+ ) |
||
| 406 | +582 |
-
+ } |
|
| 407 | -! | +||
| 583 | +
- outlier_var <- as.vector(merged$anl_input_r()$columns_source$outlier_var)+ + |
+ ||
| 584 | ++ |
+ # plot circle ---- |
|
| 408 | +585 | ! |
- categorical_var <- as.vector(merged$anl_input_r()$columns_source$categorical_var)+ plot_circle <- function(base_q) {
|
| 409 | +586 | ! |
- order_by_outlier <- input$order_by_outlier+ x_axis <- input$x_axis |
| 410 | +587 | ! |
- method <- input$method+ y_axis <- input$y_axis |
| 411 | +588 | ! |
- split_outliers <- input$split_outliers+ variables <- input$variables |
| 412 | +589 | ! |
- teal::validate_has_data(+ ggtheme <- input$ggtheme |
| 413 | +590 |
- # missing values in the categorical variable may be used to form a category of its own+ |
|
| 414 | +591 | ! |
- `if`(+ rotate_xaxis_labels <- input$rotate_xaxis_labels |
| 415 | +592 | ! |
- length(categorical_var) == 0,+ font_size <- input$font_size+ |
+
| 593 | ++ | + | |
| 416 | +594 | ! |
- ANL,+ angle <- ifelse(isTRUE(rotate_xaxis_labels), 45, 0) |
| 417 | +595 | ! |
- ANL[, names(ANL) != categorical_var, drop = FALSE]+ hjust <- ifelse(isTRUE(rotate_xaxis_labels), 1, 0.5) |
| 418 | +596 |
- ),+ |
|
| 419 | +597 | ! |
- min_nrow = 10,+ dev_ggplot2_args <- teal.widgets::ggplot2_args( |
| 420 | +598 | ! |
- complete = TRUE,+ theme = list( |
| 421 | +599 | ! |
- allow_inf = FALSE+ text = substitute(element_text(size = font_size), list(font_size = font_size)), |
| 422 | -+ | ||
| 600 | +! |
- )+ axis.text.x = substitute( |
|
| 423 | +601 | ! |
- validate(need(is.numeric(ANL[[outlier_var]]), "`Variable` is not numeric"))+ element_text(angle = angle_val, hjust = hjust_val), |
| 424 | +602 | ! |
- validate(need(length(unique(ANL[[outlier_var]])) > 1, "Variable has no variation, i.e. only one unique value"))+ list(angle_val = angle, hjust_val = hjust) |
| 425 | +603 |
-
+ ) |
|
| 426 | +604 |
- # show/hide split_outliers+ ) |
|
| 427 | -! | +||
| 605 | +
- if (length(categorical_var) == 0) {
+ ) |
||
| 428 | -! | +||
| 606 | +
- shinyjs::hide("split_outliers")
+
|
||
| 429 | +607 | ! |
- if (n_outlier_missing() > 0) {
+ all_ggplot2_args <- teal.widgets::resolve_ggplot2_args( |
| 430 | +608 | ! |
- qenv <- teal.code::eval_code(+ user_plot = ggplot2_args[["Circle plot"]], |
| 431 | +609 | ! |
- qenv,+ user_default = ggplot2_args$default, |
| 432 | +610 | ! |
- substitute(+ module_plot = dev_ggplot2_args+ |
+
| 611 | ++ |
+ )+ |
+ |
| 612 | ++ | + | |
| 433 | +613 | ! |
- expr = ANL <- ANL %>% dplyr::filter(!is.na(outlier_var_name)),+ parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args( |
| 434 | +614 | ! |
- env = list(outlier_var_name = as.name(outlier_var))+ all_ggplot2_args, |
| 435 | -+ | ||
| 615 | +! |
- )+ ggtheme = ggtheme |
|
| 436 | +616 |
- )+ ) |
|
| 437 | +617 |
- }+ |
|
| 438 | -+ | ||
| 618 | +! |
- } else {
+ teal.code::eval_code( |
|
| 439 | +619 | ! |
- validate(need(+ base_q, |
| 440 | +620 | ! |
- is.factor(ANL[[categorical_var]]) ||+ substitute( |
| 441 | +621 | ! |
- is.character(ANL[[categorical_var]]) ||+ expr = {
|
| 442 | +622 | ! |
- is.integer(ANL[[categorical_var]]),+ pca_rot <- pca$rotation[, c(x_axis, y_axis)] %>% |
| 443 | +623 | ! |
- "`Categorical factor` must be `factor`, `character`, or `integer`"+ dplyr::as_tibble(rownames = "label") %>% |
| 444 | -+ | ||
| 624 | +! |
- ))+ dplyr::filter(label %in% variables) |
|
| 445 | +625 | ||
| 446 | +626 | ! |
- if (n_outlier_missing() > 0) {
+ circle_data <- data.frame( |
| 447 | +627 | ! |
- qenv <- teal.code::eval_code(+ x = cos(seq(0, 2 * pi, length.out = 100)), |
| 448 | +628 | ! |
- qenv,+ y = sin(seq(0, 2 * pi, length.out = 100)) |
| 449 | -! | +||
| 629 | +
- substitute(+ ) |
||
| 450 | -! | +||
| 630 | +
- expr = ANL <- ANL %>% dplyr::filter(!is.na(outlier_var_name)),+ |
||
| 451 | +631 | ! |
- env = list(outlier_var_name = as.name(outlier_var))- |
-
| 452 | -- |
- )+ g <- ggplot(pca_rot) + |
|
| 453 | -+ | ||
| 632 | +! |
- )+ geom_point(aes_string(x = x_axis, y = y_axis)) + |
|
| 454 | -+ | ||
| 633 | +! |
- }+ geom_label( |
|
| 455 | +634 | ! |
- shinyjs::show("split_outliers")
+ aes_string(x = x_axis, y = y_axis, label = "label"), |
| 456 | -+ | ||
| 635 | +! |
- }+ nudge_x = 0.1, nudge_y = 0.05, |
|
| 457 | -+ | ||
| 636 | +! |
-
+ fontface = "bold" |
|
| 458 | +637 |
- # slider+ ) + |
|
| 459 | +638 | ! |
- outlier_definition_param <- if (method == "IQR") {
+ geom_path(aes(x, y, group = 1), data = circle_data) + |
| 460 | +639 | ! |
- input$iqr_slider+ geom_point(aes(x = x, y = y), data = data.frame(x = 0, y = 0), shape = "x", size = 5) + |
| 461 | +640 | ! |
- } else if (method == "Z-score") {
+ labs + |
| 462 | +641 | ! |
- input$zscore_slider+ ggthemes + |
| 463 | +642 | ! |
- } else if (method == "Percentile") {
+ themes |
| 464 | +643 | ! |
- input$percentile_slider+ print(g) |
| 465 | +644 |
- }+ }, |
|
| 466 | -+ | ||
| 645 | +! |
-
+ env = list( |
|
| 467 | -+ | ||
| 646 | +! |
- # this is utils function that converts a %>% NULL %>% b into a %>% b+ x_axis = x_axis, |
|
| 468 | +647 | ! |
- remove_pipe_null <- function(x) {
+ y_axis = y_axis, |
| 469 | +648 | ! |
- if (length(x) == 1) {
+ variables = variables, |
| 470 | +649 | ! |
- return(x)+ ggthemes = parsed_ggplot2_args$ggtheme, |
| 471 | -+ | ||
| 650 | +! |
- }+ labs = `if`(is.null(parsed_ggplot2_args$labs), quote(labs()), parsed_ggplot2_args$labs), |
|
| 472 | +651 | ! |
- if (identical(x[[1]], as.name("%>%")) && is.null(x[[3]])) {
+ themes = parsed_ggplot2_args$theme |
| 473 | -! | +||
| 652 | +
- return(remove_pipe_null(x[[2]]))+ ) |
||
| 474 | +653 |
- }+ ) |
|
| 475 | -! | +||
| 654 | +
- return(as.call(c(x[[1]], lapply(x[-1], remove_pipe_null))))+ ) |
||
| 476 | +655 |
- }+ } |
|
| 477 | +656 | ||
| 657 | ++ |
+ # plot biplot ----+ |
+ |
| 478 | +658 | ! |
- qenv <- teal.code::eval_code(+ plot_biplot <- function(base_q) {
|
| 479 | +659 | ! |
- qenv,+ qenv <- base_q+ |
+
| 660 | ++ | + | |
| 480 | +661 | ! |
- substitute(+ ANL <- qenv[["ANL"]]+ |
+
| 662 | ++ | + | |
| 481 | +663 | ! |
- expr = {
+ resp_col <- as.character(merged$anl_input_r()$columns_source$response) |
| 482 | +664 | ! |
- ANL_OUTLIER <- ANL %>%+ dat_cols <- as.character(merged$anl_input_r()$columns_source$dat) |
| 483 | +665 | ! |
- group_expr %>% # styler: off+ x_axis <- input$x_axis |
| 484 | +666 | ! |
- dplyr::mutate(is_outlier = {
+ y_axis <- input$y_axis |
| 485 | +667 | ! |
- q1_q3 <- stats::quantile(outlier_var_name, probs = c(0.25, 0.75))+ variables <- input$variables |
| 486 | +668 | ! |
- iqr <- q1_q3[2] - q1_q3[1]+ pca <- qenv[["pca"]]+ |
+
| 669 | ++ | + | |
| 487 | +670 | ! |
- !(outlier_var_name >= q1_q3[1] - 1.5 * iqr & outlier_var_name <= q1_q3[2] + 1.5 * iqr)+ ggtheme <- input$ggtheme |
| 488 | +671 |
- }) %>%+ |
|
| 489 | +672 | ! |
- calculate_outliers %>% # styler: off+ rotate_xaxis_labels <- input$rotate_xaxis_labels |
| 490 | +673 | ! |
- ungroup_expr %>% # styler: off+ alpha <- input$alpha |
| 491 | +674 | ! |
- dplyr::filter(is_outlier | is_outlier_selected) %>%+ size <- input$size |
| 492 | +675 | ! |
- dplyr::select(-is_outlier)+ font_size <- input$font_size |
| 493 | +676 |
- },+ |
|
| 494 | +677 | ! |
- env = list(+ qenv <- teal.code::eval_code( |
| 495 | +678 | ! |
- calculate_outliers = if (method == "IQR") {
+ qenv, |
| 496 | +679 | ! |
- substitute(+ substitute( |
| 497 | +680 | ! |
- expr = dplyr::mutate(is_outlier_selected = {
+ expr = pca_rot <- dplyr::as_tibble(pca$x[, c(x_axis, y_axis)]), |
| 498 | +681 | ! |
- q1_q3 <- stats::quantile(outlier_var_name, probs = c(0.25, 0.75))+ env = list(x_axis = x_axis, y_axis = y_axis) |
| 499 | -! | +||
| 682 | +
- iqr <- q1_q3[2] - q1_q3[1]+ ) |
||
| 500 | +683 |
- !(+ ) |
|
| 501 | -! | +||
| 684 | +
- outlier_var_name >= q1_q3[1] - outlier_definition_param * iqr &+ + |
+ ||
| 685 | ++ |
+ # rot_vars = data frame that displays arrows in the plot, need to be scaled to data |
|
| 502 | +686 | ! |
- outlier_var_name <= q1_q3[2] + outlier_definition_param * iqr+ if (!is.null(input$variables)) {
|
| 503 | -+ | ||
| 687 | +! |
- )+ qenv <- teal.code::eval_code( |
|
| 504 | -+ | ||
| 688 | +! |
- }),+ qenv, |
|
| 505 | +689 | ! |
- env = list(+ substitute( |
| 506 | +690 | ! |
- outlier_var_name = as.name(outlier_var),+ expr = {
|
| 507 | +691 | ! |
- outlier_definition_param = outlier_definition_param+ r <- sqrt(qchisq(0.69, df = 2)) * prod(colMeans(pca_rot ^ 2)) ^ (1 / 4) # styler: off |
| 508 | -+ | ||
| 692 | +! |
- )+ v_scale <- rowSums(pca$rotation ^ 2) # styler: off |
|
| 509 | +693 |
- )+ |
|
| 510 | +694 | ! |
- } else if (method == "Z-score") {
+ rot_vars <- pca$rotation[, c(x_axis, y_axis)] %>% |
| 511 | +695 | ! |
- substitute(+ dplyr::as_tibble(rownames = "label") %>% |
| 512 | +696 | ! |
- expr = dplyr::mutate(+ dplyr::mutate_at(vars(c(x_axis, y_axis)), function(x) r * x / sqrt(max(v_scale))) |
| 513 | -! | +||
| 697 | +
- is_outlier_selected = abs(outlier_var_name - mean(outlier_var_name)) /+ }, |
||
| 514 | +698 | ! |
- stats::sd(outlier_var_name) > outlier_definition_param+ env = list(x_axis = x_axis, y_axis = y_axis) |
| 515 | +699 |
- ),+ ) |
|
| 516 | -! | +||
| 700 | +
- env = list(+ ) %>% |
||
| 517 | +701 | ! |
- outlier_var_name = as.name(outlier_var),+ teal.code::eval_code( |
| 518 | +702 | ! |
- outlier_definition_param = outlier_definition_param- |
-
| 519 | -- |
- )+ if (is.logical(pca$center) && !pca$center) {
|
|
| 520 | -+ | ||
| 703 | +! |
- )+ substitute( |
|
| 521 | +704 | ! |
- } else if (method == "Percentile") {
+ expr = {
|
| 522 | +705 | ! |
- substitute(+ rot_vars <- rot_vars %>% |
| 523 | +706 | ! |
- expr = dplyr::mutate(+ tibble::column_to_rownames("label") %>%
|
| 524 | +707 | ! |
- is_outlier_selected = outlier_var_name < stats::quantile(outlier_var_name, outlier_definition_param) |+ sweep(1, apply(ANL[keep_columns], 2, mean, na.rm = TRUE)) %>% |
| 525 | +708 | ! |
- outlier_var_name > stats::quantile(outlier_var_name, 1 - outlier_definition_param)+ tibble::rownames_to_column("label") %>%
|
| 526 | -+ | ||
| 709 | +! |
- ),+ dplyr::mutate( |
|
| 527 | +710 | ! |
- env = list(+ xstart = mean(pca$x[, x_axis], na.rm = TRUE), |
| 528 | +711 | ! |
- outlier_var_name = as.name(outlier_var),+ ystart = mean(pca$x[, y_axis], na.rm = TRUE) |
| 529 | -! | +||
| 712 | +
- outlier_definition_param = outlier_definition_param+ ) |
||
| 530 | +713 |
- )+ },+ |
+ |
| 714 | +! | +
+ env = list(x_axis = x_axis, y_axis = y_axis) |
|
| 531 | +715 |
) |
|
| 532 | +716 |
- },+ } else {
|
|
| 533 | +717 | ! |
- outlier_var_name = as.name(outlier_var),+ quote(rot_vars <- rot_vars %>% dplyr::mutate(xstart = 0, ystart = 0)) |
| 534 | -! | +||
| 718 | +
- group_expr = if (isTRUE(split_outliers) && length(categorical_var) != 0) {
+ }+ |
+ ||
| 719 | ++ |
+ ) %>% |
|
| 535 | +720 | ! |
- substitute(dplyr::group_by(x), list(x = as.name(categorical_var)))+ teal.code::eval_code( |
| 536 | -+ | ||
| 721 | +! |
- },+ substitute( |
|
| 537 | +722 | ! |
- ungroup_expr = if (isTRUE(split_outliers) && length(categorical_var) != 0) {
+ expr = rot_vars <- rot_vars %>% dplyr::filter(label %in% variables), |
| 538 | +723 | ! |
- substitute(dplyr::ungroup())+ env = list(variables = variables) |
| 539 | +724 |
- }+ ) |
|
| 540 | +725 |
) |
|
| 541 | +726 |
- ) %>%- |
- |
| 542 | -! | -
- remove_pipe_null()+ } |
|
| 543 | +727 |
- )+ |
|
| 544 | -+ | ||
| 728 | +! |
-
+ pca_plot_biplot_expr <- list(quote(ggplot())) |
|
| 545 | +729 |
- # ANL_OUTLIER_EXTENDED is the base table+ |
|
| 546 | +730 | ! |
- qenv <- teal.code::eval_code(+ if (length(resp_col) == 0) {
|
| 547 | +731 | ! |
- qenv,+ pca_plot_biplot_expr <- c( |
| 548 | +732 | ! |
- substitute(+ pca_plot_biplot_expr, |
| 549 | +733 | ! |
- expr = {
+ substitute( |
| 550 | +734 | ! |
- ANL_OUTLIER_EXTENDED <- dplyr::left_join(+ geom_point(aes_string(x = x_axis, y = y_axis), data = pca_rot, alpha = alpha, size = size), |
| 551 | +735 | ! |
- ANL_OUTLIER,+ list(x_axis = input$x_axis, y_axis = input$y_axis, alpha = input$alpha, size = input$size) |
| 552 | -! | +||
| 736 | +
- dplyr::select(+ ) |
||
| 553 | -! | +||
| 737 | +
- dataname,+ ) |
||
| 554 | +738 | ! |
- dplyr::setdiff(names(dataname), dplyr::setdiff(names(ANL_OUTLIER), join_keys))+ dev_labs <- list() |
| 555 | +739 |
- ),+ } else {
|
|
| 556 | +740 | ! |
- by = join_keys+ rp_keys <- setdiff(colnames(ANL), as.character(unlist(merged$anl_input_r()$columns_source))) |
| 557 | +741 |
- )+ + |
+ |
| 742 | +! | +
+ response <- ANL[[resp_col]] |
|
| 558 | +743 |
- },+ |
|
| 559 | +744 | ! |
- env = list(+ aes_biplot <- substitute( |
| 560 | +745 | ! |
- dataname = as.name(dataname_first),+ aes_string(x = x_axis, y = y_axis, color = "response"), |
| 561 | +746 | ! |
- join_keys = as.character(teal.data::join_keys(data())[dataname_first, dataname_first])- |
-
| 562 | -- |
- )+ env = list(x_axis = x_axis, y_axis = y_axis) |
|
| 563 | +747 |
) |
|
| 564 | -- |
- )- |
- |
| 565 | +748 | ||
| 566 | +749 | ! |
- if (length(categorical_var) > 0) {
+ qenv <- teal.code::eval_code( |
| 567 | +750 | ! |
- qenv <- teal.code::eval_code(+ qenv, |
| 568 | +751 | ! |
- qenv,+ substitute(response <- ANL[[resp_col]], env = list(resp_col = resp_col)) |
| 569 | -! | +||
| 752 | +
- substitute(+ ) |
||
| 570 | -! | +||
| 753 | +
- expr = summary_table_pre <- ANL_OUTLIER %>%+ |
||
| 571 | +754 | ! |
- dplyr::filter(is_outlier_selected) %>%+ dev_labs <- list(color = varname_w_label(resp_col, ANL)) |
| 572 | -! | +||
| 755 | +
- dplyr::select(outlier_var_name, categorical_var_name) %>%+ |
||
| 573 | +756 | ! |
- dplyr::group_by(categorical_var_name) %>%+ scales_biplot <- |
| 574 | +757 | ! |
- dplyr::summarise(n_outliers = dplyr::n()) %>%+ if ( |
| 575 | +758 | ! |
- dplyr::right_join(+ is.character(response) || |
| 576 | +759 | ! |
- ANL %>%+ is.factor(response) || |
| 577 | +760 | ! |
- dplyr::select(outlier_var_name, categorical_var_name) %>%+ (is.numeric(response) && length(unique(response)) <= 6) |
| 578 | -! | +||
| 761 | +
- dplyr::group_by(categorical_var_name) %>%+ ) {
|
||
| 579 | +762 | ! |
- dplyr::summarise(+ qenv <- teal.code::eval_code( |
| 580 | +763 | ! |
- total_in_cat = dplyr::n(),+ qenv, |
| 581 | +764 | ! |
- n_na = sum(is.na(outlier_var_name) | is.na(categorical_var_name))+ quote(pca_rot$response <- as.factor(response)) |
| 582 | +765 |
- ),+ ) |
|
| 583 | +766 | ! |
- by = categorical_var+ quote(scale_color_brewer(palette = "Dark2")) |
| 584 | -+ | ||
| 767 | +! |
- ) %>%+ } else if (inherits(response, "Date")) {
|
|
| 585 | -+ | ||
| 768 | +! |
- # This is important as there may be categorical variables with natural orderings, e.g. AGE.+ qenv <- teal.code::eval_code(+ |
+ |
| 769 | +! | +
+ qenv,+ |
+ |
| 770 | +! | +
+ quote(pca_rot$response <- numeric(response)) |
|
| 586 | +771 |
- # The plots should be displayed by default in increasing order in these situations.+ ) |
|
| 587 | +772 |
- # dplyr::arrange will sort integer, factor, and character data types in the expected way.+ |
|
| 588 | +773 | ! |
- dplyr::arrange(categorical_var_name) %>%+ quote( |
| 589 | +774 | ! |
- dplyr::mutate(+ scale_color_gradient( |
| 590 | +775 | ! |
- n_outliers = dplyr::if_else(is.na(n_outliers), 0, as.numeric(n_outliers)),+ low = c(getOption("ggplot2.discrete.colour")[2], "darkred")[1],
|
| 591 | +776 | ! |
- display_str = dplyr::if_else(+ high = c(getOption("ggplot2.discrete.colour"), "lightblue")[1],
|
| 592 | +777 | ! |
- n_outliers > 0,+ labels = function(x) as.Date(x, origin = "1970-01-01") |
| 593 | -! | +||
| 778 | +
- sprintf("%d [%.02f%%]", n_outliers, 100 * n_outliers / total_in_cat),
+ ) |
||
| 594 | -! | +||
| 779 | +
- "0"+ ) |
||
| 595 | +780 |
- ),+ } else {
|
|
| 596 | +781 | ! |
- display_str_na = dplyr::if_else(+ qenv <- teal.code::eval_code( |
| 597 | +782 | ! |
- n_na > 0,- |
-
| 598 | -! | -
- sprintf("%d [%.02f%%]", n_na, 100 * n_na / total_in_cat),
- |
- |
| 599 | -! | -
- "0"- |
- |
| 600 | -- |
- ),+ qenv, |
|
| 601 | +783 | ! |
- order = seq_along(n_outliers)+ quote(pca_rot$response <- response) |
| 602 | +784 |
- ),- |
- |
| 603 | -! | -
- env = list(+ ) |
|
| 604 | +785 | ! |
- categorical_var = categorical_var,+ quote(scale_color_gradient( |
| 605 | +786 | ! |
- categorical_var_name = as.name(categorical_var),+ low = c(getOption("ggplot2.discrete.colour")[2], "darkred")[1],
|
| 606 | +787 | ! |
- outlier_var_name = as.name(outlier_var)- |
-
| 607 | -- |
- )+ high = c(getOption("ggplot2.discrete.colour"), "lightblue")[1]
|
|
| 608 | +788 |
- )+ )) |
|
| 609 | +789 |
- )+ } |
|
| 610 | +790 |
- # now to handle when user chooses to order based on amount of outliers+ |
|
| 611 | +791 | ! |
- if (order_by_outlier) {
+ pca_plot_biplot_expr <- c( |
| 612 | +792 | ! |
- qenv <- teal.code::eval_code(+ pca_plot_biplot_expr, |
| 613 | +793 | ! |
- qenv,+ substitute( |
| 614 | +794 | ! |
- quote(+ geom_point(aes_biplot, data = pca_rot, alpha = alpha, size = size), |
| 615 | +795 | ! |
- summary_table_pre <- summary_table_pre %>%+ env = list(aes_biplot = aes_biplot, alpha = alpha, size = size) |
| 616 | -! | +||
| 796 | +
- dplyr::arrange(desc(n_outliers / total_in_cat)) %>%+ ), |
||
| 617 | +797 | ! |
- dplyr::mutate(order = seq_len(nrow(summary_table_pre)))- |
-
| 618 | -- |
- )+ scales_biplot |
|
| 619 | +798 |
- )+ ) |
|
| 620 | +799 |
- }+ } |
|
| 621 | +800 | ||
| 622 | +801 | ! |
- qenv <- teal.code::eval_code(+ if (!is.null(input$variables)) {
|
| 623 | +802 | ! |
- qenv,+ pca_plot_biplot_expr <- c( |
| 624 | +803 | ! |
- substitute(+ pca_plot_biplot_expr, |
| 625 | +804 | ! |
- expr = {
+ substitute( |
| 626 | -+ | ||
| 805 | +! |
- # In order for geom_rug to work properly when reordering takes place inside facet_grid,+ geom_segment( |
|
| 627 | -+ | ||
| 806 | +! |
- # all tables must have the column used for reording.+ aes_string(x = "xstart", y = "ystart", xend = x_axis, yend = y_axis), |
|
| 628 | -+ | ||
| 807 | +! |
- # In this case, the column used for reordering is `order`.+ data = rot_vars, |
|
| 629 | +808 | ! |
- ANL_OUTLIER <- dplyr::left_join(+ lineend = "round", linejoin = "round", |
| 630 | +809 | ! |
- ANL_OUTLIER,+ arrow = grid::arrow(length = grid::unit(0.5, "cm")) |
| 631 | -! | +||
| 810 | +
- summary_table_pre[, c("order", categorical_var)],
+ ), |
||
| 632 | +811 | ! |
- by = categorical_var+ env = list(x_axis = x_axis, y_axis = y_axis) |
| 633 | +812 |
- )+ ), |
|
| 634 | -+ | ||
| 813 | +! |
- # so that x axis of plot aligns with columns of summary table, from most outliers to least by percentage+ substitute( |
|
| 635 | +814 | ! |
- ANL <- ANL %>%+ geom_label( |
| 636 | +815 | ! |
- dplyr::left_join(+ aes_string( |
| 637 | +816 | ! |
- dplyr::select(summary_table_pre, categorical_var_name, order),+ x = x_axis, |
| 638 | +817 | ! |
- by = categorical_var+ y = y_axis,+ |
+
| 818 | +! | +
+ label = "label" |
|
| 639 | +819 |
- ) %>%+ ), |
|
| 640 | +820 | ! |
- dplyr::arrange(order)+ data = rot_vars, |
| 641 | +821 | ! |
- summary_table <- summary_table_pre %>%+ nudge_y = 0.1, |
| 642 | +822 | ! |
- dplyr::select(+ fontface = "bold" |
| 643 | -! | +||
| 823 | +
- categorical_var_name,+ ), |
||
| 644 | +824 | ! |
- Outliers = display_str, Missings = display_str_na, Total = total_in_cat+ env = list(x_axis = x_axis, y_axis = y_axis) |
| 645 | +825 |
- ) %>%+ ), |
|
| 646 | +826 | ! |
- dplyr::mutate_all(as.character) %>%+ quote(geom_point(aes(x = xstart, y = ystart), data = rot_vars, shape = "x", size = 5))+ |
+
| 827 | ++ |
+ )+ |
+ |
| 828 | ++ |
+ }+ |
+ |
| 829 | ++ | + | |
| 647 | +830 | ! |
- tidyr::pivot_longer(-categorical_var_name) %>%+ angle <- ifelse(isTRUE(rotate_xaxis_labels), 45, 0) |
| 648 | +831 | ! |
- tidyr::pivot_wider(names_from = categorical_var, values_from = value) %>%+ hjust <- ifelse(isTRUE(rotate_xaxis_labels), 1, 0.5)+ |
+
| 832 | ++ | + | |
| 649 | +833 | ! |
- tibble::column_to_rownames("name")
+ dev_ggplot2_args <- teal.widgets::ggplot2_args( |
| 650 | +834 | ! |
- summary_table+ labs = dev_labs, |
| 651 | -+ | ||
| 835 | +! |
- },+ theme = list( |
|
| 652 | +836 | ! |
- env = list(+ text = substitute(element_text(size = font_size), list(font_size = font_size)), |
| 653 | +837 | ! |
- categorical_var = categorical_var,+ axis.text.x = substitute( |
| 654 | +838 | ! |
- categorical_var_name = as.name(categorical_var)+ element_text(angle = angle_val, hjust = hjust_val), |
| 655 | -+ | ||
| 839 | +! |
- )+ list(angle_val = angle, hjust_val = hjust) |
|
| 656 | +840 |
) |
|
| 657 | +841 |
) |
|
| 658 | +842 |
- }+ ) |
|
| 659 | +843 | ||
| 660 | +844 | ! |
- if (length(categorical_var) > 0 && nrow(qenv[["ANL_OUTLIER"]]) > 0) {
+ all_ggplot2_args <- teal.widgets::resolve_ggplot2_args( |
| 661 | +845 | ! |
- shinyjs::show("order_by_outlier")
+ user_plot = ggplot2_args[["Biplot"]], |
| 662 | -+ | ||
| 846 | +! |
- } else {
+ user_default = ggplot2_args$default, |
|
| 663 | +847 | ! |
- shinyjs::hide("order_by_outlier")
+ module_plot = dev_ggplot2_args |
| 664 | +848 |
- }+ ) |
|
| 665 | +849 | ||
| 666 | +850 | ! |
- qenv+ parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(+ |
+
| 851 | +! | +
+ all_ggplot2_args,+ |
+ |
| 852 | +! | +
+ ggtheme = ggtheme |
|
| 667 | +853 |
- })+ ) |
|
| 668 | +854 | ||
| 669 | +855 | ! |
- output$summary_table <- DT::renderDataTable(+ pca_plot_biplot_expr <- c( |
| 670 | +856 | ! |
- expr = {
+ pca_plot_biplot_expr, |
| 671 | +857 | ! |
- if (iv_r()$is_valid()) {
+ parsed_ggplot2_args |
| 672 | -! | +||
| 858 | +
- categorical_var <- as.vector(merged$anl_input_r()$columns_source$categorical_var)+ ) |
||
| 673 | -! | +||
| 859 | +
- if (!is.null(categorical_var)) {
+
|
||
| 674 | +860 | ! |
- DT::datatable(+ teal.code::eval_code( |
| 675 | +861 | ! |
- common_code_q()[["summary_table"]],+ qenv, |
| 676 | +862 | ! |
- options = list(+ substitute( |
| 677 | +863 | ! |
- dom = "t",+ expr = {
|
| 678 | +864 | ! |
- autoWidth = TRUE,+ g <- plot_call |
| 679 | +865 | ! |
- columnDefs = list(list(width = "200px", targets = "_all"))+ print(g) |
| 680 | +866 |
- )+ }, |
|
| 681 | -+ | ||
| 867 | +! |
- )+ env = list( |
|
| 682 | -+ | ||
| 868 | +! |
- }+ plot_call = Reduce(function(x, y) call("+", x, y), pca_plot_biplot_expr)
|
|
| 683 | +869 |
- }+ ) |
|
| 684 | +870 |
- }+ ) |
|
| 685 | +871 |
- )+ ) |
|
| 686 | +872 |
-
+ } |
|
| 687 | +873 |
- # boxplot/violinplot # nolint commented_code+ |
|
| 688 | -! | +||
| 874 | +
- boxplot_q <- reactive({
+ # plot pc_var ---- |
||
| 689 | +875 | ! |
- req(common_code_q())+ plot_pc_var <- function(base_q) {
|
| 690 | +876 | ! |
- ANL <- common_code_q()[["ANL"]]+ pc <- input$pc |
| 691 | +877 | ! |
- ANL_OUTLIER <- common_code_q()[["ANL_OUTLIER"]]+ ggtheme <- input$ggtheme |
| 692 | +878 | ||
| 693 | +879 | ! |
- outlier_var <- as.vector(merged$anl_input_r()$columns_source$outlier_var)+ rotate_xaxis_labels <- input$rotate_xaxis_labels |
| 694 | +880 | ! |
- categorical_var <- as.vector(merged$anl_input_r()$columns_source$categorical_var)+ font_size <- input$font_size |
| 695 | +881 | ||
| 696 | -- |
- # validation- |
- |
| 697 | +882 | ! |
- teal::validate_has_data(ANL, 1)+ angle <- ifelse(rotate_xaxis_labels, 45, 0) |
| 698 | -+ | ||
| 883 | +! |
-
+ hjust <- ifelse(rotate_xaxis_labels, 1, 0.5) |
|
| 699 | +884 |
- # boxplot+ |
|
| 700 | +885 | ! |
- plot_call <- quote(ANL %>% ggplot())+ dev_ggplot2_args <- teal.widgets::ggplot2_args( |
| 701 | -+ | ||
| 886 | +! |
-
+ theme = list( |
|
| 702 | +887 | ! |
- plot_call <- if (input$boxplot_alts == "Box plot") {
+ text = substitute(element_text(size = font_size), list(font_size = font_size)), |
| 703 | +888 | ! |
- substitute(expr = plot_call + geom_boxplot(outlier.shape = NA), env = list(plot_call = plot_call))+ axis.text.x = substitute( |
| 704 | +889 | ! |
- } else if (input$boxplot_alts == "Violin plot") {
+ element_text(angle = angle_val, hjust = hjust_val), |
| 705 | +890 | ! |
- substitute(expr = plot_call + geom_violin(), env = list(plot_call = plot_call))+ list(angle_val = angle, hjust_val = hjust) |
| 706 | +891 |
- } else {
+ ) |
|
| 707 | -! | +||
| 892 | +
- NULL+ ) |
||
| 708 | +893 |
- }+ ) |
|
| 709 | +894 | ||
| 710 | +895 | ! |
- plot_call <- if (identical(categorical_var, character(0)) || is.null(categorical_var)) {
+ all_ggplot2_args <- teal.widgets::resolve_ggplot2_args( |
| 711 | +896 | ! |
- inner_call <- substitute(+ user_plot = ggplot2_args[["Eigenvector plot"]], |
| 712 | +897 | ! |
- expr = plot_call ++ user_default = ggplot2_args$default, |
| 713 | +898 | ! |
- aes(x = "Entire dataset", y = outlier_var_name) ++ module_plot = dev_ggplot2_args+ |
+
| 899 | ++ |
+ )+ |
+ |
| 900 | ++ | + | |
| 714 | +901 | ! |
- scale_x_discrete(),+ parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args( |
| 715 | +902 | ! |
- env = list(plot_call = plot_call, outlier_var_name = as.name(outlier_var))+ all_ggplot2_args,+ |
+
| 903 | +! | +
+ ggtheme = ggtheme |
|
| 716 | +904 |
- )+ ) |
|
| 717 | -! | +||
| 905 | +
- if (nrow(ANL_OUTLIER) > 0) {
+
|
||
| 718 | +906 | ! |
- substitute(+ ggplot_exprs <- c( |
| 719 | +907 | ! |
- expr = inner_call + geom_point(+ list( |
| 720 | +908 | ! |
- data = ANL_OUTLIER,+ quote(ggplot(pca_rot)), |
| 721 | +909 | ! |
- aes(x = "Entire dataset", y = outlier_var_name, color = is_outlier_selected)+ substitute( |
| 722 | -+ | ||
| 910 | +! |
- ),+ geom_bar( |
|
| 723 | +911 | ! |
- env = list(inner_call = inner_call, outlier_var_name = as.name(outlier_var))+ aes_string(x = "Variable", y = pc), |
| 724 | -+ | ||
| 912 | +! |
- )+ stat = "identity", |
|
| 725 | -+ | ||
| 913 | +! |
- } else {
+ color = "black", |
|
| 726 | +914 | ! |
- inner_call+ fill = c(getOption("ggplot2.discrete.colour"), "lightblue")[1]
|
| 727 | +915 |
- }+ ),+ |
+ |
| 916 | +! | +
+ env = list(pc = pc) |
|
| 728 | +917 |
- } else {
+ ), |
|
| 729 | +918 | ! |
- substitute(+ substitute( |
| 730 | +919 | ! |
- expr = plot_call ++ geom_text( |
| 731 | +920 | ! |
- aes(y = outlier_var_name, x = reorder(categorical_var_name, order)) ++ aes( |
| 732 | +921 | ! |
- xlab(categorical_var) ++ x = Variable, |
| 733 | +922 | ! |
- scale_x_discrete() ++ y = pc_name, |
| 734 | +923 | ! |
- geom_point(+ label = round(pc_name, 3), |
| 735 | +924 | ! |
- data = ANL_OUTLIER,+ vjust = ifelse(pc_name > 0, -0.5, 1.3) |
| 736 | -! | +||
| 925 | +
- aes(x = as.factor(categorical_var_name), y = outlier_var_name, color = is_outlier_selected)+ ) |
||
| 737 | +926 |
), |
|
| 738 | +927 | ! |
- env = list(+ env = list(pc_name = as.name(pc)) |
| 739 | -! | +||
| 928 | +
- plot_call = plot_call,+ )+ |
+ ||
| 929 | ++ |
+ ), |
|
| 740 | +930 | ! |
- outlier_var_name = as.name(outlier_var),+ parsed_ggplot2_args$labs, |
| 741 | +931 | ! |
- categorical_var_name = as.name(categorical_var),+ parsed_ggplot2_args$ggtheme, |
| 742 | +932 | ! |
- categorical_var = categorical_var+ parsed_ggplot2_args$theme |
| 743 | +933 |
- )+ ) |
|
| 744 | +934 |
- )+ |
|
| 745 | -+ | ||
| 935 | +! |
- }+ teal.code::eval_code( |
|
| 746 | -+ | ||
| 936 | +! |
-
+ base_q, |
|
| 747 | +937 | ! |
- dev_ggplot2_args <- teal.widgets::ggplot2_args(+ substitute( |
| 748 | +938 | ! |
- labs = list(color = "Is outlier?"),+ expr = {
|
| 749 | +939 | ! |
- theme = list(legend.position = "top")+ pca_rot <- pca$rotation[, pc, drop = FALSE] %>%+ |
+
| 940 | +! | +
+ dplyr::as_tibble(rownames = "Variable") |
|
| 750 | +941 |
- )+ + |
+ |
| 942 | +! | +
+ g <- plot_call |
|
| 751 | +943 | ||
| 752 | +944 | ! |
- all_ggplot2_args <- teal.widgets::resolve_ggplot2_args(+ print(g)+ |
+
| 945 | ++ |
+ }, |
|
| 753 | +946 | ! |
- user_plot = ggplot2_args[["Boxplot"]],+ env = list( |
| 754 | +947 | ! |
- user_default = ggplot2_args$default,+ pc = pc, |
| 755 | +948 | ! |
- module_plot = dev_ggplot2_args+ plot_call = Reduce(function(x, y) call("+", x, y), ggplot_exprs)
|
| 756 | +949 |
- )+ ) |
|
| 757 | +950 | - - | -|
| 758 | -! | -
- parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(+ ) |
|
| 759 | -! | +||
| 951 | +
- all_ggplot2_args,+ ) |
||
| 760 | -! | +||
| 952 | +
- ggtheme = input$ggtheme+ } |
||
| 761 | +953 |
- )+ |
|
| 762 | +954 |
-
+ # plot final ---- |
|
| 763 | +955 | ! |
- teal.code::eval_code(+ output_q <- reactive({
|
| 764 | +956 | ! |
- common_code_q(),+ req(computation()) |
| 765 | +957 | ! |
- substitute(+ teal::validate_inputs(iv_r()) |
| 766 | +958 | ! |
- expr = g <- plot_call ++ teal::validate_inputs(iv_extra, header = "Plot settings are required") |
| 767 | -! | +||
| 959 | +
- scale_color_manual(values = c("TRUE" = "red", "FALSE" = "black")) +
+
|
||
| 768 | +960 | ! |
- labs + ggthemes + themes,+ switch(input$plot_type, |
| 769 | +961 | ! |
- env = list(+ "Elbow plot" = plot_elbow(computation()), |
| 770 | +962 | ! |
- plot_call = plot_call,+ "Circle plot" = plot_circle(computation()), |
| 771 | +963 | ! |
- labs = parsed_ggplot2_args$labs,+ "Biplot" = plot_biplot(computation()), |
| 772 | +964 | ! |
- ggthemes = parsed_ggplot2_args$ggtheme,+ "Eigenvector plot" = plot_pc_var(computation()), |
| 773 | +965 | ! |
- themes = parsed_ggplot2_args$theme+ stop("Unknown plot")
|
| 774 | +966 |
- )+ ) |
|
| 775 | +967 |
- )+ }) |
|
| 776 | +968 |
- ) %>%+ |
|
| 777 | +969 | ! |
- teal.code::eval_code(quote(print(g)))+ plot_r <- reactive({
|
| 778 | -+ | ||
| 970 | +! |
- })+ output_q()[["g"]] |
|
| 779 | +971 |
-
+ }) |
|
| 780 | +972 |
- # density plot+ |
|
| 781 | +973 | ! |
- density_plot_q <- reactive({
+ pws <- teal.widgets::plot_with_settings_srv( |
| 782 | +974 | ! |
- ANL <- common_code_q()[["ANL"]]+ id = "pca_plot", |
| 783 | +975 | ! |
- ANL_OUTLIER <- common_code_q()[["ANL_OUTLIER"]]+ plot_r = plot_r, |
| 784 | -+ | ||
| 976 | +! |
-
+ height = plot_height, |
|
| 785 | +977 | ! |
- outlier_var <- as.vector(merged$anl_input_r()$columns_source$outlier_var)+ width = plot_width, |
| 786 | +978 | ! |
- categorical_var <- as.vector(merged$anl_input_r()$columns_source$categorical_var)+ graph_align = "center" |
| 787 | +979 |
-
+ ) |
|
| 788 | +980 |
- # validation- |
- |
| 789 | -! | -
- teal::validate_has_data(ANL, 1)+ |
|
| 790 | +981 |
- # plot+ # tables ---- |
|
| 791 | +982 | ! |
- plot_call <- substitute(+ output$tbl_importance <- renderTable( |
| 792 | +983 | ! |
- expr = ANL %>%+ expr = {
|
| 793 | +984 | ! |
- ggplot(aes(x = outlier_var_name)) ++ req("importance" %in% input$tables_display, computation())
|
| 794 | +985 | ! |
- geom_density() ++ computation()[["tbl_importance"]]+ |
+
| 986 | ++ |
+ }, |
|
| 795 | +987 | ! |
- geom_rug(data = ANL_OUTLIER, aes(x = outlier_var_name, color = is_outlier_selected)) ++ bordered = TRUE, |
| 796 | +988 | ! |
- scale_color_manual(values = c("TRUE" = "red", "FALSE" = "black")),
+ align = "c", |
| 797 | +989 | ! |
- env = list(outlier_var_name = as.name(outlier_var))+ digits = 3 |
| 798 | +990 |
- )+ ) |
|
| 799 | +991 | ||
| 800 | +992 | ! |
- plot_call <- if (identical(categorical_var, character(0)) || is.null(categorical_var)) {
+ output$tbl_importance_ui <- renderUI({
|
| 801 | +993 | ! |
- substitute(expr = plot_call, env = list(plot_call = plot_call))+ req("importance" %in% input$tables_display)
|
| 802 | -+ | ||
| 994 | +! |
- } else {
+ tags$div( |
|
| 803 | +995 | ! |
- substitute(+ align = "center", |
| 804 | +996 | ! |
- expr = plot_call + facet_grid(~ reorder(categorical_var_name, order)),+ tags$h4("Principal components importance"),
|
| 805 | +997 | ! |
- env = list(plot_call = plot_call, categorical_var_name = as.name(categorical_var))+ tableOutput(session$ns("tbl_importance")),
+ |
+
| 998 | +! | +
+ tags$hr() |
|
| 806 | +999 |
- )+ ) |
|
| 807 | +1000 |
- }+ }) |
|
| 808 | +1001 | ||
| 809 | +1002 | ! |
- dev_ggplot2_args <- teal.widgets::ggplot2_args(+ output$tbl_eigenvector <- renderTable( |
| 810 | +1003 | ! |
- labs = list(color = "Is outlier?"),+ expr = {
|
| 811 | +1004 | ! |
- theme = list(legend.position = "top")+ req("eigenvector" %in% input$tables_display, req(computation()))
|
| 812 | -+ | ||
| 1005 | +! |
- )+ computation()[["tbl_eigenvector"]] |
|
| 813 | +1006 | - - | -|
| 814 | -! | -
- all_ggplot2_args <- teal.widgets::resolve_ggplot2_args(+ }, |
|
| 815 | +1007 | ! |
- user_plot = ggplot2_args[["Density Plot"]],+ bordered = TRUE, |
| 816 | +1008 | ! |
- user_default = ggplot2_args$default,+ align = "c", |
| 817 | +1009 | ! |
- module_plot = dev_ggplot2_args+ digits = 3 |
| 818 | +1010 |
- )+ ) |
|
| 819 | +1011 | ||
| 820 | +1012 | ! |
- parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(+ output$tbl_eigenvector_ui <- renderUI({
|
| 821 | +1013 | ! |
- all_ggplot2_args,+ req("eigenvector" %in% input$tables_display)
|
| 822 | +1014 | ! |
- ggtheme = input$ggtheme+ tags$div( |
| 823 | -+ | ||
| 1015 | +! |
- )+ align = "center", |
|
| 824 | -+ | ||
| 1016 | +! |
-
+ tags$h4("Eigenvectors"),
|
|
| 825 | +1017 | ! |
- teal.code::eval_code(+ tableOutput(session$ns("tbl_eigenvector")),
|
| 826 | +1018 | ! |
- common_code_q(),+ tags$hr() |
| 827 | -! | +||
| 1019 | +
- substitute(+ ) |
||
| 828 | -! | +||
| 1020 | +
- expr = g <- plot_call + labs + ggthemes + themes,+ })+ |
+ ||
| 1021 | ++ | + | |
| 829 | +1022 | ! |
- env = list(+ output$all_plots <- renderUI({
|
| 830 | +1023 | ! |
- plot_call = plot_call,+ teal::validate_inputs(iv_r()) |
| 831 | +1024 | ! |
- labs = parsed_ggplot2_args$labs,+ teal::validate_inputs(iv_extra, header = "Plot settings are required")+ |
+
| 1025 | ++ | + | |
| 832 | +1026 | ! |
- themes = parsed_ggplot2_args$theme,+ validation() |
| 833 | +1027 | ! |
- ggthemes = parsed_ggplot2_args$ggtheme+ tags$div( |
| 834 | -+ | ||
| 1028 | +! |
- )+ class = "overflow-scroll", |
|
| 835 | -+ | ||
| 1029 | +! |
- )+ uiOutput(session$ns("tbl_importance_ui")),
|
|
| 836 | -+ | ||
| 1030 | +! |
- ) %>%+ uiOutput(session$ns("tbl_eigenvector_ui")),
|
|
| 837 | +1031 | ! |
- teal.code::eval_code(quote(print(g)))+ teal.widgets::plot_with_settings_ui(id = session$ns("pca_plot"))
|
| 838 | +1032 |
- })+ ) |
|
| 839 | +1033 |
-
+ }) |
|
| 840 | +1034 |
- # Cumulative distribution plot+ |
|
| 841 | +1035 | ! |
- cumulative_plot_q <- reactive({
+ teal.widgets::verbatim_popup_srv( |
| 842 | +1036 | ! |
- ANL <- common_code_q()[["ANL"]]+ id = "rcode", |
| 843 | +1037 | ! |
- ANL_OUTLIER <- common_code_q()[["ANL_OUTLIER"]]- |
-
| 844 | -- |
-
+ verbatim_content = reactive(teal.code::get_code(output_q())), |
|
| 845 | +1038 | ! |
- qenv <- common_code_q()+ title = "R Code for PCA" |
| 846 | +1039 | - - | -|
| 847 | -! | -
- outlier_var <- as.vector(merged$anl_input_r()$columns_source$outlier_var)- |
- |
| 848 | -! | -
- categorical_var <- as.vector(merged$anl_input_r()$columns_source$categorical_var)+ ) |
|
| 849 | +1040 | ||
| 850 | +1041 |
- # validation+ ### REPORTER |
|
| 851 | +1042 | ! |
- teal::validate_has_data(ANL, 1)+ if (with_reporter) {
|
| 852 | -+ | ||
| 1043 | +! |
-
+ card_fun <- function(comment, label) {
|
|
| 853 | -+ | ||
| 1044 | +! |
- # plot+ card <- teal::report_card_template( |
|
| 854 | +1045 | ! |
- plot_call <- substitute(+ title = "Principal Component Analysis Plot", |
| 855 | +1046 | ! |
- expr = ANL %>% ggplot(aes(x = outlier_var_name)) ++ label = label, |
| 856 | +1047 | ! |
- stat_ecdf(),+ with_filter = with_filter, |
| 857 | +1048 | ! |
- env = list(outlier_var_name = as.name(outlier_var))+ filter_panel_api = filter_panel_api |
| 858 | +1049 |
- )+ ) |
|
| 859 | +1050 | ! |
- if (length(categorical_var) == 0) {
+ card$append_text("Principal Components Table", "header3")
|
| 860 | +1051 | ! |
- qenv <- teal.code::eval_code(+ card$append_table(computation()[["tbl_importance"]]) |
| 861 | +1052 | ! |
- qenv,+ card$append_text("Eigenvectors Table", "header3")
|
| 862 | +1053 | ! |
- substitute(+ card$append_table(computation()[["tbl_eigenvector"]]) |
| 863 | +1054 | ! |
- expr = {
+ card$append_text("Plot", "header3")
|
| 864 | +1055 | ! |
- ecdf_df <- ANL %>%+ card$append_plot(plot_r(), dim = pws$dim()) |
| 865 | +1056 | ! |
- dplyr::mutate(+ if (!comment == "") {
|
| 866 | +1057 | ! |
- y = stats::ecdf(ANL[[outlier_var]])(ANL[[outlier_var]])+ card$append_text("Comment", "header3")
|
| 867 | -+ | ||
| 1058 | +! |
- )+ card$append_text(comment) |
|
| 868 | +1059 |
-
+ } |
|
| 869 | +1060 | ! |
- outlier_points <- dplyr::left_join(+ card$append_src(teal.code::get_code(output_q())) |
| 870 | +1061 | ! |
- ecdf_df,+ card |
| 871 | -! | +||
| 1062 | +
- ANL_OUTLIER,+ } |
||
| 872 | +1063 | ! |
- by = dplyr::setdiff(names(ecdf_df), "y")+ teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
|
| 873 | +1064 |
- ) %>%+ } |
|
| 874 | -! | +||
| 1065 | +
- dplyr::filter(!is.na(is_outlier_selected))+ ### |
||
| 875 | +1066 |
- },+ }) |
|
| 876 | -! | +||
| 1067 | +
- env = list(outlier_var = outlier_var)+ } |
| 877 | +1 |
- )+ #' `teal` module: Univariate and bivariate visualizations |
|
| 878 | +2 |
- )+ #' |
|
| 879 | +3 |
- } else {
+ #' Module enables the creation of univariate and bivariate plots, |
|
| 880 | -! | +||
| 4 | +
- qenv <- teal.code::eval_code(+ #' facilitating the exploration of data distributions and relationships between two variables. |
||
| 881 | -! | +||
| 5 | +
- qenv,+ #' |
||
| 882 | -! | +||
| 6 | +
- substitute(+ #' This is a general module to visualize 1 & 2 dimensional data. |
||
| 883 | -! | +||
| 7 | +
- expr = {
+ #' |
||
| 884 | -! | +||
| 8 | +
- all_categories <- lapply(+ #' @note |
||
| 885 | -! | +||
| 9 | +
- unique(ANL[[categorical_var]]),+ #' For more examples, please see the vignette "Using bivariate plot" via |
||
| 886 | -! | +||
| 10 | +
- function(x) {
+ #' `vignette("using-bivariate-plot", package = "teal.modules.general")`.
|
||
| 887 | -! | +||
| 11 | +
- ANL <- ANL %>% dplyr::filter(get(categorical_var) == x)+ #' |
||
| 888 | -! | +||
| 12 | +
- anl_outlier2 <- ANL_OUTLIER %>% dplyr::filter(get(categorical_var) == x)+ #' @inheritParams teal::module |
||
| 889 | -! | +||
| 13 | +
- ecdf_df <- ANL %>%+ #' @inheritParams shared_params |
||
| 890 | -! | +||
| 14 | +
- dplyr::mutate(y = stats::ecdf(ANL[[outlier_var]])(ANL[[outlier_var]]))+ #' @param x (`data_extract_spec` or `list` of multiple `data_extract_spec`) |
||
| 891 | +15 |
-
+ #' Variable names selected to plot along the x-axis by default. |
|
| 892 | -! | +||
| 16 | +
- dplyr::left_join(+ #' Can be numeric, factor or character. |
||
| 893 | -! | +||
| 17 | +
- ecdf_df,+ #' No empty selections are allowed. |
||
| 894 | -! | +||
| 18 | +
- anl_outlier2,+ #' @param y (`data_extract_spec` or `list` of multiple `data_extract_spec`) |
||
| 895 | -! | +||
| 19 | +
- by = dplyr::setdiff(names(ecdf_df), "y")+ #' Variable names selected to plot along the y-axis by default. |
||
| 896 | +20 |
- ) %>%+ #' Can be numeric, factor or character. |
|
| 897 | -! | +||
| 21 | +
- dplyr::filter(!is.na(is_outlier_selected))+ #' @param use_density (`logical`) optional, indicates whether to plot density (`TRUE`) or frequency (`FALSE`). |
||
| 898 | +22 |
- }+ #' Defaults to frequency (`FALSE`). |
|
| 899 | +23 |
- )+ #' @param row_facet (`data_extract_spec` or `list` of multiple `data_extract_spec`) optional, |
|
| 900 | -! | +||
| 24 | +
- outlier_points <- do.call(rbind, all_categories)+ #' specification of the data variable(s) to use for faceting rows. |
||
| 901 | +25 |
- },+ #' @param col_facet (`data_extract_spec` or `list` of multiple `data_extract_spec`) optional, |
|
| 902 | -! | +||
| 26 | +
- env = list(categorical_var = categorical_var, outlier_var = outlier_var)+ #' specification of the data variable(s) to use for faceting columns. |
||
| 903 | +27 |
- )+ #' @param facet (`logical`) optional, specifies whether the facet encodings `ui` elements are toggled |
|
| 904 | +28 |
- )+ #' on and shown to the user by default. Defaults to `TRUE` if either `row_facet` or `column_facet` |
|
| 905 | -! | +||
| 29 | +
- plot_call <- substitute(+ #' are supplied. |
||
| 906 | -! | +||
| 30 | +
- expr = plot_call + facet_grid(~ reorder(categorical_var_name, order)),+ #' @param color_settings (`logical`) Whether coloring, filling and size should be applied |
||
| 907 | -! | +||
| 31 | +
- env = list(plot_call = plot_call, categorical_var_name = as.name(categorical_var))+ #' and `UI` tool offered to the user. |
||
| 908 | +32 |
- )+ #' @param color (`data_extract_spec` or `list` of multiple `data_extract_spec`) optional, |
|
| 909 | +33 |
- }+ #' specification of the data variable(s) selected for the outline color inside the coloring settings. |
|
| 910 | +34 |
-
+ #' It will be applied when `color_settings` is set to `TRUE`. |
|
| 911 | -! | +||
| 35 | +
- dev_ggplot2_args <- teal.widgets::ggplot2_args(+ #' @param fill (`data_extract_spec` or `list` of multiple `data_extract_spec`) optional, |
||
| 912 | -! | +||
| 36 | +
- labs = list(color = "Is outlier?"),+ #' specification of the data variable(s) selected for the fill color inside the coloring settings. |
||
| 913 | -! | +||
| 37 | +
- theme = list(legend.position = "top")+ #' It will be applied when `color_settings` is set to `TRUE`. |
||
| 914 | +38 |
- )+ #' @param size (`data_extract_spec` or `list` of multiple `data_extract_spec`) optional, |
|
| 915 | +39 |
-
+ #' specification of the data variable(s) selected for the size of `geom_point` plots inside the coloring settings. |
|
| 916 | -! | +||
| 40 | +
- all_ggplot2_args <- teal.widgets::resolve_ggplot2_args(+ #' It will be applied when `color_settings` is set to `TRUE`. |
||
| 917 | -! | +||
| 41 | +
- user_plot = ggplot2_args[["Cumulative Distribution Plot"]],+ #' @param free_x_scales (`logical`) optional, whether X scaling shall be changeable. |
||
| 918 | -! | +||
| 42 | +
- user_default = ggplot2_args$default,+ #' Does not allow scaling to be changed by default (`FALSE`). |
||
| 919 | -! | +||
| 43 | +
- module_plot = dev_ggplot2_args+ #' @param free_y_scales (`logical`) optional, whether Y scaling shall be changeable. |
||
| 920 | +44 |
- )+ #' Does not allow scaling to be changed by default (`FALSE`). |
|
| 921 | +45 |
-
+ #' @param swap_axes (`logical`) optional, whether to swap X and Y axes. Defaults to `FALSE`. |
|
| 922 | -! | +||
| 46 | +
- parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(+ #' |
||
| 923 | -! | +||
| 47 | +
- all_ggplot2_args,+ #' @inherit shared_params return |
||
| 924 | -! | +||
| 48 | +
- ggtheme = input$ggtheme+ #' |
||
| 925 | +49 |
- )+ #' @examplesShinylive |
|
| 926 | +50 |
-
+ #' library(teal.modules.general) |
|
| 927 | -! | +||
| 51 | +
- teal.code::eval_code(+ #' interactive <- function() TRUE |
||
| 928 | -! | +||
| 52 | +
- qenv,+ #' {{ next_example }}
|
||
| 929 | -! | +||
| 53 | +
- substitute(+ #' @examples |
||
| 930 | -! | +||
| 54 | +
- expr = g <- plot_call ++ #' # general data example |
||
| 931 | -! | +||
| 55 | +
- geom_point(data = outlier_points, aes(x = outlier_var_name, y = y, color = is_outlier_selected)) ++ #' data <- teal_data() |
||
| 932 | -! | +||
| 56 | +
- scale_color_manual(values = c("TRUE" = "red", "FALSE" = "black")) +
+ #' data <- within(data, {
|
||
| 933 | -! | +||
| 57 | +
- labs + ggthemes + themes,+ #' require(nestcolor) |
||
| 934 | -! | +||
| 58 | +
- env = list(+ #' CO2 <- data.frame(CO2) |
||
| 935 | -! | +||
| 59 | +
- plot_call = plot_call,+ #' }) |
||
| 936 | -! | +||
| 60 | +
- outlier_var_name = as.name(outlier_var),+ #' |
||
| 937 | -! | +||
| 61 | +
- labs = parsed_ggplot2_args$labs,+ #' app <- init( |
||
| 938 | -! | +||
| 62 | +
- themes = parsed_ggplot2_args$theme,+ #' data = data, |
||
| 939 | -! | +||
| 63 | +
- ggthemes = parsed_ggplot2_args$ggtheme+ #' modules = tm_g_bivariate( |
||
| 940 | +64 |
- )+ #' x = data_extract_spec( |
|
| 941 | +65 |
- )+ #' dataname = "CO2", |
|
| 942 | +66 |
- ) %>%+ #' select = select_spec( |
|
| 943 | -! | +||
| 67 | +
- teal.code::eval_code(quote(print(g)))+ #' label = "Select variable:", |
||
| 944 | +68 |
- })+ #' choices = variable_choices(data[["CO2"]]), |
|
| 945 | +69 |
-
+ #' selected = "conc", |
|
| 946 | -! | +||
| 70 | +
- final_q <- reactive({
+ #' fixed = FALSE |
||
| 947 | -! | +||
| 71 | +
- req(input$tabs)+ #' ) |
||
| 948 | -! | +||
| 72 | +
- tab_type <- input$tabs+ #' ), |
||
| 949 | -! | +||
| 73 | +
- result_q <- if (tab_type == "Boxplot") {
+ #' y = data_extract_spec( |
||
| 950 | -! | +||
| 74 | +
- boxplot_q()+ #' dataname = "CO2", |
||
| 951 | -! | +||
| 75 | +
- } else if (tab_type == "Density Plot") {
+ #' select = select_spec( |
||
| 952 | -! | +||
| 76 | +
- density_plot_q()+ #' label = "Select variable:", |
||
| 953 | -! | +||
| 77 | +
- } else if (tab_type == "Cumulative Distribution Plot") {
+ #' choices = variable_choices(data[["CO2"]]), |
||
| 954 | -! | +||
| 78 | +
- cumulative_plot_q()+ #' selected = "uptake", |
||
| 955 | +79 |
- }+ #' multiple = FALSE, |
|
| 956 | +80 |
- # used to display table when running show-r-code code+ #' fixed = FALSE |
|
| 957 | +81 |
- # added after the plots so that a change in selected columns doesn't affect+ #' ) |
|
| 958 | +82 |
- # brush selection.+ #' ), |
|
| 959 | -! | +||
| 83 | +
- teal.code::eval_code(+ #' row_facet = data_extract_spec( |
||
| 960 | -! | +||
| 84 | +
- result_q,+ #' dataname = "CO2", |
||
| 961 | -! | +||
| 85 | +
- substitute(+ #' select = select_spec( |
||
| 962 | -! | +||
| 86 | +
- expr = {
+ #' label = "Select variable:", |
||
| 963 | -! | +||
| 87 | +
- columns_index <- union(+ #' choices = variable_choices(data[["CO2"]]), |
||
| 964 | -! | +||
| 88 | +
- setdiff(names(ANL_OUTLIER), c("is_outlier_selected", "order")),
+ #' selected = "Type", |
||
| 965 | -! | +||
| 89 | +
- table_columns+ #' fixed = FALSE |
||
| 966 | +90 |
- )- |
- |
| 967 | -! | -
- ANL_OUTLIER_EXTENDED[ANL_OUTLIER_EXTENDED$is_outlier_selected, columns_index]+ #' ) |
|
| 968 | +91 |
- },+ #' ), |
|
| 969 | -! | +||
| 92 | +
- env = list(+ #' col_facet = data_extract_spec( |
||
| 970 | -! | +||
| 93 | +
- table_columns = input$table_ui_columns+ #' dataname = "CO2", |
||
| 971 | +94 |
- )+ #' select = select_spec( |
|
| 972 | +95 |
- )+ #' label = "Select variable:", |
|
| 973 | +96 |
- )+ #' choices = variable_choices(data[["CO2"]]), |
|
| 974 | +97 |
- })+ #' selected = "Treatment", |
|
| 975 | +98 |
-
+ #' fixed = FALSE |
|
| 976 | +99 |
- # slider text+ #' ) |
|
| 977 | -! | +||
| 100 | +
- output$ui_outlier_help <- renderUI({
+ #' ) |
||
| 978 | -! | +||
| 101 | +
- req(input$method)+ #' ) |
||
| 979 | -! | +||
| 102 | +
- if (input$method == "IQR") {
+ #' ) |
||
| 980 | -! | +||
| 103 | +
- req(input$iqr_slider)+ #' if (interactive()) {
|
||
| 981 | -! | +||
| 104 | +
- tags$small(+ #' shinyApp(app$ui, app$server) |
||
| 982 | -! | +||
| 105 | +
- withMathJax(+ #' } |
||
| 983 | -! | +||
| 106 | +
- helpText(+ #' |
||
| 984 | -! | +||
| 107 | +
- "Outlier data points (\\(x \\lt Q1 - ", input$iqr_slider, "\\times IQR\\) or \\(+ #' @examplesShinylive |
||
| 985 | -! | +||
| 108 | +
- Q3 + ", input$iqr_slider, "\\times IQR \\lt x\\))+ #' library(teal.modules.general) |
||
| 986 | -! | +||
| 109 | +
- are displayed in red on the plot and can be visualized in the table below."+ #' interactive <- function() TRUE |
||
| 987 | +110 |
- ),+ #' {{ next_example }}
|
|
| 988 | -! | +||
| 111 | +
- if (input$split_outliers) {
+ #' @examples |
||
| 989 | -! | +||
| 112 | +
- withMathJax(helpText("Note: Quantiles are calculated per group."))
+ #' # CDISC data example |
||
| 990 | +113 |
- }+ #' data <- teal_data() |
|
| 991 | +114 |
- )+ #' data <- within(data, {
|
|
| 992 | +115 |
- )+ #' require(nestcolor) |
|
| 993 | -! | +||
| 116 | +
- } else if (input$method == "Z-score") {
+ #' ADSL <- rADSL |
||
| 994 | -! | +||
| 117 | +
- req(input$zscore_slider)+ #' }) |
||
| 995 | -! | +||
| 118 | +
- tags$small(+ #' join_keys(data) <- default_cdisc_join_keys[names(data)] |
||
| 996 | -! | +||
| 119 | +
- withMathJax(+ #' |
||
| 997 | -! | +||
| 120 | +
- helpText(+ #' app <- init( |
||
| 998 | -! | +||
| 121 | +
- "Outlier data points (\\(Zscore(x) < -", input$zscore_slider,+ #' data = data, |
||
| 999 | -! | +||
| 122 | +
- "\\) or \\(", input$zscore_slider, "< Zscore(x) \\))
+ #' modules = tm_g_bivariate( |
||
| 1000 | -! | +||
| 123 | +
- are displayed in red on the plot and can be visualized in the table below."+ #' x = data_extract_spec( |
||
| 1001 | +124 |
- ),+ #' dataname = "ADSL", |
|
| 1002 | -! | +||
| 125 | +
- if (input$split_outliers) {
+ #' select = select_spec( |
||
| 1003 | -! | +||
| 126 | +
- withMathJax(helpText(" Note: Z-scores are calculated per group."))
+ #' label = "Select variable:", |
||
| 1004 | +127 |
- }+ #' choices = variable_choices(data[["ADSL"]]), |
|
| 1005 | +128 |
- )+ #' selected = "AGE", |
|
| 1006 | +129 |
- )+ #' fixed = FALSE |
|
| 1007 | -! | +||
| 130 | +
- } else if (input$method == "Percentile") {
+ #' ) |
||
| 1008 | -! | +||
| 131 | +
- req(input$percentile_slider)+ #' ), |
||
| 1009 | -! | +||
| 132 | +
- tags$small(+ #' y = data_extract_spec( |
||
| 1010 | -! | +||
| 133 | +
- withMathJax(+ #' dataname = "ADSL", |
||
| 1011 | -! | +||
| 134 | +
- helpText(+ #' select = select_spec( |
||
| 1012 | -! | +||
| 135 | +
- "Outlier/extreme data points (\\( Percentile(x) <", input$percentile_slider,+ #' label = "Select variable:", |
||
| 1013 | -! | +||
| 136 | +
- "\\) or \\(", 1 - input$percentile_slider, " < Percentile(x) \\))
+ #' choices = variable_choices(data[["ADSL"]]), |
||
| 1014 | -! | +||
| 137 | +
- are displayed in red on the plot and can be visualized in the table below."+ #' selected = "SEX", |
||
| 1015 | +138 |
- ),+ #' multiple = FALSE, |
|
| 1016 | -! | +||
| 139 | +
- if (input$split_outliers) {
+ #' fixed = FALSE |
||
| 1017 | -! | +||
| 140 | +
- withMathJax(helpText("Note: Percentiles are calculated per group."))
+ #' ) |
||
| 1018 | +141 |
- }+ #' ), |
|
| 1019 | +142 |
- )+ #' row_facet = data_extract_spec( |
|
| 1020 | +143 |
- )+ #' dataname = "ADSL", |
|
| 1021 | +144 |
- }+ #' select = select_spec( |
|
| 1022 | +145 |
- })+ #' label = "Select variable:", |
|
| 1023 | +146 |
-
+ #' choices = variable_choices(data[["ADSL"]]), |
|
| 1024 | -! | +||
| 147 | +
- boxplot_r <- reactive({
+ #' selected = "ARM", |
||
| 1025 | -! | +||
| 148 | +
- teal::validate_inputs(iv_r())+ #' fixed = FALSE |
||
| 1026 | -! | +||
| 149 | +
- boxplot_q()[["g"]]+ #' ) |
||
| 1027 | +150 |
- })+ #' ), |
|
| 1028 | -! | +||
| 151 | +
- density_plot_r <- reactive({
+ #' col_facet = data_extract_spec( |
||
| 1029 | -! | +||
| 152 | +
- teal::validate_inputs(iv_r())+ #' dataname = "ADSL", |
||
| 1030 | -! | +||
| 153 | +
- density_plot_q()[["g"]]+ #' select = select_spec( |
||
| 1031 | +154 |
- })+ #' label = "Select variable:", |
|
| 1032 | -! | +||
| 155 | +
- cumulative_plot_r <- reactive({
+ #' choices = variable_choices(data[["ADSL"]]), |
||
| 1033 | -! | +||
| 156 | +
- teal::validate_inputs(iv_r())+ #' selected = "COUNTRY", |
||
| 1034 | -! | +||
| 157 | +
- cumulative_plot_q()[["g"]]+ #' fixed = FALSE |
||
| 1035 | +158 |
- })+ #' ) |
|
| 1036 | +159 |
-
+ #' ) |
|
| 1037 | -! | +||
| 160 | +
- box_pws <- teal.widgets::plot_with_settings_srv(+ #' ) |
||
| 1038 | -! | +||
| 161 | +
- id = "box_plot",+ #' ) |
||
| 1039 | -! | +||
| 162 | +
- plot_r = boxplot_r,+ #' if (interactive()) {
|
||
| 1040 | -! | +||
| 163 | +
- height = plot_height,+ #' shinyApp(app$ui, app$server) |
||
| 1041 | -! | +||
| 164 | +
- width = plot_width,+ #' } |
||
| 1042 | -! | +||
| 165 | +
- brushing = TRUE+ #' |
||
| 1043 | +166 |
- )+ #' @export |
|
| 1044 | +167 | - - | -|
| 1045 | -! | -
- density_pws <- teal.widgets::plot_with_settings_srv(- |
- |
| 1046 | -! | -
- id = "density_plot",- |
- |
| 1047 | -! | -
- plot_r = density_plot_r,- |
- |
| 1048 | -! | -
- height = plot_height,+ #' |
|
| 1049 | -! | +||
| 168 | +
- width = plot_width,+ tm_g_bivariate <- function(label = "Bivariate Plots", |
||
| 1050 | -! | +||
| 169 | +
- brushing = TRUE+ x, |
||
| 1051 | +170 |
- )+ y, |
|
| 1052 | +171 |
-
+ row_facet = NULL, |
|
| 1053 | -! | +||
| 172 | +
- cum_density_pws <- teal.widgets::plot_with_settings_srv(+ col_facet = NULL, |
||
| 1054 | -! | +||
| 173 | +
- id = "cum_density_plot",+ facet = !is.null(row_facet) || !is.null(col_facet), |
||
| 1055 | -! | +||
| 174 | +
- plot_r = cumulative_plot_r,+ color = NULL, |
||
| 1056 | -! | +||
| 175 | +
- height = plot_height,+ fill = NULL, |
||
| 1057 | -! | +||
| 176 | +
- width = plot_width,+ size = NULL, |
||
| 1058 | -! | +||
| 177 | +
- brushing = TRUE+ use_density = FALSE, |
||
| 1059 | +178 |
- )+ color_settings = FALSE, |
|
| 1060 | +179 |
-
+ free_x_scales = FALSE, |
|
| 1061 | -! | +||
| 180 | +
- choices <- reactive(teal.transform::variable_choices(data()[[dataname_first]]))+ free_y_scales = FALSE, |
||
| 1062 | +181 |
-
+ plot_height = c(600, 200, 2000), |
|
| 1063 | -! | +||
| 182 | +
- observeEvent(common_code_q(), {
+ plot_width = NULL, |
||
| 1064 | -! | +||
| 183 | +
- ANL_OUTLIER <- common_code_q()[["ANL_OUTLIER"]]+ rotate_xaxis_labels = FALSE, |
||
| 1065 | -! | +||
| 184 | +
- teal.widgets::updateOptionalSelectInput(+ swap_axes = FALSE, |
||
| 1066 | -! | +||
| 185 | +
- session,+ ggtheme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void"),
|
||
| 1067 | -! | +||
| 186 | +
- inputId = "table_ui_columns",+ ggplot2_args = teal.widgets::ggplot2_args(), |
||
| 1068 | -! | +||
| 187 | +
- choices = dplyr::setdiff(choices(), names(ANL_OUTLIER)),+ pre_output = NULL, |
||
| 1069 | -! | +||
| 188 | +
- selected = restoreInput(ns("table_ui_columns"), isolate(input$table_ui_columns))
+ post_output = NULL) {
|
||
| 1070 | -+ | ||
| 189 | +18x |
- )+ message("Initializing tm_g_bivariate")
|
|
| 1071 | +190 |
- })+ |
|
| 1072 | +191 |
-
+ # Normalize the parameters |
|
| 1073 | -! | +||
| 192 | +14x |
- output$table_ui <- DT::renderDataTable(+ if (inherits(x, "data_extract_spec")) x <- list(x) |
|
| 1074 | -! | +||
| 193 | +13x |
- expr = {
+ if (inherits(y, "data_extract_spec")) y <- list(y) |
|
| 1075 | -! | +||
| 194 | +1x |
- tab <- input$tabs+ if (inherits(row_facet, "data_extract_spec")) row_facet <- list(row_facet) |
|
| 1076 | -! | +||
| 195 | +1x |
- req(tab) # tab is NULL upon app launch, hence will crash without this statement+ if (inherits(col_facet, "data_extract_spec")) col_facet <- list(col_facet) |
|
| 1077 | -! | +||
| 196 | +1x |
- req(iv_r()$is_valid()) # Same validation as output$table_ui_wrap+ if (inherits(color, "data_extract_spec")) color <- list(color) |
|
| 1078 | -! | +||
| 197 | +1x |
- outlier_var <- as.vector(merged$anl_input_r()$columns_source$outlier_var)+ if (inherits(fill, "data_extract_spec")) fill <- list(fill) |
|
| 1079 | -! | +||
| 198 | +1x |
- categorical_var <- as.vector(merged$anl_input_r()$columns_source$categorical_var)+ if (inherits(size, "data_extract_spec")) size <- list(size) |
|
| 1080 | +199 | ||
| 1081 | -! | -
- ANL_OUTLIER <- common_code_q()[["ANL_OUTLIER"]]- |
- |
| 1082 | -! | +||
| 200 | +
- ANL_OUTLIER_EXTENDED <- common_code_q()[["ANL_OUTLIER_EXTENDED"]]+ # Start of assertions |
||
| 1083 | -! | +||
| 201 | +18x |
- ANL <- common_code_q()[["ANL"]]+ checkmate::assert_string(label) |
|
| 1084 | +202 | ||
| 1085 | -! | +||
| 203 | +18x |
- plot_brush <- if (tab == "Boxplot") {
+ checkmate::assert_list(x, types = "data_extract_spec") |
|
| 1086 | -! | +||
| 204 | +18x |
- boxplot_r()+ assert_single_selection(x) |
|
| 1087 | -! | +||
| 205 | +
- box_pws$brush()+ |
||
| 1088 | -! | +||
| 206 | +16x |
- } else if (tab == "Density Plot") {
+ checkmate::assert_list(y, types = "data_extract_spec") |
|
| 1089 | -! | +||
| 207 | +16x |
- density_plot_r()+ assert_single_selection(y) |
|
| 1090 | -! | +||
| 208 | +
- density_pws$brush()+ |
||
| 1091 | -! | +||
| 209 | +14x |
- } else if (tab == "Cumulative Distribution Plot") {
+ checkmate::assert_list(row_facet, types = "data_extract_spec", null.ok = TRUE) |
|
| 1092 | -! | +||
| 210 | +14x |
- cumulative_plot_r()+ assert_single_selection(row_facet) |
|
| 1093 | -! | +||
| 211 | +
- cum_density_pws$brush()+ |
||
| 1094 | -+ | ||
| 212 | +14x |
- }+ checkmate::assert_list(col_facet, types = "data_extract_spec", null.ok = TRUE) |
|
| 1095 | -+ | ||
| 213 | +14x |
-
+ assert_single_selection(col_facet) |
|
| 1096 | +214 |
- # removing unused column ASAP+ |
|
| 1097 | -! | +||
| 215 | +14x |
- ANL_OUTLIER$order <- ANL$order <- NULL+ checkmate::assert_flag(facet) |
|
| 1098 | +216 | ||
| 1099 | -! | +||
| 217 | +14x |
- display_table <- if (!is.null(plot_brush)) {
+ checkmate::assert_list(color, types = "data_extract_spec", null.ok = TRUE) |
|
| 1100 | -! | +||
| 218 | +14x |
- if (length(categorical_var) > 0) {
+ assert_single_selection(color) |
|
| 1101 | +219 |
- # due to reordering, the x-axis label may be changed to something like "reorder(categorical_var, order)"+ |
|
| 1102 | -! | +||
| 220 | +14x |
- if (tab == "Boxplot") {
+ checkmate::assert_list(fill, types = "data_extract_spec", null.ok = TRUE) |
|
| 1103 | -! | +||
| 221 | +14x |
- plot_brush$mapping$x <- categorical_var+ assert_single_selection(fill) |
|
| 1104 | +222 |
- } else {
+
|
|
| 1105 | -+ | ||
| 223 | +14x |
- # the other plots use facetting+ checkmate::assert_list(size, types = "data_extract_spec", null.ok = TRUE)+ |
+ |
| 224 | +14x | +
+ assert_single_selection(size) |
|
| 1106 | +225 |
- # so it is panelvar1 that gets relabelled to "reorder(categorical_var, order)"+ |
|
| 1107 | -! | +||
| 226 | +14x |
- plot_brush$mapping$panelvar1 <- categorical_var+ checkmate::assert_flag(use_density) |
|
| 1108 | +227 |
- }+ |
|
| 1109 | +228 |
- } else {
+ # Determines color, fill & size if they are not explicitly set |
|
| 1110 | -! | +||
| 229 | +14x |
- if (tab == "Boxplot") {
+ checkmate::assert_flag(color_settings) |
|
| 1111 | -+ | ||
| 230 | +14x |
- # in boxplot with no categorical variable, there is no column in ANL that would correspond to x-axis+ if (color_settings) {
|
|
| 1112 | -+ | ||
| 231 | +2x |
- # so a column needs to be inserted with the value "Entire dataset" because that's the label used in plot+ if (is.null(color)) {
|
|
| 1113 | -! | +||
| 232 | +2x |
- ANL[[plot_brush$mapping$x]] <- "Entire dataset"+ color <- x |
|
| 1114 | -+ | ||
| 233 | +2x |
- }+ color[[1]]$select <- teal.transform::select_spec(choices = color[[1]]$select$choices, selected = NULL) |
|
| 1115 | +234 |
- }+ } |
|
| 1116 | -+ | ||
| 235 | +2x |
-
+ if (is.null(fill)) {
|
|
| 1117 | -- |
- # in density and cumulative plots, ANL does not have a column corresponding to y-axis.- |
- |
| 1118 | -- |
- # so they need to be computed and attached to ANL- |
- |
| 1119 | -! | -
- if (tab == "Density Plot") {
- |
- |
| 1120 | -! | +||
| 236 | +2x |
- plot_brush$mapping$y <- "density"+ fill <- x |
|
| 1121 | -! | +||
| 237 | +2x |
- ANL$density <- plot_brush$ymin+ fill[[1]]$select <- teal.transform::select_spec(choices = fill[[1]]$select$choices, selected = NULL) |
|
| 1122 | +238 |
- # either ymin or ymax will work- |
- |
| 1123 | -! | -
- } else if (tab == "Cumulative Distribution Plot") {
+ } |
|
| 1124 | -! | +||
| 239 | +2x |
- plot_brush$mapping$y <- "cdf"+ if (is.null(size)) {
|
|
| 1125 | -! | +||
| 240 | +2x |
- if (length(categorical_var) > 0) {
+ size <- x |
|
| 1126 | -! | +||
| 241 | +2x |
- ANL <- ANL %>%+ size[[1]]$select <- teal.transform::select_spec(choices = size[[1]]$select$choices, selected = NULL) |
|
| 1127 | -! | +||
| 242 | +
- dplyr::group_by(!!as.name(plot_brush$mapping$panelvar1)) %>%+ } |
||
| 1128 | -! | +||
| 243 | +
- dplyr::mutate(cdf = stats::ecdf(!!as.name(outlier_var))(!!as.name(outlier_var)))+ } else {
|
||
| 1129 | -+ | ||
| 244 | +12x |
- } else {
+ if (!is.null(c(color, fill, size))) {
|
|
| 1130 | -! | +||
| 245 | +3x |
- ANL$cdf <- stats::ecdf(ANL[[outlier_var]])(ANL[[outlier_var]])+ stop("'color_settings' argument needs to be set to TRUE if 'color', 'fill', and/or 'size' is/are supplied.")
|
|
| 1131 | +246 |
- }+ } |
|
| 1132 | +247 |
- }+ } |
|
| 1133 | +248 | ||
| 1134 | -! | -
- brushed_rows <- brushedPoints(ANL, plot_brush)- |
- |
| 1135 | -! | +||
| 249 | +11x |
- if (nrow(brushed_rows) > 0) {
+ checkmate::assert_flag(free_x_scales) |
|
| 1136 | -+ | ||
| 250 | +11x |
- # now we need to remove extra column from ANL so that it will have the same columns as ANL_OUTLIER+ checkmate::assert_flag(free_y_scales) |
|
| 1137 | +251 |
- # so that dplyr::intersect will work+ |
|
| 1138 | -! | +||
| 252 | +11x |
- if (tab == "Density Plot") {
+ checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE) |
|
| 1139 | -! | +||
| 253 | +10x |
- brushed_rows$density <- NULL+ checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height") |
|
| 1140 | -! | +||
| 254 | +8x |
- } else if (tab == "Cumulative Distribution Plot") {
+ checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE) |
|
| 1141 | -! | +||
| 255 | +7x |
- brushed_rows$cdf <- NULL+ checkmate::assert_numeric( |
|
| 1142 | -! | +||
| 256 | +7x |
- } else if (tab == "Boxplot" && length(categorical_var) == 0) {
+ plot_width[1], |
|
| 1143 | -! | +||
| 257 | +7x |
- brushed_rows[[plot_brush$mapping$x]] <- NULL+ lower = plot_width[2], upper = plot_width[3], null.ok = TRUE, .var.name = "plot_width" |
|
| 1144 | +258 |
- }+ ) |
|
| 1145 | +259 |
- # is_outlier_selected is part of ANL_OUTLIER so needed here+ |
|
| 1146 | -! | +||
| 260 | +5x |
- brushed_rows$is_outlier_selected <- TRUE+ checkmate::assert_flag(rotate_xaxis_labels) |
|
| 1147 | -! | +||
| 261 | +5x |
- dplyr::intersect(ANL_OUTLIER, brushed_rows)+ checkmate::assert_flag(swap_axes) |
|
| 1148 | +262 |
- } else {
+
|
|
| 1149 | -! | +||
| 263 | +5x |
- ANL_OUTLIER[0, ]+ ggtheme <- match.arg(ggtheme) |
|
| 1150 | -+ | ||
| 264 | +5x |
- }+ checkmate::assert_class(ggplot2_args, "ggplot2_args") |
|
| 1151 | +265 |
- } else {
+
|
|
| 1152 | -! | +||
| 266 | +5x |
- ANL_OUTLIER[ANL_OUTLIER$is_outlier_selected, ]+ checkmate::assert_multi_class(pre_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
|
|
| 1153 | -+ | ||
| 267 | +5x |
- }+ checkmate::assert_multi_class(post_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
|
|
| 1154 | +268 | - - | -|
| 1155 | -! | -
- display_table$is_outlier_selected <- NULL+ # End of assertions |
|
| 1156 | +269 | ||
| 1157 | +270 |
- # Extend the brushed ANL_OUTLIER with additional columns- |
- |
| 1158 | -! | -
- dplyr::left_join(- |
- |
| 1159 | -! | -
- display_table,+ # Make UI args |
|
| 1160 | -! | +||
| 271 | +5x |
- dplyr::select(ANL_OUTLIER_EXTENDED, -"is_outlier_selected"),+ args <- as.list(environment()) |
|
| 1161 | -! | +||
| 272 | +
- by = names(display_table)+ |
||
| 1162 | -+ | ||
| 273 | +5x |
- ) %>%+ data_extract_list <- list( |
|
| 1163 | -! | +||
| 274 | +5x |
- dplyr::select(union(names(display_table), input$table_ui_columns))+ x = x, |
|
| 1164 | -+ | ||
| 275 | +5x |
- },+ y = y, |
|
| 1165 | -! | +||
| 276 | +5x |
- options = list(+ row_facet = row_facet, |
|
| 1166 | -! | +||
| 277 | +5x |
- searching = FALSE, language = list(+ col_facet = col_facet, |
|
| 1167 | -! | +||
| 278 | +5x |
- zeroRecords = "The brushed area does not contain outlier observations for the currently defined threshold"+ color_settings = color_settings, |
|
| 1168 | -+ | ||
| 279 | +5x |
- ),+ color = color, |
|
| 1169 | -! | +||
| 280 | +5x |
- pageLength = input$table_ui_rows+ fill = fill, |
|
| 1170 | -+ | ||
| 281 | +5x |
- )+ size = size |
|
| 1171 | +282 |
- )+ ) |
|
| 1172 | +283 | ||
| 1173 | -! | +||
| 284 | +5x |
- output$total_outliers <- renderUI({
+ ans <- module( |
|
| 1174 | -! | +||
| 285 | +5x |
- req(iv_r()$is_valid())+ label = label, |
|
| 1175 | -! | +||
| 286 | +5x |
- ANL <- merged$anl_q_r()[["ANL"]]+ server = srv_g_bivariate, |
|
| 1176 | -! | +||
| 287 | +5x |
- ANL_OUTLIER <- common_code_q()[["ANL_OUTLIER"]]+ ui = ui_g_bivariate, |
|
| 1177 | -! | +||
| 288 | +5x |
- teal::validate_has_data(ANL, 1)+ ui_args = args, |
|
| 1178 | -! | +||
| 289 | +5x |
- ANL_OUTLIER_SELECTED <- ANL_OUTLIER[ANL_OUTLIER$is_outlier_selected, ]+ server_args = c( |
|
| 1179 | -! | +||
| 290 | +5x |
- tags$h5(+ data_extract_list, |
|
| 1180 | -! | +||
| 291 | +5x |
- sprintf(+ list(plot_height = plot_height, plot_width = plot_width, ggplot2_args = ggplot2_args) |
|
| 1181 | -! | +||
| 292 | +
- "%s %d / %d [%.02f%%]",+ ), |
||
| 1182 | -! | +||
| 293 | +5x |
- "Total number of outlier(s):",+ datanames = teal.transform::get_extract_datanames(data_extract_list) |
|
| 1183 | -! | +||
| 294 | +
- nrow(ANL_OUTLIER_SELECTED),+ ) |
||
| 1184 | -! | +||
| 295 | +5x |
- nrow(ANL),+ attr(ans, "teal_bookmarkable") <- TRUE |
|
| 1185 | -! | +||
| 296 | +5x |
- 100 * nrow(ANL_OUTLIER_SELECTED) / nrow(ANL)+ ans |
|
| 1186 | +297 |
- )+ } |
|
| 1187 | +298 |
- )+ |
|
| 1188 | +299 |
- })+ # UI function for the bivariate module |
|
| 1189 | +300 |
-
+ ui_g_bivariate <- function(id, ...) {
|
|
| 1190 | +301 | ! |
- output$total_missing <- renderUI({
+ args <- list(...) |
| 1191 | +302 | ! |
- if (n_outlier_missing() > 0) {
+ is_single_dataset_value <- teal.transform::is_single_dataset( |
| 1192 | +303 | ! |
- ANL <- merged$anl_q_r()[["ANL"]]+ args$x, args$y, args$row_facet, args$col_facet, args$color, args$fill, args$size |
| 1193 | -! | +||
| 304 | +
- helpText(+ ) |
||
| 1194 | -! | +||
| 305 | +
- sprintf(+ |
||
| 1195 | +306 | ! |
- "%s %d / %d [%.02f%%]",+ ns <- NS(id) |
| 1196 | +307 | ! |
- "Total number of row(s) with missing values:",+ teal.widgets::standard_layout( |
| 1197 | +308 | ! |
- n_outlier_missing(),+ output = teal.widgets::white_small_well( |
| 1198 | +309 | ! |
- nrow(ANL),+ tags$div(teal.widgets::plot_with_settings_ui(id = ns("myplot")))
+ |
+
| 310 | ++ |
+ ), |
|
| 1199 | +311 | ! |
- 100 * (n_outlier_missing()) / nrow(ANL)+ encoding = tags$div( |
| 1200 | +312 |
- )+ ### Reporter |
|
| 1201 | -+ | ||
| 313 | +! |
- )+ teal.reporter::simple_reporter_ui(ns("simple_reporter")),
|
|
| 1202 | +314 |
- }+ ### |
|
| 1203 | -+ | ||
| 315 | +! |
- })+ tags$label("Encodings", class = "text-primary"),
|
|
| 1204 | -+ | ||
| 316 | +! |
-
+ teal.transform::datanames_input(args[c("x", "y", "row_facet", "col_facet", "color", "fill", "size")]),
|
|
| 1205 | +317 | ! |
- output$table_ui_wrap <- renderUI({
+ teal.transform::data_extract_ui( |
| 1206 | +318 | ! |
- req(iv_r()$is_valid())+ id = ns("x"),
|
| 1207 | +319 | ! |
- tagList(+ label = "X variable", |
| 1208 | +320 | ! |
- teal.widgets::optionalSelectInput(+ data_extract_spec = args$x, |
| 1209 | +321 | ! |
- inputId = ns("table_ui_columns"),
+ is_single_dataset = is_single_dataset_value+ |
+
| 322 | ++ |
+ ), |
|
| 1210 | +323 | ! |
- label = "Choose additional columns",+ teal.transform::data_extract_ui( |
| 1211 | +324 | ! |
- choices = NULL,+ id = ns("y"),
|
| 1212 | +325 | ! |
- selected = NULL,+ label = "Y variable", |
| 1213 | +326 | ! |
- multiple = TRUE+ data_extract_spec = args$y,+ |
+
| 327 | +! | +
+ is_single_dataset = is_single_dataset_value |
|
| 1214 | +328 |
- ),+ ), |
|
| 1215 | +329 | ! |
- tags$h4("Outlier Table"),
+ conditionalPanel( |
| 1216 | +330 | ! |
- teal.widgets::get_dt_rows(ns("table_ui"), ns("table_ui_rows"))
+ condition = |
| 1217 | -+ | ||
| 331 | +! |
- )+ "$(\"button[data-id*='-x-dataset'][data-id$='-select']\").text() == '- Nothing selected - ' || |
|
| 1218 | -+ | ||
| 332 | +! |
- })+ $(\"button[data-id*='-y-dataset'][data-id$='-select']\").text() == '- Nothing selected - ' ", |
|
| 1219 | -+ | ||
| 333 | +! |
-
+ shinyWidgets::radioGroupButtons( |
|
| 1220 | +334 | ! |
- teal.widgets::verbatim_popup_srv(+ inputId = ns("use_density"),
|
| 1221 | +335 | ! |
- id = "rcode",+ label = NULL, |
| 1222 | +336 | ! |
- verbatim_content = reactive(teal.code::get_code(final_q())),+ choices = c("frequency", "density"),
|
| 1223 | +337 | ! |
- title = "Show R Code for Outlier"+ selected = ifelse(args$use_density, "density", "frequency"), |
| 1224 | -+ | ||
| 338 | +! |
- )+ justified = TRUE |
|
| 1225 | +339 |
-
+ ) |
|
| 1226 | +340 |
- ### REPORTER+ ), |
|
| 1227 | +341 | ! |
- if (with_reporter) {
+ if (!is.null(args$row_facet) || !is.null(args$col_facet)) {
|
| 1228 | +342 | ! |
- card_fun <- function(comment, label) {
+ tags$div( |
| 1229 | +343 | ! |
- tab_type <- input$tabs+ class = "data-extract-box", |
| 1230 | +344 | ! |
- card <- teal::report_card_template(+ tags$label("Facetting"),
|
| 1231 | +345 | ! |
- title = paste0("Outliers - ", tab_type),
+ shinyWidgets::switchInput(inputId = ns("facetting"), value = args$facet, size = "mini"),
|
| 1232 | +346 | ! |
- label = label,+ conditionalPanel( |
| 1233 | +347 | ! |
- with_filter = with_filter,+ condition = paste0("input['", ns("facetting"), "']"),
|
| 1234 | +348 | ! |
- filter_panel_api = filter_panel_api+ tags$div( |
| 1235 | -+ | ||
| 349 | +! |
- )+ if (!is.null(args$row_facet)) {
|
|
| 1236 | +350 | ! |
- categorical_var <- as.vector(merged$anl_input_r()$columns_source$categorical_var)+ teal.transform::data_extract_ui( |
| 1237 | +351 | ! |
- if (length(categorical_var) > 0) {
+ id = ns("row_facet"),
|
| 1238 | +352 | ! |
- summary_table <- common_code_q()[["summary_table"]]+ label = "Row facetting variable", |
| 1239 | +353 | ! |
- card$append_text("Summary Table", "header3")
+ data_extract_spec = args$row_facet, |
| 1240 | +354 | ! |
- card$append_table(summary_table)+ is_single_dataset = is_single_dataset_value |
| 1241 | +355 |
- }+ ) |
|
| 1242 | -! | +||
| 356 | +
- card$append_text("Plot", "header3")
+ }, |
||
| 1243 | +357 | ! |
- if (tab_type == "Boxplot") {
+ if (!is.null(args$col_facet)) {
|
| 1244 | +358 | ! |
- card$append_plot(boxplot_r(), dim = box_pws$dim())+ teal.transform::data_extract_ui( |
| 1245 | +359 | ! |
- } else if (tab_type == "Density Plot") {
+ id = ns("col_facet"),
|
| 1246 | +360 | ! |
- card$append_plot(density_plot_r(), dim = density_pws$dim())+ label = "Column facetting variable", |
| 1247 | +361 | ! |
- } else if (tab_type == "Cumulative Distribution Plot") {
+ data_extract_spec = args$col_facet, |
| 1248 | +362 | ! |
- card$append_plot(cumulative_plot_r(), dim = cum_density_pws$dim())+ is_single_dataset = is_single_dataset_value |
| 1249 | +363 |
- }+ ) |
|
| 1250 | -! | +||
| 364 | +
- if (!comment == "") {
+ }, |
||
| 1251 | +365 | ! |
- card$append_text("Comment", "header3")
+ checkboxInput(ns("free_x_scales"), "free x scales", value = args$free_x_scales),
|
| 1252 | +366 | ! |
- card$append_text(comment)+ checkboxInput(ns("free_y_scales"), "free y scales", value = args$free_y_scales)
|
| 1253 | +367 |
- }+ ) |
|
| 1254 | -! | +||
| 368 | +
- card$append_src(teal.code::get_code(final_q()))+ ) |
||
| 1255 | -! | +||
| 369 | +
- card+ ) |
||
| 1256 | +370 |
- }+ }, |
|
| 1257 | +371 | ! |
- teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
+ if (args$color_settings) {
|
| 1258 | +372 |
- }+ # Put a grey border around the coloring settings |
|
| 1259 | -+ | ||
| 373 | +! |
- ###+ tags$div( |
|
| 1260 | -+ | ||
| 374 | +! |
- })+ class = "data-extract-box", |
|
| 1261 | -+ | ||
| 375 | +! |
- }+ tags$label("Color settings"),
|
| 1 | -+ | ||
| 376 | +! |
- #' `teal` module: Scatterplot and regression analysis+ shinyWidgets::switchInput(inputId = ns("coloring"), value = TRUE, size = "mini"),
|
|
| 2 | -+ | ||
| 377 | +! |
- #'+ conditionalPanel( |
|
| 3 | -+ | ||
| 378 | +! |
- #' Module for visualizing regression analysis, including scatterplots and+ condition = paste0("input['", ns("coloring"), "']"),
|
|
| 4 | -+ | ||
| 379 | +! |
- #' various regression diagnostics plots.+ tags$div( |
|
| 5 | -+ | ||
| 380 | +! |
- #' It allows users to explore the relationship between a set of regressors and a response variable,+ teal.transform::data_extract_ui( |
|
| 6 | -+ | ||
| 381 | +! |
- #' visualize residuals, and identify outliers.+ id = ns("color"),
|
|
| 7 | -+ | ||
| 382 | +! |
- #'+ label = "Outline color by variable", |
|
| 8 | -+ | ||
| 383 | +! |
- #' @note For more examples, please see the vignette "Using regression plots" via+ data_extract_spec = args$color, |
|
| 9 | -+ | ||
| 384 | +! |
- #' `vignette("using-regression-plots", package = "teal.modules.general")`.
+ is_single_dataset = is_single_dataset_value |
|
| 10 | +385 |
- #'+ ), |
|
| 11 | -+ | ||
| 386 | +! |
- #' @inheritParams teal::module+ teal.transform::data_extract_ui( |
|
| 12 | -+ | ||
| 387 | +! |
- #' @inheritParams shared_params+ id = ns("fill"),
|
|
| 13 | -+ | ||
| 388 | +! |
- #' @param regressor (`data_extract_spec` or `list` of multiple `data_extract_spec`)+ label = "Fill color by variable", |
|
| 14 | -+ | ||
| 389 | +! |
- #' Regressor variables from an incoming dataset with filtering and selecting.+ data_extract_spec = args$fill, |
|
| 15 | -+ | ||
| 390 | +! |
- #' @param response (`data_extract_spec` or `list` of multiple `data_extract_spec`)+ is_single_dataset = is_single_dataset_value |
|
| 16 | +391 |
- #' Response variables from an incoming dataset with filtering and selecting.+ ), |
|
| 17 | -+ | ||
| 392 | +! |
- #' @param default_outlier_label (`character`) optional, default column selected to label outliers.+ tags$div( |
|
| 18 | -+ | ||
| 393 | +! |
- #' @param default_plot_type (`numeric`) optional, defaults to "Response vs Regressor".+ id = ns("size_settings"),
|
|
| 19 | -+ | ||
| 394 | +! |
- #' 1. Response vs Regressor+ teal.transform::data_extract_ui( |
|
| 20 | -+ | ||
| 395 | +! |
- #' 2. Residuals vs Fitted+ id = ns("size"),
|
|
| 21 | -+ | ||
| 396 | +! |
- #' 3. Normal Q-Q+ label = "Size of points by variable (only if x and y are numeric)", |
|
| 22 | -+ | ||
| 397 | +! |
- #' 4. Scale-Location+ data_extract_spec = args$size, |
|
| 23 | -+ | ||
| 398 | +! |
- #' 5. Cook's distance+ is_single_dataset = is_single_dataset_value |
|
| 24 | +399 |
- #' 6. Residuals vs Leverage+ ) |
|
| 25 | +400 |
- #' 7. Cook's dist vs Leverage+ ) |
|
| 26 | +401 |
- #' @param label_segment_threshold (`numeric(1)` or `numeric(3)`)+ ) |
|
| 27 | +402 |
- #' Minimum distance between label and point on the plot that triggers the creation of+ ) |
|
| 28 | +403 |
- #' a line segment between the two.+ ) |
|
| 29 | +404 |
- #' This may happen when the label cannot be placed next to the point as it overlaps another+ }, |
|
| 30 | -+ | ||
| 405 | +! |
- #' label or point.+ teal.widgets::panel_group( |
|
| 31 | -+ | ||
| 406 | +! |
- #' The value is used as the `min.segment.length` parameter to the [ggrepel::geom_text_repel()] function.+ teal.widgets::panel_item( |
|
| 32 | -+ | ||
| 407 | +! |
- #'+ title = "Plot settings", |
|
| 33 | -+ | ||
| 408 | +! |
- #' It can take the following forms:+ checkboxInput(ns("rotate_xaxis_labels"), "Rotate X axis labels", value = args$rotate_xaxis_labels),
|
|
| 34 | -+ | ||
| 409 | +! |
- #' - `numeric(1)`: Fixed value used for the minimum distance and the slider is not presented in the UI.+ checkboxInput(ns("swap_axes"), "Swap axes", value = args$swap_axes),
|
|
| 35 | -+ | ||
| 410 | +! |
- #' - `numeric(3)`: A slider is presented in the UI (under "Plot settings") to adjust the minimum distance dynamically.+ selectInput( |
|
| 36 | -+ | ||
| 411 | +! |
- #'+ inputId = ns("ggtheme"),
|
|
| 37 | -+ | ||
| 412 | +! |
- #' It takes the form of `c(value, min, max)` and it is passed to the `value_min_max`+ label = "Theme (by ggplot):", |
|
| 38 | -+ | ||
| 413 | +! |
- #' argument in `teal.widgets::optionalSliderInputValMinMax`.+ choices = ggplot_themes, |
|
| 39 | -+ | ||
| 414 | +! |
- #'+ selected = args$ggtheme, |
|
| 40 | -+ | ||
| 415 | +! |
- #' @templateVar ggnames `r regression_names`+ multiple = FALSE |
|
| 41 | +416 |
- #' @template ggplot2_args_multi+ ), |
|
| 42 | -+ | ||
| 417 | +! |
- #'+ sliderInput( |
|
| 43 | -+ | ||
| 418 | +! |
- #' @inherit shared_params return+ ns("alpha"), "Opacity Scatterplot:",
|
|
| 44 | -+ | ||
| 419 | +! |
- #'+ min = 0, max = 1, |
|
| 45 | -+ | ||
| 420 | +! |
- #' @examplesShinylive+ step = .05, value = .5, ticks = FALSE |
|
| 46 | +421 |
- #' library(teal.modules.general)+ ), |
|
| 47 | -+ | ||
| 422 | +! |
- #' interactive <- function() TRUE+ sliderInput( |
|
| 48 | -+ | ||
| 423 | +! |
- #' {{ next_example }}
+ ns("fixed_size"), "Scatterplot point size:",
|
|
| 49 | -+ | ||
| 424 | +! |
- #' @examples+ min = 1, max = 8, |
|
| 50 | -+ | ||
| 425 | +! |
- #' # general data example+ step = 1, value = 2, ticks = FALSE |
|
| 51 | +426 |
- #' data <- teal_data()+ ), |
|
| 52 | -+ | ||
| 427 | +! |
- #' data <- within(data, {
+ checkboxInput(ns("add_lines"), "Add lines"),
|
|
| 53 | +428 |
- #' require(nestcolor)+ ) |
|
| 54 | +429 |
- #' CO2 <- CO2+ ) |
|
| 55 | +430 |
- #' })+ ), |
|
| 56 | -+ | ||
| 431 | +! |
- #' datanames(data) <- c("CO2")
+ forms = tagList( |
|
| 57 | -+ | ||
| 432 | +! |
- #'+ teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code")
|
|
| 58 | +433 |
- #' app <- init(+ ), |
|
| 59 | -+ | ||
| 434 | +! |
- #' data = data,+ pre_output = args$pre_output, |
|
| 60 | -+ | ||
| 435 | +! |
- #' modules = modules(+ post_output = args$post_output |
|
| 61 | +436 |
- #' tm_a_regression(+ ) |
|
| 62 | +437 |
- #' label = "Regression",+ } |
|
| 63 | +438 |
- #' response = data_extract_spec(+ |
|
| 64 | +439 |
- #' dataname = "CO2",+ # Server function for the bivariate module |
|
| 65 | +440 |
- #' select = select_spec(+ srv_g_bivariate <- function(id, |
|
| 66 | +441 |
- #' label = "Select variable:",+ data, |
|
| 67 | +442 |
- #' choices = "uptake",+ reporter, |
|
| 68 | +443 |
- #' selected = "uptake",+ filter_panel_api, |
|
| 69 | +444 |
- #' multiple = FALSE,+ x, |
|
| 70 | +445 |
- #' fixed = TRUE+ y, |
|
| 71 | +446 |
- #' )+ row_facet, |
|
| 72 | +447 |
- #' ),+ col_facet, |
|
| 73 | +448 |
- #' regressor = data_extract_spec(+ color_settings = FALSE, |
|
| 74 | +449 |
- #' dataname = "CO2",+ color, |
|
| 75 | +450 |
- #' select = select_spec(+ fill, |
|
| 76 | +451 |
- #' label = "Select variables:",+ size, |
|
| 77 | +452 |
- #' choices = variable_choices(data[["CO2"]], c("conc", "Treatment")),
+ plot_height, |
|
| 78 | +453 |
- #' selected = "conc",+ plot_width, |
|
| 79 | +454 |
- #' multiple = TRUE,+ ggplot2_args) {
|
|
| 80 | -+ | ||
| 455 | +! |
- #' fixed = FALSE+ with_reporter <- !missing(reporter) && inherits(reporter, "Reporter") |
|
| 81 | -+ | ||
| 456 | +! |
- #' )+ with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI") |
|
| 82 | -+ | ||
| 457 | +! |
- #' )+ checkmate::assert_class(data, "reactive") |
|
| 83 | -+ | ||
| 458 | +! |
- #' )+ checkmate::assert_class(isolate(data()), "teal_data") |
|
| 84 | -+ | ||
| 459 | +! |
- #' )+ moduleServer(id, function(input, output, session) {
|
|
| 85 | -+ | ||
| 460 | +! |
- #' )+ teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.general") |
|
| 86 | +461 |
- #' if (interactive()) {
+
|
|
| 87 | -+ | ||
| 462 | +! |
- #' shinyApp(app$ui, app$server)+ ns <- session$ns |
|
| 88 | +463 |
- #' }+ |
|
| 89 | -+ | ||
| 464 | +! |
- #'+ data_extract <- list( |
|
| 90 | -+ | ||
| 465 | +! |
- #' @examplesShinylive+ x = x, y = y, row_facet = row_facet, col_facet = col_facet, |
|
| 91 | -+ | ||
| 466 | +! |
- #' library(teal.modules.general)+ color = color, fill = fill, size = size |
|
| 92 | +467 |
- #' interactive <- function() TRUE+ ) |
|
| 93 | +468 |
- #' {{ next_example }}
+
|
|
| 94 | -+ | ||
| 469 | +! |
- #' @examples+ rule_var <- function(other) {
|
|
| 95 | -+ | ||
| 470 | +! |
- #' # CDISC data example+ function(value) {
|
|
| 96 | -+ | ||
| 471 | +! |
- #' data <- teal_data()+ othervalue <- selector_list()[[other]]()$select |
|
| 97 | -+ | ||
| 472 | +! |
- #' data <- within(data, {
+ if (length(value) == 0L && length(othervalue) == 0L) {
|
|
| 98 | -+ | ||
| 473 | +! |
- #' require(nestcolor)+ "Please select at least one of x-variable or y-variable" |
|
| 99 | +474 |
- #' ADSL <- rADSL+ } |
|
| 100 | +475 |
- #' })+ } |
|
| 101 | +476 |
- #' datanames(data) <- "ADSL"+ } |
|
| 102 | -+ | ||
| 477 | +! |
- #' join_keys(data) <- default_cdisc_join_keys[datanames(data)]+ rule_diff <- function(other) {
|
|
| 103 | -+ | ||
| 478 | +! |
- #'+ function(value) {
|
|
| 104 | -- |
- #' app <- init(- |
- |
| 105 | -- |
- #' data = data,- |
- |
| 106 | -+ | ||
| 479 | +! |
- #' modules = modules(+ othervalue <- selector_list()[[other]]()[["select"]] |
|
| 107 | -+ | ||
| 480 | +! |
- #' tm_a_regression(+ if (!is.null(othervalue)) {
|
|
| 108 | -+ | ||
| 481 | +! |
- #' label = "Regression",+ if (identical(value, othervalue)) {
|
|
| 109 | -+ | ||
| 482 | +! |
- #' response = data_extract_spec(+ "Row and column facetting variables must be different." |
|
| 110 | +483 |
- #' dataname = "ADSL",+ } |
|
| 111 | +484 |
- #' select = select_spec(+ } |
|
| 112 | +485 |
- #' label = "Select variable:",+ } |
|
| 113 | +486 |
- #' choices = "BMRKR1",+ } |
|
| 114 | +487 |
- #' selected = "BMRKR1",+ |
|
| 115 | -+ | ||
| 488 | +! |
- #' multiple = FALSE,+ selector_list <- teal.transform::data_extract_multiple_srv( |
|
| 116 | -+ | ||
| 489 | +! |
- #' fixed = TRUE+ data_extract = data_extract, |
|
| 117 | -+ | ||
| 490 | +! |
- #' )+ datasets = data, |
|
| 118 | -+ | ||
| 491 | +! |
- #' ),+ select_validation_rule = list( |
|
| 119 | -+ | ||
| 492 | +! |
- #' regressor = data_extract_spec(+ x = rule_var("y"),
|
|
| 120 | -+ | ||
| 493 | +! |
- #' dataname = "ADSL",+ y = rule_var("x"),
|
|
| 121 | -+ | ||
| 494 | +! |
- #' select = select_spec(+ row_facet = shinyvalidate::compose_rules( |
|
| 122 | -+ | ||
| 495 | +! |
- #' label = "Select variables:",+ shinyvalidate::sv_optional(), |
|
| 123 | -+ | ||
| 496 | +! |
- #' choices = variable_choices(data[["ADSL"]], c("AGE", "SEX", "RACE")),
+ rule_diff("col_facet")
|
|
| 124 | +497 |
- #' selected = "AGE",+ ), |
|
| 125 | -+ | ||
| 498 | +! |
- #' multiple = TRUE,+ col_facet = shinyvalidate::compose_rules( |
|
| 126 | -+ | ||
| 499 | +! |
- #' fixed = FALSE+ shinyvalidate::sv_optional(), |
|
| 127 | -+ | ||
| 500 | +! |
- #' )+ rule_diff("row_facet")
|
|
| 128 | +501 |
- #' )+ ) |
|
| 129 | +502 |
- #' )+ ) |
|
| 130 | +503 |
- #' )+ ) |
|
| 131 | +504 |
- #' )+ |
|
| 132 | -+ | ||
| 505 | +! |
- #' if (interactive()) {
+ iv_r <- reactive({
|
|
| 133 | -+ | ||
| 506 | +! |
- #' shinyApp(app$ui, app$server)+ iv_facet <- shinyvalidate::InputValidator$new() |
|
| 134 | -+ | ||
| 507 | +! |
- #' }+ iv_child <- teal.transform::compose_and_enable_validators(iv_facet, selector_list, |
|
| 135 | -+ | ||
| 508 | +! |
- #'+ validator_names = c("row_facet", "col_facet")
|
|
| 136 | +509 |
- #' @export+ ) |
|
| 137 | -+ | ||
| 510 | +! |
- #'+ iv_child$condition(~ isTRUE(input$facetting)) |
|
| 138 | +511 |
- tm_a_regression <- function(label = "Regression Analysis",+ |
|
| 139 | -+ | ||
| 512 | +! |
- regressor,+ iv <- shinyvalidate::InputValidator$new() |
|
| 140 | -+ | ||
| 513 | +! |
- response,+ iv$add_validator(iv_child) |
|
| 141 | -+ | ||
| 514 | +! |
- plot_height = c(600, 200, 2000),+ teal.transform::compose_and_enable_validators(iv, selector_list, validator_names = c("x", "y"))
|
|
| 142 | +515 |
- plot_width = NULL,+ }) |
|
| 143 | +516 |
- alpha = c(1, 0, 1),+ |
|
| 144 | -+ | ||
| 517 | +! |
- size = c(2, 1, 8),+ anl_merged_input <- teal.transform::merge_expression_srv( |
|
| 145 | -+ | ||
| 518 | +! |
- ggtheme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void"),
+ selector_list = selector_list, |
|
| 146 | -+ | ||
| 519 | +! |
- ggplot2_args = teal.widgets::ggplot2_args(),+ datasets = data |
|
| 147 | +520 |
- pre_output = NULL,+ ) |
|
| 148 | +521 |
- post_output = NULL,+ |
|
| 149 | -+ | ||
| 522 | +! |
- default_plot_type = 1,+ anl_merged_q <- reactive({
|
|
| 150 | -+ | ||
| 523 | +! |
- default_outlier_label = "USUBJID",+ req(anl_merged_input()) |
|
| 151 | -+ | ||
| 524 | +! |
- label_segment_threshold = c(0.5, 0, 10)) {
+ data() %>% |
|
| 152 | +525 | ! |
- message("Initializing tm_a_regression")
+ teal.code::eval_code(as.expression(anl_merged_input()$expr)) |
| 153 | +526 |
-
+ }) |
|
| 154 | +527 |
- # Normalize the parameters+ |
|
| 155 | +528 | ! |
- if (inherits(regressor, "data_extract_spec")) regressor <- list(regressor)+ merged <- list( |
| 156 | +529 | ! |
- if (inherits(response, "data_extract_spec")) response <- list(response)+ anl_input_r = anl_merged_input, |
| 157 | +530 | ! |
- if (inherits(ggplot2_args, "ggplot2_args")) ggplot2_args <- list(default = ggplot2_args)+ anl_q_r = anl_merged_q |
| 158 | +531 |
-
+ ) |
|
| 159 | +532 |
- # Start of assertions+ |
|
| 160 | +533 | ! |
- checkmate::assert_string(label)+ output_q <- reactive({
|
| 161 | +534 | ! |
- checkmate::assert_list(regressor, types = "data_extract_spec")+ teal::validate_inputs(iv_r()) |
| 162 | +535 | ||
| 163 | +536 | ! |
- checkmate::assert_list(response, types = "data_extract_spec")+ ANL <- merged$anl_q_r()[["ANL"]] |
| 164 | +537 | ! |
- assert_single_selection(response)+ teal::validate_has_data(ANL, 3) |
| 165 | +538 | ||
| 166 | +539 | ! |
- checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE)+ x_col_vec <- as.vector(merged$anl_input_r()$columns_source$x) |
| 167 | +540 | ! |
- checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height")- |
-
| 168 | -- |
-
+ x_name <- `if`(is.null(x_col_vec), character(0), x_col_vec) |
|
| 169 | +541 | ! |
- checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE)+ y_col_vec <- as.vector(merged$anl_input_r()$columns_source$y) |
| 170 | +542 | ! |
- checkmate::assert_numeric(+ y_name <- `if`(is.null(y_col_vec), character(0), y_col_vec) |
| 171 | -! | +||
| 543 | +
- plot_width[1],+ |
||
| 172 | +544 | ! |
- lower = plot_width[2],+ row_facet_name <- as.vector(merged$anl_input_r()$columns_source$row_facet) |
| 173 | +545 | ! |
- upper = plot_width[3],+ col_facet_name <- as.vector(merged$anl_input_r()$columns_source$col_facet) |
| 174 | +546 | ! |
- null.ok = TRUE,+ color_name <- if ("color" %in% names(merged$anl_input_r()$columns_source)) {
|
| 175 | +547 | ! |
- .var.name = "plot_width"- |
-
| 176 | -- |
- )+ as.vector(merged$anl_input_r()$columns_source$color) |
|
| 177 | +548 | - - | -|
| 178 | -! | -
- if (length(alpha) == 1) {
+ } else {
|
|
| 179 | +549 | ! |
- checkmate::assert_numeric(alpha, any.missing = FALSE, finite = TRUE)+ character(0) |
| 180 | +550 |
- } else {
+ } |
|
| 181 | +551 | ! |
- checkmate::assert_numeric(alpha, len = 3, any.missing = FALSE, finite = TRUE)+ fill_name <- if ("fill" %in% names(merged$anl_input_r()$columns_source)) {
|
| 182 | +552 | ! |
- checkmate::assert_numeric(alpha[1], lower = alpha[2], upper = alpha[3], .var.name = "alpha")+ as.vector(merged$anl_input_r()$columns_source$fill) |
| 183 | +553 |
- }+ } else {
+ |
+ |
| 554 | +! | +
+ character(0) |
|
| 184 | +555 |
-
+ } |
|
| 185 | +556 | ! |
- if (length(size) == 1) {
+ size_name <- if ("size" %in% names(merged$anl_input_r()$columns_source)) {
|
| 186 | +557 | ! |
- checkmate::assert_numeric(size, any.missing = FALSE, finite = TRUE)+ as.vector(merged$anl_input_r()$columns_source$size) |
| 187 | +558 |
- } else {
- |
- |
| 188 | -! | -
- checkmate::assert_numeric(size, len = 3, any.missing = FALSE, finite = TRUE)+ } else {
|
|
| 189 | +559 | ! |
- checkmate::assert_numeric(size[1], lower = size[2], upper = size[3], .var.name = "size")+ character(0) |
| 190 | +560 |
- }+ } |
|
| 191 | +561 | ||
| 192 | +562 | ! |
- ggtheme <- match.arg(ggtheme)- |
-
| 193 | -- |
-
+ use_density <- input$use_density == "density" |
|
| 194 | +563 | ! |
- plot_choices <- c(+ free_x_scales <- input$free_x_scales |
| 195 | +564 | ! |
- "Response vs Regressor", "Residuals vs Fitted", "Normal Q-Q", "Scale-Location",+ free_y_scales <- input$free_y_scales |
| 196 | +565 | ! |
- "Cook's distance", "Residuals vs Leverage", "Cook's dist vs Leverage"- |
-
| 197 | -- |
- )+ ggtheme <- input$ggtheme |
|
| 198 | +566 | ! |
- checkmate::assert_list(ggplot2_args, types = "ggplot2_args")+ rotate_xaxis_labels <- input$rotate_xaxis_labels |
| 199 | +567 | ! |
- checkmate::assert_subset(names(ggplot2_args), c("default", plot_choices))
+ swap_axes <- input$swap_axes |
| 200 | +568 | ||
| 201 | +569 | ! |
- checkmate::assert_multi_class(pre_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
+ is_scatterplot <- all(vapply(ANL[c(x_name, y_name)], is.numeric, logical(1))) && |
| 202 | +570 | ! |
- checkmate::assert_multi_class(post_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
+ length(x_name) > 0 && length(y_name) > 0 |
| 203 | -! | +||
| 571 | +
- checkmate::assert_choice(default_plot_type, seq.int(1L, length(plot_choices)))+ |
||
| 204 | +572 | ! |
- checkmate::assert_string(default_outlier_label)+ if (is_scatterplot) {
|
| 205 | -+ | ||
| 573 | +! |
-
+ shinyjs::show("alpha")
|
|
| 206 | +574 | ! |
- if (length(label_segment_threshold) == 1) {
+ alpha <- input$alpha |
| 207 | +575 | ! |
- checkmate::assert_numeric(label_segment_threshold, any.missing = FALSE, finite = TRUE)+ shinyjs::show("add_lines")
|
| 208 | +576 |
- } else {
+
|
|
| 209 | +577 | ! |
- checkmate::assert_numeric(label_segment_threshold, len = 3, any.missing = FALSE, finite = TRUE)+ if (color_settings && input$coloring) {
|
| 210 | +578 | ! |
- checkmate::assert_numeric(+ shinyjs::hide("fixed_size")
|
| 211 | +579 | ! |
- label_segment_threshold[1],+ shinyjs::show("size_settings")
|
| 212 | +580 | ! |
- lower = label_segment_threshold[2],+ size <- NULL |
| 213 | -! | +||
| 581 | +
- upper = label_segment_threshold[3],+ } else {
|
||
| 214 | +582 | ! |
- .var.name = "label_segment_threshold"+ shinyjs::show("fixed_size")
|
| 215 | -+ | ||
| 583 | +! |
- )+ size <- input$fixed_size |
|
| 216 | +584 |
- }+ } |
|
| 217 | +585 |
- # End of assertions+ } else {
|
|
| 218 | -+ | ||
| 586 | +! |
-
+ shinyjs::hide("add_lines")
|
|
| 219 | -+ | ||
| 587 | +! |
- # Make UI args+ updateCheckboxInput(session, "add_lines", value = restoreInput(ns("add_lines"), FALSE))
|
|
| 220 | +588 | ! |
- args <- as.list(environment())+ shinyjs::hide("alpha")
|
| 221 | +589 | ! |
- args[["plot_choices"]] <- plot_choices+ shinyjs::hide("fixed_size")
|
| 222 | +590 | ! |
- data_extract_list <- list(+ shinyjs::hide("size_settings")
|
| 223 | +591 | ! |
- regressor = regressor,+ alpha <- 1 |
| 224 | +592 | ! |
- response = response+ size <- NULL |
| 225 | +593 |
- )+ } |
|
| 226 | +594 | ||
| 227 | +595 | ! |
- ans <- module(+ teal::validate_has_data(ANL[, c(x_name, y_name), drop = FALSE], 3, complete = TRUE, allow_inf = FALSE)+ |
+
| 596 | ++ | + | |
| 228 | +597 | ! |
- label = label,+ cl <- bivariate_plot_call( |
| 229 | +598 | ! |
- server = srv_a_regression,+ data_name = "ANL", |
| 230 | +599 | ! |
- ui = ui_a_regression,+ x = x_name, |
| 231 | +600 | ! |
- ui_args = args,+ y = y_name, |
| 232 | +601 | ! |
- server_args = c(+ x_class = ifelse(!identical(x_name, character(0)), class(ANL[[x_name]]), "NULL"), |
| 233 | +602 | ! |
- data_extract_list,+ y_class = ifelse(!identical(y_name, character(0)), class(ANL[[y_name]]), "NULL"), |
| 234 | +603 | ! |
- list(+ x_label = varname_w_label(x_name, ANL), |
| 235 | +604 | ! |
- plot_height = plot_height,+ y_label = varname_w_label(y_name, ANL), |
| 236 | +605 | ! |
- plot_width = plot_width,+ freq = !use_density, |
| 237 | +606 | ! |
- default_outlier_label = default_outlier_label,+ theme = ggtheme, |
| 238 | +607 | +! | +
+ rotate_xaxis_labels = rotate_xaxis_labels,+ |
+
| 608 | +! | +
+ swap_axes = swap_axes,+ |
+ |
| 609 | +! | +
+ alpha = alpha,+ |
+ |
| 610 | +! | +
+ size = size,+ |
+ |
| 611 | ! |
ggplot2_args = ggplot2_args |
|
| 239 | +612 |
) |
|
| 240 | +613 |
- ),+ |
|
| 241 | +614 | ! |
- datanames = teal.transform::get_extract_datanames(data_extract_list)+ facetting <- (isTRUE(input$facetting) && (!is.null(row_facet_name) || !is.null(col_facet_name))) |
| 242 | +615 |
- )+ |
|
| 243 | +616 | ! |
- attr(ans, "teal_bookmarkable") <- FALSE+ if (facetting) {
|
| 244 | +617 | ! |
- ans+ facet_cl <- facet_ggplot_call(row_facet_name, col_facet_name, free_x_scales, free_y_scales) |
| 245 | +618 |
- }+ + |
+ |
| 619 | +! | +
+ if (!is.null(facet_cl)) {
+ |
+ |
| 620 | +! | +
+ cl <- call("+", cl, facet_cl)
|
|
| 246 | +621 |
-
+ } |
|
| 247 | +622 |
- # UI function for the regression module+ } |
|
| 248 | +623 |
- ui_a_regression <- function(id, ...) {
+
|
|
| 249 | +624 | ! |
- ns <- NS(id)+ if (input$add_lines) {
|
| 250 | +625 | ! |
- args <- list(...)+ cl <- call("+", cl, quote(geom_line(size = 1)))
|
| 251 | -! | +||
| 626 | +
- is_single_dataset_value <- teal.transform::is_single_dataset(args$regressor, args$response)+ } |
||
| 252 | +627 | ||
| 253 | +628 | ! |
- teal.widgets::standard_layout(+ coloring_cl <- NULL |
| 254 | +629 | ! |
- output = teal.widgets::white_small_well(tags$div(+ if (color_settings) {
|
| 255 | +630 | ! |
- teal.widgets::plot_with_settings_ui(id = ns("myplot")),
+ if (input$coloring) {
|
| 256 | +631 | ! |
- tags$div(verbatimTextOutput(ns("text")))
+ coloring_cl <- coloring_ggplot_call( |
| 257 | -+ | ||
| 632 | +! |
- )),+ colour = color_name, |
|
| 258 | +633 | ! |
- encoding = tags$div(+ fill = fill_name, |
| 259 | -+ | ||
| 634 | +! |
- ### Reporter+ size = size_name, |
|
| 260 | +635 | ! |
- teal.reporter::simple_reporter_ui(ns("simple_reporter")),
+ is_point = any(grepl("geom_point", cl %>% deparse()))
|
| 261 | +636 |
- ###+ ) |
|
| 262 | +637 | ! |
- tags$label("Encodings", class = "text-primary"),
+ legend_lbls <- substitute( |
| 263 | +638 | ! |
- teal.transform::datanames_input(args[c("response", "regressor")]),
+ expr = labs(color = color_name, fill = fill_name, size = size_name), |
| 264 | +639 | ! |
- teal.transform::data_extract_ui(+ env = list( |
| 265 | +640 | ! |
- id = ns("response"),
+ color_name = varname_w_label(color_name, ANL), |
| 266 | +641 | ! |
- label = "Response variable",+ fill_name = varname_w_label(fill_name, ANL), |
| 267 | +642 | ! |
- data_extract_spec = args$response,+ size_name = varname_w_label(size_name, ANL) |
| 268 | -! | +||
| 643 | +
- is_single_dataset = is_single_dataset_value+ ) |
||
| 269 | +644 |
- ),+ ) |
|
| 270 | -! | +||
| 645 | +
- teal.transform::data_extract_ui(+ } |
||
| 271 | +646 | ! |
- id = ns("regressor"),
+ if (!is.null(coloring_cl)) {
|
| 272 | +647 | ! |
- label = "Regressor variables",+ cl <- call("+", call("+", cl, coloring_cl), legend_lbls)
|
| 273 | -! | +||
| 648 | +
- data_extract_spec = args$regressor,+ } |
||
| 274 | -! | +||
| 649 | +
- is_single_dataset = is_single_dataset_value+ } |
||
| 275 | +650 |
- ),+ + |
+ |
| 651 | ++ |
+ # Add labels to facets |
|
| 276 | +652 | ! |
- radioButtons(+ nulled_row_facet_name <- varname_w_label(row_facet_name, ANL) |
| 277 | +653 | ! |
- ns("plot_type"),
+ nulled_col_facet_name <- varname_w_label(col_facet_name, ANL) |
| 278 | +654 | ! |
- label = "Plot type:",+ without_facet <- (is.null(nulled_row_facet_name) && is.null(nulled_col_facet_name)) || !facetting+ |
+
| 655 | ++ | + | |
| 279 | +656 | ! |
- choices = args$plot_choices,+ print_call <- if (without_facet) {
|
| 280 | +657 | ! |
- selected = args$plot_choices[args$default_plot_type]+ quote(print(p)) |
| 281 | +658 |
- ),+ } else {
|
|
| 282 | +659 | ! |
- checkboxInput(ns("show_outlier"), label = "Display outlier labels", value = TRUE),
+ substitute( |
| 283 | +660 | ! |
- conditionalPanel(+ expr = {
|
| 284 | -! | +||
| 661 | +
- condition = "input['show_outlier']",+ # Add facetting labels |
||
| 285 | -! | +||
| 662 | +
- ns = ns,+ # optional: grid.newpage() # nolint: commented_code. |
||
| 286 | -! | +||
| 663 | +
- teal.widgets::optionalSliderInput(+ # Prefixed with teal.modules.general as its usage will appear in "Show R code" |
||
| 287 | +664 | ! |
- ns("outlier"),
+ p <- teal.modules.general::add_facet_labels( |
| 288 | +665 | ! |
- tags$div(+ p, |
| 289 | +666 | ! |
- class = "teal-tooltip",+ xfacet_label = nulled_col_facet_name, |
| 290 | +667 | ! |
- tagList(+ yfacet_label = nulled_row_facet_name |
| 291 | -! | +||
| 668 | +
- "Outlier definition:",+ ) |
||
| 292 | +669 | ! |
- icon("circle-info"),
+ grid::grid.newpage() |
| 293 | -! | -
- tags$span(- |
- |
| 294 | -! | -
- class = "tooltiptext",- |
- |
| 295 | -! | -
- paste(- |
- |
| 296 | +670 | ! |
- "Use the slider to choose the cut-off value to define outliers.",+ grid::grid.draw(p) |
| 297 | -! | +||
| 671 | +
- "Points with a Cook's distance greater than",+ }, |
||
| 298 | +672 | ! |
- "the value on the slider times the mean of the Cook's distance of the dataset will have labels."+ env = list(nulled_col_facet_name = nulled_col_facet_name, nulled_row_facet_name = nulled_row_facet_name) |
| 299 | +673 |
- )+ ) |
|
| 300 | +674 |
- )+ } |
|
| 301 | +675 |
- )+ |
|
| 302 | -+ | ||
| 676 | +! |
- ),+ teal.code::eval_code(merged$anl_q_r(), substitute(expr = p <- cl, env = list(cl = cl))) %>% |
|
| 303 | +677 | ! |
- min = 1, max = 10, value = 9, ticks = FALSE, step = .1+ teal.code::eval_code(print_call) |
| 304 | +678 |
- ),- |
- |
| 305 | -! | -
- teal.widgets::optionalSelectInput(+ }) |
|
| 306 | -! | +||
| 679 | +
- ns("label_var"),
+
|
||
| 307 | +680 | ! |
- multiple = FALSE,+ plot_r <- reactive({
|
| 308 | +681 | ! |
- label = "Outlier label"+ output_q()[["p"]] |
| 309 | +682 |
- )+ }) |
|
| 310 | +683 |
- ),+ |
|
| 311 | +684 | ! |
- teal.widgets::panel_group(+ pws <- teal.widgets::plot_with_settings_srv( |
| 312 | +685 | ! |
- teal.widgets::panel_item(+ id = "myplot", |
| 313 | +686 | ! |
- title = "Plot settings",+ plot_r = plot_r, |
| 314 | +687 | ! |
- teal.widgets::optionalSliderInputValMinMax(ns("alpha"), "Opacity:", args$alpha, ticks = FALSE),
+ height = plot_height, |
| 315 | +688 | ! |
- teal.widgets::optionalSliderInputValMinMax(ns("size"), "Points size:", args$size, ticks = FALSE),
+ width = plot_width |
| 316 | -! | +||
| 689 | +
- teal.widgets::optionalSliderInputValMinMax(+ ) |
||
| 317 | -! | +||
| 690 | +
- inputId = ns("label_min_segment"),
+
|
||
| 318 | +691 | ! |
- label = tags$div(+ teal.widgets::verbatim_popup_srv( |
| 319 | +692 | ! |
- class = "teal-tooltip",+ id = "rcode", |
| 320 | +693 | ! |
- tagList(+ verbatim_content = reactive(teal.code::get_code(output_q())), |
| 321 | +694 | ! |
- "Label min. segment:",+ title = "Bivariate Plot" |
| 322 | -! | +||
| 695 | +
- icon("circle-info"),
+ ) |
||
| 323 | -! | +||
| 696 | +
- tags$span(+ |
||
| 324 | -! | +||
| 697 | +
- class = "tooltiptext",+ ### REPORTER |
||
| 325 | +698 | ! |
- paste(+ if (with_reporter) {
|
| 326 | +699 | ! |
- "Use the slider to choose the cut-off value to define minimum distance between label and point",+ card_fun <- function(comment, label) {
|
| 327 | +700 | ! |
- "that generates a line segment.",+ card <- teal::report_card_template( |
| 328 | +701 | ! |
- "It's only valid when 'Display outlier labels' is checked."- |
-
| 329 | -- |
- )- |
- |
| 330 | -- |
- )+ title = "Bivariate Plot", |
|
| 331 | -+ | ||
| 702 | +! |
- )+ label = label, |
|
| 332 | -+ | ||
| 703 | +! |
- ),+ with_filter = with_filter, |
|
| 333 | +704 | ! |
- value_min_max = args$label_segment_threshold,+ filter_panel_api = filter_panel_api |
| 334 | +705 |
- # Extra parameters to sliderInput+ ) |
|
| 335 | +706 | ! |
- ticks = FALSE,+ card$append_text("Plot", "header3")
|
| 336 | +707 | ! |
- step = .1,+ card$append_plot(plot_r(), dim = pws$dim()) |
| 337 | +708 | ! |
- round = FALSE+ if (!comment == "") {
|
| 338 | -+ | ||
| 709 | +! |
- ),+ card$append_text("Comment", "header3")
|
|
| 339 | +710 | ! |
- selectInput(+ card$append_text(comment) |
| 340 | -! | +||
| 711 | +
- inputId = ns("ggtheme"),
+ } |
||
| 341 | +712 | ! |
- label = "Theme (by ggplot):",+ card$append_src(teal.code::get_code(output_q())) |
| 342 | +713 | ! |
- choices = ggplot_themes,+ card |
| 343 | -! | +||
| 714 | +
- selected = args$ggtheme,+ } |
||
| 344 | +715 | ! |
- multiple = FALSE+ teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
|
| 345 | +716 |
- )+ } |
|
| 346 | +717 |
- )+ ### |
|
| 347 | +718 |
- )+ }) |
|
| 348 | +719 |
- ),- |
- |
| 349 | -! | -
- forms = tagList(- |
- |
| 350 | -! | -
- teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code")
+ } |
|
| 351 | +720 |
- ),- |
- |
| 352 | -! | -
- pre_output = args$pre_output,+ |
|
| 353 | -! | +||
| 721 | +
- post_output = args$post_output+ # Get Substituted ggplot call |
||
| 354 | +722 |
- )+ bivariate_plot_call <- function(data_name, |
|
| 355 | +723 |
- }+ x = character(0), |
|
| 356 | +724 |
-
+ y = character(0), |
|
| 357 | +725 |
- # Server function for the regression module+ x_class = "NULL", |
|
| 358 | +726 |
- srv_a_regression <- function(id,+ y_class = "NULL", |
|
| 359 | +727 |
- data,+ x_label = NULL, |
|
| 360 | +728 |
- reporter,+ y_label = NULL, |
|
| 361 | +729 |
- filter_panel_api,+ freq = TRUE, |
|
| 362 | +730 |
- response,+ theme = "gray", |
|
| 363 | +731 |
- regressor,+ rotate_xaxis_labels = FALSE, |
|
| 364 | +732 |
- plot_height,+ swap_axes = FALSE, |
|
| 365 | +733 |
- plot_width,+ alpha = double(0), |
|
| 366 | +734 |
- ggplot2_args,+ size = 2, |
|
| 367 | +735 |
- default_outlier_label) {
+ ggplot2_args = teal.widgets::ggplot2_args()) {
|
|
| 368 | +736 | ! |
- with_reporter <- !missing(reporter) && inherits(reporter, "Reporter")+ supported_types <- c("NULL", "numeric", "integer", "factor", "character", "logical", "ordered")
|
| 369 | +737 | ! |
- with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI")+ validate(need(x_class %in% supported_types, paste0("Data type '", x_class, "' is not supported.")))
|
| 370 | +738 | ! |
- checkmate::assert_class(data, "reactive")+ validate(need(y_class %in% supported_types, paste0("Data type '", y_class, "' is not supported.")))
|
| 371 | -! | +||
| 739 | +
- checkmate::assert_class(isolate(data()), "teal_data")+ + |
+ ||
| 740 | ++ | + | |
| 372 | +741 | ! |
- moduleServer(id, function(input, output, session) {
+ if (identical(x, character(0))) {
|
| 373 | +742 | ! |
- teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.general")+ x <- x_label <- "-" |
| 374 | +743 |
-
+ } else {
|
|
| 375 | +744 | ! |
- ns <- session$ns+ x <- if (is.call(x)) x else as.name(x) |
| 376 | +745 |
-
+ } |
|
| 377 | +746 | ! |
- rule_rvr1 <- function(value) {
+ if (identical(y, character(0))) {
|
| 378 | +747 | ! |
- if (isTRUE(input$plot_type == "Response vs Regressor")) {
+ y <- y_label <- "-" |
| 379 | -! | +||
| 748 | +
- if (length(value) > 1L) {
+ } else {
|
||
| 380 | +749 | ! |
- "This plot can only have one regressor."+ y <- if (is.call(y)) y else as.name(y) |
| 381 | +750 |
- }+ } |
|
| 382 | +751 |
- }+ |
|
| 383 | -+ | ||
| 752 | +! |
- }+ cl <- bivariate_ggplot_call( |
|
| 384 | +753 | ! |
- rule_rvr2 <- function(other) {
+ x_class = x_class, |
| 385 | +754 | ! |
- function(value) {
+ y_class = y_class, |
| 386 | +755 | ! |
- if (isTRUE(input$plot_type == "Response vs Regressor")) {
+ freq = freq, |
| 387 | +756 | ! |
- otherval <- selector_list()[[other]]()$select+ theme = theme, |
| 388 | +757 | ! |
- if (isTRUE(value == otherval)) {
+ rotate_xaxis_labels = rotate_xaxis_labels, |
| 389 | +758 | ! |
- "Response and Regressor must be different."+ swap_axes = swap_axes, |
| 390 | -+ | ||
| 759 | +! |
- }+ alpha = alpha, |
|
| 391 | -+ | ||
| 760 | +! |
- }+ size = size, |
|
| 392 | -+ | ||
| 761 | +! |
- }- |
- |
| 393 | -- |
- }- |
- |
| 394 | -- |
-
+ ggplot2_args = ggplot2_args, |
|
| 395 | +762 | ! |
- selector_list <- teal.transform::data_extract_multiple_srv(+ x = x, |
| 396 | +763 | ! |
- data_extract = list(response = response, regressor = regressor),+ y = y, |
| 397 | +764 | ! |
- datasets = data,+ xlab = x_label, |
| 398 | +765 | ! |
- select_validation_rule = list(+ ylab = y_label, |
| 399 | +766 | ! |
- regressor = shinyvalidate::compose_rules(+ data_name = data_name |
| 400 | -! | +||
| 767 | +
- shinyvalidate::sv_required("At least one regressor should be selected."),
+ ) |
||
| 401 | -! | +||
| 768 | +
- rule_rvr1,+ } |
||
| 402 | -! | +||
| 769 | +
- rule_rvr2("response")
+
|
||
| 403 | +770 |
- ),+ # Create ggplot part of plot call |
|
| 404 | -! | +||
| 771 | +
- response = shinyvalidate::compose_rules(+ # Due to the type of the x and y variable the plot type is chosen |
||
| 405 | -! | +||
| 772 | +
- shinyvalidate::sv_required("At least one response should be selected."),
+ bivariate_ggplot_call <- function(x_class, |
||
| 406 | -! | +||
| 773 | +
- rule_rvr2("regressor")
+ y_class, |
||
| 407 | +774 |
- )+ freq = TRUE, |
|
| 408 | +775 |
- )+ theme = "gray", |
|
| 409 | +776 |
- )+ rotate_xaxis_labels = FALSE, |
|
| 410 | +777 |
-
+ swap_axes = FALSE, |
|
| 411 | -! | +||
| 778 | +
- iv_r <- reactive({
+ size = double(0), |
||
| 412 | -! | +||
| 779 | +
- iv <- shinyvalidate::InputValidator$new()+ alpha = double(0), |
||
| 413 | -! | +||
| 780 | +
- teal.transform::compose_and_enable_validators(iv, selector_list)+ x = NULL, |
||
| 414 | +781 |
- })+ y = NULL, |
|
| 415 | +782 |
-
+ xlab = "-", |
|
| 416 | -! | +||
| 783 | +
- iv_out <- shinyvalidate::InputValidator$new()+ ylab = "-", |
||
| 417 | -! | +||
| 784 | +
- iv_out$condition(~ isTRUE(input$show_outlier))+ data_name = "ANL", |
||
| 418 | -! | +||
| 785 | +
- iv_out$add_rule("label_var", shinyvalidate::sv_required("Please provide an `Outlier label` variable"))
+ ggplot2_args = teal.widgets::ggplot2_args()) {
|
||
| 419 | -! | +||
| 786 | +42x |
- iv_out$enable()+ x_class <- switch(x_class, |
|
| 420 | -+ | ||
| 787 | +42x |
-
+ "character" = , |
|
| 421 | -! | +||
| 788 | +42x |
- anl_merged_input <- teal.transform::merge_expression_srv(+ "ordered" = , |
|
| 422 | -! | +||
| 789 | +42x |
- selector_list = selector_list,+ "logical" = , |
|
| 423 | -! | +||
| 790 | +42x |
- datasets = data+ "factor" = "factor", |
|
| 424 | -+ | ||
| 791 | +42x |
- )+ "integer" = , |
|
| 425 | -+ | ||
| 792 | +42x |
-
+ "numeric" = "numeric", |
|
| 426 | -! | +||
| 793 | +42x |
- regression_var <- reactive({
+ "NULL" = "NULL", |
|
| 427 | -! | +||
| 794 | +42x |
- teal::validate_inputs(iv_r())+ stop("unsupported x_class: ", x_class)
|
|
| 428 | +795 | - - | -|
| 429 | -! | -
- list(+ ) |
|
| 430 | -! | +||
| 796 | +42x |
- response = as.vector(anl_merged_input()$columns_source$response),+ y_class <- switch(y_class, |
|
| 431 | -! | +||
| 797 | +42x |
- regressor = as.vector(anl_merged_input()$columns_source$regressor)+ "character" = , |
|
| 432 | -+ | ||
| 798 | +42x |
- )+ "ordered" = , |
|
| 433 | -+ | ||
| 799 | +42x |
- })+ "logical" = , |
|
| 434 | -+ | ||
| 800 | +42x |
-
+ "factor" = "factor", |
|
| 435 | -! | +||
| 801 | +42x |
- anl_merged_q <- reactive({
+ "integer" = , |
|
| 436 | -! | +||
| 802 | +42x |
- req(anl_merged_input())+ "numeric" = "numeric", |
|
| 437 | -! | +||
| 803 | +42x |
- data() %>%+ "NULL" = "NULL", |
|
| 438 | -! | +||
| 804 | +42x |
- teal.code::eval_code(as.expression(anl_merged_input()$expr))+ stop("unsupported y_class: ", y_class)
|
|
| 439 | +805 |
- })+ ) |
|
| 440 | +806 | ||
| 441 | -- |
- # sets qenv object and populates it with data merge call and fit expression- |
- |
| 442 | -! | +||
| 807 | +42x |
- fit_r <- reactive({
+ if (all(c(x_class, y_class) == "NULL")) {
|
|
| 443 | +808 | ! |
- ANL <- anl_merged_q()[["ANL"]]+ stop("either x or y is required")
|
| 444 | -! | +||
| 809 | +
- teal::validate_has_data(ANL, 10)+ } |
||
| 445 | +810 | ||
| 446 | -! | +||
| 811 | +42x |
- validate(need(is.numeric(ANL[regression_var()$response][[1]]), "Response variable should be numeric."))+ reduce_plot_call <- function(...) {
|
|
| 447 | -+ | ||
| 812 | +104x |
-
+ args <- Filter(Negate(is.null), list(...)) |
|
| 448 | -! | +||
| 813 | +104x |
- teal::validate_has_data(+ Reduce(function(x, y) call("+", x, y), args)
|
|
| 449 | -! | +||
| 814 | +
- ANL[, c(regression_var()$response, regression_var()$regressor)], 10,+ } |
||
| 450 | -! | +||
| 815 | +
- complete = TRUE, allow_inf = FALSE+ |
||
| 451 | -+ | ||
| 816 | +42x |
- )+ plot_call <- substitute(ggplot(data_name), env = list(data_name = as.name(data_name))) |
|
| 452 | +817 | ||
| 453 | -! | +||
| 818 | +
- form <- stats::as.formula(+ # Single data plots |
||
| 454 | -! | +||
| 819 | +42x |
- paste(+ if (x_class == "numeric" && y_class == "NULL") {
|
|
| 455 | -! | +||
| 820 | +6x |
- regression_var()$response,+ plot_call <- reduce_plot_call(plot_call, substitute(aes(x = xval), env = list(xval = x))) |
|
| 456 | -! | +||
| 821 | +
- paste(+ |
||
| 457 | -! | +||
| 822 | +6x |
- regression_var()$regressor,+ if (freq) {
|
|
| 458 | -! | +||
| 823 | +4x |
- collapse = " + "+ plot_call <- reduce_plot_call( |
|
| 459 | -+ | ||
| 824 | +4x |
- ),+ plot_call, |
|
| 460 | -! | +||
| 825 | +4x |
- sep = " ~ "+ quote(geom_histogram(bins = 30)), |
|
| 461 | -+ | ||
| 826 | +4x |
- )+ quote(ylab("Frequency"))
|
|
| 462 | +827 |
) |
|
| 463 | +828 |
-
+ } else {
|
|
| 464 | -! | +||
| 829 | +2x |
- if (input$show_outlier) {
+ plot_call <- reduce_plot_call( |
|
| 465 | -! | +||
| 830 | +2x |
- opts <- teal.transform::variable_choices(ANL)+ plot_call, |
|
| 466 | -! | +||
| 831 | +2x |
- selected <- if (!is.null(isolate(input$label_var)) && isolate(input$label_var) %in% as.character(opts)) {
+ quote(geom_histogram(bins = 30, aes(y = after_stat(density)))), |
|
| 467 | -! | +||
| 832 | +2x |
- isolate(input$label_var)+ quote(geom_density(aes(y = after_stat(density)))), |
|
| 468 | -- |
- } else {
- |
- |
| 469 | -! | +||
| 833 | +2x |
- if (length(opts[as.character(opts) == default_outlier_label]) == 0) {
+ quote(ylab("Density"))
|
|
| 470 | -! | +||
| 834 | +
- opts[[1]]+ ) |
||
| 471 | +835 |
- } else {
+ } |
|
| 472 | -! | +||
| 836 | +36x |
- opts[as.character(opts) == default_outlier_label]+ } else if (x_class == "NULL" && y_class == "numeric") {
|
|
| 473 | -+ | ||
| 837 | +6x |
- }+ plot_call <- reduce_plot_call(plot_call, substitute(aes(x = yval), env = list(yval = y))) |
|
| 474 | +838 |
- }+ |
|
| 475 | -! | +||
| 839 | +6x |
- teal.widgets::updateOptionalSelectInput(+ if (freq) {
|
|
| 476 | -! | +||
| 840 | +4x |
- session = session,+ plot_call <- reduce_plot_call( |
|
| 477 | -! | +||
| 841 | +4x |
- inputId = "label_var",+ plot_call, |
|
| 478 | -! | +||
| 842 | +4x |
- choices = opts,+ quote(geom_histogram(bins = 30)), |
|
| 479 | -! | +||
| 843 | +4x |
- selected = restoreInput(ns("label_var"), selected)
+ quote(ylab("Frequency"))
|
|
| 480 | +844 |
- )+ ) |
|
| 481 | +845 |
-
+ } else {
|
|
| 482 | -! | +||
| 846 | +2x |
- data <- fortify(stats::lm(form, data = ANL))+ plot_call <- reduce_plot_call( |
|
| 483 | -! | +||
| 847 | +2x |
- cooksd <- data$.cooksd[!is.nan(data$.cooksd)]+ plot_call, |
|
| 484 | -! | +||
| 848 | +2x |
- max_outlier <- max(ceiling(max(cooksd) / mean(cooksd)), 2)+ quote(geom_histogram(bins = 30, aes(y = after_stat(density)))), |
|
| 485 | -! | +||
| 849 | +2x |
- cur_outlier <- isolate(input$outlier)+ quote(geom_density(aes(y = after_stat(density)))), |
|
| 486 | -! | +||
| 850 | +2x |
- updateSliderInput(+ quote(ylab("Density"))
|
|
| 487 | -! | +||
| 851 | +
- session = session,+ ) |
||
| 488 | -! | +||
| 852 | +
- inputId = "outlier",+ } |
||
| 489 | -! | +||
| 853 | +30x |
- min = 1,+ } else if (x_class == "factor" && y_class == "NULL") {
|
|
| 490 | -! | +||
| 854 | +4x |
- max = max_outlier,+ plot_call <- reduce_plot_call(plot_call, substitute(aes(x = xval), env = list(xval = x))) |
|
| 491 | -! | +||
| 855 | +
- value = restoreInput(ns("outlier"), if (cur_outlier < max_outlier) cur_outlier else max_outlier * .9)
+
|
||
| 492 | -+ | ||
| 856 | +4x |
- )+ if (freq) {
|
|
| 493 | -+ | ||
| 857 | +2x |
- }+ plot_call <- reduce_plot_call( |
|
| 494 | -+ | ||
| 858 | +2x |
-
+ plot_call, |
|
| 495 | -! | +||
| 859 | +2x |
- anl_merged_q() %>%+ quote(geom_bar()), |
|
| 496 | -! | +||
| 860 | +2x |
- teal.code::eval_code(substitute(fit <- stats::lm(form, data = ANL), env = list(form = form))) %>%+ quote(ylab("Frequency"))
|
|
| 497 | -! | +||
| 861 | +
- teal.code::eval_code(quote({
+ ) |
||
| 498 | -! | +||
| 862 | +
- for (regressor in names(fit$contrasts)) {
+ } else {
|
||
| 499 | -! | +||
| 863 | +2x |
- alts <- paste0(levels(ANL[[regressor]]), collapse = "|")+ plot_call <- reduce_plot_call( |
|
| 500 | -! | +||
| 864 | +2x |
- names(fit$coefficients) <- gsub(+ plot_call, |
|
| 501 | -! | +||
| 865 | +2x |
- paste0("^(", regressor, ")(", alts, ")$"), paste0("\\1", ": ", "\\2"), names(fit$coefficients)
+ quote(geom_bar(aes(y = after_stat(prop), group = 1))), |
|
| 502 | -+ | ||
| 866 | +2x |
- )+ quote(ylab("Fraction"))
|
|
| 503 | +867 |
- }+ ) |
|
| 504 | +868 |
- })) %>%+ } |
|
| 505 | -! | +||
| 869 | +26x |
- teal.code::eval_code(quote(summary(fit)))+ } else if (x_class == "NULL" && y_class == "factor") {
|
|
| 506 | -+ | ||
| 870 | +4x |
- })+ plot_call <- reduce_plot_call(plot_call, substitute(aes(x = yval), env = list(yval = y))) |
|
| 507 | +871 | ||
| 508 | -! | +||
| 872 | +4x |
- label_col <- reactive({
+ if (freq) {
|
|
| 509 | -! | +||
| 873 | +2x |
- teal::validate_inputs(iv_out)+ plot_call <- reduce_plot_call( |
|
| 510 | -+ | ||
| 874 | +2x |
-
+ plot_call, |
|
| 511 | -! | +||
| 875 | +2x |
- substitute(+ quote(geom_bar()), |
|
| 512 | -! | +||
| 876 | +2x |
- expr = dplyr::if_else(+ quote(ylab("Frequency"))
|
|
| 513 | -! | +||
| 877 | +
- data$.cooksd > outliers * mean(data$.cooksd, na.rm = TRUE),+ ) |
||
| 514 | -! | +||
| 878 | +
- as.character(stats::na.omit(ANL)[[label_var]]),+ } else {
|
||
| 515 | -+ | ||
| 879 | +2x |
- ""+ plot_call <- reduce_plot_call( |
|
| 516 | -+ | ||
| 880 | +2x |
- ) %>%+ plot_call, |
|
| 517 | -! | +||
| 881 | +2x |
- dplyr::if_else(is.na(.), "cooksd == NaN", .),+ quote(geom_bar(aes(y = after_stat(prop), group = 1))), |
|
| 518 | -! | +||
| 882 | +2x |
- env = list(outliers = input$outlier, label_var = input$label_var)+ quote(ylab("Fraction"))
|
|
| 519 | +883 |
) |
|
| 520 | +884 |
- })+ } |
|
| 521 | +885 |
-
+ # Numeric Plots |
|
| 522 | -! | +||
| 886 | +22x |
- label_min_segment <- reactive({
+ } else if (x_class == "numeric" && y_class == "numeric") {
|
|
| 523 | -! | +||
| 887 | +2x |
- input$label_min_segment+ plot_call <- reduce_plot_call( |
|
| 524 | -+ | ||
| 888 | +2x |
- })+ plot_call,+ |
+ |
| 889 | +2x | +
+ substitute(aes(x = xval, y = yval), env = list(xval = x, yval = y)), |
|
| 525 | +890 |
-
+ # pch = 21 for consistent coloring behaviour b/w all geoms (outline and fill properties) |
|
| 526 | -! | +||
| 891 | +2x |
- outlier_label <- reactive({
+ `if`( |
|
| 527 | -! | +||
| 892 | +2x |
- substitute(+ !is.null(size), |
|
| 528 | -! | +||
| 893 | +2x |
- expr = ggrepel::geom_text_repel(+ substitute( |
|
| 529 | -! | +||
| 894 | +2x |
- label = label_col,+ geom_point(alpha = alphaval, size = sizeval, pch = 21), |
|
| 530 | -! | +||
| 895 | +2x |
- color = "red",+ env = list(alphaval = alpha, sizeval = size) |
|
| 531 | -! | +||
| 896 | +
- hjust = 0,+ ), |
||
| 532 | -! | +||
| 897 | +2x |
- vjust = 1,+ substitute( |
|
| 533 | -! | +||
| 898 | +2x |
- max.overlaps = Inf,+ geom_point(alpha = alphaval, pch = 21), |
|
| 534 | -! | +||
| 899 | +2x |
- min.segment.length = label_min_segment,+ env = list(alphaval = alpha) |
|
| 535 | -! | +||
| 900 | +
- segment.alpha = 0.5,+ ) |
||
| 536 | -! | +||
| 901 | +
- seed = 123+ ) |
||
| 537 | +902 |
- ),+ ) |
|
| 538 | -! | +||
| 903 | +20x |
- env = list(label_col = label_col(), label_min_segment = label_min_segment())+ } else if ((x_class == "numeric" && y_class == "factor") || (x_class == "factor" && y_class == "numeric")) {
|
|
| 539 | -+ | ||
| 904 | +6x |
- )+ plot_call <- reduce_plot_call(+ |
+ |
| 905 | +6x | +
+ plot_call,+ |
+ |
| 906 | +6x | +
+ substitute(aes(x = xval, y = yval), env = list(xval = x, yval = y)),+ |
+ |
| 907 | +6x | +
+ quote(geom_boxplot()) |
|
| 540 | +908 |
- })+ ) |
|
| 541 | +909 |
-
+ # Factor and character plots |
|
| 542 | -! | +||
| 910 | +14x |
- output_q <- reactive({
+ } else if (x_class == "factor" && y_class == "factor") {
|
|
| 543 | -! | +||
| 911 | +14x |
- alpha <- input$alpha+ plot_call <- reduce_plot_call( |
|
| 544 | -! | +||
| 912 | +14x |
- size <- input$size+ plot_call, |
|
| 545 | -! | +||
| 913 | +14x |
- ggtheme <- input$ggtheme+ substitute( |
|
| 546 | -! | +||
| 914 | +14x |
- input_type <- input$plot_type+ ggmosaic::geom_mosaic(aes(x = ggmosaic::product(xval), fill = yval), na.rm = TRUE), |
|
| 547 | -! | +||
| 915 | +14x |
- show_outlier <- input$show_outlier+ env = list(xval = x, yval = y) |
|
| 548 | +916 | - - | -|
| 549 | -! | -
- teal::validate_inputs(iv_r())+ ) |
|
| 550 | +917 |
-
+ ) |
|
| 551 | -! | +||
| 918 | +
- plot_type_0 <- function() {
+ } else {
|
||
| 552 | +919 | ! |
- fit <- fit_r()[["fit"]]+ stop("x y type combination not allowed")
|
| 553 | -! | +||
| 920 | +
- ANL <- anl_merged_q()[["ANL"]]+ } |
||
| 554 | +921 | ||
| 555 | -! | +||
| 922 | +42x |
- stopifnot(ncol(fit$model) == 2)+ labs_base <- if (x_class == "NULL") {
|
|
| 556 | -+ | ||
| 923 | +10x |
-
+ list(x = substitute(ylab, list(ylab = ylab))) |
|
| 557 | -! | +||
| 924 | +42x |
- if (!is.factor(ANL[[regression_var()$regressor]])) {
+ } else if (y_class == "NULL") {
|
|
| 558 | -! | +||
| 925 | +10x |
- shinyjs::show("size")
+ list(x = substitute(xlab, list(xlab = xlab))) |
|
| 559 | -! | +||
| 926 | +
- shinyjs::show("alpha")
+ } else {
|
||
| 560 | -! | +||
| 927 | +22x |
- plot <- substitute(+ list( |
|
| 561 | -! | +||
| 928 | +22x |
- env = list(+ x = substitute(xlab, list(xlab = xlab)), |
|
| 562 | -! | +||
| 929 | +22x |
- regressor = regression_var()$regressor,+ y = substitute(ylab, list(ylab = ylab)) |
|
| 563 | -! | +||
| 930 | +
- response = regression_var()$response,+ ) |
||
| 564 | -! | +||
| 931 | +
- size = size,+ } |
||
| 565 | -! | +||
| 932 | +
- alpha = alpha+ |
||
| 566 | -+ | ||
| 933 | +42x |
- ),+ dev_ggplot2_args <- teal.widgets::ggplot2_args(labs = labs_base) |
|
| 567 | -! | +||
| 934 | +
- expr = ggplot(+ |
||
| 568 | -! | +||
| 935 | +42x |
- fit$model[, 2:1],+ if (rotate_xaxis_labels) {
|
|
| 569 | +936 | ! |
- aes_string(regressor, response)+ dev_ggplot2_args$theme <- list(axis.text.x = quote(element_text(angle = 45, hjust = 1))) |
| 570 | +937 |
- ) ++ } |
|
| 571 | -! | +||
| 938 | +
- geom_point(size = size, alpha = alpha) ++ |
||
| 572 | -! | +||
| 939 | +42x |
- stat_smooth(+ all_ggplot2_args <- teal.widgets::resolve_ggplot2_args( |
|
| 573 | -! | +||
| 940 | +42x |
- method = "lm",+ user_plot = ggplot2_args, |
|
| 574 | -! | +||
| 941 | +42x |
- formula = y ~ x,+ module_plot = dev_ggplot2_args |
|
| 575 | -! | +||
| 942 | +
- se = FALSE+ ) |
||
| 576 | +943 |
- )+ + |
+ |
| 944 | +42x | +
+ parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(all_ggplot2_args, ggtheme = theme) |
|
| 577 | +945 |
- )+ |
|
| 578 | -! | +||
| 946 | +42x |
- if (show_outlier) {
+ plot_call <- reduce_plot_call( |
|
| 579 | -! | +||
| 947 | +42x |
- plot <- substitute(+ plot_call, |
|
| 580 | -! | +||
| 948 | +42x |
- expr = plot + outlier_label,+ parsed_ggplot2_args$labs, |
|
| 581 | -! | +||
| 949 | +42x |
- env = list(plot = plot, outlier_label = outlier_label())+ parsed_ggplot2_args$ggtheme, |
|
| 582 | -+ | ||
| 950 | +42x |
- )+ parsed_ggplot2_args$theme |
|
| 583 | +951 |
- }+ ) |
|
| 584 | +952 |
- } else {
+
|
|
| 585 | -! | +||
| 953 | +42x |
- shinyjs::hide("size")
+ if (swap_axes) {
|
|
| 586 | +954 | ! |
- shinyjs::hide("alpha")
+ plot_call <- reduce_plot_call(plot_call, quote(coord_flip())) |
| 587 | -! | +||
| 955 | +
- plot <- substitute(+ } |
||
| 588 | -! | +||
| 956 | +
- expr = ggplot(fit$model[, 2:1], aes_string(regressor, response)) ++ |
||
| 589 | -! | +||
| 957 | +42x |
- geom_boxplot(),+ plot_call |
|
| 590 | -! | +||
| 958 | +
- env = list(regressor = regression_var()$regressor, response = regression_var()$response)+ } |
||
| 591 | +959 |
- )+ |
|
| 592 | -! | +||
| 960 | +
- if (show_outlier) {
+ # Create facet call |
||
| 593 | -! | +||
| 961 | +
- plot <- substitute(expr = plot + outlier_label, env = list(plot = plot, outlier_label = outlier_label()))+ facet_ggplot_call <- function(row_facet = character(0), |
||
| 594 | +962 |
- }+ col_facet = character(0), |
|
| 595 | +963 |
- }+ free_x_scales = FALSE, |
|
| 596 | +964 |
-
+ free_y_scales = FALSE) {
|
|
| 597 | +965 | ! |
- parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(+ scales <- if (free_x_scales && free_y_scales) {
|
| 598 | +966 | ! |
- teal.widgets::resolve_ggplot2_args(+ "free" |
| 599 | +967 | ! |
- user_plot = ggplot2_args[["Response vs Regressor"]],+ } else if (free_x_scales) {
|
| 600 | +968 | ! |
- user_default = ggplot2_args$default,+ "free_x" |
| 601 | +969 | ! |
- module_plot = teal.widgets::ggplot2_args(+ } else if (free_y_scales) {
|
| 602 | +970 | ! |
- labs = list(+ "free_y" |
| 603 | -! | +||
| 971 | +
- title = "Response vs Regressor",+ } else {
|
||
| 604 | +972 | ! |
- x = varname_w_label(regression_var()$regressor, ANL),+ "fixed" |
| 605 | -! | +||
| 973 | +
- y = varname_w_label(regression_var()$response, ANL)+ } |
||
| 606 | +974 |
- ),+ |
|
| 607 | +975 | ! |
- theme = list()+ if (identical(row_facet, character(0)) && identical(col_facet, character(0))) {
|
| 608 | -+ | ||
| 976 | +! |
- )+ NULL |
|
| 609 | -+ | ||
| 977 | +! |
- ),+ } else if (!identical(row_facet, character(0)) && !identical(col_facet, character(0))) {
|
|
| 610 | +978 | ! |
- ggtheme = ggtheme+ call( |
| 611 | -+ | ||
| 979 | +! |
- )- |
- |
| 612 | -- |
-
+ "facet_grid", |
|
| 613 | +980 | ! |
- teal.code::eval_code(+ rows = call_fun_dots("vars", row_facet),
|
| 614 | +981 | ! |
- fit_r(),+ cols = call_fun_dots("vars", col_facet),
|
| 615 | +982 | ! |
- substitute(+ scales = scales |
| 616 | -! | +||
| 983 | +
- expr = {
+ ) |
||
| 617 | +984 | ! |
- class(fit$residuals) <- NULL+ } else if (identical(row_facet, character(0)) && !identical(col_facet, character(0))) {
|
| 618 | +985 | ! |
- data <- fortify(fit)+ call("facet_grid", cols = call_fun_dots("vars", col_facet), scales = scales)
|
| 619 | +986 | ! |
- g <- plot+ } else if (!identical(row_facet, character(0)) && identical(col_facet, character(0))) {
|
| 620 | +987 | ! |
- print(g)+ call("facet_grid", rows = call_fun_dots("vars", row_facet), scales = scales)
|
| 621 | +988 |
- },- |
- |
| 622 | -! | -
- env = list(- |
- |
| 623 | -! | -
- plot = Reduce(function(x, y) call("+", x, y), c(plot, parsed_ggplot2_args))
+ } |
|
| 624 | +989 |
- )+ } |
|
| 625 | +990 |
- )+ |
|
| 626 | +991 |
- )+ coloring_ggplot_call <- function(colour, |
|
| 627 | +992 |
- }+ fill, |
|
| 628 | +993 |
-
+ size, |
|
| 629 | -! | +||
| 994 | +
- plot_base <- function() {
+ is_point = FALSE) {
|
||
| 630 | -! | +||
| 995 | +
- base_fit <- fit_r()+ if ( |
||
| 631 | -! | +||
| 996 | +15x |
- teal.code::eval_code(+ !identical(colour, character(0)) && |
|
| 632 | -! | +||
| 997 | +15x |
- base_fit,+ !identical(fill, character(0)) && |
|
| 633 | -! | +||
| 998 | +15x |
- quote({
+ is_point && |
|
| 634 | -! | +||
| 999 | +15x |
- class(fit$residuals) <- NULL+ !identical(size, character(0)) |
|
| 635 | +1000 | - - | -|
| 636 | -! | -
- data <- ggplot2::fortify(fit)+ ) {
|
|
| 637 | -+ | ||
| 1001 | +1x |
-
+ substitute( |
|
| 638 | -! | +||
| 1002 | +1x |
- smooth <- function(x, y) {
+ expr = aes(colour = colour_name, fill = fill_name, size = size_name), |
|
| 639 | -! | +||
| 1003 | +1x |
- as.data.frame(stats::lowess(x, y, f = 2 / 3, iter = 3))+ env = list(colour_name = as.name(colour), fill_name = as.name(fill), size_name = as.name(size)) |
|
| 640 | +1004 |
- }+ ) |
|
| 641 | +1005 |
-
+ } else if ( |
|
| 642 | -! | +||
| 1006 | +14x |
- smoothy_aes <- ggplot2::aes_string(x = "x", y = "y")+ identical(colour, character(0)) && |
|
| 643 | -+ | ||
| 1007 | +14x |
-
+ !identical(fill, character(0)) && |
|
| 644 | -! | +||
| 1008 | +14x |
- reg_form <- deparse(fit$call[[2]])+ is_point && |
|
| 645 | -+ | ||
| 1009 | +14x |
- })+ identical(size, character(0)) |
|
| 646 | +1010 |
- )+ ) {
|
|
| 647 | -+ | ||
| 1011 | +1x |
- }+ substitute(expr = aes(fill = fill_name), env = list(fill_name = as.name(fill))) |
|
| 648 | +1012 |
-
+ } else if ( |
|
| 649 | -! | +||
| 1013 | +13x |
- plot_type_1 <- function(plot_base) {
+ !identical(colour, character(0)) && |
|
| 650 | -! | +||
| 1014 | +13x |
- shinyjs::show("size")
+ !identical(fill, character(0)) && |
|
| 651 | -! | +||
| 1015 | +13x |
- shinyjs::show("alpha")
+ (!is_point || identical(size, character(0))) |
|
| 652 | -! | +||
| 1016 | +
- plot <- substitute(+ ) {
|
||
| 653 | -! | +||
| 1017 | +3x |
- expr = ggplot(data = data, aes(.fitted, .resid)) ++ substitute( |
|
| 654 | -! | +||
| 1018 | +3x |
- geom_point(size = size, alpha = alpha) ++ expr = aes(colour = colour_name, fill = fill_name), |
|
| 655 | -! | +||
| 1019 | +3x |
- geom_hline(yintercept = 0, linetype = "dashed", size = 1) ++ env = list(colour_name = as.name(colour), fill_name = as.name(fill)) |
|
| 656 | -! | +||
| 1020 | +
- geom_line(data = smoothy, mapping = smoothy_aes),+ ) |
||
| 657 | -! | +||
| 1021 | +
- env = list(size = size, alpha = alpha)+ } else if ( |
||
| 658 | -+ | ||
| 1022 | +10x |
- )+ !identical(colour, character(0)) && |
|
| 659 | -! | +||
| 1023 | +10x |
- if (show_outlier) {
+ identical(fill, character(0)) && |
|
| 660 | -! | +||
| 1024 | +10x |
- plot <- substitute(expr = plot + outlier_label, env = list(plot = plot, outlier_label = outlier_label()))+ (!is_point || identical(size, character(0))) |
|
| 661 | +1025 |
- }+ ) {
|
|
| 662 | -+ | ||
| 1026 | +1x |
-
+ substitute(expr = aes(colour = colour_name), env = list(colour_name = as.name(colour))) |
|
| 663 | -! | +||
| 1027 | +
- parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(+ } else if ( |
||
| 664 | -! | +||
| 1028 | +9x |
- teal.widgets::resolve_ggplot2_args(+ identical(colour, character(0)) && |
|
| 665 | -! | +||
| 1029 | +9x |
- user_plot = ggplot2_args[["Residuals vs Fitted"]],+ !identical(fill, character(0)) && |
|
| 666 | -! | +||
| 1030 | +9x |
- user_default = ggplot2_args$default,+ (!is_point || identical(size, character(0))) |
|
| 667 | -! | +||
| 1031 | +
- module_plot = teal.widgets::ggplot2_args(+ ) {
|
||
| 668 | -! | +||
| 1032 | +2x |
- labs = list(+ substitute(expr = aes(fill = fill_name), env = list(fill_name = as.name(fill))) |
|
| 669 | -! | +||
| 1033 | +
- x = quote(paste0("Fitted values\nlm(", reg_form, ")")),
+ } else if ( |
||
| 670 | -! | +||
| 1034 | +7x |
- y = "Residuals",+ identical(colour, character(0)) && |
|
| 671 | -! | +||
| 1035 | +7x |
- title = "Residuals vs Fitted"+ identical(fill, character(0)) && |
|
| 672 | -+ | ||
| 1036 | +7x |
- )+ is_point && |
|
| 673 | -+ | ||
| 1037 | +7x |
- )+ !identical(size, character(0)) |
|
| 674 | +1038 |
- ),+ ) {
|
|
| 675 | -! | +||
| 1039 | +1x |
- ggtheme = ggtheme+ substitute(expr = aes(size = size_name), env = list(size_name = as.name(size))) |
|
| 676 | +1040 |
- )+ } else if ( |
|
| 677 | -+ | ||
| 1041 | +6x |
-
+ !identical(colour, character(0)) && |
|
| 678 | -! | +||
| 1042 | +6x |
- teal.code::eval_code(+ identical(fill, character(0)) && |
|
| 679 | -! | +||
| 1043 | +6x |
- plot_base,+ is_point && |
|
| 680 | -! | +||
| 1044 | +6x |
- substitute(+ !identical(size, character(0)) |
|
| 681 | -! | +||
| 1045 | +
- expr = {
+ ) {
|
||
| 682 | -! | +||
| 1046 | +1x |
- smoothy <- smooth(data$.fitted, data$.resid)+ substitute( |
|
| 683 | -! | +||
| 1047 | +1x |
- g <- plot+ expr = aes(colour = colour_name, size = size_name), |
|
| 684 | -! | +||
| 1048 | +1x |
- print(g)+ env = list(colour_name = as.name(colour), size_name = as.name(size)) |
|
| 685 | +1049 |
- },+ ) |
|
| 686 | -! | +||
| 1050 | +
- env = list(+ } else if ( |
||
| 687 | -! | +||
| 1051 | +5x |
- plot = Reduce(function(x, y) call("+", x, y), c(plot, parsed_ggplot2_args))
+ identical(colour, character(0)) && |
|
| 688 | -+ | ||
| 1052 | +5x |
- )+ !identical(fill, character(0)) && |
|
| 689 | -+ | ||
| 1053 | +5x |
- )+ is_point && |
|
| 690 | -+ | ||
| 1054 | +5x |
- )+ !identical(size, character(0)) |
|
| 691 | +1055 |
- }+ ) {
|
|
| 692 | -+ | ||
| 1056 | +1x |
-
+ substitute( |
|
| 693 | -! | +||
| 1057 | +1x |
- plot_type_2 <- function(plot_base) {
+ expr = aes(colour = colour_name, fill = fill_name, size = size_name), |
|
| 694 | -! | +||
| 1058 | +1x |
- shinyjs::show("size")
+ env = list(colour_name = as.name(fill), fill_name = as.name(fill), size_name = as.name(size)) |
|
| 695 | -! | +||
| 1059 | +
- shinyjs::show("alpha")
+ ) |
||
| 696 | -! | +||
| 1060 | +
- plot <- substitute(+ } else {
|
||
| 697 | -! | +||
| 1061 | +4x |
- expr = ggplot(data = data, aes(sample = .stdresid)) ++ NULL |
|
| 698 | -! | +||
| 1062 | +
- stat_qq(size = size, alpha = alpha) ++ } |
||
| 699 | -! | +||
| 1063 | +
- geom_abline(linetype = "dashed"),+ } |
||
| 700 | -! | +
| 1 | +
- env = list(size = size, alpha = alpha)+ #' `teal` module: Variable browser |
||
| 701 | +2 |
- )+ #' |
|
| 702 | -! | +||
| 3 | +
- if (show_outlier) {
+ #' Module provides provides a detailed summary and visualization of variable distributions |
||
| 703 | -! | +||
| 4 | +
- plot <- substitute(+ #' for `data.frame` objects, with interactive features to customize analysis. |
||
| 704 | -! | +||
| 5 | +
- expr = plot ++ #' |
||
| 705 | -! | +||
| 6 | +
- stat_qq(+ #' Numeric columns with fewer than 30 distinct values can be treated as either discrete |
||
| 706 | -! | +||
| 7 | +
- geom = ggrepel::GeomTextRepel,+ #' or continuous with a checkbox allowing users to switch how they are treated(if < 6 unique values |
||
| 707 | -! | +||
| 8 | +
- label = label_col %>%+ #' then the default is discrete, otherwise it is continuous). |
||
| 708 | -! | +||
| 9 | +
- data.frame(label = .) %>%+ #' |
||
| 709 | -! | +||
| 10 | +
- dplyr::filter(label != "cooksd == NaN") %>%+ #' @inheritParams teal::module |
||
| 710 | -! | +||
| 11 | +
- unlist(),+ #' @inheritParams shared_params |
||
| 711 | -! | +||
| 12 | +
- color = "red",+ #' @param parent_dataname (`character(1)`) string specifying a parent dataset. |
||
| 712 | -! | +||
| 13 | +
- hjust = 0,+ #' If it exists in `datasets_selected`then an extra checkbox will be shown to |
||
| 713 | -! | +||
| 14 | +
- vjust = 0,+ #' allow users to not show variables in other datasets which exist in this `dataname`. |
||
| 714 | -! | +||
| 15 | +
- max.overlaps = Inf,+ #' This is typically used to remove `ADSL` columns in `CDISC` data. |
||
| 715 | -! | +||
| 16 | +
- min.segment.length = label_min_segment,+ #' In non `CDISC` data this can be ignored. Defaults to `"ADSL"`. |
||
| 716 | -! | +||
| 17 | +
- segment.alpha = .5,+ #' @param datasets_selected (`character`) vector of datasets which should be |
||
| 717 | -! | +||
| 18 | +
- seed = 123+ #' shown, in order. Names must correspond with datasets names. |
||
| 718 | +19 |
- ),+ #' If vector of length zero (default) then all datasets are shown. |
|
| 719 | -! | +||
| 20 | +
- env = list(plot = plot, label_col = label_col(), label_min_segment = label_min_segment())+ #' Note: Only `data.frame` objects are compatible; using other types will cause an error. |
||
| 720 | +21 |
- )+ #' |
|
| 721 | +22 |
- }+ #' @inherit shared_params return |
|
| 722 | +23 |
-
+ #' |
|
| 723 | -! | +||
| 24 | +
- parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(+ #' @examplesShinylive |
||
| 724 | -! | +||
| 25 | +
- teal.widgets::resolve_ggplot2_args(+ #' library(teal.modules.general) |
||
| 725 | -! | +||
| 26 | +
- user_plot = ggplot2_args[["Normal Q-Q"]],+ #' interactive <- function() TRUE |
||
| 726 | -! | +||
| 27 | +
- user_default = ggplot2_args$default,+ #' {{ next_example }}
|
||
| 727 | -! | +||
| 28 | +
- module_plot = teal.widgets::ggplot2_args(+ # nolint start: line_length_linter. |
||
| 728 | -! | +||
| 29 | +
- labs = list(+ #' @examplesIf require("sparkline", quietly = TRUE) && require("htmlwidgets", quietly = TRUE) && require("jsonlite", quietly = TRUE)
|
||
| 729 | -! | +||
| 30 | +
- x = quote(paste0("Theoretical Quantiles\nlm(", reg_form, ")")),
+ # nolint end: line_length_linter. |
||
| 730 | -! | +||
| 31 | +
- y = "Standardized residuals",+ #' # general data example |
||
| 731 | -! | +||
| 32 | +
- title = "Normal Q-Q"+ #' data <- teal_data() |
||
| 732 | +33 |
- )+ #' data <- within(data, {
|
|
| 733 | +34 |
- )+ #' iris <- iris |
|
| 734 | +35 |
- ),+ #' mtcars <- mtcars |
|
| 735 | -! | +||
| 36 | +
- ggtheme = ggtheme+ #' women <- women |
||
| 736 | +37 |
- )+ #' faithful <- faithful |
|
| 737 | +38 |
-
+ #' CO2 <- CO2 |
|
| 738 | -! | +||
| 39 | +
- teal.code::eval_code(+ #' }) |
||
| 739 | -! | +||
| 40 | +
- plot_base,+ #' |
||
| 740 | -! | +||
| 41 | +
- substitute(+ #' app <- init( |
||
| 741 | -! | +||
| 42 | +
- expr = {
+ #' data = data, |
||
| 742 | -! | +||
| 43 | +
- g <- plot+ #' modules = modules( |
||
| 743 | -! | +||
| 44 | +
- print(g)+ #' tm_variable_browser( |
||
| 744 | +45 |
- },+ #' label = "Variable browser" |
|
| 745 | -! | +||
| 46 | +
- env = list(+ #' ) |
||
| 746 | -! | +||
| 47 | +
- plot = Reduce(function(x, y) call("+", x, y), c(plot, parsed_ggplot2_args))
+ #' ) |
||
| 747 | +48 |
- )+ #' ) |
|
| 748 | +49 |
- )+ #' if (interactive()) {
|
|
| 749 | +50 |
- )+ #' shinyApp(app$ui, app$server) |
|
| 750 | +51 |
- }+ #' } |
|
| 751 | +52 |
-
+ #' |
|
| 752 | -! | +||
| 53 | +
- plot_type_3 <- function(plot_base) {
+ #' @examplesShinylive |
||
| 753 | -! | +||
| 54 | +
- shinyjs::show("size")
+ #' library(teal.modules.general) |
||
| 754 | -! | +||
| 55 | +
- shinyjs::show("alpha")
+ #' interactive <- function() TRUE |
||
| 755 | -! | +||
| 56 | +
- plot <- substitute(+ #' {{ next_example }}
|
||
| 756 | -! | +||
| 57 | +
- expr = ggplot(data = data, aes(.fitted, sqrt(abs(.stdresid)))) ++ # nolint start: line_length_linter. |
||
| 757 | -! | +||
| 58 | +
- geom_point(size = size, alpha = alpha) ++ #' @examplesIf require("sparkline", quietly = TRUE) && require("htmlwidgets", quietly = TRUE) && require("jsonlite", quietly = TRUE)
|
||
| 758 | -! | +||
| 59 | +
- geom_line(data = smoothy, mapping = smoothy_aes),- |
- ||
| 759 | -! | -
- env = list(size = size, alpha = alpha)+ # nolint end: line_length_linter. |
|
| 760 | +60 |
- )+ #' # CDISC example data |
|
| 761 | -! | +||
| 61 | +
- if (show_outlier) {
+ #' library(sparkline) |
||
| 762 | -! | +||
| 62 | +
- plot <- substitute(expr = plot + outlier_label, env = list(plot = plot, outlier_label = outlier_label()))+ #' data <- teal_data() |
||
| 763 | +63 |
- }+ #' data <- within(data, {
|
|
| 764 | +64 |
-
+ #' ADSL <- rADSL |
|
| 765 | -! | +||
| 65 | +
- parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(+ #' ADTTE <- rADTTE |
||
| 766 | -! | +||
| 66 | +
- teal.widgets::resolve_ggplot2_args(+ #' }) |
||
| 767 | -! | +||
| 67 | +
- user_plot = ggplot2_args[["Scale-Location"]],+ #' join_keys(data) <- default_cdisc_join_keys[names(data)] |
||
| 768 | -! | +||
| 68 | +
- user_default = ggplot2_args$default,+ #' |
||
| 769 | -! | +||
| 69 | +
- module_plot = teal.widgets::ggplot2_args(+ #' app <- init( |
||
| 770 | -! | +||
| 70 | +
- labs = list(+ #' data = data, |
||
| 771 | -! | +||
| 71 | +
- x = quote(paste0("Fitted values\nlm(", reg_form, ")")),
+ #' modules = modules( |
||
| 772 | -! | +||
| 72 | +
- y = quote(expression(sqrt(abs(`Standardized residuals`)))),+ #' tm_variable_browser( |
||
| 773 | -! | +||
| 73 | +
- title = "Scale-Location"+ #' label = "Variable browser" |
||
| 774 | +74 |
- )+ #' ) |
|
| 775 | +75 |
- )+ #' ) |
|
| 776 | +76 |
- ),+ #' ) |
|
| 777 | -! | +||
| 77 | +
- ggtheme = ggtheme+ #' if (interactive()) {
|
||
| 778 | +78 |
- )+ #' shinyApp(app$ui, app$server) |
|
| 779 | +79 |
-
+ #' } |
|
| 780 | -! | +||
| 80 | +
- teal.code::eval_code(+ #' |
||
| 781 | -! | +||
| 81 | +
- plot_base,+ #' @export |
||
| 782 | -! | +||
| 82 | +
- substitute(+ #' |
||
| 783 | -! | +||
| 83 | +
- expr = {
+ tm_variable_browser <- function(label = "Variable Browser", |
||
| 784 | -! | +||
| 84 | +
- smoothy <- smooth(data$.fitted, sqrt(abs(data$.stdresid)))+ datasets_selected = character(0), |
||
| 785 | -! | +||
| 85 | +
- g <- plot+ parent_dataname = "ADSL", |
||
| 786 | -! | +||
| 86 | +
- print(g)+ pre_output = NULL, |
||
| 787 | +87 |
- },+ post_output = NULL, |
|
| 788 | -! | +||
| 88 | +
- env = list(+ ggplot2_args = teal.widgets::ggplot2_args()) {
|
||
| 789 | +89 | ! |
- plot = Reduce(function(x, y) call("+", x, y), c(plot, parsed_ggplot2_args))
+ message("Initializing tm_variable_browser")
|
| 790 | +90 |
- )+ |
|
| 791 | +91 |
- )+ # Requires Suggested packages |
|
| 792 | -+ | ||
| 92 | +! |
- )+ if (!requireNamespace("sparkline", quietly = TRUE)) {
|
|
| 793 | -+ | ||
| 93 | +! |
- }+ stop("Cannot load sparkline - please install the package or restart your session.")
|
|
| 794 | +94 |
-
+ } |
|
| 795 | +95 | ! |
- plot_type_4 <- function(plot_base) {
+ if (!requireNamespace("htmlwidgets", quietly = TRUE)) {
|
| 796 | +96 | ! |
- shinyjs::hide("size")
+ stop("Cannot load htmlwidgets - please install the package or restart your session.")
|
| 797 | -! | +||
| 97 | +
- shinyjs::show("alpha")
+ } |
||
| 798 | +98 | ! |
- plot <- substitute(+ if (!requireNamespace("jsonlite", quietly = TRUE)) {
|
| 799 | +99 | ! |
- expr = ggplot(data = data, aes(seq_along(.cooksd), .cooksd)) ++ stop("Cannot load jsonlite - please install the package or restart your session.")
|
| 800 | -! | +||
| 100 | +
- geom_col(alpha = alpha),+ } |
||
| 801 | -! | +||
| 101 | +
- env = list(alpha = alpha)+ |
||
| 802 | +102 |
- )+ # Start of assertions |
|
| 803 | +103 | ! |
- if (show_outlier) {
+ checkmate::assert_string(label) |
| 804 | +104 | ! |
- plot <- substitute(+ checkmate::assert_character(datasets_selected) |
| 805 | +105 | ! |
- expr = plot ++ checkmate::assert_character(parent_dataname, min.len = 0, max.len = 1) |
| 806 | +106 | ! |
- geom_hline(+ checkmate::assert_multi_class(pre_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
|
| 807 | +107 | ! |
- yintercept = c(+ checkmate::assert_multi_class(post_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
|
| 808 | +108 | ! |
- outlier * mean(data$.cooksd, na.rm = TRUE),+ checkmate::assert_class(ggplot2_args, "ggplot2_args")+ |
+
| 109 | ++ |
+ # End of assertions+ |
+ |
| 110 | ++ | + | |
| 809 | +111 | ! |
- mean(data$.cooksd, na.rm = TRUE)+ datasets_selected <- unique(datasets_selected) |
| 810 | +112 |
- ),+ |
|
| 811 | +113 | ! |
- color = "red",+ ans <- module( |
| 812 | +114 | ! |
- linetype = "dashed"+ label, |
| 813 | -+ | ||
| 115 | +! |
- ) ++ server = srv_variable_browser, |
|
| 814 | +116 | ! |
- geom_text(+ ui = ui_variable_browser, |
| 815 | +117 | ! |
- aes(+ datanames = "all", |
| 816 | +118 | ! |
- x = 0,+ server_args = list( |
| 817 | +119 | ! |
- y = mean(data$.cooksd, na.rm = TRUE),+ datasets_selected = datasets_selected, |
| 818 | +120 | ! |
- label = paste("mu", "=", round(mean(data$.cooksd, na.rm = TRUE), 4)),
+ parent_dataname = parent_dataname, |
| 819 | +121 | ! |
- vjust = -1,+ ggplot2_args = ggplot2_args+ |
+
| 122 | ++ |
+ ), |
|
| 820 | +123 | ! |
- hjust = 0,+ ui_args = list( |
| 821 | +124 | ! |
- color = "red",+ pre_output = pre_output, |
| 822 | +125 | ! |
- angle = 90+ post_output = post_output |
| 823 | +126 |
- ),+ )+ |
+ |
| 127 | ++ |
+ )+ |
+ |
| 128 | ++ |
+ # `shiny` inputs are stored properly but the majority of the module is state of `datatable` which is not stored. |
|
| 824 | +129 | ! |
- parse = TRUE,+ attr(ans, "teal_bookmarkable") <- NULL |
| 825 | +130 | ! |
- show.legend = FALSE+ ans |
| 826 | +131 |
- ) ++ } |
|
| 827 | -! | +||
| 132 | +
- outlier_label,+ |
||
| 828 | -! | +||
| 133 | +
- env = list(plot = plot, outlier = input$outlier, outlier_label = outlier_label())+ # UI function for the variable browser module |
||
| 829 | +134 |
- )+ ui_variable_browser <- function(id, |
|
| 830 | +135 |
- }+ pre_output = NULL, |
|
| 831 | +136 |
-
+ post_output = NULL) {
|
|
| 832 | +137 | ! |
- parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(+ ns <- NS(id)+ |
+
| 138 | ++ | + | |
| 833 | +139 | ! |
- teal.widgets::resolve_ggplot2_args(+ tagList( |
| 834 | +140 | ! |
- user_plot = ggplot2_args[["Cook's distance"]],+ include_css_files("custom"),
|
| 835 | +141 | ! |
- user_default = ggplot2_args$default,+ shinyjs::useShinyjs(), |
| 836 | +142 | ! |
- module_plot = teal.widgets::ggplot2_args(+ teal.widgets::standard_layout( |
| 837 | +143 | ! |
- labs = list(+ output = fluidRow( |
| 838 | +144 | ! |
- x = quote(paste0("Obs. number\nlm(", reg_form, ")")),
+ htmlwidgets::getDependency("sparkline"), # needed for sparklines to work
|
| 839 | +145 | ! |
- y = "Cook's distance",+ column( |
| 840 | +146 | ! |
- title = "Cook's distance"+ 6, |
| 841 | +147 |
- )+ # variable browser |
|
| 842 | -+ | ||
| 148 | +! |
- )+ teal.widgets::white_small_well( |
|
| 843 | -+ | ||
| 149 | +! |
- ),+ uiOutput(ns("ui_variable_browser")),
|
|
| 844 | +150 | ! |
- ggtheme = ggtheme+ shinyjs::hidden({
|
| 845 | -+ | ||
| 151 | +! |
- )+ checkboxInput(ns("show_parent_vars"), "Show parent dataset variables", value = FALSE)
|
|
| 846 | +152 |
-
+ }) |
|
| 847 | -! | +||
| 153 | +
- teal.code::eval_code(+ ) |
||
| 848 | -! | +||
| 154 | +
- plot_base,+ ), |
||
| 849 | +155 | ! |
- substitute(+ column( |
| 850 | +156 | ! |
- expr = {
+ 6, |
| 851 | +157 | ! |
- g <- plot+ teal.widgets::white_small_well(+ |
+
| 158 | ++ |
+ ### Reporter |
|
| 852 | +159 | ! |
- print(g)+ teal.reporter::simple_reporter_ui(ns("simple_reporter")),
|
| 853 | +160 |
- },+ ### |
|
| 854 | +161 | ! |
- env = list(+ tags$div( |
| 855 | +162 | ! |
- plot = Reduce(function(x, y) call("+", x, y), c(plot, parsed_ggplot2_args))
+ class = "block", |
| 856 | -+ | ||
| 163 | +! |
- )+ uiOutput(ns("ui_histogram_display"))
|
|
| 857 | +164 |
- )+ ), |
|
| 858 | -+ | ||
| 165 | +! |
- )+ tags$div( |
|
| 859 | -+ | ||
| 166 | +! |
- }+ class = "block", |
|
| 860 | -+ | ||
| 167 | +! |
-
+ uiOutput(ns("ui_numeric_display"))
|
|
| 861 | +168 |
-
+ ), |
|
| 862 | +169 | ! |
- plot_type_5 <- function(plot_base) {
+ teal.widgets::plot_with_settings_ui(ns("variable_plot")),
|
| 863 | +170 | ! |
- shinyjs::show("size")
+ tags$br(), |
| 864 | -! | +||
| 171 | +
- shinyjs::show("alpha")
+ # input user-defined text size |
||
| 865 | +172 | ! |
- plot <- substitute(+ teal.widgets::panel_item( |
| 866 | +173 | ! |
- expr = ggplot(data = data, aes(.hat, .stdresid)) ++ title = "Plot settings", |
| 867 | +174 | ! |
- geom_vline(+ collapsed = TRUE, |
| 868 | +175 | ! |
- size = 1,+ selectInput( |
| 869 | +176 | ! |
- colour = "black",+ inputId = ns("ggplot_theme"), label = "ggplot2 theme",
|
| 870 | +177 | ! |
- linetype = "dashed",+ choices = ggplot_themes, |
| 871 | +178 | ! |
- xintercept = 0+ selected = "grey" |
| 872 | +179 |
- ) +- |
- |
| 873 | -! | -
- geom_hline(+ ), |
|
| 874 | +180 | ! |
- size = 1,+ fluidRow( |
| 875 | +181 | ! |
- colour = "black",+ column(6, sliderInput( |
| 876 | +182 | ! |
- linetype = "dashed",+ inputId = ns("font_size"), label = "font size",
|
| 877 | +183 | ! |
- yintercept = 0+ min = 5L, max = 30L, value = 15L, step = 1L, ticks = FALSE |
| 878 | +184 |
- ) ++ )), |
|
| 879 | +185 | ! |
- geom_point(size = size, alpha = alpha) ++ column(6, sliderInput( |
| 880 | +186 | ! |
- geom_line(data = smoothy, mapping = smoothy_aes),+ inputId = ns("label_rotation"), label = "rotate x labels",
|
| 881 | +187 | ! |
- env = list(size = size, alpha = alpha)+ min = 0L, max = 90L, value = 45L, step = 1, ticks = FALSE |
| 882 | +188 |
- )- |
- |
| 883 | -! | -
- if (show_outlier) {
- |
- |
| 884 | -! | -
- plot <- substitute(expr = plot + outlier_label, env = list(plot = plot, outlier_label = outlier_label()))+ )) |
|
| 885 | +189 |
- }+ ) |
|
| 886 | +190 |
-
+ ), |
|
| 887 | +191 | ! |
- parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(+ tags$br(), |
| 888 | +192 | ! |
- teal.widgets::resolve_ggplot2_args(+ teal.widgets::get_dt_rows(ns("variable_summary_table"), ns("variable_summary_table_rows")),
|
| 889 | +193 | ! |
- user_plot = ggplot2_args[["Residuals vs Leverage"]],+ DT::dataTableOutput(ns("variable_summary_table"))
|
| 890 | -! | +||
| 194 | +
- user_default = ggplot2_args$default,+ ) |
||
| 891 | -! | +||
| 195 | +
- module_plot = teal.widgets::ggplot2_args(+ ) |
||
| 892 | -! | +||
| 196 | +
- labs = list(+ ), |
||
| 893 | +197 | ! |
- x = quote(paste0("Standardized residuals\nlm(", reg_form, ")")),
+ pre_output = pre_output, |
| 894 | +198 | ! |
- y = "Leverage",+ post_output = post_output |
| 895 | -! | +||
| 199 | +
- title = "Residuals vs Leverage"+ ) |
||
| 896 | +200 |
- )+ ) |
|
| 897 | +201 |
- )+ } |
|
| 898 | +202 |
- ),+ |
|
| 899 | -! | +||
| 203 | +
- ggtheme = ggtheme+ # Server function for the variable browser module |
||
| 900 | +204 |
- )+ srv_variable_browser <- function(id, |
|
| 901 | +205 |
-
+ data, |
|
| 902 | -! | +||
| 206 | +
- teal.code::eval_code(+ reporter, |
||
| 903 | -! | +||
| 207 | +
- plot_base,+ filter_panel_api, |
||
| 904 | -! | +||
| 208 | +
- substitute(+ datasets_selected, parent_dataname, ggplot2_args) {
|
||
| 905 | +209 | ! |
- expr = {
+ with_reporter <- !missing(reporter) && inherits(reporter, "Reporter") |
| 906 | +210 | ! |
- smoothy <- smooth(data$.hat, data$.stdresid)+ with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI") |
| 907 | +211 | ! |
- g <- plot+ checkmate::assert_class(data, "reactive") |
| 908 | +212 | ! |
- print(g)- |
-
| 909 | -- |
- },+ checkmate::assert_class(isolate(data()), "teal_data") |
|
| 910 | +213 | ! |
- env = list(+ moduleServer(id, function(input, output, session) {
|
| 911 | +214 | ! |
- plot = Reduce(function(x, y) call("+", x, y), c(plot, parsed_ggplot2_args))
- |
-
| 912 | -- |
- )+ teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.general") |
|
| 913 | +215 |
- )+ |
|
| 914 | +216 |
- )+ # if there are < this number of unique records then a numeric |
|
| 915 | +217 |
- }+ # variable can be treated as a factor and all factors with < this groups |
|
| 916 | +218 |
-
+ # have their values plotted |
|
| 917 | +219 | ! |
- plot_type_6 <- function(plot_base) {
+ .unique_records_for_factor <- 30 |
| 918 | -! | +||
| 220 | +
- shinyjs::show("size")
+ # if there are < this number of unique records then a numeric |
||
| 919 | -! | +||
| 221 | +
- shinyjs::show("alpha")
+ # variable is by default treated as a factor |
||
| 920 | +222 | ! |
- plot <- substitute(+ .unique_records_default_as_factor <- 6 # nolint: object_length. |
| 921 | -! | +||
| 223 | +
- expr = ggplot(data = data, aes(.hat, .cooksd)) ++ |
||
| 922 | +224 | ! |
- geom_vline(xintercept = 0, colour = NA) ++ varname_numeric_as_factor <- reactiveValues() |
| 923 | -! | +||
| 225 | +
- geom_abline(+ |
||
| 924 | +226 | ! |
- slope = seq(0, 3, by = 0.5),+ datanames <- isolate(names(data())) |
| 925 | +227 | ! |
- colour = "black",+ datanames <- Filter(function(name) {
|
| 926 | +228 | ! |
- linetype = "dashed",+ is.data.frame(isolate(data())[[name]]) |
| 927 | +229 | ! |
- size = 1+ }, datanames) |
| 928 | +230 |
- ) ++ |
|
| 929 | +231 | ! |
- geom_line(data = smoothy, mapping = smoothy_aes) ++ checkmate::assert_character(datasets_selected) |
| 930 | +232 | ! |
- geom_point(size = size, alpha = alpha),+ checkmate::assert_subset(datasets_selected, datanames) |
| 931 | +233 | ! |
- env = list(size = size, alpha = alpha)- |
-
| 932 | -- |
- )+ if (!identical(datasets_selected, character(0))) {
|
|
| 933 | +234 | ! |
- if (show_outlier) {
+ checkmate::assert_subset(datasets_selected, datanames) |
| 934 | +235 | ! |
- plot <- substitute(expr = plot + outlier_label, env = list(plot = plot, outlier_label = outlier_label()))+ datanames <- datasets_selected |
| 935 | +236 |
- }+ } |
|
| 936 | +237 | ||
| 937 | +238 | ! |
- parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(+ output$ui_variable_browser <- renderUI({
|
| 938 | +239 | ! |
- teal.widgets::resolve_ggplot2_args(+ ns <- session$ns |
| 939 | +240 | ! |
- user_plot = ggplot2_args[["Cook's dist vs Leverage"]],+ do.call( |
| 940 | +241 | ! |
- user_default = ggplot2_args$default,+ tabsetPanel, |
| 941 | +242 | ! |
- module_plot = teal.widgets::ggplot2_args(+ c( |
| 942 | +243 | ! |
- labs = list(+ id = ns("tabset_panel"),
|
| 943 | +244 | ! |
- x = quote(paste0("Leverage\nlm(", reg_form, ")")),
+ do.call( |
| 944 | +245 | ! |
- y = "Cooks's distance",+ tagList, |
| 945 | +246 | ! |
- title = "Cook's dist vs Leverage"+ lapply(datanames, function(dataname) {
|
| 946 | -+ | ||
| 247 | +! |
- )+ tabPanel( |
|
| 947 | -+ | ||
| 248 | +! |
- )+ dataname, |
|
| 948 | -+ | ||
| 249 | +! |
- ),+ tags$div( |
|
| 949 | +250 | ! |
- ggtheme = ggtheme+ class = "mt-4", |
| 950 | -+ | ||
| 251 | +! |
- )+ textOutput(ns(paste0("dataset_summary_", dataname)))
|
|
| 951 | +252 |
-
+ ), |
|
| 952 | +253 | ! |
- teal.code::eval_code(+ tags$div( |
| 953 | +254 | ! |
- plot_base,+ class = "mt-4", |
| 954 | +255 | ! |
- substitute(+ teal.widgets::get_dt_rows( |
| 955 | +256 | ! |
- expr = {
+ ns(paste0("variable_browser_", dataname)),
|
| 956 | +257 | ! |
- smoothy <- smooth(data$.hat, data$.cooksd)+ ns(paste0("variable_browser_", dataname, "_rows"))
|
| 957 | -! | +||
| 258 | +
- g <- plot+ ), |
||
| 958 | +259 | ! |
- print(g)+ DT::dataTableOutput(ns(paste0("variable_browser_", dataname)), width = "100%")
|
| 959 | +260 |
- },- |
- |
| 960 | -! | -
- env = list(+ ) |
|
| 961 | -! | +||
| 261 | +
- plot = Reduce(function(x, y) call("+", x, y), c(plot, parsed_ggplot2_args))
+ ) |
||
| 962 | +262 |
- )+ }) |
|
| 963 | +263 |
) |
|
| 964 | +264 |
) |
|
| 965 | +265 |
- }+ ) |
|
| 966 | +266 | - - | -|
| 967 | -! | -
- qenv <- if (input_type == "Response vs Regressor") {
+ }) |
|
| 968 | -! | +||
| 267 | +
- plot_type_0()+ |
||
| 969 | +268 |
- } else {
+ # conditionally display checkbox |
|
| 970 | +269 | ! |
- plot_base_q <- plot_base()+ shinyjs::toggle( |
| 971 | +270 | ! |
- switch(input_type,+ id = "show_parent_vars", |
| 972 | +271 | ! |
- "Residuals vs Fitted" = plot_base_q %>% plot_type_1(),+ condition = length(parent_dataname) > 0 && parent_dataname %in% datanames |
| 973 | -! | +||
| 272 | +
- "Normal Q-Q" = plot_base_q %>% plot_type_2(),+ ) |
||
| 974 | -! | +||
| 273 | +
- "Scale-Location" = plot_base_q %>% plot_type_3(),+ |
||
| 975 | +274 | ! |
- "Cook's distance" = plot_base_q %>% plot_type_4(),+ columns_names <- new.env() |
| 976 | -! | +||
| 275 | +
- "Residuals vs Leverage" = plot_base_q %>% plot_type_5(),+ |
||
| 977 | -! | +||
| 276 | +
- "Cook's dist vs Leverage" = plot_base_q %>% plot_type_6()+ # plot_var$data holds the name of the currently selected dataset |
||
| 978 | +277 |
- )+ # plot_var$variable[[<dataset_name>]] holds the name of the currently selected |
|
| 979 | +278 |
- }+ # variable for dataset <dataset_name> |
|
| 980 | +279 | ! |
- qenv+ plot_var <- reactiveValues(data = NULL, variable = list()) |
| 981 | +280 |
- })+ |
|
| 982 | -+ | ||
| 281 | +! |
-
+ establish_updating_selection(datanames, input, plot_var, columns_names) |
|
| 983 | +282 | ||
| 984 | -! | +||
| 283 | +
- fitted <- reactive(output_q()[["fit"]])+ # validations |
||
| 985 | +284 | ! |
- plot_r <- reactive(output_q()[["g"]])+ validation_checks <- validate_input(input, plot_var, data) |
| 986 | +285 | ||
| 987 | +286 |
- # Insert the plot into a plot_with_settings module from teal.widgets- |
- |
| 988 | -! | -
- pws <- teal.widgets::plot_with_settings_srv(+ # data_for_analysis is a list with two elements: a column from a dataset and the column label |
|
| 989 | +287 | ! |
- id = "myplot",+ plotted_data <- reactive({
|
| 990 | +288 | ! |
- plot_r = plot_r,+ validation_checks() |
| 991 | -! | +||
| 289 | +
- height = plot_height,+ |
||
| 992 | +290 | ! |
- width = plot_width+ get_plotted_data(input, plot_var, data) |
| 993 | +291 |
- )+ }) |
|
| 994 | +292 | ||
| 995 | +293 | ! |
- output$text <- renderText({
+ treat_numeric_as_factor <- reactive({
|
| 996 | +294 | ! |
- req(iv_r()$is_valid())+ if (is_num_var_short(.unique_records_for_factor, input, plotted_data)) {
|
| 997 | +295 | ! |
- req(iv_out$is_valid())+ input$numeric_as_factor |
| 998 | -! | +||
| 296 | +
- paste(utils::capture.output(summary(teal.code::dev_suppress(fitted())))[-1],+ } else {
|
||
| 999 | +297 | ! |
- collapse = "\n"+ FALSE |
| 1000 | +298 |
- )+ } |
|
| 1001 | +299 |
}) |
|
| 1002 | +300 | ||
| 1003 | +301 | ! |
- teal.widgets::verbatim_popup_srv(+ render_tabset_panel_content( |
| 1004 | +302 | ! |
- id = "rcode",+ input = input, |
| 1005 | +303 | ! |
- verbatim_content = reactive(teal.code::get_code(output_q())),+ output = output, |
| 1006 | +304 | ! |
- title = "R code for the regression plot",+ data = data, |
| 1007 | -+ | ||
| 305 | +! |
- )+ datanames = datanames, |
|
| 1008 | -+ | ||
| 306 | +! |
-
+ parent_dataname = parent_dataname, |
|
| 1009 | -+ | ||
| 307 | +! |
- ### REPORTER+ columns_names = columns_names, |
|
| 1010 | +308 | ! |
- if (with_reporter) {
+ plot_var = plot_var |
| 1011 | -! | +||
| 309 | +
- card_fun <- function(comment, label) {
+ )+ |
+ ||
| 310 | ++ |
+ # add used-defined text size to ggplot arguments passed from caller frame |
|
| 1012 | +311 | ! |
- card <- teal::report_card_template(+ all_ggplot2_args <- reactive({
|
| 1013 | +312 | ! |
- title = "Linear Regression Plot",+ user_text <- teal.widgets::ggplot2_args( |
| 1014 | +313 | ! |
- label = label,+ theme = list( |
| 1015 | +314 | ! |
- with_filter = with_filter,+ "text" = ggplot2::element_text(size = input[["font_size"]]), |
| 1016 | +315 | ! |
- filter_panel_api = filter_panel_api+ "axis.text.x" = ggplot2::element_text(angle = input[["label_rotation"]], hjust = 1) |
| 1017 | +316 |
) |
|
| 1018 | -! | +||
| 317 | +
- card$append_text("Plot", "header3")
+ ) |
||
| 1019 | +318 | ! |
- card$append_plot(plot_r(), dim = pws$dim())+ user_theme <- utils::getFromNamespace(sprintf("theme_%s", input[["ggplot_theme"]]), ns = "ggplot2")
|
| 1020 | +319 | ! |
- if (!comment == "") {
+ user_theme <- user_theme() |
| 1021 | -! | +||
| 320 | +
- card$append_text("Comment", "header3")
+ # temporary fix to circumvent assertion issue with resolve_ggplot2_args+ |
+ ||
| 321 | ++ |
+ # drop problematic elements |
|
| 1022 | +322 | ! |
- card$append_text(comment)+ user_theme <- user_theme[grep("strip.text.y.left", names(user_theme), fixed = TRUE, invert = TRUE)]
|
| 1023 | +323 |
- }+ |
|
| 1024 | +324 | ! |
- card$append_src(teal.code::get_code(output_q()))+ teal.widgets::resolve_ggplot2_args( |
| 1025 | +325 | ! |
- card+ user_plot = user_text, |
| 1026 | -+ | ||
| 326 | +! |
- }+ user_default = teal.widgets::ggplot2_args(theme = user_theme), |
|
| 1027 | +327 | ! |
- teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
+ module_plot = ggplot2_args |
| 1028 | +328 |
- }+ ) |
|
| 1029 | +329 |
- ###+ }) |
|
| 1030 | +330 |
- })+ |
|
| 1031 | -+ | ||
| 331 | +! |
- }+ output$ui_numeric_display <- renderUI({
|
|
| 1032 | -+ | ||
| 332 | +! |
-
+ validation_checks() |
|
| 1033 | -+ | ||
| 333 | +! |
- regression_names <- paste0(+ dataname <- input$tabset_panel |
|
| 1034 | -+ | ||
| 334 | +! |
- '"Response vs Regressor", "Residuals vs Fitted", ',+ varname <- plot_var$variable[[dataname]] |
|
| 1035 | -+ | ||
| 335 | +! |
- '"Scale-Location", "Cook\'s distance", "Residuals vs Leverage"", "Cook\'s dist vs Leverage"'+ df <- data()[[dataname]] |
|
| 1036 | +336 |
- )+ |
| 1 | -+ | ||
| 337 | +! |
- #' `teal` module: Stack plots of variables and show association with reference variable+ numeric_ui <- tagList( |
|
| 2 | -+ | ||
| 338 | +! |
- #'+ fluidRow( |
|
| 3 | -+ | ||
| 339 | +! |
- #' Module provides functionality for visualizing the distribution of variables and+ tags$div( |
|
| 4 | -+ | ||
| 340 | +! |
- #' their association with a reference variable.+ class = "col-md-4", |
|
| 5 | -+ | ||
| 341 | +! |
- #' It supports configuring the appearance of the plots, including themes and whether to show associations.+ tags$br(), |
|
| 6 | -+ | ||
| 342 | +! |
- #'+ shinyWidgets::switchInput( |
|
| 7 | -+ | ||
| 343 | +! |
- #'+ inputId = session$ns("display_density"),
|
|
| 8 | -+ | ||
| 344 | +! |
- #' @note For more examples, please see the vignette "Using association plot" via+ label = "Show density", |
|
| 9 | -+ | ||
| 345 | +! |
- #' `vignette("using-association-plot", package = "teal.modules.general")`.
+ value = `if`(is.null(isolate(input$display_density)), TRUE, isolate(input$display_density)), |
|
| 10 | -+ | ||
| 346 | +! |
- #'+ width = "50%", |
|
| 11 | -+ | ||
| 347 | +! |
- #' @inheritParams teal::module+ labelWidth = "100px", |
|
| 12 | -+ | ||
| 348 | +! |
- #' @inheritParams shared_params+ handleWidth = "50px" |
|
| 13 | +349 |
- #' @param ref (`data_extract_spec` or `list` of multiple `data_extract_spec`)+ ) |
|
| 14 | +350 |
- #' Reference variable, must accepts a `data_extract_spec` with `select_spec(multiple = FALSE)`+ ), |
|
| 15 | -+ | ||
| 351 | +! |
- #' to ensure single selection option.+ tags$div( |
|
| 16 | -+ | ||
| 352 | +! |
- #' @param vars (`data_extract_spec` or `list` of multiple `data_extract_spec`)+ class = "col-md-4", |
|
| 17 | -+ | ||
| 353 | +! |
- #' Variables to be associated with the reference variable.+ tags$br(), |
|
| 18 | -+ | ||
| 354 | +! |
- #' @param show_association (`logical`) optional, whether show association of `vars`+ shinyWidgets::switchInput( |
|
| 19 | -+ | ||
| 355 | +! |
- #' with reference variable. Defaults to `TRUE`.+ inputId = session$ns("remove_outliers"),
|
|
| 20 | -+ | ||
| 356 | +! |
- #' @param distribution_theme,association_theme (`character`) optional, `ggplot2` themes to be used by default.+ label = "Remove outliers", |
|
| 21 | -+ | ||
| 357 | +! |
- #' Default to `"gray"`.+ value = `if`(is.null(isolate(input$remove_outliers)), FALSE, isolate(input$remove_outliers)), |
|
| 22 | -+ | ||
| 358 | +! |
- #'+ width = "50%", |
|
| 23 | -+ | ||
| 359 | +! |
- #' @templateVar ggnames "Bivariate1", "Bivariate2"+ labelWidth = "100px", |
|
| 24 | -+ | ||
| 360 | +! |
- #' @template ggplot2_args_multi+ handleWidth = "50px" |
|
| 25 | +361 |
- #'+ ) |
|
| 26 | +362 |
- #' @inherit shared_params return+ ), |
|
| 27 | -+ | ||
| 363 | +! |
- #'+ tags$div( |
|
| 28 | -+ | ||
| 364 | +! |
- #' @examplesShinylive+ class = "col-md-4", |
|
| 29 | -+ | ||
| 365 | +! |
- #' library(teal.modules.general)+ uiOutput(session$ns("outlier_definition_slider_ui"))
|
|
| 30 | +366 |
- #' interactive <- function() TRUE+ ) |
|
| 31 | +367 |
- #' {{ next_example }}
+ ), |
|
| 32 | -+ | ||
| 368 | +! |
- #' @examples+ tags$div( |
|
| 33 | -+ | ||
| 369 | +! |
- #' # general data example+ class = "ml-4", |
|
| 34 | -+ | ||
| 370 | +! |
- #' data <- teal_data()+ uiOutput(session$ns("ui_density_help")),
|
|
| 35 | -+ | ||
| 371 | +! |
- #' data <- within(data, {
+ uiOutput(session$ns("ui_outlier_help"))
|
|
| 36 | +372 |
- #' require(nestcolor)+ ) |
|
| 37 | +373 |
- #' CO2 <- CO2+ ) |
|
| 38 | +374 |
- #' factors <- names(Filter(isTRUE, vapply(CO2, is.factor, logical(1L))))+ |
|
| 39 | -+ | ||
| 375 | +! |
- #' CO2[factors] <- lapply(CO2[factors], as.character)+ observeEvent(input$numeric_as_factor, ignoreInit = TRUE, {
|
|
| 40 | -+ | ||
| 376 | +! |
- #' })+ varname_numeric_as_factor[[plot_var$variable[[dataname]]]] <- input$numeric_as_factor |
|
| 41 | +377 |
- #' datanames(data) <- c("CO2")
+ }) |
|
| 42 | +378 |
- #'+ |
|
| 43 | -+ | ||
| 379 | +! |
- #' app <- init(+ if (is.numeric(df[[varname]])) {
|
|
| 44 | -+ | ||
| 380 | +! |
- #' data = data,+ unique_entries <- length(unique(df[[varname]])) |
|
| 45 | -+ | ||
| 381 | +! |
- #' modules = modules(+ if (unique_entries < .unique_records_for_factor && unique_entries > 0) {
|
|
| 46 | -+ | ||
| 382 | +! |
- #' tm_g_association(+ list( |
|
| 47 | -+ | ||
| 383 | +! |
- #' ref = data_extract_spec(+ checkboxInput( |
|
| 48 | -+ | ||
| 384 | +! |
- #' dataname = "CO2",+ session$ns("numeric_as_factor"),
|
|
| 49 | -+ | ||
| 385 | +! |
- #' select = select_spec(+ "Treat variable as factor", |
|
| 50 | -+ | ||
| 386 | +! |
- #' label = "Select variable:",+ value = `if`( |
|
| 51 | -+ | ||
| 387 | +! |
- #' choices = variable_choices(data[["CO2"]], c("Plant", "Type", "Treatment")),
+ is.null(varname_numeric_as_factor[[varname]]), |
|
| 52 | -+ | ||
| 388 | +! |
- #' selected = "Plant",+ unique_entries < .unique_records_default_as_factor, |
|
| 53 | -+ | ||
| 389 | +! |
- #' fixed = FALSE+ varname_numeric_as_factor[[varname]] |
|
| 54 | +390 |
- #' )+ ) |
|
| 55 | +391 |
- #' ),+ ), |
|
| 56 | -+ | ||
| 392 | +! |
- #' vars = data_extract_spec(+ conditionalPanel("!input.numeric_as_factor", ns = session$ns, numeric_ui)
|
|
| 57 | +393 |
- #' dataname = "CO2",+ ) |
|
| 58 | -+ | ||
| 394 | +! |
- #' select = select_spec(+ } else if (unique_entries > 0) {
|
|
| 59 | -+ | ||
| 395 | +! |
- #' label = "Select variables:",+ numeric_ui |
|
| 60 | +396 |
- #' choices = variable_choices(data[["CO2"]], c("Plant", "Type", "Treatment")),
+ } |
|
| 61 | +397 |
- #' selected = "Treatment",+ } else {
|
|
| 62 | -+ | ||
| 398 | +! |
- #' multiple = TRUE,+ NULL |
|
| 63 | +399 |
- #' fixed = FALSE+ } |
|
| 64 | +400 |
- #' )+ }) |
|
| 65 | +401 |
- #' )+ |
|
| 66 | -+ | ||
| 402 | +! |
- #' )+ output$ui_histogram_display <- renderUI({
|
|
| 67 | -+ | ||
| 403 | +! |
- #' )+ validation_checks() |
|
| 68 | -+ | ||
| 404 | +! |
- #' )+ dataname <- input$tabset_panel |
|
| 69 | -+ | ||
| 405 | +! |
- #' if (interactive()) {
+ varname <- plot_var$variable[[dataname]] |
|
| 70 | -+ | ||
| 406 | +! |
- #' shinyApp(app$ui, app$server)+ df <- data()[[dataname]] |
|
| 71 | +407 |
- #' }+ |
|
| 72 | -+ | ||
| 408 | +! |
- #'+ numeric_ui <- tagList(fluidRow( |
|
| 73 | -+ | ||
| 409 | +! |
- #' @examplesShinylive+ tags$div( |
|
| 74 | -+ | ||
| 410 | +! |
- #' library(teal.modules.general)+ class = "col-md-4", |
|
| 75 | -+ | ||
| 411 | +! |
- #' interactive <- function() TRUE+ shinyWidgets::switchInput( |
|
| 76 | -+ | ||
| 412 | +! |
- #' {{ next_example }}
+ inputId = session$ns("remove_NA_hist"),
|
|
| 77 | -+ | ||
| 413 | +! |
- #' @examples+ label = "Remove NA values", |
|
| 78 | -+ | ||
| 414 | +! |
- #' # CDISC data example+ value = FALSE, |
|
| 79 | -+ | ||
| 415 | +! |
- #' data <- teal_data()+ width = "50%", |
|
| 80 | -+ | ||
| 416 | +! |
- #' data <- within(data, {
+ labelWidth = "100px", |
|
| 81 | -+ | ||
| 417 | +! |
- #' require(nestcolor)+ handleWidth = "50px" |
|
| 82 | +418 |
- #' ADSL <- rADSL+ ) |
|
| 83 | +419 |
- #' })+ ) |
|
| 84 | +420 |
- #' datanames(data) <- "ADSL"+ )) |
|
| 85 | +421 |
- #' join_keys(data) <- default_cdisc_join_keys[datanames(data)]+ |
|
| 86 | -+ | ||
| 422 | +! |
- #'+ var <- df[[varname]] |
|
| 87 | -+ | ||
| 423 | +! |
- #' app <- init(+ if (anyNA(var) && (is.factor(var) || is.character(var) || is.logical(var))) {
|
|
| 88 | -+ | ||
| 424 | +! |
- #' data = data,+ groups <- unique(as.character(var)) |
|
| 89 | -+ | ||
| 425 | +! |
- #' modules = modules(+ len_groups <- length(groups) |
|
| 90 | -+ | ||
| 426 | +! |
- #' tm_g_association(+ if (len_groups >= .unique_records_for_factor) {
|
|
| 91 | -+ | ||
| 427 | +! |
- #' ref = data_extract_spec(+ NULL |
|
| 92 | +428 |
- #' dataname = "ADSL",+ } else {
|
|
| 93 | -+ | ||
| 429 | +! |
- #' select = select_spec(+ numeric_ui |
|
| 94 | +430 |
- #' label = "Select variable:",+ } |
|
| 95 | +431 |
- #' choices = variable_choices(+ } else {
|
|
| 96 | -+ | ||
| 432 | +! |
- #' data[["ADSL"]],+ NULL |
|
| 97 | +433 |
- #' c("SEX", "RACE", "COUNTRY", "ARM", "STRATA1", "STRATA2", "ITTFL", "BMRKR2")
+ } |
|
| 98 | +434 |
- #' ),+ }) |
|
| 99 | +435 |
- #' selected = "RACE",+ |
|
| 100 | -+ | ||
| 436 | +! |
- #' fixed = FALSE+ output$outlier_definition_slider_ui <- renderUI({
|
|
| 101 | -+ | ||
| 437 | +! |
- #' )+ req(input$remove_outliers) |
|
| 102 | -+ | ||
| 438 | +! |
- #' ),+ sliderInput( |
|
| 103 | -+ | ||
| 439 | +! |
- #' vars = data_extract_spec(+ inputId = session$ns("outlier_definition_slider"),
|
|
| 104 | -+ | ||
| 440 | +! |
- #' dataname = "ADSL",+ tags$div( |
|
| 105 | -+ | ||
| 441 | +! |
- #' select = select_spec(+ class = "teal-tooltip", |
|
| 106 | -+ | ||
| 442 | +! |
- #' label = "Select variables:",+ tagList( |
|
| 107 | -+ | ||
| 443 | +! |
- #' choices = variable_choices(+ "Outlier definition:", |
|
| 108 | -+ | ||
| 444 | +! |
- #' data[["ADSL"]],+ icon("circle-info"),
|
|
| 109 | -+ | ||
| 445 | +! |
- #' c("SEX", "RACE", "COUNTRY", "ARM", "STRATA1", "STRATA2", "ITTFL", "BMRKR2")
+ tags$span( |
|
| 110 | -+ | ||
| 446 | +! |
- #' ),+ class = "tooltiptext", |
|
| 111 | -+ | ||
| 447 | +! |
- #' selected = "BMRKR2",+ paste( |
|
| 112 | -+ | ||
| 448 | +! |
- #' multiple = TRUE,+ "Use the slider to choose the cut-off value to define outliers; the larger the value the", |
|
| 113 | -+ | ||
| 449 | +! |
- #' fixed = FALSE+ "further below Q1/above Q3 points have to be in order to be classed as outliers" |
|
| 114 | +450 |
- #' )+ ) |
|
| 115 | +451 |
- #' )+ ) |
|
| 116 | +452 |
- #' )+ ) |
|
| 117 | +453 |
- #' )+ ), |
|
| 118 | -+ | ||
| 454 | +! |
- #' )+ min = 1, |
|
| 119 | -+ | ||
| 455 | +! |
- #' if (interactive()) {
+ max = 5, |
|
| 120 | -+ | ||
| 456 | +! |
- #' shinyApp(app$ui, app$server)+ value = 3, |
|
| 121 | -+ | ||
| 457 | +! |
- #' }+ step = 0.5 |
|
| 122 | +458 |
- #'+ ) |
|
| 123 | +459 |
- #' @export+ }) |
|
| 124 | +460 |
- #'+ |
|
| 125 | -+ | ||
| 461 | +! |
- tm_g_association <- function(label = "Association",+ output$ui_density_help <- renderUI({
|
|
| 126 | -+ | ||
| 462 | +! |
- ref,+ req(is.logical(input$display_density)) |
|
| 127 | -+ | ||
| 463 | +! |
- vars,+ if (input$display_density) {
|
|
| 128 | -+ | ||
| 464 | +! |
- show_association = TRUE,+ tags$small(helpText(paste( |
|
| 129 | -+ | ||
| 465 | +! |
- plot_height = c(600, 400, 5000),+ "Kernel density estimation with gaussian kernel", |
|
| 130 | -+ | ||
| 466 | +! |
- plot_width = NULL,+ "and bandwidth function bw.nrd0 (R default)" |
|
| 131 | +467 |
- distribution_theme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void"), # nolint: line_length.
+ ))) |
|
| 132 | +468 |
- association_theme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void"), # nolint: line_length.
+ } else {
|
|
| 133 | -+ | ||
| 469 | +! |
- pre_output = NULL,+ NULL |
|
| 134 | +470 |
- post_output = NULL,+ } |
|
| 135 | +471 |
- ggplot2_args = teal.widgets::ggplot2_args()) {
- |
- |
| 136 | -! | -
- message("Initializing tm_g_association")
+ }) |
|
| 137 | +472 | ||
| 138 | -+ | ||
| 473 | +! |
- # Normalize the parameters+ output$ui_outlier_help <- renderUI({
|
|
| 139 | +474 | ! |
- if (inherits(ref, "data_extract_spec")) ref <- list(ref)+ req(is.logical(input$remove_outliers), input$outlier_definition_slider) |
| 140 | +475 | ! |
- if (inherits(vars, "data_extract_spec")) vars <- list(vars)+ if (input$remove_outliers) {
|
| 141 | +476 | ! |
- if (inherits(ggplot2_args, "ggplot2_args")) ggplot2_args <- list(default = ggplot2_args)+ tags$small( |
| 142 | -+ | ||
| 477 | +! |
-
+ helpText( |
|
| 143 | -+ | ||
| 478 | +! |
- # Start of assertions+ withMathJax(paste0( |
|
| 144 | +479 | ! |
- checkmate::assert_string(label)+ "Outlier data points (\\( X \\lt Q1 - ", input$outlier_definition_slider, "\\times IQR \\) or |
| 145 | -+ | ||
| 480 | +! |
-
+ \\(Q3 + ", input$outlier_definition_slider, "\\times IQR \\lt X\\)) |
|
| 146 | +481 | ! |
- checkmate::assert_list(ref, types = "data_extract_spec")+ have not been displayed on the graph and will not be used for any kernel density estimations, ", |
| 147 | +482 | ! |
- if (!all(vapply(ref, function(x) !x$select$multiple, logical(1)))) {
+ "although their values remain in the statisics table below." |
| 148 | -! | +||
| 483 | +
- stop("'ref' should not allow multiple selection")
+ )) |
||
| 149 | +484 |
- }+ ) |
|
| 150 | +485 |
-
+ ) |
|
| 151 | -! | +||
| 486 | +
- checkmate::assert_list(vars, types = "data_extract_spec")+ } else {
|
||
| 152 | +487 | ! |
- checkmate::assert_flag(show_association)+ NULL |
| 153 | +488 |
-
+ } |
|
| 154 | -! | +||
| 489 | +
- checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE)+ }) |
||
| 155 | -! | +||
| 490 | +
- checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height")+ |
||
| 156 | -! | +||
| 491 | +
- checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE)+ |
||
| 157 | +492 | ! |
- checkmate::assert_numeric(+ variable_plot_r <- reactive({
|
| 158 | +493 | ! |
- plot_width[1],+ display_density <- `if`(is.null(input$display_density), FALSE, input$display_density) |
| 159 | +494 | ! |
- lower = plot_width[2], upper = plot_width[3], null.ok = TRUE, .var.name = "plot_width"+ remove_outliers <- `if`(is.null(input$remove_outliers), FALSE, input$remove_outliers) |
| 160 | +495 |
- )+ |
|
| 161 | -+ | ||
| 496 | +! |
-
+ if (remove_outliers) {
|
|
| 162 | +497 | ! |
- distribution_theme <- match.arg(distribution_theme)+ req(input$outlier_definition_slider) |
| 163 | +498 | ! |
- association_theme <- match.arg(association_theme)+ outlier_definition <- as.numeric(input$outlier_definition_slider) |
| 164 | +499 |
-
+ } else {
|
|
| 165 | +500 | ! |
- checkmate::assert_multi_class(pre_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
+ outlier_definition <- 0 |
| 166 | -! | +||
| 501 | +
- checkmate::assert_multi_class(post_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
+ } |
||
| 167 | +502 | ||
| 168 | +503 | ! |
- plot_choices <- c("Bivariate1", "Bivariate2")
+ plot_var_summary( |
| 169 | +504 | ! |
- checkmate::assert_list(ggplot2_args, types = "ggplot2_args")+ var = plotted_data()$data, |
| 170 | +505 | ! |
- checkmate::assert_subset(names(ggplot2_args), c("default", plot_choices))
+ var_lab = plotted_data()$var_description, |
| 171 | -+ | ||
| 506 | +! |
- # End of assertions+ wrap_character = 15, |
|
| 172 | -+ | ||
| 507 | +! |
-
+ numeric_as_factor = treat_numeric_as_factor(), |
|
| 173 | -+ | ||
| 508 | +! |
- # Make UI args+ remove_NA_hist = input$remove_NA_hist, |
|
| 174 | +509 | ! |
- args <- as.list(environment())+ display_density = display_density, |
| 175 | -+ | ||
| 510 | +! |
-
+ outlier_definition = outlier_definition, |
|
| 176 | +511 | ! |
- data_extract_list <- list(+ records_for_factor = .unique_records_for_factor, |
| 177 | +512 | ! |
- ref = ref,+ ggplot2_args = all_ggplot2_args() |
| 178 | -! | +||
| 513 | +
- vars = vars+ ) |
||
| 179 | +514 |
- )+ }) |
|
| 180 | +515 | ||
| 181 | +516 | ! |
- ans <- module(+ pws <- teal.widgets::plot_with_settings_srv( |
| 182 | +517 | ! |
- label = label,+ id = "variable_plot", |
| 183 | +518 | ! |
- server = srv_tm_g_association,+ plot_r = variable_plot_r, |
| 184 | +519 | ! |
- ui = ui_tm_g_association,+ height = c(500, 200, 2000)+ |
+
| 520 | ++ |
+ )+ |
+ |
| 521 | ++ | + | |
| 185 | +522 | ! |
- ui_args = args,+ output$variable_summary_table <- DT::renderDataTable({
|
| 186 | +523 | ! |
- server_args = c(+ var_summary_table( |
| 187 | +524 | ! |
- data_extract_list,+ plotted_data()$data, |
| 188 | +525 | ! |
- list(plot_height = plot_height, plot_width = plot_width, ggplot2_args = ggplot2_args)+ treat_numeric_as_factor(), |
| 189 | -+ | ||
| 526 | +! |
- ),+ input$variable_summary_table_rows, |
|
| 190 | +527 | ! |
- datanames = teal.transform::get_extract_datanames(data_extract_list)+ if (!is.null(input$remove_outliers) && input$remove_outliers) {
|
| 191 | -+ | ||
| 528 | +! |
- )+ req(input$outlier_definition_slider) |
|
| 192 | +529 | ! |
- attr(ans, "teal_bookmarkable") <- TRUE+ as.numeric(input$outlier_definition_slider)+ |
+
| 530 | ++ |
+ } else {
|
|
| 193 | +531 | ! |
- ans+ 0 |
| 194 | +532 |
- }+ } |
|
| 195 | +533 |
-
+ ) |
|
| 196 | +534 |
- # UI function for the association module+ }) |
|
| 197 | +535 |
- ui_tm_g_association <- function(id, ...) {
+
+ |
+ |
| 536 | ++ |
+ ### REPORTER |
|
| 198 | +537 | ! |
- ns <- NS(id)+ if (with_reporter) {
|
| 199 | +538 | ! |
- args <- list(...)+ card_fun <- function(comment) {
|
| 200 | +539 | ! |
- is_single_dataset_value <- teal.transform::is_single_dataset(args$ref, args$vars)+ card <- teal::TealReportCard$new() |
| 201 | -+ | ||
| 540 | +! |
-
+ card$set_name("Variable Browser Plot")
|
|
| 202 | +541 | ! |
- teal.widgets::standard_layout(+ card$append_text("Variable Browser Plot", "header2")
|
| 203 | +542 | ! |
- output = teal.widgets::white_small_well(+ if (with_filter) card$append_fs(filter_panel_api$get_filter_state()) |
| 204 | +543 | ! |
- textOutput(ns("title")),
+ card$append_text("Plot", "header3")
|
| 205 | +544 | ! |
- tags$br(),+ card$append_plot(variable_plot_r(), dim = pws$dim()) |
| 206 | +545 | ! |
- teal.widgets::plot_with_settings_ui(id = ns("myplot"))
+ if (!comment == "") {
|
| 207 | -+ | ||
| 546 | +! |
- ),+ card$append_text("Comment", "header3")
|
|
| 208 | +547 | ! |
- encoding = tags$div(+ card$append_text(comment) |
| 209 | +548 |
- ### Reporter+ } |
|
| 210 | +549 | ! |
- teal.reporter::simple_reporter_ui(ns("simple_reporter")),
+ card |
| 211 | +550 |
- ###+ } |
|
| 212 | +551 | ! |
- tags$label("Encodings", class = "text-primary"),
+ teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
|
| 213 | -! | +||
| 552 | +
- teal.transform::datanames_input(args[c("ref", "vars")]),
+ } |
||
| 214 | -! | +||
| 553 | +
- teal.transform::data_extract_ui(+ ### |
||
| 215 | -! | +||
| 554 | +
- id = ns("ref"),
+ }) |
||
| 216 | -! | +||
| 555 | +
- label = "Reference variable",+ } |
||
| 217 | -! | +||
| 556 | +
- data_extract_spec = args$ref,+ |
||
| 218 | -! | +||
| 557 | +
- is_single_dataset = is_single_dataset_value+ #' Summarize NAs. |
||
| 219 | +558 |
- ),+ #' |
|
| 220 | -! | +||
| 559 | +
- teal.transform::data_extract_ui(+ #' Summarizes occurrence of missing values in vector. |
||
| 221 | -! | +||
| 560 | +
- id = ns("vars"),
+ #' @param x vector of any type and length |
||
| 222 | -! | +||
| 561 | +
- label = "Associated variables",+ #' @return Character string describing `NA` occurrence. |
||
| 223 | -! | +||
| 562 | +
- data_extract_spec = args$vars,+ #' @keywords internal+ |
+ ||
| 563 | ++ |
+ var_missings_info <- function(x) {
|
|
| 224 | +564 | ! |
- is_single_dataset = is_single_dataset_value+ sprintf("%s [%s%%]", sum(is.na(x)), round(mean(is.na(x) * 100), 2))
|
| 225 | +565 |
- ),+ } |
|
| 226 | -! | +||
| 566 | +
- checkboxInput(+ |
||
| 227 | -! | +||
| 567 | +
- ns("association"),
+ #' Summarizes variable |
||
| 228 | -! | +||
| 568 | +
- "Association with reference variable",+ #' |
||
| 229 | -! | +||
| 569 | +
- value = args$show_association+ #' Creates html summary with statistics relevant to data type. For numeric values it returns central |
||
| 230 | +570 |
- ),+ #' tendency measures, for factor returns level counts, for Date date range, for other just |
|
| 231 | -! | +||
| 571 | +
- checkboxInput(+ #' number of levels. |
||
| 232 | -! | +||
| 572 | +
- ns("show_dist"),
+ #' |
||
| 233 | -! | +||
| 573 | +
- "Scaled frequencies",+ #' @param x vector of any type |
||
| 234 | -! | +||
| 574 | +
- value = FALSE+ #' @param numeric_as_factor `logical` should the numeric variable be treated as a factor |
||
| 235 | +575 |
- ),+ #' @param dt_rows `numeric` current/latest `DT` page length |
|
| 236 | -! | +||
| 576 | +
- checkboxInput(+ #' @param outlier_definition If 0 no outliers are removed, otherwise |
||
| 237 | -! | +||
| 577 | +
- ns("log_transformation"),
+ #' outliers (those more than `outlier_definition*IQR below/above Q1/Q3` be removed) |
||
| 238 | -! | +||
| 578 | +
- "Log transformed",+ #' @return text with simple statistics. |
||
| 239 | -! | +||
| 579 | +
- value = FALSE+ #' @keywords internal |
||
| 240 | +580 |
- ),+ var_summary_table <- function(x, numeric_as_factor, dt_rows, outlier_definition) {
|
|
| 241 | +581 | ! |
- teal.widgets::panel_group(+ if (is.null(dt_rows)) {
|
| 242 | +582 | ! |
- teal.widgets::panel_item(+ dt_rows <- 10 |
| 243 | -! | +||
| 583 | +
- title = "Plot settings",+ } |
||
| 244 | +584 | ! |
- teal.widgets::optionalSliderInputValMinMax(ns("alpha"), "Scatterplot opacity:", c(0.5, 0, 1), ticks = FALSE),
+ if (is.numeric(x) && !numeric_as_factor) {
|
| 245 | +585 | ! |
- teal.widgets::optionalSliderInputValMinMax(ns("size"), "Scatterplot points size:", c(2, 1, 8), ticks = FALSE),
+ req(!any(is.infinite(x))) |
| 246 | -! | +||
| 586 | +
- checkboxInput(ns("swap_axes"), "Swap axes", value = FALSE),
+
|
||
| 247 | +587 | ! |
- checkboxInput(ns("rotate_xaxis_labels"), "Rotate X axis labels", value = FALSE),
+ x <- remove_outliers_from(x, outlier_definition) |
| 248 | -! | +||
| 588 | +
- selectInput(+ |
||
| 249 | +589 | ! |
- inputId = ns("distribution_theme"),
+ qvals <- round(stats::quantile(x, na.rm = TRUE, probs = c(0.25, 0.5, 0.75), type = 2), 2)+ |
+
| 590 | ++ |
+ # classical central tendency measures+ |
+ |
| 591 | ++ | + | |
| 250 | +592 | ! |
- label = "Distribution theme (by ggplot):",+ summary <- |
| 251 | +593 | ! |
- choices = ggplot_themes,+ data.frame( |
| 252 | +594 | ! |
- selected = args$distribution_theme,+ Statistic = c("min", "Q1", "median", "mean", "Q3", "max", "sd", "n"),
|
| 253 | +595 | ! |
- multiple = FALSE+ Value = c( |
| 254 | -+ | ||
| 596 | +! |
- ),+ round(min(x, na.rm = TRUE), 2), |
|
| 255 | +597 | ! |
- selectInput(+ qvals[1], |
| 256 | +598 | ! |
- inputId = ns("association_theme"),
+ qvals[2], |
| 257 | +599 | ! |
- label = "Association theme (by ggplot):",+ round(mean(x, na.rm = TRUE), 2), |
| 258 | +600 | ! |
- choices = ggplot_themes,+ qvals[3], |
| 259 | +601 | ! |
- selected = args$association_theme,+ round(max(x, na.rm = TRUE), 2), |
| 260 | +602 | ! |
- multiple = FALSE+ round(stats::sd(x, na.rm = TRUE), 2), |
| 261 | -+ | ||
| 603 | +! |
- )+ length(x[!is.na(x)]) |
|
| 262 | +604 |
) |
|
| 263 | +605 |
) |
|
| 264 | +606 |
- ),+ |
|
| 265 | +607 | ! |
- forms = tagList(+ DT::datatable(summary, rownames = FALSE, options = list(dom = "<t>", pageLength = dt_rows)) |
| 266 | +608 | ! |
- teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code")
+ } else if (is.factor(x) || is.character(x) || (is.numeric(x) && numeric_as_factor) || is.logical(x)) {
|
| 267 | +609 |
- ),+ # make sure factor is ordered numeric |
|
| 268 | +610 | ! |
- pre_output = args$pre_output,+ if (is.numeric(x)) {
|
| 269 | +611 | ! |
- post_output = args$post_output+ x <- factor(x, levels = sort(unique(x))) |
| 270 | +612 |
- )+ } |
|
| 271 | +613 |
- }+ + |
+ |
| 614 | +! | +
+ level_counts <- table(x)+ |
+ |
| 615 | +! | +
+ max_levels_signif <- nchar(level_counts) |
|
| 272 | +616 | ||
| 273 | -+ | ||
| 617 | +! |
- # Server function for the association module+ if (!all(is.na(x))) {
|
|
| 274 | -+ | ||
| 618 | +! |
- srv_tm_g_association <- function(id,+ levels <- names(level_counts) |
|
| 275 | -+ | ||
| 619 | +! |
- data,+ counts <- sprintf( |
|
| 276 | -+ | ||
| 620 | +! |
- reporter,+ "%s [%.2f%%]", |
|
| 277 | -+ | ||
| 621 | +! |
- filter_panel_api,+ format(level_counts, width = max_levels_signif), prop.table(level_counts) * 100 |
|
| 278 | +622 |
- ref,+ ) |
|
| 279 | +623 |
- vars,+ } else {
|
|
| 280 | -+ | ||
| 624 | +! |
- plot_height,+ levels <- character(0)+ |
+ |
| 625 | +! | +
+ counts <- numeric(0) |
|
| 281 | +626 |
- plot_width,+ } |
|
| 282 | +627 |
- ggplot2_args) {
+
|
|
| 283 | +628 | ! |
- with_reporter <- !missing(reporter) && inherits(reporter, "Reporter")+ summary <- data.frame( |
| 284 | +629 | ! |
- with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI")+ Level = levels, |
| 285 | +630 | ! |
- checkmate::assert_class(data, "reactive")+ Count = counts, |
| 286 | +631 | ! |
- checkmate::assert_class(isolate(data()), "teal_data")+ stringsAsFactors = FALSE |
| 287 | +632 | ++ |
+ )+ |
+
| 633 | |||
| 288 | -! | +||
| 634 | +
- moduleServer(id, function(input, output, session) {
+ # sort the dataset in decreasing order of counts (needed as character variables default to alphabetical) |
||
| 289 | +635 | ! |
- teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.general")+ summary <- summary[order(summary$Count, decreasing = TRUE), ] |
| 290 | +636 | ||
| 291 | +637 | ! |
- selector_list <- teal.transform::data_extract_multiple_srv(+ dom_opts <- if (nrow(summary) <= 10) {
|
| 292 | +638 | ! |
- data_extract = list(ref = ref, vars = vars),+ "<t>" |
| 293 | -! | +||
| 639 | +
- datasets = data,+ } else {
|
||
| 294 | +640 | ! |
- select_validation_rule = list(+ "<lf<t>ip>" |
| 295 | -! | +||
| 641 | +
- ref = shinyvalidate::compose_rules(+ } |
||
| 296 | +642 | ! |
- shinyvalidate::sv_required("A reference variable needs to be selected."),
+ DT::datatable(summary, rownames = FALSE, options = list(dom = dom_opts, pageLength = dt_rows)) |
| 297 | +643 | ! |
- ~ if ((.) %in% selector_list()$vars()$select) {
+ } else if (inherits(x, "Date") || inherits(x, "POSIXct") || inherits(x, "POSIXlt")) {
|
| 298 | +644 | ! |
- "Associated variables and reference variable cannot overlap"- |
-
| 299 | -- |
- }+ summary <- |
|
| 300 | -+ | ||
| 645 | +! |
- ),+ data.frame( |
|
| 301 | +646 | ! |
- vars = shinyvalidate::compose_rules(+ Statistic = c("min", "median", "max"),
|
| 302 | +647 | ! |
- shinyvalidate::sv_required("An associated variable needs to be selected."),
+ Value = c( |
| 303 | +648 | ! |
- ~ if (length(selector_list()$ref()$select) != 0 && selector_list()$ref()$select %in% (.)) {
+ min(x, na.rm = TRUE), |
| 304 | +649 | ! |
- "Associated variables and reference variable cannot overlap"+ stats::median(x, na.rm = TRUE), |
| 305 | -+ | ||
| 650 | +! |
- }+ max(x, na.rm = TRUE) |
|
| 306 | +651 |
) |
|
| 307 | +652 |
) |
|
| 308 | -+ | ||
| 653 | +! |
- )+ DT::datatable(summary, rownames = FALSE, options = list(dom = "<t>", pageLength = dt_rows)) |
|
| 309 | +654 | - - | -|
| 310 | -! | -
- iv_r <- reactive({
+ } else {
|
|
| 311 | +655 | ! |
- iv <- shinyvalidate::InputValidator$new()+ NULL |
| 312 | -! | +||
| 656 | +
- teal.transform::compose_and_enable_validators(iv, selector_list)+ } |
||
| 313 | +657 |
- })+ } |
|
| 314 | +658 | ||
| 315 | -! | +||
| 659 | +
- anl_merged_input <- teal.transform::merge_expression_srv(+ #' Plot variable |
||
| 316 | -! | +||
| 660 | +
- datasets = data,+ #' |
||
| 317 | -! | +||
| 661 | +
- selector_list = selector_list+ #' Creates summary plot with statistics relevant to data type. |
||
| 318 | +662 |
- )+ #' |
|
| 319 | +663 |
-
+ #' @inheritParams shared_params |
|
| 320 | -! | +||
| 664 | +
- anl_merged_q <- reactive({
+ #' @param var vector of any type to be plotted. For numeric variables it produces histogram with |
||
| 321 | -! | +||
| 665 | +
- req(anl_merged_input())+ #' density line, for factors it creates frequency plot |
||
| 322 | -! | +||
| 666 | +
- data() %>% teal.code::eval_code(as.expression(anl_merged_input()$expr))+ #' @param var_lab text describing selected variable to be displayed on the plot |
||
| 323 | +667 |
- })+ #' @param wrap_character (`numeric`) number of characters at which to wrap text values of `var` |
|
| 324 | +668 |
-
+ #' @param numeric_as_factor (`logical`) should the numeric variable be treated as a factor |
|
| 325 | -! | +||
| 669 | +
- merged <- list(+ #' @param display_density (`logical`) should density estimation be displayed for numeric values |
||
| 326 | -! | +||
| 670 | +
- anl_input_r = anl_merged_input,+ #' @param remove_NA_hist (`logical`) should `NA` values be removed for histogram of factor like variables |
||
| 327 | -! | +||
| 671 | +
- anl_q_r = anl_merged_q+ #' @param outlier_definition if 0 no outliers are removed, otherwise |
||
| 328 | +672 |
- )+ #' outliers (those more than outlier_definition*IQR below/above Q1/Q3 be removed) |
|
| 329 | +673 |
-
+ #' @param records_for_factor (`numeric`) if the number of factor levels is >= than this value then |
|
| 330 | -! | +||
| 674 | +
- output_q <- reactive({
+ #' a graph of the factors isn't shown, only a list of values |
||
| 331 | -! | +||
| 675 | +
- teal::validate_inputs(iv_r())+ #' |
||
| 332 | +676 |
-
+ #' @return plot |
|
| 333 | -! | +||
| 677 | +
- ANL <- merged$anl_q_r()[["ANL"]]+ #' @keywords internal |
||
| 334 | -! | +||
| 678 | +
- teal::validate_has_data(ANL, 3)+ plot_var_summary <- function(var, |
||
| 335 | +679 |
-
+ var_lab, |
|
| 336 | -! | +||
| 680 | +
- vars_names <- merged$anl_input_r()$columns_source$vars+ wrap_character = NULL, |
||
| 337 | +681 |
-
+ numeric_as_factor, |
|
| 338 | -! | +||
| 682 | +
- ref_name <- as.vector(merged$anl_input_r()$columns_source$ref)+ display_density = is.numeric(var), |
||
| 339 | -! | +||
| 683 | +
- association <- input$association+ remove_NA_hist = FALSE, # nolint: object_name. |
||
| 340 | -! | +||
| 684 | +
- show_dist <- input$show_dist+ outlier_definition, |
||
| 341 | -! | +||
| 685 | +
- log_transformation <- input$log_transformation+ records_for_factor, |
||
| 342 | -! | +||
| 686 | +
- rotate_xaxis_labels <- input$rotate_xaxis_labels+ ggplot2_args) {
|
||
| 343 | +687 | ! |
- swap_axes <- input$swap_axes+ checkmate::assert_character(var_lab) |
| 344 | +688 | ! |
- distribution_theme <- input$distribution_theme+ checkmate::assert_numeric(wrap_character, null.ok = TRUE) |
| 345 | +689 | ! |
- association_theme <- input$association_theme+ checkmate::assert_flag(numeric_as_factor) |
| 346 | -+ | ||
| 690 | +! |
-
+ checkmate::assert_flag(display_density) |
|
| 347 | +691 | ! |
- is_scatterplot <- is.numeric(ANL[[ref_name]]) && any(vapply(ANL[vars_names], is.numeric, logical(1)))+ checkmate::assert_logical(remove_NA_hist, null.ok = TRUE) |
| 348 | +692 | ! |
- if (is_scatterplot) {
+ checkmate::assert_number(outlier_definition, lower = 0, finite = TRUE) |
| 349 | +693 | ! |
- shinyjs::show("alpha")
+ checkmate::assert_integerish(records_for_factor, lower = 0, len = 1, any.missing = FALSE) |
| 350 | +694 | ! |
- shinyjs::show("size")
+ checkmate::assert_class(ggplot2_args, "ggplot2_args") |
| 351 | -! | +||
| 695 | +
- alpha <- input$alpha+ |
||
| 352 | +696 | ! |
- size <- input$size+ grid::grid.newpage() |
| 353 | +697 |
- } else {
+
|
|
| 354 | +698 | ! |
- shinyjs::hide("alpha")
+ plot_main <- if (is.factor(var) || is.character(var) || is.logical(var)) {
|
| 355 | +699 | ! |
- shinyjs::hide("size")
+ groups <- unique(as.character(var)) |
| 356 | +700 | ! |
- alpha <- 0.5+ len_groups <- length(groups) |
| 357 | +701 | ! |
- size <- 2+ if (len_groups >= records_for_factor) {
|
| 358 | -+ | ||
| 702 | +! |
- }+ grid::textGrob( |
|
| 359 | -+ | ||
| 703 | +! |
-
+ sprintf( |
|
| 360 | +704 | ! |
- teal::validate_has_data(ANL[, c(ref_name, vars_names)], 3, complete = TRUE, allow_inf = FALSE)+ "%s unique values\n%s:\n %s\n ...\n %s", |
| 361 | -+ | ||
| 705 | +! |
-
+ len_groups, |
|
| 362 | -+ | ||
| 706 | +! |
- # reference+ var_lab, |
|
| 363 | +707 | ! |
- ref_class <- class(ANL[[ref_name]])[1]+ paste(utils::head(groups), collapse = ",\n "), |
| 364 | +708 | ! |
- if (is.numeric(ANL[[ref_name]]) && log_transformation) {
+ paste(utils::tail(groups), collapse = ",\n ") |
| 365 | +709 |
- # works for both integers and doubles+ ), |
|
| 366 | +710 | ! |
- ref_cl_name <- call("log", as.name(ref_name))
+ x = grid::unit(1, "line"), |
| 367 | +711 | ! |
- ref_cl_lbl <- varname_w_label(ref_name, ANL, prefix = "Log of ")+ y = grid::unit(1, "npc") - grid::unit(1, "line"), |
| 368 | -+ | ||
| 712 | +! |
- } else {
+ just = c("left", "top")
|
|
| 369 | +713 |
- # silently ignore when non-numeric even if `log` is selected because some+ ) |
|
| 370 | +714 |
- # variables may be numeric and others not+ } else {
|
|
| 371 | +715 | ! |
- ref_cl_name <- as.name(ref_name)+ if (!is.null(wrap_character)) {
|
| 372 | +716 | ! |
- ref_cl_lbl <- varname_w_label(ref_name, ANL)+ var <- stringr::str_wrap(var, width = wrap_character) |
| 373 | +717 |
} |
|
| 374 | -+ | ||
| 718 | +! |
-
+ var <- if (isTRUE(remove_NA_hist)) as.vector(stats::na.omit(var)) else var |
|
| 375 | +719 | ! |
- user_ggplot2_args <- teal.widgets::resolve_ggplot2_args(+ ggplot(data.frame(var), aes(x = forcats::fct_infreq(as.factor(var)))) + |
| 376 | +720 | ! |
- user_plot = ggplot2_args[["Bivariate1"]],+ geom_bar( |
| 377 | +721 | ! |
- user_default = ggplot2_args$default+ stat = "count", aes(fill = ifelse(is.na(var), "withcolor", "")), show.legend = FALSE |
| 378 | +722 |
- )+ ) ++ |
+ |
| 723 | +! | +
+ scale_fill_manual(values = c("gray50", "tan"))
|
|
| 379 | +724 |
-
+ } |
|
| 380 | +725 | ! |
- ref_call <- bivariate_plot_call(+ } else if (is.numeric(var)) {
|
| 381 | +726 | ! |
- data_name = "ANL",+ validate(need(any(!is.na(var)), "No data left to visualize.")) |
| 382 | -! | +||
| 727 | +
- x = ref_cl_name,+ |
||
| 383 | -! | +||
| 728 | +
- x_class = ref_class,+ # Filter out NA |
||
| 384 | +729 | ! |
- x_label = ref_cl_lbl,+ var <- var[which(!is.na(var))] |
| 385 | -! | +||
| 730 | +
- freq = !show_dist,+ |
||
| 386 | +731 | ! |
- theme = distribution_theme,+ validate(need(!any(is.infinite(var)), "Cannot display graph when data includes infinite values")) |
| 387 | -! | +||
| 732 | +
- rotate_xaxis_labels = rotate_xaxis_labels,+ |
||
| 388 | +733 | ! |
- swap_axes = FALSE,+ if (numeric_as_factor) {
|
| 389 | +734 | ! |
- size = size,+ var <- factor(var) |
| 390 | +735 | ! |
- alpha = alpha,+ ggplot(NULL, aes(x = var)) + |
| 391 | +736 | ! |
- ggplot2_args = user_ggplot2_args+ geom_histogram(stat = "count") |
| 392 | +737 |
- )+ } else {
|
|
| 393 | +738 |
-
+ # remove outliers |
|
| 394 | -+ | ||
| 739 | +! |
- # association+ if (outlier_definition != 0) {
|
|
| 395 | +740 | ! |
- ref_class_cov <- ifelse(association, ref_class, "NULL")+ number_records <- length(var) |
| 396 | -+ | ||
| 741 | +! |
-
+ var <- remove_outliers_from(var, outlier_definition) |
|
| 397 | +742 | ! |
- print_call <- quote(print(p))+ number_outliers <- number_records - length(var) |
| 398 | -+ | ||
| 743 | +! |
-
+ outlier_text <- paste0( |
|
| 399 | +744 | ! |
- var_calls <- lapply(vars_names, function(var_i) {
+ number_outliers, " outliers (",
|
| 400 | +745 | ! |
- var_class <- class(ANL[[var_i]])[1]+ round(number_outliers / number_records * 100, 2), |
| 401 | +746 | ! |
- if (is.numeric(ANL[[var_i]]) && log_transformation) {
+ "% of non-missing records) not shown" |
| 402 | +747 |
- # works for both integers and doubles+ ) |
|
| 403 | +748 | ! |
- var_cl_name <- call("log", as.name(var_i))
+ validate(need( |
| 404 | +749 | ! |
- var_cl_lbl <- varname_w_label(var_i, ANL, prefix = "Log of ")+ length(var) > 1,+ |
+
| 750 | +! | +
+ "At least two data points must remain after removing outliers for this graph to be displayed" |
|
| 405 | +751 |
- } else {
+ )) |
|
| 406 | +752 |
- # silently ignore when non-numeric even if `log` is selected because some+ } |
|
| 407 | +753 |
- # variables may be numeric and others not+ ## histogram |
|
| 408 | +754 | ! |
- var_cl_name <- as.name(var_i)+ binwidth <- get_bin_width(var) |
| 409 | +755 | ! |
- var_cl_lbl <- varname_w_label(var_i, ANL)+ p <- ggplot(data = data.frame(var = var), aes(x = var, y = after_stat(count))) + |
| 410 | -+ | ||
| 756 | +! |
- }+ geom_histogram(binwidth = binwidth) + |
|
| 411 | -+ | ||
| 757 | +! |
-
+ scale_y_continuous( |
|
| 412 | +758 | ! |
- user_ggplot2_args <- teal.widgets::resolve_ggplot2_args(+ sec.axis = sec_axis( |
| 413 | +759 | ! |
- user_plot = ggplot2_args[["Bivariate2"]],+ trans = ~ . / nrow(data.frame(var = var)), |
| 414 | +760 | ! |
- user_default = ggplot2_args$default+ labels = scales::percent, |
| 415 | -+ | ||
| 761 | +! |
- )+ name = "proportion (in %)" |
|
| 416 | +762 |
-
+ ) |
|
| 417 | -! | +||
| 763 | +
- bivariate_plot_call(+ ) |
||
| 418 | -! | +||
| 764 | +
- data_name = "ANL",+ |
||
| 419 | +765 | ! |
- x = ref_cl_name,+ if (display_density) {
|
| 420 | +766 | ! |
- y = var_cl_name,+ p <- p + geom_density(aes(y = after_stat(count * binwidth))) |
| 421 | -! | +||
| 767 | +
- x_class = ref_class_cov,+ } |
||
| 422 | -! | +||
| 768 | +
- y_class = var_class,+ |
||
| 423 | +769 | ! |
- x_label = ref_cl_lbl,+ if (outlier_definition != 0) {
|
| 424 | +770 | ! |
- y_label = var_cl_lbl,+ p <- p + annotate( |
| 425 | +771 | ! |
- theme = association_theme,+ geom = "text", |
| 426 | +772 | ! |
- freq = !show_dist,+ label = outlier_text, |
| 427 | +773 | ! |
- rotate_xaxis_labels = rotate_xaxis_labels,+ x = Inf, y = Inf, |
| 428 | +774 | ! |
- swap_axes = swap_axes,+ hjust = 1.02, vjust = 1.2, |
| 429 | +775 | ! |
- alpha = alpha,+ color = "black", |
| 430 | -! | +||
| 776 | +
- size = size,+ # explicitly modify geom text size according |
||
| 431 | +777 | ! |
- ggplot2_args = user_ggplot2_args+ size = ggplot2_args[["theme"]][["text"]][["size"]] / 3.5 |
| 432 | +778 |
) |
|
| 433 | +779 |
- })+ } |
|
| 434 | -+ | ||
| 780 | +! |
-
+ p |
|
| 435 | +781 |
- # helper function to format variable name+ } |
|
| 436 | +782 | ! |
- format_varnames <- function(x) {
+ } else if (inherits(var, "Date") || inherits(var, "POSIXct") || inherits(var, "POSIXlt")) {
|
| 437 | +783 | ! |
- if (is.numeric(ANL[[x]]) && log_transformation) {
+ var_num <- as.numeric(var) |
| 438 | +784 | ! |
- varname_w_label(x, ANL, prefix = "Log of ")+ binwidth <- get_bin_width(var_num, 1) |
| 439 | -+ | ||
| 785 | +! |
- } else {
+ p <- ggplot(data = data.frame(var = var), aes(x = var, y = after_stat(count))) + |
|
| 440 | +786 | ! |
- varname_w_label(x, ANL)+ geom_histogram(binwidth = binwidth) |
| 441 | +787 |
- }+ } else {
|
|
| 442 | -+ | ||
| 788 | +! |
- }+ grid::textGrob( |
|
| 443 | +789 | ! |
- new_title <-+ paste(strwrap( |
| 444 | +790 | ! |
- if (association) {
+ utils::capture.output(utils::str(var)), |
| 445 | +791 | ! |
- switch(as.character(length(vars_names)),+ width = .9 * grid::convertWidth(grid::unit(1, "npc"), "char", TRUE) |
| 446 | +792 | ! |
- "0" = sprintf("Value distribution for %s", ref_cl_lbl),
+ ), collapse = "\n"), |
| 447 | +793 | ! |
- "1" = sprintf(+ x = grid::unit(1, "line"), y = grid::unit(1, "npc") - grid::unit(1, "line"), just = c("left", "top")
|
| 448 | -! | +||
| 794 | +
- "Association between %s and %s",+ )+ |
+ ||
| 795 | ++ |
+ }+ |
+ |
| 796 | ++ | + | |
| 449 | +797 | ! |
- ref_cl_lbl,+ dev_ggplot2_args <- teal.widgets::ggplot2_args( |
| 450 | +798 | ! |
- format_varnames(vars_names)+ labs = list(x = var_lab) |
| 451 | +799 |
- ),+ ) |
|
| 452 | -! | +||
| 800 | +
- sprintf(+ ### |
||
| 453 | +801 | ! |
- "Associations between %s and: %s",+ all_ggplot2_args <- teal.widgets::resolve_ggplot2_args( |
| 454 | +802 | ! |
- ref_cl_lbl,+ ggplot2_args, |
| 455 | +803 | ! |
- paste(lapply(vars_names, format_varnames), collapse = ", ")+ module_plot = dev_ggplot2_args |
| 456 | +804 |
- )+ ) |
|
| 457 | +805 |
- )+ |
|
| 458 | -+ | ||
| 806 | +! |
- } else {
+ if (is.ggplot(plot_main)) {
|
|
| 459 | +807 | ! |
- switch(as.character(length(vars_names)),+ if (is.numeric(var) && !numeric_as_factor) {
|
| 460 | -! | +||
| 808 | +
- "0" = sprintf("Value distribution for %s", ref_cl_lbl),
+ # numeric not as factor |
||
| 461 | +809 | ! |
- sprintf(+ plot_main <- plot_main + |
| 462 | +810 | ! |
- "Value distributions for %s and %s",+ theme_light() + |
| 463 | +811 | ! |
- ref_cl_lbl,+ list( |
| 464 | +812 | ! |
- paste(lapply(vars_names, format_varnames), collapse = ", ")+ labs = do.call("labs", all_ggplot2_args$labs),
|
| 465 | -+ | ||
| 813 | +! |
- )+ theme = do.call("theme", all_ggplot2_args$theme)
|
|
| 466 | +814 |
- )+ ) |
|
| 467 | +815 |
- }+ } else {
|
|
| 468 | +816 |
-
+ # factor low number of levels OR numeric as factor OR Date |
|
| 469 | +817 | ! |
- teal.code::eval_code(+ plot_main <- plot_main + |
| 470 | +818 | ! |
- merged$anl_q_r(),+ theme_light() + |
| 471 | +819 | ! |
- substitute(+ list( |
| 472 | +820 | ! |
- expr = title <- new_title,+ labs = do.call("labs", all_ggplot2_args$labs),
|
| 473 | +821 | ! |
- env = list(new_title = new_title)+ theme = do.call("theme", all_ggplot2_args$theme)
|
| 474 | +822 |
) |
|
| 475 | +823 |
- ) %>%+ } |
|
| 476 | +824 | ! |
- teal.code::eval_code(+ plot_main <- ggplotGrob(plot_main) |
| 477 | -! | +||
| 825 | +
- substitute(+ } |
||
| 478 | -! | +||
| 826 | +
- expr = {
+
|
||
| 479 | +827 | ! |
- plots <- plot_calls+ grid::grid.draw(plot_main) |
| 480 | +828 | ! |
- p <- tern::stack_grobs(grobs = lapply(plots, ggplotGrob))+ plot_main |
| 481 | -! | +||
| 829 | +
- grid::grid.newpage()+ } |
||
| 482 | -! | +||
| 830 | +
- grid::grid.draw(p)+ |
||
| 483 | +831 |
- },+ is_num_var_short <- function(.unique_records_for_factor, input, data_for_analysis) {
|
|
| 484 | +832 | ! |
- env = list(+ length(unique(data_for_analysis()$data)) < .unique_records_for_factor && !is.null(input$numeric_as_factor) |
| 485 | -! | +||
| 833 | +
- plot_calls = do.call(+ } |
||
| 486 | -! | +||
| 834 | +
- "call",+ |
||
| 487 | -! | +||
| 835 | +
- c(list("list", ref_call), var_calls),
+ #' Validates the variable browser inputs |
||
| 488 | -! | +||
| 836 | +
- quote = TRUE+ #' |
||
| 489 | +837 |
- )+ #' @param input (`session$input`) the `shiny` session input |
|
| 490 | +838 |
- )+ #' @param plot_var (`list`) list of a data frame and an array of variable names |
|
| 491 | +839 |
- )+ #' @param data (`teal_data`) the datasets passed to the module |
|
| 492 | +840 |
- )+ #' |
|
| 493 | +841 |
- })+ #' @returns `logical` TRUE if validations pass; a `shiny` validation error otherwise |
|
| 494 | +842 |
-
+ #' @keywords internal |
|
| 495 | -! | +||
| 843 | +
- plot_r <- reactive({
+ validate_input <- function(input, plot_var, data) {
|
||
| 496 | +844 | ! |
- req(iv_r()$is_valid())+ reactive({
|
| 497 | +845 | ! |
- output_q()[["p"]]+ dataset_name <- req(input$tabset_panel) |
| 498 | -+ | ||
| 846 | +! |
- })+ varname <- plot_var$variable[[dataset_name]] |
|
| 499 | +847 | ||
| 500 | +848 | ! |
- pws <- teal.widgets::plot_with_settings_srv(+ validate(need(dataset_name, "No data selected")) |
| 501 | +849 | ! |
- id = "myplot",+ validate(need(varname, "No variable selected")) |
| 502 | +850 | ! |
- plot_r = plot_r,+ df <- data()[[dataset_name]] |
| 503 | +851 | ! |
- height = plot_height,+ teal::validate_has_data(df, 1) |
| 504 | +852 | ! |
- width = plot_width- |
-
| 505 | -- |
- )+ teal::validate_has_variable(varname = varname, data = df, "Variable not available") |
|
| 506 | +853 | ||
| 507 | +854 | ! |
- output$title <- renderText({
+ TRUE |
| 508 | -! | +||
| 855 | +
- teal.code::dev_suppress(output_q()[["title"]])+ }) |
||
| 509 | +856 |
- })+ } |
|
| 510 | +857 | ||
| 858 | ++ |
+ get_plotted_data <- function(input, plot_var, data) {
+ |
+ |
| 511 | +859 | ! |
- teal.widgets::verbatim_popup_srv(+ dataset_name <- input$tabset_panel |
| 512 | +860 | ! |
- id = "rcode",+ varname <- plot_var$variable[[dataset_name]] |
| 513 | +861 | ! |
- verbatim_content = reactive(teal.code::get_code(output_q())),+ df <- data()[[dataset_name]]+ |
+
| 862 | ++ | + | |
| 514 | +863 | ! |
- title = "Association Plot"+ var_description <- teal.data::col_labels(df)[[varname]]+ |
+
| 864 | +! | +
+ list(data = df[[varname]], var_description = var_description) |
|
| 515 | +865 |
- )+ } |
|
| 516 | +866 | ||
| 517 | +867 |
- ### REPORTER+ #' Renders the left-hand side `tabset` panel of the module |
|
| 518 | -! | +||
| 868 | +
- if (with_reporter) {
+ #' |
||
| 519 | -! | +||
| 869 | +
- card_fun <- function(comment, label) {
+ #' @param datanames (`character`) the name of the dataset |
||
| 520 | -! | +||
| 870 | +
- card <- teal::report_card_template(+ #' @param parent_dataname (`character`) the name of a parent `dataname` to filter out variables from |
||
| 521 | -! | +||
| 871 | +
- title = "Association Plot",+ #' @param data (`teal_data`) the object containing all datasets |
||
| 522 | -! | +||
| 872 | +
- label = label,+ #' @param input (`session$input`) the `shiny` session input |
||
| 523 | -! | +||
| 873 | +
- with_filter = with_filter,+ #' @param output (`session$output`) the `shiny` session output |
||
| 524 | -! | +||
| 874 | +
- filter_panel_api = filter_panel_api+ #' @param columns_names (`environment`) the environment containing bindings for each dataset |
||
| 525 | +875 |
- )+ #' @param plot_var (`list`) the list containing the currently selected dataset (tab) and its column names |
|
| 526 | -! | +||
| 876 | +
- card$append_text("Plot", "header3")
+ #' @keywords internal |
||
| 527 | -! | +||
| 877 | +
- card$append_plot(plot_r(), dim = pws$dim())+ render_tabset_panel_content <- function(datanames, parent_dataname, output, data, input, columns_names, plot_var) {
|
||
| 528 | +878 | ! |
- if (!comment == "") {
+ lapply(datanames, render_single_tab, |
| 529 | +879 | ! |
- card$append_text("Comment", "header3")
+ input = input, |
| 530 | +880 | ! |
- card$append_text(comment)- |
-
| 531 | -- |
- }+ output = output, |
|
| 532 | +881 | ! |
- card$append_src(teal.code::get_code(output_q()))+ data = data, |
| 533 | +882 | ! |
- card+ parent_dataname = parent_dataname, |
| 534 | -+ | ||
| 883 | +! |
- }+ columns_names = columns_names, |
|
| 535 | +884 | ! |
- teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
+ plot_var = plot_var |
| 536 | +885 |
- }+ ) |
|
| 537 | +886 |
- ###+ } |
|
| 538 | +887 |
- })+ |
|
| 539 | +888 |
- }+ #' Renders a single tab in the left-hand side tabset panel |
| 1 | +889 |
- #' `teal` module: Scatterplot matrix+ #' |
|
| 2 | +890 |
- #'+ #' Renders a single tab in the left-hand side tabset panel. The rendered tab contains |
|
| 3 | +891 |
- #' Generates a scatterplot matrix from selected `variables` from datasets.+ #' information about one dataset out of many presented in the module. |
|
| 4 | +892 |
- #' Each plot within the matrix represents the relationship between two variables,+ #' |
|
| 5 | +893 |
- #' providing the overview of correlations and distributions across selected data.+ #' @param dataset_name (`character`) the name of the dataset contained in the rendered tab |
|
| 6 | +894 |
- #'+ #' @param parent_dataname (`character`) the name of a parent `dataname` to filter out variables from |
|
| 7 | +895 |
- #' @note For more examples, please see the vignette "Using scatterplot matrix" via+ #' @inheritParams render_tabset_panel_content |
|
| 8 | +896 |
- #' `vignette("using-scatterplot-matrix", package = "teal.modules.general")`.
+ #' @keywords internal |
|
| 9 | +897 |
- #'+ render_single_tab <- function(dataset_name, parent_dataname, output, data, input, columns_names, plot_var) {
|
|
| 10 | -+ | ||
| 898 | +! |
- #' @inheritParams teal::module+ render_tab_header(dataset_name, output, data) |
|
| 11 | +899 |
- #' @inheritParams tm_g_scatterplot+ |
|
| 12 | -+ | ||
| 900 | +! |
- #' @inheritParams shared_params+ render_tab_table( |
|
| 13 | -+ | ||
| 901 | +! |
- #'+ dataset_name = dataset_name, |
|
| 14 | -+ | ||
| 902 | +! |
- #' @param variables (`data_extract_spec` or `list` of multiple `data_extract_spec`)+ parent_dataname = parent_dataname, |
|
| 15 | -+ | ||
| 903 | +! |
- #' Specifies plotting variables from an incoming dataset with filtering and selecting. In case of+ output = output, |
|
| 16 | -+ | ||
| 904 | +! |
- #' `data_extract_spec` use `select_spec(..., ordered = TRUE)` if plot elements should be+ data = data, |
|
| 17 | -+ | ||
| 905 | +! |
- #' rendered according to selection order.+ input = input, |
|
| 18 | -+ | ||
| 906 | +! |
- #'+ columns_names = columns_names, |
|
| 19 | -+ | ||
| 907 | +! |
- #' @inherit shared_params return+ plot_var = plot_var |
|
| 20 | +908 |
- #'+ ) |
|
| 21 | +909 |
- #' @examplesShinylive+ } |
|
| 22 | +910 |
- #' library(teal.modules.general)+ |
|
| 23 | +911 |
- #' interactive <- function() TRUE+ #' Renders the text headlining a single tab in the left-hand side tabset panel |
|
| 24 | +912 |
- #' {{ next_example }}
+ #' |
|
| 25 | +913 |
- #' @examplesIf require("lattice", quietly = TRUE)
+ #' @param dataset_name (`character`) the name of the dataset of the tab |
|
| 26 | +914 |
- #' # general data example+ #' @inheritParams render_tabset_panel_content |
|
| 27 | +915 |
- #' data <- teal_data()+ #' @keywords internal |
|
| 28 | +916 |
- #' data <- within(data, {
+ render_tab_header <- function(dataset_name, output, data) {
|
|
| 29 | -+ | ||
| 917 | +! |
- #' countries <- data.frame(+ dataset_ui_id <- paste0("dataset_summary_", dataset_name)
|
|
| 30 | -+ | ||
| 918 | +! |
- #' id = c("DE", "FR", "IT", "ES", "PT", "GR", "NL", "BE", "LU", "AT"),
+ output[[dataset_ui_id]] <- renderText({
|
|
| 31 | -+ | ||
| 919 | +! |
- #' government = factor(+ df <- data()[[dataset_name]] |
|
| 32 | -+ | ||
| 920 | +! |
- #' c(2, 2, 2, 1, 2, 2, 1, 1, 1, 2),+ join_keys <- teal.data::join_keys(data()) |
|
| 33 | -+ | ||
| 921 | +! |
- #' labels = c("Monarchy", "Republic")
+ if (!is.null(join_keys)) {
|
|
| 34 | -+ | ||
| 922 | +! |
- #' ),+ key <- teal.data::join_keys(data())[dataset_name, dataset_name] |
|
| 35 | +923 |
- #' language_family = factor(+ } else {
|
|
| 36 | -+ | ||
| 924 | +! |
- #' c(1, 3, 3, 3, 3, 2, 1, 1, 3, 1),+ key <- NULL |
|
| 37 | +925 |
- #' labels = c("Germanic", "Hellenic", "Romance")
+ } |
|
| 38 | -+ | ||
| 926 | +! |
- #' ),+ sprintf( |
|
| 39 | -+ | ||
| 927 | +! |
- #' population = c(83, 67, 60, 47, 10, 11, 17, 11, 0.6, 9),+ "Dataset with %s unique key rows and %s variables", |
|
| 40 | -+ | ||
| 928 | +! |
- #' area = c(357, 551, 301, 505, 92, 132, 41, 30, 2.6, 83),+ nrow(unique(`if`(length(key) > 0, df[, key, drop = FALSE], df))), |
|
| 41 | -+ | ||
| 929 | +! |
- #' gdp = c(3.4, 2.7, 2.1, 1.4, 0.3, 0.2, 0.7, 0.5, 0.1, 0.4),+ ncol(df) |
|
| 42 | +930 |
- #' debt = c(2.1, 2.3, 2.4, 2.6, 2.3, 2.4, 2.3, 2.4, 2.3, 2.4)+ ) |
|
| 43 | +931 |
- #' )+ }) |
|
| 44 | +932 |
- #' sales <- data.frame(+ } |
|
| 45 | +933 |
- #' id = 1:50,+ |
|
| 46 | +934 |
- #' country_id = sample(+ #' Renders the table for a single dataset in the left-hand side tabset panel |
|
| 47 | +935 |
- #' c("DE", "FR", "IT", "ES", "PT", "GR", "NL", "BE", "LU", "AT"),
+ #' |
|
| 48 | +936 |
- #' size = 50,+ #' The table contains column names, column labels, |
|
| 49 | +937 |
- #' replace = TRUE+ #' small summary about NA values and `sparkline` (if appropriate). |
|
| 50 | +938 |
- #' ),+ #' |
|
| 51 | +939 |
- #' year = sort(sample(2010:2020, 50, replace = TRUE)),+ #' @param dataset_name (`character`) the name of the dataset |
|
| 52 | +940 |
- #' venue = sample(c("small", "medium", "large", "online"), 50, replace = TRUE),
+ #' @param parent_dataname (`character`) the name of a parent `dataname` to filter out variables from |
|
| 53 | +941 |
- #' cancelled = sample(c(TRUE, FALSE), 50, replace = TRUE),+ #' @inheritParams render_tabset_panel_content |
|
| 54 | +942 |
- #' quantity = rnorm(50, 100, 20),+ #' @keywords internal |
|
| 55 | +943 |
- #' costs = rnorm(50, 80, 20),+ render_tab_table <- function(dataset_name, parent_dataname, output, data, input, columns_names, plot_var) {
|
|
| 56 | -+ | ||
| 944 | +! |
- #' profit = rnorm(50, 20, 10)+ table_ui_id <- paste0("variable_browser_", dataset_name)
|
|
| 57 | +945 |
- #' )+ |
|
| 58 | -+ | ||
| 946 | +! |
- #' })+ output[[table_ui_id]] <- DT::renderDataTable({
|
|
| 59 | -+ | ||
| 947 | +! |
- #' datanames(data) <- c("countries", "sales")
+ df <- data()[[dataset_name]] |
|
| 60 | +948 |
- #' join_keys(data) <- join_keys(+ |
|
| 61 | -+ | ||
| 949 | +! |
- #' join_key("countries", "countries", "id"),
+ get_vars_df <- function(input, dataset_name, parent_name, data) {
|
|
| 62 | -+ | ||
| 950 | +! |
- #' join_key("sales", "sales", "id"),
+ data_cols <- colnames(df) |
|
| 63 | -+ | ||
| 951 | +! |
- #' join_key("countries", "sales", c("id" = "country_id"))
+ if (isTRUE(input$show_parent_vars)) {
|
|
| 64 | -+ | ||
| 952 | +! |
- #' )+ data_cols |
|
| 65 | -+ | ||
| 953 | +! |
- #'+ } else if (dataset_name != parent_name && parent_name %in% names(data)) {
|
|
| 66 | -+ | ||
| 954 | +! |
- #' app <- init(+ setdiff(data_cols, colnames(data()[[parent_name]])) |
|
| 67 | +955 |
- #' data = data,+ } else {
|
|
| 68 | -+ | ||
| 956 | +! |
- #' modules = modules(+ data_cols |
|
| 69 | +957 |
- #' tm_g_scatterplotmatrix(+ } |
|
| 70 | +958 |
- #' label = "Scatterplot matrix",+ } |
|
| 71 | +959 |
- #' variables = list(+ |
|
| 72 | -+ | ||
| 960 | +! |
- #' data_extract_spec(+ if (length(parent_dataname) > 0) {
|
|
| 73 | -+ | ||
| 961 | +! |
- #' dataname = "countries",+ df_vars <- get_vars_df(input, dataset_name, parent_dataname, data) |
|
| 74 | -+ | ||
| 962 | +! |
- #' select = select_spec(+ df <- df[df_vars] |
|
| 75 | +963 |
- #' label = "Select variables:",+ } |
|
| 76 | +964 |
- #' choices = variable_choices(data[["countries"]]),+ |
|
| 77 | -+ | ||
| 965 | +! |
- #' selected = c("area", "gdp", "debt"),
+ if (is.null(df) || ncol(df) == 0) {
|
|
| 78 | -+ | ||
| 966 | +! |
- #' multiple = TRUE,+ columns_names[[dataset_name]] <- character(0) |
|
| 79 | -+ | ||
| 967 | +! |
- #' ordered = TRUE,+ df_output <- data.frame( |
|
| 80 | -+ | ||
| 968 | +! |
- #' fixed = FALSE+ Type = character(0), |
|
| 81 | -+ | ||
| 969 | +! |
- #' )+ Variable = character(0), |
|
| 82 | -+ | ||
| 970 | +! |
- #' ),+ Label = character(0), |
|
| 83 | -+ | ||
| 971 | +! |
- #' data_extract_spec(+ Missings = character(0), |
|
| 84 | -+ | ||
| 972 | +! |
- #' dataname = "sales",+ Sparklines = character(0), |
|
| 85 | -+ | ||
| 973 | +! |
- #' filter = filter_spec(+ stringsAsFactors = FALSE |
|
| 86 | +974 |
- #' label = "Select variable:",+ ) |
|
| 87 | +975 |
- #' vars = "country_id",+ } else {
|
|
| 88 | +976 |
- #' choices = value_choices(data[["sales"]], "country_id"),+ # extract data variable labels |
|
| 89 | -+ | ||
| 977 | +! |
- #' selected = c("DE", "FR", "IT", "ES", "PT", "GR", "NL", "BE", "LU", "AT"),
+ labels <- teal.data::col_labels(df) |
|
| 90 | +978 |
- #' multiple = TRUE+ |
|
| 91 | -+ | ||
| 979 | +! |
- #' ),+ columns_names[[dataset_name]] <- names(labels) |
|
| 92 | +980 |
- #' select = select_spec(+ |
|
| 93 | +981 |
- #' label = "Select variables:",+ # calculate number of missing values |
|
| 94 | -+ | ||
| 982 | +! |
- #' choices = variable_choices(data[["sales"]], c("quantity", "costs", "profit")),
+ missings <- vapply( |
|
| 95 | -+ | ||
| 983 | +! |
- #' selected = c("quantity", "costs", "profit"),
+ df, |
|
| 96 | -+ | ||
| 984 | +! |
- #' multiple = TRUE,+ var_missings_info, |
|
| 97 | -+ | ||
| 985 | +! |
- #' ordered = TRUE,+ FUN.VALUE = character(1), |
|
| 98 | -+ | ||
| 986 | +! |
- #' fixed = FALSE+ USE.NAMES = FALSE |
|
| 99 | +987 |
- #' )+ ) |
|
| 100 | +988 |
- #' )+ |
|
| 101 | +989 |
- #' )+ # get icons proper for the data types |
|
| 102 | -+ | ||
| 990 | +! |
- #' )+ icons <- vapply(df, function(x) class(x)[1L], character(1L)) |
|
| 103 | +991 |
- #' )+ |
|
| 104 | -+ | ||
| 992 | +! |
- #' )+ join_keys <- teal.data::join_keys(data()) |
|
| 105 | -+ | ||
| 993 | +! |
- #' if (interactive()) {
+ if (!is.null(join_keys)) {
|
|
| 106 | -+ | ||
| 994 | +! |
- #' shinyApp(app$ui, app$server)+ icons[intersect(join_keys[dataset_name, dataset_name], colnames(df))] <- "primary_key" |
|
| 107 | +995 |
- #' }+ } |
|
| 108 | -+ | ||
| 996 | +! |
- #'+ icons <- variable_type_icons(icons) |
|
| 109 | +997 |
- #' @examplesShinylive+ |
|
| 110 | +998 |
- #' library(teal.modules.general)+ # generate sparklines |
|
| 111 | -+ | ||
| 999 | +! |
- #' interactive <- function() TRUE+ sparklines_html <- vapply( |
|
| 112 | -+ | ||
| 1000 | +! |
- #' {{ next_example }}
+ df, |
|
| 113 | -+ | ||
| 1001 | +! |
- #' @examplesIf require("lattice", quietly = TRUE)
+ create_sparklines, |
|
| 114 | -+ | ||
| 1002 | +! |
- #' # CDISC data example+ FUN.VALUE = character(1), |
|
| 115 | -+ | ||
| 1003 | +! |
- #' data <- teal_data()+ USE.NAMES = FALSE |
|
| 116 | +1004 |
- #' data <- within(data, {
+ ) |
|
| 117 | +1005 |
- #' ADSL <- rADSL+ |
|
| 118 | -+ | ||
| 1006 | +! |
- #' ADRS <- rADRS+ df_output <- data.frame( |
|
| 119 | -+ | ||
| 1007 | +! |
- #' })+ Type = icons, |
|
| 120 | -+ | ||
| 1008 | +! |
- #' datanames(data) <- c("ADSL", "ADRS")
+ Variable = names(labels), |
|
| 121 | -+ | ||
| 1009 | +! |
- #' join_keys(data) <- default_cdisc_join_keys[datanames(data)]+ Label = labels, |
|
| 122 | -+ | ||
| 1010 | +! |
- #'+ Missings = missings, |
|
| 123 | -+ | ||
| 1011 | +! |
- #' app <- init(+ Sparklines = sparklines_html, |
|
| 124 | -+ | ||
| 1012 | +! |
- #' data = data,+ stringsAsFactors = FALSE |
|
| 125 | +1013 |
- #' modules = modules(+ ) |
|
| 126 | +1014 |
- #' tm_g_scatterplotmatrix(+ } |
|
| 127 | +1015 |
- #' label = "Scatterplot matrix",+ |
|
| 128 | +1016 |
- #' variables = list(+ # Select row 1 as default / fallback |
|
| 129 | -+ | ||
| 1017 | +! |
- #' data_extract_spec(+ selected_ix <- 1 |
|
| 130 | +1018 |
- #' dataname = "ADSL",+ # Define starting page index (base-0 index of the first item on page |
|
| 131 | +1019 |
- #' select = select_spec(+ # note: in many cases it's not the item itself |
|
| 132 | -+ | ||
| 1020 | +! |
- #' label = "Select variables:",+ selected_page_ix <- 0 |
|
| 133 | +1021 |
- #' choices = variable_choices(data[["ADSL"]]),+ |
|
| 134 | +1022 |
- #' selected = c("AGE", "RACE", "SEX"),
+ # Retrieve current selected variable if any |
|
| 135 | -+ | ||
| 1023 | +! |
- #' multiple = TRUE,+ isolated_variable <- isolate(plot_var$variable[[dataset_name]]) |
|
| 136 | +1024 |
- #' ordered = TRUE,+ |
|
| 137 | -+ | ||
| 1025 | +! |
- #' fixed = FALSE+ if (!is.null(isolated_variable)) {
|
|
| 138 | -+ | ||
| 1026 | +! |
- #' )+ index <- which(columns_names[[dataset_name]] == isolated_variable)[1] |
|
| 139 | -+ | ||
| 1027 | +! |
- #' ),+ if (!is.null(index) && !is.na(index) && length(index) > 0) selected_ix <- index |
|
| 140 | +1028 |
- #' data_extract_spec(+ } |
|
| 141 | +1029 |
- #' dataname = "ADRS",+ |
|
| 142 | +1030 |
- #' filter = filter_spec(+ # Retrieve the index of the first item of the current page |
|
| 143 | +1031 |
- #' label = "Select endpoints:",+ # it works with varying number of entries on the page (10, 25, ...) |
|
| 144 | -+ | ||
| 1032 | +! |
- #' vars = c("PARAMCD", "AVISIT"),
+ table_id_sel <- paste0("variable_browser_", dataset_name, "_state")
|
|
| 145 | -+ | ||
| 1033 | +! |
- #' choices = value_choices(data[["ADRS"]], c("PARAMCD", "AVISIT"), c("PARAM", "AVISIT")),
+ dt_state <- isolate(input[[table_id_sel]]) |
|
| 146 | -+ | ||
| 1034 | +! |
- #' selected = "INVET - END OF INDUCTION",+ if (selected_ix != 1 && !is.null(dt_state)) {
|
|
| 147 | -+ | ||
| 1035 | +! |
- #' multiple = TRUE+ selected_page_ix <- floor(selected_ix / dt_state$length) * dt_state$length |
|
| 148 | +1036 |
- #' ),+ } |
|
| 149 | +1037 |
- #' select = select_spec(+ |
|
| 150 | -+ | ||
| 1038 | +! |
- #' label = "Select variables:",+ DT::datatable( |
|
| 151 | -+ | ||
| 1039 | +! |
- #' choices = variable_choices(data[["ADRS"]]),+ df_output, |
|
| 152 | -+ | ||
| 1040 | +! |
- #' selected = c("AGE", "AVAL", "ADY"),
+ escape = FALSE, |
|
| 153 | -+ | ||
| 1041 | +! |
- #' multiple = TRUE,+ rownames = FALSE, |
|
| 154 | -+ | ||
| 1042 | +! |
- #' ordered = TRUE,+ selection = list(mode = "single", target = "row", selected = selected_ix), |
|
| 155 | -+ | ||
| 1043 | +! |
- #' fixed = FALSE+ options = list( |
|
| 156 | -+ | ||
| 1044 | +! |
- #' )+ fnDrawCallback = htmlwidgets::JS("function() { HTMLWidgets.staticRender(); }"),
|
|
| 157 | -+ | ||
| 1045 | +! |
- #' )+ pageLength = input[[paste0(table_ui_id, "_rows")]], |
|
| 158 | -+ | ||
| 1046 | +! |
- #' )+ displayStart = selected_page_ix |
|
| 159 | +1047 |
- #' )+ ) |
|
| 160 | +1048 |
- #' )+ ) |
|
| 161 | +1049 |
- #' )+ }) |
|
| 162 | +1050 |
- #' if (interactive()) {
+ } |
|
| 163 | +1051 |
- #' shinyApp(app$ui, app$server)+ |
|
| 164 | +1052 |
- #' }+ #' Creates observers updating the currently selected column |
|
| 165 | +1053 |
#' |
|
| 166 | +1054 |
- #' @export+ #' The created observers update the column currently selected in the left-hand side |
|
| 167 | +1055 | ++ |
+ #' tabset panel.+ |
+
| 1056 |
#' |
||
| 168 | +1057 |
- tm_g_scatterplotmatrix <- function(label = "Scatterplot Matrix",+ #' @note |
|
| 169 | +1058 |
- variables,+ #' Creates an observer for each dataset (each tab in the tabset panel). |
|
| 170 | +1059 |
- plot_height = c(600, 200, 2000),+ #' |
|
| 171 | +1060 |
- plot_width = NULL,+ #' @inheritParams render_tabset_panel_content |
|
| 172 | +1061 |
- pre_output = NULL,+ #' @keywords internal |
|
| 173 | +1062 |
- post_output = NULL) {
+ establish_updating_selection <- function(datanames, input, plot_var, columns_names) {
|
|
| 174 | +1063 | ! |
- message("Initializing tm_g_scatterplotmatrix")
+ lapply(datanames, function(dataset_name) {
|
| 175 | -+ | ||
| 1064 | +! |
-
+ table_ui_id <- paste0("variable_browser_", dataset_name)
|
|
| 176 | -+ | ||
| 1065 | +! |
- # Requires Suggested packages+ table_id_sel <- paste0(table_ui_id, "_rows_selected") |
|
| 177 | +1066 | ! |
- if (!requireNamespace("lattice", quietly = TRUE)) {
+ observeEvent(input[[table_id_sel]], {
|
| 178 | +1067 | ! |
- stop("Cannot load lattice - please install the package or restart your session.")
+ plot_var$data <- dataset_name |
| 179 | -+ | ||
| 1068 | +! |
- }+ plot_var$variable[[dataset_name]] <- columns_names[[dataset_name]][input[[table_id_sel]]] |
|
| 180 | +1069 |
-
+ }) |
|
| 181 | +1070 |
- # Normalize the parameters+ }) |
|
| 182 | -! | +||
| 1071 | +
- if (inherits(variables, "data_extract_spec")) variables <- list(variables)+ } |
||
| 183 | +1072 | ||
| 184 | +1073 |
- # Start of assertions+ get_bin_width <- function(x_vec, scaling_factor = 2) {
|
|
| 185 | +1074 | ! |
- checkmate::assert_string(label)+ x_vec <- x_vec[!is.na(x_vec)] |
| 186 | +1075 | ! |
- checkmate::assert_list(variables, types = "data_extract_spec")- |
-
| 187 | -- |
-
+ qntls <- stats::quantile(x_vec, probs = c(0.1, 0.25, 0.75, 0.9), type = 2) |
|
| 188 | +1076 | ! |
- checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE)+ iqr <- qntls[3] - qntls[2] |
| 189 | +1077 | ! |
- checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height")+ binwidth <- max(scaling_factor * iqr / length(x_vec) ^ (1 / 3), sqrt(qntls[4] - qntls[1])) # styler: off |
| 190 | +1078 | ! |
- checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE)+ binwidth <- ifelse(binwidth == 0, 1, binwidth) |
| 191 | -! | +||
| 1079 | +
- checkmate::assert_numeric(+ # to ensure at least two bins when variable span is very small |
||
| 192 | +1080 | ! |
- plot_width[1],+ x_span <- diff(range(x_vec)) |
| 193 | +1081 | ! |
- lower = plot_width[2], upper = plot_width[3], null.ok = TRUE, .var.name = "plot_width"+ if (isTRUE(x_span / binwidth >= 2)) binwidth else x_span / 2 |
| 194 | +1082 |
- )+ } |
|
| 195 | +1083 | ||
| 196 | -! | +||
| 1084 | +
- checkmate::assert_multi_class(pre_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
+ #' Removes the outlier observation from an array |
||
| 197 | -! | +||
| 1085 | +
- checkmate::assert_multi_class(post_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
+ #' |
||
| 198 | +1086 |
- # End of assertions+ #' @param var (`numeric`) a numeric vector |
|
| 199 | +1087 |
-
+ #' @param outlier_definition (`numeric`) if `0` then no outliers are removed, otherwise |
|
| 200 | +1088 |
- # Make UI args+ #' outliers (those more than `outlier_definition*IQR below/above Q1/Q3`) are removed |
|
| 201 | -! | +||
| 1089 | +
- args <- as.list(environment())+ #' @returns (`numeric`) vector without the outlier values |
||
| 202 | +1090 |
-
+ #' @keywords internal |
|
| 203 | -! | +||
| 1091 | +
- ans <- module(+ remove_outliers_from <- function(var, outlier_definition) {
|
||
| 204 | -! | +||
| 1092 | +3x |
- label = label,+ if (outlier_definition == 0) {
|
|
| 205 | -! | +||
| 1093 | +1x |
- server = srv_g_scatterplotmatrix,+ return(var) |
|
| 206 | -! | +||
| 1094 | +
- ui = ui_g_scatterplotmatrix,+ } |
||
| 207 | -! | +||
| 1095 | +2x |
- ui_args = args,+ q1_q3 <- stats::quantile(var, probs = c(0.25, 0.75), type = 2, na.rm = TRUE) |
|
| 208 | -! | +||
| 1096 | +2x |
- server_args = list(variables = variables, plot_height = plot_height, plot_width = plot_width),+ iqr <- q1_q3[2] - q1_q3[1] |
|
| 209 | -! | +||
| 1097 | +2x |
- datanames = teal.transform::get_extract_datanames(variables)+ var[var >= q1_q3[1] - outlier_definition * iqr & var <= q1_q3[2] + outlier_definition * iqr] |
|
| 210 | +1098 |
- )+ } |
|
| 211 | -! | +||
| 1099 | +
- attr(ans, "teal_bookmarkable") <- TRUE+ |
||
| 212 | -! | +||
| 1100 | +
- ans+ |
||
| 213 | +1101 |
- }+ # sparklines ---- |
|
| 214 | +1102 | ||
| 215 | +1103 |
- # UI function for the scatterplot matrix module+ #' S3 generic for `sparkline` widget HTML |
|
| 216 | +1104 |
- ui_g_scatterplotmatrix <- function(id, ...) {
+ #' |
|
| 217 | -! | +||
| 1105 | +
- args <- list(...)+ #' Generates the `sparkline` HTML code corresponding to the input array. |
||
| 218 | -! | +||
| 1106 | +
- is_single_dataset_value <- teal.transform::is_single_dataset(args$variables)+ #' For numeric variables creates a box plot, for character and factors - bar plot. |
||
| 219 | -! | +||
| 1107 | +
- ns <- NS(id)+ #' Produces an empty string for variables of other types. |
||
| 220 | -! | +||
| 1108 | +
- teal.widgets::standard_layout(+ #' |
||
| 221 | -! | +||
| 1109 | +
- output = teal.widgets::white_small_well(+ #' @param arr vector of any type and length |
||
| 222 | -! | +||
| 1110 | +
- textOutput(ns("message")),
+ #' @param width `numeric` the width of the `sparkline` widget (pixels) |
||
| 223 | -! | +||
| 1111 | +
- tags$br(),+ #' @param bar_spacing `numeric` the spacing between the bars (in pixels) |
||
| 224 | -! | +||
| 1112 | +
- teal.widgets::plot_with_settings_ui(id = ns("myplot"))
+ #' @param bar_width `numeric` the width of the bars (in pixels) |
||
| 225 | +1113 |
- ),+ #' @param ... `list` additional options passed to bar plots of `jquery.sparkline`; |
|
| 226 | -! | +||
| 1114 | +
- encoding = tags$div(+ #' see [`jquery.sparkline docs`](https://omnipotent.net/jquery.sparkline/#common) |
||
| 227 | +1115 |
- ### Reporter+ #' |
|
| 228 | -! | +||
| 1116 | +
- teal.reporter::simple_reporter_ui(ns("simple_reporter")),
+ #' @return Character string containing HTML code of the `sparkline` HTML widget. |
||
| 229 | +1117 |
- ###+ #' @keywords internal |
|
| 230 | -! | +||
| 1118 | +
- tags$label("Encodings", class = "text-primary"),
+ create_sparklines <- function(arr, width = 150, ...) {
|
||
| 231 | +1119 | ! |
- teal.transform::datanames_input(args$variables),+ if (all(is.null(arr))) {
|
| 232 | +1120 | ! |
- teal.transform::data_extract_ui(+ return("")
|
| 233 | -! | +||
| 1121 | +
- id = ns("variables"),
+ } |
||
| 234 | +1122 | ! |
- label = "Variables",+ UseMethod("create_sparklines")
|
| 235 | -! | +||
| 1123 | +
- data_extract_spec = args$variables,+ } |
||
| 236 | -! | +||
| 1124 | +
- is_single_dataset = is_single_dataset_value+ |
||
| 237 | +1125 |
- ),+ #' @rdname create_sparklines |
|
| 238 | -! | +||
| 1126 | +
- tags$hr(),+ #' @keywords internal |
||
| 239 | -! | +||
| 1127 | +
- teal.widgets::panel_group(+ #' @export |
||
| 240 | -! | +||
| 1128 | +
- teal.widgets::panel_item(+ create_sparklines.logical <- function(arr, ...) {
|
||
| 241 | +1129 | ! |
- title = "Plot settings",+ create_sparklines(as.factor(arr)) |
| 242 | -! | +||
| 1130 | +
- sliderInput(+ } |
||
| 243 | -! | +||
| 1131 | +
- ns("alpha"), "Opacity:",
+
|
||
| 244 | -! | +||
| 1132 | +
- min = 0, max = 1,+ #' @rdname create_sparklines |
||
| 245 | -! | +||
| 1133 | +
- step = .05, value = .5, ticks = FALSE+ #' @keywords internal |
||
| 246 | +1134 |
- ),+ #' @export |
|
| 247 | -! | +||
| 1135 | +
- sliderInput(+ create_sparklines.numeric <- function(arr, width = 150, ...) {
|
||
| 248 | +1136 | ! |
- ns("cex"), "Points size:",
+ if (any(is.infinite(arr))) {
|
| 249 | -! | -
- min = 0.2, max = 3,- |
- |
| 250 | +1137 | ! |
- step = .05, value = .65, ticks = FALSE+ return(as.character(tags$code("infinite values", class = "text-blue")))
|
| 251 | +1138 |
- ),+ } |
|
| 252 | +1139 | ! |
- checkboxInput(ns("cor"), "Add Correlation", value = FALSE),
+ if (length(arr) > 100000) {
|
| 253 | +1140 | ! |
- radioButtons(+ return(as.character(tags$code("Too many rows (>100000)", class = "text-blue")))
|
| 254 | -! | +||
| 1141 | +
- ns("cor_method"), "Select Correlation Method",
+ } |
||
| 255 | -! | +||
| 1142 | +
- choiceNames = c("Pearson", "Kendall", "Spearman"),
+
|
||
| 256 | +1143 | ! |
- choiceValues = c("pearson", "kendall", "spearman"),
+ arr <- arr[!is.na(arr)] |
| 257 | +1144 | ! |
- inline = TRUE+ sparkline::spk_chr(unname(arr), type = "box", width = width, ...) |
| 258 | +1145 |
- ),+ } |
|
| 259 | -! | +||
| 1146 | +
- checkboxInput(ns("cor_na_omit"), "Omit Missing Values", value = TRUE)
+
|
||
| 260 | +1147 |
- )+ #' @rdname create_sparklines |
|
| 261 | +1148 |
- )+ #' @keywords internal |
|
| 262 | +1149 |
- ),+ #' @export |
|
| 263 | -! | +||
| 1150 | +
- forms = tagList(+ create_sparklines.character <- function(arr, ...) {
|
||
| 264 | +1151 | ! |
- teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code")
+ return(create_sparklines(as.factor(arr))) |
| 265 | +1152 |
- ),- |
- |
| 266 | -! | -
- pre_output = args$pre_output,+ } |
|
| 267 | -! | +||
| 1153 | +
- post_output = args$post_output+ |
||
| 268 | +1154 |
- )+ |
|
| 269 | +1155 |
- }+ #' @rdname create_sparklines |
|
| 270 | +1156 |
-
+ #' @keywords internal |
|
| 271 | +1157 |
- # Server function for the scatterplot matrix module+ #' @export |
|
| 272 | +1158 |
- srv_g_scatterplotmatrix <- function(id, data, reporter, filter_panel_api, variables, plot_height, plot_width) {
+ create_sparklines.factor <- function(arr, width = 150, bar_spacing = 5, bar_width = 20, ...) {
|
|
| 273 | +1159 | ! |
- with_reporter <- !missing(reporter) && inherits(reporter, "Reporter")+ decreasing_order <- TRUE |
| 274 | -! | +||
| 1160 | +
- with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI")+ |
||
| 275 | +1161 | ! |
- checkmate::assert_class(data, "reactive")+ counts <- table(arr) |
| 276 | +1162 | ! |
- checkmate::assert_class(isolate(data()), "teal_data")+ if (length(counts) >= 100) {
|
| 277 | +1163 | ! |
- moduleServer(id, function(input, output, session) {
+ return(as.character(tags$code("> 99 levels", class = "text-blue")))
|
| 278 | +1164 | ! |
- teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.general")- |
-
| 279 | -- |
-
+ } else if (length(counts) == 0) {
|
|
| 280 | +1165 | ! |
- selector_list <- teal.transform::data_extract_multiple_srv(+ return(as.character(tags$code("no levels", class = "text-blue")))
|
| 281 | +1166 | ! |
- data_extract = list(variables = variables),+ } else if (length(counts) == 1) {
|
| 282 | +1167 | ! |
- datasets = data,+ return(as.character(tags$code("one level", class = "text-blue")))
|
| 283 | -! | +||
| 1168 | +
- select_validation_rule = list(+ } |
||
| 284 | -! | +||
| 1169 | +
- variables = ~ if (length(.) <= 1) "Please select at least 2 columns."+ |
||
| 285 | +1170 |
- )+ # Summarize the occurences of different levels |
|
| 286 | +1171 |
- )+ # and get the maximum and minimum number of occurences |
|
| 287 | +1172 |
-
+ # This is needed for the sparkline to correctly display the bar plots |
|
| 288 | -! | +||
| 1173 | +
- iv_r <- reactive({
+ # Otherwise they are cropped |
||
| 289 | +1174 | ! |
- iv <- shinyvalidate::InputValidator$new()+ counts <- sort(counts, decreasing = decreasing_order, method = "radix") |
| 290 | +1175 | ! |
- teal.transform::compose_and_enable_validators(iv, selector_list)+ max_value <- if (decreasing_order) counts[1] else counts[length[counts]] |
| 291 | -+ | ||
| 1176 | +! |
- })+ max_value <- unname(max_value) |
|
| 292 | +1177 | ||
| 293 | +1178 | ! |
- anl_merged_input <- teal.transform::merge_expression_srv(+ sparkline::spk_chr( |
| 294 | +1179 | ! |
- datasets = data,+ unname(counts), |
| 295 | +1180 | ! |
- selector_list = selector_list+ type = "bar", |
| 296 | -+ | ||
| 1181 | +! |
- )+ chartRangeMin = 0, |
|
| 297 | -+ | ||
| 1182 | +! |
-
+ chartRangeMax = max_value, |
|
| 298 | +1183 | ! |
- anl_merged_q <- reactive({
+ width = width, |
| 299 | +1184 | ! |
- req(anl_merged_input())+ barWidth = bar_width, |
| 300 | +1185 | ! |
- data() %>%+ barSpacing = bar_spacing, |
| 301 | +1186 | ! |
- teal.code::eval_code(as.expression(anl_merged_input()$expr))+ tooltipFormatter = custom_sparkline_formatter(names(counts), as.vector(counts)) |
| 302 | +1187 |
- })+ ) |
|
| 303 | +1188 |
-
+ } |
|
| 304 | -! | +||
| 1189 | +
- merged <- list(+ |
||
| 305 | -! | +||
| 1190 | +
- anl_input_r = anl_merged_input,+ #' @rdname create_sparklines |
||
| 306 | -! | +||
| 1191 | +
- anl_q_r = anl_merged_q+ #' @keywords internal |
||
| 307 | +1192 |
- )+ #' @export |
|
| 308 | +1193 |
-
+ create_sparklines.Date <- function(arr, width = 150, bar_spacing = 5, bar_width = 20, ...) {
|
|
| 309 | -+ | ||
| 1194 | +! |
- # plot+ arr_num <- as.numeric(arr) |
|
| 310 | +1195 | ! |
- output_q <- reactive({
+ arr_num <- sort(arr_num, decreasing = FALSE, method = "radix") |
| 311 | +1196 | ! |
- teal::validate_inputs(iv_r())+ binwidth <- get_bin_width(arr_num, 1) |
| 312 | -+ | ||
| 1197 | +! |
-
+ bins <- floor(diff(range(arr_num)) / binwidth) + 1 |
|
| 313 | +1198 | ! |
- qenv <- merged$anl_q_r()+ if (all(is.na(bins))) {
|
| 314 | +1199 | ! |
- ANL <- qenv[["ANL"]]+ return(as.character(tags$code("only NA", class = "text-blue")))
|
| 315 | -+ | ||
| 1200 | +! |
-
+ } else if (bins == 1) {
|
|
| 316 | +1201 | ! |
- cols_names <- merged$anl_input_r()$columns_source$variables+ return(as.character(tags$code("one date", class = "text-blue")))
+ |
+
| 1202 | ++ |
+ } |
|
| 317 | +1203 | ! |
- alpha <- input$alpha+ counts <- as.vector(unname(base::table(cut(arr_num, breaks = bins)))) |
| 318 | +1204 | ! |
- cex <- input$cex+ max_value <- max(counts)+ |
+
| 1205 | ++ | + | |
| 319 | +1206 | ! |
- add_cor <- input$cor+ start_bins <- as.integer(seq(1, length(arr_num), length.out = bins)) |
| 320 | +1207 | ! |
- cor_method <- input$cor_method+ labels_start <- as.character(as.Date(arr_num[start_bins], origin = as.Date("1970-01-01")))
|
| 321 | +1208 | ! |
- cor_na_omit <- input$cor_na_omit+ labels <- paste("Start:", labels_start)
|
| 322 | +1209 | ||
| 323 | +1210 | ! |
- cor_na_action <- if (isTruthy(cor_na_omit)) {
+ sparkline::spk_chr( |
| 324 | +1211 | ! |
- "na.omit"+ unname(counts), |
| 325 | -+ | ||
| 1212 | +! |
- } else {
+ type = "bar", |
|
| 326 | +1213 | ! |
- "na.fail"+ chartRangeMin = 0, |
| 327 | -+ | ||
| 1214 | +! |
- }+ chartRangeMax = max_value, |
|
| 328 | -+ | ||
| 1215 | +! |
-
+ width = width, |
|
| 329 | +1216 | ! |
- teal::validate_has_data(ANL, 10)+ barWidth = bar_width, |
| 330 | +1217 | ! |
- teal::validate_has_data(ANL[, cols_names, drop = FALSE], 10, complete = TRUE, allow_inf = FALSE)+ barSpacing = bar_spacing,+ |
+
| 1218 | +! | +
+ tooltipFormatter = custom_sparkline_formatter(labels, counts) |
|
| 331 | +1219 |
-
+ ) |
|
| 332 | +1220 |
- # get labels and proper variable names+ } |
|
| 333 | -! | +||
| 1221 | +
- varnames <- varname_w_label(cols_names, ANL, wrap_width = 20)+ |
||
| 334 | +1222 |
-
+ #' @rdname create_sparklines |
|
| 335 | +1223 |
- # check character columns. If any, then those are converted to factors+ #' @keywords internal |
|
| 336 | -! | +||
| 1224 | +
- check_char <- vapply(ANL[, cols_names], is.character, logical(1))+ #' @export+ |
+ ||
| 1225 | ++ |
+ create_sparklines.POSIXct <- function(arr, width = 150, bar_spacing = 5, bar_width = 20, ...) {
|
|
| 337 | +1226 | ! |
- if (any(check_char)) {
+ arr_num <- as.numeric(arr) |
| 338 | +1227 | ! |
- qenv <- teal.code::eval_code(+ arr_num <- sort(arr_num, decreasing = FALSE, method = "radix") |
| 339 | +1228 | ! |
- qenv,+ binwidth <- get_bin_width(arr_num, 1) |
| 340 | +1229 | ! |
- substitute(+ bins <- floor(diff(range(arr_num)) / binwidth) + 1 |
| 341 | +1230 | ! |
- expr = ANL <- ANL[, cols_names] %>%+ if (all(is.na(bins))) {
|
| 342 | +1231 | ! |
- dplyr::mutate_if(is.character, as.factor) %>%+ return(as.character(tags$code("only NA", class = "text-blue")))
|
| 343 | +1232 | ! |
- droplevels(),+ } else if (bins == 1) {
|
| 344 | +1233 | ! |
- env = list(cols_names = cols_names)+ return(as.character(tags$code("one date-time", class = "text-blue")))
|
| 345 | +1234 |
- )- |
- |
| 346 | -- |
- )- |
- |
| 347 | -- |
- } else {
+ } |
|
| 348 | +1235 | ! |
- qenv <- teal.code::eval_code(+ counts <- as.vector(unname(base::table(cut(arr_num, breaks = bins)))) |
| 349 | +1236 | ! |
- qenv,+ max_value <- max(counts) |
| 350 | -! | +||
| 1237 | +
- substitute(+ |
||
| 351 | +1238 | ! |
- expr = ANL <- ANL[, cols_names] %>%+ start_bins <- as.integer(seq(1, length(arr_num), length.out = bins)) |
| 352 | +1239 | ! |
- droplevels(),+ labels_start <- as.character(format(as.POSIXct(arr_num[start_bins], origin = as.Date("1970-01-01")), "%Y-%m-%d"))
|
| 353 | +1240 | ! |
- env = list(cols_names = cols_names)+ labels <- paste("Start:", labels_start)
|
| 354 | +1241 |
- )+ |
|
| 355 | -+ | ||
| 1242 | +! |
- )+ sparkline::spk_chr( |
|
| 356 | -+ | ||
| 1243 | +! |
- }+ unname(counts), |
|
| 357 | -+ | ||
| 1244 | +! |
-
+ type = "bar", |
|
| 358 | -+ | ||
| 1245 | +! |
-
+ chartRangeMin = 0, |
|
| 359 | -+ | ||
| 1246 | +! |
- # create plot+ chartRangeMax = max_value, |
|
| 360 | +1247 | ! |
- if (add_cor) {
+ width = width, |
| 361 | +1248 | ! |
- shinyjs::show("cor_method")
+ barWidth = bar_width, |
| 362 | +1249 | ! |
- shinyjs::show("cor_use")
+ barSpacing = bar_spacing, |
| 363 | +1250 | ! |
- shinyjs::show("cor_na_omit")
+ tooltipFormatter = custom_sparkline_formatter(labels, counts) |
| 364 | +1251 | ++ |
+ )+ |
+
| 1252 | ++ |
+ }+ |
+ |
| 1253 | |||
| 365 | -! | +||
| 1254 | +
- qenv <- teal.code::eval_code(+ #' @rdname create_sparklines |
||
| 366 | -! | +||
| 1255 | +
- qenv,+ #' @keywords internal |
||
| 367 | -! | +||
| 1256 | +
- substitute(+ #' @export |
||
| 368 | -! | +||
| 1257 | +
- expr = {
+ create_sparklines.POSIXlt <- function(arr, width = 150, bar_spacing = 5, bar_width = 20, ...) {
|
||
| 369 | +1258 | ! |
- g <- lattice::splom(+ arr_num <- as.numeric(arr) |
| 370 | +1259 | ! |
- ANL,+ arr_num <- sort(arr_num, decreasing = FALSE, method = "radix") |
| 371 | +1260 | ! |
- varnames = varnames_value,+ binwidth <- get_bin_width(arr_num, 1) |
| 372 | +1261 | ! |
- panel = function(x, y, ...) {
+ bins <- floor(diff(range(arr_num)) / binwidth) + 1 |
| 373 | +1262 | ! |
- lattice::panel.splom(x = x, y = y, ...)+ if (all(is.na(bins))) {
|
| 374 | +1263 | ! |
- cpl <- lattice::current.panel.limits()+ return(as.character(tags$code("only NA", class = "text-blue")))
|
| 375 | +1264 | ! |
- lattice::panel.text(+ } else if (bins == 1) {
|
| 376 | +1265 | ! |
- mean(cpl$xlim),+ return(as.character(tags$code("one date-time", class = "text-blue")))
|
| 377 | -! | +||
| 1266 | +
- mean(cpl$ylim),+ } |
||
| 378 | +1267 | ! |
- get_scatterplotmatrix_stats(+ counts <- as.vector(unname(base::table(cut(arr_num, breaks = bins)))) |
| 379 | +1268 | ! |
- x,+ max_value <- max(counts)+ |
+
| 1269 | ++ | + | |
| 380 | +1270 | ! |
- y,+ start_bins <- as.integer(seq(1, length(arr_num), length.out = bins)) |
| 381 | +1271 | ! |
- .f = stats::cor.test,+ labels_start <- as.character(format(as.POSIXct(arr_num[start_bins], origin = as.Date("1970-01-01")), "%Y-%m-%d"))
|
| 382 | +1272 | ! |
- .f_args = list(method = cor_method, na.action = cor_na_action)+ labels <- paste("Start:", labels_start)
|
| 383 | +1273 |
- ),+ |
|
| 384 | +1274 | ! |
- alpha = 0.6,+ sparkline::spk_chr( |
| 385 | +1275 | ! |
- fontsize = 18,+ unname(counts), |
| 386 | +1276 | ! |
- fontface = "bold"+ type = "bar", |
| 387 | -+ | ||
| 1277 | +! |
- )+ chartRangeMin = 0, |
|
| 388 | -+ | ||
| 1278 | +! |
- },+ chartRangeMax = max_value, |
|
| 389 | +1279 | ! |
- pch = 16,+ width = width, |
| 390 | +1280 | ! |
- alpha = alpha_value,+ barWidth = bar_width, |
| 391 | +1281 | ! |
- cex = cex_value+ barSpacing = bar_spacing, |
| 392 | -+ | ||
| 1282 | +! |
- )+ tooltipFormatter = custom_sparkline_formatter(labels, counts) |
|
| 393 | -! | +||
| 1283 | +
- print(g)+ ) |
||
| 394 | +1284 |
- },+ } |
|
| 395 | -! | +||
| 1285 | +
- env = list(+ |
||
| 396 | -! | +||
| 1286 | +
- varnames_value = varnames,+ #' @rdname create_sparklines |
||
| 397 | -! | +||
| 1287 | +
- cor_method = cor_method,+ #' @keywords internal |
||
| 398 | -! | +||
| 1288 | +
- cor_na_action = cor_na_action,+ #' @export |
||
| 399 | -! | +||
| 1289 | +
- alpha_value = alpha,+ create_sparklines.default <- function(arr, width = 150, ...) {
|
||
| 400 | +1290 | ! |
- cex_value = cex+ as.character(tags$code("unsupported variable type", class = "text-blue"))
|
| 401 | +1291 |
- )+ } |
|
| 402 | +1292 |
- )+ |
|
| 403 | +1293 |
- )+ |
|
| 404 | +1294 |
- } else {
+ custom_sparkline_formatter <- function(labels, counts) {
|
|
| 405 | +1295 | ! |
- shinyjs::hide("cor_method")
+ htmlwidgets::JS( |
| 406 | +1296 | ! |
- shinyjs::hide("cor_use")
+ sprintf( |
| 407 | +1297 | ! |
- shinyjs::hide("cor_na_omit")
+ "function(sparkline, options, field) {
|
| 408 | +1298 | ! |
- qenv <- teal.code::eval_code(+ return 'ID: ' + %s[field[0].offset] + '<br>' + 'Count: ' + %s[field[0].offset]; |
| 409 | -! | +||
| 1299 | +
- qenv,+ }", |
||
| 410 | +1300 | ! |
- substitute(+ jsonlite::toJSON(labels), |
| 411 | +1301 | ! |
- expr = {
+ jsonlite::toJSON(counts) |
| 412 | -! | +||
| 1302 | +
- g <- lattice::splom(ANL, varnames = varnames_value, pch = 16, alpha = alpha_value, cex = cex_value)+ ) |
||
| 413 | -! | +||
| 1303 | +
- g+ ) |
||
| 414 | +1304 |
- },+ } |
|
| 415 | -! | +
| 1 | +
- env = list(varnames_value = varnames, alpha_value = alpha, cex_value = cex)+ #' `teal` module: Outliers analysis |
||
| 416 | +2 |
- )+ #' |
|
| 417 | +3 |
- )+ #' Module to analyze and identify outliers using different methods |
|
| 418 | +4 |
- }+ #' such as IQR, Z-score, and Percentiles, and offers visualizations including |
|
| 419 | -! | +||
| 5 | +
- qenv+ #' box plots, density plots, and cumulative distribution plots to help interpret the outliers. |
||
| 420 | +6 |
- })+ #' |
|
| 421 | +7 |
-
+ #' @inheritParams teal::module |
|
| 422 | -! | +||
| 8 | +
- plot_r <- reactive(output_q()[["g"]])+ #' @inheritParams shared_params |
||
| 423 | +9 |
-
+ #' |
|
| 424 | +10 |
- # Insert the plot into a plot_with_settings module+ #' @param outlier_var (`data_extract_spec` or `list` of multiple `data_extract_spec`) |
|
| 425 | -! | +||
| 11 | +
- pws <- teal.widgets::plot_with_settings_srv(+ #' Specifies variable(s) to be analyzed for outliers. |
||
| 426 | -! | +||
| 12 | +
- id = "myplot",+ #' @param categorical_var (`data_extract_spec` or `list` of multiple `data_extract_spec`) optional, |
||
| 427 | -! | +||
| 13 | +
- plot_r = plot_r,+ #' specifies the categorical variable(s) to split the selected outlier variables on. |
||
| 428 | -! | +||
| 14 | +
- height = plot_height,+ #' |
||
| 429 | -! | +||
| 15 | +
- width = plot_width+ #' @templateVar ggnames "Boxplot","Density Plot","Cumulative Distribution Plot" |
||
| 430 | +16 |
- )+ #' @template ggplot2_args_multi |
|
| 431 | +17 |
-
+ #' |
|
| 432 | +18 |
- # show a message if conversion to factors took place+ #' @inherit shared_params return |
|
| 433 | -! | +||
| 19 | +
- output$message <- renderText({
+ #' |
||
| 434 | -! | +||
| 20 | +
- req(iv_r()$is_valid())+ #' @examplesShinylive |
||
| 435 | -! | +||
| 21 | +
- req(selector_list()$variables())+ #' library(teal.modules.general) |
||
| 436 | -! | +||
| 22 | +
- ANL <- merged$anl_q_r()[["ANL"]]+ #' interactive <- function() TRUE |
||
| 437 | -! | +||
| 23 | +
- cols_names <- unique(unname(do.call(c, merged$anl_input_r()$columns_source)))+ #' {{ next_example }}
|
||
| 438 | -! | +||
| 24 | +
- check_char <- vapply(ANL[, cols_names], is.character, logical(1))+ #' @examples |
||
| 439 | -! | +||
| 25 | +
- if (any(check_char)) {
+ #' # general data example |
||
| 440 | -! | +||
| 26 | +
- is_single <- sum(check_char) == 1+ #' data <- teal_data() |
||
| 441 | -! | +||
| 27 | +
- paste(+ #' data <- within(data, {
|
||
| 442 | -! | +||
| 28 | +
- "Character",+ #' CO2 <- CO2 |
||
| 443 | -! | +||
| 29 | +
- ifelse(is_single, "variable", "variables"),+ #' CO2[["primary_key"]] <- seq_len(nrow(CO2)) |
||
| 444 | -! | +||
| 30 | +
- paste0("(", paste(cols_names[check_char], collapse = ", "), ")"),
+ #' }) |
||
| 445 | -! | +||
| 31 | +
- ifelse(is_single, "was", "were"),+ #' join_keys(data) <- join_keys(join_key("CO2", "CO2", "primary_key"))
|
||
| 446 | -! | +||
| 32 | +
- "converted to",+ #' |
||
| 447 | -! | +||
| 33 | +
- ifelse(is_single, "factor.", "factors.")+ #' vars <- choices_selected(variable_choices(data[["CO2"]], c("Plant", "Type", "Treatment")))
|
||
| 448 | +34 |
- )+ #' |
|
| 449 | +35 |
- } else {
+ #' app <- init( |
|
| 450 | +36 |
- ""+ #' data = data, |
|
| 451 | +37 |
- }+ #' modules = modules( |
|
| 452 | +38 |
- })+ #' tm_outliers( |
|
| 453 | +39 |
-
+ #' outlier_var = list( |
|
| 454 | -! | +||
| 40 | +
- teal.widgets::verbatim_popup_srv(+ #' data_extract_spec( |
||
| 455 | -! | +||
| 41 | +
- id = "rcode",+ #' dataname = "CO2", |
||
| 456 | -! | +||
| 42 | +
- verbatim_content = reactive(teal.code::get_code(output_q())),+ #' select = select_spec( |
||
| 457 | -! | +||
| 43 | +
- title = "Show R Code for Scatterplotmatrix"+ #' label = "Select variable:", |
||
| 458 | +44 |
- )+ #' choices = variable_choices(data[["CO2"]], c("conc", "uptake")),
|
|
| 459 | +45 |
-
+ #' selected = "uptake", |
|
| 460 | +46 |
- ### REPORTER+ #' multiple = FALSE, |
|
| 461 | -! | +||
| 47 | +
- if (with_reporter) {
+ #' fixed = FALSE |
||
| 462 | -! | +||
| 48 | +
- card_fun <- function(comment, label) {
+ #' ) |
||
| 463 | -! | +||
| 49 | +
- card <- teal::report_card_template(+ #' ) |
||
| 464 | -! | +||
| 50 | +
- title = "Scatter Plot Matrix",+ #' ), |
||
| 465 | -! | +||
| 51 | +
- label = label,+ #' categorical_var = list( |
||
| 466 | -! | +||
| 52 | +
- with_filter = with_filter,+ #' data_extract_spec( |
||
| 467 | -! | +||
| 53 | +
- filter_panel_api = filter_panel_api+ #' dataname = "CO2", |
||
| 468 | +54 |
- )+ #' filter = filter_spec( |
|
| 469 | -! | +||
| 55 | +
- card$append_text("Plot", "header3")
+ #' vars = vars, |
||
| 470 | -! | +||
| 56 | +
- card$append_plot(plot_r(), dim = pws$dim())+ #' choices = value_choices(data[["CO2"]], vars$selected), |
||
| 471 | -! | +||
| 57 | +
- if (!comment == "") {
+ #' selected = value_choices(data[["CO2"]], vars$selected), |
||
| 472 | -! | +||
| 58 | +
- card$append_text("Comment", "header3")
+ #' multiple = TRUE |
||
| 473 | -! | +||
| 59 | +
- card$append_text(comment)+ #' ) |
||
| 474 | +60 |
- }+ #' ) |
|
| 475 | -! | +||
| 61 | +
- card$append_src(teal.code::get_code(output_q()))+ #' ) |
||
| 476 | -! | +||
| 62 | +
- card+ #' ) |
||
| 477 | +63 |
- }+ #' ) |
|
| 478 | -! | +||
| 64 | +
- teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
+ #' ) |
||
| 479 | +65 |
- }+ #' if (interactive()) {
|
|
| 480 | +66 |
- ###+ #' shinyApp(app$ui, app$server) |
|
| 481 | +67 |
- })+ #' } |
|
| 482 | +68 |
- }+ #' |
|
| 483 | +69 |
-
+ #' @examplesShinylive |
|
| 484 | +70 |
- #' Get stats for x-y pairs in scatterplot matrix+ #' library(teal.modules.general) |
|
| 485 | +71 |
- #'+ #' interactive <- function() TRUE |
|
| 486 | +72 |
- #' Uses [stats::cor.test()] per default for all numerical input variables and converts results+ #' {{ next_example }}
|
|
| 487 | +73 |
- #' to character vector.+ #' @examples |
|
| 488 | +74 |
- #' Could be extended if different stats for different variable types are needed.+ #' # CDISC data example |
|
| 489 | +75 |
- #' Meant to be called from [lattice::panel.text()].+ #' data <- teal_data() |
|
| 490 | +76 |
- #'+ #' data <- within(data, {
|
|
| 491 | +77 |
- #' Presently we need to use a formula input for `stats::cor.test` because+ #' ADSL <- rADSL |
|
| 492 | +78 |
- #' `na.fail` only gets evaluated when a formula is passed (see below).+ #' }) |
|
| 493 | +79 |
- #' ```+ #' join_keys(data) <- default_cdisc_join_keys[names(data)] |
|
| 494 | +80 |
- #' x = c(1,3,5,7,NA)+ #' |
|
| 495 | +81 |
- #' y = c(3,6,7,8,1)+ #' fact_vars_adsl <- names(Filter(isTRUE, sapply(data[["ADSL"]], is.factor))) |
|
| 496 | +82 |
- #' stats::cor.test(x, y, na.action = "na.fail")+ #' vars <- choices_selected(variable_choices(data[["ADSL"]], fact_vars_adsl)) |
|
| 497 | +83 |
- #' stats::cor.test(~ x + y, na.action = "na.fail")+ #' |
|
| 498 | +84 |
- #' ```+ #' app <- init( |
|
| 499 | +85 |
- #'+ #' data = data, |
|
| 500 | +86 |
- #' @param x,y (`numeric`) vectors of data values. `x` and `y` must have the same length.+ #' modules = modules( |
|
| 501 | +87 |
- #' @param .f (`function`) function that accepts x and y as formula input `~ x + y`.+ #' tm_outliers( |
|
| 502 | +88 |
- #' Default `stats::cor.test`.+ #' outlier_var = list( |
|
| 503 | +89 |
- #' @param .f_args (`list`) of arguments to be passed to `.f`.+ #' data_extract_spec( |
|
| 504 | +90 |
- #' @param round_stat (`integer(1)`) optional, number of decimal places to use when rounding the estimate.+ #' dataname = "ADSL", |
|
| 505 | +91 |
- #' @param round_pval (`integer(1)`) optional, number of decimal places to use when rounding the p-value.+ #' select = select_spec( |
|
| 506 | +92 |
- #'+ #' label = "Select variable:", |
|
| 507 | +93 |
- #' @return Character with stats. For [stats::cor.test()] correlation coefficient and p-value.+ #' choices = variable_choices(data[["ADSL"]], c("AGE", "BMRKR1")),
|
|
| 508 | +94 |
- #'+ #' selected = "AGE", |
|
| 509 | +95 |
- #' @examples+ #' multiple = FALSE, |
|
| 510 | +96 |
- #' set.seed(1)+ #' fixed = FALSE |
|
| 511 | +97 |
- #' x <- runif(25, 0, 1)+ #' ) |
|
| 512 | +98 |
- #' y <- runif(25, 0, 1)+ #' ) |
|
| 513 | +99 |
- #' x[c(3, 10, 18)] <- NA+ #' ), |
|
| 514 | +100 |
- #'+ #' categorical_var = list( |
|
| 515 | +101 |
- #' get_scatterplotmatrix_stats(x, y, .f = stats::cor.test, .f_args = list(method = "pearson"))+ #' data_extract_spec( |
|
| 516 | +102 |
- #' get_scatterplotmatrix_stats(x, y, .f = stats::cor.test, .f_args = list(+ #' dataname = "ADSL", |
|
| 517 | +103 |
- #' method = "pearson",+ #' filter = filter_spec( |
|
| 518 | +104 |
- #' na.action = na.fail+ #' vars = vars, |
|
| 519 | +105 |
- #' ))+ #' choices = value_choices(data[["ADSL"]], vars$selected), |
|
| 520 | +106 |
- #'+ #' selected = value_choices(data[["ADSL"]], vars$selected), |
|
| 521 | +107 |
- #' @export+ #' multiple = TRUE |
|
| 522 | +108 |
- #'+ #' ) |
|
| 523 | +109 |
- get_scatterplotmatrix_stats <- function(x, y,+ #' ) |
|
| 524 | +110 |
- .f = stats::cor.test,+ #' ) |
|
| 525 | +111 |
- .f_args = list(),+ #' ) |
|
| 526 | +112 |
- round_stat = 2,+ #' ) |
|
| 527 | +113 |
- round_pval = 4) {
+ #' ) |
|
| 528 | -6x | +||
| 114 | +
- if (is.numeric(x) && is.numeric(y)) {
+ #' if (interactive()) {
|
||
| 529 | -3x | +||
| 115 | +
- stat <- tryCatch(do.call(.f, c(list(~ x + y), .f_args)), error = function(e) NA)+ #' shinyApp(app$ui, app$server) |
||
| 530 | +116 |
-
+ #' } |
|
| 531 | -3x | +||
| 117 | +
- if (anyNA(stat)) {
+ #' |
||
| 532 | -1x | +||
| 118 | +
- return("NA")
+ #' @export |
||
| 533 | -2x | +||
| 119 | +
- } else if (all(c("estimate", "p.value") %in% names(stat))) {
+ #' |
||
| 534 | -2x | +||
| 120 | +
- return(paste(+ tm_outliers <- function(label = "Outliers Module", |
||
| 535 | -2x | +||
| 121 | +
- c(+ outlier_var, |
||
| 536 | -2x | +||
| 122 | +
- paste0(names(stat$estimate), ":", round(stat$estimate, round_stat)),+ categorical_var = NULL, |
||
| 537 | -2x | +||
| 123 | +
- paste0("P:", round(stat$p.value, round_pval))
+ ggtheme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void"),
|
||
| 538 | +124 |
- ),+ ggplot2_args = teal.widgets::ggplot2_args(), |
|
| 539 | -2x | +||
| 125 | +
- collapse = "\n"+ plot_height = c(600, 200, 2000), |
||
| 540 | +126 |
- ))+ plot_width = NULL, |
|
| 541 | +127 |
- } else {
+ pre_output = NULL,+ |
+ |
| 128 | ++ |
+ post_output = NULL) {
|
|
| 542 | +129 | ! |
- stop("function not supported")
+ message("Initializing tm_outliers")
|
| 543 | +130 |
- }+ |
|
| 544 | +131 |
- } else {
+ # Normalize the parameters |
|
| 545 | -3x | +||
| 132 | +! |
- if ("method" %in% names(.f_args)) {
+ if (inherits(outlier_var, "data_extract_spec")) outlier_var <- list(outlier_var) |
|
| 546 | -3x | +||
| 133 | +! |
- if (.f_args$method == "pearson") {
+ if (inherits(categorical_var, "data_extract_spec")) categorical_var <- list(categorical_var) |
|
| 547 | -1x | +||
| 134 | +! |
- return("cor:-")
+ if (inherits(ggplot2_args, "ggplot2_args")) ggplot2_args <- list(default = ggplot2_args) |
|
| 548 | +135 |
- }- |
- |
| 549 | -2x | -
- if (.f_args$method == "kendall") {
- |
- |
| 550 | -1x | -
- return("tau:-")
+
|
|
| 551 | +136 |
- }+ # Start of assertions |
|
| 552 | -1x | +||
| 137 | +! |
- if (.f_args$method == "spearman") {
+ checkmate::assert_string(label) |
|
| 553 | -1x | +||
| 138 | +! |
- return("rho:-")
+ checkmate::assert_list(outlier_var, types = "data_extract_spec") |
|
| 554 | +139 |
- }+ |
|
| 555 | -+ | ||
| 140 | +! |
- }+ checkmate::assert_list(categorical_var, types = "data_extract_spec", null.ok = TRUE) |
|
| 556 | +141 | ! |
- return("-")
+ if (is.list(categorical_var)) {
|
| 557 | -+ | ||
| 142 | +! |
- }+ lapply(categorical_var, function(x) {
|
|
| 558 | -+ | ||
| 143 | +! |
- }+ if (length(x$filter) > 1L) {
|
| 1 | -+ | ||
| 144 | +! |
- #' `teal` module: Data table viewer+ stop("tm_outliers: categorical_var data_extract_specs may only specify one filter_spec", call. = FALSE)
|
|
| 2 | +145 |
- #'+ } |
|
| 3 | +146 |
- #' Module provides a dynamic and interactive way to view `data.frame`s in a `teal` application.+ }) |
|
| 4 | +147 |
- #' It uses the `DT` package to display data tables in a paginated, searchable, and sortable format,+ } |
|
| 5 | +148 |
- #' which helps to enhance data exploration and analysis.+ |
|
| 6 | -+ | ||
| 149 | +! |
- #'+ ggtheme <- match.arg(ggtheme) |
|
| 7 | +150 |
- #' The `DT` package has an option `DT.TOJSON_ARGS` to show `Inf` and `NA` in data tables.+ |
|
| 8 | -+ | ||
| 151 | +! |
- #' Configure the `DT.TOJSON_ARGS` option via+ plot_choices <- c("Boxplot", "Density Plot", "Cumulative Distribution Plot")
|
|
| 9 | -+ | ||
| 152 | +! |
- #' `options(DT.TOJSON_ARGS = list(na = "string"))` before running the module.+ checkmate::assert_list(ggplot2_args, types = "ggplot2_args") |
|
| 10 | -+ | ||
| 153 | +! |
- #' Note though that sorting of numeric columns with `NA`/`Inf` will be lexicographic not numerical.+ checkmate::assert_subset(names(ggplot2_args), c("default", plot_choices))
|
|
| 11 | +154 |
- #'+ |
|
| 12 | -+ | ||
| 155 | +! |
- #' @inheritParams teal::module+ checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE) |
|
| 13 | -+ | ||
| 156 | +! |
- #' @inheritParams shared_params+ checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height") |
|
| 14 | -+ | ||
| 157 | +! |
- #' @param variables_selected (`named list`) Character vectors of the variables (i.e. columns)+ checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE) |
|
| 15 | -+ | ||
| 158 | +! |
- #' which should be initially shown for each dataset.+ checkmate::assert_numeric( |
|
| 16 | -+ | ||
| 159 | +! |
- #' Names of list elements should correspond to the names of the datasets available in the app.+ plot_width[1], |
|
| 17 | -+ | ||
| 160 | +! |
- #' If no entry is specified for a dataset, the first six variables from that+ lower = plot_width[2], upper = plot_width[3], null.ok = TRUE, .var.name = "plot_width" |
|
| 18 | +161 |
- #' dataset will initially be shown.+ ) |
|
| 19 | +162 |
- #' @param datasets_selected (`character`) A vector of datasets which should be+ |
|
| 20 | -+ | ||
| 163 | +! |
- #' shown and in what order. Names in the vector have to correspond with datasets names.+ checkmate::assert_multi_class(pre_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
|
|
| 21 | -+ | ||
| 164 | +! |
- #' If vector of `length == 0` (default) then all datasets are shown.+ checkmate::assert_multi_class(post_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
|
|
| 22 | +165 |
- #' Note: Only datasets of the `data.frame` class are compatible.+ # End of assertions |
|
| 23 | +166 |
- #' @param dt_args (`named list`) Additional arguments to be passed to [DT::datatable()]+ |
|
| 24 | +167 |
- #' (must not include `data` or `options`).+ # Make UI args |
|
| 25 | -+ | ||
| 168 | +! |
- #' @param dt_options (`named list`) The `options` argument to `DT::datatable`. By default+ args <- as.list(environment()) |
|
| 26 | +169 |
- #' `list(searching = FALSE, pageLength = 30, lengthMenu = c(5, 15, 30, 100), scrollX = TRUE)`+ |
|
| 27 | -+ | ||
| 170 | +! |
- #' @param server_rendering (`logical`) should the data table be rendered server side+ data_extract_list <- list( |
|
| 28 | -+ | ||
| 171 | +! |
- #' (see `server` argument of [DT::renderDataTable()])+ outlier_var = outlier_var, |
|
| 29 | -+ | ||
| 172 | +! |
- #'+ categorical_var = categorical_var |
|
| 30 | +173 |
- #' @inherit shared_params return+ ) |
|
| 31 | +174 |
- #'+ |
|
| 32 | -+ | ||
| 175 | +! |
- #' @examplesShinylive+ ans <- module( |
|
| 33 | -+ | ||
| 176 | +! |
- #' library(teal.modules.general)+ label = label, |
|
| 34 | -+ | ||
| 177 | +! |
- #' interactive <- function() TRUE+ server = srv_outliers, |
|
| 35 | -+ | ||
| 178 | +! |
- #' {{ next_example }}
+ server_args = c( |
|
| 36 | -+ | ||
| 179 | +! |
- #' @examples+ data_extract_list, |
|
| 37 | -+ | ||
| 180 | +! |
- #' # general data example+ list(plot_height = plot_height, plot_width = plot_width, ggplot2_args = ggplot2_args) |
|
| 38 | +181 |
- #' data <- teal_data()+ ), |
|
| 39 | -+ | ||
| 182 | +! |
- #' data <- within(data, {
+ ui = ui_outliers, |
|
| 40 | -+ | ||
| 183 | +! |
- #' require(nestcolor)+ ui_args = args, |
|
| 41 | -+ | ||
| 184 | +! |
- #' iris <- iris+ datanames = teal.transform::get_extract_datanames(data_extract_list) |
|
| 42 | +185 |
- #' })+ ) |
|
| 43 | -+ | ||
| 186 | +! |
- #' datanames(data) <- c("iris")
+ attr(ans, "teal_bookmarkable") <- TRUE |
|
| 44 | -+ | ||
| 187 | +! |
- #'+ ans |
|
| 45 | +188 |
- #' app <- init(+ } |
|
| 46 | +189 |
- #' data = data,+ |
|
| 47 | +190 |
- #' modules = modules(+ # UI function for the outliers module |
|
| 48 | +191 |
- #' tm_data_table(+ ui_outliers <- function(id, ...) {
|
|
| 49 | -- |
- #' variables_selected = list(- |
- |
| 50 | -- |
- #' iris = c("Sepal.Length", "Sepal.Width", "Petal.Length", "Petal.Width", "Species")
- |
- |
| 51 | -- |
- #' ),- |
- |
| 52 | -- |
- #' dt_args = list(caption = "IRIS Table Caption")- |
- |
| 53 | -- |
- #' )- |
- |
| 54 | -- |
- #' )- |
- |
| 55 | -- |
- #' )- |
- |
| 56 | -+ | ||
| 192 | +! |
- #' if (interactive()) {
+ args <- list(...) |
|
| 57 | -+ | ||
| 193 | +! |
- #' shinyApp(app$ui, app$server)+ ns <- NS(id) |
|
| 58 | -+ | ||
| 194 | +! |
- #' }+ is_single_dataset_value <- teal.transform::is_single_dataset(args$outlier_var, args$categorical_var) |
|
| 59 | +195 |
- #'+ |
|
| 60 | -+ | ||
| 196 | +! |
- #' @examplesShinylive+ teal.widgets::standard_layout( |
|
| 61 | -+ | ||
| 197 | +! |
- #' library(teal.modules.general)+ output = teal.widgets::white_small_well( |
|
| 62 | -+ | ||
| 198 | +! |
- #' interactive <- function() TRUE+ uiOutput(ns("total_outliers")),
|
|
| 63 | -+ | ||
| 199 | +! |
- #' {{ next_example }}
+ DT::dataTableOutput(ns("summary_table")),
|
|
| 64 | -+ | ||
| 200 | +! |
- #' @examples+ uiOutput(ns("total_missing")),
|
|
| 65 | -+ | ||
| 201 | +! |
- #' # CDISC data example+ tags$br(), tags$hr(), |
|
| 66 | -+ | ||
| 202 | +! |
- #' data <- teal_data()+ tabsetPanel( |
|
| 67 | -+ | ||
| 203 | +! |
- #' data <- within(data, {
+ id = ns("tabs"),
|
|
| 68 | -+ | ||
| 204 | +! |
- #' require(nestcolor)+ tabPanel( |
|
| 69 | -+ | ||
| 205 | +! |
- #' ADSL <- rADSL+ "Boxplot", |
|
| 70 | -+ | ||
| 206 | +! |
- #' })+ teal.widgets::plot_with_settings_ui(id = ns("box_plot"))
|
|
| 71 | +207 |
- #' datanames(data) <- "ADSL"+ ), |
|
| 72 | -+ | ||
| 208 | +! |
- #' join_keys(data) <- default_cdisc_join_keys[datanames(data)]+ tabPanel( |
|
| 73 | -+ | ||
| 209 | +! |
- #'+ "Density Plot", |
|
| 74 | -+ | ||
| 210 | +! |
- #' app <- init(+ teal.widgets::plot_with_settings_ui(id = ns("density_plot"))
|
|
| 75 | +211 |
- #' data = data,+ ), |
|
| 76 | -+ | ||
| 212 | +! |
- #' modules = modules(+ tabPanel( |
|
| 77 | -+ | ||
| 213 | +! |
- #' tm_data_table(+ "Cumulative Distribution Plot", |
|
| 78 | -+ | ||
| 214 | +! |
- #' variables_selected = list(ADSL = c("STUDYID", "USUBJID", "SUBJID", "SITEID", "AGE", "SEX")),
+ teal.widgets::plot_with_settings_ui(id = ns("cum_density_plot"))
|
|
| 79 | +215 |
- #' dt_args = list(caption = "ADSL Table Caption")+ ) |
|
| 80 | +216 |
- #' )+ ), |
|
| 81 | -+ | ||
| 217 | +! |
- #' )+ tags$br(), tags$hr(), |
|
| 82 | -+ | ||
| 218 | +! |
- #' )+ uiOutput(ns("table_ui_wrap")),
|
|
| 83 | -+ | ||
| 219 | +! |
- #' if (interactive()) {
+ DT::dataTableOutput(ns("table_ui"))
|
|
| 84 | +220 |
- #' shinyApp(app$ui, app$server)+ ), |
|
| 85 | -+ | ||
| 221 | +! |
- #' }+ encoding = tags$div( |
|
| 86 | +222 |
- #'+ ### Reporter |
|
| 87 | -+ | ||
| 223 | +! |
- #' @export+ teal.reporter::simple_reporter_ui(ns("simple_reporter")),
|
|
| 88 | +224 |
- #'+ ### |
|
| 89 | -+ | ||
| 225 | +! |
- tm_data_table <- function(label = "Data Table",+ tags$label("Encodings", class = "text-primary"),
|
|
| 90 | -+ | ||
| 226 | +! |
- variables_selected = list(),+ teal.transform::datanames_input(args[c("outlier_var", "categorical_var")]),
|
|
| 91 | -+ | ||
| 227 | +! |
- datasets_selected = character(0),+ teal.transform::data_extract_ui( |
|
| 92 | -+ | ||
| 228 | +! |
- dt_args = list(),+ id = ns("outlier_var"),
|
|
| 93 | -+ | ||
| 229 | +! |
- dt_options = list(+ label = "Variable", |
|
| 94 | -+ | ||
| 230 | +! |
- searching = FALSE,+ data_extract_spec = args$outlier_var, |
|
| 95 | -+ | ||
| 231 | +! |
- pageLength = 30,+ is_single_dataset = is_single_dataset_value |
|
| 96 | +232 |
- lengthMenu = c(5, 15, 30, 100),+ ), |
|
| 97 | -+ | ||
| 233 | +! |
- scrollX = TRUE+ if (!is.null(args$categorical_var)) {
|
|
| 98 | -+ | ||
| 234 | +! |
- ),+ teal.transform::data_extract_ui( |
|
| 99 | -+ | ||
| 235 | +! |
- server_rendering = FALSE,+ id = ns("categorical_var"),
|
|
| 100 | -+ | ||
| 236 | +! |
- pre_output = NULL,+ label = "Categorical factor", |
|
| 101 | -+ | ||
| 237 | +! |
- post_output = NULL) {
+ data_extract_spec = args$categorical_var, |
|
| 102 | +238 | ! |
- message("Initializing tm_data_table")
+ is_single_dataset = is_single_dataset_value |
| 103 | +239 |
-
+ ) |
|
| 104 | +240 |
- # Start of assertions+ }, |
|
| 105 | +241 | ! |
- checkmate::assert_string(label)+ conditionalPanel( |
| 106 | -+ | ||
| 242 | +! |
-
+ condition = paste0("input['", ns("tabs"), "'] == 'Boxplot'"),
|
|
| 107 | +243 | ! |
- checkmate::assert_list(variables_selected, min.len = 0, types = "character", names = "named")+ teal.widgets::optionalSelectInput( |
| 108 | +244 | ! |
- if (length(variables_selected) > 0) {
+ inputId = ns("boxplot_alts"),
|
| 109 | +245 | ! |
- lapply(seq_along(variables_selected), function(i) {
+ label = "Plot type", |
| 110 | +246 | ! |
- checkmate::assert_character(variables_selected[[i]], min.chars = 1, min.len = 1)+ choices = c("Box plot", "Violin plot"),
|
| 111 | +247 | ! |
- if (!is.null(names(variables_selected[[i]]))) {
+ selected = "Box plot", |
| 112 | +248 | ! |
- checkmate::assert_names(names(variables_selected[[i]]))+ multiple = FALSE |
| 113 | +249 |
- }+ ) |
|
| 114 | +250 |
- })+ ), |
|
| 115 | -+ | ||
| 251 | +! |
- }+ shinyjs::hidden(checkboxInput(ns("split_outliers"), "Define outliers based on group splitting", value = FALSE)),
|
|
| 116 | -+ | ||
| 252 | +! |
-
+ shinyjs::hidden(checkboxInput(ns("order_by_outlier"), "Re-order categories by outliers [by %]", value = FALSE)),
|
|
| 117 | +253 | ! |
- checkmate::assert_character(datasets_selected, min.len = 0, min.chars = 1)+ teal.widgets::panel_group( |
| 118 | +254 | ! |
- checkmate::assert(+ teal.widgets::panel_item( |
| 119 | +255 | ! |
- checkmate::check_list(dt_args, len = 0),+ title = "Method parameters", |
| 120 | +256 | ! |
- checkmate::check_subset(names(dt_args), choices = names(formals(DT::datatable)))+ collapsed = FALSE, |
| 121 | -+ | ||
| 257 | +! |
- )+ teal.widgets::optionalSelectInput( |
|
| 122 | +258 | ! |
- checkmate::assert_list(dt_options, names = "named")+ inputId = ns("method"),
|
| 123 | +259 | ! |
- checkmate::assert_flag(server_rendering)+ label = "Method", |
| 124 | +260 | ! |
- checkmate::assert_multi_class(pre_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
+ choices = c("IQR", "Z-score", "Percentile"),
|
| 125 | +261 | ! |
- checkmate::assert_multi_class(post_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
+ selected = "IQR", |
| 126 | -+ | ||
| 262 | +! |
- # End of assertions+ multiple = FALSE |
|
| 127 | +263 |
-
+ ), |
|
| 128 | +264 | ! |
- ans <- module(+ conditionalPanel( |
| 129 | +265 | ! |
- label,+ condition = |
| 130 | +266 | ! |
- server = srv_page_data_table,+ paste0("input['", ns("method"), "'] == 'IQR'"),
|
| 131 | +267 | ! |
- ui = ui_page_data_table,+ sliderInput( |
| 132 | +268 | ! |
- datanames = if (length(datasets_selected) == 0) "all" else datasets_selected,+ ns("iqr_slider"),
|
| 133 | +269 | ! |
- server_args = list(+ "Outlier range:", |
| 134 | +270 | ! |
- variables_selected = variables_selected,+ min = 1, |
| 135 | +271 | ! |
- datasets_selected = datasets_selected,+ max = 5, |
| 136 | +272 | ! |
- dt_args = dt_args,+ value = 3, |
| 137 | +273 | ! |
- dt_options = dt_options,+ step = 0.5 |
| 138 | -! | +||
| 274 | +
- server_rendering = server_rendering+ ) |
||
| 139 | +275 |
- ),+ ), |
|
| 140 | +276 | ! |
- ui_args = list(+ conditionalPanel( |
| 141 | +277 | ! |
- pre_output = pre_output,+ condition = |
| 142 | +278 | ! |
- post_output = post_output- |
-
| 143 | -- |
- )+ paste0("input['", ns("method"), "'] == 'Z-score'"),
|
|
| 144 | -+ | ||
| 279 | +! |
- )+ sliderInput( |
|
| 145 | +280 | ! |
- attr(ans, "teal_bookmarkable") <- TRUE+ ns("zscore_slider"),
|
| 146 | +281 | ! |
- ans+ "Outlier range:", |
| 147 | -+ | ||
| 282 | +! |
- }+ min = 1, |
|
| 148 | -+ | ||
| 283 | +! |
-
+ max = 5, |
|
| 149 | -+ | ||
| 284 | +! |
- # UI page module+ value = 3, |
|
| 150 | -+ | ||
| 285 | +! |
- ui_page_data_table <- function(id,+ step = 0.5 |
|
| 151 | +286 |
- pre_output = NULL,+ ) |
|
| 152 | +287 |
- post_output = NULL) {
+ ), |
|
| 153 | +288 | ! |
- ns <- NS(id)+ conditionalPanel( |
| 154 | -+ | ||
| 289 | +! |
-
+ condition = |
|
| 155 | +290 | ! |
- tagList(+ paste0("input['", ns("method"), "'] == 'Percentile'"),
|
| 156 | +291 | ! |
- include_css_files("custom"),
+ sliderInput( |
| 157 | +292 | ! |
- teal.widgets::standard_layout(+ ns("percentile_slider"),
|
| 158 | +293 | ! |
- output = teal.widgets::white_small_well(+ "Outlier range:", |
| 159 | +294 | ! |
- fluidRow(+ min = 0.001, |
| 160 | +295 | ! |
- column(+ max = 0.5, |
| 161 | +296 | ! |
- width = 12,+ value = 0.01, |
| 162 | +297 | ! |
- checkboxInput(+ step = 0.001 |
| 163 | -! | +||
| 298 | +
- ns("if_distinct"),
+ ) |
||
| 164 | -! | +||
| 299 | +
- "Show only distinct rows:",+ ), |
||
| 165 | +300 | ! |
- value = FALSE+ uiOutput(ns("ui_outlier_help"))
|
| 166 | +301 |
- )+ ) |
|
| 167 | +302 |
- )+ ), |
|
| 168 | -+ | ||
| 303 | +! |
- ),+ teal.widgets::panel_item( |
|
| 169 | +304 | ! |
- fluidRow(+ title = "Plot settings", |
| 170 | +305 | ! |
- class = "mb-8",+ selectInput( |
| 171 | +306 | ! |
- column(+ inputId = ns("ggtheme"),
|
| 172 | +307 | ! |
- width = 12,+ label = "Theme (by ggplot):", |
| 173 | +308 | ! |
- uiOutput(ns("dataset_table"))
+ choices = ggplot_themes, |
| 174 | -+ | ||
| 309 | +! |
- )+ selected = args$ggtheme,+ |
+ |
| 310 | +! | +
+ multiple = FALSE |
|
| 175 | +311 |
) |
|
| 176 | +312 |
- ),+ ) |
|
| 177 | -! | +||
| 313 | +
- pre_output = pre_output,+ ), |
||
| 178 | +314 | ! |
- post_output = post_output+ forms = tagList( |
| 179 | -+ | ||
| 315 | +! |
- )+ teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code")
|
|
| 180 | +316 |
- )+ ), |
|
| 181 | -+ | ||
| 317 | +! |
- }+ pre_output = args$pre_output, |
|
| 182 | -+ | ||
| 318 | +! |
-
+ post_output = args$post_output |
|
| 183 | +319 |
- # Server page module+ ) |
|
| 184 | +320 |
- srv_page_data_table <- function(id,+ } |
|
| 185 | +321 |
- data,+ |
|
| 186 | +322 |
- datasets_selected,+ # Server function for the outliers module |
|
| 187 | +323 |
- variables_selected,+ srv_outliers <- function(id, data, reporter, filter_panel_api, outlier_var, |
|
| 188 | +324 |
- dt_args,+ categorical_var, plot_height, plot_width, ggplot2_args) {
|
|
| 189 | -+ | ||
| 325 | +! |
- dt_options,+ with_reporter <- !missing(reporter) && inherits(reporter, "Reporter") |
|
| 190 | -+ | ||
| 326 | +! |
- server_rendering) {
+ with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI") |
|
| 191 | +327 | ! |
checkmate::assert_class(data, "reactive") |
| 192 | +328 | ! |
checkmate::assert_class(isolate(data()), "teal_data") |
| 193 | +329 | ! |
moduleServer(id, function(input, output, session) {
|
| 194 | +330 | ! |
teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.general") |
| 195 | +331 | ||
| 196 | +332 | ! |
- if_filtered <- reactive(as.logical(input$if_filtered))+ ns <- session$ns+ |
+
| 333 | ++ | + | |
| 197 | +334 | ! |
- if_distinct <- reactive(as.logical(input$if_distinct))+ vars <- list(outlier_var = outlier_var, categorical_var = categorical_var) |
| 198 | +335 | ||
| 199 | +336 | ! |
- datanames <- isolate(teal.data::datanames(data()))+ rule_diff <- function(other) {
|
| 200 | +337 | ! |
- datanames <- Filter(function(name) {
+ function(value) {
|
| 201 | +338 | ! |
- is.data.frame(isolate(data())[[name]])+ othervalue <- tryCatch(selector_list()[[other]]()[["select"]], error = function(e) NULL) |
| 202 | +339 | ! |
- }, datanames)- |
-
| 203 | -- |
-
+ if (!is.null(othervalue) && identical(othervalue, value)) {
|
|
| 204 | +340 | ! |
- if (!identical(datasets_selected, character(0))) {
+ "`Variable` and `Categorical factor` cannot be the same" |
| 205 | -! | +||
| 341 | +
- checkmate::assert_subset(datasets_selected, datanames)+ } |
||
| 206 | -! | +||
| 342 | +
- datanames <- datasets_selected+ } |
||
| 207 | +343 |
} |
|
| 208 | +344 | ||
| 209 | +345 | ! |
- output$dataset_table <- renderUI({
+ selector_list <- teal.transform::data_extract_multiple_srv( |
| 210 | +346 | ! |
- do.call(+ data_extract = vars, |
| 211 | +347 | ! |
- tabsetPanel,+ datasets = data, |
| 212 | +348 | ! |
- c(+ select_validation_rule = list( |
| 213 | +349 | ! |
- list(id = session$ns("dataname_tab")),
+ outlier_var = shinyvalidate::compose_rules( |
| 214 | +350 | ! |
- lapply(+ shinyvalidate::sv_required("Please select a variable"),
|
| 215 | +351 | ! |
- datanames,+ rule_diff("categorical_var")
|
| 216 | -! | +||
| 352 | +
- function(x) {
+ ), |
||
| 217 | +353 | ! |
- dataset <- isolate(data()[[x]])+ categorical_var = rule_diff("outlier_var")
+ |
+
| 354 | ++ |
+ )+ |
+ |
| 355 | ++ |
+ )+ |
+ |
| 356 | ++ | + | |
| 218 | +357 | ! |
- choices <- names(dataset)+ iv_r <- reactive({
|
| 219 | +358 | ! |
- labels <- vapply(+ iv <- shinyvalidate::InputValidator$new() |
| 220 | +359 | ! |
- dataset,+ iv$add_rule("method", shinyvalidate::sv_required("Please select a method"))
|
| 221 | +360 | ! |
- function(x) ifelse(is.null(attr(x, "label")), "", attr(x, "label")),+ iv$add_rule("boxplot_alts", shinyvalidate::sv_required("Please select Plot Type"))
|
| 222 | +361 | ! |
- character(1)+ teal.transform::compose_and_enable_validators(iv, selector_list) |
| 223 | +362 |
- )+ }) |
|
| 224 | -! | +||
| 363 | +
- names(choices) <- ifelse(+ |
||
| 225 | +364 | ! |
- is.na(labels) | labels == "",+ reactive_select_input <- reactive({
|
| 226 | +365 | ! |
- choices,+ if (is.null(selector_list()$categorical_var) || length(selector_list()$categorical_var()$select) == 0) {
|
| 227 | +366 | ! |
- paste(choices, labels, sep = ": ")+ selector_list()[names(selector_list()) != "categorical_var"] |
| 228 | +367 |
- )- |
- |
| 229 | -! | -
- variables_selected <- if (!is.null(variables_selected[[x]])) {
+ } else {
|
|
| 230 | +368 | ! |
- variables_selected[[x]]+ selector_list() |
| 231 | +369 |
- } else {
+ } |
|
| 232 | -! | +||
| 370 | +
- utils::head(choices)+ }) |
||
| 233 | +371 |
- }+ |
|
| 234 | +372 | ! |
- tabPanel(+ anl_merged_input <- teal.transform::merge_expression_srv( |
| 235 | +373 | ! |
- title = x,+ selector_list = reactive_select_input, |
| 236 | +374 | ! |
- column(+ datasets = data, |
| 237 | +375 | ! |
- width = 12,+ merge_function = "dplyr::inner_join" |
| 238 | -! | +||
| 376 | +
- div(+ ) |
||
| 239 | -! | +||
| 377 | +
- class = "mt-4",+ |
||
| 240 | +378 | ! |
- ui_data_table(+ anl_merged_q <- reactive({
|
| 241 | +379 | ! |
- id = session$ns(x),+ req(anl_merged_input()) |
| 242 | +380 | ! |
- choices = choices,+ data() %>% |
| 243 | +381 | ! |
- selected = variables_selected- |
-
| 244 | -- |
- )- |
- |
| 245 | -- |
- )- |
- |
| 246 | -- |
- )+ teal.code::eval_code(as.expression(anl_merged_input()$expr)) |
|
| 247 | +382 |
- )+ }) |
|
| 248 | +383 |
- }+ |
|
| 249 | -+ | ||
| 384 | +! |
- )+ merged <- list( |
|
| 250 | -+ | ||
| 385 | +! |
- )+ anl_input_r = anl_merged_input, |
|
| 251 | -+ | ||
| 386 | +! |
- )+ anl_q_r = anl_merged_q |
|
| 252 | +387 |
- })+ ) |
|
| 253 | +388 | ||
| 254 | +389 | ! |
- lapply(+ n_outlier_missing <- reactive({
|
| 255 | +390 | ! |
- datanames,+ req(iv_r()$is_valid()) |
| 256 | +391 | ! |
- function(x) {
+ outlier_var <- as.vector(merged$anl_input_r()$columns_source$outlier_var) |
| 257 | +392 | ! |
- srv_data_table(+ ANL <- merged$anl_q_r()[["ANL"]] |
| 258 | +393 | ! |
- id = x,+ sum(is.na(ANL[[outlier_var]])) |
| 259 | -! | +||
| 394 | +
- data = data,+ }) |
||
| 260 | -! | +||
| 395 | +
- dataname = x,+ |
||
| 261 | -! | +||
| 396 | +
- if_filtered = if_filtered,+ # Used to create outlier table and the dropdown with additional columns |
||
| 262 | +397 | ! |
- if_distinct = if_distinct,+ dataname_first <- isolate(names(data())[[1]]) |
| 263 | -! | +||
| 398 | +
- dt_args = dt_args,+ |
||
| 264 | +399 | ! |
- dt_options = dt_options,+ common_code_q <- reactive({
|
| 265 | +400 | ! |
- server_rendering = server_rendering- |
-
| 266 | -- |
- )+ req(iv_r()$is_valid()) |
|
| 267 | +401 |
- }+ |
|
| 268 | -+ | ||
| 402 | +! |
- )+ ANL <- merged$anl_q_r()[["ANL"]] |
|
| 269 | -+ | ||
| 403 | +! |
- })+ qenv <- merged$anl_q_r() |
|
| 270 | +404 |
- }+ |
|
| 271 | -+ | ||
| 405 | +! |
-
+ outlier_var <- as.vector(merged$anl_input_r()$columns_source$outlier_var) |
|
| 272 | -+ | ||
| 406 | +! |
- # UI function for the data_table module+ categorical_var <- as.vector(merged$anl_input_r()$columns_source$categorical_var) |
|
| 273 | -+ | ||
| 407 | +! |
- ui_data_table <- function(id,+ order_by_outlier <- input$order_by_outlier |
|
| 274 | -+ | ||
| 408 | +! |
- choices,+ method <- input$method |
|
| 275 | -+ | ||
| 409 | +! |
- selected) {
+ split_outliers <- input$split_outliers |
|
| 276 | +410 | ! |
- ns <- NS(id)+ teal::validate_has_data( |
| 277 | +411 |
-
+ # missing values in the categorical variable may be used to form a category of its own |
|
| 278 | +412 | ! |
- if (!is.null(selected)) {
+ `if`( |
| 279 | +413 | ! |
- all_choices <- choices+ length(categorical_var) == 0, |
| 280 | +414 | ! |
- choices <- c(selected, setdiff(choices, selected))+ ANL, |
| 281 | +415 | ! |
- names(choices) <- names(all_choices)[match(choices, all_choices)]+ ANL[, names(ANL) != categorical_var, drop = FALSE] |
| 282 | +416 |
- }+ ), |
|
| 283 | -+ | ||
| 417 | +! |
-
+ min_nrow = 10, |
|
| 284 | +418 | ! |
- tagList(+ complete = TRUE, |
| 285 | +419 | ! |
- teal.widgets::get_dt_rows(ns("data_table"), ns("dt_rows")),
+ allow_inf = FALSE |
| 286 | -! | +||
| 420 | +
- fluidRow(+ ) |
||
| 287 | +421 | ! |
- teal.widgets::optionalSelectInput(+ validate(need(is.numeric(ANL[[outlier_var]]), "`Variable` is not numeric")) |
| 288 | +422 | ! |
- ns("variables"),
+ validate(need(length(unique(ANL[[outlier_var]])) > 1, "Variable has no variation, i.e. only one unique value")) |
| 289 | -! | +||
| 423 | +
- "Select variables:",+ |
||
| 290 | -! | +||
| 424 | +
- choices = choices,+ # show/hide split_outliers |
||
| 291 | +425 | ! |
- selected = selected,+ if (length(categorical_var) == 0) {
|
| 292 | +426 | ! |
- multiple = TRUE,+ shinyjs::hide("split_outliers")
|
| 293 | +427 | ! |
- width = "100%"+ if (n_outlier_missing() > 0) {
|
| 294 | -+ | ||
| 428 | +! |
- )+ qenv <- teal.code::eval_code( |
|
| 295 | -+ | ||
| 429 | +! |
- ),+ qenv, |
|
| 296 | +430 | ! |
- fluidRow(+ substitute( |
| 297 | +431 | ! |
- DT::dataTableOutput(ns("data_table"), width = "100%")
+ expr = ANL <- ANL %>% dplyr::filter(!is.na(outlier_var_name)), |
| 298 | -+ | ||
| 432 | +! |
- )+ env = list(outlier_var_name = as.name(outlier_var)) |
|
| 299 | +433 |
- )+ ) |
|
| 300 | +434 |
- }+ ) |
|
| 301 | +435 |
-
+ } |
|
| 302 | +436 |
- # Server function for the data_table module+ } else {
|
|
| 303 | -+ | ||
| 437 | +! |
- srv_data_table <- function(id,+ validate(need( |
|
| 304 | -+ | ||
| 438 | +! |
- data,+ is.factor(ANL[[categorical_var]]) || |
|
| 305 | -+ | ||
| 439 | +! |
- dataname,+ is.character(ANL[[categorical_var]]) || |
|
| 306 | -+ | ||
| 440 | +! |
- if_filtered,+ is.integer(ANL[[categorical_var]]), |
|
| 307 | -+ | ||
| 441 | +! |
- if_distinct,+ "`Categorical factor` must be `factor`, `character`, or `integer`" |
|
| 308 | +442 |
- dt_args,+ )) |
|
| 309 | +443 |
- dt_options,+ |
|
| 310 | -+ | ||
| 444 | +! |
- server_rendering) {
+ if (n_outlier_missing() > 0) {
|
|
| 311 | +445 | ! |
- moduleServer(id, function(input, output, session) {
+ qenv <- teal.code::eval_code( |
| 312 | +446 | ! |
- iv <- shinyvalidate::InputValidator$new()+ qenv, |
| 313 | +447 | ! |
- iv$add_rule("variables", shinyvalidate::sv_required("Please select valid variable names"))
+ substitute( |
| 314 | +448 | ! |
- iv$add_rule("variables", shinyvalidate::sv_in_set(
+ expr = ANL <- ANL %>% dplyr::filter(!is.na(outlier_var_name)), |
| 315 | +449 | ! |
- set = names(isolate(data())[[dataname]]), message_fmt = "Not all selected variables exist in the data"+ env = list(outlier_var_name = as.name(outlier_var)) |
| 316 | +450 |
- ))+ ) |
|
| 317 | -! | +||
| 451 | +
- iv$enable()+ ) |
||
| 318 | +452 |
-
+ } |
|
| 319 | +453 | ! |
- output$data_table <- DT::renderDataTable(server = server_rendering, {
+ shinyjs::show("split_outliers")
|
| 320 | -! | +||
| 454 | +
- teal::validate_inputs(iv)+ } |
||
| 321 | +455 | ||
| 322 | -! | +||
| 456 | +
- df <- data()[[dataname]]+ # slider |
||
| 323 | +457 | ! |
- variables <- input$variables+ outlier_definition_param <- if (method == "IQR") {
|
| 324 | -+ | ||
| 458 | +! |
-
+ input$iqr_slider |
|
| 325 | +459 | ! |
- teal::validate_has_data(df, min_nrow = 1L, msg = paste("data", dataname, "is empty"))
+ } else if (method == "Z-score") {
|
| 326 | -+ | ||
| 460 | +! |
-
+ input$zscore_slider |
|
| 327 | +461 | ! |
- dataframe_selected <- if (if_distinct()) {
+ } else if (method == "Percentile") {
|
| 328 | +462 | ! |
- dplyr::count(df, dplyr::across(dplyr::all_of(variables)))+ input$percentile_slider |
| 329 | +463 |
- } else {
- |
- |
| 330 | -! | -
- df[variables]+ } |
|
| 331 | +464 |
- }+ |
|
| 332 | +465 |
-
+ # this is utils function that converts a %>% NULL %>% b into a %>% b |
|
| 333 | +466 | ! |
- dt_args$options <- dt_options+ remove_pipe_null <- function(x) {
|
| 334 | +467 | ! |
- if (!is.null(input$dt_rows)) {
+ if (length(x) == 1) {
|
| 335 | +468 | ! |
- dt_args$options$pageLength <- input$dt_rows+ return(x) |
| 336 | +469 |
- }+ } |
|
| 337 | +470 | ! |
- dt_args$data <- dataframe_selected- |
-
| 338 | -- |
-
+ if (identical(x[[1]], as.name("%>%")) && is.null(x[[3]])) {
|
|
| 339 | +471 | ! |
- do.call(DT::datatable, dt_args)+ return(remove_pipe_null(x[[2]])) |
| 340 | +472 |
- })+ } |
|
| 341 | -+ | ||
| 473 | +! |
- })+ return(as.call(c(x[[1]], lapply(x[-1], remove_pipe_null)))) |
|
| 342 | +474 |
- }+ } |
| 1 | +475 |
- #' `teal` module: Cross-table+ |
|
| 2 | -+ | ||
| 476 | +! |
- #'+ qenv <- teal.code::eval_code( |
|
| 3 | -+ | ||
| 477 | +! |
- #' Generates a simple cross-table of two variables from a dataset with custom+ qenv, |
|
| 4 | -+ | ||
| 478 | +! |
- #' options for showing percentages and sub-totals.+ substitute( |
|
| 5 | -+ | ||
| 479 | +! |
- #'+ expr = {
|
|
| 6 | -+ | ||
| 480 | +! |
- #' @inheritParams teal::module+ ANL_OUTLIER <- ANL %>% |
|
| 7 | -+ | ||
| 481 | +! |
- #' @inheritParams shared_params+ group_expr %>% # styler: off |
|
| 8 | -+ | ||
| 482 | +! |
- #' @param x (`data_extract_spec` or `list` of multiple `data_extract_spec`)+ dplyr::mutate(is_outlier = {
|
|
| 9 | -+ | ||
| 483 | +! |
- #' Object with all available choices with pre-selected option for variable X - row values.+ q1_q3 <- stats::quantile(outlier_var_name, probs = c(0.25, 0.75)) |
|
| 10 | -+ | ||
| 484 | +! |
- #' In case of `data_extract_spec` use `select_spec(..., ordered = TRUE)` if table elements should be+ iqr <- q1_q3[2] - q1_q3[1] |
|
| 11 | -+ | ||
| 485 | +! |
- #' rendered according to selection order.+ !(outlier_var_name >= q1_q3[1] - 1.5 * iqr & outlier_var_name <= q1_q3[2] + 1.5 * iqr) |
|
| 12 | +486 |
- #' @param y (`data_extract_spec` or `list` of multiple `data_extract_spec`)+ }) %>% |
|
| 13 | -+ | ||
| 487 | +! |
- #' Object with all available choices with pre-selected option for variable Y - column values.+ calculate_outliers %>% # styler: off |
|
| 14 | -+ | ||
| 488 | +! |
- #'+ ungroup_expr %>% # styler: off |
|
| 15 | -+ | ||
| 489 | +! |
- #' `data_extract_spec` must not allow multiple selection in this case.+ dplyr::filter(is_outlier | is_outlier_selected) %>% |
|
| 16 | -+ | ||
| 490 | +! |
- #' @param show_percentage (`logical(1)`)+ dplyr::select(-is_outlier) |
|
| 17 | +491 |
- #' Indicates whether to show percentages (relevant only when `x` is a `factor`).+ }, |
|
| 18 | -+ | ||
| 492 | +! |
- #' Defaults to `TRUE`.+ env = list( |
|
| 19 | -+ | ||
| 493 | +! |
- #' @param show_total (`logical(1)`)+ calculate_outliers = if (method == "IQR") {
|
|
| 20 | -+ | ||
| 494 | +! |
- #' Indicates whether to show total column.+ substitute( |
|
| 21 | -+ | ||
| 495 | +! |
- #' Defaults to `TRUE`.+ expr = dplyr::mutate(is_outlier_selected = {
|
|
| 22 | -+ | ||
| 496 | +! |
- #'+ q1_q3 <- stats::quantile(outlier_var_name, probs = c(0.25, 0.75)) |
|
| 23 | -+ | ||
| 497 | +! |
- #' @note For more examples, please see the vignette "Using cross table" via+ iqr <- q1_q3[2] - q1_q3[1] |
|
| 24 | +498 |
- #' `vignette("using-cross-table", package = "teal.modules.general")`.
+ !( |
|
| 25 | -+ | ||
| 499 | +! |
- #'+ outlier_var_name >= q1_q3[1] - outlier_definition_param * iqr & |
|
| 26 | -+ | ||
| 500 | +! |
- #' @inherit shared_params return+ outlier_var_name <= q1_q3[2] + outlier_definition_param * iqr |
|
| 27 | +501 |
- #'+ ) |
|
| 28 | +502 |
- #' @examplesShinylive+ }), |
|
| 29 | -+ | ||
| 503 | +! |
- #' library(teal.modules.general)+ env = list( |
|
| 30 | -+ | ||
| 504 | +! |
- #' interactive <- function() TRUE+ outlier_var_name = as.name(outlier_var), |
|
| 31 | -+ | ||
| 505 | +! |
- #' {{ next_example }}
+ outlier_definition_param = outlier_definition_param |
|
| 32 | +506 |
- #' @examplesIf require("rtables", quietly = TRUE)
+ ) |
|
| 33 | +507 |
- #' # general data example+ ) |
|
| 34 | -+ | ||
| 508 | +! |
- #' data <- teal_data()+ } else if (method == "Z-score") {
|
|
| 35 | -+ | ||
| 509 | +! |
- #' data <- within(data, {
+ substitute( |
|
| 36 | -+ | ||
| 510 | +! |
- #' mtcars <- mtcars+ expr = dplyr::mutate( |
|
| 37 | -+ | ||
| 511 | +! |
- #' for (v in c("cyl", "vs", "am", "gear")) {
+ is_outlier_selected = abs(outlier_var_name - mean(outlier_var_name)) / |
|
| 38 | -+ | ||
| 512 | +! |
- #' mtcars[[v]] <- as.factor(mtcars[[v]])+ stats::sd(outlier_var_name) > outlier_definition_param |
|
| 39 | +513 |
- #' }+ ), |
|
| 40 | -+ | ||
| 514 | +! |
- #' mtcars[["primary_key"]] <- seq_len(nrow(mtcars))+ env = list( |
|
| 41 | -+ | ||
| 515 | +! |
- #' })+ outlier_var_name = as.name(outlier_var), |
|
| 42 | -+ | ||
| 516 | +! |
- #' datanames(data) <- "mtcars"+ outlier_definition_param = outlier_definition_param |
|
| 43 | +517 |
- #' join_keys(data) <- join_keys(join_key("mtcars", "mtcars", "primary_key"))
+ ) |
|
| 44 | +518 |
- #'+ ) |
|
| 45 | -+ | ||
| 519 | +! |
- #' app <- init(+ } else if (method == "Percentile") {
|
|
| 46 | -+ | ||
| 520 | +! |
- #' data = data,+ substitute( |
|
| 47 | -+ | ||
| 521 | +! |
- #' modules = modules(+ expr = dplyr::mutate( |
|
| 48 | -+ | ||
| 522 | +! |
- #' tm_t_crosstable(+ is_outlier_selected = outlier_var_name < stats::quantile(outlier_var_name, outlier_definition_param) | |
|
| 49 | -+ | ||
| 523 | +! |
- #' label = "Cross Table",+ outlier_var_name > stats::quantile(outlier_var_name, 1 - outlier_definition_param) |
|
| 50 | +524 |
- #' x = data_extract_spec(+ ), |
|
| 51 | -+ | ||
| 525 | +! |
- #' dataname = "mtcars",+ env = list( |
|
| 52 | -+ | ||
| 526 | +! |
- #' select = select_spec(+ outlier_var_name = as.name(outlier_var), |
|
| 53 | -+ | ||
| 527 | +! |
- #' label = "Select variable:",+ outlier_definition_param = outlier_definition_param |
|
| 54 | +528 |
- #' choices = variable_choices(data[["mtcars"]], c("cyl", "vs", "am", "gear")),
+ ) |
|
| 55 | +529 |
- #' selected = c("cyl", "gear"),
+ ) |
|
| 56 | +530 |
- #' multiple = TRUE,+ }, |
|
| 57 | -+ | ||
| 531 | +! |
- #' ordered = TRUE,+ outlier_var_name = as.name(outlier_var), |
|
| 58 | -+ | ||
| 532 | +! |
- #' fixed = FALSE+ group_expr = if (isTRUE(split_outliers) && length(categorical_var) != 0) {
|
|
| 59 | -+ | ||
| 533 | +! |
- #' )+ substitute(dplyr::group_by(x), list(x = as.name(categorical_var))) |
|
| 60 | +534 |
- #' ),+ }, |
|
| 61 | -+ | ||
| 535 | +! |
- #' y = data_extract_spec(+ ungroup_expr = if (isTRUE(split_outliers) && length(categorical_var) != 0) {
|
|
| 62 | -+ | ||
| 536 | +! |
- #' dataname = "mtcars",+ substitute(dplyr::ungroup()) |
|
| 63 | +537 |
- #' select = select_spec(+ } |
|
| 64 | +538 |
- #' label = "Select variable:",+ ) |
|
| 65 | +539 |
- #' choices = variable_choices(data[["mtcars"]], c("cyl", "vs", "am", "gear")),
+ ) %>% |
|
| 66 | -+ | ||
| 540 | +! |
- #' selected = "vs",+ remove_pipe_null() |
|
| 67 | +541 |
- #' multiple = FALSE,+ ) |
|
| 68 | +542 |
- #' fixed = FALSE+ |
|
| 69 | +543 |
- #' )+ # ANL_OUTLIER_EXTENDED is the base table |
|
| 70 | -+ | ||
| 544 | +! |
- #' )+ qenv <- teal.code::eval_code( |
|
| 71 | -+ | ||
| 545 | +! |
- #' )+ qenv, |
|
| 72 | -+ | ||
| 546 | +! |
- #' )+ substitute( |
|
| 73 | -+ | ||
| 547 | +! |
- #' )+ expr = {
|
|
| 74 | -+ | ||
| 548 | +! |
- #' if (interactive()) {
+ ANL_OUTLIER_EXTENDED <- dplyr::left_join( |
|
| 75 | -+ | ||
| 549 | +! |
- #' shinyApp(app$ui, app$server)+ ANL_OUTLIER, |
|
| 76 | -+ | ||
| 550 | +! |
- #' }+ dplyr::select( |
|
| 77 | -+ | ||
| 551 | +! |
- #'+ dataname, |
|
| 78 | -+ | ||
| 552 | +! |
- #' @examplesShinylive+ dplyr::setdiff(names(dataname), dplyr::setdiff(names(ANL_OUTLIER), join_keys)) |
|
| 79 | +553 |
- #' library(teal.modules.general)+ ), |
|
| 80 | -+ | ||
| 554 | +! |
- #' interactive <- function() TRUE+ by = join_keys |
|
| 81 | +555 |
- #' {{ next_example }}
+ ) |
|
| 82 | +556 |
- #' @examplesIf require("rtables", quietly = TRUE)
+ }, |
|
| 83 | -+ | ||
| 557 | +! |
- #' # CDISC data example+ env = list( |
|
| 84 | -+ | ||
| 558 | +! |
- #' data <- teal_data()+ dataname = as.name(dataname_first), |
|
| 85 | -+ | ||
| 559 | +! |
- #' data <- within(data, {
+ join_keys = as.character(teal.data::join_keys(data())[dataname_first, dataname_first]) |
|
| 86 | +560 |
- #' ADSL <- rADSL+ ) |
|
| 87 | +561 |
- #' })+ ) |
|
| 88 | +562 |
- #' datanames(data) <- "ADSL"+ ) |
|
| 89 | +563 |
- #' join_keys(data) <- default_cdisc_join_keys[datanames(data)]+ |
|
| 90 | -+ | ||
| 564 | +! |
- #'+ if (length(categorical_var) > 0) {
|
|
| 91 | -+ | ||
| 565 | +! |
- #' app <- init(+ qenv <- teal.code::eval_code( |
|
| 92 | -+ | ||
| 566 | +! |
- #' data = data,+ qenv, |
|
| 93 | -+ | ||
| 567 | +! |
- #' modules = modules(+ substitute( |
|
| 94 | -+ | ||
| 568 | +! |
- #' tm_t_crosstable(+ expr = summary_table_pre <- ANL_OUTLIER %>% |
|
| 95 | -+ | ||
| 569 | +! |
- #' label = "Cross Table",+ dplyr::filter(is_outlier_selected) %>% |
|
| 96 | -+ | ||
| 570 | +! |
- #' x = data_extract_spec(+ dplyr::select(outlier_var_name, categorical_var_name) %>% |
|
| 97 | -+ | ||
| 571 | +! |
- #' dataname = "ADSL",+ dplyr::group_by(categorical_var_name) %>% |
|
| 98 | -+ | ||
| 572 | +! |
- #' select = select_spec(+ dplyr::summarise(n_outliers = dplyr::n()) %>% |
|
| 99 | -+ | ||
| 573 | +! |
- #' label = "Select variable:",+ dplyr::right_join( |
|
| 100 | -+ | ||
| 574 | +! |
- #' choices = variable_choices(data[["ADSL"]], subset = function(data) {
+ ANL %>% |
|
| 101 | -+ | ||
| 575 | +! |
- #' idx <- !vapply(data, inherits, logical(1), c("Date", "POSIXct", "POSIXlt"))
+ dplyr::select(outlier_var_name, categorical_var_name) %>% |
|
| 102 | -+ | ||
| 576 | +! |
- #' return(names(data)[idx])+ dplyr::group_by(categorical_var_name) %>% |
|
| 103 | -+ | ||
| 577 | +! |
- #' }),+ dplyr::summarise( |
|
| 104 | -+ | ||
| 578 | +! |
- #' selected = "COUNTRY",+ total_in_cat = dplyr::n(), |
|
| 105 | -+ | ||
| 579 | +! |
- #' multiple = TRUE,+ n_na = sum(is.na(outlier_var_name) | is.na(categorical_var_name)) |
|
| 106 | +580 |
- #' ordered = TRUE,+ ), |
|
| 107 | -+ | ||
| 581 | +! |
- #' fixed = FALSE+ by = categorical_var |
|
| 108 | +582 |
- #' )+ ) %>% |
|
| 109 | +583 |
- #' ),+ # This is important as there may be categorical variables with natural orderings, e.g. AGE. |
|
| 110 | +584 |
- #' y = data_extract_spec(+ # The plots should be displayed by default in increasing order in these situations. |
|
| 111 | +585 |
- #' dataname = "ADSL",+ # dplyr::arrange will sort integer, factor, and character data types in the expected way. |
|
| 112 | -+ | ||
| 586 | +! |
- #' select = select_spec(+ dplyr::arrange(categorical_var_name) %>% |
|
| 113 | -+ | ||
| 587 | +! |
- #' label = "Select variable:",+ dplyr::mutate( |
|
| 114 | -+ | ||
| 588 | +! |
- #' choices = variable_choices(data[["ADSL"]], subset = function(data) {
+ n_outliers = dplyr::if_else(is.na(n_outliers), 0, as.numeric(n_outliers)), |
|
| 115 | -+ | ||
| 589 | +! |
- #' idx <- vapply(data, is.factor, logical(1))+ display_str = dplyr::if_else( |
|
| 116 | -+ | ||
| 590 | +! |
- #' return(names(data)[idx])+ n_outliers > 0, |
|
| 117 | -+ | ||
| 591 | +! |
- #' }),+ sprintf("%d [%.02f%%]", n_outliers, 100 * n_outliers / total_in_cat),
|
|
| 118 | -+ | ||
| 592 | +! |
- #' selected = "SEX",+ "0" |
|
| 119 | +593 |
- #' multiple = FALSE,+ ), |
|
| 120 | -+ | ||
| 594 | +! |
- #' fixed = FALSE+ display_str_na = dplyr::if_else( |
|
| 121 | -+ | ||
| 595 | +! |
- #' )+ n_na > 0, |
|
| 122 | -+ | ||
| 596 | +! |
- #' )+ sprintf("%d [%.02f%%]", n_na, 100 * n_na / total_in_cat),
|
|
| 123 | -+ | ||
| 597 | +! |
- #' )+ "0" |
|
| 124 | +598 |
- #' )+ ), |
|
| 125 | -+ | ||
| 599 | +! |
- #' )+ order = seq_along(n_outliers) |
|
| 126 | +600 |
- #' if (interactive()) {
+ ), |
|
| 127 | -+ | ||
| 601 | +! |
- #' shinyApp(app$ui, app$server)+ env = list( |
|
| 128 | -+ | ||
| 602 | +! |
- #' }+ categorical_var = categorical_var, |
|
| 129 | -+ | ||
| 603 | +! |
- #'+ categorical_var_name = as.name(categorical_var), |
|
| 130 | -+ | ||
| 604 | +! |
- #' @export+ outlier_var_name = as.name(outlier_var) |
|
| 131 | +605 |
- #'+ ) |
|
| 132 | +606 |
- tm_t_crosstable <- function(label = "Cross Table",+ ) |
|
| 133 | +607 |
- x,+ ) |
|
| 134 | +608 |
- y,+ # now to handle when user chooses to order based on amount of outliers |
|
| 135 | -+ | ||
| 609 | +! |
- show_percentage = TRUE,+ if (order_by_outlier) {
|
|
| 136 | -+ | ||
| 610 | +! |
- show_total = TRUE,- |
- |
| 137 | -- |
- pre_output = NULL,- |
- |
| 138 | -- |
- post_output = NULL,- |
- |
| 139 | -- |
- basic_table_args = teal.widgets::basic_table_args()) {
+ qenv <- teal.code::eval_code( |
|
| 140 | +611 | ! |
- message("Initializing tm_t_crosstable")
+ qenv, |
| 141 | -+ | ||
| 612 | +! |
-
+ quote( |
|
| 142 | -+ | ||
| 613 | +! |
- # Requires Suggested packages+ summary_table_pre <- summary_table_pre %>% |
|
| 143 | +614 | ! |
- if (!requireNamespace("rtables", quietly = TRUE)) {
+ dplyr::arrange(desc(n_outliers / total_in_cat)) %>% |
| 144 | +615 | ! |
- stop("Cannot load rtables - please install the package or restart your session.")
+ dplyr::mutate(order = seq_len(nrow(summary_table_pre))) |
| 145 | +616 |
- }+ ) |
|
| 146 | +617 |
-
+ ) |
|
| 147 | +618 |
- # Normalize the parameters- |
- |
| 148 | -! | -
- if (inherits(x, "data_extract_spec")) x <- list(x)- |
- |
| 149 | -! | -
- if (inherits(y, "data_extract_spec")) y <- list(y)+ } |
|
| 150 | +619 | ||
| 151 | -- |
- # Start of assertions- |
- |
| 152 | +620 | ! |
- checkmate::assert_string(label)+ qenv <- teal.code::eval_code( |
| 153 | +621 | ! |
- checkmate::assert_list(x, types = "data_extract_spec")+ qenv, |
| 154 | -+ | ||
| 622 | +! |
-
+ substitute( |
|
| 155 | +623 | ! |
- checkmate::assert_list(y, types = "data_extract_spec")+ expr = {
|
| 156 | -! | +||
| 624 | +
- assert_single_selection(y)+ # In order for geom_rug to work properly when reordering takes place inside facet_grid, |
||
| 157 | +625 |
-
+ # all tables must have the column used for reording. |
|
| 158 | -! | +||
| 626 | +
- checkmate::assert_flag(show_percentage)+ # In this case, the column used for reordering is `order`. |
||
| 159 | +627 | ! |
- checkmate::assert_flag(show_total)+ ANL_OUTLIER <- dplyr::left_join( |
| 160 | +628 | ! |
- checkmate::assert_multi_class(pre_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
+ ANL_OUTLIER, |
| 161 | +629 | ! |
- checkmate::assert_multi_class(post_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
+ summary_table_pre[, c("order", categorical_var)],
|
| 162 | +630 | ! |
- checkmate::assert_class(basic_table_args, classes = "basic_table_args")+ by = categorical_var |
| 163 | +631 |
- # End of assertions+ ) |
|
| 164 | +632 |
-
+ # so that x axis of plot aligns with columns of summary table, from most outliers to least by percentage |
|
| 165 | -+ | ||
| 633 | +! |
- # Make UI args+ ANL <- ANL %>% |
|
| 166 | +634 | ! |
- ui_args <- as.list(environment())+ dplyr::left_join( |
| 167 | -+ | ||
| 635 | +! |
-
+ dplyr::select(summary_table_pre, categorical_var_name, order), |
|
| 168 | +636 | ! |
- server_args <- list(+ by = categorical_var+ |
+
| 637 | ++ |
+ ) %>% |
|
| 169 | +638 | ! |
- label = label,+ dplyr::arrange(order) |
| 170 | +639 | ! |
- x = x,+ summary_table <- summary_table_pre %>% |
| 171 | +640 | ! |
- y = y,+ dplyr::select( |
| 172 | +641 | ! |
- basic_table_args = basic_table_args+ categorical_var_name, |
| 173 | -+ | ||
| 642 | +! |
- )+ Outliers = display_str, Missings = display_str_na, Total = total_in_cat |
|
| 174 | +643 |
-
+ ) %>% |
|
| 175 | +644 | ! |
- ans <- module(+ dplyr::mutate_all(as.character) %>% |
| 176 | +645 | ! |
- label = label,+ tidyr::pivot_longer(-categorical_var_name) %>% |
| 177 | +646 | ! |
- server = srv_t_crosstable,+ tidyr::pivot_wider(names_from = categorical_var, values_from = value) %>% |
| 178 | +647 | ! |
- ui = ui_t_crosstable,+ tibble::column_to_rownames("name")
|
| 179 | +648 | ! |
- ui_args = ui_args,+ summary_table |
| 180 | -! | +||
| 649 | +
- server_args = server_args,+ }, |
||
| 181 | +650 | ! |
- datanames = teal.transform::get_extract_datanames(list(x = x, y = y))+ env = list( |
| 182 | -+ | ||
| 651 | +! |
- )+ categorical_var = categorical_var, |
|
| 183 | +652 | ! |
- attr(ans, "teal_bookmarkable") <- TRUE+ categorical_var_name = as.name(categorical_var) |
| 184 | -! | +||
| 653 | +
- ans+ ) |
||
| 185 | +654 |
- }+ ) |
|
| 186 | +655 |
-
+ ) |
|
| 187 | +656 |
- # UI function for the cross-table module+ } |
|
| 188 | +657 |
- ui_t_crosstable <- function(id, x, y, show_percentage, show_total, pre_output, post_output, ...) {
+
|
|
| 189 | +658 | ! |
- ns <- NS(id)+ if (length(categorical_var) > 0 && nrow(qenv[["ANL_OUTLIER"]]) > 0) {
|
| 190 | +659 | ! |
- is_single_dataset <- teal.transform::is_single_dataset(x, y)+ shinyjs::show("order_by_outlier")
|
| 191 | +660 | - - | -|
| 192 | -! | -
- join_default_options <- c(+ } else {
|
|
| 193 | +661 | ! |
- "Full Join" = "dplyr::full_join",+ shinyjs::hide("order_by_outlier")
|
| 194 | -! | +||
| 662 | +
- "Inner Join" = "dplyr::inner_join",+ } |
||
| 195 | -! | +||
| 663 | +
- "Left Join" = "dplyr::left_join",+ |
||
| 196 | +664 | ! |
- "Right Join" = "dplyr::right_join"+ qenv |
| 197 | +665 |
- )+ }) |
|
| 198 | +666 | ||
| 199 | +667 | ! |
- teal.widgets::standard_layout(+ output$summary_table <- DT::renderDataTable( |
| 200 | +668 | ! |
- output = teal.widgets::white_small_well(+ expr = {
|
| 201 | +669 | ! |
- textOutput(ns("title")),
+ if (iv_r()$is_valid()) {
|
| 202 | +670 | ! |
- teal.widgets::table_with_settings_ui(ns("table"))
- |
-
| 203 | -- |
- ),+ categorical_var <- as.vector(merged$anl_input_r()$columns_source$categorical_var) |
|
| 204 | +671 | ! |
- encoding = tags$div(+ if (!is.null(categorical_var)) {
|
| 205 | -+ | ||
| 672 | +! |
- ### Reporter+ DT::datatable( |
|
| 206 | +673 | ! |
- teal.reporter::simple_reporter_ui(ns("simple_reporter")),
+ common_code_q()[["summary_table"]], |
| 207 | -+ | ||
| 674 | +! |
- ###+ options = list( |
|
| 208 | +675 | ! |
- tags$label("Encodings", class = "text-primary"),
+ dom = "t", |
| 209 | +676 | ! |
- teal.transform::datanames_input(list(x, y)),+ autoWidth = TRUE, |
| 210 | +677 | ! |
- teal.transform::data_extract_ui(ns("x"), label = "Row values", x, is_single_dataset = is_single_dataset),
+ columnDefs = list(list(width = "200px", targets = "_all")) |
| 211 | -! | +||
| 678 | +
- teal.transform::data_extract_ui(ns("y"), label = "Column values", y, is_single_dataset = is_single_dataset),
+ ) |
||
| 212 | -! | +||
| 679 | +
- teal.widgets::optionalSelectInput(+ ) |
||
| 213 | -! | +||
| 680 | +
- ns("join_fun"),
+ } |
||
| 214 | -! | +||
| 681 | +
- label = "Row to Column type of join",+ } |
||
| 215 | -! | +||
| 682 | +
- choices = join_default_options,+ } |
||
| 216 | -! | +||
| 683 | +
- selected = join_default_options[1],+ ) |
||
| 217 | -! | +||
| 684 | +
- multiple = FALSE+ |
||
| 218 | +685 |
- ),+ # boxplot/violinplot # nolint commented_code |
|
| 219 | +686 | ! |
- tags$hr(),+ boxplot_q <- reactive({
|
| 220 | +687 | ! |
- teal.widgets::panel_group(+ req(common_code_q()) |
| 221 | +688 | ! |
- teal.widgets::panel_item(+ ANL <- common_code_q()[["ANL"]] |
| 222 | +689 | ! |
- title = "Table settings",+ ANL_OUTLIER <- common_code_q()[["ANL_OUTLIER"]]+ |
+
| 690 | ++ | + | |
| 223 | +691 | ! |
- checkboxInput(ns("show_percentage"), "Show column percentage", value = show_percentage),
+ outlier_var <- as.vector(merged$anl_input_r()$columns_source$outlier_var) |
| 224 | +692 | ! |
- checkboxInput(ns("show_total"), "Show total column", value = show_total)
+ categorical_var <- as.vector(merged$anl_input_r()$columns_source$categorical_var) |
| 225 | +693 |
- )+ |
|
| 226 | +694 |
- )+ # validation+ |
+ |
| 695 | +! | +
+ teal::validate_has_data(ANL, 1) |
|
| 227 | +696 |
- ),+ |
|
| 228 | -! | +||
| 697 | +
- forms = tagList(+ # boxplot |
||
| 229 | +698 | ! |
- teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code")
+ plot_call <- quote(ANL %>% ggplot()) |
| 230 | +699 |
- ),+ |
|
| 231 | +700 | ! |
- pre_output = pre_output,+ plot_call <- if (input$boxplot_alts == "Box plot") {
|
| 232 | +701 | ! |
- post_output = post_output+ substitute(expr = plot_call + geom_boxplot(outlier.shape = NA), env = list(plot_call = plot_call)) |
| 233 | -+ | ||
| 702 | +! |
- )+ } else if (input$boxplot_alts == "Violin plot") {
|
|
| 234 | -+ | ||
| 703 | +! |
- }+ substitute(expr = plot_call + geom_violin(), env = list(plot_call = plot_call)) |
|
| 235 | +704 |
-
+ } else {
+ |
+ |
| 705 | +! | +
+ NULL |
|
| 236 | +706 |
- # Server function for the cross-table module+ } |
|
| 237 | +707 |
- srv_t_crosstable <- function(id, data, reporter, filter_panel_api, label, x, y, basic_table_args) {
+
|
|
| 238 | +708 | ! |
- with_reporter <- !missing(reporter) && inherits(reporter, "Reporter")+ plot_call <- if (identical(categorical_var, character(0)) || is.null(categorical_var)) {
|
| 239 | +709 | ! |
- with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI")+ inner_call <- substitute( |
| 240 | +710 | ! |
- checkmate::assert_class(data, "reactive")+ expr = plot_call + |
| 241 | +711 | ! |
- checkmate::assert_class(isolate(data()), "teal_data")+ aes(x = "Entire dataset", y = outlier_var_name) + |
| 242 | +712 | ! |
- moduleServer(id, function(input, output, session) {
+ scale_x_discrete(), |
| 243 | +713 | ! |
- teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.general")+ env = list(plot_call = plot_call, outlier_var_name = as.name(outlier_var)) |
| 244 | +714 |
-
+ ) |
|
| 245 | +715 | ! |
- selector_list <- teal.transform::data_extract_multiple_srv(+ if (nrow(ANL_OUTLIER) > 0) {
|
| 246 | +716 | ! |
- data_extract = list(x = x, y = y),+ substitute( |
| 247 | +717 | ! |
- datasets = data,+ expr = inner_call + geom_point( |
| 248 | +718 | ! |
- select_validation_rule = list(+ data = ANL_OUTLIER, |
| 249 | +719 | ! |
- x = shinyvalidate::sv_required("Please define column for row variable."),
+ aes(x = "Entire dataset", y = outlier_var_name, color = is_outlier_selected)+ |
+
| 720 | ++ |
+ ), |
|
| 250 | +721 | ! |
- y = shinyvalidate::sv_required("Please define column for column variable.")
+ env = list(inner_call = inner_call, outlier_var_name = as.name(outlier_var)) |
| 251 | +722 |
- )+ ) |
|
| 252 | +723 |
- )+ } else {
+ |
+ |
| 724 | +! | +
+ inner_call |
|
| 253 | +725 |
-
+ } |
|
| 254 | -! | +||
| 726 | +
- iv_r <- reactive({
+ } else {
|
||
| 255 | +727 | ! |
- iv <- shinyvalidate::InputValidator$new()+ substitute( |
| 256 | +728 | ! |
- iv$add_rule("join_fun", function(value) {
+ expr = plot_call + |
| 257 | +729 | ! |
- if (!identical(selector_list()$x()$dataname, selector_list()$y()$dataname)) {
+ aes(y = outlier_var_name, x = reorder(categorical_var_name, order)) + |
| 258 | +730 | ! |
- if (!shinyvalidate::input_provided(value)) {
+ xlab(categorical_var) + |
| 259 | +731 | ! |
- "Please select a joining function."- |
-
| 260 | -- |
- }+ scale_x_discrete() + |
|
| 261 | -+ | ||
| 732 | +! |
- }+ geom_point( |
|
| 262 | -+ | ||
| 733 | +! |
- })+ data = ANL_OUTLIER, |
|
| 263 | +734 | ! |
- teal.transform::compose_and_enable_validators(iv, selector_list)+ aes(x = as.factor(categorical_var_name), y = outlier_var_name, color = is_outlier_selected) |
| 264 | +735 |
- })+ ), |
|
| 265 | -+ | ||
| 736 | +! |
-
+ env = list( |
|
| 266 | +737 | ! |
- observeEvent(+ plot_call = plot_call, |
| 267 | +738 | ! |
- eventExpr = {
+ outlier_var_name = as.name(outlier_var), |
| 268 | +739 | ! |
- req(!is.null(selector_list()$x()) && !is.null(selector_list()$y()))+ categorical_var_name = as.name(categorical_var), |
| 269 | +740 | ! |
- list(selector_list()$x(), selector_list()$y())+ categorical_var = categorical_var |
| 270 | +741 |
- },- |
- |
| 271 | -! | -
- handlerExpr = {
+ ) |
|
| 272 | -! | +||
| 742 | +
- if (identical(selector_list()$x()$dataname, selector_list()$y()$dataname)) {
+ ) |
||
| 273 | -! | +||
| 743 | +
- shinyjs::hide("join_fun")
+ } |
||
| 274 | +744 |
- } else {
+
|
|
| 275 | +745 | ! |
- shinyjs::show("join_fun")
+ dev_ggplot2_args <- teal.widgets::ggplot2_args( |
| 276 | -+ | ||
| 746 | +! |
- }+ labs = list(color = "Is outlier?"), |
|
| 277 | -+ | ||
| 747 | +! |
- }+ theme = list(legend.position = "top") |
|
| 278 | +748 |
- )+ ) |
|
| 279 | +749 | ||
| 280 | +750 | ! |
- merge_function <- reactive({
+ all_ggplot2_args <- teal.widgets::resolve_ggplot2_args( |
| 281 | +751 | ! |
- if (is.null(input$join_fun)) {
+ user_plot = ggplot2_args[["Boxplot"]], |
| 282 | +752 | ! |
- "dplyr::full_join"+ user_default = ggplot2_args$default,+ |
+
| 753 | +! | +
+ module_plot = dev_ggplot2_args |
|
| 283 | +754 |
- } else {
+ )+ |
+ |
| 755 | ++ | + | |
| 284 | +756 | ! |
- input$join_fun+ parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args( |
| 285 | -+ | ||
| 757 | +! |
- }+ all_ggplot2_args,+ |
+ |
| 758 | +! | +
+ ggtheme = input$ggtheme |
|
| 286 | +759 |
- })+ ) |
|
| 287 | +760 | ||
| 288 | +761 | ! |
- anl_merged_input <- teal.transform::merge_expression_srv(+ teal.code::eval_code( |
| 289 | +762 | ! |
- datasets = data,+ common_code_q(), |
| 290 | +763 | ! |
- selector_list = selector_list,+ substitute( |
| 291 | +764 | ! |
- merge_function = merge_function+ expr = g <- plot_call + |
| 292 | -+ | ||
| 765 | +! |
- )+ scale_color_manual(values = c("TRUE" = "red", "FALSE" = "black")) +
|
|
| 293 | -+ | ||
| 766 | +! |
-
+ labs + ggthemes + themes, |
|
| 294 | +767 | ! |
- anl_merged_q <- reactive({
+ env = list( |
| 295 | +768 | ! |
- req(anl_merged_input())+ plot_call = plot_call, |
| 296 | +769 | ! |
- data() %>%+ labs = parsed_ggplot2_args$labs, |
| 297 | +770 | ! |
- teal.code::eval_code(as.expression(anl_merged_input()$expr))+ ggthemes = parsed_ggplot2_args$ggtheme,+ |
+
| 771 | +! | +
+ themes = parsed_ggplot2_args$theme |
|
| 298 | +772 |
- })+ ) |
|
| 299 | +773 |
-
+ ) |
|
| 300 | -! | +||
| 774 | +
- merged <- list(+ ) %>% |
||
| 301 | +775 | ! |
- anl_input_r = anl_merged_input,+ teal.code::eval_code(quote(print(g))) |
| 302 | -! | +||
| 776 | +
- anl_q_r = anl_merged_q+ }) |
||
| 303 | +777 |
- )+ |
|
| 304 | +778 |
-
+ # density plot |
|
| 305 | +779 | ! |
- output_q <- reactive({
+ density_plot_q <- reactive({
|
| 306 | +780 | ! |
- teal::validate_inputs(iv_r())+ ANL <- common_code_q()[["ANL"]] |
| 307 | +781 | ! |
- ANL <- merged$anl_q_r()[["ANL"]]+ ANL_OUTLIER <- common_code_q()[["ANL_OUTLIER"]] |
| 308 | +782 | ||
| 309 | -- |
- # As this is a summary- |
- |
| 310 | +783 | ! |
- x_name <- as.vector(merged$anl_input_r()$columns_source$x)+ outlier_var <- as.vector(merged$anl_input_r()$columns_source$outlier_var) |
| 311 | +784 | ! |
- y_name <- as.vector(merged$anl_input_r()$columns_source$y)+ categorical_var <- as.vector(merged$anl_input_r()$columns_source$categorical_var) |
| 312 | +785 | ||
| 313 | -! | +||
| 786 | +
- teal::validate_has_data(ANL, 3)+ # validation |
||
| 314 | +787 | ! |
- teal::validate_has_data(ANL[, c(x_name, y_name)], 3, complete = TRUE, allow_inf = FALSE)+ teal::validate_has_data(ANL, 1) |
| 315 | +788 |
-
+ # plot |
|
| 316 | +789 | ! |
- is_allowed_class <- function(x) is.numeric(x) || is.factor(x) || is.character(x) || is.logical(x)+ plot_call <- substitute( |
| 317 | +790 | ! |
- validate(need(+ expr = ANL %>% |
| 318 | +791 | ! |
- all(vapply(ANL[x_name], is_allowed_class, logical(1))),+ ggplot(aes(x = outlier_var_name)) + |
| 319 | +792 | ! |
- "Selected row variable has an unsupported data type."- |
-
| 320 | -- |
- ))+ geom_density() + |
|
| 321 | +793 | ! |
- validate(need(+ geom_rug(data = ANL_OUTLIER, aes(x = outlier_var_name, color = is_outlier_selected)) + |
| 322 | +794 | ! |
- is_allowed_class(ANL[[y_name]]),+ scale_color_manual(values = c("TRUE" = "red", "FALSE" = "black")),
|
| 323 | +795 | ! |
- "Selected column variable has an unsupported data type."+ env = list(outlier_var_name = as.name(outlier_var)) |
| 324 | +796 |
- ))+ ) |
|
| 325 | +797 | ||
| 326 | +798 | ! |
- show_percentage <- input$show_percentage+ plot_call <- if (identical(categorical_var, character(0)) || is.null(categorical_var)) {
|
| 327 | +799 | ! |
- show_total <- input$show_total+ substitute(expr = plot_call, env = list(plot_call = plot_call)) |
| 328 | +800 |
-
+ } else {
|
|
| 329 | +801 | ! |
- plot_title <- paste(+ substitute( |
| 330 | +802 | ! |
- "Cross-Table of",+ expr = plot_call + facet_grid(~ reorder(categorical_var_name, order)), |
| 331 | +803 | ! |
- paste0(varname_w_label(x_name, ANL), collapse = ", "),+ env = list(plot_call = plot_call, categorical_var_name = as.name(categorical_var))+ |
+
| 804 | ++ |
+ )+ |
+ |
| 805 | ++ |
+ }+ |
+ |
| 806 | ++ | + | |
| 332 | +807 | ! |
- "(rows)", "vs.",+ dev_ggplot2_args <- teal.widgets::ggplot2_args( |
| 333 | +808 | ! |
- varname_w_label(y_name, ANL),+ labs = list(color = "Is outlier?"), |
| 334 | +809 | ! |
- "(columns)"+ theme = list(legend.position = "top") |
| 335 | +810 |
) |
|
| 336 | +811 | ||
| 337 | -! | -
- labels_vec <- vapply(- |
- |
| 338 | +812 | ! |
- x_name,+ all_ggplot2_args <- teal.widgets::resolve_ggplot2_args( |
| 339 | +813 | ! |
- varname_w_label,+ user_plot = ggplot2_args[["Density Plot"]], |
| 340 | +814 | ! |
- character(1),+ user_default = ggplot2_args$default, |
| 341 | +815 | ! |
- ANL+ module_plot = dev_ggplot2_args |
| 342 | +816 |
) |
|
| 343 | +817 | ||
| 344 | -! | -
- teal.code::eval_code(- |
- |
| 345 | +818 | ! |
- merged$anl_q_r(),+ parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args( |
| 346 | +819 | ! |
- substitute(+ all_ggplot2_args, |
| 347 | +820 | ! |
- expr = {
+ ggtheme = input$ggtheme |
| 348 | -! | +||
| 821 | +
- title <- plot_title+ ) |
||
| 349 | +822 |
- },+ |
|
| 350 | +823 | ! |
- env = list(plot_title = plot_title)- |
-
| 351 | -- |
- )+ teal.code::eval_code( |
|
| 352 | -+ | ||
| 824 | +! |
- ) %>%+ common_code_q(), |
|
| 353 | +825 | ! |
- teal.code::eval_code(+ substitute( |
| 354 | +826 | ! |
- substitute(+ expr = g <- plot_call + labs + ggthemes + themes, |
| 355 | +827 | ! |
- expr = {
+ env = list( |
| 356 | +828 | ! |
- lyt <- basic_tables %>%+ plot_call = plot_call, |
| 357 | +829 | ! |
- split_call %>% # styler: off+ labs = parsed_ggplot2_args$labs, |
| 358 | +830 | ! |
- rtables::add_colcounts() %>%+ themes = parsed_ggplot2_args$theme, |
| 359 | +831 | ! |
- tern::analyze_vars(+ ggthemes = parsed_ggplot2_args$ggtheme |
| 360 | -! | +||
| 832 | +
- vars = x_name,+ ) |
||
| 361 | -! | +||
| 833 | +
- var_labels = labels_vec,+ ) |
||
| 362 | -! | +||
| 834 | +
- na.rm = FALSE,+ ) %>% |
||
| 363 | +835 | ! |
- denom = "N_col",+ teal.code::eval_code(quote(print(g))) |
| 364 | -! | +||
| 836 | +
- .stats = c("mean_sd", "median", "range", count_value)
+ }) |
||
| 365 | +837 |
- )+ |
|
| 366 | +838 |
- },+ # Cumulative distribution plot |
|
| 367 | +839 | ! |
- env = list(+ cumulative_plot_q <- reactive({
|
| 368 | +840 | ! |
- basic_tables = teal.widgets::parse_basic_table_args(+ ANL <- common_code_q()[["ANL"]] |
| 369 | +841 | ! |
- basic_table_args = teal.widgets::resolve_basic_table_args(basic_table_args)+ ANL_OUTLIER <- common_code_q()[["ANL_OUTLIER"]] |
| 370 | +842 |
- ),+ |
|
| 371 | +843 | ! |
- split_call = if (show_total) {
+ qenv <- common_code_q() |
| 372 | -! | +||
| 844 | +
- substitute(+ |
||
| 373 | +845 | ! |
- expr = rtables::split_cols_by(+ outlier_var <- as.vector(merged$anl_input_r()$columns_source$outlier_var) |
| 374 | +846 | ! |
- y_name,+ categorical_var <- as.vector(merged$anl_input_r()$columns_source$categorical_var) |
| 375 | -! | +||
| 847 | +
- split_fun = rtables::add_overall_level(label = "Total", first = FALSE)+ |
||
| 376 | +848 |
- ),+ # validation |
|
| 377 | +849 | ! |
- env = list(y_name = y_name)+ teal::validate_has_data(ANL, 1) |
| 378 | +850 |
- )+ |
|
| 379 | +851 |
- } else {
+ # plot |
|
| 380 | +852 | ! |
- substitute(rtables::split_cols_by(y_name), env = list(y_name = y_name))- |
-
| 381 | -- |
- },+ plot_call <- substitute( |
|
| 382 | +853 | ! |
- x_name = x_name,+ expr = ANL %>% ggplot(aes(x = outlier_var_name)) + |
| 383 | +854 | ! |
- labels_vec = labels_vec,+ stat_ecdf(), |
| 384 | +855 | ! |
- count_value = ifelse(show_percentage, "count_fraction", "count")+ env = list(outlier_var_name = as.name(outlier_var)) |
| 385 | +856 |
- )+ ) |
|
| 386 | -+ | ||
| 857 | +! |
- )+ if (length(categorical_var) == 0) {
|
|
| 387 | -+ | ||
| 858 | +! |
- ) %>%+ qenv <- teal.code::eval_code( |
|
| 388 | +859 | ! |
- teal.code::eval_code(+ qenv, |
| 389 | +860 | ! |
substitute( |
| 390 | +861 | ! |
expr = {
|
| 391 | +862 | ! |
- ANL <- tern::df_explicit_na(ANL)+ ecdf_df <- ANL %>% |
| 392 | +863 | ! |
- tbl <- rtables::build_table(lyt = lyt, df = ANL[order(ANL[[y_name]]), ])+ dplyr::mutate( |
| 393 | +864 | ! |
- tbl+ y = stats::ecdf(ANL[[outlier_var]])(ANL[[outlier_var]]) |
| 394 | +865 |
- },- |
- |
| 395 | -! | -
- env = list(y_name = y_name)+ ) |
|
| 396 | +866 |
- )+ |
|
| 397 | -+ | ||
| 867 | +! |
- )+ outlier_points <- dplyr::left_join( |
|
| 398 | -+ | ||
| 868 | +! |
- })+ ecdf_df, |
|
| 399 | -+ | ||
| 869 | +! |
-
+ ANL_OUTLIER, |
|
| 400 | +870 | ! |
- output$title <- renderText(output_q()[["title"]])+ by = dplyr::setdiff(names(ecdf_df), "y") |
| 401 | +871 |
-
+ ) %>% |
|
| 402 | +872 | ! |
- table_r <- reactive({
+ dplyr::filter(!is.na(is_outlier_selected)) |
| 403 | -! | +||
| 873 | +
- req(iv_r()$is_valid())+ }, |
||
| 404 | +874 | ! |
- output_q()[["tbl"]]+ env = list(outlier_var = outlier_var) |
| 405 | +875 |
- })+ ) |
|
| 406 | +876 |
-
+ )+ |
+ |
| 877 | ++ |
+ } else {
|
|
| 407 | +878 | ! |
- teal.widgets::table_with_settings_srv(+ qenv <- teal.code::eval_code( |
| 408 | +879 | ! |
- id = "table",+ qenv, |
| 409 | +880 | ! |
- table_r = table_r+ substitute( |
| 410 | -+ | ||
| 881 | +! |
- )+ expr = {
|
|
| 411 | -+ | ||
| 882 | +! |
-
+ all_categories <- lapply( |
|
| 412 | +883 | ! |
- teal.widgets::verbatim_popup_srv(+ unique(ANL[[categorical_var]]), |
| 413 | +884 | ! |
- id = "rcode",+ function(x) {
|
| 414 | +885 | ! |
- verbatim_content = reactive(teal.code::get_code(output_q())),+ ANL <- ANL %>% dplyr::filter(get(categorical_var) == x) |
| 415 | +886 | ! |
- title = "Show R Code for Cross-Table"+ anl_outlier2 <- ANL_OUTLIER %>% dplyr::filter(get(categorical_var) == x) |
| 416 | -+ | ||
| 887 | +! |
- )+ ecdf_df <- ANL %>% |
|
| 417 | -+ | ||
| 888 | +! |
-
+ dplyr::mutate(y = stats::ecdf(ANL[[outlier_var]])(ANL[[outlier_var]])) |
|
| 418 | +889 |
- ### REPORTER+ |
|
| 419 | +890 | ! |
- if (with_reporter) {
+ dplyr::left_join( |
| 420 | +891 | ! |
- card_fun <- function(comment, label) {
+ ecdf_df, |
| 421 | +892 | ! |
- card <- teal::report_card_template(+ anl_outlier2, |
| 422 | +893 | ! |
- title = "Cross Table",+ by = dplyr::setdiff(names(ecdf_df), "y") |
| 423 | -! | +||
| 894 | +
- label = label,+ ) %>% |
||
| 424 | +895 | ! |
- with_filter = with_filter,+ dplyr::filter(!is.na(is_outlier_selected)) |
| 425 | -! | +||
| 896 | +
- filter_panel_api = filter_panel_api+ } |
||
| 426 | +897 |
- )+ ) |
|
| 427 | +898 | ! |
- card$append_text("Table", "header3")
+ outlier_points <- do.call(rbind, all_categories) |
| 428 | -! | +||
| 899 | +
- card$append_table(table_r())+ }, |
||
| 429 | +900 | ! |
- if (!comment == "") {
+ env = list(categorical_var = categorical_var, outlier_var = outlier_var) |
| 430 | -! | -
- card$append_text("Comment", "header3")
- |
- |
| 431 | -! | +||
| 901 | +
- card$append_text(comment)+ ) |
||
| 432 | +902 |
- }+ ) |
|
| 433 | +903 | ! |
- card$append_src(teal.code::get_code(output_q()))+ plot_call <- substitute( |
| 434 | +904 | ! |
- card- |
-
| 435 | -- |
- }+ expr = plot_call + facet_grid(~ reorder(categorical_var_name, order)), |
|
| 436 | +905 | ! |
- teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
+ env = list(plot_call = plot_call, categorical_var_name = as.name(categorical_var)) |
| 437 | +906 |
- }+ ) |
|
| 438 | +907 |
- ###+ } |
|
| 439 | +908 |
- })+ |
|
| 440 | -+ | ||
| 909 | +! |
- }+ dev_ggplot2_args <- teal.widgets::ggplot2_args( |
| 1 | -+ | ||
| 910 | +! |
- #' `teal` module: Front page+ labs = list(color = "Is outlier?"), |
|
| 2 | -+ | ||
| 911 | +! |
- #'+ theme = list(legend.position = "top") |
|
| 3 | +912 |
- #' Creates a simple front page for `teal` applications, displaying+ ) |
|
| 4 | +913 |
- #' introductory text, tables, additional `html` or `shiny` tags, and footnotes.+ |
|
| 5 | -+ | ||
| 914 | +! |
- #'+ all_ggplot2_args <- teal.widgets::resolve_ggplot2_args( |
|
| 6 | -+ | ||
| 915 | +! |
- #' @inheritParams teal::module+ user_plot = ggplot2_args[["Cumulative Distribution Plot"]], |
|
| 7 | -+ | ||
| 916 | +! |
- #' @param header_text (`character` vector) text to be shown at the top of the module, for each+ user_default = ggplot2_args$default, |
|
| 8 | -+ | ||
| 917 | +! |
- #' element, if named the name is shown first in bold as a header followed by the value. The first+ module_plot = dev_ggplot2_args |
|
| 9 | +918 |
- #' element's header is displayed larger than the others.+ ) |
|
| 10 | +919 |
- #' @param tables (`named list` of `data.frame`s) tables to be shown in the module.+ |
|
| 11 | -+ | ||
| 920 | +! |
- #' @param additional_tags (`shiny.tag.list` or `html`) additional `shiny` tags or `html` to be included after the table,+ parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args( |
|
| 12 | -+ | ||
| 921 | +! |
- #' for example to include an image, `tagList(tags$img(src = "image.png"))` or to include further `html`,+ all_ggplot2_args, |
|
| 13 | -+ | ||
| 922 | +! |
- #' `HTML("html text here")`.
+ ggtheme = input$ggtheme |
|
| 14 | +923 |
- #' @param footnotes (`character` vector) of text to be shown at the bottom of the module, for each+ ) |
|
| 15 | +924 |
- #' element, if named the name is shown first in bold, followed by the value.+ |
|
| 16 | -+ | ||
| 925 | +! |
- #' @param show_metadata (`logical`) indicating whether the metadata of the datasets be available on the module.+ teal.code::eval_code( |
|
| 17 | -+ | ||
| 926 | +! |
- #'+ qenv, |
|
| 18 | -+ | ||
| 927 | +! |
- #' @inherit shared_params return+ substitute( |
|
| 19 | -+ | ||
| 928 | +! |
- #'+ expr = g <- plot_call + |
|
| 20 | -+ | ||
| 929 | +! |
- #' @examplesShinylive+ geom_point(data = outlier_points, aes(x = outlier_var_name, y = y, color = is_outlier_selected)) + |
|
| 21 | -+ | ||
| 930 | +! |
- #' library(teal.modules.general)+ scale_color_manual(values = c("TRUE" = "red", "FALSE" = "black")) +
|
|
| 22 | -+ | ||
| 931 | +! |
- #' interactive <- function() TRUE+ labs + ggthemes + themes, |
|
| 23 | -+ | ||
| 932 | +! |
- #' {{ next_example }}
+ env = list( |
|
| 24 | -+ | ||
| 933 | +! |
- #' @examples+ plot_call = plot_call, |
|
| 25 | -+ | ||
| 934 | +! |
- #' data <- teal_data()+ outlier_var_name = as.name(outlier_var), |
|
| 26 | -+ | ||
| 935 | +! |
- #' data <- within(data, {
+ labs = parsed_ggplot2_args$labs, |
|
| 27 | -+ | ||
| 936 | +! |
- #' require(nestcolor)+ themes = parsed_ggplot2_args$theme, |
|
| 28 | -+ | ||
| 937 | +! |
- #' ADSL <- rADSL+ ggthemes = parsed_ggplot2_args$ggtheme |
|
| 29 | +938 |
- #' attr(ADSL, "metadata") <- list("Author" = "NEST team", "data_source" = "synthetic data")
+ ) |
|
| 30 | +939 |
- #' })+ ) |
|
| 31 | +940 |
- #' datanames(data) <- "ADSL"+ ) %>% |
|
| 32 | -+ | ||
| 941 | +! |
- #' join_keys(data) <- default_cdisc_join_keys[datanames(data)]+ teal.code::eval_code(quote(print(g))) |
|
| 33 | +942 |
- #'+ }) |
|
| 34 | +943 |
- #' table_1 <- data.frame(Info = c("A", "B"), Text = c("A", "B"))
+
|
|
| 35 | -+ | ||
| 944 | +! |
- #' table_2 <- data.frame(`Column 1` = c("C", "D"), `Column 2` = c(5.5, 6.6), `Column 3` = c("A", "B"))
+ final_q <- reactive({
|
|
| 36 | -+ | ||
| 945 | +! |
- #' table_3 <- data.frame(Info = c("E", "F"), Text = c("G", "H"))
+ req(input$tabs) |
|
| 37 | -+ | ||
| 946 | +! |
- #'+ tab_type <- input$tabs |
|
| 38 | -+ | ||
| 947 | +! |
- #' table_input <- list(+ result_q <- if (tab_type == "Boxplot") {
|
|
| 39 | -+ | ||
| 948 | +! |
- #' "Table 1" = table_1,+ boxplot_q() |
|
| 40 | -+ | ||
| 949 | +! |
- #' "Table 2" = table_2,+ } else if (tab_type == "Density Plot") {
|
|
| 41 | -+ | ||
| 950 | +! |
- #' "Table 3" = table_3+ density_plot_q() |
|
| 42 | -+ | ||
| 951 | +! |
- #' )+ } else if (tab_type == "Cumulative Distribution Plot") {
|
|
| 43 | -+ | ||
| 952 | +! |
- #'+ cumulative_plot_q() |
|
| 44 | +953 |
- #' app <- init(+ } |
|
| 45 | +954 |
- #' data = data,+ # used to display table when running show-r-code code |
|
| 46 | +955 |
- #' modules = modules(+ # added after the plots so that a change in selected columns doesn't affect |
|
| 47 | +956 |
- #' tm_front_page(+ # brush selection. |
|
| 48 | -+ | ||
| 957 | +! |
- #' header_text = c(+ teal.code::eval_code( |
|
| 49 | -+ | ||
| 958 | +! |
- #' "Important information" = "It can go here.",+ result_q, |
|
| 50 | -+ | ||
| 959 | +! |
- #' "Other information" = "Can go here."+ substitute( |
|
| 51 | -+ | ||
| 960 | +! |
- #' ),+ expr = {
|
|
| 52 | -+ | ||
| 961 | +! |
- #' tables = table_input,+ columns_index <- union( |
|
| 53 | -+ | ||
| 962 | +! |
- #' additional_tags = HTML("Additional HTML or shiny tags go here <br>"),
+ setdiff(names(ANL_OUTLIER), c("is_outlier_selected", "order")),
|
|
| 54 | -+ | ||
| 963 | +! |
- #' footnotes = c("X" = "is the first footnote", "Y is the second footnote"),
+ table_columns |
|
| 55 | +964 |
- #' show_metadata = TRUE+ ) |
|
| 56 | -+ | ||
| 965 | +! |
- #' )+ ANL_OUTLIER_EXTENDED[ANL_OUTLIER_EXTENDED$is_outlier_selected, columns_index] |
|
| 57 | +966 |
- #' ),+ }, |
|
| 58 | -+ | ||
| 967 | +! |
- #' header = tags$h1("Sample Application"),
+ env = list( |
|
| 59 | -+ | ||
| 968 | +! |
- #' footer = tags$p("Application footer"),
+ table_columns = input$table_ui_columns |
|
| 60 | +969 |
- #' )+ ) |
|
| 61 | +970 |
- #'+ ) |
|
| 62 | +971 |
- #' if (interactive()) {
+ ) |
|
| 63 | +972 |
- #' shinyApp(app$ui, app$server)+ }) |
|
| 64 | +973 |
- #' }+ |
|
| 65 | +974 |
- #'+ # slider text |
|
| 66 | -+ | ||
| 975 | +! |
- #' @export+ output$ui_outlier_help <- renderUI({
|
|
| 67 | -+ | ||
| 976 | +! |
- #'+ req(input$method) |
|
| 68 | -+ | ||
| 977 | +! |
- tm_front_page <- function(label = "Front page",+ if (input$method == "IQR") {
|
|
| 69 | -- |
- header_text = character(0),- |
- |
| 70 | -- |
- tables = list(),- |
- |
| 71 | -- |
- additional_tags = tagList(),- |
- |
| 72 | -- |
- footnotes = character(0),- |
- |
| 73 | -+ | ||
| 978 | +! |
- show_metadata = FALSE) {
+ req(input$iqr_slider) |
|
| 74 | +979 | ! |
- message("Initializing tm_front_page")
+ tags$small( |
| 75 | -+ | ||
| 980 | +! |
-
+ withMathJax( |
|
| 76 | -+ | ||
| 981 | +! |
- # Start of assertions+ helpText( |
|
| 77 | +982 | ! |
- checkmate::assert_string(label)+ "Outlier data points (\\(x \\lt Q1 - ", input$iqr_slider, "\\times IQR\\) or \\( |
| 78 | +983 | ! |
- checkmate::assert_character(header_text, min.len = 0, any.missing = FALSE)+ Q3 + ", input$iqr_slider, "\\times IQR \\lt x\\)) |
| 79 | +984 | ! |
- checkmate::assert_list(tables, types = "data.frame", names = "named", any.missing = FALSE)+ are displayed in red on the plot and can be visualized in the table below." |
| 80 | -! | +||
| 985 | +
- checkmate::assert_multi_class(additional_tags, classes = c("shiny.tag.list", "html"))
+ ), |
||
| 81 | +986 | ! |
- checkmate::assert_character(footnotes, min.len = 0, any.missing = FALSE)+ if (input$split_outliers) {
|
| 82 | +987 | ! |
- checkmate::assert_flag(show_metadata)+ withMathJax(helpText("Note: Quantiles are calculated per group."))
|
| 83 | +988 |
- # End of assertions+ } |
|
| 84 | +989 |
-
+ ) |
|
| 85 | +990 |
- # Make UI args+ ) |
|
| 86 | +991 | ! |
- args <- as.list(environment())- |
-
| 87 | -- |
-
+ } else if (input$method == "Z-score") {
|
|
| 88 | +992 | ! |
- ans <- module(+ req(input$zscore_slider) |
| 89 | +993 | ! |
- label = label,+ tags$small( |
| 90 | +994 | ! |
- server = srv_front_page,+ withMathJax( |
| 91 | +995 | ! |
- ui = ui_front_page,+ helpText( |
| 92 | +996 | ! |
- ui_args = args,+ "Outlier data points (\\(Zscore(x) < -", input$zscore_slider, |
| 93 | +997 | ! |
- server_args = list(tables = tables, show_metadata = show_metadata),+ "\\) or \\(", input$zscore_slider, "< Zscore(x) \\))
|
| 94 | +998 | ! |
- datanames = if (show_metadata) "all" else NULL+ are displayed in red on the plot and can be visualized in the table below." |
| 95 | +999 |
- )+ ), |
|
| 96 | +1000 | ! |
- attr(ans, "teal_bookmarkable") <- TRUE+ if (input$split_outliers) {
|
| 97 | +1001 | ! |
- ans- |
-
| 98 | -- |
- }+ withMathJax(helpText(" Note: Z-scores are calculated per group."))
|
|
| 99 | +1002 |
-
+ } |
|
| 100 | +1003 |
- # UI function for the front page module+ ) |
|
| 101 | +1004 |
- ui_front_page <- function(id, ...) {
+ ) |
|
| 102 | +1005 | ! |
- args <- list(...)+ } else if (input$method == "Percentile") {
|
| 103 | +1006 | ! |
- ns <- NS(id)+ req(input$percentile_slider) |
| 104 | -+ | ||
| 1007 | +! |
-
+ tags$small( |
|
| 105 | +1008 | ! |
- tagList(+ withMathJax( |
| 106 | +1009 | ! |
- include_css_files("custom"),
+ helpText( |
| 107 | +1010 | ! |
- tags$div(+ "Outlier/extreme data points (\\( Percentile(x) <", input$percentile_slider, |
| 108 | +1011 | ! |
- id = "front_page_content",+ "\\) or \\(", 1 - input$percentile_slider, " < Percentile(x) \\))
|
| 109 | +1012 | ! |
- class = "ml-8",+ are displayed in red on the plot and can be visualized in the table below." |
| 110 | -! | +||
| 1013 | +
- tags$div(+ ), |
||
| 111 | +1014 | ! |
- id = "front_page_headers",+ if (input$split_outliers) {
|
| 112 | +1015 | ! |
- get_header_tags(args$header_text)+ withMathJax(helpText("Note: Percentiles are calculated per group."))
|
| 113 | +1016 |
- ),+ } |
|
| 114 | -! | +||
| 1017 | +
- tags$div(+ ) |
||
| 115 | -! | +||
| 1018 | +
- id = "front_page_tables",+ ) |
||
| 116 | -! | +||
| 1019 | +
- class = "ml-4",+ } |
||
| 117 | -! | +||
| 1020 | +
- get_table_tags(args$tables, ns)+ }) |
||
| 118 | +1021 |
- ),+ |
|
| 119 | +1022 | ! |
- tags$div(+ boxplot_r <- reactive({
|
| 120 | +1023 | ! |
- id = "front_page_custom_html",+ teal::validate_inputs(iv_r()) |
| 121 | +1024 | ! |
- class = "my-4",+ boxplot_q()[["g"]] |
| 122 | -! | +||
| 1025 | +
- args$additional_tags+ }) |
||
| 123 | -+ | ||
| 1026 | +! |
- ),+ density_plot_r <- reactive({
|
|
| 124 | +1027 | ! |
- if (args$show_metadata) {
+ teal::validate_inputs(iv_r()) |
| 125 | +1028 | ! |
- tags$div(+ density_plot_q()[["g"]]+ |
+
| 1029 | ++ |
+ }) |
|
| 126 | +1030 | ! |
- id = "front_page_metabutton",+ cumulative_plot_r <- reactive({
|
| 127 | +1031 | ! |
- class = "m-4",+ teal::validate_inputs(iv_r()) |
| 128 | +1032 | ! |
- actionButton(ns("metadata_button"), "Show metadata")
+ cumulative_plot_q()[["g"]] |
| 129 | +1033 |
- )+ }) |
|
| 130 | +1034 |
- },+ |
|
| 131 | +1035 | ! |
- tags$footer(+ box_pws <- teal.widgets::plot_with_settings_srv( |
| 132 | +1036 | ! |
- class = ".small",+ id = "box_plot", |
| 133 | +1037 | ! |
- get_footer_tags(args$footnotes)+ plot_r = boxplot_r, |
| 134 | -+ | ||
| 1038 | +! |
- )+ height = plot_height, |
|
| 135 | -+ | ||
| 1039 | +! |
- )+ width = plot_width, |
|
| 136 | -+ | ||
| 1040 | +! |
- )+ brushing = TRUE |
|
| 137 | +1041 |
- }+ ) |
|
| 138 | +1042 | ||
| 139 | -- |
- # Server function for the front page module- |
- |
| 140 | -- |
- srv_front_page <- function(id, data, tables, show_metadata) {
- |
- |
| 141 | +1043 | ! |
- checkmate::assert_class(data, "reactive")+ density_pws <- teal.widgets::plot_with_settings_srv( |
| 142 | +1044 | ! |
- checkmate::assert_class(isolate(data()), "teal_data")+ id = "density_plot", |
| 143 | +1045 | ! |
- moduleServer(id, function(input, output, session) {
+ plot_r = density_plot_r, |
| 144 | +1046 | ! |
- teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.general")+ height = plot_height, |
| 145 | -+ | ||
| 1047 | +! |
-
+ width = plot_width, |
|
| 146 | +1048 | ! |
- ns <- session$ns+ brushing = TRUE |
| 147 | +1049 | - - | -|
| 148 | -! | -
- setBookmarkExclude("metadata_button")
+ ) |
|
| 149 | +1050 | ||
| 150 | +1051 | ! |
- lapply(seq_along(tables), function(idx) {
+ cum_density_pws <- teal.widgets::plot_with_settings_srv( |
| 151 | +1052 | ! |
- output[[paste0("table_", idx)]] <- renderTable(
+ id = "cum_density_plot", |
| 152 | +1053 | ! |
- tables[[idx]],+ plot_r = cumulative_plot_r, |
| 153 | +1054 | ! |
- bordered = TRUE,+ height = plot_height, |
| 154 | +1055 | ! |
- caption = names(tables)[idx],+ width = plot_width, |
| 155 | +1056 | ! |
- caption.placement = "top"- |
-
| 156 | -- |
- )+ brushing = TRUE |
|
| 157 | +1057 |
- })+ ) |
|
| 158 | +1058 | ||
| 159 | +1059 | ! |
- if (show_metadata) {
+ choices <- reactive(teal.transform::variable_choices(data()[[dataname_first]])) |
| 160 | -! | +||
| 1060 | +
- observeEvent(+ |
||
| 161 | +1061 | ! |
- input$metadata_button, showModal(+ observeEvent(common_code_q(), {
|
| 162 | +1062 | ! |
- modalDialog(+ ANL_OUTLIER <- common_code_q()[["ANL_OUTLIER"]] |
| 163 | +1063 | ! |
- title = "Metadata",+ teal.widgets::updateOptionalSelectInput( |
| 164 | +1064 | ! |
- dataTableOutput(ns("metadata_table")),
+ session, |
| 165 | +1065 | ! |
- size = "l",+ inputId = "table_ui_columns", |
| 166 | +1066 | ! |
- easyClose = TRUE+ choices = dplyr::setdiff(choices(), names(ANL_OUTLIER)), |
| 167 | -+ | ||
| 1067 | +! |
- )+ selected = restoreInput(ns("table_ui_columns"), isolate(input$table_ui_columns))
|
|
| 168 | +1068 |
- )+ ) |
|
| 169 | +1069 |
- )+ }) |
|
| 170 | +1070 | ||
| 171 | +1071 | ! |
- metadata_data_frame <- reactive({
+ output$table_ui <- DT::renderDataTable( |
| 172 | +1072 | ! |
- datanames <- teal.data::datanames(data())+ expr = {
|
| 173 | +1073 | ! |
- convert_metadata_to_dataframe(+ tab <- input$tabs |
| 174 | +1074 | ! |
- lapply(datanames, function(dataname) attr(data()[[dataname]], "metadata")),+ req(tab) # tab is NULL upon app launch, hence will crash without this statement |
| 175 | +1075 | ! |
- datanames+ req(iv_r()$is_valid()) # Same validation as output$table_ui_wrap |
| 176 | -+ | ||
| 1076 | +! |
- )+ outlier_var <- as.vector(merged$anl_input_r()$columns_source$outlier_var) |
|
| 177 | -+ | ||
| 1077 | +! |
- })+ categorical_var <- as.vector(merged$anl_input_r()$columns_source$categorical_var) |
|
| 178 | +1078 | ||
| 179 | +1079 | ! |
- output$metadata_table <- renderDataTable({
+ ANL_OUTLIER <- common_code_q()[["ANL_OUTLIER"]] |
| 180 | +1080 | ! |
- validate(need(nrow(metadata_data_frame()) > 0, "The data has no associated metadata"))+ ANL_OUTLIER_EXTENDED <- common_code_q()[["ANL_OUTLIER_EXTENDED"]] |
| 181 | +1081 | ! |
- metadata_data_frame()+ ANL <- common_code_q()[["ANL"]] |
| 182 | +1082 |
- })+ |
|
| 183 | -+ | ||
| 1083 | +! |
- }+ plot_brush <- if (tab == "Boxplot") {
|
|
| 184 | -+ | ||
| 1084 | +! |
- })+ boxplot_r() |
|
| 185 | -+ | ||
| 1085 | +! |
- }+ box_pws$brush() |
|
| 186 | -+ | ||
| 1086 | +! |
-
+ } else if (tab == "Density Plot") {
|
|
| 187 | -+ | ||
| 1087 | +! |
- ## utils functions+ density_plot_r() |
|
| 188 | -+ | ||
| 1088 | +! |
-
+ density_pws$brush() |
|
| 189 | -+ | ||
| 1089 | +! |
- get_header_tags <- function(header_text) {
+ } else if (tab == "Cumulative Distribution Plot") {
|
|
| 190 | +1090 | ! |
- if (length(header_text) == 0) {
+ cumulative_plot_r() |
| 191 | +1091 | ! |
- return(list())+ cum_density_pws$brush() |
| 192 | +1092 |
- }+ } |
|
| 193 | +1093 | ||
| 194 | -! | +||
| 1094 | +
- get_single_header_tags <- function(header_text, p_text, header_tag = tags$h4) {
+ # removing unused column ASAP |
||
| 195 | +1095 | ! |
- tagList(+ ANL_OUTLIER$order <- ANL$order <- NULL |
| 196 | -! | +||
| 1096 | +
- tags$div(+ |
||
| 197 | +1097 | ! |
- if (!is.null(header_text) && nchar(header_text) > 0) header_tag(header_text),+ display_table <- if (!is.null(plot_brush)) {
|
| 198 | +1098 | ! |
- tags$p(p_text)- |
-
| 199 | -- |
- )- |
- |
| 200 | -- |
- )- |
- |
| 201 | -- |
- }+ if (length(categorical_var) > 0) {
|
|
| 202 | +1099 |
-
+ # due to reordering, the x-axis label may be changed to something like "reorder(categorical_var, order)" |
|
| 203 | +1100 | ! |
- header_tags <- get_single_header_tags(names(header_text[1]), header_text[1], header_tag = tags$h3)+ if (tab == "Boxplot") {
|
| 204 | +1101 | ! |
- c(header_tags, mapply(get_single_header_tags, utils::tail(names(header_text), -1), utils::tail(header_text, -1)))+ plot_brush$mapping$x <- categorical_var |
| 205 | +1102 |
- }+ } else {
|
|
| 206 | +1103 |
-
+ # the other plots use facetting |
|
| 207 | +1104 |
- get_table_tags <- function(tables, ns) {
+ # so it is panelvar1 that gets relabelled to "reorder(categorical_var, order)" |
|
| 208 | +1105 | ! |
- if (length(tables) == 0) {
+ plot_brush$mapping$panelvar1 <- categorical_var |
| 209 | -! | +||
| 1106 | +
- return(list())+ } |
||
| 210 | +1107 |
- }+ } else {
|
|
| 211 | +1108 | ! |
- table_tags <- c(lapply(seq_along(tables), function(idx) {
+ if (tab == "Boxplot") {
|
| 212 | -! | +||
| 1109 | +
- list(+ # in boxplot with no categorical variable, there is no column in ANL that would correspond to x-axis+ |
+ ||
| 1110 | ++ |
+ # so a column needs to be inserted with the value "Entire dataset" because that's the label used in plot |
|
| 213 | +1111 | ! |
- tableOutput(ns(paste0("table_", idx)))
+ ANL[[plot_brush$mapping$x]] <- "Entire dataset" |
| 214 | +1112 |
- )+ } |
|
| 215 | +1113 |
- }))- |
- |
| 216 | -! | -
- return(table_tags)+ } |
|
| 217 | +1114 |
- }+ |
|
| 218 | +1115 |
-
+ # in density and cumulative plots, ANL does not have a column corresponding to y-axis. |
|
| 219 | +1116 |
- get_footer_tags <- function(footnotes) {
+ # so they need to be computed and attached to ANL |
|
| 220 | +1117 | ! |
- if (length(footnotes) == 0) {
+ if (tab == "Density Plot") {
|
| 221 | +1118 | ! |
- return(list())- |
-
| 222 | -- |
- }+ plot_brush$mapping$y <- "density" |
|
| 223 | +1119 | ! |
- bold_texts <- if (is.null(names(footnotes))) rep("", length(footnotes)) else names(footnotes)
+ ANL$density <- plot_brush$ymin |
| 224 | -! | +||
| 1120 | +
- footnote_tags <- mapply(function(bold_text, value) {
+ # either ymin or ymax will work |
||
| 225 | +1121 | ! |
- list(+ } else if (tab == "Cumulative Distribution Plot") {
|
| 226 | +1122 | ! |
- tags$div(+ plot_brush$mapping$y <- "cdf" |
| 227 | +1123 | ! |
- tags$b(bold_text),+ if (length(categorical_var) > 0) {
|
| 228 | +1124 | ! |
- value,+ ANL <- ANL %>% |
| 229 | +1125 | ! |
- tags$br()+ dplyr::group_by(!!as.name(plot_brush$mapping$panelvar1)) %>% |
| 230 | -+ | ||
| 1126 | +! |
- )+ dplyr::mutate(cdf = stats::ecdf(!!as.name(outlier_var))(!!as.name(outlier_var))) |
|
| 231 | +1127 |
- )+ } else {
|
|
| 232 | +1128 | ! |
- }, bold_text = bold_texts, value = footnotes)+ ANL$cdf <- stats::ecdf(ANL[[outlier_var]])(ANL[[outlier_var]]) |
| 233 | +1129 |
- }+ } |
|
| 234 | +1130 |
-
+ } |
|
| 235 | +1131 |
- # take a list of metadata, one item per dataset (raw_metadata each element from datasets$get_metadata())+ |
|
| 236 | -+ | ||
| 1132 | +! |
- # and the corresponding datanames and output a data.frame with columns {Dataset, Name, Value}.
+ brushed_rows <- brushedPoints(ANL, plot_brush) |
|
| 237 | -+ | ||
| 1133 | +! |
- # which are, the Dataset the metadata came from, the metadata's name and value+ if (nrow(brushed_rows) > 0) {
|
|
| 238 | +1134 |
- convert_metadata_to_dataframe <- function(raw_metadata, datanames) {
+ # now we need to remove extra column from ANL so that it will have the same columns as ANL_OUTLIER |
|
| 239 | -4x | +||
| 1135 | +
- output <- mapply(function(metadata, dataname) {
+ # so that dplyr::intersect will work |
||
| 240 | -6x | +||
| 1136 | +! |
- if (is.null(metadata)) {
+ if (tab == "Density Plot") {
|
|
| 241 | -2x | +||
| 1137 | +! |
- return(data.frame(Dataset = character(0), Name = character(0), Value = character(0)))+ brushed_rows$density <- NULL |
|
| 242 | -+ | ||
| 1138 | +! |
- }+ } else if (tab == "Cumulative Distribution Plot") {
|
|
| 243 | -4x | +||
| 1139 | +! |
- return(data.frame(+ brushed_rows$cdf <- NULL |
|
| 244 | -4x | +||
| 1140 | +! |
- Dataset = dataname,+ } else if (tab == "Boxplot" && length(categorical_var) == 0) {
|
|
| 245 | -4x | +||
| 1141 | +! |
- Name = names(metadata),+ brushed_rows[[plot_brush$mapping$x]] <- NULL |
|
| 246 | -4x | +||
| 1142 | +
- Value = unname(unlist(lapply(metadata, as.character)))+ } |
||
| 247 | +1143 |
- ))+ # is_outlier_selected is part of ANL_OUTLIER so needed here |
|
| 248 | -4x | +||
| 1144 | +! |
- }, raw_metadata, datanames, SIMPLIFY = FALSE)+ brushed_rows$is_outlier_selected <- TRUE |
|
| 249 | -4x | +||
| 1145 | +! |
- do.call(rbind, output)+ dplyr::intersect(ANL_OUTLIER, brushed_rows) |
|
| 250 | +1146 |
- }+ } else {
|
| 1 | -+ | ||
| 1147 | +! |
- #' `teal` module: Scatterplot+ ANL_OUTLIER[0, ] |
|
| 2 | +1148 |
- #'+ } |
|
| 3 | +1149 |
- #' Generates a customizable scatterplot using `ggplot2`.+ } else {
|
|
| 4 | -+ | ||
| 1150 | +! |
- #' This module allows users to select variables for the x and y axes,+ ANL_OUTLIER[ANL_OUTLIER$is_outlier_selected, ] |
|
| 5 | +1151 |
- #' color and size encodings, faceting options, and more. It supports log transformations,+ } |
|
| 6 | +1152 |
- #' trend line additions, and dynamic adjustments of point opacity and size through UI controls.+ |
|
| 7 | -+ | ||
| 1153 | +! |
- #'+ display_table$is_outlier_selected <- NULL |
|
| 8 | +1154 |
- #' @note For more examples, please see the vignette "Using scatterplot" via+ |
|
| 9 | +1155 |
- #' `vignette("using-scatterplot", package = "teal.modules.general")`.
+ # Extend the brushed ANL_OUTLIER with additional columns |
|
| 10 | -+ | ||
| 1156 | +! |
- #'+ dplyr::left_join( |
|
| 11 | -+ | ||
| 1157 | +! |
- #' @inheritParams teal::module+ display_table, |
|
| 12 | -+ | ||
| 1158 | +! |
- #' @inheritParams shared_params+ dplyr::select(ANL_OUTLIER_EXTENDED, -"is_outlier_selected"), |
|
| 13 | -+ | ||
| 1159 | +! |
- #' @param x (`data_extract_spec` or `list` of multiple `data_extract_spec`) Specifies+ by = names(display_table) |
|
| 14 | +1160 |
- #' variable names selected to plot along the x-axis by default.+ ) %>% |
|
| 15 | -+ | ||
| 1161 | +! |
- #' @param y (`data_extract_spec` or `list` of multiple `data_extract_spec`) Specifies+ dplyr::select(union(names(display_table), input$table_ui_columns)) |
|
| 16 | +1162 |
- #' variable names selected to plot along the y-axis by default.+ }, |
|
| 17 | -+ | ||
| 1163 | +! |
- #' @param color_by (`data_extract_spec` or `list` of multiple `data_extract_spec`) optional,+ options = list( |
|
| 18 | -+ | ||
| 1164 | +! |
- #' defines the color encoding. If `NULL` then no color encoding option will be displayed.+ searching = FALSE, language = list( |
|
| 19 | -+ | ||
| 1165 | +! |
- #' @param size_by (`data_extract_spec` or `list` of multiple `data_extract_spec`) optional,+ zeroRecords = "The brushed area does not contain outlier observations for the currently defined threshold" |
|
| 20 | +1166 |
- #' defines the point size encoding. If `NULL` then no size encoding option will be displayed.+ ), |
|
| 21 | -+ | ||
| 1167 | +! |
- #' @param row_facet (`data_extract_spec` or `list` of multiple `data_extract_spec`) optional,+ pageLength = input$table_ui_rows |
|
| 22 | +1168 |
- #' specifies the variable(s) for faceting rows.+ ) |
|
| 23 | +1169 |
- #' @param col_facet (`data_extract_spec` or `list` of multiple `data_extract_spec`) optional,+ ) |
|
| 24 | +1170 |
- #' specifies the variable(s) for faceting columns.+ |
|
| 25 | -+ | ||
| 1171 | +! |
- #' @param shape (`character`) optional, character vector with the names of the+ output$total_outliers <- renderUI({
|
|
| 26 | -+ | ||
| 1172 | +! |
- #' shape, e.g. `c("triangle", "square", "circle")`. It defaults to `shape_names`. This is a complete list from
+ req(iv_r()$is_valid()) |
|
| 27 | -+ | ||
| 1173 | +! |
- #' `vignette("ggplot2-specs", package="ggplot2")`.
+ ANL <- merged$anl_q_r()[["ANL"]] |
|
| 28 | -+ | ||
| 1174 | +! |
- #' @param max_deg (`integer`) optional, maximum degree for the polynomial trend line. Must not be less than 1.+ ANL_OUTLIER <- common_code_q()[["ANL_OUTLIER"]] |
|
| 29 | -+ | ||
| 1175 | +! |
- #' @param table_dec (`integer`) optional, number of decimal places used to round numeric values in the table.+ teal::validate_has_data(ANL, 1) |
|
| 30 | -+ | ||
| 1176 | +! |
- #'+ ANL_OUTLIER_SELECTED <- ANL_OUTLIER[ANL_OUTLIER$is_outlier_selected, ] |
|
| 31 | -+ | ||
| 1177 | +! |
- #' @inherit shared_params return+ tags$h5( |
|
| 32 | -+ | ||
| 1178 | +! |
- #'+ sprintf( |
|
| 33 | -+ | ||
| 1179 | +! |
- #' @examplesShinylive+ "%s %d / %d [%.02f%%]", |
|
| 34 | -+ | ||
| 1180 | +! |
- #' library(teal.modules.general)+ "Total number of outlier(s):", |
|
| 35 | -+ | ||
| 1181 | +! |
- #' interactive <- function() TRUE+ nrow(ANL_OUTLIER_SELECTED), |
|
| 36 | -+ | ||
| 1182 | +! |
- #' {{ next_example }}
+ nrow(ANL), |
|
| 37 | -+ | ||
| 1183 | +! |
- # nolint start: line_length_linter.+ 100 * nrow(ANL_OUTLIER_SELECTED) / nrow(ANL) |
|
| 38 | +1184 |
- #' @examplesIf require("ggpmisc", quietly = TRUE) && require("ggExtra", quietly = TRUE) && require("colourpicker", quietly = TRUE)
+ ) |
|
| 39 | +1185 |
- # nolint end: line_length_linter.+ ) |
|
| 40 | +1186 |
- #' # general data example+ }) |
|
| 41 | +1187 |
- #' data <- teal_data()+ |
|
| 42 | -+ | ||
| 1188 | +! |
- #' data <- within(data, {
+ output$total_missing <- renderUI({
|
|
| 43 | -+ | ||
| 1189 | +! |
- #' require(nestcolor)+ if (n_outlier_missing() > 0) {
|
|
| 44 | -+ | ||
| 1190 | +! |
- #' CO2 <- CO2+ ANL <- merged$anl_q_r()[["ANL"]] |
|
| 45 | -+ | ||
| 1191 | +! |
- #' })+ helpText( |
|
| 46 | -+ | ||
| 1192 | +! |
- #' datanames(data) <- "CO2"+ sprintf( |
|
| 47 | -+ | ||
| 1193 | +! |
- #'+ "%s %d / %d [%.02f%%]", |
|
| 48 | -+ | ||
| 1194 | +! |
- #' app <- init(+ "Total number of row(s) with missing values:", |
|
| 49 | -+ | ||
| 1195 | +! |
- #' data = data,+ n_outlier_missing(), |
|
| 50 | -+ | ||
| 1196 | +! |
- #' modules = modules(+ nrow(ANL), |
|
| 51 | -+ | ||
| 1197 | +! |
- #' tm_g_scatterplot(+ 100 * (n_outlier_missing()) / nrow(ANL) |
|
| 52 | +1198 |
- #' label = "Scatterplot Choices",+ ) |
|
| 53 | +1199 |
- #' x = data_extract_spec(+ ) |
|
| 54 | +1200 |
- #' dataname = "CO2",+ } |
|
| 55 | +1201 |
- #' select = select_spec(+ }) |
|
| 56 | +1202 |
- #' label = "Select variable:",+ |
|
| 57 | -+ | ||
| 1203 | +! |
- #' choices = variable_choices(data[["CO2"]], c("conc", "uptake")),
+ output$table_ui_wrap <- renderUI({
|
|
| 58 | -+ | ||
| 1204 | +! |
- #' selected = "conc",+ req(iv_r()$is_valid()) |
|
| 59 | -+ | ||
| 1205 | +! |
- #' multiple = FALSE,+ tagList( |
|
| 60 | -+ | ||
| 1206 | +! |
- #' fixed = FALSE+ teal.widgets::optionalSelectInput( |
|
| 61 | -+ | ||
| 1207 | +! |
- #' )+ inputId = ns("table_ui_columns"),
|
|
| 62 | -+ | ||
| 1208 | +! |
- #' ),+ label = "Choose additional columns", |
|
| 63 | -+ | ||
| 1209 | +! |
- #' y = data_extract_spec(+ choices = NULL, |
|
| 64 | -+ | ||
| 1210 | +! |
- #' dataname = "CO2",+ selected = NULL, |
|
| 65 | -+ | ||
| 1211 | +! |
- #' select = select_spec(+ multiple = TRUE |
|
| 66 | +1212 |
- #' label = "Select variable:",+ ), |
|
| 67 | -+ | ||
| 1213 | +! |
- #' choices = variable_choices(data[["CO2"]], c("conc", "uptake")),
+ tags$h4("Outlier Table"),
|
|
| 68 | -+ | ||
| 1214 | +! |
- #' selected = "uptake",+ teal.widgets::get_dt_rows(ns("table_ui"), ns("table_ui_rows"))
|
|
| 69 | +1215 |
- #' multiple = FALSE,+ ) |
|
| 70 | +1216 |
- #' fixed = FALSE+ }) |
|
| 71 | +1217 |
- #' )+ |
|
| 72 | -+ | ||
| 1218 | +! |
- #' ),+ teal.widgets::verbatim_popup_srv( |
|
| 73 | -+ | ||
| 1219 | +! |
- #' color_by = data_extract_spec(+ id = "rcode", |
|
| 74 | -+ | ||
| 1220 | +! |
- #' dataname = "CO2",+ verbatim_content = reactive(teal.code::get_code(final_q())), |
|
| 75 | -+ | ||
| 1221 | +! |
- #' select = select_spec(+ title = "Show R Code for Outlier" |
|
| 76 | +1222 |
- #' label = "Select variable:",+ ) |
|
| 77 | +1223 |
- #' choices = variable_choices(+ |
|
| 78 | +1224 |
- #' data[["CO2"]],+ ### REPORTER |
|
| 79 | -+ | ||
| 1225 | +! |
- #' c("Plant", "Type", "Treatment", "conc", "uptake")
+ if (with_reporter) {
|
|
| 80 | -+ | ||
| 1226 | +! |
- #' ),+ card_fun <- function(comment, label) {
|
|
| 81 | -+ | ||
| 1227 | +! |
- #' selected = NULL,+ tab_type <- input$tabs |
|
| 82 | -+ | ||
| 1228 | +! |
- #' multiple = FALSE,+ card <- teal::report_card_template( |
|
| 83 | -+ | ||
| 1229 | +! |
- #' fixed = FALSE+ title = paste0("Outliers - ", tab_type),
|
|
| 84 | -+ | ||
| 1230 | +! |
- #' )+ label = label, |
|
| 85 | -+ | ||
| 1231 | +! |
- #' ),+ with_filter = with_filter, |
|
| 86 | -+ | ||
| 1232 | +! |
- #' size_by = data_extract_spec(+ filter_panel_api = filter_panel_api |
|
| 87 | +1233 |
- #' dataname = "CO2",+ ) |
|
| 88 | -+ | ||
| 1234 | +! |
- #' select = select_spec(+ categorical_var <- as.vector(merged$anl_input_r()$columns_source$categorical_var) |
|
| 89 | -+ | ||
| 1235 | +! |
- #' label = "Select variable:",+ if (length(categorical_var) > 0) {
|
|
| 90 | -+ | ||
| 1236 | +! |
- #' choices = variable_choices(data[["CO2"]], c("conc", "uptake")),
+ summary_table <- common_code_q()[["summary_table"]] |
|
| 91 | -+ | ||
| 1237 | +! |
- #' selected = "uptake",+ card$append_text("Summary Table", "header3")
|
|
| 92 | -+ | ||
| 1238 | +! |
- #' multiple = FALSE,+ card$append_table(summary_table) |
|
| 93 | +1239 |
- #' fixed = FALSE+ } |
|
| 94 | -+ | ||
| 1240 | +! |
- #' )+ card$append_text("Plot", "header3")
|
|
| 95 | -+ | ||
| 1241 | +! |
- #' ),+ if (tab_type == "Boxplot") {
|
|
| 96 | -+ | ||
| 1242 | +! |
- #' row_facet = data_extract_spec(+ card$append_plot(boxplot_r(), dim = box_pws$dim()) |
|
| 97 | -+ | ||
| 1243 | +! |
- #' dataname = "CO2",+ } else if (tab_type == "Density Plot") {
|
|
| 98 | -+ | ||
| 1244 | +! |
- #' select = select_spec(+ card$append_plot(density_plot_r(), dim = density_pws$dim()) |
|
| 99 | -+ | ||
| 1245 | +! |
- #' label = "Select variable:",+ } else if (tab_type == "Cumulative Distribution Plot") {
|
|
| 100 | -+ | ||
| 1246 | +! |
- #' choices = variable_choices(data[["CO2"]], c("Plant", "Type", "Treatment")),
+ card$append_plot(cumulative_plot_r(), dim = cum_density_pws$dim()) |
|
| 101 | +1247 |
- #' selected = NULL,+ } |
|
| 102 | -+ | ||
| 1248 | +! |
- #' multiple = FALSE,+ if (!comment == "") {
|
|
| 103 | -+ | ||
| 1249 | +! |
- #' fixed = FALSE+ card$append_text("Comment", "header3")
|
|
| 104 | -+ | ||
| 1250 | +! |
- #' )+ card$append_text(comment) |
|
| 105 | +1251 |
- #' ),+ } |
|
| 106 | -+ | ||
| 1252 | +! |
- #' col_facet = data_extract_spec(+ card$append_src(teal.code::get_code(final_q())) |
|
| 107 | -+ | ||
| 1253 | +! |
- #' dataname = "CO2",+ card |
|
| 108 | +1254 |
- #' select = select_spec(+ } |
|
| 109 | -+ | ||
| 1255 | +! |
- #' label = "Select variable:",+ teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
|
|
| 110 | +1256 |
- #' choices = variable_choices(data[["CO2"]], c("Plant", "Type", "Treatment")),
+ } |
|
| 111 | +1257 |
- #' selected = NULL,+ ### |
|
| 112 | +1258 |
- #' multiple = FALSE,+ }) |
|
| 113 | +1259 |
- #' fixed = FALSE+ } |
| 114 | +1 |
- #' )+ #' `teal` module: Data table viewer |
|
| 115 | +2 |
- #' )+ #' |
|
| 116 | +3 |
- #' )+ #' Module provides a dynamic and interactive way to view `data.frame`s in a `teal` application. |
|
| 117 | +4 |
- #' )+ #' It uses the `DT` package to display data tables in a paginated, searchable, and sortable format, |
|
| 118 | +5 |
- #' )+ #' which helps to enhance data exploration and analysis. |
|
| 119 | +6 |
- #' if (interactive()) {
+ #' |
|
| 120 | +7 |
- #' shinyApp(app$ui, app$server)+ #' The `DT` package has an option `DT.TOJSON_ARGS` to show `Inf` and `NA` in data tables. |
|
| 121 | +8 |
- #' }+ #' Configure the `DT.TOJSON_ARGS` option via |
|
| 122 | +9 |
- #'+ #' `options(DT.TOJSON_ARGS = list(na = "string"))` before running the module. |
|
| 123 | +10 |
- #' @examplesShinylive+ #' Note though that sorting of numeric columns with `NA`/`Inf` will be lexicographic not numerical. |
|
| 124 | +11 |
- #' library(teal.modules.general)+ #' |
|
| 125 | +12 |
- #' interactive <- function() TRUE+ #' @inheritParams teal::module |
|
| 126 | +13 |
- #' {{ next_example }}
+ #' @inheritParams shared_params |
|
| 127 | +14 |
- # nolint start: line_length_linter.+ #' @param variables_selected (`named list`) Character vectors of the variables (i.e. columns) |
|
| 128 | +15 |
- #' @examplesIf require("ggpmisc", quietly = TRUE) && require("ggExtra", quietly = TRUE) && require("colourpicker", quietly = TRUE)
+ #' which should be initially shown for each dataset. |
|
| 129 | +16 |
- # nolint end: line_length_linter.+ #' Names of list elements should correspond to the names of the datasets available in the app. |
|
| 130 | +17 |
- #' # CDISC data example+ #' If no entry is specified for a dataset, the first six variables from that |
|
| 131 | +18 |
- #' data <- teal_data()+ #' dataset will initially be shown. |
|
| 132 | +19 |
- #' data <- within(data, {
+ #' @param datasets_selected (`character`) A vector of datasets which should be |
|
| 133 | +20 |
- #' require(nestcolor)+ #' shown and in what order. Names in the vector have to correspond with datasets names. |
|
| 134 | +21 |
- #' ADSL <- rADSL+ #' If vector of `length == 0` (default) then all datasets are shown. |
|
| 135 | +22 |
- #' })+ #' Note: Only datasets of the `data.frame` class are compatible. |
|
| 136 | +23 |
- #' datanames(data) <- c("ADSL")
+ #' @param dt_args (`named list`) Additional arguments to be passed to [DT::datatable()] |
|
| 137 | +24 |
- #' join_keys(data) <- default_cdisc_join_keys[datanames(data)]+ #' (must not include `data` or `options`). |
|
| 138 | +25 |
- #'+ #' @param dt_options (`named list`) The `options` argument to `DT::datatable`. By default |
|
| 139 | +26 |
- #' app <- init(+ #' `list(searching = FALSE, pageLength = 30, lengthMenu = c(5, 15, 30, 100), scrollX = TRUE)` |
|
| 140 | +27 |
- #' data = data,+ #' @param server_rendering (`logical`) should the data table be rendered server side |
|
| 141 | +28 |
- #' modules = modules(+ #' (see `server` argument of [DT::renderDataTable()]) |
|
| 142 | +29 |
- #' tm_g_scatterplot(+ #' |
|
| 143 | +30 |
- #' label = "Scatterplot Choices",+ #' @inherit shared_params return |
|
| 144 | +31 |
- #' x = data_extract_spec(+ #' |
|
| 145 | +32 |
- #' dataname = "ADSL",+ #' @examplesShinylive |
|
| 146 | +33 |
- #' select = select_spec(+ #' library(teal.modules.general) |
|
| 147 | +34 |
- #' label = "Select variable:",+ #' interactive <- function() TRUE |
|
| 148 | +35 |
- #' choices = variable_choices(data[["ADSL"]], c("AGE", "BMRKR1", "BMRKR2")),
+ #' {{ next_example }}
|
|
| 149 | +36 |
- #' selected = "AGE",+ #' @examples |
|
| 150 | +37 |
- #' multiple = FALSE,+ #' # general data example |
|
| 151 | +38 |
- #' fixed = FALSE+ #' data <- teal_data() |
|
| 152 | +39 |
- #' )+ #' data <- within(data, {
|
|
| 153 | +40 |
- #' ),+ #' require(nestcolor) |
|
| 154 | +41 |
- #' y = data_extract_spec(+ #' iris <- iris |
|
| 155 | +42 |
- #' dataname = "ADSL",+ #' }) |
|
| 156 | +43 |
- #' select = select_spec(+ #' |
|
| 157 | +44 |
- #' label = "Select variable:",+ #' app <- init( |
|
| 158 | +45 |
- #' choices = variable_choices(data[["ADSL"]], c("AGE", "BMRKR1", "BMRKR2")),
+ #' data = data, |
|
| 159 | +46 |
- #' selected = "BMRKR1",+ #' modules = modules( |
|
| 160 | +47 |
- #' multiple = FALSE,+ #' tm_data_table( |
|
| 161 | +48 |
- #' fixed = FALSE+ #' variables_selected = list( |
|
| 162 | +49 |
- #' )+ #' iris = c("Sepal.Length", "Sepal.Width", "Petal.Length", "Petal.Width", "Species")
|
|
| 163 | +50 |
#' ), |
|
| 164 | +51 |
- #' color_by = data_extract_spec(+ #' dt_args = list(caption = "IRIS Table Caption") |
|
| 165 | +52 |
- #' dataname = "ADSL",+ #' ) |
|
| 166 | +53 |
- #' select = select_spec(+ #' ) |
|
| 167 | +54 |
- #' label = "Select variable:",+ #' ) |
|
| 168 | +55 |
- #' choices = variable_choices(+ #' if (interactive()) {
|
|
| 169 | +56 |
- #' data[["ADSL"]],+ #' shinyApp(app$ui, app$server) |
|
| 170 | +57 |
- #' c("AGE", "BMRKR1", "BMRKR2", "RACE", "REGION1")
+ #' } |
|
| 171 | +58 |
- #' ),+ #' |
|
| 172 | +59 |
- #' selected = NULL,+ #' @examplesShinylive |
|
| 173 | +60 |
- #' multiple = FALSE,+ #' library(teal.modules.general) |
|
| 174 | +61 |
- #' fixed = FALSE+ #' interactive <- function() TRUE |
|
| 175 | +62 |
- #' )+ #' {{ next_example }}
|
|
| 176 | +63 |
- #' ),+ #' @examples |
|
| 177 | +64 |
- #' size_by = data_extract_spec(+ #' # CDISC data example |
|
| 178 | +65 |
- #' dataname = "ADSL",+ #' data <- teal_data() |
|
| 179 | +66 |
- #' select = select_spec(+ #' data <- within(data, {
|
|
| 180 | +67 |
- #' label = "Select variable:",+ #' require(nestcolor) |
|
| 181 | +68 |
- #' choices = variable_choices(data[["ADSL"]], c("AGE", "BMRKR1")),
+ #' ADSL <- rADSL |
|
| 182 | +69 |
- #' selected = "AGE",+ #' }) |
|
| 183 | +70 |
- #' multiple = FALSE,+ #' join_keys(data) <- default_cdisc_join_keys[names(data)] |
|
| 184 | +71 |
- #' fixed = FALSE+ #' |
|
| 185 | +72 |
- #' )+ #' app <- init( |
|
| 186 | +73 |
- #' ),+ #' data = data, |
|
| 187 | +74 |
- #' row_facet = data_extract_spec(+ #' modules = modules( |
|
| 188 | +75 |
- #' dataname = "ADSL",+ #' tm_data_table( |
|
| 189 | +76 |
- #' select = select_spec(+ #' variables_selected = list(ADSL = c("STUDYID", "USUBJID", "SUBJID", "SITEID", "AGE", "SEX")),
|
|
| 190 | +77 |
- #' label = "Select variable:",+ #' dt_args = list(caption = "ADSL Table Caption") |
|
| 191 | +78 |
- #' choices = variable_choices(data[["ADSL"]], c("BMRKR2", "RACE", "REGION1")),
+ #' ) |
|
| 192 | +79 |
- #' selected = NULL,+ #' ) |
|
| 193 | +80 |
- #' multiple = FALSE,+ #' ) |
|
| 194 | +81 |
- #' fixed = FALSE+ #' if (interactive()) {
|
|
| 195 | +82 |
- #' )+ #' shinyApp(app$ui, app$server) |
|
| 196 | +83 |
- #' ),+ #' } |
|
| 197 | +84 |
- #' col_facet = data_extract_spec(+ #' |
|
| 198 | +85 |
- #' dataname = "ADSL",+ #' @export |
|
| 199 | +86 |
- #' select = select_spec(+ #' |
|
| 200 | +87 |
- #' label = "Select variable:",+ tm_data_table <- function(label = "Data Table", |
|
| 201 | +88 |
- #' choices = variable_choices(data[["ADSL"]], c("BMRKR2", "RACE", "REGION1")),
+ variables_selected = list(), |
|
| 202 | +89 |
- #' selected = NULL,+ datasets_selected = character(0), |
|
| 203 | +90 |
- #' multiple = FALSE,+ dt_args = list(), |
|
| 204 | +91 |
- #' fixed = FALSE+ dt_options = list( |
|
| 205 | +92 |
- #' )+ searching = FALSE, |
|
| 206 | +93 |
- #' )+ pageLength = 30, |
|
| 207 | +94 |
- #' )+ lengthMenu = c(5, 15, 30, 100), |
|
| 208 | +95 |
- #' )+ scrollX = TRUE |
|
| 209 | +96 |
- #' )+ ), |
|
| 210 | +97 |
- #' if (interactive()) {
+ server_rendering = FALSE, |
|
| 211 | +98 |
- #' shinyApp(app$ui, app$server)+ pre_output = NULL, |
|
| 212 | +99 |
- #' }+ post_output = NULL) {
|
|
| 213 | -+ | ||
| 100 | +! |
- #'+ message("Initializing tm_data_table")
|
|
| 214 | +101 |
- #' @export+ |
|
| 215 | +102 |
- #'+ # Start of assertions |
|
| 216 | -+ | ||
| 103 | +! |
- tm_g_scatterplot <- function(label = "Scatterplot",+ checkmate::assert_string(label) |
|
| 217 | +104 |
- x,+ |
|
| 218 | -+ | ||
| 105 | +! |
- y,+ checkmate::assert_list(variables_selected, min.len = 0, types = "character", names = "named") |
|
| 219 | -+ | ||
| 106 | +! |
- color_by = NULL,+ if (length(variables_selected) > 0) {
|
|
| 220 | -+ | ||
| 107 | +! |
- size_by = NULL,+ lapply(seq_along(variables_selected), function(i) {
|
|
| 221 | -+ | ||
| 108 | +! |
- row_facet = NULL,+ checkmate::assert_character(variables_selected[[i]], min.chars = 1, min.len = 1) |
|
| 222 | -+ | ||
| 109 | +! |
- col_facet = NULL,+ if (!is.null(names(variables_selected[[i]]))) {
|
|
| 223 | -+ | ||
| 110 | +! |
- plot_height = c(600, 200, 2000),+ checkmate::assert_names(names(variables_selected[[i]])) |
|
| 224 | +111 |
- plot_width = NULL,+ } |
|
| 225 | +112 |
- alpha = c(1, 0, 1),+ }) |
|
| 226 | +113 |
- shape = shape_names,+ } |
|
| 227 | +114 |
- size = c(5, 1, 15),+ |
|
| 228 | -+ | ||
| 115 | +! |
- max_deg = 5L,+ checkmate::assert_character(datasets_selected, min.len = 0, min.chars = 1) |
|
| 229 | -+ | ||
| 116 | +! |
- rotate_xaxis_labels = FALSE,+ checkmate::assert( |
|
| 230 | -+ | ||
| 117 | +! |
- ggtheme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void"),
+ checkmate::check_list(dt_args, len = 0), |
|
| 231 | -+ | ||
| 118 | +! |
- pre_output = NULL,+ checkmate::check_subset(names(dt_args), choices = names(formals(DT::datatable))) |
|
| 232 | +119 |
- post_output = NULL,+ ) |
|
| 233 | -+ | ||
| 120 | +! |
- table_dec = 4,+ checkmate::assert_list(dt_options, names = "named") |
|
| 234 | -+ | ||
| 121 | +! |
- ggplot2_args = teal.widgets::ggplot2_args()) {
+ checkmate::assert_flag(server_rendering) |
|
| 235 | +122 | ! |
- message("Initializing tm_g_scatterplot")
+ checkmate::assert_multi_class(pre_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
+ |
+
| 123 | +! | +
+ checkmate::assert_multi_class(post_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
|
|
| 236 | +124 |
-
+ # End of assertions |
|
| 237 | +125 |
- # Requires Suggested packages+ |
|
| 238 | +126 | ! |
- extra_packages <- c("ggpmisc", "ggExtra", "colourpicker")
+ ans <- module( |
| 239 | +127 | ! |
- missing_packages <- Filter(function(x) !requireNamespace(x, quietly = TRUE), extra_packages)+ label, |
| 240 | +128 | ! |
- if (length(missing_packages) > 0L) {
+ server = srv_page_data_table, |
| 241 | +129 | ! |
- stop(sprintf(+ ui = ui_page_data_table, |
| 242 | +130 | ! |
- "Cannot load package(s): %s.\nInstall or restart your session.",+ datanames = if (length(datasets_selected) == 0) "all" else datasets_selected, |
| 243 | +131 | ! |
- toString(missing_packages)- |
-
| 244 | -- |
- ))- |
- |
| 245 | -- |
- }+ server_args = list( |
|
| 246 | -+ | ||
| 132 | +! |
-
+ variables_selected = variables_selected, |
|
| 247 | -+ | ||
| 133 | +! |
- # Normalize the parameters+ datasets_selected = datasets_selected, |
|
| 248 | +134 | ! |
- if (inherits(x, "data_extract_spec")) x <- list(x)+ dt_args = dt_args, |
| 249 | +135 | ! |
- if (inherits(y, "data_extract_spec")) y <- list(y)+ dt_options = dt_options, |
| 250 | +136 | ! |
- if (inherits(color_by, "data_extract_spec")) color_by <- list(color_by)+ server_rendering = server_rendering |
| 251 | -! | +||
| 137 | +
- if (inherits(size_by, "data_extract_spec")) size_by <- list(size_by)+ ), |
||
| 252 | +138 | ! |
- if (inherits(row_facet, "data_extract_spec")) row_facet <- list(row_facet)+ ui_args = list( |
| 253 | +139 | ! |
- if (inherits(col_facet, "data_extract_spec")) col_facet <- list(col_facet)+ pre_output = pre_output, |
| 254 | +140 | ! |
- if (is.double(max_deg)) max_deg <- as.integer(max_deg)+ post_output = post_output |
| 255 | +141 |
-
+ ) |
|
| 256 | +142 |
- # Start of assertions- |
- |
| 257 | -! | -
- checkmate::assert_string(label)- |
- |
| 258 | -! | -
- checkmate::assert_list(x, types = "data_extract_spec")+ ) |
|
| 259 | +143 | ! |
- checkmate::assert_list(y, types = "data_extract_spec")+ attr(ans, "teal_bookmarkable") <- TRUE |
| 260 | +144 | ! |
- checkmate::assert_list(color_by, types = "data_extract_spec", null.ok = TRUE)+ ans |
| 261 | -! | +||
| 145 | +
- checkmate::assert_list(size_by, types = "data_extract_spec", null.ok = TRUE)+ } |
||
| 262 | +146 | ||
| 263 | -! | +||
| 147 | +
- checkmate::assert_list(row_facet, types = "data_extract_spec", null.ok = TRUE)+ # UI page module |
||
| 264 | -! | +||
| 148 | +
- assert_single_selection(row_facet)+ ui_page_data_table <- function(id, |
||
| 265 | +149 |
-
+ pre_output = NULL, |
|
| 266 | -! | +||
| 150 | +
- checkmate::assert_list(col_facet, types = "data_extract_spec", null.ok = TRUE)+ post_output = NULL) {
|
||
| 267 | +151 | ! |
- assert_single_selection(col_facet)+ ns <- NS(id) |
| 268 | +152 | ||
| 269 | +153 | ! |
- checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE)+ tagList( |
| 270 | +154 | ! |
- checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height")+ include_css_files("custom"),
|
| 271 | +155 | ! |
- checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE)+ teal.widgets::standard_layout( |
| 272 | +156 | ! |
- checkmate::assert_numeric(+ output = teal.widgets::white_small_well( |
| 273 | +157 | ! |
- plot_width[1],+ fluidRow( |
| 274 | +158 | ! |
- lower = plot_width[2], upper = plot_width[3], null.ok = TRUE, .var.name = "plot_width"- |
-
| 275 | -- |
- )- |
- |
| 276 | -- |
-
+ column( |
|
| 277 | +159 | ! |
- if (length(alpha) == 1) {
+ width = 12, |
| 278 | +160 | ! |
- checkmate::assert_numeric(alpha, any.missing = FALSE, finite = TRUE)+ checkboxInput( |
| 279 | -+ | ||
| 161 | +! |
- } else {
+ ns("if_distinct"),
|
|
| 280 | +162 | ! |
- checkmate::assert_numeric(alpha, len = 3, any.missing = FALSE, finite = TRUE)+ "Show only distinct rows:", |
| 281 | +163 | ! |
- checkmate::assert_numeric(alpha[1], lower = alpha[2], upper = alpha[3], .var.name = "alpha")+ value = FALSE |
| 282 | +164 |
- }+ ) |
|
| 283 | +165 | - - | -|
| 284 | -! | -
- checkmate::assert_character(shape)+ ) |
|
| 285 | +166 |
-
+ ), |
|
| 286 | +167 | ! |
- if (length(size) == 1) {
+ fluidRow( |
| 287 | +168 | ! |
- checkmate::assert_numeric(size, any.missing = FALSE, finite = TRUE)+ class = "mb-8", |
| 288 | -+ | ||
| 169 | +! |
- } else {
+ column( |
|
| 289 | +170 | ! |
- checkmate::assert_numeric(size, len = 3, any.missing = FALSE, finite = TRUE)+ width = 12, |
| 290 | +171 | ! |
- checkmate::assert_numeric(size[1], lower = size[2], upper = size[3], .var.name = "size")+ uiOutput(ns("dataset_table"))
|
| 291 | +172 |
- }+ ) |
|
| 292 | +173 |
-
+ ) |
|
| 293 | -! | +||
| 174 | +
- checkmate::assert_int(max_deg, lower = 1L)+ ), |
||
| 294 | +175 | ! |
- checkmate::assert_flag(rotate_xaxis_labels)+ pre_output = pre_output, |
| 295 | +176 | ! |
- ggtheme <- match.arg(ggtheme)+ post_output = post_output |
| 296 | +177 |
-
+ ) |
|
| 297 | -! | +||
| 178 | +
- checkmate::assert_multi_class(pre_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
+ ) |
||
| 298 | -! | +||
| 179 | +
- checkmate::assert_multi_class(post_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
+ } |
||
| 299 | +180 | ||
| 300 | -! | -
- checkmate::assert_scalar(table_dec)- |
- |
| 301 | -! | -
- checkmate::assert_class(ggplot2_args, "ggplot2_args")- |
- |
| 302 | +181 |
- # End of assertions+ # Server page module |
|
| 303 | +182 |
-
+ srv_page_data_table <- function(id, |
|
| 304 | +183 |
- # Make UI args+ data, |
|
| 305 | -! | +||
| 184 | +
- args <- as.list(environment())+ datasets_selected, |
||
| 306 | +185 |
-
+ variables_selected, |
|
| 307 | -! | +||
| 186 | +
- data_extract_list <- list(+ dt_args, |
||
| 308 | -! | +||
| 187 | +
- x = x,+ dt_options, |
||
| 309 | -! | +||
| 188 | +
- y = y,+ server_rendering) {
|
||
| 310 | +189 | ! |
- color_by = color_by,+ checkmate::assert_class(data, "reactive") |
| 311 | +190 | ! |
- size_by = size_by,+ checkmate::assert_class(isolate(data()), "teal_data") |
| 312 | +191 | ! |
- row_facet = row_facet,+ moduleServer(id, function(input, output, session) {
|
| 313 | +192 | ! |
- col_facet = col_facet- |
-
| 314 | -- |
- )+ teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.general") |
|
| 315 | +193 | ||
| 316 | -! | -
- ans <- module(- |
- |
| 317 | +194 | ! |
- label = label,+ if_filtered <- reactive(as.logical(input$if_filtered)) |
| 318 | +195 | ! |
- server = srv_g_scatterplot,+ if_distinct <- reactive(as.logical(input$if_distinct)) |
| 319 | -! | +||
| 196 | +
- ui = ui_g_scatterplot,+ |
||
| 320 | +197 | ! |
- ui_args = args,+ datanames <- isolate(names(data())) |
| 321 | +198 | ! |
- server_args = c(+ datanames <- Filter(function(name) {
|
| 322 | +199 | ! |
- data_extract_list,+ is.data.frame(isolate(data())[[name]]) |
| 323 | +200 | ! |
- list(plot_height = plot_height, plot_width = plot_width, table_dec = table_dec, ggplot2_args = ggplot2_args)+ }, datanames) |
| 324 | +201 |
- ),+ |
|
| 325 | +202 | ! |
- datanames = teal.transform::get_extract_datanames(data_extract_list)- |
-
| 326 | -- |
- )+ if (!identical(datasets_selected, character(0))) {
|
|
| 327 | +203 | ! |
- attr(ans, "teal_bookmarkable") <- TRUE+ checkmate::assert_subset(datasets_selected, datanames) |
| 328 | +204 | ! |
- ans+ datanames <- datasets_selected |
| 329 | +205 |
- }+ } |
|
| 330 | +206 | ||
| 331 | -- |
- # UI function for the scatterplot module- |
- |
| 332 | -- |
- ui_g_scatterplot <- function(id, ...) {
- |
- |
| 333 | +207 | ! |
- args <- list(...)+ output$dataset_table <- renderUI({
|
| 334 | +208 | ! |
- ns <- NS(id)+ do.call( |
| 335 | +209 | ! |
- is_single_dataset_value <- teal.transform::is_single_dataset(+ tabsetPanel, |
| 336 | +210 | ! |
- args$x, args$y, args$color_by, args$size_by, args$row_facet, args$col_facet+ c( |
| 337 | -+ | ||
| 211 | +! |
- )+ list(id = session$ns("dataname_tab")),
|
|
| 338 | -+ | ||
| 212 | +! |
-
+ lapply( |
|
| 339 | +213 | ! |
- tagList(+ datanames, |
| 340 | +214 | ! |
- include_css_files("custom"),
+ function(x) {
|
| 341 | +215 | ! |
- teal.widgets::standard_layout(+ dataset <- isolate(data()[[x]]) |
| 342 | +216 | ! |
- output = teal.widgets::white_small_well(+ choices <- names(dataset) |
| 343 | +217 | ! |
- teal.widgets::plot_with_settings_ui(id = ns("scatter_plot")),
+ labels <- vapply( |
| 344 | +218 | ! |
- tags$h1(tags$strong("Selected points:"), class = "text-center font-150p"),
+ dataset, |
| 345 | +219 | ! |
- teal.widgets::get_dt_rows(ns("data_table"), ns("data_table_rows")),
+ function(x) ifelse(is.null(attr(x, "label")), "", attr(x, "label")), |
| 346 | +220 | ! |
- DT::dataTableOutput(ns("data_table"), width = "100%")
+ character(1) |
| 347 | +221 |
- ),+ ) |
|
| 348 | +222 | ! |
- encoding = tags$div(+ names(choices) <- ifelse( |
| 349 | -+ | ||
| 223 | +! |
- ### Reporter+ is.na(labels) | labels == "", |
|
| 350 | +224 | ! |
- teal.reporter::simple_reporter_ui(ns("simple_reporter")),
+ choices,+ |
+
| 225 | +! | +
+ paste(choices, labels, sep = ": ") |
|
| 351 | +226 |
- ###+ ) |
|
| 352 | +227 | ! |
- tags$label("Encodings", class = "text-primary"),
+ variables_selected <- if (!is.null(variables_selected[[x]])) {
|
| 353 | +228 | ! |
- teal.transform::datanames_input(args[c("x", "y", "color_by", "size_by", "row_facet", "col_facet")]),
+ variables_selected[[x]] |
| 354 | -! | +||
| 229 | +
- teal.transform::data_extract_ui(+ } else {
|
||
| 355 | +230 | ! |
- id = ns("x"),
+ utils::head(choices) |
| 356 | -! | +||
| 231 | +
- label = "X variable",+ } |
||
| 357 | +232 | ! |
- data_extract_spec = args$x,+ tabPanel( |
| 358 | +233 | ! |
- is_single_dataset = is_single_dataset_value- |
-
| 359 | -- |
- ),+ title = x, |
|
| 360 | +234 | ! |
- checkboxInput(ns("log_x"), "Use log transformation", value = FALSE),
+ column( |
| 361 | +235 | ! |
- conditionalPanel(+ width = 12, |
| 362 | +236 | ! |
- condition = paste0("input['", ns("log_x"), "'] == true"),
+ div( |
| 363 | +237 | ! |
- radioButtons(+ class = "mt-4", |
| 364 | +238 | ! |
- ns("log_x_base"),
+ ui_data_table( |
| 365 | +239 | ! |
- label = NULL,+ id = session$ns(x), |
| 366 | +240 | ! |
- inline = TRUE,+ choices = choices, |
| 367 | +241 | ! |
- choices = c("Natural" = "log", "Base 10" = "log10", "Base 2" = "log2")
+ selected = variables_selected |
| 368 | +242 |
- )+ ) |
|
| 369 | +243 |
- ),+ ) |
|
| 370 | -! | +||
| 244 | +
- teal.transform::data_extract_ui(+ ) |
||
| 371 | -! | +||
| 245 | +
- id = ns("y"),
+ ) |
||
| 372 | -! | +||
| 246 | +
- label = "Y variable",+ } |
||
| 373 | -! | +||
| 247 | +
- data_extract_spec = args$y,+ ) |
||
| 374 | -! | +||
| 248 | +
- is_single_dataset = is_single_dataset_value+ ) |
||
| 375 | +249 |
- ),+ ) |
|
| 376 | -! | +||
| 250 | +
- checkboxInput(ns("log_y"), "Use log transformation", value = FALSE),
+ }) |
||
| 377 | -! | +||
| 251 | +
- conditionalPanel(+ |
||
| 378 | +252 | ! |
- condition = paste0("input['", ns("log_y"), "'] == true"),
+ lapply( |
| 379 | +253 | ! |
- radioButtons(+ datanames, |
| 380 | +254 | ! |
- ns("log_y_base"),
+ function(x) {
|
| 381 | +255 | ! |
- label = NULL,+ srv_data_table( |
| 382 | +256 | ! |
- inline = TRUE,+ id = x, |
| 383 | +257 | ! |
- choices = c("Natural" = "log", "Base 10" = "log10", "Base 2" = "log2")
- |
-
| 384 | -- |
- )+ data = data, |
|
| 385 | -+ | ||
| 258 | +! |
- ),+ dataname = x, |
|
| 386 | +259 | ! |
- if (!is.null(args$color_by)) {
+ if_filtered = if_filtered, |
| 387 | +260 | ! |
- teal.transform::data_extract_ui(+ if_distinct = if_distinct, |
| 388 | +261 | ! |
- id = ns("color_by"),
+ dt_args = dt_args, |
| 389 | +262 | ! |
- label = "Color by variable",+ dt_options = dt_options, |
| 390 | +263 | ! |
- data_extract_spec = args$color_by,+ server_rendering = server_rendering |
| 391 | -! | +||
| 264 | +
- is_single_dataset = is_single_dataset_value+ ) |
||
| 392 | +265 |
- )+ } |
|
| 393 | +266 |
- },+ ) |
|
| 394 | -! | +||
| 267 | +
- if (!is.null(args$size_by)) {
+ }) |
||
| 395 | -! | -
- teal.transform::data_extract_ui(- |
- |
| 396 | -! | +||
| 268 | +
- id = ns("size_by"),
+ } |
||
| 397 | -! | +||
| 269 | +
- label = "Size by variable",+ |
||
| 398 | -! | +||
| 270 | +
- data_extract_spec = args$size_by,+ # UI function for the data_table module |
||
| 399 | -! | +||
| 271 | +
- is_single_dataset = is_single_dataset_value+ ui_data_table <- function(id, |
||
| 400 | +272 |
- )+ choices, |
|
| 401 | +273 |
- },+ selected) {
|
|
| 402 | +274 | ! |
- if (!is.null(args$row_facet)) {
+ ns <- NS(id) |
| 403 | -! | +||
| 275 | +
- teal.transform::data_extract_ui(+ |
||
| 404 | +276 | ! |
- id = ns("row_facet"),
+ if (!is.null(selected)) {
|
| 405 | +277 | ! |
- label = "Row facetting",+ all_choices <- choices |
| 406 | +278 | ! |
- data_extract_spec = args$row_facet,+ choices <- c(selected, setdiff(choices, selected)) |
| 407 | +279 | ! |
- is_single_dataset = is_single_dataset_value+ names(choices) <- names(all_choices)[match(choices, all_choices)] |
| 408 | +280 |
- )+ } |
|
| 409 | +281 |
- },+ |
|
| 410 | +282 | ! |
- if (!is.null(args$col_facet)) {
+ tagList( |
| 411 | +283 | ! |
- teal.transform::data_extract_ui(+ teal.widgets::get_dt_rows(ns("data_table"), ns("dt_rows")),
|
| 412 | +284 | ! |
- id = ns("col_facet"),
+ fluidRow( |
| 413 | +285 | ! |
- label = "Column facetting",+ teal.widgets::optionalSelectInput( |
| 414 | +286 | ! |
- data_extract_spec = args$col_facet,+ ns("variables"),
|
| 415 | +287 | ! |
- is_single_dataset = is_single_dataset_value- |
-
| 416 | -- |
- )- |
- |
| 417 | -- |
- },+ "Select variables:", |
|
| 418 | +288 | ! |
- teal.widgets::panel_group(+ choices = choices, |
| 419 | +289 | ! |
- teal.widgets::panel_item(+ selected = selected, |
| 420 | +290 | ! |
- title = "Plot settings",+ multiple = TRUE, |
| 421 | +291 | ! |
- teal.widgets::optionalSliderInputValMinMax(ns("alpha"), "Opacity:", args$alpha, ticks = FALSE),
+ width = "100%" |
| 422 | -! | +||
| 292 | +
- teal.widgets::optionalSelectInput(+ ) |
||
| 423 | -! | +||
| 293 | +
- inputId = ns("shape"),
+ ), |
||
| 424 | +294 | ! |
- label = "Points shape:",+ fluidRow( |
| 425 | +295 | ! |
- choices = args$shape,+ DT::dataTableOutput(ns("data_table"), width = "100%")
|
| 426 | -! | +||
| 296 | +
- selected = args$shape[1],+ ) |
||
| 427 | -! | +||
| 297 | +
- multiple = FALSE+ ) |
||
| 428 | +298 |
- ),+ } |
|
| 429 | -! | +||
| 299 | +
- colourpicker::colourInput(ns("color"), "Points color:", "black"),
+
|
||
| 430 | -! | +||
| 300 | +
- teal.widgets::optionalSliderInputValMinMax(ns("size"), "Points size:", args$size, ticks = FALSE, step = .1),
+ # Server function for the data_table module |
||
| 431 | -! | +||
| 301 | +
- checkboxInput(ns("rotate_xaxis_labels"), "Rotate X axis labels", value = args$rotate_xaxis_labels),
+ srv_data_table <- function(id, |
||
| 432 | -! | +||
| 302 | +
- checkboxInput(ns("add_density"), "Add marginal density", value = FALSE),
+ data, |
||
| 433 | -! | +||
| 303 | +
- checkboxInput(ns("rug_plot"), "Include rug plot", value = FALSE),
+ dataname, |
||
| 434 | -! | +||
| 304 | +
- checkboxInput(ns("show_count"), "Show N (number of observations)", value = FALSE),
+ if_filtered, |
||
| 435 | -! | +||
| 305 | +
- shinyjs::hidden(helpText(id = ns("line_msg"), "Trendline needs numeric X and Y variables")),
+ if_distinct, |
||
| 436 | -! | +||
| 306 | +
- teal.widgets::optionalSelectInput(ns("smoothing_degree"), "Smoothing degree", seq_len(args$max_deg)),
+ dt_args, |
||
| 437 | -! | +||
| 307 | +
- shinyjs::hidden(teal.widgets::optionalSelectInput(ns("color_sub"), label = "", multiple = TRUE)),
+ dt_options, |
||
| 438 | -! | +||
| 308 | +
- teal.widgets::optionalSliderInputValMinMax(ns("ci"), "Confidence", c(.95, .8, .99), ticks = FALSE),
+ server_rendering) {
|
||
| 439 | +309 | ! |
- shinyjs::hidden(checkboxInput(ns("show_form"), "Show formula", value = TRUE)),
+ moduleServer(id, function(input, output, session) {
|
| 440 | +310 | ! |
- shinyjs::hidden(checkboxInput(ns("show_r2"), "Show adj-R Squared", value = TRUE)),
+ iv <- shinyvalidate::InputValidator$new() |
| 441 | +311 | ! |
- uiOutput(ns("num_na_removed")),
+ iv$add_rule("variables", shinyvalidate::sv_required("Please select valid variable names"))
|
| 442 | +312 | ! |
- tags$div(+ iv$add_rule("variables", shinyvalidate::sv_in_set(
|
| 443 | +313 | ! |
- id = ns("label_pos"),
+ set = names(isolate(data())[[dataname]]), message_fmt = "Not all selected variables exist in the data" |
| 444 | -! | +||
| 314 | +
- tags$div(tags$strong("Stats position")),
+ )) |
||
| 445 | +315 | ! |
- tags$div(class = "inline-block w-10", helpText("Left")),
+ iv$enable() |
| 446 | -! | +||
| 316 | +
- tags$div(+ |
||
| 447 | +317 | ! |
- class = "inline-block w-70",+ output$data_table <- DT::renderDataTable(server = server_rendering, {
|
| 448 | +318 | ! |
- teal.widgets::optionalSliderInput(+ teal::validate_inputs(iv) |
| 449 | -! | +||
| 319 | +
- ns("pos"),
+
|
||
| 450 | +320 | ! |
- label = NULL,+ df <- data()[[dataname]] |
| 451 | +321 | ! |
- min = 0, max = 1, value = .99, ticks = FALSE, step = .01- |
-
| 452 | -- |
- )+ variables <- input$variables |
|
| 453 | +322 |
- ),+ |
|
| 454 | +323 | ! |
- tags$div(class = "inline-block w-10", helpText("Right"))
+ teal::validate_has_data(df, min_nrow = 1L, msg = paste("data", dataname, "is empty"))
|
| 455 | +324 |
- ),- |
- |
| 456 | -! | -
- teal.widgets::optionalSliderInput(+ |
|
| 457 | +325 | ! |
- ns("label_size"), "Stats font size",
+ dataframe_selected <- if (if_distinct()) {
|
| 458 | +326 | ! |
- min = 3, max = 10, value = 5, ticks = FALSE, step = .1+ dplyr::count(df, dplyr::across(dplyr::all_of(variables))) |
| 459 | +327 |
- ),+ } else {
|
|
| 460 | +328 | ! |
- if (!is.null(args$row_facet) || !is.null(args$col_facet)) {
+ df[variables] |
| 461 | -! | +||
| 329 | +
- checkboxInput(ns("free_scales"), "Free scales", value = FALSE)
+ } |
||
| 462 | +330 |
- },+ |
|
| 463 | +331 | ! |
- selectInput(+ dt_args$options <- dt_options |
| 464 | +332 | ! |
- inputId = ns("ggtheme"),
+ if (!is.null(input$dt_rows)) {
|
| 465 | +333 | ! |
- label = "Theme (by ggplot):",+ dt_args$options$pageLength <- input$dt_rows |
| 466 | -! | +||
| 334 | +
- choices = ggplot_themes,+ } |
||
| 467 | +335 | ! |
- selected = args$ggtheme,+ dt_args$data <- dataframe_selected+ |
+
| 336 | ++ | + | |
| 468 | +337 | ! |
- multiple = FALSE+ do.call(DT::datatable, dt_args) |
| 469 | +338 |
- )+ }) |
|
| 470 | +339 |
- )+ }) |
|
| 471 | +340 |
- )+ } |
| 472 | +1 |
- ),+ #' `teal` module: Scatterplot matrix |
|
| 473 | -! | +||
| 2 | +
- forms = tagList(+ #' |
||
| 474 | -! | +||
| 3 | +
- teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code")
+ #' Generates a scatterplot matrix from selected `variables` from datasets. |
||
| 475 | +4 |
- ),+ #' Each plot within the matrix represents the relationship between two variables, |
|
| 476 | -! | +||
| 5 | +
- pre_output = args$pre_output,+ #' providing the overview of correlations and distributions across selected data. |
||
| 477 | -! | +||
| 6 | +
- post_output = args$post_output+ #' |
||
| 478 | +7 |
- )+ #' @note For more examples, please see the vignette "Using scatterplot matrix" via |
|
| 479 | +8 |
- )+ #' `vignette("using-scatterplot-matrix", package = "teal.modules.general")`.
|
|
| 480 | +9 |
- }+ #' |
|
| 481 | +10 |
-
+ #' @inheritParams teal::module |
|
| 482 | +11 |
- # Server function for the scatterplot module+ #' @inheritParams tm_g_scatterplot |
|
| 483 | +12 |
- srv_g_scatterplot <- function(id,+ #' @inheritParams shared_params |
|
| 484 | +13 |
- data,+ #' |
|
| 485 | +14 |
- reporter,+ #' @param variables (`data_extract_spec` or `list` of multiple `data_extract_spec`) |
|
| 486 | +15 |
- filter_panel_api,+ #' Specifies plotting variables from an incoming dataset with filtering and selecting. In case of |
|
| 487 | +16 |
- x,+ #' `data_extract_spec` use `select_spec(..., ordered = TRUE)` if plot elements should be |
|
| 488 | +17 |
- y,+ #' rendered according to selection order. |
|
| 489 | +18 |
- color_by,+ #' |
|
| 490 | +19 |
- size_by,+ #' @inherit shared_params return |
|
| 491 | +20 |
- row_facet,+ #' |
|
| 492 | +21 |
- col_facet,+ #' @examplesShinylive |
|
| 493 | +22 |
- plot_height,+ #' library(teal.modules.general) |
|
| 494 | +23 |
- plot_width,+ #' interactive <- function() TRUE |
|
| 495 | +24 |
- table_dec,+ #' {{ next_example }}
|
|
| 496 | +25 |
- ggplot2_args) {
+ #' @examplesIf require("lattice", quietly = TRUE)
|
|
| 497 | -! | +||
| 26 | +
- with_reporter <- !missing(reporter) && inherits(reporter, "Reporter")+ #' # general data example |
||
| 498 | -! | +||
| 27 | +
- with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI")+ #' data <- teal_data() |
||
| 499 | -! | +||
| 28 | +
- checkmate::assert_class(data, "reactive")+ #' data <- within(data, {
|
||
| 500 | -! | +||
| 29 | +
- checkmate::assert_class(isolate(data()), "teal_data")+ #' countries <- data.frame( |
||
| 501 | -! | +||
| 30 | +
- moduleServer(id, function(input, output, session) {
+ #' id = c("DE", "FR", "IT", "ES", "PT", "GR", "NL", "BE", "LU", "AT"),
|
||
| 502 | -! | +||
| 31 | +
- teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.general")+ #' government = factor( |
||
| 503 | +32 |
-
+ #' c(2, 2, 2, 1, 2, 2, 1, 1, 1, 2), |
|
| 504 | -! | +||
| 33 | +
- data_extract <- list(+ #' labels = c("Monarchy", "Republic")
|
||
| 505 | -! | +||
| 34 | +
- x = x,+ #' ), |
||
| 506 | -! | +||
| 35 | +
- y = y,+ #' language_family = factor( |
||
| 507 | -! | +||
| 36 | +
- color_by = color_by,+ #' c(1, 3, 3, 3, 3, 2, 1, 1, 3, 1), |
||
| 508 | -! | +||
| 37 | +
- size_by = size_by,+ #' labels = c("Germanic", "Hellenic", "Romance")
|
||
| 509 | -! | +||
| 38 | +
- row_facet = row_facet,+ #' ), |
||
| 510 | -! | +||
| 39 | +
- col_facet = col_facet+ #' population = c(83, 67, 60, 47, 10, 11, 17, 11, 0.6, 9), |
||
| 511 | +40 |
- )+ #' area = c(357, 551, 301, 505, 92, 132, 41, 30, 2.6, 83), |
|
| 512 | +41 |
-
+ #' gdp = c(3.4, 2.7, 2.1, 1.4, 0.3, 0.2, 0.7, 0.5, 0.1, 0.4), |
|
| 513 | -! | +||
| 42 | +
- rule_diff <- function(other) {
+ #' debt = c(2.1, 2.3, 2.4, 2.6, 2.3, 2.4, 2.3, 2.4, 2.3, 2.4) |
||
| 514 | -! | +||
| 43 | +
- function(value) {
+ #' ) |
||
| 515 | -! | +||
| 44 | +
- othervalue <- selector_list()[[other]]()[["select"]]+ #' sales <- data.frame( |
||
| 516 | -! | +||
| 45 | +
- if (!is.null(othervalue)) {
+ #' id = 1:50, |
||
| 517 | -! | +||
| 46 | +
- if (identical(value, othervalue)) {
+ #' country_id = sample( |
||
| 518 | -! | +||
| 47 | +
- "Row and column facetting variables must be different."+ #' c("DE", "FR", "IT", "ES", "PT", "GR", "NL", "BE", "LU", "AT"),
|
||
| 519 | +48 |
- }+ #' size = 50, |
|
| 520 | +49 |
- }+ #' replace = TRUE |
|
| 521 | +50 |
- }+ #' ), |
|
| 522 | +51 |
- }+ #' year = sort(sample(2010:2020, 50, replace = TRUE)), |
|
| 523 | +52 |
-
+ #' venue = sample(c("small", "medium", "large", "online"), 50, replace = TRUE),
|
|
| 524 | -! | +||
| 53 | +
- selector_list <- teal.transform::data_extract_multiple_srv(+ #' cancelled = sample(c(TRUE, FALSE), 50, replace = TRUE), |
||
| 525 | -! | +||
| 54 | +
- data_extract = data_extract,+ #' quantity = rnorm(50, 100, 20), |
||
| 526 | -! | +||
| 55 | +
- datasets = data,+ #' costs = rnorm(50, 80, 20), |
||
| 527 | -! | +||
| 56 | +
- select_validation_rule = list(+ #' profit = rnorm(50, 20, 10) |
||
| 528 | -! | +||
| 57 | +
- x = ~ if (length(.) != 1) "Please select exactly one x var.",+ #' ) |
||
| 529 | -! | +||
| 58 | +
- y = ~ if (length(.) != 1) "Please select exactly one y var.",+ #' }) |
||
| 530 | -! | +||
| 59 | +
- color_by = ~ if (length(.) > 1) "There cannot be more than 1 color variable.",+ #' join_keys(data) <- join_keys( |
||
| 531 | -! | +||
| 60 | +
- size_by = ~ if (length(.) > 1) "There cannot be more than 1 size variable.",+ #' join_key("countries", "countries", "id"),
|
||
| 532 | -! | +||
| 61 | +
- row_facet = shinyvalidate::compose_rules(+ #' join_key("sales", "sales", "id"),
|
||
| 533 | -! | +||
| 62 | +
- shinyvalidate::sv_optional(),+ #' join_key("countries", "sales", c("id" = "country_id"))
|
||
| 534 | -! | +||
| 63 | +
- rule_diff("col_facet")
+ #' ) |
||
| 535 | +64 |
- ),+ #' |
|
| 536 | -! | +||
| 65 | +
- col_facet = shinyvalidate::compose_rules(+ #' app <- init( |
||
| 537 | -! | +||
| 66 | +
- shinyvalidate::sv_optional(),+ #' data = data, |
||
| 538 | -! | +||
| 67 | +
- rule_diff("row_facet")
+ #' modules = modules( |
||
| 539 | +68 |
- )+ #' tm_g_scatterplotmatrix( |
|
| 540 | +69 |
- )+ #' label = "Scatterplot matrix", |
|
| 541 | +70 |
- )+ #' variables = list( |
|
| 542 | +71 |
-
+ #' data_extract_spec( |
|
| 543 | -! | +||
| 72 | +
- iv_r <- reactive({
+ #' dataname = "countries", |
||
| 544 | -! | +||
| 73 | +
- iv_facet <- shinyvalidate::InputValidator$new()+ #' select = select_spec( |
||
| 545 | -! | +||
| 74 | +
- iv <- shinyvalidate::InputValidator$new()+ #' label = "Select variables:", |
||
| 546 | -! | +||
| 75 | +
- teal.transform::compose_and_enable_validators(iv, selector_list)+ #' choices = variable_choices(data[["countries"]]), |
||
| 547 | +76 |
- })+ #' selected = c("area", "gdp", "debt"),
|
|
| 548 | -! | +||
| 77 | +
- iv_facet <- shinyvalidate::InputValidator$new()+ #' multiple = TRUE, |
||
| 549 | -! | +||
| 78 | +
- iv_facet$add_rule("add_density", ~ if (
+ #' ordered = TRUE, |
||
| 550 | -! | +||
| 79 | +
- isTRUE(.) &&+ #' fixed = FALSE |
||
| 551 | +80 |
- (+ #' ) |
|
| 552 | -! | +||
| 81 | +
- length(selector_list()$row_facet()$select) > 0L ||+ #' ), |
||
| 553 | -! | +||
| 82 | +
- length(selector_list()$col_facet()$select) > 0L+ #' data_extract_spec( |
||
| 554 | +83 |
- )+ #' dataname = "sales", |
|
| 555 | +84 |
- ) {
+ #' filter = filter_spec( |
|
| 556 | -! | +||
| 85 | +
- "Cannot add marginal density when Row or Column facetting has been selected"+ #' label = "Select variable:", |
||
| 557 | +86 |
- })+ #' vars = "country_id", |
|
| 558 | -! | +||
| 87 | +
- iv_facet$enable()+ #' choices = value_choices(data[["sales"]], "country_id"), |
||
| 559 | +88 |
-
+ #' selected = c("DE", "FR", "IT", "ES", "PT", "GR", "NL", "BE", "LU", "AT"),
|
|
| 560 | -! | +||
| 89 | +
- anl_merged_input <- teal.transform::merge_expression_srv(+ #' multiple = TRUE |
||
| 561 | -! | +||
| 90 | +
- selector_list = selector_list,+ #' ), |
||
| 562 | -! | +||
| 91 | +
- datasets = data,+ #' select = select_spec( |
||
| 563 | -! | +||
| 92 | +
- merge_function = "dplyr::inner_join"+ #' label = "Select variables:", |
||
| 564 | +93 |
- )+ #' choices = variable_choices(data[["sales"]], c("quantity", "costs", "profit")),
|
|
| 565 | +94 |
-
+ #' selected = c("quantity", "costs", "profit"),
|
|
| 566 | -! | +||
| 95 | +
- anl_merged_q <- reactive({
+ #' multiple = TRUE, |
||
| 567 | -! | +||
| 96 | +
- req(anl_merged_input())+ #' ordered = TRUE, |
||
| 568 | -! | +||
| 97 | +
- data() %>%+ #' fixed = FALSE |
||
| 569 | -! | +||
| 98 | +
- teal.code::eval_code(as.expression(anl_merged_input()$expr)) %>%+ #' ) |
||
| 570 | -! | +||
| 99 | +
- teal.code::eval_code(quote(ANL)) # used to display table when running show-r-code code+ #' ) |
||
| 571 | +100 |
- })+ #' ) |
|
| 572 | +101 |
-
+ #' ) |
|
| 573 | -! | +||
| 102 | +
- merged <- list(+ #' ) |
||
| 574 | -! | +||
| 103 | +
- anl_input_r = anl_merged_input,+ #' ) |
||
| 575 | -! | +||
| 104 | +
- anl_q_r = anl_merged_q+ #' if (interactive()) {
|
||
| 576 | +105 |
- )+ #' shinyApp(app$ui, app$server) |
|
| 577 | +106 |
-
+ #' } |
|
| 578 | -! | +||
| 107 | +
- trend_line_is_applicable <- reactive({
+ #' |
||
| 579 | -! | +||
| 108 | +
- ANL <- merged$anl_q_r()[["ANL"]]+ #' @examplesShinylive |
||
| 580 | -! | +||
| 109 | +
- x_var <- as.vector(merged$anl_input_r()$columns_source$x)+ #' library(teal.modules.general) |
||
| 581 | -! | +||
| 110 | +
- y_var <- as.vector(merged$anl_input_r()$columns_source$y)+ #' interactive <- function() TRUE |
||
| 582 | -! | +||
| 111 | +
- length(x_var) > 0 && length(y_var) > 0 && is.numeric(ANL[[x_var]]) && is.numeric(ANL[[y_var]])+ #' {{ next_example }}
|
||
| 583 | +112 |
- })+ #' @examplesIf require("lattice", quietly = TRUE)
|
|
| 584 | +113 |
-
+ #' # CDISC data example |
|
| 585 | -! | +||
| 114 | +
- add_trend_line <- reactive({
+ #' data <- teal_data() |
||
| 586 | -! | +||
| 115 | +
- smoothing_degree <- as.integer(input$smoothing_degree)+ #' data <- within(data, {
|
||
| 587 | -! | +||
| 116 | +
- trend_line_is_applicable() && length(smoothing_degree) > 0+ #' ADSL <- rADSL |
||
| 588 | +117 |
- })+ #' ADRS <- rADRS |
|
| 589 | +118 |
-
+ #' }) |
|
| 590 | -! | +||
| 119 | +
- if (!is.null(color_by)) {
+ #' join_keys(data) <- default_cdisc_join_keys[names(data)] |
||
| 591 | -! | +||
| 120 | +
- observeEvent(+ #' |
||
| 592 | -! | +||
| 121 | +
- eventExpr = merged$anl_input_r()$columns_source$color_by,+ #' app <- init( |
||
| 593 | -! | +||
| 122 | +
- handlerExpr = {
+ #' data = data, |
||
| 594 | -! | +||
| 123 | +
- color_by_var <- as.vector(merged$anl_input_r()$columns_source$color_by)+ #' modules = modules( |
||
| 595 | -! | +||
| 124 | +
- if (length(color_by_var) > 0) {
+ #' tm_g_scatterplotmatrix( |
||
| 596 | -! | +||
| 125 | +
- shinyjs::hide("color")
+ #' label = "Scatterplot matrix", |
||
| 597 | +126 |
- } else {
+ #' variables = list( |
|
| 598 | -! | +||
| 127 | +
- shinyjs::show("color")
+ #' data_extract_spec( |
||
| 599 | +128 |
- }+ #' dataname = "ADSL", |
|
| 600 | +129 |
- }+ #' select = select_spec( |
|
| 601 | +130 |
- )+ #' label = "Select variables:", |
|
| 602 | +131 |
- }+ #' choices = variable_choices(data[["ADSL"]]), |
|
| 603 | +132 |
-
+ #' selected = c("AGE", "RACE", "SEX"),
|
|
| 604 | -! | +||
| 133 | +
- output$num_na_removed <- renderUI({
+ #' multiple = TRUE, |
||
| 605 | -! | +||
| 134 | +
- if (add_trend_line()) {
+ #' ordered = TRUE, |
||
| 606 | -! | +||
| 135 | +
- ANL <- merged$anl_q_r()[["ANL"]]+ #' fixed = FALSE |
||
| 607 | -! | +||
| 136 | +
- x_var <- as.vector(merged$anl_input_r()$columns_source$x)+ #' ) |
||
| 608 | -! | +||
| 137 | +
- y_var <- as.vector(merged$anl_input_r()$columns_source$y)+ #' ), |
||
| 609 | -! | +||
| 138 | +
- if ((num_total_na <- nrow(ANL) - nrow(stats::na.omit(ANL[, c(x_var, y_var)]))) > 0) {
+ #' data_extract_spec( |
||
| 610 | -! | +||
| 139 | +
- tags$div(paste(num_total_na, "row(s) with missing values were removed"), tags$hr())+ #' dataname = "ADRS", |
||
| 611 | +140 |
- }+ #' filter = filter_spec( |
|
| 612 | +141 |
- }+ #' label = "Select endpoints:", |
|
| 613 | +142 |
- })+ #' vars = c("PARAMCD", "AVISIT"),
|
|
| 614 | +143 |
-
+ #' choices = value_choices(data[["ADRS"]], c("PARAMCD", "AVISIT"), c("PARAM", "AVISIT")),
|
|
| 615 | -! | +||
| 144 | +
- observeEvent(+ #' selected = "INVET - END OF INDUCTION", |
||
| 616 | -! | +||
| 145 | +
- eventExpr = merged$anl_input_r()$columns_source[c("col_facet", "row_facet")],
+ #' multiple = TRUE |
||
| 617 | -! | +||
| 146 | +
- handlerExpr = {
+ #' ), |
||
| 618 | -! | +||
| 147 | +
- if (+ #' select = select_spec( |
||
| 619 | -! | +||
| 148 | +
- length(merged$anl_input_r()$columns_source$col_facet) == 0 &&+ #' label = "Select variables:", |
||
| 620 | -! | +||
| 149 | +
- length(merged$anl_input_r()$columns_source$row_facet) == 0+ #' choices = variable_choices(data[["ADRS"]]), |
||
| 621 | +150 |
- ) {
+ #' selected = c("AGE", "AVAL", "ADY"),
|
|
| 622 | -! | +||
| 151 | +
- shinyjs::hide("free_scales")
+ #' multiple = TRUE, |
||
| 623 | +152 |
- } else {
+ #' ordered = TRUE, |
|
| 624 | -! | +||
| 153 | +
- shinyjs::show("free_scales")
+ #' fixed = FALSE |
||
| 625 | +154 |
- }+ #' ) |
|
| 626 | +155 |
- }+ #' ) |
|
| 627 | +156 |
- )+ #' ) |
|
| 628 | +157 |
-
+ #' ) |
|
| 629 | -! | +||
| 158 | +
- output_q <- reactive({
+ #' ) |
||
| 630 | -! | +||
| 159 | +
- teal::validate_inputs(iv_r(), iv_facet)+ #' ) |
||
| 631 | +160 |
-
+ #' if (interactive()) {
|
|
| 632 | -! | +||
| 161 | +
- ANL <- merged$anl_q_r()[["ANL"]]+ #' shinyApp(app$ui, app$server) |
||
| 633 | +162 |
-
+ #' } |
|
| 634 | -! | +||
| 163 | +
- x_var <- as.vector(merged$anl_input_r()$columns_source$x)+ #' |
||
| 635 | -! | +||
| 164 | +
- y_var <- as.vector(merged$anl_input_r()$columns_source$y)+ #' @export |
||
| 636 | -! | +||
| 165 | +
- color_by_var <- as.vector(merged$anl_input_r()$columns_source$color_by)+ #' |
||
| 637 | -! | +||
| 166 | +
- size_by_var <- as.vector(merged$anl_input_r()$columns_source$size_by)+ tm_g_scatterplotmatrix <- function(label = "Scatterplot Matrix", |
||
| 638 | -! | +||
| 167 | +
- row_facet_name <- if (length(merged$anl_input_r()$columns_source$row_facet) == 0) {
+ variables, |
||
| 639 | -! | +||
| 168 | +
- character(0)+ plot_height = c(600, 200, 2000), |
||
| 640 | +169 |
- } else {
+ plot_width = NULL, |
|
| 641 | -! | +||
| 170 | +
- as.vector(merged$anl_input_r()$columns_source$row_facet)+ pre_output = NULL, |
||
| 642 | +171 |
- }+ post_output = NULL) {
|
|
| 643 | +172 | ! |
- col_facet_name <- if (length(merged$anl_input_r()$columns_source$col_facet) == 0) {
+ message("Initializing tm_g_scatterplotmatrix")
|
| 644 | -! | +||
| 173 | +
- character(0)+ |
||
| 645 | +174 |
- } else {
+ # Requires Suggested packages |
|
| 646 | -! | -
- as.vector(merged$anl_input_r()$columns_source$col_facet)- |
- |
| 647 | -- |
- }- |
- |
| 648 | +175 | ! |
- alpha <- input$alpha+ if (!requireNamespace("lattice", quietly = TRUE)) {
|
| 649 | +176 | ! |
- size <- input$size+ stop("Cannot load lattice - please install the package or restart your session.")
|
| 650 | -! | +||
| 177 | +
- rotate_xaxis_labels <- input$rotate_xaxis_labels+ } |
||
| 651 | -! | +||
| 178 | +
- add_density <- input$add_density+ |
||
| 652 | -! | +||
| 179 | +
- ggtheme <- input$ggtheme+ # Normalize the parameters |
||
| 653 | +180 | ! |
- rug_plot <- input$rug_plot+ if (inherits(variables, "data_extract_spec")) variables <- list(variables) |
| 654 | -! | +||
| 181 | +
- color <- input$color+ |
||
| 655 | -! | +||
| 182 | +
- shape <- `if`(is.null(input$shape) || identical(input$shape, ""), "circle", input$shape)+ # Start of assertions |
||
| 656 | +183 | ! |
- smoothing_degree <- as.integer(input$smoothing_degree)+ checkmate::assert_string(label) |
| 657 | +184 | ! |
- ci <- input$ci+ checkmate::assert_list(variables, types = "data_extract_spec") |
| 658 | +185 | ||
| 659 | +186 | ! |
- log_x <- input$log_x+ checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE) |
| 660 | +187 | ! |
- log_y <- input$log_y+ checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height") |
| 661 | -+ | ||
| 188 | +! |
-
+ checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE) |
|
| 662 | +189 | ! |
- validate(need(+ checkmate::assert_numeric( |
| 663 | +190 | ! |
- length(row_facet_name) == 0 || inherits(ANL[[row_facet_name]], c("character", "factor", "Date", "integer")),
+ plot_width[1], |
| 664 | +191 | ! |
- "`Row facetting` variable must be of class `character`, `factor`, `Date`, or `integer`"+ lower = plot_width[2], upper = plot_width[3], null.ok = TRUE, .var.name = "plot_width" |
| 665 | +192 |
- ))+ ) |
|
| 666 | -! | +||
| 193 | +
- validate(need(+ |
||
| 667 | +194 | ! |
- length(col_facet_name) == 0 || inherits(ANL[[col_facet_name]], c("character", "factor", "Date", "integer")),
+ checkmate::assert_multi_class(pre_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
|
| 668 | +195 | ! |
- "`Column facetting` variable must be of class `character`, `factor`, `Date`, or `integer`"+ checkmate::assert_multi_class(post_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
|
| 669 | +196 |
- ))+ # End of assertions |
|
| 670 | +197 | ||
| 671 | -! | +||
| 198 | +
- if (add_density && length(color_by_var) > 0) {
+ # Make UI args |
||
| 672 | +199 | ! |
- validate(need(+ args <- as.list(environment()) |
| 673 | -! | +||
| 200 | +
- !is.numeric(ANL[[color_by_var]]),+ |
||
| 674 | +201 | ! |
- "Marginal plots cannot be produced when the points are colored by numeric variables.+ ans <- module( |
| 675 | +202 | ! |
- \n Uncheck the 'Add marginal density' checkbox to display the plot."- |
-
| 676 | -- |
- ))+ label = label, |
|
| 677 | +203 | ! |
- validate(need(+ server = srv_g_scatterplotmatrix, |
| 678 | -+ | ||
| 204 | +! |
- !(+ ui = ui_g_scatterplotmatrix, |
|
| 679 | +205 | ! |
- inherits(ANL[[color_by_var]], "Date") ||+ ui_args = args, |
| 680 | +206 | ! |
- inherits(ANL[[color_by_var]], "POSIXct") ||+ server_args = list(variables = variables, plot_height = plot_height, plot_width = plot_width), |
| 681 | +207 | ! |
- inherits(ANL[[color_by_var]], "POSIXlt")+ datanames = teal.transform::get_extract_datanames(variables) |
| 682 | +208 |
- ),+ ) |
|
| 683 | +209 | ! |
- "Marginal plots cannot be produced when the points are colored by Date or POSIX variables.+ attr(ans, "teal_bookmarkable") <- TRUE |
| 684 | +210 | ! |
- \n Uncheck the 'Add marginal density' checkbox to display the plot."+ ans |
| 685 | +211 |
- ))+ } |
|
| 686 | +212 |
- }+ |
|
| 687 | +213 | - - | -|
| 688 | -! | -
- teal::validate_has_data(ANL[, c(x_var, y_var)], 10, complete = TRUE, allow_inf = FALSE)+ # UI function for the scatterplot matrix module |
|
| 689 | +214 | - - | -|
| 690 | -! | -
- if (log_x) {
- |
- |
| 691 | -! | -
- validate(- |
- |
| 692 | -! | -
- need(+ ui_g_scatterplotmatrix <- function(id, ...) {
|
|
| 693 | +215 | ! |
- is.numeric(ANL[[x_var]]) && all(+ args <- list(...) |
| 694 | +216 | ! |
- ANL[[x_var]] > 0 | is.na(ANL[[x_var]])- |
-
| 695 | -- |
- ),+ is_single_dataset_value <- teal.transform::is_single_dataset(args$variables) |
|
| 696 | +217 | ! |
- "X variable can only be log transformed if variable is numeric and all values are positive."- |
-
| 697 | -- |
- )- |
- |
| 698 | -- |
- )- |
- |
| 699 | -- |
- }+ ns <- NS(id) |
|
| 700 | +218 | ! |
- if (log_y) {
+ teal.widgets::standard_layout( |
| 701 | +219 | ! |
- validate(+ output = teal.widgets::white_small_well( |
| 702 | +220 | ! |
- need(+ textOutput(ns("message")),
|
| 703 | +221 | ! |
- is.numeric(ANL[[y_var]]) && all(+ tags$br(), |
| 704 | +222 | ! |
- ANL[[y_var]] > 0 | is.na(ANL[[y_var]])+ teal.widgets::plot_with_settings_ui(id = ns("myplot"))
|
| 705 | +223 |
- ),+ ), |
|
| 706 | +224 | ! |
- "Y variable can only be log transformed if variable is numeric and all values are positive."+ encoding = tags$div( |
| 707 | +225 |
- )+ ### Reporter |
|
| 708 | -+ | ||
| 226 | +! |
- )+ teal.reporter::simple_reporter_ui(ns("simple_reporter")),
|
|
| 709 | +227 |
- }+ ### |
|
| 710 | -+ | ||
| 228 | +! |
-
+ tags$label("Encodings", class = "text-primary"),
|
|
| 711 | +229 | ! |
- facet_cl <- facet_ggplot_call(+ teal.transform::datanames_input(args$variables), |
| 712 | +230 | ! |
- row_facet_name,+ teal.transform::data_extract_ui( |
| 713 | +231 | ! |
- col_facet_name,+ id = ns("variables"),
|
| 714 | +232 | ! |
- free_x_scales = isTRUE(input$free_scales),+ label = "Variables", |
| 715 | +233 | ! |
- free_y_scales = isTRUE(input$free_scales)+ data_extract_spec = args$variables, |
| 716 | -+ | ||
| 234 | +! |
- )+ is_single_dataset = is_single_dataset_value |
|
| 717 | +235 |
-
+ ), |
|
| 718 | +236 | ! |
- point_sizes <- if (length(size_by_var) > 0) {
+ tags$hr(), |
| 719 | +237 | ! |
- validate(need(is.numeric(ANL[[size_by_var]]), "Variable to size by must be numeric"))+ teal.widgets::panel_group( |
| 720 | +238 | ! |
- substitute(+ teal.widgets::panel_item( |
| 721 | +239 | ! |
- expr = size * ANL[[size_by_var]] / max(ANL[[size_by_var]], na.rm = TRUE),+ title = "Plot settings", |
| 722 | +240 | ! |
- env = list(size = size, size_by_var = size_by_var)- |
-
| 723 | -- |
- )+ sliderInput( |
|
| 724 | -+ | ||
| 241 | +! |
- } else {
+ ns("alpha"), "Opacity:",
|
|
| 725 | +242 | ! |
- size+ min = 0, max = 1, |
| 726 | -+ | ||
| 243 | +! |
- }+ step = .05, value = .5, ticks = FALSE |
|
| 727 | +244 |
-
+ ), |
|
| 728 | +245 | ! |
- plot_q <- merged$anl_q_r()- |
-
| 729 | -- |
-
+ sliderInput( |
|
| 730 | +246 | ! |
- if (log_x) {
+ ns("cex"), "Points size:",
|
| 731 | +247 | ! |
- log_x_fn <- input$log_x_base+ min = 0.2, max = 3, |
| 732 | +248 | ! |
- plot_q <- teal.code::eval_code(+ step = .05, value = .65, ticks = FALSE |
| 733 | -! | +||
| 249 | +
- object = plot_q,+ ), |
||
| 734 | +250 | ! |
- code = substitute(+ checkboxInput(ns("cor"), "Add Correlation", value = FALSE),
|
| 735 | +251 | ! |
- expr = ANL[, log_x_var] <- log_x_fn(ANL[, x_var]),+ radioButtons( |
| 736 | +252 | ! |
- env = list(+ ns("cor_method"), "Select Correlation Method",
|
| 737 | +253 | ! |
- x_var = x_var,+ choiceNames = c("Pearson", "Kendall", "Spearman"),
|
| 738 | +254 | ! |
- log_x_fn = as.name(log_x_fn),+ choiceValues = c("pearson", "kendall", "spearman"),
|
| 739 | +255 | ! |
- log_x_var = paste0(log_x_fn, "_", x_var)+ inline = TRUE |
| 740 | +256 |
- )+ ), |
|
| 741 | -+ | ||
| 257 | +! |
- )+ checkboxInput(ns("cor_na_omit"), "Omit Missing Values", value = TRUE)
|
|
| 742 | +258 |
) |
|
| 743 | +259 |
- }+ ) |
|
| 744 | +260 |
-
+ ), |
|
| 745 | +261 | ! |
- if (log_y) {
+ forms = tagList( |
| 746 | +262 | ! |
- log_y_fn <- input$log_y_base+ teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code")
|
| 747 | -! | +||
| 263 | +
- plot_q <- teal.code::eval_code(+ ), |
||
| 748 | -! | -
- object = plot_q,- |
- |
| 749 | -! | -
- code = substitute(- |
- |
| 750 | -! | -
- expr = ANL[, log_y_var] <- log_y_fn(ANL[, y_var]),- |
- |
| 751 | -! | -
- env = list(- |
- |
| 752 | -! | -
- y_var = y_var,- |
- |
| 753 | +264 | ! |
- log_y_fn = as.name(log_y_fn),+ pre_output = args$pre_output, |
| 754 | +265 | ! |
- log_y_var = paste0(log_y_fn, "_", y_var)+ post_output = args$post_output |
| 755 | +266 |
- )+ ) |
|
| 756 | +267 |
- )+ } |
|
| 757 | +268 |
- )+ |
|
| 758 | +269 |
- }+ # Server function for the scatterplot matrix module |
|
| 759 | +270 |
-
+ srv_g_scatterplotmatrix <- function(id, data, reporter, filter_panel_api, variables, plot_height, plot_width) {
|
|
| 760 | +271 | ! |
- pre_pro_anl <- if (input$show_count) {
+ with_reporter <- !missing(reporter) && inherits(reporter, "Reporter") |
| 761 | +272 | ! |
- paste0(+ with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI") |
| 762 | +273 | ! |
- "ANL %>% dplyr::group_by(",
+ checkmate::assert_class(data, "reactive") |
| 763 | +274 | ! |
- paste(+ checkmate::assert_class(isolate(data()), "teal_data") |
| 764 | +275 | ! |
- c(+ moduleServer(id, function(input, output, session) {
|
| 765 | +276 | ! |
- if (length(color_by_var) > 0 && inherits(ANL[[color_by_var]], c("factor", "character"))) color_by_var,
+ teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.general") |
| 766 | -! | +||
| 277 | +
- row_facet_name,+ |
||
| 767 | +278 | ! |
- col_facet_name+ selector_list <- teal.transform::data_extract_multiple_srv( |
| 768 | -+ | ||
| 279 | +! |
- ),+ data_extract = list(variables = variables), |
|
| 769 | +280 | ! |
- collapse = ", "+ datasets = data, |
| 770 | -+ | ||
| 281 | +! |
- ),+ select_validation_rule = list( |
|
| 771 | +282 | ! |
- ") %>% dplyr::mutate(n = dplyr::n()) %>% dplyr::ungroup()"+ variables = ~ if (length(.) <= 1) "Please select at least 2 columns." |
| 772 | +283 |
- )+ ) |
|
| 773 | +284 |
- } else {
+ ) |
|
| 774 | -! | +||
| 285 | +
- "ANL"+ |
||
| 775 | -+ | ||
| 286 | +! |
- }+ iv_r <- reactive({
|
|
| 776 | -+ | ||
| 287 | +! |
-
+ iv <- shinyvalidate::InputValidator$new() |
|
| 777 | +288 | ! |
- plot_call <- substitute(expr = pre_pro_anl %>% ggplot(), env = list(pre_pro_anl = str2lang(pre_pro_anl)))+ teal.transform::compose_and_enable_validators(iv, selector_list) |
| 778 | +289 | ++ |
+ })+ |
+
| 290 | |||
| 779 | +291 | ! |
- plot_call <- if (length(color_by_var) == 0) {
+ anl_merged_input <- teal.transform::merge_expression_srv( |
| 780 | +292 | ! |
- substitute(+ datasets = data, |
| 781 | +293 | ! |
- expr = plot_call ++ selector_list = selector_list |
| 782 | -! | +||
| 294 | +
- ggplot2::aes(x = x_name, y = y_name) ++ ) |
||
| 783 | -! | +||
| 295 | +
- ggplot2::geom_point(alpha = alpha_value, size = point_sizes, shape = shape_value, color = color_value),+ |
||
| 784 | +296 | ! |
- env = list(+ anl_merged_q <- reactive({
|
| 785 | +297 | ! |
- plot_call = plot_call,+ req(anl_merged_input()) |
| 786 | +298 | ! |
- x_name = if (log_x) as.name(paste0(log_x_fn, "_", x_var)) else as.name(x_var),+ data() %>% |
| 787 | +299 | ! |
- y_name = if (log_y) as.name(paste0(log_y_fn, "_", y_var)) else as.name(y_var),+ teal.code::eval_code(as.expression(anl_merged_input()$expr)) |
| 788 | -! | +||
| 300 | +
- alpha_value = alpha,+ })+ |
+ ||
| 301 | ++ | + | |
| 789 | +302 | ! |
- point_sizes = point_sizes,+ merged <- list( |
| 790 | +303 | ! |
- shape_value = shape,+ anl_input_r = anl_merged_input, |
| 791 | +304 | ! |
- color_value = color+ anl_q_r = anl_merged_q |
| 792 | +305 |
- )+ ) |
|
| 793 | +306 |
- )+ |
|
| 794 | +307 |
- } else {
+ # plot |
|
| 795 | +308 | ! |
- substitute(+ output_q <- reactive({
|
| 796 | +309 | ! |
- expr = plot_call ++ teal::validate_inputs(iv_r())+ |
+
| 310 | ++ | + | |
| 797 | +311 | ! |
- ggplot2::aes(x = x_name, y = y_name, color = color_by_var_name) ++ qenv <- merged$anl_q_r() |
| 798 | +312 | ! |
- ggplot2::geom_point(alpha = alpha_value, size = point_sizes, shape = shape_value),+ ANL <- qenv[["ANL"]]+ |
+
| 313 | ++ | + | |
| 799 | +314 | ! |
- env = list(+ cols_names <- merged$anl_input_r()$columns_source$variables |
| 800 | +315 | ! |
- plot_call = plot_call,+ alpha <- input$alpha |
| 801 | +316 | ! |
- x_name = if (log_x) as.name(paste0(log_x_fn, "_", x_var)) else as.name(x_var),+ cex <- input$cex |
| 802 | +317 | ! |
- y_name = if (log_y) as.name(paste0(log_y_fn, "_", y_var)) else as.name(y_var),+ add_cor <- input$cor |
| 803 | +318 | ! |
- color_by_var_name = as.name(color_by_var),+ cor_method <- input$cor_method |
| 804 | +319 | ! |
- alpha_value = alpha,+ cor_na_omit <- input$cor_na_omit+ |
+
| 320 | ++ | + | |
| 805 | +321 | ! |
- point_sizes = point_sizes,+ cor_na_action <- if (isTruthy(cor_na_omit)) {
|
| 806 | +322 | ! |
- shape_value = shape+ "na.omit" |
| 807 | +323 |
- )+ } else {
|
|
| 808 | -+ | ||
| 324 | +! |
- )+ "na.fail" |
|
| 809 | +325 |
} |
|
| 810 | +326 | ||
| 811 | +327 | ! |
- if (rug_plot) plot_call <- substitute(expr = plot_call + geom_rug(), env = list(plot_call = plot_call))+ teal::validate_has_data(ANL, 10)+ |
+
| 328 | +! | +
+ teal::validate_has_data(ANL[, cols_names, drop = FALSE], 10, complete = TRUE, allow_inf = FALSE) |
|
| 812 | +329 | ||
| 813 | -! | +||
| 330 | +
- plot_label_generator <- function(rhs_formula = quote(y ~ 1),+ # get labels and proper variable names |
||
| 814 | +331 | ! |
- show_form = input$show_form,+ varnames <- varname_w_label(cols_names, ANL, wrap_width = 20)+ |
+
| 332 | ++ | + + | +|
| 333 | ++ |
+ # check character columns. If any, then those are converted to factors |
|
| 815 | +334 | ! |
- show_r2 = input$show_r2,+ check_char <- vapply(ANL[, cols_names], is.character, logical(1)) |
| 816 | +335 | ! |
- show_count = input$show_count,+ if (any(check_char)) {
|
| 817 | +336 | ! |
- pos = input$pos,+ qenv <- teal.code::eval_code( |
| 818 | +337 | ! |
- label_size = input$label_size) {
+ qenv, |
| 819 | +338 | ! |
- stopifnot(sum(show_form, show_r2, show_count) >= 1)+ substitute( |
| 820 | +339 | ! |
- aes_label <- paste0(+ expr = ANL <- ANL[, cols_names] %>% |
| 821 | +340 | ! |
- "aes(",
+ dplyr::mutate_if(is.character, as.factor) %>% |
| 822 | +341 | ! |
- if (show_count) "n = n, ",+ droplevels(), |
| 823 | +342 | ! |
- "label = ",+ env = list(cols_names = cols_names)+ |
+
| 343 | ++ |
+ )+ |
+ |
| 344 | ++ |
+ )+ |
+ |
| 345 | ++ |
+ } else {
|
|
| 824 | +346 | ! |
- if (sum(show_form, show_r2, show_count) > 1) "paste(",
+ qenv <- teal.code::eval_code( |
| 825 | +347 | ! |
- paste(+ qenv, |
| 826 | +348 | ! |
- c(+ substitute( |
| 827 | +349 | ! |
- if (show_form) "stat(eq.label)",+ expr = ANL <- ANL[, cols_names] %>% |
| 828 | +350 | ! |
- if (show_r2) "stat(adj.rr.label)",+ droplevels(), |
| 829 | +351 | ! |
- if (show_count) "paste('N ~`=`~', n)"
+ env = list(cols_names = cols_names) |
| 830 | +352 |
- ),+ ) |
|
| 831 | -! | +||
| 353 | +
- collapse = ", "+ ) |
||
| 832 | +354 |
- ),+ } |
|
| 833 | -! | +||
| 355 | +
- if (sum(show_form, show_r2, show_count) > 1) ", sep = '*\", \"*'))" else ")"+ |
||
| 834 | +356 |
- )+ |
|
| 835 | -! | +||
| 357 | +
- label_geom <- substitute(+ # create plot |
||
| 836 | +358 | ! |
- expr = ggpmisc::stat_poly_eq(+ if (add_cor) {
|
| 837 | +359 | ! |
- mapping = aes_label,+ shinyjs::show("cor_method")
|
| 838 | +360 | ! |
- formula = rhs_formula,+ shinyjs::show("cor_use")
|
| 839 | +361 | ! |
- parse = TRUE,+ shinyjs::show("cor_na_omit")
|
| 840 | -! | -
- label.x = pos,+ | |
| 362 | ++ | + | |
| 841 | +363 | ! |
- size = label_size+ qenv <- teal.code::eval_code( |
| 842 | -+ | ||
| 364 | +! |
- ),+ qenv, |
|
| 843 | +365 | ! |
- env = list(+ substitute( |
| 844 | +366 | ! |
- rhs_formula = rhs_formula,+ expr = {
|
| 845 | +367 | ! |
- pos = pos,+ g <- lattice::splom( |
| 846 | +368 | ! |
- aes_label = str2lang(aes_label),+ ANL, |
| 847 | +369 | ! |
- label_size = label_size+ varnames = varnames_value, |
| 848 | -+ | ||
| 370 | +! |
- )+ panel = function(x, y, ...) {
|
|
| 849 | -+ | ||
| 371 | +! |
- )+ lattice::panel.splom(x = x, y = y, ...) |
|
| 850 | +372 | ! |
- substitute(+ cpl <- lattice::current.panel.limits() |
| 851 | +373 | ! |
- expr = plot_call + label_geom,+ lattice::panel.text( |
| 852 | +374 | ! |
- env = list(+ mean(cpl$xlim), |
| 853 | +375 | ! |
- plot_call = plot_call,+ mean(cpl$ylim), |
| 854 | +376 | ! |
- label_geom = label_geom+ get_scatterplotmatrix_stats( |
| 855 | -+ | ||
| 377 | +! |
- )+ x, |
|
| 856 | -+ | ||
| 378 | +! |
- )+ y, |
|
| 857 | -+ | ||
| 379 | +! |
- }+ .f = stats::cor.test,+ |
+ |
| 380 | +! | +
+ .f_args = list(method = cor_method, na.action = cor_na_action) |
|
| 858 | +381 |
-
+ ), |
|
| 859 | +382 | ! |
- if (trend_line_is_applicable()) {
+ alpha = 0.6, |
| 860 | +383 | ! |
- shinyjs::hide("line_msg")
+ fontsize = 18, |
| 861 | +384 | ! |
- shinyjs::show("smoothing_degree")
+ fontface = "bold" |
| 862 | -! | +||
| 385 | +
- if (!add_trend_line()) {
+ ) |
||
| 863 | -! | +||
| 386 | +
- shinyjs::hide("ci")
+ }, |
||
| 864 | +387 | ! |
- shinyjs::hide("color_sub")
+ pch = 16, |
| 865 | +388 | ! |
- shinyjs::hide("show_form")
+ alpha = alpha_value, |
| 866 | +389 | ! |
- shinyjs::hide("show_r2")
+ cex = cex_value+ |
+
| 390 | ++ |
+ ) |
|
| 867 | +391 | ! |
- if (input$show_count) {
+ print(g)+ |
+
| 392 | ++ |
+ }, |
|
| 868 | +393 | ! |
- plot_call <- plot_label_generator(show_form = FALSE, show_r2 = FALSE)+ env = list( |
| 869 | +394 | ! |
- shinyjs::show("label_pos")
+ varnames_value = varnames, |
| 870 | +395 | ! |
- shinyjs::show("label_size")
+ cor_method = cor_method, |
| 871 | -+ | ||
| 396 | +! |
- } else {
+ cor_na_action = cor_na_action, |
|
| 872 | +397 | ! |
- shinyjs::hide("label_pos")
+ alpha_value = alpha, |
| 873 | +398 | ! |
- shinyjs::hide("label_size")
+ cex_value = cex |
| 874 | +399 |
- }+ ) |
|
| 875 | +400 |
- } else {
+ ) |
|
| 876 | -! | +||
| 401 | +
- shinyjs::show("ci")
+ ) |
||
| 877 | -! | +||
| 402 | +
- shinyjs::show("show_form")
+ } else {
|
||
| 878 | +403 | ! |
- shinyjs::show("show_r2")
+ shinyjs::hide("cor_method")
|
| 879 | +404 | ! |
- if (nrow(ANL) - nrow(stats::na.omit(ANL[, c(x_var, y_var)])) > 0) {
+ shinyjs::hide("cor_use")
|
| 880 | +405 | ! |
- plot_q <- teal.code::eval_code(+ shinyjs::hide("cor_na_omit")
|
| 881 | +406 | ! |
- plot_q,+ qenv <- teal.code::eval_code( |
| 882 | +407 | ! |
- substitute(+ qenv, |
| 883 | +408 | ! |
- expr = ANL <- dplyr::filter(ANL, !is.na(x_var) & !is.na(y_var)),+ substitute( |
| 884 | +409 | ! |
- env = list(x_var = as.name(x_var), y_var = as.name(y_var))+ expr = {
|
| 885 | -+ | ||
| 410 | +! |
- )+ g <- lattice::splom(ANL, varnames = varnames_value, pch = 16, alpha = alpha_value, cex = cex_value) |
|
| 886 | -+ | ||
| 411 | +! |
- )+ g |
|
| 887 | +412 |
- }+ }, |
|
| 888 | +413 | ! |
- rhs_formula <- substitute(+ env = list(varnames_value = varnames, alpha_value = alpha, cex_value = cex) |
| 889 | -! | +||
| 414 | +
- expr = y ~ poly(x, smoothing_degree, raw = TRUE),+ ) |
||
| 890 | -! | +||
| 415 | +
- env = list(smoothing_degree = smoothing_degree)+ ) |
||
| 891 | +416 |
- )+ } |
|
| 892 | +417 | ! |
- if (input$show_form || input$show_r2 || input$show_count) {
+ qenv |
| 893 | -! | +||
| 418 | +
- plot_call <- plot_label_generator(rhs_formula = rhs_formula)+ }) |
||
| 894 | -! | +||
| 419 | +
- shinyjs::show("label_pos")
+
|
||
| 895 | +420 | ! |
- shinyjs::show("label_size")
+ plot_r <- reactive(output_q()[["g"]]) |
| 896 | +421 |
- } else {
+
|
|
| 897 | -! | +||
| 422 | +
- shinyjs::hide("label_pos")
+ # Insert the plot into a plot_with_settings module |
||
| 898 | +423 | ! |
- shinyjs::hide("label_size")
+ pws <- teal.widgets::plot_with_settings_srv( |
| 899 | -+ | ||
| 424 | +! |
- }+ id = "myplot", |
|
| 900 | +425 | ! |
- plot_call <- substitute(+ plot_r = plot_r, |
| 901 | +426 | ! |
- expr = plot_call + ggplot2::geom_smooth(formula = rhs_formula, se = TRUE, level = ci, method = "lm"),+ height = plot_height, |
| 902 | +427 | ! |
- env = list(plot_call = plot_call, rhs_formula = rhs_formula, ci = ci)+ width = plot_width |
| 903 | +428 |
- )+ ) |
|
| 904 | +429 |
- }+ |
|
| 905 | +430 |
- } else {
+ # show a message if conversion to factors took place |
|
| 906 | +431 | ! |
- shinyjs::hide("smoothing_degree")
+ output$message <- renderText({
|
| 907 | +432 | ! |
- shinyjs::hide("ci")
+ req(iv_r()$is_valid()) |
| 908 | +433 | ! |
- shinyjs::hide("color_sub")
+ req(selector_list()$variables()) |
| 909 | +434 | ! |
- shinyjs::hide("show_form")
+ ANL <- merged$anl_q_r()[["ANL"]] |
| 910 | +435 | ! |
- shinyjs::hide("show_r2")
+ cols_names <- unique(unname(do.call(c, merged$anl_input_r()$columns_source))) |
| 911 | +436 | ! |
- if (input$show_count) {
+ check_char <- vapply(ANL[, cols_names], is.character, logical(1)) |
| 912 | +437 | ! |
- plot_call <- plot_label_generator(show_form = FALSE, show_r2 = FALSE)+ if (any(check_char)) {
|
| 913 | +438 | ! |
- shinyjs::show("label_pos")
+ is_single <- sum(check_char) == 1 |
| 914 | +439 | ! |
- shinyjs::show("label_size")
+ paste( |
| 915 | -+ | ||
| 440 | +! |
- } else {
+ "Character", |
|
| 916 | +441 | ! |
- shinyjs::hide("label_pos")
+ ifelse(is_single, "variable", "variables"), |
| 917 | +442 | ! |
- shinyjs::hide("label_size")
+ paste0("(", paste(cols_names[check_char], collapse = ", "), ")"),
|
| 918 | -+ | ||
| 443 | +! |
- }+ ifelse(is_single, "was", "were"), |
|
| 919 | +444 | ! |
- shinyjs::show("line_msg")
+ "converted to",+ |
+
| 445 | +! | +
+ ifelse(is_single, "factor.", "factors.") |
|
| 920 | +446 |
- }+ ) |
|
| 921 | +447 |
-
+ } else {
|
|
| 922 | -! | +||
| 448 | +
- if (!is.null(facet_cl)) {
+ "" |
||
| 923 | -! | +||
| 449 | +
- plot_call <- substitute(expr = plot_call + facet_cl, env = list(plot_call = plot_call, facet_cl = facet_cl))+ } |
||
| 924 | +450 |
- }+ }) |
|
| 925 | +451 | ||
| 926 | +452 | ! |
- y_label <- varname_w_label(+ teal.widgets::verbatim_popup_srv( |
| 927 | +453 | ! |
- y_var,+ id = "rcode", |
| 928 | +454 | ! |
- ANL,+ verbatim_content = reactive(teal.code::get_code(output_q())), |
| 929 | +455 | ! |
- prefix = if (log_y) paste(log_y_fn, "(") else NULL,
+ title = "Show R Code for Scatterplotmatrix" |
| 930 | -! | +||
| 456 | +
- suffix = if (log_y) ")" else NULL+ ) |
||
| 931 | +457 |
- )+ |
|
| 932 | -! | +||
| 458 | +
- x_label <- varname_w_label(+ ### REPORTER |
||
| 933 | +459 | ! |
- x_var,+ if (with_reporter) {
|
| 934 | +460 | ! |
- ANL,+ card_fun <- function(comment, label) {
|
| 935 | +461 | ! |
- prefix = if (log_x) paste(log_x_fn, "(") else NULL,
+ card <- teal::report_card_template( |
| 936 | +462 | ! |
- suffix = if (log_x) ")" else NULL- |
-
| 937 | -- |
- )- |
- |
| 938 | -- |
-
+ title = "Scatter Plot Matrix", |
|
| 939 | +463 | ! |
- dev_ggplot2_args <- teal.widgets::ggplot2_args(+ label = label, |
| 940 | +464 | ! |
- labs = list(y = y_label, x = x_label),+ with_filter = with_filter, |
| 941 | +465 | ! |
- theme = list(legend.position = "bottom")+ filter_panel_api = filter_panel_api |
| 942 | +466 |
- )+ ) |
|
| 943 | -+ | ||
| 467 | +! |
-
+ card$append_text("Plot", "header3")
|
|
| 944 | +468 | ! |
- if (rotate_xaxis_labels) {
+ card$append_plot(plot_r(), dim = pws$dim()) |
| 945 | +469 | ! |
- dev_ggplot2_args$theme[["axis.text.x"]] <- quote(element_text(angle = 45, hjust = 1))+ if (!comment == "") {
|
| 946 | -+ | ||
| 470 | +! |
- }+ card$append_text("Comment", "header3")
+ |
+ |
| 471 | +! | +
+ card$append_text(comment) |
|
| 947 | +472 |
-
+ } |
|
| 948 | +473 | ! |
- all_ggplot2_args <- teal.widgets::resolve_ggplot2_args(+ card$append_src(teal.code::get_code(output_q())) |
| 949 | +474 | ! |
- user_plot = ggplot2_args,+ card+ |
+
| 475 | ++ |
+ } |
|
| 950 | +476 | ! |
- module_plot = dev_ggplot2_args+ teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
|
| 951 | +477 |
- )+ } |
|
| 952 | +478 |
-
+ ### |
|
| 953 | -! | +||
| 479 | +
- parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(all_ggplot2_args, ggtheme = ggtheme)+ }) |
||
| 954 | +480 |
-
+ } |
|
| 955 | +481 | ||
| 956 | -! | +||
| 482 | +
- if (add_density) {
+ #' Get stats for x-y pairs in scatterplot matrix |
||
| 957 | -! | +||
| 483 | +
- plot_call <- substitute(+ #' |
||
| 958 | -! | +||
| 484 | +
- expr = ggExtra::ggMarginal(+ #' Uses [stats::cor.test()] per default for all numerical input variables and converts results |
||
| 959 | -! | +||
| 485 | +
- plot_call + labs + ggthemes + themes,+ #' to character vector. |
||
| 960 | -! | +||
| 486 | +
- type = "density",+ #' Could be extended if different stats for different variable types are needed. |
||
| 961 | -! | +||
| 487 | +
- groupColour = group_colour+ #' Meant to be called from [lattice::panel.text()]. |
||
| 962 | +488 |
- ),+ #' |
|
| 963 | -! | +||
| 489 | +
- env = list(+ #' Presently we need to use a formula input for `stats::cor.test` because |
||
| 964 | -! | +||
| 490 | +
- plot_call = plot_call,+ #' `na.fail` only gets evaluated when a formula is passed (see below). |
||
| 965 | -! | +||
| 491 | +
- group_colour = if (length(color_by_var) > 0) TRUE else FALSE,+ #' ``` |
||
| 966 | -! | +||
| 492 | +
- labs = parsed_ggplot2_args$labs,+ #' x = c(1,3,5,7,NA) |
||
| 967 | -! | +||
| 493 | +
- ggthemes = parsed_ggplot2_args$ggtheme,+ #' y = c(3,6,7,8,1) |
||
| 968 | -! | +||
| 494 | +
- themes = parsed_ggplot2_args$theme+ #' stats::cor.test(x, y, na.action = "na.fail") |
||
| 969 | +495 |
- )+ #' stats::cor.test(~ x + y, na.action = "na.fail") |
|
| 970 | +496 |
- )+ #' ``` |
|
| 971 | +497 |
- } else {
+ #' |
|
| 972 | -! | +||
| 498 | +
- plot_call <- substitute(+ #' @param x,y (`numeric`) vectors of data values. `x` and `y` must have the same length. |
||
| 973 | -! | +||
| 499 | +
- expr = plot_call ++ #' @param .f (`function`) function that accepts x and y as formula input `~ x + y`. |
||
| 974 | -! | +||
| 500 | +
- labs ++ #' Default `stats::cor.test`. |
||
| 975 | -! | +||
| 501 | +
- ggthemes ++ #' @param .f_args (`list`) of arguments to be passed to `.f`. |
||
| 976 | -! | +||
| 502 | +
- themes,+ #' @param round_stat (`integer(1)`) optional, number of decimal places to use when rounding the estimate. |
||
| 977 | -! | +||
| 503 | +
- env = list(+ #' @param round_pval (`integer(1)`) optional, number of decimal places to use when rounding the p-value. |
||
| 978 | -! | +||
| 504 | +
- plot_call = plot_call,+ #' |
||
| 979 | -! | +||
| 505 | +
- labs = parsed_ggplot2_args$labs,+ #' @return Character with stats. For [stats::cor.test()] correlation coefficient and p-value. |
||
| 980 | -! | +||
| 506 | +
- ggthemes = parsed_ggplot2_args$ggtheme,+ #' |
||
| 981 | -! | +||
| 507 | +
- themes = parsed_ggplot2_args$theme+ #' @examples |
||
| 982 | +508 |
- )+ #' set.seed(1) |
|
| 983 | +509 |
- )+ #' x <- runif(25, 0, 1) |
|
| 984 | +510 |
- }+ #' y <- runif(25, 0, 1) |
|
| 985 | +511 |
-
+ #' x[c(3, 10, 18)] <- NA |
|
| 986 | -! | +||
| 512 | +
- plot_call <- substitute(expr = p <- plot_call, env = list(plot_call = plot_call))+ #' |
||
| 987 | +513 |
-
+ #' get_scatterplotmatrix_stats(x, y, .f = stats::cor.test, .f_args = list(method = "pearson")) |
|
| 988 | -! | +||
| 514 | +
- teal.code::eval_code(plot_q, plot_call) %>%+ #' get_scatterplotmatrix_stats(x, y, .f = stats::cor.test, .f_args = list( |
||
| 989 | -! | +||
| 515 | +
- teal.code::eval_code(quote(print(p)))+ #' method = "pearson", |
||
| 990 | +516 |
- })+ #' na.action = na.fail |
|
| 991 | +517 |
-
+ #' )) |
|
| 992 | -! | +||
| 518 | +
- plot_r <- reactive(output_q()[["p"]])+ #' |
||
| 993 | +519 |
-
+ #' @export |
|
| 994 | +520 |
- # Insert the plot into a plot_with_settings module from teal.widgets+ #' |
|
| 995 | -! | +||
| 521 | +
- pws <- teal.widgets::plot_with_settings_srv(+ get_scatterplotmatrix_stats <- function(x, y, |
||
| 996 | -! | +||
| 522 | +
- id = "scatter_plot",+ .f = stats::cor.test, |
||
| 997 | -! | +||
| 523 | +
- plot_r = plot_r,+ .f_args = list(), |
||
| 998 | -! | +||
| 524 | +
- height = plot_height,+ round_stat = 2, |
||
| 999 | -! | +||
| 525 | +
- width = plot_width,+ round_pval = 4) {
|
||
| 1000 | -! | +||
| 526 | +6x |
- brushing = TRUE+ if (is.numeric(x) && is.numeric(y)) {
|
|
| 1001 | -+ | ||
| 527 | +3x |
- )+ stat <- tryCatch(do.call(.f, c(list(~ x + y), .f_args)), error = function(e) NA) |
|
| 1002 | +528 | ||
| 1003 | -! | +||
| 529 | +3x |
- output$data_table <- DT::renderDataTable({
+ if (anyNA(stat)) {
|
|
| 1004 | -! | +||
| 530 | +1x |
- plot_brush <- pws$brush()+ return("NA")
|
|
| 1005 | -+ | ||
| 531 | +2x |
-
+ } else if (all(c("estimate", "p.value") %in% names(stat))) {
|
|
| 1006 | -! | +||
| 532 | +2x |
- if (!is.null(plot_brush)) {
+ return(paste( |
|
| 1007 | -! | +||
| 533 | +2x |
- validate(need(!input$add_density, "Brushing feature is currently not supported when plot has marginal density"))+ c( |
|
| 1008 | -+ | ||
| 534 | +2x |
- }+ paste0(names(stat$estimate), ":", round(stat$estimate, round_stat)),+ |
+ |
| 535 | +2x | +
+ paste0("P:", round(stat$p.value, round_pval))
|
|
| 1009 | +536 |
-
+ ), |
|
| 1010 | -! | +||
| 537 | +2x |
- merged_data <- isolate(teal.code::dev_suppress(output_q()[["ANL"]]))+ collapse = "\n" |
|
| 1011 | +538 |
-
+ )) |
|
| 1012 | -! | +||
| 539 | +
- brushed_df <- teal.widgets::clean_brushedPoints(merged_data, plot_brush)+ } else {
|
||
| 1013 | +540 | ! |
- numeric_cols <- names(brushed_df)[- |
-
| 1014 | -! | -
- vapply(brushed_df, function(x) is.numeric(x) && !is.integer(x), FUN.VALUE = logical(1))- |
- |
| 1015 | -- |
- ]+ stop("function not supported")
|
|
| 1016 | +541 | - - | -|
| 1017 | -! | -
- if (length(numeric_cols) > 0) {
- |
- |
| 1018 | -! | -
- DT::formatRound(- |
- |
| 1019 | -! | -
- DT::datatable(brushed_df,- |
- |
| 1020 | -! | -
- rownames = FALSE,- |
- |
| 1021 | -! | -
- options = list(scrollX = TRUE, pageLength = input$data_table_rows)+ } |
|
| 1022 | +542 |
- ),- |
- |
| 1023 | -! | -
- numeric_cols,- |
- |
| 1024 | -! | -
- table_dec+ } else {
|
|
| 1025 | -+ | ||
| 543 | +3x |
- )+ if ("method" %in% names(.f_args)) {
|
|
| 1026 | -+ | ||
| 544 | +3x |
- } else {
+ if (.f_args$method == "pearson") {
|
|
| 1027 | -! | +||
| 545 | +1x |
- DT::datatable(brushed_df, rownames = FALSE, options = list(scrollX = TRUE, pageLength = input$data_table_rows))+ return("cor:-")
|
|
| 1028 | +546 |
} |
|
| 1029 | -- |
- })- |
- |
| 1030 | -- | - - | -|
| 1031 | -! | -
- teal.widgets::verbatim_popup_srv(- |
- |
| 1032 | -! | -
- id = "rcode",- |
- |
| 1033 | -! | -
- verbatim_content = reactive(teal.code::get_code(output_q())),- |
- |
| 1034 | -! | -
- title = "R Code for scatterplot"- |
- |
| 1035 | -- |
- )- |
- |
| 1036 | -- | - - | -|
| 1037 | -- |
- ### REPORTER- |
- |
| 1038 | -! | -
- if (with_reporter) {
- |
- |
| 1039 | -! | -
- card_fun <- function(comment, label) {
- |
- |
| 1040 | -! | -
- card <- teal::report_card_template(- |
- |
| 1041 | -! | -
- title = "Scatter Plot",- |
- |
| 1042 | -! | -
- label = label,- |
- |
| 1043 | -! | -
- with_filter = with_filter,- |
- |
| 1044 | -! | -
- filter_panel_api = filter_panel_api- |
- |
| 1045 | -- |
- )- |
- |
| 1046 | -! | -
- card$append_text("Plot", "header3")
- |
- |
| 1047 | -! | -
- card$append_plot(plot_r(), dim = pws$dim())- |
- |
| 1048 | -! | -
- if (!comment == "") {
- |
- |
| 1049 | -! | +||
| 547 | +2x |
- card$append_text("Comment", "header3")
+ if (.f_args$method == "kendall") {
|
|
| 1050 | -! | +||
| 548 | +1x |
- card$append_text(comment)+ return("tau:-")
|
|
| 1051 | +549 |
- }+ } |
|
| 1052 | -! | +||
| 550 | +1x |
- card$append_src(teal.code::get_code(output_q()))+ if (.f_args$method == "spearman") {
|
|
| 1053 | -! | +||
| 551 | +1x |
- card+ return("rho:-")
|
|
| 1054 | +552 |
} |
|
| 1055 | -! | -
- teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
- |
- |
| 1056 | +553 |
} |
|
| 1057 | -+ | ||
| 554 | +! |
- ###+ return("-")
|
|
| 1058 | +555 |
- })+ } |
|
| 1059 | +556 |
}@@ -56907,14 +55908,14 @@ teal.modules.general coverage - 3.44% |
| 1 |
- #' `teal` module: Univariate and bivariate visualizations+ #' `teal` module: Response plot |
||
| 3 |
- #' Module enables the creation of univariate and bivariate plots,+ #' Generates a response plot for a given `response` and `x` variables. |
||
| 4 |
- #' facilitating the exploration of data distributions and relationships between two variables.+ #' This module allows users customize and add annotations to the plot depending |
||
| 5 |
- #'+ #' on the module's arguments. |
||
| 6 |
- #' This is a general module to visualize 1 & 2 dimensional data.+ #' 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+ #' as frequency or density. |
||
| 9 |
- #' For more examples, please see the vignette "Using bivariate plot" via+ #' |
||
| 10 |
- #' `vignette("using-bivariate-plot", package = "teal.modules.general")`.
+ #' @inheritParams teal::module |
||
| 11 |
- #'+ #' @inheritParams shared_params |
||
| 12 |
- #' @inheritParams teal::module+ #' @param response (`data_extract_spec` or `list` of multiple `data_extract_spec`) |
||
| 13 |
- #' @inheritParams shared_params+ #' Which variable to use as the response. |
||
| 14 |
- #' @param x (`data_extract_spec` or `list` of multiple `data_extract_spec`)+ #' You can define one fixed column by setting `fixed = TRUE` inside the `select_spec`. |
||
| 15 |
- #' Variable names selected to plot along the x-axis by default.+ #' |
||
| 16 |
- #' Can be numeric, factor or character.+ #' The `data_extract_spec` must not allow multiple selection in this case. |
||
| 17 |
- #' No empty selections are allowed.+ #' @param x (`data_extract_spec` or `list` of multiple `data_extract_spec`) |
||
| 18 |
- #' @param y (`data_extract_spec` or `list` of multiple `data_extract_spec`)+ #' Specifies which variable to use on the X-axis of the response plot. |
||
| 19 |
- #' Variable names selected to plot along the y-axis by default.+ #' Allow the user to select multiple columns from the `data` allowed in teal. |
||
| 20 |
- #' Can be numeric, factor or character.+ #' |
||
| 21 |
- #' @param use_density (`logical`) optional, indicates whether to plot density (`TRUE`) or frequency (`FALSE`).+ #' The `data_extract_spec` must not allow multiple selection in this case. |
||
| 22 |
- #' Defaults to frequency (`FALSE`).+ #' @param row_facet (`data_extract_spec` or `list` of multiple `data_extract_spec`) |
||
| 23 |
- #' @param row_facet (`data_extract_spec` or `list` of multiple `data_extract_spec`) optional,+ #' optional specification of the data variable(s) to use for faceting rows. |
||
| 24 |
- #' specification of the data variable(s) to use for faceting rows.+ #' @param col_facet (`data_extract_spec` or `list` of multiple `data_extract_spec`) |
||
| 25 |
- #' @param col_facet (`data_extract_spec` or `list` of multiple `data_extract_spec`) optional,+ #' optional specification of the data variable(s) to use for faceting columns. |
||
| 26 |
- #' specification of the data variable(s) to use for faceting columns.+ #' @param coord_flip (`logical(1)`) |
||
| 27 |
- #' @param facet (`logical`) optional, specifies whether the facet encodings `ui` elements are toggled+ #' Indicates whether to flip coordinates between `x` and `response`. |
||
| 28 |
- #' on and shown to the user by default. Defaults to `TRUE` if either `row_facet` or `column_facet`+ #' The default value is `FALSE` and it will show the `x` variable on the x-axis |
||
| 29 |
- #' are supplied.+ #' and the `response` variable on the y-axis. |
||
| 30 |
- #' @param color_settings (`logical`) Whether coloring, filling and size should be applied+ #' @param count_labels (`logical(1)`) |
||
| 31 |
- #' and `UI` tool offered to the user.+ #' Indicates whether to show count labels. |
||
| 32 |
- #' @param color (`data_extract_spec` or `list` of multiple `data_extract_spec`) optional,+ #' Defaults to `TRUE`. |
||
| 33 |
- #' specification of the data variable(s) selected for the outline color inside the coloring settings.+ #' @param freq (`logical(1)`) |
||
| 34 |
- #' It will be applied when `color_settings` is set to `TRUE`.+ #' Indicates whether to display frequency (`TRUE`) or density (`FALSE`). |
||
| 35 |
- #' @param fill (`data_extract_spec` or `list` of multiple `data_extract_spec`) optional,+ #' Defaults to density (`FALSE`). |
||
| 36 |
- #' specification of the data variable(s) selected for the fill color inside the coloring settings.+ #' |
||
| 37 |
- #' It will be applied when `color_settings` is set to `TRUE`.+ #' @inherit shared_params return |
||
| 38 |
- #' @param size (`data_extract_spec` or `list` of multiple `data_extract_spec`) optional,+ #' |
||
| 39 |
- #' specification of the data variable(s) selected for the size of `geom_point` plots inside the coloring settings.+ #' @note For more examples, please see the vignette "Using response plot" via |
||
| 40 |
- #' It will be applied when `color_settings` is set to `TRUE`.+ #' `vignette("using-response-plot", package = "teal.modules.general")`.
|
||
| 41 |
- #' @param free_x_scales (`logical`) optional, whether X scaling shall be changeable.+ #' |
||
| 42 |
- #' Does not allow scaling to be changed by default (`FALSE`).+ #' @examplesShinylive |
||
| 43 |
- #' @param free_y_scales (`logical`) optional, whether Y scaling shall be changeable.+ #' library(teal.modules.general) |
||
| 44 |
- #' Does not allow scaling to be changed by default (`FALSE`).+ #' interactive <- function() TRUE |
||
| 45 |
- #' @param swap_axes (`logical`) optional, whether to swap X and Y axes. Defaults to `FALSE`.+ #' {{ next_example }}
|
||
| 46 |
- #'+ #' @examples |
||
| 47 |
- #' @inherit shared_params return+ #' # general data example |
||
| 48 |
- #'+ #' data <- teal_data() |
||
| 49 |
- #' @examplesShinylive+ #' data <- within(data, {
|
||
| 50 |
- #' library(teal.modules.general)+ #' require(nestcolor) |
||
| 51 |
- #' interactive <- function() TRUE+ #' mtcars <- mtcars |
||
| 52 |
- #' {{ next_example }}
+ #' for (v in c("cyl", "vs", "am", "gear")) {
|
||
| 53 |
- #' @examples+ #' mtcars[[v]] <- as.factor(mtcars[[v]]) |
||
| 54 |
- #' # general data example+ #' } |
||
| 55 |
- #' data <- teal_data()+ #' }) |
||
| 56 |
- #' data <- within(data, {
+ #' |
||
| 57 |
- #' require(nestcolor)+ #' app <- init( |
||
| 58 |
- #' CO2 <- data.frame(CO2)+ #' data = data, |
||
| 59 |
- #' })+ #' modules = modules( |
||
| 60 |
- #' datanames(data) <- c("CO2")
+ #' tm_g_response( |
||
| 61 |
- #'+ #' label = "Response Plots", |
||
| 62 |
- #' app <- init(+ #' response = data_extract_spec( |
||
| 63 |
- #' data = data,+ #' dataname = "mtcars", |
||
| 64 |
- #' modules = tm_g_bivariate(+ #' select = select_spec( |
||
| 65 |
- #' x = data_extract_spec(+ #' label = "Select variable:", |
||
| 66 |
- #' dataname = "CO2",+ #' choices = variable_choices(data[["mtcars"]], c("cyl", "gear")),
|
||
| 67 |
- #' select = select_spec(+ #' selected = "cyl", |
||
| 68 |
- #' label = "Select variable:",+ #' multiple = FALSE, |
||
| 69 |
- #' choices = variable_choices(data[["CO2"]]),+ #' fixed = FALSE |
||
| 70 |
- #' selected = "conc",+ #' ) |
||
| 71 |
- #' fixed = FALSE+ #' ), |
||
| 72 |
- #' )+ #' x = data_extract_spec( |
||
| 73 |
- #' ),+ #' dataname = "mtcars", |
||
| 74 |
- #' y = data_extract_spec(+ #' select = select_spec( |
||
| 75 |
- #' dataname = "CO2",+ #' label = "Select variable:", |
||
| 76 |
- #' select = select_spec(+ #' choices = variable_choices(data[["mtcars"]], c("vs", "am")),
|
||
| 77 |
- #' label = "Select variable:",+ #' selected = "vs", |
||
| 78 |
- #' choices = variable_choices(data[["CO2"]]),+ #' multiple = FALSE, |
||
| 79 |
- #' selected = "uptake",+ #' fixed = FALSE |
||
| 80 |
- #' multiple = FALSE,+ #' ) |
||
| 81 |
- #' fixed = FALSE+ #' ) |
||
| 82 |
- #' )+ #' ) |
||
| 83 |
- #' ),+ #' ) |
||
| 84 |
- #' row_facet = data_extract_spec(+ #' ) |
||
| 85 |
- #' dataname = "CO2",+ #' if (interactive()) {
|
||
| 86 |
- #' select = select_spec(+ #' shinyApp(app$ui, app$server) |
||
| 87 |
- #' label = "Select variable:",+ #' } |
||
| 88 |
- #' choices = variable_choices(data[["CO2"]]),+ #' |
||
| 89 |
- #' selected = "Type",+ #' @examplesShinylive |
||
| 90 |
- #' fixed = FALSE+ #' library(teal.modules.general) |
||
| 91 |
- #' )+ #' interactive <- function() TRUE |
||
| 92 |
- #' ),+ #' {{ next_example }}
|
||
| 93 |
- #' col_facet = data_extract_spec(+ #' @examples |
||
| 94 |
- #' dataname = "CO2",+ #' # CDISC data example |
||
| 95 |
- #' select = select_spec(+ #' data <- teal_data() |
||
| 96 |
- #' label = "Select variable:",+ #' data <- within(data, {
|
||
| 97 |
- #' choices = variable_choices(data[["CO2"]]),+ #' require(nestcolor) |
||
| 98 |
- #' selected = "Treatment",+ #' ADSL <- rADSL |
||
| 99 |
- #' fixed = FALSE+ #' }) |
||
| 100 |
- #' )+ #' join_keys(data) <- default_cdisc_join_keys[names(data)] |
||
| 101 |
- #' )+ #' |
||
| 102 |
- #' )+ #' app <- init( |
||
| 103 |
- #' )+ #' data = data, |
||
| 104 |
- #' if (interactive()) {
+ #' modules = modules( |
||
| 105 |
- #' shinyApp(app$ui, app$server)+ #' tm_g_response( |
||
| 106 |
- #' }+ #' label = "Response Plots", |
||
| 107 |
- #'+ #' response = data_extract_spec( |
||
| 108 |
- #' @examplesShinylive+ #' dataname = "ADSL", |
||
| 109 |
- #' library(teal.modules.general)+ #' select = select_spec( |
||
| 110 |
- #' interactive <- function() TRUE+ #' label = "Select variable:", |
||
| 111 |
- #' {{ next_example }}
+ #' choices = variable_choices(data[["ADSL"]], c("BMRKR2", "COUNTRY")),
|
||
| 112 |
- #' @examples+ #' selected = "BMRKR2", |
||
| 113 |
- #' # CDISC data example+ #' multiple = FALSE, |
||
| 114 |
- #' data <- teal_data()+ #' fixed = FALSE |
||
| 115 |
- #' data <- within(data, {
+ #' ) |
||
| 116 |
- #' require(nestcolor)+ #' ), |
||
| 117 |
- #' ADSL <- rADSL+ #' x = data_extract_spec( |
||
| 118 |
- #' })+ #' dataname = "ADSL", |
||
| 119 |
- #' datanames(data) <- c("ADSL")
+ #' select = select_spec( |
||
| 120 |
- #' join_keys(data) <- default_cdisc_join_keys[datanames(data)]+ #' label = "Select variable:", |
||
| 121 |
- #'+ #' choices = variable_choices(data[["ADSL"]], c("SEX", "RACE")),
|
||
| 122 |
- #' app <- init(+ #' selected = "RACE", |
||
| 123 |
- #' data = data,+ #' multiple = FALSE, |
||
| 124 |
- #' modules = tm_g_bivariate(+ #' fixed = FALSE |
||
| 125 |
- #' x = data_extract_spec(+ #' ) |
||
| 126 |
- #' dataname = "ADSL",+ #' ) |
||
| 127 |
- #' select = select_spec(+ #' ) |
||
| 128 |
- #' label = "Select variable:",+ #' ) |
||
| 129 |
- #' choices = variable_choices(data[["ADSL"]]),+ #' ) |
||
| 130 |
- #' selected = "AGE",+ #' if (interactive()) {
|
||
| 131 |
- #' fixed = FALSE+ #' shinyApp(app$ui, app$server) |
||
| 132 |
- #' )+ #' } |
||
| 133 |
- #' ),+ #' |
||
| 134 |
- #' y = data_extract_spec(+ #' @export |
||
| 135 |
- #' dataname = "ADSL",+ #' |
||
| 136 |
- #' select = select_spec(+ tm_g_response <- function(label = "Response Plot", |
||
| 137 |
- #' label = "Select variable:",+ response, |
||
| 138 |
- #' choices = variable_choices(data[["ADSL"]]),+ x, |
||
| 139 |
- #' selected = "SEX",+ row_facet = NULL, |
||
| 140 |
- #' multiple = FALSE,+ col_facet = NULL, |
||
| 141 |
- #' fixed = FALSE+ coord_flip = FALSE, |
||
| 142 |
- #' )+ count_labels = TRUE, |
||
| 143 |
- #' ),+ rotate_xaxis_labels = FALSE, |
||
| 144 |
- #' row_facet = data_extract_spec(+ freq = FALSE, |
||
| 145 |
- #' dataname = "ADSL",+ plot_height = c(600, 400, 5000), |
||
| 146 |
- #' select = select_spec(+ plot_width = NULL, |
||
| 147 |
- #' label = "Select variable:",+ ggtheme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void"),
|
||
| 148 |
- #' choices = variable_choices(data[["ADSL"]]),+ ggplot2_args = teal.widgets::ggplot2_args(), |
||
| 149 |
- #' selected = "ARM",+ pre_output = NULL, |
||
| 150 |
- #' fixed = FALSE+ post_output = NULL) {
|
||
| 151 | -+ | ! |
- #' )+ message("Initializing tm_g_response")
|
| 152 |
- #' ),+ |
||
| 153 |
- #' col_facet = data_extract_spec(+ # Normalize the parameters |
||
| 154 | -+ | ! |
- #' dataname = "ADSL",+ if (inherits(response, "data_extract_spec")) response <- list(response) |
| 155 | -+ | ! |
- #' select = select_spec(+ if (inherits(x, "data_extract_spec")) x <- list(x) |
| 156 | -+ | ! |
- #' label = "Select variable:",+ if (inherits(row_facet, "data_extract_spec")) row_facet <- list(row_facet) |
| 157 | -+ | ! |
- #' choices = variable_choices(data[["ADSL"]]),+ if (inherits(col_facet, "data_extract_spec")) col_facet <- list(col_facet) |
| 158 |
- #' selected = "COUNTRY",+ |
||
| 159 |
- #' fixed = FALSE+ # Start of assertions |
||
| 160 | -+ | ! |
- #' )+ checkmate::assert_string(label) |
| 161 |
- #' )+ |
||
| 162 | -+ | ! |
- #' )+ checkmate::assert_list(response, types = "data_extract_spec") |
| 163 | -+ | ! |
- #' )+ if (!all(vapply(response, function(x) !("" %in% x$select$choices), logical(1)))) {
|
| 164 | -+ | ! |
- #' if (interactive()) {
+ stop("'response' should not allow empty values")
|
| 165 |
- #' shinyApp(app$ui, app$server)+ } |
||
| 166 | -+ | ! |
- #' }+ assert_single_selection(response) |
| 167 |
- #'+ |
||
| 168 | -+ | ! |
- #' @export+ checkmate::assert_list(x, types = "data_extract_spec") |
| 169 | -+ | ! |
- #'+ if (!all(vapply(x, function(x) !("" %in% x$select$choices), logical(1)))) {
|
| 170 | -+ | ! |
- tm_g_bivariate <- function(label = "Bivariate Plots",+ stop("'x' should not allow empty values")
|
| 171 |
- x,+ } |
||
| 172 | -+ | ! |
- y,+ assert_single_selection(x) |
| 173 |
- row_facet = NULL,+ |
||
| 174 | -+ | ! |
- col_facet = NULL,+ checkmate::assert_list(row_facet, types = "data_extract_spec", null.ok = TRUE) |
| 175 | -+ | ! |
- facet = !is.null(row_facet) || !is.null(col_facet),+ checkmate::assert_list(col_facet, types = "data_extract_spec", null.ok = TRUE) |
| 176 | -+ | ! |
- color = NULL,+ checkmate::assert_flag(coord_flip) |
| 177 | -+ | ! |
- fill = NULL,+ checkmate::assert_flag(count_labels) |
| 178 | -+ | ! |
- size = NULL,+ checkmate::assert_flag(rotate_xaxis_labels) |
| 179 | -+ | ! |
- use_density = FALSE,+ checkmate::assert_flag(freq) |
| 180 |
- color_settings = FALSE,+ |
||
| 181 | -+ | ! |
- free_x_scales = FALSE,+ checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE) |
| 182 | -+ | ! |
- free_y_scales = FALSE,+ checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height") |
| 183 | -+ | ! |
- plot_height = c(600, 200, 2000),+ checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE) |
| 184 | -+ | ! |
- plot_width = NULL,+ checkmate::assert_numeric( |
| 185 | -+ | ! |
- rotate_xaxis_labels = FALSE,+ plot_width[1], |
| 186 | -+ | ! |
- swap_axes = FALSE,+ lower = plot_width[2], upper = plot_width[3], null.ok = TRUE, .var.name = "plot_width" |
| 187 |
- ggtheme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void"),
+ ) |
||
| 188 |
- ggplot2_args = teal.widgets::ggplot2_args(),+ |
||
| 189 | -+ | ! |
- pre_output = NULL,+ ggtheme <- match.arg(ggtheme) |
| 190 | -+ | ! |
- post_output = NULL) {
+ checkmate::assert_class(ggplot2_args, "ggplot2_args") |
| 191 | -18x | +
- message("Initializing tm_g_bivariate")
+
|
|
| 192 | -+ | ! |
-
+ checkmate::assert_multi_class(pre_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
|
| 193 | -+ | ! |
- # Normalize the parameters+ checkmate::assert_multi_class(post_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
|
| 194 | -14x | +
- if (inherits(x, "data_extract_spec")) x <- list(x)+ # End of assertions |
|
| 195 | -13x | +
- if (inherits(y, "data_extract_spec")) y <- list(y)+ |
|
| 196 | -1x | +
- if (inherits(row_facet, "data_extract_spec")) row_facet <- list(row_facet)+ # Make UI args |
|
| 197 | -1x | +! |
- if (inherits(col_facet, "data_extract_spec")) col_facet <- list(col_facet)+ args <- as.list(environment()) |
| 198 | -1x | +
- if (inherits(color, "data_extract_spec")) color <- list(color)+ |
|
| 199 | -1x | +! |
- if (inherits(fill, "data_extract_spec")) fill <- list(fill)+ data_extract_list <- list( |
| 200 | -1x | +! |
- if (inherits(size, "data_extract_spec")) size <- list(size)+ response = response, |
| 201 | -+ | ! |
-
+ x = x, |
| 202 | -+ | ! |
- # Start of assertions+ row_facet = row_facet, |
| 203 | -18x | +! |
- checkmate::assert_string(label)+ col_facet = col_facet |
| 204 |
-
+ ) |
||
| 205 | -18x | +
- checkmate::assert_list(x, types = "data_extract_spec")+ |
|
| 206 | -18x | +! |
- assert_single_selection(x)+ ans <- module( |
| 207 | -+ | ! |
-
+ label = label, |
| 208 | -16x | +! |
- checkmate::assert_list(y, types = "data_extract_spec")+ server = srv_g_response, |
| 209 | -16x | +! |
- assert_single_selection(y)+ ui = ui_g_response, |
| 210 | -+ | ! |
-
+ ui_args = args, |
| 211 | -14x | +! |
- checkmate::assert_list(row_facet, types = "data_extract_spec", null.ok = TRUE)+ server_args = c( |
| 212 | -14x | +! |
- assert_single_selection(row_facet)+ data_extract_list, |
| 213 | -+ | ! |
-
+ list(plot_height = plot_height, plot_width = plot_width, ggplot2_args = ggplot2_args) |
| 214 | -14x | +
- checkmate::assert_list(col_facet, types = "data_extract_spec", null.ok = TRUE)+ ), |
|
| 215 | -14x | +! |
- assert_single_selection(col_facet)+ datanames = teal.transform::get_extract_datanames(data_extract_list) |
| 216 |
-
+ ) |
||
| 217 | -14x | +! |
- checkmate::assert_flag(facet)+ attr(ans, "teal_bookmarkable") <- TRUE |
| 218 | -+ | ! |
-
+ ans |
| 219 | -14x | +
- checkmate::assert_list(color, types = "data_extract_spec", null.ok = TRUE)+ } |
|
| 220 | -14x | +
- assert_single_selection(color)+ |
|
| 221 |
-
+ # UI function for the response module |
||
| 222 | -14x | +
- checkmate::assert_list(fill, types = "data_extract_spec", null.ok = TRUE)+ ui_g_response <- function(id, ...) {
|
|
| 223 | -14x | +! |
- assert_single_selection(fill)+ ns <- NS(id) |
| 224 | -+ | ! |
-
+ args <- list(...) |
| 225 | -14x | +! |
- checkmate::assert_list(size, types = "data_extract_spec", null.ok = TRUE)+ is_single_dataset_value <- teal.transform::is_single_dataset(args$response, args$x, args$row_facet, args$col_facet) |
| 226 | -14x | +
- assert_single_selection(size)+ |
|
| 227 | -+ | ! |
-
+ teal.widgets::standard_layout( |
| 228 | -14x | +! |
- checkmate::assert_flag(use_density)+ output = teal.widgets::white_small_well( |
| 229 | -+ | ! |
-
+ teal.widgets::plot_with_settings_ui(id = ns("myplot"))
|
| 230 |
- # Determines color, fill & size if they are not explicitly set+ ), |
||
| 231 | -14x | +! |
- checkmate::assert_flag(color_settings)+ encoding = tags$div( |
| 232 | -14x | +
- if (color_settings) {
+ ### Reporter |
|
| 233 | -2x | +! |
- if (is.null(color)) {
+ teal.reporter::simple_reporter_ui(ns("simple_reporter")),
|
| 234 | -2x | +
- color <- x+ ### |
|
| 235 | -2x | +! |
- color[[1]]$select <- teal.transform::select_spec(choices = color[[1]]$select$choices, selected = NULL)+ tags$label("Encodings", class = "text-primary"),
|
| 236 | -+ | ! |
- }+ teal.transform::datanames_input(args[c("response", "x", "row_facet", "col_facet")]),
|
| 237 | -2x | +! |
- if (is.null(fill)) {
+ teal.transform::data_extract_ui( |
| 238 | -2x | +! |
- fill <- x+ id = ns("response"),
|
| 239 | -2x | +! |
- fill[[1]]$select <- teal.transform::select_spec(choices = fill[[1]]$select$choices, selected = NULL)+ label = "Response variable", |
| 240 | -+ | ! |
- }+ data_extract_spec = args$response, |
| 241 | -2x | +! |
- if (is.null(size)) {
+ is_single_dataset = is_single_dataset_value |
| 242 | -2x | +
- size <- x+ ), |
|
| 243 | -2x | +! |
- size[[1]]$select <- teal.transform::select_spec(choices = size[[1]]$select$choices, selected = NULL)+ teal.transform::data_extract_ui( |
| 244 | -+ | ! |
- }+ id = ns("x"),
|
| 245 | -+ | ! |
- } else {
+ label = "X variable", |
| 246 | -12x | +! |
- if (!is.null(c(color, fill, size))) {
+ data_extract_spec = args$x, |
| 247 | -3x | +! |
- stop("'color_settings' argument needs to be set to TRUE if 'color', 'fill', and/or 'size' is/are supplied.")
+ is_single_dataset = is_single_dataset_value |
| 248 |
- }+ ), |
||
| 249 | -+ | ! |
- }+ if (!is.null(args$row_facet)) {
|
| 250 | -+ | ! |
-
+ teal.transform::data_extract_ui( |
| 251 | -11x | +! |
- checkmate::assert_flag(free_x_scales)+ id = ns("row_facet"),
|
| 252 | -11x | +! |
- checkmate::assert_flag(free_y_scales)+ label = "Row facetting", |
| 253 | -+ | ! |
-
+ data_extract_spec = args$row_facet, |
| 254 | -11x | +! |
- checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE)+ is_single_dataset = is_single_dataset_value |
| 255 | -10x | +
- checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height")+ ) |
|
| 256 | -8x | +
- checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE)+ }, |
|
| 257 | -7x | +! |
- checkmate::assert_numeric(+ if (!is.null(args$col_facet)) {
|
| 258 | -7x | +! |
- plot_width[1],+ teal.transform::data_extract_ui( |
| 259 | -7x | +! |
- lower = plot_width[2], upper = plot_width[3], null.ok = TRUE, .var.name = "plot_width"+ id = ns("col_facet"),
|
| 260 | -+ | ! |
- )+ label = "Column facetting", |
| 261 | -+ | ! |
-
+ data_extract_spec = args$col_facet, |
| 262 | -5x | +! |
- checkmate::assert_flag(rotate_xaxis_labels)+ is_single_dataset = is_single_dataset_value |
| 263 | -5x | +
- checkmate::assert_flag(swap_axes)+ ) |
|
| 264 |
-
+ }, |
||
| 265 | -5x | +! |
- ggtheme <- match.arg(ggtheme)+ shinyWidgets::radioGroupButtons( |
| 266 | -5x | +! |
- checkmate::assert_class(ggplot2_args, "ggplot2_args")+ inputId = ns("freq"),
|
| 267 | -+ | ! |
-
+ label = NULL, |
| 268 | -5x | +! |
- checkmate::assert_multi_class(pre_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
+ choices = c("frequency", "density"),
|
| 269 | -5x | +! |
- checkmate::assert_multi_class(post_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
+ selected = ifelse(args$freq, "frequency", "density"), |
| 270 | -+ | ! |
- # End of assertions+ justified = TRUE |
| 271 |
-
+ ), |
||
| 272 | -+ | ! |
- # Make UI args+ teal.widgets::panel_group( |
| 273 | -5x | +! |
- args <- as.list(environment())+ teal.widgets::panel_item( |
| 274 | -+ | ! |
-
+ title = "Plot settings", |
| 275 | -5x | +! |
- data_extract_list <- list(+ checkboxInput(ns("count_labels"), "Add count labels", value = args$count_labels),
|
| 276 | -5x | +! |
- x = x,+ checkboxInput(ns("coord_flip"), "Swap axes", value = args$coord_flip),
|
| 277 | -5x | +! |
- y = y,+ checkboxInput(ns("rotate_xaxis_labels"), "Rotate X axis labels", value = args$rotate_xaxis_labels),
|
| 278 | -5x | +! |
- row_facet = row_facet,+ selectInput( |
| 279 | -5x | +! |
- col_facet = col_facet,+ inputId = ns("ggtheme"),
|
| 280 | -5x | +! |
- color_settings = color_settings,+ label = "Theme (by ggplot):", |
| 281 | -5x | +! |
- color = color,+ choices = ggplot_themes, |
| 282 | -5x | +! |
- fill = fill,+ selected = args$ggtheme, |
| 283 | -5x | +! |
- size = size+ multiple = FALSE |
| 284 |
- )+ ) |
||
| 285 |
-
+ ) |
||
| 286 | -5x | +
- ans <- module(+ ) |
|
| 287 | -5x | +
- label = label,+ ), |
|
| 288 | -5x | +! |
- server = srv_g_bivariate,+ forms = tagList( |
| 289 | -5x | +! |
- ui = ui_g_bivariate,+ teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code")
|
| 290 | -5x | +
- ui_args = args,+ ), |
|
| 291 | -5x | +! |
- server_args = c(+ pre_output = args$pre_output, |
| 292 | -5x | +! |
- data_extract_list,+ post_output = args$post_output |
| 293 | -5x | +
- list(plot_height = plot_height, plot_width = plot_width, ggplot2_args = ggplot2_args)+ ) |
|
| 294 |
- ),+ } |
||
| 295 | -5x | +
- datanames = teal.transform::get_extract_datanames(data_extract_list)+ |
|
| 296 |
- )+ # Server function for the response module |
||
| 297 | -5x | +
- attr(ans, "teal_bookmarkable") <- TRUE+ srv_g_response <- function(id, |
|
| 298 | -5x | +
- ans+ data, |
|
| 299 |
- }+ reporter, |
||
| 300 |
-
+ filter_panel_api, |
||
| 301 |
- # UI function for the bivariate module+ response, |
||
| 302 |
- ui_g_bivariate <- function(id, ...) {
+ x, |
||
| 303 | -! | +
- args <- list(...)+ row_facet, |
|
| 304 | -! | +
- is_single_dataset_value <- teal.transform::is_single_dataset(+ col_facet, |
|
| 305 | -! | +
- args$x, args$y, args$row_facet, args$col_facet, args$color, args$fill, args$size+ plot_height, |
|
| 306 |
- )+ plot_width, |
||
| 307 |
-
+ ggplot2_args) {
|
||
| 308 | ! |
- ns <- NS(id)+ with_reporter <- !missing(reporter) && inherits(reporter, "Reporter") |
|
| 309 | ! |
- teal.widgets::standard_layout(+ with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI") |
|
| 310 | ! |
- output = teal.widgets::white_small_well(+ checkmate::assert_class(data, "reactive") |
|
| 311 | ! |
- tags$div(teal.widgets::plot_with_settings_ui(id = ns("myplot")))
+ checkmate::assert_class(isolate(data()), "teal_data") |
|
| 312 | -+ | ! |
- ),+ moduleServer(id, function(input, output, session) {
|
| 313 | ! |
- encoding = tags$div(+ teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.general") |
|
| 314 |
- ### Reporter+ |
||
| 315 | ! |
- teal.reporter::simple_reporter_ui(ns("simple_reporter")),
+ data_extract <- list(response = response, x = x, row_facet = row_facet, col_facet = col_facet) |
|
| 316 |
- ###+ |
||
| 317 | ! |
- tags$label("Encodings", class = "text-primary"),
+ rule_diff <- function(other) {
|
|
| 318 | ! |
- teal.transform::datanames_input(args[c("x", "y", "row_facet", "col_facet", "color", "fill", "size")]),
+ function(value) {
|
|
| 319 | ! |
- teal.transform::data_extract_ui(+ if (other %in% names(selector_list())) {
|
|
| 320 | ! |
- id = ns("x"),
+ othervalue <- selector_list()[[other]]()[["select"]] |
|
| 321 | ! |
- label = "X variable",+ if (!is.null(othervalue)) {
|
|
| 322 | ! |
- data_extract_spec = args$x,+ if (identical(value, othervalue)) {
|
|
| 323 | ! |
- is_single_dataset = is_single_dataset_value+ "Row and column facetting variables must be different." |
|
| 324 |
- ),+ } |
||
| 325 | -! | +
- teal.transform::data_extract_ui(+ } |
|
| 326 | -! | +
- id = ns("y"),
+ } |
|
| 327 | -! | +
- label = "Y variable",+ } |
|
| 328 | -! | +
- data_extract_spec = args$y,+ } |
|
| 329 | -! | +
- is_single_dataset = is_single_dataset_value+ |
|
| 330 | -+ | ! |
- ),+ selector_list <- teal.transform::data_extract_multiple_srv( |
| 331 | ! |
- conditionalPanel(+ data_extract = data_extract, |
|
| 332 | ! |
- condition =+ datasets = data, |
|
| 333 | ! |
- "$(\"button[data-id*='-x-dataset'][data-id$='-select']\").text() == '- Nothing selected - ' ||+ select_validation_rule = list( |
|
| 334 | ! |
- $(\"button[data-id*='-y-dataset'][data-id$='-select']\").text() == '- Nothing selected - ' ",+ response = shinyvalidate::sv_required("Please define a column for the response variable"),
|
|
| 335 | ! |
- shinyWidgets::radioGroupButtons(+ x = shinyvalidate::sv_required("Please define a column for X variable"),
|
|
| 336 | ! |
- inputId = ns("use_density"),
+ row_facet = shinyvalidate::compose_rules( |
|
| 337 | ! |
- label = NULL,+ shinyvalidate::sv_optional(), |
|
| 338 | ! |
- choices = c("frequency", "density"),
+ ~ if (length(.) > 1) "There must be 1 or no row facetting variable.", |
|
| 339 | ! |
- selected = ifelse(args$use_density, "density", "frequency"),+ rule_diff("col_facet")
|
|
| 340 | -! | +
- justified = TRUE+ ), |
|
| 341 | -+ | ! |
- )+ col_facet = shinyvalidate::compose_rules( |
| 342 | -+ | ! |
- ),+ shinyvalidate::sv_optional(), |
| 343 | ! |
- if (!is.null(args$row_facet) || !is.null(args$col_facet)) {
+ ~ if (length(.) > 1) "There must be 1 or no column facetting variable.", |
|
| 344 | ! |
- tags$div(+ rule_diff("row_facet")
|
|
| 345 | -! | +
- class = "data-extract-box",+ ) |
|
| 346 | -! | +
- tags$label("Facetting"),
+ ) |
|
| 347 | -! | +
- shinyWidgets::switchInput(inputId = ns("facetting"), value = args$facet, size = "mini"),
+ ) |
|
| 348 | -! | +
- conditionalPanel(+ |
|
| 349 | ! |
- condition = paste0("input['", ns("facetting"), "']"),
+ iv_r <- reactive({
|
|
| 350 | ! |
- tags$div(+ iv <- shinyvalidate::InputValidator$new() |
|
| 351 | ! |
- if (!is.null(args$row_facet)) {
+ iv$add_rule("ggtheme", shinyvalidate::sv_required("Please select a theme"))
|
|
| 352 | ! |
- teal.transform::data_extract_ui(+ teal.transform::compose_and_enable_validators(iv, selector_list) |
|
| 353 | -! | +
- id = ns("row_facet"),
+ }) |
|
| 354 | -! | +
- label = "Row facetting variable",+ |
|
| 355 | ! |
- data_extract_spec = args$row_facet,+ anl_merged_input <- teal.transform::merge_expression_srv( |
|
| 356 | ! |
- is_single_dataset = is_single_dataset_value+ selector_list = selector_list, |
|
| 357 | -+ | ! |
- )+ datasets = data |
| 358 |
- },+ ) |
||
| 359 | -! | +
- if (!is.null(args$col_facet)) {
+
|
|
| 360 | ! |
- teal.transform::data_extract_ui(+ anl_merged_q <- reactive({
|
|
| 361 | ! |
- id = ns("col_facet"),
+ req(anl_merged_input()) |
|
| 362 | ! |
- label = "Column facetting variable",+ data() %>% |
|
| 363 | ! |
- data_extract_spec = args$col_facet,+ teal.code::eval_code(as.expression(anl_merged_input()$expr)) |
|
| 364 | -! | +
- is_single_dataset = is_single_dataset_value+ }) |
|
| 365 |
- )+ |
||
| 366 | -+ | ! |
- },+ merged <- list( |
| 367 | ! |
- checkboxInput(ns("free_x_scales"), "free x scales", value = args$free_x_scales),
+ anl_input_r = anl_merged_input, |
|
| 368 | ! |
- checkboxInput(ns("free_y_scales"), "free y scales", value = args$free_y_scales)
+ anl_q_r = anl_merged_q |
|
| 369 |
- )+ ) |
||
| 370 |
- )+ |
||
| 371 | -+ | ! |
- )+ output_q <- reactive({
|
| 372 | -+ | ! |
- },+ teal::validate_inputs(iv_r()) |
| 373 | -! | +
- if (args$color_settings) {
+
|
|
| 374 | -+ | ! |
- # Put a grey border around the coloring settings+ qenv <- merged$anl_q_r() |
| 375 | ! |
- tags$div(+ ANL <- qenv[["ANL"]] |
|
| 376 | ! |
- class = "data-extract-box",+ resp_var <- as.vector(merged$anl_input_r()$columns_source$response) |
|
| 377 | ! |
- tags$label("Color settings"),
+ x <- as.vector(merged$anl_input_r()$columns_source$x) |
|
| 378 | -! | +
- shinyWidgets::switchInput(inputId = ns("coloring"), value = TRUE, size = "mini"),
+
|
|
| 379 | ! |
- conditionalPanel(+ validate(need(is.factor(ANL[[resp_var]]), "Please select a factor variable as the response.")) |
|
| 380 | ! |
- condition = paste0("input['", ns("coloring"), "']"),
+ validate(need(is.factor(ANL[[x]]), "Please select a factor variable as the X-Variable.")) |
|
| 381 | ! |
- tags$div(+ teal::validate_has_data(ANL, 10) |
|
| 382 | ! |
- teal.transform::data_extract_ui(+ teal::validate_has_data(ANL[, c(resp_var, x)], 10, complete = TRUE, allow_inf = FALSE) |
|
| 383 | -! | +
- id = ns("color"),
+
|
|
| 384 | ! |
- label = "Outline color by variable",+ row_facet_name <- if (length(merged$anl_input_r()$columns_source$row_facet) == 0) {
|
|
| 385 | ! |
- data_extract_spec = args$color,+ character(0) |
|
| 386 | -! | +
- is_single_dataset = is_single_dataset_value+ } else {
|
|
| 387 | -+ | ! |
- ),+ as.vector(merged$anl_input_r()$columns_source$row_facet) |
| 388 | -! | +
- teal.transform::data_extract_ui(+ } |
|
| 389 | ! |
- id = ns("fill"),
+ col_facet_name <- if (length(merged$anl_input_r()$columns_source$col_facet) == 0) {
|
|
| 390 | ! |
- label = "Fill color by variable",+ character(0) |
|
| 391 | -! | +
- data_extract_spec = args$fill,+ } else {
|
|
| 392 | ! |
- is_single_dataset = is_single_dataset_value+ as.vector(merged$anl_input_r()$columns_source$col_facet) |
|
| 393 |
- ),+ } |
||
| 394 | -! | +
- tags$div(+ |
|
| 395 | ! |
- id = ns("size_settings"),
+ freq <- input$freq == "frequency" |
|
| 396 | ! |
- teal.transform::data_extract_ui(+ swap_axes <- input$coord_flip |
|
| 397 | ! |
- id = ns("size"),
+ counts <- input$count_labels |
|
| 398 | ! |
- label = "Size of points by variable (only if x and y are numeric)",+ rotate_xaxis_labels <- input$rotate_xaxis_labels |
|
| 399 | ! |
- data_extract_spec = args$size,+ ggtheme <- input$ggtheme |
|
| 400 | -! | +
- is_single_dataset = is_single_dataset_value+ |
|
| 401 | -+ | ! |
- )+ arg_position <- if (freq) "stack" else "fill" |
| 402 |
- )+ |
||
| 403 | -+ | ! |
- )+ rowf <- if (length(row_facet_name) != 0) as.name(row_facet_name) |
| 404 | -+ | ! |
- )+ colf <- if (length(col_facet_name) != 0) as.name(col_facet_name) |
| 405 | -+ | ! |
- )+ resp_cl <- as.name(resp_var) |
| 406 | -+ | ! |
- },+ x_cl <- as.name(x) |
| 407 | -! | +
- teal.widgets::panel_group(+ |
|
| 408 | ! |
- teal.widgets::panel_item(+ if (swap_axes) {
|
|
| 409 | ! |
- title = "Plot settings",+ qenv <- teal.code::eval_code( |
|
| 410 | ! |
- checkboxInput(ns("rotate_xaxis_labels"), "Rotate X axis labels", value = args$rotate_xaxis_labels),
+ qenv, |
|
| 411 | ! |
- checkboxInput(ns("swap_axes"), "Swap axes", value = args$swap_axes),
+ substitute( |
|
| 412 | ! |
- selectInput(+ expr = ANL[[x]] <- with(ANL, forcats::fct_rev(x_cl)), |
|
| 413 | ! |
- inputId = ns("ggtheme"),
+ env = list(x = x, x_cl = x_cl) |
|
| 414 | -! | +
- label = "Theme (by ggplot):",+ ) |
|
| 415 | -! | +
- choices = ggplot_themes,+ ) |
|
| 416 | -! | +
- selected = args$ggtheme,+ } |
|
| 417 | -! | +
- multiple = FALSE+ |
|
| 418 | -+ | ! |
- ),+ qenv <- teal.code::eval_code( |
| 419 | ! |
- sliderInput(+ qenv, |
|
| 420 | ! |
- ns("alpha"), "Opacity Scatterplot:",
+ substitute( |
|
| 421 | ! |
- min = 0, max = 1,+ expr = ANL[[resp_var]] <- factor(ANL[[resp_var]]), |
|
| 422 | ! |
- step = .05, value = .5, ticks = FALSE+ env = list(resp_var = resp_var) |
|
| 423 |
- ),+ ) |
||
| 424 | -! | +
- sliderInput(+ ) %>% |
|
| 425 | -! | +
- ns("fixed_size"), "Scatterplot point size:",
+ # rowf and colf will be a NULL if not set by a user |
|
| 426 | ! |
- min = 1, max = 8,+ teal.code::eval_code( |
|
| 427 | ! |
- step = 1, value = 2, ticks = FALSE+ substitute( |
|
| 428 | -+ | ! |
- ),+ expr = ANL2 <- ANL %>% |
| 429 | ! |
- checkboxInput(ns("add_lines"), "Add lines"),
+ dplyr::group_by_at(dplyr::vars(x_cl, resp_cl, rowf, colf)) %>% |
|
| 430 | -+ | ! |
- )+ dplyr::summarise(ns = dplyr::n()) %>% |
| 431 | -+ | ! |
- )+ dplyr::group_by_at(dplyr::vars(x_cl, rowf, colf)) %>% |
| 432 | -+ | ! |
- ),+ dplyr::mutate(sums = sum(ns), percent = round(ns / sums * 100, 1)), |
| 433 | ! |
- forms = tagList(+ env = list(x_cl = x_cl, resp_cl = resp_cl, rowf = rowf, colf = colf) |
|
| 434 | -! | +
- teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code")
+ ) |
|
| 435 |
- ),+ ) %>% |
||
| 436 | ! |
- pre_output = args$pre_output,+ teal.code::eval_code( |
|
| 437 | ! |
- post_output = args$post_output+ substitute( |
|
| 438 | -+ | ! |
- )+ expr = ANL3 <- ANL %>% |
| 439 | -+ | ! |
- }+ dplyr::group_by_at(dplyr::vars(x_cl, rowf, colf)) %>% |
| 440 | -+ | ! |
-
+ dplyr::summarise(ns = dplyr::n()), |
| 441 | -+ | ! |
- # Server function for the bivariate module+ env = list(x_cl = x_cl, rowf = rowf, colf = colf) |
| 442 |
- srv_g_bivariate <- function(id,+ ) |
||
| 443 |
- data,+ ) |
||
| 444 |
- reporter,+ |
||
| 445 | -+ | ! |
- filter_panel_api,+ plot_call <- substitute( |
| 446 | -+ | ! |
- x,+ expr = ggplot(ANL2, aes(x = x_cl, y = ns)) + |
| 447 | -+ | ! |
- y,+ geom_bar(aes(fill = resp_cl), stat = "identity", position = arg_position), |
| 448 | -+ | ! |
- row_facet,+ env = list( |
| 449 | -+ | ! |
- col_facet,+ x_cl = x_cl, |
| 450 | -+ | ! |
- color_settings = FALSE,+ resp_cl = resp_cl, |
| 451 | -+ | ! |
- color,+ arg_position = arg_position |
| 452 |
- fill,+ ) |
||
| 453 |
- size,+ ) |
||
| 454 |
- plot_height,+ |
||
| 455 | -+ | ! |
- plot_width,+ if (!freq) {
|
| 456 | -+ | ! |
- ggplot2_args) {
+ plot_call <- substitute( |
| 457 | ! |
- with_reporter <- !missing(reporter) && inherits(reporter, "Reporter")+ plot_call + expand_limits(y = c(0, 1.1)), |
|
| 458 | ! |
- with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI")+ env = list(plot_call = plot_call) |
|
| 459 | -! | +
- checkmate::assert_class(data, "reactive")+ ) |
|
| 460 | -! | +
- checkmate::assert_class(isolate(data()), "teal_data")+ } |
|
| 461 | -! | +
- moduleServer(id, function(input, output, session) {
+
|
|
| 462 | ! |
- teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.general")+ if (counts) {
|
|
| 463 | -+ | ! |
-
+ plot_call <- substitute( |
| 464 | ! |
- ns <- session$ns+ expr = plot_call + |
|
| 465 | -+ | ! |
-
+ geom_text( |
| 466 | ! |
- data_extract <- list(+ data = ANL2, |
|
| 467 | ! |
- x = x, y = y, row_facet = row_facet, col_facet = col_facet,+ aes(label = ns, x = x_cl, y = ns, group = resp_cl), |
|
| 468 | ! |
- color = color, fill = fill, size = size+ col = "white", |
|
| 469 | -+ | ! |
- )+ vjust = "middle", |
| 470 | -+ | ! |
-
+ hjust = "middle", |
| 471 | ! |
- rule_var <- function(other) {
+ position = position_anl2_value |
|
| 472 | -! | +
- function(value) {
+ ) + |
|
| 473 | ! |
- othervalue <- selector_list()[[other]]()$select+ geom_text( |
|
| 474 | ! |
- if (length(value) == 0L && length(othervalue) == 0L) {
+ data = ANL3, aes(label = ns, x = x_cl, y = anl3_y), |
|
| 475 | ! |
- "Please select at least one of x-variable or y-variable"+ hjust = hjust_value, |
|
| 476 | -+ | ! |
- }+ vjust = vjust_value, |
| 477 | -+ | ! |
- }+ position = position_anl3_value |
| 478 |
- }+ ), |
||
| 479 | ! |
- rule_diff <- function(other) {
+ env = list( |
|
| 480 | ! |
- function(value) {
+ plot_call = plot_call, |
|
| 481 | ! |
- othervalue <- selector_list()[[other]]()[["select"]]+ x_cl = x_cl, |
|
| 482 | ! |
- if (!is.null(othervalue)) {
+ resp_cl = resp_cl, |
|
| 483 | ! |
- if (identical(value, othervalue)) {
+ hjust_value = if (swap_axes) "left" else "middle", |
|
| 484 | ! |
- "Row and column facetting variables must be different."+ vjust_value = if (swap_axes) "middle" else -1, |
|
| 485 | -+ | ! |
- }+ position_anl2_value = if (!freq) quote(position_fill(0.5)) else quote(position_stack(0.5)), # nolint: line_length. |
| 486 | -+ | ! |
- }+ anl3_y = if (!freq) 1.1 else as.name("ns"),
|
| 487 | -+ | ! |
- }+ position_anl3_value = if (!freq) "fill" else "stack" |
| 488 |
- }+ ) |
||
| 489 |
-
+ ) |
||
| 490 | -! | +
- selector_list <- teal.transform::data_extract_multiple_srv(+ } |
|
| 491 | -! | +
- data_extract = data_extract,+ |
|
| 492 | ! |
- datasets = data,+ if (swap_axes) {
|
|
| 493 | ! |
- select_validation_rule = list(+ plot_call <- substitute(plot_call + coord_flip(), env = list(plot_call = plot_call)) |
|
| 494 | -! | +
- x = rule_var("y"),
+ } |
|
| 495 | -! | +
- y = rule_var("x"),
+
|
|
| 496 | ! |
- row_facet = shinyvalidate::compose_rules(+ facet_cl <- facet_ggplot_call(row_facet_name, col_facet_name) |
|
| 497 | -! | +
- shinyvalidate::sv_optional(),+ |
|
| 498 | ! |
- rule_diff("col_facet")
+ if (!is.null(facet_cl)) {
|
|
| 499 | -+ | ! |
- ),+ plot_call <- substitute(expr = plot_call + facet_cl, env = list(plot_call = plot_call, facet_cl = facet_cl)) |
| 500 | -! | +
- col_facet = shinyvalidate::compose_rules(+ } |
|
| 501 | -! | +
- shinyvalidate::sv_optional(),+ |
|
| 502 | ! |
- rule_diff("row_facet")
+ dev_ggplot2_args <- teal.widgets::ggplot2_args( |
|
| 503 | -+ | ! |
- )+ labs = list( |
| 504 | -+ | ! |
- )+ x = varname_w_label(x, ANL), |
| 505 | -+ | ! |
- )+ y = varname_w_label(resp_var, ANL, prefix = "Proportion of "), |
| 506 | -+ | ! |
-
+ fill = varname_w_label(resp_var, ANL) |
| 507 | -! | +
- iv_r <- reactive({
+ ), |
|
| 508 | ! |
- iv_facet <- shinyvalidate::InputValidator$new()+ theme = list(legend.position = "bottom") |
|
| 509 | -! | +
- iv_child <- teal.transform::compose_and_enable_validators(iv_facet, selector_list,+ ) |
|
| 510 | -! | +
- validator_names = c("row_facet", "col_facet")
+
|
|
| 511 | -+ | ! |
- )+ if (rotate_xaxis_labels) {
|
| 512 | ! |
- iv_child$condition(~ isTRUE(input$facetting))+ dev_ggplot2_args$theme[["axis.text.x"]] <- quote(element_text(angle = 45, hjust = 1)) |
|
| 513 |
-
+ } |
||
| 514 | -! | +
- iv <- shinyvalidate::InputValidator$new()+ |
|
| 515 | ! |
- iv$add_validator(iv_child)+ all_ggplot2_args <- teal.widgets::resolve_ggplot2_args( |
|
| 516 | ! |
- teal.transform::compose_and_enable_validators(iv, selector_list, validator_names = c("x", "y"))
+ user_plot = ggplot2_args, |
|
| 517 | -+ | ! |
- })+ module_plot = dev_ggplot2_args |
| 518 |
-
+ ) |
||
| 519 | -! | +
- anl_merged_input <- teal.transform::merge_expression_srv(+ |
|
| 520 | ! |
- selector_list = selector_list,+ parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args( |
|
| 521 | ! |
- datasets = data+ all_ggplot2_args, |
|
| 522 | -+ | ! |
- )+ ggtheme = ggtheme |
| 523 |
-
+ ) |
||
| 524 | -! | +
- anl_merged_q <- reactive({
+
|
|
| 525 | ! |
- req(anl_merged_input())+ plot_call <- substitute(expr = {
|
|
| 526 | ! |
- data() %>%+ p <- plot_call + labs + ggthemes + themes |
|
| 527 | ! |
- teal.code::eval_code(as.expression(anl_merged_input()$expr))+ print(p) |
|
| 528 | -+ | ! |
- })+ }, env = list( |
| 529 | -+ | ! |
-
+ plot_call = plot_call, |
| 530 | ! |
- merged <- list(+ labs = parsed_ggplot2_args$labs, |
|
| 531 | ! |
- anl_input_r = anl_merged_input,+ themes = parsed_ggplot2_args$theme, |
|
| 532 | ! |
- anl_q_r = anl_merged_q+ ggthemes = parsed_ggplot2_args$ggtheme |
|
| 533 |
- )+ )) |
||
| 535 | ! |
- output_q <- reactive({
+ teal.code::eval_code(qenv, plot_call) |
|
| 536 | -! | +
- teal::validate_inputs(iv_r())+ }) |
|
| 538 | ! |
- ANL <- merged$anl_q_r()[["ANL"]]+ plot_r <- reactive(output_q()[["p"]]) |
|
| 539 | -! | +
- teal::validate_has_data(ANL, 3)+ |
|
| 540 |
-
+ # Insert the plot into a plot_with_settings module from teal.widgets |
||
| 541 | ! |
- x_col_vec <- as.vector(merged$anl_input_r()$columns_source$x)+ pws <- teal.widgets::plot_with_settings_srv( |
|
| 542 | ! |
- x_name <- `if`(is.null(x_col_vec), character(0), x_col_vec)+ id = "myplot", |
|
| 543 | ! |
- y_col_vec <- as.vector(merged$anl_input_r()$columns_source$y)+ plot_r = plot_r, |
|
| 544 | ! |
- y_name <- `if`(is.null(y_col_vec), character(0), y_col_vec)+ height = plot_height, |
|
| 545 | -+ | ! |
-
+ width = plot_width |
| 546 | -! | +
- row_facet_name <- as.vector(merged$anl_input_r()$columns_source$row_facet)+ ) |
|
| 547 | -! | +
- col_facet_name <- as.vector(merged$anl_input_r()$columns_source$col_facet)+ |
|
| 548 | ! |
- color_name <- if ("color" %in% names(merged$anl_input_r()$columns_source)) {
+ teal.widgets::verbatim_popup_srv( |
|
| 549 | ! |
- as.vector(merged$anl_input_r()$columns_source$color)+ id = "rcode", |
|
| 550 | -+ | ! |
- } else {
+ verbatim_content = reactive(teal.code::get_code(output_q())), |
| 551 | ! |
- character(0)+ title = "Show R Code for Response" |
|
| 552 |
- }+ ) |
||
| 553 | -! | +
- fill_name <- if ("fill" %in% names(merged$anl_input_r()$columns_source)) {
+
|
|
| 554 | -! | +
- as.vector(merged$anl_input_r()$columns_source$fill)+ ### REPORTER |
|
| 555 | -+ | ! |
- } else {
+ if (with_reporter) {
|
| 556 | ! |
- character(0)+ card_fun <- function(comment, label) {
|
|
| 557 | -+ | ! |
- }+ card <- teal::report_card_template( |
| 558 | ! |
- size_name <- if ("size" %in% names(merged$anl_input_r()$columns_source)) {
+ title = "Response Plot", |
|
| 559 | ! |
- as.vector(merged$anl_input_r()$columns_source$size)+ label = label, |
|
| 560 | -+ | ! |
- } else {
+ with_filter = with_filter, |
| 561 | ! |
- character(0)+ filter_panel_api = filter_panel_api |
|
| 562 |
- }+ ) |
||
| 563 | -+ | ! |
-
+ card$append_text("Plot", "header3")
|
| 564 | ! |
- use_density <- input$use_density == "density"+ card$append_plot(plot_r(), dim = pws$dim()) |
|
| 565 | ! |
- free_x_scales <- input$free_x_scales+ if (!comment == "") {
|
|
| 566 | ! |
- free_y_scales <- input$free_y_scales+ card$append_text("Comment", "header3")
|
|
| 567 | ! |
- ggtheme <- input$ggtheme+ card$append_text(comment) |
|
| 568 | -! | +
- rotate_xaxis_labels <- input$rotate_xaxis_labels+ } |
|
| 569 | ! |
- swap_axes <- input$swap_axes+ card$append_src(teal.code::get_code(output_q())) |
|
| 570 | -+ | ! |
-
+ card |
| 571 | -! | +
- is_scatterplot <- all(vapply(ANL[c(x_name, y_name)], is.numeric, logical(1))) &&+ } |
|
| 572 | ! |
- length(x_name) > 0 && length(y_name) > 0+ teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
|
|
| 573 |
-
+ } |
||
| 574 | -! | +
- if (is_scatterplot) {
+ ### |
|
| 575 | -! | +
- shinyjs::show("alpha")
+ }) |
|
| 576 | -! | +
- alpha <- input$alpha+ } |
|
| 577 | -! | +
| 1 | +
- shinyjs::show("add_lines")
+ #' `teal` module: Stack plots of variables and show association with reference variable |
||
| 578 | +2 |
-
+ #' |
|
| 579 | -! | +||
| 3 | +
- if (color_settings && input$coloring) {
+ #' Module provides functionality for visualizing the distribution of variables and |
||
| 580 | -! | +||
| 4 | +
- shinyjs::hide("fixed_size")
+ #' their association with a reference variable. |
||
| 581 | -! | +||
| 5 | +
- shinyjs::show("size_settings")
+ #' It supports configuring the appearance of the plots, including themes and whether to show associations. |
||
| 582 | -! | +||
| 6 | +
- size <- NULL+ #' |
||
| 583 | +7 |
- } else {
+ #' |
|
| 584 | -! | +||
| 8 | +
- shinyjs::show("fixed_size")
+ #' @note For more examples, please see the vignette "Using association plot" via |
||
| 585 | -! | +||
| 9 | +
- size <- input$fixed_size+ #' `vignette("using-association-plot", package = "teal.modules.general")`.
|
||
| 586 | +10 |
- }+ #' |
|
| 587 | +11 |
- } else {
+ #' @inheritParams teal::module |
|
| 588 | -! | +||
| 12 | +
- shinyjs::hide("add_lines")
+ #' @inheritParams shared_params |
||
| 589 | -! | +||
| 13 | +
- updateCheckboxInput(session, "add_lines", value = restoreInput(ns("add_lines"), FALSE))
+ #' @param ref (`data_extract_spec` or `list` of multiple `data_extract_spec`) |
||
| 590 | -! | +||
| 14 | +
- shinyjs::hide("alpha")
+ #' Reference variable, must accepts a `data_extract_spec` with `select_spec(multiple = FALSE)` |
||
| 591 | -! | +||
| 15 | +
- shinyjs::hide("fixed_size")
+ #' to ensure single selection option. |
||
| 592 | -! | +||
| 16 | +
- shinyjs::hide("size_settings")
+ #' @param vars (`data_extract_spec` or `list` of multiple `data_extract_spec`) |
||
| 593 | -! | +||
| 17 | +
- alpha <- 1+ #' Variables to be associated with the reference variable. |
||
| 594 | -! | +||
| 18 | +
- size <- NULL+ #' @param show_association (`logical`) optional, whether show association of `vars` |
||
| 595 | +19 |
- }+ #' with reference variable. Defaults to `TRUE`. |
|
| 596 | +20 |
-
+ #' @param distribution_theme,association_theme (`character`) optional, `ggplot2` themes to be used by default. |
|
| 597 | -! | +||
| 21 | +
- teal::validate_has_data(ANL[, c(x_name, y_name), drop = FALSE], 3, complete = TRUE, allow_inf = FALSE)+ #' Default to `"gray"`. |
||
| 598 | +22 |
-
+ #' |
|
| 599 | -! | +||
| 23 | +
- cl <- bivariate_plot_call(+ #' @templateVar ggnames "Bivariate1", "Bivariate2" |
||
| 600 | -! | +||
| 24 | +
- data_name = "ANL",+ #' @template ggplot2_args_multi |
||
| 601 | -! | +||
| 25 | +
- x = x_name,+ #' |
||
| 602 | -! | +||
| 26 | +
- y = y_name,+ #' @inherit shared_params return |
||
| 603 | -! | +||
| 27 | +
- x_class = ifelse(!identical(x_name, character(0)), class(ANL[[x_name]]), "NULL"),+ #' |
||
| 604 | -! | +||
| 28 | +
- y_class = ifelse(!identical(y_name, character(0)), class(ANL[[y_name]]), "NULL"),+ #' @examplesShinylive |
||
| 605 | -! | +||
| 29 | +
- x_label = varname_w_label(x_name, ANL),+ #' library(teal.modules.general) |
||
| 606 | -! | +||
| 30 | +
- y_label = varname_w_label(y_name, ANL),+ #' interactive <- function() TRUE |
||
| 607 | -! | +||
| 31 | +
- freq = !use_density,+ #' {{ next_example }}
|
||
| 608 | -! | +||
| 32 | +
- theme = ggtheme,+ #' @examples |
||
| 609 | -! | +||
| 33 | +
- rotate_xaxis_labels = rotate_xaxis_labels,+ #' # general data example |
||
| 610 | -! | +||
| 34 | +
- swap_axes = swap_axes,+ #' data <- teal_data() |
||
| 611 | -! | +||
| 35 | +
- alpha = alpha,+ #' data <- within(data, {
|
||
| 612 | -! | +||
| 36 | +
- size = size,+ #' require(nestcolor) |
||
| 613 | -! | +||
| 37 | +
- ggplot2_args = ggplot2_args+ #' CO2 <- CO2 |
||
| 614 | +38 |
- )+ #' factors <- names(Filter(isTRUE, vapply(CO2, is.factor, logical(1L)))) |
|
| 615 | +39 |
-
+ #' CO2[factors] <- lapply(CO2[factors], as.character) |
|
| 616 | -! | +||
| 40 | +
- facetting <- (isTRUE(input$facetting) && (!is.null(row_facet_name) || !is.null(col_facet_name)))+ #' }) |
||
| 617 | +41 |
-
+ #' |
|
| 618 | -! | +||
| 42 | +
- if (facetting) {
+ #' app <- init( |
||
| 619 | -! | +||
| 43 | +
- facet_cl <- facet_ggplot_call(row_facet_name, col_facet_name, free_x_scales, free_y_scales)+ #' data = data, |
||
| 620 | +44 |
-
+ #' modules = modules( |
|
| 621 | -! | +||
| 45 | +
- if (!is.null(facet_cl)) {
+ #' tm_g_association( |
||
| 622 | -! | +||
| 46 | +
- cl <- call("+", cl, facet_cl)
+ #' ref = data_extract_spec( |
||
| 623 | +47 |
- }+ #' dataname = "CO2", |
|
| 624 | +48 |
- }+ #' select = select_spec( |
|
| 625 | +49 |
-
+ #' label = "Select variable:", |
|
| 626 | -! | +||
| 50 | +
- if (input$add_lines) {
+ #' choices = variable_choices(data[["CO2"]], c("Plant", "Type", "Treatment")),
|
||
| 627 | -! | +||
| 51 | +
- cl <- call("+", cl, quote(geom_line(size = 1)))
+ #' selected = "Plant", |
||
| 628 | +52 |
- }+ #' fixed = FALSE |
|
| 629 | +53 |
-
+ #' ) |
|
| 630 | -! | +||
| 54 | +
- coloring_cl <- NULL+ #' ), |
||
| 631 | -! | +||
| 55 | +
- if (color_settings) {
+ #' vars = data_extract_spec( |
||
| 632 | -! | +||
| 56 | +
- if (input$coloring) {
+ #' dataname = "CO2", |
||
| 633 | -! | +||
| 57 | +
- coloring_cl <- coloring_ggplot_call(+ #' select = select_spec( |
||
| 634 | -! | +||
| 58 | +
- colour = color_name,+ #' label = "Select variables:", |
||
| 635 | -! | +||
| 59 | +
- fill = fill_name,+ #' choices = variable_choices(data[["CO2"]], c("Plant", "Type", "Treatment")),
|
||
| 636 | -! | +||
| 60 | +
- size = size_name,+ #' selected = "Treatment", |
||
| 637 | -! | +||
| 61 | +
- is_point = any(grepl("geom_point", cl %>% deparse()))
+ #' multiple = TRUE, |
||
| 638 | +62 |
- )+ #' fixed = FALSE |
|
| 639 | -! | +||
| 63 | +
- legend_lbls <- substitute(+ #' ) |
||
| 640 | -! | +||
| 64 | +
- expr = labs(color = color_name, fill = fill_name, size = size_name),+ #' ) |
||
| 641 | -! | +||
| 65 | +
- env = list(+ #' ) |
||
| 642 | -! | +||
| 66 | +
- color_name = varname_w_label(color_name, ANL),+ #' ) |
||
| 643 | -! | +||
| 67 | +
- fill_name = varname_w_label(fill_name, ANL),+ #' ) |
||
| 644 | -! | +||
| 68 | +
- size_name = varname_w_label(size_name, ANL)+ #' if (interactive()) {
|
||
| 645 | +69 |
- )+ #' shinyApp(app$ui, app$server) |
|
| 646 | +70 |
- )+ #' } |
|
| 647 | +71 |
- }+ #' |
|
| 648 | -! | +||
| 72 | +
- if (!is.null(coloring_cl)) {
+ #' @examplesShinylive |
||
| 649 | -! | +||
| 73 | +
- cl <- call("+", call("+", cl, coloring_cl), legend_lbls)
+ #' library(teal.modules.general) |
||
| 650 | +74 |
- }+ #' interactive <- function() TRUE |
|
| 651 | +75 |
- }+ #' {{ next_example }}
|
|
| 652 | +76 |
-
+ #' @examples |
|
| 653 | +77 |
- # Add labels to facets+ #' # CDISC data example |
|
| 654 | -! | +||
| 78 | +
- nulled_row_facet_name <- varname_w_label(row_facet_name, ANL)+ #' data <- teal_data() |
||
| 655 | -! | +||
| 79 | +
- nulled_col_facet_name <- varname_w_label(col_facet_name, ANL)+ #' data <- within(data, {
|
||
| 656 | -! | +||
| 80 | +
- without_facet <- (is.null(nulled_row_facet_name) && is.null(nulled_col_facet_name)) || !facetting+ #' require(nestcolor) |
||
| 657 | +81 |
-
+ #' ADSL <- rADSL |
|
| 658 | -! | +||
| 82 | +
- print_call <- if (without_facet) {
+ #' }) |
||
| 659 | -! | +||
| 83 | +
- quote(print(p))+ #' join_keys(data) <- default_cdisc_join_keys[names(data)] |
||
| 660 | +84 |
- } else {
+ #' |
|
| 661 | -! | +||
| 85 | +
- substitute(+ #' app <- init( |
||
| 662 | -! | +||
| 86 | +
- expr = {
+ #' data = data, |
||
| 663 | +87 |
- # Add facetting labels+ #' modules = modules( |
|
| 664 | +88 |
- # optional: grid.newpage() # nolint: commented_code.+ #' tm_g_association( |
|
| 665 | +89 |
- # Prefixed with teal.modules.general as its usage will appear in "Show R code"+ #' ref = data_extract_spec( |
|
| 666 | -! | +||
| 90 | +
- p <- teal.modules.general::add_facet_labels(+ #' dataname = "ADSL", |
||
| 667 | -! | +||
| 91 | +
- p,+ #' select = select_spec( |
||
| 668 | -! | +||
| 92 | +
- xfacet_label = nulled_col_facet_name,+ #' label = "Select variable:", |
||
| 669 | -! | +||
| 93 | +
- yfacet_label = nulled_row_facet_name+ #' choices = variable_choices( |
||
| 670 | +94 |
- )+ #' data[["ADSL"]], |
|
| 671 | -! | +||
| 95 | +
- grid::grid.newpage()+ #' c("SEX", "RACE", "COUNTRY", "ARM", "STRATA1", "STRATA2", "ITTFL", "BMRKR2")
|
||
| 672 | -! | +||
| 96 | +
- grid::grid.draw(p)+ #' ), |
||
| 673 | +97 |
- },+ #' selected = "RACE", |
|
| 674 | -! | +||
| 98 | +
- env = list(nulled_col_facet_name = nulled_col_facet_name, nulled_row_facet_name = nulled_row_facet_name)+ #' fixed = FALSE |
||
| 675 | +99 |
- )+ #' ) |
|
| 676 | +100 |
- }+ #' ), |
|
| 677 | +101 |
-
+ #' vars = data_extract_spec( |
|
| 678 | -! | +||
| 102 | +
- teal.code::eval_code(merged$anl_q_r(), substitute(expr = p <- cl, env = list(cl = cl))) %>%+ #' dataname = "ADSL", |
||
| 679 | -! | +||
| 103 | +
- teal.code::eval_code(print_call)+ #' select = select_spec( |
||
| 680 | +104 |
- })+ #' label = "Select variables:", |
|
| 681 | +105 |
-
+ #' choices = variable_choices( |
|
| 682 | -! | +||
| 106 | +
- plot_r <- reactive({
+ #' data[["ADSL"]], |
||
| 683 | -! | +||
| 107 | +
- output_q()[["p"]]+ #' c("SEX", "RACE", "COUNTRY", "ARM", "STRATA1", "STRATA2", "ITTFL", "BMRKR2")
|
||
| 684 | +108 |
- })+ #' ), |
|
| 685 | +109 |
-
+ #' selected = "BMRKR2", |
|
| 686 | -! | +||
| 110 | +
- pws <- teal.widgets::plot_with_settings_srv(+ #' multiple = TRUE, |
||
| 687 | -! | +||
| 111 | +
- id = "myplot",+ #' fixed = FALSE |
||
| 688 | -! | +||
| 112 | +
- plot_r = plot_r,+ #' ) |
||
| 689 | -! | +||
| 113 | +
- height = plot_height,+ #' ) |
||
| 690 | -! | +||
| 114 | +
- width = plot_width+ #' ) |
||
| 691 | +115 |
- )+ #' ) |
|
| 692 | +116 |
-
+ #' ) |
|
| 693 | -! | +||
| 117 | +
- teal.widgets::verbatim_popup_srv(+ #' if (interactive()) {
|
||
| 694 | -! | +||
| 118 | +
- id = "rcode",+ #' shinyApp(app$ui, app$server) |
||
| 695 | -! | +||
| 119 | +
- verbatim_content = reactive(teal.code::get_code(output_q())),+ #' } |
||
| 696 | -! | +||
| 120 | +
- title = "Bivariate Plot"+ #' |
||
| 697 | +121 |
- )+ #' @export |
|
| 698 | +122 |
-
+ #' |
|
| 699 | +123 |
- ### REPORTER+ tm_g_association <- function(label = "Association", |
|
| 700 | -! | +||
| 124 | +
- if (with_reporter) {
+ ref, |
||
| 701 | -! | +||
| 125 | +
- card_fun <- function(comment, label) {
+ vars, |
||
| 702 | -! | +||
| 126 | +
- card <- teal::report_card_template(+ show_association = TRUE, |
||
| 703 | -! | +||
| 127 | +
- title = "Bivariate Plot",+ plot_height = c(600, 400, 5000), |
||
| 704 | -! | +||
| 128 | +
- label = label,+ plot_width = NULL, |
||
| 705 | -! | +||
| 129 | +
- with_filter = with_filter,+ distribution_theme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void"), # nolint: line_length.
|
||
| 706 | -! | +||
| 130 | +
- filter_panel_api = filter_panel_api+ association_theme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void"), # nolint: line_length.
|
||
| 707 | +131 |
- )+ pre_output = NULL, |
|
| 708 | -! | +||
| 132 | +
- card$append_text("Plot", "header3")
+ post_output = NULL,+ |
+ ||
| 133 | ++ |
+ ggplot2_args = teal.widgets::ggplot2_args()) {
|
|
| 709 | +134 | ! |
- card$append_plot(plot_r(), dim = pws$dim())+ message("Initializing tm_g_association")
+ |
+
| 135 | ++ | + + | +|
| 136 | ++ |
+ # Normalize the parameters |
|
| 710 | +137 | ! |
- if (!comment == "") {
+ if (inherits(ref, "data_extract_spec")) ref <- list(ref) |
| 711 | +138 | ! |
- card$append_text("Comment", "header3")
+ if (inherits(vars, "data_extract_spec")) vars <- list(vars) |
| 712 | +139 | ! |
- card$append_text(comment)+ if (inherits(ggplot2_args, "ggplot2_args")) ggplot2_args <- list(default = ggplot2_args) |
| 713 | +140 |
- }+ |
|
| 714 | -! | +||
| 141 | +
- card$append_src(teal.code::get_code(output_q()))+ # Start of assertions |
||
| 715 | +142 | ! |
- card+ checkmate::assert_string(label) |
| 716 | +143 |
- }+ |
|
| 717 | +144 | ! |
- teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
+ checkmate::assert_list(ref, types = "data_extract_spec") |
| 718 | -+ | ||
| 145 | +! |
- }+ if (!all(vapply(ref, function(x) !x$select$multiple, logical(1)))) {
|
|
| 719 | -+ | ||
| 146 | +! |
- ###+ stop("'ref' should not allow multiple selection")
|
|
| 720 | +147 |
- })+ } |
|
| 721 | +148 |
- }+ |
|
| 722 | -+ | ||
| 149 | +! |
-
+ checkmate::assert_list(vars, types = "data_extract_spec") |
|
| 723 | -+ | ||
| 150 | +! |
- # Get Substituted ggplot call+ checkmate::assert_flag(show_association) |
|
| 724 | +151 |
- bivariate_plot_call <- function(data_name,+ |
|
| 725 | -+ | ||
| 152 | +! |
- x = character(0),+ checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE) |
|
| 726 | -+ | ||
| 153 | +! |
- y = character(0),+ checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height") |
|
| 727 | -+ | ||
| 154 | +! |
- x_class = "NULL",+ checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE) |
|
| 728 | -+ | ||
| 155 | +! |
- y_class = "NULL",+ checkmate::assert_numeric( |
|
| 729 | -+ | ||
| 156 | +! |
- x_label = NULL,+ plot_width[1], |
|
| 730 | -+ | ||
| 157 | +! |
- y_label = NULL,+ lower = plot_width[2], upper = plot_width[3], null.ok = TRUE, .var.name = "plot_width" |
|
| 731 | +158 |
- freq = TRUE,+ ) |
|
| 732 | +159 |
- theme = "gray",+ |
|
| 733 | -+ | ||
| 160 | +! |
- rotate_xaxis_labels = FALSE,+ distribution_theme <- match.arg(distribution_theme) |
|
| 734 | -+ | ||
| 161 | +! |
- swap_axes = FALSE,+ association_theme <- match.arg(association_theme) |
|
| 735 | +162 |
- alpha = double(0),+ |
|
| 736 | -+ | ||
| 163 | +! |
- size = 2,+ checkmate::assert_multi_class(pre_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
+ |
+ |
| 164 | +! | +
+ checkmate::assert_multi_class(post_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
|
|
| 737 | +165 |
- ggplot2_args = teal.widgets::ggplot2_args()) {
+
|
|
| 738 | +166 | ! |
- supported_types <- c("NULL", "numeric", "integer", "factor", "character", "logical", "ordered")
+ plot_choices <- c("Bivariate1", "Bivariate2")
|
| 739 | +167 | ! |
- validate(need(x_class %in% supported_types, paste0("Data type '", x_class, "' is not supported.")))
+ checkmate::assert_list(ggplot2_args, types = "ggplot2_args") |
| 740 | +168 | ! |
- validate(need(y_class %in% supported_types, paste0("Data type '", y_class, "' is not supported.")))
+ checkmate::assert_subset(names(ggplot2_args), c("default", plot_choices))
|
| 741 | +169 |
-
+ # End of assertions |
|
| 742 | +170 | ||
| 743 | -! | -
- if (identical(x, character(0))) {
- |
- |
| 744 | -! | -
- x <- x_label <- "-"- |
- |
| 745 | +171 |
- } else {
+ # Make UI args |
|
| 746 | +172 | ! |
- x <- if (is.call(x)) x else as.name(x)+ args <- as.list(environment()) |
| 747 | +173 |
- }+ |
|
| 748 | +174 | ! |
- if (identical(y, character(0))) {
+ data_extract_list <- list( |
| 749 | +175 | ! |
- y <- y_label <- "-"- |
-
| 750 | -- |
- } else {
+ ref = ref, |
|
| 751 | +176 | ! |
- y <- if (is.call(y)) y else as.name(y)+ vars = vars |
| 752 | +177 |
- }+ ) |
|
| 753 | +178 | ||
| 754 | +179 | ! |
- cl <- bivariate_ggplot_call(+ ans <- module( |
| 755 | +180 | ! |
- x_class = x_class,+ label = label, |
| 756 | -! | -
- y_class = y_class,- |
- |
| 757 | -! | -
- freq = freq,- |
- |
| 758 | +181 | ! |
- theme = theme,+ server = srv_tm_g_association, |
| 759 | +182 | ! |
- rotate_xaxis_labels = rotate_xaxis_labels,+ ui = ui_tm_g_association, |
| 760 | +183 | ! |
- swap_axes = swap_axes,+ ui_args = args, |
| 761 | +184 | ! |
- alpha = alpha,+ server_args = c( |
| 762 | +185 | ! |
- size = size,+ data_extract_list, |
| 763 | +186 | ! |
- ggplot2_args = ggplot2_args,+ list(plot_height = plot_height, plot_width = plot_width, ggplot2_args = ggplot2_args) |
| 764 | -! | +||
| 187 | +
- x = x,+ ), |
||
| 765 | +188 | ! |
- y = y,+ datanames = teal.transform::get_extract_datanames(data_extract_list) |
| 766 | -! | +||
| 189 | +
- xlab = x_label,+ ) |
||
| 767 | +190 | ! |
- ylab = y_label,+ attr(ans, "teal_bookmarkable") <- TRUE |
| 768 | +191 | ! |
- data_name = data_name- |
-
| 769 | -- |
- )+ ans |
|
| 770 | +192 |
} |
|
| 771 | +193 | ||
| 772 | +194 |
- # Create ggplot part of plot call+ # UI function for the association module |
|
| 773 | +195 |
- # Due to the type of the x and y variable the plot type is chosen+ ui_tm_g_association <- function(id, ...) {
|
|
| 774 | -+ | ||
| 196 | +! |
- bivariate_ggplot_call <- function(x_class,+ ns <- NS(id) |
|
| 775 | -+ | ||
| 197 | +! |
- y_class,+ args <- list(...) |
|
| 776 | -+ | ||
| 198 | +! |
- freq = TRUE,+ is_single_dataset_value <- teal.transform::is_single_dataset(args$ref, args$vars) |
|
| 777 | +199 |
- theme = "gray",+ |
|
| 778 | -+ | ||
| 200 | +! |
- rotate_xaxis_labels = FALSE,+ teal.widgets::standard_layout( |
|
| 779 | -+ | ||
| 201 | +! |
- swap_axes = FALSE,+ output = teal.widgets::white_small_well( |
|
| 780 | -+ | ||
| 202 | +! |
- size = double(0),+ textOutput(ns("title")),
|
|
| 781 | -+ | ||
| 203 | +! |
- alpha = double(0),+ tags$br(), |
|
| 782 | -+ | ||
| 204 | +! |
- x = NULL,+ teal.widgets::plot_with_settings_ui(id = ns("myplot"))
|
|
| 783 | +205 |
- y = NULL,+ ), |
|
| 784 | -+ | ||
| 206 | +! |
- xlab = "-",+ encoding = tags$div( |
|
| 785 | +207 |
- ylab = "-",+ ### Reporter |
|
| 786 | -+ | ||
| 208 | +! |
- data_name = "ANL",+ teal.reporter::simple_reporter_ui(ns("simple_reporter")),
|
|
| 787 | +209 |
- ggplot2_args = teal.widgets::ggplot2_args()) {
+ ### |
|
| 788 | -42x | +||
| 210 | +! |
- x_class <- switch(x_class,+ tags$label("Encodings", class = "text-primary"),
|
|
| 789 | -42x | +||
| 211 | +! |
- "character" = ,+ teal.transform::datanames_input(args[c("ref", "vars")]),
|
|
| 790 | -42x | +||
| 212 | +! |
- "ordered" = ,+ teal.transform::data_extract_ui( |
|
| 791 | -42x | +||
| 213 | +! |
- "logical" = ,+ id = ns("ref"),
|
|
| 792 | -42x | +||
| 214 | +! |
- "factor" = "factor",+ label = "Reference variable", |
|
| 793 | -42x | +||
| 215 | +! |
- "integer" = ,+ data_extract_spec = args$ref, |
|
| 794 | -42x | +||
| 216 | +! |
- "numeric" = "numeric",+ is_single_dataset = is_single_dataset_value |
|
| 795 | -42x | +||
| 217 | +
- "NULL" = "NULL",+ ), |
||
| 796 | -42x | +||
| 218 | +! |
- stop("unsupported x_class: ", x_class)
+ teal.transform::data_extract_ui( |
|
| 797 | -+ | ||
| 219 | +! |
- )+ id = ns("vars"),
|
|
| 798 | -42x | +||
| 220 | +! |
- y_class <- switch(y_class,+ label = "Associated variables", |
|
| 799 | -42x | +||
| 221 | +! |
- "character" = ,+ data_extract_spec = args$vars, |
|
| 800 | -42x | +||
| 222 | +! |
- "ordered" = ,+ is_single_dataset = is_single_dataset_value |
|
| 801 | -42x | +||
| 223 | +
- "logical" = ,+ ), |
||
| 802 | -42x | +||
| 224 | +! |
- "factor" = "factor",+ checkboxInput( |
|
| 803 | -42x | +||
| 225 | +! |
- "integer" = ,+ ns("association"),
|
|
| 804 | -42x | +||
| 226 | +! |
- "numeric" = "numeric",+ "Association with reference variable", |
|
| 805 | -42x | +||
| 227 | +! |
- "NULL" = "NULL",+ value = args$show_association |
|
| 806 | -42x | +||
| 228 | +
- stop("unsupported y_class: ", y_class)
+ ), |
||
| 807 | -+ | ||
| 229 | +! |
- )+ checkboxInput( |
|
| 808 | -+ | ||
| 230 | +! |
-
+ ns("show_dist"),
|
|
| 809 | -42x | +||
| 231 | +! |
- if (all(c(x_class, y_class) == "NULL")) {
+ "Scaled frequencies", |
|
| 810 | +232 | ! |
- stop("either x or y is required")
+ value = FALSE |
| 811 | +233 |
- }+ ), |
|
| 812 | -+ | ||
| 234 | +! |
-
+ checkboxInput( |
|
| 813 | -42x | +||
| 235 | +! |
- reduce_plot_call <- function(...) {
+ ns("log_transformation"),
|
|
| 814 | -104x | +||
| 236 | +! |
- args <- Filter(Negate(is.null), list(...))+ "Log transformed", |
|
| 815 | -104x | +||
| 237 | +! |
- Reduce(function(x, y) call("+", x, y), args)
+ value = FALSE |
|
| 816 | +238 |
- }+ ), |
|
| 817 | -+ | ||
| 239 | +! |
-
+ teal.widgets::panel_group( |
|
| 818 | -42x | +||
| 240 | +! |
- plot_call <- substitute(ggplot(data_name), env = list(data_name = as.name(data_name)))+ teal.widgets::panel_item( |
|
| 819 | -+ | ||
| 241 | +! |
-
+ title = "Plot settings", |
|
| 820 | -+ | ||
| 242 | +! |
- # Single data plots+ teal.widgets::optionalSliderInputValMinMax(ns("alpha"), "Scatterplot opacity:", c(0.5, 0, 1), ticks = FALSE),
|
|
| 821 | -42x | +||
| 243 | +! |
- if (x_class == "numeric" && y_class == "NULL") {
+ teal.widgets::optionalSliderInputValMinMax(ns("size"), "Scatterplot points size:", c(2, 1, 8), ticks = FALSE),
|
|
| 822 | -6x | +||
| 244 | +! |
- plot_call <- reduce_plot_call(plot_call, substitute(aes(x = xval), env = list(xval = x)))+ checkboxInput(ns("swap_axes"), "Swap axes", value = FALSE),
|
|
| 823 | -+ | ||
| 245 | +! |
-
+ checkboxInput(ns("rotate_xaxis_labels"), "Rotate X axis labels", value = FALSE),
|
|
| 824 | -6x | +||
| 246 | +! |
- if (freq) {
+ selectInput( |
|
| 825 | -4x | +||
| 247 | +! |
- plot_call <- reduce_plot_call(+ inputId = ns("distribution_theme"),
|
|
| 826 | -4x | +||
| 248 | +! |
- plot_call,+ label = "Distribution theme (by ggplot):", |
|
| 827 | -4x | +||
| 249 | +! |
- quote(geom_histogram(bins = 30)),+ choices = ggplot_themes, |
|
| 828 | -4x | +||
| 250 | +! |
- quote(ylab("Frequency"))
+ selected = args$distribution_theme, |
|
| 829 | -+ | ||
| 251 | +! |
- )+ multiple = FALSE |
|
| 830 | +252 |
- } else {
+ ), |
|
| 831 | -2x | -
- plot_call <- reduce_plot_call(+ | |
| 253 | +! | +
+ selectInput( |
|
| 832 | -2x | +||
| 254 | +! |
- plot_call,+ inputId = ns("association_theme"),
|
|
| 833 | -2x | +||
| 255 | +! |
- quote(geom_histogram(bins = 30, aes(y = after_stat(density)))),+ label = "Association theme (by ggplot):", |
|
| 834 | -2x | +||
| 256 | +! |
- quote(geom_density(aes(y = after_stat(density)))),+ choices = ggplot_themes, |
|
| 835 | -2x | +||
| 257 | +! |
- quote(ylab("Density"))
+ selected = args$association_theme,+ |
+ |
| 258 | +! | +
+ multiple = FALSE |
|
| 836 | +259 | ++ |
+ )+ |
+
| 260 | ++ |
+ )+ |
+ |
| 261 |
) |
||
| 837 | +262 |
- }+ ), |
|
| 838 | -36x | +||
| 263 | +! |
- } else if (x_class == "NULL" && y_class == "numeric") {
+ forms = tagList( |
|
| 839 | -6x | +||
| 264 | +! |
- plot_call <- reduce_plot_call(plot_call, substitute(aes(x = yval), env = list(yval = y)))+ teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code")
|
|
| 840 | +265 |
-
+ ), |
|
| 841 | -6x | +||
| 266 | +! |
- if (freq) {
+ pre_output = args$pre_output, |
|
| 842 | -4x | +||
| 267 | +! |
- plot_call <- reduce_plot_call(+ post_output = args$post_output |
|
| 843 | -4x | +||
| 268 | +
- plot_call,+ ) |
||
| 844 | -4x | +||
| 269 | +
- quote(geom_histogram(bins = 30)),+ } |
||
| 845 | -4x | +||
| 270 | +
- quote(ylab("Frequency"))
+
|
||
| 846 | +271 |
- )+ # Server function for the association module |
|
| 847 | +272 |
- } else {
+ srv_tm_g_association <- function(id, |
|
| 848 | -2x | +||
| 273 | +
- plot_call <- reduce_plot_call(+ data, |
||
| 849 | -2x | +||
| 274 | +
- plot_call,+ reporter, |
||
| 850 | -2x | +||
| 275 | +
- quote(geom_histogram(bins = 30, aes(y = after_stat(density)))),+ filter_panel_api, |
||
| 851 | -2x | +||
| 276 | +
- quote(geom_density(aes(y = after_stat(density)))),+ ref, |
||
| 852 | -2x | +||
| 277 | +
- quote(ylab("Density"))
+ vars, |
||
| 853 | +278 |
- )+ plot_height, |
|
| 854 | +279 |
- }+ plot_width, |
|
| 855 | -30x | +||
| 280 | +
- } else if (x_class == "factor" && y_class == "NULL") {
+ ggplot2_args) {
|
||
| 856 | -4x | +||
| 281 | +! |
- plot_call <- reduce_plot_call(plot_call, substitute(aes(x = xval), env = list(xval = x)))+ with_reporter <- !missing(reporter) && inherits(reporter, "Reporter")+ |
+ |
| 282 | +! | +
+ with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI")+ |
+ |
| 283 | +! | +
+ checkmate::assert_class(data, "reactive")+ |
+ |
| 284 | +! | +
+ checkmate::assert_class(isolate(data()), "teal_data") |
|
| 857 | +285 | ||
| 858 | -4x | +||
| 286 | +! |
- if (freq) {
+ moduleServer(id, function(input, output, session) {
|
|
| 859 | -2x | +||
| 287 | +! |
- plot_call <- reduce_plot_call(+ teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.general") |
|
| 860 | -2x | +||
| 288 | +
- plot_call,+ |
||
| 861 | -2x | +||
| 289 | +! |
- quote(geom_bar()),+ selector_list <- teal.transform::data_extract_multiple_srv( |
|
| 862 | -2x | +||
| 290 | +! |
- quote(ylab("Frequency"))
+ data_extract = list(ref = ref, vars = vars),+ |
+ |
| 291 | +! | +
+ datasets = data,+ |
+ |
| 292 | +! | +
+ select_validation_rule = list(+ |
+ |
| 293 | +! | +
+ ref = shinyvalidate::compose_rules(+ |
+ |
| 294 | +! | +
+ shinyvalidate::sv_required("A reference variable needs to be selected."),
+ |
+ |
| 295 | +! | +
+ ~ if ((.) %in% selector_list()$vars()$select) {
+ |
+ |
| 296 | +! | +
+ "Associated variables and reference variable cannot overlap" |
|
| 863 | +297 |
- )+ } |
|
| 864 | +298 |
- } else {
+ ), |
|
| 865 | -2x | +||
| 299 | +! |
- plot_call <- reduce_plot_call(+ vars = shinyvalidate::compose_rules( |
|
| 866 | -2x | +||
| 300 | +! |
- plot_call,+ shinyvalidate::sv_required("An associated variable needs to be selected."),
|
|
| 867 | -2x | +||
| 301 | +! |
- quote(geom_bar(aes(y = after_stat(prop), group = 1))),+ ~ if (length(selector_list()$ref()$select) != 0 && selector_list()$ref()$select %in% (.)) {
|
|
| 868 | -2x | +||
| 302 | +! |
- quote(ylab("Fraction"))
+ "Associated variables and reference variable cannot overlap" |
|
| 869 | +303 | ++ |
+ }+ |
+
| 304 | ++ |
+ )+ |
+ |
| 305 |
) |
||
| 870 | +306 |
- }+ ) |
|
| 871 | -26x | +||
| 307 | +
- } else if (x_class == "NULL" && y_class == "factor") {
+
|
||
| 872 | -4x | +||
| 308 | +! |
- plot_call <- reduce_plot_call(plot_call, substitute(aes(x = yval), env = list(yval = y)))+ iv_r <- reactive({
+ |
+ |
| 309 | +! | +
+ iv <- shinyvalidate::InputValidator$new()+ |
+ |
| 310 | +! | +
+ teal.transform::compose_and_enable_validators(iv, selector_list) |
|
| 873 | +311 | ++ |
+ })+ |
+
| 312 | |||
| 874 | -4x | +||
| 313 | +! |
- if (freq) {
+ anl_merged_input <- teal.transform::merge_expression_srv( |
|
| 875 | -2x | +||
| 314 | +! | +
+ datasets = data,+ |
+ |
| 315 | +! | +
+ selector_list = selector_list+ |
+ |
| 316 | ++ |
+ )+ |
+ |
| 317 | ++ | + + | +|
| 318 | +! | +
+ anl_merged_q <- reactive({
+ |
+ |
| 319 | +! | +
+ req(anl_merged_input())+ |
+ |
| 320 | +! | +
+ data() %>% teal.code::eval_code(as.expression(anl_merged_input()$expr))+ |
+ |
| 321 | ++ |
+ })+ |
+ |
| 322 | ++ | + + | +|
| 323 | +! | +
+ merged <- list(+ |
+ |
| 324 | +! | +
+ anl_input_r = anl_merged_input,+ |
+ |
| 325 | +! | +
+ anl_q_r = anl_merged_q+ |
+ |
| 326 | ++ |
+ )+ |
+ |
| 327 | ++ | + + | +|
| 328 | +! | +
+ output_q <- reactive({
+ |
+ |
| 329 | +! | +
+ teal::validate_inputs(iv_r())+ |
+ |
| 330 | ++ | + + | +|
| 331 | +! | +
+ ANL <- merged$anl_q_r()[["ANL"]]+ |
+ |
| 332 | +! | +
+ teal::validate_has_data(ANL, 3)+ |
+ |
| 333 | ++ | + + | +|
| 334 | +! | +
+ vars_names <- merged$anl_input_r()$columns_source$vars+ |
+ |
| 335 | ++ | + + | +|
| 336 | +! | +
+ ref_name <- as.vector(merged$anl_input_r()$columns_source$ref)+ |
+ |
| 337 | +! | +
+ association <- input$association+ |
+ |
| 338 | +! | +
+ show_dist <- input$show_dist+ |
+ |
| 339 | +! | +
+ log_transformation <- input$log_transformation+ |
+ |
| 340 | +! | +
+ rotate_xaxis_labels <- input$rotate_xaxis_labels+ |
+ |
| 341 | +! | +
+ swap_axes <- input$swap_axes+ |
+ |
| 342 | +! | +
+ distribution_theme <- input$distribution_theme+ |
+ |
| 343 | +! | +
+ association_theme <- input$association_theme+ |
+ |
| 344 | ++ | + + | +|
| 345 | +! | +
+ is_scatterplot <- is.numeric(ANL[[ref_name]]) && any(vapply(ANL[vars_names], is.numeric, logical(1)))+ |
+ |
| 346 | +! | +
+ if (is_scatterplot) {
+ |
+ |
| 347 | +! | +
+ shinyjs::show("alpha")
+ |
+ |
| 348 | +! | +
+ shinyjs::show("size")
+ |
+ |
| 349 | +! | +
+ alpha <- input$alpha+ |
+ |
| 350 | +! | +
+ size <- input$size+ |
+ |
| 351 | ++ |
+ } else {
+ |
+ |
| 352 | +! | +
+ shinyjs::hide("alpha")
+ |
+ |
| 353 | +! | +
+ shinyjs::hide("size")
+ |
+ |
| 354 | +! | +
+ alpha <- 0.5+ |
+ |
| 355 | +! | +
+ size <- 2+ |
+ |
| 356 | ++ |
+ }+ |
+ |
| 357 | ++ | + + | +|
| 358 | +! | +
+ teal::validate_has_data(ANL[, c(ref_name, vars_names)], 3, complete = TRUE, allow_inf = FALSE)+ |
+ |
| 359 | ++ | + + | +|
| 360 | ++ |
+ # reference+ |
+ |
| 361 | +! | +
+ ref_class <- class(ANL[[ref_name]])[1]+ |
+ |
| 362 | +! | +
+ if (is.numeric(ANL[[ref_name]]) && log_transformation) {
+ |
+ |
| 363 | ++ |
+ # works for both integers and doubles+ |
+ |
| 364 | +! | +
+ ref_cl_name <- call("log", as.name(ref_name))
+ |
+ |
| 365 | +! | +
+ ref_cl_lbl <- varname_w_label(ref_name, ANL, prefix = "Log of ")+ |
+ |
| 366 | ++ |
+ } else {
+ |
+ |
| 367 | ++ |
+ # silently ignore when non-numeric even if `log` is selected because some+ |
+ |
| 368 | ++ |
+ # variables may be numeric and others not+ |
+ |
| 369 | +! | +
+ ref_cl_name <- as.name(ref_name)+ |
+ |
| 370 | +! | +
+ ref_cl_lbl <- varname_w_label(ref_name, ANL)+ |
+ |
| 371 | ++ |
+ }+ |
+ |
| 372 | ++ | + + | +|
| 373 | +! | +
+ user_ggplot2_args <- teal.widgets::resolve_ggplot2_args(+ |
+ |
| 374 | +! | +
+ user_plot = ggplot2_args[["Bivariate1"]],+ |
+ |
| 375 | +! | +
+ user_default = ggplot2_args$default+ |
+ |
| 376 | ++ |
+ )+ |
+ |
| 377 | ++ | + + | +|
| 378 | +! | +
+ ref_call <- bivariate_plot_call(+ |
+ |
| 379 | +! | +
+ data_name = "ANL",+ |
+ |
| 380 | +! | +
+ x = ref_cl_name,+ |
+ |
| 381 | +! | +
+ x_class = ref_class,+ |
+ |
| 382 | +! | +
+ x_label = ref_cl_lbl,+ |
+ |
| 383 | +! | +
+ freq = !show_dist,+ |
+ |
| 384 | +! | +
+ theme = distribution_theme,+ |
+ |
| 385 | +! | +
+ rotate_xaxis_labels = rotate_xaxis_labels,+ |
+ |
| 386 | +! | +
+ swap_axes = FALSE,+ |
+ |
| 387 | +! | +
+ size = size,+ |
+ |
| 388 | +! | +
+ alpha = alpha,+ |
+ |
| 389 | +! | +
+ ggplot2_args = user_ggplot2_args+ |
+ |
| 390 | ++ |
+ )+ |
+ |
| 391 | ++ | + + | +|
| 392 | ++ |
+ # association+ |
+ |
| 393 | +! | +
+ ref_class_cov <- ifelse(association, ref_class, "NULL")+ |
+ |
| 394 | ++ | + + | +|
| 395 | +! | +
+ print_call <- quote(print(p))+ |
+ |
| 396 | ++ | + + | +|
| 397 | +! | +
+ var_calls <- lapply(vars_names, function(var_i) {
+ |
+ |
| 398 | +! | +
+ var_class <- class(ANL[[var_i]])[1]+ |
+ |
| 399 | +! | +
+ if (is.numeric(ANL[[var_i]]) && log_transformation) {
+ |
+ |
| 400 | ++ |
+ # works for both integers and doubles+ |
+ |
| 401 | +! | +
+ var_cl_name <- call("log", as.name(var_i))
+ |
+ |
| 402 | +! | +
+ var_cl_lbl <- varname_w_label(var_i, ANL, prefix = "Log of ")+ |
+ |
| 403 | ++ |
+ } else {
+ |
+ |
| 404 | +
- plot_call <- reduce_plot_call(+ # silently ignore when non-numeric even if `log` is selected because some |
||
| 876 | -2x | +||
| 405 | +
- plot_call,+ # variables may be numeric and others not |
||
| 877 | -2x | +||
| 406 | +! |
- quote(geom_bar()),+ var_cl_name <- as.name(var_i) |
|
| 878 | -2x | +||
| 407 | +! |
- quote(ylab("Frequency"))
+ var_cl_lbl <- varname_w_label(var_i, ANL) |
|
| 879 | +408 |
- )+ } |
|
| 880 | +409 |
- } else {
- |
- |
| 881 | -2x | -
- plot_call <- reduce_plot_call(+ |
|
| 882 | -2x | +||
| 410 | +! |
- plot_call,+ user_ggplot2_args <- teal.widgets::resolve_ggplot2_args( |
|
| 883 | -2x | +||
| 411 | +! |
- quote(geom_bar(aes(y = after_stat(prop), group = 1))),+ user_plot = ggplot2_args[["Bivariate2"]], |
|
| 884 | -2x | +||
| 412 | +! |
- quote(ylab("Fraction"))
+ user_default = ggplot2_args$default |
|
| 885 | +413 |
- )+ ) |
|
| 886 | +414 |
- }+ |
|
| 887 | -+ | ||
| 415 | +! |
- # Numeric Plots+ bivariate_plot_call( |
|
| 888 | -22x | +||
| 416 | +! |
- } else if (x_class == "numeric" && y_class == "numeric") {
+ data_name = "ANL", |
|
| 889 | -2x | +||
| 417 | +! |
- plot_call <- reduce_plot_call(+ x = ref_cl_name, |
|
| 890 | -2x | +||
| 418 | +! |
- plot_call,+ y = var_cl_name, |
|
| 891 | -2x | +||
| 419 | +! |
- substitute(aes(x = xval, y = yval), env = list(xval = x, yval = y)),+ x_class = ref_class_cov, |
|
| 892 | -+ | ||
| 420 | +! |
- # pch = 21 for consistent coloring behaviour b/w all geoms (outline and fill properties)+ y_class = var_class, |
|
| 893 | -2x | +||
| 421 | +! |
- `if`(+ x_label = ref_cl_lbl, |
|
| 894 | -2x | +||
| 422 | +! |
- !is.null(size),+ y_label = var_cl_lbl, |
|
| 895 | -2x | +||
| 423 | +! |
- substitute(+ theme = association_theme, |
|
| 896 | -2x | +||
| 424 | +! |
- geom_point(alpha = alphaval, size = sizeval, pch = 21),+ freq = !show_dist, |
|
| 897 | -2x | +||
| 425 | +! |
- env = list(alphaval = alpha, sizeval = size)+ rotate_xaxis_labels = rotate_xaxis_labels, |
|
| 898 | -+ | ||
| 426 | +! |
- ),+ swap_axes = swap_axes, |
|
| 899 | -2x | +||
| 427 | +! |
- substitute(+ alpha = alpha, |
|
| 900 | -2x | +||
| 428 | +! |
- geom_point(alpha = alphaval, pch = 21),+ size = size, |
|
| 901 | -2x | +||
| 429 | +! |
- env = list(alphaval = alpha)+ ggplot2_args = user_ggplot2_args |
|
| 902 | +430 |
) |
|
| 903 | +431 |
- )+ }) |
|
| 904 | +432 |
- )+ |
|
| 905 | -20x | +||
| 433 | +
- } else if ((x_class == "numeric" && y_class == "factor") || (x_class == "factor" && y_class == "numeric")) {
+ # helper function to format variable name |
||
| 906 | -6x | +||
| 434 | +! |
- plot_call <- reduce_plot_call(+ format_varnames <- function(x) {
|
|
| 907 | -6x | +||
| 435 | +! |
- plot_call,+ if (is.numeric(ANL[[x]]) && log_transformation) {
|
|
| 908 | -6x | +||
| 436 | +! |
- substitute(aes(x = xval, y = yval), env = list(xval = x, yval = y)),+ varname_w_label(x, ANL, prefix = "Log of ") |
|
| 909 | -6x | +||
| 437 | +
- quote(geom_boxplot())+ } else {
+ |
+ ||
| 438 | +! | +
+ varname_w_label(x, ANL) |
|
| 910 | +439 |
- )+ } |
|
| 911 | +440 |
- # Factor and character plots+ } |
|
| 912 | -14x | +||
| 441 | +! |
- } else if (x_class == "factor" && y_class == "factor") {
+ new_title <- |
|
| 913 | -14x | +||
| 442 | +! |
- plot_call <- reduce_plot_call(+ if (association) {
|
|
| 914 | -14x | +||
| 443 | +! |
- plot_call,+ switch(as.character(length(vars_names)), |
|
| 915 | -14x | +||
| 444 | +! |
- substitute(+ "0" = sprintf("Value distribution for %s", ref_cl_lbl),
|
|
| 916 | -14x | +||
| 445 | +! |
- ggmosaic::geom_mosaic(aes(x = ggmosaic::product(xval), fill = yval), na.rm = TRUE),+ "1" = sprintf( |
|
| 917 | -14x | +||
| 446 | +! |
- env = list(xval = x, yval = y)+ "Association between %s and %s", |
|
| 918 | -+ | ||
| 447 | +! |
- )+ ref_cl_lbl, |
|
| 919 | -+ | ||
| 448 | +! |
- )+ format_varnames(vars_names) |
|
| 920 | +449 |
- } else {
+ ), |
|
| 921 | +450 | ! |
- stop("x y type combination not allowed")
+ sprintf( |
| 922 | -+ | ||
| 451 | +! |
- }+ "Associations between %s and: %s",+ |
+ |
| 452 | +! | +
+ ref_cl_lbl,+ |
+ |
| 453 | +! | +
+ paste(lapply(vars_names, format_varnames), collapse = ", ") |
|
| 923 | +454 |
-
+ ) |
|
| 924 | -42x | +||
| 455 | +
- labs_base <- if (x_class == "NULL") {
+ ) |
||
| 925 | -10x | +||
| 456 | +
- list(x = substitute(ylab, list(ylab = ylab)))+ } else {
|
||
| 926 | -42x | +||
| 457 | +! |
- } else if (y_class == "NULL") {
+ switch(as.character(length(vars_names)), |
|
| 927 | -10x | +||
| 458 | +! |
- list(x = substitute(xlab, list(xlab = xlab)))+ "0" = sprintf("Value distribution for %s", ref_cl_lbl),
|
|
| 928 | -+ | ||
| 459 | +! |
- } else {
+ sprintf( |
|
| 929 | -22x | +||
| 460 | +! |
- list(+ "Value distributions for %s and %s", |
|
| 930 | -22x | +||
| 461 | +! |
- x = substitute(xlab, list(xlab = xlab)),+ ref_cl_lbl, |
|
| 931 | -22x | +||
| 462 | +! |
- y = substitute(ylab, list(ylab = ylab))+ paste(lapply(vars_names, format_varnames), collapse = ", ") |
|
| 932 | +463 |
- )+ ) |
|
| 933 | +464 |
- }+ ) |
|
| 934 | +465 | - - | -|
| 935 | -42x | -
- dev_ggplot2_args <- teal.widgets::ggplot2_args(labs = labs_base)+ } |
|
| 936 | +466 | ||
| 937 | -42x | -
- if (rotate_xaxis_labels) {
- |
- |
| 938 | +467 | ! |
- dev_ggplot2_args$theme <- list(axis.text.x = quote(element_text(angle = 45, hjust = 1)))- |
-
| 939 | -- |
- }+ teal.code::eval_code( |
|
| 940 | -+ | ||
| 468 | +! |
-
+ merged$anl_q_r(), |
|
| 941 | -42x | +||
| 469 | +! |
- all_ggplot2_args <- teal.widgets::resolve_ggplot2_args(+ substitute( |
|
| 942 | -42x | +||
| 470 | +! |
- user_plot = ggplot2_args,+ expr = title <- new_title, |
|
| 943 | -42x | +||
| 471 | +! |
- module_plot = dev_ggplot2_args+ env = list(new_title = new_title) |
|
| 944 | +472 |
- )+ ) |
|
| 945 | +473 | - - | -|
| 946 | -42x | -
- parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(all_ggplot2_args, ggtheme = theme)+ ) %>% |
|
| 947 | -+ | ||
| 474 | +! |
-
+ teal.code::eval_code( |
|
| 948 | -42x | +||
| 475 | +! |
- plot_call <- reduce_plot_call(+ substitute( |
|
| 949 | -42x | +||
| 476 | +! |
- plot_call,+ expr = {
|
|
| 950 | -42x | +||
| 477 | +! |
- parsed_ggplot2_args$labs,+ plots <- plot_calls |
|
| 951 | -42x | +||
| 478 | +! |
- parsed_ggplot2_args$ggtheme,+ p <- tern::stack_grobs(grobs = lapply(plots, ggplotGrob)) |
|
| 952 | -42x | +||
| 479 | +! |
- parsed_ggplot2_args$theme+ grid::grid.newpage() |
|
| 953 | -+ | ||
| 480 | +! |
- )+ grid::grid.draw(p) |
|
| 954 | +481 |
-
+ }, |
|
| 955 | -42x | +||
| 482 | +! |
- if (swap_axes) {
+ env = list( |
|
| 956 | +483 | ! |
- plot_call <- reduce_plot_call(plot_call, quote(coord_flip()))+ plot_calls = do.call( |
| 957 | -+ | ||
| 484 | +! |
- }+ "call", |
|
| 958 | -+ | ||
| 485 | +! |
-
+ c(list("list", ref_call), var_calls),
|
|
| 959 | -42x | +||
| 486 | +! |
- plot_call+ quote = TRUE |
|
| 960 | +487 |
- }+ ) |
|
| 961 | +488 |
-
+ ) |
|
| 962 | +489 |
- # Create facet call+ ) |
|
| 963 | +490 |
- facet_ggplot_call <- function(row_facet = character(0),+ ) |
|
| 964 | +491 |
- col_facet = character(0),+ }) |
|
| 965 | +492 |
- free_x_scales = FALSE,+ |
|
| 966 | -+ | ||
| 493 | +! |
- free_y_scales = FALSE) {
+ plot_r <- reactive({
|
|
| 967 | +494 | ! |
- scales <- if (free_x_scales && free_y_scales) {
+ req(iv_r()$is_valid()) |
| 968 | +495 | ! |
- "free"+ output_q()[["p"]] |
| 969 | -! | +||
| 496 | +
- } else if (free_x_scales) {
+ })+ |
+ ||
| 497 | ++ | + | |
| 970 | +498 | ! |
- "free_x"+ pws <- teal.widgets::plot_with_settings_srv( |
| 971 | +499 | ! |
- } else if (free_y_scales) {
+ id = "myplot", |
| 972 | +500 | ! |
- "free_y"+ plot_r = plot_r, |
| 973 | -+ | ||
| 501 | +! |
- } else {
+ height = plot_height, |
|
| 974 | +502 | ! |
- "fixed"+ width = plot_width |
| 975 | +503 |
- }+ ) |
|
| 976 | +504 | ||
| 977 | +505 | ! |
- if (identical(row_facet, character(0)) && identical(col_facet, character(0))) {
+ output$title <- renderText({
|
| 978 | +506 | ! |
- NULL+ teal.code::dev_suppress(output_q()[["title"]]) |
| 979 | -! | +||
| 507 | +
- } else if (!identical(row_facet, character(0)) && !identical(col_facet, character(0))) {
+ }) |
||
| 980 | -! | +||
| 508 | +
- call(+ |
||
| 981 | +509 | ! |
- "facet_grid",+ teal.widgets::verbatim_popup_srv( |
| 982 | +510 | ! |
- rows = call_fun_dots("vars", row_facet),
+ id = "rcode", |
| 983 | +511 | ! |
- cols = call_fun_dots("vars", col_facet),
+ verbatim_content = reactive(teal.code::get_code(output_q())), |
| 984 | +512 | ! |
- scales = scales+ title = "Association Plot" |
| 985 | +513 |
) |
|
| 986 | -! | +||
| 514 | +
- } else if (identical(row_facet, character(0)) && !identical(col_facet, character(0))) {
+
|
||
| 987 | -! | +||
| 515 | +
- call("facet_grid", cols = call_fun_dots("vars", col_facet), scales = scales)
+ ### REPORTER |
||
| 988 | +516 | ! |
- } else if (!identical(row_facet, character(0)) && identical(col_facet, character(0))) {
+ if (with_reporter) {
|
| 989 | +517 | ! |
- call("facet_grid", rows = call_fun_dots("vars", row_facet), scales = scales)
- |
-
| 990 | -- |
- }+ card_fun <- function(comment, label) {
|
|
| 991 | -+ | ||
| 518 | +! |
- }+ card <- teal::report_card_template( |
|
| 992 | -+ | ||
| 519 | +! |
-
+ title = "Association Plot", |
|
| 993 | -+ | ||
| 520 | +! |
- coloring_ggplot_call <- function(colour,+ label = label, |
|
| 994 | -+ | ||
| 521 | +! |
- fill,+ with_filter = with_filter, |
|
| 995 | -+ | ||
| 522 | +! |
- size,+ filter_panel_api = filter_panel_api |
|
| 996 | +523 |
- is_point = FALSE) {
+ ) |
|
| 997 | -+ | ||
| 524 | +! |
- if (+ card$append_text("Plot", "header3")
|
|
| 998 | -15x | +||
| 525 | +! |
- !identical(colour, character(0)) &&+ card$append_plot(plot_r(), dim = pws$dim()) |
|
| 999 | -15x | +||
| 526 | +! |
- !identical(fill, character(0)) &&+ if (!comment == "") {
|
|
| 1000 | -15x | +||
| 527 | +! |
- is_point &&+ card$append_text("Comment", "header3")
|
|
| 1001 | -15x | +||
| 528 | +! |
- !identical(size, character(0))+ card$append_text(comment) |
|
| 1002 | +529 |
- ) {
- |
- |
| 1003 | -1x | -
- substitute(+ } |
|
| 1004 | -1x | +||
| 530 | +! |
- expr = aes(colour = colour_name, fill = fill_name, size = size_name),+ card$append_src(teal.code::get_code(output_q())) |
|
| 1005 | -1x | +||
| 531 | +! |
- env = list(colour_name = as.name(colour), fill_name = as.name(fill), size_name = as.name(size))+ card |
|
| 1006 | +532 |
- )+ } |
|
| 1007 | -+ | ||
| 533 | +! |
- } else if (+ teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
|
|
| 1008 | -14x | +||
| 534 | +
- identical(colour, character(0)) &&+ } |
||
| 1009 | -14x | +||
| 535 | +
- !identical(fill, character(0)) &&+ ### |
||
| 1010 | -14x | +||
| 536 | +
- is_point &&+ }) |
||
| 1011 | -14x | +||
| 537 | +
- identical(size, character(0))+ } |
| 1012 | +1 |
- ) {
+ #' `teal` module: Distribution analysis |
|
| 1013 | -1x | +||
| 2 | +
- substitute(expr = aes(fill = fill_name), env = list(fill_name = as.name(fill)))+ #' |
||
| 1014 | +3 |
- } else if (+ #' Module is designed to explore the distribution of a single variable within a given dataset. |
|
| 1015 | -13x | +||
| 4 | +
- !identical(colour, character(0)) &&+ #' It offers several tools, such as histograms, Q-Q plots, and various statistical tests to |
||
| 1016 | -13x | +||
| 5 | +
- !identical(fill, character(0)) &&+ #' visually and statistically analyze the variable's distribution. |
||
| 1017 | -13x | +||
| 6 | +
- (!is_point || identical(size, character(0)))+ #' |
||
| 1018 | +7 |
- ) {
+ #' @inheritParams teal::module |
|
| 1019 | -3x | +||
| 8 | +
- substitute(+ #' @inheritParams teal.widgets::standard_layout |
||
| 1020 | -3x | +||
| 9 | +
- expr = aes(colour = colour_name, fill = fill_name),+ #' @inheritParams shared_params |
||
| 1021 | -3x | +||
| 10 | +
- env = list(colour_name = as.name(colour), fill_name = as.name(fill))+ #' |
||
| 1022 | +11 |
- )+ #' @param dist_var (`data_extract_spec` or `list` of multiple `data_extract_spec`) |
|
| 1023 | +12 |
- } else if (+ #' Variable(s) for which the distribution will be analyzed. |
|
| 1024 | -10x | +||
| 13 | +
- !identical(colour, character(0)) &&+ #' @param strata_var (`data_extract_spec` or `list` of multiple `data_extract_spec`) |
||
| 1025 | -10x | +||
| 14 | +
- identical(fill, character(0)) &&+ #' Categorical variable used to split the distribution analysis. |
||
| 1026 | -10x | +||
| 15 | +
- (!is_point || identical(size, character(0)))+ #' @param group_var (`data_extract_spec` or `list` of multiple `data_extract_spec`) |
||
| 1027 | +16 |
- ) {
+ #' Variable used for faceting plot into multiple panels. |
|
| 1028 | -1x | +||
| 17 | +
- substitute(expr = aes(colour = colour_name), env = list(colour_name = as.name(colour)))+ #' @param freq (`logical`) optional, whether to display frequency (`TRUE`) or density (`FALSE`). |
||
| 1029 | +18 |
- } else if (+ #' Defaults to density (`FALSE`). |
|
| 1030 | -9x | +||
| 19 | +
- identical(colour, character(0)) &&+ #' @param bins (`integer(1)` or `integer(3)`) optional, specifies the number of bins for the histogram. |
||
| 1031 | -9x | +||
| 20 | +
- !identical(fill, character(0)) &&+ #' - When the length of `bins` is one: The histogram bins will have a fixed size based on the `bins` provided. |
||
| 1032 | -9x | +||
| 21 | +
- (!is_point || identical(size, character(0)))+ #' - When the length of `bins` is three: The histogram bins are dynamically adjusted based on vector of `value`, `min`, |
||
| 1033 | +22 |
- ) {
+ #' and `max`. |
|
| 1034 | -2x | +||
| 23 | +
- substitute(expr = aes(fill = fill_name), env = list(fill_name = as.name(fill)))+ #' Defaults to `c(30L, 1L, 100L)`. |
||
| 1035 | +24 |
- } else if (+ #' |
|
| 1036 | -7x | +||
| 25 | +
- identical(colour, character(0)) &&+ #' @templateVar ggnames "Histogram", "QQplot" |
||
| 1037 | -7x | +||
| 26 | +
- identical(fill, character(0)) &&+ #' @template ggplot2_args_multi |
||
| 1038 | -7x | +||
| 27 | +
- is_point &&+ #' |
||
| 1039 | -7x | +||
| 28 | +
- !identical(size, character(0))+ #' @inherit shared_params return |
||
| 1040 | +29 |
- ) {
+ #' |
|
| 1041 | -1x | +||
| 30 | +
- substitute(expr = aes(size = size_name), env = list(size_name = as.name(size)))+ #' @examplesShinylive |
||
| 1042 | +31 |
- } else if (+ #' library(teal.modules.general) |
|
| 1043 | -6x | +||
| 32 | +
- !identical(colour, character(0)) &&+ #' interactive <- function() TRUE |
||
| 1044 | -6x | +||
| 33 | +
- identical(fill, character(0)) &&+ #' {{ next_example }}
|
||
| 1045 | -6x | +||
| 34 | +
- is_point &&+ # nolint start: line_length_linter. |
||
| 1046 | -6x | +||
| 35 | +
- !identical(size, character(0))+ #' @examplesIf require("ggpmisc", quietly = TRUE) && require("ggpp", quietly = TRUE) && require("goftest", quietly = TRUE) && require("MASS", quietly = TRUE) && require("broom", quietly = TRUE)
|
||
| 1047 | +36 |
- ) {
+ # nolint end: line_length_linter. |
|
| 1048 | -1x | +||
| 37 | +
- substitute(+ #' # general data example |
||
| 1049 | -1x | +||
| 38 | +
- expr = aes(colour = colour_name, size = size_name),+ #' data <- teal_data() |
||
| 1050 | -1x | +||
| 39 | +
- env = list(colour_name = as.name(colour), size_name = as.name(size))+ #' data <- within(data, {
|
||
| 1051 | +40 |
- )+ #' iris <- iris |
|
| 1052 | +41 |
- } else if (+ #' }) |
|
| 1053 | -5x | +||
| 42 | +
- identical(colour, character(0)) &&+ #' |
||
| 1054 | -5x | +||
| 43 | +
- !identical(fill, character(0)) &&+ #' app <- init( |
||
| 1055 | -5x | +||
| 44 | +
- is_point &&+ #' data = data, |
||
| 1056 | -5x | +||
| 45 | +
- !identical(size, character(0))+ #' modules = list( |
||
| 1057 | +46 |
- ) {
+ #' tm_g_distribution( |
|
| 1058 | -1x | +||
| 47 | +
- substitute(+ #' dist_var = data_extract_spec( |
||
| 1059 | -1x | +||
| 48 | +
- expr = aes(colour = colour_name, fill = fill_name, size = size_name),+ #' dataname = "iris", |
||
| 1060 | -1x | +||
| 49 | +
- env = list(colour_name = as.name(fill), fill_name = as.name(fill), size_name = as.name(size))+ #' select = select_spec(variable_choices("iris"), "Petal.Length")
|
||
| 1061 | +50 |
- )+ #' ) |
|
| 1062 | +51 |
- } else {
+ #' ) |
|
| 1063 | -4x | +||
| 52 | +
- NULL+ #' ) |
||
| 1064 | +53 |
- }+ #' ) |
|
| 1065 | +54 |
- }+ #' if (interactive()) {
|
| 1 | +55 |
- #' `teal` module: Missing data analysis+ #' shinyApp(app$ui, app$server) |
||
| 2 | +56 |
- #'+ #' } |
||
| 3 | +57 |
- #' This module analyzes missing data in `data.frame`s to help users explore missing observations and+ #' |
||
| 4 | +58 |
- #' gain insights into the completeness of their data.+ #' @examplesShinylive |
||
| 5 | +59 |
- #' It is useful for clinical data analysis within the context of `CDISC` standards and+ #' library(teal.modules.general) |
||
| 6 | +60 |
- #' adaptable for general data analysis purposes.+ #' interactive <- function() TRUE |
||
| 7 | +61 |
- #'+ #' {{ next_example }}
|
||
| 8 | +62 |
- #' @inheritParams teal::module+ # nolint start: line_length_linter. |
||
| 9 | +63 |
- #' @inheritParams shared_params+ #' @examplesIf require("ggpmisc", quietly = TRUE) && require("ggpp", quietly = TRUE) && require("goftest", quietly = TRUE) && require("MASS", quietly = TRUE) && require("broom", quietly = TRUE)
|
||
| 10 | +64 |
- #' @param parent_dataname (`character(1)`) Specifies the parent dataset name. Default is `ADSL` for `CDISC` data.+ # nolint end: line_length_linter. |
||
| 11 | +65 |
- #' If provided and exists, enables additional analysis "by subject". For non-`CDISC` data, this parameter can be+ #' # CDISC data example |
||
| 12 | +66 |
- #' ignored.+ #' data <- teal_data() |
||
| 13 | +67 |
- #' @param ggtheme (`character`) optional, specifies the default `ggplot2` theme for plots. Defaults to `classic`.+ #' data <- within(data, {
|
||
| 14 | +68 |
- #'+ #' ADSL <- rADSL |
||
| 15 | +69 |
- #' @templateVar ggnames "Summary Obs", "Summary Patients", "Combinations Main", "Combinations Hist", "By Subject"+ #' }) |
||
| 16 | +70 |
- #' @template ggplot2_args_multi+ #' join_keys(data) <- default_cdisc_join_keys[names(data)] |
||
| 17 | +71 |
#' |
||
| 18 | +72 |
- #' @inherit shared_params return+ #' vars1 <- choices_selected( |
||
| 19 | +73 |
- #'+ #' variable_choices(data[["ADSL"]], c("ARM", "COUNTRY", "SEX")),
|
||
| 20 | +74 |
- #' @examplesShinylive+ #' selected = NULL |
||
| 21 | +75 |
- #' library(teal.modules.general)+ #' ) |
||
| 22 | +76 |
- #' interactive <- function() TRUE+ #' |
||
| 23 | +77 |
- #' {{ next_example }}
+ #' app <- init( |
||
| 24 | +78 |
- #' @examplesIf require("gridExtra", quietly = TRUE) && require("rlang", quietly = TRUE)
+ #' data = data, |
||
| 25 | +79 |
- #' # general example data+ #' modules = modules( |
||
| 26 | +80 |
- #' data <- teal_data()+ #' tm_g_distribution( |
||
| 27 | +81 |
- #' data <- within(data, {
+ #' dist_var = data_extract_spec( |
||
| 28 | +82 |
- #' require(nestcolor)+ #' dataname = "ADSL", |
||
| 29 | +83 |
- #'+ #' select = select_spec( |
||
| 30 | +84 |
- #' add_nas <- function(x) {
+ #' choices = variable_choices(data[["ADSL"]], c("AGE", "BMRKR1")),
|
||
| 31 | +85 |
- #' x[sample(seq_along(x), floor(length(x) * runif(1, .05, .17)))] <- NA+ #' selected = "BMRKR1", |
||
| 32 | +86 |
- #' x+ #' multiple = FALSE, |
||
| 33 | +87 |
- #' }+ #' fixed = FALSE |
||
| 34 | +88 |
- #'+ #' ) |
||
| 35 | +89 |
- #' iris <- iris+ #' ), |
||
| 36 | +90 |
- #' mtcars <- mtcars+ #' strata_var = data_extract_spec( |
||
| 37 | +91 |
- #'+ #' dataname = "ADSL", |
||
| 38 | +92 |
- #' iris[] <- lapply(iris, add_nas)+ #' filter = filter_spec( |
||
| 39 | +93 |
- #' mtcars[] <- lapply(mtcars, add_nas)+ #' vars = vars1, |
||
| 40 | +94 |
- #' mtcars[["cyl"]] <- as.factor(mtcars[["cyl"]])+ #' multiple = TRUE |
||
| 41 | +95 |
- #' mtcars[["gear"]] <- as.factor(mtcars[["gear"]])+ #' ) |
||
| 42 | +96 |
- #' })+ #' ), |
||
| 43 | +97 |
- #' datanames(data) <- c("iris", "mtcars")
+ #' group_var = data_extract_spec( |
||
| 44 | +98 |
- #'+ #' dataname = "ADSL", |
||
| 45 | +99 |
- #' app <- init(+ #' filter = filter_spec( |
||
| 46 | +100 |
- #' data = data,+ #' vars = vars1, |
||
| 47 | +101 |
- #' modules = modules(+ #' multiple = TRUE |
||
| 48 | +102 |
- #' tm_missing_data()+ #' ) |
||
| 49 | +103 |
- #' )+ #' ) |
||
| 50 | +104 |
- #' )+ #' ) |
||
| 51 | +105 |
- #' if (interactive()) {
+ #' ) |
||
| 52 | +106 |
- #' shinyApp(app$ui, app$server)+ #' ) |
||
| 53 | +107 |
- #' }+ #' if (interactive()) {
|
||
| 54 | +108 |
- #'+ #' shinyApp(app$ui, app$server) |
||
| 55 | +109 |
- #' @examplesShinylive+ #' } |
||
| 56 | +110 |
- #' library(teal.modules.general)+ #' |
||
| 57 | +111 |
- #' interactive <- function() TRUE+ #' @export |
||
| 58 | +112 |
- #' {{ next_example }}
+ #' |
||
| 59 | +113 |
- #' @examplesIf require("gridExtra", quietly = TRUE) && require("rlang", quietly = TRUE)
+ tm_g_distribution <- function(label = "Distribution Module", |
||
| 60 | +114 |
- #' # CDISC example data+ dist_var, |
||
| 61 | +115 |
- #' data <- teal_data()+ strata_var = NULL, |
||
| 62 | +116 |
- #' data <- within(data, {
+ group_var = NULL, |
||
| 63 | +117 |
- #' require(nestcolor)+ freq = FALSE, |
||
| 64 | +118 |
- #' ADSL <- rADSL+ ggtheme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void"),
|
||
| 65 | +119 |
- #' ADRS <- rADRS+ ggplot2_args = teal.widgets::ggplot2_args(), |
||
| 66 | +120 |
- #' })+ bins = c(30L, 1L, 100L), |
||
| 67 | +121 |
- #' datanames(data) <- c("ADSL", "ADRS")
+ plot_height = c(600, 200, 2000), |
||
| 68 | +122 |
- #' join_keys(data) <- default_cdisc_join_keys[datanames(data)]+ plot_width = NULL, |
||
| 69 | +123 |
- #'+ pre_output = NULL, |
||
| 70 | +124 |
- #' app <- init(+ post_output = NULL) {
|
||
| 71 | -+ | |||
| 125 | +! |
- #' data = data,+ message("Initializing tm_g_distribution")
|
||
| 72 | +126 |
- #' modules = modules(+ |
||
| 73 | +127 |
- #' tm_missing_data()+ # Requires Suggested packages |
||
| 74 | -+ | |||
| 128 | +! |
- #' )+ extra_packages <- c("ggpmisc", "ggpp", "goftest", "MASS", "broom")
|
||
| 75 | -+ | |||
| 129 | +! |
- #' )+ missing_packages <- Filter(function(x) !requireNamespace(x, quietly = TRUE), extra_packages) |
||
| 76 | -+ | |||
| 130 | +! |
- #' if (interactive()) {
+ if (length(missing_packages) > 0L) {
|
||
| 77 | -+ | |||
| 131 | +! |
- #' shinyApp(app$ui, app$server)+ stop(sprintf( |
||
| 78 | -+ | |||
| 132 | +! |
- #' }+ "Cannot load package(s): %s.\nInstall or restart your session.", |
||
| 79 | -+ | |||
| 133 | +! |
- #'+ toString(missing_packages) |
||
| 80 | +134 |
- #' @export+ )) |
||
| 81 | +135 |
- #'+ } |
||
| 82 | +136 |
- tm_missing_data <- function(label = "Missing data",+ |
||
| 83 | +137 |
- plot_height = c(600, 400, 5000),+ # Normalize the parameters |
||
| 84 | -+ | |||
| 138 | +! |
- plot_width = NULL,+ if (inherits(dist_var, "data_extract_spec")) dist_var <- list(dist_var) |
||
| 85 | -+ | |||
| 139 | +! |
- parent_dataname = "ADSL",+ if (inherits(strata_var, "data_extract_spec")) strata_var <- list(strata_var) |
||
| 86 | -+ | |||
| 140 | +! |
- ggtheme = c("classic", "gray", "bw", "linedraw", "light", "dark", "minimal", "void"),
+ if (inherits(group_var, "data_extract_spec")) group_var <- list(group_var) |
||
| 87 | -+ | |||
| 141 | +! |
- ggplot2_args = list(+ if (inherits(ggplot2_args, "ggplot2_args")) ggplot2_args <- list(default = ggplot2_args) |
||
| 88 | +142 |
- "Combinations Hist" = teal.widgets::ggplot2_args(labs = list(caption = NULL)),+ |
||
| 89 | +143 |
- "Combinations Main" = teal.widgets::ggplot2_args(labs = list(title = NULL))+ # Start of assertions |
||
| 90 | -+ | |||
| 144 | +! |
- ),+ checkmate::assert_string(label) |
||
| 91 | +145 |
- pre_output = NULL,+ |
||
| 92 | -+ | |||
| 146 | +! |
- post_output = NULL) {
+ checkmate::assert_list(dist_var, "data_extract_spec") |
||
| 93 | +147 | ! |
- message("Initializing tm_missing_data")
+ checkmate::assert_false(dist_var[[1L]]$select$multiple) |
|
| 94 | +148 | |||
| 95 | -+ | |||
| 149 | +! |
- # Requires Suggested packages+ checkmate::assert_list(strata_var, types = "data_extract_spec", null.ok = TRUE) |
||
| 96 | +150 | ! |
- if (!requireNamespace("gridExtra", quietly = TRUE)) {
+ checkmate::assert_list(group_var, types = "data_extract_spec", null.ok = TRUE) |
|
| 97 | +151 | ! |
- stop("Cannot load gridExtra - please install the package or restart your session.")
+ checkmate::assert_flag(freq)+ |
+ |
| 152 | +! | +
+ ggtheme <- match.arg(ggtheme) |
||
| 98 | +153 |
- }+ |
||
| 99 | +154 | ! |
- if (!requireNamespace("rlang", quietly = TRUE)) {
+ plot_choices <- c("Histogram", "QQplot")
|
|
| 100 | +155 | ! |
- stop("Cannot load rlang - please install the package or restart your session.")
+ checkmate::assert_list(ggplot2_args, types = "ggplot2_args") |
|
| 101 | -+ | |||
| 156 | +! |
- }+ checkmate::assert_subset(names(ggplot2_args), c("default", plot_choices))
|
||
| 102 | +157 | |||
| 103 | -+ | |||
| 158 | +! |
- # Normalize the parameters+ if (length(bins) == 1) {
|
||
| 104 | +159 | ! |
- if (inherits(ggplot2_args, "ggplot2_args")) ggplot2_args <- list(default = ggplot2_args)+ checkmate::assert_numeric(bins, any.missing = FALSE, lower = 1) |
|
| 105 | +160 |
-
+ } else {
|
||
| 106 | -+ | |||
| 161 | +! |
- # Start of assertions+ checkmate::assert_numeric(bins, len = 3, any.missing = FALSE, lower = 1) |
||
| 107 | +162 | ! |
- checkmate::assert_string(label)+ checkmate::assert_numeric(bins[1], lower = bins[2], upper = bins[3], .var.name = "bins") |
|
| 108 | +163 | ++ |
+ }+ |
+ |
| 164 | ||||
| 109 | +165 | ! |
checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE) |
|
| 110 | +166 | ! |
checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height") |
|
| 111 | +167 | ! |
checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE) |
|
| 112 | +168 | ! |
checkmate::assert_numeric( |
|
| 113 | +169 | ! |
plot_width[1], |
|
| 114 | +170 | ! |
lower = plot_width[2], upper = plot_width[3], null.ok = TRUE, .var.name = "plot_width" |
|
| 115 | +171 |
) |
||
| 116 | +172 | |||
| 117 | +173 | ! |
- checkmate::assert_character(parent_dataname, min.len = 0, max.len = 1)+ checkmate::assert_multi_class(pre_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
|
|
| 118 | +174 | ! |
- ggtheme <- match.arg(ggtheme)+ checkmate::assert_multi_class(post_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
|
|
| 119 | +175 |
-
+ # End of assertions |
||
| 120 | -! | +|||
| 176 | +
- plot_choices <- c("Summary Obs", "Summary Patients", "Combinations Main", "Combinations Hist", "By Subject")
+
|
|||
| 121 | -! | +|||
| 177 | +
- checkmate::assert_list(ggplot2_args, types = "ggplot2_args")+ # Make UI args |
|||
| 122 | +178 | ! |
- checkmate::assert_subset(names(ggplot2_args), c("default", plot_choices))
+ args <- as.list(environment()) |
|
| 123 | +179 | |||
| 124 | +180 | ! |
- checkmate::assert_multi_class(pre_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
+ data_extract_list <- list( |
|
| 125 | +181 | ! |
- checkmate::assert_multi_class(post_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
+ dist_var = dist_var,+ |
+ |
| 182 | +! | +
+ strata_var = strata_var,+ |
+ ||
| 183 | +! | +
+ group_var = group_var |
||
| 126 | +184 |
- # End of assertions+ ) |
||
| 127 | +185 | |||
| 128 | +186 | ! |
ans <- module( |
|
| 129 | +187 | ! |
- label,+ label = label, |
|
| 130 | +188 | ! |
- server = srv_page_missing_data,+ server = srv_distribution, |
|
| 131 | +189 | ! |
- server_args = list(+ server_args = c( |
|
| 132 | +190 | ! |
- parent_dataname = parent_dataname, plot_height = plot_height,+ data_extract_list, |
|
| 133 | +191 | ! |
- plot_width = plot_width, ggplot2_args = ggplot2_args, ggtheme = ggtheme+ list(plot_height = plot_height, plot_width = plot_width, ggplot2_args = ggplot2_args) |
|
| 134 | +192 |
), |
||
| 135 | +193 | ! |
- ui = ui_page_missing_data,+ ui = ui_distribution, |
|
| 136 | +194 | ! |
- datanames = "all",+ ui_args = args, |
|
| 137 | +195 | ! |
- ui_args = list(pre_output = pre_output, post_output = post_output)+ datanames = teal.transform::get_extract_datanames(data_extract_list) |
|
| 138 | +196 |
) |
||
| 139 | +197 | ! |
attr(ans, "teal_bookmarkable") <- TRUE |
|
| 140 | +198 | ! |
ans |
|
| 141 | +199 |
} |
||
| 142 | +200 | |||
| 143 | +201 |
- # UI function for the missing data module (all datasets)+ # UI function for the distribution module |
||
| 144 | +202 |
- ui_page_missing_data <- function(id, pre_output = NULL, post_output = NULL) {
+ ui_distribution <- function(id, ...) {
|
||
| 145 | +203 | +! | +
+ args <- list(...)+ |
+ |
| 204 | ! |
ns <- NS(id) |
||
| 146 | +205 | ! |
- tagList(+ is_single_dataset_value <- teal.transform::is_single_dataset(args$dist_var, args$strata_var, args$group_var)+ |
+ |
| 206 | ++ | + | ||
| 147 | +207 | ! |
- include_css_files("custom"),
+ teal.widgets::standard_layout( |
|
| 148 | +208 | ! |
- teal.widgets::standard_layout(+ output = teal.widgets::white_small_well( |
|
| 149 | +209 | ! |
- output = teal.widgets::white_small_well(+ tabsetPanel( |
|
| 150 | +210 | ! |
- tags$div(+ id = ns("tabs"),
|
|
| 151 | +211 | ! |
- class = "flex",+ tabPanel("Histogram", teal.widgets::plot_with_settings_ui(id = ns("hist_plot"))),
|
|
| 152 | +212 | ! |
- column(+ tabPanel("QQplot", teal.widgets::plot_with_settings_ui(id = ns("qq_plot")))
+ |
+ |
| 213 | ++ |
+ ), |
||
| 153 | +214 | ! |
- width = 12,+ tags$h3("Statistics Table"),
|
|
| 154 | +215 | ! |
- uiOutput(ns("dataset_tabs"))
+ DT::dataTableOutput(ns("summary_table")),
|
|
| 155 | -+ | |||
| 216 | +! |
- )+ tags$h3("Tests"),
|
||
| 156 | -+ | |||
| 217 | +! |
- )+ DT::dataTableOutput(ns("t_stats"))
|
||
| 157 | +218 |
- ),+ ), |
||
| 158 | +219 | ! |
- encoding = tags$div(+ encoding = tags$div(+ |
+ |
| 220 | ++ |
+ ### Reporter |
||
| 159 | +221 | ! |
- uiOutput(ns("dataset_encodings"))
+ teal.reporter::simple_reporter_ui(ns("simple_reporter")),
|
|
| 160 | +222 |
- ),+ ### |
||
| 161 | +223 | ! |
- uiOutput(ns("dataset_reporter")),
+ tags$label("Encodings", class = "text-primary"),
|
|
| 162 | +224 | ! |
- pre_output = pre_output,+ teal.transform::datanames_input(args[c("dist_var", "strata_var")]),
|
|
| 163 | +225 | ! |
- post_output = post_output+ teal.transform::data_extract_ui( |
|
| 164 | -+ | |||
| 226 | +! |
- )+ id = ns("dist_i"),
|
||
| 165 | -+ | |||
| 227 | +! | +
+ label = "Variable",+ |
+ ||
| 228 | +! |
- )+ data_extract_spec = args$dist_var, |
||
| 166 | -+ | |||
| 229 | +! |
- }+ is_single_dataset = is_single_dataset_value |
||
| 167 | +230 |
-
+ ), |
||
| 168 | -+ | |||
| 231 | +! |
- # Server function for the missing data module (all datasets)+ if (!is.null(args$group_var)) {
|
||
| 169 | -+ | |||
| 232 | +! |
- srv_page_missing_data <- function(id, data, reporter, filter_panel_api, parent_dataname,+ tagList( |
||
| 170 | -+ | |||
| 233 | +! |
- plot_height, plot_width, ggplot2_args, ggtheme) {
+ teal.transform::data_extract_ui( |
||
| 171 | +234 | ! |
- with_reporter <- !missing(reporter) && inherits(reporter, "Reporter")+ id = ns("group_i"),
|
|
| 172 | +235 | ! |
- with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI")+ label = "Group by", |
|
| 173 | +236 | ! |
- moduleServer(id, function(input, output, session) {
+ data_extract_spec = args$group_var, |
|
| 174 | +237 | ! |
- teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.general")+ is_single_dataset = is_single_dataset_value |
|
| 175 | +238 |
-
+ ), |
||
| 176 | +239 | ! |
- datanames <- isolate(teal.data::datanames(data()))+ uiOutput(ns("scales_types_ui"))
+ |
+ |
| 240 | ++ |
+ )+ |
+ ||
| 241 | ++ |
+ }, |
||
| 177 | +242 | ! |
- datanames <- Filter(function(name) {
+ if (!is.null(args$strata_var)) {
|
|
| 178 | +243 | ! |
- is.data.frame(isolate(data())[[name]])+ teal.transform::data_extract_ui( |
|
| 179 | +244 | ! |
- }, datanames)+ id = ns("strata_i"),
|
|
| 180 | +245 | ! |
- if_subject_plot <- length(parent_dataname) > 0 && parent_dataname %in% datanames+ label = "Stratify by", |
|
| 181 | -+ | |||
| 246 | +! |
-
+ data_extract_spec = args$strata_var, |
||
| 182 | +247 | ! |
- ns <- session$ns+ is_single_dataset = is_single_dataset_value |
|
| 183 | +248 |
-
+ )+ |
+ ||
| 249 | ++ |
+ }, |
||
| 184 | +250 | ! |
- output$dataset_tabs <- renderUI({
+ teal.widgets::panel_group( |
|
| 185 | +251 | ! |
- do.call(+ conditionalPanel( |
|
| 186 | +252 | ! |
- tabsetPanel,+ condition = paste0("input['", ns("tabs"), "'] == 'Histogram'"),
|
|
| 187 | +253 | ! |
- c(+ teal.widgets::panel_item( |
|
| 188 | +254 | ! |
- id = ns("dataname_tab"),
+ "Histogram", |
|
| 189 | +255 | ! |
- lapply(+ teal.widgets::optionalSliderInputValMinMax(ns("bins"), "Bins", args$bins, ticks = FALSE, step = 1),
|
|
| 190 | +256 | ! |
- datanames,+ shinyWidgets::prettyRadioButtons( |
|
| 191 | +257 | ! |
- function(x) {
+ ns("main_type"),
|
|
| 192 | +258 | ! |
- tabPanel(+ label = "Plot Type:", |
|
| 193 | +259 | ! |
- title = x,+ choices = c("Density", "Frequency"),
|
|
| 194 | +260 | ! |
- column(+ selected = if (!args$freq) "Density" else "Frequency", |
|
| 195 | +261 | ! |
- width = 12,+ bigger = FALSE, |
|
| 196 | +262 | ! |
- tags$div(+ inline = TRUE+ |
+ |
| 263 | ++ |
+ ), |
||
| 197 | +264 | ! |
- class = "mt-4",+ checkboxInput(ns("add_dens"), label = "Overlay Density", value = TRUE),
|
|
| 198 | +265 | ! |
- ui_missing_data(id = ns(x), by_subject_plot = if_subject_plot)+ collapsed = FALSE |
|
| 199 | +266 |
- )+ ) |
||
| 200 | +267 |
- )+ ), |
||
| 201 | -+ | |||
| 268 | +! |
- )+ conditionalPanel( |
||
| 202 | -+ | |||
| 269 | +! |
- }+ condition = paste0("input['", ns("tabs"), "'] == 'QQplot'"),
|
||
| 203 | -+ | |||
| 270 | +! |
- )+ teal.widgets::panel_item( |
||
| 204 | -+ | |||
| 271 | +! |
- )+ "QQ Plot", |
||
| 205 | -+ | |||
| 272 | +! |
- )+ checkboxInput(ns("qq_line"), label = "Add diagonal line(s)", TRUE),
+ |
+ ||
| 273 | +! | +
+ collapsed = FALSE |
||
| 206 | +274 |
- })+ ) |
||
| 207 | +275 |
-
+ ), |
||
| 208 | +276 | ! |
- output$dataset_encodings <- renderUI({
+ conditionalPanel( |
|
| 209 | +277 | ! |
- tagList(+ condition = paste0("input['", ns("main_type"), "'] == 'Density'"),
|
|
| 210 | +278 | ! |
- lapply(+ teal.widgets::panel_item( |
|
| 211 | +279 | ! |
- datanames,+ "Theoretical Distribution", |
|
| 212 | +280 | ! |
- function(x) {
+ teal.widgets::optionalSelectInput( |
|
| 213 | +281 | ! |
- conditionalPanel(+ ns("t_dist"),
|
|
| 214 | +282 | ! |
- is_tab_active_js(ns("dataname_tab"), x),
+ tags$div( |
|
| 215 | +283 | ! |
- encoding_missing_data(+ class = "teal-tooltip", |
|
| 216 | +284 | ! |
- id = ns(x),+ tagList( |
|
| 217 | +285 | ! |
- summary_per_patient = if_subject_plot,+ "Distribution:", |
|
| 218 | +286 | ! |
- ggtheme = ggtheme,+ icon("circle-info"),
|
|
| 219 | +287 | ! |
- datanames = datanames- |
- |
| 220 | -- |
- )- |
- ||
| 221 | -- |
- )+ tags$span( |
||
| 222 | -+ | |||
| 288 | +! |
- }+ class = "tooltiptext", |
||
| 223 | -+ | |||
| 289 | +! |
- )+ "Default parameters are optimized with MASS::fitdistr function." |
||
| 224 | +290 |
- )+ ) |
||
| 225 | +291 |
- })+ ) |
||
| 226 | +292 |
-
+ ), |
||
| 227 | +293 | ! |
- output$dataset_reporter <- renderUI({
+ choices = c("normal", "lognormal", "gamma", "unif"),
|
|
| 228 | +294 | ! |
- lapply(datanames, function(x) {
+ selected = NULL, |
|
| 229 | +295 | ! |
- dataname_ns <- NS(ns(x))+ multiple = FALSE |
|
| 230 | +296 |
-
+ ), |
||
| 231 | +297 | ! |
- conditionalPanel(+ numericInput(ns("dist_param1"), label = "param1", value = NULL),
|
|
| 232 | +298 | ! |
- is_tab_active_js(ns("dataname_tab"), x),
+ numericInput(ns("dist_param2"), label = "param2", value = NULL),
|
|
| 233 | +299 | ! |
- tagList(+ tags$span(actionButton(ns("params_reset"), "Default params")),
|
|
| 234 | +300 | ! |
- teal.widgets::verbatim_popup_ui(dataname_ns("rcode"), "Show R code")
+ collapsed = FALSE |
|
| 235 | +301 |
) |
||
| 236 | +302 |
) |
||
| 237 | -- |
- })- |
- ||
| 238 | -- |
- })- |
- ||
| 239 | +303 |
-
+ ), |
||
| 240 | +304 | ! |
- lapply(+ teal.widgets::panel_item( |
|
| 241 | +305 | ! |
- datanames,+ "Tests", |
|
| 242 | +306 | ! |
- function(x) {
+ teal.widgets::optionalSelectInput( |
|
| 243 | +307 | ! |
- srv_missing_data(+ ns("dist_tests"),
|
|
| 244 | +308 | ! |
- id = x,+ "Tests:", |
|
| 245 | +309 | ! |
- data = data,+ choices = c( |
|
| 246 | +310 | ! |
- reporter = if (with_reporter) reporter,+ "Shapiro-Wilk", |
|
| 247 | +311 | ! |
- filter_panel_api = if (with_filter) filter_panel_api,+ if (!is.null(args$strata_var)) "t-test (two-samples, not paired)", |
|
| 248 | +312 | ! |
- dataname = x,+ if (!is.null(args$strata_var)) "one-way ANOVA", |
|
| 249 | +313 | ! |
- parent_dataname = parent_dataname,+ if (!is.null(args$strata_var)) "Fligner-Killeen", |
|
| 250 | +314 | ! |
- plot_height = plot_height,+ if (!is.null(args$strata_var)) "F-test", |
|
| 251 | +315 | ! |
- plot_width = plot_width,+ "Kolmogorov-Smirnov (one-sample)", |
|
| 252 | +316 | ! |
- ggplot2_args = ggplot2_args- |
- |
| 253 | -- |
- )- |
- ||
| 254 | -- |
- }- |
- ||
| 255 | -- |
- )+ "Anderson-Darling (one-sample)", |
||
| 256 | -+ | |||
| 317 | +! |
- })+ "Cramer-von Mises (one-sample)", |
||
| 257 | -+ | |||
| 318 | +! |
- }+ if (!is.null(args$strata_var)) "Kolmogorov-Smirnov (two-samples)" |
||
| 258 | +319 |
-
+ ), |
||
| 259 | -+ | |||
| 320 | +! |
- # UI function for the missing data module (single dataset)+ selected = NULL |
||
| 260 | +321 |
- ui_missing_data <- function(id, by_subject_plot = FALSE) {
- |
- ||
| 261 | -! | -
- ns <- NS(id)+ ) |
||
| 262 | +322 |
-
+ ), |
||
| 263 | +323 | ! |
- tab_list <- list(+ teal.widgets::panel_item( |
|
| 264 | +324 | ! |
- tabPanel(+ "Statistics Table", |
|
| 265 | +325 | ! |
- "Summary",+ sliderInput(ns("roundn"), "Round to n digits", min = 0, max = 10, value = 2)
|
|
| 266 | -! | +|||
| 326 | +
- teal.widgets::plot_with_settings_ui(id = ns("summary_plot")),
+ ), |
|||
| 267 | +327 | ! |
- helpText(+ teal.widgets::panel_item( |
|
| 268 | +328 | ! |
- tags$p(paste(+ title = "Plot settings", |
|
| 269 | +329 | ! |
- 'The "Summary" graph shows the number of missing values per variable (both absolute and percentage),',+ selectInput( |
|
| 270 | +330 | ! |
- "sorted by magnitude."+ inputId = ns("ggtheme"),
|
|
| 271 | -+ | |||
| 331 | +! |
- )),+ label = "Theme (by ggplot):", |
||
| 272 | +332 | ! |
- tags$p(+ choices = ggplot_themes, |
|
| 273 | +333 | ! |
- 'The "summary per patients" graph is showing how many subjects have at least one missing observation',+ selected = args$ggtheme, |
|
| 274 | +334 | ! |
- "for each variable. It will be most useful for panel datasets."+ multiple = FALSE |
|
| 275 | +335 |
) |
||
| 276 | +336 |
) |
||
| 277 | +337 |
), |
||
| 278 | +338 | ! |
- tabPanel(+ forms = tagList( |
|
| 279 | +339 | ! |
- "Combinations",+ teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code")
|
|
| 280 | -! | +|||
| 340 | +
- teal.widgets::plot_with_settings_ui(id = ns("combination_plot")),
+ ), |
|||
| 281 | +341 | ! |
- helpText(+ pre_output = args$pre_output, |
|
| 282 | +342 | ! |
- tags$p(paste(+ post_output = args$post_output |
|
| 283 | -! | +|||
| 343 | +
- 'The "Combinations" graph is used to explore the relationship between the missing data within',+ ) |
|||
| 284 | -! | +|||
| 344 | +
- "different columns of the dataset.",+ } |
|||
| 285 | -! | +|||
| 345 | +
- "It shows the different patterns of missingness in the rows of the data.",+ |
|||
| 286 | -! | +|||
| 346 | +
- 'For example, suppose that 70 rows of the data have exactly columns "A" and "B" missing.',+ # Server function for the distribution module |
|||
| 287 | -! | +|||
| 347 | +
- "In this case there would be a bar of height 70 in the top graph and",+ srv_distribution <- function(id, |
|||
| 288 | -! | +|||
| 348 | +
- 'the column below this in the second graph would have rows "A" and "B" cells shaded red.'+ data, |
|||
| 289 | +349 |
- )),+ reporter, |
||
| 290 | -! | +|||
| 350 | +
- tags$p(paste(+ filter_panel_api, |
|||
| 291 | -! | +|||
| 351 | +
- "Due to the large number of missing data patterns possible, only those with a large set of observations",+ dist_var, |
|||
| 292 | -! | +|||
| 352 | +
- 'are shown in the graph and the "Combination cut-off" slider can be used to adjust the number shown.'+ strata_var, |
|||
| 293 | +353 |
- ))+ group_var, |
||
| 294 | +354 |
- )+ plot_height, |
||
| 295 | +355 |
- ),+ plot_width, |
||
| 296 | -! | +|||
| 356 | +
- tabPanel(+ ggplot2_args) {
|
|||
| 297 | +357 | ! |
- "By Variable Levels",+ with_reporter <- !missing(reporter) && inherits(reporter, "Reporter") |
|
| 298 | +358 | ! |
- teal.widgets::get_dt_rows(ns("levels_table"), ns("levels_table_rows")),
+ with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI") |
|
| 299 | +359 | ! |
- DT::dataTableOutput(ns("levels_table"))
+ checkmate::assert_class(data, "reactive") |
|
| 300 | -+ | |||
| 360 | +! |
- )+ checkmate::assert_class(isolate(data()), "teal_data") |
||
| 301 | -+ | |||
| 361 | +! |
- )+ moduleServer(id, function(input, output, session) {
|
||
| 302 | +362 | ! |
- if (isTRUE(by_subject_plot)) {
+ teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.general") |
|
| 303 | -! | +|||
| 363 | +
- tab_list <- append(+ |
|||
| 304 | +364 | ! |
- tab_list,+ setBookmarkExclude("params_reset")
|
|
| 305 | -! | +|||
| 365 | +
- list(tabPanel(+ |
|||
| 306 | +366 | ! |
- "Grouped by Subject",+ ns <- session$ns+ |
+ |
| 367 | ++ | + | ||
| 307 | +368 | ! |
- teal.widgets::plot_with_settings_ui(id = ns("by_subject_plot")),
+ rule_req <- function(value) {
|
|
| 308 | +369 | ! |
- helpText(+ if (isTRUE(input$dist_tests %in% c( |
|
| 309 | +370 | ! |
- tags$p(paste(+ "Fligner-Killeen", |
|
| 310 | +371 | ! |
- "This graph shows the missingness with respect to subjects rather than individual rows of the",+ "t-test (two-samples, not paired)", |
|
| 311 | +372 | ! |
- "dataset. Each row represents one dataset variable and each column a single subject. Only subjects",+ "F-test", |
|
| 312 | +373 | ! |
- "with at least one record in this dataset are shown. For a given subject, if they have any missing",+ "Kolmogorov-Smirnov (two-samples)", |
|
| 313 | +374 | ! |
- "values of a specific variable then the appropriate cell in the graph is marked as missing."+ "one-way ANOVA" |
|
| 314 | +375 |
- ))+ ))) {
|
||
| 315 | -+ | |||
| 376 | +! |
- )+ if (!shinyvalidate::input_provided(value)) {
|
||
| 316 | -+ | |||
| 377 | +! |
- ))+ "Please select stratify variable." |
||
| 317 | +378 |
- )+ } |
||
| 318 | +379 |
- }+ } |
||
| 319 | +380 |
-
+ } |
||
| 320 | +381 | ! |
- do.call(+ rule_dupl <- function(...) {
|
|
| 321 | +382 | ! |
- tabsetPanel,+ if (identical(input$dist_tests, "Fligner-Killeen")) {
|
|
| 322 | +383 | ! |
- c(+ strata <- selector_list()$strata_i()$select |
|
| 323 | +384 | ! |
- id = ns("summary_type"),
+ group <- selector_list()$group_i()$select |
|
| 324 | +385 | ! |
- tab_list+ if (isTRUE(strata == group)) {
+ |
+ |
| 386 | +! | +
+ "Please select different variables for strata and group." |
||
| 325 | +387 |
- )+ } |
||
| 326 | +388 |
- )+ } |
||
| 327 | +389 |
- }+ } |
||
| 328 | +390 | |||
| 329 | -+ | |||
| 391 | +! |
- # UI encoding for the missing data module (all datasets)+ selector_list <- teal.transform::data_extract_multiple_srv( |
||
| 330 | -+ | |||
| 392 | +! |
- encoding_missing_data <- function(id, summary_per_patient = FALSE, ggtheme, datanames) {
+ data_extract = list( |
||
| 331 | +393 | ! |
- ns <- NS(id)+ dist_i = dist_var, |
|
| 332 | -+ | |||
| 394 | +! |
-
+ strata_i = strata_var, |
||
| 333 | +395 | ! |
- tagList(+ group_i = group_var |
|
| 334 | +396 |
- ### Reporter+ ), |
||
| 335 | +397 | ! |
- teal.reporter::simple_reporter_ui(ns("simple_reporter")),
+ data,+ |
+ |
| 398 | +! | +
+ select_validation_rule = list(+ |
+ ||
| 399 | +! | +
+ dist_i = shinyvalidate::sv_required("Please select a variable")
|
||
| 336 | +400 |
- ###+ ), |
||
| 337 | +401 | ! |
- tags$label("Encodings", class = "text-primary"),
+ filter_validation_rule = list( |
|
| 338 | +402 | ! |
- helpText(+ strata_i = shinyvalidate::compose_rules( |
|
| 339 | +403 | ! |
- paste0("Dataset", `if`(length(datanames) > 1, "s", ""), ":"),
+ rule_req, |
|
| 340 | +404 | ! |
- tags$code(paste(datanames, collapse = ", "))+ rule_dupl |
|
| 341 | +405 |
- ),+ ), |
||
| 342 | +406 | ! |
- uiOutput(ns("variables")),
+ group_i = rule_dupl |
|
| 343 | -! | +|||
| 407 | +
- actionButton(+ ) |
|||
| 344 | -! | +|||
| 408 | +
- ns("filter_na"),
+ )+ |
+ |||
| 409 | ++ | + | ||
| 345 | +410 | ! |
- tags$span("Select only vars with missings", class = "whitespace-normal"),
+ iv_r <- reactive({
|
|
| 346 | +411 | ! |
- width = "100%",+ iv <- shinyvalidate::InputValidator$new() |
|
| 347 | +412 | ! |
- class = "mb-4"+ teal.transform::compose_and_enable_validators(iv, selector_list, validator_names = "dist_i") |
|
| 348 | +413 |
- ),+ })+ |
+ ||
| 414 | ++ | + | ||
| 349 | +415 | ! |
- conditionalPanel(+ iv_r_dist <- reactive({
|
|
| 350 | +416 | ! |
- is_tab_active_js(ns("summary_type"), "Summary"),
+ iv <- shinyvalidate::InputValidator$new() |
|
| 351 | +417 | ! |
- checkboxInput(+ teal.transform::compose_and_enable_validators( |
|
| 352 | +418 | ! |
- ns("any_na"),
+ iv, selector_list, |
|
| 353 | +419 | ! |
- tags$div(+ validator_names = c("strata_i", "group_i")
+ |
+ |
| 420 | ++ |
+ )+ |
+ ||
| 421 | ++ |
+ }) |
||
| 354 | +422 | ! |
- class = "teal-tooltip",+ rule_dist_1 <- function(value) {
+ |
+ |
| 423 | +! | +
+ if (!is.null(input$t_dist)) {
|
||
| 355 | +424 | ! |
- tagList(+ switch(input$t_dist, |
|
| 356 | +425 | ! |
- "Add **anyna** variable",+ "normal" = if (!shinyvalidate::input_provided(value)) "mean is required", |
|
| 357 | +426 | ! |
- icon("circle-info"),
+ "lognormal" = if (!shinyvalidate::input_provided(value)) "meanlog is required", |
|
| 358 | +427 | ! |
- tags$span(+ "gamma" = {
|
|
| 359 | +428 | ! |
- class = "tooltiptext",+ if (!shinyvalidate::input_provided(value)) "shape is required" else if (value <= 0) "shape must be positive"+ |
+ |
| 429 | ++ |
+ }, |
||
| 360 | +430 | ! |
- "Describes the number of observations with at least one missing value in any variable."+ "unif" = NULL |
|
| 361 | +431 |
- )+ ) |
||
| 362 | +432 |
- )+ } |
||
| 363 | +433 |
- ),+ } |
||
| 364 | +434 | ! |
- value = FALSE+ rule_dist_2 <- function(value) {
|
|
| 365 | -+ | |||
| 435 | +! |
- ),+ if (!is.null(input$t_dist)) {
|
||
| 366 | +436 | ! |
- if (summary_per_patient) {
+ switch(input$t_dist, |
|
| 367 | +437 | ! |
- checkboxInput(+ "normal" = {
|
|
| 368 | +438 | ! |
- ns("if_patients_plot"),
+ if (!shinyvalidate::input_provided(value)) {
|
|
| 369 | +439 | ! |
- tags$div(+ "sd is required" |
|
| 370 | +440 | ! |
- class = "teal-tooltip",+ } else if (value < 0) {
|
|
| 371 | +441 | ! |
- tagList(+ "sd must be non-negative" |
|
| 372 | -! | +|||
| 442 | +
- "Add summary per patients",+ } |
|||
| 373 | -! | +|||
| 443 | +
- icon("circle-info"),
+ }, |
|||
| 374 | +444 | ! |
- tags$span(+ "lognormal" = {
|
|
| 375 | +445 | ! |
- class = "tooltiptext",+ if (!shinyvalidate::input_provided(value)) {
|
|
| 376 | +446 | ! |
- paste(+ "sdlog is required" |
|
| 377 | +447 | ! |
- "Displays the number of missing values per observation,",+ } else if (value < 0) {
|
|
| 378 | +448 | ! |
- "where the x-axis is sorted by observation appearance in the table."+ "sdlog must be non-negative" |
|
| 379 | +449 |
- )+ } |
||
| 380 | +450 |
- )+ }, |
||
| 381 | -+ | |||
| 451 | +! |
- )+ "gamma" = {
|
||
| 382 | -+ | |||
| 452 | +! |
- ),+ if (!shinyvalidate::input_provided(value)) {
|
||
| 383 | +453 | ! |
- value = FALSE+ "rate is required" |
|
| 384 | -+ | |||
| 454 | +! |
- )+ } else if (value <= 0) {
|
||
| 385 | -+ | |||
| 455 | +! |
- }+ "rate must be positive" |
||
| 386 | +456 |
- ),- |
- ||
| 387 | -! | -
- conditionalPanel(+ } |
||
| 388 | -! | +|||
| 457 | +
- is_tab_active_js(ns("summary_type"), "Combinations"),
+ }, |
|||
| 389 | +458 | ! |
- uiOutput(ns("cutoff"))
+ "unif" = NULL |
|
| 390 | +459 |
- ),+ ) |
||
| 391 | -! | +|||
| 460 | +
- conditionalPanel(+ } |
|||
| 392 | -! | +|||
| 461 | +
- is_tab_active_js(ns("summary_type"), "By Variable Levels"),
+ } |
|||
| 393 | +462 | ! |
- tagList(+ rule_dist <- function(value) {
|
|
| 394 | +463 | ! |
- uiOutput(ns("group_by_var_ui")),
+ if (isTRUE(input$tabs == "QQplot" || |
|
| 395 | +464 | ! |
- uiOutput(ns("group_by_vals_ui")),
+ input$dist_tests %in% c( |
|
| 396 | +465 | ! |
- radioButtons(+ "Kolmogorov-Smirnov (one-sample)", |
|
| 397 | +466 | ! |
- ns("count_type"),
+ "Anderson-Darling (one-sample)", |
|
| 398 | +467 | ! |
- label = "Display missing as",+ "Cramer-von Mises (one-sample)" |
|
| 399 | -! | +|||
| 468 | +
- choices = c("counts", "proportions"),
+ ))) {
|
|||
| 400 | +469 | ! |
- selected = "counts",+ if (!shinyvalidate::input_provided(value)) {
|
|
| 401 | +470 | ! |
- inline = TRUE+ "Please select the theoretical distribution." |
|
| 402 | +471 |
- )+ } |
||
| 403 | +472 |
- )+ } |
||
| 404 | +473 |
- ),+ } |
||
| 405 | +474 | ! |
- teal.widgets::panel_item(+ iv_dist <- shinyvalidate::InputValidator$new() |
|
| 406 | +475 | ! |
- title = "Plot settings",+ iv_dist$add_rule("t_dist", rule_dist)
|
|
| 407 | +476 | ! |
- selectInput(+ iv_dist$add_rule("dist_param1", rule_dist_1)
|
|
| 408 | +477 | ! |
- inputId = ns("ggtheme"),
+ iv_dist$add_rule("dist_param2", rule_dist_2)
|
|
| 409 | +478 | ! |
- label = "Theme (by ggplot):",+ iv_dist$enable()+ |
+ |
| 479 | ++ | + | ||
| 410 | +480 | ! |
- choices = ggplot_themes,+ anl_merged_input <- teal.transform::merge_expression_srv( |
|
| 411 | +481 | ! |
- selected = ggtheme,+ selector_list = selector_list, |
|
| 412 | +482 | ! |
- multiple = FALSE+ datasets = data |
|
| 413 | +483 |
- )+ ) |
||
| 414 | +484 |
- )+ |
||
| 415 | -+ | |||
| 485 | +! |
- )+ anl_merged_q <- reactive({
+ |
+ ||
| 486 | +! | +
+ req(anl_merged_input())+ |
+ ||
| 487 | +! | +
+ data() %>%+ |
+ ||
| 488 | +! | +
+ teal.code::eval_code(as.expression(anl_merged_input()$expr)) |
||
| 416 | +489 |
- }+ }) |
||
| 417 | +490 | |||
| 418 | -+ | |||
| 491 | +! |
- # Server function for the missing data (single dataset)+ merged <- list(+ |
+ ||
| 492 | +! | +
+ anl_input_r = anl_merged_input,+ |
+ ||
| 493 | +! | +
+ anl_q_r = anl_merged_q |
||
| 419 | +494 |
- srv_missing_data <- function(id, data, reporter, filter_panel_api, dataname, parent_dataname,+ ) |
||
| 420 | +495 |
- plot_height, plot_width, ggplot2_args) {
+
|
||
| 421 | +496 | ! |
- with_reporter <- !missing(reporter) && inherits(reporter, "Reporter")+ output$scales_types_ui <- renderUI({
|
|
| 422 | +497 | ! |
- with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI")+ if ("group_i" %in% names(selector_list()) && length(selector_list()$group_i()$filters[[1]]$selected) > 0) {
|
|
| 423 | +498 | ! |
- checkmate::assert_class(data, "reactive")+ shinyWidgets::prettyRadioButtons( |
|
| 424 | +499 | ! |
- checkmate::assert_class(isolate(data()), "teal_data")+ ns("scales_type"),
|
|
| 425 | +500 | ! |
- moduleServer(id, function(input, output, session) {
+ label = "Scales:", |
|
| 426 | +501 | ! |
- ns <- session$ns- |
- |
| 427 | -- |
-
+ choices = c("Fixed", "Free"),
|
||
| 428 | +502 | ! |
- prev_group_by_var <- reactiveVal("")
+ selected = "Fixed", |
|
| 429 | +503 | ! |
- data_r <- reactive(data()[[dataname]])+ bigger = FALSE, |
|
| 430 | +504 | ! |
- data_keys <- reactive(unlist(teal.data::join_keys(data())[[dataname]]))+ inline = TRUE |
|
| 431 | +505 |
-
+ ) |
||
| 432 | -! | +|||
| 506 | +
- iv_r <- reactive({
+ } |
|||
| 433 | -! | +|||
| 507 | +
- iv <- shinyvalidate::InputValidator$new()+ }) |
|||
| 434 | -! | +|||
| 508 | +
- iv$add_rule(+ |
|||
| 435 | +509 | ! |
- "variables_select",+ observeEvent( |
|
| 436 | +510 | ! |
- shinyvalidate::sv_required("At least one reference variable needs to be selected.")
- |
- |
| 437 | -- |
- )+ eventExpr = list( |
||
| 438 | +511 | ! |
- iv$add_rule(+ input$t_dist, |
|
| 439 | +512 | ! |
- "variables_select",+ input$params_reset, |
|
| 440 | +513 | ! |
- ~ if (length(setdiff((.), data_keys())) < 1) "Please also select non-key columns."+ selector_list()$dist_i()$select |
|
| 441 | +514 |
- )+ ), |
||
| 442 | +515 | ! |
- iv_summary_table <- shinyvalidate::InputValidator$new()+ handlerExpr = {
|
|
| 443 | +516 | ! |
- iv_summary_table$condition(~ isTRUE(input$summary_type == "By Variable Levels"))+ params <- |
|
| 444 | +517 | ! |
- iv_summary_table$add_rule("count_type", shinyvalidate::sv_required("Please select type of counts"))
+ if (length(input$t_dist) != 0) {
|
|
| 445 | +518 | ! |
- iv_summary_table$add_rule(+ get_dist_params <- function(x, dist) {
|
|
| 446 | +519 | ! |
- "group_by_vals",+ if (dist == "unif") {
|
|
| 447 | +520 | ! |
- shinyvalidate::sv_required("Please select both group-by variable and values")
+ return(stats::setNames(range(x, na.rm = TRUE), c("min", "max")))
|
|
| 448 | +521 |
- )+ } |
||
| 449 | +522 | ! |
- iv_summary_table$add_rule(+ tryCatch( |
|
| 450 | +523 | ! |
- "group_by_var",+ MASS::fitdistr(x, densfun = dist)$estimate, |
|
| 451 | +524 | ! |
- ~ if (length(.) > 0 && length(input$variables_select) == 1 && (.) == input$variables_select) {
+ error = function(e) c(param1 = NA_real_, param2 = NA_real_) |
- |
| 452 | -! | +|||
| 525 | +
- "If only one reference variable is selected it must not be the grouping variable."+ ) |
|||
| 453 | +526 |
- }+ } |
||
| 454 | +527 |
- )+ |
||
| 455 | +528 | ! |
- iv_summary_table$add_rule(+ ANL <- merged$anl_q_r()[["ANL"]] |
|
| 456 | +529 | ! |
- "variables_select",+ round(get_dist_params(as.numeric(stats::na.omit(ANL[[merge_vars()$dist_var]])), input$t_dist), 2) |
|
| 457 | -! | +|||
| 530 | +
- ~ if (length(input$group_by_var) > 0 && length(.) == 1 && (.) == input$group_by_var) {
+ } else {
|
|||
| 458 | +531 | ! |
- "If only one reference variable is selected it must not be the grouping variable."+ c("param1" = NA_real_, "param2" = NA_real_)
|
|
| 459 | +532 |
- }+ } |
||
| 460 | +533 |
- )+ |
||
| 461 | +534 | ! |
- iv$add_validator(iv_summary_table)+ params_vals <- unname(params) |
|
| 462 | +535 | ! |
- iv$enable()+ params_names <- names(params)+ |
+ |
| 536 | ++ | + | ||
| 463 | +537 | ! |
- iv+ updateNumericInput( |
|
| 464 | -+ | |||
| 538 | +! |
- })+ inputId = "dist_param1", |
||
| 465 | -+ | |||
| 539 | +! |
-
+ label = params_names[1],+ |
+ ||
| 540 | +! | +
+ value = restoreInput(ns("dist_param1"), params_vals[1])
|
||
| 466 | +541 |
-
+ ) |
||
| 467 | +542 | ! |
- data_parent_keys <- reactive({
+ updateNumericInput( |
|
| 468 | +543 | ! |
- if (length(parent_dataname) > 0 && parent_dataname %in% teal.data::datanames(data())) {
+ inputId = "dist_param2", |
|
| 469 | +544 | ! |
- keys <- teal.data::join_keys(data())[[dataname]]+ label = params_names[2], |
|
| 470 | +545 | ! |
- if (parent_dataname %in% names(keys)) {
+ value = restoreInput(ns("dist_param1"), params_vals[2])
|
|
| 471 | -! | +|||
| 546 | +
- keys[[parent_dataname]]+ ) |
|||
| 472 | +547 |
- } else {
+ }, |
||
| 473 | +548 | ! |
- keys[[dataname]]+ ignoreInit = TRUE |
|
| 474 | +549 |
- }+ ) |
||
| 475 | +550 |
- } else {
+
|
||
| 476 | +551 | ! |
- NULL+ observeEvent(input$params_reset, {
|
|
| 477 | -+ | |||
| 552 | +! |
- }+ updateActionButton(inputId = "params_reset", label = "Reset params") |
||
| 478 | +553 |
}) |
||
| 479 | +554 | |||
| 480 | +555 | ! |
- common_code_q <- reactive({
+ merge_vars <- reactive({
|
|
| 481 | +556 | ! |
teal::validate_inputs(iv_r()) |
|
| 482 | +557 | |||
| 483 | +558 | ! |
- group_var <- input$group_by_var+ dist_var <- as.vector(merged$anl_input_r()$columns_source$dist_i) |
|
| 484 | +559 | ! |
- anl <- data_r()+ s_var <- as.vector(merged$anl_input_r()$columns_source$strata_i)+ |
+ |
| 560 | +! | +
+ g_var <- as.vector(merged$anl_input_r()$columns_source$group_i) |
||
| 485 | +561 | |||
| 486 | +562 | ! |
- qenv <- if (!is.null(selected_vars()) && length(selected_vars()) != ncol(anl)) {
+ dist_var_name <- if (length(dist_var)) as.name(dist_var) else NULL |
|
| 487 | +563 | ! |
- teal.code::eval_code(+ s_var_name <- if (length(s_var)) as.name(s_var) else NULL |
|
| 488 | +564 | ! |
- data(),+ g_var_name <- if (length(g_var)) as.name(g_var) else NULL |
|
| 489 | -! | +|||
| 565 | +
- substitute(+ |
|||
| 490 | +566 | ! |
- expr = ANL <- anl_name[, selected_vars, drop = FALSE],+ list( |
|
| 491 | +567 | ! |
- env = list(anl_name = as.name(dataname), selected_vars = selected_vars())- |
- |
| 492 | -- |
- )+ dist_var = dist_var, |
||
| 493 | -+ | |||
| 568 | +! |
- )+ s_var = s_var, |
||
| 494 | -+ | |||
| 569 | +! |
- } else {
+ g_var = g_var, |
||
| 495 | +570 | ! |
- teal.code::eval_code(+ dist_var_name = dist_var_name, |
|
| 496 | +571 | ! |
- data(),+ s_var_name = s_var_name, |
|
| 497 | +572 | ! |
- substitute(expr = ANL <- anl_name, env = list(anl_name = as.name(dataname)))+ g_var_name = g_var_name |
|
| 498 | +573 |
- )+ ) |
||
| 499 | +574 |
- }+ }) |
||
| 500 | +575 | |||
| 501 | -! | +|||
| 576 | +
- if (input$summary_type == "By Variable Levels" && !is.null(group_var) && !(group_var %in% selected_vars())) {
+ # common qenv |
|||
| 502 | +577 | ! |
- qenv <- teal.code::eval_code(+ common_q <- reactive({
|
|
| 503 | -! | +|||
| 578 | +
- qenv,+ # Create a private stack for this function only.+ |
+ |||
| 579 | ++ | + | ||
| 504 | +580 | ! |
- substitute(+ ANL <- merged$anl_q_r()[["ANL"]] |
|
| 505 | +581 | ! |
- expr = ANL[[group_var]] <- anl_name[[group_var]],+ dist_var <- merge_vars()$dist_var |
|
| 506 | +582 | ! |
- env = list(group_var = group_var, anl_name = as.name(dataname))+ s_var <- merge_vars()$s_var |
|
| 507 | -+ | |||
| 583 | +! |
- )+ g_var <- merge_vars()$g_var |
||
| 508 | +584 |
- )+ |
||
| 509 | -+ | |||
| 585 | +! |
- }+ dist_var_name <- merge_vars()$dist_var_name |
||
| 510 | -+ | |||
| 586 | +! |
-
+ s_var_name <- merge_vars()$s_var_name |
||
| 511 | +587 | ! |
- new_col_name <- "**anyna**"+ g_var_name <- merge_vars()$g_var_name |
|
| 512 | +588 | |||
| 513 | +589 | ! |
- qenv <- teal.code::eval_code(+ roundn <- input$roundn |
|
| 514 | +590 | ! |
- qenv,+ dist_param1 <- input$dist_param1 |
|
| 515 | +591 | ! |
- substitute(+ dist_param2 <- input$dist_param2 |
|
| 516 | -! | +|||
| 592 | +
- expr =+ # isolated as dist_param1/dist_param2 already triggered the reactivity |
|||
| 517 | +593 | ! |
- create_cols_labels <- function(cols, just_label = FALSE) {
+ t_dist <- isolate(input$t_dist)+ |
+ |
| 594 | ++ | + | ||
| 518 | +595 | ! |
- column_labels <- column_labels_value+ qenv <- merged$anl_q_r()+ |
+ |
| 596 | ++ | + | ||
| 519 | +597 | ! |
- column_labels[is.na(column_labels) | length(column_labels) == 0] <- ""+ if (length(g_var) > 0) {
|
|
| 520 | +598 | ! |
- if (just_label) {
+ validate( |
|
| 521 | +599 | ! |
- labels <- column_labels[cols]+ need( |
|
| 522 | -+ | |||
| 600 | +! |
- } else {
+ inherits(ANL[[g_var]], c("integer", "factor", "character")),
|
||
| 523 | +601 | ! |
- labels <- ifelse(cols == new_col_name | cols == "", cols, paste0(column_labels[cols], " [", cols, "]"))+ "Group by variable must be `factor`, `character`, or `integer`" |
|
| 524 | +602 |
- }+ ) |
||
| 525 | -! | +|||
| 603 | +
- labels+ ) |
|||
| 526 | -+ | |||
| 604 | +! |
- },+ qenv <- teal.code::eval_code( |
||
| 527 | +605 | ! |
- env = list(+ qenv, |
|
| 528 | +606 | ! |
- new_col_name = new_col_name,+ substitute( |
|
| 529 | +607 | ! |
- column_labels_value = c(teal.data::col_labels(data_r())[selected_vars()],+ expr = ANL[[g_var]] <- forcats::fct_na_value_to_level(as.factor(ANL[[g_var]]), "NA"), |
|
| 530 | +608 | ! |
- new_col_name = new_col_name+ env = list(g_var = g_var) |
|
| 531 | +609 |
- )+ ) |
||
| 532 | +610 |
- )+ ) |
||
| 533 | +611 |
- )+ } |
||
| 534 | +612 |
- )+ |
||
| 535 | +613 | ! |
- qenv+ if (length(s_var) > 0) {
+ |
+ |
| 614 | +! | +
+ validate(+ |
+ ||
| 615 | +! | +
+ need(+ |
+ ||
| 616 | +! | +
+ inherits(ANL[[s_var]], c("integer", "factor", "character")),
+ |
+ ||
| 617 | +! | +
+ "Stratify by variable must be `factor`, `character`, or `integer`" |
||
| 536 | +618 |
- })+ ) |
||
| 537 | +619 |
-
+ ) |
||
| 538 | +620 | ! |
- selected_vars <- reactive({
+ qenv <- teal.code::eval_code( |
|
| 539 | +621 | ! |
- req(input$variables_select)+ qenv, |
|
| 540 | +622 | ! |
- keys <- data_keys()+ substitute( |
|
| 541 | +623 | ! |
- vars <- unique(c(keys, input$variables_select))+ expr = ANL[[s_var]] <- forcats::fct_na_value_to_level(as.factor(ANL[[s_var]]), "NA"), |
|
| 542 | +624 | ! |
- vars+ env = list(s_var = s_var) |
|
| 543 | +625 |
- })+ ) |
||
| 544 | +626 | ++ |
+ )+ |
+ |
| 627 | ++ |
+ }+ |
+ ||
| 628 | ||||
| 545 | +629 | ! |
- vars_summary <- reactive({
+ validate(need(is.numeric(ANL[[dist_var]]), "Please select a numeric variable.")) |
|
| 546 | +630 | ! |
- na_count <- data_r() %>%+ teal::validate_has_data(ANL, 1, complete = TRUE) |
|
| 547 | -! | +|||
| 631 | +
- sapply(function(x) mean(is.na(x)), USE.NAMES = TRUE) %>%+ |
|||
| 548 | +632 | ! |
- sort(decreasing = TRUE)+ if (length(t_dist) != 0) {
|
|
| 549 | -+ | |||
| 633 | +! |
-
+ map_distr_nams <- list( |
||
| 550 | +634 | ! |
- tibble::tibble(+ normal = c("mean", "sd"),
|
|
| 551 | +635 | ! |
- key = names(na_count),+ lognormal = c("meanlog", "sdlog"),
|
|
| 552 | +636 | ! |
- value = unname(na_count),+ gamma = c("shape", "rate"),
|
|
| 553 | +637 | ! |
- label = cut(na_count, breaks = seq(from = 0, to = 1, by = 0.1), include.lowest = TRUE)+ unif = c("min", "max")
|
|
| 554 | +638 |
- )+ ) |
||
| 555 | -+ | |||
| 639 | +! |
- })+ params_names_raw <- map_distr_nams[[t_dist]] |
||
| 556 | +640 | |||
| 557 | +641 | ! |
- output$variables <- renderUI({
+ qenv <- teal.code::eval_code( |
|
| 558 | +642 | ! |
- choices <- split(x = vars_summary()$key, f = vars_summary()$label, drop = TRUE) %>% rev()+ qenv, |
|
| 559 | +643 | ! |
- selected <- choices <- unname(unlist(choices))+ substitute( |
|
| 560 | -+ | |||
| 644 | +! |
-
+ expr = {
|
||
| 561 | +645 | ! |
- teal.widgets::optionalSelectInput(+ params <- as.list(c(dist_param1, dist_param2)) |
|
| 562 | +646 | ! |
- ns("variables_select"),
+ names(params) <- params_names_raw |
|
| 563 | -! | +|||
| 647 | +
- label = "Select variables",+ }, |
|||
| 564 | +648 | ! |
- label_help = HTML(paste0("Dataset: ", tags$code(dataname))),
+ env = list( |
|
| 565 | +649 | ! |
- choices = teal.transform::variable_choices(data_r(), choices),+ dist_param1 = dist_param1, |
|
| 566 | +650 | ! |
- selected = selected,+ dist_param2 = dist_param2, |
|
| 567 | +651 | ! |
- multiple = TRUE+ params_names_raw = params_names_raw |
|
| 568 | +652 |
- )+ ) |
||
| 569 | +653 |
- })+ ) |
||
| 570 | +654 | ++ |
+ )+ |
+ |
| 655 | ++ |
+ }+ |
+ ||
| 656 | ||||
| 571 | +657 | ! |
- observeEvent(input$filter_na, {
+ if (length(s_var) == 0 && length(g_var) == 0) {
|
|
| 572 | +658 | ! |
- choices <- vars_summary() %>%+ qenv <- teal.code::eval_code( |
|
| 573 | +659 | ! |
- dplyr::select(!!as.name("key")) %>%
+ qenv, |
|
| 574 | +660 | ! |
- getElement(name = 1)+ substitute( |
|
| 575 | -+ | |||
| 661 | +! |
-
+ expr = {
|
||
| 576 | +662 | ! |
- selected <- vars_summary() %>%+ summary_table <- ANL %>% |
|
| 577 | +663 | ! |
- dplyr::filter(!!as.name("value") > 0) %>%
+ dplyr::summarise( |
|
| 578 | +664 | ! |
- dplyr::select(!!as.name("key")) %>%
+ min = round(min(dist_var_name, na.rm = TRUE), roundn), |
|
| 579 | +665 | ! |
- getElement(name = 1)+ median = round(stats::median(dist_var_name, na.rm = TRUE), roundn), |
|
| 580 | -+ | |||
| 666 | +! |
-
+ mean = round(mean(dist_var_name, na.rm = TRUE), roundn), |
||
| 581 | +667 | ! |
- teal.widgets::updateOptionalSelectInput(+ max = round(max(dist_var_name, na.rm = TRUE), roundn), |
|
| 582 | +668 | ! |
- session = session,+ sd = round(stats::sd(dist_var_name, na.rm = TRUE), roundn), |
|
| 583 | +669 | ! |
- inputId = "variables_select",+ count = dplyr::n()+ |
+ |
| 670 | ++ |
+ )+ |
+ ||
| 671 | ++ |
+ }, |
||
| 584 | +672 | ! |
- choices = teal.transform::variable_choices(data_r()),+ env = list( |
|
| 585 | +673 | ! |
- selected = restoreInput(ns("variables_select"), selected)
+ dist_var_name = as.name(dist_var),+ |
+ |
| 674 | +! | +
+ roundn = roundn |
||
| 586 | +675 |
- )+ ) |
||
| 587 | +676 |
- })+ ) |
||
| 588 | +677 |
-
+ )+ |
+ ||
| 678 | ++ |
+ } else {
|
||
| 589 | +679 | ! |
- output$group_by_var_ui <- renderUI({
+ qenv <- teal.code::eval_code( |
|
| 590 | +680 | ! |
- all_choices <- teal.transform::variable_choices(data_r())+ qenv, |
|
| 591 | +681 | ! |
- cat_choices <- all_choices[!sapply(data_r(), function(x) is.numeric(x) || inherits(x, "POSIXct"))]+ substitute( |
|
| 592 | +682 | ! |
- validate(+ expr = {
|
|
| 593 | +683 | ! |
- need(cat_choices, "Dataset does not have any non-numeric or non-datetime variables to use to group data with")+ strata_vars <- strata_vars_raw |
|
| 594 | -+ | |||
| 684 | +! |
- )+ summary_table <- ANL %>% |
||
| 595 | +685 | ! |
- teal.widgets::optionalSelectInput(+ dplyr::group_by_at(dplyr::vars(dplyr::any_of(strata_vars))) %>% |
|
| 596 | +686 | ! |
- ns("group_by_var"),
+ dplyr::summarise( |
|
| 597 | +687 | ! |
- label = "Group by variable",+ min = round(min(dist_var_name, na.rm = TRUE), roundn), |
|
| 598 | +688 | ! |
- choices = cat_choices,+ median = round(stats::median(dist_var_name, na.rm = TRUE), roundn), |
|
| 599 | +689 | ! |
- selected = `if`(+ mean = round(mean(dist_var_name, na.rm = TRUE), roundn), |
|
| 600 | +690 | ! |
- is.null(isolate(input$group_by_var)),+ max = round(max(dist_var_name, na.rm = TRUE), roundn), |
|
| 601 | +691 | ! |
- cat_choices[1],+ sd = round(stats::sd(dist_var_name, na.rm = TRUE), roundn), |
|
| 602 | +692 | ! |
- isolate(input$group_by_var)+ count = dplyr::n() |
|
| 603 | +693 |
- ),- |
- ||
| 604 | -! | -
- multiple = FALSE,+ ) |
||
| 605 | +694 | ! |
- label_help = paste0("Dataset: ", dataname)
+ summary_table # used to display table when running show-r-code code |
|
| 606 | +695 |
- )+ }, |
||
| 607 | -+ | |||
| 696 | +! |
- })+ env = list( |
||
| 608 | -+ | |||
| 697 | +! |
-
+ dist_var_name = dist_var_name, |
||
| 609 | +698 | ! |
- output$group_by_vals_ui <- renderUI({
+ strata_vars_raw = c(g_var, s_var), |
|
| 610 | +699 | ! |
- req(input$group_by_var)+ roundn = roundn |
|
| 611 | +700 |
-
+ ) |
||
| 612 | -! | +|||
| 701 | +
- choices <- teal.transform::value_choices(data_r(), input$group_by_var, input$group_by_var)+ ) |
|||
| 613 | -! | +|||
| 702 | +
- prev_choices <- isolate(input$group_by_vals)+ ) |
|||
| 614 | +703 |
-
+ } |
||
| 615 | +704 |
- # determine selected value based on filtered data+ }) |
||
| 616 | +705 |
- # display those previously selected values that are still available+ + |
+ ||
| 706 | ++ |
+ # distplot qenv ---- |
||
| 617 | +707 | ! |
- selected <- if (!is.null(prev_choices) && any(prev_choices %in% choices)) {
+ dist_q <- eventReactive( |
|
| 618 | +708 | ! |
- prev_choices[match(choices[choices %in% prev_choices], prev_choices)]+ eventExpr = {
|
|
| 619 | +709 | ! |
- } else if (+ common_q() |
|
| 620 | +710 | ! |
- !is.null(prev_choices) &&+ input$scales_type |
|
| 621 | +711 | ! |
- !any(prev_choices %in% choices) &&+ input$main_type |
|
| 622 | +712 | ! |
- isolate(prev_group_by_var()) == input$group_by_var+ input$bins |
|
| 623 | -+ | |||
| 713 | +! |
- ) {
+ input$add_dens |
||
| 624 | -+ | |||
| 714 | +! |
- # if not any previously selected value is available and the grouping variable is the same,+ is.null(input$ggtheme) |
||
| 625 | +715 |
- # then display NULL+ }, |
||
| 626 | +716 | ! |
- NULL+ valueExpr = {
|
|
| 627 | -+ | |||
| 717 | +! |
- } else {
+ dist_var <- merge_vars()$dist_var |
||
| 628 | -+ | |||
| 718 | +! |
- # if new grouping variable (i.e. not any previously selected value is available),+ s_var <- merge_vars()$s_var |
||
| 629 | -+ | |||
| 719 | +! |
- # then display all choices+ g_var <- merge_vars()$g_var |
||
| 630 | +720 | ! |
- choices+ dist_var_name <- merge_vars()$dist_var_name |
|
| 631 | -+ | |||
| 721 | +! |
- }+ s_var_name <- merge_vars()$s_var_name |
||
| 632 | -+ | |||
| 722 | +! |
-
+ g_var_name <- merge_vars()$g_var_name |
||
| 633 | +723 | ! |
- prev_group_by_var(input$group_by_var) # set current group_by_var+ t_dist <- input$t_dist |
|
| 634 | +724 | ! |
- validate(need(length(choices) < 100, "Please select group-by variable with fewer than 100 unique values"))+ dist_param1 <- input$dist_param1 |
|
| 635 | -+ | |||
| 725 | +! |
-
+ dist_param2 <- input$dist_param2 |
||
| 636 | -! | +|||
| 726 | +
- teal.widgets::optionalSelectInput(+ |
|||
| 637 | +727 | ! |
- ns("group_by_vals"),
+ scales_type <- input$scales_type |
|
| 638 | -! | +|||
| 728 | +
- label = "Filter levels",+ |
|||
| 639 | +729 | ! |
- choices = choices,+ ndensity <- 512 |
|
| 640 | +730 | ! |
- selected = selected,+ main_type_var <- input$main_type |
|
| 641 | +731 | ! |
- multiple = TRUE,+ bins_var <- input$bins |
|
| 642 | +732 | ! |
- label_help = paste0("Dataset: ", dataname)
- |
- |
| 643 | -- |
- )+ add_dens_var <- input$add_dens |
||
| 644 | -+ | |||
| 733 | +! |
- })+ ggtheme <- input$ggtheme |
||
| 645 | +734 | |||
| 646 | +735 | ! |
- summary_plot_q <- reactive({
+ teal::validate_inputs(iv_dist) |
|
| 647 | -! | +|||
| 736 | +
- req(input$summary_type == "Summary") # needed to trigger show r code update on tab change+ |
|||
| 648 | +737 | ! |
- teal::validate_has_data(data_r(), 1)+ qenv <- common_q() |
|
| 649 | +738 | |||
| 650 | +739 | ! |
- qenv <- common_code_q()+ m_type <- if (main_type_var == "Density") "density" else "count" |
|
| 651 | +740 | |||
| 652 | +741 | ! |
- if (input$any_na) {
+ plot_call <- if (length(s_var) == 0 && length(g_var) == 0) {
|
|
| 653 | +742 | ! |
- new_col_name <- "**anyna**"+ substitute( |
|
| 654 | +743 | ! |
- qenv <- teal.code::eval_code(+ expr = ggplot(ANL, aes(dist_var_name)) + |
|
| 655 | +744 | ! |
- qenv,+ geom_histogram( |
|
| 656 | +745 | ! |
- substitute(+ position = "identity", aes(y = after_stat(m_type)), bins = bins_var, alpha = 0.3 |
|
| 657 | -! | +|||
| 746 | +
- expr = ANL[[new_col_name]] <- ifelse(rowSums(is.na(ANL)) > 0, NA, FALSE),+ ), |
|||
| 658 | +747 | ! |
- env = list(new_col_name = new_col_name)- |
- |
| 659 | -- |
- )+ env = list( |
||
| 660 | -+ | |||
| 748 | +! |
- )+ m_type = as.name(m_type), bins_var = bins_var, dist_var_name = as.name(dist_var) |
||
| 661 | +749 |
- }+ ) |
||
| 662 | +750 |
-
+ ) |
||
| 663 | +751 | ! |
- qenv <- teal.code::eval_code(+ } else if (length(s_var) != 0 && length(g_var) == 0) {
|
|
| 664 | +752 | ! |
- qenv,+ substitute( |
|
| 665 | +753 | ! |
- substitute(+ expr = ggplot(ANL, aes(dist_var_name, col = s_var_name)) + |
|
| 666 | +754 | ! |
- expr = analysis_vars <- setdiff(colnames(ANL), data_keys),+ geom_histogram( |
|
| 667 | +755 | ! |
- env = list(data_keys = data_keys())+ position = "identity", aes(y = after_stat(m_type), fill = s_var), bins = bins_var, alpha = 0.3 |
|
| 668 | +756 |
- )+ ), |
||
| 669 | -+ | |||
| 757 | +! |
- ) %>%+ env = list( |
||
| 670 | +758 | ! |
- teal.code::eval_code(+ m_type = as.name(m_type), |
|
| 671 | +759 | ! |
- substitute(+ bins_var = bins_var, |
|
| 672 | +760 | ! |
- expr = summary_plot_obs <- data_frame_call[, analysis_vars] %>%+ dist_var_name = dist_var_name, |
|
| 673 | +761 | ! |
- dplyr::summarise_all(list(function(x) sum(is.na(x)))) %>%+ s_var = as.name(s_var), |
|
| 674 | +762 | ! |
- tidyr::pivot_longer(dplyr::everything(), names_to = "col", values_to = "n_na") %>%+ s_var_name = s_var_name |
|
| 675 | -! | +|||
| 763 | +
- dplyr::mutate(n_not_na = nrow(ANL) - n_na) %>%+ ) |
|||
| 676 | -! | +|||
| 764 | +
- tidyr::pivot_longer(-col, names_to = "isna", values_to = "n") %>%+ ) |
|||
| 677 | +765 | ! |
- dplyr::mutate(isna = isna == "n_na", n_pct = n / nrow(ANL) * 100),+ } else if (length(s_var) == 0 && length(g_var) != 0) {
|
|
| 678 | +766 | ! |
- env = list(data_frame_call = if (!inherits(data_r(), "tbl_df")) {
+ req(scales_type) |
|
| 679 | +767 | ! |
- quote(tibble::as_tibble(ANL))+ substitute( |
|
| 680 | -+ | |||
| 768 | +! |
- } else {
+ expr = ggplot(ANL[ANL[[g_var]] != "NA", ], aes(dist_var_name)) + |
||
| 681 | +769 | ! |
- quote(ANL)+ geom_histogram( |
|
| 682 | -+ | |||
| 770 | +! |
- })+ position = "identity", aes(y = after_stat(m_type)), bins = bins_var, alpha = 0.3 |
||
| 683 | +771 |
- )+ ) + |
||
| 684 | -+ | |||
| 772 | +! |
- ) %>%+ facet_wrap(~g_var_name, ncol = 1, scales = scales_raw), |
||
| 685 | -+ | |||
| 773 | +! |
- # x axis ordering according to number of missing values and alphabet+ env = list( |
||
| 686 | +774 | ! |
- teal.code::eval_code(+ m_type = as.name(m_type), |
|
| 687 | +775 | ! |
- quote(+ bins_var = bins_var, |
|
| 688 | +776 | ! |
- expr = x_levels <- dplyr::filter(summary_plot_obs, isna) %>%+ dist_var_name = dist_var_name, |
|
| 689 | +777 | ! |
- dplyr::arrange(n_pct, dplyr::desc(col)) %>%+ g_var = g_var, |
|
| 690 | +778 | ! |
- dplyr::pull(col) %>%+ g_var_name = g_var_name, |
|
| 691 | +779 | ! |
- create_cols_labels()+ scales_raw = tolower(scales_type) |
|
| 692 | +780 |
- )+ ) |
||
| 693 | +781 |
- )+ ) |
||
| 694 | +782 |
-
+ } else {
|
||
| 695 | -+ | |||
| 783 | +! |
- # always set "**anyna**" level as the last one+ req(scales_type) |
||
| 696 | +784 | ! |
- if (isolate(input$any_na)) {
+ substitute( |
|
| 697 | +785 | ! |
- qenv <- teal.code::eval_code(+ expr = ggplot(ANL[ANL[[g_var]] != "NA", ], aes(dist_var_name, col = s_var_name)) + |
|
| 698 | +786 | ! |
- qenv,+ geom_histogram( |
|
| 699 | +787 | ! |
- quote(x_levels <- c(setdiff(x_levels, "**anyna**"), "**anyna**"))+ position = "identity", |
|
| 700 | -+ | |||
| 788 | +! |
- )+ aes(y = after_stat(m_type), fill = s_var), bins = bins_var, alpha = 0.3 |
||
| 701 | +789 |
- }+ ) + |
||
| 702 | -+ | |||
| 790 | +! |
-
+ facet_wrap(~g_var_name, ncol = 1, scales = scales_raw), |
||
| 703 | +791 | ! |
- dev_ggplot2_args <- teal.widgets::ggplot2_args(+ env = list( |
|
| 704 | +792 | ! |
- labs = list(x = "Variable", y = "Missing observations"),+ m_type = as.name(m_type), |
|
| 705 | +793 | ! |
- theme = list(legend.position = "bottom", axis.text.x = quote(element_text(angle = 45, hjust = 1)))+ bins_var = bins_var, |
|
| 706 | -+ | |||
| 794 | +! |
- )+ dist_var_name = dist_var_name, |
||
| 707 | -+ | |||
| 795 | +! |
-
+ g_var = g_var, |
||
| 708 | +796 | ! |
- all_ggplot2_args <- teal.widgets::resolve_ggplot2_args(+ s_var = as.name(s_var), |
|
| 709 | +797 | ! |
- user_plot = ggplot2_args[["Summary Obs"]],+ g_var_name = g_var_name, |
|
| 710 | +798 | ! |
- user_default = ggplot2_args$default,+ s_var_name = s_var_name, |
|
| 711 | +799 | ! |
- module_plot = dev_ggplot2_args+ scales_raw = tolower(scales_type) |
|
| 712 | +800 |
- )+ ) |
||
| 713 | +801 | ++ |
+ )+ |
+ |
| 802 | ++ |
+ }+ |
+ ||
| 803 | ||||
| 714 | +804 | ! |
- parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(+ if (add_dens_var) {
|
|
| 715 | +805 | ! |
- all_ggplot2_args,+ plot_call <- substitute( |
|
| 716 | +806 | ! |
- ggtheme = input$ggtheme+ expr = plot_call + |
|
| 717 | -+ | |||
| 807 | +! |
- )+ stat_density( |
||
| 718 | -+ | |||
| 808 | +! |
-
+ aes(y = after_stat(const * m_type2)), |
||
| 719 | +809 | ! |
- qenv <- teal.code::eval_code(+ geom = "line", |
|
| 720 | +810 | ! |
- qenv,+ position = "identity", |
|
| 721 | +811 | ! |
- substitute(+ alpha = 0.5, |
|
| 722 | +812 | ! |
- p1 <- summary_plot_obs %>%+ size = 2, |
|
| 723 | +813 | ! |
- ggplot() ++ n = ndensity+ |
+ |
| 814 | ++ |
+ ), |
||
| 724 | +815 | ! |
- aes(+ env = list( |
|
| 725 | +816 | ! |
- x = factor(create_cols_labels(col), levels = x_levels),+ plot_call = plot_call, |
|
| 726 | +817 | ! |
- y = n_pct,+ const = if (main_type_var == "Density") {
|
|
| 727 | +818 | ! |
- fill = isna+ 1 |
|
| 728 | +819 |
- ) ++ } else {
|
||
| 729 | +820 | ! |
- geom_bar(position = "fill", stat = "identity") ++ diff(range(qenv[["ANL"]][[dist_var]], na.rm = TRUE)) / bins_var |
|
| 730 | -! | +|||
| 821 | +
- scale_fill_manual(+ }, |
|||
| 731 | +822 | ! |
- name = "",+ m_type2 = if (main_type_var == "Density") as.name("density") else as.name("count"),
|
|
| 732 | +823 | ! |
- values = c("grey90", c(getOption("ggplot2.discrete.colour")[2], "#ff2951ff")[1]),
+ ndensity = ndensity |
|
| 733 | -! | +|||
| 824 | +
- labels = c("Present", "Missing")
+ ) |
|||
| 734 | +825 |
- ) ++ ) |
||
| 735 | -! | +|||
| 826 | +
- scale_y_continuous(+ } |
|||
| 736 | -! | +|||
| 827 | +
- labels = scales::percent_format(),+ |
|||
| 737 | +828 | ! |
- breaks = seq(0, 1, by = 0.1),+ if (length(t_dist) != 0 && main_type_var == "Density" && length(g_var) == 0 && length(s_var) == 0) {
|
|
| 738 | +829 | ! |
- expand = c(0, 0)- |
- |
| 739 | -- |
- ) ++ qenv <- teal.code::eval_code( |
||
| 740 | +830 | ! |
- geom_text(+ qenv, |
|
| 741 | +831 | ! |
- aes(label = ifelse(isna == TRUE, sprintf("%d [%.02f%%]", n, n_pct), ""), y = 1),
+ substitute( |
|
| 742 | +832 | ! |
- hjust = 1,+ df_params <- as.data.frame(append(params, list(name = t_dist))), |
|
| 743 | +833 | ! |
- color = "black"+ env = list(t_dist = t_dist) |
|
| 744 | +834 |
- ) ++ ) |
||
| 745 | -! | +|||
| 835 | +
- labs ++ ) |
|||
| 746 | +836 | ! |
- ggthemes ++ datas <- quote(data.frame(x = 0.7, y = 1, tb = I(list(df_params = df_params)))) |
|
| 747 | +837 | ! |
- themes ++ label <- quote(tb)+ |
+ |
| 838 | ++ | + | ||
| 748 | +839 | ! |
- coord_flip(),+ plot_call <- substitute( |
|
| 749 | +840 | ! |
- env = list(+ expr = plot_call + ggpp::geom_table_npc( |
|
| 750 | +841 | ! |
- labs = parsed_ggplot2_args$labs,+ data = data, |
|
| 751 | +842 | ! |
- themes = parsed_ggplot2_args$theme,+ aes(npcx = x, npcy = y, label = label), |
|
| 752 | +843 | ! |
- ggthemes = parsed_ggplot2_args$ggtheme+ hjust = 0, vjust = 1, size = 4 |
|
| 753 | +844 |
- )+ ),+ |
+ ||
| 845 | +! | +
+ env = list(plot_call = plot_call, data = datas, label = label) |
||
| 754 | +846 |
- )+ ) |
||
| 755 | +847 |
- )+ } |
||
| 756 | +848 | |||
| 757 | +849 | ! |
- if (isTRUE(input$if_patients_plot)) {
+ if ( |
|
| 758 | +850 | ! |
- qenv <- teal.code::eval_code(+ length(s_var) == 0 && |
|
| 759 | +851 | ! |
- qenv,+ length(g_var) == 0 && |
|
| 760 | +852 | ! |
- substitute(+ main_type_var == "Density" && |
|
| 761 | +853 | ! |
- expr = parent_keys <- keys,+ length(t_dist) != 0 && |
|
| 762 | +854 | ! |
- env = list(keys = data_parent_keys())- |
- |
| 763 | -- |
- )+ main_type_var == "Density" |
||
| 764 | +855 |
- ) %>%- |
- ||
| 765 | -! | -
- teal.code::eval_code(quote(ndistinct_subjects <- dplyr::n_distinct(ANL[, parent_keys]))) %>%+ ) {
|
||
| 766 | +856 | ! |
- teal.code::eval_code(+ map_dist <- stats::setNames( |
|
| 767 | +857 | ! |
- quote(+ c("dnorm", "dlnorm", "dgamma", "dunif"),
|
|
| 768 | +858 | ! |
- summary_plot_patients <- ANL[, c(parent_keys, analysis_vars)] %>%+ c("normal", "lognormal", "gamma", "unif")
|
|
| 769 | -! | +|||
| 859 | +
- dplyr::group_by_at(parent_keys) %>%+ ) |
|||
| 770 | +860 | ! |
- dplyr::summarise_all(anyNA) %>%+ plot_call <- substitute( |
|
| 771 | +861 | ! |
- tidyr::pivot_longer(cols = !dplyr::all_of(parent_keys), names_to = "col", values_to = "anyna") %>%+ expr = plot_call + stat_function( |
|
| 772 | +862 | ! |
- dplyr::group_by_at(c("col")) %>%
+ data = data.frame(x = range(ANL[[dist_var]]), color = mapped_dist), |
|
| 773 | +863 | ! |
- dplyr::summarise(count_na = sum(anyna)) %>%+ aes(x, color = color), |
|
| 774 | +864 | ! |
- dplyr::mutate(count_not_na = ndistinct_subjects - count_na) %>%+ fun = mapped_dist_name, |
|
| 775 | +865 | ! |
- tidyr::pivot_longer(-c(col), names_to = "isna", values_to = "n") %>%+ n = ndensity, |
|
| 776 | +866 | ! |
- dplyr::mutate(isna = isna == "count_na", n_pct = n / ndistinct_subjects * 100) %>%+ size = 2, |
|
| 777 | +867 | ! |
- dplyr::arrange_at(c("isna", "n"), .funs = dplyr::desc)
+ args = params |
|
| 778 | +868 |
- )+ ) + |
||
| 779 | -+ | |||
| 869 | +! |
- )+ scale_color_manual(values = stats::setNames("blue", mapped_dist), aesthetics = "color"),
|
||
| 780 | -+ | |||
| 870 | +! |
-
+ env = list( |
||
| 781 | +871 | ! |
- dev_ggplot2_args <- teal.widgets::ggplot2_args(+ plot_call = plot_call, |
|
| 782 | +872 | ! |
- labs = list(x = "", y = "Missing patients"),+ dist_var = dist_var, |
|
| 783 | +873 | ! |
- theme = list(+ ndensity = ndensity, |
|
| 784 | +874 | ! |
- legend.position = "bottom",+ mapped_dist = unname(map_dist[t_dist]), |
|
| 785 | +875 | ! |
- axis.text.x = quote(element_text(angle = 45, hjust = 1)),+ mapped_dist_name = as.name(unname(map_dist[t_dist])) |
|
| 786 | -! | +|||
| 876 | +
- axis.text.y = quote(element_blank())+ ) |
|||
| 787 | +877 |
) |
||
| 788 | +878 |
- )+ } |
||
| 789 | +879 | |||
| 790 | +880 | ! |
all_ggplot2_args <- teal.widgets::resolve_ggplot2_args( |
|
| 791 | -! | -
- user_plot = ggplot2_args[["Summary Patients"]],- |
- ||
| 792 | +881 | ! |
- user_default = ggplot2_args$default,+ user_plot = ggplot2_args[["Histogram"]], |
|
| 793 | +882 | ! |
- module_plot = dev_ggplot2_args+ user_default = ggplot2_args$default |
|
| 794 | +883 |
) |
||
| 795 | +884 | |||
| 796 | +885 | ! |
parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args( |
|
| 797 | +886 | ! |
all_ggplot2_args, |
|
| 798 | +887 | ! |
- ggtheme = input$ggtheme+ ggtheme = ggtheme |
|
| 799 | +888 |
) |
||
| 800 | +889 | |||
| 801 | +890 | ! |
- qenv <- teal.code::eval_code(+ teal.code::eval_code( |
|
| 802 | +891 | ! |
qenv, |
|
| 803 | +892 | ! |
substitute( |
|
| 804 | +893 | ! |
- p2 <- summary_plot_patients %>%+ expr = {
|
|
| 805 | +894 | ! |
- ggplot() ++ g <- plot_call |
|
| 806 | +895 | ! |
- aes_(+ print(g) |
|
| 807 | -! | +|||
| 896 | +
- x = ~ factor(create_cols_labels(col), levels = x_levels),+ }, |
|||
| 808 | +897 | ! |
- y = ~n_pct,+ env = list(plot_call = Reduce(function(x, y) call("+", x, y), c(plot_call, parsed_ggplot2_args)))
|
|
| 809 | -! | +|||
| 898 | +
- fill = ~isna+ ) |
|||
| 810 | +899 |
- ) ++ ) |
||
| 811 | -! | +|||
| 900 | +
- geom_bar(alpha = 1, stat = "identity", position = "fill") ++ } |
|||
| 812 | -! | +|||
| 901 | +
- scale_y_continuous(+ ) |
|||
| 813 | -! | +|||
| 902 | +
- labels = scales::percent_format(),+ |
|||
| 814 | -! | +|||
| 903 | +
- breaks = seq(0, 1, by = 0.1),+ # qqplot qenv ---- |
|||
| 815 | +904 | ! |
- expand = c(0, 0)+ qq_q <- eventReactive( |
|
| 816 | -+ | |||
| 905 | +! |
- ) ++ eventExpr = {
|
||
| 817 | +906 | ! |
- scale_fill_manual(+ common_q() |
|
| 818 | +907 | ! |
- name = "",+ input$scales_type |
|
| 819 | +908 | ! |
- values = c("grey90", c(getOption("ggplot2.discrete.colour")[2], "#ff2951ff")[1]),
+ input$qq_line |
|
| 820 | +909 | ! |
- labels = c("Present", "Missing")
+ is.null(input$ggtheme) |
|
| 821 | +910 |
- ) ++ }, |
||
| 822 | +911 | ! |
- geom_text(+ valueExpr = {
|
|
| 823 | +912 | ! |
- aes(label = ifelse(isna == TRUE, sprintf("%d [%.02f%%]", n, n_pct), ""), y = 1),
+ dist_var <- merge_vars()$dist_var |
|
| 824 | +913 | ! |
- hjust = 1,+ s_var <- merge_vars()$s_var |
|
| 825 | +914 | ! |
- color = "black"+ g_var <- merge_vars()$g_var |
|
| 826 | -+ | |||
| 915 | +! |
- ) ++ dist_var_name <- merge_vars()$dist_var_name |
||
| 827 | +916 | ! |
- labs ++ s_var_name <- merge_vars()$s_var_name |
|
| 828 | +917 | ! |
- ggthemes ++ g_var_name <- merge_vars()$g_var_name |
|
| 829 | +918 | ! |
- themes ++ t_dist <- input$t_dist |
|
| 830 | +919 | ! |
- coord_flip(),+ dist_param1 <- input$dist_param1 |
|
| 831 | +920 | ! |
- env = list(+ dist_param2 <- input$dist_param2 |
|
| 832 | -! | +|||
| 921 | +
- labs = parsed_ggplot2_args$labs,+ |
|||
| 833 | +922 | ! |
- themes = parsed_ggplot2_args$theme,+ scales_type <- input$scales_type |
|
| 834 | +923 | ! |
- ggthemes = parsed_ggplot2_args$ggtheme+ ggtheme <- input$ggtheme |
|
| 835 | +924 |
- )+ |
||
| 836 | -+ | |||
| 925 | +! |
- )+ teal::validate_inputs(iv_r_dist(), iv_dist) |
||
| 837 | +926 |
- ) %>%- |
- ||
| 838 | -! | -
- teal.code::eval_code(+ |
||
| 839 | +927 | ! |
- quote({
+ qenv <- common_q() |
|
| 840 | -! | +|||
| 928 | +
- g1 <- ggplotGrob(p1)+ |
|||
| 841 | +929 | ! |
- g2 <- ggplotGrob(p2)+ plot_call <- if (length(s_var) == 0 && length(g_var) == 0) {
|
|
| 842 | +930 | ! |
- g <- gridExtra::gtable_cbind(g1, g2, size = "first")+ substitute( |
|
| 843 | +931 | ! |
- g$heights <- grid::unit.pmax(g1$heights, g2$heights)+ expr = ggplot(ANL, aes_string(sample = dist_var)), |
|
| 844 | +932 | ! |
- grid::grid.newpage()- |
- |
| 845 | -- |
- })- |
- ||
| 846 | -- |
- )+ env = list(dist_var = dist_var) |
||
| 847 | -- |
- } else {
- |
- ||
| 848 | -! | +933 | +
- qenv <- teal.code::eval_code(+ ) |
|
| 849 | +934 | ! |
- qenv,+ } else if (length(s_var) != 0 && length(g_var) == 0) {
|
|
| 850 | +935 | ! |
- quote({
+ substitute( |
|
| 851 | +936 | ! |
- g <- ggplotGrob(p1)+ expr = ggplot(ANL, aes_string(sample = dist_var, color = s_var)), |
|
| 852 | +937 | ! |
- grid::grid.newpage()+ env = list(dist_var = dist_var, s_var = s_var) |
|
| 853 | +938 |
- })+ ) |
||
| 854 | -+ | |||
| 939 | +! |
- )+ } else if (length(s_var) == 0 && length(g_var) != 0) {
|
||
| 855 | -+ | |||
| 940 | +! |
- }+ substitute( |
||
| 856 | -+ | |||
| 941 | +! |
-
+ expr = ggplot(ANL[ANL[[g_var]] != "NA", ], aes_string(sample = dist_var)) + |
||
| 857 | +942 | ! |
- teal.code::eval_code(+ facet_wrap(~g_var_name, ncol = 1, scales = scales_raw), |
|
| 858 | +943 | ! |
- qenv,+ env = list( |
|
| 859 | +944 | ! |
- quote(grid::grid.draw(g))+ dist_var = dist_var, |
|
| 860 | -+ | |||
| 945 | +! |
- )+ g_var = g_var, |
||
| 861 | -+ | |||
| 946 | +! |
- })+ g_var_name = g_var_name, |
||
| 862 | -+ | |||
| 947 | +! |
-
+ scales_raw = tolower(scales_type) |
||
| 863 | -! | +|||
| 948 | +
- summary_plot_r <- reactive(summary_plot_q()[["g"]])+ ) |
|||
| 864 | +949 |
-
+ ) |
||
| 865 | -! | +|||
| 950 | +
- combination_cutoff_q <- reactive({
+ } else {
|
|||
| 866 | +951 | ! |
- req(common_code_q())+ substitute( |
|
| 867 | +952 | ! |
- teal.code::eval_code(+ expr = ggplot(ANL[ANL[[g_var]] != "NA", ], aes_string(sample = dist_var, color = s_var)) + |
|
| 868 | +953 | ! |
- common_code_q(),+ facet_wrap(~g_var_name, ncol = 1, scales = scales_raw), |
|
| 869 | +954 | ! |
- quote(+ env = list( |
|
| 870 | +955 | ! |
- combination_cutoff <- ANL %>%+ dist_var = dist_var, |
|
| 871 | +956 | ! |
- dplyr::mutate_all(is.na) %>%+ g_var = g_var, |
|
| 872 | +957 | ! |
- dplyr::group_by_all() %>%+ s_var = s_var, |
|
| 873 | +958 | ! |
- dplyr::tally() %>%+ g_var_name = g_var_name, |
|
| 874 | +959 | ! |
- dplyr::ungroup()+ scales_raw = tolower(scales_type) |
|
| 875 | +960 |
- )+ ) |
||
| 876 | +961 |
- )+ ) |
||
| 877 | +962 |
- })+ } |
||
| 878 | +963 | |||
| 879 | +964 | ! |
- output$cutoff <- renderUI({
+ map_dist <- stats::setNames( |
|
| 880 | +965 | ! |
- x <- combination_cutoff_q()[["combination_cutoff"]]$n+ c("qnorm", "qlnorm", "qgamma", "qunif"),
|
|
| 881 | -+ | |||
| 966 | +! |
-
+ c("normal", "lognormal", "gamma", "unif")
|
||
| 882 | +967 |
- # select 10-th from the top- |
- ||
| 883 | -! | -
- n <- length(x)+ ) |
||
| 884 | -! | +|||
| 968 | +
- idx <- max(1, n - 10)+ |
|||
| 885 | +969 | ! |
- prev_value <- isolate(input$combination_cutoff)+ plot_call <- substitute( |
|
| 886 | +970 | ! |
- value <- `if`(+ expr = plot_call + |
|
| 887 | +971 | ! |
- is.null(prev_value) || prev_value > max(x) || prev_value < min(x),+ stat_qq(distribution = mapped_dist, dparams = params), |
|
| 888 | +972 | ! |
- sort(x, partial = idx)[idx], prev_value+ env = list(plot_call = plot_call, mapped_dist = as.name(unname(map_dist[t_dist]))) |
|
| 889 | +973 |
- )+ ) |
||
| 890 | +974 | |||
| 891 | +975 | ! |
- teal.widgets::optionalSliderInputValMinMax(+ if (length(t_dist) != 0 && length(g_var) == 0 && length(s_var) == 0) {
|
|
| 892 | +976 | ! |
- ns("combination_cutoff"),
+ qenv <- teal.code::eval_code( |
|
| 893 | +977 | ! |
- "Combination cut-off",+ qenv, |
|
| 894 | +978 | ! |
- c(value, range(x))+ substitute( |
|
| 895 | -+ | |||
| 979 | +! |
- )+ df_params <- as.data.frame(append(params, list(name = t_dist))), |
||
| 896 | -+ | |||
| 980 | +! |
- })+ env = list(t_dist = t_dist) |
||
| 897 | +981 |
-
+ ) |
||
| 898 | -! | +|||
| 982 | +
- combination_plot_q <- reactive({
+ ) |
|||
| 899 | +983 | ! |
- req(input$summary_type == "Combinations", input$combination_cutoff, combination_cutoff_q())+ datas <- quote(data.frame(x = 0.7, y = 1, tb = I(list(df_params = df_params)))) |
|
| 900 | +984 | ! |
- teal::validate_has_data(data_r(), 1)+ label <- quote(tb) |
|
| 901 | +985 | |||
| 902 | +986 | ! |
- qenv <- teal.code::eval_code(+ plot_call <- substitute( |
|
| 903 | +987 | ! |
- combination_cutoff_q(),+ expr = plot_call + |
|
| 904 | +988 | ! |
- substitute(+ ggpp::geom_table_npc( |
|
| 905 | +989 | ! |
- expr = data_combination_plot_cutoff <- combination_cutoff %>%+ data = data, |
|
| 906 | +990 | ! |
- dplyr::filter(n >= combination_cutoff_value) %>%+ aes(npcx = x, npcy = y, label = label), |
|
| 907 | +991 | ! |
- dplyr::mutate(id = rank(-n, ties.method = "first")) %>%+ hjust = 0, |
|
| 908 | +992 | ! |
- tidyr::pivot_longer(-c(n, id), names_to = "key", values_to = "value") %>%+ vjust = 1, |
|
| 909 | +993 | ! |
- dplyr::arrange(n),+ size = 4+ |
+ |
| 994 | ++ |
+ ), |
||
| 910 | +995 | ! |
- env = list(combination_cutoff_value = input$combination_cutoff)+ env = list( |
|
| 911 | -+ | |||
| 996 | +! |
- )+ plot_call = plot_call, |
||
| 912 | -+ | |||
| 997 | +! |
- )+ data = datas, |
||
| 913 | -+ | |||
| 998 | +! |
-
+ label = label |
||
| 914 | +999 |
- # find keys in dataset not selected in the UI and remove them from dataset+ ) |
||
| 915 | -! | +|||
| 1000 | +
- keys_not_selected <- setdiff(data_keys(), input$variables_select)+ ) |
|||
| 916 | -! | +|||
| 1001 | +
- if (length(keys_not_selected) > 0) {
+ } |
|||
| 917 | -! | +|||
| 1002 | +
- qenv <- teal.code::eval_code(+ |
|||
| 918 | +1003 | ! |
- qenv,+ if (isTRUE(input$qq_line)) {
|
|
| 919 | +1004 | ! |
- substitute(+ plot_call <- substitute( |
|
| 920 | +1005 | ! |
- expr = data_combination_plot_cutoff <- data_combination_plot_cutoff %>%+ expr = plot_call + |
|
| 921 | +1006 | ! |
- dplyr::filter(!key %in% keys_not_selected),+ stat_qq_line(distribution = mapped_dist, dparams = params), |
|
| 922 | +1007 | ! |
- env = list(keys_not_selected = keys_not_selected)+ env = list(plot_call = plot_call, mapped_dist = as.name(unname(map_dist[t_dist]))) |
|
| 923 | +1008 |
) |
||
| 924 | +1009 |
- )+ } |
||
| 925 | +1010 |
- }+ |
||
| 926 | -+ | |||
| 1011 | +! |
-
+ all_ggplot2_args <- teal.widgets::resolve_ggplot2_args( |
||
| 927 | +1012 | ! |
- qenv <- teal.code::eval_code(+ user_plot = ggplot2_args[["QQplot"]], |
|
| 928 | +1013 | ! |
- qenv,+ user_default = ggplot2_args$default, |
|
| 929 | +1014 | ! |
- quote(+ module_plot = teal.widgets::ggplot2_args(labs = list(x = "theoretical", y = "sample"))+ |
+ |
| 1015 | ++ |
+ )+ |
+ ||
| 1016 | ++ | + | ||
| 930 | +1017 | ! |
- labels <- data_combination_plot_cutoff %>%+ parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args( |
|
| 931 | +1018 | ! |
- dplyr::filter(key == key[[1]]) %>%+ all_ggplot2_args, |
|
| 932 | +1019 | ! |
- getElement(name = 1)+ ggtheme = ggtheme |
|
| 933 | +1020 |
) |
||
| 934 | +1021 |
- )+ |
||
| 935 | -+ | |||
| 1022 | +! |
-
+ teal.code::eval_code( |
||
| 936 | +1023 | ! |
- dev_ggplot2_args1 <- teal.widgets::ggplot2_args(+ qenv, |
|
| 937 | +1024 | ! |
- labs = list(x = "", y = ""),+ substitute( |
|
| 938 | +1025 | ! |
- theme = list(+ expr = {
|
|
| 939 | +1026 | ! |
- legend.position = "bottom",+ g <- plot_call |
|
| 940 | +1027 | ! |
- axis.text.x = quote(element_blank())+ print(g) |
|
| 941 | +1028 | ++ |
+ },+ |
+ |
| 1029 | +! | +
+ env = list(plot_call = Reduce(function(x, y) call("+", x, y), c(plot_call, parsed_ggplot2_args)))
+ |
+ ||
| 1030 | ++ |
+ )+ |
+ ||
| 1031 |
) |
|||
| 942 | +1032 |
- )+ } |
||
| 943 | +1033 | ++ |
+ )+ |
+ |
| 1034 | ||||
| 1035 | ++ |
+ # test qenv ----+ |
+ ||
| 944 | +1036 | ! |
- all_ggplot2_args1 <- teal.widgets::resolve_ggplot2_args(+ test_q <- eventReactive( |
|
| 945 | +1037 | ! |
- user_plot = ggplot2_args[["Combinations Hist"]],+ ignoreNULL = FALSE, |
|
| 946 | +1038 | ! |
- user_default = ggplot2_args$default,+ eventExpr = {
|
|
| 947 | +1039 | ! |
- module_plot = dev_ggplot2_args1+ common_q() |
|
| 948 | -+ | |||
| 1040 | +! |
- )+ input$dist_param1 |
||
| 949 | -+ | |||
| 1041 | +! |
-
+ input$dist_param2 |
||
| 950 | +1042 | ! |
- parsed_ggplot2_args1 <- teal.widgets::parse_ggplot2_args(+ input$dist_tests |
|
| 951 | -! | +|||
| 1043 | +
- all_ggplot2_args1,+ }, |
|||
| 952 | +1044 | ! |
- ggtheme = "void"+ valueExpr = {
|
|
| 953 | +1045 |
- )+ # Create a private stack for this function only.+ |
+ ||
| 1046 | +! | +
+ ANL <- common_q()[["ANL"]] |
||
| 954 | +1047 | |||
| 955 | +1048 | ! |
- dev_ggplot2_args2 <- teal.widgets::ggplot2_args(+ dist_var <- merge_vars()$dist_var |
|
| 956 | +1049 | ! |
- labs = list(x = "", y = ""),+ s_var <- merge_vars()$s_var |
|
| 957 | +1050 | ! |
- theme = list(+ g_var <- merge_vars()$g_var |
|
| 958 | -! | +|||
| 1051 | +
- legend.position = "bottom",+ |
|||
| 959 | +1052 | ! |
- axis.text.x = quote(element_blank()),+ dist_var_name <- merge_vars()$dist_var_name |
|
| 960 | +1053 | ! |
- axis.ticks = quote(element_blank()),+ s_var_name <- merge_vars()$s_var_name |
|
| 961 | +1054 | ! |
- panel.grid.major = quote(element_blank())- |
- |
| 962 | -- |
- )- |
- ||
| 963 | -- |
- )+ g_var_name <- merge_vars()$g_var_name |
||
| 964 | +1055 | |||
| 965 | +1056 | ! |
- all_ggplot2_args2 <- teal.widgets::resolve_ggplot2_args(+ dist_param1 <- input$dist_param1 |
|
| 966 | +1057 | ! |
- user_plot = ggplot2_args[["Combinations Main"]],+ dist_param2 <- input$dist_param2 |
|
| 967 | +1058 | ! |
- user_default = ggplot2_args$default,+ dist_tests <- input$dist_tests |
|
| 968 | +1059 | ! |
- module_plot = dev_ggplot2_args2- |
- |
| 969 | -- |
- )+ t_dist <- input$t_dist |
||
| 970 | +1060 | |||
| 971 | +1061 | ! |
- parsed_ggplot2_args2 <- teal.widgets::parse_ggplot2_args(+ validate(need(dist_tests, "Please select a test")) |
|
| 972 | -! | +|||
| 1062 | +
- all_ggplot2_args2,+ |
|||
| 973 | +1063 | ! |
- ggtheme = input$ggtheme- |
- |
| 974 | -- |
- )+ teal::validate_inputs(iv_dist) |
||
| 975 | +1064 | |||
| 976 | +1065 | ! |
- teal.code::eval_code(+ if (length(s_var) > 0 || length(g_var) > 0) {
|
|
| 977 | +1066 | ! |
- qenv,+ counts <- ANL %>% |
|
| 978 | +1067 | ! |
- substitute(+ dplyr::group_by_at(dplyr::vars(dplyr::any_of(c(s_var, g_var)))) %>% |
|
| 979 | +1068 | ! |
- expr = {
+ dplyr::summarise(n = dplyr::n()) |
|
| 980 | -! | +|||
| 1069 | +
- p1 <- data_combination_plot_cutoff %>%+ |
|||
| 981 | +1070 | ! |
- dplyr::select(id, n) %>%+ validate(need(all(counts$n > 5), "Please select strata*group with at least 5 observation each.")) |
|
| 982 | -! | +|||
| 1071 | +
- dplyr::distinct() %>%+ } |
|||
| 983 | -! | +|||
| 1072 | +
- ggplot(aes(x = id, y = n)) ++ |
|||
| 984 | -! | +|||
| 1073 | +
- geom_bar(stat = "identity", fill = c(getOption("ggplot2.discrete.colour")[2], "#ff2951ff")[1]) +
+
|
|||
| 985 | +1074 | ! |
- geom_text(+ if (dist_tests %in% c( |
|
| 986 | +1075 | ! |
- aes(label = n),+ "t-test (two-samples, not paired)", |
|
| 987 | +1076 | ! |
- position = position_dodge(width = 0.9),+ "F-test", |
|
| 988 | +1077 | ! |
- vjust = -0.25+ "Kolmogorov-Smirnov (two-samples)" |
|
| 989 | +1078 |
- ) ++ )) {
|
||
| 990 | +1079 | ! |
- ylim(c(0, max(data_combination_plot_cutoff$n) * 1.5)) ++ if (length(g_var) == 0 && length(s_var) > 0) {
|
|
| 991 | +1080 | ! |
- labs1 ++ validate(need( |
|
| 992 | +1081 | ! |
- ggthemes1 ++ length(unique(ANL[[s_var]])) == 2, |
|
| 993 | +1082 | ! |
- themes1+ "Please select stratify variable with 2 levels." |
|
| 994 | +1083 |
-
+ )) |
||
| 995 | -! | +|||
| 1084 | +
- graph_number_rows <- length(unique(data_combination_plot_cutoff$id))+ } |
|||
| 996 | +1085 | ! |
- graph_number_cols <- nrow(data_combination_plot_cutoff) / graph_number_rows- |
- |
| 997 | -- |
-
+ if (length(g_var) > 0 && length(s_var) > 0) {
|
||
| 998 | +1086 | ! |
- p2 <- data_combination_plot_cutoff %>% ggplot() ++ validate(need( |
|
| 999 | +1087 | ! |
- aes(x = create_cols_labels(key), y = id - 0.5, fill = value) ++ all(stats::na.omit(as.vector( |
|
| 1000 | +1088 | ! |
- geom_tile(alpha = 0.85, height = 0.95) ++ tapply(ANL[[s_var]], list(ANL[[g_var]]), function(x) length(unique(x))) == 2 |
|
| 1001 | -! | +|||
| 1089 | +
- scale_fill_manual(+ ))), |
|||
| 1002 | +1090 | ! |
- name = "",+ "Please select stratify variable with 2 levels, per each group." |
|
| 1003 | -! | +|||
| 1091 | +
- values = c("grey90", c(getOption("ggplot2.discrete.colour")[2], "#ff2951ff")[1]),
+ )) |
|||
| 1004 | -! | +|||
| 1092 | +
- labels = c("Present", "Missing")
+ } |
|||
| 1005 | +1093 |
- ) ++ } |
||
| 1006 | -! | +|||
| 1094 | +
- geom_hline(yintercept = seq_len(1 + graph_number_rows) - 1) ++ |
|||
| 1007 | +1095 | ! |
- geom_vline(xintercept = seq_len(1 + graph_number_cols) - 0.5, linetype = "dotted") ++ map_dist <- stats::setNames( |
|
| 1008 | +1096 | ! |
- coord_flip() ++ c("pnorm", "plnorm", "pgamma", "punif"),
|
|
| 1009 | +1097 | ! |
- labs2 ++ c("normal", "lognormal", "gamma", "unif")
|
|
| 1010 | -! | +|||
| 1098 | +
- ggthemes2 ++ ) |
|||
| 1011 | +1099 | ! |
- themes2+ sks_args <- list( |
|
| 1012 | -+ | |||
| 1100 | +! |
-
+ test = quote(stats::ks.test), |
||
| 1013 | +1101 | ! |
- g1 <- ggplotGrob(p1)+ args = bquote(append(list(.[[.(dist_var)]], .(map_dist[t_dist])), params)), |
|
| 1014 | +1102 | ! |
- g2 <- ggplotGrob(p2)+ groups = c(g_var, s_var) |
|
| 1015 | +1103 |
-
+ ) |
||
| 1016 | +1104 | ! |
- g <- gridExtra::gtable_rbind(g1, g2, size = "last")+ ssw_args <- list( |
|
| 1017 | +1105 | ! |
- g$heights[7] <- grid::unit(0.2, "null") # rescale to get the bar chart smaller+ test = quote(stats::shapiro.test), |
|
| 1018 | +1106 | ! |
- grid::grid.newpage()+ args = bquote(list(.[[.(dist_var)]])), |
|
| 1019 | +1107 | ! |
- grid::grid.draw(g)+ groups = c(g_var, s_var) |
|
| 1020 | +1108 |
- },+ ) |
||
| 1021 | +1109 | ! |
- env = list(+ mfil_args <- list( |
|
| 1022 | +1110 | ! |
- labs1 = parsed_ggplot2_args1$labs,+ test = quote(stats::fligner.test), |
|
| 1023 | +1111 | ! |
- themes1 = parsed_ggplot2_args1$theme,+ args = bquote(list(.[[.(dist_var)]], .[[.(s_var)]])), |
|
| 1024 | +1112 | ! |
- ggthemes1 = parsed_ggplot2_args1$ggtheme,+ groups = c(g_var)+ |
+ |
| 1113 | ++ |
+ ) |
||
| 1025 | +1114 | ! |
- labs2 = parsed_ggplot2_args2$labs,+ sad_args <- list( |
|
| 1026 | +1115 | ! |
- themes2 = parsed_ggplot2_args2$theme,+ test = quote(goftest::ad.test), |
|
| 1027 | +1116 | ! |
- ggthemes2 = parsed_ggplot2_args2$ggtheme+ args = bquote(append(list(.[[.(dist_var)]], .(map_dist[t_dist])), params)), |
|
| 1028 | -+ | |||
| 1117 | +! |
- )+ groups = c(g_var, s_var) |
||
| 1029 | +1118 |
) |
||
| 1030 | -+ | |||
| 1119 | +! |
- )+ scvm_args <- list( |
||
| 1031 | -+ | |||
| 1120 | +! |
- })+ test = quote(goftest::cvm.test), |
||
| 1032 | -+ | |||
| 1121 | +! |
-
+ args = bquote(append(list(.[[.(dist_var)]], .(map_dist[t_dist])), params)), |
||
| 1033 | +1122 | ! |
- combination_plot_r <- reactive(combination_plot_q()[["g"]])+ groups = c(g_var, s_var) |
|
| 1034 | +1123 |
-
+ ) |
||
| 1035 | +1124 | ! |
- summary_table_q <- reactive({
+ manov_args <- list( |
|
| 1036 | +1125 | ! |
- req(+ test = quote(stats::aov), |
|
| 1037 | +1126 | ! |
- input$summary_type == "By Variable Levels", # needed to trigger show r code update on tab change+ args = bquote(list(stats::formula(.(dist_var_name) ~ .(s_var_name)), .)), |
|
| 1038 | +1127 | ! |
- common_code_q()+ groups = c(g_var) |
|
| 1039 | +1128 |
- )+ ) |
||
| 1040 | +1129 | ! |
- teal::validate_has_data(data_r(), 1)- |
- |
| 1041 | -- | - - | -||
| 1042 | -- |
- # extract the ANL dataset for use in further validation+ mt_args <- list( |
||
| 1043 | +1130 | ! |
- anl <- common_code_q()[["ANL"]]+ test = quote(stats::t.test), |
|
| 1044 | -+ | |||
| 1131 | +! |
-
+ args = bquote(unname(split(.[[.(dist_var)]], .[[.(s_var)]], drop = TRUE))), |
||
| 1045 | +1132 | ! |
- group_var <- input$group_by_var+ groups = c(g_var) |
|
| 1046 | -! | +|||
| 1133 | +
- validate(+ ) |
|||
| 1047 | +1134 | ! |
- need(+ mv_args <- list( |
|
| 1048 | +1135 | ! |
- is.null(group_var) ||+ test = quote(stats::var.test), |
|
| 1049 | +1136 | ! |
- length(unique(anl[[group_var]])) < 100,+ args = bquote(unname(split(.[[.(dist_var)]], .[[.(s_var)]], drop = TRUE))), |
|
| 1050 | +1137 | ! |
- "Please select group-by variable with fewer than 100 unique values"+ groups = c(g_var) |
|
| 1051 | +1138 |
) |
||
| 1052 | -- |
- )- |
- ||
| 1053 | -+ | |||
| 1139 | +! |
-
+ mks_args <- list( |
||
| 1054 | +1140 | ! |
- group_vals <- input$group_by_vals+ test = quote(stats::ks.test), |
|
| 1055 | +1141 | ! |
- variables_select <- input$variables_select+ args = bquote(unname(split(.[[.(dist_var)]], .[[.(s_var)]], drop = TRUE))), |
|
| 1056 | +1142 | ! |
- vars <- unique(variables_select, group_var)+ groups = c(g_var) |
|
| 1057 | -! | +|||
| 1143 | +
- count_type <- input$count_type+ ) |
|||
| 1058 | +1144 | |||
| 1059 | +1145 | ! |
- if (!is.null(selected_vars()) && length(selected_vars()) != ncol(anl)) {
+ tests_base <- switch(dist_tests, |
|
| 1060 | +1146 | ! |
- variables <- selected_vars()+ "Kolmogorov-Smirnov (one-sample)" = sks_args, |
|
| 1061 | -+ | |||
| 1147 | +! |
- } else {
+ "Shapiro-Wilk" = ssw_args, |
||
| 1062 | +1148 | ! |
- variables <- colnames(anl)+ "Fligner-Killeen" = mfil_args, |
|
| 1063 | -+ | |||
| 1149 | +! |
- }+ "one-way ANOVA" = manov_args, |
||
| 1064 | -+ | |||
| 1150 | +! |
-
+ "t-test (two-samples, not paired)" = mt_args, |
||
| 1065 | +1151 | ! |
- summ_fn <- if (input$count_type == "counts") {
+ "F-test" = mv_args, |
|
| 1066 | +1152 | ! |
- function(x) sum(is.na(x))+ "Kolmogorov-Smirnov (two-samples)" = mks_args, |
|
| 1067 | -+ | |||
| 1153 | +! |
- } else {
+ "Anderson-Darling (one-sample)" = sad_args, |
||
| 1068 | +1154 | ! |
- function(x) round(sum(is.na(x)) / length(x), 4)+ "Cramer-von Mises (one-sample)" = scvm_args |
|
| 1069 | +1155 |
- }+ ) |
||
| 1070 | +1156 | |||
| 1071 | +1157 | ! |
- qenv <- common_code_q()+ env <- list( |
|
| 1072 | -+ | |||
| 1158 | +! |
-
+ t_test = t_dist, |
||
| 1073 | +1159 | ! |
- if (!is.null(group_var)) {
+ dist_var = dist_var, |
|
| 1074 | +1160 | ! |
- qenv <- teal.code::eval_code(+ g_var = g_var, |
|
| 1075 | +1161 | ! |
- qenv,+ s_var = s_var, |
|
| 1076 | +1162 | ! |
- substitute(+ args = tests_base$args, |
|
| 1077 | +1163 | ! |
- expr = {
+ groups = tests_base$groups, |
|
| 1078 | +1164 | ! |
- summary_data <- ANL %>%+ test = tests_base$test, |
|
| 1079 | +1165 | ! |
- dplyr::mutate(group_var_name := forcats::fct_na_value_to_level(as.factor(group_var_name), "NA")) %>%+ dist_var_name = dist_var_name, |
|
| 1080 | +1166 | ! |
- dplyr::group_by_at(group_var) %>%+ g_var_name = g_var_name, |
|
| 1081 | +1167 | ! |
- dplyr::filter(group_var_name %in% group_vals)+ s_var_name = s_var_name |
|
| 1082 | +1168 | ++ |
+ )+ |
+ |
| 1169 | ||||
| 1083 | +1170 | ! |
- count_data <- dplyr::summarise(summary_data, n = dplyr::n())+ qenv <- common_q() |
|
| 1084 | +1171 | |||
| 1085 | +1172 | ! |
- summary_data <- dplyr::summarise_all(summary_data, summ_fn) %>%+ if (length(s_var) == 0 && length(g_var) == 0) {
|
|
| 1086 | +1173 | ! |
- dplyr::mutate(group_var_name := paste0(group_var, ":", group_var_name, "(N=", count_data$n, ")")) %>%+ qenv <- teal.code::eval_code( |
|
| 1087 | +1174 | ! |
- tidyr::pivot_longer(!dplyr::all_of(group_var), names_to = "Variable", values_to = "out") %>%+ qenv, |
|
| 1088 | +1175 | ! |
- tidyr::pivot_wider(names_from = group_var, values_from = "out") %>%+ substitute( |
|
| 1089 | +1176 | ! |
- dplyr::mutate(`Variable label` = create_cols_labels(Variable, just_label = TRUE), .after = Variable)+ expr = {
|
|
| 1090 | -+ | |||
| 1177 | +! |
- },+ test_stats <- ANL %>% |
||
| 1091 | +1178 | ! |
- env = list(+ dplyr::select(dist_var) %>% |
|
| 1092 | +1179 | ! |
- group_var = group_var, group_var_name = as.name(group_var), group_vals = group_vals, summ_fn = summ_fn+ with(., broom::glance(do.call(test, args))) %>%+ |
+ |
| 1180 | +! | +
+ dplyr::mutate_if(is.numeric, round, 3) |
||
| 1093 | +1181 |
- )+ },+ |
+ ||
| 1182 | +! | +
+ env = env |
||
| 1094 | +1183 |
- )+ ) |
||
| 1095 | +1184 |
- )+ ) |
||
| 1096 | +1185 |
- } else {
+ } else {
|
||
| 1097 | +1186 | ! |
- qenv <- teal.code::eval_code(+ qenv <- teal.code::eval_code( |
|
| 1098 | +1187 | ! |
- qenv,+ qenv, |
|
| 1099 | +1188 | ! |
- substitute(+ substitute( |
|
| 1100 | +1189 | ! |
- expr = summary_data <- ANL %>%+ expr = {
|
|
| 1101 | +1190 | ! |
- dplyr::summarise_all(summ_fn) %>%+ test_stats <- ANL %>% |
|
| 1102 | +1191 | ! |
- tidyr::pivot_longer(dplyr::everything(),+ dplyr::select(dist_var, s_var, g_var) %>% |
|
| 1103 | +1192 | ! |
- names_to = "Variable",+ dplyr::group_by_at(dplyr::vars(dplyr::any_of(groups))) %>% |
|
| 1104 | +1193 | ! |
- values_to = paste0("Missing (N=", nrow(ANL), ")")
- |
- |
| 1105 | -- |
- ) %>%+ dplyr::do(tests = broom::glance(do.call(test, args))) %>% |
||
| 1106 | +1194 | ! |
- dplyr::mutate(`Variable label` = create_cols_labels(Variable), .after = Variable),+ tidyr::unnest(tests) %>% |
|
| 1107 | +1195 | ! |
- env = list(summ_fn = summ_fn)- |
- |
| 1108 | -- |
- )+ dplyr::mutate_if(is.numeric, round, 3) |
||
| 1109 | +1196 |
- )+ }, |
||
| 1110 | -+ | |||
| 1197 | +! |
- }+ env = env |
||
| 1111 | +1198 | - - | -||
| 1112 | -! | -
- teal.code::eval_code(qenv, quote(summary_data))+ ) |
||
| 1113 | +1199 |
- })+ ) |
||
| 1114 | +1200 |
-
+ } |
||
| 1115 | +1201 | ! |
- summary_table_r <- reactive(summary_table_q()[["summary_data"]])+ qenv %>% |
|
| 1116 | +1202 |
-
+ # used to display table when running show-r-code code |
||
| 1117 | +1203 | ! |
- by_subject_plot_q <- reactive({
+ teal.code::eval_code(quote(test_stats)) |
|
| 1118 | +1204 |
- # needed to trigger show r code update on tab change+ } |
||
| 1119 | -! | +|||
| 1205 | +
- req(input$summary_type == "Grouped by Subject", common_code_q())+ ) |
|||
| 1120 | +1206 | |||
| 1121 | -! | +|||
| 1207 | +
- teal::validate_has_data(data_r(), 1)+ # outputs ---- |
|||
| 1122 | +1208 |
-
+ ## building main qenv |
||
| 1123 | +1209 | ! |
- dev_ggplot2_args <- teal.widgets::ggplot2_args(+ output_q <- reactive({
|
|
| 1124 | +1210 | ! |
- labs = list(x = "", y = ""),+ tab <- input$tabs |
|
| 1125 | +1211 | ! |
- theme = list(legend.position = "bottom", axis.text.x = quote(element_blank()))- |
- |
| 1126 | -- |
- )+ req(tab) # tab is NULL upon app launch, hence will crash without this statement |
||
| 1127 | +1212 | |||
| 1128 | -! | -
- all_ggplot2_args <- teal.widgets::resolve_ggplot2_args(- |
- ||
| 1129 | -! | -
- user_plot = ggplot2_args[["By Subject"]],- |
- ||
| 1130 | -! | -
- user_default = ggplot2_args$default,- |
- ||
| 1131 | +1213 | ! |
- module_plot = dev_ggplot2_args- |
- |
| 1132 | -- |
- )+ qenv_final <- common_q() |
||
| 1133 | +1214 |
-
+ # wrapped in if since could lead into validate error - we do want to continue |
||
| 1134 | +1215 | ! |
- parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(+ test_r_qenv_out <- try(test_q(), silent = TRUE) |
|
| 1135 | +1216 | ! |
- all_ggplot2_args,+ if (!inherits(test_r_qenv_out, c("try-error", "error"))) {
|
|
| 1136 | +1217 | ! |
- ggtheme = input$ggtheme+ qenv_final <- c(qenv_final, test_q()) |
|
| 1137 | +1218 |
- )+ } |
||
| 1138 | +1219 | |||
| 1139 | +1220 | ! |
- teal.code::eval_code(+ qenv_final <- if (tab == "Histogram") {
|
|
| 1140 | +1221 | ! |
- common_code_q(),+ req(dist_q()) |
|
| 1141 | +1222 | ! |
- substitute(+ c(qenv_final, dist_q()) |
|
| 1142 | +1223 | ! |
- expr = parent_keys <- keys,+ } else if (tab == "QQplot") {
|
|
| 1143 | +1224 | ! |
- env = list(keys = data_parent_keys())- |
- |
| 1144 | -- |
- )- |
- ||
| 1145 | -- |
- ) %>%+ req(qq_q()) |
||
| 1146 | +1225 | ! |
- teal.code::eval_code(+ c(qenv_final, qq_q()) |
|
| 1147 | -! | +|||
| 1226 | +
- substitute(+ } |
|||
| 1148 | +1227 | ! |
- expr = analysis_vars <- setdiff(colnames(ANL), data_keys),+ qenv_final |
|
| 1149 | -! | +|||
| 1228 | +
- env = list(data_keys = data_keys())+ }) |
|||
| 1150 | +1229 |
- )+ + |
+ ||
| 1230 | +! | +
+ dist_r <- reactive(dist_q()[["g"]]) |
||
| 1151 | +1231 |
- ) %>%+ |
||
| 1152 | +1232 | ! |
- teal.code::eval_code(+ qq_r <- reactive(qq_q()[["g"]]) |
|
| 1153 | -! | +|||
| 1233 | +
- quote({
+
|
|||
| 1154 | +1234 | ! |
- summary_plot_patients <- ANL[, c(parent_keys, analysis_vars)] %>%+ output$summary_table <- DT::renderDataTable( |
|
| 1155 | +1235 | ! |
- dplyr::group_by_at(parent_keys) %>%+ expr = if (iv_r()$is_valid()) common_q()[["summary_table"]] else NULL, |
|
| 1156 | +1236 | ! |
- dplyr::mutate(id = dplyr::cur_group_id()) %>%+ options = list( |
|
| 1157 | +1237 | ! |
- dplyr::ungroup() %>%+ autoWidth = TRUE, |
|
| 1158 | +1238 | ! |
- dplyr::group_by_at(c(parent_keys, "id")) %>%+ columnDefs = list(list(width = "200px", targets = "_all")) |
|
| 1159 | -! | +|||
| 1239 | +
- dplyr::summarise_all(anyNA) %>%+ ), |
|||
| 1160 | +1240 | ! |
- dplyr::ungroup()+ rownames = FALSE |
|
| 1161 | +1241 |
-
+ ) |
||
| 1162 | +1242 |
- # order subjects by decreasing number of missing and then by+ |
||
| 1163 | -+ | |||
| 1243 | +! |
- # missingness pattern (defined using sha1)+ tests_r <- reactive({
|
||
| 1164 | +1244 | ! |
- order_subjects <- summary_plot_patients %>%+ req(iv_r()$is_valid()) |
|
| 1165 | +1245 | ! |
- dplyr::select(-"id", -dplyr::all_of(parent_keys)) %>%+ teal::validate_inputs(iv_r_dist()) |
|
| 1166 | +1246 | ! |
- dplyr::transmute(+ test_q()[["test_stats"]]+ |
+ |
| 1247 | ++ |
+ })+ |
+ ||
| 1248 | ++ | + | ||
| 1167 | +1249 | ! |
- id = dplyr::row_number(),+ pws1 <- teal.widgets::plot_with_settings_srv( |
|
| 1168 | +1250 | ! |
- number_NA = apply(., 1, sum),+ id = "hist_plot", |
|
| 1169 | +1251 | ! |
- sha = apply(., 1, rlang::hash)+ plot_r = dist_r, |
|
| 1170 | -+ | |||
| 1252 | +! |
- ) %>%+ height = plot_height, |
||
| 1171 | +1253 | ! |
- dplyr::arrange(dplyr::desc(number_NA), sha) %>%+ width = plot_width, |
|
| 1172 | +1254 | ! |
- getElement(name = "id")+ brushing = FALSE |
|
| 1173 | +1255 |
-
+ ) |
||
| 1174 | +1256 |
- # order columns by decreasing percent of missing values+ |
||
| 1175 | +1257 | ! |
- ordered_columns <- summary_plot_patients %>%+ pws2 <- teal.widgets::plot_with_settings_srv( |
|
| 1176 | +1258 | ! |
- dplyr::select(-"id", -dplyr::all_of(parent_keys)) %>%+ id = "qq_plot", |
|
| 1177 | +1259 | ! |
- dplyr::summarise(+ plot_r = qq_r, |
|
| 1178 | +1260 | ! |
- column = create_cols_labels(colnames(.)),+ height = plot_height, |
|
| 1179 | +1261 | ! |
- na_count = apply(., MARGIN = 2, FUN = sum),+ width = plot_width, |
|
| 1180 | +1262 | ! |
- na_percent = na_count / nrow(.) * 100+ brushing = FALSE |
|
| 1181 | +1263 |
- ) %>%- |
- ||
| 1182 | -! | -
- dplyr::arrange(na_percent, dplyr::desc(column))+ ) |
||
| 1183 | +1264 | |||
| 1184 | +1265 | ! |
- summary_plot_patients <- summary_plot_patients %>%+ output$t_stats <- DT::renderDataTable( |
|
| 1185 | +1266 | ! |
- tidyr::gather("col", "isna", -"id", -dplyr::all_of(parent_keys)) %>%
+ expr = tests_r(), |
|
| 1186 | +1267 | ! |
- dplyr::mutate(col = create_cols_labels(col))+ options = list(scrollX = TRUE), |
|
| 1187 | -+ | |||
| 1268 | +! |
- })+ rownames = FALSE |
||
| 1188 | +1269 |
- ) %>%+ ) |
||
| 1189 | -! | +|||
| 1270 | +
- teal.code::eval_code(+ |
|||
| 1190 | +1271 | ! |
- substitute(+ teal.widgets::verbatim_popup_srv( |
|
| 1191 | +1272 | ! |
- expr = {
+ id = "rcode", |
|
| 1192 | +1273 | ! |
- g <- ggplot(summary_plot_patients, aes(+ verbatim_content = reactive(teal.code::get_code(output_q())), |
|
| 1193 | +1274 | ! |
- x = factor(id, levels = order_subjects),+ title = "R Code for distribution" |
|
| 1194 | -! | +|||
| 1275 | +
- y = factor(col, levels = ordered_columns[["column"]]),+ ) |
|||
| 1195 | -! | +|||
| 1276 | +
- fill = isna+ |
|||
| 1196 | +1277 |
- )) ++ ### REPORTER |
||
| 1197 | +1278 | ! |
- geom_raster() ++ if (with_reporter) {
|
|
| 1198 | +1279 | ! |
- annotate(+ card_fun <- function(comment, label) {
|
|
| 1199 | +1280 | ! |
- "text",+ card <- teal::report_card_template( |
|
| 1200 | +1281 | ! |
- x = length(order_subjects),+ title = "Distribution Plot", |
|
| 1201 | +1282 | ! |
- y = seq_len(nrow(ordered_columns)),+ label = label, |
|
| 1202 | +1283 | ! |
- hjust = 1,+ with_filter = with_filter, |
|
| 1203 | +1284 | ! |
- label = sprintf("%d [%.02f%%]", ordered_columns[["na_count"]], ordered_columns[["na_percent"]])
+ filter_panel_api = filter_panel_api |
|
| 1204 | +1285 |
- ) +- |
- ||
| 1205 | -! | -
- scale_fill_manual(+ ) |
||
| 1206 | +1286 | ! |
- name = "",+ card$append_text("Plot", "header3")
|
|
| 1207 | +1287 | ! |
- values = c("grey90", c(getOption("ggplot2.discrete.colour")[2], "#ff2951ff")[1]),
+ if (input$tabs == "Histogram") {
|
|
| 1208 | +1288 | ! |
- labels = c("Present", "Missing (at least one)")
- |
- |
| 1209 | -- |
- ) ++ card$append_plot(dist_r(), dim = pws1$dim()) |
||
| 1210 | +1289 | ! |
- labs ++ } else if (input$tabs == "QQplot") {
|
|
| 1211 | +1290 | ! |
- ggthemes ++ card$append_plot(qq_r(), dim = pws2$dim()) |
|
| 1212 | -! | +|||
| 1291 | +
- themes+ } |
|||
| 1213 | +1292 | ! |
- print(g)+ card$append_text("Statistics table", "header3")
|
|
| 1214 | +1293 |
- },+ |
||
| 1215 | +1294 | ! |
- env = list(+ card$append_table(common_q()[["summary_table"]]) |
|
| 1216 | +1295 | ! |
- labs = parsed_ggplot2_args$labs,+ tests_error <- tryCatch(expr = tests_r(), error = function(e) "error") |
|
| 1217 | +1296 | ! |
- themes = parsed_ggplot2_args$theme,+ if (inherits(tests_error, "data.frame")) {
|
|
| 1218 | +1297 | ! |
- ggthemes = parsed_ggplot2_args$ggtheme+ card$append_text("Tests table", "header3")
|
|
| 1219 | -+ | |||
| 1298 | +! |
- )+ card$append_table(tests_r()) |
||
| 1220 | +1299 |
- )+ } |
||
| 1221 | +1300 |
- )+ |
||
| 1222 | -+ | |||
| 1301 | +! |
- })+ if (!comment == "") {
|
||
| 1223 | -+ | |||
| 1302 | +! |
-
+ card$append_text("Comment", "header3")
|
||
| 1224 | +1303 | ! |
- by_subject_plot_r <- reactive(by_subject_plot_q()[["g"]])+ card$append_text(comment) |
|
| 1225 | +1304 | - - | -||
| 1226 | -! | -
- output$levels_table <- DT::renderDataTable(+ } |
||
| 1227 | +1305 | ! |
- expr = {
+ card$append_src(teal.code::get_code(output_q())) |
|
| 1228 | +1306 | ! |
- if (length(input$variables_select) == 0) {
- |
- |
| 1229 | -- |
- # so that zeroRecords message gets printed+ card |
||
| 1230 | +1307 |
- # using tibble as it supports weird column names, such as " "+ } |
||
| 1231 | +1308 | ! |
- tibble::tibble(` ` = logical(0))+ teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
|
|
| 1232 | +1309 |
- } else {
- |
- ||
| 1233 | -! | -
- summary_table_r()+ } |
||
| 1234 | +1310 |
- }+ ### |
||
| 1235 | +1311 |
- },+ }) |
||
| 1236 | -! | +|||
| 1312 | +
- options = list(language = list(zeroRecords = "No variable selected"), pageLength = input$levels_table_rows)+ } |
| 1237 | +1 |
- )+ #' `teal` module: Cross-table |
|
| 1238 | +2 |
-
+ #' |
|
| 1239 | -! | +||
| 3 | +
- pws1 <- teal.widgets::plot_with_settings_srv(+ #' Generates a simple cross-table of two variables from a dataset with custom |
||
| 1240 | -! | +||
| 4 | +
- id = "summary_plot",+ #' options for showing percentages and sub-totals. |
||
| 1241 | -! | +||
| 5 | +
- plot_r = summary_plot_r,+ #' |
||
| 1242 | -! | +||
| 6 | +
- height = plot_height,+ #' @inheritParams teal::module |
||
| 1243 | -! | +||
| 7 | +
- width = plot_width+ #' @inheritParams shared_params |
||
| 1244 | +8 |
- )+ #' @param x (`data_extract_spec` or `list` of multiple `data_extract_spec`) |
|
| 1245 | +9 |
-
+ #' Object with all available choices with pre-selected option for variable X - row values. |
|
| 1246 | -! | +||
| 10 | +
- pws2 <- teal.widgets::plot_with_settings_srv(+ #' In case of `data_extract_spec` use `select_spec(..., ordered = TRUE)` if table elements should be |
||
| 1247 | -! | +||
| 11 | +
- id = "combination_plot",+ #' rendered according to selection order. |
||
| 1248 | -! | +||
| 12 | +
- plot_r = combination_plot_r,+ #' @param y (`data_extract_spec` or `list` of multiple `data_extract_spec`) |
||
| 1249 | -! | +||
| 13 | +
- height = plot_height,+ #' Object with all available choices with pre-selected option for variable Y - column values. |
||
| 1250 | -! | +||
| 14 | +
- width = plot_width+ #' |
||
| 1251 | +15 |
- )+ #' `data_extract_spec` must not allow multiple selection in this case. |
|
| 1252 | +16 |
-
+ #' @param show_percentage (`logical(1)`) |
|
| 1253 | -! | +||
| 17 | +
- pws3 <- teal.widgets::plot_with_settings_srv(+ #' Indicates whether to show percentages (relevant only when `x` is a `factor`). |
||
| 1254 | -! | +||
| 18 | +
- id = "by_subject_plot",+ #' Defaults to `TRUE`. |
||
| 1255 | -! | +||
| 19 | +
- plot_r = by_subject_plot_r,+ #' @param show_total (`logical(1)`) |
||
| 1256 | -! | +||
| 20 | +
- height = plot_height,+ #' Indicates whether to show total column. |
||
| 1257 | -! | +||
| 21 | +
- width = plot_width+ #' Defaults to `TRUE`. |
||
| 1258 | +22 |
- )+ #' |
|
| 1259 | +23 |
-
+ #' @note For more examples, please see the vignette "Using cross table" via |
|
| 1260 | -! | +||
| 24 | +
- final_q <- reactive({
+ #' `vignette("using-cross-table", package = "teal.modules.general")`.
|
||
| 1261 | -! | +||
| 25 | +
- req(input$summary_type)+ #' |
||
| 1262 | -! | +||
| 26 | +
- sum_type <- input$summary_type+ #' @inherit shared_params return |
||
| 1263 | -! | +||
| 27 | +
- if (sum_type == "Summary") {
+ #' |
||
| 1264 | -! | +||
| 28 | +
- summary_plot_q()+ #' @examplesShinylive |
||
| 1265 | -! | +||
| 29 | +
- } else if (sum_type == "Combinations") {
+ #' library(teal.modules.general) |
||
| 1266 | -! | +||
| 30 | +
- combination_plot_q()+ #' interactive <- function() TRUE |
||
| 1267 | -! | +||
| 31 | +
- } else if (sum_type == "By Variable Levels") {
+ #' {{ next_example }}
|
||
| 1268 | -! | +||
| 32 | +
- summary_table_q()+ #' @examplesIf require("rtables", quietly = TRUE)
|
||
| 1269 | -! | +||
| 33 | +
- } else if (sum_type == "Grouped by Subject") {
+ #' # general data example |
||
| 1270 | -! | +||
| 34 | +
- by_subject_plot_q()+ #' data <- teal_data() |
||
| 1271 | +35 |
- }+ #' data <- within(data, {
|
|
| 1272 | +36 |
- })+ #' mtcars <- mtcars |
|
| 1273 | +37 |
-
+ #' for (v in c("cyl", "vs", "am", "gear")) {
|
|
| 1274 | -! | +||
| 38 | +
- teal.widgets::verbatim_popup_srv(+ #' mtcars[[v]] <- as.factor(mtcars[[v]]) |
||
| 1275 | -! | +||
| 39 | +
- id = "rcode",+ #' } |
||
| 1276 | -! | +||
| 40 | +
- verbatim_content = reactive(teal.code::get_code(final_q())),+ #' mtcars[["primary_key"]] <- seq_len(nrow(mtcars)) |
||
| 1277 | -! | +||
| 41 | +
- title = "Show R Code for Missing Data"+ #' }) |
||
| 1278 | +42 |
- )+ #' join_keys(data) <- join_keys(join_key("mtcars", "mtcars", "primary_key"))
|
|
| 1279 | +43 |
-
+ #' |
|
| 1280 | +44 |
- ### REPORTER+ #' app <- init( |
|
| 1281 | -! | +||
| 45 | +
- if (with_reporter) {
+ #' data = data, |
||
| 1282 | -! | +||
| 46 | +
- card_fun <- function(comment, label) {
+ #' modules = modules( |
||
| 1283 | -! | +||
| 47 | +
- card <- teal::TealReportCard$new()+ #' tm_t_crosstable( |
||
| 1284 | -! | +||
| 48 | +
- sum_type <- input$summary_type+ #' label = "Cross Table", |
||
| 1285 | -! | +||
| 49 | +
- title <- if (sum_type == "By Variable Levels") paste0(sum_type, " Table") else paste0(sum_type, " Plot")+ #' x = data_extract_spec( |
||
| 1286 | -! | +||
| 50 | +
- title_dataname <- paste(title, dataname, sep = " - ")+ #' dataname = "mtcars", |
||
| 1287 | -! | +||
| 51 | +
- label <- if (label == "") {
+ #' select = select_spec( |
||
| 1288 | -! | +||
| 52 | +
- paste("Missing Data", sum_type, dataname, sep = " - ")
+ #' label = "Select variable:", |
||
| 1289 | +53 |
- } else {
+ #' choices = variable_choices(data[["mtcars"]], c("cyl", "vs", "am", "gear")),
|
|
| 1290 | -! | +||
| 54 | +
- label+ #' selected = c("cyl", "gear"),
|
||
| 1291 | +55 |
- }+ #' multiple = TRUE, |
|
| 1292 | -! | +||
| 56 | +
- card$set_name(label)+ #' ordered = TRUE, |
||
| 1293 | -! | +||
| 57 | +
- card$append_text(title_dataname, "header2")+ #' fixed = FALSE |
||
| 1294 | -! | +||
| 58 | +
- if (with_filter) card$append_fs(filter_panel_api$get_filter_state())+ #' ) |
||
| 1295 | -! | +||
| 59 | +
- if (sum_type == "Summary") {
+ #' ), |
||
| 1296 | -! | +||
| 60 | +
- card$append_text("Plot", "header3")
+ #' y = data_extract_spec( |
||
| 1297 | -! | +||
| 61 | +
- card$append_plot(summary_plot_r(), dim = pws1$dim())+ #' dataname = "mtcars", |
||
| 1298 | -! | +||
| 62 | +
- } else if (sum_type == "Combinations") {
+ #' select = select_spec( |
||
| 1299 | -! | +||
| 63 | +
- card$append_text("Plot", "header3")
+ #' label = "Select variable:", |
||
| 1300 | -! | +||
| 64 | +
- card$append_plot(combination_plot_r(), dim = pws2$dim())+ #' choices = variable_choices(data[["mtcars"]], c("cyl", "vs", "am", "gear")),
|
||
| 1301 | -! | +||
| 65 | +
- } else if (sum_type == "By Variable Levels") {
+ #' selected = "vs", |
||
| 1302 | -! | +||
| 66 | +
- card$append_text("Table", "header3")
+ #' multiple = FALSE, |
||
| 1303 | -! | +||
| 67 | +
- card$append_table(summary_table_r[["summary_data"]])+ #' fixed = FALSE |
||
| 1304 | -! | +||
| 68 | +
- } else if (sum_type == "Grouped by Subject") {
+ #' ) |
||
| 1305 | -! | +||
| 69 | +
- card$append_text("Plot", "header3")
+ #' ) |
||
| 1306 | -! | +||
| 70 | +
- card$append_plot(by_subject_plot_r(), dim = pws3$dim())+ #' ) |
||
| 1307 | +71 |
- }+ #' ) |
|
| 1308 | -! | +||
| 72 | +
- if (!comment == "") {
+ #' ) |
||
| 1309 | -! | +||
| 73 | +
- card$append_text("Comment", "header3")
+ #' if (interactive()) {
|
||
| 1310 | -! | +||
| 74 | +
- card$append_text(comment)+ #' shinyApp(app$ui, app$server) |
||
| 1311 | +75 |
- }+ #' } |
|
| 1312 | -! | +||
| 76 | +
- card$append_src(teal.code::get_code(final_q()))+ #' |
||
| 1313 | -! | +||
| 77 | +
- card+ #' @examplesShinylive |
||
| 1314 | +78 |
- }+ #' library(teal.modules.general) |
|
| 1315 | -! | +||
| 79 | +
- teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
+ #' interactive <- function() TRUE |
||
| 1316 | +80 |
- }+ #' {{ next_example }}
|
|
| 1317 | +81 |
- ###+ #' @examplesIf require("rtables", quietly = TRUE)
|
|
| 1318 | +82 |
- })+ #' # CDISC data example |
|
| 1319 | +83 |
- }+ #' data <- teal_data() |
| 1 | +84 |
- #' Shared parameters documentation+ #' data <- within(data, {
|
|
| 2 | +85 |
- #'+ #' ADSL <- rADSL |
|
| 3 | +86 |
- #' Defines common arguments shared across multiple functions in the package+ #' }) |
|
| 4 | +87 |
- #' to avoid repetition by using `inheritParams`.+ #' join_keys(data) <- default_cdisc_join_keys[names(data)] |
|
| 5 | +88 |
#' |
|
| 6 | +89 |
- #' @param plot_height (`numeric`) optional, specifies the plot height as a three-element vector of+ #' app <- init( |
|
| 7 | +90 |
- #' `value`, `min`, and `max` intended for use with a slider UI element.+ #' data = data, |
|
| 8 | +91 |
- #' @param plot_width (`numeric`) optional, specifies the plot width as a three-element vector of+ #' modules = modules( |
|
| 9 | +92 |
- #' `value`, `min`, and `max` for a slider encoding the plot width.+ #' tm_t_crosstable( |
|
| 10 | +93 |
- #' @param rotate_xaxis_labels (`logical`) optional, whether to rotate plot X axis labels. Does not+ #' label = "Cross Table", |
|
| 11 | +94 |
- #' rotate by default (`FALSE`).+ #' x = data_extract_spec( |
|
| 12 | +95 |
- #' @param ggtheme (`character`) optional, `ggplot2` theme to be used by default. Defaults to `"gray"`.+ #' dataname = "ADSL", |
|
| 13 | +96 |
- #' @param ggplot2_args (`ggplot2_args`) object created by [teal.widgets::ggplot2_args()]+ #' select = select_spec( |
|
| 14 | +97 |
- #' with settings for the module plot.+ #' label = "Select variable:", |
|
| 15 | +98 |
- #' The argument is merged with options variable `teal.ggplot2_args` and default module setup.+ #' choices = variable_choices(data[["ADSL"]], subset = function(data) {
|
|
| 16 | +99 |
- #'+ #' idx <- !vapply(data, inherits, logical(1), c("Date", "POSIXct", "POSIXlt"))
|
|
| 17 | +100 |
- #' For more details see the vignette: `vignette("custom-ggplot2-arguments", package = "teal.widgets")`
+ #' return(names(data)[idx]) |
|
| 18 | +101 |
- #' @param basic_table_args (`basic_table_args`) object created by [teal.widgets::basic_table_args()]+ #' }), |
|
| 19 | +102 |
- #' with settings for the module table.+ #' selected = "COUNTRY", |
|
| 20 | +103 |
- #' The argument is merged with options variable `teal.basic_table_args` and default module setup.+ #' multiple = TRUE, |
|
| 21 | +104 |
- #'+ #' ordered = TRUE, |
|
| 22 | +105 |
- #' For more details see the vignette: `vignette("custom-basic-table-arguments", package = "teal.widgets")`
+ #' fixed = FALSE |
|
| 23 | +106 |
- #' @param pre_output (`shiny.tag`) optional, text or UI element to be displayed before the module's output,+ #' ) |
|
| 24 | +107 |
- #' providing context or a title.+ #' ), |
|
| 25 | +108 |
- #' with text placed before the output to put the output into context. For example a title.+ #' y = data_extract_spec( |
|
| 26 | +109 |
- #' @param post_output (`shiny.tag`) optional, text or UI element to be displayed after the module's output,+ #' dataname = "ADSL", |
|
| 27 | +110 |
- #' adding context or further instructions. Elements like `shiny::helpText()` are useful.+ #' select = select_spec( |
|
| 28 | +111 |
- #'+ #' label = "Select variable:", |
|
| 29 | +112 |
- #' @param alpha (`integer(1)` or `integer(3)`) optional, specifies point opacity.+ #' choices = variable_choices(data[["ADSL"]], subset = function(data) {
|
|
| 30 | +113 |
- #' - When the length of `alpha` is one: the plot points will have a fixed opacity.+ #' idx <- vapply(data, is.factor, logical(1)) |
|
| 31 | +114 |
- #' - When the length of `alpha` is three: the plot points opacity are dynamically adjusted based on+ #' return(names(data)[idx]) |
|
| 32 | +115 |
- #' vector of `value`, `min`, and `max`.+ #' }), |
|
| 33 | +116 |
- #' @param size (`integer(1)` or `integer(3)`) optional, specifies point size.+ #' selected = "SEX", |
|
| 34 | +117 |
- #' - When the length of `size` is one: the plot point sizes will have a fixed size.+ #' multiple = FALSE, |
|
| 35 | +118 |
- #' - When the length of `size` is three: the plot points size are dynamically adjusted based on+ #' fixed = FALSE |
|
| 36 | +119 |
- #' vector of `value`, `min`, and `max`.+ #' ) |
|
| 37 | +120 |
- #'+ #' ) |
|
| 38 | +121 |
- #' @return Object of class `teal_module` to be used in `teal` applications.+ #' ) |
|
| 39 | +122 |
- #'+ #' ) |
|
| 40 | +123 |
- #' @name shared_params+ #' ) |
|
| 41 | +124 |
- #' @keywords internal+ #' if (interactive()) {
|
|
| 42 | +125 |
- NULL+ #' shinyApp(app$ui, app$server) |
|
| 43 | +126 |
-
+ #' } |
|
| 44 | +127 |
- #' Add labels for facets to a `ggplot2` object+ #' |
|
| 45 | +128 |
- #'+ #' @export |
|
| 46 | +129 |
- #' Enhances a `ggplot2` plot by adding labels that describe+ #' |
|
| 47 | +130 |
- #' the faceting variables along the x and y axes.+ tm_t_crosstable <- function(label = "Cross Table", |
|
| 48 | +131 |
- #'+ x, |
|
| 49 | +132 |
- #' @param p (`ggplot2`) object to which facet labels will be added.+ y, |
|
| 50 | +133 |
- #' @param xfacet_label (`character`) Label for the facet along the x-axis.+ show_percentage = TRUE, |
|
| 51 | +134 |
- #' If `NULL`, no label is added. If a vector, labels are joined with " & ".+ show_total = TRUE, |
|
| 52 | +135 |
- #' @param yfacet_label (`character`) Label for the facet along the y-axis.+ pre_output = NULL, |
|
| 53 | +136 |
- #' Similar behavior to `xfacet_label`.+ post_output = NULL, |
|
| 54 | +137 |
- #'+ basic_table_args = teal.widgets::basic_table_args()) {
|
|
| 55 | -+ | ||
| 138 | +! |
- #' @return Returns `grid` or `grob` object (to be drawn with `grid.draw`)+ message("Initializing tm_t_crosstable")
|
|
| 56 | +139 |
- #'+ |
|
| 57 | +140 |
- #' @examples+ # Requires Suggested packages |
|
| 58 | -+ | ||
| 141 | +! |
- #' library(ggplot2)+ if (!requireNamespace("rtables", quietly = TRUE)) {
|
|
| 59 | -+ | ||
| 142 | +! |
- #' library(grid)+ stop("Cannot load rtables - please install the package or restart your session.")
|
|
| 60 | +143 |
- #'+ } |
|
| 61 | +144 |
- #' p <- ggplot(mtcars) ++ |
|
| 62 | +145 |
- #' aes(x = mpg, y = disp) ++ # Normalize the parameters |
|
| 63 | -+ | ||
| 146 | +! |
- #' geom_point() ++ if (inherits(x, "data_extract_spec")) x <- list(x) |
|
| 64 | -+ | ||
| 147 | +! |
- #' facet_grid(gear ~ cyl)+ if (inherits(y, "data_extract_spec")) y <- list(y) |
|
| 65 | +148 |
- #'+ |
|
| 66 | +149 |
- #' xfacet_label <- "cylinders"+ # Start of assertions |
|
| 67 | -+ | ||
| 150 | +! |
- #' yfacet_label <- "gear"+ checkmate::assert_string(label) |
|
| 68 | -+ | ||
| 151 | +! |
- #' res <- add_facet_labels(p, xfacet_label, yfacet_label)+ checkmate::assert_list(x, types = "data_extract_spec") |
|
| 69 | +152 |
- #' grid.newpage()+ |
|
| 70 | -+ | ||
| 153 | +! |
- #' grid.draw(res)+ checkmate::assert_list(y, types = "data_extract_spec") |
|
| 71 | -+ | ||
| 154 | +! |
- #'+ assert_single_selection(y) |
|
| 72 | +155 |
- #' grid.newpage()+ |
|
| 73 | -+ | ||
| 156 | +! |
- #' grid.draw(add_facet_labels(p, xfacet_label = NULL, yfacet_label))+ checkmate::assert_flag(show_percentage) |
|
| 74 | -+ | ||
| 157 | +! |
- #' grid.newpage()+ checkmate::assert_flag(show_total) |
|
| 75 | -+ | ||
| 158 | +! |
- #' grid.draw(add_facet_labels(p, xfacet_label, yfacet_label = NULL))+ checkmate::assert_multi_class(pre_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
|
|
| 76 | -+ | ||
| 159 | +! |
- #' grid.newpage()+ checkmate::assert_multi_class(post_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
|
|
| 77 | -+ | ||
| 160 | +! |
- #' grid.draw(add_facet_labels(p, xfacet_label = NULL, yfacet_label = NULL))+ checkmate::assert_class(basic_table_args, classes = "basic_table_args") |
|
| 78 | +161 |
- #'+ # End of assertions |
|
| 79 | +162 |
- #' @export+ |
|
| 80 | +163 |
- #'+ # Make UI args+ |
+ |
| 164 | +! | +
+ ui_args <- as.list(environment()) |
|
| 81 | +165 |
- add_facet_labels <- function(p, xfacet_label = NULL, yfacet_label = NULL) {
+
|
|
| 82 | +166 | ! |
- checkmate::assert_class(p, classes = "ggplot")+ server_args <- list( |
| 83 | +167 | ! |
- checkmate::assert_character(xfacet_label, null.ok = TRUE, min.len = 1)+ label = label, |
| 84 | +168 | ! |
- checkmate::assert_character(yfacet_label, null.ok = TRUE, min.len = 1)+ x = x, |
| 85 | +169 | ! |
- if (is.null(xfacet_label) && is.null(yfacet_label)) {
+ y = y, |
| 86 | +170 | ! |
- return(ggplotGrob(p))+ basic_table_args = basic_table_args |
| 87 | +171 |
- }+ )+ |
+ |
| 172 | ++ | + | |
| 88 | +173 | ! |
- grid::grid.grabExpr({
+ ans <- module( |
| 89 | +174 | ! |
- g <- ggplotGrob(p)+ label = label, |
| 90 | -+ | ||
| 175 | +! |
-
+ server = srv_t_crosstable, |
|
| 91 | -+ | ||
| 176 | +! |
- # we are going to replace these, so we make sure they have nothing in them+ ui = ui_t_crosstable, |
|
| 92 | +177 | ! |
- checkmate::assert_class(g$grobs[[grep("xlab-t", g$layout$name, fixed = TRUE)]], "zeroGrob")
+ ui_args = ui_args, |
| 93 | +178 | ! |
- checkmate::assert_class(g$grobs[[grep("ylab-r", g$layout$name, fixed = TRUE)]], "zeroGrob")
+ server_args = server_args,+ |
+
| 179 | +! | +
+ datanames = teal.transform::get_extract_datanames(list(x = x, y = y)) |
|
| 94 | +180 |
-
+ ) |
|
| 95 | +181 | ! |
- xaxis_label_grob <- g$grobs[[grep("xlab-b", g$layout$name, fixed = TRUE)]]
+ attr(ans, "teal_bookmarkable") <- TRUE |
| 96 | +182 | ! |
- xaxis_label_grob$children[[1]]$label <- paste(xfacet_label, collapse = " & ")+ ans |
| 97 | -! | +||
| 183 | +
- yaxis_label_grob <- g$grobs[[grep("ylab-l", g$layout$name, fixed = TRUE)]]
+ } |
||
| 98 | -! | +||
| 184 | +
- yaxis_label_grob$children[[1]]$label <- paste(yfacet_label, collapse = " & ")+ |
||
| 99 | -! | +||
| 185 | +
- yaxis_label_grob$children[[1]]$rot <- 270+ # UI function for the cross-table module |
||
| 100 | +186 |
-
+ ui_t_crosstable <- function(id, x, y, show_percentage, show_total, pre_output, post_output, ...) {
|
|
| 101 | +187 | ! |
- top_height <- if (is.null(xfacet_label)) 0 else grid::unit(2, "line")+ ns <- NS(id) |
| 102 | +188 | ! |
- right_width <- if (is.null(yfacet_label)) 0 else grid::unit(2, "line")+ is_single_dataset <- teal.transform::is_single_dataset(x, y) |
| 103 | +189 | ||
| 104 | +190 | ! |
- grid::grid.newpage()+ join_default_options <- c( |
| 105 | +191 | +! | +
+ "Full Join" = "dplyr::full_join",+ |
+
| 192 | ! |
- grid::pushViewport(grid::plotViewport(margins = c(0, 0, top_height, right_width), name = "ggplot"))+ "Inner Join" = "dplyr::inner_join", |
|
| 106 | +193 | ! |
- grid::grid.draw(g)+ "Left Join" = "dplyr::left_join", |
| 107 | +194 | ! |
- grid::upViewport(1)+ "Right Join" = "dplyr::right_join" |
| 108 | +195 |
-
+ ) |
|
| 109 | +196 |
- # draw x facet+ |
|
| 110 | +197 | ! |
- if (!is.null(xfacet_label)) {
+ teal.widgets::standard_layout( |
| 111 | +198 | ! |
- grid::pushViewport(grid::viewport(+ output = teal.widgets::white_small_well( |
| 112 | +199 | ! |
- x = 0, y = grid::unit(1, "npc") - top_height, width = grid::unit(1, "npc"),+ textOutput(ns("title")),
|
| 113 | +200 | ! |
- height = top_height, just = c("left", "bottom"), name = "topxaxis"
+ teal.widgets::table_with_settings_ui(ns("table"))
|
| 114 | +201 |
- ))- |
- |
| 115 | -! | -
- grid::grid.draw(xaxis_label_grob)+ ), |
|
| 116 | +202 | ! |
- grid::upViewport(1)+ encoding = tags$div( |
| 117 | +203 |
- }+ ### Reporter |
|
| 118 | -+ | ||
| 204 | +! |
-
+ teal.reporter::simple_reporter_ui(ns("simple_reporter")),
|
|
| 119 | +205 |
- # draw y facet+ ### |
|
| 120 | +206 | ! |
- if (!is.null(yfacet_label)) {
+ tags$label("Encodings", class = "text-primary"),
|
| 121 | +207 | ! |
- grid::pushViewport(grid::viewport(+ teal.transform::datanames_input(list(x, y)), |
| 122 | +208 | ! |
- x = grid::unit(1, "npc") - grid::unit(as.numeric(right_width) / 2, "line"), y = 0, width = right_width,+ teal.transform::data_extract_ui(ns("x"), label = "Row values", x, is_single_dataset = is_single_dataset),
|
| 123 | +209 | ! |
- height = grid::unit(1, "npc"), just = c("left", "bottom"), name = "rightyaxis"
- |
-
| 124 | -- |
- ))+ teal.transform::data_extract_ui(ns("y"), label = "Column values", y, is_single_dataset = is_single_dataset),
|
|
| 125 | +210 | ! |
- grid::grid.draw(yaxis_label_grob)+ teal.widgets::optionalSelectInput( |
| 126 | +211 | ! |
- grid::upViewport(1)+ ns("join_fun"),
|
| 127 | -+ | ||
| 212 | +! |
- }+ label = "Row to Column type of join", |
|
| 128 | -+ | ||
| 213 | +! |
- })+ choices = join_default_options, |
|
| 129 | -+ | ||
| 214 | +! |
- }+ selected = join_default_options[1], |
|
| 130 | -+ | ||
| 215 | +! |
-
+ multiple = FALSE |
|
| 131 | +216 |
- #' Call a function with a character vector for the `...` argument+ ), |
|
| 132 | -+ | ||
| 217 | +! |
- #'+ tags$hr(), |
|
| 133 | -+ | ||
| 218 | +! |
- #' @param fun (`character`) Name of a function where the `...` argument shall be replaced by values from `str_args`.+ teal.widgets::panel_group( |
|
| 134 | -+ | ||
| 219 | +! |
- #' @param str_args (`character`) A character vector that the function shall be executed with+ teal.widgets::panel_item( |
|
| 135 | -+ | ||
| 220 | +! |
- #'+ title = "Table settings", |
|
| 136 | -+ | ||
| 221 | +! |
- #' @return+ checkboxInput(ns("show_percentage"), "Show column percentage", value = show_percentage),
|
|
| 137 | -+ | ||
| 222 | +! |
- #' Value of call to `fun` with arguments specified in `str_args`.+ checkboxInput(ns("show_total"), "Show total column", value = show_total)
|
|
| 138 | +223 |
- #'+ ) |
|
| 139 | +224 |
- #' @keywords internal+ ) |
|
| 140 | +225 |
- call_fun_dots <- function(fun, str_args) {
+ ), |
|
| 141 | +226 | ! |
- do.call("call", c(list(fun), lapply(str_args, as.name)), quote = TRUE)
- |
-
| 142 | -- |
- }+ forms = tagList( |
|
| 143 | -+ | ||
| 227 | +! |
-
+ teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code")
|
|
| 144 | +228 |
- #' Generate a string for a variable including its label+ ), |
|
| 145 | -+ | ||
| 229 | +! |
- #'+ pre_output = pre_output, |
|
| 146 | -+ | ||
| 230 | +! |
- #' @param var_names (`character`) Name of variable to extract labels from.+ post_output = post_output |
|
| 147 | +231 |
- #' @param dataset (`dataset`) Name of analysis dataset.+ ) |
|
| 148 | +232 |
- #' @param prefix,suffix (`character`) String to paste to the beginning/end of the variable name with label.+ } |
|
| 149 | +233 |
- #' @param wrap_width (`numeric`) Number of characters to wrap original label to. Defaults to 80.+ |
|
| 150 | +234 |
- #'+ # Server function for the cross-table module |
|
| 151 | +235 |
- #' @return (`character`) String with variable name and label.+ srv_t_crosstable <- function(id, data, reporter, filter_panel_api, label, x, y, basic_table_args) {
|
|
| 152 | -+ | ||
| 236 | +! |
- #'+ with_reporter <- !missing(reporter) && inherits(reporter, "Reporter") |
|
| 153 | -+ | ||
| 237 | +! |
- #' @keywords internal+ with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI") |
|
| 154 | -+ | ||
| 238 | +! |
- #'+ checkmate::assert_class(data, "reactive") |
|
| 155 | -+ | ||
| 239 | +! |
- varname_w_label <- function(var_names,+ checkmate::assert_class(isolate(data()), "teal_data") |
|
| 156 | -+ | ||
| 240 | +! |
- dataset,+ moduleServer(id, function(input, output, session) {
|
|
| 157 | -+ | ||
| 241 | +! |
- wrap_width = 80,+ teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.general") |
|
| 158 | +242 |
- prefix = NULL,+ |
|
| 159 | -+ | ||
| 243 | +! |
- suffix = NULL) {
+ selector_list <- teal.transform::data_extract_multiple_srv( |
|
| 160 | +244 | ! |
- add_label <- function(var_names) {
+ data_extract = list(x = x, y = y), |
| 161 | +245 | ! |
- label <- vapply(+ datasets = data, |
| 162 | +246 | ! |
- dataset[var_names], function(x) {
+ select_validation_rule = list( |
| 163 | +247 | ! |
- attr_label <- attr(x, "label")+ x = shinyvalidate::sv_required("Please define column for row variable."),
|
| 164 | +248 | ! |
- `if`(is.null(attr_label), "", attr_label)+ y = shinyvalidate::sv_required("Please define column for column variable.")
|
| 165 | +249 |
- },- |
- |
| 166 | -! | -
- character(1)+ ) |
|
| 167 | +250 |
) |
|
| 168 | +251 | ||
| 169 | +252 | ! |
- if (length(label) == 1 && !is.na(label) && !identical(label, "")) {
+ iv_r <- reactive({
|
| 170 | +253 | ! |
- paste0(prefix, label, " [", var_names, "]", suffix)+ iv <- shinyvalidate::InputValidator$new() |
| 171 | -+ | ||
| 254 | +! |
- } else {
+ iv$add_rule("join_fun", function(value) {
|
|
| 172 | +255 | ! |
- var_names+ if (!identical(selector_list()$x()$dataname, selector_list()$y()$dataname)) {
+ |
+
| 256 | +! | +
+ if (!shinyvalidate::input_provided(value)) {
+ |
+ |
| 257 | +! | +
+ "Please select a joining function." |
|
| 173 | +258 |
- }+ } |
|
| 174 | +259 |
- }+ } |
|
| 175 | +260 |
-
+ }) |
|
| 176 | +261 | ! |
- if (length(var_names) < 1) {
+ teal.transform::compose_and_enable_validators(iv, selector_list) |
| 177 | -! | +||
| 262 | +
- NULL+ }) |
||
| 178 | -! | +||
| 263 | +
- } else if (length(var_names) == 1) {
+
|
||
| 179 | +264 | ! |
- stringr::str_wrap(add_label(var_names), width = wrap_width)+ observeEvent( |
| 180 | +265 | ! |
- } else if (length(var_names) > 1) {
+ eventExpr = {
|
| 181 | +266 | ! |
- stringr::str_wrap(vapply(var_names, add_label, character(1)), width = wrap_width)- |
-
| 182 | -- |
- }+ req(!is.null(selector_list()$x()) && !is.null(selector_list()$y())) |
|
| 183 | -+ | ||
| 267 | +! |
- }+ list(selector_list()$x(), selector_list()$y()) |
|
| 184 | +268 |
-
+ }, |
|
| 185 | -+ | ||
| 269 | +! |
- # see vignette("ggplot2-specs", package="ggplot2")
+ handlerExpr = {
|
|
| 186 | -+ | ||
| 270 | +! |
- shape_names <- c(+ if (identical(selector_list()$x()$dataname, selector_list()$y()$dataname)) {
|
|
| 187 | -+ | ||
| 271 | +! |
- "circle", paste("circle", c("open", "filled", "cross", "plus", "small")), "bullet",
+ shinyjs::hide("join_fun")
|
|
| 188 | +272 |
- "square", paste("square", c("open", "filled", "cross", "plus", "triangle")),
+ } else {
|
|
| 189 | -+ | ||
| 273 | +! |
- "diamond", paste("diamond", c("open", "filled", "plus")),
+ shinyjs::show("join_fun")
|
|
| 190 | +274 |
- "triangle", paste("triangle", c("open", "filled", "square")),
+ } |
|
| 191 | +275 |
- paste("triangle down", c("open", "filled")),
+ } |
|
| 192 | +276 |
- "plus", "cross", "asterisk"+ ) |
|
| 193 | +277 |
- )+ |
|
| 194 | -+ | ||
| 278 | +! |
-
+ merge_function <- reactive({
|
|
| 195 | -+ | ||
| 279 | +! |
- #' Get icons to represent variable types in dataset+ if (is.null(input$join_fun)) {
|
|
| 196 | -+ | ||
| 280 | +! |
- #'+ "dplyr::full_join" |
|
| 197 | +281 |
- #' @param var_type (`character`) of R internal types (classes).+ } else {
|
|
| 198 | -+ | ||
| 282 | +! |
- #' @return (`character`) vector of HTML icons corresponding to data type in each column.+ input$join_fun |
|
| 199 | +283 |
- #' @keywords internal+ } |
|
| 200 | +284 |
- variable_type_icons <- function(var_type) {
- |
- |
| 201 | -! | -
- checkmate::assert_character(var_type, any.missing = FALSE)+ }) |
|
| 202 | +285 | ||
| 203 | -! | -
- class_to_icon <- list(- |
- |
| 204 | +286 | ! |
- numeric = "arrow-up-1-9",+ anl_merged_input <- teal.transform::merge_expression_srv( |
| 205 | +287 | ! |
- integer = "arrow-up-1-9",+ datasets = data, |
| 206 | +288 | ! |
- logical = "pause",+ selector_list = selector_list, |
| 207 | +289 | ! |
- Date = "calendar",+ merge_function = merge_function |
| 208 | -! | +||
| 290 | +
- POSIXct = "calendar",+ ) |
||
| 209 | -! | +||
| 291 | +
- POSIXlt = "calendar",+ |
||
| 210 | +292 | ! |
- factor = "chart-bar",+ anl_merged_q <- reactive({
|
| 211 | +293 | ! |
- character = "keyboard",+ req(anl_merged_input()) |
| 212 | +294 | ! |
- primary_key = "key",+ data() %>% |
| 213 | +295 | ! |
- unknown = "circle-question"+ teal.code::eval_code(as.expression(anl_merged_input()$expr)) |
| 214 | +296 |
- )- |
- |
| 215 | -! | -
- class_to_icon <- lapply(class_to_icon, function(icon_name) toString(icon(icon_name, lib = "font-awesome")))+ }) |
|
| 216 | +297 | ||
| 217 | +298 | ! |
- unname(vapply(+ merged <- list( |
| 218 | +299 | ! |
- var_type,+ anl_input_r = anl_merged_input, |
| 219 | +300 | ! |
- FUN.VALUE = character(1),+ anl_q_r = anl_merged_q |
| 220 | -! | +||
| 301 | +
- FUN = function(class) {
+ ) |
||
| 221 | -! | +||
| 302 | +
- if (class == "") {
+
|
||
| 222 | +303 | ! |
- class+ output_q <- reactive({
|
| 223 | +304 | ! |
- } else if (is.null(class_to_icon[[class]])) {
+ teal::validate_inputs(iv_r()) |
| 224 | +305 | ! |
- class_to_icon[["unknown"]]+ ANL <- merged$anl_q_r()[["ANL"]] |
| 225 | +306 |
- } else {
- |
- |
| 226 | -! | -
- class_to_icon[[class]]+ |
|
| 227 | +307 |
- }+ # As this is a summary |
|
| 228 | -+ | ||
| 308 | +! |
- }+ x_name <- as.vector(merged$anl_input_r()$columns_source$x) |
|
| 229 | -+ | ||
| 309 | +! |
- ))+ y_name <- as.vector(merged$anl_input_r()$columns_source$y) |
|
| 230 | +310 |
- }+ |
|
| 231 | -+ | ||
| 311 | +! |
-
+ teal::validate_has_data(ANL, 3) |
|
| 232 | -+ | ||
| 312 | +! |
- #' Include `CSS` files from `/inst/css/` package directory to application header+ teal::validate_has_data(ANL[, c(x_name, y_name)], 3, complete = TRUE, allow_inf = FALSE) |
|
| 233 | +313 |
- #'+ |
|
| 234 | -+ | ||
| 314 | +! |
- #' `system.file` should not be used to access files in other packages, it does+ is_allowed_class <- function(x) is.numeric(x) || is.factor(x) || is.character(x) || is.logical(x) |
|
| 235 | -+ | ||
| 315 | +! |
- #' not work with `devtools`. Therefore, we redefine this method in each package+ validate(need( |
|
| 236 | -+ | ||
| 316 | +! |
- #' as needed. Thus, we do not export this method+ all(vapply(ANL[x_name], is_allowed_class, logical(1))), |
|
| 237 | -+ | ||
| 317 | +! |
- #'+ "Selected row variable has an unsupported data type." |
|
| 238 | +318 |
- #' @param pattern (`character`) optional, regular expression to match the file names to be included.+ )) |
|
| 239 | -+ | ||
| 319 | +! |
- #'+ validate(need( |
|
| 240 | -+ | ||
| 320 | +! |
- #' @return HTML code that includes `CSS` files.+ is_allowed_class(ANL[[y_name]]), |
|
| 241 | -+ | ||
| 321 | +! |
- #' @keywords internal+ "Selected column variable has an unsupported data type." |
|
| 242 | +322 |
- #'+ )) |
|
| 243 | +323 |
- include_css_files <- function(pattern = "*") {
- |
- |
| 244 | -! | -
- css_files <- list.files(+ |
|
| 245 | +324 | ! |
- system.file("css", package = "teal.modules.general", mustWork = TRUE),
+ show_percentage <- input$show_percentage |
| 246 | +325 | ! |
- pattern = pattern, full.names = TRUE+ show_total <- input$show_total |
| 247 | +326 |
- )+ |
|
| 248 | +327 | ! |
- if (length(css_files) == 0) {
+ plot_title <- paste( |
| 249 | +328 | ! |
- return(NULL)+ "Cross-Table of", |
| 250 | -+ | ||
| 329 | +! |
- }+ paste0(varname_w_label(x_name, ANL), collapse = ", "), |
|
| 251 | +330 | ! |
- singleton(tags$head(lapply(css_files, includeCSS)))+ "(rows)", "vs.", |
| 252 | -+ | ||
| 331 | +! |
- }+ varname_w_label(y_name, ANL), |
|
| 253 | -+ | ||
| 332 | +! |
-
+ "(columns)" |
|
| 254 | +333 |
- #' JavaScript condition to check if a specific tab is active+ ) |
|
| 255 | +334 |
- #'+ |
|
| 256 | -+ | ||
| 335 | +! |
- #' @param id (`character(1)`) the id of the tab panel with tabs.+ labels_vec <- vapply( |
|
| 257 | -+ | ||
| 336 | +! |
- #' @param name (`character(1)`) the name of the tab.+ x_name, |
|
| 258 | -+ | ||
| 337 | +! |
- #' @return JavaScript expression to be used in `shiny::conditionalPanel()` to determine+ varname_w_label, |
|
| 259 | -+ | ||
| 338 | +! |
- #' if the specified tab is active.+ character(1), |
|
| 260 | -+ | ||
| 339 | +! |
- #' @keywords internal+ ANL |
|
| 261 | +340 |
- #'+ ) |
|
| 262 | +341 |
- is_tab_active_js <- function(id, name) {
+
|
|
| 263 | -+ | ||
| 342 | +! |
- # supporting the bs3 and higher version at the same time+ teal.code::eval_code( |
|
| 264 | +343 | ! |
- sprintf(+ merged$anl_q_r(), |
| 265 | +344 | ! |
- "$(\"#%1$s > li.active\").text().trim() == '%2$s' || $(\"#%1$s > li a.active\").text().trim() == '%2$s'",+ substitute( |
| 266 | +345 | ! |
- id, name+ expr = {
|
| 267 | -+ | ||
| 346 | +! |
- )+ title <- plot_title |
|
| 268 | +347 |
- }+ }, |
|
| 269 | -+ | ||
| 348 | +! |
-
+ env = list(plot_title = plot_title) |
|
| 270 | +349 |
- #' Assert single selection on `data_extract_spec` object+ ) |
|
| 271 | +350 |
- #' Helper to reduce code in assertions+ ) %>% |
|
| 272 | -+ | ||
| 351 | +! |
- #' @noRd+ teal.code::eval_code( |
|
| 273 | -+ | ||
| 352 | +! |
- #'+ substitute( |
|
| 274 | -+ | ||
| 353 | +! |
- assert_single_selection <- function(x,+ expr = {
|
|
| 275 | -+ | ||
| 354 | +! |
- .var.name = checkmate::vname(x)) { # nolint: object_name.
+ lyt <- basic_tables %>% |
|
| 276 | -104x | +||
| 355 | +! |
- if (any(vapply(x, function(.x) .x$select$multiple, logical(1)))) {
+ split_call %>% # styler: off |
|
| 277 | -4x | +||
| 356 | +! |
- stop("'", .var.name, "' should not allow multiple selection")
+ rtables::add_colcounts() %>% |
|
| 278 | -+ | ||
| 357 | +! |
- }+ tern::analyze_vars( |
|
| 279 | -100x | +||
| 358 | +! |
- invisible(TRUE)+ vars = x_name, |
|
| 280 | -+ | ||
| 359 | +! |
- }+ var_labels = labels_vec, |
| 1 | -+ | ||
| 360 | +! |
- #' `teal` module: Response plot+ na.rm = FALSE, |
|
| 2 | -+ | ||
| 361 | +! |
- #'+ denom = "N_col", |
|
| 3 | -+ | ||
| 362 | +! |
- #' Generates a response plot for a given `response` and `x` variables.+ .stats = c("mean_sd", "median", "range", count_value)
|
|
| 4 | +363 |
- #' This module allows users customize and add annotations to the plot depending+ ) |
|
| 5 | +364 |
- #' on the module's arguments.+ }, |
|
| 6 | -+ | ||
| 365 | +! |
- #' It supports showing the counts grouped by other variable facets (by row / column),+ env = list( |
|
| 7 | -+ | ||
| 366 | +! |
- #' swapping the coordinates, show count annotations and displaying the response plot+ basic_tables = teal.widgets::parse_basic_table_args( |
|
| 8 | -+ | ||
| 367 | +! |
- #' as frequency or density.+ basic_table_args = teal.widgets::resolve_basic_table_args(basic_table_args) |
|
| 9 | +368 |
- #'+ ), |
|
| 10 | -+ | ||
| 369 | +! |
- #' @inheritParams teal::module+ split_call = if (show_total) {
|
|
| 11 | -+ | ||
| 370 | +! |
- #' @inheritParams shared_params+ substitute( |
|
| 12 | -+ | ||
| 371 | +! |
- #' @param response (`data_extract_spec` or `list` of multiple `data_extract_spec`)+ expr = rtables::split_cols_by( |
|
| 13 | -+ | ||
| 372 | +! |
- #' Which variable to use as the response.+ y_name, |
|
| 14 | -+ | ||
| 373 | +! |
- #' You can define one fixed column by setting `fixed = TRUE` inside the `select_spec`.+ split_fun = rtables::add_overall_level(label = "Total", first = FALSE) |
|
| 15 | +374 |
- #'+ ), |
|
| 16 | -+ | ||
| 375 | +! |
- #' The `data_extract_spec` must not allow multiple selection in this case.+ env = list(y_name = y_name) |
|
| 17 | +376 |
- #' @param x (`data_extract_spec` or `list` of multiple `data_extract_spec`)+ ) |
|
| 18 | +377 |
- #' Specifies which variable to use on the X-axis of the response plot.+ } else {
|
|
| 19 | -+ | ||
| 378 | +! |
- #' Allow the user to select multiple columns from the `data` allowed in teal.+ substitute(rtables::split_cols_by(y_name), env = list(y_name = y_name)) |
|
| 20 | +379 |
- #'+ }, |
|
| 21 | -+ | ||
| 380 | +! |
- #' The `data_extract_spec` must not allow multiple selection in this case.+ x_name = x_name, |
|
| 22 | -+ | ||
| 381 | +! |
- #' @param row_facet (`data_extract_spec` or `list` of multiple `data_extract_spec`)+ labels_vec = labels_vec, |
|
| 23 | -+ | ||
| 382 | +! |
- #' optional specification of the data variable(s) to use for faceting rows.+ count_value = ifelse(show_percentage, "count_fraction", "count") |
|
| 24 | +383 |
- #' @param col_facet (`data_extract_spec` or `list` of multiple `data_extract_spec`)+ ) |
|
| 25 | +384 |
- #' optional specification of the data variable(s) to use for faceting columns.+ ) |
|
| 26 | +385 |
- #' @param coord_flip (`logical(1)`)+ ) %>% |
|
| 27 | -+ | ||
| 386 | +! |
- #' Indicates whether to flip coordinates between `x` and `response`.+ teal.code::eval_code( |
|
| 28 | -+ | ||
| 387 | +! |
- #' The default value is `FALSE` and it will show the `x` variable on the x-axis+ substitute( |
|
| 29 | -+ | ||
| 388 | +! |
- #' and the `response` variable on the y-axis.+ expr = {
|
|
| 30 | -+ | ||
| 389 | +! |
- #' @param count_labels (`logical(1)`)+ ANL <- tern::df_explicit_na(ANL) |
|
| 31 | -+ | ||
| 390 | +! |
- #' Indicates whether to show count labels.+ tbl <- rtables::build_table(lyt = lyt, df = ANL[order(ANL[[y_name]]), ]) |
|
| 32 | -+ | ||
| 391 | +! |
- #' Defaults to `TRUE`.+ tbl |
|
| 33 | +392 |
- #' @param freq (`logical(1)`)+ }, |
|
| 34 | -+ | ||
| 393 | +! |
- #' Indicates whether to display frequency (`TRUE`) or density (`FALSE`).+ env = list(y_name = y_name) |
|
| 35 | +394 |
- #' Defaults to density (`FALSE`).+ ) |
|
| 36 | +395 |
- #'+ ) |
|
| 37 | +396 |
- #' @inherit shared_params return+ }) |
|
| 38 | +397 |
- #'+ |
|
| 39 | -+ | ||
| 398 | +! |
- #' @note For more examples, please see the vignette "Using response plot" via+ output$title <- renderText(output_q()[["title"]]) |
|
| 40 | +399 |
- #' `vignette("using-response-plot", package = "teal.modules.general")`.
+
|
|
| 41 | -+ | ||
| 400 | +! |
- #'+ table_r <- reactive({
|
|
| 42 | -+ | ||
| 401 | +! |
- #' @examplesShinylive+ req(iv_r()$is_valid()) |
|
| 43 | -+ | ||
| 402 | +! |
- #' library(teal.modules.general)+ output_q()[["tbl"]] |
|
| 44 | +403 |
- #' interactive <- function() TRUE+ }) |
|
| 45 | +404 |
- #' {{ next_example }}
+
|
|
| 46 | -+ | ||
| 405 | +! |
- #' @examples+ teal.widgets::table_with_settings_srv( |
|
| 47 | -+ | ||
| 406 | +! |
- #' # general data example+ id = "table", |
|
| 48 | -+ | ||
| 407 | +! |
- #' data <- teal_data()+ table_r = table_r |
|
| 49 | +408 |
- #' data <- within(data, {
+ ) |
|
| 50 | +409 |
- #' require(nestcolor)+ |
|
| 51 | -+ | ||
| 410 | +! |
- #' mtcars <- mtcars+ teal.widgets::verbatim_popup_srv( |
|
| 52 | -+ | ||
| 411 | +! |
- #' for (v in c("cyl", "vs", "am", "gear")) {
+ id = "rcode", |
|
| 53 | -+ | ||
| 412 | +! |
- #' mtcars[[v]] <- as.factor(mtcars[[v]])+ verbatim_content = reactive(teal.code::get_code(output_q())), |
|
| 54 | -+ | ||
| 413 | +! |
- #' }+ title = "Show R Code for Cross-Table" |
|
| 55 | +414 |
- #' })+ ) |
|
| 56 | +415 |
- #' datanames(data) <- "mtcars"+ |
|
| 57 | +416 |
- #'+ ### REPORTER |
|
| 58 | -+ | ||
| 417 | +! |
- #' app <- init(+ if (with_reporter) {
|
|
| 59 | -+ | ||
| 418 | +! |
- #' data = data,+ card_fun <- function(comment, label) {
|
|
| 60 | -+ | ||
| 419 | +! |
- #' modules = modules(+ card <- teal::report_card_template( |
|
| 61 | -+ | ||
| 420 | +! |
- #' tm_g_response(+ title = "Cross Table", |
|
| 62 | -+ | ||
| 421 | +! |
- #' label = "Response Plots",+ label = label, |
|
| 63 | -+ | ||
| 422 | +! |
- #' response = data_extract_spec(+ with_filter = with_filter, |
|
| 64 | -+ | ||
| 423 | +! |
- #' dataname = "mtcars",+ filter_panel_api = filter_panel_api |
|
| 65 | +424 |
- #' select = select_spec(+ ) |
|
| 66 | -+ | ||
| 425 | +! |
- #' label = "Select variable:",+ card$append_text("Table", "header3")
|
|
| 67 | -+ | ||
| 426 | +! |
- #' choices = variable_choices(data[["mtcars"]], c("cyl", "gear")),
+ card$append_table(table_r()) |
|
| 68 | -+ | ||
| 427 | +! |
- #' selected = "cyl",+ if (!comment == "") {
|
|
| 69 | -+ | ||
| 428 | +! |
- #' multiple = FALSE,+ card$append_text("Comment", "header3")
|
|
| 70 | -+ | ||
| 429 | +! |
- #' fixed = FALSE+ card$append_text(comment) |
|
| 71 | +430 |
- #' )+ } |
|
| 72 | -+ | ||
| 431 | +! |
- #' ),+ card$append_src(teal.code::get_code(output_q())) |
|
| 73 | -+ | ||
| 432 | +! |
- #' x = data_extract_spec(+ card |
|
| 74 | +433 |
- #' dataname = "mtcars",+ } |
|
| 75 | -+ | ||
| 434 | +! |
- #' select = select_spec(+ teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
|
|
| 76 | +435 |
- #' label = "Select variable:",+ } |
|
| 77 | +436 |
- #' choices = variable_choices(data[["mtcars"]], c("vs", "am")),
+ ### |
|
| 78 | +437 |
- #' selected = "vs",+ }) |
|
| 79 | +438 |
- #' multiple = FALSE,+ } |
| 80 | +1 |
- #' fixed = FALSE+ #' `teal` module: Scatterplot and regression analysis |
|
| 81 | +2 |
- #' )+ #' |
|
| 82 | +3 |
- #' )+ #' Module for visualizing regression analysis, including scatterplots and |
|
| 83 | +4 |
- #' )+ #' various regression diagnostics plots. |
|
| 84 | +5 |
- #' )+ #' It allows users to explore the relationship between a set of regressors and a response variable, |
|
| 85 | +6 |
- #' )+ #' visualize residuals, and identify outliers. |
|
| 86 | +7 |
- #' if (interactive()) {
+ #' |
|
| 87 | +8 |
- #' shinyApp(app$ui, app$server)+ #' @note For more examples, please see the vignette "Using regression plots" via |
|
| 88 | +9 |
- #' }+ #' `vignette("using-regression-plots", package = "teal.modules.general")`.
|
|
| 89 | +10 |
#' |
|
| 90 | +11 |
- #' @examplesShinylive+ #' @inheritParams teal::module |
|
| 91 | +12 |
- #' library(teal.modules.general)+ #' @inheritParams shared_params |
|
| 92 | +13 |
- #' interactive <- function() TRUE+ #' @param regressor (`data_extract_spec` or `list` of multiple `data_extract_spec`) |
|
| 93 | +14 |
- #' {{ next_example }}
+ #' Regressor variables from an incoming dataset with filtering and selecting. |
|
| 94 | +15 |
- #' @examples+ #' @param response (`data_extract_spec` or `list` of multiple `data_extract_spec`) |
|
| 95 | +16 |
- #' # CDISC data example+ #' Response variables from an incoming dataset with filtering and selecting. |
|
| 96 | +17 |
- #' data <- teal_data()+ #' @param default_outlier_label (`character`) optional, default column selected to label outliers. |
|
| 97 | +18 |
- #' data <- within(data, {
+ #' @param default_plot_type (`numeric`) optional, defaults to "Response vs Regressor". |
|
| 98 | +19 |
- #' require(nestcolor)+ #' 1. Response vs Regressor |
|
| 99 | +20 |
- #' ADSL <- rADSL+ #' 2. Residuals vs Fitted |
|
| 100 | +21 |
- #' })+ #' 3. Normal Q-Q |
|
| 101 | +22 |
- #' datanames(data) <- c("ADSL")
+ #' 4. Scale-Location |
|
| 102 | +23 |
- #' join_keys(data) <- default_cdisc_join_keys[datanames(data)]+ #' 5. Cook's distance |
|
| 103 | +24 |
- #'+ #' 6. Residuals vs Leverage |
|
| 104 | +25 |
- #' app <- init(+ #' 7. Cook's dist vs Leverage |
|
| 105 | +26 |
- #' data = data,+ #' @param label_segment_threshold (`numeric(1)` or `numeric(3)`) |
|
| 106 | +27 |
- #' modules = modules(+ #' Minimum distance between label and point on the plot that triggers the creation of |
|
| 107 | +28 |
- #' tm_g_response(+ #' a line segment between the two. |
|
| 108 | +29 |
- #' label = "Response Plots",+ #' This may happen when the label cannot be placed next to the point as it overlaps another |
|
| 109 | +30 |
- #' response = data_extract_spec(+ #' label or point. |
|
| 110 | +31 |
- #' dataname = "ADSL",+ #' The value is used as the `min.segment.length` parameter to the [ggrepel::geom_text_repel()] function. |
|
| 111 | +32 |
- #' select = select_spec(+ #' |
|
| 112 | +33 |
- #' label = "Select variable:",+ #' It can take the following forms: |
|
| 113 | +34 |
- #' choices = variable_choices(data[["ADSL"]], c("BMRKR2", "COUNTRY")),
+ #' - `numeric(1)`: Fixed value used for the minimum distance and the slider is not presented in the UI. |
|
| 114 | +35 |
- #' selected = "BMRKR2",+ #' - `numeric(3)`: A slider is presented in the UI (under "Plot settings") to adjust the minimum distance dynamically. |
|
| 115 | +36 |
- #' multiple = FALSE,+ #' |
|
| 116 | +37 |
- #' fixed = FALSE+ #' It takes the form of `c(value, min, max)` and it is passed to the `value_min_max` |
|
| 117 | +38 |
- #' )+ #' argument in `teal.widgets::optionalSliderInputValMinMax`. |
|
| 118 | +39 |
- #' ),+ #' |
|
| 119 | +40 |
- #' x = data_extract_spec(+ #' @templateVar ggnames `r regression_names` |
|
| 120 | +41 |
- #' dataname = "ADSL",+ #' @template ggplot2_args_multi |
|
| 121 | +42 |
- #' select = select_spec(+ #' |
|
| 122 | +43 |
- #' label = "Select variable:",+ #' @inherit shared_params return |
|
| 123 | +44 |
- #' choices = variable_choices(data[["ADSL"]], c("SEX", "RACE")),
+ #' |
|
| 124 | +45 |
- #' selected = "RACE",+ #' @examplesShinylive |
|
| 125 | +46 |
- #' multiple = FALSE,+ #' library(teal.modules.general) |
|
| 126 | +47 |
- #' fixed = FALSE+ #' interactive <- function() TRUE |
|
| 127 | +48 |
- #' )+ #' {{ next_example }}
|
|
| 128 | +49 |
- #' )+ #' @examples |
|
| 129 | +50 |
- #' )+ #' # general data example |
|
| 130 | +51 |
- #' )+ #' data <- teal_data() |
|
| 131 | +52 |
- #' )+ #' data <- within(data, {
|
|
| 132 | +53 |
- #' if (interactive()) {
+ #' require(nestcolor) |
|
| 133 | +54 |
- #' shinyApp(app$ui, app$server)+ #' CO2 <- CO2 |
|
| 134 | +55 |
- #' }+ #' }) |
|
| 135 | +56 |
#' |
|
| 136 | +57 |
- #' @export+ #' app <- init( |
|
| 137 | +58 |
- #'+ #' data = data, |
|
| 138 | +59 |
- tm_g_response <- function(label = "Response Plot",+ #' modules = modules( |
|
| 139 | +60 |
- response,+ #' tm_a_regression( |
|
| 140 | +61 |
- x,+ #' label = "Regression", |
|
| 141 | +62 |
- row_facet = NULL,+ #' response = data_extract_spec( |
|
| 142 | +63 |
- col_facet = NULL,+ #' dataname = "CO2", |
|
| 143 | +64 |
- coord_flip = FALSE,+ #' select = select_spec( |
|
| 144 | +65 |
- count_labels = TRUE,+ #' label = "Select variable:", |
|
| 145 | +66 |
- rotate_xaxis_labels = FALSE,+ #' choices = "uptake", |
|
| 146 | +67 |
- freq = FALSE,+ #' selected = "uptake", |
|
| 147 | +68 |
- plot_height = c(600, 400, 5000),+ #' multiple = FALSE, |
|
| 148 | +69 |
- plot_width = NULL,+ #' fixed = TRUE |
|
| 149 | +70 |
- ggtheme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void"),
+ #' ) |
|
| 150 | +71 |
- ggplot2_args = teal.widgets::ggplot2_args(),+ #' ), |
|
| 151 | +72 |
- pre_output = NULL,+ #' regressor = data_extract_spec( |
|
| 152 | +73 |
- post_output = NULL) {
- |
- |
| 153 | -! | -
- message("Initializing tm_g_response")
+ #' dataname = "CO2", |
|
| 154 | +74 |
-
+ #' select = select_spec( |
|
| 155 | +75 |
- # Normalize the parameters- |
- |
| 156 | -! | -
- if (inherits(response, "data_extract_spec")) response <- list(response)- |
- |
| 157 | -! | -
- if (inherits(x, "data_extract_spec")) x <- list(x)- |
- |
| 158 | -! | -
- if (inherits(row_facet, "data_extract_spec")) row_facet <- list(row_facet)- |
- |
| 159 | -! | -
- if (inherits(col_facet, "data_extract_spec")) col_facet <- list(col_facet)+ #' label = "Select variables:", |
|
| 160 | +76 |
-
+ #' choices = variable_choices(data[["CO2"]], c("conc", "Treatment")),
|
|
| 161 | +77 |
- # Start of assertions- |
- |
| 162 | -! | -
- checkmate::assert_string(label)+ #' selected = "conc", |
|
| 163 | +78 |
-
+ #' multiple = TRUE, |
|
| 164 | -! | +||
| 79 | +
- checkmate::assert_list(response, types = "data_extract_spec")+ #' fixed = FALSE |
||
| 165 | -! | +||
| 80 | +
- if (!all(vapply(response, function(x) !("" %in% x$select$choices), logical(1)))) {
+ #' ) |
||
| 166 | -! | +||
| 81 | +
- stop("'response' should not allow empty values")
+ #' ) |
||
| 167 | +82 |
- }+ #' ) |
|
| 168 | -! | +||
| 83 | +
- assert_single_selection(response)+ #' ) |
||
| 169 | +84 |
-
+ #' ) |
|
| 170 | -! | +||
| 85 | +
- checkmate::assert_list(x, types = "data_extract_spec")+ #' if (interactive()) {
|
||
| 171 | -! | +||
| 86 | +
- if (!all(vapply(x, function(x) !("" %in% x$select$choices), logical(1)))) {
+ #' shinyApp(app$ui, app$server) |
||
| 172 | -! | +||
| 87 | +
- stop("'x' should not allow empty values")
+ #' } |
||
| 173 | +88 |
- }+ #' |
|
| 174 | -! | +||
| 89 | +
- assert_single_selection(x)+ #' @examplesShinylive |
||
| 175 | +90 |
-
+ #' library(teal.modules.general) |
|
| 176 | -! | +||
| 91 | +
- checkmate::assert_list(row_facet, types = "data_extract_spec", null.ok = TRUE)+ #' interactive <- function() TRUE |
||
| 177 | -! | +||
| 92 | +
- checkmate::assert_list(col_facet, types = "data_extract_spec", null.ok = TRUE)+ #' {{ next_example }}
|
||
| 178 | -! | +||
| 93 | +
- checkmate::assert_flag(coord_flip)+ #' @examples |
||
| 179 | -! | +||
| 94 | +
- checkmate::assert_flag(count_labels)+ #' # CDISC data example |
||
| 180 | -! | +||
| 95 | +
- checkmate::assert_flag(rotate_xaxis_labels)+ #' data <- teal_data() |
||
| 181 | -! | +||
| 96 | +
- checkmate::assert_flag(freq)+ #' data <- within(data, {
|
||
| 182 | +97 |
-
+ #' require(nestcolor) |
|
| 183 | -! | +||
| 98 | +
- checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE)+ #' ADSL <- rADSL |
||
| 184 | -! | +||
| 99 | +
- checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height")+ #' }) |
||
| 185 | -! | +||
| 100 | +
- checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE)+ #' join_keys(data) <- default_cdisc_join_keys[names(data)] |
||
| 186 | -! | +||
| 101 | +
- checkmate::assert_numeric(+ #' |
||
| 187 | -! | +||
| 102 | +
- plot_width[1],+ #' app <- init( |
||
| 188 | -! | +||
| 103 | +
- lower = plot_width[2], upper = plot_width[3], null.ok = TRUE, .var.name = "plot_width"+ #' data = data, |
||
| 189 | +104 |
- )+ #' modules = modules( |
|
| 190 | +105 |
-
+ #' tm_a_regression( |
|
| 191 | -! | +||
| 106 | +
- ggtheme <- match.arg(ggtheme)+ #' label = "Regression", |
||
| 192 | -! | +||
| 107 | +
- checkmate::assert_class(ggplot2_args, "ggplot2_args")+ #' response = data_extract_spec( |
||
| 193 | +108 |
-
+ #' dataname = "ADSL", |
|
| 194 | -! | +||
| 109 | +
- checkmate::assert_multi_class(pre_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
+ #' select = select_spec( |
||
| 195 | -! | +||
| 110 | +
- checkmate::assert_multi_class(post_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
+ #' label = "Select variable:", |
||
| 196 | +111 |
- # End of assertions+ #' choices = "BMRKR1", |
|
| 197 | +112 |
-
+ #' selected = "BMRKR1", |
|
| 198 | +113 |
- # Make UI args+ #' multiple = FALSE, |
|
| 199 | -! | +||
| 114 | +
- args <- as.list(environment())+ #' fixed = TRUE |
||
| 200 | +115 |
-
+ #' ) |
|
| 201 | -! | +||
| 116 | +
- data_extract_list <- list(+ #' ), |
||
| 202 | -! | +||
| 117 | +
- response = response,+ #' regressor = data_extract_spec( |
||
| 203 | -! | +||
| 118 | +
- x = x,+ #' dataname = "ADSL", |
||
| 204 | -! | +||
| 119 | +
- row_facet = row_facet,+ #' select = select_spec( |
||
| 205 | -! | +||
| 120 | +
- col_facet = col_facet+ #' label = "Select variables:", |
||
| 206 | +121 |
- )+ #' choices = variable_choices(data[["ADSL"]], c("AGE", "SEX", "RACE")),
|
|
| 207 | +122 |
-
+ #' selected = "AGE", |
|
| 208 | -! | +||
| 123 | +
- ans <- module(+ #' multiple = TRUE, |
||
| 209 | -! | +||
| 124 | +
- label = label,+ #' fixed = FALSE |
||
| 210 | -! | +||
| 125 | +
- server = srv_g_response,+ #' ) |
||
| 211 | -! | +||
| 126 | +
- ui = ui_g_response,+ #' ) |
||
| 212 | -! | +||
| 127 | +
- ui_args = args,+ #' ) |
||
| 213 | -! | +||
| 128 | +
- server_args = c(+ #' ) |
||
| 214 | -! | +||
| 129 | +
- data_extract_list,+ #' ) |
||
| 215 | -! | +||
| 130 | +
- list(plot_height = plot_height, plot_width = plot_width, ggplot2_args = ggplot2_args)+ #' if (interactive()) {
|
||
| 216 | +131 |
- ),+ #' shinyApp(app$ui, app$server) |
|
| 217 | -! | +||
| 132 | +
- datanames = teal.transform::get_extract_datanames(data_extract_list)+ #' } |
||
| 218 | +133 |
- )+ #' |
|
| 219 | -! | +||
| 134 | +
- attr(ans, "teal_bookmarkable") <- TRUE+ #' @export |
||
| 220 | -! | +||
| 135 | +
- ans+ #' |
||
| 221 | +136 |
- }+ tm_a_regression <- function(label = "Regression Analysis", |
|
| 222 | +137 |
-
+ regressor, |
|
| 223 | +138 |
- # UI function for the response module+ response, |
|
| 224 | +139 |
- ui_g_response <- function(id, ...) {
+ plot_height = c(600, 200, 2000), |
|
| 225 | -! | +||
| 140 | +
- ns <- NS(id)+ plot_width = NULL, |
||
| 226 | -! | +||
| 141 | +
- args <- list(...)+ alpha = c(1, 0, 1), |
||
| 227 | -! | +||
| 142 | +
- is_single_dataset_value <- teal.transform::is_single_dataset(args$response, args$x, args$row_facet, args$col_facet)+ size = c(2, 1, 8), |
||
| 228 | +143 |
-
+ ggtheme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void"),
|
|
| 229 | -! | +||
| 144 | +
- teal.widgets::standard_layout(+ ggplot2_args = teal.widgets::ggplot2_args(), |
||
| 230 | -! | +||
| 145 | +
- output = teal.widgets::white_small_well(+ pre_output = NULL, |
||
| 231 | -! | +||
| 146 | +
- teal.widgets::plot_with_settings_ui(id = ns("myplot"))
+ post_output = NULL, |
||
| 232 | +147 |
- ),+ default_plot_type = 1, |
|
| 233 | -! | +||
| 148 | +
- encoding = tags$div(+ default_outlier_label = "USUBJID", |
||
| 234 | +149 |
- ### Reporter+ label_segment_threshold = c(0.5, 0, 10)) {
|
|
| 235 | +150 | ! |
- teal.reporter::simple_reporter_ui(ns("simple_reporter")),
+ message("Initializing tm_a_regression")
|
| 236 | +151 |
- ###+ |
|
| 237 | -! | +||
| 152 | +
- tags$label("Encodings", class = "text-primary"),
+ # Normalize the parameters |
||
| 238 | +153 | ! |
- teal.transform::datanames_input(args[c("response", "x", "row_facet", "col_facet")]),
+ if (inherits(regressor, "data_extract_spec")) regressor <- list(regressor) |
| 239 | +154 | ! |
- teal.transform::data_extract_ui(+ if (inherits(response, "data_extract_spec")) response <- list(response) |
| 240 | +155 | ! |
- id = ns("response"),
+ if (inherits(ggplot2_args, "ggplot2_args")) ggplot2_args <- list(default = ggplot2_args) |
| 241 | -! | +||
| 156 | +
- label = "Response variable",+ + |
+ ||
| 157 | ++ |
+ # Start of assertions |
|
| 242 | +158 | ! |
- data_extract_spec = args$response,+ checkmate::assert_string(label) |
| 243 | +159 | ! |
- is_single_dataset = is_single_dataset_value+ checkmate::assert_list(regressor, types = "data_extract_spec") |
| 244 | +160 |
- ),+ |
|
| 245 | +161 | ! |
- teal.transform::data_extract_ui(+ checkmate::assert_list(response, types = "data_extract_spec") |
| 246 | +162 | ! |
- id = ns("x"),
+ assert_single_selection(response) |
| 247 | -! | +||
| 163 | +
- label = "X variable",+ |
||
| 248 | +164 | ! |
- data_extract_spec = args$x,+ checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE) |
| 249 | +165 | ! |
- is_single_dataset = is_single_dataset_value+ checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height") |
| 250 | +166 |
- ),+ |
|
| 251 | +167 | ! |
- if (!is.null(args$row_facet)) {
+ checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE) |
| 252 | +168 | ! |
- teal.transform::data_extract_ui(+ checkmate::assert_numeric( |
| 253 | +169 | ! |
- id = ns("row_facet"),
+ plot_width[1], |
| 254 | +170 | ! |
- label = "Row facetting",+ lower = plot_width[2], |
| 255 | +171 | ! |
- data_extract_spec = args$row_facet,+ upper = plot_width[3], |
| 256 | +172 | ! |
- is_single_dataset = is_single_dataset_value+ null.ok = TRUE, |
| 257 | -+ | ||
| 173 | +! |
- )+ .var.name = "plot_width" |
|
| 258 | +174 |
- },+ ) |
|
| 259 | -! | +||
| 175 | +
- if (!is.null(args$col_facet)) {
+
|
||
| 260 | +176 | ! |
- teal.transform::data_extract_ui(+ if (length(alpha) == 1) {
|
| 261 | +177 | ! |
- id = ns("col_facet"),
+ checkmate::assert_numeric(alpha, any.missing = FALSE, finite = TRUE) |
| 262 | -! | +||
| 178 | +
- label = "Column facetting",+ } else {
|
||
| 263 | +179 | ! |
- data_extract_spec = args$col_facet,+ checkmate::assert_numeric(alpha, len = 3, any.missing = FALSE, finite = TRUE) |
| 264 | +180 | ! |
- is_single_dataset = is_single_dataset_value+ checkmate::assert_numeric(alpha[1], lower = alpha[2], upper = alpha[3], .var.name = "alpha") |
| 265 | +181 |
- )+ } |
|
| 266 | +182 |
- },+ |
|
| 267 | +183 | ! |
- shinyWidgets::radioGroupButtons(+ if (length(size) == 1) {
|
| 268 | +184 | ! |
- inputId = ns("freq"),
+ checkmate::assert_numeric(size, any.missing = FALSE, finite = TRUE) |
| 269 | -! | +||
| 185 | +
- label = NULL,+ } else {
|
||
| 270 | +186 | ! |
- choices = c("frequency", "density"),
+ checkmate::assert_numeric(size, len = 3, any.missing = FALSE, finite = TRUE) |
| 271 | +187 | ! |
- selected = ifelse(args$freq, "frequency", "density"),+ checkmate::assert_numeric(size[1], lower = size[2], upper = size[3], .var.name = "size") |
| 272 | -! | +||
| 188 | +
- justified = TRUE+ } |
||
| 273 | +189 |
- ),+ |
|
| 274 | +190 | ! |
- teal.widgets::panel_group(+ ggtheme <- match.arg(ggtheme)+ |
+
| 191 | ++ | + | |
| 275 | +192 | ! |
- teal.widgets::panel_item(+ plot_choices <- c( |
| 276 | +193 | ! |
- title = "Plot settings",+ "Response vs Regressor", "Residuals vs Fitted", "Normal Q-Q", "Scale-Location", |
| 277 | +194 | ! |
- checkboxInput(ns("count_labels"), "Add count labels", value = args$count_labels),
+ "Cook's distance", "Residuals vs Leverage", "Cook's dist vs Leverage" |
| 278 | -! | +||
| 195 | +
- checkboxInput(ns("coord_flip"), "Swap axes", value = args$coord_flip),
+ ) |
||
| 279 | +196 | ! |
- checkboxInput(ns("rotate_xaxis_labels"), "Rotate X axis labels", value = args$rotate_xaxis_labels),
+ checkmate::assert_list(ggplot2_args, types = "ggplot2_args") |
| 280 | +197 | ! |
- selectInput(+ checkmate::assert_subset(names(ggplot2_args), c("default", plot_choices))
|
| 281 | -! | +||
| 198 | +
- inputId = ns("ggtheme"),
+
|
||
| 282 | +199 | ! |
- label = "Theme (by ggplot):",+ checkmate::assert_multi_class(pre_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
|
| 283 | +200 | ! |
- choices = ggplot_themes,+ checkmate::assert_multi_class(post_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
|
| 284 | +201 | ! |
- selected = args$ggtheme,+ checkmate::assert_choice(default_plot_type, seq.int(1L, length(plot_choices))) |
| 285 | +202 | ! |
- multiple = FALSE+ checkmate::assert_string(default_outlier_label) |
| 286 | +203 |
- )+ |
|
| 287 | -+ | ||
| 204 | +! |
- )+ if (length(label_segment_threshold) == 1) {
|
|
| 288 | -+ | ||
| 205 | +! |
- )+ checkmate::assert_numeric(label_segment_threshold, any.missing = FALSE, finite = TRUE) |
|
| 289 | +206 |
- ),+ } else {
|
|
| 290 | +207 | ! |
- forms = tagList(+ checkmate::assert_numeric(label_segment_threshold, len = 3, any.missing = FALSE, finite = TRUE) |
| 291 | +208 | ! |
- teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code")
- |
-
| 292 | -- |
- ),+ checkmate::assert_numeric( |
|
| 293 | +209 | ! |
- pre_output = args$pre_output,+ label_segment_threshold[1], |
| 294 | +210 | ! |
- post_output = args$post_output- |
-
| 295 | -- |
- )+ lower = label_segment_threshold[2], |
|
| 296 | -+ | ||
| 211 | +! |
- }+ upper = label_segment_threshold[3], |
|
| 297 | -+ | ||
| 212 | +! |
-
+ .var.name = "label_segment_threshold" |
|
| 298 | +213 |
- # Server function for the response module+ ) |
|
| 299 | +214 |
- srv_g_response <- function(id,+ } |
|
| 300 | +215 |
- data,+ # End of assertions |
|
| 301 | +216 |
- reporter,+ |
|
| 302 | +217 |
- filter_panel_api,+ # Make UI args |
|
| 303 | -+ | ||
| 218 | +! |
- response,+ args <- as.list(environment()) |
|
| 304 | -+ | ||
| 219 | +! |
- x,+ args[["plot_choices"]] <- plot_choices |
|
| 305 | -+ | ||
| 220 | +! |
- row_facet,+ data_extract_list <- list( |
|
| 306 | -+ | ||
| 221 | +! |
- col_facet,+ regressor = regressor, |
|
| 307 | -+ | ||
| 222 | +! |
- plot_height,+ response = response |
|
| 308 | +223 |
- plot_width,+ ) |
|
| 309 | +224 |
- ggplot2_args) {
+
|
|
| 310 | +225 | ! |
- with_reporter <- !missing(reporter) && inherits(reporter, "Reporter")+ ans <- module( |
| 311 | +226 | ! |
- with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI")+ label = label, |
| 312 | +227 | ! |
- checkmate::assert_class(data, "reactive")+ server = srv_a_regression, |
| 313 | +228 | ! |
- checkmate::assert_class(isolate(data()), "teal_data")+ ui = ui_a_regression, |
| 314 | +229 | ! |
- moduleServer(id, function(input, output, session) {
+ ui_args = args, |
| 315 | +230 | ! |
- teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.general")- |
-
| 316 | -- |
-
+ server_args = c( |
|
| 317 | +231 | ! |
- data_extract <- list(response = response, x = x, row_facet = row_facet, col_facet = col_facet)+ data_extract_list, |
| 318 | -+ | ||
| 232 | +! |
-
+ list( |
|
| 319 | +233 | ! |
- rule_diff <- function(other) {
+ plot_height = plot_height, |
| 320 | +234 | ! |
- function(value) {
+ plot_width = plot_width, |
| 321 | +235 | ! |
- if (other %in% names(selector_list())) {
+ default_outlier_label = default_outlier_label, |
| 322 | +236 | ! |
- othervalue <- selector_list()[[other]]()[["select"]]+ ggplot2_args = ggplot2_args |
| 323 | -! | +||
| 237 | +
- if (!is.null(othervalue)) {
+ ) |
||
| 324 | -! | +||
| 238 | +
- if (identical(value, othervalue)) {
+ ), |
||
| 325 | +239 | ! |
- "Row and column facetting variables must be different."+ datanames = teal.transform::get_extract_datanames(data_extract_list) |
| 326 | +240 |
- }+ ) |
|
| 327 | -+ | ||
| 241 | +! |
- }+ attr(ans, "teal_bookmarkable") <- FALSE+ |
+ |
| 242 | +! | +
+ ans |
|
| 328 | +243 |
- }+ } |
|
| 329 | +244 |
- }+ |
|
| 330 | +245 |
- }+ # UI function for the regression module |
|
| 331 | +246 |
-
+ ui_a_regression <- function(id, ...) {
|
|
| 332 | +247 | ! |
- selector_list <- teal.transform::data_extract_multiple_srv(+ ns <- NS(id) |
| 333 | +248 | ! |
- data_extract = data_extract,+ args <- list(...) |
| 334 | +249 | ! |
- datasets = data,+ is_single_dataset_value <- teal.transform::is_single_dataset(args$regressor, args$response) |
| 335 | -! | +||
| 250 | +
- select_validation_rule = list(+ |
||
| 336 | +251 | ! |
- response = shinyvalidate::sv_required("Please define a column for the response variable"),
+ teal.widgets::standard_layout( |
| 337 | +252 | ! |
- x = shinyvalidate::sv_required("Please define a column for X variable"),
+ output = teal.widgets::white_small_well(tags$div( |
| 338 | +253 | ! |
- row_facet = shinyvalidate::compose_rules(+ teal.widgets::plot_with_settings_ui(id = ns("myplot")),
|
| 339 | +254 | ! |
- shinyvalidate::sv_optional(),+ tags$div(verbatimTextOutput(ns("text")))
|
| 340 | -! | +||
| 255 | +
- ~ if (length(.) > 1) "There must be 1 or no row facetting variable.",+ )), |
||
| 341 | +256 | ! |
- rule_diff("col_facet")
+ encoding = tags$div( |
| 342 | +257 |
- ),+ ### Reporter |
|
| 343 | +258 | ! |
- col_facet = shinyvalidate::compose_rules(+ teal.reporter::simple_reporter_ui(ns("simple_reporter")),
|
| 344 | -! | +||
| 259 | +
- shinyvalidate::sv_optional(),+ ### |
||
| 345 | +260 | ! |
- ~ if (length(.) > 1) "There must be 1 or no column facetting variable.",+ tags$label("Encodings", class = "text-primary"),
|
| 346 | +261 | ! |
- rule_diff("row_facet")
- |
-
| 347 | -- |
- )- |
- |
| 348 | -- |
- )- |
- |
| 349 | -- |
- )+ teal.transform::datanames_input(args[c("response", "regressor")]),
|
|
| 350 | -+ | ||
| 262 | +! |
-
+ teal.transform::data_extract_ui( |
|
| 351 | +263 | ! |
- iv_r <- reactive({
+ id = ns("response"),
|
| 352 | +264 | ! |
- iv <- shinyvalidate::InputValidator$new()+ label = "Response variable", |
| 353 | +265 | ! |
- iv$add_rule("ggtheme", shinyvalidate::sv_required("Please select a theme"))
+ data_extract_spec = args$response, |
| 354 | +266 | ! |
- teal.transform::compose_and_enable_validators(iv, selector_list)+ is_single_dataset = is_single_dataset_value |
| 355 | +267 |
- })+ ), |
|
| 356 | -+ | ||
| 268 | +! |
-
+ teal.transform::data_extract_ui( |
|
| 357 | +269 | ! |
- anl_merged_input <- teal.transform::merge_expression_srv(+ id = ns("regressor"),
|
| 358 | +270 | ! |
- selector_list = selector_list,+ label = "Regressor variables", |
| 359 | +271 | ! |
- datasets = data+ data_extract_spec = args$regressor, |
| 360 | -+ | ||
| 272 | +! |
- )+ is_single_dataset = is_single_dataset_value |
|
| 361 | +273 |
-
+ ), |
|
| 362 | +274 | ! |
- anl_merged_q <- reactive({
+ radioButtons( |
| 363 | +275 | ! |
- req(anl_merged_input())+ ns("plot_type"),
|
| 364 | +276 | ! |
- data() %>%+ label = "Plot type:", |
| 365 | +277 | ! |
- teal.code::eval_code(as.expression(anl_merged_input()$expr))+ choices = args$plot_choices, |
| 366 | -+ | ||
| 278 | +! |
- })+ selected = args$plot_choices[args$default_plot_type] |
|
| 367 | +279 |
-
+ ), |
|
| 368 | +280 | ! |
- merged <- list(+ checkboxInput(ns("show_outlier"), label = "Display outlier labels", value = TRUE),
|
| 369 | +281 | ! |
- anl_input_r = anl_merged_input,+ conditionalPanel( |
| 370 | +282 | ! |
- anl_q_r = anl_merged_q+ condition = "input['show_outlier']", |
| 371 | -+ | ||
| 283 | +! |
- )+ ns = ns, |
- |
| 372 | -+ | ||
| 284 | +! |
-
+ teal.widgets::optionalSliderInput( |
|
| 373 | +285 | ! |
- output_q <- reactive({
+ ns("outlier"),
|
| 374 | +286 | ! |
- teal::validate_inputs(iv_r())+ tags$div( |
| 375 | -+ | ||
| 287 | +! |
-
+ class = "teal-tooltip", |
|
| 376 | +288 | ! |
- qenv <- merged$anl_q_r()+ tagList( |
| 377 | +289 | ! |
- ANL <- qenv[["ANL"]]+ "Outlier definition:", |
| 378 | +290 | ! |
- resp_var <- as.vector(merged$anl_input_r()$columns_source$response)+ icon("circle-info"),
|
| 379 | +291 | ! |
- x <- as.vector(merged$anl_input_r()$columns_source$x)+ tags$span( |
| 380 | -+ | ||
| 292 | +! |
-
+ class = "tooltiptext", |
|
| 381 | +293 | ! |
- validate(need(is.factor(ANL[[resp_var]]), "Please select a factor variable as the response."))+ paste( |
| 382 | +294 | ! |
- validate(need(is.factor(ANL[[x]]), "Please select a factor variable as the X-Variable."))+ "Use the slider to choose the cut-off value to define outliers.", |
| 383 | +295 | ! |
- teal::validate_has_data(ANL, 10)+ "Points with a Cook's distance greater than", |
| 384 | +296 | ! |
- teal::validate_has_data(ANL[, c(resp_var, x)], 10, complete = TRUE, allow_inf = FALSE)+ "the value on the slider times the mean of the Cook's distance of the dataset will have labels." |
| 385 | +297 |
-
+ ) |
|
| 386 | -! | +||
| 298 | +
- row_facet_name <- if (length(merged$anl_input_r()$columns_source$row_facet) == 0) {
+ ) |
||
| 387 | -! | +||
| 299 | +
- character(0)+ ) |
||
| 388 | +300 |
- } else {
+ ), |
|
| 389 | +301 | ! |
- as.vector(merged$anl_input_r()$columns_source$row_facet)+ min = 1, max = 10, value = 9, ticks = FALSE, step = .1 |
| 390 | +302 |
- }+ ), |
|
| 391 | +303 | ! |
- col_facet_name <- if (length(merged$anl_input_r()$columns_source$col_facet) == 0) {
+ teal.widgets::optionalSelectInput( |
| 392 | +304 | ! |
- character(0)+ ns("label_var"),
|
| 393 | -+ | ||
| 305 | +! |
- } else {
+ multiple = FALSE, |
|
| 394 | +306 | ! |
- as.vector(merged$anl_input_r()$columns_source$col_facet)+ label = "Outlier label" |
| 395 | +307 |
- }+ ) |
|
| 396 | +308 |
-
+ ), |
|
| 397 | +309 | ! |
- freq <- input$freq == "frequency"+ teal.widgets::panel_group( |
| 398 | +310 | ! |
- swap_axes <- input$coord_flip+ teal.widgets::panel_item( |
| 399 | +311 | ! |
- counts <- input$count_labels+ title = "Plot settings", |
| 400 | +312 | ! |
- rotate_xaxis_labels <- input$rotate_xaxis_labels+ teal.widgets::optionalSliderInputValMinMax(ns("alpha"), "Opacity:", args$alpha, ticks = FALSE),
|
| 401 | +313 | ! |
- ggtheme <- input$ggtheme- |
-
| 402 | -- |
-
+ teal.widgets::optionalSliderInputValMinMax(ns("size"), "Points size:", args$size, ticks = FALSE),
|
|
| 403 | +314 | ! |
- arg_position <- if (freq) "stack" else "fill"+ teal.widgets::optionalSliderInputValMinMax( |
| 404 | -+ | ||
| 315 | +! |
-
+ inputId = ns("label_min_segment"),
|
|
| 405 | +316 | ! |
- rowf <- if (length(row_facet_name) != 0) as.name(row_facet_name)+ label = tags$div( |
| 406 | +317 | ! |
- colf <- if (length(col_facet_name) != 0) as.name(col_facet_name)+ class = "teal-tooltip", |
| 407 | +318 | ! |
- resp_cl <- as.name(resp_var)+ tagList( |
| 408 | +319 | ! |
- x_cl <- as.name(x)+ "Label min. segment:", |
| 409 | -+ | ||
| 320 | +! |
-
+ icon("circle-info"),
|
|
| 410 | +321 | ! |
- if (swap_axes) {
+ tags$span( |
| 411 | +322 | ! |
- qenv <- teal.code::eval_code(+ class = "tooltiptext", |
| 412 | +323 | ! |
- qenv,+ paste( |
| 413 | +324 | ! |
- substitute(+ "Use the slider to choose the cut-off value to define minimum distance between label and point", |
| 414 | +325 | ! |
- expr = ANL[[x]] <- with(ANL, forcats::fct_rev(x_cl)),+ "that generates a line segment.", |
| 415 | +326 | ! |
- env = list(x = x, x_cl = x_cl)+ "It's only valid when 'Display outlier labels' is checked." |
| 416 | +327 |
- )+ ) |
|
| 417 | +328 |
- )+ ) |
|
| 418 | +329 |
- }+ ) |
|
| 419 | +330 |
-
+ ), |
|
| 420 | +331 | ! |
- qenv <- teal.code::eval_code(+ value_min_max = args$label_segment_threshold, |
| 421 | -! | +||
| 332 | +
- qenv,+ # Extra parameters to sliderInput |
||
| 422 | +333 | ! |
- substitute(+ ticks = FALSE, |
| 423 | +334 | ! |
- expr = ANL[[resp_var]] <- factor(ANL[[resp_var]]),+ step = .1, |
| 424 | +335 | ! |
- env = list(resp_var = resp_var)- |
-
| 425 | -- |
- )- |
- |
| 426 | -- |
- ) %>%+ round = FALSE |
|
| 427 | +336 |
- # rowf and colf will be a NULL if not set by a user+ ), |
|
| 428 | +337 | ! |
- teal.code::eval_code(+ selectInput( |
| 429 | +338 | ! |
- substitute(+ inputId = ns("ggtheme"),
|
| 430 | +339 | ! |
- expr = ANL2 <- ANL %>%+ label = "Theme (by ggplot):", |
| 431 | +340 | ! |
- dplyr::group_by_at(dplyr::vars(x_cl, resp_cl, rowf, colf)) %>%+ choices = ggplot_themes, |
| 432 | +341 | ! |
- dplyr::summarise(ns = dplyr::n()) %>%+ selected = args$ggtheme, |
| 433 | +342 | ! |
- dplyr::group_by_at(dplyr::vars(x_cl, rowf, colf)) %>%+ multiple = FALSE |
| 434 | -! | +||
| 343 | +
- dplyr::mutate(sums = sum(ns), percent = round(ns / sums * 100, 1)),+ ) |
||
| 435 | -! | +||
| 344 | +
- env = list(x_cl = x_cl, resp_cl = resp_cl, rowf = rowf, colf = colf)+ ) |
||
| 436 | +345 |
- )+ ) |
|
| 437 | +346 |
- ) %>%+ ), |
|
| 438 | +347 | ! |
- teal.code::eval_code(+ forms = tagList( |
| 439 | +348 | ! |
- substitute(+ teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code")
|
| 440 | -! | +||
| 349 | +
- expr = ANL3 <- ANL %>%+ ), |
||
| 441 | +350 | ! |
- dplyr::group_by_at(dplyr::vars(x_cl, rowf, colf)) %>%+ pre_output = args$pre_output, |
| 442 | +351 | ! |
- dplyr::summarise(ns = dplyr::n()),+ post_output = args$post_output |
| 443 | -! | +||
| 352 | +
- env = list(x_cl = x_cl, rowf = rowf, colf = colf)+ ) |
||
| 444 | +353 |
- )+ } |
|
| 445 | +354 |
- )+ |
|
| 446 | +355 |
-
+ # Server function for the regression module |
|
| 447 | -! | +||
| 356 | +
- plot_call <- substitute(+ srv_a_regression <- function(id, |
||
| 448 | -! | +||
| 357 | +
- expr = ggplot(ANL2, aes(x = x_cl, y = ns)) ++ data, |
||
| 449 | -! | +||
| 358 | +
- geom_bar(aes(fill = resp_cl), stat = "identity", position = arg_position),+ reporter, |
||
| 450 | -! | +||
| 359 | +
- env = list(+ filter_panel_api, |
||
| 451 | -! | +||
| 360 | +
- x_cl = x_cl,+ response, |
||
| 452 | -! | +||
| 361 | +
- resp_cl = resp_cl,+ regressor, |
||
| 453 | -! | +||
| 362 | +
- arg_position = arg_position+ plot_height, |
||
| 454 | +363 |
- )+ plot_width, |
|
| 455 | +364 |
- )+ ggplot2_args, |
|
| 456 | +365 |
-
+ default_outlier_label) {
|
|
| 457 | +366 | ! |
- if (!freq) {
+ with_reporter <- !missing(reporter) && inherits(reporter, "Reporter") |
| 458 | +367 | ! |
- plot_call <- substitute(+ with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI") |
| 459 | +368 | ! |
- plot_call + expand_limits(y = c(0, 1.1)),+ checkmate::assert_class(data, "reactive") |
| 460 | +369 | ! |
- env = list(plot_call = plot_call)+ checkmate::assert_class(isolate(data()), "teal_data") |
| 461 | -+ | ||
| 370 | +! |
- )+ moduleServer(id, function(input, output, session) {
|
|
| 462 | -+ | ||
| 371 | +! |
- }+ teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.general") |
|
| 463 | +372 | ||
| 464 | +373 | ! |
- if (counts) {
+ ns <- session$ns |
| 465 | -! | +||
| 374 | +
- plot_call <- substitute(+ |
||
| 466 | +375 | ! |
- expr = plot_call ++ rule_rvr1 <- function(value) {
|
| 467 | +376 | ! |
- geom_text(+ if (isTRUE(input$plot_type == "Response vs Regressor")) {
|
| 468 | +377 | ! |
- data = ANL2,+ if (length(value) > 1L) {
|
| 469 | +378 | ! |
- aes(label = ns, x = x_cl, y = ns, group = resp_cl),+ "This plot can only have one regressor." |
| 470 | -! | +||
| 379 | +
- col = "white",+ } |
||
| 471 | -! | +||
| 380 | +
- vjust = "middle",+ }+ |
+ ||
| 381 | ++ |
+ } |
|
| 472 | +382 | ! |
- hjust = "middle",+ rule_rvr2 <- function(other) {
|
| 473 | +383 | ! |
- position = position_anl2_value- |
-
| 474 | -- |
- ) ++ function(value) {
|
|
| 475 | +384 | ! |
- geom_text(+ if (isTRUE(input$plot_type == "Response vs Regressor")) {
|
| 476 | +385 | ! |
- data = ANL3, aes(label = ns, x = x_cl, y = anl3_y),+ otherval <- selector_list()[[other]]()$select |
| 477 | +386 | ! |
- hjust = hjust_value,+ if (isTRUE(value == otherval)) {
|
| 478 | +387 | ! |
- vjust = vjust_value,+ "Response and Regressor must be different." |
| 479 | -! | +||
| 388 | +
- position = position_anl3_value+ } |
||
| 480 | +389 |
- ),+ } |
|
| 481 | -! | +||
| 390 | +
- env = list(+ } |
||
| 482 | -! | +||
| 391 | +
- plot_call = plot_call,+ } |
||
| 483 | -! | +||
| 392 | +
- x_cl = x_cl,+ |
||
| 484 | +393 | ! |
- resp_cl = resp_cl,+ selector_list <- teal.transform::data_extract_multiple_srv( |
| 485 | +394 | ! |
- hjust_value = if (swap_axes) "left" else "middle",+ data_extract = list(response = response, regressor = regressor), |
| 486 | +395 | ! |
- vjust_value = if (swap_axes) "middle" else -1,+ datasets = data, |
| 487 | +396 | ! |
- position_anl2_value = if (!freq) quote(position_fill(0.5)) else quote(position_stack(0.5)), # nolint: line_length.+ select_validation_rule = list( |
| 488 | +397 | ! |
- anl3_y = if (!freq) 1.1 else as.name("ns"),
+ regressor = shinyvalidate::compose_rules( |
| 489 | +398 | ! |
- position_anl3_value = if (!freq) "fill" else "stack"+ shinyvalidate::sv_required("At least one regressor should be selected."),
|
| 490 | -+ | ||
| 399 | +! |
- )+ rule_rvr1, |
|
| 491 | -+ | ||
| 400 | +! |
- )+ rule_rvr2("response")
|
|
| 492 | +401 |
- }+ ), |
|
| 493 | -+ | ||
| 402 | +! |
-
+ response = shinyvalidate::compose_rules( |
|
| 494 | +403 | ! |
- if (swap_axes) {
+ shinyvalidate::sv_required("At least one response should be selected."),
|
| 495 | +404 | ! |
- plot_call <- substitute(plot_call + coord_flip(), env = list(plot_call = plot_call))+ rule_rvr2("regressor")
|
| 496 | +405 |
- }+ ) |
|
| 497 | +406 |
-
+ ) |
|
| 498 | -! | +||
| 407 | +
- facet_cl <- facet_ggplot_call(row_facet_name, col_facet_name)+ ) |
||
| 499 | +408 | ||
| 500 | +409 | ! |
- if (!is.null(facet_cl)) {
+ iv_r <- reactive({
|
| 501 | +410 | ! |
- plot_call <- substitute(expr = plot_call + facet_cl, env = list(plot_call = plot_call, facet_cl = facet_cl))+ iv <- shinyvalidate::InputValidator$new()+ |
+
| 411 | +! | +
+ teal.transform::compose_and_enable_validators(iv, selector_list) |
|
| 502 | +412 |
- }+ }) |
|
| 503 | +413 | ||
| 504 | +414 | ! |
- dev_ggplot2_args <- teal.widgets::ggplot2_args(+ iv_out <- shinyvalidate::InputValidator$new() |
| 505 | +415 | ! |
- labs = list(+ iv_out$condition(~ isTRUE(input$show_outlier)) |
| 506 | +416 | ! |
- x = varname_w_label(x, ANL),+ iv_out$add_rule("label_var", shinyvalidate::sv_required("Please provide an `Outlier label` variable"))
|
| 507 | +417 | ! |
- y = varname_w_label(resp_var, ANL, prefix = "Proportion of "),+ iv_out$enable()+ |
+
| 418 | ++ | + | |
| 508 | +419 | ! |
- fill = varname_w_label(resp_var, ANL)+ anl_merged_input <- teal.transform::merge_expression_srv( |
| 509 | -+ | ||
| 420 | +! |
- ),+ selector_list = selector_list, |
|
| 510 | +421 | ! |
- theme = list(legend.position = "bottom")+ datasets = data |
| 511 | +422 |
- )+ ) |
|
| 512 | +423 | ||
| 513 | +424 | ! |
- if (rotate_xaxis_labels) {
+ regression_var <- reactive({
|
| 514 | +425 | ! |
- dev_ggplot2_args$theme[["axis.text.x"]] <- quote(element_text(angle = 45, hjust = 1))- |
-
| 515 | -- |
- }+ teal::validate_inputs(iv_r()) |
|
| 516 | +426 | ||
| 517 | +427 | ! |
- all_ggplot2_args <- teal.widgets::resolve_ggplot2_args(+ list( |
| 518 | +428 | ! |
- user_plot = ggplot2_args,+ response = as.vector(anl_merged_input()$columns_source$response), |
| 519 | +429 | ! |
- module_plot = dev_ggplot2_args+ regressor = as.vector(anl_merged_input()$columns_source$regressor) |
| 520 | +430 |
) |
|
| 521 | +431 | ++ |
+ })+ |
+
| 432 | |||
| 522 | +433 | ! |
- parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(+ anl_merged_q <- reactive({
|
| 523 | +434 | ! |
- all_ggplot2_args,+ req(anl_merged_input()) |
| 524 | +435 | ! |
- ggtheme = ggtheme+ data() %>%+ |
+
| 436 | +! | +
+ teal.code::eval_code(as.expression(anl_merged_input()$expr)) |
|
| 525 | +437 |
- )+ }) |
|
| 526 | +438 | ||
| 527 | -! | +||
| 439 | +
- plot_call <- substitute(expr = {
+ # sets qenv object and populates it with data merge call and fit expression |
||
| 528 | +440 | ! |
- p <- plot_call + labs + ggthemes + themes+ fit_r <- reactive({
|
| 529 | +441 | ! |
- print(p)+ ANL <- anl_merged_q()[["ANL"]] |
| 530 | +442 | ! |
- }, env = list(+ teal::validate_has_data(ANL, 10) |
| 531 | -! | +||
| 443 | +
- plot_call = plot_call,+ |
||
| 532 | +444 | ! |
- labs = parsed_ggplot2_args$labs,+ validate(need(is.numeric(ANL[regression_var()$response][[1]]), "Response variable should be numeric.")) |
| 533 | -! | +||
| 445 | +
- themes = parsed_ggplot2_args$theme,+ |
||
| 534 | +446 | ! |
- ggthemes = parsed_ggplot2_args$ggtheme- |
-
| 535 | -- |
- ))+ teal::validate_has_data( |
|
| 536 | -+ | ||
| 447 | +! |
-
+ ANL[, c(regression_var()$response, regression_var()$regressor)], 10, |
|
| 537 | +448 | ! |
- teal.code::eval_code(qenv, plot_call)+ complete = TRUE, allow_inf = FALSE |
| 538 | +449 |
- })+ ) |
|
| 539 | +450 | ||
| 540 | +451 | ! |
- plot_r <- reactive(output_q()[["p"]])+ form <- stats::as.formula( |
| 541 | -+ | ||
| 452 | +! |
-
+ paste( |
|
| 542 | -+ | ||
| 453 | +! |
- # Insert the plot into a plot_with_settings module from teal.widgets+ regression_var()$response, |
|
| 543 | +454 | ! |
- pws <- teal.widgets::plot_with_settings_srv(+ paste( |
| 544 | +455 | ! |
- id = "myplot",+ regression_var()$regressor, |
| 545 | +456 | ! |
- plot_r = plot_r,+ collapse = " + " |
| 546 | -! | +||
| 457 | +
- height = plot_height,+ ), |
||
| 547 | +458 | ! |
- width = plot_width+ sep = " ~ " |
| 548 | +459 |
- )+ ) |
|
| 549 | +460 | ++ |
+ )+ |
+
| 461 | |||
| 550 | +462 | ! |
- teal.widgets::verbatim_popup_srv(+ if (input$show_outlier) {
|
| 551 | +463 | ! |
- id = "rcode",+ opts <- teal.transform::variable_choices(ANL) |
| 552 | +464 | ! |
- verbatim_content = reactive(teal.code::get_code(output_q())),+ selected <- if (!is.null(isolate(input$label_var)) && isolate(input$label_var) %in% as.character(opts)) {
|
| 553 | +465 | ! |
- title = "Show R Code for Response"+ isolate(input$label_var) |
| 554 | +466 |
- )+ } else {
|
|
| 555 | -+ | ||
| 467 | +! |
-
+ if (length(opts[as.character(opts) == default_outlier_label]) == 0) {
+ |
+ |
| 468 | +! | +
+ opts[[1]] |
|
| 556 | +469 |
- ### REPORTER+ } else {
|
|
| 557 | +470 | ! |
- if (with_reporter) {
+ opts[as.character(opts) == default_outlier_label] |
| 558 | -! | +||
| 471 | +
- card_fun <- function(comment, label) {
+ }+ |
+ ||
| 472 | ++ |
+ } |
|
| 559 | +473 | ! |
- card <- teal::report_card_template(+ teal.widgets::updateOptionalSelectInput( |
| 560 | +474 | ! |
- title = "Response Plot",+ session = session, |
| 561 | +475 | ! |
- label = label,+ inputId = "label_var", |
| 562 | +476 | ! |
- with_filter = with_filter,+ choices = opts, |
| 563 | +477 | ! |
- filter_panel_api = filter_panel_api+ selected = restoreInput(ns("label_var"), selected)
|
| 564 | +478 |
) |
|
| 565 | -! | +||
| 479 | +
- card$append_text("Plot", "header3")
+
|
||
| 566 | +480 | ! |
- card$append_plot(plot_r(), dim = pws$dim())+ data <- fortify(stats::lm(form, data = ANL)) |
| 567 | +481 | ! |
- if (!comment == "") {
+ cooksd <- data$.cooksd[!is.nan(data$.cooksd)] |
| 568 | +482 | ! |
- card$append_text("Comment", "header3")
+ max_outlier <- max(ceiling(max(cooksd) / mean(cooksd)), 2) |
| 569 | +483 | ! |
- card$append_text(comment)+ cur_outlier <- isolate(input$outlier) |
| 570 | -+ | ||
| 484 | +! |
- }+ updateSliderInput( |
|
| 571 | +485 | ! |
- card$append_src(teal.code::get_code(output_q()))+ session = session, |
| 572 | +486 | ! |
- card+ inputId = "outlier", |
| 573 | -+ | ||
| 487 | +! |
- }+ min = 1, |
|
| 574 | +488 | ! |
- teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
+ max = max_outlier, |
| 575 | -+ | ||
| 489 | +! |
- }+ value = restoreInput(ns("outlier"), if (cur_outlier < max_outlier) cur_outlier else max_outlier * .9)
|
|
| 576 | +490 |
- ###+ ) |
|
| 577 | +491 |
- })+ } |
|
| 578 | +492 |
- }+ |
| 1 | -+ | ||
| 493 | +! |
- #' `teal` module: File viewer+ anl_merged_q() %>% |
|
| 2 | -+ | ||
| 494 | +! |
- #'+ teal.code::eval_code(substitute(fit <- stats::lm(form, data = ANL), env = list(form = form))) %>% |
|
| 3 | -+ | ||
| 495 | +! |
- #' The file viewer module provides a tool to view static files.+ teal.code::eval_code(quote({
|
|
| 4 | -+ | ||
| 496 | +! |
- #' Supported formats include text formats, `PDF`, `PNG` `APNG`,+ for (regressor in names(fit$contrasts)) {
|
|
| 5 | -+ | ||
| 497 | +! |
- #' `JPEG` `SVG`, `WEBP`, `GIF` and `BMP`.+ alts <- paste0(levels(ANL[[regressor]]), collapse = "|") |
|
| 6 | -+ | ||
| 498 | +! |
- #'+ names(fit$coefficients) <- gsub( |
|
| 7 | -+ | ||
| 499 | +! |
- #' @inheritParams teal::module+ paste0("^(", regressor, ")(", alts, ")$"), paste0("\\1", ": ", "\\2"), names(fit$coefficients)
|
|
| 8 | +500 |
- #' @inheritParams shared_params+ ) |
|
| 9 | +501 |
- #' @param input_path (`list`) of the input paths, optional. Each element can be:+ } |
|
| 10 | +502 |
- #'+ })) %>% |
|
| 11 | -+ | ||
| 503 | +! |
- #' Paths can be specified as absolute paths or relative to the running directory of the application.+ teal.code::eval_code(quote(summary(fit))) |
|
| 12 | +504 |
- #' Default to the current working directory if not supplied.+ }) |
|
| 13 | +505 |
- #'+ |
|
| 14 | -+ | ||
| 506 | +! |
- #' @inherit shared_params return+ label_col <- reactive({
|
|
| 15 | -+ | ||
| 507 | +! |
- #'+ teal::validate_inputs(iv_out) |
|
| 16 | +508 |
- #' @examplesShinylive+ |
|
| 17 | -+ | ||
| 509 | +! |
- #' library(teal.modules.general)+ substitute( |
|
| 18 | -+ | ||
| 510 | +! |
- #' interactive <- function() TRUE+ expr = dplyr::if_else( |
|
| 19 | -+ | ||
| 511 | +! |
- #' {{ next_example }}
+ data$.cooksd > outliers * mean(data$.cooksd, na.rm = TRUE), |
|
| 20 | -+ | ||
| 512 | +! |
- #' @examples+ as.character(stats::na.omit(ANL)[[label_var]]), |
|
| 21 | +513 |
- #' data <- teal_data()+ "" |
|
| 22 | +514 |
- #' data <- within(data, {
+ ) %>% |
|
| 23 | -+ | ||
| 515 | +! |
- #' data <- data.frame(1)+ dplyr::if_else(is.na(.), "cooksd == NaN", .), |
|
| 24 | -+ | ||
| 516 | +! |
- #' })+ env = list(outliers = input$outlier, label_var = input$label_var) |
|
| 25 | +517 |
- #' datanames(data) <- c("data")
+ ) |
|
| 26 | +518 |
- #'+ }) |
|
| 27 | +519 |
- #' app <- init(+ |
|
| 28 | -+ | ||
| 520 | +! |
- #' data = data,+ label_min_segment <- reactive({
|
|
| 29 | -+ | ||
| 521 | +! |
- #' modules = modules(+ input$label_min_segment |
|
| 30 | +522 |
- #' tm_file_viewer(+ }) |
|
| 31 | +523 |
- #' input_path = list(+ |
|
| 32 | -+ | ||
| 524 | +! |
- #' folder = system.file("sample_files", package = "teal.modules.general"),
+ outlier_label <- reactive({
|
|
| 33 | -+ | ||
| 525 | +! |
- #' png = system.file("sample_files/sample_file.png", package = "teal.modules.general"),
+ substitute( |
|
| 34 | -+ | ||
| 526 | +! |
- #' txt = system.file("sample_files/sample_file.txt", package = "teal.modules.general"),
+ expr = ggrepel::geom_text_repel( |
|
| 35 | -+ | ||
| 527 | +! |
- #' url = "https://fda.gov/files/drugs/published/Portable-Document-Format-Specifications.pdf"+ label = label_col, |
|
| 36 | -+ | ||
| 528 | +! |
- #' )+ color = "red", |
|
| 37 | -+ | ||
| 529 | +! |
- #' )+ hjust = 0, |
|
| 38 | -+ | ||
| 530 | +! |
- #' )+ vjust = 1, |
|
| 39 | -+ | ||
| 531 | +! |
- #' )+ max.overlaps = Inf, |
|
| 40 | -+ | ||
| 532 | +! |
- #' if (interactive()) {
+ min.segment.length = label_min_segment, |
|
| 41 | -+ | ||
| 533 | +! |
- #' shinyApp(app$ui, app$server)+ segment.alpha = 0.5, |
|
| 42 | -+ | ||
| 534 | +! |
- #' }+ seed = 123 |
|
| 43 | +535 |
- #'+ ), |
|
| 44 | -+ | ||
| 536 | +! |
- #' @export+ env = list(label_col = label_col(), label_min_segment = label_min_segment()) |
|
| 45 | +537 |
- #'+ ) |
|
| 46 | +538 |
- tm_file_viewer <- function(label = "File Viewer Module",+ }) |
|
| 47 | +539 |
- input_path = list("Current Working Directory" = ".")) {
+
|
|
| 48 | +540 | ! |
- message("Initializing tm_file_viewer")
+ output_q <- reactive({
|
| 49 | -+ | ||
| 541 | +! |
-
+ alpha <- input$alpha |
|
| 50 | -+ | ||
| 542 | +! |
- # Normalize the parameters+ size <- input$size |
|
| 51 | +543 | ! |
- if (length(label) == 0 || identical(label, "")) label <- " "+ ggtheme <- input$ggtheme |
| 52 | +544 | ! |
- if (length(input_path) == 0 || identical(input_path, "")) input_path <- list()+ input_type <- input$plot_type |
| 53 | -+ | ||
| 545 | +! |
-
+ show_outlier <- input$show_outlier |
|
| 54 | +546 |
- # Start of assertions+ |
|
| 55 | +547 | ! |
- checkmate::assert_string(label)+ teal::validate_inputs(iv_r()) |
| 56 | +548 | ||
| 57 | +549 | ! |
- checkmate::assert(+ plot_type_0 <- function() {
|
| 58 | +550 | ! |
- checkmate::check_list(input_path, types = "character", min.len = 0),+ fit <- fit_r()[["fit"]] |
| 59 | +551 | ! |
- checkmate::check_character(input_path, min.len = 1)+ ANL <- anl_merged_q()[["ANL"]] |
| 60 | +552 |
- )+ |
|
| 61 | +553 | ! |
- if (length(input_path) > 0) {
+ stopifnot(ncol(fit$model) == 2) |
| 62 | -! | +||
| 554 | +
- valid_url <- function(url_input, timeout = 2) {
+
|
||
| 63 | +555 | ! |
- con <- try(url(url_input), silent = TRUE)+ if (!is.factor(ANL[[regression_var()$regressor]])) {
|
| 64 | +556 | ! |
- check <- suppressWarnings(try(open.connection(con, open = "rt", timeout = timeout), silent = TRUE)[1])+ shinyjs::show("size")
|
| 65 | +557 | ! |
- try(close.connection(con), silent = TRUE)+ shinyjs::show("alpha")
|
| 66 | +558 | ! |
- is.null(check)+ plot <- substitute( |
| 67 | -+ | ||
| 559 | +! |
- }+ env = list( |
|
| 68 | +560 | ! |
- idx <- vapply(input_path, function(x) file.exists(x) || valid_url(x), logical(1))+ regressor = regression_var()$regressor, |
| 69 | -+ | ||
| 561 | +! |
-
+ response = regression_var()$response, |
|
| 70 | +562 | ! |
- if (!all(idx)) {
+ size = size, |
| 71 | +563 | ! |
- warning(+ alpha = alpha |
| 72 | -! | +||
| 564 | +
- paste0(+ ), |
||
| 73 | +565 | ! |
- "Non-existent file or url path. Please provide valid paths for:\n",+ expr = ggplot( |
| 74 | +566 | ! |
- paste0(input_path[!idx], collapse = "\n")+ fit$model[, 2:1], |
| 75 | -+ | ||
| 567 | +! |
- )+ aes_string(regressor, response) |
|
| 76 | +568 |
- )+ ) + |
|
| 77 | -+ | ||
| 569 | +! |
- }+ geom_point(size = size, alpha = alpha) + |
|
| 78 | +570 | ! |
- input_path <- input_path[idx]+ stat_smooth( |
| 79 | -+ | ||
| 571 | +! |
- } else {
+ method = "lm", |
|
| 80 | +572 | ! |
- warning(+ formula = y ~ x, |
| 81 | +573 | ! |
- "No file or url paths were provided."+ se = FALSE |
| 82 | +574 |
- )+ ) |
|
| 83 | +575 |
- }+ ) |
|
| 84 | -+ | ||
| 576 | +! |
- # End of assertions+ if (show_outlier) {
|
|
| 85 | -+ | ||
| 577 | +! |
-
+ plot <- substitute( |
|
| 86 | -+ | ||
| 578 | +! |
- # Make UI args+ expr = plot + outlier_label, |
|
| 87 | +579 | ! |
- args <- as.list(environment())+ env = list(plot = plot, outlier_label = outlier_label()) |
| 88 | +580 |
-
+ ) |
|
| 89 | -! | +||
| 581 | +
- ans <- module(+ }+ |
+ ||
| 582 | ++ |
+ } else {
|
|
| 90 | +583 | ! |
- label = label,+ shinyjs::hide("size")
|
| 91 | +584 | ! |
- server = srv_viewer,+ shinyjs::hide("alpha")
|
| 92 | +585 | ! |
- server_args = list(input_path = input_path),+ plot <- substitute( |
| 93 | +586 | ! |
- ui = ui_viewer,+ expr = ggplot(fit$model[, 2:1], aes_string(regressor, response)) + |
| 94 | +587 | ! |
- ui_args = args,+ geom_boxplot(), |
| 95 | +588 | ! |
- datanames = NULL+ env = list(regressor = regression_var()$regressor, response = regression_var()$response) |
| 96 | +589 |
- )+ ) |
|
| 97 | +590 | ! |
- attr(ans, "teal_bookmarkable") <- FALSE+ if (show_outlier) {
|
| 98 | +591 | ! |
- ans+ plot <- substitute(expr = plot + outlier_label, env = list(plot = plot, outlier_label = outlier_label())) |
| 99 | +592 |
- }+ } |
|
| 100 | +593 |
-
+ } |
|
| 101 | +594 |
- # UI function for the file viewer module+ |
|
| 102 | -+ | ||
| 595 | +! |
- ui_viewer <- function(id, ...) {
+ parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args( |
|
| 103 | +596 | ! |
- args <- list(...)+ teal.widgets::resolve_ggplot2_args( |
| 104 | +597 | ! |
- ns <- NS(id)+ user_plot = ggplot2_args[["Response vs Regressor"]], |
| 105 | -+ | ||
| 598 | +! |
-
+ user_default = ggplot2_args$default, |
|
| 106 | +599 | ! |
- tagList(+ module_plot = teal.widgets::ggplot2_args( |
| 107 | +600 | ! |
- include_css_files("custom"),
+ labs = list( |
| 108 | +601 | ! |
- teal.widgets::standard_layout(+ title = "Response vs Regressor", |
| 109 | +602 | ! |
- output = tags$div(+ x = varname_w_label(regression_var()$regressor, ANL), |
| 110 | +603 | ! |
- uiOutput(ns("output"))
+ y = varname_w_label(regression_var()$response, ANL) |
| 111 | +604 |
- ),+ ), |
|
| 112 | +605 | ! |
- encoding = tags$div(+ theme = list()+ |
+
| 606 | ++ |
+ )+ |
+ |
| 607 | ++ |
+ ), |
|
| 113 | +608 | ! |
- class = "file_viewer_encoding",+ ggtheme = ggtheme+ |
+
| 609 | ++ |
+ )+ |
+ |
| 610 | ++ | + | |
| 114 | +611 | ! |
- tags$label("Encodings", class = "text-primary"),
+ teal.code::eval_code( |
| 115 | +612 | ! |
- shinyTree::shinyTree(+ fit_r(), |
| 116 | +613 | ! |
- ns("tree"),
+ substitute( |
| 117 | +614 | ! |
- dragAndDrop = FALSE,+ expr = {
|
| 118 | +615 | ! |
- sort = FALSE,+ class(fit$residuals) <- NULL |
| 119 | +616 | ! |
- wholerow = TRUE,+ data <- fortify(fit) |
| 120 | +617 | ! |
- theme = "proton",+ g <- plot |
| 121 | +618 | ! |
- multiple = FALSE+ print(g) |
| 122 | +619 |
- )+ }, |
|
| 123 | -+ | ||
| 620 | +! |
- )+ env = list( |
|
| 124 | -+ | ||
| 621 | +! |
- )+ plot = Reduce(function(x, y) call("+", x, y), c(plot, parsed_ggplot2_args))
|
|
| 125 | +622 |
- )+ ) |
|
| 126 | +623 |
- }+ ) |
|
| 127 | +624 |
-
+ ) |
|
| 128 | +625 |
- # Server function for the file viewer module+ } |
|
| 129 | +626 |
- srv_viewer <- function(id, input_path) {
+
|
|
| 130 | +627 | ! |
- moduleServer(id, function(input, output, session) {
+ plot_base <- function() {
|
| 131 | +628 | ! |
- teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.general")- |
-
| 132 | -- |
-
+ base_fit <- fit_r() |
|
| 133 | +629 | ! |
- temp_dir <- tempfile()+ teal.code::eval_code( |
| 134 | +630 | ! |
- if (!dir.exists(temp_dir)) {
+ base_fit, |
| 135 | +631 | ! |
- dir.create(temp_dir, recursive = TRUE)- |
-
| 136 | -- |
- }+ quote({
|
|
| 137 | +632 | ! |
- addResourcePath(basename(temp_dir), temp_dir)+ class(fit$residuals) <- NULL |
| 138 | +633 | ||
| 139 | -! | -
- test_path_text <- function(selected_path, type) {
- |
- |
| 140 | +634 | ! |
- out <- tryCatch(+ data <- ggplot2::fortify(fit) |
| 141 | -! | +||
| 635 | +
- expr = {
+
|
||
| 142 | +636 | ! |
- if (type != "url") {
+ smooth <- function(x, y) {
|
| 143 | +637 | ! |
- selected_path <- normalizePath(selected_path, winslash = "/")+ as.data.frame(stats::lowess(x, y, f = 2 / 3, iter = 3)) |
| 144 | +638 |
- }- |
- |
| 145 | -! | -
- readLines(con = selected_path)+ } |
|
| 146 | +639 |
- },+ |
|
| 147 | +640 | ! |
- error = function(cond) FALSE,+ smoothy_aes <- ggplot2::aes_string(x = "x", y = "y") |
| 148 | -! | +||
| 641 | +
- warning = function(cond) {
+
|
||
| 149 | +642 | ! |
- `if`(grepl("^incomplete final line found on", cond[[1]]), suppressWarnings(eval(cond[[2]])), FALSE)
+ reg_form <- deparse(fit$call[[2]]) |
| 150 | +643 |
- }+ }) |
|
| 151 | +644 |
- )+ ) |
|
| 152 | +645 |
- }+ } |
|
| 153 | +646 | ||
| 154 | +647 | ! |
- handle_connection_type <- function(selected_path) {
+ plot_type_1 <- function(plot_base) {
|
| 155 | +648 | ! |
- file_extension <- tools::file_ext(selected_path)+ shinyjs::show("size")
|
| 156 | +649 | ! |
- file_class <- suppressWarnings(file(selected_path))+ shinyjs::show("alpha")
|
| 157 | +650 | ! |
- close(file_class)+ plot <- substitute( |
| 158 | -+ | ||
| 651 | +! |
-
+ expr = ggplot(data = data, aes(.fitted, .resid)) + |
|
| 159 | +652 | ! |
- output_text <- test_path_text(selected_path, type = class(file_class)[1])+ geom_point(size = size, alpha = alpha) + |
| 160 | -+ | ||
| 653 | +! |
-
+ geom_hline(yintercept = 0, linetype = "dashed", size = 1) + |
|
| 161 | +654 | ! |
- if (class(file_class)[1] == "url") {
+ geom_line(data = smoothy, mapping = smoothy_aes), |
| 162 | +655 | ! |
- list(selected_path = selected_path, output_text = output_text)+ env = list(size = size, alpha = alpha) |
| 163 | +656 |
- } else {
- |
- |
| 164 | -! | -
- file.copy(normalizePath(selected_path, winslash = "/"), temp_dir)+ ) |
|
| 165 | +657 | ! |
- selected_path <- file.path(basename(temp_dir), basename(selected_path))+ if (show_outlier) {
|
| 166 | +658 | ! |
- list(selected_path = selected_path, output_text = output_text)- |
-
| 167 | -- |
- }+ plot <- substitute(expr = plot + outlier_label, env = list(plot = plot, outlier_label = outlier_label())) |
|
| 168 | +659 |
- }+ } |
|
| 169 | +660 | ||
| 170 | -! | -
- display_file <- function(selected_path) {
- |
- |
| 171 | -! | -
- con_type <- handle_connection_type(selected_path)- |
- |
| 172 | -! | -
- file_extension <- tools::file_ext(selected_path)- |
- |
| 173 | -! | -
- if (file_extension %in% c("png", "apng", "jpg", "jpeg", "svg", "gif", "webp", "bmp")) {
- |
- |
| 174 | -! | -
- tags$img(src = con_type$selected_path, alt = "file does not exist")- |
- |
| 175 | +661 | ! |
- } else if (file_extension == "pdf") {
+ parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args( |
| 176 | +662 | ! |
- tags$embed(+ teal.widgets::resolve_ggplot2_args( |
| 177 | +663 | ! |
- class = "embed_pdf",+ user_plot = ggplot2_args[["Residuals vs Fitted"]], |
| 178 | +664 | ! |
- src = con_type$selected_path+ user_default = ggplot2_args$default, |
| 179 | -+ | ||
| 665 | +! |
- )+ module_plot = teal.widgets::ggplot2_args( |
|
| 180 | +666 | ! |
- } else if (!isFALSE(con_type$output_text[1])) {
+ labs = list( |
| 181 | +667 | ! |
- tags$pre(paste0(con_type$output_text, collapse = "\n"))+ x = quote(paste0("Fitted values\nlm(", reg_form, ")")),
|
| 182 | -+ | ||
| 668 | +! |
- } else {
+ y = "Residuals", |
|
| 183 | +669 | ! |
- tags$p("Please select a supported format.")
+ title = "Residuals vs Fitted" |
| 184 | +670 |
- }+ ) |
|
| 185 | +671 |
- }+ ) |
|
| 186 | +672 |
-
+ ), |
|
| 187 | +673 | ! |
- tree_list <- function(file_or_dir) {
+ ggtheme = ggtheme |
| 188 | -! | +||
| 674 | +
- nested_list <- lapply(file_or_dir, function(path) {
+ ) |
||
| 189 | -! | +||
| 675 | +
- file_class <- suppressWarnings(file(path))+ |
||
| 190 | +676 | ! |
- close(file_class)+ teal.code::eval_code( |
| 191 | +677 | ! |
- if (class(file_class)[[1]] != "url") {
+ plot_base, |
| 192 | +678 | ! |
- isdir <- file.info(path)$isdir+ substitute( |
| 193 | +679 | ! |
- if (!isdir) {
+ expr = {
|
| 194 | +680 | ! |
- structure(path, ancestry = path, sticon = "file")- |
-
| 195 | -- |
- } else {
+ smoothy <- smooth(data$.fitted, data$.resid) |
|
| 196 | +681 | ! |
- files <- list.files(path, full.names = TRUE, include.dirs = TRUE)+ g <- plot |
| 197 | +682 | ! |
- out <- lapply(files, function(x) tree_list(x))+ print(g) |
| 198 | -! | +||
| 683 | +
- out <- unlist(out, recursive = FALSE)+ }, |
||
| 199 | +684 | ! |
- if (length(files) > 0) names(out) <- basename(files)+ env = list( |
| 200 | +685 | ! |
- out+ plot = Reduce(function(x, y) call("+", x, y), c(plot, parsed_ggplot2_args))
|
| 201 | +686 |
- }+ ) |
|
| 202 | +687 |
- } else {
- |
- |
| 203 | -! | -
- structure(path, ancestry = path, sticon = "file")+ ) |
|
| 204 | +688 |
- }+ ) |
|
| 205 | +689 |
- })+ } |
|
| 206 | +690 | ||
| 207 | +691 | ! |
- missing_labels <- if (is.null(names(nested_list))) seq_along(nested_list) else which(names(nested_list) == "")+ plot_type_2 <- function(plot_base) {
|
| 208 | +692 | ! |
- names(nested_list)[missing_labels] <- file_or_dir[missing_labels]+ shinyjs::show("size")
|
| 209 | +693 | ! |
- nested_list- |
-
| 210 | -- |
- }- |
- |
| 211 | -- |
-
+ shinyjs::show("alpha")
|
|
| 212 | +694 | ! |
- output$tree <- shinyTree::renderTree({
+ plot <- substitute( |
| 213 | +695 | ! |
- if (length(input_path) > 0) {
+ expr = ggplot(data = data, aes(sample = .stdresid)) + |
| 214 | +696 | ! |
- tree_list(input_path)- |
-
| 215 | -- |
- } else {
+ stat_qq(size = size, alpha = alpha) + |
|
| 216 | +697 | ! |
- list("Empty Path" = NULL)
- |
-
| 217 | -- |
- }+ geom_abline(linetype = "dashed"), |
|
| 218 | -+ | ||
| 698 | +! |
- })+ env = list(size = size, alpha = alpha) |
|
| 219 | +699 |
-
+ ) |
|
| 220 | +700 | ! |
- output$output <- renderUI({
+ if (show_outlier) {
|
| 221 | +701 | ! |
- validate(+ plot <- substitute( |
| 222 | +702 | ! |
- need(+ expr = plot + |
| 223 | +703 | ! |
- length(shinyTree::get_selected(input$tree)) > 0,+ stat_qq( |
| 224 | +704 | ! |
- "Please select a file."- |
-
| 225 | -- |
- )- |
- |
| 226 | -- |
- )+ geom = ggrepel::GeomTextRepel, |
|
| 227 | -+ | ||
| 705 | +! |
-
+ label = label_col %>% |
|
| 228 | +706 | ! |
- obj <- shinyTree::get_selected(input$tree, format = "names")[[1]]+ data.frame(label = .) %>% |
| 229 | +707 | ! |
- repo <- attr(obj, "ancestry")+ dplyr::filter(label != "cooksd == NaN") %>% |
| 230 | +708 | ! |
- repo_collapsed <- if (length(repo) > 1) paste0(repo, collapse = "/") else repo+ unlist(), |
| 231 | +709 | ! |
- is_not_named <- file.exists(file.path(c(repo_collapsed, obj[1])))[1]+ color = "red", |
| 232 | -+ | ||
| 710 | +! |
-
+ hjust = 0, |
|
| 233 | +711 | ! |
- if (is_not_named) {
+ vjust = 0, |
| 234 | +712 | ! |
- selected_path <- do.call("file.path", as.list(c(repo, obj[1])))
+ max.overlaps = Inf, |
| 235 | -+ | ||
| 713 | +! |
- } else {
+ min.segment.length = label_min_segment, |
|
| 236 | +714 | ! |
- if (length(repo) == 0) {
+ segment.alpha = .5, |
| 237 | +715 | ! |
- selected_path <- do.call("file.path", as.list(attr(input$tree[[obj[1]]], "ancestry")))
+ seed = 123 |
| 238 | +716 |
- } else {
+ ), |
|
| 239 | +717 | ! |
- selected_path <- do.call("file.path", as.list(attr(input$tree[[repo]][[obj[1]]], "ancestry")))
+ env = list(plot = plot, label_col = label_col(), label_min_segment = label_min_segment()) |
| 240 | +718 |
- }+ ) |
|
| 241 | +719 |
- }+ } |
|
| 242 | +720 | ||
| 243 | +721 | ! |
- validate(+ parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args( |
| 244 | +722 | ! |
- need(+ teal.widgets::resolve_ggplot2_args( |
| 245 | +723 | ! |
- !isTRUE(file.info(selected_path)$isdir) && length(selected_path) > 0,+ user_plot = ggplot2_args[["Normal Q-Q"]], |
| 246 | +724 | ! |
- "Please select a single file."- |
-
| 247 | -- |
- )- |
- |
| 248 | -- |
- )+ user_default = ggplot2_args$default, |
|
| 249 | +725 | ! |
- display_file(selected_path)- |
-
| 250 | -- |
- })+ module_plot = teal.widgets::ggplot2_args( |
|
| 251 | -+ | ||
| 726 | +! |
-
+ labs = list( |
|
| 252 | +727 | ! |
- onStop(function() {
+ x = quote(paste0("Theoretical Quantiles\nlm(", reg_form, ")")),
|
| 253 | +728 | ! |
- removeResourcePath(basename(temp_dir))+ y = "Standardized residuals", |
| 254 | +729 | ! |
- unlink(temp_dir)+ title = "Normal Q-Q" |
| 255 | +730 |
- })+ ) |
|
| 256 | +731 |
- })+ ) |
|
| 257 | +732 |
- }+ ), |
| 1 | -+ | ||
| 733 | +! |
- #' `teal` module: Principal component analysis+ ggtheme = ggtheme |
|
| 2 | +734 |
- #'+ ) |
|
| 3 | +735 |
- #' Module conducts principal component analysis (PCA) on a given dataset and offers different+ |
|
| 4 | -+ | ||
| 736 | +! |
- #' ways of visualizing the outcomes, including elbow plot, circle plot, biplot, and eigenvector plot.+ teal.code::eval_code( |
|
| 5 | -+ | ||
| 737 | +! |
- #' Additionally, it enables dynamic customization of plot aesthetics, such as opacity, size, and+ plot_base, |
|
| 6 | -+ | ||
| 738 | +! |
- #' font size, through UI inputs.+ substitute( |
|
| 7 | -+ | ||
| 739 | +! |
- #'+ expr = {
|
|
| 8 | -+ | ||
| 740 | +! |
- #' @inheritParams teal::module+ g <- plot |
|
| 9 | -+ | ||
| 741 | +! |
- #' @inheritParams shared_params+ print(g) |
|
| 10 | +742 |
- #' @param dat (`data_extract_spec` or `list` of multiple `data_extract_spec`)+ }, |
|
| 11 | -+ | ||
| 743 | +! |
- #' specifying columns used to compute PCA.+ env = list( |
|
| 12 | -+ | ||
| 744 | +! |
- #' @param font_size (`numeric`) optional, specifies font size.+ plot = Reduce(function(x, y) call("+", x, y), c(plot, parsed_ggplot2_args))
|
|
| 13 | +745 |
- #' It controls the font size for plot titles, axis labels, and legends.+ ) |
|
| 14 | +746 |
- #' - If vector of `length == 1` then the font sizes will have a fixed size.+ ) |
|
| 15 | +747 |
- #' - while vector of `value`, `min`, and `max` allows dynamic adjustment.+ ) |
|
| 16 | +748 |
- #' @templateVar ggnames "Elbow plot", "Circle plot", "Biplot", "Eigenvector plot"+ } |
|
| 17 | +749 |
- #' @template ggplot2_args_multi+ |
|
| 18 | -+ | ||
| 750 | +! |
- #'+ plot_type_3 <- function(plot_base) {
+ |
+ |
| 751 | +! | +
+ shinyjs::show("size")
|
|
| 19 | -+ | ||
| 752 | +! |
- #' @inherit shared_params return+ shinyjs::show("alpha")
|
|
| 20 | -+ | ||
| 753 | +! |
- #'+ plot <- substitute( |
|
| 21 | -+ | ||
| 754 | +! |
- #' @examplesShinylive+ expr = ggplot(data = data, aes(.fitted, sqrt(abs(.stdresid)))) + |
|
| 22 | -+ | ||
| 755 | +! |
- #' library(teal.modules.general)+ geom_point(size = size, alpha = alpha) + |
|
| 23 | -+ | ||
| 756 | +! |
- #' interactive <- function() TRUE+ geom_line(data = smoothy, mapping = smoothy_aes), |
|
| 24 | -+ | ||
| 757 | +! |
- #' {{ next_example }}
+ env = list(size = size, alpha = alpha) |
|
| 25 | +758 |
- #' @examples+ ) |
|
| 26 | -+ | ||
| 759 | +! |
- #' # general data example+ if (show_outlier) {
|
|
| 27 | -+ | ||
| 760 | +! |
- #' data <- teal_data()+ plot <- substitute(expr = plot + outlier_label, env = list(plot = plot, outlier_label = outlier_label())) |
|
| 28 | +761 |
- #' data <- within(data, {
+ } |
|
| 29 | +762 |
- #' require(nestcolor)+ |
|
| 30 | -+ | ||
| 763 | +! |
- #' USArrests <- USArrests+ parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args( |
|
| 31 | -+ | ||
| 764 | +! |
- #' })+ teal.widgets::resolve_ggplot2_args( |
|
| 32 | -+ | ||
| 765 | +! |
- #'+ user_plot = ggplot2_args[["Scale-Location"]], |
|
| 33 | -+ | ||
| 766 | +! |
- #' datanames(data) <- "USArrests"+ user_default = ggplot2_args$default, |
|
| 34 | -+ | ||
| 767 | +! |
- #'+ module_plot = teal.widgets::ggplot2_args( |
|
| 35 | -+ | ||
| 768 | +! |
- #' app <- init(+ labs = list( |
|
| 36 | -+ | ||
| 769 | +! |
- #' data = data,+ x = quote(paste0("Fitted values\nlm(", reg_form, ")")),
|
|
| 37 | -+ | ||
| 770 | +! |
- #' modules = modules(+ y = quote(expression(sqrt(abs(`Standardized residuals`)))), |
|
| 38 | -+ | ||
| 771 | +! |
- #' tm_a_pca(+ title = "Scale-Location" |
|
| 39 | +772 |
- #' "PCA",+ ) |
|
| 40 | +773 |
- #' dat = data_extract_spec(+ ) |
|
| 41 | +774 |
- #' dataname = "USArrests",+ ), |
|
| 42 | -+ | ||
| 775 | +! |
- #' select = select_spec(+ ggtheme = ggtheme |
|
| 43 | +776 |
- #' choices = variable_choices(+ ) |
|
| 44 | +777 |
- #' data = data[["USArrests"]], c("Murder", "Assault", "UrbanPop", "Rape")
+
|
|
| 45 | -+ | ||
| 778 | +! |
- #' ),+ teal.code::eval_code( |
|
| 46 | -+ | ||
| 779 | +! |
- #' selected = c("Murder", "Assault"),
+ plot_base, |
|
| 47 | -+ | ||
| 780 | +! |
- #' multiple = TRUE+ substitute( |
|
| 48 | -+ | ||
| 781 | +! |
- #' ),+ expr = {
|
|
| 49 | -+ | ||
| 782 | +! |
- #' filter = NULL+ smoothy <- smooth(data$.fitted, sqrt(abs(data$.stdresid))) |
|
| 50 | -+ | ||
| 783 | +! |
- #' )+ g <- plot |
|
| 51 | -+ | ||
| 784 | +! |
- #' )+ print(g) |
|
| 52 | +785 |
- #' )+ }, |
|
| 53 | -+ | ||
| 786 | +! |
- #' )+ env = list( |
|
| 54 | -+ | ||
| 787 | +! |
- #' if (interactive()) {
+ plot = Reduce(function(x, y) call("+", x, y), c(plot, parsed_ggplot2_args))
|
|
| 55 | +788 |
- #' shinyApp(app$ui, app$server)+ ) |
|
| 56 | +789 |
- #' }+ ) |
|
| 57 | +790 |
- #'+ ) |
|
| 58 | +791 |
- #' @examplesShinylive+ } |
|
| 59 | +792 |
- #' library(teal.modules.general)+ |
|
| 60 | -+ | ||
| 793 | +! |
- #' interactive <- function() TRUE+ plot_type_4 <- function(plot_base) {
|
|
| 61 | -+ | ||
| 794 | +! |
- #' {{ next_example }}
+ shinyjs::hide("size")
|
|
| 62 | -+ | ||
| 795 | +! |
- #' @examples+ shinyjs::show("alpha")
|
|
| 63 | -+ | ||
| 796 | +! |
- #' # CDISC data example+ plot <- substitute( |
|
| 64 | -+ | ||
| 797 | +! |
- #' data <- teal_data()+ expr = ggplot(data = data, aes(seq_along(.cooksd), .cooksd)) + |
|
| 65 | -+ | ||
| 798 | +! |
- #' data <- within(data, {
+ geom_col(alpha = alpha), |
|
| 66 | -+ | ||
| 799 | +! |
- #' require(nestcolor)+ env = list(alpha = alpha) |
|
| 67 | +800 |
- #' ADSL <- rADSL+ ) |
|
| 68 | -+ | ||
| 801 | +! |
- #' })+ if (show_outlier) {
|
|
| 69 | -+ | ||
| 802 | +! |
- #' datanames(data) <- "ADSL"+ plot <- substitute( |
|
| 70 | -+ | ||
| 803 | +! |
- #' join_keys(data) <- default_cdisc_join_keys[datanames(data)]+ expr = plot + |
|
| 71 | -+ | ||
| 804 | +! |
- #'+ geom_hline( |
|
| 72 | -+ | ||
| 805 | +! |
- #' app <- init(+ yintercept = c( |
|
| 73 | -+ | ||
| 806 | +! |
- #' data = data,+ outlier * mean(data$.cooksd, na.rm = TRUE), |
|
| 74 | -+ | ||
| 807 | +! |
- #' modules = modules(+ mean(data$.cooksd, na.rm = TRUE) |
|
| 75 | +808 |
- #' tm_a_pca(+ ), |
|
| 76 | -+ | ||
| 809 | +! |
- #' "PCA",+ color = "red", |
|
| 77 | -+ | ||
| 810 | +! |
- #' dat = data_extract_spec(+ linetype = "dashed" |
|
| 78 | +811 |
- #' dataname = "ADSL",+ ) + |
|
| 79 | -+ | ||
| 812 | +! |
- #' select = select_spec(+ geom_text( |
|
| 80 | -+ | ||
| 813 | +! |
- #' choices = variable_choices(+ aes( |
|
| 81 | -+ | ||
| 814 | +! |
- #' data = data[["ADSL"]], c("BMRKR1", "AGE", "EOSDY")
+ x = 0, |
|
| 82 | -+ | ||
| 815 | +! |
- #' ),+ y = mean(data$.cooksd, na.rm = TRUE), |
|
| 83 | -+ | ||
| 816 | +! |
- #' selected = c("BMRKR1", "AGE"),
+ label = paste("mu", "=", round(mean(data$.cooksd, na.rm = TRUE), 4)),
|
|
| 84 | -+ | ||
| 817 | +! |
- #' multiple = TRUE+ vjust = -1, |
|
| 85 | -+ | ||
| 818 | +! |
- #' ),+ hjust = 0, |
|
| 86 | -+ | ||
| 819 | +! |
- #' filter = NULL+ color = "red", |
|
| 87 | -+ | ||
| 820 | +! |
- #' )+ angle = 90 |
|
| 88 | +821 |
- #' )+ ), |
|
| 89 | -+ | ||
| 822 | +! |
- #' )+ parse = TRUE, |
|
| 90 | -+ | ||
| 823 | +! |
- #' )+ show.legend = FALSE |
|
| 91 | +824 |
- #' if (interactive()) {
+ ) + |
|
| 92 | -+ | ||
| 825 | +! |
- #' shinyApp(app$ui, app$server)+ outlier_label, |
|
| 93 | -+ | ||
| 826 | +! |
- #' }+ env = list(plot = plot, outlier = input$outlier, outlier_label = outlier_label()) |
|
| 94 | +827 |
- #'+ ) |
|
| 95 | +828 |
- #' @export+ } |
|
| 96 | +829 |
- #'+ |
|
| 97 | -+ | ||
| 830 | +! |
- tm_a_pca <- function(label = "Principal Component Analysis",+ parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args( |
|
| 98 | -+ | ||
| 831 | +! |
- dat,+ teal.widgets::resolve_ggplot2_args( |
|
| 99 | -+ | ||
| 832 | +! |
- plot_height = c(600, 200, 2000),+ user_plot = ggplot2_args[["Cook's distance"]], |
|
| 100 | -+ | ||
| 833 | +! |
- plot_width = NULL,+ user_default = ggplot2_args$default, |
|
| 101 | -+ | ||
| 834 | +! |
- ggtheme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void"),
+ module_plot = teal.widgets::ggplot2_args( |
|
| 102 | -+ | ||
| 835 | +! |
- ggplot2_args = teal.widgets::ggplot2_args(),+ labs = list( |
|
| 103 | -+ | ||
| 836 | +! |
- rotate_xaxis_labels = FALSE,+ x = quote(paste0("Obs. number\nlm(", reg_form, ")")),
|
|
| 104 | -+ | ||
| 837 | +! |
- font_size = c(12, 8, 20),+ y = "Cook's distance", |
|
| 105 | -+ | ||
| 838 | +! |
- alpha = c(1, 0, 1),+ title = "Cook's distance" |
|
| 106 | +839 |
- size = c(2, 1, 8),+ ) |
|
| 107 | +840 |
- pre_output = NULL,+ ) |
|
| 108 | +841 |
- post_output = NULL) {
+ ), |
|
| 109 | +842 | ! |
- message("Initializing tm_a_pca")
+ ggtheme = ggtheme |
| 110 | +843 |
-
+ ) |
|
| 111 | +844 |
- # Normalize the parameters+ |
|
| 112 | +845 | ! |
- if (inherits(dat, "data_extract_spec")) dat <- list(dat)+ teal.code::eval_code( |
| 113 | +846 | ! |
- if (inherits(ggplot2_args, "ggplot2_args")) ggplot2_args <- list(default = ggplot2_args)+ plot_base, |
| 114 | -+ | ||
| 847 | +! |
-
+ substitute( |
|
| 115 | -+ | ||
| 848 | +! |
- # Start of assertions+ expr = {
|
|
| 116 | +849 | ! |
- checkmate::assert_string(label)+ g <- plot |
| 117 | +850 | ! |
- checkmate::assert_list(dat, types = "data_extract_spec")+ print(g) |
| 118 | +851 |
-
+ }, |
|
| 119 | +852 | ! |
- checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE)+ env = list( |
| 120 | +853 | ! |
- checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height")+ plot = Reduce(function(x, y) call("+", x, y), c(plot, parsed_ggplot2_args))
|
| 121 | -! | +||
| 854 | +
- checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE)+ ) |
||
| 122 | -! | +||
| 855 | +
- checkmate::assert_numeric(+ ) |
||
| 123 | -! | +||
| 856 | +
- plot_width[1],+ ) |
||
| 124 | -! | +||
| 857 | +
- lower = plot_width[2], upper = plot_width[3], null.ok = TRUE, .var.name = "plot_width"+ } |
||
| 125 | +858 |
- )+ |
|
| 126 | +859 | ||
| 127 | +860 | ! |
- ggtheme <- match.arg(ggtheme)+ plot_type_5 <- function(plot_base) {
|
| 128 | -+ | ||
| 861 | +! |
-
+ shinyjs::show("size")
|
|
| 129 | +862 | ! |
- plot_choices <- c("Elbow plot", "Circle plot", "Biplot", "Eigenvector plot")
+ shinyjs::show("alpha")
|
| 130 | +863 | ! |
- checkmate::assert_list(ggplot2_args, types = "ggplot2_args")+ plot <- substitute( |
| 131 | +864 | ! |
- checkmate::assert_subset(names(ggplot2_args), c("default", plot_choices))
+ expr = ggplot(data = data, aes(.hat, .stdresid)) + |
| 132 | -+ | ||
| 865 | +! |
-
+ geom_vline( |
|
| 133 | +866 | ! |
- checkmate::assert_flag(rotate_xaxis_labels)+ size = 1, |
| 134 | -+ | ||
| 867 | +! |
-
+ colour = "black", |
|
| 135 | +868 | ! |
- if (length(font_size) == 1) {
+ linetype = "dashed", |
| 136 | +869 | ! |
- checkmate::assert_numeric(font_size, any.missing = FALSE, finite = TRUE, lower = 8, upper = 20)+ xintercept = 0 |
| 137 | +870 |
- } else {
+ ) + |
|
| 138 | +871 | ! |
- checkmate::assert_numeric(font_size, len = 3, any.missing = FALSE, finite = TRUE, lower = 8, upper = 20)+ geom_hline( |
| 139 | +872 | ! |
- checkmate::assert_numeric(font_size[1], lower = font_size[2], upper = font_size[3], .var.name = "font_size")+ size = 1, |
| 140 | -+ | ||
| 873 | +! |
- }+ colour = "black",+ |
+ |
| 874 | +! | +
+ linetype = "dashed",+ |
+ |
| 875 | +! | +
+ yintercept = 0 |
|
| 141 | +876 |
-
+ ) + |
|
| 142 | +877 | ! |
- if (length(alpha) == 1) {
+ geom_point(size = size, alpha = alpha) + |
| 143 | +878 | ! |
- checkmate::assert_numeric(alpha, any.missing = FALSE, finite = TRUE, lower = 0, upper = 1)+ geom_line(data = smoothy, mapping = smoothy_aes),+ |
+
| 879 | +! | +
+ env = list(size = size, alpha = alpha) |
|
| 144 | +880 |
- } else {
+ ) |
|
| 145 | +881 | ! |
- checkmate::assert_numeric(alpha, len = 3, any.missing = FALSE, finite = TRUE, lower = 0, upper = 1)+ if (show_outlier) {
|
| 146 | +882 | ! |
- checkmate::assert_numeric(alpha[1], lower = alpha[2], upper = alpha[3], .var.name = "alpha")+ plot <- substitute(expr = plot + outlier_label, env = list(plot = plot, outlier_label = outlier_label())) |
| 147 | +883 |
- }+ } |
|
| 148 | +884 | ||
| 149 | +885 | ! |
- if (length(size) == 1) {
+ parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args( |
| 150 | +886 | ! |
- checkmate::assert_numeric(size, any.missing = FALSE, finite = TRUE, lower = 1, upper = 8)+ teal.widgets::resolve_ggplot2_args( |
| 151 | -+ | ||
| 887 | +! |
- } else {
+ user_plot = ggplot2_args[["Residuals vs Leverage"]], |
|
| 152 | +888 | ! |
- checkmate::assert_numeric(size, len = 3, any.missing = FALSE, finite = TRUE, lower = 1, upper = 8)+ user_default = ggplot2_args$default, |
| 153 | +889 | ! |
- checkmate::assert_numeric(size[1], lower = size[2], upper = size[3], .var.name = "size")+ module_plot = teal.widgets::ggplot2_args( |
| 154 | -+ | ||
| 890 | +! |
- }+ labs = list( |
|
| 155 | -+ | ||
| 891 | +! |
-
+ x = quote(paste0("Standardized residuals\nlm(", reg_form, ")")),
|
|
| 156 | +892 | ! |
- checkmate::assert_multi_class(pre_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
+ y = "Leverage", |
| 157 | +893 | ! |
- checkmate::assert_multi_class(post_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
+ title = "Residuals vs Leverage" |
| 158 | +894 |
- # End of assertions+ ) |
|
| 159 | +895 |
-
+ ) |
|
| 160 | +896 |
- # Make UI args+ ), |
|
| 161 | +897 | ! |
- args <- as.list(environment())+ ggtheme = ggtheme |
| 162 | +898 | - - | -|
| 163 | -! | -
- data_extract_list <- list(dat = dat)+ ) |
|
| 164 | +899 | ||
| 165 | +900 | ! |
- ans <- module(+ teal.code::eval_code( |
| 166 | +901 | ! |
- label = label,+ plot_base, |
| 167 | +902 | ! |
- server = srv_a_pca,+ substitute( |
| 168 | +903 | ! |
- ui = ui_a_pca,+ expr = {
|
| 169 | +904 | ! |
- ui_args = args,+ smoothy <- smooth(data$.hat, data$.stdresid) |
| 170 | +905 | ! |
- server_args = c(+ g <- plot |
| 171 | +906 | ! |
- data_extract_list,+ print(g) |
| 172 | -! | +||
| 907 | +
- list(+ }, |
||
| 173 | +908 | ! |
- plot_height = plot_height,+ env = list( |
| 174 | +909 | ! |
- plot_width = plot_width,+ plot = Reduce(function(x, y) call("+", x, y), c(plot, parsed_ggplot2_args))
|
| 175 | -! | +||
| 910 | +
- ggplot2_args = ggplot2_args+ ) |
||
| 176 | +911 |
- )+ ) |
|
| 177 | +912 |
- ),+ ) |
|
| 178 | -! | +||
| 913 | +
- datanames = teal.transform::get_extract_datanames(data_extract_list)+ } |
||
| 179 | +914 |
- )+ + |
+ |
| 915 | +! | +
+ plot_type_6 <- function(plot_base) {
+ |
+ |
| 916 | +! | +
+ shinyjs::show("size")
+ |
+ |
| 917 | +! | +
+ shinyjs::show("alpha")
+ |
+ |
| 918 | +! | +
+ plot <- substitute(+ |
+ |
| 919 | +! | +
+ expr = ggplot(data = data, aes(.hat, .cooksd)) ++ |
+ |
| 920 | +! | +
+ geom_vline(xintercept = 0, colour = NA) + |
|
| 180 | +921 | ! |
- attr(ans, "teal_bookmarkable") <- FALSE+ geom_abline( |
| 181 | +922 | ! |
- ans+ slope = seq(0, 3, by = 0.5), |
| 182 | -+ | ||
| 923 | +! |
- }+ colour = "black", |
|
| 183 | -+ | ||
| 924 | +! |
-
+ linetype = "dashed", |
|
| 184 | -+ | ||
| 925 | +! |
- # UI function for the PCA module+ size = 1 |
|
| 185 | +926 |
- ui_a_pca <- function(id, ...) {
+ ) + |
|
| 186 | +927 | ! |
- ns <- NS(id)+ geom_line(data = smoothy, mapping = smoothy_aes) + |
| 187 | +928 | ! |
- args <- list(...)+ geom_point(size = size, alpha = alpha), |
| 188 | +929 | ! |
- is_single_dataset_value <- teal.transform::is_single_dataset(args$dat)+ env = list(size = size, alpha = alpha) |
| 189 | +930 |
-
+ ) |
|
| 190 | +931 | ! |
- color_selector <- args$dat+ if (show_outlier) {
|
| 191 | +932 | ! |
- for (i in seq_along(color_selector)) {
+ plot <- substitute(expr = plot + outlier_label, env = list(plot = plot, outlier_label = outlier_label())) |
| 192 | -! | +||
| 933 | +
- color_selector[[i]]$select$multiple <- FALSE+ }+ |
+ ||
| 934 | ++ | + | |
| 193 | +935 | ! |
- color_selector[[i]]$select$always_selected <- NULL+ parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args( |
| 194 | +936 | ! |
- color_selector[[i]]$select$selected <- NULL+ teal.widgets::resolve_ggplot2_args( |
| 195 | -+ | ||
| 937 | +! |
- }+ user_plot = ggplot2_args[["Cook's dist vs Leverage"]], |
|
| 196 | -+ | ||
| 938 | +! |
-
+ user_default = ggplot2_args$default, |
|
| 197 | +939 | ! |
- tagList(+ module_plot = teal.widgets::ggplot2_args( |
| 198 | +940 | ! |
- include_css_files("custom"),
+ labs = list( |
| 199 | +941 | ! |
- teal.widgets::standard_layout(+ x = quote(paste0("Leverage\nlm(", reg_form, ")")),
|
| 200 | +942 | ! |
- output = teal.widgets::white_small_well(+ y = "Cooks's distance", |
| 201 | +943 | ! |
- uiOutput(ns("all_plots"))
+ title = "Cook's dist vs Leverage" |
| 202 | +944 |
- ),+ ) |
|
| 203 | -! | +||
| 945 | +
- encoding = tags$div(+ ) |
||
| 204 | +946 |
- ### Reporter+ ), |
|
| 205 | +947 | ! |
- teal.reporter::simple_reporter_ui(ns("simple_reporter")),
+ ggtheme = ggtheme |
| 206 | +948 |
- ###+ )+ |
+ |
| 949 | ++ | + | |
| 207 | +950 | ! |
- tags$label("Encodings", class = "text-primary"),
+ teal.code::eval_code( |
| 208 | +951 | ! |
- teal.transform::datanames_input(args["dat"]),+ plot_base, |
| 209 | +952 | ! |
- teal.transform::data_extract_ui(+ substitute( |
| 210 | +953 | ! |
- id = ns("dat"),
+ expr = {
|
| 211 | +954 | ! |
- label = "Data selection",+ smoothy <- smooth(data$.hat, data$.cooksd) |
| 212 | +955 | ! |
- data_extract_spec = args$dat,+ g <- plot |
| 213 | +956 | ! |
- is_single_dataset = is_single_dataset_value+ print(g) |
| 214 | +957 |
- ),+ }, |
|
| 215 | +958 | ! |
- teal.widgets::panel_group(+ env = list( |
| 216 | +959 | ! |
- teal.widgets::panel_item(+ plot = Reduce(function(x, y) call("+", x, y), c(plot, parsed_ggplot2_args))
|
| 217 | -! | +||
| 960 | +
- title = "Display",+ ) |
||
| 218 | -! | +||
| 961 | +
- collapsed = FALSE,+ ) |
||
| 219 | -! | +||
| 962 | +
- checkboxGroupInput(+ ) |
||
| 220 | -! | +||
| 963 | +
- ns("tables_display"),
+ } |
||
| 221 | -! | +||
| 964 | +
- "Tables display",+ |
||
| 222 | +965 | ! |
- choices = c("PC importance" = "importance", "Eigenvectors" = "eigenvector"),
+ qenv <- if (input_type == "Response vs Regressor") {
|
| 223 | +966 | ! |
- selected = c("importance", "eigenvector")
+ plot_type_0() |
| 224 | +967 |
- ),+ } else {
|
|
| 225 | +968 | ! |
- radioButtons(+ plot_base_q <- plot_base() |
| 226 | +969 | ! |
- ns("plot_type"),
+ switch(input_type, |
| 227 | +970 | ! |
- label = "Plot type",+ "Residuals vs Fitted" = plot_base_q %>% plot_type_1(), |
| 228 | +971 | ! |
- choices = args$plot_choices,+ "Normal Q-Q" = plot_base_q %>% plot_type_2(), |
| 229 | +972 | ! |
- selected = args$plot_choices[1]- |
-
| 230 | -- |
- )- |
- |
| 231 | -- |
- ),+ "Scale-Location" = plot_base_q %>% plot_type_3(), |
|
| 232 | +973 | ! |
- teal.widgets::panel_item(+ "Cook's distance" = plot_base_q %>% plot_type_4(), |
| 233 | +974 | ! |
- title = "Pre-processing",+ "Residuals vs Leverage" = plot_base_q %>% plot_type_5(), |
| 234 | +975 | ! |
- radioButtons(+ "Cook's dist vs Leverage" = plot_base_q %>% plot_type_6() |
| 235 | -! | +||
| 976 | +
- ns("standardization"), "Standardization",
+ ) |
||
| 236 | -! | +||
| 977 | +
- choices = c("None" = "none", "Center" = "center", "Center & Scale" = "center_scale"),
+ } |
||
| 237 | +978 | ! |
- selected = "center_scale"+ qenv |
| 238 | +979 |
- ),+ }) |
|
| 239 | -! | +||
| 980 | +
- radioButtons(+ |
||
| 240 | -! | +||
| 981 | +
- ns("na_action"), "NA action",
+
|
||
| 241 | +982 | ! |
- choices = c("None" = "none", "Drop" = "drop"),
+ fitted <- reactive(output_q()[["fit"]]) |
| 242 | +983 | ! |
- selected = "none"+ plot_r <- reactive(output_q()[["g"]]) |
| 243 | +984 |
- )+ |
|
| 244 | +985 |
- ),+ # Insert the plot into a plot_with_settings module from teal.widgets |
|
| 245 | +986 | ! |
- teal.widgets::panel_item(+ pws <- teal.widgets::plot_with_settings_srv( |
| 246 | +987 | ! |
- title = "Selected plot specific settings",+ id = "myplot", |
| 247 | +988 | ! |
- collapsed = FALSE,+ plot_r = plot_r, |
| 248 | +989 | ! |
- uiOutput(ns("plot_settings")),
+ height = plot_height, |
| 249 | +990 | ! |
- conditionalPanel(+ width = plot_width |
| 250 | -! | +||
| 991 | +
- condition = sprintf("input['%s'] == 'Biplot'", ns("plot_type")),
+ ) |
||
| 251 | -! | +||
| 992 | +
- list(+ |
||
| 252 | +993 | ! |
- teal.transform::data_extract_ui(+ output$text <- renderText({
|
| 253 | +994 | ! |
- id = ns("response"),
+ req(iv_r()$is_valid()) |
| 254 | +995 | ! |
- label = "Color by",+ req(iv_out$is_valid()) |
| 255 | +996 | ! |
- data_extract_spec = color_selector,+ paste(utils::capture.output(summary(teal.code::dev_suppress(fitted())))[-1], |
| 256 | +997 | ! |
- is_single_dataset = is_single_dataset_value+ collapse = "\n" |
| 257 | +998 |
- ),+ )+ |
+ |
| 999 | ++ |
+ })+ |
+ |
| 1000 | ++ | + | |
| 258 | +1001 | ! |
- teal.widgets::optionalSliderInputValMinMax(ns("alpha"), "Opacity:", args$alpha, ticks = FALSE),
+ teal.widgets::verbatim_popup_srv( |
| 259 | +1002 | ! |
- teal.widgets::optionalSliderInputValMinMax(ns("size"), "Points size:", args$size, ticks = FALSE)
+ id = "rcode",+ |
+
| 1003 | +! | +
+ verbatim_content = reactive(teal.code::get_code(output_q())),+ |
+ |
| 1004 | +! | +
+ title = "R code for the regression plot", |
|
| 260 | +1005 |
- )+ ) |
|
| 261 | +1006 |
- )+ |
|
| 262 | +1007 |
- ),+ ### REPORTER |
|
| 263 | +1008 | ! |
- teal.widgets::panel_item(+ if (with_reporter) {
|
| 264 | +1009 | ! |
- title = "Plot settings",+ card_fun <- function(comment, label) {
|
| 265 | +1010 | ! |
- collapsed = TRUE,+ card <- teal::report_card_template( |
| 266 | +1011 | ! |
- conditionalPanel(+ title = "Linear Regression Plot", |
| 267 | +1012 | ! |
- condition = sprintf(+ label = label, |
| 268 | +1013 | ! |
- "input['%s'] == 'Elbow plot' || input['%s'] == 'Eigenvector plot'",+ with_filter = with_filter, |
| 269 | +1014 | ! |
- ns("plot_type"),
+ filter_panel_api = filter_panel_api+ |
+
| 1015 | ++ |
+ ) |
|
| 270 | +1016 | ! |
- ns("plot_type")
+ card$append_text("Plot", "header3")
|
| 271 | -+ | ||
| 1017 | +! |
- ),+ card$append_plot(plot_r(), dim = pws$dim()) |
|
| 272 | +1018 | ! |
- list(checkboxInput(ns("rotate_xaxis_labels"), "Rotate X axis labels", value = args$rotate_xaxis_labels))
+ if (!comment == "") {
|
| 273 | -+ | ||
| 1019 | +! |
- ),+ card$append_text("Comment", "header3")
|
|
| 274 | +1020 | ! |
- selectInput(+ card$append_text(comment) |
| 275 | -! | +||
| 1021 | +
- inputId = ns("ggtheme"),
+ } |
||
| 276 | +1022 | ! |
- label = "Theme (by ggplot):",+ card$append_src(teal.code::get_code(output_q())) |
| 277 | +1023 | ! |
- choices = ggplot_themes,+ card |
| 278 | -! | +||
| 1024 | +
- selected = args$ggtheme,+ } |
||
| 279 | +1025 | ! |
- multiple = FALSE+ teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
|
| 280 | +1026 |
- ),+ } |
|
| 281 | -! | +||
| 1027 | +
- teal.widgets::optionalSliderInputValMinMax(ns("font_size"), "Font Size", args$font_size, ticks = FALSE)
+ ### |
||
| 282 | +1028 |
- )+ }) |
|
| 283 | +1029 |
- )+ } |
|
| 284 | +1030 |
- ),+ |
|
| 285 | -! | +||
| 1031 | +
- forms = tagList(+ regression_names <- paste0( |
||
| 286 | -! | +||
| 1032 | +
- teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code")
+ '"Response vs Regressor", "Residuals vs Fitted", ', |
||
| 287 | +1033 |
- ),+ '"Scale-Location", "Cook\'s distance", "Residuals vs Leverage"", "Cook\'s dist vs Leverage"' |
|
| 288 | -! | +||
| 1034 | +
- pre_output = args$pre_output,+ ) |
||
| 289 | -! | +
| 1 | +
- post_output = args$post_output+ #' `teal` module: File viewer |
||
| 290 | +2 |
- )+ #' |
|
| 291 | +3 |
- )+ #' The file viewer module provides a tool to view static files. |
|
| 292 | +4 |
- }+ #' Supported formats include text formats, `PDF`, `PNG` `APNG`, |
|
| 293 | +5 |
-
+ #' `JPEG` `SVG`, `WEBP`, `GIF` and `BMP`. |
|
| 294 | +6 |
- # Server function for the PCA module+ #' |
|
| 295 | +7 |
- srv_a_pca <- function(id, data, reporter, filter_panel_api, dat, plot_height, plot_width, ggplot2_args) {
+ #' @inheritParams teal::module |
|
| 296 | -! | +||
| 8 | +
- with_reporter <- !missing(reporter) && inherits(reporter, "Reporter")+ #' @inheritParams shared_params |
||
| 297 | -! | +||
| 9 | +
- with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI")+ #' @param input_path (`list`) of the input paths, optional. Each element can be: |
||
| 298 | -! | +||
| 10 | +
- checkmate::assert_class(data, "reactive")+ #' |
||
| 299 | -! | +||
| 11 | +
- checkmate::assert_class(isolate(data()), "teal_data")+ #' Paths can be specified as absolute paths or relative to the running directory of the application. |
||
| 300 | -! | +||
| 12 | +
- moduleServer(id, function(input, output, session) {
+ #' Default to the current working directory if not supplied. |
||
| 301 | -! | +||
| 13 | +
- teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.general")+ #' |
||
| 302 | +14 |
-
+ #' @inherit shared_params return |
|
| 303 | -! | +||
| 15 | +
- response <- dat+ #' |
||
| 304 | +16 |
-
+ #' @examplesShinylive |
|
| 305 | -! | +||
| 17 | +
- for (i in seq_along(response)) {
+ #' library(teal.modules.general) |
||
| 306 | -! | +||
| 18 | +
- response[[i]]$select$multiple <- FALSE+ #' interactive <- function() TRUE |
||
| 307 | -! | +||
| 19 | +
- response[[i]]$select$always_selected <- NULL+ #' {{ next_example }}
|
||
| 308 | -! | +||
| 20 | +
- response[[i]]$select$selected <- NULL+ #' @examples |
||
| 309 | -! | +||
| 21 | +
- all_cols <- teal.data::col_labels(isolate(data())[[response[[i]]$dataname]])+ #' data <- teal_data() |
||
| 310 | -! | +||
| 22 | +
- ignore_cols <- unlist(teal.data::join_keys(isolate(data()))[[response[[i]]$dataname]])+ #' data <- within(data, {
|
||
| 311 | -! | +||
| 23 | +
- color_cols <- all_cols[!names(all_cols) %in% ignore_cols]+ #' data <- data.frame(1) |
||
| 312 | -! | +||
| 24 | +
- response[[i]]$select$choices <- teal.transform::choices_labeled(names(color_cols), color_cols)+ #' }) |
||
| 313 | +25 |
- }+ #' |
|
| 314 | +26 |
-
+ #' app <- init( |
|
| 315 | -! | +||
| 27 | +
- selector_list <- teal.transform::data_extract_multiple_srv(+ #' data = data, |
||
| 316 | -! | +||
| 28 | +
- data_extract = list(dat = dat, response = response),+ #' modules = modules( |
||
| 317 | -! | +||
| 29 | +
- datasets = data,+ #' tm_file_viewer( |
||
| 318 | -! | +||
| 30 | +
- select_validation_rule = list(+ #' input_path = list( |
||
| 319 | -! | +||
| 31 | +
- dat = ~ if (length(.) < 2L) "Please select more than 1 variable to perform PCA.",+ #' folder = system.file("sample_files", package = "teal.modules.general"),
|
||
| 320 | -! | +||
| 32 | +
- response = shinyvalidate::compose_rules(+ #' png = system.file("sample_files/sample_file.png", package = "teal.modules.general"),
|
||
| 321 | -! | +||
| 33 | +
- shinyvalidate::sv_optional(),+ #' txt = system.file("sample_files/sample_file.txt", package = "teal.modules.general"),
|
||
| 322 | -! | +||
| 34 | +
- ~ if (isTRUE(is.element(., selector_list()$dat()$select))) {
+ #' url = "https://fda.gov/files/drugs/published/Portable-Document-Format-Specifications.pdf" |
||
| 323 | -! | +||
| 35 | +
- "Response must not have been used for PCA."+ #' ) |
||
| 324 | +36 |
- }+ #' ) |
|
| 325 | +37 |
- )+ #' ) |
|
| 326 | +38 |
- )+ #' ) |
|
| 327 | +39 |
- )+ #' if (interactive()) {
|
|
| 328 | +40 |
-
+ #' shinyApp(app$ui, app$server) |
|
| 329 | -! | +||
| 41 | +
- iv_r <- reactive({
+ #' } |
||
| 330 | -! | +||
| 42 | +
- iv <- shinyvalidate::InputValidator$new()+ #' |
||
| 331 | -! | +||
| 43 | +
- teal.transform::compose_and_enable_validators(iv, selector_list)+ #' @export |
||
| 332 | +44 |
- })+ #' |
|
| 333 | +45 |
-
+ tm_file_viewer <- function(label = "File Viewer Module", |
|
| 334 | -! | +||
| 46 | +
- iv_extra <- shinyvalidate::InputValidator$new()+ input_path = list("Current Working Directory" = ".")) {
|
||
| 335 | +47 | ! |
- iv_extra$add_rule("x_axis", function(value) {
+ message("Initializing tm_file_viewer")
|
| 336 | -! | +||
| 48 | +
- if (isTRUE(input$plot_type %in% c("Circle plot", "Biplot"))) {
+
|
||
| 337 | -! | +||
| 49 | +
- if (!shinyvalidate::input_provided(value)) {
+ # Normalize the parameters |
||
| 338 | +50 | ! |
- "Need X axis"+ if (length(label) == 0 || identical(label, "")) label <- " " |
| 339 | -+ | ||
| 51 | +! |
- }+ if (length(input_path) == 0 || identical(input_path, "")) input_path <- list() |
|
| 340 | +52 |
- }+ |
|
| 341 | +53 |
- })+ # Start of assertions |
|
| 342 | +54 | ! |
- iv_extra$add_rule("y_axis", function(value) {
+ checkmate::assert_string(label)+ |
+
| 55 | ++ | + | |
| 343 | +56 | ! |
- if (isTRUE(input$plot_type %in% c("Circle plot", "Biplot"))) {
+ checkmate::assert( |
| 344 | +57 | ! |
- if (!shinyvalidate::input_provided(value)) {
+ checkmate::check_list(input_path, types = "character", min.len = 0), |
| 345 | +58 | ! |
- "Need Y axis"+ checkmate::check_character(input_path, min.len = 1) |
| 346 | +59 |
- }+ ) |
|
| 347 | -+ | ||
| 60 | +! |
- }+ if (length(input_path) > 0) {
|
|
| 348 | -+ | ||
| 61 | +! |
- })+ valid_url <- function(url_input, timeout = 2) {
|
|
| 349 | +62 | ! |
- rule_dupl <- function(...) {
+ con <- try(url(url_input), silent = TRUE) |
| 350 | +63 | ! |
- if (isTRUE(input$plot_type %in% c("Circle plot", "Biplot"))) {
+ check <- suppressWarnings(try(open.connection(con, open = "rt", timeout = timeout), silent = TRUE)[1]) |
| 351 | +64 | ! |
- if (isTRUE(input$x_axis == input$y_axis)) {
+ try(close.connection(con), silent = TRUE) |
| 352 | +65 | ! |
- "Please choose different X and Y axes."+ is.null(check) |
| 353 | +66 |
- }+ } |
|
| 354 | -+ | ||
| 67 | +! |
- }+ idx <- vapply(input_path, function(x) file.exists(x) || valid_url(x), logical(1)) |
|
| 355 | +68 |
- }- |
- |
| 356 | -! | -
- iv_extra$add_rule("x_axis", rule_dupl)
+
|
|
| 357 | +69 | ! |
- iv_extra$add_rule("y_axis", rule_dupl)
+ if (!all(idx)) {
|
| 358 | +70 | ! |
- iv_extra$add_rule("variables", function(value) {
+ warning( |
| 359 | +71 | ! |
- if (identical(input$plot_type, "Circle plot")) {
+ paste0( |
| 360 | +72 | ! |
- if (!shinyvalidate::input_provided(value)) {
+ "Non-existent file or url path. Please provide valid paths for:\n", |
| 361 | +73 | ! |
- "Need Original Coordinates"+ paste0(input_path[!idx], collapse = "\n") |
| 362 | +74 |
- }+ ) |
|
| 363 | +75 |
- }+ ) |
|
| 364 | +76 |
- })+ } |
|
| 365 | +77 | ! |
- iv_extra$add_rule("pc", function(value) {
+ input_path <- input_path[idx] |
| 366 | -! | +||
| 78 | +
- if (identical(input$plot_type, "Eigenvector plot")) {
+ } else {
|
||
| 367 | +79 | ! |
- if (!shinyvalidate::input_provided(value)) {
+ warning( |
| 368 | +80 | ! |
- "Need PC"+ "No file or url paths were provided." |
| 369 | +81 |
- }+ ) |
|
| 370 | +82 |
- }+ } |
|
| 371 | +83 |
- })+ # End of assertions+ |
+ |
| 84 | ++ | + + | +|
| 85 | ++ |
+ # Make UI args |
|
| 372 | +86 | ! |
- iv_extra$enable()+ args <- as.list(environment()) |
| 373 | +87 | ||
| 374 | +88 | ! |
- anl_merged_input <- teal.transform::merge_expression_srv(+ ans <- module( |
| 375 | +89 | ! |
- selector_list = selector_list,+ label = label, |
| 376 | +90 | ! |
- datasets = data+ server = srv_viewer, |
| 377 | -+ | ||
| 91 | +! |
- )+ server_args = list(input_path = input_path), |
|
| 378 | -+ | ||
| 92 | +! |
-
+ ui = ui_viewer, |
|
| 379 | +93 | ! |
- anl_merged_q <- reactive({
+ ui_args = args, |
| 380 | +94 | ! |
- req(anl_merged_input())+ datanames = NULL+ |
+
| 95 | ++ |
+ ) |
|
| 381 | +96 | ! |
- data() %>%+ attr(ans, "teal_bookmarkable") <- FALSE |
| 382 | +97 | ! |
- teal.code::eval_code(as.expression(anl_merged_input()$expr))+ ans |
| 383 | +98 |
- })+ } |
|
| 384 | +99 | ||
| 385 | -! | +||
| 100 | +
- merged <- list(+ # UI function for the file viewer module |
||
| 386 | -! | +||
| 101 | +
- anl_input_r = anl_merged_input,+ ui_viewer <- function(id, ...) {
|
||
| 387 | +102 | ! |
- anl_q_r = anl_merged_q+ args <- list(...) |
| 388 | -+ | ||
| 103 | +! |
- )+ ns <- NS(id) |
|
| 389 | +104 | ||
| 390 | +105 | ! |
- validation <- reactive({
+ tagList( |
| 391 | +106 | ! |
- req(merged$anl_q_r())+ include_css_files("custom"),
|
| 392 | -+ | ||
| 107 | +! |
- # inputs+ teal.widgets::standard_layout( |
|
| 393 | +108 | ! |
- keep_cols <- as.character(merged$anl_input_r()$columns_source$dat)+ output = tags$div( |
| 394 | +109 | ! |
- na_action <- input$na_action+ uiOutput(ns("output"))
|
| 395 | -! | +||
| 110 | +
- standardization <- input$standardization+ ), |
||
| 396 | +111 | ! |
- center <- standardization %in% c("center", "center_scale")
+ encoding = tags$div( |
| 397 | +112 | ! |
- scale <- standardization == "center_scale"+ class = "file_viewer_encoding", |
| 398 | +113 | ! |
- ANL <- merged$anl_q_r()[["ANL"]]+ tags$label("Encodings", class = "text-primary"),
|
| 399 | -+ | ||
| 114 | +! |
-
+ shinyTree::shinyTree( |
|
| 400 | +115 | ! |
- teal::validate_has_data(ANL, 10)+ ns("tree"),
|
| 401 | +116 | ! |
- validate(need(+ dragAndDrop = FALSE, |
| 402 | +117 | ! |
- na_action != "none" | !anyNA(ANL[keep_cols]),+ sort = FALSE, |
| 403 | +118 | ! |
- paste(+ wholerow = TRUE, |
| 404 | +119 | ! |
- "There are NAs in the dataset. Please deal with them in preprocessing",+ theme = "proton", |
| 405 | +120 | ! |
- "or select \"Drop\" in the NA actions inside the encodings panel (left)."+ multiple = FALSE |
| 406 | +121 |
) |
|
| 407 | +122 |
- ))+ )+ |
+ |
| 123 | ++ |
+ )+ |
+ |
| 124 | ++ |
+ )+ |
+ |
| 125 | ++ |
+ }+ |
+ |
| 126 | ++ | + + | +|
| 127 | ++ |
+ # Server function for the file viewer module+ |
+ |
| 128 | ++ |
+ srv_viewer <- function(id, input_path) {
|
|
| 408 | +129 | ! |
- if (scale) {
+ moduleServer(id, function(input, output, session) {
|
| 409 | +130 | ! |
- not_single <- vapply(ANL[keep_cols], function(column) length(unique(column)) != 1, FUN.VALUE = logical(1))+ teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.general") |
| 410 | +131 | ||
| 411 | +132 | ! |
- msg <- paste0(+ temp_dir <- tempfile() |
| 412 | +133 | ! |
- "You have selected `Center & Scale` under `Standardization` in the `Pre-processing` panel, ",+ if (!dir.exists(temp_dir)) {
|
| 413 | +134 | ! |
- "but one or more of your columns has/have a variance value of zero, indicating all values are identical"+ dir.create(temp_dir, recursive = TRUE) |
| 414 | +135 |
- )+ } |
|
| 415 | +136 | ! |
- validate(need(all(not_single), msg))+ addResourcePath(basename(temp_dir), temp_dir) |
| 416 | +137 |
- }+ |
|
| 417 | -+ | ||
| 138 | +! |
- })+ test_path_text <- function(selected_path, type) {
|
|
| 418 | -+ | ||
| 139 | +! |
-
+ out <- tryCatch( |
|
| 419 | -+ | ||
| 140 | +! |
- # computation ----+ expr = {
|
|
| 420 | +141 | ! |
- computation <- reactive({
+ if (type != "url") {
|
| 421 | +142 | ! |
- validation()+ selected_path <- normalizePath(selected_path, winslash = "/") |
| 422 | +143 |
-
+ } |
|
| 423 | -+ | ||
| 144 | +! |
- # inputs+ readLines(con = selected_path) |
|
| 424 | -! | +||
| 145 | +
- keep_cols <- as.character(merged$anl_input_r()$columns_source$dat)+ }, |
||
| 425 | +146 | ! |
- na_action <- input$na_action+ error = function(cond) FALSE, |
| 426 | +147 | ! |
- standardization <- input$standardization+ warning = function(cond) {
|
| 427 | +148 | ! |
- center <- standardization %in% c("center", "center_scale")
+ `if`(grepl("^incomplete final line found on", cond[[1]]), suppressWarnings(eval(cond[[2]])), FALSE)
|
| 428 | -! | +||
| 149 | +
- scale <- standardization == "center_scale"+ } |
||
| 429 | -! | +||
| 150 | +
- ANL <- merged$anl_q_r()[["ANL"]]+ ) |
||
| 430 | +151 |
-
+ } |
|
| 431 | -! | +||
| 152 | +
- qenv <- teal.code::eval_code(+ |
||
| 432 | +153 | ! |
- merged$anl_q_r(),+ handle_connection_type <- function(selected_path) {
|
| 433 | +154 | ! |
- substitute(+ file_extension <- tools::file_ext(selected_path) |
| 434 | +155 | ! |
- expr = keep_columns <- keep_cols,+ file_class <- suppressWarnings(file(selected_path)) |
| 435 | +156 | ! |
- env = list(keep_cols = keep_cols)+ close(file_class) |
| 436 | +157 |
- )+ |
|
| 437 | -+ | ||
| 158 | +! |
- )+ output_text <- test_path_text(selected_path, type = class(file_class)[1]) |
|
| 438 | +159 | ||
| 439 | +160 | ! |
- if (na_action == "drop") {
+ if (class(file_class)[1] == "url") {
|
| 440 | +161 | ! |
- qenv <- teal.code::eval_code(+ list(selected_path = selected_path, output_text = output_text)+ |
+
| 162 | ++ |
+ } else {
|
|
| 441 | +163 | ! |
- qenv,+ file.copy(normalizePath(selected_path, winslash = "/"), temp_dir) |
| 442 | +164 | ! |
- quote(ANL <- tidyr::drop_na(ANL, keep_columns))+ selected_path <- file.path(basename(temp_dir), basename(selected_path))+ |
+
| 165 | +! | +
+ list(selected_path = selected_path, output_text = output_text) |
|
| 443 | +166 |
- )+ } |
|
| 444 | +167 |
- }+ } |
|
| 445 | +168 | ||
| 446 | +169 | ! |
- qenv <- teal.code::eval_code(+ display_file <- function(selected_path) {
|
| 447 | +170 | +! | +
+ con_type <- handle_connection_type(selected_path)+ |
+
| 171 | +! | +
+ file_extension <- tools::file_ext(selected_path)+ |
+ |
| 172 | ! |
- qenv,+ if (file_extension %in% c("png", "apng", "jpg", "jpeg", "svg", "gif", "webp", "bmp")) {
|
|
| 448 | +173 | ! |
- substitute(+ tags$img(src = con_type$selected_path, alt = "file does not exist") |
| 449 | +174 | ! |
- expr = pca <- summary(stats::prcomp(ANL[keep_columns], center = center, scale. = scale, retx = TRUE)),+ } else if (file_extension == "pdf") {
|
| 450 | +175 | ! |
- env = list(center = center, scale = scale)+ tags$embed( |
| 451 | -+ | ||
| 176 | +! |
- )+ class = "embed_pdf", |
|
| 452 | -+ | ||
| 177 | +! |
- )+ src = con_type$selected_path |
|
| 453 | +178 | - - | -|
| 454 | -! | -
- qenv <- teal.code::eval_code(+ ) |
|
| 455 | +179 | ! |
- qenv,+ } else if (!isFALSE(con_type$output_text[1])) {
|
| 456 | +180 | ! |
- quote({
+ tags$pre(paste0(con_type$output_text, collapse = "\n")) |
| 457 | -! | +||
| 181 | +
- tbl_importance <- dplyr::as_tibble(pca$importance, rownames = "Metric")+ } else {
|
||
| 458 | +182 | ! |
- tbl_importance+ tags$p("Please select a supported format.")
|
| 459 | +183 |
- })+ } |
|
| 460 | +184 |
- )+ } |
|
| 461 | +185 | ||
| 462 | +186 | ! |
- teal.code::eval_code(+ tree_list <- function(file_or_dir) {
|
| 463 | +187 | ! |
- qenv,+ nested_list <- lapply(file_or_dir, function(path) {
|
| 464 | +188 | ! |
- quote({
+ file_class <- suppressWarnings(file(path)) |
| 465 | +189 | ! |
- tbl_eigenvector <- dplyr::as_tibble(pca$rotation, rownames = "Variable")+ close(file_class) |
| 466 | +190 | ! |
- tbl_eigenvector+ if (class(file_class)[[1]] != "url") {
|
| 467 | -+ | ||
| 191 | +! |
- })+ isdir <- file.info(path)$isdir |
|
| 468 | -+ | ||
| 192 | +! |
- )+ if (!isdir) {
|
|
| 469 | -+ | ||
| 193 | +! |
- })+ structure(path, ancestry = path, sticon = "file") |
|
| 470 | +194 |
-
+ } else {
|
|
| 471 | -+ | ||
| 195 | +! |
- # plot args ----+ files <- list.files(path, full.names = TRUE, include.dirs = TRUE) |
|
| 472 | +196 | ! |
- output$plot_settings <- renderUI({
+ out <- lapply(files, function(x) tree_list(x)) |
| 473 | -+ | ||
| 197 | +! |
- # reactivity triggers+ out <- unlist(out, recursive = FALSE) |
|
| 474 | +198 | ! |
- req(iv_r()$is_valid())+ if (length(files) > 0) names(out) <- basename(files) |
| 475 | +199 | ! |
- req(computation())+ out |
| 476 | -! | +||
| 200 | +
- qenv <- computation()+ } |
||
| 477 | +201 |
-
+ } else {
|
|
| 478 | +202 | ! |
- ns <- session$ns+ structure(path, ancestry = path, sticon = "file") |
| 479 | +203 | ++ |
+ }+ |
+
| 204 | ++ |
+ })+ |
+ |
| 205 | |||
| 480 | +206 | ! |
- pca <- qenv[["pca"]]+ missing_labels <- if (is.null(names(nested_list))) seq_along(nested_list) else which(names(nested_list) == "") |
| 481 | +207 | ! |
- chcs_pcs <- colnames(pca$rotation)+ names(nested_list)[missing_labels] <- file_or_dir[missing_labels] |
| 482 | +208 | ! |
- chcs_vars <- qenv[["keep_columns"]]+ nested_list |
| 483 | +209 | ++ |
+ }+ |
+
| 210 | |||
| 484 | +211 | ! |
- tagList(+ output$tree <- shinyTree::renderTree({
|
| 485 | +212 | ! |
- conditionalPanel(+ if (length(input_path) > 0) {
|
| 486 | +213 | ! |
- condition = sprintf(+ tree_list(input_path) |
| 487 | -! | +||
| 214 | +
- "input['%s'] == 'Biplot' || input['%s'] == 'Circle plot'",+ } else {
|
||
| 488 | +215 | ! |
- ns("plot_type"), ns("plot_type")
+ list("Empty Path" = NULL)
|
| 489 | +216 |
- ),+ } |
|
| 490 | -! | +||
| 217 | +
- list(+ }) |
||
| 491 | -! | +||
| 218 | +
- teal.widgets::optionalSelectInput(ns("x_axis"), "X axis", choices = chcs_pcs, selected = chcs_pcs[1]),
+
|
||
| 492 | +219 | ! |
- teal.widgets::optionalSelectInput(ns("y_axis"), "Y axis", choices = chcs_pcs, selected = chcs_pcs[2]),
+ output$output <- renderUI({
|
| 493 | +220 | ! |
- teal.widgets::optionalSelectInput(+ validate( |
| 494 | +221 | ! |
- ns("variables"), "Original coordinates",
+ need( |
| 495 | +222 | ! |
- choices = chcs_vars, selected = chcs_vars,+ length(shinyTree::get_selected(input$tree)) > 0, |
| 496 | +223 | ! |
- multiple = TRUE+ "Please select a file." |
| 497 | +224 |
- )+ ) |
|
| 498 | +225 |
- )+ ) |
|
| 499 | +226 |
- ),+ |
|
| 500 | +227 | ! |
- conditionalPanel(+ obj <- shinyTree::get_selected(input$tree, format = "names")[[1]] |
| 501 | +228 | ! |
- condition = sprintf("input['%s'] == 'Elbow plot'", ns("plot_type")),
+ repo <- attr(obj, "ancestry") |
| 502 | +229 | ! |
- helpText("No plot specific settings available.")
+ repo_collapsed <- if (length(repo) > 1) paste0(repo, collapse = "/") else repo+ |
+
| 230 | +! | +
+ is_not_named <- file.exists(file.path(c(repo_collapsed, obj[1])))[1] |
|
| 503 | +231 |
- ),+ |
|
| 504 | +232 | ! |
- conditionalPanel(+ if (is_not_named) {
|
| 505 | +233 | ! |
- condition = paste0("input['", ns("plot_type"), "'] == 'Eigenvector plot'"),
+ selected_path <- do.call("file.path", as.list(c(repo, obj[1])))
+ |
+
| 234 | ++ |
+ } else {
|
|
| 506 | +235 | ! |
- teal.widgets::optionalSelectInput(ns("pc"), "PC", choices = chcs_pcs, selected = chcs_pcs[1])
+ if (length(repo) == 0) {
|
| 507 | -+ | ||
| 236 | +! |
- )+ selected_path <- do.call("file.path", as.list(attr(input$tree[[obj[1]]], "ancestry")))
|
|
| 508 | +237 |
- )+ } else {
+ |
+ |
| 238 | +! | +
+ selected_path <- do.call("file.path", as.list(attr(input$tree[[repo]][[obj[1]]], "ancestry")))
|
|
| 509 | +239 |
- })+ } |
|
| 510 | +240 |
-
+ } |
|
| 511 | +241 |
- # plot elbow ----+ |
|
| 512 | +242 | ! |
- plot_elbow <- function(base_q) {
+ validate( |
| 513 | +243 | ! |
- ggtheme <- input$ggtheme+ need( |
| 514 | +244 | ! |
- rotate_xaxis_labels <- input$rotate_xaxis_labels+ !isTRUE(file.info(selected_path)$isdir) && length(selected_path) > 0, |
| 515 | +245 | ! |
- font_size <- input$font_size+ "Please select a single file." |
| 516 | +246 | - - | -|
| 517 | -! | -
- angle_value <- ifelse(isTRUE(rotate_xaxis_labels), 45, 0)- |
- |
| 518 | -! | -
- hjust_value <- ifelse(isTRUE(rotate_xaxis_labels), 1, 0.5)+ ) |
|
| 519 | +247 | - - | -|
| 520 | -! | -
- dev_ggplot2_args <- teal.widgets::ggplot2_args(+ ) |
|
| 521 | +248 | ! |
- labs = list(x = "Principal component", y = "Proportion of variance explained", color = "", fill = "Legend"),+ display_file(selected_path) |
| 522 | -! | +||
| 249 | +
- theme = list(+ }) |
||
| 523 | -! | +||
| 250 | +
- legend.position = "right",+ |
||
| 524 | +251 | ! |
- legend.spacing.y = quote(grid::unit(-5, "pt")),+ onStop(function() {
|
| 525 | +252 | ! |
- legend.title = quote(element_text(vjust = 25)),+ removeResourcePath(basename(temp_dir)) |
| 526 | +253 | ! |
- axis.text.x = substitute(+ unlink(temp_dir) |
| 527 | -! | +||
| 254 | +
- element_text(angle = angle_value, hjust = hjust_value),+ }) |
||
| 528 | -! | +||
| 255 | +
- list(angle_value = angle_value, hjust_value = hjust_value)+ }) |
||
| 529 | +256 |
- ),+ } |
|
| 530 | -! | +
| 1 | +
- text = substitute(element_text(size = font_size), list(font_size = font_size))+ #' Shared parameters documentation |
||
| 531 | +2 |
- )+ #' |
|
| 532 | +3 |
- )+ #' Defines common arguments shared across multiple functions in the package |
|
| 533 | +4 |
-
+ #' to avoid repetition by using `inheritParams`. |
|
| 534 | -! | +||
| 5 | +
- parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(+ #' |
||
| 535 | -! | +||
| 6 | +
- teal.widgets::resolve_ggplot2_args(+ #' @param plot_height (`numeric`) optional, specifies the plot height as a three-element vector of |
||
| 536 | -! | +||
| 7 | +
- user_plot = ggplot2_args[["Elbow plot"]],+ #' `value`, `min`, and `max` intended for use with a slider UI element. |
||
| 537 | -! | +||
| 8 | +
- user_default = ggplot2_args$default,+ #' @param plot_width (`numeric`) optional, specifies the plot width as a three-element vector of |
||
| 538 | -! | +||
| 9 | +
- module_plot = dev_ggplot2_args+ #' `value`, `min`, and `max` for a slider encoding the plot width. |
||
| 539 | +10 |
- ),+ #' @param rotate_xaxis_labels (`logical`) optional, whether to rotate plot X axis labels. Does not |
|
| 540 | -! | +||
| 11 | +
- ggtheme = ggtheme+ #' rotate by default (`FALSE`). |
||
| 541 | +12 |
- )+ #' @param ggtheme (`character`) optional, `ggplot2` theme to be used by default. Defaults to `"gray"`. |
|
| 542 | +13 |
-
+ #' @param ggplot2_args (`ggplot2_args`) object created by [teal.widgets::ggplot2_args()] |
|
| 543 | -! | +||
| 14 | +
- teal.code::eval_code(+ #' with settings for the module plot. |
||
| 544 | -! | +||
| 15 | +
- base_q,+ #' The argument is merged with options variable `teal.ggplot2_args` and default module setup. |
||
| 545 | -! | +||
| 16 | +
- substitute(+ #' |
||
| 546 | -! | +||
| 17 | +
- expr = {
+ #' For more details see the vignette: `vignette("custom-ggplot2-arguments", package = "teal.widgets")`
|
||
| 547 | -! | +||
| 18 | +
- elb_dat <- pca$importance[c("Proportion of Variance", "Cumulative Proportion"), ] %>%
+ #' @param basic_table_args (`basic_table_args`) object created by [teal.widgets::basic_table_args()] |
||
| 548 | -! | +||
| 19 | +
- dplyr::as_tibble(rownames = "metric") %>%+ #' with settings for the module table. |
||
| 549 | -! | +||
| 20 | +
- tidyr::gather("component", "value", -metric) %>%
+ #' The argument is merged with options variable `teal.basic_table_args` and default module setup. |
||
| 550 | -! | +||
| 21 | +
- dplyr::mutate(+ #' |
||
| 551 | -! | +||
| 22 | +
- component = factor(component, levels = unique(stringr::str_sort(component, numeric = TRUE)))+ #' For more details see the vignette: `vignette("custom-basic-table-arguments", package = "teal.widgets")`
|
||
| 552 | +23 |
- )+ #' @param pre_output (`shiny.tag`) optional, text or UI element to be displayed before the module's output, |
|
| 553 | +24 |
-
+ #' providing context or a title. |
|
| 554 | -! | +||
| 25 | +
- cols <- c(getOption("ggplot2.discrete.colour"), c("lightblue", "darkred", "black"))[1:3]
+ #' with text placed before the output to put the output into context. For example a title. |
||
| 555 | -! | +||
| 26 | +
- g <- ggplot(mapping = aes_string(x = "component", y = "value")) ++ #' @param post_output (`shiny.tag`) optional, text or UI element to be displayed after the module's output, |
||
| 556 | -! | +||
| 27 | +
- geom_bar(+ #' adding context or further instructions. Elements like `shiny::helpText()` are useful. |
||
| 557 | -! | +||
| 28 | +
- aes(fill = "Single variance"),+ #' |
||
| 558 | -! | +||
| 29 | +
- data = dplyr::filter(elb_dat, metric == "Proportion of Variance"),+ #' @param alpha (`integer(1)` or `integer(3)`) optional, specifies point opacity. |
||
| 559 | -! | +||
| 30 | +
- color = "black",+ #' - When the length of `alpha` is one: the plot points will have a fixed opacity. |
||
| 560 | -! | +||
| 31 | +
- stat = "identity"+ #' - When the length of `alpha` is three: the plot points opacity are dynamically adjusted based on |
||
| 561 | +32 |
- ) ++ #' vector of `value`, `min`, and `max`. |
|
| 562 | -! | +||
| 33 | +
- geom_point(+ #' @param size (`integer(1)` or `integer(3)`) optional, specifies point size. |
||
| 563 | -! | +||
| 34 | +
- aes(color = "Cumulative variance"),+ #' - When the length of `size` is one: the plot point sizes will have a fixed size. |
||
| 564 | -! | +||
| 35 | +
- data = dplyr::filter(elb_dat, metric == "Cumulative Proportion")+ #' - When the length of `size` is three: the plot points size are dynamically adjusted based on |
||
| 565 | +36 |
- ) ++ #' vector of `value`, `min`, and `max`. |
|
| 566 | -! | +||
| 37 | +
- geom_line(+ #' |
||
| 567 | -! | +||
| 38 | +
- aes(group = 1, color = "Cumulative variance"),+ #' @return Object of class `teal_module` to be used in `teal` applications. |
||
| 568 | -! | +||
| 39 | +
- data = dplyr::filter(elb_dat, metric == "Cumulative Proportion")+ #' |
||
| 569 | +40 |
- ) ++ #' @name shared_params |
|
| 570 | -! | +||
| 41 | +
- labs ++ #' @keywords internal |
||
| 571 | -! | +||
| 42 | +
- scale_color_manual(values = c("Cumulative variance" = cols[2], "Single variance" = cols[3])) +
+ NULL |
||
| 572 | -! | +||
| 43 | +
- scale_fill_manual(values = c("Cumulative variance" = cols[2], "Single variance" = cols[1])) +
+
|
||
| 573 | -! | +||
| 44 | +
- ggthemes ++ #' Add labels for facets to a `ggplot2` object |
||
| 574 | -! | +||
| 45 | +
- themes+ #' |
||
| 575 | +46 |
-
+ #' Enhances a `ggplot2` plot by adding labels that describe |
|
| 576 | -! | +||
| 47 | +
- print(g)+ #' the faceting variables along the x and y axes. |
||
| 577 | +48 |
- },+ #' |
|
| 578 | -! | +||
| 49 | +
- env = list(+ #' @param p (`ggplot2`) object to which facet labels will be added. |
||
| 579 | -! | +||
| 50 | +
- ggthemes = parsed_ggplot2_args$ggtheme,+ #' @param xfacet_label (`character`) Label for the facet along the x-axis. |
||
| 580 | -! | +||
| 51 | +
- labs = parsed_ggplot2_args$labs,+ #' If `NULL`, no label is added. If a vector, labels are joined with " & ". |
||
| 581 | -! | +||
| 52 | +
- themes = parsed_ggplot2_args$theme+ #' @param yfacet_label (`character`) Label for the facet along the y-axis. |
||
| 582 | +53 |
- )+ #' Similar behavior to `xfacet_label`. |
|
| 583 | +54 |
- )+ #' |
|
| 584 | +55 |
- )+ #' @return Returns `grid` or `grob` object (to be drawn with `grid.draw`) |
|
| 585 | +56 |
- }+ #' |
|
| 586 | +57 |
-
+ #' @examples |
|
| 587 | +58 |
- # plot circle ----+ #' library(ggplot2) |
|
| 588 | -! | +||
| 59 | +
- plot_circle <- function(base_q) {
+ #' library(grid) |
||
| 589 | -! | +||
| 60 | +
- x_axis <- input$x_axis+ #' |
||
| 590 | -! | +||
| 61 | +
- y_axis <- input$y_axis+ #' p <- ggplot(mtcars) + |
||
| 591 | -! | +||
| 62 | +
- variables <- input$variables+ #' aes(x = mpg, y = disp) + |
||
| 592 | -! | +||
| 63 | +
- ggtheme <- input$ggtheme+ #' geom_point() + |
||
| 593 | +64 |
-
+ #' facet_grid(gear ~ cyl) |
|
| 594 | -! | +||
| 65 | +
- rotate_xaxis_labels <- input$rotate_xaxis_labels+ #' |
||
| 595 | -! | +||
| 66 | +
- font_size <- input$font_size+ #' xfacet_label <- "cylinders" |
||
| 596 | +67 |
-
+ #' yfacet_label <- "gear" |
|
| 597 | -! | +||
| 68 | +
- angle <- ifelse(isTRUE(rotate_xaxis_labels), 45, 0)+ #' res <- add_facet_labels(p, xfacet_label, yfacet_label) |
||
| 598 | -! | +||
| 69 | +
- hjust <- ifelse(isTRUE(rotate_xaxis_labels), 1, 0.5)+ #' grid.newpage() |
||
| 599 | +70 |
-
+ #' grid.draw(res) |
|
| 600 | -! | +||
| 71 | +
- dev_ggplot2_args <- teal.widgets::ggplot2_args(+ #' |
||
| 601 | -! | +||
| 72 | +
- theme = list(+ #' grid.newpage() |
||
| 602 | -! | +||
| 73 | +
- text = substitute(element_text(size = font_size), list(font_size = font_size)),+ #' grid.draw(add_facet_labels(p, xfacet_label = NULL, yfacet_label)) |
||
| 603 | -! | +||
| 74 | +
- axis.text.x = substitute(+ #' grid.newpage() |
||
| 604 | -! | +||
| 75 | +
- element_text(angle = angle_val, hjust = hjust_val),+ #' grid.draw(add_facet_labels(p, xfacet_label, yfacet_label = NULL)) |
||
| 605 | -! | +||
| 76 | +
- list(angle_val = angle, hjust_val = hjust)+ #' grid.newpage() |
||
| 606 | +77 |
- )+ #' grid.draw(add_facet_labels(p, xfacet_label = NULL, yfacet_label = NULL)) |
|
| 607 | +78 |
- )+ #' |
|
| 608 | +79 |
- )+ #' @export |
|
| 609 | +80 |
-
+ #' |
|
| 610 | -! | +||
| 81 | +
- all_ggplot2_args <- teal.widgets::resolve_ggplot2_args(+ add_facet_labels <- function(p, xfacet_label = NULL, yfacet_label = NULL) {
|
||
| 611 | +82 | ! |
- user_plot = ggplot2_args[["Circle plot"]],+ checkmate::assert_class(p, classes = "ggplot") |
| 612 | +83 | ! |
- user_default = ggplot2_args$default,+ checkmate::assert_character(xfacet_label, null.ok = TRUE, min.len = 1) |
| 613 | +84 | ! |
- module_plot = dev_ggplot2_args+ checkmate::assert_character(yfacet_label, null.ok = TRUE, min.len = 1) |
| 614 | -+ | ||
| 85 | +! |
- )+ if (is.null(xfacet_label) && is.null(yfacet_label)) {
|
|
| 615 | -+ | ||
| 86 | +! |
-
+ return(ggplotGrob(p)) |
|
| 616 | -! | +||
| 87 | +
- parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(+ } |
||
| 617 | +88 | ! |
- all_ggplot2_args,+ grid::grid.grabExpr({
|
| 618 | +89 | ! |
- ggtheme = ggtheme+ g <- ggplotGrob(p) |
| 619 | +90 |
- )+ |
|
| 620 | +91 |
-
+ # we are going to replace these, so we make sure they have nothing in them |
|
| 621 | +92 | ! |
- teal.code::eval_code(+ checkmate::assert_class(g$grobs[[grep("xlab-t", g$layout$name, fixed = TRUE)]], "zeroGrob")
|
| 622 | +93 | ! |
- base_q,+ checkmate::assert_class(g$grobs[[grep("ylab-r", g$layout$name, fixed = TRUE)]], "zeroGrob")
+ |
+
| 94 | ++ | + | |
| 623 | +95 | ! |
- substitute(+ xaxis_label_grob <- g$grobs[[grep("xlab-b", g$layout$name, fixed = TRUE)]]
|
| 624 | +96 | ! |
- expr = {
+ xaxis_label_grob$children[[1]]$label <- paste(xfacet_label, collapse = " & ") |
| 625 | +97 | ! |
- pca_rot <- pca$rotation[, c(x_axis, y_axis)] %>%+ yaxis_label_grob <- g$grobs[[grep("ylab-l", g$layout$name, fixed = TRUE)]]
|
| 626 | +98 | ! |
- dplyr::as_tibble(rownames = "label") %>%+ yaxis_label_grob$children[[1]]$label <- paste(yfacet_label, collapse = " & ") |
| 627 | +99 | ! |
- dplyr::filter(label %in% variables)+ yaxis_label_grob$children[[1]]$rot <- 270 |
| 628 | +100 | ||
| 629 | -! | -
- circle_data <- data.frame(- |
- |
| 630 | +101 | ! |
- x = cos(seq(0, 2 * pi, length.out = 100)),+ top_height <- if (is.null(xfacet_label)) 0 else grid::unit(2, "line") |
| 631 | +102 | ! |
- y = sin(seq(0, 2 * pi, length.out = 100))- |
-
| 632 | -- |
- )+ right_width <- if (is.null(yfacet_label)) 0 else grid::unit(2, "line") |
|
| 633 | +103 | ||
| 634 | -! | -
- g <- ggplot(pca_rot) +- |
- |
| 635 | +104 | ! |
- geom_point(aes_string(x = x_axis, y = y_axis)) ++ grid::grid.newpage() |
| 636 | +105 | ! |
- geom_label(+ grid::pushViewport(grid::plotViewport(margins = c(0, 0, top_height, right_width), name = "ggplot")) |
| 637 | +106 | ! |
- aes_string(x = x_axis, y = y_axis, label = "label"),+ grid::grid.draw(g) |
| 638 | +107 | ! |
- nudge_x = 0.1, nudge_y = 0.05,+ grid::upViewport(1) |
| 639 | -! | +||
| 108 | +
- fontface = "bold"+ |
||
| 640 | +109 |
- ) ++ # draw x facet |
|
| 641 | +110 | ! |
- geom_path(aes(x, y, group = 1), data = circle_data) ++ if (!is.null(xfacet_label)) {
|
| 642 | +111 | ! |
- geom_point(aes(x = x, y = y), data = data.frame(x = 0, y = 0), shape = "x", size = 5) ++ grid::pushViewport(grid::viewport( |
| 643 | +112 | ! |
- labs ++ x = 0, y = grid::unit(1, "npc") - top_height, width = grid::unit(1, "npc"), |
| 644 | +113 | ! |
- ggthemes ++ height = top_height, just = c("left", "bottom"), name = "topxaxis"
+ |
+
| 114 | ++ |
+ )) |
|
| 645 | +115 | ! |
- themes+ grid::grid.draw(xaxis_label_grob) |
| 646 | +116 | ! |
- print(g)+ grid::upViewport(1) |
| 647 | +117 |
- },+ } |
|
| 648 | -! | +||
| 118 | +
- env = list(+ |
||
| 649 | -! | +||
| 119 | +
- x_axis = x_axis,+ # draw y facet |
||
| 650 | +120 | ! |
- y_axis = y_axis,+ if (!is.null(yfacet_label)) {
|
| 651 | +121 | ! |
- variables = variables,+ grid::pushViewport(grid::viewport( |
| 652 | +122 | ! |
- ggthemes = parsed_ggplot2_args$ggtheme,+ x = grid::unit(1, "npc") - grid::unit(as.numeric(right_width) / 2, "line"), y = 0, width = right_width, |
| 653 | +123 | ! |
- labs = `if`(is.null(parsed_ggplot2_args$labs), quote(labs()), parsed_ggplot2_args$labs),+ height = grid::unit(1, "npc"), just = c("left", "bottom"), name = "rightyaxis"
+ |
+
| 124 | ++ |
+ )) |
|
| 654 | +125 | ! |
- themes = parsed_ggplot2_args$theme+ grid::grid.draw(yaxis_label_grob) |
| 655 | -+ | ||
| 126 | +! |
- )+ grid::upViewport(1) |
|
| 656 | +127 |
- )+ } |
|
| 657 | +128 |
- )+ }) |
|
| 658 | +129 |
- }+ } |
|
| 659 | +130 | ||
| 660 | +131 |
- # plot biplot ----+ #' Call a function with a character vector for the `...` argument |
|
| 661 | -! | +||
| 132 | +
- plot_biplot <- function(base_q) {
+ #' |
||
| 662 | -! | +||
| 133 | +
- qenv <- base_q+ #' @param fun (`character`) Name of a function where the `...` argument shall be replaced by values from `str_args`. |
||
| 663 | +134 |
-
+ #' @param str_args (`character`) A character vector that the function shall be executed with |
|
| 664 | -! | +||
| 135 | +
- ANL <- qenv[["ANL"]]+ #' |
||
| 665 | +136 |
-
+ #' @return |
|
| 666 | -! | +||
| 137 | +
- resp_col <- as.character(merged$anl_input_r()$columns_source$response)+ #' Value of call to `fun` with arguments specified in `str_args`. |
||
| 667 | -! | +||
| 138 | +
- dat_cols <- as.character(merged$anl_input_r()$columns_source$dat)+ #' |
||
| 668 | -! | +||
| 139 | +
- x_axis <- input$x_axis+ #' @keywords internal |
||
| 669 | -! | +||
| 140 | +
- y_axis <- input$y_axis+ call_fun_dots <- function(fun, str_args) {
|
||
| 670 | +141 | ! |
- variables <- input$variables+ do.call("call", c(list(fun), lapply(str_args, as.name)), quote = TRUE)
|
| 671 | -! | +||
| 142 | +
- pca <- qenv[["pca"]]+ } |
||
| 672 | +143 | ||
| 673 | -! | +||
| 144 | +
- ggtheme <- input$ggtheme+ #' Generate a string for a variable including its label |
||
| 674 | +145 |
-
+ #' |
|
| 675 | -! | +||
| 146 | +
- rotate_xaxis_labels <- input$rotate_xaxis_labels+ #' @param var_names (`character`) Name of variable to extract labels from. |
||
| 676 | -! | +||
| 147 | +
- alpha <- input$alpha+ #' @param dataset (`dataset`) Name of analysis dataset. |
||
| 677 | -! | +||
| 148 | +
- size <- input$size+ #' @param prefix,suffix (`character`) String to paste to the beginning/end of the variable name with label. |
||
| 678 | -! | +||
| 149 | +
- font_size <- input$font_size+ #' @param wrap_width (`numeric`) Number of characters to wrap original label to. Defaults to 80. |
||
| 679 | +150 |
-
+ #' |
|
| 680 | -! | +||
| 151 | +
- qenv <- teal.code::eval_code(+ #' @return (`character`) String with variable name and label. |
||
| 681 | -! | +||
| 152 | +
- qenv,+ #' |
||
| 682 | -! | +||
| 153 | +
- substitute(+ #' @keywords internal |
||
| 683 | -! | +||
| 154 | +
- expr = pca_rot <- dplyr::as_tibble(pca$x[, c(x_axis, y_axis)]),+ #' |
||
| 684 | -! | +||
| 155 | +
- env = list(x_axis = x_axis, y_axis = y_axis)+ varname_w_label <- function(var_names, |
||
| 685 | +156 |
- )+ dataset, |
|
| 686 | +157 |
- )+ wrap_width = 80, |
|
| 687 | +158 |
-
+ prefix = NULL, |
|
| 688 | +159 |
- # rot_vars = data frame that displays arrows in the plot, need to be scaled to data+ suffix = NULL) {
|
|
| 689 | +160 | ! |
- if (!is.null(input$variables)) {
+ add_label <- function(var_names) {
|
| 690 | +161 | ! |
- qenv <- teal.code::eval_code(+ label <- vapply( |
| 691 | +162 | ! |
- qenv,+ dataset[var_names], function(x) {
|
| 692 | +163 | ! |
- substitute(+ attr_label <- attr(x, "label") |
| 693 | +164 | ! |
- expr = {
+ `if`(is.null(attr_label), "", attr_label) |
| 694 | -! | +||
| 165 | +
- r <- sqrt(qchisq(0.69, df = 2)) * prod(colMeans(pca_rot ^ 2)) ^ (1 / 4) # styler: off+ }, |
||
| 695 | +166 | ! |
- v_scale <- rowSums(pca$rotation ^ 2) # styler: off+ character(1) |
| 696 | +167 |
-
+ ) |
|
| 697 | -! | +||
| 168 | +
- rot_vars <- pca$rotation[, c(x_axis, y_axis)] %>%+ |
||
| 698 | +169 | ! |
- dplyr::as_tibble(rownames = "label") %>%+ if (length(label) == 1 && !is.na(label) && !identical(label, "")) {
|
| 699 | +170 | ! |
- dplyr::mutate_at(vars(c(x_axis, y_axis)), function(x) r * x / sqrt(max(v_scale)))+ paste0(prefix, label, " [", var_names, "]", suffix) |
| 700 | +171 |
- },+ } else {
|
|
| 701 | +172 | ! |
- env = list(x_axis = x_axis, y_axis = y_axis)+ var_names |
| 702 | +173 |
- )+ } |
|
| 703 | +174 |
- ) %>%- |
- |
| 704 | -! | -
- teal.code::eval_code(- |
- |
| 705 | -! | -
- if (is.logical(pca$center) && !pca$center) {
+ } |
|
| 706 | -! | +||
| 175 | +
- substitute(+ |
||
| 707 | +176 | ! |
- expr = {
+ if (length(var_names) < 1) {
|
| 708 | +177 | ! |
- rot_vars <- rot_vars %>%+ NULL |
| 709 | +178 | ! |
- tibble::column_to_rownames("label") %>%
+ } else if (length(var_names) == 1) {
|
| 710 | +179 | ! |
- sweep(1, apply(ANL[keep_columns], 2, mean, na.rm = TRUE)) %>%+ stringr::str_wrap(add_label(var_names), width = wrap_width) |
| 711 | +180 | ! |
- tibble::rownames_to_column("label") %>%
+ } else if (length(var_names) > 1) {
|
| 712 | +181 | ! |
- dplyr::mutate(+ stringr::str_wrap(vapply(var_names, add_label, character(1)), width = wrap_width) |
| 713 | -! | +||
| 182 | +
- xstart = mean(pca$x[, x_axis], na.rm = TRUE),+ } |
||
| 714 | -! | +||
| 183 | +
- ystart = mean(pca$x[, y_axis], na.rm = TRUE)+ } |
||
| 715 | +184 |
- )+ |
|
| 716 | +185 |
- },+ # see vignette("ggplot2-specs", package="ggplot2")
|
|
| 717 | -! | +||
| 186 | +
- env = list(x_axis = x_axis, y_axis = y_axis)+ shape_names <- c( |
||
| 718 | +187 |
- )+ "circle", paste("circle", c("open", "filled", "cross", "plus", "small")), "bullet",
|
|
| 719 | +188 |
- } else {
+ "square", paste("square", c("open", "filled", "cross", "plus", "triangle")),
|
|
| 720 | -! | +||
| 189 | +
- quote(rot_vars <- rot_vars %>% dplyr::mutate(xstart = 0, ystart = 0))+ "diamond", paste("diamond", c("open", "filled", "plus")),
|
||
| 721 | +190 |
- }+ "triangle", paste("triangle", c("open", "filled", "square")),
|
|
| 722 | +191 |
- ) %>%+ paste("triangle down", c("open", "filled")),
|
|
| 723 | -! | +||
| 192 | +
- teal.code::eval_code(+ "plus", "cross", "asterisk" |
||
| 724 | -! | +||
| 193 | +
- substitute(+ ) |
||
| 725 | -! | +||
| 194 | +
- expr = rot_vars <- rot_vars %>% dplyr::filter(label %in% variables),+ |
||
| 726 | -! | +||
| 195 | +
- env = list(variables = variables)+ #' Get icons to represent variable types in dataset |
||
| 727 | +196 |
- )+ #' |
|
| 728 | +197 |
- )+ #' @param var_type (`character`) of R internal types (classes). |
|
| 729 | +198 |
- }+ #' @return (`character`) vector of HTML icons corresponding to data type in each column. |
|
| 730 | +199 |
-
+ #' @keywords internal+ |
+ |
| 200 | ++ |
+ variable_type_icons <- function(var_type) {
|
|
| 731 | +201 | ! |
- pca_plot_biplot_expr <- list(quote(ggplot()))+ checkmate::assert_character(var_type, any.missing = FALSE) |
| 732 | +202 | ||
| 733 | +203 | ! |
- if (length(resp_col) == 0) {
+ class_to_icon <- list( |
| 734 | +204 | ! |
- pca_plot_biplot_expr <- c(+ numeric = "arrow-up-1-9", |
| 735 | +205 | ! |
- pca_plot_biplot_expr,+ integer = "arrow-up-1-9", |
| 736 | +206 | ! |
- substitute(+ logical = "pause", |
| 737 | +207 | ! |
- geom_point(aes_string(x = x_axis, y = y_axis), data = pca_rot, alpha = alpha, size = size),+ Date = "calendar", |
| 738 | +208 | ! |
- list(x_axis = input$x_axis, y_axis = input$y_axis, alpha = input$alpha, size = input$size)+ POSIXct = "calendar", |
| 739 | -+ | ||
| 209 | +! |
- )+ POSIXlt = "calendar", |
|
| 740 | -+ | ||
| 210 | +! |
- )+ factor = "chart-bar", |
|
| 741 | +211 | ! |
- dev_labs <- list()+ character = "keyboard", |
| 742 | -+ | ||
| 212 | +! |
- } else {
+ primary_key = "key", |
|
| 743 | +213 | ! |
- rp_keys <- setdiff(colnames(ANL), as.character(unlist(merged$anl_input_r()$columns_source)))+ unknown = "circle-question" |
| 744 | +214 |
-
+ ) |
|
| 745 | +215 | ! |
- response <- ANL[[resp_col]]+ class_to_icon <- lapply(class_to_icon, function(icon_name) toString(icon(icon_name, lib = "font-awesome"))) |
| 746 | +216 | ||
| 747 | +217 | ! |
- aes_biplot <- substitute(+ unname(vapply( |
| 748 | +218 | ! |
- aes_string(x = x_axis, y = y_axis, color = "response"),+ var_type, |
| 749 | +219 | ! |
- env = list(x_axis = x_axis, y_axis = y_axis)- |
-
| 750 | -- |
- )+ FUN.VALUE = character(1), |
|
| 751 | -+ | ||
| 220 | +! |
-
+ FUN = function(class) {
|
|
| 752 | +221 | ! |
- qenv <- teal.code::eval_code(+ if (class == "") {
|
| 753 | +222 | ! |
- qenv,+ class |
| 754 | +223 | ! |
- substitute(response <- ANL[[resp_col]], env = list(resp_col = resp_col))+ } else if (is.null(class_to_icon[[class]])) {
|
| 755 | -+ | ||
| 224 | +! |
- )+ class_to_icon[["unknown"]] |
|
| 756 | +225 |
-
+ } else {
|
|
| 757 | +226 | ! |
- dev_labs <- list(color = varname_w_label(resp_col, ANL))+ class_to_icon[[class]] |
| 758 | +227 | - - | -|
| 759 | -! | -
- scales_biplot <-+ } |
|
| 760 | -! | +||
| 228 | +
- if (+ } |
||
| 761 | -! | +||
| 229 | +
- is.character(response) ||+ )) |
||
| 762 | -! | +||
| 230 | +
- is.factor(response) ||+ } |
||
| 763 | -! | +||
| 231 | +
- (is.numeric(response) && length(unique(response)) <= 6)+ |
||
| 764 | +232 |
- ) {
+ #' Include `CSS` files from `/inst/css/` package directory to application header |
|
| 765 | -! | +||
| 233 | +
- qenv <- teal.code::eval_code(+ #' |
||
| 766 | -! | +||
| 234 | +
- qenv,+ #' `system.file` should not be used to access files in other packages, it does |
||
| 767 | -! | +||
| 235 | +
- quote(pca_rot$response <- as.factor(response))+ #' not work with `devtools`. Therefore, we redefine this method in each package |
||
| 768 | +236 |
- )+ #' as needed. Thus, we do not export this method |
|
| 769 | -! | +||
| 237 | +
- quote(scale_color_brewer(palette = "Dark2"))+ #' |
||
| 770 | -! | +||
| 238 | +
- } else if (inherits(response, "Date")) {
+ #' @param pattern (`character`) optional, regular expression to match the file names to be included. |
||
| 771 | -! | +||
| 239 | +
- qenv <- teal.code::eval_code(+ #' |
||
| 772 | -! | +||
| 240 | +
- qenv,+ #' @return HTML code that includes `CSS` files. |
||
| 773 | -! | +||
| 241 | +
- quote(pca_rot$response <- numeric(response))+ #' @keywords internal |
||
| 774 | +242 |
- )+ #' |
|
| 775 | +243 |
-
+ include_css_files <- function(pattern = "*") {
|
|
| 776 | +244 | ! |
- quote(+ css_files <- list.files( |
| 777 | +245 | ! |
- scale_color_gradient(+ system.file("css", package = "teal.modules.general", mustWork = TRUE),
|
| 778 | +246 | ! |
- low = c(getOption("ggplot2.discrete.colour")[2], "darkred")[1],
+ pattern = pattern, full.names = TRUE+ |
+
| 247 | ++ |
+ ) |
|
| 779 | +248 | ! |
- high = c(getOption("ggplot2.discrete.colour"), "lightblue")[1],
+ if (length(css_files) == 0) {
|
| 780 | +249 | ! |
- labels = function(x) as.Date(x, origin = "1970-01-01")+ return(NULL) |
| 781 | +250 |
- )+ } |
|
| 782 | -+ | ||
| 251 | +! |
- )+ singleton(tags$head(lapply(css_files, includeCSS))) |
|
| 783 | +252 |
- } else {
- |
- |
| 784 | -! | -
- qenv <- teal.code::eval_code(+ } |
|
| 785 | -! | +||
| 253 | +
- qenv,+ |
||
| 786 | -! | +||
| 254 | +
- quote(pca_rot$response <- response)+ #' JavaScript condition to check if a specific tab is active |
||
| 787 | +255 |
- )+ #' |
|
| 788 | -! | +||
| 256 | +
- quote(scale_color_gradient(+ #' @param id (`character(1)`) the id of the tab panel with tabs. |
||
| 789 | -! | +||
| 257 | +
- low = c(getOption("ggplot2.discrete.colour")[2], "darkred")[1],
+ #' @param name (`character(1)`) the name of the tab. |
||
| 790 | -! | +||
| 258 | +
- high = c(getOption("ggplot2.discrete.colour"), "lightblue")[1]
+ #' @return JavaScript expression to be used in `shiny::conditionalPanel()` to determine |
||
| 791 | +259 |
- ))+ #' if the specified tab is active. |
|
| 792 | +260 |
- }+ #' @keywords internal |
|
| 793 | +261 |
-
+ #' |
|
| 794 | -! | +||
| 262 | +
- pca_plot_biplot_expr <- c(+ is_tab_active_js <- function(id, name) {
|
||
| 795 | -! | +||
| 263 | +
- pca_plot_biplot_expr,+ # supporting the bs3 and higher version at the same time |
||
| 796 | +264 | ! |
- substitute(+ sprintf( |
| 797 | +265 | ! |
- geom_point(aes_biplot, data = pca_rot, alpha = alpha, size = size),+ "$(\"#%1$s > li.active\").text().trim() == '%2$s' || $(\"#%1$s > li a.active\").text().trim() == '%2$s'", |
| 798 | +266 | ! |
- env = list(aes_biplot = aes_biplot, alpha = alpha, size = size)+ id, name |
| 799 | +267 |
- ),+ ) |
|
| 800 | -! | +||
| 268 | +
- scales_biplot+ } |
||
| 801 | +269 |
- )+ |
|
| 802 | +270 |
- }+ #' Assert single selection on `data_extract_spec` object |
|
| 803 | +271 |
-
+ #' Helper to reduce code in assertions |
|
| 804 | -! | +||
| 272 | +
- if (!is.null(input$variables)) {
+ #' @noRd |
||
| 805 | -! | +||
| 273 | +
- pca_plot_biplot_expr <- c(+ #' |
||
| 806 | -! | +||
| 274 | +
- pca_plot_biplot_expr,+ assert_single_selection <- function(x, |
||
| 807 | -! | +||
| 275 | +
- substitute(+ .var.name = checkmate::vname(x)) { # nolint: object_name.
|
||
| 808 | -! | +||
| 276 | +104x |
- geom_segment(+ if (any(vapply(x, function(.x) .x$select$multiple, logical(1)))) {
|
|
| 809 | -! | +||
| 277 | +4x |
- aes_string(x = "xstart", y = "ystart", xend = x_axis, yend = y_axis),+ stop("'", .var.name, "' should not allow multiple selection")
|
|
| 810 | -! | +||
| 278 | +
- data = rot_vars,+ } |
||
| 811 | -! | +||
| 279 | +100x |
- lineend = "round", linejoin = "round",+ invisible(TRUE) |
|
| 812 | -! | +||
| 280 | +
- arrow = grid::arrow(length = grid::unit(0.5, "cm"))+ } |
| 813 | +1 |
- ),+ #' `teal` module: Front page |
|
| 814 | -! | +||
| 2 | +
- env = list(x_axis = x_axis, y_axis = y_axis)+ #' |
||
| 815 | +3 |
- ),+ #' Creates a simple front page for `teal` applications, displaying |
|
| 816 | -! | +||
| 4 | +
- substitute(+ #' introductory text, tables, additional `html` or `shiny` tags, and footnotes. |
||
| 817 | -! | +||
| 5 | +
- geom_label(+ #' |
||
| 818 | -! | +||
| 6 | +
- aes_string(+ #' @inheritParams teal::module |
||
| 819 | -! | +||
| 7 | +
- x = x_axis,+ #' @param header_text (`character` vector) text to be shown at the top of the module, for each |
||
| 820 | -! | +||
| 8 | +
- y = y_axis,+ #' element, if named the name is shown first in bold as a header followed by the value. The first |
||
| 821 | -! | +||
| 9 | +
- label = "label"+ #' element's header is displayed larger than the others. |
||
| 822 | +10 |
- ),+ #' @param tables (`named list` of `data.frame`s) tables to be shown in the module. |
|
| 823 | -! | +||
| 11 | +
- data = rot_vars,+ #' @param additional_tags (`shiny.tag.list` or `html`) additional `shiny` tags or `html` to be included after the table, |
||
| 824 | -! | +||
| 12 | +
- nudge_y = 0.1,+ #' for example to include an image, `tagList(tags$img(src = "image.png"))` or to include further `html`, |
||
| 825 | -! | +||
| 13 | +
- fontface = "bold"+ #' `HTML("html text here")`.
|
||
| 826 | +14 |
- ),+ #' @param footnotes (`character` vector) of text to be shown at the bottom of the module, for each |
|
| 827 | -! | +||
| 15 | +
- env = list(x_axis = x_axis, y_axis = y_axis)+ #' element, if named the name is shown first in bold, followed by the value. |
||
| 828 | +16 |
- ),+ #' @param show_metadata (`logical`) indicating whether the metadata of the datasets be available on the module. |
|
| 829 | -! | +||
| 17 | +
- quote(geom_point(aes(x = xstart, y = ystart), data = rot_vars, shape = "x", size = 5))+ #' |
||
| 830 | +18 |
- )+ #' @inherit shared_params return |
|
| 831 | +19 |
- }+ #' |
|
| 832 | +20 |
-
+ #' @examplesShinylive |
|
| 833 | -! | +||
| 21 | +
- angle <- ifelse(isTRUE(rotate_xaxis_labels), 45, 0)+ #' library(teal.modules.general) |
||
| 834 | -! | +||
| 22 | +
- hjust <- ifelse(isTRUE(rotate_xaxis_labels), 1, 0.5)+ #' interactive <- function() TRUE |
||
| 835 | +23 |
-
+ #' {{ next_example }}
|
|
| 836 | -! | +||
| 24 | +
- dev_ggplot2_args <- teal.widgets::ggplot2_args(+ #' @examples |
||
| 837 | -! | +||
| 25 | +
- labs = dev_labs,+ #' data <- teal_data() |
||
| 838 | -! | +||
| 26 | +
- theme = list(+ #' data <- within(data, {
|
||
| 839 | -! | +||
| 27 | +
- text = substitute(element_text(size = font_size), list(font_size = font_size)),+ #' require(nestcolor) |
||
| 840 | -! | +||
| 28 | +
- axis.text.x = substitute(+ #' ADSL <- rADSL |
||
| 841 | -! | +||
| 29 | +
- element_text(angle = angle_val, hjust = hjust_val),+ #' attr(ADSL, "metadata") <- list("Author" = "NEST team", "data_source" = "synthetic data")
|
||
| 842 | -! | +||
| 30 | +
- list(angle_val = angle, hjust_val = hjust)+ #' }) |
||
| 843 | +31 |
- )+ #' join_keys(data) <- default_cdisc_join_keys[names(data)] |
|
| 844 | +32 |
- )+ #' |
|
| 845 | +33 |
- )+ #' table_1 <- data.frame(Info = c("A", "B"), Text = c("A", "B"))
|
|
| 846 | +34 |
-
+ #' table_2 <- data.frame(`Column 1` = c("C", "D"), `Column 2` = c(5.5, 6.6), `Column 3` = c("A", "B"))
|
|
| 847 | -! | +||
| 35 | +
- all_ggplot2_args <- teal.widgets::resolve_ggplot2_args(+ #' table_3 <- data.frame(Info = c("E", "F"), Text = c("G", "H"))
|
||
| 848 | -! | +||
| 36 | +
- user_plot = ggplot2_args[["Biplot"]],+ #' |
||
| 849 | -! | +||
| 37 | +
- user_default = ggplot2_args$default,+ #' table_input <- list( |
||
| 850 | -! | +||
| 38 | +
- module_plot = dev_ggplot2_args+ #' "Table 1" = table_1, |
||
| 851 | +39 |
- )+ #' "Table 2" = table_2, |
|
| 852 | +40 |
-
+ #' "Table 3" = table_3 |
|
| 853 | -! | +||
| 41 | +
- parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(+ #' ) |
||
| 854 | -! | +||
| 42 | +
- all_ggplot2_args,+ #' |
||
| 855 | -! | +||
| 43 | +
- ggtheme = ggtheme+ #' app <- init( |
||
| 856 | +44 |
- )+ #' data = data, |
|
| 857 | +45 |
-
+ #' modules = modules( |
|
| 858 | -! | +||
| 46 | +
- pca_plot_biplot_expr <- c(+ #' tm_front_page( |
||
| 859 | -! | +||
| 47 | +
- pca_plot_biplot_expr,+ #' header_text = c( |
||
| 860 | -! | +||
| 48 | +
- parsed_ggplot2_args+ #' "Important information" = "It can go here.", |
||
| 861 | +49 |
- )+ #' "Other information" = "Can go here." |
|
| 862 | +50 |
-
+ #' ), |
|
| 863 | -! | +||
| 51 | +
- teal.code::eval_code(+ #' tables = table_input, |
||
| 864 | -! | +||
| 52 | +
- qenv,+ #' additional_tags = HTML("Additional HTML or shiny tags go here <br>"),
|
||
| 865 | -! | +||
| 53 | +
- substitute(+ #' footnotes = c("X" = "is the first footnote", "Y is the second footnote"),
|
||
| 866 | -! | +||
| 54 | +
- expr = {
+ #' show_metadata = TRUE |
||
| 867 | -! | +||
| 55 | +
- g <- plot_call+ #' ) |
||
| 868 | -! | +||
| 56 | +
- print(g)+ #' ), |
||
| 869 | +57 |
- },+ #' header = tags$h1("Sample Application"),
|
|
| 870 | -! | +||
| 58 | +
- env = list(+ #' footer = tags$p("Application footer"),
|
||
| 871 | -! | +||
| 59 | +
- plot_call = Reduce(function(x, y) call("+", x, y), pca_plot_biplot_expr)
+ #' ) |
||
| 872 | +60 |
- )+ #' |
|
| 873 | +61 |
- )+ #' if (interactive()) {
|
|
| 874 | +62 |
- )+ #' shinyApp(app$ui, app$server) |
|
| 875 | +63 |
- }+ #' } |
|
| 876 | +64 |
-
+ #' |
|
| 877 | +65 |
- # plot pc_var ----+ #' @export |
|
| 878 | -! | +||
| 66 | +
- plot_pc_var <- function(base_q) {
+ #' |
||
| 879 | -! | +||
| 67 | +
- pc <- input$pc+ tm_front_page <- function(label = "Front page", |
||
| 880 | -! | +||
| 68 | +
- ggtheme <- input$ggtheme+ header_text = character(0), |
||
| 881 | +69 |
-
+ tables = list(), |
|
| 882 | -! | +||
| 70 | +
- rotate_xaxis_labels <- input$rotate_xaxis_labels+ additional_tags = tagList(), |
||
| 883 | -! | +||
| 71 | +
- font_size <- input$font_size+ footnotes = character(0), |
||
| 884 | +72 |
-
+ show_metadata = FALSE) {
|
|
| 885 | +73 | ! |
- angle <- ifelse(rotate_xaxis_labels, 45, 0)+ message("Initializing tm_front_page")
|
| 886 | -! | +||
| 74 | +
- hjust <- ifelse(rotate_xaxis_labels, 1, 0.5)+ |
||
| 887 | +75 |
-
+ # Start of assertions |
|
| 888 | +76 | ! |
- dev_ggplot2_args <- teal.widgets::ggplot2_args(+ checkmate::assert_string(label) |
| 889 | +77 | ! |
- theme = list(+ checkmate::assert_character(header_text, min.len = 0, any.missing = FALSE) |
| 890 | +78 | ! |
- text = substitute(element_text(size = font_size), list(font_size = font_size)),+ checkmate::assert_list(tables, types = "data.frame", names = "named", any.missing = FALSE) |
| 891 | +79 | ! |
- axis.text.x = substitute(+ checkmate::assert_multi_class(additional_tags, classes = c("shiny.tag.list", "html"))
|
| 892 | +80 | ! |
- element_text(angle = angle_val, hjust = hjust_val),+ checkmate::assert_character(footnotes, min.len = 0, any.missing = FALSE) |
| 893 | +81 | ! |
- list(angle_val = angle, hjust_val = hjust)+ checkmate::assert_flag(show_metadata) |
| 894 | +82 |
- )+ # End of assertions |
|
| 895 | +83 |
- )+ |
|
| 896 | +84 |
- )+ # Make UI args+ |
+ |
| 85 | +! | +
+ args <- as.list(environment()) |
|
| 897 | +86 | ||
| 898 | +87 | ! |
- all_ggplot2_args <- teal.widgets::resolve_ggplot2_args(+ ans <- module( |
| 899 | +88 | ! |
- user_plot = ggplot2_args[["Eigenvector plot"]],+ label = label, |
| 900 | +89 | ! |
- user_default = ggplot2_args$default,+ server = srv_front_page, |
| 901 | +90 | ! |
- module_plot = dev_ggplot2_args- |
-
| 902 | -- |
- )- |
- |
| 903 | -- |
-
+ ui = ui_front_page, |
|
| 904 | +91 | ! |
- parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(+ ui_args = args, |
| 905 | +92 | ! |
- all_ggplot2_args,+ server_args = list(tables = tables, show_metadata = show_metadata), |
| 906 | +93 | ! |
- ggtheme = ggtheme- |
-
| 907 | -- |
- )+ datanames = if (show_metadata) "all" else NULL |
|
| 908 | +94 | - - | -|
| 909 | -! | -
- ggplot_exprs <- c(+ ) |
|
| 910 | +95 | ! |
- list(+ attr(ans, "teal_bookmarkable") <- TRUE |
| 911 | +96 | ! |
- quote(ggplot(pca_rot)),+ ans |
| 912 | -! | +||
| 97 | +
- substitute(+ } |
||
| 913 | -! | +||
| 98 | +
- geom_bar(+ |
||
| 914 | -! | +||
| 99 | +
- aes_string(x = "Variable", y = pc),+ # UI function for the front page module |
||
| 915 | -! | +||
| 100 | +
- stat = "identity",+ ui_front_page <- function(id, ...) {
|
||
| 916 | +101 | ! |
- color = "black",+ args <- list(...) |
| 917 | +102 | ! |
- fill = c(getOption("ggplot2.discrete.colour"), "lightblue")[1]
+ ns <- NS(id) |
| 918 | +103 |
- ),+ |
|
| 919 | +104 | ! |
- env = list(pc = pc)- |
-
| 920 | -- |
- ),+ tagList( |
|
| 921 | +105 | ! |
- substitute(+ include_css_files("custom"),
|
| 922 | +106 | ! |
- geom_text(+ tags$div( |
| 923 | +107 | ! |
- aes(+ id = "front_page_content", |
| 924 | +108 | ! |
- x = Variable,+ class = "ml-8", |
| 925 | +109 | ! |
- y = pc_name,+ tags$div( |
| 926 | +110 | ! |
- label = round(pc_name, 3),+ id = "front_page_headers", |
| 927 | +111 | ! |
- vjust = ifelse(pc_name > 0, -0.5, 1.3)- |
-
| 928 | -- |
- )+ get_header_tags(args$header_text) |
|
| 929 | +112 |
- ),+ ), |
|
| 930 | +113 | ! |
- env = list(pc_name = as.name(pc))- |
-
| 931 | -- |
- )- |
- |
| 932 | -- |
- ),+ tags$div( |
|
| 933 | +114 | ! |
- parsed_ggplot2_args$labs,+ id = "front_page_tables", |
| 934 | +115 | ! |
- parsed_ggplot2_args$ggtheme,+ class = "ml-4", |
| 935 | +116 | ! |
- parsed_ggplot2_args$theme+ get_table_tags(args$tables, ns) |
| 936 | +117 |
- )+ ), |
|
| 937 | -+ | ||
| 118 | +! |
-
+ tags$div( |
|
| 938 | +119 | ! |
- teal.code::eval_code(+ id = "front_page_custom_html", |
| 939 | +120 | ! |
- base_q,+ class = "my-4", |
| 940 | +121 | ! |
- substitute(+ args$additional_tags+ |
+
| 122 | ++ |
+ ), |
|
| 941 | +123 | ! |
- expr = {
+ if (args$show_metadata) {
|
| 942 | +124 | ! |
- pca_rot <- pca$rotation[, pc, drop = FALSE] %>%+ tags$div( |
| 943 | +125 | ! |
- dplyr::as_tibble(rownames = "Variable")+ id = "front_page_metabutton", |
| 944 | -+ | ||
| 126 | +! |
-
+ class = "m-4", |
|
| 945 | +127 | ! |
- g <- plot_call+ actionButton(ns("metadata_button"), "Show metadata")
|
| 946 | +128 | - - | -|
| 947 | -! | -
- print(g)+ ) |
|
| 948 | +129 |
- },+ }, |
|
| 949 | +130 | ! |
- env = list(+ tags$footer( |
| 950 | +131 | ! |
- pc = pc,+ class = ".small", |
| 951 | +132 | ! |
- plot_call = Reduce(function(x, y) call("+", x, y), ggplot_exprs)
+ get_footer_tags(args$footnotes) |
| 952 | +133 |
- )+ ) |
|
| 953 | +134 |
- )+ ) |
|
| 954 | +135 |
- )+ ) |
|
| 955 | +136 |
- }+ } |
|
| 956 | +137 | ||
| 957 | +138 |
- # plot final ----- |
- |
| 958 | -! | -
- output_q <- reactive({
- |
- |
| 959 | -! | -
- req(computation())- |
- |
| 960 | -! | -
- teal::validate_inputs(iv_r())- |
- |
| 961 | -! | -
- teal::validate_inputs(iv_extra, header = "Plot settings are required")+ # Server function for the front page module |
|
| 962 | +139 | - - | -|
| 963 | -! | -
- switch(input$plot_type,- |
- |
| 964 | -! | -
- "Elbow plot" = plot_elbow(computation()),+ srv_front_page <- function(id, data, tables, show_metadata) {
|
|
| 965 | +140 | ! |
- "Circle plot" = plot_circle(computation()),+ checkmate::assert_class(data, "reactive") |
| 966 | +141 | ! |
- "Biplot" = plot_biplot(computation()),+ checkmate::assert_class(isolate(data()), "teal_data") |
| 967 | +142 | ! |
- "Eigenvector plot" = plot_pc_var(computation()),+ moduleServer(id, function(input, output, session) {
|
| 968 | +143 | ! |
- stop("Unknown plot")
+ teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.general") |
| 969 | +144 |
- )+ |
|
| 970 | -+ | ||
| 145 | +! |
- })+ ns <- session$ns |
|
| 971 | +146 | ||
| 972 | -! | -
- plot_r <- reactive({
- |
- |
| 973 | +147 | ! |
- output_q()[["g"]]- |
-
| 974 | -- |
- })+ setBookmarkExclude("metadata_button")
|
|
| 975 | +148 | ||
| 976 | +149 | ! |
- pws <- teal.widgets::plot_with_settings_srv(+ lapply(seq_along(tables), function(idx) {
|
| 977 | +150 | ! |
- id = "pca_plot",+ output[[paste0("table_", idx)]] <- renderTable(
|
| 978 | +151 | ! |
- plot_r = plot_r,+ tables[[idx]], |
| 979 | +152 | ! |
- height = plot_height,+ bordered = TRUE, |
| 980 | +153 | ! |
- width = plot_width,+ caption = names(tables)[idx], |
| 981 | +154 | ! |
- graph_align = "center"+ caption.placement = "top" |
| 982 | +155 |
- )+ ) |
|
| 983 | +156 |
-
+ }) |
|
| 984 | +157 |
- # tables ----+ |
|
| 985 | +158 | ! |
- output$tbl_importance <- renderTable(+ if (show_metadata) {
|
| 986 | +159 | ! |
- expr = {
+ observeEvent( |
| 987 | +160 | ! |
- req("importance" %in% input$tables_display, computation())
+ input$metadata_button, showModal( |
| 988 | +161 | ! |
- computation()[["tbl_importance"]]+ modalDialog( |
| 989 | -+ | ||
| 162 | +! |
- },+ title = "Metadata", |
|
| 990 | +163 | ! |
- bordered = TRUE,+ dataTableOutput(ns("metadata_table")),
|
| 991 | +164 | ! |
- align = "c",+ size = "l", |
| 992 | +165 | ! |
- digits = 3+ easyClose = TRUE |
| 993 | +166 |
- )+ ) |
|
| 994 | +167 |
-
+ ) |
|
| 995 | -! | +||
| 168 | +
- output$tbl_importance_ui <- renderUI({
+ ) |
||
| 996 | -! | +||
| 169 | +
- req("importance" %in% input$tables_display)
+
|
||
| 997 | +170 | ! |
- tags$div(+ metadata_data_frame <- reactive({
|
| 998 | +171 | ! |
- align = "center",+ datanames <- names(data()) |
| 999 | +172 | ! |
- tags$h4("Principal components importance"),
+ convert_metadata_to_dataframe( |
| 1000 | +173 | ! |
- tableOutput(session$ns("tbl_importance")),
+ lapply(datanames, function(dataname) attr(data()[[dataname]], "metadata")), |
| 1001 | +174 | ! |
- tags$hr()+ datanames |
| 1002 | +175 |
- )+ ) |
|
| 1003 | +176 |
- })+ }) |
|
| 1004 | +177 | ||
| 1005 | +178 | ! |
- output$tbl_eigenvector <- renderTable(+ output$metadata_table <- renderDataTable({
|
| 1006 | +179 | ! |
- expr = {
+ validate(need(nrow(metadata_data_frame()) > 0, "The data has no associated metadata")) |
| 1007 | +180 | ! |
- req("eigenvector" %in% input$tables_display, req(computation()))
+ metadata_data_frame() |
| 1008 | -! | +||
| 181 | +
- computation()[["tbl_eigenvector"]]+ }) |
||
| 1009 | +182 |
- },+ } |
|
| 1010 | -! | +||
| 183 | +
- bordered = TRUE,+ }) |
||
| 1011 | -! | +||
| 184 | +
- align = "c",+ } |
||
| 1012 | -! | +||
| 185 | +
- digits = 3+ |
||
| 1013 | +186 |
- )+ ## utils functions |
|
| 1014 | +187 | ||
| 188 | ++ |
+ get_header_tags <- function(header_text) {
+ |
+ |
| 1015 | +189 | ! |
- output$tbl_eigenvector_ui <- renderUI({
+ if (length(header_text) == 0) {
|
| 1016 | +190 | ! |
- req("eigenvector" %in% input$tables_display)
+ return(list())+ |
+
| 191 | ++ |
+ }+ |
+ |
| 192 | ++ | + | |
| 1017 | +193 | ! |
- tags$div(+ get_single_header_tags <- function(header_text, p_text, header_tag = tags$h4) {
|
| 1018 | +194 | ! |
- align = "center",+ tagList( |
| 1019 | +195 | ! |
- tags$h4("Eigenvectors"),
+ tags$div( |
| 1020 | +196 | ! |
- tableOutput(session$ns("tbl_eigenvector")),
+ if (!is.null(header_text) && nchar(header_text) > 0) header_tag(header_text), |
| 1021 | +197 | ! |
- tags$hr()+ tags$p(p_text) |
| 1022 | +198 |
) |
|
| 1023 | +199 |
- })+ ) |
|
| 1024 | +200 | ++ |
+ }+ |
+
| 201 | |||
| 1025 | +202 | ! |
- output$all_plots <- renderUI({
+ header_tags <- get_single_header_tags(names(header_text[1]), header_text[1], header_tag = tags$h3) |
| 1026 | +203 | ! |
- teal::validate_inputs(iv_r())+ c(header_tags, mapply(get_single_header_tags, utils::tail(names(header_text), -1), utils::tail(header_text, -1))) |
| 1027 | -! | +||
| 204 | +
- teal::validate_inputs(iv_extra, header = "Plot settings are required")+ } |
||
| 1028 | +205 | ||
| 1029 | -! | +||
| 206 | +
- validation()+ get_table_tags <- function(tables, ns) {
|
||
| 1030 | +207 | ! |
- tags$div(+ if (length(tables) == 0) {
|
| 1031 | +208 | ! |
- class = "overflow-scroll",+ return(list())+ |
+
| 209 | ++ |
+ } |
|
| 1032 | +210 | ! |
- uiOutput(session$ns("tbl_importance_ui")),
+ table_tags <- c(lapply(seq_along(tables), function(idx) {
|
| 1033 | +211 | ! |
- uiOutput(session$ns("tbl_eigenvector_ui")),
+ list( |
| 1034 | +212 | ! |
- teal.widgets::plot_with_settings_ui(id = session$ns("pca_plot"))
+ tableOutput(ns(paste0("table_", idx)))
|
| 1035 | +213 |
- )+ ) |
|
| 1036 | +214 |
- })+ }))+ |
+ |
| 215 | +! | +
+ return(table_tags) |
|
| 1037 | +216 |
-
+ } |
|
| 1038 | -! | +||
| 217 | +
- teal.widgets::verbatim_popup_srv(+ |
||
| 1039 | -! | +||
| 218 | +
- id = "rcode",+ get_footer_tags <- function(footnotes) {
|
||
| 1040 | +219 | ! |
- verbatim_content = reactive(teal.code::get_code(output_q())),+ if (length(footnotes) == 0) {
|
| 1041 | +220 | ! |
- title = "R Code for PCA"- |
-
| 1042 | -- |
- )+ return(list()) |
|
| 1043 | +221 |
-
+ } |
|
| 1044 | -+ | ||
| 222 | +! |
- ### REPORTER+ bold_texts <- if (is.null(names(footnotes))) rep("", length(footnotes)) else names(footnotes)
|
|
| 1045 | +223 | ! |
- if (with_reporter) {
+ footnote_tags <- mapply(function(bold_text, value) {
|
| 1046 | +224 | ! |
- card_fun <- function(comment, label) {
+ list( |
| 1047 | +225 | ! |
- card <- teal::report_card_template(+ tags$div( |
| 1048 | +226 | ! |
- title = "Principal Component Analysis Plot",+ tags$b(bold_text), |
| 1049 | +227 | ! |
- label = label,+ value, |
| 1050 | +228 | ! |
- with_filter = with_filter,+ tags$br() |
| 1051 | -! | +||
| 229 | +
- filter_panel_api = filter_panel_api+ ) |
||
| 1052 | +230 |
- )+ ) |
|
| 1053 | +231 | ! |
- card$append_text("Principal Components Table", "header3")
+ }, bold_text = bold_texts, value = footnotes) |
| 1054 | -! | +||
| 232 | +
- card$append_table(computation()[["tbl_importance"]])+ } |
||
| 1055 | -! | +||
| 233 | +
- card$append_text("Eigenvectors Table", "header3")
+
|
||
| 1056 | -! | +||
| 234 | +
- card$append_table(computation()[["tbl_eigenvector"]])+ # take a list of metadata, one item per dataset (raw_metadata each element from datasets$get_metadata()) |
||
| 1057 | -! | +||
| 235 | +
- card$append_text("Plot", "header3")
+ # and the corresponding datanames and output a data.frame with columns {Dataset, Name, Value}.
|
||
| 1058 | -! | +||
| 236 | +
- card$append_plot(plot_r(), dim = pws$dim())+ # which are, the Dataset the metadata came from, the metadata's name and value |
||
| 1059 | -! | +||
| 237 | +
- if (!comment == "") {
+ convert_metadata_to_dataframe <- function(raw_metadata, datanames) {
|
||
| 1060 | -! | +||
| 238 | +4x |
- card$append_text("Comment", "header3")
+ output <- mapply(function(metadata, dataname) {
|
|
| 1061 | -! | +||
| 239 | +6x |
- card$append_text(comment)+ if (is.null(metadata)) {
+ |
+ |
| 240 | +2x | +
+ return(data.frame(Dataset = character(0), Name = character(0), Value = character(0))) |
|
| 1062 | +241 |
- }+ } |
|
| 1063 | -! | +||
| 242 | +4x |
- card$append_src(teal.code::get_code(output_q()))+ return(data.frame( |
|
| 1064 | -! | +||
| 243 | +4x |
- card+ Dataset = dataname, |
|
| 1065 | -+ | ||
| 244 | +4x |
- }+ Name = names(metadata), |
|
| 1066 | -! | +||
| 245 | +4x |
- teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
+ Value = unname(unlist(lapply(metadata, as.character))) |
|
| 1067 | +246 |
- }+ )) |
|
| 1068 | -+ | ||
| 247 | +4x |
- ###+ }, raw_metadata, datanames, SIMPLIFY = FALSE) |
|
| 1069 | -+ | ||
| 248 | +4x |
- })+ do.call(rbind, output) |
|
| 1070 | +249 |
} |