| 1 |
- #' `teal` module: Scatterplot matrix+ #' `teal` module: Distribution analysis |
|||
| 3 |
- #' Generates a scatterplot matrix from selected `variables` from datasets.+ #' Module is designed to explore the distribution of a single variable within a given dataset. |
|||
| 4 |
- #' Each plot within the matrix represents the relationship between two variables,+ #' It offers several tools, such as histograms, Q-Q plots, and various statistical tests to |
|||
| 5 |
- #' providing the overview of correlations and distributions across selected data.+ #' visually and statistically analyze the variable's distribution. |
|||
| 7 |
- #' @note For more examples, please see the vignette "Using scatterplot matrix" via+ #' @inheritParams teal::module |
|||
| 8 |
- #' `vignette("using-scatterplot-matrix", package = "teal.modules.general")`.
+ #' @inheritParams teal.widgets::standard_layout |
|||
| 9 |
- #'+ #' @inheritParams shared_params |
|||
| 10 |
- #' @inheritParams teal::module+ #' |
|||
| 11 |
- #' @inheritParams tm_g_scatterplot+ #' @param dist_var (`data_extract_spec` or `list` of multiple `data_extract_spec`) |
|||
| 12 |
- #' @inheritParams shared_params+ #' Variable(s) for which the distribution will be analyzed. |
|||
| 13 |
- #'+ #' @param strata_var (`data_extract_spec` or `list` of multiple `data_extract_spec`) |
|||
| 14 |
- #' @param variables (`data_extract_spec` or `list` of multiple `data_extract_spec`)+ #' Categorical variable used to split the distribution analysis. |
|||
| 15 |
- #' Specifies plotting variables from an incoming dataset with filtering and selecting. In case of+ #' @param group_var (`data_extract_spec` or `list` of multiple `data_extract_spec`) |
|||
| 16 |
- #' `data_extract_spec` use `select_spec(..., ordered = TRUE)` if plot elements should be+ #' Variable used for faceting plot into multiple panels. |
|||
| 17 |
- #' rendered according to selection order.+ #' @param freq (`logical`) optional, whether to display frequency (`TRUE`) or density (`FALSE`). |
|||
| 18 |
- #' @param decorators `r roxygen_decorators_param("tm_g_scatterplotmatrix")`
+ #' Defaults to density (`FALSE`). |
|||
| 19 |
- #'+ #' @param bins (`integer(1)` or `integer(3)`) optional, specifies the number of bins for the histogram. |
|||
| 20 |
- #' @inherit shared_params return+ #' - When the length of `bins` is one: The histogram bins will have a fixed size based on the `bins` provided. |
|||
| 21 |
- #'+ #' - When the length of `bins` is three: The histogram bins are dynamically adjusted based on vector of `value`, `min`, |
|||
| 22 |
- #' @section Decorating `tm_g_scatterplotmatrix`:+ #' and `max`. |
|||
| 23 |
- #'+ #' Defaults to `c(30L, 1L, 100L)`. |
|||
| 24 |
- #' This module generates the following objects, which can be modified in place using decorators:+ #' |
|||
| 25 |
- #' - `plot` (`trellis` - output of `lattice::splom`)+ #' @param ggplot2_args `r roxygen_ggplot2_args_param("Histogram", "QQplot")`
|
|||
| 26 |
- #'+ #' @param decorators `r roxygen_decorators_param("tm_g_distribution")`
|
|||
| 27 |
- #' For additional details and examples of decorators, refer to the vignette+ #' |
|||
| 28 |
- #' `vignette("decorate-modules-output", package = "teal")` or the [`teal::teal_transform_module()`] documentation.
+ #' @inherit shared_params return |
|||
| 30 |
- #' @examplesShinylive+ #' @section Decorating `tm_g_distribution`: |
|||
| 31 |
- #' library(teal.modules.general)+ #' |
|||
| 32 |
- #' interactive <- function() TRUE+ #' This module generates the following objects, which can be modified in place using decorators:: |
|||
| 33 |
- #' {{ next_example }}
+ #' - `histogram_plot` (`ggplot2`) |
|||
| 34 |
- #' @examplesIf require("lattice", quietly = TRUE)
+ #' - `qq_plot` (`data.frame`) |
|||
| 35 |
- #' # general data example+ #' - `summary_table` (`data.frame`) |
|||
| 36 |
- #' data <- teal_data()+ #' - `test_table` (`data.frame`) |
|||
| 37 |
- #' data <- within(data, {
+ #' |
|||
| 38 |
- #' countries <- data.frame(+ #' Decorators can be applied to all outputs or only to specific objects using a |
|||
| 39 |
- #' id = c("DE", "FR", "IT", "ES", "PT", "GR", "NL", "BE", "LU", "AT"),
+ #' named list of `teal_transform_module` objects. |
|||
| 40 |
- #' government = factor(+ #' The `"default"` name is reserved for decorators that are applied to all outputs. |
|||
| 41 |
- #' c(2, 2, 2, 1, 2, 2, 1, 1, 1, 2),+ #' See code snippet below: |
|||
| 42 |
- #' labels = c("Monarchy", "Republic")
+ #' |
|||
| 43 |
- #' ),+ #' ``` |
|||
| 44 |
- #' language_family = factor(+ #' tm_g_distribution( |
|||
| 45 |
- #' c(1, 3, 3, 3, 3, 2, 1, 1, 3, 1),+ #' ..., # arguments for module |
|||
| 46 |
- #' labels = c("Germanic", "Hellenic", "Romance")
+ #' decorators = list( |
|||
| 47 |
- #' ),+ #' default = list(teal_transform_module(...)), # applied to all outputs |
|||
| 48 |
- #' population = c(83, 67, 60, 47, 10, 11, 17, 11, 0.6, 9),+ #' histogram_plot = list(teal_transform_module(...)), # applied only to `histogram_plot` output |
|||
| 49 |
- #' area = c(357, 551, 301, 505, 92, 132, 41, 30, 2.6, 83),+ #' qq_plot = list(teal_transform_module(...)) # applied only to `qq_plot` output |
|||
| 50 |
- #' gdp = c(3.4, 2.7, 2.1, 1.4, 0.3, 0.2, 0.7, 0.5, 0.1, 0.4),+ #' summary_table = list(teal_transform_module(...)) # applied only to `summary_table` output |
|||
| 51 |
- #' debt = c(2.1, 2.3, 2.4, 2.6, 2.3, 2.4, 2.3, 2.4, 2.3, 2.4)+ #' test_table = list(teal_transform_module(...)) # applied only to `test_table` output |
|||
| 52 |
- #' )+ #' ) |
|||
| 53 |
- #' sales <- data.frame(+ #' ) |
|||
| 54 |
- #' id = 1:50,+ #' ``` |
|||
| 55 |
- #' country_id = sample(+ #' |
|||
| 56 |
- #' c("DE", "FR", "IT", "ES", "PT", "GR", "NL", "BE", "LU", "AT"),
+ #' For additional details and examples of decorators, refer to the vignette |
|||
| 57 |
- #' size = 50,+ #' `vignette("decorate-modules-output", package = "teal")` or the [`teal::teal_transform_module()`] documentation.
|
|||
| 58 |
- #' replace = TRUE+ #' |
|||
| 59 |
- #' ),+ #' @examplesShinylive |
|||
| 60 |
- #' year = sort(sample(2010:2020, 50, replace = TRUE)),+ #' library(teal.modules.general) |
|||
| 61 |
- #' venue = sample(c("small", "medium", "large", "online"), 50, replace = TRUE),
+ #' interactive <- function() TRUE |
|||
| 62 |
- #' cancelled = sample(c(TRUE, FALSE), 50, replace = TRUE),+ #' {{ next_example }}
|
|||
| 63 |
- #' quantity = rnorm(50, 100, 20),+ # nolint start: line_length_linter. |
|||
| 64 |
- #' costs = rnorm(50, 80, 20),+ #' @examplesIf require("ggpmisc", quietly = TRUE) && require("ggpp", quietly = TRUE) && require("goftest", quietly = TRUE) && require("MASS", quietly = TRUE) && require("broom", quietly = TRUE)
|
|||
| 65 |
- #' profit = rnorm(50, 20, 10)+ # nolint end: line_length_linter. |
|||
| 66 |
- #' )+ #' # general data example |
|||
| 67 |
- #' })+ #' data <- teal_data() |
|||
| 68 |
- #' join_keys(data) <- join_keys(+ #' data <- within(data, {
|
|||
| 69 |
- #' join_key("countries", "countries", "id"),
+ #' iris <- iris |
|||
| 70 |
- #' join_key("sales", "sales", "id"),
+ #' }) |
|||
| 71 |
- #' join_key("countries", "sales", c("id" = "country_id"))
+ #' |
|||
| 72 |
- #' )+ #' app <- init( |
|||
| 73 |
- #'+ #' data = data, |
|||
| 74 |
- #' app <- init(+ #' modules = list( |
|||
| 75 |
- #' data = data,+ #' tm_g_distribution( |
|||
| 76 |
- #' modules = modules(+ #' dist_var = data_extract_spec( |
|||
| 77 |
- #' tm_g_scatterplotmatrix(+ #' dataname = "iris", |
|||
| 78 |
- #' label = "Scatterplot matrix",+ #' select = select_spec(variable_choices("iris"), "Petal.Length")
|
|||
| 79 |
- #' variables = list(+ #' ) |
|||
| 80 |
- #' data_extract_spec(+ #' ) |
|||
| 81 |
- #' dataname = "countries",+ #' ) |
|||
| 82 |
- #' select = select_spec(+ #' ) |
|||
| 83 |
- #' label = "Select variables:",+ #' if (interactive()) {
|
|||
| 84 |
- #' choices = variable_choices(data[["countries"]]),+ #' shinyApp(app$ui, app$server) |
|||
| 85 |
- #' selected = c("area", "gdp", "debt"),
+ #' } |
|||
| 86 |
- #' multiple = TRUE,+ #' |
|||
| 87 |
- #' ordered = TRUE,+ #' @examplesShinylive |
|||
| 88 |
- #' fixed = FALSE+ #' library(teal.modules.general) |
|||
| 89 |
- #' )+ #' interactive <- function() TRUE |
|||
| 90 |
- #' ),+ #' {{ next_example }}
|
|||
| 91 |
- #' data_extract_spec(+ # nolint start: line_length_linter. |
|||
| 92 |
- #' dataname = "sales",+ #' @examplesIf require("ggpmisc", quietly = TRUE) && require("ggpp", quietly = TRUE) && require("goftest", quietly = TRUE) && require("MASS", quietly = TRUE) && require("broom", quietly = TRUE)
|
|||
| 93 |
- #' filter = filter_spec(+ # nolint end: line_length_linter. |
|||
| 94 |
- #' label = "Select variable:",+ #' # CDISC data example |
|||
| 95 |
- #' vars = "country_id",+ #' data <- teal_data() |
|||
| 96 |
- #' choices = value_choices(data[["sales"]], "country_id"),+ #' data <- within(data, {
|
|||
| 97 |
- #' selected = c("DE", "FR", "IT", "ES", "PT", "GR", "NL", "BE", "LU", "AT"),
+ #' ADSL <- teal.data::rADSL |
|||
| 98 |
- #' multiple = TRUE+ #' }) |
|||
| 99 |
- #' ),+ #' join_keys(data) <- default_cdisc_join_keys[names(data)] |
|||
| 100 |
- #' select = select_spec(+ #' |
|||
| 101 |
- #' label = "Select variables:",+ #' vars1 <- choices_selected( |
|||
| 102 |
- #' choices = variable_choices(data[["sales"]], c("quantity", "costs", "profit")),
+ #' variable_choices(data[["ADSL"]], c("ARM", "COUNTRY", "SEX")),
|
|||
| 103 |
- #' selected = c("quantity", "costs", "profit"),
+ #' selected = NULL |
|||
| 104 |
- #' multiple = TRUE,+ #' ) |
|||
| 105 |
- #' ordered = TRUE,+ #' |
|||
| 106 |
- #' fixed = FALSE+ #' app <- init( |
|||
| 107 |
- #' )+ #' data = data, |
|||
| 108 |
- #' )+ #' modules = modules( |
|||
| 109 |
- #' )+ #' tm_g_distribution( |
|||
| 110 |
- #' )+ #' dist_var = data_extract_spec( |
|||
| 111 |
- #' )+ #' dataname = "ADSL", |
|||
| 112 |
- #' )+ #' select = select_spec( |
|||
| 113 |
- #' if (interactive()) {
+ #' choices = variable_choices(data[["ADSL"]], c("AGE", "BMRKR1")),
|
|||
| 114 |
- #' shinyApp(app$ui, app$server)+ #' selected = "BMRKR1", |
|||
| 115 |
- #' }+ #' multiple = FALSE, |
|||
| 116 |
- #'+ #' fixed = FALSE |
|||
| 117 |
- #' @examplesShinylive+ #' ) |
|||
| 118 |
- #' library(teal.modules.general)+ #' ), |
|||
| 119 |
- #' interactive <- function() TRUE+ #' strata_var = data_extract_spec( |
|||
| 120 |
- #' {{ next_example }}
+ #' dataname = "ADSL", |
|||
| 121 |
- #' @examplesIf require("lattice", quietly = TRUE)
+ #' filter = filter_spec( |
|||
| 122 |
- #' # CDISC data example+ #' vars = vars1, |
|||
| 123 |
- #' data <- teal_data()+ #' multiple = TRUE |
|||
| 124 |
- #' data <- within(data, {
+ #' ) |
|||
| 125 |
- #' ADSL <- rADSL+ #' ), |
|||
| 126 |
- #' ADRS <- rADRS+ #' group_var = data_extract_spec( |
|||
| 127 |
- #' })+ #' dataname = "ADSL", |
|||
| 128 |
- #' join_keys(data) <- default_cdisc_join_keys[names(data)]+ #' filter = filter_spec( |
|||
| 129 |
- #'+ #' vars = vars1, |
|||
| 130 |
- #' app <- init(+ #' multiple = TRUE |
|||
| 131 |
- #' data = data,+ #' ) |
|||
| 132 |
- #' modules = modules(+ #' ) |
|||
| 133 |
- #' tm_g_scatterplotmatrix(+ #' ) |
|||
| 134 |
- #' label = "Scatterplot matrix",+ #' ) |
|||
| 135 |
- #' variables = list(+ #' ) |
|||
| 136 |
- #' data_extract_spec(+ #' if (interactive()) {
|
|||
| 137 |
- #' dataname = "ADSL",+ #' shinyApp(app$ui, app$server) |
|||
| 138 |
- #' select = select_spec(+ #' } |
|||
| 139 |
- #' label = "Select variables:",+ #' |
|||
| 140 |
- #' choices = variable_choices(data[["ADSL"]]),+ #' @export |
|||
| 141 |
- #' selected = c("AGE", "RACE", "SEX"),
+ #' |
|||
| 142 |
- #' multiple = TRUE,+ tm_g_distribution <- function(label = "Distribution Module", |
|||
| 143 |
- #' ordered = TRUE,+ dist_var, |
|||
| 144 |
- #' fixed = FALSE+ strata_var = NULL, |
|||
| 145 |
- #' )+ group_var = NULL, |
|||
| 146 |
- #' ),+ freq = FALSE, |
|||
| 147 |
- #' data_extract_spec(+ ggtheme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void"),
|
|||
| 148 |
- #' dataname = "ADRS",+ ggplot2_args = teal.widgets::ggplot2_args(), |
|||
| 149 |
- #' filter = filter_spec(+ bins = c(30L, 1L, 100L), |
|||
| 150 |
- #' label = "Select endpoints:",+ plot_height = c(600, 200, 2000), |
|||
| 151 |
- #' vars = c("PARAMCD", "AVISIT"),
+ plot_width = NULL, |
|||
| 152 |
- #' choices = value_choices(data[["ADRS"]], c("PARAMCD", "AVISIT"), c("PARAM", "AVISIT")),
+ pre_output = NULL, |
|||
| 153 |
- #' selected = "INVET - END OF INDUCTION",+ post_output = NULL, |
|||
| 154 |
- #' multiple = TRUE+ decorators = NULL) {
|
|||
| 155 | -+ | ! |
- #' ),+ message("Initializing tm_g_distribution")
|
|
| 156 |
- #' select = select_spec(+ |
|||
| 157 |
- #' label = "Select variables:",+ # Requires Suggested packages |
|||
| 158 | -+ | ! |
- #' choices = variable_choices(data[["ADRS"]]),+ extra_packages <- c("ggpmisc", "ggpp", "goftest", "MASS", "broom")
|
|
| 159 | -+ | ! |
- #' selected = c("AGE", "AVAL", "ADY"),
+ missing_packages <- Filter(function(x) !requireNamespace(x, quietly = TRUE), extra_packages) |
|
| 160 | -+ | ! |
- #' multiple = TRUE,+ if (length(missing_packages) > 0L) {
|
|
| 161 | -+ | ! |
- #' ordered = TRUE,+ stop(sprintf( |
|
| 162 | -+ | ! |
- #' fixed = FALSE+ "Cannot load package(s): %s.\nInstall or restart your session.", |
|
| 163 | -+ | ! |
- #' )+ toString(missing_packages) |
|
| 164 |
- #' )+ )) |
|||
| 165 |
- #' )+ } |
|||
| 166 |
- #' )+ |
|||
| 167 |
- #' )+ # Normalize the parameters |
|||
| 168 | -+ | ! |
- #' )+ if (inherits(dist_var, "data_extract_spec")) dist_var <- list(dist_var) |
|
| 169 | -+ | ! |
- #' if (interactive()) {
+ if (inherits(strata_var, "data_extract_spec")) strata_var <- list(strata_var) |
|
| 170 | -+ | ! |
- #' shinyApp(app$ui, app$server)+ if (inherits(group_var, "data_extract_spec")) group_var <- list(group_var) |
|
| 171 | -+ | ! |
- #' }+ if (inherits(ggplot2_args, "ggplot2_args")) ggplot2_args <- list(default = ggplot2_args) |
|
| 172 |
- #'+ |
|||
| 173 |
- #' @export+ # Start of assertions |
|||
| 174 | -+ | ! |
- #'+ checkmate::assert_string(label) |
|
| 175 |
- tm_g_scatterplotmatrix <- function(label = "Scatterplot Matrix",+ |
|||
| 176 | -+ | ! |
- variables,+ checkmate::assert_list(dist_var, "data_extract_spec") |
|
| 177 | -+ | ! |
- plot_height = c(600, 200, 2000),+ checkmate::assert_false(dist_var[[1L]]$select$multiple) |
|
| 178 |
- plot_width = NULL,+ |
|||
| 179 | -+ | ! |
- pre_output = NULL,+ checkmate::assert_list(strata_var, types = "data_extract_spec", null.ok = TRUE) |
|
| 180 | -+ | ! |
- post_output = NULL,+ checkmate::assert_list(group_var, types = "data_extract_spec", null.ok = TRUE) |
|
| 181 | -+ | ! |
- decorators = NULL) {
+ checkmate::assert_flag(freq) |
|
| 182 | ! |
- message("Initializing tm_g_scatterplotmatrix")
+ ggtheme <- match.arg(ggtheme) |
||
| 184 | -+ | ! |
- # Requires Suggested packages+ plot_choices <- c("Histogram", "QQplot")
|
|
| 185 | ! |
- if (!requireNamespace("lattice", quietly = TRUE)) {
+ checkmate::assert_list(ggplot2_args, types = "ggplot2_args") |
||
| 186 | ! |
- stop("Cannot load lattice - please install the package or restart your session.")
+ checkmate::assert_subset(names(ggplot2_args), c("default", plot_choices))
|
||
| 187 | - |
- }- |
- ||
| 188 | -||||
| 189 | -+ | |||
| 188 | +! |
- # Normalize the parameters+ if (length(bins) == 1) {
|
||
| 190 | +189 | ! |
- if (inherits(variables, "data_extract_spec")) variables <- list(variables)+ checkmate::assert_numeric(bins, any.missing = FALSE, lower = 1) |
|
| 191 | +190 |
-
+ } else {
|
||
| 192 | -+ | |||
| 191 | +! |
- # Start of assertions+ checkmate::assert_numeric(bins, len = 3, any.missing = FALSE, lower = 1) |
||
| 193 | +192 | ! |
- checkmate::assert_string(label)+ checkmate::assert_numeric(bins[1], lower = bins[2], upper = bins[3], .var.name = "bins") |
|
| 194 | -! | +|||
| 193 | +
- checkmate::assert_list(variables, types = "data_extract_spec")+ } |
|||
| 195 | +194 | |||
| 196 | +195 | ! |
checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE) |
|
| 197 | +196 | ! |
checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height") |
|
| 198 | +197 | ! |
checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE) |
|
| 199 | +198 | ! |
checkmate::assert_numeric( |
|
| 200 | +199 | ! |
plot_width[1], |
|
| 201 | +200 | ! |
lower = plot_width[2], upper = plot_width[3], null.ok = TRUE, .var.name = "plot_width" |
|
| 202 | +201 |
) |
||
| 203 | +202 | |||
| 204 | +203 | ! |
checkmate::assert_multi_class(pre_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
|
|
| 205 | +204 | ! |
checkmate::assert_multi_class(post_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
|
|
| 206 | +205 | |||
| 206 | +! | +
+ available_decorators <- c("histogram_plot", "qq_plot", "test_table", "summary_table")
+ |
+ ||
| 207 | ! | @@ -1568,315 +1568,315 @@208 | ! |
- assert_decorators(decorators, null.ok = TRUE, "plot")+ assert_decorators(decorators, null.ok = TRUE, names = available_decorators) |
| 209 |
- # End of assertions+ |
|||
| 210 |
-
+ # End of assertions |
|||
| 211 | + | + + | +||
| 212 | +
# Make UI args |
|||
| 212 | +213 | ! |
args <- as.list(environment()) |
|
| 213 | +214 | |||
| 214 | -! | -
- ans <- module(- |
- ||
| 215 | ! |
- label = label,+ data_extract_list <- list( |
||
| 216 | ! |
- server = srv_g_scatterplotmatrix,+ dist_var = dist_var, |
||
| 217 | ! |
- ui = ui_g_scatterplotmatrix,+ strata_var = strata_var, |
||
| 218 | ! |
- ui_args = args,+ group_var = group_var |
||
| 219 | -! | +
- server_args = list(+ ) |
||
| 220 | -! | +
- variables = variables,+ |
||
| 221 | ! |
- plot_height = plot_height,+ ans <- module( |
||
| 222 | ! |
- plot_width = plot_width,+ label = label, |
||
| 223 | ! |
- decorators = decorators+ server = srv_distribution, |
||
| 224 | -+ | ! |
- ),+ server_args = c( |
|
| 225 | ! |
- datanames = teal.transform::get_extract_datanames(variables)+ data_extract_list, |
||
| 226 | -+ | ! |
- )+ list( |
|
| 227 | ! |
- attr(ans, "teal_bookmarkable") <- TRUE+ plot_height = plot_height, |
||
| 228 | ! |
- ans+ plot_width = plot_width, |
||
| 229 | -+ | ! |
- }+ ggplot2_args = ggplot2_args, |
|
| 230 | -+ | ! |
-
+ decorators = decorators |
|
| 231 |
- # UI function for the scatterplot matrix module+ ) |
|||
| 232 |
- ui_g_scatterplotmatrix <- function(id, ...) {
+ ), |
|||
| 233 | ! |
- args <- list(...)+ ui = ui_distribution, |
||
| 234 | ! |
- is_single_dataset_value <- teal.transform::is_single_dataset(args$variables)+ ui_args = args, |
||
| 235 | ! |
- ns <- NS(id)+ datanames = teal.transform::get_extract_datanames(data_extract_list) |
||
| 236 | -! | +
- teal.widgets::standard_layout(+ ) |
||
| 237 | ! |
- output = teal.widgets::white_small_well(+ attr(ans, "teal_bookmarkable") <- TRUE |
||
| 238 | ! |
- textOutput(ns("message")),
+ ans |
||
| 239 | -! | +
- tags$br(),+ } |
||
| 240 | -! | +
- teal.widgets::plot_with_settings_ui(id = ns("myplot"))
+
|
||
| 241 |
- ),+ # UI function for the distribution module |
|||
| 242 | -! | +
- encoding = tags$div(+ ui_distribution <- function(id, ...) {
|
||
| 243 | -+ | ! |
- ### Reporter+ args <- list(...) |
|
| 244 | ! |
- teal.reporter::simple_reporter_ui(ns("simple_reporter")),
+ ns <- NS(id) |
||
| 245 | -+ | ! |
- ###+ is_single_dataset_value <- teal.transform::is_single_dataset(args$dist_var, args$strata_var, args$group_var) |
|
| 246 | -! | +
- tags$label("Encodings", class = "text-primary"),
+
|
||
| 247 | ! |
- teal.transform::datanames_input(args$variables),+ teal.widgets::standard_layout( |
||
| 248 | ! |
- teal.transform::data_extract_ui(+ output = teal.widgets::white_small_well( |
||
| 249 | ! |
- id = ns("variables"),
+ tabsetPanel( |
||
| 250 | ! |
- label = "Variables",+ id = ns("tabs"),
|
||
| 251 | ! |
- data_extract_spec = args$variables,+ tabPanel("Histogram", teal.widgets::plot_with_settings_ui(id = ns("hist_plot"))),
|
||
| 252 | ! |
- is_single_dataset = is_single_dataset_value+ tabPanel("QQplot", teal.widgets::plot_with_settings_ui(id = ns("qq_plot")))
|
||
| 254 | ! |
- tags$hr(),+ tags$h3("Statistics Table"),
|
||
| 255 | ! |
- ui_decorate_teal_data(ns("decorator"), decorators = select_decorators(args$decorators, "plot")),
+ DT::dataTableOutput(ns("summary_table")),
|
||
| 256 | ! |
- teal.widgets::panel_group(+ tags$h3("Tests"),
|
||
| 257 | ! |
- teal.widgets::panel_item(+ DT::dataTableOutput(ns("t_stats"))
|
||
| 258 | -! | +
- title = "Plot settings",+ ), |
||
| 259 | ! |
- sliderInput(+ encoding = tags$div( |
||
| 260 | -! | +
- ns("alpha"), "Opacity:",
+ ### Reporter |
||
| 261 | ! |
- min = 0, max = 1,+ teal.reporter::simple_reporter_ui(ns("simple_reporter")),
|
||
| 262 | -! | +
- step = .05, value = .5, ticks = FALSE+ ### |
||
| 263 | -+ | ! |
- ),+ tags$label("Encodings", class = "text-primary"),
|
|
| 264 | ! |
- sliderInput(+ teal.transform::datanames_input(args[c("dist_var", "strata_var")]),
|
||
| 265 | ! |
- ns("cex"), "Points size:",
+ teal.transform::data_extract_ui( |
||
| 266 | ! |
- min = 0.2, max = 3,+ id = ns("dist_i"),
|
||
| 267 | ! |
- step = .05, value = .65, ticks = FALSE+ label = "Variable", |
||
| 268 | -+ | ! |
- ),+ data_extract_spec = args$dist_var, |
|
| 269 | ! |
- checkboxInput(ns("cor"), "Add Correlation", value = FALSE),
+ is_single_dataset = is_single_dataset_value |
||
| 270 | -! | +
- radioButtons(+ ), |
||
| 271 | ! |
- ns("cor_method"), "Select Correlation Method",
+ if (!is.null(args$group_var)) {
|
||
| 272 | ! |
- choiceNames = c("Pearson", "Kendall", "Spearman"),
+ tagList( |
||
| 273 | ! |
- choiceValues = c("pearson", "kendall", "spearman"),
+ teal.transform::data_extract_ui( |
||
| 274 | ! |
- inline = TRUE+ id = ns("group_i"),
|
||
| 275 | -+ | ! |
- ),+ label = "Group by", |
|
| 276 | ! |
- checkboxInput(ns("cor_na_omit"), "Omit Missing Values", value = TRUE)
+ data_extract_spec = args$group_var, |
||
| 277 | -+ | ! |
- )+ is_single_dataset = is_single_dataset_value |
|
| 278 |
- )+ ), |
|||
| 279 | -+ | ! |
- ),+ uiOutput(ns("scales_types_ui"))
|
|
| 280 | -! | +
- forms = tagList(+ ) |
||
| 281 | -! | +
- teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code")
+ }, |
||
| 282 | -+ | ! |
- ),+ if (!is.null(args$strata_var)) {
|
|
| 283 | ! |
- pre_output = args$pre_output,+ teal.transform::data_extract_ui( |
||
| 284 | ! |
- post_output = args$post_output+ id = ns("strata_i"),
|
||
| 285 | -+ | ! |
- )+ label = "Stratify by", |
|
| 286 | -+ | ! |
- }+ data_extract_spec = args$strata_var, |
|
| 287 | -+ | ! |
-
+ is_single_dataset = is_single_dataset_value |
|
| 288 |
- # Server function for the scatterplot matrix module+ ) |
|||
| 289 |
- srv_g_scatterplotmatrix <- function(id,+ }, |
|||
| 290 | -+ | ! |
- data,+ teal.widgets::panel_group( |
|
| 291 | -+ | ! |
- reporter,+ conditionalPanel( |
|
| 292 | -+ | ! |
- filter_panel_api,+ condition = paste0("input['", ns("tabs"), "'] == 'Histogram'"),
|
|
| 293 | -+ | ! |
- variables,+ teal.widgets::panel_item( |
|
| 294 | -+ | ! |
- plot_height,+ "Histogram", |
|
| 295 | -+ | ! |
- plot_width,+ teal.widgets::optionalSliderInputValMinMax(ns("bins"), "Bins", args$bins, ticks = FALSE, step = 1),
|
|
| 296 | -+ | ! |
- decorators) {
+ shinyWidgets::prettyRadioButtons( |
|
| 297 | ! |
- with_reporter <- !missing(reporter) && inherits(reporter, "Reporter")+ ns("main_type"),
|
||
| 298 | ! |
- with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI")+ label = "Plot Type:", |
||
| 299 | ! |
- checkmate::assert_class(data, "reactive")+ choices = c("Density", "Frequency"),
|
||
| 300 | ! |
- checkmate::assert_class(isolate(data()), "teal_data")+ selected = if (!args$freq) "Density" else "Frequency", |
||
| 301 | ! |
- moduleServer(id, function(input, output, session) {
+ bigger = FALSE, |
||
| 302 | ! |
- teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.general")+ inline = TRUE |
||
| 303 |
-
+ ), |
|||
| 304 | ! |
- selector_list <- teal.transform::data_extract_multiple_srv(+ checkboxInput(ns("add_dens"), label = "Overlay Density", value = TRUE),
|
||
| 305 | ! |
- data_extract = list(variables = variables),+ ui_decorate_teal_data( |
||
| 306 | ! |
- datasets = data,+ ns("d_density"),
|
||
| 307 | ! |
- select_validation_rule = list(+ decorators = select_decorators(args$decorators, "histogram_plot") |
||
| 308 | -! | +
- variables = ~ if (length(.) <= 1) "Please select at least 2 columns."+ ), |
||
| 309 | -+ | ! |
- )+ collapsed = FALSE |
|
| 310 |
- )+ ) |
|||
| 311 |
-
+ ), |
|||
| 312 | ! |
- iv_r <- reactive({
+ conditionalPanel( |
||
| 313 | ! |
- iv <- shinyvalidate::InputValidator$new()+ condition = paste0("input['", ns("tabs"), "'] == 'QQplot'"),
|
||
| 314 | ! |
- teal.transform::compose_and_enable_validators(iv, selector_list)+ teal.widgets::panel_item( |
||
| 315 | -+ | ! |
- })+ "QQ Plot", |
|
| 316 | -+ | ! |
-
+ checkboxInput(ns("qq_line"), label = "Add diagonal line(s)", TRUE),
|
|
| 317 | ! |
- anl_merged_input <- teal.transform::merge_expression_srv(+ ui_decorate_teal_data( |
||
| 318 | ! |
- datasets = data,+ ns("d_qq"),
|
||
| 319 | ! |
- selector_list = selector_list+ decorators = select_decorators(args$decorators, "qq_plot") |
||
| 320 |
- )+ ), |
|||
| 321 | -+ | ! |
-
+ collapsed = FALSE |
|
| 322 | -! | +
- anl_merged_q <- reactive({
+ ) |
||
| 323 | -! | +
- req(anl_merged_input())+ ), |
||
| 324 | ! |
- data() %>%+ ui_decorate_teal_data( |
||
| 325 | ! |
- teal.code::eval_code(as.expression(anl_merged_input()$expr))+ ns("d_summary"),
|
||
| 326 | -+ | ! |
- })+ decorators = select_decorators(args$decorators, "summary_table") |
|
| 327 |
-
+ ), |
|||
| 328 | ! |
- merged <- list(+ ui_decorate_teal_data( |
||
| 329 | ! |
- anl_input_r = anl_merged_input,+ ns("d_test"),
|
||
| 330 | ! |
- anl_q_r = anl_merged_q+ decorators = select_decorators(args$decorators, "test_table") |
||
| 331 |
- )+ ), |
|||
| 332 | -+ | ! |
-
+ conditionalPanel( |
|
| 333 | -+ | ! |
- # plot+ condition = paste0("input['", ns("main_type"), "'] == 'Density'"),
|
|
| 334 | ! |
- output_q <- reactive({
+ teal.widgets::panel_item( |
||
| 335 | ! |
- teal::validate_inputs(iv_r())+ "Theoretical Distribution", |
||
| 336 | -+ | ! |
-
+ teal.widgets::optionalSelectInput( |
|
| 337 | ! |
- qenv <- merged$anl_q_r()+ ns("t_dist"),
|
||
| 338 | ! |
- ANL <- qenv[["ANL"]]+ tags$div( |
||
| 339 | -+ | ! |
-
+ class = "teal-tooltip", |
|
| 340 | ! |
- cols_names <- merged$anl_input_r()$columns_source$variables+ tagList( |
||
| 341 | ! |
- alpha <- input$alpha+ "Distribution:", |
||
| 342 | ! |
- cex <- input$cex+ icon("circle-info"),
|
||
| 343 | ! |
- add_cor <- input$cor+ tags$span( |
||
| 344 | ! |
- cor_method <- input$cor_method+ class = "tooltiptext", |
||
| 345 | ! |
- cor_na_omit <- input$cor_na_omit+ "Default parameters are optimized with MASS::fitdistr function." |
||
| 346 |
-
+ ) |
|||
| 347 | -! | +
- cor_na_action <- if (isTruthy(cor_na_omit)) {
+ ) |
||
| 348 | -! | +
- "na.omit"+ ), |
||
| 349 | -+ | ! |
- } else {
+ choices = c("normal", "lognormal", "gamma", "unif"),
|
|
| 350 | ! |
- "na.fail"+ selected = NULL, |
||
| 351 | -+ | ! |
- }+ multiple = FALSE |
|
| 352 |
-
+ ), |
|||
| 353 | ! |
- teal::validate_has_data(ANL, 10)+ numericInput(ns("dist_param1"), label = "param1", value = NULL),
|
||
| 354 | ! |
- teal::validate_has_data(ANL[, cols_names, drop = FALSE], 10, complete = TRUE, allow_inf = FALSE)+ numericInput(ns("dist_param2"), label = "param2", value = NULL),
|
||
| 355 | -+ | ! |
-
+ tags$span(actionButton(ns("params_reset"), "Default params")),
|
|
| 356 | -+ | ! |
- # get labels and proper variable names+ collapsed = FALSE |
|
| 357 | -! | +
- varnames <- varname_w_label(cols_names, ANL, wrap_width = 20)+ ) |
||
| 358 |
-
+ ) |
|||
| 359 |
- # check character columns. If any, then those are converted to factors+ ), |
|||
| 360 | ! |
- check_char <- vapply(ANL[, cols_names], is.character, logical(1))+ teal.widgets::panel_item( |
||
| 361 | ! |
- if (any(check_char)) {
+ "Tests", |
||
| 362 | ! |
- qenv <- teal.code::eval_code(+ teal.widgets::optionalSelectInput( |
||
| 363 | ! |
- qenv,+ ns("dist_tests"),
|
||
| 364 | ! |
- substitute(+ "Tests:", |
||
| 365 | ! |
- expr = ANL <- ANL[, cols_names] %>%+ choices = c( |
||
| 366 | ! |
- dplyr::mutate_if(is.character, as.factor) %>%+ "Shapiro-Wilk", |
||
| 367 | ! |
- droplevels(),+ if (!is.null(args$strata_var)) "t-test (two-samples, not paired)", |
||
| 368 | ! |
- env = list(cols_names = cols_names)+ if (!is.null(args$strata_var)) "one-way ANOVA", |
||
| 369 | -+ | ! |
- )+ if (!is.null(args$strata_var)) "Fligner-Killeen", |
|
| 370 | -+ | ! |
- )+ if (!is.null(args$strata_var)) "F-test", |
|
| 371 | -+ | ! |
- } else {
+ "Kolmogorov-Smirnov (one-sample)", |
|
| 372 | ! |
- qenv <- teal.code::eval_code(+ "Anderson-Darling (one-sample)", |
||
| 373 | ! |
- qenv,+ "Cramer-von Mises (one-sample)", |
||
| 374 | ! |
- substitute(+ if (!is.null(args$strata_var)) "Kolmogorov-Smirnov (two-samples)" |
||
| 375 | -! | +
- expr = ANL <- ANL[, cols_names] %>%+ ), |
||
| 376 | ! |
- droplevels(),+ selected = NULL |
||
| 377 | -! | +
- env = list(cols_names = cols_names)+ ) |
||
| 378 |
- )+ ), |
|||
| 379 | -+ | ! |
- )+ teal.widgets::panel_item( |
|
| 380 | -+ | ! |
- }+ "Statistics Table", |
|
| 381 | -+ | ! |
-
+ sliderInput(ns("roundn"), "Round to n digits", min = 0, max = 10, value = 2)
|
|
| 382 |
-
+ ), |
|||
| 383 | -+ | ! |
- # create plot+ teal.widgets::panel_item( |
|
| 384 | ! |
- if (add_cor) {
+ title = "Plot settings", |
||
| 385 | ! |
- shinyjs::show("cor_method")
+ selectInput( |
||
| 386 | ! |
- shinyjs::show("cor_use")
+ inputId = ns("ggtheme"),
|
||
| 387 | ! |
- shinyjs::show("cor_na_omit")
+ label = "Theme (by ggplot):", |
||
| 388 | -+ | ! |
-
+ choices = ggplot_themes, |
|
| 389 | ! |
- qenv <- teal.code::eval_code(+ selected = args$ggtheme, |
||
| 390 | ! |
- qenv,+ multiple = FALSE |
||
| 391 | -! | +
- substitute(+ ) |
||
| 392 | -! | +
- expr = {
+ ) |
||
| 393 | -! | +
- plot <- lattice::splom(+ ), |
||
| 394 | ! |
- ANL,+ forms = tagList( |
||
| 395 | ! |
- varnames = varnames_value,+ teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code")
|
||
| 396 | -! | +
- panel = function(x, y, ...) {
+ ), |
||
| 397 | ! |
- lattice::panel.splom(x = x, y = y, ...)+ pre_output = args$pre_output, |
||
| 398 | ! |
- cpl <- lattice::current.panel.limits()+ post_output = args$post_output |
||
| 399 | -! | +
- lattice::panel.text(+ ) |
||
| 400 | -! | +
- mean(cpl$xlim),+ } |
||
| 401 | -! | +
- mean(cpl$ylim),+ |
||
| 402 | -! | +
- get_scatterplotmatrix_stats(+ # Server function for the distribution module |
||
| 403 | -! | +
- x,+ srv_distribution <- function(id, |
||
| 404 | -! | +
- y,+ data, |
||
| 405 | -! | +
- .f = stats::cor.test,+ reporter, |
||
| 406 | -! | +
- .f_args = list(method = cor_method, na.action = cor_na_action)+ filter_panel_api, |
||
| 407 |
- ),+ dist_var, |
|||
| 408 | -! | +
- alpha = 0.6,+ strata_var, |
||
| 409 | -! | +
- fontsize = 18,+ group_var, |
||
| 410 | -! | +
- fontface = "bold"+ plot_height, |
||
| 411 |
- )+ plot_width, |
|||
| 412 |
- },+ ggplot2_args, |
|||
| 413 | -! | +
- pch = 16,+ decorators) {
|
||
| 414 | ! |
- alpha = alpha_value,+ with_reporter <- !missing(reporter) && inherits(reporter, "Reporter") |
||
| 415 | ! |
- cex = cex_value+ with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI") |
||
| 416 | -+ | ! |
- )+ checkmate::assert_class(data, "reactive") |
|
| 417 | -+ | ! |
- },+ checkmate::assert_class(isolate(data()), "teal_data") |
|
| 418 | ! |
- env = list(+ moduleServer(id, function(input, output, session) {
|
||
| 419 | ! |
- varnames_value = varnames,+ teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.general") |
||
| 420 | -! | +
- cor_method = cor_method,+ |
||
| 421 | ! |
- cor_na_action = cor_na_action,+ setBookmarkExclude("params_reset")
|
||
| 422 | -! | +
- alpha_value = alpha,+ |
||
| 423 | ! |
- cex_value = cex+ ns <- session$ns |
||
| 424 |
- )+ |
|||
| 425 | -+ | ! |
- )+ rule_req <- function(value) {
|
|
| 426 | -+ | ! |
- )+ if (isTRUE(input$dist_tests %in% c( |
|
| 427 | -+ | ! |
- } else {
+ "Fligner-Killeen", |
|
| 428 | ! |
- shinyjs::hide("cor_method")
+ "t-test (two-samples, not paired)", |
||
| 429 | ! |
- shinyjs::hide("cor_use")
+ "F-test", |
||
| 430 | ! |
- shinyjs::hide("cor_na_omit")
+ "Kolmogorov-Smirnov (two-samples)", |
||
| 431 | ! |
- qenv <- teal.code::eval_code(+ "one-way ANOVA" |
||
| 432 | -! | +
- qenv,+ ))) {
|
||
| 433 | ! |
- substitute(+ if (!shinyvalidate::input_provided(value)) {
|
||
| 434 | ! |
- expr = {
+ "Please select stratify variable." |
||
| 435 | -! | +
- plot <- lattice::splom(+ } |
||
| 436 | -! | +
- ANL,+ } |
||
| 437 | -! | +
- varnames = varnames_value,+ } |
||
| 438 | ! |
- pch = 16,+ rule_dupl <- function(...) {
|
||
| 439 | ! |
- alpha = alpha_value,+ if (identical(input$dist_tests, "Fligner-Killeen")) {
|
||
| 440 | ! |
- cex = cex_value+ strata <- selector_list()$strata_i()$select |
||
| 441 | -+ | ! |
- )+ group <- selector_list()$group_i()$select |
|
| 442 | -+ | ! |
- },+ if (isTRUE(strata == group)) {
|
|
| 443 | ! |
- env = list(varnames_value = varnames, alpha_value = alpha, cex_value = cex)+ "Please select different variables for strata and group." |
||
| 444 |
- )+ } |
|||
| 445 |
- )+ } |
|||
| 446 |
- }+ } |
|||
| 447 | -! | +
- qenv+ |
||
| 448 | -+ | ! |
- })+ selector_list <- teal.transform::data_extract_multiple_srv( |
|
| 449 | -+ | ! |
-
+ data_extract = list( |
|
| 450 | ! |
- decorated_output_q <- srv_decorate_teal_data(+ dist_i = dist_var, |
||
| 451 | ! |
- id = "decorator",+ strata_i = strata_var, |
||
| 452 | ! |
- data = output_q,+ group_i = group_var |
||
| 453 | -! | +
- decorators = select_decorators(decorators, "plot"),+ ), |
||
| 454 | ! |
- expr = print(plot)+ data, |
||
| 455 | -+ | ! |
- )+ select_validation_rule = list( |
|
| 456 | -+ | ! |
-
+ dist_i = shinyvalidate::sv_required("Please select a variable")
|
|
| 457 | -! | +
- plot_r <- reactive(req(decorated_output_q())[["plot"]])+ ), |
||
| 458 | -+ | ! |
-
+ filter_validation_rule = list( |
|
| 459 | -+ | ! |
- # Insert the plot into a plot_with_settings module+ strata_i = shinyvalidate::compose_rules( |
|
| 460 | ! |
- pws <- teal.widgets::plot_with_settings_srv(+ rule_req, |
||
| 461 | ! |
- id = "myplot",+ rule_dupl |
||
| 462 | -! | +
- plot_r = plot_r,+ ), |
||
| 463 | ! |
- height = plot_height,+ group_i = rule_dupl |
||
| 464 | -! | +
- width = plot_width+ ) |
||
| 467 | -+ | ! |
- # show a message if conversion to factors took place+ iv_r <- reactive({
|
|
| 468 | ! |
- output$message <- renderText({
+ iv <- shinyvalidate::InputValidator$new() |
||
| 469 | ! |
- req(iv_r()$is_valid())+ teal.transform::compose_and_enable_validators(iv, selector_list, validator_names = "dist_i") |
||
| 470 | -! | +
- req(selector_list()$variables())+ }) |
||
| 471 | -! | +
- ANL <- merged$anl_q_r()[["ANL"]]+ |
||
| 472 | ! |
- cols_names <- unique(unname(do.call(c, merged$anl_input_r()$columns_source)))+ iv_r_dist <- reactive({
|
||
| 473 | ! |
- check_char <- vapply(ANL[, cols_names], is.character, logical(1))+ iv <- shinyvalidate::InputValidator$new() |
||
| 474 | ! |
- if (any(check_char)) {
+ teal.transform::compose_and_enable_validators( |
||
| 475 | ! |
- is_single <- sum(check_char) == 1+ iv, selector_list, |
||
| 476 | ! |
- paste(+ validator_names = c("strata_i", "group_i")
|
||
| 477 | -! | +
- "Character",+ ) |
||
| 478 | -! | +
- ifelse(is_single, "variable", "variables"),+ }) |
||
| 479 | ! |
- paste0("(", paste(cols_names[check_char], collapse = ", "), ")"),
+ rule_dist_1 <- function(value) {
|
||
| 480 | ! |
- ifelse(is_single, "was", "were"),+ if (!is.null(input$t_dist)) {
|
||
| 481 | ! |
- "converted to",+ switch(input$t_dist, |
||
| 482 | ! |
- ifelse(is_single, "factor.", "factors.")+ "normal" = if (!shinyvalidate::input_provided(value)) "mean is required", |
||
| 483 | -+ | ! |
- )+ "lognormal" = if (!shinyvalidate::input_provided(value)) "meanlog is required", |
|
| 484 | -+ | ! |
- } else {
+ "gamma" = {
|
|
| 485 | -+ | ! |
- ""+ if (!shinyvalidate::input_provided(value)) "shape is required" else if (value <= 0) "shape must be positive" |
|
| 486 |
- }+ }, |
|||
| 487 | -+ | ! |
- })+ "unif" = NULL |
|
| 488 |
-
+ ) |
|||
| 489 | -! | +
- teal.widgets::verbatim_popup_srv(+ } |
||
| 490 | -! | +
- id = "rcode",+ } |
||
| 491 | ! |
- verbatim_content = reactive(teal.code::get_code(req(decorated_output_q()))),+ rule_dist_2 <- function(value) {
|
||
| 492 | ! |
- title = "Show R Code for Scatterplotmatrix"+ if (!is.null(input$t_dist)) {
|
||
| 493 | -+ | ! |
- )+ switch(input$t_dist, |
|
| 494 | -+ | ! |
-
+ "normal" = {
|
|
| 495 | -+ | ! |
- ### REPORTER+ if (!shinyvalidate::input_provided(value)) {
|
|
| 496 | ! |
- if (with_reporter) {
+ "sd is required" |
||
| 497 | ! |
- card_fun <- function(comment, label) {
+ } else if (value < 0) {
|
||
| 498 | ! |
- card <- teal::report_card_template(+ "sd must be non-negative" |
||
| 499 | -! | +
- title = "Scatter Plot Matrix",+ } |
||
| 500 | -! | +
- label = label,+ }, |
||
| 501 | ! |
- with_filter = with_filter,+ "lognormal" = {
|
||
| 502 | ! |
- filter_panel_api = filter_panel_api+ if (!shinyvalidate::input_provided(value)) {
|
||
| 503 | -+ | ! |
- )+ "sdlog is required" |
|
| 504 | ! |
- card$append_text("Plot", "header3")
+ } else if (value < 0) {
|
||
| 505 | ! |
- card$append_plot(plot_r(), dim = pws$dim())+ "sdlog must be non-negative" |
||
| 506 | -! | +
- if (!comment == "") {
+ } |
||
| 507 | -! | +
- card$append_text("Comment", "header3")
+ }, |
||
| 508 | ! |
- card$append_text(comment)+ "gamma" = {
|
||
| 509 | -+ | ! |
- }+ if (!shinyvalidate::input_provided(value)) {
|
|
| 510 | ! |
- card$append_src(teal.code::get_code(req(decorated_output_q())))+ "rate is required" |
||
| 511 | ! |
- card+ } else if (value <= 0) {
|
||
| 512 | -+ | ! |
- }+ "rate must be positive" |
|
| 513 | -! | +
- teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
+ } |
||
| 514 |
- }+ }, |
|||
| 515 | -+ | ! |
- ###+ "unif" = NULL |
|
| 516 |
- })+ ) |
|||
| 517 |
- }+ } |
|||
| 518 |
-
+ } |
|||
| 519 |
- #' Get stats for x-y pairs in scatterplot matrix+ |
|||
| 520 | -+ | ! |
- #'+ rule_dist <- function(value) {
|
|
| 521 | -+ | ! |
- #' Uses [stats::cor.test()] per default for all numerical input variables and converts results+ if (isTRUE(input$tabs == "QQplot") || |
|
| 522 | -+ | ! |
- #' to character vector.+ isTRUE(input$dist_tests %in% c( |
|
| 523 | -+ | ! |
- #' Could be extended if different stats for different variable types are needed.+ "Kolmogorov-Smirnov (one-sample)", |
|
| 524 | -+ | ! |
- #' Meant to be called from [lattice::panel.text()].+ "Anderson-Darling (one-sample)", |
|
| 525 | -+ | ! |
- #'+ "Cramer-von Mises (one-sample)" |
|
| 526 |
- #' Presently we need to use a formula input for `stats::cor.test` because+ ))) {
|
|||
| 527 | -+ | ! |
- #' `na.fail` only gets evaluated when a formula is passed (see below).+ if (!shinyvalidate::input_provided(value)) {
|
|
| 528 | -+ | ! |
- #' ```+ "Please select the theoretical distribution." |
|
| 529 |
- #' x = c(1,3,5,7,NA)+ } |
|||
| 530 |
- #' y = c(3,6,7,8,1)+ } |
|||
| 531 |
- #' stats::cor.test(x, y, na.action = "na.fail")+ } |
|||
| 532 |
- #' stats::cor.test(~ x + y, na.action = "na.fail")+ |
|||
| 533 | -+ | ! |
- #' ```+ iv_dist <- shinyvalidate::InputValidator$new() |
|
| 534 | -+ | ! |
- #'+ iv_dist$add_rule("t_dist", rule_dist)
|
|
| 535 | -+ | ! |
- #' @param x,y (`numeric`) vectors of data values. `x` and `y` must have the same length.+ iv_dist$add_rule("dist_param1", rule_dist_1)
|
|
| 536 | -+ | ! |
- #' @param .f (`function`) function that accepts x and y as formula input `~ x + y`.+ iv_dist$add_rule("dist_param2", rule_dist_2)
|
|
| 537 | -+ | ! |
- #' Default `stats::cor.test`.+ iv_dist$enable() |
|
| 538 |
- #' @param .f_args (`list`) of arguments to be passed to `.f`.+ |
|||
| 539 | -+ | ! |
- #' @param round_stat (`integer(1)`) optional, number of decimal places to use when rounding the estimate.+ anl_merged_input <- teal.transform::merge_expression_srv( |
|
| 540 | -+ | ! |
- #' @param round_pval (`integer(1)`) optional, number of decimal places to use when rounding the p-value.+ selector_list = selector_list, |
|
| 541 | -+ | ! |
- #'+ datasets = data |
|
| 542 |
- #' @return Character with stats. For [stats::cor.test()] correlation coefficient and p-value.+ ) |
|||
| 543 |
- #'+ |
|||
| 544 | -+ | ! |
- #' @examples+ anl_merged_q <- reactive({
|
|
| 545 | -+ | ! |
- #' set.seed(1)+ req(anl_merged_input()) |
|
| 546 | -+ | ! |
- #' x <- runif(25, 0, 1)+ data() %>% |
|
| 547 | -+ | ! |
- #' y <- runif(25, 0, 1)+ teal.code::eval_code(as.expression(anl_merged_input()$expr)) |
|
| 548 |
- #' x[c(3, 10, 18)] <- NA+ }) |
|||
| 549 |
- #'+ |
|||
| 550 | -+ | ! |
- #' get_scatterplotmatrix_stats(x, y, .f = stats::cor.test, .f_args = list(method = "pearson"))+ merged <- list( |
|
| 551 | -+ | ! |
- #' get_scatterplotmatrix_stats(x, y, .f = stats::cor.test, .f_args = list(+ anl_input_r = anl_merged_input, |
|
| 552 | -+ | ! |
- #' method = "pearson",+ anl_q_r = anl_merged_q |
|
| 553 |
- #' na.action = na.fail+ ) |
|||
| 554 |
- #' ))+ |
|||
| 555 | -+ | ! |
- #'+ output$scales_types_ui <- renderUI({
|
|
| 556 | -+ | ! |
- #' @export+ if ("group_i" %in% names(selector_list()) && length(selector_list()$group_i()$filters[[1]]$selected) > 0) {
|
|
| 557 | -+ | ! |
- #'+ shinyWidgets::prettyRadioButtons( |
|
| 558 | -+ | ! |
- get_scatterplotmatrix_stats <- function(x, y,+ ns("scales_type"),
|
|
| 559 | -+ | ! |
- .f = stats::cor.test,+ label = "Scales:", |
|
| 560 | -+ | ! |
- .f_args = list(),+ choices = c("Fixed", "Free"),
|
|
| 561 | -+ | ! |
- round_stat = 2,+ selected = "Fixed", |
|
| 562 | -+ | ! |
- round_pval = 4) {
+ bigger = FALSE, |
|
| 563 | -6x | +! |
- if (is.numeric(x) && is.numeric(y)) {
+ inline = TRUE |
|
| 564 | -3x | +
- stat <- tryCatch(do.call(.f, c(list(~ x + y), .f_args)), error = function(e) NA)+ ) |
||
| 565 |
-
+ } |
|||
| 566 | -3x | +
- if (anyNA(stat)) {
+ }) |
||
| 567 | -1x | +
- return("NA")
+
|
||
| 568 | -2x | +! |
- } else if (all(c("estimate", "p.value") %in% names(stat))) {
+ observeEvent( |
|
| 569 | -2x | +! |
- return(paste(+ eventExpr = list( |
|
| 570 | -2x | +! |
- c(+ input$t_dist, |
|
| 571 | -2x | +! |
- paste0(names(stat$estimate), ":", round(stat$estimate, round_stat)),+ input$params_reset, |
|
| 572 | -2x | +! |
- paste0("P:", round(stat$p.value, round_pval))
+ selector_list()$dist_i()$select |
|
| 573 |
- ),+ ), |
|||
| 574 | -2x | +! |
- collapse = "\n"+ handlerExpr = {
|
|
| 575 | -+ | ! |
- ))+ params <- |
|
| 576 | -+ | ! |
- } else {
+ if (length(input$t_dist) != 0) {
|
|
| 577 | ! |
- stop("function not supported")
+ get_dist_params <- function(x, dist) {
|
||
| 578 | -+ | ! |
- }+ if (dist == "unif") {
|
|
| 579 | -+ | ! |
- } else {
+ return(stats::setNames(range(x, na.rm = TRUE), c("min", "max")))
|
|
| 580 | -3x | +
- if ("method" %in% names(.f_args)) {
+ } |
||
| 581 | -3x | +! |
- if (.f_args$method == "pearson") {
+ tryCatch( |
|
| 582 | -1x | +! |
- return("cor:-")
+ MASS::fitdistr(x, densfun = dist)$estimate, |
|
| 583 | -+ | ! |
- }+ error = function(e) c(param1 = NA_real_, param2 = NA_real_) |
|
| 584 | -2x | +
- if (.f_args$method == "kendall") {
+ ) |
||
| 585 | -1x | +
- return("tau:-")
+ } |
||
| 586 |
- }+ |
|||
| 587 | -1x | +! |
- if (.f_args$method == "spearman") {
+ ANL <- merged$anl_q_r()[["ANL"]] |
|
| 588 | -1x | +! |
- return("rho:-")
+ round(get_dist_params(as.numeric(stats::na.omit(ANL[[merge_vars()$dist_var]])), input$t_dist), 2) |
|
| 589 |
- }+ } else {
|
|||
| 590 | -+ | ! |
- }+ c("param1" = NA_real_, "param2" = NA_real_)
|
|
| 591 | -! | +
- return("-")
+ } |
||
| 592 |
- }+ |
|||
| 593 | -+ | ! |
- }+ params_vals <- unname(params) |
| 1 | -+ | ||
| 594 | +! |
- #' `teal` module: File viewer+ params_names <- names(params) |
|
| 2 | +595 |
- #'+ |
|
| 3 | -+ | ||
| 596 | +! |
- #' The file viewer module provides a tool to view static files.+ updateNumericInput( |
|
| 4 | -- |
- #' Supported formats include text formats, `PDF`, `PNG` `APNG`,- |
- |
| 5 | -- |
- #' `JPEG` `SVG`, `WEBP`, `GIF` and `BMP`.- |
- |
| 6 | -- |
- #'- |
- |
| 7 | -- |
- #' @inheritParams teal::module- |
- |
| 8 | -+ | ||
| 597 | +! |
- #' @inheritParams shared_params+ inputId = "dist_param1", |
|
| 9 | -+ | ||
| 598 | +! |
- #' @param input_path (`list`) of the input paths, optional. Each element can be:+ label = params_names[1], |
|
| 10 | -+ | ||
| 599 | +! |
- #'+ value = restoreInput(ns("dist_param1"), params_vals[1])
|
|
| 11 | +600 |
- #' Paths can be specified as absolute paths or relative to the running directory of the application.+ ) |
|
| 12 | -+ | ||
| 601 | +! |
- #' Default to the current working directory if not supplied.+ updateNumericInput( |
|
| 13 | -+ | ||
| 602 | +! |
- #'+ inputId = "dist_param2", |
|
| 14 | -+ | ||
| 603 | +! |
- #' @inherit shared_params return+ label = params_names[2], |
|
| 15 | -+ | ||
| 604 | +! |
- #'+ value = restoreInput(ns("dist_param1"), params_vals[2])
|
|
| 16 | +605 |
- #' @examplesShinylive+ ) |
|
| 17 | +606 |
- #' library(teal.modules.general)+ }, |
|
| 18 | -+ | ||
| 607 | +! |
- #' interactive <- function() TRUE+ ignoreInit = TRUE |
|
| 19 | +608 |
- #' {{ next_example }}
+ ) |
|
| 20 | +609 |
- #' @examples+ |
|
| 21 | -+ | ||
| 610 | +! |
- #' data <- teal_data()+ observeEvent(input$params_reset, {
|
|
| 22 | -+ | ||
| 611 | +! |
- #' data <- within(data, {
+ updateActionButton(inputId = "params_reset", label = "Reset params") |
|
| 23 | +612 |
- #' data <- data.frame(1)+ }) |
|
| 24 | +613 |
- #' })+ |
|
| 25 | -+ | ||
| 614 | +! |
- #'+ merge_vars <- reactive({
|
|
| 26 | -+ | ||
| 615 | +! |
- #' app <- init(+ teal::validate_inputs(iv_r()) |
|
| 27 | +616 |
- #' data = data,+ |
|
| 28 | -+ | ||
| 617 | +! |
- #' modules = modules(+ dist_var <- as.vector(merged$anl_input_r()$columns_source$dist_i) |
|
| 29 | -+ | ||
| 618 | +! |
- #' tm_file_viewer(+ s_var <- as.vector(merged$anl_input_r()$columns_source$strata_i) |
|
| 30 | -+ | ||
| 619 | +! |
- #' input_path = list(+ g_var <- as.vector(merged$anl_input_r()$columns_source$group_i) |
|
| 31 | +620 |
- #' folder = system.file("sample_files", package = "teal.modules.general"),
+
|
|
| 32 | -+ | ||
| 621 | +! |
- #' png = system.file("sample_files/sample_file.png", package = "teal.modules.general"),
+ dist_var_name <- if (length(dist_var)) as.name(dist_var) else NULL |
|
| 33 | -+ | ||
| 622 | +! |
- #' txt = system.file("sample_files/sample_file.txt", package = "teal.modules.general"),
+ s_var_name <- if (length(s_var)) as.name(s_var) else NULL |
|
| 34 | -+ | ||
| 623 | +! |
- #' url = "https://fda.gov/files/drugs/published/Portable-Document-Format-Specifications.pdf"+ g_var_name <- if (length(g_var)) as.name(g_var) else NULL |
|
| 35 | +624 |
- #' )+ |
|
| 36 | -+ | ||
| 625 | +! |
- #' )+ list( |
|
| 37 | -+ | ||
| 626 | +! |
- #' )+ dist_var = dist_var, |
|
| 38 | -+ | ||
| 627 | +! |
- #' )+ s_var = s_var, |
|
| 39 | -+ | ||
| 628 | +! |
- #' if (interactive()) {
+ g_var = g_var, |
|
| 40 | -+ | ||
| 629 | +! |
- #' shinyApp(app$ui, app$server)+ dist_var_name = dist_var_name, |
|
| 41 | -+ | ||
| 630 | +! |
- #' }+ s_var_name = s_var_name, |
|
| 42 | -+ | ||
| 631 | +! |
- #'+ g_var_name = g_var_name |
|
| 43 | +632 |
- #' @export+ ) |
|
| 44 | +633 |
- #'+ }) |
|
| 45 | +634 |
- tm_file_viewer <- function(label = "File Viewer Module",+ |
|
| 46 | +635 |
- input_path = list("Current Working Directory" = ".")) {
+ # common qenv |
|
| 47 | +636 | ! |
- message("Initializing tm_file_viewer")
+ common_q <- reactive({
|
| 48 | +637 |
-
+ # Create a private stack for this function only. |
|
| 49 | +638 |
- # Normalize the parameters+ |
|
| 50 | +639 | ! |
- if (length(label) == 0 || identical(label, "")) label <- " "+ ANL <- merged$anl_q_r()[["ANL"]] |
| 51 | +640 | ! |
- if (length(input_path) == 0 || identical(input_path, "")) input_path <- list()- |
-
| 52 | -- |
-
+ dist_var <- merge_vars()$dist_var |
|
| 53 | -+ | ||
| 641 | +! |
- # Start of assertions+ s_var <- merge_vars()$s_var |
|
| 54 | +642 | ! |
- checkmate::assert_string(label)+ g_var <- merge_vars()$g_var |
| 55 | +643 | ||
| 56 | +644 | ! |
- checkmate::assert(+ dist_var_name <- merge_vars()$dist_var_name |
| 57 | +645 | ! |
- checkmate::check_list(input_path, types = "character", min.len = 0),+ s_var_name <- merge_vars()$s_var_name |
| 58 | +646 | ! |
- checkmate::check_character(input_path, min.len = 1)+ g_var_name <- merge_vars()$g_var_name |
| 59 | +647 |
- )- |
- |
| 60 | -! | -
- if (length(input_path) > 0) {
+
|
|
| 61 | +648 | ! |
- valid_url <- function(url_input, timeout = 2) {
+ roundn <- input$roundn |
| 62 | +649 | ! |
- con <- try(url(url_input), silent = TRUE)+ dist_param1 <- input$dist_param1 |
| 63 | +650 | ! |
- check <- suppressWarnings(try(open.connection(con, open = "rt", timeout = timeout), silent = TRUE)[1])+ dist_param2 <- input$dist_param2 |
| 64 | -! | +||
| 651 | +
- try(close.connection(con), silent = TRUE)+ # isolated as dist_param1/dist_param2 already triggered the reactivity |
||
| 65 | +652 | ! |
- is.null(check)+ t_dist <- isolate(input$t_dist) |
| 66 | +653 |
- }+ |
|
| 67 | +654 | ! |
- idx <- vapply(input_path, function(x) file.exists(x) || valid_url(x), logical(1))+ qenv <- merged$anl_q_r() |
| 68 | +655 | ||
| 69 | +656 | ! |
- if (!all(idx)) {
+ if (length(g_var) > 0) {
|
| 70 | +657 | ! |
- warning(+ validate( |
| 71 | +658 | ! |
- paste0(+ need( |
| 72 | +659 | ! |
- "Non-existent file or url path. Please provide valid paths for:\n",+ inherits(ANL[[g_var]], c("integer", "factor", "character")),
|
| 73 | +660 | ! |
- paste0(input_path[!idx], collapse = "\n")+ "Group by variable must be `factor`, `character`, or `integer`" |
| 74 | +661 |
- )+ ) |
|
| 75 | +662 |
- )+ ) |
|
| 76 | -+ | ||
| 663 | +! |
- }+ qenv <- teal.code::eval_code( |
|
| 77 | +664 | ! |
- input_path <- input_path[idx]+ qenv, |
| 78 | -+ | ||
| 665 | +! |
- } else {
+ substitute( |
|
| 79 | +666 | ! |
- warning(+ expr = ANL[[g_var]] <- forcats::fct_na_value_to_level(as.factor(ANL[[g_var]]), "NA"), |
| 80 | +667 | ! |
- "No file or url paths were provided."+ env = list(g_var = g_var) |
| 81 | +668 |
- )+ ) |
|
| 82 | +669 |
- }+ ) |
|
| 83 | +670 |
- # End of assertions+ } |
|
| 84 | +671 | ||
| 85 | -+ | ||
| 672 | +! |
- # Make UI args+ if (length(s_var) > 0) {
|
|
| 86 | +673 | ! |
- args <- as.list(environment())+ validate( |
| 87 | -+ | ||
| 674 | +! |
-
+ need( |
|
| 88 | +675 | ! |
- ans <- module(+ inherits(ANL[[s_var]], c("integer", "factor", "character")),
|
| 89 | +676 | ! |
- label = label,+ "Stratify by variable must be `factor`, `character`, or `integer`"+ |
+
| 677 | ++ |
+ )+ |
+ |
| 678 | ++ |
+ ) |
|
| 90 | +679 | ! |
- server = srv_viewer,+ qenv <- teal.code::eval_code( |
| 91 | +680 | ! |
- server_args = list(input_path = input_path),+ qenv, |
| 92 | +681 | ! |
- ui = ui_viewer,+ substitute( |
| 93 | +682 | ! |
- ui_args = args,+ expr = ANL[[s_var]] <- forcats::fct_na_value_to_level(as.factor(ANL[[s_var]]), "NA"), |
| 94 | +683 | ! |
- datanames = NULL+ env = list(s_var = s_var) |
| 95 | +684 |
- )- |
- |
| 96 | -! | -
- attr(ans, "teal_bookmarkable") <- FALSE- |
- |
| 97 | -! | -
- ans- |
- |
| 98 | -- |
- }+ ) |
|
| 99 | +685 |
-
+ ) |
|
| 100 | +686 |
- # UI function for the file viewer module+ } |
|
| 101 | +687 |
- ui_viewer <- function(id, ...) {
+
|
|
| 102 | +688 | ! |
- args <- list(...)+ validate(need(is.numeric(ANL[[dist_var]]), "Please select a numeric variable.")) |
| 103 | +689 | ! |
- ns <- NS(id)+ teal::validate_has_data(ANL, 1, complete = TRUE) |
| 104 | +690 | ||
| 105 | +691 | ! |
- tagList(+ if (length(t_dist) != 0) {
|
| 106 | +692 | ! |
- include_css_files("custom"),
+ map_distr_nams <- list( |
| 107 | +693 | ! |
- teal.widgets::standard_layout(+ normal = c("mean", "sd"),
|
| 108 | +694 | ! |
- output = tags$div(+ lognormal = c("meanlog", "sdlog"),
|
| 109 | +695 | ! |
- uiOutput(ns("output"))
+ gamma = c("shape", "rate"),
+ |
+
| 696 | +! | +
+ unif = c("min", "max")
|
|
| 110 | +697 |
- ),+ ) |
|
| 111 | +698 | ! |
- encoding = tags$div(+ params_names_raw <- map_distr_nams[[t_dist]] |
| 112 | -! | +||
| 699 | +
- class = "file_viewer_encoding",+ |
||
| 113 | +700 | ! |
- tags$label("Encodings", class = "text-primary"),
+ qenv <- teal.code::eval_code( |
| 114 | +701 | ! |
- shinyTree::shinyTree(+ qenv, |
| 115 | +702 | ! |
- ns("tree"),
+ substitute( |
| 116 | +703 | ! |
- dragAndDrop = FALSE,+ expr = {
|
| 117 | +704 | ! |
- sort = FALSE,+ params <- as.list(c(dist_param1, dist_param2)) |
| 118 | +705 | ! |
- wholerow = TRUE,+ names(params) <- params_names_raw |
| 119 | -! | +||
| 706 | +
- theme = "proton",+ }, |
||
| 120 | +707 | ! |
- multiple = FALSE+ env = list( |
| 121 | -+ | ||
| 708 | +! |
- )+ dist_param1 = dist_param1, |
|
| 122 | -+ | ||
| 709 | +! |
- )+ dist_param2 = dist_param2, |
|
| 123 | -+ | ||
| 710 | +! |
- )+ params_names_raw = params_names_raw |
|
| 124 | +711 |
- )+ ) |
|
| 125 | +712 |
- }+ ) |
|
| 126 | +713 |
-
+ ) |
|
| 127 | +714 |
- # Server function for the file viewer module+ } |
|
| 128 | +715 |
- srv_viewer <- function(id, input_path) {
+
|
|
| 129 | +716 | ! |
- moduleServer(id, function(input, output, session) {
+ qenv <- if (length(s_var) == 0 && length(g_var) == 0) {
|
| 130 | +717 | ! |
- teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.general")- |
-
| 131 | -- |
-
+ teal.code::eval_code( |
|
| 132 | +718 | ! |
- temp_dir <- tempfile()+ qenv, |
| 133 | +719 | ! |
- if (!dir.exists(temp_dir)) {
+ substitute( |
| 134 | +720 | ! |
- dir.create(temp_dir, recursive = TRUE)+ expr = {
|
| 135 | -+ | ||
| 721 | +! |
- }+ summary_table_data <- ANL %>% |
|
| 136 | +722 | ! |
- addResourcePath(basename(temp_dir), temp_dir)+ dplyr::summarise( |
| 137 | -+ | ||
| 723 | +! |
-
+ min = round(min(dist_var_name, na.rm = TRUE), roundn), |
|
| 138 | +724 | ! |
- test_path_text <- function(selected_path, type) {
+ median = round(stats::median(dist_var_name, na.rm = TRUE), roundn), |
| 139 | +725 | ! |
- out <- tryCatch(+ mean = round(mean(dist_var_name, na.rm = TRUE), roundn), |
| 140 | +726 | ! |
- expr = {
+ max = round(max(dist_var_name, na.rm = TRUE), roundn), |
| 141 | +727 | ! |
- if (type != "url") {
+ sd = round(stats::sd(dist_var_name, na.rm = TRUE), roundn), |
| 142 | +728 | ! |
- selected_path <- normalizePath(selected_path, winslash = "/")+ count = dplyr::n() |
| 143 | +729 |
- }- |
- |
| 144 | -! | -
- readLines(con = selected_path)+ ) |
|
| 145 | +730 |
- },+ }, |
|
| 146 | +731 | ! |
- error = function(cond) FALSE,+ env = list( |
| 147 | +732 | ! |
- warning = function(cond) {
+ dist_var_name = as.name(dist_var), |
| 148 | +733 | ! |
- `if`(grepl("^incomplete final line found on", cond[[1]]), suppressWarnings(eval(cond[[2]])), FALSE)
+ roundn = roundn |
| 149 | +734 |
- }+ ) |
|
| 150 | +735 |
- )+ ) |
|
| 151 | +736 |
- }+ ) |
|
| 152 | +737 |
-
+ } else {
|
|
| 153 | +738 | ! |
- handle_connection_type <- function(selected_path) {
+ teal.code::eval_code( |
| 154 | +739 | ! |
- file_extension <- tools::file_ext(selected_path)+ qenv, |
| 155 | +740 | ! |
- file_class <- suppressWarnings(file(selected_path))+ substitute( |
| 156 | +741 | ! |
- close(file_class)+ expr = {
|
| 157 | -+ | ||
| 742 | +! |
-
+ strata_vars <- strata_vars_raw |
|
| 158 | +743 | ! |
- output_text <- test_path_text(selected_path, type = class(file_class)[1])+ summary_table_data <- ANL %>% |
| 159 | -+ | ||
| 744 | +! |
-
+ dplyr::group_by_at(dplyr::vars(dplyr::any_of(strata_vars))) %>% |
|
| 160 | +745 | ! |
- if (class(file_class)[1] == "url") {
+ dplyr::summarise( |
| 161 | +746 | ! |
- list(selected_path = selected_path, output_text = output_text)+ min = round(min(dist_var_name, na.rm = TRUE), roundn), |
| 162 | -+ | ||
| 747 | +! |
- } else {
+ median = round(stats::median(dist_var_name, na.rm = TRUE), roundn), |
|
| 163 | +748 | ! |
- file.copy(normalizePath(selected_path, winslash = "/"), temp_dir)+ mean = round(mean(dist_var_name, na.rm = TRUE), roundn), |
| 164 | +749 | ! |
- selected_path <- file.path(basename(temp_dir), basename(selected_path))+ max = round(max(dist_var_name, na.rm = TRUE), roundn), |
| 165 | +750 | ! |
- list(selected_path = selected_path, output_text = output_text)+ sd = round(stats::sd(dist_var_name, na.rm = TRUE), roundn), |
| 166 | -+ | ||
| 751 | +! |
- }+ count = dplyr::n() |
|
| 167 | +752 |
- }+ ) |
|
| 168 | +753 |
-
+ }, |
|
| 169 | +754 | ! |
- display_file <- function(selected_path) {
+ env = list( |
| 170 | +755 | ! |
- con_type <- handle_connection_type(selected_path)+ dist_var_name = dist_var_name, |
| 171 | +756 | ! |
- file_extension <- tools::file_ext(selected_path)+ strata_vars_raw = c(g_var, s_var), |
| 172 | +757 | ! |
- if (file_extension %in% c("png", "apng", "jpg", "jpeg", "svg", "gif", "webp", "bmp")) {
+ roundn = roundn+ |
+
| 758 | ++ |
+ )+ |
+ |
| 759 | ++ |
+ )+ |
+ |
| 760 | ++ |
+ )+ |
+ |
| 761 | ++ |
+ } |
|
| 173 | +762 | ! |
- tags$img(src = con_type$selected_path, alt = "file does not exist")+ if (iv_r()$is_valid()) {
|
| 174 | +763 | ! |
- } else if (file_extension == "pdf") {
+ within(qenv, {
|
| 175 | +764 | ! |
- tags$embed(+ summary_table <- DT::datatable( |
| 176 | +765 | ! |
- class = "embed_pdf",+ summary_table_data, |
| 177 | +766 | ! |
- src = con_type$selected_path+ options = list( |
| 178 | -+ | ||
| 767 | +! |
- )+ autoWidth = TRUE, |
|
| 179 | +768 | ! |
- } else if (!isFALSE(con_type$output_text[1])) {
+ columnDefs = list(list(width = "200px", targets = "_all"))+ |
+
| 769 | ++ |
+ ), |
|
| 180 | +770 | ! |
- tags$pre(paste0(con_type$output_text, collapse = "\n"))+ rownames = FALSE |
| 181 | +771 | ++ |
+ )+ |
+
| 772 | ++ |
+ })+ |
+ |
| 773 |
} else {
|
||
| 182 | +774 | ! |
- tags$p("Please select a supported format.")
+ within(qenv, summary_table <- NULL) |
| 183 | +775 |
} |
|
| 184 | +776 |
- }+ }) |
|
| 185 | +777 | ||
| 778 | ++ |
+ # distplot qenv ----+ |
+ |
| 186 | +779 | ! |
- tree_list <- function(file_or_dir) {
+ dist_q <- eventReactive( |
| 187 | +780 | ! |
- nested_list <- lapply(file_or_dir, function(path) {
+ eventExpr = {
|
| 188 | +781 | ! |
- file_class <- suppressWarnings(file(path))+ common_q() |
| 189 | +782 | ! |
- close(file_class)+ input$scales_type |
| 190 | +783 | ! |
- if (class(file_class)[[1]] != "url") {
+ input$main_type |
| 191 | +784 | ! |
- isdir <- file.info(path)$isdir+ input$bins |
| 192 | +785 | ! |
- if (!isdir) {
+ input$add_dens |
| 193 | +786 | ! |
- structure(path, ancestry = path, sticon = "file")+ is.null(input$ggtheme) |
| 194 | +787 |
- } else {
+ }, |
|
| 195 | +788 | ! |
- files <- list.files(path, full.names = TRUE, include.dirs = TRUE)+ valueExpr = {
|
| 196 | +789 | ! |
- out <- lapply(files, function(x) tree_list(x))+ dist_var <- merge_vars()$dist_var |
| 197 | +790 | ! |
- out <- unlist(out, recursive = FALSE)+ s_var <- merge_vars()$s_var |
| 198 | +791 | ! |
- if (length(files) > 0) names(out) <- basename(files)+ g_var <- merge_vars()$g_var |
| 199 | +792 | ! |
- out+ dist_var_name <- merge_vars()$dist_var_name |
| 200 | -+ | ||
| 793 | +! |
- }+ s_var_name <- merge_vars()$s_var_name |
|
| 201 | -+ | ||
| 794 | +! |
- } else {
+ g_var_name <- merge_vars()$g_var_name |
|
| 202 | +795 | ! |
- structure(path, ancestry = path, sticon = "file")+ t_dist <- input$t_dist |
| 203 | -+ | ||
| 796 | +! |
- }+ dist_param1 <- input$dist_param1 |
|
| 204 | -+ | ||
| 797 | +! |
- })+ dist_param2 <- input$dist_param2 |
|
| 205 | +798 | ||
| 206 | +799 | ! |
- missing_labels <- if (is.null(names(nested_list))) seq_along(nested_list) else which(names(nested_list) == "")+ scales_type <- input$scales_type |
| 207 | -! | +||
| 800 | +
- names(nested_list)[missing_labels] <- file_or_dir[missing_labels]+ |
||
| 208 | +801 | ! |
- nested_list+ ndensity <- 512 |
| 209 | -+ | ||
| 802 | +! |
- }+ main_type_var <- input$main_type |
|
| 210 | -+ | ||
| 803 | +! |
-
+ bins_var <- input$bins |
|
| 211 | +804 | ! |
- output$tree <- shinyTree::renderTree({
+ add_dens_var <- input$add_dens |
| 212 | +805 | ! |
- if (length(input_path) > 0) {
+ ggtheme <- input$ggtheme+ |
+
| 806 | ++ | + | |
| 213 | +807 | ! |
- tree_list(input_path)+ teal::validate_inputs(iv_dist) |
| 214 | +808 |
- } else {
+
|
|
| 215 | +809 | ! |
- list("Empty Path" = NULL)
+ qenv <- common_q() |
| 216 | +810 |
- }+ |
|
| 217 | -+ | ||
| 811 | +! |
- })+ m_type <- if (main_type_var == "Density") "density" else "count" |
|
| 218 | +812 | ||
| 219 | +813 | ! |
- output$output <- renderUI({
+ plot_call <- if (length(s_var) == 0 && length(g_var) == 0) {
|
| 220 | +814 | ! |
- validate(+ substitute( |
| 221 | +815 | ! |
- need(+ expr = ggplot(ANL, aes(dist_var_name)) + |
| 222 | +816 | ! |
- length(shinyTree::get_selected(input$tree)) > 0,+ geom_histogram( |
| 223 | +817 | ! |
- "Please select a file."+ position = "identity", aes(y = after_stat(m_type)), bins = bins_var, alpha = 0.3 |
| 224 | +818 |
- )+ ),+ |
+ |
| 819 | +! | +
+ env = list(+ |
+ |
| 820 | +! | +
+ m_type = as.name(m_type), bins_var = bins_var, dist_var_name = as.name(dist_var) |
|
| 225 | +821 |
- )+ ) |
|
| 226 | +822 |
-
+ ) |
|
| 227 | +823 | ! |
- obj <- shinyTree::get_selected(input$tree, format = "names")[[1]]+ } else if (length(s_var) != 0 && length(g_var) == 0) {
|
| 228 | +824 | ! |
- repo <- attr(obj, "ancestry")+ substitute( |
| 229 | +825 | ! |
- repo_collapsed <- if (length(repo) > 1) paste0(repo, collapse = "/") else repo+ expr = ggplot(ANL, aes(dist_var_name, col = s_var_name)) + |
| 230 | +826 | ! |
- is_not_named <- file.exists(file.path(c(repo_collapsed, obj[1])))[1]+ geom_histogram(+ |
+
| 827 | +! | +
+ position = "identity", aes(y = after_stat(m_type), fill = s_var), bins = bins_var, alpha = 0.3 |
|
| 231 | +828 |
-
+ ), |
|
| 232 | +829 | ! |
- if (is_not_named) {
+ env = list( |
| 233 | +830 | ! |
- selected_path <- do.call("file.path", as.list(c(repo, obj[1])))
- |
-
| 234 | -- |
- } else {
+ m_type = as.name(m_type), |
|
| 235 | +831 | ! |
- if (length(repo) == 0) {
+ bins_var = bins_var, |
| 236 | +832 | ! |
- selected_path <- do.call("file.path", as.list(attr(input$tree[[obj[1]]], "ancestry")))
+ dist_var_name = dist_var_name, |
| 237 | -+ | ||
| 833 | +! |
- } else {
+ s_var = as.name(s_var), |
|
| 238 | +834 | ! |
- selected_path <- do.call("file.path", as.list(attr(input$tree[[repo]][[obj[1]]], "ancestry")))
+ s_var_name = s_var_name |
| 239 | +835 |
- }+ ) |
|
| 240 | +836 |
- }+ ) |
|
| 241 | -+ | ||
| 837 | +! |
-
+ } else if (length(s_var) == 0 && length(g_var) != 0) {
|
|
| 242 | +838 | ! |
- validate(+ req(scales_type) |
| 243 | +839 | ! |
- need(+ substitute( |
| 244 | +840 | ! |
- !isTRUE(file.info(selected_path)$isdir) && length(selected_path) > 0,+ expr = ggplot(ANL[ANL[[g_var]] != "NA", ], aes(dist_var_name)) + |
| 245 | +841 | ! |
- "Please select a single file."+ geom_histogram( |
| 246 | -+ | ||
| 842 | +! |
- )+ position = "identity", aes(y = after_stat(m_type)), bins = bins_var, alpha = 0.3 |
|
| 247 | +843 |
- )+ ) + |
|
| 248 | +844 | ! |
- display_file(selected_path)+ facet_wrap(~g_var_name, ncol = 1, scales = scales_raw), |
| 249 | -+ | ||
| 845 | +! |
- })+ env = list( |
|
| 250 | -+ | ||
| 846 | +! |
-
+ m_type = as.name(m_type), |
|
| 251 | +847 | ! |
- onStop(function() {
+ bins_var = bins_var, |
| 252 | +848 | ! |
- removeResourcePath(basename(temp_dir))+ dist_var_name = dist_var_name, |
| 253 | +849 | ! |
- unlink(temp_dir)+ g_var = g_var, |
| 254 | -+ | ||
| 850 | +! |
- })+ g_var_name = g_var_name, |
|
| 255 | -+ | ||
| 851 | +! |
- })+ scales_raw = tolower(scales_type) |
|
| 256 | +852 |
- }+ ) |
| 1 | +853 |
- #' `teal` module: Variable browser+ ) |
|
| 2 | +854 |
- #'+ } else {
|
|
| 3 | -+ | ||
| 855 | +! |
- #' Module provides provides a detailed summary and visualization of variable distributions+ req(scales_type) |
|
| 4 | -+ | ||
| 856 | +! |
- #' for `data.frame` objects, with interactive features to customize analysis.+ substitute( |
|
| 5 | -+ | ||
| 857 | +! |
- #'+ expr = ggplot(ANL[ANL[[g_var]] != "NA", ], aes(dist_var_name, col = s_var_name)) + |
|
| 6 | -+ | ||
| 858 | +! |
- #' Numeric columns with fewer than 30 distinct values can be treated as either discrete+ geom_histogram( |
|
| 7 | -+ | ||
| 859 | +! |
- #' or continuous with a checkbox allowing users to switch how they are treated(if < 6 unique values+ position = "identity", |
|
| 8 | -+ | ||
| 860 | +! |
- #' then the default is discrete, otherwise it is continuous).+ aes(y = after_stat(m_type), fill = s_var), bins = bins_var, alpha = 0.3 |
|
| 9 | +861 |
- #'+ ) + |
|
| 10 | -+ | ||
| 862 | +! |
- #' @inheritParams teal::module+ facet_wrap(~g_var_name, ncol = 1, scales = scales_raw), |
|
| 11 | -+ | ||
| 863 | +! |
- #' @inheritParams shared_params+ env = list( |
|
| 12 | -+ | ||
| 864 | +! |
- #' @param parent_dataname (`character(1)`) string specifying a parent dataset.+ m_type = as.name(m_type), |
|
| 13 | -+ | ||
| 865 | +! |
- #' If it exists in `datasets_selected`then an extra checkbox will be shown to+ bins_var = bins_var, |
|
| 14 | -+ | ||
| 866 | +! |
- #' allow users to not show variables in other datasets which exist in this `dataname`.+ dist_var_name = dist_var_name, |
|
| 15 | -+ | ||
| 867 | +! |
- #' This is typically used to remove `ADSL` columns in `CDISC` data.+ g_var = g_var, |
|
| 16 | -+ | ||
| 868 | +! |
- #' In non `CDISC` data this can be ignored. Defaults to `"ADSL"`.+ s_var = as.name(s_var), |
|
| 17 | -+ | ||
| 869 | +! |
- #' @param datasets_selected (`character`) vector of datasets which should be+ g_var_name = g_var_name, |
|
| 18 | -+ | ||
| 870 | +! |
- #' shown, in order. Names must correspond with datasets names.+ s_var_name = s_var_name, |
|
| 19 | -+ | ||
| 871 | +! |
- #' If vector of length zero (default) then all datasets are shown.+ scales_raw = tolower(scales_type) |
|
| 20 | +872 |
- #' Note: Only `data.frame` objects are compatible; using other types will cause an error.+ ) |
|
| 21 | +873 |
- #'+ ) |
|
| 22 | +874 |
- #' @inherit shared_params return+ } |
|
| 23 | +875 |
- #'+ |
|
| 24 | -+ | ||
| 876 | +! |
- #' @examplesShinylive+ if (add_dens_var) {
|
|
| 25 | -- |
- #' library(teal.modules.general)- |
- |
| 26 | -- |
- #' interactive <- function() TRUE- |
- |
| 27 | -- |
- #' {{ next_example }}
- |
- |
| 28 | -+ | ||
| 877 | +! |
- # nolint start: line_length_linter.+ plot_call <- substitute( |
|
| 29 | -+ | ||
| 878 | +! |
- #' @examplesIf require("sparkline", quietly = TRUE) && require("htmlwidgets", quietly = TRUE) && require("jsonlite", quietly = TRUE)
+ expr = plot_call + |
|
| 30 | -+ | ||
| 879 | +! |
- # nolint end: line_length_linter.+ stat_density( |
|
| 31 | -+ | ||
| 880 | +! |
- #' # general data example+ aes(y = after_stat(const * m_type2)), |
|
| 32 | -+ | ||
| 881 | +! |
- #' data <- teal_data()+ geom = "line", |
|
| 33 | -+ | ||
| 882 | +! |
- #' data <- within(data, {
+ position = "identity", |
|
| 34 | -+ | ||
| 883 | +! |
- #' iris <- iris+ alpha = 0.5, |
|
| 35 | -+ | ||
| 884 | +! |
- #' mtcars <- mtcars+ size = 2, |
|
| 36 | -+ | ||
| 885 | +! |
- #' women <- women+ n = ndensity |
|
| 37 | +886 |
- #' faithful <- faithful+ ), |
|
| 38 | -+ | ||
| 887 | +! |
- #' CO2 <- CO2+ env = list( |
|
| 39 | -+ | ||
| 888 | +! |
- #' })+ plot_call = plot_call, |
|
| 40 | -+ | ||
| 889 | +! |
- #'+ const = if (main_type_var == "Density") {
|
|
| 41 | -+ | ||
| 890 | +! |
- #' app <- init(+ 1 |
|
| 42 | +891 |
- #' data = data,+ } else {
|
|
| 43 | -+ | ||
| 892 | +! |
- #' modules = modules(+ diff(range(qenv[["ANL"]][[dist_var]], na.rm = TRUE)) / bins_var |
|
| 44 | +893 |
- #' tm_variable_browser(+ }, |
|
| 45 | -+ | ||
| 894 | +! |
- #' label = "Variable browser"+ m_type2 = if (main_type_var == "Density") as.name("density") else as.name("count"),
|
|
| 46 | -+ | ||
| 895 | +! |
- #' )+ ndensity = ndensity |
|
| 47 | +896 |
- #' )+ ) |
|
| 48 | +897 |
- #' )+ ) |
|
| 49 | +898 |
- #' if (interactive()) {
+ } |
|
| 50 | +899 |
- #' shinyApp(app$ui, app$server)+ |
|
| 51 | -+ | ||
| 900 | +! |
- #' }+ if (length(t_dist) != 0 && main_type_var == "Density" && length(g_var) == 0 && length(s_var) == 0) {
|
|
| 52 | -+ | ||
| 901 | +! |
- #'+ qenv <- teal.code::eval_code( |
|
| 53 | -+ | ||
| 902 | +! |
- #' @examplesShinylive+ qenv, |
|
| 54 | -+ | ||
| 903 | +! |
- #' library(teal.modules.general)+ substitute( |
|
| 55 | -+ | ||
| 904 | +! |
- #' interactive <- function() TRUE+ df_params <- as.data.frame(append(params, list(name = t_dist))), |
|
| 56 | -+ | ||
| 905 | +! |
- #' {{ next_example }}
+ env = list(t_dist = t_dist) |
|
| 57 | +906 |
- # nolint start: line_length_linter.+ ) |
|
| 58 | +907 |
- #' @examplesIf require("sparkline", quietly = TRUE) && require("htmlwidgets", quietly = TRUE) && require("jsonlite", quietly = TRUE)
+ ) |
|
| 59 | -+ | ||
| 908 | +! |
- # nolint end: line_length_linter.+ datas <- quote(data.frame(x = 0.7, y = 1, tb = I(list(df_params = df_params)))) |
|
| 60 | -+ | ||
| 909 | +! |
- #' # CDISC example data+ label <- quote(tb) |
|
| 61 | +910 |
- #' library(sparkline)+ |
|
| 62 | -+ | ||
| 911 | +! |
- #' data <- teal_data()+ plot_call <- substitute( |
|
| 63 | -+ | ||
| 912 | +! |
- #' data <- within(data, {
+ expr = plot_call + ggpp::geom_table_npc( |
|
| 64 | -+ | ||
| 913 | +! |
- #' ADSL <- rADSL+ data = data, |
|
| 65 | -+ | ||
| 914 | +! |
- #' ADTTE <- rADTTE+ aes(npcx = x, npcy = y, label = label), |
|
| 66 | -+ | ||
| 915 | +! |
- #' })+ hjust = 0, vjust = 1, size = 4 |
|
| 67 | +916 |
- #' join_keys(data) <- default_cdisc_join_keys[names(data)]+ ), |
|
| 68 | -+ | ||
| 917 | +! |
- #'+ env = list(plot_call = plot_call, data = datas, label = label) |
|
| 69 | +918 |
- #' app <- init(+ ) |
|
| 70 | +919 |
- #' data = data,+ } |
|
| 71 | +920 |
- #' modules = modules(+ |
|
| 72 | -+ | ||
| 921 | +! |
- #' tm_variable_browser(+ if ( |
|
| 73 | -+ | ||
| 922 | +! |
- #' label = "Variable browser"+ length(s_var) == 0 && |
|
| 74 | -+ | ||
| 923 | +! |
- #' )+ length(g_var) == 0 && |
|
| 75 | -+ | ||
| 924 | +! |
- #' )+ main_type_var == "Density" && |
|
| 76 | -+ | ||
| 925 | +! |
- #' )+ length(t_dist) != 0 && |
|
| 77 | -+ | ||
| 926 | +! |
- #' if (interactive()) {
+ main_type_var == "Density" |
|
| 78 | +927 |
- #' shinyApp(app$ui, app$server)+ ) {
|
|
| 79 | -+ | ||
| 928 | +! |
- #' }+ map_dist <- stats::setNames( |
|
| 80 | -+ | ||
| 929 | +! |
- #'+ c("dnorm", "dlnorm", "dgamma", "dunif"),
|
|
| 81 | -+ | ||
| 930 | +! |
- #' @export+ c("normal", "lognormal", "gamma", "unif")
|
|
| 82 | +931 |
- #'+ ) |
|
| 83 | -+ | ||
| 932 | +! |
- tm_variable_browser <- function(label = "Variable Browser",+ plot_call <- substitute( |
|
| 84 | -+ | ||
| 933 | +! |
- datasets_selected = character(0),+ expr = plot_call + stat_function( |
|
| 85 | -+ | ||
| 934 | +! |
- parent_dataname = "ADSL",+ data = data.frame(x = range(ANL[[dist_var]]), color = mapped_dist), |
|
| 86 | -+ | ||
| 935 | +! |
- pre_output = NULL,+ aes(x, color = color), |
|
| 87 | -+ | ||
| 936 | +! |
- post_output = NULL,+ fun = mapped_dist_name, |
|
| 88 | -+ | ||
| 937 | +! |
- ggplot2_args = teal.widgets::ggplot2_args()) {
+ n = ndensity, |
|
| 89 | +938 | ! |
- message("Initializing tm_variable_browser")
+ size = 2, |
| 90 | -+ | ||
| 939 | +! |
-
+ args = params |
|
| 91 | +940 |
- # Requires Suggested packages+ ) + |
|
| 92 | +941 | ! |
- if (!requireNamespace("sparkline", quietly = TRUE)) {
+ scale_color_manual(values = stats::setNames("blue", mapped_dist), aesthetics = "color"),
|
| 93 | +942 | ! |
- stop("Cannot load sparkline - please install the package or restart your session.")
+ env = list( |
| 94 | -+ | ||
| 943 | +! |
- }+ plot_call = plot_call, |
|
| 95 | +944 | ! |
- if (!requireNamespace("htmlwidgets", quietly = TRUE)) {
+ dist_var = dist_var, |
| 96 | +945 | ! |
- stop("Cannot load htmlwidgets - please install the package or restart your session.")
+ ndensity = ndensity, |
| 97 | -+ | ||
| 946 | +! |
- }+ mapped_dist = unname(map_dist[t_dist]), |
|
| 98 | +947 | ! |
- if (!requireNamespace("jsonlite", quietly = TRUE)) {
+ mapped_dist_name = as.name(unname(map_dist[t_dist])) |
| 99 | -! | +||
| 948 | +
- stop("Cannot load jsonlite - please install the package or restart your session.")
+ ) |
||
| 100 | +949 |
- }+ ) |
|
| 101 | +950 |
-
+ } |
|
| 102 | +951 |
- # Start of assertions+ |
|
| 103 | -! | -
- checkmate::assert_string(label)- |
- |
| 104 | -! | -
- checkmate::assert_character(datasets_selected)- |
- |
| 105 | -! | -
- checkmate::assert_character(parent_dataname, min.len = 0, max.len = 1)- |
- |
| 106 | +952 | ! |
- checkmate::assert_multi_class(pre_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
+ all_ggplot2_args <- teal.widgets::resolve_ggplot2_args( |
| 107 | +953 | ! |
- checkmate::assert_multi_class(post_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
+ user_plot = ggplot2_args[["Histogram"]], |
| 108 | +954 | ! |
- checkmate::assert_class(ggplot2_args, "ggplot2_args")+ user_default = ggplot2_args$default |
| 109 | +955 |
- # End of assertions+ ) |
|
| 110 | +956 | ||
| 111 | +957 | ! |
- datasets_selected <- unique(datasets_selected)- |
-
| 112 | -- |
-
+ parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args( |
|
| 113 | +958 | ! |
- ans <- module(+ all_ggplot2_args, |
| 114 | +959 | ! |
- label,+ ggtheme = ggtheme |
| 115 | -! | +||
| 960 | +
- server = srv_variable_browser,+ ) |
||
| 116 | -! | +||
| 961 | +
- ui = ui_variable_browser,+ |
||
| 117 | +962 | ! |
- datanames = "all",+ teal.code::eval_code( |
| 118 | +963 | ! |
- server_args = list(+ qenv, |
| 119 | +964 | ! |
- datasets_selected = datasets_selected,+ substitute( |
| 120 | +965 | ! |
- parent_dataname = parent_dataname,+ expr = histogram_plot <- plot_call, |
| 121 | +966 | ! |
- ggplot2_args = ggplot2_args+ env = list(plot_call = Reduce(function(x, y) call("+", x, y), c(plot_call, parsed_ggplot2_args)))
|
| 122 | +967 |
- ),- |
- |
| 123 | -! | -
- ui_args = list(+ ) |
|
| 124 | -! | +||
| 968 | +
- pre_output = pre_output,+ ) |
||
| 125 | -! | +||
| 969 | +
- post_output = post_output+ } |
||
| 126 | +970 |
) |
|
| 127 | +971 |
- )+ |
|
| 128 | +972 |
- # `shiny` inputs are stored properly but the majority of the module is state of `datatable` which is not stored.+ # qqplot qenv ---- |
|
| 129 | +973 | ! |
- attr(ans, "teal_bookmarkable") <- NULL+ qq_q <- eventReactive( |
| 130 | +974 | ! |
- ans+ eventExpr = {
|
| 131 | -+ | ||
| 975 | +! |
- }+ common_q() |
|
| 132 | -+ | ||
| 976 | +! |
-
+ input$scales_type |
|
| 133 | -+ | ||
| 977 | +! |
- # UI function for the variable browser module+ input$qq_line |
|
| 134 | -+ | ||
| 978 | +! |
- ui_variable_browser <- function(id,+ is.null(input$ggtheme) |
|
| 135 | -+ | ||
| 979 | +! |
- pre_output = NULL,+ input$tabs |
|
| 136 | +980 |
- post_output = NULL) {
+ }, |
|
| 137 | +981 | ! |
- ns <- NS(id)- |
-
| 138 | -- |
-
+ valueExpr = {
|
|
| 139 | +982 | ! |
- tagList(+ dist_var <- merge_vars()$dist_var |
| 140 | +983 | ! |
- include_css_files("custom"),
+ s_var <- merge_vars()$s_var |
| 141 | +984 | ! |
- shinyjs::useShinyjs(),+ g_var <- merge_vars()$g_var |
| 142 | +985 | ! |
- teal.widgets::standard_layout(+ dist_var_name <- merge_vars()$dist_var_name |
| 143 | +986 | ! |
- output = fluidRow(+ s_var_name <- merge_vars()$s_var_name |
| 144 | +987 | ! |
- htmlwidgets::getDependency("sparkline"), # needed for sparklines to work
+ g_var_name <- merge_vars()$g_var_name |
| 145 | +988 | ! |
- column(+ dist_param1 <- input$dist_param1 |
| 146 | +989 | ! |
- 6,+ dist_param2 <- input$dist_param2 |
| 147 | +990 |
- # variable browser+ |
|
| 148 | +991 | ! |
- teal.widgets::white_small_well(+ scales_type <- input$scales_type |
| 149 | +992 | ! |
- uiOutput(ns("ui_variable_browser")),
+ ggtheme <- input$ggtheme+ |
+
| 993 | ++ | + | |
| 150 | +994 | ! |
- shinyjs::hidden({
+ teal::validate_inputs(iv_r_dist(), iv_dist) |
| 151 | +995 | ! |
- checkboxInput(ns("show_parent_vars"), "Show parent dataset variables", value = FALSE)
+ t_dist <- req(input$t_dist) # Not validated when tab is not selected |
| 152 | -+ | ||
| 996 | +! |
- })+ qenv <- common_q() |
|
| 153 | +997 |
- )+ |
|
| 154 | -+ | ||
| 998 | +! |
- ),+ plot_call <- if (length(s_var) == 0 && length(g_var) == 0) {
|
|
| 155 | +999 | ! |
- column(+ substitute( |
| 156 | +1000 | ! |
- 6,+ expr = ggplot(ANL, aes_string(sample = dist_var)), |
| 157 | +1001 | ! |
- teal.widgets::white_small_well(+ env = list(dist_var = dist_var) |
| 158 | +1002 |
- ### Reporter+ ) |
|
| 159 | +1003 | ! |
- teal.reporter::simple_reporter_ui(ns("simple_reporter")),
- |
-
| 160 | -- |
- ###+ } else if (length(s_var) != 0 && length(g_var) == 0) {
|
|
| 161 | +1004 | ! |
- tags$div(+ substitute( |
| 162 | +1005 | ! |
- class = "block",+ expr = ggplot(ANL, aes_string(sample = dist_var, color = s_var)), |
| 163 | +1006 | ! |
- uiOutput(ns("ui_histogram_display"))
+ env = list(dist_var = dist_var, s_var = s_var) |
| 164 | +1007 |
- ),+ ) |
|
| 165 | +1008 | ! |
- tags$div(+ } else if (length(s_var) == 0 && length(g_var) != 0) {
|
| 166 | +1009 | ! |
- class = "block",+ substitute( |
| 167 | +1010 | ! |
- uiOutput(ns("ui_numeric_display"))
- |
-
| 168 | -- |
- ),+ expr = ggplot(ANL[ANL[[g_var]] != "NA", ], aes_string(sample = dist_var)) + |
|
| 169 | +1011 | ! |
- teal.widgets::plot_with_settings_ui(ns("variable_plot")),
+ facet_wrap(~g_var_name, ncol = 1, scales = scales_raw), |
| 170 | +1012 | ! |
- tags$br(),- |
-
| 171 | -- |
- # input user-defined text size+ env = list( |
|
| 172 | +1013 | ! |
- teal.widgets::panel_item(+ dist_var = dist_var, |
| 173 | +1014 | ! |
- title = "Plot settings",+ g_var = g_var, |
| 174 | +1015 | ! |
- collapsed = TRUE,+ g_var_name = g_var_name, |
| 175 | +1016 | ! |
- selectInput(+ scales_raw = tolower(scales_type) |
| 176 | -! | +||
| 1017 | +
- inputId = ns("ggplot_theme"), label = "ggplot2 theme",
+ ) |
||
| 177 | -! | +||
| 1018 | +
- choices = ggplot_themes,+ ) |
||
| 178 | -! | +||
| 1019 | +
- selected = "grey"+ } else {
|
||
| 179 | -+ | ||
| 1020 | +! |
- ),+ substitute( |
|
| 180 | +1021 | ! |
- fluidRow(+ expr = ggplot(ANL[ANL[[g_var]] != "NA", ], aes_string(sample = dist_var, color = s_var)) + |
| 181 | +1022 | ! |
- column(6, sliderInput(+ facet_wrap(~g_var_name, ncol = 1, scales = scales_raw), |
| 182 | +1023 | ! |
- inputId = ns("font_size"), label = "font size",
+ env = list( |
| 183 | +1024 | ! |
- min = 5L, max = 30L, value = 15L, step = 1L, ticks = FALSE+ dist_var = dist_var, |
| 184 | -+ | ||
| 1025 | +! |
- )),+ g_var = g_var, |
|
| 185 | +1026 | ! |
- column(6, sliderInput(+ s_var = s_var, |
| 186 | +1027 | ! |
- inputId = ns("label_rotation"), label = "rotate x labels",
+ g_var_name = g_var_name, |
| 187 | +1028 | ! |
- min = 0L, max = 90L, value = 45L, step = 1, ticks = FALSE+ scales_raw = tolower(scales_type) |
| 188 | +1029 |
- ))+ ) |
|
| 189 | +1030 |
- )+ ) |
|
| 190 | +1031 |
- ),+ } |
|
| 191 | -! | +||
| 1032 | +
- tags$br(),+ |
||
| 192 | +1033 | ! |
- teal.widgets::get_dt_rows(ns("variable_summary_table"), ns("variable_summary_table_rows")),
+ map_dist <- stats::setNames( |
| 193 | +1034 | ! |
- DT::dataTableOutput(ns("variable_summary_table"))
+ c("qnorm", "qlnorm", "qgamma", "qunif"),
|
| 194 | -+ | ||
| 1035 | +! |
- )+ c("normal", "lognormal", "gamma", "unif")
|
|
| 195 | +1036 |
) |
|
| 196 | +1037 |
- ),+ |
|
| 197 | +1038 | ! |
- pre_output = pre_output,+ plot_call <- substitute( |
| 198 | +1039 | ! |
- post_output = post_output+ expr = plot_call + |
| 199 | -+ | ||
| 1040 | +! |
- )+ stat_qq(distribution = mapped_dist, dparams = params), |
|
| 200 | -+ | ||
| 1041 | +! |
- )+ env = list(plot_call = plot_call, mapped_dist = as.name(unname(map_dist[t_dist]))) |
|
| 201 | +1042 |
- }+ ) |
|
| 202 | +1043 | ||
| 203 | -+ | ||
| 1044 | +! |
- # Server function for the variable browser module- |
- |
| 204 | -- |
- srv_variable_browser <- function(id,- |
- |
| 205 | -- |
- data,- |
- |
| 206 | -- |
- reporter,- |
- |
| 207 | -- |
- filter_panel_api,- |
- |
| 208 | -- |
- datasets_selected, parent_dataname, ggplot2_args) {
- |
- |
| 209 | -! | -
- with_reporter <- !missing(reporter) && inherits(reporter, "Reporter")+ if (length(t_dist) != 0 && length(g_var) == 0 && length(s_var) == 0) {
|
|
| 210 | +1045 | ! |
- with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI")+ qenv <- teal.code::eval_code( |
| 211 | +1046 | ! |
- checkmate::assert_class(data, "reactive")+ qenv, |
| 212 | +1047 | ! |
- checkmate::assert_class(isolate(data()), "teal_data")+ substitute( |
| 213 | +1048 | ! |
- moduleServer(id, function(input, output, session) {
+ df_params <- as.data.frame(append(params, list(name = t_dist))), |
| 214 | +1049 | ! |
- teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.general")- |
-
| 215 | -- | - - | -|
| 216 | -- |
- # if there are < this number of unique records then a numeric+ env = list(t_dist = t_dist) |
|
| 217 | +1050 |
- # variable can be treated as a factor and all factors with < this groups+ ) |
|
| 218 | +1051 |
- # have their values plotted+ ) |
|
| 219 | +1052 | ! |
- .unique_records_for_factor <- 30+ datas <- quote(data.frame(x = 0.7, y = 1, tb = I(list(df_params = df_params)))) |
| 220 | -+ | ||
| 1053 | +! |
- # if there are < this number of unique records then a numeric+ label <- quote(tb) |
|
| 221 | +1054 |
- # variable is by default treated as a factor+ |
|
| 222 | +1055 | ! |
- .unique_records_default_as_factor <- 6 # nolint: object_length.+ plot_call <- substitute( |
| 223 | -+ | ||
| 1056 | +! |
-
+ expr = plot_call + |
|
| 224 | +1057 | ! |
- varname_numeric_as_factor <- reactiveValues()+ ggpp::geom_table_npc( |
| 225 | -+ | ||
| 1058 | +! |
-
+ data = data, |
|
| 226 | +1059 | ! |
- datanames <- isolate(names(data()))+ aes(npcx = x, npcy = y, label = label), |
| 227 | +1060 | ! |
- datanames <- Filter(function(name) {
+ hjust = 0, |
| 228 | +1061 | ! |
- is.data.frame(isolate(data())[[name]])+ vjust = 1, |
| 229 | +1062 | ! |
- }, datanames)+ size = 4 |
| 230 | +1063 |
-
+ ), |
|
| 231 | +1064 | ! |
- checkmate::assert_character(datasets_selected)+ env = list( |
| 232 | +1065 | ! |
- checkmate::assert_subset(datasets_selected, datanames)+ plot_call = plot_call, |
| 233 | +1066 | ! |
- if (!identical(datasets_selected, character(0))) {
+ data = datas, |
| 234 | +1067 | ! |
- checkmate::assert_subset(datasets_selected, datanames)+ label = label |
| 235 | -! | +||
| 1068 | +
- datanames <- datasets_selected+ ) |
||
| 236 | +1069 |
- }+ ) |
|
| 237 | +1070 |
-
+ } |
|
| 238 | -! | +||
| 1071 | +
- output$ui_variable_browser <- renderUI({
+
|
||
| 239 | +1072 | ! |
- ns <- session$ns+ if (isTRUE(input$qq_line)) {
|
| 240 | +1073 | ! |
- do.call(+ plot_call <- substitute( |
| 241 | +1074 | ! |
- tabsetPanel,+ expr = plot_call + |
| 242 | +1075 | ! |
- c(+ stat_qq_line(distribution = mapped_dist, dparams = params), |
| 243 | +1076 | ! |
- id = ns("tabset_panel"),
+ env = list(plot_call = plot_call, mapped_dist = as.name(unname(map_dist[t_dist]))) |
| 244 | -! | +||
| 1077 | +
- do.call(+ ) |
||
| 245 | -! | +||
| 1078 | +
- tagList,+ } |
||
| 246 | -! | +||
| 1079 | +
- lapply(datanames, function(dataname) {
+
|
||
| 247 | +1080 | ! |
- tabPanel(+ all_ggplot2_args <- teal.widgets::resolve_ggplot2_args( |
| 248 | +1081 | ! |
- dataname,+ user_plot = ggplot2_args[["QQplot"]], |
| 249 | +1082 | ! |
- tags$div(+ user_default = ggplot2_args$default, |
| 250 | +1083 | ! |
- class = "mt-4",+ module_plot = teal.widgets::ggplot2_args(labs = list(x = "theoretical", y = "sample")) |
| 251 | -! | +||
| 1084 | +
- textOutput(ns(paste0("dataset_summary_", dataname)))
+ ) |
||
| 252 | +1085 |
- ),+ |
|
| 253 | +1086 | ! |
- tags$div(+ parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args( |
| 254 | +1087 | ! |
- class = "mt-4",+ all_ggplot2_args, |
| 255 | +1088 | ! |
- teal.widgets::get_dt_rows(+ ggtheme = ggtheme |
| 256 | -! | +||
| 1089 | +
- ns(paste0("variable_browser_", dataname)),
+ ) |
||
| 257 | -! | +||
| 1090 | +
- ns(paste0("variable_browser_", dataname, "_rows"))
+
|
||
| 258 | -+ | ||
| 1091 | +! |
- ),+ teal.code::eval_code( |
|
| 259 | +1092 | ! |
- DT::dataTableOutput(ns(paste0("variable_browser_", dataname)), width = "100%")
+ qenv, |
| 260 | -+ | ||
| 1093 | +! |
- )+ substitute( |
|
| 261 | -+ | ||
| 1094 | +! |
- )+ expr = qq_plot <- plot_call, |
|
| 262 | -+ | ||
| 1095 | +! |
- })+ env = list(plot_call = Reduce(function(x, y) call("+", x, y), c(plot_call, parsed_ggplot2_args)))
|
|
| 263 | +1096 |
) |
|
| 264 | +1097 |
) |
|
| 265 | +1098 |
- )+ } |
|
| 266 | +1099 |
- })+ ) |
|
| 267 | +1100 | ||
| 268 | +1101 |
- # conditionally display checkbox+ # test qenv ---- |
|
| 269 | +1102 | ! |
- shinyjs::toggle(+ test_q <- eventReactive( |
| 270 | +1103 | ! |
- id = "show_parent_vars",+ ignoreNULL = FALSE, |
| 271 | +1104 | ! |
- condition = length(parent_dataname) > 0 && parent_dataname %in% datanames+ eventExpr = {
|
| 272 | -+ | ||
| 1105 | +! |
- )+ common_q() |
|
| 273 | -+ | ||
| 1106 | +! |
-
+ input$dist_param1 |
|
| 274 | +1107 | ! |
- columns_names <- new.env()+ input$dist_param2 |
| 275 | -+ | ||
| 1108 | +! |
-
+ input$dist_tests |
|
| 276 | +1109 |
- # plot_var$data holds the name of the currently selected dataset+ }, |
|
| 277 | -+ | ||
| 1110 | +! |
- # plot_var$variable[[<dataset_name>]] holds the name of the currently selected+ valueExpr = {
|
|
| 278 | +1111 |
- # variable for dataset <dataset_name>+ # Create a private stack for this function only. |
|
| 279 | +1112 | ! |
- plot_var <- reactiveValues(data = NULL, variable = list())+ ANL <- common_q()[["ANL"]] |
| 280 | +1113 | ||
| 281 | +1114 | ! |
- establish_updating_selection(datanames, input, plot_var, columns_names)- |
-
| 282 | -- |
-
+ dist_var <- merge_vars()$dist_var |
|
| 283 | -+ | ||
| 1115 | +! |
- # validations+ s_var <- merge_vars()$s_var |
|
| 284 | +1116 | ! |
- validation_checks <- validate_input(input, plot_var, data)+ g_var <- merge_vars()$g_var |
| 285 | +1117 | ||
| 286 | -+ | ||
| 1118 | +! |
- # data_for_analysis is a list with two elements: a column from a dataset and the column label+ dist_var_name <- merge_vars()$dist_var_name |
|
| 287 | +1119 | ! |
- plotted_data <- reactive({
+ s_var_name <- merge_vars()$s_var_name |
| 288 | +1120 | ! |
- validation_checks()+ g_var_name <- merge_vars()$g_var_name |
| 289 | +1121 | ||
| 290 | +1122 | ! |
- get_plotted_data(input, plot_var, data)- |
-
| 291 | -- |
- })- |
- |
| 292 | -- |
-
+ dist_param1 <- input$dist_param1 |
|
| 293 | +1123 | ! |
- treat_numeric_as_factor <- reactive({
+ dist_param2 <- input$dist_param2 |
| 294 | +1124 | ! |
- if (is_num_var_short(.unique_records_for_factor, input, plotted_data)) {
+ dist_tests <- input$dist_tests |
| 295 | +1125 | ! |
- input$numeric_as_factor+ t_dist <- input$t_dist |
| 296 | +1126 |
- } else {
+
|
|
| 297 | +1127 | ! |
- FALSE+ validate(need(dist_tests, "Please select a test")) |
| 298 | +1128 |
- }+ |
|
| 299 | -+ | ||
| 1129 | +! |
- })+ teal::validate_inputs(iv_dist) |
|
| 300 | +1130 | ||
| 301 | +1131 | ! |
- render_tabset_panel_content(+ if (length(s_var) > 0 || length(g_var) > 0) {
|
| 302 | +1132 | ! |
- input = input,+ counts <- ANL %>% |
| 303 | +1133 | ! |
- output = output,+ dplyr::group_by_at(dplyr::vars(dplyr::any_of(c(s_var, g_var)))) %>% |
| 304 | +1134 | ! |
- data = data,- |
-
| 305 | -! | -
- datanames = datanames,+ dplyr::summarise(n = dplyr::n()) |
|
| 306 | -! | +||
| 1135 | +
- parent_dataname = parent_dataname,+ |
||
| 307 | +1136 | ! |
- columns_names = columns_names,+ validate(need(all(counts$n > 5), "Please select strata*group with at least 5 observation each.")) |
| 308 | -! | +||
| 1137 | +
- plot_var = plot_var+ } |
||
| 309 | +1138 |
- )+ |
|
| 310 | +1139 |
- # add used-defined text size to ggplot arguments passed from caller frame+ |
|
| 311 | +1140 | ! |
- all_ggplot2_args <- reactive({
+ if (dist_tests %in% c( |
| 312 | +1141 | ! |
- user_text <- teal.widgets::ggplot2_args(+ "t-test (two-samples, not paired)", |
| 313 | +1142 | ! |
- theme = list(+ "F-test", |
| 314 | +1143 | ! |
- "text" = ggplot2::element_text(size = input[["font_size"]]),+ "Kolmogorov-Smirnov (two-samples)" |
| 315 | -! | +||
| 1144 | +
- "axis.text.x" = ggplot2::element_text(angle = input[["label_rotation"]], hjust = 1)+ )) {
|
||
| 316 | -+ | ||
| 1145 | +! |
- )+ if (length(g_var) == 0 && length(s_var) > 0) {
|
|
| 317 | -+ | ||
| 1146 | +! |
- )+ validate(need( |
|
| 318 | +1147 | ! |
- user_theme <- utils::getFromNamespace(sprintf("theme_%s", input[["ggplot_theme"]]), ns = "ggplot2")
+ length(unique(ANL[[s_var]])) == 2, |
| 319 | +1148 | ! |
- user_theme <- user_theme()+ "Please select stratify variable with 2 levels." |
| 320 | +1149 |
- # temporary fix to circumvent assertion issue with resolve_ggplot2_args+ )) |
|
| 321 | +1150 |
- # drop problematic elements+ } |
|
| 322 | +1151 | ! |
- user_theme <- user_theme[grep("strip.text.y.left", names(user_theme), fixed = TRUE, invert = TRUE)]
+ if (length(g_var) > 0 && length(s_var) > 0) {
|
| 323 | -+ | ||
| 1152 | +! |
-
+ validate(need( |
|
| 324 | +1153 | ! |
- teal.widgets::resolve_ggplot2_args(+ all(stats::na.omit(as.vector( |
| 325 | +1154 | ! |
- user_plot = user_text,+ tapply(ANL[[s_var]], list(ANL[[g_var]]), function(x) length(unique(x))) == 2 |
| 326 | -! | +||
| 1155 | +
- user_default = teal.widgets::ggplot2_args(theme = user_theme),+ ))), |
||
| 327 | +1156 | ! |
- module_plot = ggplot2_args+ "Please select stratify variable with 2 levels, per each group." |
| 328 | +1157 |
- )+ )) |
|
| 329 | +1158 |
- })+ } |
|
| 330 | +1159 | - - | -|
| 331 | -! | -
- output$ui_numeric_display <- renderUI({
+ } |
|
| 332 | -! | +||
| 1160 | +
- validation_checks()+ |
||
| 333 | +1161 | ! |
- dataname <- input$tabset_panel+ map_dist <- stats::setNames( |
| 334 | +1162 | ! |
- varname <- plot_var$variable[[dataname]]+ c("pnorm", "plnorm", "pgamma", "punif"),
|
| 335 | +1163 | ! |
- df <- data()[[dataname]]+ c("normal", "lognormal", "gamma", "unif")
|
| 336 | +1164 |
-
+ ) |
|
| 337 | +1165 | ! |
- numeric_ui <- tagList(+ sks_args <- list( |
| 338 | +1166 | ! |
- fluidRow(+ test = quote(stats::ks.test), |
| 339 | +1167 | ! |
- tags$div(+ args = bquote(append(list(.[[.(dist_var)]], .(map_dist[t_dist])), params)), |
| 340 | +1168 | ! |
- class = "col-md-4",+ groups = c(g_var, s_var)+ |
+
| 1169 | ++ |
+ ) |
|
| 341 | +1170 | ! |
- tags$br(),+ ssw_args <- list( |
| 342 | +1171 | ! |
- shinyWidgets::switchInput(+ test = quote(stats::shapiro.test), |
| 343 | +1172 | ! |
- inputId = session$ns("display_density"),
+ args = bquote(list(.[[.(dist_var)]])), |
| 344 | +1173 | ! |
- label = "Show density",+ groups = c(g_var, s_var)+ |
+
| 1174 | ++ |
+ ) |
|
| 345 | +1175 | ! |
- value = `if`(is.null(isolate(input$display_density)), TRUE, isolate(input$display_density)),+ mfil_args <- list( |
| 346 | +1176 | ! |
- width = "50%",+ test = quote(stats::fligner.test), |
| 347 | +1177 | ! |
- labelWidth = "100px",+ args = bquote(list(.[[.(dist_var)]], .[[.(s_var)]])), |
| 348 | +1178 | ! |
- handleWidth = "50px"+ groups = c(g_var) |
| 349 | +1179 |
- )+ ) |
|
| 350 | -+ | ||
| 1180 | +! |
- ),+ sad_args <- list( |
|
| 351 | +1181 | ! |
- tags$div(+ test = quote(goftest::ad.test), |
| 352 | +1182 | ! |
- class = "col-md-4",+ args = bquote(append(list(.[[.(dist_var)]], .(map_dist[t_dist])), params)), |
| 353 | +1183 | ! |
- tags$br(),+ groups = c(g_var, s_var)+ |
+
| 1184 | ++ |
+ ) |
|
| 354 | +1185 | ! |
- shinyWidgets::switchInput(+ scvm_args <- list( |
| 355 | +1186 | ! |
- inputId = session$ns("remove_outliers"),
+ test = quote(goftest::cvm.test), |
| 356 | +1187 | ! |
- label = "Remove outliers",+ args = bquote(append(list(.[[.(dist_var)]], .(map_dist[t_dist])), params)), |
| 357 | +1188 | ! |
- value = `if`(is.null(isolate(input$remove_outliers)), FALSE, isolate(input$remove_outliers)),+ groups = c(g_var, s_var)+ |
+
| 1189 | ++ |
+ ) |
|
| 358 | +1190 | ! |
- width = "50%",+ manov_args <- list( |
| 359 | +1191 | ! |
- labelWidth = "100px",+ test = quote(stats::aov), |
| 360 | +1192 | ! |
- handleWidth = "50px"+ args = bquote(list(stats::formula(.(dist_var_name) ~ .(s_var_name)), .)), |
| 361 | -+ | ||
| 1193 | +! |
- )+ groups = c(g_var) |
|
| 362 | +1194 |
- ),+ ) |
|
| 363 | +1195 | ! |
- tags$div(+ mt_args <- list( |
| 364 | +1196 | ! |
- class = "col-md-4",+ test = quote(stats::t.test), |
| 365 | +1197 | ! |
- uiOutput(session$ns("outlier_definition_slider_ui"))
+ args = bquote(unname(split(.[[.(dist_var)]], .[[.(s_var)]], drop = TRUE))), |
| 366 | -+ | ||
| 1198 | +! |
- )+ groups = c(g_var) |
|
| 367 | +1199 |
- ),+ ) |
|
| 368 | +1200 | ! |
- tags$div(+ mv_args <- list( |
| 369 | +1201 | ! |
- class = "ml-4",+ test = quote(stats::var.test), |
| 370 | +1202 | ! |
- uiOutput(session$ns("ui_density_help")),
+ args = bquote(unname(split(.[[.(dist_var)]], .[[.(s_var)]], drop = TRUE))), |
| 371 | +1203 | ! |
- uiOutput(session$ns("ui_outlier_help"))
+ groups = c(g_var) |
| 372 | +1204 |
) |
|
| 373 | -+ | ||
| 1205 | +! |
- )+ mks_args <- list( |
|
| 374 | -+ | ||
| 1206 | +! |
-
+ test = quote(stats::ks.test), |
|
| 375 | +1207 | ! |
- observeEvent(input$numeric_as_factor, ignoreInit = TRUE, {
+ args = bquote(unname(split(.[[.(dist_var)]], .[[.(s_var)]], drop = TRUE))), |
| 376 | +1208 | ! |
- varname_numeric_as_factor[[plot_var$variable[[dataname]]]] <- input$numeric_as_factor+ groups = c(g_var) |
| 377 | +1209 |
- })+ ) |
|
| 378 | +1210 | ||
| 379 | -! | -
- if (is.numeric(df[[varname]])) {
- |
- |
| 380 | +1211 | ! |
- unique_entries <- length(unique(df[[varname]]))+ tests_base <- switch(dist_tests, |
| 381 | +1212 | ! |
- if (unique_entries < .unique_records_for_factor && unique_entries > 0) {
+ "Kolmogorov-Smirnov (one-sample)" = sks_args, |
| 382 | +1213 | ! |
- list(+ "Shapiro-Wilk" = ssw_args, |
| 383 | +1214 | ! |
- checkboxInput(+ "Fligner-Killeen" = mfil_args, |
| 384 | +1215 | ! |
- session$ns("numeric_as_factor"),
+ "one-way ANOVA" = manov_args, |
| 385 | +1216 | ! |
- "Treat variable as factor",+ "t-test (two-samples, not paired)" = mt_args, |
| 386 | +1217 | ! |
- value = `if`(+ "F-test" = mv_args, |
| 387 | +1218 | ! |
- is.null(varname_numeric_as_factor[[varname]]),+ "Kolmogorov-Smirnov (two-samples)" = mks_args, |
| 388 | +1219 | ! |
- unique_entries < .unique_records_default_as_factor,+ "Anderson-Darling (one-sample)" = sad_args, |
| 389 | +1220 | ! |
- varname_numeric_as_factor[[varname]]+ "Cramer-von Mises (one-sample)" = scvm_args |
| 390 | +1221 |
- )+ ) |
|
| 391 | +1222 |
- ),+ |
|
| 392 | +1223 | ! |
- conditionalPanel("!input.numeric_as_factor", ns = session$ns, numeric_ui)
- |
-
| 393 | -- |
- )+ env <- list( |
|
| 394 | +1224 | ! |
- } else if (unique_entries > 0) {
+ t_test = t_dist, |
| 395 | +1225 | ! |
- numeric_ui- |
-
| 396 | -- |
- }- |
- |
| 397 | -- |
- } else {
+ dist_var = dist_var, |
|
| 398 | +1226 | ! |
- NULL- |
-
| 399 | -- |
- }+ g_var = g_var, |
|
| 400 | -+ | ||
| 1227 | +! |
- })+ s_var = s_var, |
|
| 401 | -+ | ||
| 1228 | +! |
-
+ args = tests_base$args, |
|
| 402 | +1229 | ! |
- output$ui_histogram_display <- renderUI({
+ groups = tests_base$groups, |
| 403 | +1230 | ! |
- validation_checks()+ test = tests_base$test, |
| 404 | +1231 | ! |
- dataname <- input$tabset_panel+ dist_var_name = dist_var_name, |
| 405 | +1232 | ! |
- varname <- plot_var$variable[[dataname]]+ g_var_name = g_var_name, |
| 406 | +1233 | ! |
- df <- data()[[dataname]]+ s_var_name = s_var_name |
| 407 | +1234 | ++ |
+ )+ |
+
| 1235 | |||
| 408 | +1236 | ! |
- numeric_ui <- tagList(fluidRow(+ qenv <- common_q()+ |
+
| 1237 | ++ | + | |
| 409 | +1238 | ! |
- tags$div(+ if (length(s_var) == 0 && length(g_var) == 0) {
|
| 410 | +1239 | ! |
- class = "col-md-4",+ qenv <- teal.code::eval_code( |
| 411 | +1240 | ! |
- shinyWidgets::switchInput(+ qenv, |
| 412 | +1241 | ! |
- inputId = session$ns("remove_NA_hist"),
+ substitute( |
| 413 | +1242 | ! |
- label = "Remove NA values",+ expr = {
|
| 414 | +1243 | ! |
- value = FALSE,+ test_table_data <- ANL %>% |
| 415 | +1244 | ! |
- width = "50%",+ dplyr::select(dist_var) %>% |
| 416 | +1245 | ! |
- labelWidth = "100px",+ with(., broom::glance(do.call(test, args))) %>% |
| 417 | +1246 | ! |
- handleWidth = "50px"+ dplyr::mutate_if(is.numeric, round, 3) |
| 418 | +1247 |
- )+ },+ |
+ |
| 1248 | +! | +
+ env = env |
|
| 419 | +1249 |
- )+ ) |
|
| 420 | +1250 |
- ))+ ) |
|
| 421 | +1251 |
-
+ } else {
|
|
| 422 | +1252 | ! |
- var <- df[[varname]]+ qenv <- teal.code::eval_code( |
| 423 | +1253 | ! |
- if (anyNA(var) && (is.factor(var) || is.character(var) || is.logical(var))) {
+ qenv, |
| 424 | +1254 | ! |
- groups <- unique(as.character(var))+ substitute( |
| 425 | +1255 | ! |
- len_groups <- length(groups)+ expr = {
|
| 426 | +1256 | ! |
- if (len_groups >= .unique_records_for_factor) {
+ test_table_data <- ANL %>% |
| 427 | +1257 | ! |
- NULL+ dplyr::select(dist_var, s_var, g_var) %>%+ |
+
| 1258 | +! | +
+ dplyr::group_by_at(dplyr::vars(dplyr::any_of(groups))) %>%+ |
+ |
| 1259 | +! | +
+ dplyr::do(tests = broom::glance(do.call(test, args))) %>%+ |
+ |
| 1260 | +! | +
+ tidyr::unnest(tests) %>%+ |
+ |
| 1261 | +! | +
+ dplyr::mutate_if(is.numeric, round, 3) |
|
| 428 | +1262 |
- } else {
+ }, |
|
| 429 | +1263 | ! |
- numeric_ui+ env = env |
| 430 | +1264 |
- }+ ) |
|
| 431 | +1265 |
- } else {
+ ) |
|
| 432 | -! | +||
| 1266 | +
- NULL+ } |
||
| 433 | +1267 |
} |
|
| 434 | +1268 |
- })+ ) |
|
| 435 | +1269 | ||
| 436 | -! | -
- output$outlier_definition_slider_ui <- renderUI({
- |
- |
| 437 | -! | +||
| 1270 | +
- req(input$remove_outliers)+ # outputs ---- |
||
| 438 | -! | +||
| 1271 | +
- sliderInput(+ ## building main qenv |
||
| 439 | +1272 | ! |
- inputId = session$ns("outlier_definition_slider"),
+ output_common_q <- reactive({
|
| 440 | -! | +||
| 1273 | +
- tags$div(+ # wrapped in if since could lead into validate error - we do want to continue |
||
| 441 | +1274 | ! |
- class = "teal-tooltip",+ test_q_out <- try(test_q(), silent = TRUE) |
| 442 | +1275 | ! |
- tagList(+ if (!inherits(test_q_out, c("try-error", "error"))) {
|
| 443 | +1276 | ! |
- "Outlier definition:",+ c( |
| 444 | +1277 | ! |
- icon("circle-info"),
+ common_q(), |
| 445 | +1278 | ! |
- tags$span(+ within(test_q_out, {
|
| 446 | +1279 | ! |
- class = "tooltiptext",+ test_table <- DT::datatable( |
| 447 | +1280 | ! |
- paste(+ test_table_data, |
| 448 | +1281 | ! |
- "Use the slider to choose the cut-off value to define outliers; the larger the value the",+ options = list(scrollX = TRUE), |
| 449 | +1282 | ! |
- "further below Q1/above Q3 points have to be in order to be classed as outliers"+ rownames = FALSE |
| 450 | +1283 |
- )+ ) |
|
| 451 | +1284 |
- )+ }) |
|
| 452 | +1285 |
- )+ ) |
|
| 453 | +1286 |
- ),- |
- |
| 454 | -! | -
- min = 1,- |
- |
| 455 | -! | -
- max = 5,- |
- |
| 456 | -! | -
- value = 3,+ } else {
|
|
| 457 | +1287 | ! |
- step = 0.5+ within(common_q(), test_table <- NULL) |
| 458 | +1288 |
- )+ } |
|
| 459 | +1289 |
}) |
|
| 460 | +1290 | ||
| 461 | +1291 | ! |
- output$ui_density_help <- renderUI({
+ output_dist_q <- reactive(c(output_common_q(), req(dist_q()))) |
| 462 | +1292 | ! |
- req(is.logical(input$display_density))+ output_qq_q <- reactive(c(output_common_q(), req(qq_q()))) |
| 463 | -! | +||
| 1293 | +
- if (input$display_density) {
+
|
||
| 464 | +1294 | ! |
- tags$small(helpText(paste(+ decorated_output_dist_q <- srv_decorate_teal_data( |
| 465 | +1295 | ! |
- "Kernel density estimation with gaussian kernel",+ "d_density", |
| 466 | +1296 | ! |
- "and bandwidth function bw.nrd0 (R default)"- |
-
| 467 | -- |
- )))- |
- |
| 468 | -- |
- } else {
+ data = output_dist_q, |
|
| 469 | +1297 | ! |
- NULL+ decorators = select_decorators(decorators, "histogram_plot"), |
| 470 | -+ | ||
| 1298 | +! |
- }+ expr = print(histogram_plot) |
|
| 471 | +1299 |
- })+ ) |
|
| 472 | +1300 | ||
| 473 | +1301 | ! |
- output$ui_outlier_help <- renderUI({
+ decorated_output_qq_q <- srv_decorate_teal_data( |
| 474 | +1302 | ! |
- req(is.logical(input$remove_outliers), input$outlier_definition_slider)+ "d_qq", |
| 475 | +1303 | ! |
- if (input$remove_outliers) {
+ data = output_qq_q, |
| 476 | +1304 | ! |
- tags$small(+ decorators = select_decorators(decorators, "qq_plot"), |
| 477 | +1305 | ! |
- helpText(+ expr = print(qq_plot)+ |
+
| 1306 | ++ |
+ )+ |
+ |
| 1307 | ++ | + | |
| 478 | +1308 | ! |
- withMathJax(paste0(+ decorated_output_summary_q <- srv_decorate_teal_data( |
| 479 | +1309 | ! |
- "Outlier data points (\\( X \\lt Q1 - ", input$outlier_definition_slider, "\\times IQR \\) or+ "d_summary", |
| 480 | +1310 | ! |
- \\(Q3 + ", input$outlier_definition_slider, "\\times IQR \\lt X\\))+ data = output_common_q, |
| 481 | +1311 | ! |
- have not been displayed on the graph and will not be used for any kernel density estimations, ",+ decorators = select_decorators(decorators, "summary_table"), |
| 482 | +1312 | ! |
- "although their values remain in the statisics table below."+ expr = summary_table |
| 483 | +1313 |
- ))+ ) |
|
| 484 | +1314 |
- )+ |
|
| 485 | -+ | ||
| 1315 | +! |
- )+ decorated_output_test_q <- srv_decorate_teal_data( |
|
| 486 | -+ | ||
| 1316 | +! |
- } else {
+ "d_test", |
|
| 487 | +1317 | ! |
- NULL+ data = output_common_q, |
| 488 | -+ | ||
| 1318 | +! |
- }+ decorators = select_decorators(decorators, "test_table"), |
|
| 489 | -+ | ||
| 1319 | +! |
- })+ expr = test_table |
|
| 490 | +1320 |
-
+ ) |
|
| 491 | +1321 | ||
| 492 | -! | -
- variable_plot_r <- reactive({
- |
- |
| 493 | +1322 | ! |
- display_density <- `if`(is.null(input$display_density), FALSE, input$display_density)+ decorated_output_q <- reactive({
|
| 494 | +1323 | ! |
- remove_outliers <- `if`(is.null(input$remove_outliers), FALSE, input$remove_outliers)- |
-
| 495 | -- |
-
+ tab <- req(input$tabs) # tab is NULL upon app launch, hence will crash without this statement |
|
| 496 | +1324 | ! |
- if (remove_outliers) {
+ test_q_out <- try(test_q(), silent = TRUE) |
| 497 | +1325 | ! |
- req(input$outlier_definition_slider)+ decorated_test_q_out <- if (inherits(test_q_out, c("try-error", "error"))) {
|
| 498 | +1326 | ! |
- outlier_definition <- as.numeric(input$outlier_definition_slider)+ teal.code::qenv() |
| 499 | +1327 |
} else {
|
|
| 500 | +1328 | ! |
- outlier_definition <- 0+ decorated_output_test_q() |
| 501 | +1329 |
} |
|
| 502 | +1330 | ||
| 503 | +1331 | ! |
- plot_var_summary(+ out_q <- switch(tab, |
| 504 | +1332 | ! |
- var = plotted_data()$data,+ Histogram = decorated_output_dist_q(), |
| 505 | +1333 | ! |
- var_lab = plotted_data()$var_description,+ QQplot = decorated_output_qq_q() |
| 506 | -! | +||
| 1334 | +
- wrap_character = 15,+ ) |
||
| 507 | +1335 | ! |
- numeric_as_factor = treat_numeric_as_factor(),+ c(out_q, decorated_output_summary_q(), decorated_test_q_out)+ |
+
| 1336 | ++ |
+ })+ |
+ |
| 1337 | ++ | + | |
| 508 | +1338 | ! |
- remove_NA_hist = input$remove_NA_hist,+ dist_r <- reactive(req(decorated_output_dist_q())[["histogram_plot"]])+ |
+
| 1339 | ++ | + | |
| 509 | +1340 | ! |
- display_density = display_density,+ qq_r <- reactive(req(decorated_output_qq_q())[["qq_plot"]])+ |
+
| 1341 | ++ | + | |
| 510 | +1342 | ! |
- outlier_definition = outlier_definition,+ output$summary_table <- DT::renderDataTable(expr = decorated_output_summary_q()[["summary_table"]])+ |
+
| 1343 | ++ | + | |
| 511 | +1344 | ! |
- records_for_factor = .unique_records_for_factor,+ tests_r <- reactive({
|
| 512 | +1345 | ! |
- ggplot2_args = all_ggplot2_args()+ req(iv_r()$is_valid()) |
| 513 | -+ | ||
| 1346 | +! |
- )+ teal::validate_inputs(iv_r_dist())+ |
+ |
| 1347 | +! | +
+ req(test_q()) # Ensure original errors are displayed+ |
+ |
| 1348 | +! | +
+ decorated_output_test_q()[["test_table"]] |
|
| 514 | +1349 |
}) |
|
| 515 | +1350 | ||
| 516 | +1351 | ! |
- pws <- teal.widgets::plot_with_settings_srv(+ pws1 <- teal.widgets::plot_with_settings_srv( |
| 517 | +1352 | ! |
- id = "variable_plot",+ id = "hist_plot", |
| 518 | +1353 | ! |
- plot_r = variable_plot_r,+ plot_r = dist_r, |
| 519 | +1354 | ! |
- height = c(500, 200, 2000)+ height = plot_height,+ |
+
| 1355 | +! | +
+ width = plot_width,+ |
+ |
| 1356 | +! | +
+ brushing = FALSE |
|
| 520 | +1357 |
) |
|
| 521 | +1358 | ||
| 522 | +1359 | ! |
- output$variable_summary_table <- DT::renderDataTable({
+ pws2 <- teal.widgets::plot_with_settings_srv( |
| 523 | +1360 | ! |
- var_summary_table(+ id = "qq_plot", |
| 524 | +1361 | ! |
- plotted_data()$data,+ plot_r = qq_r, |
| 525 | +1362 | ! |
- treat_numeric_as_factor(),+ height = plot_height, |
| 526 | +1363 | ! |
- input$variable_summary_table_rows,+ width = plot_width, |
| 527 | +1364 | ! |
- if (!is.null(input$remove_outliers) && input$remove_outliers) {
+ brushing = FALSE+ |
+
| 1365 | ++ |
+ )+ |
+ |
| 1366 | ++ | + | |
| 528 | +1367 | ! |
- req(input$outlier_definition_slider)+ output$t_stats <- DT::renderDataTable( |
| 529 | +1368 | ! |
- as.numeric(input$outlier_definition_slider)+ expr = tests_r() |
| 530 | +1369 |
- } else {
+ )+ |
+ |
| 1370 | ++ | + | |
| 531 | +1371 | ! |
- 0+ teal.widgets::verbatim_popup_srv( |
| 532 | -+ | ||
| 1372 | +! |
- }+ id = "rcode", |
|
| 533 | -+ | ||
| 1373 | +! |
- )+ verbatim_content = reactive(teal.code::get_code(req(decorated_output_q()))),+ |
+ |
| 1374 | +! | +
+ title = "R Code for distribution" |
|
| 534 | +1375 |
- })+ ) |
|
| 535 | +1376 | ||
| 536 | +1377 |
### REPORTER |
|
| 537 | +1378 | ! |
if (with_reporter) {
|
| 538 | +1379 | ! |
- card_fun <- function(comment) {
+ card_fun <- function(comment, label) {
|
| 539 | +1380 | ! |
- card <- teal::TealReportCard$new()+ card <- teal::report_card_template( |
| 540 | +1381 | ! |
- card$set_name("Variable Browser Plot")
+ title = "Distribution Plot", |
| 541 | +1382 | ! |
- card$append_text("Variable Browser Plot", "header2")
+ label = label, |
| 542 | +1383 | ! |
- if (with_filter) card$append_fs(filter_panel_api$get_filter_state())+ with_filter = with_filter, |
| 543 | +1384 | +! | +
+ filter_panel_api = filter_panel_api+ |
+
| 1385 | ++ |
+ )+ |
+ |
| 1386 | ! |
card$append_text("Plot", "header3")
|
|
| 544 | +1387 | ! |
- card$append_plot(variable_plot_r(), dim = pws$dim())+ if (input$tabs == "Histogram") {
|
| 545 | +1388 | ! |
- if (!comment == "") {
+ card$append_plot(dist_r(), dim = pws1$dim()) |
| 546 | +1389 | ! |
- card$append_text("Comment", "header3")
+ } else if (input$tabs == "QQplot") {
|
| 547 | +1390 | ! |
- card$append_text(comment)+ card$append_plot(qq_r(), dim = pws2$dim()) |
| 548 | +1391 |
} |
|
| 549 | +1392 | ! |
- card+ card$append_text("Statistics table", "header3")
|
| 550 | +1393 |
- }+ |
|
| 551 | +1394 | ! |
- teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
+ card$append_table(common_q()[["summary_table"]]) |
| 552 | -+ | ||
| 1395 | +! |
- }+ tests_error <- tryCatch(expr = tests_r(), error = function(e) "error") |
|
| 553 | -+ | ||
| 1396 | +! |
- ###+ if (inherits(tests_error, "data.frame")) {
|
|
| 554 | -+ | ||
| 1397 | +! |
- })+ card$append_text("Tests table", "header3")
+ |
+ |
| 1398 | +! | +
+ card$append_table(tests_r()) |
|
| 555 | +1399 |
- }+ } |
|
| 556 | +1400 | ||
| 557 | -+ | ||
| 1401 | +! |
- #' Summarize NAs.+ if (!comment == "") {
|
|
| 558 | -+ | ||
| 1402 | +! |
- #'+ card$append_text("Comment", "header3")
|
|
| 559 | -+ | ||
| 1403 | +! |
- #' Summarizes occurrence of missing values in vector.+ card$append_text(comment) |
|
| 560 | +1404 |
- #' @param x vector of any type and length+ } |
|
| 561 | -+ | ||
| 1405 | +! |
- #' @return Character string describing `NA` occurrence.+ card$append_src(teal.code::get_code(req(decorated_output_q()))) |
|
| 562 | -+ | ||
| 1406 | +! |
- #' @keywords internal+ card |
|
| 563 | +1407 |
- var_missings_info <- function(x) {
+ } |
|
| 564 | +1408 | ! |
- sprintf("%s [%s%%]", sum(is.na(x)), round(mean(is.na(x) * 100), 2))
+ teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
|
| 565 | +1409 |
- }+ } |
|
| 566 | +1410 |
-
+ ### |
|
| 567 | +1411 |
- #' Summarizes variable+ }) |
|
| 568 | +1412 |
- #'+ } |
| 569 | +1 |
- #' Creates html summary with statistics relevant to data type. For numeric values it returns central+ #' `teal` module: Scatterplot |
|
| 570 | +2 |
- #' tendency measures, for factor returns level counts, for Date date range, for other just+ #' |
|
| 571 | +3 |
- #' number of levels.+ #' Generates a customizable scatterplot using `ggplot2`. |
|
| 572 | +4 |
- #'+ #' This module allows users to select variables for the x and y axes, |
|
| 573 | +5 |
- #' @param x vector of any type+ #' color and size encodings, faceting options, and more. It supports log transformations, |
|
| 574 | +6 |
- #' @param numeric_as_factor `logical` should the numeric variable be treated as a factor+ #' trend line additions, and dynamic adjustments of point opacity and size through UI controls. |
|
| 575 | +7 |
- #' @param dt_rows `numeric` current/latest `DT` page length+ #' |
|
| 576 | +8 |
- #' @param outlier_definition If 0 no outliers are removed, otherwise+ #' @note For more examples, please see the vignette "Using scatterplot" via |
|
| 577 | +9 |
- #' outliers (those more than `outlier_definition*IQR below/above Q1/Q3` be removed)+ #' `vignette("using-scatterplot", package = "teal.modules.general")`.
|
|
| 578 | +10 |
- #' @return text with simple statistics.+ #' |
|
| 579 | +11 |
- #' @keywords internal+ #' @inheritParams teal::module |
|
| 580 | +12 |
- var_summary_table <- function(x, numeric_as_factor, dt_rows, outlier_definition) {
+ #' @inheritParams shared_params |
|
| 581 | -! | +||
| 13 | +
- if (is.null(dt_rows)) {
+ #' @param x (`data_extract_spec` or `list` of multiple `data_extract_spec`) Specifies |
||
| 582 | -! | +||
| 14 | +
- dt_rows <- 10+ #' variable names selected to plot along the x-axis by default. |
||
| 583 | +15 |
- }+ #' @param y (`data_extract_spec` or `list` of multiple `data_extract_spec`) Specifies |
|
| 584 | -! | +||
| 16 | +
- if (is.numeric(x) && !numeric_as_factor) {
+ #' variable names selected to plot along the y-axis by default. |
||
| 585 | -! | +||
| 17 | +
- req(!any(is.infinite(x)))+ #' @param color_by (`data_extract_spec` or `list` of multiple `data_extract_spec`) optional, |
||
| 586 | +18 |
-
+ #' defines the color encoding. If `NULL` then no color encoding option will be displayed. |
|
| 587 | -! | +||
| 19 | +
- x <- remove_outliers_from(x, outlier_definition)+ #' @param size_by (`data_extract_spec` or `list` of multiple `data_extract_spec`) optional, |
||
| 588 | +20 |
-
+ #' defines the point size encoding. If `NULL` then no size encoding option will be displayed. |
|
| 589 | -! | +||
| 21 | +
- qvals <- round(stats::quantile(x, na.rm = TRUE, probs = c(0.25, 0.5, 0.75), type = 2), 2)+ #' @param row_facet (`data_extract_spec` or `list` of multiple `data_extract_spec`) optional, |
||
| 590 | +22 |
- # classical central tendency measures+ #' specifies the variable(s) for faceting rows. |
|
| 591 | +23 |
-
+ #' @param col_facet (`data_extract_spec` or `list` of multiple `data_extract_spec`) optional, |
|
| 592 | -! | -
- summary <-- |
- |
| 593 | -! | +||
| 24 | +
- data.frame(+ #' specifies the variable(s) for faceting columns. |
||
| 594 | -! | +||
| 25 | +
- Statistic = c("min", "Q1", "median", "mean", "Q3", "max", "sd", "n"),
+ #' @param shape (`character`) optional, character vector with the names of the |
||
| 595 | -! | +||
| 26 | +
- Value = c(+ #' shape, e.g. `c("triangle", "square", "circle")`. It defaults to `shape_names`. This is a complete list from
|
||
| 596 | -! | +||
| 27 | +
- round(min(x, na.rm = TRUE), 2),+ #' `vignette("ggplot2-specs", package="ggplot2")`.
|
||
| 597 | -! | +||
| 28 | +
- qvals[1],+ #' @param max_deg (`integer`) optional, maximum degree for the polynomial trend line. Must not be less than 1. |
||
| 598 | -! | +||
| 29 | +
- qvals[2],+ #' @param table_dec (`integer`) optional, number of decimal places used to round numeric values in the table. |
||
| 599 | -! | +||
| 30 | +
- round(mean(x, na.rm = TRUE), 2),+ #' @param decorators `r roxygen_decorators_param("tm_g_scatterplot")`
|
||
| 600 | -! | +||
| 31 | +
- qvals[3],+ #' |
||
| 601 | -! | +||
| 32 | +
- round(max(x, na.rm = TRUE), 2),+ #' @inherit shared_params return |
||
| 602 | -! | +||
| 33 | +
- round(stats::sd(x, na.rm = TRUE), 2),+ #' |
||
| 603 | -! | +||
| 34 | +
- length(x[!is.na(x)])+ #' @section Decorating `tm_g_scatterplot`: |
||
| 604 | +35 |
- )+ #' |
|
| 605 | +36 |
- )+ #' This module generates the following objects, which can be modified in place using decorators: |
|
| 606 | +37 |
-
+ #' - `plot` (`ggplot2`) |
|
| 607 | -! | +||
| 38 | +
- DT::datatable(summary, rownames = FALSE, options = list(dom = "<t>", pageLength = dt_rows))+ #' |
||
| 608 | -! | +||
| 39 | +
- } else if (is.factor(x) || is.character(x) || (is.numeric(x) && numeric_as_factor) || is.logical(x)) {
+ #' For additional details and examples of decorators, refer to the vignette |
||
| 609 | +40 |
- # make sure factor is ordered numeric+ #' `vignette("decorate-modules-output", package = "teal")` or the [`teal::teal_transform_module()`] documentation.
|
|
| 610 | -! | +||
| 41 | +
- if (is.numeric(x)) {
+ #' |
||
| 611 | -! | +||
| 42 | +
- x <- factor(x, levels = sort(unique(x)))+ #' |
||
| 612 | +43 |
- }+ #' @examplesShinylive |
|
| 613 | +44 |
-
+ #' library(teal.modules.general) |
|
| 614 | -! | +||
| 45 | +
- level_counts <- table(x)+ #' interactive <- function() TRUE |
||
| 615 | -! | +||
| 46 | +
- max_levels_signif <- nchar(level_counts)+ #' {{ next_example }}
|
||
| 616 | +47 |
-
+ # nolint start: line_length_linter. |
|
| 617 | -! | +||
| 48 | +
- if (!all(is.na(x))) {
+ #' @examplesIf require("ggpmisc", quietly = TRUE) && require("ggExtra", quietly = TRUE) && require("colourpicker", quietly = TRUE)
|
||
| 618 | -! | +||
| 49 | +
- levels <- names(level_counts)+ # nolint end: line_length_linter. |
||
| 619 | -! | +||
| 50 | +
- counts <- sprintf(+ #' # general data example |
||
| 620 | -! | +||
| 51 | +
- "%s [%.2f%%]",+ #' data <- teal_data() |
||
| 621 | -! | +||
| 52 | +
- format(level_counts, width = max_levels_signif), prop.table(level_counts) * 100+ #' data <- within(data, {
|
||
| 622 | +53 |
- )+ #' require(nestcolor) |
|
| 623 | +54 |
- } else {
+ #' CO2 <- CO2 |
|
| 624 | -! | +||
| 55 | +
- levels <- character(0)+ #' }) |
||
| 625 | -! | +||
| 56 | +
- counts <- numeric(0)+ #' |
||
| 626 | +57 |
- }+ #' app <- init( |
|
| 627 | +58 |
-
+ #' data = data, |
|
| 628 | -! | +||
| 59 | +
- summary <- data.frame(+ #' modules = modules( |
||
| 629 | -! | +||
| 60 | +
- Level = levels,+ #' tm_g_scatterplot( |
||
| 630 | -! | +||
| 61 | +
- Count = counts,+ #' label = "Scatterplot Choices", |
||
| 631 | -! | +||
| 62 | +
- stringsAsFactors = FALSE+ #' x = data_extract_spec( |
||
| 632 | +63 |
- )+ #' dataname = "CO2", |
|
| 633 | +64 |
-
+ #' select = select_spec( |
|
| 634 | +65 |
- # sort the dataset in decreasing order of counts (needed as character variables default to alphabetical)+ #' label = "Select variable:", |
|
| 635 | -! | +||
| 66 | +
- summary <- summary[order(summary$Count, decreasing = TRUE), ]+ #' choices = variable_choices(data[["CO2"]], c("conc", "uptake")),
|
||
| 636 | +67 |
-
+ #' selected = "conc", |
|
| 637 | -! | +||
| 68 | +
- dom_opts <- if (nrow(summary) <= 10) {
+ #' multiple = FALSE, |
||
| 638 | -! | +||
| 69 | +
- "<t>"+ #' fixed = FALSE |
||
| 639 | +70 |
- } else {
+ #' ) |
|
| 640 | -! | +||
| 71 | +
- "<lf<t>ip>"+ #' ), |
||
| 641 | +72 |
- }+ #' y = data_extract_spec( |
|
| 642 | -! | +||
| 73 | +
- DT::datatable(summary, rownames = FALSE, options = list(dom = dom_opts, pageLength = dt_rows))+ #' dataname = "CO2", |
||
| 643 | -! | +||
| 74 | +
- } else if (inherits(x, "Date") || inherits(x, "POSIXct") || inherits(x, "POSIXlt")) {
+ #' select = select_spec( |
||
| 644 | -! | +||
| 75 | +
- summary <-+ #' label = "Select variable:", |
||
| 645 | -! | +||
| 76 | +
- data.frame(+ #' choices = variable_choices(data[["CO2"]], c("conc", "uptake")),
|
||
| 646 | -! | +||
| 77 | +
- Statistic = c("min", "median", "max"),
+ #' selected = "uptake", |
||
| 647 | -! | +||
| 78 | +
- Value = c(+ #' multiple = FALSE, |
||
| 648 | -! | +||
| 79 | +
- min(x, na.rm = TRUE),+ #' fixed = FALSE |
||
| 649 | -! | +||
| 80 | +
- stats::median(x, na.rm = TRUE),+ #' ) |
||
| 650 | -! | +||
| 81 | +
- max(x, na.rm = TRUE)+ #' ), |
||
| 651 | +82 |
- )+ #' color_by = data_extract_spec( |
|
| 652 | +83 |
- )+ #' dataname = "CO2", |
|
| 653 | -! | +||
| 84 | +
- DT::datatable(summary, rownames = FALSE, options = list(dom = "<t>", pageLength = dt_rows))+ #' select = select_spec( |
||
| 654 | +85 |
- } else {
+ #' label = "Select variable:", |
|
| 655 | -! | +||
| 86 | +
- NULL+ #' choices = variable_choices( |
||
| 656 | +87 |
- }+ #' data[["CO2"]], |
|
| 657 | +88 |
- }+ #' c("Plant", "Type", "Treatment", "conc", "uptake")
|
|
| 658 | +89 |
-
+ #' ), |
|
| 659 | +90 |
- #' Plot variable+ #' selected = NULL, |
|
| 660 | +91 |
- #'+ #' multiple = FALSE, |
|
| 661 | +92 |
- #' Creates summary plot with statistics relevant to data type.+ #' fixed = FALSE |
|
| 662 | +93 |
- #'+ #' ) |
|
| 663 | +94 |
- #' @inheritParams shared_params+ #' ), |
|
| 664 | +95 |
- #' @param var vector of any type to be plotted. For numeric variables it produces histogram with+ #' size_by = data_extract_spec( |
|
| 665 | +96 |
- #' density line, for factors it creates frequency plot+ #' dataname = "CO2", |
|
| 666 | +97 |
- #' @param var_lab text describing selected variable to be displayed on the plot+ #' select = select_spec( |
|
| 667 | +98 |
- #' @param wrap_character (`numeric`) number of characters at which to wrap text values of `var`+ #' label = "Select variable:", |
|
| 668 | +99 |
- #' @param numeric_as_factor (`logical`) should the numeric variable be treated as a factor+ #' choices = variable_choices(data[["CO2"]], c("conc", "uptake")),
|
|
| 669 | +100 |
- #' @param display_density (`logical`) should density estimation be displayed for numeric values+ #' selected = "uptake", |
|
| 670 | +101 |
- #' @param remove_NA_hist (`logical`) should `NA` values be removed for histogram of factor like variables+ #' multiple = FALSE, |
|
| 671 | +102 |
- #' @param outlier_definition if 0 no outliers are removed, otherwise+ #' fixed = FALSE |
|
| 672 | +103 |
- #' outliers (those more than outlier_definition*IQR below/above Q1/Q3 be removed)+ #' ) |
|
| 673 | +104 |
- #' @param records_for_factor (`numeric`) if the number of factor levels is >= than this value then+ #' ), |
|
| 674 | +105 |
- #' a graph of the factors isn't shown, only a list of values+ #' row_facet = data_extract_spec( |
|
| 675 | +106 |
- #'+ #' dataname = "CO2", |
|
| 676 | +107 |
- #' @return plot+ #' select = select_spec( |
|
| 677 | +108 |
- #' @keywords internal+ #' label = "Select variable:", |
|
| 678 | +109 |
- plot_var_summary <- function(var,+ #' choices = variable_choices(data[["CO2"]], c("Plant", "Type", "Treatment")),
|
|
| 679 | +110 |
- var_lab,+ #' selected = NULL, |
|
| 680 | +111 |
- wrap_character = NULL,+ #' multiple = FALSE, |
|
| 681 | +112 |
- numeric_as_factor,+ #' fixed = FALSE |
|
| 682 | +113 |
- display_density = is.numeric(var),+ #' ) |
|
| 683 | +114 |
- remove_NA_hist = FALSE, # nolint: object_name.+ #' ), |
|
| 684 | +115 |
- outlier_definition,+ #' col_facet = data_extract_spec( |
|
| 685 | +116 |
- records_for_factor,+ #' dataname = "CO2", |
|
| 686 | +117 |
- ggplot2_args) {
+ #' select = select_spec( |
|
| 687 | -! | +||
| 118 | +
- checkmate::assert_character(var_lab)+ #' label = "Select variable:", |
||
| 688 | -! | +||
| 119 | +
- checkmate::assert_numeric(wrap_character, null.ok = TRUE)+ #' choices = variable_choices(data[["CO2"]], c("Plant", "Type", "Treatment")),
|
||
| 689 | -! | +||
| 120 | +
- checkmate::assert_flag(numeric_as_factor)+ #' selected = NULL, |
||
| 690 | -! | +||
| 121 | +
- checkmate::assert_flag(display_density)+ #' multiple = FALSE, |
||
| 691 | -! | +||
| 122 | +
- checkmate::assert_logical(remove_NA_hist, null.ok = TRUE)+ #' fixed = FALSE |
||
| 692 | -! | +||
| 123 | +
- checkmate::assert_number(outlier_definition, lower = 0, finite = TRUE)+ #' ) |
||
| 693 | -! | +||
| 124 | +
- checkmate::assert_integerish(records_for_factor, lower = 0, len = 1, any.missing = FALSE)+ #' ) |
||
| 694 | -! | +||
| 125 | +
- checkmate::assert_class(ggplot2_args, "ggplot2_args")+ #' ) |
||
| 695 | +126 |
-
+ #' ) |
|
| 696 | -! | +||
| 127 | +
- grid::grid.newpage()+ #' ) |
||
| 697 | +128 |
-
+ #' if (interactive()) {
|
|
| 698 | -! | +||
| 129 | +
- plot_main <- if (is.factor(var) || is.character(var) || is.logical(var)) {
+ #' shinyApp(app$ui, app$server) |
||
| 699 | -! | +||
| 130 | +
- groups <- unique(as.character(var))+ #' } |
||
| 700 | -! | +||
| 131 | +
- len_groups <- length(groups)+ #' |
||
| 701 | -! | +||
| 132 | +
- if (len_groups >= records_for_factor) {
+ #' @examplesShinylive |
||
| 702 | -! | +||
| 133 | +
- grid::textGrob(+ #' library(teal.modules.general) |
||
| 703 | -! | +||
| 134 | +
- sprintf(+ #' interactive <- function() TRUE |
||
| 704 | -! | +||
| 135 | +
- "%s unique values\n%s:\n %s\n ...\n %s",+ #' {{ next_example }}
|
||
| 705 | -! | +||
| 136 | +
- len_groups,+ # nolint start: line_length_linter. |
||
| 706 | -! | +||
| 137 | +
- var_lab,+ #' @examplesIf require("ggpmisc", quietly = TRUE) && require("ggExtra", quietly = TRUE) && require("colourpicker", quietly = TRUE)
|
||
| 707 | -! | +||
| 138 | +
- paste(utils::head(groups), collapse = ",\n "),+ # nolint end: line_length_linter. |
||
| 708 | -! | +||
| 139 | +
- paste(utils::tail(groups), collapse = ",\n ")+ #' # CDISC data example |
||
| 709 | +140 |
- ),+ #' data <- teal_data() |
|
| 710 | -! | +||
| 141 | +
- x = grid::unit(1, "line"),+ #' data <- within(data, {
|
||
| 711 | -! | +||
| 142 | +
- y = grid::unit(1, "npc") - grid::unit(1, "line"),+ #' require(nestcolor) |
||
| 712 | -! | +||
| 143 | +
- just = c("left", "top")
+ #' ADSL <- teal.data::rADSL |
||
| 713 | +144 |
- )+ #' }) |
|
| 714 | +145 |
- } else {
+ #' join_keys(data) <- default_cdisc_join_keys[names(data)] |
|
| 715 | -! | +||
| 146 | +
- if (!is.null(wrap_character)) {
+ #' |
||
| 716 | -! | +||
| 147 | +
- var <- stringr::str_wrap(var, width = wrap_character)+ #' app <- init( |
||
| 717 | +148 |
- }+ #' data = data, |
|
| 718 | -! | +||
| 149 | +
- var <- if (isTRUE(remove_NA_hist)) as.vector(stats::na.omit(var)) else var+ #' modules = modules( |
||
| 719 | -! | +||
| 150 | +
- ggplot(data.frame(var), aes(x = forcats::fct_infreq(as.factor(var)))) ++ #' tm_g_scatterplot( |
||
| 720 | -! | +||
| 151 | +
- geom_bar(+ #' label = "Scatterplot Choices", |
||
| 721 | -! | +||
| 152 | +
- stat = "count", aes(fill = ifelse(is.na(var), "withcolor", "")), show.legend = FALSE+ #' x = data_extract_spec( |
||
| 722 | +153 |
- ) ++ #' dataname = "ADSL", |
|
| 723 | -! | +||
| 154 | +
- scale_fill_manual(values = c("gray50", "tan"))
+ #' select = select_spec( |
||
| 724 | +155 |
- }+ #' label = "Select variable:", |
|
| 725 | -! | +||
| 156 | +
- } else if (is.numeric(var)) {
+ #' choices = variable_choices(data[["ADSL"]], c("AGE", "BMRKR1", "BMRKR2")),
|
||
| 726 | -! | +||
| 157 | +
- validate(need(any(!is.na(var)), "No data left to visualize."))+ #' selected = "AGE", |
||
| 727 | +158 |
-
+ #' multiple = FALSE, |
|
| 728 | +159 |
- # Filter out NA+ #' fixed = FALSE |
|
| 729 | -! | +||
| 160 | +
- var <- var[which(!is.na(var))]+ #' ) |
||
| 730 | +161 |
-
+ #' ), |
|
| 731 | -! | +||
| 162 | +
- validate(need(!any(is.infinite(var)), "Cannot display graph when data includes infinite values"))+ #' y = data_extract_spec( |
||
| 732 | +163 |
-
+ #' dataname = "ADSL", |
|
| 733 | -! | +||
| 164 | +
- if (numeric_as_factor) {
+ #' select = select_spec( |
||
| 734 | -! | +||
| 165 | +
- var <- factor(var)+ #' label = "Select variable:", |
||
| 735 | -! | +||
| 166 | +
- ggplot(NULL, aes(x = var)) ++ #' choices = variable_choices(data[["ADSL"]], c("AGE", "BMRKR1", "BMRKR2")),
|
||
| 736 | -! | +||
| 167 | +
- geom_histogram(stat = "count")+ #' selected = "BMRKR1", |
||
| 737 | +168 |
- } else {
+ #' multiple = FALSE, |
|
| 738 | +169 |
- # remove outliers+ #' fixed = FALSE |
|
| 739 | -! | +||
| 170 | +
- if (outlier_definition != 0) {
+ #' ) |
||
| 740 | -! | +||
| 171 | +
- number_records <- length(var)+ #' ), |
||
| 741 | -! | +||
| 172 | +
- var <- remove_outliers_from(var, outlier_definition)+ #' color_by = data_extract_spec( |
||
| 742 | -! | +||
| 173 | +
- number_outliers <- number_records - length(var)+ #' dataname = "ADSL", |
||
| 743 | -! | +||
| 174 | +
- outlier_text <- paste0(+ #' select = select_spec( |
||
| 744 | -! | +||
| 175 | +
- number_outliers, " outliers (",
+ #' label = "Select variable:", |
||
| 745 | -! | +||
| 176 | +
- round(number_outliers / number_records * 100, 2),+ #' choices = variable_choices( |
||
| 746 | -! | +||
| 177 | +
- "% of non-missing records) not shown"+ #' data[["ADSL"]], |
||
| 747 | +178 |
- )+ #' c("AGE", "BMRKR1", "BMRKR2", "RACE", "REGION1")
|
|
| 748 | -! | +||
| 179 | +
- validate(need(+ #' ), |
||
| 749 | -! | +||
| 180 | +
- length(var) > 1,+ #' selected = NULL, |
||
| 750 | -! | +||
| 181 | +
- "At least two data points must remain after removing outliers for this graph to be displayed"+ #' multiple = FALSE, |
||
| 751 | +182 |
- ))+ #' fixed = FALSE |
|
| 752 | +183 |
- }+ #' ) |
|
| 753 | +184 |
- ## histogram+ #' ), |
|
| 754 | -! | +||
| 185 | +
- binwidth <- get_bin_width(var)+ #' size_by = data_extract_spec( |
||
| 755 | -! | +||
| 186 | +
- p <- ggplot(data = data.frame(var = var), aes(x = var, y = after_stat(count))) ++ #' dataname = "ADSL", |
||
| 756 | -! | +||
| 187 | +
- geom_histogram(binwidth = binwidth) ++ #' select = select_spec( |
||
| 757 | -! | +||
| 188 | +
- scale_y_continuous(+ #' label = "Select variable:", |
||
| 758 | -! | +||
| 189 | +
- sec.axis = sec_axis(+ #' choices = variable_choices(data[["ADSL"]], c("AGE", "BMRKR1")),
|
||
| 759 | -! | +||
| 190 | +
- trans = ~ . / nrow(data.frame(var = var)),+ #' selected = "AGE", |
||
| 760 | -! | +||
| 191 | +
- labels = scales::percent,+ #' multiple = FALSE, |
||
| 761 | -! | +||
| 192 | +
- name = "proportion (in %)"+ #' fixed = FALSE |
||
| 762 | +193 |
- )+ #' ) |
|
| 763 | +194 |
- )+ #' ), |
|
| 764 | +195 |
-
+ #' row_facet = data_extract_spec( |
|
| 765 | -! | +||
| 196 | +
- if (display_density) {
+ #' dataname = "ADSL", |
||
| 766 | -! | +||
| 197 | +
- p <- p + geom_density(aes(y = after_stat(count * binwidth)))+ #' select = select_spec( |
||
| 767 | +198 |
- }+ #' label = "Select variable:", |
|
| 768 | +199 |
-
+ #' choices = variable_choices(data[["ADSL"]], c("BMRKR2", "RACE", "REGION1")),
|
|
| 769 | -! | +||
| 200 | +
- if (outlier_definition != 0) {
+ #' selected = NULL, |
||
| 770 | -! | +||
| 201 | +
- p <- p + annotate(+ #' multiple = FALSE, |
||
| 771 | -! | +||
| 202 | +
- geom = "text",+ #' fixed = FALSE |
||
| 772 | -! | +||
| 203 | +
- label = outlier_text,+ #' ) |
||
| 773 | -! | +||
| 204 | +
- x = Inf, y = Inf,+ #' ), |
||
| 774 | -! | +||
| 205 | +
- hjust = 1.02, vjust = 1.2,+ #' col_facet = data_extract_spec( |
||
| 775 | -! | +||
| 206 | +
- color = "black",+ #' dataname = "ADSL", |
||
| 776 | +207 |
- # explicitly modify geom text size according+ #' select = select_spec( |
|
| 777 | -! | +||
| 208 | +
- size = ggplot2_args[["theme"]][["text"]][["size"]] / 3.5+ #' label = "Select variable:", |
||
| 778 | +209 |
- )+ #' choices = variable_choices(data[["ADSL"]], c("BMRKR2", "RACE", "REGION1")),
|
|
| 779 | +210 |
- }+ #' selected = NULL, |
|
| 780 | -! | +||
| 211 | +
- p+ #' multiple = FALSE, |
||
| 781 | +212 |
- }+ #' fixed = FALSE |
|
| 782 | -! | +||
| 213 | +
- } else if (inherits(var, "Date") || inherits(var, "POSIXct") || inherits(var, "POSIXlt")) {
+ #' ) |
||
| 783 | -! | +||
| 214 | +
- var_num <- as.numeric(var)+ #' ) |
||
| 784 | -! | +||
| 215 | +
- binwidth <- get_bin_width(var_num, 1)+ #' ) |
||
| 785 | -! | +||
| 216 | +
- p <- ggplot(data = data.frame(var = var), aes(x = var, y = after_stat(count))) ++ #' ) |
||
| 786 | -! | +||
| 217 | +
- geom_histogram(binwidth = binwidth)+ #' ) |
||
| 787 | +218 |
- } else {
+ #' if (interactive()) {
|
|
| 788 | -! | +||
| 219 | +
- grid::textGrob(+ #' shinyApp(app$ui, app$server) |
||
| 789 | -! | +||
| 220 | +
- paste(strwrap(+ #' } |
||
| 790 | -! | +||
| 221 | +
- utils::capture.output(utils::str(var)),+ #' |
||
| 791 | -! | +||
| 222 | +
- width = .9 * grid::convertWidth(grid::unit(1, "npc"), "char", TRUE)+ #' @export |
||
| 792 | -! | +||
| 223 | +
- ), collapse = "\n"),+ #' |
||
| 793 | -! | +||
| 224 | +
- x = grid::unit(1, "line"), y = grid::unit(1, "npc") - grid::unit(1, "line"), just = c("left", "top")
+ tm_g_scatterplot <- function(label = "Scatterplot", |
||
| 794 | +225 |
- )+ x, |
|
| 795 | +226 |
- }+ y, |
|
| 796 | +227 |
-
+ color_by = NULL, |
|
| 797 | -! | +||
| 228 | +
- dev_ggplot2_args <- teal.widgets::ggplot2_args(+ size_by = NULL, |
||
| 798 | -! | +||
| 229 | +
- labs = list(x = var_lab)+ row_facet = NULL, |
||
| 799 | +230 |
- )+ col_facet = NULL, |
|
| 800 | +231 |
- ###+ plot_height = c(600, 200, 2000), |
|
| 801 | -! | +||
| 232 | +
- all_ggplot2_args <- teal.widgets::resolve_ggplot2_args(+ plot_width = NULL, |
||
| 802 | -! | +||
| 233 | +
- ggplot2_args,+ alpha = c(1, 0, 1), |
||
| 803 | -! | +||
| 234 | +
- module_plot = dev_ggplot2_args+ shape = shape_names, |
||
| 804 | +235 |
- )+ size = c(5, 1, 15), |
|
| 805 | +236 |
-
+ max_deg = 5L, |
|
| 806 | -! | +||
| 237 | +
- if (is.ggplot(plot_main)) {
+ rotate_xaxis_labels = FALSE, |
||
| 807 | -! | +||
| 238 | +
- if (is.numeric(var) && !numeric_as_factor) {
+ ggtheme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void"),
|
||
| 808 | +239 |
- # numeric not as factor+ pre_output = NULL, |
|
| 809 | -! | +||
| 240 | +
- plot_main <- plot_main ++ post_output = NULL, |
||
| 810 | -! | +||
| 241 | +
- theme_light() ++ table_dec = 4, |
||
| 811 | -! | +||
| 242 | +
- list(+ ggplot2_args = teal.widgets::ggplot2_args(), |
||
| 812 | -! | +||
| 243 | +
- labs = do.call("labs", all_ggplot2_args$labs),
+ decorators = NULL) {
|
||
| 813 | +244 | ! |
- theme = do.call("theme", all_ggplot2_args$theme)
+ message("Initializing tm_g_scatterplot")
|
| 814 | +245 |
- )+ |
|
| 815 | +246 |
- } else {
+ # Requires Suggested packages |
|
| 816 | -+ | ||
| 247 | +! |
- # factor low number of levels OR numeric as factor OR Date+ extra_packages <- c("ggpmisc", "ggExtra", "colourpicker")
|
|
| 817 | +248 | ! |
- plot_main <- plot_main ++ missing_packages <- Filter(function(x) !requireNamespace(x, quietly = TRUE), extra_packages) |
| 818 | +249 | ! |
- theme_light() ++ if (length(missing_packages) > 0L) {
|
| 819 | +250 | ! |
- list(+ stop(sprintf( |
| 820 | +251 | ! |
- labs = do.call("labs", all_ggplot2_args$labs),
+ "Cannot load package(s): %s.\nInstall or restart your session.", |
| 821 | +252 | ! |
- theme = do.call("theme", all_ggplot2_args$theme)
+ toString(missing_packages) |
| 822 | +253 |
- )+ )) |
|
| 823 | +254 |
- }- |
- |
| 824 | -! | -
- plot_main <- ggplotGrob(plot_main)+ } |
|
| 825 | +255 |
- }+ |
|
| 826 | +256 |
-
+ # Normalize the parameters |
|
| 827 | +257 | ! |
- grid::grid.draw(plot_main)+ if (inherits(x, "data_extract_spec")) x <- list(x) |
| 828 | +258 | ! |
- plot_main+ if (inherits(y, "data_extract_spec")) y <- list(y) |
| 829 | -+ | ||
| 259 | +! |
- }+ if (inherits(color_by, "data_extract_spec")) color_by <- list(color_by) |
|
| 830 | -+ | ||
| 260 | +! |
-
+ if (inherits(size_by, "data_extract_spec")) size_by <- list(size_by) |
|
| 831 | -+ | ||
| 261 | +! |
- is_num_var_short <- function(.unique_records_for_factor, input, data_for_analysis) {
+ if (inherits(row_facet, "data_extract_spec")) row_facet <- list(row_facet) |
|
| 832 | +262 | ! |
- length(unique(data_for_analysis()$data)) < .unique_records_for_factor && !is.null(input$numeric_as_factor)+ if (inherits(col_facet, "data_extract_spec")) col_facet <- list(col_facet) |
| 833 | -+ | ||
| 263 | +! |
- }+ if (is.double(max_deg)) max_deg <- as.integer(max_deg) |
|
| 834 | +264 | ||
| 835 | +265 |
- #' Validates the variable browser inputs+ # Start of assertions |
|
| 836 | -+ | ||
| 266 | +! |
- #'+ checkmate::assert_string(label) |
|
| 837 | -+ | ||
| 267 | +! |
- #' @param input (`session$input`) the `shiny` session input+ checkmate::assert_list(x, types = "data_extract_spec") |
|
| 838 | -+ | ||
| 268 | +! |
- #' @param plot_var (`list`) list of a data frame and an array of variable names+ checkmate::assert_list(y, types = "data_extract_spec") |
|
| 839 | -+ | ||
| 269 | +! |
- #' @param data (`teal_data`) the datasets passed to the module+ checkmate::assert_list(color_by, types = "data_extract_spec", null.ok = TRUE) |
|
| 840 | -+ | ||
| 270 | +! |
- #'+ checkmate::assert_list(size_by, types = "data_extract_spec", null.ok = TRUE) |
|
| 841 | +271 |
- #' @returns `logical` TRUE if validations pass; a `shiny` validation error otherwise+ |
|
| 842 | -+ | ||
| 272 | +! |
- #' @keywords internal+ checkmate::assert_list(row_facet, types = "data_extract_spec", null.ok = TRUE) |
|
| 843 | -+ | ||
| 273 | +! |
- validate_input <- function(input, plot_var, data) {
+ assert_single_selection(row_facet) |
|
| 844 | -! | +||
| 274 | +
- reactive({
+
|
||
| 845 | +275 | ! |
- dataset_name <- req(input$tabset_panel)+ checkmate::assert_list(col_facet, types = "data_extract_spec", null.ok = TRUE) |
| 846 | +276 | ! |
- varname <- plot_var$variable[[dataset_name]]+ assert_single_selection(col_facet) |
| 847 | +277 | ||
| 848 | +278 | ! |
- validate(need(dataset_name, "No data selected"))+ checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE) |
| 849 | +279 | ! |
- validate(need(varname, "No variable selected"))+ checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height") |
| 850 | +280 | ! |
- df <- data()[[dataset_name]]+ checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE) |
| 851 | +281 | ! |
- teal::validate_has_data(df, 1)+ checkmate::assert_numeric( |
| 852 | +282 | ! |
- teal::validate_has_variable(varname = varname, data = df, "Variable not available")- |
-
| 853 | -- |
-
+ plot_width[1], |
|
| 854 | +283 | ! |
- TRUE- |
-
| 855 | -- |
- })+ lower = plot_width[2], upper = plot_width[3], null.ok = TRUE, .var.name = "plot_width" |
|
| 856 | +284 |
- }+ ) |
|
| 857 | +285 | ||
| 858 | -- |
- get_plotted_data <- function(input, plot_var, data) {
- |
- |
| 859 | -! | -
- dataset_name <- input$tabset_panel- |
- |
| 860 | +286 | ! |
- varname <- plot_var$variable[[dataset_name]]+ if (length(alpha) == 1) {
|
| 861 | +287 | ! |
- df <- data()[[dataset_name]]+ checkmate::assert_numeric(alpha, any.missing = FALSE, finite = TRUE) |
| 862 | +288 |
-
+ } else {
|
|
| 863 | +289 | ! |
- var_description <- teal.data::col_labels(df)[[varname]]+ checkmate::assert_numeric(alpha, len = 3, any.missing = FALSE, finite = TRUE) |
| 864 | +290 | ! |
- list(data = df[[varname]], var_description = var_description)+ checkmate::assert_numeric(alpha[1], lower = alpha[2], upper = alpha[3], .var.name = "alpha") |
| 865 | +291 |
- }+ } |
|
| 866 | +292 | ||
| 867 | -- |
- #' Renders the left-hand side `tabset` panel of the module- |
- |
| 868 | -- |
- #'- |
- |
| 869 | -+ | ||
| 293 | +! |
- #' @param datanames (`character`) the name of the dataset+ checkmate::assert_character(shape) |
|
| 870 | +294 |
- #' @param parent_dataname (`character`) the name of a parent `dataname` to filter out variables from+ |
|
| 871 | -+ | ||
| 295 | +! |
- #' @param data (`teal_data`) the object containing all datasets+ if (length(size) == 1) {
|
|
| 872 | -+ | ||
| 296 | +! |
- #' @param input (`session$input`) the `shiny` session input+ checkmate::assert_numeric(size, any.missing = FALSE, finite = TRUE) |
|
| 873 | +297 |
- #' @param output (`session$output`) the `shiny` session output+ } else {
|
|
| 874 | -+ | ||
| 298 | +! |
- #' @param columns_names (`environment`) the environment containing bindings for each dataset+ checkmate::assert_numeric(size, len = 3, any.missing = FALSE, finite = TRUE) |
|
| 875 | -+ | ||
| 299 | +! |
- #' @param plot_var (`list`) the list containing the currently selected dataset (tab) and its column names+ checkmate::assert_numeric(size[1], lower = size[2], upper = size[3], .var.name = "size") |
|
| 876 | +300 |
- #' @keywords internal+ } |
|
| 877 | +301 |
- render_tabset_panel_content <- function(datanames, parent_dataname, output, data, input, columns_names, plot_var) {
- |
- |
| 878 | -! | -
- lapply(datanames, render_single_tab,+ |
|
| 879 | +302 | ! |
- input = input,+ checkmate::assert_int(max_deg, lower = 1L) |
| 880 | +303 | ! |
- output = output,+ checkmate::assert_flag(rotate_xaxis_labels) |
| 881 | +304 | ! |
- data = data,+ ggtheme <- match.arg(ggtheme) |
| 882 | -! | +||
| 305 | +
- parent_dataname = parent_dataname,+ |
||
| 883 | +306 | ! |
- columns_names = columns_names,+ checkmate::assert_multi_class(pre_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
|
| 884 | +307 | ! |
- plot_var = plot_var- |
-
| 885 | -- |
- )- |
- |
| 886 | -- |
- }+ checkmate::assert_multi_class(post_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
|
|
| 887 | +308 | ||
| 888 | -- |
- #' Renders a single tab in the left-hand side tabset panel- |
- |
| 889 | -+ | ||
| 309 | +! |
- #'+ checkmate::assert_scalar(table_dec) |
|
| 890 | -+ | ||
| 310 | +! |
- #' Renders a single tab in the left-hand side tabset panel. The rendered tab contains+ checkmate::assert_class(ggplot2_args, "ggplot2_args") |
|
| 891 | +311 |
- #' information about one dataset out of many presented in the module.+ |
|
| 892 | -+ | ||
| 312 | +! |
- #'+ decorators <- normalize_decorators(decorators) |
|
| 893 | -+ | ||
| 313 | +! |
- #' @param dataset_name (`character`) the name of the dataset contained in the rendered tab+ assert_decorators(decorators, null.ok = TRUE, "plot") |
|
| 894 | +314 |
- #' @param parent_dataname (`character`) the name of a parent `dataname` to filter out variables from+ |
|
| 895 | +315 |
- #' @inheritParams render_tabset_panel_content+ # End of assertions |
|
| 896 | +316 |
- #' @keywords internal+ |
|
| 897 | +317 |
- render_single_tab <- function(dataset_name, parent_dataname, output, data, input, columns_names, plot_var) {
+ # Make UI args |
|
| 898 | +318 | ! |
- render_tab_header(dataset_name, output, data)+ args <- as.list(environment()) |
| 899 | +319 | ||
| 900 | -! | -
- render_tab_table(- |
- |
| 901 | +320 | ! |
- dataset_name = dataset_name,+ data_extract_list <- list( |
| 902 | +321 | ! |
- parent_dataname = parent_dataname,+ x = x, |
| 903 | +322 | ! |
- output = output,+ y = y, |
| 904 | +323 | ! |
- data = data,+ color_by = color_by, |
| 905 | +324 | ! |
- input = input,+ size_by = size_by, |
| 906 | +325 | ! |
- columns_names = columns_names,+ row_facet = row_facet, |
| 907 | +326 | ! |
- plot_var = plot_var+ col_facet = col_facet |
| 908 | +327 |
) |
|
| 909 | +328 |
- }+ |
|
| 910 | -+ | ||
| 329 | +! |
-
+ ans <- module( |
|
| 911 | -+ | ||
| 330 | +! |
- #' Renders the text headlining a single tab in the left-hand side tabset panel+ label = label, |
|
| 912 | -+ | ||
| 331 | +! |
- #'+ server = srv_g_scatterplot, |
|
| 913 | -+ | ||
| 332 | +! |
- #' @param dataset_name (`character`) the name of the dataset of the tab+ ui = ui_g_scatterplot, |
|
| 914 | -+ | ||
| 333 | +! |
- #' @inheritParams render_tabset_panel_content+ ui_args = args, |
|
| 915 | -+ | ||
| 334 | +! |
- #' @keywords internal+ server_args = c( |
|
| 916 | -+ | ||
| 335 | +! |
- render_tab_header <- function(dataset_name, output, data) {
+ data_extract_list, |
|
| 917 | +336 | ! |
- dataset_ui_id <- paste0("dataset_summary_", dataset_name)
+ list( |
| 918 | +337 | ! |
- output[[dataset_ui_id]] <- renderText({
+ plot_height = plot_height, |
| 919 | +338 | ! |
- df <- data()[[dataset_name]]+ plot_width = plot_width, |
| 920 | +339 | ! |
- join_keys <- teal.data::join_keys(data())+ table_dec = table_dec, |
| 921 | +340 | ! |
- if (!is.null(join_keys)) {
+ ggplot2_args = ggplot2_args, |
| 922 | +341 | ! |
- key <- teal.data::join_keys(data())[dataset_name, dataset_name]+ decorators = decorators |
| 923 | +342 |
- } else {
- |
- |
| 924 | -! | -
- key <- NULL+ ) |
|
| 925 | +343 |
- }+ ), |
|
| 926 | +344 | ! |
- sprintf(+ datanames = teal.transform::get_extract_datanames(data_extract_list) |
| 927 | -! | +||
| 345 | +
- "Dataset with %s unique key rows and %s variables",+ ) |
||
| 928 | +346 | ! |
- nrow(unique(`if`(length(key) > 0, df[, key, drop = FALSE], df))),+ attr(ans, "teal_bookmarkable") <- TRUE |
| 929 | +347 | ! |
- ncol(df)+ ans |
| 930 | +348 |
- )+ } |
|
| 931 | +349 |
- })+ |
|
| 932 | +350 |
- }+ # UI function for the scatterplot module |
|
| 933 | +351 |
-
+ ui_g_scatterplot <- function(id, ...) {
|
|
| 934 | -- |
- #' Renders the table for a single dataset in the left-hand side tabset panel- |
- |
| 935 | -- |
- #'- |
- |
| 936 | -- |
- #' The table contains column names, column labels,- |
- |
| 937 | -- |
- #' small summary about NA values and `sparkline` (if appropriate).- |
- |
| 938 | -- |
- #'- |
- |
| 939 | -+ | ||
| 352 | +! |
- #' @param dataset_name (`character`) the name of the dataset+ args <- list(...) |
|
| 940 | -+ | ||
| 353 | +! |
- #' @param parent_dataname (`character`) the name of a parent `dataname` to filter out variables from+ ns <- NS(id) |
|
| 941 | -+ | ||
| 354 | +! |
- #' @inheritParams render_tabset_panel_content+ is_single_dataset_value <- teal.transform::is_single_dataset( |
|
| 942 | -+ | ||
| 355 | +! |
- #' @keywords internal+ args$x, args$y, args$color_by, args$size_by, args$row_facet, args$col_facet |
|
| 943 | +356 |
- render_tab_table <- function(dataset_name, parent_dataname, output, data, input, columns_names, plot_var) {
- |
- |
| 944 | -! | -
- table_ui_id <- paste0("variable_browser_", dataset_name)
+ ) |
|
| 945 | +357 | ||
| 946 | +358 | ! |
- output[[table_ui_id]] <- DT::renderDataTable({
+ tagList( |
| 947 | +359 | ! |
- df <- data()[[dataset_name]]- |
-
| 948 | -- |
-
+ include_css_files("custom"),
|
|
| 949 | +360 | ! |
- get_vars_df <- function(input, dataset_name, parent_name, data) {
+ teal.widgets::standard_layout( |
| 950 | +361 | ! |
- data_cols <- colnames(df)+ output = teal.widgets::white_small_well( |
| 951 | +362 | ! |
- if (isTRUE(input$show_parent_vars)) {
+ teal.widgets::plot_with_settings_ui(id = ns("scatter_plot")),
|
| 952 | +363 | ! |
- data_cols+ tags$h1(tags$strong("Selected points:"), class = "text-center font-150p"),
|
| 953 | +364 | ! |
- } else if (dataset_name != parent_name && parent_name %in% names(data)) {
+ teal.widgets::get_dt_rows(ns("data_table"), ns("data_table_rows")),
|
| 954 | +365 | ! |
- setdiff(data_cols, colnames(data()[[parent_name]]))+ DT::dataTableOutput(ns("data_table"), width = "100%")
|
| 955 | +366 |
- } else {
+ ), |
|
| 956 | +367 | ! |
- data_cols+ encoding = tags$div( |
| 957 | +368 |
- }+ ### Reporter |
|
| 958 | -+ | ||
| 369 | +! |
- }+ teal.reporter::simple_reporter_ui(ns("simple_reporter")),
|
|
| 959 | +370 |
-
+ ### |
|
| 960 | +371 | ! |
- if (length(parent_dataname) > 0) {
+ tags$label("Encodings", class = "text-primary"),
|
| 961 | +372 | ! |
- df_vars <- get_vars_df(input, dataset_name, parent_dataname, data)+ teal.transform::datanames_input(args[c("x", "y", "color_by", "size_by", "row_facet", "col_facet")]),
|
| 962 | +373 | ! |
- df <- df[df_vars]- |
-
| 963 | -- |
- }- |
- |
| 964 | -- |
-
+ teal.transform::data_extract_ui( |
|
| 965 | +374 | ! |
- if (is.null(df) || ncol(df) == 0) {
+ id = ns("x"),
|
| 966 | +375 | ! |
- columns_names[[dataset_name]] <- character(0)+ label = "X variable", |
| 967 | +376 | ! |
- df_output <- data.frame(+ data_extract_spec = args$x, |
| 968 | +377 | ! |
- Type = character(0),+ is_single_dataset = is_single_dataset_value |
| 969 | -! | +||
| 378 | +
- Variable = character(0),+ ), |
||
| 970 | +379 | ! |
- Label = character(0),+ checkboxInput(ns("log_x"), "Use log transformation", value = FALSE),
|
| 971 | +380 | ! |
- Missings = character(0),+ conditionalPanel( |
| 972 | +381 | ! |
- Sparklines = character(0),+ condition = paste0("input['", ns("log_x"), "'] == true"),
|
| 973 | +382 | ! |
- stringsAsFactors = FALSE- |
-
| 974 | -- |
- )- |
- |
| 975 | -- |
- } else {
+ radioButtons( |
|
| 976 | -+ | ||
| 383 | +! |
- # extract data variable labels+ ns("log_x_base"),
|
|
| 977 | +384 | ! |
- labels <- teal.data::col_labels(df)+ label = NULL, |
| 978 | -+ | ||
| 385 | +! |
-
+ inline = TRUE, |
|
| 979 | +386 | ! |
- columns_names[[dataset_name]] <- names(labels)+ choices = c("Natural" = "log", "Base 10" = "log10", "Base 2" = "log2")
|
| 980 | +387 |
-
+ ) |
|
| 981 | +388 |
- # calculate number of missing values+ ), |
|
| 982 | +389 | ! |
- missings <- vapply(+ teal.transform::data_extract_ui( |
| 983 | +390 | ! |
- df,+ id = ns("y"),
|
| 984 | +391 | ! |
- var_missings_info,+ label = "Y variable", |
| 985 | +392 | ! |
- FUN.VALUE = character(1),+ data_extract_spec = args$y, |
| 986 | +393 | ! |
- USE.NAMES = FALSE- |
-
| 987 | -- |
- )+ is_single_dataset = is_single_dataset_value |
|
| 988 | +394 |
-
+ ), |
|
| 989 | -+ | ||
| 395 | +! |
- # get icons proper for the data types+ checkboxInput(ns("log_y"), "Use log transformation", value = FALSE),
|
|
| 990 | +396 | ! |
- icons <- vapply(df, function(x) class(x)[1L], character(1L))+ conditionalPanel( |
| 991 | -+ | ||
| 397 | +! |
-
+ condition = paste0("input['", ns("log_y"), "'] == true"),
|
|
| 992 | +398 | ! |
- join_keys <- teal.data::join_keys(data())+ radioButtons( |
| 993 | +399 | ! |
- if (!is.null(join_keys)) {
+ ns("log_y_base"),
|
| 994 | +400 | ! |
- icons[intersect(join_keys[dataset_name, dataset_name], colnames(df))] <- "primary_key"+ label = NULL, |
| 995 | -+ | ||
| 401 | +! |
- }+ inline = TRUE, |
|
| 996 | +402 | ! |
- icons <- variable_type_icons(icons)+ choices = c("Natural" = "log", "Base 10" = "log10", "Base 2" = "log2")
|
| 997 | +403 |
-
+ ) |
|
| 998 | +404 |
- # generate sparklines+ ), |
|
| 999 | +405 | ! |
- sparklines_html <- vapply(+ if (!is.null(args$color_by)) {
|
| 1000 | +406 | ! |
- df,+ teal.transform::data_extract_ui( |
| 1001 | +407 | ! |
- create_sparklines,+ id = ns("color_by"),
|
| 1002 | +408 | ! |
- FUN.VALUE = character(1),+ label = "Color by variable", |
| 1003 | +409 | ! |
- USE.NAMES = FALSE+ data_extract_spec = args$color_by, |
| 1004 | -+ | ||
| 410 | +! |
- )+ is_single_dataset = is_single_dataset_value |
|
| 1005 | +411 |
-
+ ) |
|
| 1006 | -! | +||
| 412 | +
- df_output <- data.frame(+ }, |
||
| 1007 | +413 | ! |
- Type = icons,+ if (!is.null(args$size_by)) {
|
| 1008 | +414 | ! |
- Variable = names(labels),+ teal.transform::data_extract_ui( |
| 1009 | +415 | ! |
- Label = labels,+ id = ns("size_by"),
|
| 1010 | +416 | ! |
- Missings = missings,+ label = "Size by variable", |
| 1011 | +417 | ! |
- Sparklines = sparklines_html,+ data_extract_spec = args$size_by, |
| 1012 | +418 | ! |
- stringsAsFactors = FALSE+ is_single_dataset = is_single_dataset_value |
| 1013 | +419 |
- )+ ) |
|
| 1014 | +420 |
- }+ }, |
|
| 1015 | -+ | ||
| 421 | +! |
-
+ if (!is.null(args$row_facet)) {
|
|
| 1016 | -+ | ||
| 422 | +! |
- # Select row 1 as default / fallback+ teal.transform::data_extract_ui( |
|
| 1017 | +423 | ! |
- selected_ix <- 1+ id = ns("row_facet"),
|
| 1018 | -+ | ||
| 424 | +! |
- # Define starting page index (base-0 index of the first item on page+ label = "Row facetting", |
|
| 1019 | -+ | ||
| 425 | +! |
- # note: in many cases it's not the item itself+ data_extract_spec = args$row_facet, |
|
| 1020 | +426 | ! |
- selected_page_ix <- 0+ is_single_dataset = is_single_dataset_value |
| 1021 | +427 |
-
+ ) |
|
| 1022 | +428 |
- # Retrieve current selected variable if any+ }, |
|
| 1023 | +429 | ! |
- isolated_variable <- isolate(plot_var$variable[[dataset_name]])+ if (!is.null(args$col_facet)) {
|
| 1024 | -+ | ||
| 430 | +! |
-
+ teal.transform::data_extract_ui( |
|
| 1025 | +431 | ! |
- if (!is.null(isolated_variable)) {
+ id = ns("col_facet"),
|
| 1026 | +432 | ! |
- index <- which(columns_names[[dataset_name]] == isolated_variable)[1]+ label = "Column facetting", |
| 1027 | +433 | ! |
- if (!is.null(index) && !is.na(index) && length(index) > 0) selected_ix <- index+ data_extract_spec = args$col_facet, |
| 1028 | -+ | ||
| 434 | +! |
- }+ is_single_dataset = is_single_dataset_value |
|
| 1029 | +435 |
-
+ ) |
|
| 1030 | +436 |
- # Retrieve the index of the first item of the current page+ }, |
|
| 1031 | -+ | ||
| 437 | +! |
- # it works with varying number of entries on the page (10, 25, ...)+ ui_decorate_teal_data(ns("decorator"), decorators = select_decorators(args$decorators, "plot")),
|
|
| 1032 | +438 | ! |
- table_id_sel <- paste0("variable_browser_", dataset_name, "_state")
+ teal.widgets::panel_group( |
| 1033 | +439 | ! |
- dt_state <- isolate(input[[table_id_sel]])+ teal.widgets::panel_item( |
| 1034 | +440 | ! |
- if (selected_ix != 1 && !is.null(dt_state)) {
+ title = "Plot settings", |
| 1035 | +441 | ! |
- selected_page_ix <- floor(selected_ix / dt_state$length) * dt_state$length- |
-
| 1036 | -- |
- }- |
- |
| 1037 | -- |
-
+ teal.widgets::optionalSliderInputValMinMax(ns("alpha"), "Opacity:", args$alpha, ticks = FALSE),
|
|
| 1038 | +442 | ! |
- DT::datatable(+ teal.widgets::optionalSelectInput( |
| 1039 | +443 | ! |
- df_output,+ inputId = ns("shape"),
|
| 1040 | +444 | ! |
- escape = FALSE,+ label = "Points shape:", |
| 1041 | +445 | ! |
- rownames = FALSE,+ choices = args$shape, |
| 1042 | +446 | ! |
- selection = list(mode = "single", target = "row", selected = selected_ix),+ selected = args$shape[1], |
| 1043 | +447 | ! |
- options = list(+ multiple = FALSE |
| 1044 | -! | +||
| 448 | +
- fnDrawCallback = htmlwidgets::JS("function() { HTMLWidgets.staticRender(); }"),
+ ), |
||
| 1045 | +449 | ! |
- pageLength = input[[paste0(table_ui_id, "_rows")]],+ colourpicker::colourInput(ns("color"), "Points color:", "black"),
|
| 1046 | +450 | ! |
- displayStart = selected_page_ix- |
-
| 1047 | -- |
- )+ teal.widgets::optionalSliderInputValMinMax(ns("size"), "Points size:", args$size, ticks = FALSE, step = .1),
|
|
| 1048 | -+ | ||
| 451 | +! |
- )+ checkboxInput(ns("rotate_xaxis_labels"), "Rotate X axis labels", value = args$rotate_xaxis_labels),
|
|
| 1049 | -+ | ||
| 452 | +! |
- })+ checkboxInput(ns("add_density"), "Add marginal density", value = FALSE),
|
|
| 1050 | -+ | ||
| 453 | +! |
- }+ checkboxInput(ns("rug_plot"), "Include rug plot", value = FALSE),
|
|
| 1051 | -+ | ||
| 454 | +! |
-
+ checkboxInput(ns("show_count"), "Show N (number of observations)", value = FALSE),
|
|
| 1052 | -+ | ||
| 455 | +! |
- #' Creates observers updating the currently selected column+ shinyjs::hidden(helpText(id = ns("line_msg"), "Trendline needs numeric X and Y variables")),
|
|
| 1053 | -+ | ||
| 456 | +! |
- #'+ teal.widgets::optionalSelectInput(ns("smoothing_degree"), "Smoothing degree", seq_len(args$max_deg)),
|
|
| 1054 | -+ | ||
| 457 | +! |
- #' The created observers update the column currently selected in the left-hand side+ shinyjs::hidden(teal.widgets::optionalSelectInput(ns("color_sub"), label = "", multiple = TRUE)),
|
|
| 1055 | -+ | ||
| 458 | +! |
- #' tabset panel.+ teal.widgets::optionalSliderInputValMinMax(ns("ci"), "Confidence", c(.95, .8, .99), ticks = FALSE),
|
|
| 1056 | -+ | ||
| 459 | +! |
- #'+ shinyjs::hidden(checkboxInput(ns("show_form"), "Show formula", value = TRUE)),
|
|
| 1057 | -+ | ||
| 460 | +! |
- #' @note+ shinyjs::hidden(checkboxInput(ns("show_r2"), "Show adj-R Squared", value = TRUE)),
|
|
| 1058 | -+ | ||
| 461 | +! |
- #' Creates an observer for each dataset (each tab in the tabset panel).+ uiOutput(ns("num_na_removed")),
|
|
| 1059 | -+ | ||
| 462 | +! |
- #'+ tags$div( |
|
| 1060 | -+ | ||
| 463 | +! |
- #' @inheritParams render_tabset_panel_content+ id = ns("label_pos"),
|
|
| 1061 | -+ | ||
| 464 | +! |
- #' @keywords internal+ tags$div(tags$strong("Stats position")),
|
|
| 1062 | -+ | ||
| 465 | +! |
- establish_updating_selection <- function(datanames, input, plot_var, columns_names) {
+ tags$div(class = "inline-block w-10", helpText("Left")),
|
|
| 1063 | +466 | ! |
- lapply(datanames, function(dataset_name) {
+ tags$div( |
| 1064 | +467 | ! |
- table_ui_id <- paste0("variable_browser_", dataset_name)
+ class = "inline-block w-70", |
| 1065 | +468 | ! |
- table_id_sel <- paste0(table_ui_id, "_rows_selected")+ teal.widgets::optionalSliderInput( |
| 1066 | +469 | ! |
- observeEvent(input[[table_id_sel]], {
+ ns("pos"),
|
| 1067 | +470 | ! |
- plot_var$data <- dataset_name+ label = NULL, |
| 1068 | +471 | ! |
- plot_var$variable[[dataset_name]] <- columns_names[[dataset_name]][input[[table_id_sel]]]+ min = 0, max = 1, value = .99, ticks = FALSE, step = .01 |
| 1069 | +472 |
- })+ ) |
|
| 1070 | +473 |
- })+ ), |
|
| 1071 | -+ | ||
| 474 | +! |
- }+ tags$div(class = "inline-block w-10", helpText("Right"))
|
|
| 1072 | +475 |
-
+ ), |
|
| 1073 | -+ | ||
| 476 | +! |
- get_bin_width <- function(x_vec, scaling_factor = 2) {
+ teal.widgets::optionalSliderInput( |
|
| 1074 | +477 | ! |
- x_vec <- x_vec[!is.na(x_vec)]+ ns("label_size"), "Stats font size",
|
| 1075 | +478 | ! |
- qntls <- stats::quantile(x_vec, probs = c(0.1, 0.25, 0.75, 0.9), type = 2)+ min = 3, max = 10, value = 5, ticks = FALSE, step = .1 |
| 1076 | -! | +||
| 479 | +
- iqr <- qntls[3] - qntls[2]+ ), |
||
| 1077 | +480 | ! |
- binwidth <- max(scaling_factor * iqr / length(x_vec) ^ (1 / 3), sqrt(qntls[4] - qntls[1])) # styler: off+ if (!is.null(args$row_facet) || !is.null(args$col_facet)) {
|
| 1078 | +481 | ! |
- binwidth <- ifelse(binwidth == 0, 1, binwidth)+ checkboxInput(ns("free_scales"), "Free scales", value = FALSE)
|
| 1079 | +482 |
- # to ensure at least two bins when variable span is very small+ }, |
|
| 1080 | +483 | ! |
- x_span <- diff(range(x_vec))+ selectInput( |
| 1081 | +484 | ! |
- if (isTRUE(x_span / binwidth >= 2)) binwidth else x_span / 2- |
-
| 1082 | -- |
- }- |
- |
| 1083 | -- |
-
+ inputId = ns("ggtheme"),
|
|
| 1084 | -+ | ||
| 485 | +! |
- #' Removes the outlier observation from an array+ label = "Theme (by ggplot):", |
|
| 1085 | -+ | ||
| 486 | +! |
- #'+ choices = ggplot_themes, |
|
| 1086 | -+ | ||
| 487 | +! |
- #' @param var (`numeric`) a numeric vector+ selected = args$ggtheme, |
|
| 1087 | -+ | ||
| 488 | +! |
- #' @param outlier_definition (`numeric`) if `0` then no outliers are removed, otherwise+ multiple = FALSE |
|
| 1088 | +489 |
- #' outliers (those more than `outlier_definition*IQR below/above Q1/Q3`) are removed+ ) |
|
| 1089 | +490 |
- #' @returns (`numeric`) vector without the outlier values+ ) |
|
| 1090 | +491 |
- #' @keywords internal+ ) |
|
| 1091 | +492 |
- remove_outliers_from <- function(var, outlier_definition) {
+ ), |
|
| 1092 | -3x | +||
| 493 | +! |
- if (outlier_definition == 0) {
+ forms = tagList( |
|
| 1093 | -1x | +||
| 494 | +! |
- return(var)+ teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code")
|
|
| 1094 | +495 |
- }- |
- |
| 1095 | -2x | -
- q1_q3 <- stats::quantile(var, probs = c(0.25, 0.75), type = 2, na.rm = TRUE)+ ), |
|
| 1096 | -2x | +||
| 496 | +! |
- iqr <- q1_q3[2] - q1_q3[1]+ pre_output = args$pre_output, |
|
| 1097 | -2x | +||
| 497 | +! |
- var[var >= q1_q3[1] - outlier_definition * iqr & var <= q1_q3[2] + outlier_definition * iqr]+ post_output = args$post_output |
|
| 1098 | +498 |
- }+ ) |
|
| 1099 | +499 |
-
+ ) |
|
| 1100 | +500 |
-
+ } |
|
| 1101 | +501 |
- # sparklines ----+ |
|
| 1102 | +502 |
-
+ # Server function for the scatterplot module |
|
| 1103 | +503 |
- #' S3 generic for `sparkline` widget HTML+ srv_g_scatterplot <- function(id, |
|
| 1104 | +504 |
- #'+ data, |
|
| 1105 | +505 |
- #' Generates the `sparkline` HTML code corresponding to the input array.+ reporter, |
|
| 1106 | +506 |
- #' For numeric variables creates a box plot, for character and factors - bar plot.+ filter_panel_api, |
|
| 1107 | +507 |
- #' Produces an empty string for variables of other types.+ x, |
|
| 1108 | +508 |
- #'+ y, |
|
| 1109 | +509 |
- #' @param arr vector of any type and length+ color_by, |
|
| 1110 | +510 |
- #' @param width `numeric` the width of the `sparkline` widget (pixels)+ size_by, |
|
| 1111 | +511 |
- #' @param bar_spacing `numeric` the spacing between the bars (in pixels)+ row_facet, |
|
| 1112 | +512 |
- #' @param bar_width `numeric` the width of the bars (in pixels)+ col_facet, |
|
| 1113 | +513 |
- #' @param ... `list` additional options passed to bar plots of `jquery.sparkline`;+ plot_height, |
|
| 1114 | +514 |
- #' see [`jquery.sparkline docs`](https://omnipotent.net/jquery.sparkline/#common)+ plot_width, |
|
| 1115 | +515 |
- #'+ table_dec, |
|
| 1116 | +516 |
- #' @return Character string containing HTML code of the `sparkline` HTML widget.+ ggplot2_args, |
|
| 1117 | +517 |
- #' @keywords internal+ decorators) {
|
|
| 1118 | -+ | ||
| 518 | +! |
- create_sparklines <- function(arr, width = 150, ...) {
+ with_reporter <- !missing(reporter) && inherits(reporter, "Reporter") |
|
| 1119 | +519 | ! |
- if (all(is.null(arr))) {
+ with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI") |
| 1120 | +520 | ! |
- return("")
+ checkmate::assert_class(data, "reactive") |
| 1121 | -+ | ||
| 521 | +! |
- }+ checkmate::assert_class(isolate(data()), "teal_data") |
|
| 1122 | +522 | ! |
- UseMethod("create_sparklines")
+ moduleServer(id, function(input, output, session) {
|
| 1123 | -+ | ||
| 523 | +! |
- }+ teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.general") |
|
| 1124 | +524 | ||
| 1125 | -+ | ||
| 525 | +! |
- #' @rdname create_sparklines+ data_extract <- list( |
|
| 1126 | -- |
- #' @keywords internal+ | |
| 526 | +! | +
+ x = x, |
|
| 1127 | -+ | ||
| 527 | +! |
- #' @export+ y = y, |
|
| 1128 | -+ | ||
| 528 | +! |
- create_sparklines.logical <- function(arr, ...) {
+ color_by = color_by, |
|
| 1129 | +529 | ! |
- create_sparklines(as.factor(arr))+ size_by = size_by,+ |
+
| 530 | +! | +
+ row_facet = row_facet,+ |
+ |
| 531 | +! | +
+ col_facet = col_facet |
|
| 1130 | +532 |
- }+ ) |
|
| 1131 | +533 | ||
| 1132 | -+ | ||
| 534 | +! |
- #' @rdname create_sparklines+ rule_diff <- function(other) {
|
|
| 1133 | -+ | ||
| 535 | +! |
- #' @keywords internal+ function(value) {
|
|
| 1134 | -+ | ||
| 536 | +! |
- #' @export+ othervalue <- selector_list()[[other]]()[["select"]] |
|
| 1135 | -+ | ||
| 537 | +! |
- create_sparklines.numeric <- function(arr, width = 150, ...) {
+ if (!is.null(othervalue)) {
|
|
| 1136 | +538 | ! |
- if (any(is.infinite(arr))) {
+ if (identical(value, othervalue)) {
|
| 1137 | +539 | ! |
- return(as.character(tags$code("infinite values", class = "text-blue")))
+ "Row and column facetting variables must be different." |
| 1138 | +540 |
- }+ } |
|
| 1139 | -! | +||
| 541 | +
- if (length(arr) > 100000) {
+ } |
||
| 1140 | -! | +||
| 542 | +
- return(as.character(tags$code("Too many rows (>100000)", class = "text-blue")))
+ } |
||
| 1141 | +543 |
- }+ } |
|
| 1142 | +544 | ||
| 1143 | +545 | ! |
- arr <- arr[!is.na(arr)]+ selector_list <- teal.transform::data_extract_multiple_srv( |
| 1144 | +546 | ! |
- sparkline::spk_chr(unname(arr), type = "box", width = width, ...)+ data_extract = data_extract, |
| 1145 | -+ | ||
| 547 | +! |
- }+ datasets = data, |
|
| 1146 | -+ | ||
| 548 | +! |
-
+ select_validation_rule = list( |
|
| 1147 | -+ | ||
| 549 | +! |
- #' @rdname create_sparklines+ x = ~ if (length(.) != 1) "Please select exactly one x var.", |
|
| 1148 | -+ | ||
| 550 | +! |
- #' @keywords internal+ y = ~ if (length(.) != 1) "Please select exactly one y var.", |
|
| 1149 | -+ | ||
| 551 | +! |
- #' @export+ color_by = ~ if (length(.) > 1) "There cannot be more than 1 color variable.", |
|
| 1150 | -+ | ||
| 552 | +! |
- create_sparklines.character <- function(arr, ...) {
+ size_by = ~ if (length(.) > 1) "There cannot be more than 1 size variable.", |
|
| 1151 | +553 | ! |
- return(create_sparklines(as.factor(arr)))+ row_facet = shinyvalidate::compose_rules( |
| 1152 | -+ | ||
| 554 | +! |
- }+ shinyvalidate::sv_optional(), |
|
| 1153 | -+ | ||
| 555 | +! |
-
+ rule_diff("col_facet")
|
|
| 1154 | +556 |
-
+ ), |
|
| 1155 | -+ | ||
| 557 | +! |
- #' @rdname create_sparklines+ col_facet = shinyvalidate::compose_rules( |
|
| 1156 | -+ | ||
| 558 | +! |
- #' @keywords internal+ shinyvalidate::sv_optional(),+ |
+ |
| 559 | +! | +
+ rule_diff("row_facet")
|
|
| 1157 | +560 |
- #' @export+ ) |
|
| 1158 | +561 |
- create_sparklines.factor <- function(arr, width = 150, bar_spacing = 5, bar_width = 20, ...) {
+ ) |
|
| 1159 | -! | +||
| 562 | +
- decreasing_order <- TRUE+ ) |
||
| 1160 | +563 | ||
| 1161 | +564 | ! |
- counts <- table(arr)+ iv_r <- reactive({
|
| 1162 | +565 | ! |
- if (length(counts) >= 100) {
+ iv_facet <- shinyvalidate::InputValidator$new() |
| 1163 | +566 | ! |
- return(as.character(tags$code("> 99 levels", class = "text-blue")))
+ iv <- shinyvalidate::InputValidator$new() |
| 1164 | +567 | ! |
- } else if (length(counts) == 0) {
+ teal.transform::compose_and_enable_validators(iv, selector_list) |
| 1165 | -! | +||
| 568 | +
- return(as.character(tags$code("no levels", class = "text-blue")))
+ }) |
||
| 1166 | +569 | ! |
- } else if (length(counts) == 1) {
+ iv_facet <- shinyvalidate::InputValidator$new() |
| 1167 | +570 | ! |
- return(as.character(tags$code("one level", class = "text-blue")))
+ iv_facet$add_rule("add_density", ~ if (
|
| 1168 | -+ | ||
| 571 | +! |
- }+ isTRUE(.) && |
|
| 1169 | +572 |
-
+ ( |
|
| 1170 | -+ | ||
| 573 | +! |
- # Summarize the occurences of different levels+ length(selector_list()$row_facet()$select) > 0L || |
|
| 1171 | -+ | ||
| 574 | +! |
- # and get the maximum and minimum number of occurences+ length(selector_list()$col_facet()$select) > 0L |
|
| 1172 | +575 |
- # This is needed for the sparkline to correctly display the bar plots+ ) |
|
| 1173 | +576 |
- # Otherwise they are cropped+ ) {
|
|
| 1174 | +577 | ! |
- counts <- sort(counts, decreasing = decreasing_order, method = "radix")+ "Cannot add marginal density when Row or Column facetting has been selected" |
| 1175 | -! | +||
| 578 | +
- max_value <- if (decreasing_order) counts[1] else counts[length[counts]]+ }) |
||
| 1176 | +579 | ! |
- max_value <- unname(max_value)+ iv_facet$enable() |
| 1177 | +580 | ||
| 1178 | +581 | ! |
- sparkline::spk_chr(+ anl_merged_input <- teal.transform::merge_expression_srv( |
| 1179 | +582 | ! |
- unname(counts),+ selector_list = selector_list, |
| 1180 | +583 | ! |
- type = "bar",+ datasets = data, |
| 1181 | +584 | ! |
- chartRangeMin = 0,+ merge_function = "dplyr::inner_join"+ |
+
| 585 | ++ |
+ )+ |
+ |
| 586 | ++ | + | |
| 1182 | +587 | ! |
- chartRangeMax = max_value,+ anl_merged_q <- reactive({
|
| 1183 | +588 | ! |
- width = width,+ req(anl_merged_input()) |
| 1184 | +589 | ! |
- barWidth = bar_width,+ data() %>% |
| 1185 | +590 | ! |
- barSpacing = bar_spacing,+ teal.code::eval_code(as.expression(anl_merged_input()$expr)) %>% |
| 1186 | +591 | ! |
- tooltipFormatter = custom_sparkline_formatter(names(counts), as.vector(counts))+ teal.code::eval_code(quote(ANL)) # used to display table when running show-r-code code |
| 1187 | +592 |
- )+ }) |
|
| 1188 | +593 |
- }+ |
|
| 1189 | -+ | ||
| 594 | +! |
-
+ merged <- list( |
|
| 1190 | -+ | ||
| 595 | +! |
- #' @rdname create_sparklines+ anl_input_r = anl_merged_input, |
|
| 1191 | -+ | ||
| 596 | +! |
- #' @keywords internal+ anl_q_r = anl_merged_q |
|
| 1192 | +597 |
- #' @export+ ) |
|
| 1193 | +598 |
- create_sparklines.Date <- function(arr, width = 150, bar_spacing = 5, bar_width = 20, ...) {
+
|
|
| 1194 | +599 | ! |
- arr_num <- as.numeric(arr)+ trend_line_is_applicable <- reactive({
|
| 1195 | +600 | ! |
- arr_num <- sort(arr_num, decreasing = FALSE, method = "radix")+ ANL <- merged$anl_q_r()[["ANL"]] |
| 1196 | +601 | ! |
- binwidth <- get_bin_width(arr_num, 1)+ x_var <- as.vector(merged$anl_input_r()$columns_source$x) |
| 1197 | +602 | ! |
- bins <- floor(diff(range(arr_num)) / binwidth) + 1+ y_var <- as.vector(merged$anl_input_r()$columns_source$y) |
| 1198 | +603 | ! |
- if (all(is.na(bins))) {
+ length(x_var) > 0 && length(y_var) > 0 && is.numeric(ANL[[x_var]]) && is.numeric(ANL[[y_var]]) |
| 1199 | -! | +||
| 604 | +
- return(as.character(tags$code("only NA", class = "text-blue")))
+ }) |
||
| 1200 | -! | +||
| 605 | +
- } else if (bins == 1) {
+
|
||
| 1201 | +606 | ! |
- return(as.character(tags$code("one date", class = "text-blue")))
+ add_trend_line <- reactive({
|
| 1202 | -+ | ||
| 607 | +! |
- }+ smoothing_degree <- as.integer(input$smoothing_degree) |
|
| 1203 | +608 | ! |
- counts <- as.vector(unname(base::table(cut(arr_num, breaks = bins))))+ trend_line_is_applicable() && length(smoothing_degree) > 0 |
| 1204 | -! | +||
| 609 | +
- max_value <- max(counts)+ }) |
||
| 1205 | +610 | ||
| 1206 | +611 | ! |
- start_bins <- as.integer(seq(1, length(arr_num), length.out = bins))+ if (!is.null(color_by)) {
|
| 1207 | +612 | ! |
- labels_start <- as.character(as.Date(arr_num[start_bins], origin = as.Date("1970-01-01")))
+ observeEvent( |
| 1208 | +613 | ! |
- labels <- paste("Start:", labels_start)
+ eventExpr = merged$anl_input_r()$columns_source$color_by, |
| 1209 | -+ | ||
| 614 | +! |
-
+ handlerExpr = {
|
|
| 1210 | +615 | ! |
- sparkline::spk_chr(+ color_by_var <- as.vector(merged$anl_input_r()$columns_source$color_by) |
| 1211 | +616 | ! |
- unname(counts),+ if (length(color_by_var) > 0) {
|
| 1212 | +617 | ! |
- type = "bar",+ shinyjs::hide("color")
|
| 1213 | -! | +||
| 618 | +
- chartRangeMin = 0,+ } else {
|
||
| 1214 | +619 | ! |
- chartRangeMax = max_value,+ shinyjs::show("color")
+ |
+
| 620 | ++ |
+ }+ |
+ |
| 621 | ++ |
+ }+ |
+ |
| 622 | ++ |
+ )+ |
+ |
| 623 | ++ |
+ }+ |
+ |
| 624 | ++ | + | |
| 1215 | +625 | ! |
- width = width,+ output$num_na_removed <- renderUI({
|
| 1216 | +626 | ! |
- barWidth = bar_width,+ if (add_trend_line()) {
|
| 1217 | +627 | ! |
- barSpacing = bar_spacing,+ ANL <- merged$anl_q_r()[["ANL"]] |
| 1218 | +628 | ! |
- tooltipFormatter = custom_sparkline_formatter(labels, counts)+ x_var <- as.vector(merged$anl_input_r()$columns_source$x) |
| 1219 | -+ | ||
| 629 | +! |
- )+ y_var <- as.vector(merged$anl_input_r()$columns_source$y) |
|
| 1220 | -+ | ||
| 630 | +! |
- }+ if ((num_total_na <- nrow(ANL) - nrow(stats::na.omit(ANL[, c(x_var, y_var)]))) > 0) {
|
|
| 1221 | -+ | ||
| 631 | +! |
-
+ tags$div(paste(num_total_na, "row(s) with missing values were removed"), tags$hr()) |
|
| 1222 | +632 |
- #' @rdname create_sparklines+ } |
|
| 1223 | +633 |
- #' @keywords internal+ } |
|
| 1224 | +634 |
- #' @export+ }) |
|
| 1225 | +635 |
- create_sparklines.POSIXct <- function(arr, width = 150, bar_spacing = 5, bar_width = 20, ...) {
+
|
|
| 1226 | +636 | ! |
- arr_num <- as.numeric(arr)+ observeEvent( |
| 1227 | +637 | ! |
- arr_num <- sort(arr_num, decreasing = FALSE, method = "radix")+ eventExpr = merged$anl_input_r()$columns_source[c("col_facet", "row_facet")],
|
| 1228 | +638 | ! |
- binwidth <- get_bin_width(arr_num, 1)+ handlerExpr = {
|
| 1229 | +639 | ! |
- bins <- floor(diff(range(arr_num)) / binwidth) + 1+ if ( |
| 1230 | +640 | ! |
- if (all(is.na(bins))) {
+ length(merged$anl_input_r()$columns_source$col_facet) == 0 && |
| 1231 | +641 | ! |
- return(as.character(tags$code("only NA", class = "text-blue")))
+ length(merged$anl_input_r()$columns_source$row_facet) == 0 |
| 1232 | -! | +||
| 642 | +
- } else if (bins == 1) {
+ ) {
|
||
| 1233 | +643 | ! |
- return(as.character(tags$code("one date-time", class = "text-blue")))
+ shinyjs::hide("free_scales")
|
| 1234 | +644 |
- }+ } else {
|
|
| 1235 | +645 | ! |
- counts <- as.vector(unname(base::table(cut(arr_num, breaks = bins))))+ shinyjs::show("free_scales")
|
| 1236 | -! | +||
| 646 | +
- max_value <- max(counts)+ } |
||
| 1237 | +647 |
-
+ } |
|
| 1238 | -! | +||
| 648 | +
- start_bins <- as.integer(seq(1, length(arr_num), length.out = bins))+ )+ |
+ ||
| 649 | ++ | + | |
| 1239 | +650 | ! |
- labels_start <- as.character(format(as.POSIXct(arr_num[start_bins], origin = as.Date("1970-01-01")), "%Y-%m-%d"))
+ output_q <- reactive({
|
| 1240 | +651 | ! |
- labels <- paste("Start:", labels_start)
+ teal::validate_inputs(iv_r(), iv_facet) |
| 1241 | +652 | ||
| 1242 | +653 | ! |
- sparkline::spk_chr(+ ANL <- merged$anl_q_r()[["ANL"]] |
| 1243 | -! | +||
| 654 | +
- unname(counts),+ |
||
| 1244 | +655 | ! |
- type = "bar",+ x_var <- as.vector(merged$anl_input_r()$columns_source$x) |
| 1245 | +656 | ! |
- chartRangeMin = 0,+ y_var <- as.vector(merged$anl_input_r()$columns_source$y) |
| 1246 | +657 | ! |
- chartRangeMax = max_value,+ color_by_var <- as.vector(merged$anl_input_r()$columns_source$color_by) |
| 1247 | +658 | ! |
- width = width,+ size_by_var <- as.vector(merged$anl_input_r()$columns_source$size_by) |
| 1248 | +659 | ! |
- barWidth = bar_width,+ row_facet_name <- if (length(merged$anl_input_r()$columns_source$row_facet) == 0) {
|
| 1249 | +660 | ! |
- barSpacing = bar_spacing,+ character(0)+ |
+
| 661 | ++ |
+ } else {
|
|
| 1250 | +662 | ! |
- tooltipFormatter = custom_sparkline_formatter(labels, counts)+ as.vector(merged$anl_input_r()$columns_source$row_facet) |
| 1251 | +663 |
- )+ } |
|
| 1252 | -+ | ||
| 664 | +! |
- }+ col_facet_name <- if (length(merged$anl_input_r()$columns_source$col_facet) == 0) {
|
|
| 1253 | -+ | ||
| 665 | +! |
-
+ character(0) |
|
| 1254 | +666 |
- #' @rdname create_sparklines+ } else {
|
|
| 1255 | -+ | ||
| 667 | +! |
- #' @keywords internal+ as.vector(merged$anl_input_r()$columns_source$col_facet) |
|
| 1256 | +668 |
- #' @export+ } |
|
| 1257 | -+ | ||
| 669 | +! |
- create_sparklines.POSIXlt <- function(arr, width = 150, bar_spacing = 5, bar_width = 20, ...) {
+ alpha <- input$alpha |
|
| 1258 | +670 | ! |
- arr_num <- as.numeric(arr)+ size <- input$size |
| 1259 | +671 | ! |
- arr_num <- sort(arr_num, decreasing = FALSE, method = "radix")+ rotate_xaxis_labels <- input$rotate_xaxis_labels |
| 1260 | +672 | ! |
- binwidth <- get_bin_width(arr_num, 1)+ add_density <- input$add_density |
| 1261 | +673 | ! |
- bins <- floor(diff(range(arr_num)) / binwidth) + 1+ ggtheme <- input$ggtheme |
| 1262 | +674 | ! |
- if (all(is.na(bins))) {
+ rug_plot <- input$rug_plot |
| 1263 | +675 | ! |
- return(as.character(tags$code("only NA", class = "text-blue")))
+ color <- input$color |
| 1264 | +676 | ! |
- } else if (bins == 1) {
+ shape <- `if`(is.null(input$shape) || identical(input$shape, ""), "circle", input$shape) |
| 1265 | +677 | ! |
- return(as.character(tags$code("one date-time", class = "text-blue")))
+ smoothing_degree <- as.integer(input$smoothing_degree)+ |
+
| 678 | +! | +
+ ci <- input$ci |
|
| 1266 | +679 |
- }+ |
|
| 1267 | +680 | ! |
- counts <- as.vector(unname(base::table(cut(arr_num, breaks = bins))))+ log_x <- input$log_x |
| 1268 | +681 | ! |
- max_value <- max(counts)+ log_y <- input$log_y |
| 1269 | +682 | ||
| 1270 | +683 | ! |
- start_bins <- as.integer(seq(1, length(arr_num), length.out = bins))+ validate(need( |
| 1271 | +684 | ! |
- labels_start <- as.character(format(as.POSIXct(arr_num[start_bins], origin = as.Date("1970-01-01")), "%Y-%m-%d"))
+ length(row_facet_name) == 0 || inherits(ANL[[row_facet_name]], c("character", "factor", "Date", "integer")),
|
| 1272 | +685 | ! |
- labels <- paste("Start:", labels_start)
+ "`Row facetting` variable must be of class `character`, `factor`, `Date`, or `integer`" |
| 1273 | +686 |
-
+ )) |
|
| 1274 | +687 | ! |
- sparkline::spk_chr(+ validate(need( |
| 1275 | +688 | ! |
- unname(counts),+ length(col_facet_name) == 0 || inherits(ANL[[col_facet_name]], c("character", "factor", "Date", "integer")),
|
| 1276 | +689 | ! |
- type = "bar",+ "`Column facetting` variable must be of class `character`, `factor`, `Date`, or `integer`" |
| 1277 | -! | +||
| 690 | +
- chartRangeMin = 0,+ ))+ |
+ ||
| 691 | ++ | + | |
| 1278 | +692 | ! |
- chartRangeMax = max_value,+ if (add_density && length(color_by_var) > 0) {
|
| 1279 | +693 | ! |
- width = width,+ validate(need( |
| 1280 | +694 | ! |
- barWidth = bar_width,+ !is.numeric(ANL[[color_by_var]]), |
| 1281 | +695 | ! |
- barSpacing = bar_spacing,+ "Marginal plots cannot be produced when the points are colored by numeric variables. |
| 1282 | +696 | ! |
- tooltipFormatter = custom_sparkline_formatter(labels, counts)+ \n Uncheck the 'Add marginal density' checkbox to display the plot." |
| 1283 | +697 |
- )+ )) |
|
| 1284 | -+ | ||
| 698 | +! |
- }+ validate(need( |
|
| 1285 | +699 |
-
+ !( |
|
| 1286 | -+ | ||
| 700 | +! |
- #' @rdname create_sparklines+ inherits(ANL[[color_by_var]], "Date") || |
|
| 1287 | -+ | ||
| 701 | +! |
- #' @keywords internal+ inherits(ANL[[color_by_var]], "POSIXct") || |
|
| 1288 | -+ | ||
| 702 | +! |
- #' @export+ inherits(ANL[[color_by_var]], "POSIXlt") |
|
| 1289 | +703 |
- create_sparklines.default <- function(arr, width = 150, ...) {
+ ), |
|
| 1290 | +704 | ! |
- as.character(tags$code("unsupported variable type", class = "text-blue"))
+ "Marginal plots cannot be produced when the points are colored by Date or POSIX variables. |
| 1291 | -+ | ||
| 705 | +! |
- }+ \n Uncheck the 'Add marginal density' checkbox to display the plot." |
|
| 1292 | +706 |
-
+ )) |
|
| 1293 | +707 |
-
+ } |
|
| 1294 | +708 |
- custom_sparkline_formatter <- function(labels, counts) {
+
|
|
| 1295 | +709 | ! |
- htmlwidgets::JS(+ teal::validate_has_data(ANL[, c(x_var, y_var)], 10, complete = TRUE, allow_inf = FALSE) |
| 1296 | -! | +||
| 710 | +
- sprintf(+ |
||
| 1297 | +711 | ! |
- "function(sparkline, options, field) {
+ if (log_x) {
|
| 1298 | +712 | ! |
- return 'ID: ' + %s[field[0].offset] + '<br>' + 'Count: ' + %s[field[0].offset];+ validate( |
| 1299 | -+ | ||
| 713 | +! |
- }",+ need( |
|
| 1300 | +714 | ! |
- jsonlite::toJSON(labels),+ is.numeric(ANL[[x_var]]) && all( |
| 1301 | +715 | ! |
- jsonlite::toJSON(counts)+ ANL[[x_var]] > 0 | is.na(ANL[[x_var]]) |
| 1302 | +716 |
- )+ ), |
|
| 1303 | -+ | ||
| 717 | +! |
- )+ "X variable can only be log transformed if variable is numeric and all values are positive." |
|
| 1304 | +718 |
- }+ ) |
| 1 | +719 |
- #' `teal` module: Principal component analysis+ ) |
|
| 2 | +720 |
- #'+ } |
|
| 3 | -+ | ||
| 721 | +! |
- #' Module conducts principal component analysis (PCA) on a given dataset and offers different+ if (log_y) {
|
|
| 4 | -+ | ||
| 722 | +! |
- #' ways of visualizing the outcomes, including elbow plot, circle plot, biplot, and eigenvector plot.+ validate( |
|
| 5 | -+ | ||
| 723 | +! |
- #' Additionally, it enables dynamic customization of plot aesthetics, such as opacity, size, and+ need( |
|
| 6 | -+ | ||
| 724 | +! |
- #' font size, through UI inputs.+ is.numeric(ANL[[y_var]]) && all( |
|
| 7 | -+ | ||
| 725 | +! |
- #'+ ANL[[y_var]] > 0 | is.na(ANL[[y_var]]) |
|
| 8 | +726 |
- #' @inheritParams teal::module+ ), |
|
| 9 | -+ | ||
| 727 | +! |
- #' @inheritParams shared_params+ "Y variable can only be log transformed if variable is numeric and all values are positive." |
|
| 10 | +728 |
- #' @param dat (`data_extract_spec` or `list` of multiple `data_extract_spec`)+ ) |
|
| 11 | +729 |
- #' specifying columns used to compute PCA.+ ) |
|
| 12 | +730 |
- #' @param font_size (`numeric`) optional, specifies font size.+ } |
|
| 13 | +731 |
- #' It controls the font size for plot titles, axis labels, and legends.+ |
|
| 14 | -+ | ||
| 732 | +! |
- #' - If vector of `length == 1` then the font sizes will have a fixed size.+ facet_cl <- facet_ggplot_call( |
|
| 15 | -+ | ||
| 733 | +! |
- #' - while vector of `value`, `min`, and `max` allows dynamic adjustment.+ row_facet_name, |
|
| 16 | -+ | ||
| 734 | +! |
- #' @param ggplot2_args `r roxygen_ggplot2_args_param("Elbow plot", "Circle plot", "Biplot", "Eigenvector plot")`
+ col_facet_name, |
|
| 17 | -+ | ||
| 735 | +! |
- #' @param decorators `r roxygen_decorators_param("tm_a_pca")`
+ free_x_scales = isTRUE(input$free_scales), |
|
| 18 | -+ | ||
| 736 | +! |
- #'+ free_y_scales = isTRUE(input$free_scales) |
|
| 19 | +737 |
- #' @inherit shared_params return+ ) |
|
| 20 | +738 |
- #'+ |
|
| 21 | -+ | ||
| 739 | +! |
- #' @section Decorating `tm_a_pca`:+ point_sizes <- if (length(size_by_var) > 0) {
|
|
| 22 | -+ | ||
| 740 | +! |
- #'+ validate(need(is.numeric(ANL[[size_by_var]]), "Variable to size by must be numeric")) |
|
| 23 | -+ | ||
| 741 | +! |
- #' This module generates the following objects, which can be modified in place using decorators:+ substitute( |
|
| 24 | -+ | ||
| 742 | +! |
- #' - `elbow_plot` (`ggplot2`)+ expr = size * ANL[[size_by_var]] / max(ANL[[size_by_var]], na.rm = TRUE), |
|
| 25 | -+ | ||
| 743 | +! |
- #' - `circle_plot` (`ggplot2`)+ env = list(size = size, size_by_var = size_by_var) |
|
| 26 | +744 |
- #' - `biplot` (`ggplot2`)+ ) |
|
| 27 | +745 |
- #' - `eigenvector_plot` (`ggplot2`)+ } else {
|
|
| 28 | -+ | ||
| 746 | +! |
- #'+ size |
|
| 29 | +747 |
- #' Decorators can be applied to all outputs or only to specific objects using a+ } |
|
| 30 | +748 |
- #' named list of `teal_transform_module` objects.+ |
|
| 31 | -+ | ||
| 749 | +! |
- #' The `"default"` name is reserved for decorators that are applied to all outputs.+ plot_q <- merged$anl_q_r() |
|
| 32 | +750 |
- #' See code snippet below:+ |
|
| 33 | -+ | ||
| 751 | +! |
- #'+ if (log_x) {
|
|
| 34 | -+ | ||
| 752 | +! |
- #' ```+ log_x_fn <- input$log_x_base |
|
| 35 | -+ | ||
| 753 | +! |
- #' tm_a_pca(+ plot_q <- teal.code::eval_code( |
|
| 36 | -+ | ||
| 754 | +! |
- #' ..., # arguments for module+ object = plot_q, |
|
| 37 | -+ | ||
| 755 | +! |
- #' decorators = list(+ code = substitute( |
|
| 38 | -+ | ||
| 756 | +! |
- #' default = list(teal_transform_module(...)), # applied to all outputs+ expr = ANL[, log_x_var] <- log_x_fn(ANL[, x_var]), |
|
| 39 | -+ | ||
| 757 | +! |
- #' elbow_plot = list(teal_transform_module(...)), # applied only to `elbow_plot` output+ env = list( |
|
| 40 | -+ | ||
| 758 | +! |
- #' circle_plot = list(teal_transform_module(...)) # applied only to `circle_plot` output+ x_var = x_var, |
|
| 41 | -+ | ||
| 759 | +! |
- #' biplot = list(teal_transform_module(...)) # applied only to `biplot` output+ log_x_fn = as.name(log_x_fn), |
|
| 42 | -+ | ||
| 760 | +! |
- #' eigenvector_plot = list(teal_transform_module(...)) # applied only to `eigenvector_plot` output+ log_x_var = paste0(log_x_fn, "_", x_var) |
|
| 43 | +761 |
- #' )+ ) |
|
| 44 | +762 |
- #' )+ ) |
|
| 45 | +763 |
- #' ```+ ) |
|
| 46 | +764 |
- #'+ } |
|
| 47 | +765 |
- #' For additional details and examples of decorators, refer to the vignette+ |
|
| 48 | -+ | ||
| 766 | +! |
- #' `vignette("decorate-modules-output", package = "teal")` or the [`teal::teal_transform_module()`] documentation.
+ if (log_y) {
|
|
| 49 | -+ | ||
| 767 | +! |
- #'+ log_y_fn <- input$log_y_base |
|
| 50 | -+ | ||
| 768 | +! |
- #' @examplesShinylive+ plot_q <- teal.code::eval_code( |
|
| 51 | -+ | ||
| 769 | +! |
- #' library(teal.modules.general)+ object = plot_q, |
|
| 52 | -+ | ||
| 770 | +! |
- #' interactive <- function() TRUE+ code = substitute( |
|
| 53 | -+ | ||
| 771 | +! |
- #' {{ next_example }}
+ expr = ANL[, log_y_var] <- log_y_fn(ANL[, y_var]), |
|
| 54 | -+ | ||
| 772 | +! |
- #' @examples+ env = list( |
|
| 55 | -+ | ||
| 773 | +! |
- #'+ y_var = y_var, |
|
| 56 | -+ | ||
| 774 | +! |
- #' # general data example+ log_y_fn = as.name(log_y_fn), |
|
| 57 | -+ | ||
| 775 | +! |
- #' data <- teal_data()+ log_y_var = paste0(log_y_fn, "_", y_var) |
|
| 58 | +776 |
- #' data <- within(data, {
+ ) |
|
| 59 | +777 |
- #' require(nestcolor)+ ) |
|
| 60 | +778 |
- #' USArrests <- USArrests+ ) |
|
| 61 | +779 |
- #' })+ } |
|
| 62 | +780 |
- #'+ |
|
| 63 | -+ | ||
| 781 | +! |
- #' app <- init(+ pre_pro_anl <- if (input$show_count) {
|
|
| 64 | -+ | ||
| 782 | +! |
- #' data = data,+ paste0( |
|
| 65 | -+ | ||
| 783 | +! |
- #' modules = modules(+ "ANL %>% dplyr::group_by(",
|
|
| 66 | -+ | ||
| 784 | +! |
- #' tm_a_pca(+ paste( |
|
| 67 | -+ | ||
| 785 | +! |
- #' "PCA",+ c( |
|
| 68 | -+ | ||
| 786 | +! |
- #' dat = data_extract_spec(+ if (length(color_by_var) > 0 && inherits(ANL[[color_by_var]], c("factor", "character"))) color_by_var,
|
|
| 69 | -+ | ||
| 787 | +! |
- #' dataname = "USArrests",+ row_facet_name, |
|
| 70 | -+ | ||
| 788 | +! |
- #' select = select_spec(+ col_facet_name |
|
| 71 | +789 |
- #' choices = variable_choices(+ ), |
|
| 72 | -+ | ||
| 790 | +! |
- #' data = data[["USArrests"]], c("Murder", "Assault", "UrbanPop", "Rape")
+ collapse = ", " |
|
| 73 | +791 |
- #' ),+ ), |
|
| 74 | -+ | ||
| 792 | +! |
- #' selected = c("Murder", "Assault"),
+ ") %>% dplyr::mutate(n = dplyr::n()) %>% dplyr::ungroup()" |
|
| 75 | +793 |
- #' multiple = TRUE+ ) |
|
| 76 | +794 |
- #' ),+ } else {
|
|
| 77 | -+ | ||
| 795 | +! |
- #' filter = NULL+ "ANL" |
|
| 78 | +796 |
- #' )+ } |
|
| 79 | +797 |
- #' )+ |
|
| 80 | -- |
- #' )- |
- |
| 81 | -- |
- #' )- |
- |
| 82 | -+ | ||
| 798 | +! |
- #' if (interactive()) {
+ plot_call <- substitute(expr = pre_pro_anl %>% ggplot(), env = list(pre_pro_anl = str2lang(pre_pro_anl))) |
|
| 83 | +799 |
- #' shinyApp(app$ui, app$server)+ |
|
| 84 | -+ | ||
| 800 | +! |
- #' }+ plot_call <- if (length(color_by_var) == 0) {
|
|
| 85 | -+ | ||
| 801 | +! |
- #'+ substitute( |
|
| 86 | -+ | ||
| 802 | +! |
- #' @examplesShinylive+ expr = plot_call + |
|
| 87 | -+ | ||
| 803 | +! |
- #' library(teal.modules.general)+ ggplot2::aes(x = x_name, y = y_name) + |
|
| 88 | -+ | ||
| 804 | +! |
- #' interactive <- function() TRUE+ ggplot2::geom_point(alpha = alpha_value, size = point_sizes, shape = shape_value, color = color_value), |
|
| 89 | -+ | ||
| 805 | +! |
- #' {{ next_example }}
+ env = list( |
|
| 90 | -+ | ||
| 806 | +! |
- #' @examples+ plot_call = plot_call, |
|
| 91 | -+ | ||
| 807 | +! |
- #'+ x_name = if (log_x) as.name(paste0(log_x_fn, "_", x_var)) else as.name(x_var), |
|
| 92 | -+ | ||
| 808 | +! |
- #' # CDISC data example+ y_name = if (log_y) as.name(paste0(log_y_fn, "_", y_var)) else as.name(y_var), |
|
| 93 | -+ | ||
| 809 | +! |
- #' data <- teal_data()+ alpha_value = alpha, |
|
| 94 | -+ | ||
| 810 | +! |
- #' data <- within(data, {
+ point_sizes = point_sizes, |
|
| 95 | -+ | ||
| 811 | +! |
- #' require(nestcolor)+ shape_value = shape, |
|
| 96 | -+ | ||
| 812 | +! |
- #' ADSL <- rADSL+ color_value = color |
|
| 97 | +813 |
- #' })+ ) |
|
| 98 | +814 |
- #' join_keys(data) <- default_cdisc_join_keys[names(data)]+ ) |
|
| 99 | +815 |
- #'+ } else {
|
|
| 100 | -+ | ||
| 816 | +! |
- #' app <- init(+ substitute( |
|
| 101 | -+ | ||
| 817 | +! |
- #' data = data,+ expr = plot_call + |
|
| 102 | -+ | ||
| 818 | +! |
- #' modules = modules(+ ggplot2::aes(x = x_name, y = y_name, color = color_by_var_name) + |
|
| 103 | -+ | ||
| 819 | +! |
- #' tm_a_pca(+ ggplot2::geom_point(alpha = alpha_value, size = point_sizes, shape = shape_value), |
|
| 104 | -+ | ||
| 820 | +! |
- #' "PCA",+ env = list( |
|
| 105 | -+ | ||
| 821 | +! |
- #' dat = data_extract_spec(+ plot_call = plot_call, |
|
| 106 | -+ | ||
| 822 | +! |
- #' dataname = "ADSL",+ x_name = if (log_x) as.name(paste0(log_x_fn, "_", x_var)) else as.name(x_var), |
|
| 107 | -+ | ||
| 823 | +! |
- #' select = select_spec(+ y_name = if (log_y) as.name(paste0(log_y_fn, "_", y_var)) else as.name(y_var), |
|
| 108 | -+ | ||
| 824 | +! |
- #' choices = variable_choices(+ color_by_var_name = as.name(color_by_var), |
|
| 109 | -+ | ||
| 825 | +! |
- #' data = data[["ADSL"]], c("BMRKR1", "AGE", "EOSDY")
+ alpha_value = alpha, |
|
| 110 | -+ | ||
| 826 | +! |
- #' ),+ point_sizes = point_sizes, |
|
| 111 | -+ | ||
| 827 | +! |
- #' selected = c("BMRKR1", "AGE"),
+ shape_value = shape |
|
| 112 | +828 |
- #' multiple = TRUE+ ) |
|
| 113 | +829 |
- #' ),+ ) |
|
| 114 | +830 |
- #' filter = NULL+ } |
|
| 115 | +831 |
- #' )+ |
|
| 116 | -+ | ||
| 832 | +! |
- #' )+ if (rug_plot) plot_call <- substitute(expr = plot_call + geom_rug(), env = list(plot_call = plot_call)) |
|
| 117 | +833 |
- #' )+ |
|
| 118 | -+ | ||
| 834 | +! |
- #' )+ plot_label_generator <- function(rhs_formula = quote(y ~ 1), |
|
| 119 | -+ | ||
| 835 | +! |
- #' if (interactive()) {
+ show_form = input$show_form, |
|
| 120 | -+ | ||
| 836 | +! |
- #' shinyApp(app$ui, app$server)+ show_r2 = input$show_r2, |
|
| 121 | -+ | ||
| 837 | +! |
- #' }+ show_count = input$show_count, |
|
| 122 | -+ | ||
| 838 | +! |
- #'+ pos = input$pos, |
|
| 123 | -+ | ||
| 839 | +! |
- #' @export+ label_size = input$label_size) {
|
|
| 124 | -+ | ||
| 840 | +! |
- #'+ stopifnot(sum(show_form, show_r2, show_count) >= 1) |
|
| 125 | -+ | ||
| 841 | +! |
- tm_a_pca <- function(label = "Principal Component Analysis",+ aes_label <- paste0( |
|
| 126 | -+ | ||
| 842 | +! |
- dat,+ "aes(",
|
|
| 127 | -+ | ||
| 843 | +! |
- plot_height = c(600, 200, 2000),+ if (show_count) "n = n, ", |
|
| 128 | -+ | ||
| 844 | +! |
- plot_width = NULL,+ "label = ", |
|
| 129 | -+ | ||
| 845 | +! |
- ggtheme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void"),
+ if (sum(show_form, show_r2, show_count) > 1) "paste(",
|
|
| 130 | -+ | ||
| 846 | +! |
- ggplot2_args = teal.widgets::ggplot2_args(),+ paste( |
|
| 131 | -+ | ||
| 847 | +! |
- rotate_xaxis_labels = FALSE,+ c( |
|
| 132 | -+ | ||
| 848 | +! |
- font_size = c(12, 8, 20),+ if (show_form) "stat(eq.label)", |
|
| 133 | -+ | ||
| 849 | +! |
- alpha = c(1, 0, 1),+ if (show_r2) "stat(adj.rr.label)", |
|
| 134 | -+ | ||
| 850 | +! |
- size = c(2, 1, 8),+ if (show_count) "paste('N ~`=`~', n)"
|
|
| 135 | +851 |
- pre_output = NULL,+ ), |
|
| 136 | -+ | ||
| 852 | +! |
- post_output = NULL,+ collapse = ", " |
|
| 137 | +853 |
- decorators = NULL) {
+ ), |
|
| 138 | +854 | ! |
- message("Initializing tm_a_pca")
+ if (sum(show_form, show_r2, show_count) > 1) ", sep = '*\", \"*'))" else ")" |
| 139 | +855 |
-
+ ) |
|
| 140 | -+ | ||
| 856 | +! |
- # Normalize the parameters+ label_geom <- substitute( |
|
| 141 | +857 | ! |
- if (inherits(dat, "data_extract_spec")) dat <- list(dat)+ expr = ggpmisc::stat_poly_eq( |
| 142 | +858 | ! |
- if (inherits(ggplot2_args, "ggplot2_args")) ggplot2_args <- list(default = ggplot2_args)+ mapping = aes_label, |
| 143 | -+ | ||
| 859 | +! |
-
+ formula = rhs_formula, |
|
| 144 | -+ | ||
| 860 | +! |
- # Start of assertions+ parse = TRUE, |
|
| 145 | +861 | ! |
- checkmate::assert_string(label)+ label.x = pos, |
| 146 | +862 | ! |
- checkmate::assert_list(dat, types = "data_extract_spec")+ size = label_size |
| 147 | +863 | - - | -|
| 148 | -! | -
- checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE)+ ), |
|
| 149 | +864 | ! |
- checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height")+ env = list( |
| 150 | +865 | ! |
- checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE)+ rhs_formula = rhs_formula, |
| 151 | +866 | ! |
- checkmate::assert_numeric(+ pos = pos, |
| 152 | +867 | ! |
- plot_width[1],+ aes_label = str2lang(aes_label), |
| 153 | +868 | ! |
- lower = plot_width[2], upper = plot_width[3], null.ok = TRUE, .var.name = "plot_width"+ label_size = label_size |
| 154 | +869 |
- )+ ) |
|
| 155 | +870 |
-
+ ) |
|
| 156 | +871 | ! |
- ggtheme <- match.arg(ggtheme)+ substitute( |
| 157 | -+ | ||
| 872 | +! |
-
+ expr = plot_call + label_geom, |
|
| 158 | +873 | ! |
- plot_choices <- c("Elbow plot", "Circle plot", "Biplot", "Eigenvector plot")
+ env = list( |
| 159 | +874 | ! |
- checkmate::assert_list(ggplot2_args, types = "ggplot2_args")+ plot_call = plot_call, |
| 160 | +875 | ! |
- checkmate::assert_subset(names(ggplot2_args), c("default", plot_choices))
+ label_geom = label_geom |
| 161 | +876 |
-
+ ) |
|
| 162 | -! | +||
| 877 | +
- checkmate::assert_flag(rotate_xaxis_labels)+ ) |
||
| 163 | +878 |
-
+ } |
|
| 164 | -! | +||
| 879 | +
- if (length(font_size) == 1) {
+
|
||
| 165 | +880 | ! |
- checkmate::assert_numeric(font_size, any.missing = FALSE, finite = TRUE, lower = 8, upper = 20)+ if (trend_line_is_applicable()) {
|
| 166 | -+ | ||
| 881 | +! |
- } else {
+ shinyjs::hide("line_msg")
|
|
| 167 | +882 | ! |
- checkmate::assert_numeric(font_size, len = 3, any.missing = FALSE, finite = TRUE, lower = 8, upper = 20)+ shinyjs::show("smoothing_degree")
|
| 168 | +883 | ! |
- checkmate::assert_numeric(font_size[1], lower = font_size[2], upper = font_size[3], .var.name = "font_size")+ if (!add_trend_line()) {
|
| 169 | -+ | ||
| 884 | +! |
- }+ shinyjs::hide("ci")
|
|
| 170 | -+ | ||
| 885 | +! |
-
+ shinyjs::hide("color_sub")
|
|
| 171 | +886 | ! |
- if (length(alpha) == 1) {
+ shinyjs::hide("show_form")
|
| 172 | +887 | ! |
- checkmate::assert_numeric(alpha, any.missing = FALSE, finite = TRUE, lower = 0, upper = 1)+ shinyjs::hide("show_r2")
|
| 173 | -+ | ||
| 888 | +! |
- } else {
+ if (input$show_count) {
|
|
| 174 | +889 | ! |
- checkmate::assert_numeric(alpha, len = 3, any.missing = FALSE, finite = TRUE, lower = 0, upper = 1)+ plot_call <- plot_label_generator(show_form = FALSE, show_r2 = FALSE) |
| 175 | +890 | ! |
- checkmate::assert_numeric(alpha[1], lower = alpha[2], upper = alpha[3], .var.name = "alpha")+ shinyjs::show("label_pos")
|
| 176 | -+ | ||
| 891 | +! |
- }+ shinyjs::show("label_size")
|
|
| 177 | +892 |
-
+ } else {
|
|
| 178 | +893 | ! |
- if (length(size) == 1) {
+ shinyjs::hide("label_pos")
|
| 179 | +894 | ! |
- checkmate::assert_numeric(size, any.missing = FALSE, finite = TRUE, lower = 1, upper = 8)+ shinyjs::hide("label_size")
|
| 180 | +895 |
- } else {
+ } |
|
| 181 | -! | +||
| 896 | +
- checkmate::assert_numeric(size, len = 3, any.missing = FALSE, finite = TRUE, lower = 1, upper = 8)+ } else {
|
||
| 182 | +897 | ! |
- checkmate::assert_numeric(size[1], lower = size[2], upper = size[3], .var.name = "size")+ shinyjs::show("ci")
|
| 183 | -+ | ||
| 898 | +! |
- }+ shinyjs::show("show_form")
|
|
| 184 | -+ | ||
| 899 | +! |
-
+ shinyjs::show("show_r2")
|
|
| 185 | +900 | ! |
- checkmate::assert_multi_class(pre_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
+ if (nrow(ANL) - nrow(stats::na.omit(ANL[, c(x_var, y_var)])) > 0) {
|
| 186 | +901 | ! |
- checkmate::assert_multi_class(post_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
+ plot_q <- teal.code::eval_code( |
| 187 | -+ | ||
| 902 | +! |
-
+ plot_q, |
|
| 188 | +903 | ! |
- available_decorators <- c("elbow_plot", "circle_plot", "biplot", "eigenvector_plot")
+ substitute( |
| 189 | +904 | ! |
- decorators <- normalize_decorators(decorators)+ expr = ANL <- dplyr::filter(ANL, !is.na(x_var) & !is.na(y_var)), |
| 190 | +905 | ! |
- assert_decorators(decorators, null.ok = TRUE, available_decorators)+ env = list(x_var = as.name(x_var), y_var = as.name(y_var)) |
| 191 | +906 |
- # End of assertions+ ) |
|
| 192 | +907 |
-
+ ) |
|
| 193 | +908 |
- # Make UI args+ } |
|
| 194 | +909 | ! |
- args <- as.list(environment())+ rhs_formula <- substitute( |
| 195 | -+ | ||
| 910 | +! |
-
+ expr = y ~ poly(x, smoothing_degree, raw = TRUE), |
|
| 196 | +911 | ! |
- data_extract_list <- list(dat = dat)+ env = list(smoothing_degree = smoothing_degree) |
| 197 | +912 |
-
+ ) |
|
| 198 | +913 | ! |
- ans <- module(+ if (input$show_form || input$show_r2 || input$show_count) {
|
| 199 | +914 | ! |
- label = label,+ plot_call <- plot_label_generator(rhs_formula = rhs_formula) |
| 200 | +915 | ! |
- server = srv_a_pca,+ shinyjs::show("label_pos")
|
| 201 | +916 | ! |
- ui = ui_a_pca,+ shinyjs::show("label_size")
|
| 202 | -! | +||
| 917 | +
- ui_args = args,+ } else {
|
||
| 203 | +918 | ! |
- server_args = c(+ shinyjs::hide("label_pos")
|
| 204 | +919 | ! |
- data_extract_list,+ shinyjs::hide("label_size")
|
| 205 | -! | +||
| 920 | +
- list(+ } |
||
| 206 | +921 | ! |
- plot_height = plot_height,+ plot_call <- substitute( |
| 207 | +922 | ! |
- plot_width = plot_width,+ expr = plot_call + ggplot2::geom_smooth(formula = rhs_formula, se = TRUE, level = ci, method = "lm"), |
| 208 | +923 | ! |
- ggplot2_args = ggplot2_args,+ env = list(plot_call = plot_call, rhs_formula = rhs_formula, ci = ci) |
| 209 | -! | +||
| 924 | +
- decorators = decorators+ ) |
||
| 210 | +925 |
- )+ } |
|
| 211 | +926 |
- ),+ } else {
|
|
| 212 | +927 | ! |
- datanames = teal.transform::get_extract_datanames(data_extract_list)+ shinyjs::hide("smoothing_degree")
|
| 213 | -+ | ||
| 928 | +! |
- )+ shinyjs::hide("ci")
|
|
| 214 | +929 | ! |
- attr(ans, "teal_bookmarkable") <- FALSE+ shinyjs::hide("color_sub")
|
| 215 | +930 | ! |
- ans+ shinyjs::hide("show_form")
|
| 216 | -+ | ||
| 931 | +! |
- }+ shinyjs::hide("show_r2")
|
|
| 217 | -+ | ||
| 932 | +! |
-
+ if (input$show_count) {
|
|
| 218 | -+ | ||
| 933 | +! |
- # UI function for the PCA module+ plot_call <- plot_label_generator(show_form = FALSE, show_r2 = FALSE) |
|
| 219 | -+ | ||
| 934 | +! |
- ui_a_pca <- function(id, ...) {
+ shinyjs::show("label_pos")
|
|
| 220 | +935 | ! |
- ns <- NS(id)+ shinyjs::show("label_size")
+ |
+
| 936 | ++ |
+ } else {
|
|
| 221 | +937 | ! |
- args <- list(...)+ shinyjs::hide("label_pos")
|
| 222 | +938 | ! |
- is_single_dataset_value <- teal.transform::is_single_dataset(args$dat)+ shinyjs::hide("label_size")
|
| 223 | +939 |
-
+ } |
|
| 224 | +940 | ! |
- color_selector <- args$dat+ shinyjs::show("line_msg")
|
| 225 | -! | +||
| 941 | +
- for (i in seq_along(color_selector)) {
+ } |
||
| 226 | -! | +||
| 942 | +
- color_selector[[i]]$select$multiple <- FALSE+ |
||
| 227 | +943 | ! |
- color_selector[[i]]$select$always_selected <- NULL+ if (!is.null(facet_cl)) {
|
| 228 | +944 | ! |
- color_selector[[i]]$select$selected <- NULL+ plot_call <- substitute(expr = plot_call + facet_cl, env = list(plot_call = plot_call, facet_cl = facet_cl)) |
| 229 | +945 |
- }+ } |
|
| 230 | +946 | ||
| 231 | +947 | ! |
- tagList(+ y_label <- varname_w_label( |
| 232 | +948 | ! |
- include_css_files("custom"),
+ y_var, |
| 233 | +949 | ! |
- teal.widgets::standard_layout(+ ANL, |
| 234 | +950 | ! |
- output = teal.widgets::white_small_well(+ prefix = if (log_y) paste(log_y_fn, "(") else NULL,
|
| 235 | +951 | ! |
- uiOutput(ns("all_plots"))
+ suffix = if (log_y) ")" else NULL |
| 236 | +952 |
- ),+ ) |
|
| 237 | +953 | ! |
- encoding = tags$div(- |
-
| 238 | -- |
- ### Reporter+ x_label <- varname_w_label( |
|
| 239 | +954 | ! |
- teal.reporter::simple_reporter_ui(ns("simple_reporter")),
+ x_var, |
| 240 | -+ | ||
| 955 | +! |
- ###+ ANL, |
|
| 241 | +956 | ! |
- tags$label("Encodings", class = "text-primary"),
+ prefix = if (log_x) paste(log_x_fn, "(") else NULL,
|
| 242 | +957 | ! |
- teal.transform::datanames_input(args["dat"]),+ suffix = if (log_x) ")" else NULL |
| 243 | -! | +||
| 958 | +
- teal.transform::data_extract_ui(+ ) |
||
| 244 | -! | +||
| 959 | +
- id = ns("dat"),
+
|
||
| 245 | +960 | ! |
- label = "Data selection",+ dev_ggplot2_args <- teal.widgets::ggplot2_args( |
| 246 | +961 | ! |
- data_extract_spec = args$dat,+ labs = list(y = y_label, x = x_label), |
| 247 | +962 | ! |
- is_single_dataset = is_single_dataset_value+ theme = list(legend.position = "bottom") |
| 248 | +963 |
- ),+ ) |
|
| 249 | -! | +||
| 964 | +
- teal.widgets::panel_group(+ |
||
| 250 | +965 | ! |
- teal.widgets::panel_item(+ if (rotate_xaxis_labels) {
|
| 251 | +966 | ! |
- title = "Display",+ dev_ggplot2_args$theme[["axis.text.x"]] <- quote(element_text(angle = 45, hjust = 1)) |
| 252 | -! | +||
| 967 | +
- collapsed = FALSE,+ } |
||
| 253 | -! | +||
| 968 | +
- checkboxGroupInput(+ |
||
| 254 | +969 | ! |
- ns("tables_display"),
+ all_ggplot2_args <- teal.widgets::resolve_ggplot2_args( |
| 255 | +970 | ! |
- "Tables display",+ user_plot = ggplot2_args, |
| 256 | -! | -
- choices = c("PC importance" = "importance", "Eigenvectors" = "eigenvector"),
- |
- |
| 257 | +971 | ! |
- selected = c("importance", "eigenvector")
+ module_plot = dev_ggplot2_args |
| 258 | +972 |
- ),+ ) |
|
| 259 | -! | +||
| 973 | +
- radioButtons(+ |
||
| 260 | +974 | ! |
- ns("plot_type"),
+ parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(all_ggplot2_args, ggtheme = ggtheme) |
| 261 | -! | +||
| 975 | +
- label = "Plot type",+ |
||
| 262 | -! | +||
| 976 | +
- choices = args$plot_choices,+ |
||
| 263 | +977 | ! |
- selected = args$plot_choices[1]- |
-
| 264 | -- |
- ),+ if (add_density) {
|
|
| 265 | +978 | ! |
- conditionalPanel(+ plot_call <- substitute( |
| 266 | +979 | ! |
- condition = sprintf("input['%s'] == 'Elbow plot'", ns("plot_type")),
+ expr = ggExtra::ggMarginal( |
| 267 | +980 | ! |
- ui_decorate_teal_data(+ plot_call + labs + ggthemes + themes, |
| 268 | +981 | ! |
- ns("d_elbow_plot"),
+ type = "density", |
| 269 | +982 | ! |
- decorators = select_decorators(args$decorators, "elbow_plot")+ groupColour = group_colour |
| 270 | +983 |
- )+ ), |
|
| 271 | -+ | ||
| 984 | +! |
- ),+ env = list( |
|
| 272 | +985 | ! |
- conditionalPanel(+ plot_call = plot_call, |
| 273 | +986 | ! |
- condition = sprintf("input['%s'] == 'Circle plot'", ns("plot_type")),
+ group_colour = if (length(color_by_var) > 0) TRUE else FALSE, |
| 274 | +987 | ! |
- ui_decorate_teal_data(+ labs = parsed_ggplot2_args$labs, |
| 275 | +988 | ! |
- ns("d_circle_plot"),
+ ggthemes = parsed_ggplot2_args$ggtheme, |
| 276 | +989 | ! |
- decorators = select_decorators(args$decorators, "circle_plot")+ themes = parsed_ggplot2_args$theme |
| 277 | +990 |
- )+ ) |
|
| 278 | +991 |
- ),+ ) |
|
| 279 | -! | +||
| 992 | +
- conditionalPanel(+ } else {
|
||
| 280 | +993 | ! |
- condition = sprintf("input['%s'] == 'Biplot'", ns("plot_type")),
+ plot_call <- substitute( |
| 281 | +994 | ! |
- ui_decorate_teal_data(+ expr = plot_call + |
| 282 | +995 | ! |
- ns("d_biplot"),
+ labs + |
| 283 | +996 | ! |
- decorators = select_decorators(args$decorators, "biplot")- |
-
| 284 | -- |
- )+ ggthemes + |
|
| 285 | -+ | ||
| 997 | +! |
- ),+ themes, |
|
| 286 | +998 | ! |
- conditionalPanel(+ env = list( |
| 287 | +999 | ! |
- condition = sprintf("input['%s'] == 'Eigenvector plot'", ns("plot_type")),
+ plot_call = plot_call, |
| 288 | +1000 | ! |
- ui_decorate_teal_data(+ labs = parsed_ggplot2_args$labs, |
| 289 | +1001 | ! |
- ns("d_eigenvector_plot"),
+ ggthemes = parsed_ggplot2_args$ggtheme, |
| 290 | +1002 | ! |
- decorators = select_decorators(args$decorators, "eigenvector_plot")+ themes = parsed_ggplot2_args$theme |
| 291 | +1003 |
- )+ ) |
|
| 292 | +1004 |
- )+ ) |
|
| 293 | +1005 |
- ),+ } |
|
| 294 | -! | +||
| 1006 | +
- teal.widgets::panel_item(+ |
||
| 295 | +1007 | ! |
- title = "Pre-processing",+ plot_call <- substitute(expr = plot <- plot_call, env = list(plot_call = plot_call)) |
| 296 | -! | +||
| 1008 | +
- radioButtons(+ |
||
| 297 | +1009 | ! |
- ns("standardization"), "Standardization",
+ teal.code::eval_code(plot_q, plot_call) |
| 298 | -! | +||
| 1010 | +
- choices = c("None" = "none", "Center" = "center", "Center & Scale" = "center_scale"),
+ }) |
||
| 299 | -! | +||
| 1011 | +
- selected = "center_scale"+ |
||
| 300 | -+ | ||
| 1012 | +! |
- ),+ decorated_output_plot_q <- srv_decorate_teal_data( |
|
| 301 | +1013 | ! |
- radioButtons(+ id = "decorator", |
| 302 | +1014 | ! |
- ns("na_action"), "NA action",
+ data = output_q, |
| 303 | +1015 | ! |
- choices = c("None" = "none", "Drop" = "drop"),
+ decorators = select_decorators(decorators, "plot"), |
| 304 | +1016 | ! |
- selected = "none"+ expr = print(plot) |
| 305 | +1017 |
- )+ ) |
|
| 306 | +1018 |
- ),+ |
|
| 307 | +1019 | ! |
- teal.widgets::panel_item(+ plot_r <- reactive(req(decorated_output_plot_q())[["plot"]]) |
| 308 | -! | +||
| 1020 | +
- title = "Selected plot specific settings",+ |
||
| 309 | -! | +||
| 1021 | +
- collapsed = FALSE,+ # Insert the plot into a plot_with_settings module from teal.widgets |
||
| 310 | +1022 | ! |
- uiOutput(ns("plot_settings")),
+ pws <- teal.widgets::plot_with_settings_srv( |
| 311 | +1023 | ! |
- conditionalPanel(+ id = "scatter_plot", |
| 312 | +1024 | ! |
- condition = sprintf("input['%s'] == 'Biplot'", ns("plot_type")),
+ plot_r = plot_r, |
| 313 | +1025 | ! |
- list(+ height = plot_height, |
| 314 | +1026 | ! |
- teal.transform::data_extract_ui(+ width = plot_width, |
| 315 | +1027 | ! |
- id = ns("response"),
+ brushing = TRUE |
| 316 | -! | +||
| 1028 | +
- label = "Color by",+ )+ |
+ ||
| 1029 | ++ | + | |
| 317 | +1030 | ! |
- data_extract_spec = color_selector,+ output$data_table <- DT::renderDataTable({
|
| 318 | +1031 | ! |
- is_single_dataset = is_single_dataset_value+ plot_brush <- pws$brush() |
| 319 | +1032 |
- ),+ |
|
| 320 | +1033 | ! |
- teal.widgets::optionalSliderInputValMinMax(ns("alpha"), "Opacity:", args$alpha, ticks = FALSE),
+ if (!is.null(plot_brush)) {
|
| 321 | +1034 | ! |
- teal.widgets::optionalSliderInputValMinMax(ns("size"), "Points size:", args$size, ticks = FALSE)
- |
-
| 322 | -- |
- )+ validate(need(!input$add_density, "Brushing feature is currently not supported when plot has marginal density")) |
|
| 323 | +1035 |
- )+ } |
|
| 324 | +1036 |
- ),+ |
|
| 325 | +1037 | ! |
- teal.widgets::panel_item(+ merged_data <- isolate(teal.code::dev_suppress(output_q()[["ANL"]])) |
| 326 | -! | +||
| 1038 | +
- title = "Plot settings",+ |
||
| 327 | +1039 | ! |
- collapsed = TRUE,+ brushed_df <- teal.widgets::clean_brushedPoints(merged_data, plot_brush) |
| 328 | +1040 | ! |
- conditionalPanel(+ numeric_cols <- names(brushed_df)[ |
| 329 | +1041 | ! |
- condition = sprintf(+ vapply(brushed_df, function(x) is.numeric(x) && !is.integer(x), FUN.VALUE = logical(1)) |
| 330 | -! | +||
| 1042 | +
- "input['%s'] == 'Elbow plot' || input['%s'] == 'Eigenvector plot'",+ ] |
||
| 331 | -! | +||
| 1043 | +
- ns("plot_type"),
+
|
||
| 332 | +1044 | ! |
- ns("plot_type")
- |
-
| 333 | -- |
- ),+ if (length(numeric_cols) > 0) {
|
|
| 334 | +1045 | ! |
- list(checkboxInput(ns("rotate_xaxis_labels"), "Rotate X axis labels", value = args$rotate_xaxis_labels))
+ DT::formatRound( |
| 335 | -+ | ||
| 1046 | +! |
- ),+ DT::datatable(brushed_df, |
|
| 336 | +1047 | ! |
- selectInput(+ rownames = FALSE, |
| 337 | +1048 | ! |
- inputId = ns("ggtheme"),
+ options = list(scrollX = TRUE, pageLength = input$data_table_rows) |
| 338 | -! | +||
| 1049 | +
- label = "Theme (by ggplot):",+ ), |
||
| 339 | +1050 | ! |
- choices = ggplot_themes,+ numeric_cols, |
| 340 | +1051 | ! |
- selected = args$ggtheme,+ table_dec |
| 341 | -! | +||
| 1052 | +
- multiple = FALSE+ ) |
||
| 342 | +1053 |
- ),+ } else {
|
|
| 343 | +1054 | ! |
- teal.widgets::optionalSliderInputValMinMax(ns("font_size"), "Font Size", args$font_size, ticks = FALSE)
+ DT::datatable(brushed_df, rownames = FALSE, options = list(scrollX = TRUE, pageLength = input$data_table_rows)) |
| 344 | +1055 |
- )+ } |
|
| 345 | +1056 |
- )+ }) |
|
| 346 | +1057 |
- ),+ |
|
| 347 | +1058 | ! |
- forms = tagList(+ teal.widgets::verbatim_popup_srv( |
| 348 | +1059 | ! |
- teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code")
- |
-
| 349 | -- |
- ),+ id = "rcode", |
|
| 350 | +1060 | ! |
- pre_output = args$pre_output,+ verbatim_content = reactive(teal.code::get_code(req(decorated_output_plot_q()))), |
| 351 | +1061 | ! |
- post_output = args$post_output+ title = "R Code for scatterplot" |
| 352 | +1062 |
) |
|
| 353 | +1063 |
- )+ |
|
| 354 | +1064 |
- }+ ### REPORTER |
|
| 355 | -+ | ||
| 1065 | +! | - - | -|
| 356 | -- |
- # Server function for the PCA module- |
- |
| 357 | -- |
- srv_a_pca <- function(id, data, reporter, filter_panel_api, dat, plot_height, plot_width, ggplot2_args, decorators) {
+ if (with_reporter) {
|
|
| 358 | +1066 | ! |
- with_reporter <- !missing(reporter) && inherits(reporter, "Reporter")+ card_fun <- function(comment, label) {
|
| 359 | +1067 | ! |
- with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI")+ card <- teal::report_card_template( |
| 360 | +1068 | ! |
- checkmate::assert_class(data, "reactive")+ title = "Scatter Plot", |
| 361 | +1069 | ! |
- checkmate::assert_class(isolate(data()), "teal_data")+ label = label, |
| 362 | +1070 | ! |
- moduleServer(id, function(input, output, session) {
+ with_filter = with_filter, |
| 363 | +1071 | ! |
- teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.general")+ filter_panel_api = filter_panel_api |
| 364 | +1072 |
-
+ ) |
|
| 365 | +1073 | ! |
- response <- dat+ card$append_text("Plot", "header3")
|
| 366 | -+ | ||
| 1074 | +! |
-
+ card$append_plot(plot_r(), dim = pws$dim()) |
|
| 367 | +1075 | ! |
- for (i in seq_along(response)) {
+ if (!comment == "") {
|
| 368 | +1076 | ! |
- response[[i]]$select$multiple <- FALSE+ card$append_text("Comment", "header3")
|
| 369 | +1077 | ! |
- response[[i]]$select$always_selected <- NULL+ card$append_text(comment) |
| 370 | -! | +||
| 1078 | +
- response[[i]]$select$selected <- NULL+ } |
||
| 371 | +1079 | ! |
- all_cols <- teal.data::col_labels(isolate(data())[[response[[i]]$dataname]])+ card$append_src(teal.code::get_code(req(decorated_output_plot_q()))) |
| 372 | +1080 | ! |
- ignore_cols <- unlist(teal.data::join_keys(isolate(data()))[[response[[i]]$dataname]])+ card |
| 373 | -! | +||
| 1081 | +
- color_cols <- all_cols[!names(all_cols) %in% ignore_cols]+ } |
||
| 374 | +1082 | ! |
- response[[i]]$select$choices <- teal.transform::choices_labeled(names(color_cols), color_cols)+ teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
|
| 375 | +1083 |
} |
|
| 376 | +1084 | - - | -|
| 377 | -! | -
- selector_list <- teal.transform::data_extract_multiple_srv(- |
- |
| 378 | -! | -
- data_extract = list(dat = dat, response = response),+ ### |
|
| 379 | -! | +||
| 1085 | +
- datasets = data,+ }) |
||
| 380 | -! | +||
| 1086 | +
- select_validation_rule = list(+ } |
||
| 381 | -! | +
| 1 | +
- dat = ~ if (length(.) < 2L) "Please select more than 1 variable to perform PCA.",+ #' `teal` module: File viewer |
||
| 382 | -! | +||
| 2 | +
- response = shinyvalidate::compose_rules(+ #' |
||
| 383 | -! | +||
| 3 | +
- shinyvalidate::sv_optional(),+ #' The file viewer module provides a tool to view static files. |
||
| 384 | -! | +||
| 4 | +
- ~ if (isTRUE(is.element(., selector_list()$dat()$select))) {
+ #' Supported formats include text formats, `PDF`, `PNG` `APNG`, |
||
| 385 | -! | +||
| 5 | +
- "Response must not have been used for PCA."+ #' `JPEG` `SVG`, `WEBP`, `GIF` and `BMP`. |
||
| 386 | +6 |
- }+ #' |
|
| 387 | +7 |
- )+ #' @inheritParams teal::module |
|
| 388 | +8 |
- )+ #' @inheritParams shared_params |
|
| 389 | +9 |
- )+ #' @param input_path (`list`) of the input paths, optional. Each element can be: |
|
| 390 | +10 |
-
+ #' |
|
| 391 | -! | +||
| 11 | +
- iv_r <- reactive({
+ #' Paths can be specified as absolute paths or relative to the running directory of the application. |
||
| 392 | -! | +||
| 12 | +
- iv <- shinyvalidate::InputValidator$new()+ #' Default to the current working directory if not supplied. |
||
| 393 | -! | +||
| 13 | +
- teal.transform::compose_and_enable_validators(iv, selector_list)+ #' |
||
| 394 | +14 |
- })+ #' @inherit shared_params return |
|
| 395 | +15 |
-
+ #' |
|
| 396 | -! | +||
| 16 | +
- iv_extra <- shinyvalidate::InputValidator$new()+ #' @examplesShinylive |
||
| 397 | -! | +||
| 17 | +
- iv_extra$add_rule("x_axis", function(value) {
+ #' library(teal.modules.general) |
||
| 398 | -! | +||
| 18 | +
- if (isTRUE(input$plot_type %in% c("Circle plot", "Biplot"))) {
+ #' interactive <- function() TRUE |
||
| 399 | -! | +||
| 19 | +
- if (!shinyvalidate::input_provided(value)) {
+ #' {{ next_example }}
|
||
| 400 | -! | +||
| 20 | +
- "Need X axis"+ #' @examples |
||
| 401 | +21 |
- }+ #' data <- teal_data() |
|
| 402 | +22 |
- }+ #' data <- within(data, {
|
|
| 403 | +23 |
- })+ #' data <- data.frame(1) |
|
| 404 | -! | +||
| 24 | +
- iv_extra$add_rule("y_axis", function(value) {
+ #' }) |
||
| 405 | -! | +||
| 25 | +
- if (isTRUE(input$plot_type %in% c("Circle plot", "Biplot"))) {
+ #' |
||
| 406 | -! | +||
| 26 | +
- if (!shinyvalidate::input_provided(value)) {
+ #' app <- init( |
||
| 407 | -! | +||
| 27 | +
- "Need Y axis"+ #' data = data, |
||
| 408 | +28 |
- }+ #' modules = modules( |
|
| 409 | +29 |
- }+ #' tm_file_viewer( |
|
| 410 | +30 |
- })+ #' input_path = list( |
|
| 411 | -! | +||
| 31 | +
- rule_dupl <- function(...) {
+ #' folder = system.file("sample_files", package = "teal.modules.general"),
|
||
| 412 | -! | +||
| 32 | +
- if (isTRUE(input$plot_type %in% c("Circle plot", "Biplot"))) {
+ #' png = system.file("sample_files/sample_file.png", package = "teal.modules.general"),
|
||
| 413 | -! | +||
| 33 | +
- if (isTRUE(input$x_axis == input$y_axis)) {
+ #' txt = system.file("sample_files/sample_file.txt", package = "teal.modules.general"),
|
||
| 414 | -! | +||
| 34 | +
- "Please choose different X and Y axes."+ #' url = "https://fda.gov/files/drugs/published/Portable-Document-Format-Specifications.pdf" |
||
| 415 | +35 |
- }+ #' ) |
|
| 416 | +36 |
- }+ #' ) |
|
| 417 | +37 |
- }+ #' ) |
|
| 418 | -! | +||
| 38 | +
- iv_extra$add_rule("x_axis", rule_dupl)
+ #' ) |
||
| 419 | -! | +||
| 39 | +
- iv_extra$add_rule("y_axis", rule_dupl)
+ #' if (interactive()) {
|
||
| 420 | -! | +||
| 40 | +
- iv_extra$add_rule("variables", function(value) {
+ #' shinyApp(app$ui, app$server) |
||
| 421 | -! | +||
| 41 | +
- if (identical(input$plot_type, "Circle plot")) {
+ #' } |
||
| 422 | -! | +||
| 42 | +
- if (!shinyvalidate::input_provided(value)) {
+ #' |
||
| 423 | -! | +||
| 43 | +
- "Need Original Coordinates"+ #' @export |
||
| 424 | +44 |
- }+ #' |
|
| 425 | +45 |
- }+ tm_file_viewer <- function(label = "File Viewer Module", |
|
| 426 | +46 |
- })+ input_path = list("Current Working Directory" = ".")) {
|
|
| 427 | +47 | ! |
- iv_extra$add_rule("pc", function(value) {
+ message("Initializing tm_file_viewer")
|
| 428 | -! | +||
| 48 | +
- if (identical(input$plot_type, "Eigenvector plot")) {
+
|
||
| 429 | -! | +||
| 49 | +
- if (!shinyvalidate::input_provided(value)) {
+ # Normalize the parameters |
||
| 430 | +50 | ! |
- "Need PC"+ if (length(label) == 0 || identical(label, "")) label <- " " |
| 431 | -+ | ||
| 51 | +! |
- }+ if (length(input_path) == 0 || identical(input_path, "")) input_path <- list() |
|
| 432 | +52 |
- }+ |
|
| 433 | +53 |
- })+ # Start of assertions |
|
| 434 | +54 | ! |
- iv_extra$enable()+ checkmate::assert_string(label) |
| 435 | +55 | ||
| 436 | +56 | ! |
- anl_merged_input <- teal.transform::merge_expression_srv(+ checkmate::assert( |
| 437 | +57 | ! |
- selector_list = selector_list,+ checkmate::check_list(input_path, types = "character", min.len = 0), |
| 438 | +58 | ! |
- datasets = data+ checkmate::check_character(input_path, min.len = 1) |
| 439 | +59 |
- )+ ) |
|
| 440 | -+ | ||
| 60 | +! |
-
+ if (length(input_path) > 0) {
|
|
| 441 | +61 | ! |
- anl_merged_q <- reactive({
+ valid_url <- function(url_input, timeout = 2) {
|
| 442 | +62 | ! |
- req(anl_merged_input())+ con <- try(url(url_input), silent = TRUE) |
| 443 | +63 | ! |
- data() %>%+ check <- suppressWarnings(try(open.connection(con, open = "rt", timeout = timeout), silent = TRUE)[1]) |
| 444 | +64 | ! |
- teal.code::eval_code(as.expression(anl_merged_input()$expr))+ try(close.connection(con), silent = TRUE) |
| 445 | -+ | ||
| 65 | +! |
- })+ is.null(check) |
|
| 446 | +66 |
-
+ } |
|
| 447 | +67 | ! |
- merged <- list(+ idx <- vapply(input_path, function(x) file.exists(x) || valid_url(x), logical(1)) |
| 448 | -! | +||
| 68 | +
- anl_input_r = anl_merged_input,+ |
||
| 449 | +69 | ! |
- anl_q_r = anl_merged_q+ if (!all(idx)) {
|
| 450 | -+ | ||
| 70 | +! |
- )+ warning( |
|
| 451 | -+ | ||
| 71 | +! |
-
+ paste0( |
|
| 452 | +72 | ! |
- validation <- reactive({
+ "Non-existent file or url path. Please provide valid paths for:\n", |
| 453 | +73 | ! |
- req(merged$anl_q_r())+ paste0(input_path[!idx], collapse = "\n") |
| 454 | +74 |
- # inputs+ ) |
|
| 455 | -! | +||
| 75 | +
- keep_cols <- as.character(merged$anl_input_r()$columns_source$dat)+ ) |
||
| 456 | -! | +||
| 76 | +
- na_action <- input$na_action+ } |
||
| 457 | +77 | ! |
- standardization <- input$standardization+ input_path <- input_path[idx] |
| 458 | -! | +||
| 78 | +
- center <- standardization %in% c("center", "center_scale")
+ } else {
|
||
| 459 | +79 | ! |
- scale <- standardization == "center_scale"+ warning( |
| 460 | +80 | ! |
- ANL <- merged$anl_q_r()[["ANL"]]+ "No file or url paths were provided." |
| 461 | +81 | - - | -|
| 462 | -! | -
- teal::validate_has_data(ANL, 10)+ ) |
|
| 463 | -! | +||
| 82 | +
- validate(need(+ } |
||
| 464 | -! | +||
| 83 | +
- na_action != "none" | !anyNA(ANL[keep_cols]),+ # End of assertions |
||
| 465 | -! | +||
| 84 | +
- paste(+ |
||
| 466 | -! | +||
| 85 | +
- "There are NAs in the dataset. Please deal with them in preprocessing",+ # Make UI args |
||
| 467 | +86 | ! |
- "or select \"Drop\" in the NA actions inside the encodings panel (left)."+ args <- as.list(environment()) |
| 468 | +87 |
- )+ |
|
| 469 | -+ | ||
| 88 | +! |
- ))+ ans <- module( |
|
| 470 | +89 | ! |
- if (scale) {
+ label = label, |
| 471 | +90 | ! |
- not_single <- vapply(ANL[keep_cols], function(column) length(unique(column)) != 1, FUN.VALUE = logical(1))+ server = srv_viewer, |
| 472 | -+ | ||
| 91 | +! |
-
+ server_args = list(input_path = input_path), |
|
| 473 | +92 | ! |
- msg <- paste0(+ ui = ui_viewer, |
| 474 | +93 | ! |
- "You have selected `Center & Scale` under `Standardization` in the `Pre-processing` panel, ",+ ui_args = args, |
| 475 | +94 | ! |
- "but one or more of your columns has/have a variance value of zero, indicating all values are identical"+ datanames = NULL |
| 476 | +95 |
- )+ ) |
|
| 477 | +96 | ! |
- validate(need(all(not_single), msg))+ attr(ans, "teal_bookmarkable") <- FALSE+ |
+
| 97 | +! | +
+ ans |
|
| 478 | +98 |
- }+ } |
|
| 479 | +99 |
- })+ |
|
| 480 | +100 |
-
+ # UI function for the file viewer module |
|
| 481 | +101 |
- # computation ----+ ui_viewer <- function(id, ...) {
|
|
| 482 | +102 | ! |
- computation <- reactive({
+ args <- list(...) |
| 483 | +103 | ! |
- validation()+ ns <- NS(id) |
| 484 | +104 | ||
| 485 | -+ | ||
| 105 | +! |
- # inputs+ tagList( |
|
| 486 | +106 | ! |
- keep_cols <- as.character(merged$anl_input_r()$columns_source$dat)+ include_css_files("custom"),
|
| 487 | +107 | ! |
- na_action <- input$na_action+ teal.widgets::standard_layout( |
| 488 | +108 | ! |
- standardization <- input$standardization+ output = tags$div( |
| 489 | +109 | ! |
- center <- standardization %in% c("center", "center_scale")
+ uiOutput(ns("output"))
+ |
+
| 110 | ++ |
+ ), |
|
| 490 | +111 | ! |
- scale <- standardization == "center_scale"+ encoding = tags$div( |
| 491 | +112 | ! |
- ANL <- merged$anl_q_r()[["ANL"]]+ class = "file_viewer_encoding", |
| 492 | -+ | ||
| 113 | +! |
-
+ tags$label("Encodings", class = "text-primary"),
|
|
| 493 | +114 | ! |
- qenv <- teal.code::eval_code(+ shinyTree::shinyTree( |
| 494 | +115 | ! |
- merged$anl_q_r(),+ ns("tree"),
|
| 495 | +116 | ! |
- substitute(+ dragAndDrop = FALSE, |
| 496 | +117 | ! |
- expr = keep_columns <- keep_cols,+ sort = FALSE, |
| 497 | +118 | ! |
- env = list(keep_cols = keep_cols)+ wholerow = TRUE, |
| 498 | -+ | ||
| 119 | +! |
- )+ theme = "proton", |
|
| 499 | -+ | ||
| 120 | +! |
- )+ multiple = FALSE |
|
| 500 | +121 |
-
+ ) |
|
| 501 | -! | +||
| 122 | +
- if (na_action == "drop") {
+ ) |
||
| 502 | -! | +||
| 123 | +
- qenv <- teal.code::eval_code(+ ) |
||
| 503 | -! | +||
| 124 | +
- qenv,+ ) |
||
| 504 | -! | +||
| 125 | +
- quote(ANL <- tidyr::drop_na(ANL, keep_columns))+ } |
||
| 505 | +126 |
- )+ |
|
| 506 | +127 |
- }+ # Server function for the file viewer module |
|
| 507 | +128 |
-
+ srv_viewer <- function(id, input_path) {
|
|
| 508 | +129 | ! |
- qenv <- teal.code::eval_code(+ moduleServer(id, function(input, output, session) {
|
| 509 | +130 | ! |
- qenv,+ teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.general")+ |
+
| 131 | ++ | + | |
| 510 | +132 | ! |
- substitute(+ temp_dir <- tempfile() |
| 511 | +133 | ! |
- expr = pca <- summary(stats::prcomp(ANL[keep_columns], center = center, scale. = scale, retx = TRUE)),+ if (!dir.exists(temp_dir)) {
|
| 512 | +134 | ! |
- env = list(center = center, scale = scale)+ dir.create(temp_dir, recursive = TRUE) |
| 513 | +135 |
- )+ } |
|
| 514 | -+ | ||
| 136 | +! |
- )+ addResourcePath(basename(temp_dir), temp_dir) |
|
| 515 | +137 | ||
| 516 | +138 | ! |
- qenv <- teal.code::eval_code(+ test_path_text <- function(selected_path, type) {
|
| 517 | +139 | ! |
- qenv,+ out <- tryCatch( |
| 518 | +140 | ! |
- quote({
+ expr = {
|
| 519 | +141 | ! |
- tbl_importance <- dplyr::as_tibble(pca$importance, rownames = "Metric")+ if (type != "url") {
|
| 520 | +142 | ! |
- tbl_importance- |
-
| 521 | -- |
- })- |
- |
| 522 | -- |
- )+ selected_path <- normalizePath(selected_path, winslash = "/") |
|
| 523 | +143 |
-
+ } |
|
| 524 | +144 | ! |
- teal.code::eval_code(+ readLines(con = selected_path) |
| 525 | -! | +||
| 145 | +
- qenv,+ }, |
||
| 526 | +146 | ! |
- quote({
+ error = function(cond) FALSE, |
| 527 | +147 | ! |
- tbl_eigenvector <- dplyr::as_tibble(pca$rotation, rownames = "Variable")+ warning = function(cond) {
|
| 528 | +148 | ! |
- tbl_eigenvector+ `if`(grepl("^incomplete final line found on", cond[[1]]), suppressWarnings(eval(cond[[2]])), FALSE)
|
| 529 | +149 |
- })+ } |
|
| 530 | +150 |
) |
|
| 531 | +151 |
- })+ } |
|
| 532 | +152 | ||
| 533 | -- |
- # plot args ----- |
- |
| 534 | +153 | ! |
- output$plot_settings <- renderUI({
- |
-
| 535 | -- |
- # reactivity triggers+ handle_connection_type <- function(selected_path) {
|
|
| 536 | +154 | ! |
- req(iv_r()$is_valid())+ file_extension <- tools::file_ext(selected_path) |
| 537 | +155 | ! |
- req(computation())+ file_class <- suppressWarnings(file(selected_path)) |
| 538 | +156 | ! |
- qenv <- computation()+ close(file_class) |
| 539 | +157 | ||
| 540 | +158 | ! |
- ns <- session$ns+ output_text <- test_path_text(selected_path, type = class(file_class)[1]) |
| 541 | +159 | ||
| 542 | +160 | ! |
- pca <- qenv[["pca"]]+ if (class(file_class)[1] == "url") {
|
| 543 | +161 | ! |
- chcs_pcs <- colnames(pca$rotation)- |
-
| 544 | -! | -
- chcs_vars <- qenv[["keep_columns"]]+ list(selected_path = selected_path, output_text = output_text) |
|
| 545 | +162 | - - | -|
| 546 | -! | -
- tagList(+ } else {
|
|
| 547 | +163 | ! |
- conditionalPanel(+ file.copy(normalizePath(selected_path, winslash = "/"), temp_dir) |
| 548 | +164 | ! |
- condition = sprintf(+ selected_path <- file.path(basename(temp_dir), basename(selected_path)) |
| 549 | +165 | ! |
- "input['%s'] == 'Biplot' || input['%s'] == 'Circle plot'",+ list(selected_path = selected_path, output_text = output_text) |
| 550 | -! | +||
| 166 | +
- ns("plot_type"), ns("plot_type")
+ } |
||
| 551 | +167 |
- ),+ } |
|
| 552 | -! | +||
| 168 | +
- list(+ |
||
| 553 | +169 | ! |
- teal.widgets::optionalSelectInput(ns("x_axis"), "X axis", choices = chcs_pcs, selected = chcs_pcs[1]),
+ display_file <- function(selected_path) {
|
| 554 | +170 | ! |
- teal.widgets::optionalSelectInput(ns("y_axis"), "Y axis", choices = chcs_pcs, selected = chcs_pcs[2]),
+ con_type <- handle_connection_type(selected_path) |
| 555 | +171 | ! |
- teal.widgets::optionalSelectInput(+ file_extension <- tools::file_ext(selected_path) |
| 556 | +172 | ! |
- ns("variables"), "Original coordinates",
+ if (file_extension %in% c("png", "apng", "jpg", "jpeg", "svg", "gif", "webp", "bmp")) {
|
| 557 | +173 | ! |
- choices = chcs_vars, selected = chcs_vars,+ tags$img(src = con_type$selected_path, alt = "file does not exist") |
| 558 | +174 | ! |
- multiple = TRUE- |
-
| 559 | -- |
- )- |
- |
| 560 | -- |
- )- |
- |
| 561 | -- |
- ),+ } else if (file_extension == "pdf") {
|
|
| 562 | +175 | ! |
- conditionalPanel(+ tags$embed( |
| 563 | +176 | ! |
- condition = sprintf("input['%s'] == 'Elbow plot'", ns("plot_type")),
+ class = "embed_pdf", |
| 564 | +177 | ! |
- helpText("No plot specific settings available.")
+ src = con_type$selected_path |
| 565 | +178 |
- ),- |
- |
| 566 | -! | -
- conditionalPanel(+ ) |
|
| 567 | +179 | ! |
- condition = paste0("input['", ns("plot_type"), "'] == 'Eigenvector plot'"),
+ } else if (!isFALSE(con_type$output_text[1])) {
|
| 568 | +180 | ! |
- teal.widgets::optionalSelectInput(ns("pc"), "PC", choices = chcs_pcs, selected = chcs_pcs[1])
+ tags$pre(paste0(con_type$output_text, collapse = "\n")) |
| 569 | +181 |
- )+ } else {
|
|
| 570 | -+ | ||
| 182 | +! |
- )+ tags$p("Please select a supported format.")
|
|
| 571 | +183 |
- })+ } |
|
| 572 | +184 |
-
+ } |
|
| 573 | +185 |
- # plot elbow ----+ |
|
| 574 | +186 | ! |
- plot_elbow <- function(base_q) {
+ tree_list <- function(file_or_dir) {
|
| 575 | +187 | ! |
- ggtheme <- input$ggtheme+ nested_list <- lapply(file_or_dir, function(path) {
|
| 576 | +188 | ! |
- rotate_xaxis_labels <- input$rotate_xaxis_labels+ file_class <- suppressWarnings(file(path)) |
| 577 | +189 | ! |
- font_size <- input$font_size- |
-
| 578 | -- |
-
+ close(file_class) |
|
| 579 | +190 | ! |
- angle_value <- ifelse(isTRUE(rotate_xaxis_labels), 45, 0)+ if (class(file_class)[[1]] != "url") {
|
| 580 | +191 | ! |
- hjust_value <- ifelse(isTRUE(rotate_xaxis_labels), 1, 0.5)- |
-
| 581 | -- |
-
+ isdir <- file.info(path)$isdir |
|
| 582 | +192 | ! |
- dev_ggplot2_args <- teal.widgets::ggplot2_args(+ if (!isdir) {
|
| 583 | +193 | ! |
- labs = list(x = "Principal component", y = "Proportion of variance explained", color = "", fill = "Legend"),+ structure(path, ancestry = path, sticon = "file") |
| 584 | -! | +||
| 194 | +
- theme = list(+ } else {
|
||
| 585 | +195 | ! |
- legend.position = "right",+ files <- list.files(path, full.names = TRUE, include.dirs = TRUE) |
| 586 | +196 | ! |
- legend.spacing.y = quote(grid::unit(-5, "pt")),+ out <- lapply(files, function(x) tree_list(x)) |
| 587 | +197 | ! |
- legend.title = quote(element_text(vjust = 25)),+ out <- unlist(out, recursive = FALSE) |
| 588 | +198 | ! |
- axis.text.x = substitute(+ if (length(files) > 0) names(out) <- basename(files) |
| 589 | +199 | ! |
- element_text(angle = angle_value, hjust = hjust_value),+ out |
| 590 | -! | +||
| 200 | +
- list(angle_value = angle_value, hjust_value = hjust_value)+ } |
||
| 591 | +201 |
- ),+ } else {
|
|
| 592 | +202 | ! |
- text = substitute(element_text(size = font_size), list(font_size = font_size))+ structure(path, ancestry = path, sticon = "file") |
| 593 | +203 |
- )+ } |
|
| 594 | +204 |
- )+ }) |
|
| 595 | +205 | ||
| 596 | +206 | ! |
- parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(+ missing_labels <- if (is.null(names(nested_list))) seq_along(nested_list) else which(names(nested_list) == "") |
| 597 | +207 | ! |
- teal.widgets::resolve_ggplot2_args(+ names(nested_list)[missing_labels] <- file_or_dir[missing_labels] |
| 598 | +208 | ! |
- user_plot = ggplot2_args[["Elbow plot"]],+ nested_list |
| 599 | -! | +||
| 209 | +
- user_default = ggplot2_args$default,+ } |
||
| 600 | -! | +||
| 210 | +
- module_plot = dev_ggplot2_args+ |
||
| 601 | -+ | ||
| 211 | +! |
- ),+ output$tree <- shinyTree::renderTree({
|
|
| 602 | +212 | ! |
- ggtheme = ggtheme+ if (length(input_path) > 0) {
|
| 603 | -+ | ||
| 213 | +! |
- )+ tree_list(input_path) |
|
| 604 | +214 |
-
+ } else {
|
|
| 605 | +215 | ! |
- teal.code::eval_code(+ list("Empty Path" = NULL)
|
| 606 | -! | +||
| 216 | +
- base_q,+ } |
||
| 607 | -! | +||
| 217 | +
- substitute(+ }) |
||
| 608 | -! | +||
| 218 | +
- expr = {
+
|
||
| 609 | +219 | ! |
- elb_dat <- pca$importance[c("Proportion of Variance", "Cumulative Proportion"), ] %>%
+ output$output <- renderUI({
|
| 610 | +220 | ! |
- dplyr::as_tibble(rownames = "metric") %>%+ validate( |
| 611 | +221 | ! |
- tidyr::gather("component", "value", -metric) %>%
+ need( |
| 612 | +222 | ! |
- dplyr::mutate(+ length(shinyTree::get_selected(input$tree)) > 0, |
| 613 | +223 | ! |
- component = factor(component, levels = unique(stringr::str_sort(component, numeric = TRUE)))+ "Please select a file." |
| 614 | +224 |
- )+ ) |
|
| 615 | +225 | ++ |
+ )+ |
+
| 226 | |||
| 616 | +227 | ! |
- cols <- c(getOption("ggplot2.discrete.colour"), c("lightblue", "darkred", "black"))[1:3]
+ obj <- shinyTree::get_selected(input$tree, format = "names")[[1]] |
| 617 | +228 | ! |
- elbow_plot <- ggplot(mapping = aes_string(x = "component", y = "value")) ++ repo <- attr(obj, "ancestry") |
| 618 | +229 | ! |
- geom_bar(+ repo_collapsed <- if (length(repo) > 1) paste0(repo, collapse = "/") else repo |
| 619 | +230 | ! |
- aes(fill = "Single variance"),+ is_not_named <- file.exists(file.path(c(repo_collapsed, obj[1])))[1] |
| 620 | -! | +||
| 231 | +
- data = dplyr::filter(elb_dat, metric == "Proportion of Variance"),+ |
||
| 621 | +232 | ! |
- color = "black",+ if (is_not_named) {
|
| 622 | +233 | ! |
- stat = "identity"+ selected_path <- do.call("file.path", as.list(c(repo, obj[1])))
|
| 623 | +234 |
- ) +- |
- |
| 624 | -! | -
- geom_point(+ } else {
|
|
| 625 | +235 | ! |
- aes(color = "Cumulative variance"),+ if (length(repo) == 0) {
|
| 626 | +236 | ! |
- data = dplyr::filter(elb_dat, metric == "Cumulative Proportion")+ selected_path <- do.call("file.path", as.list(attr(input$tree[[obj[1]]], "ancestry")))
|
| 627 | +237 |
- ) ++ } else {
|
|
| 628 | +238 | ! |
- geom_line(+ selected_path <- do.call("file.path", as.list(attr(input$tree[[repo]][[obj[1]]], "ancestry")))
|
| 629 | -! | +||
| 239 | +
- aes(group = 1, color = "Cumulative variance"),+ } |
||
| 630 | -! | +||
| 240 | +
- data = dplyr::filter(elb_dat, metric == "Cumulative Proportion")+ } |
||
| 631 | +241 |
- ) ++ |
|
| 632 | +242 | ! |
- labs ++ validate( |
| 633 | +243 | ! |
- scale_color_manual(values = c("Cumulative variance" = cols[2], "Single variance" = cols[3])) +
+ need( |
| 634 | +244 | ! |
- scale_fill_manual(values = c("Cumulative variance" = cols[2], "Single variance" = cols[1])) +
+ !isTRUE(file.info(selected_path)$isdir) && length(selected_path) > 0, |
| 635 | +245 | ! |
- ggthemes ++ "Please select a single file." |
| 636 | -! | +||
| 246 | +
- themes+ ) |
||
| 637 | +247 |
- },+ ) |
|
| 638 | +248 | ! |
- env = list(+ display_file(selected_path)+ |
+
| 249 | ++ |
+ })+ |
+ |
| 250 | ++ | + | |
| 639 | +251 | ! |
- ggthemes = parsed_ggplot2_args$ggtheme,+ onStop(function() {
|
| 640 | +252 | ! |
- labs = parsed_ggplot2_args$labs,+ removeResourcePath(basename(temp_dir)) |
| 641 | +253 | ! |
- themes = parsed_ggplot2_args$theme+ unlink(temp_dir) |
| 642 | +254 |
- )+ }) |
|
| 643 | +255 |
- )+ }) |
|
| 644 | +256 |
- )+ } |
|
| 645 | -+ |
| 1 | +
- }+ #' `teal` module: Scatterplot and regression analysis |
||
| 646 | +2 |
-
+ #' |
|
| 647 | +3 |
- # plot circle ----+ #' Module for visualizing regression analysis, including scatterplots and |
|
| 648 | -! | +||
| 4 | +
- plot_circle <- function(base_q) {
+ #' various regression diagnostics plots. |
||
| 649 | -! | +||
| 5 | +
- x_axis <- input$x_axis+ #' It allows users to explore the relationship between a set of regressors and a response variable, |
||
| 650 | -! | +||
| 6 | +
- y_axis <- input$y_axis+ #' visualize residuals, and identify outliers. |
||
| 651 | -! | +||
| 7 | +
- variables <- input$variables+ #' |
||
| 652 | -! | +||
| 8 | +
- ggtheme <- input$ggtheme+ #' @note For more examples, please see the vignette "Using regression plots" via |
||
| 653 | +9 |
-
+ #' `vignette("using-regression-plots", package = "teal.modules.general")`.
|
|
| 654 | -! | +||
| 10 | +
- rotate_xaxis_labels <- input$rotate_xaxis_labels+ #' |
||
| 655 | -! | +||
| 11 | +
- font_size <- input$font_size+ #' @inheritParams teal::module |
||
| 656 | +12 |
-
+ #' @inheritParams shared_params |
|
| 657 | -! | +||
| 13 | +
- angle <- ifelse(isTRUE(rotate_xaxis_labels), 45, 0)+ #' @param regressor (`data_extract_spec` or `list` of multiple `data_extract_spec`) |
||
| 658 | -! | +||
| 14 | +
- hjust <- ifelse(isTRUE(rotate_xaxis_labels), 1, 0.5)+ #' Regressor variables from an incoming dataset with filtering and selecting. |
||
| 659 | +15 |
-
+ #' @param response (`data_extract_spec` or `list` of multiple `data_extract_spec`) |
|
| 660 | -! | +||
| 16 | +
- dev_ggplot2_args <- teal.widgets::ggplot2_args(+ #' Response variables from an incoming dataset with filtering and selecting. |
||
| 661 | -! | +||
| 17 | +
- theme = list(+ #' @param default_outlier_label (`character`) optional, default column selected to label outliers. |
||
| 662 | -! | +||
| 18 | +
- text = substitute(element_text(size = font_size), list(font_size = font_size)),+ #' @param default_plot_type (`numeric`) optional, defaults to "Response vs Regressor". |
||
| 663 | -! | +||
| 19 | +
- axis.text.x = substitute(+ #' 1. Response vs Regressor |
||
| 664 | -! | +||
| 20 | +
- element_text(angle = angle_val, hjust = hjust_val),+ #' 2. Residuals vs Fitted |
||
| 665 | -! | +||
| 21 | +
- list(angle_val = angle, hjust_val = hjust)+ #' 3. Normal Q-Q |
||
| 666 | +22 |
- )+ #' 4. Scale-Location |
|
| 667 | +23 |
- )+ #' 5. Cook's distance |
|
| 668 | +24 |
- )+ #' 6. Residuals vs Leverage |
|
| 669 | +25 |
-
+ #' 7. Cook's dist vs Leverage |
|
| 670 | -! | +||
| 26 | +
- all_ggplot2_args <- teal.widgets::resolve_ggplot2_args(+ #' @param label_segment_threshold (`numeric(1)` or `numeric(3)`) |
||
| 671 | -! | +||
| 27 | +
- user_plot = ggplot2_args[["Circle plot"]],+ #' Minimum distance between label and point on the plot that triggers the creation of |
||
| 672 | -! | +||
| 28 | +
- user_default = ggplot2_args$default,+ #' a line segment between the two. |
||
| 673 | -! | +||
| 29 | +
- module_plot = dev_ggplot2_args+ #' This may happen when the label cannot be placed next to the point as it overlaps another |
||
| 674 | +30 |
- )+ #' label or point. |
|
| 675 | +31 |
-
+ #' The value is used as the `min.segment.length` parameter to the [ggrepel::geom_text_repel()] function. |
|
| 676 | -! | +||
| 32 | +
- parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(+ #' |
||
| 677 | -! | +||
| 33 | +
- all_ggplot2_args,+ #' It can take the following forms: |
||
| 678 | -! | +||
| 34 | +
- ggtheme = ggtheme+ #' - `numeric(1)`: Fixed value used for the minimum distance and the slider is not presented in the UI. |
||
| 679 | +35 |
- )+ #' - `numeric(3)`: A slider is presented in the UI (under "Plot settings") to adjust the minimum distance dynamically. |
|
| 680 | +36 |
-
+ #' |
|
| 681 | -! | +||
| 37 | +
- teal.code::eval_code(+ #' It takes the form of `c(value, min, max)` and it is passed to the `value_min_max` |
||
| 682 | -! | +||
| 38 | +
- base_q,+ #' argument in `teal.widgets::optionalSliderInputValMinMax`. |
||
| 683 | -! | +||
| 39 | +
- substitute(+ #' |
||
| 684 | -! | +||
| 40 | +
- expr = {
+ # nolint start: line_length. |
||
| 685 | -! | +||
| 41 | +
- pca_rot <- pca$rotation[, c(x_axis, y_axis)] %>%+ #' @param ggplot2_args `r roxygen_ggplot2_args_param("Response vs Regressor", "Residuals vs Fitted", "Scale-Location", "Cook's distance", "Residuals vs Leverage", "Cook's dist vs Leverage")`
|
||
| 686 | -! | +||
| 42 | +
- dplyr::as_tibble(rownames = "label") %>%+ # nolint end: line_length. |
||
| 687 | -! | +||
| 43 | +
- dplyr::filter(label %in% variables)+ #' @param decorators `r roxygen_decorators_param("tm_a_regression")`
|
||
| 688 | +44 |
-
+ #' |
|
| 689 | -! | +||
| 45 | +
- circle_data <- data.frame(+ #' @inherit shared_params return |
||
| 690 | -! | +||
| 46 | +
- x = cos(seq(0, 2 * pi, length.out = 100)),+ #' |
||
| 691 | -! | +||
| 47 | +
- y = sin(seq(0, 2 * pi, length.out = 100))+ #' @section Decorating `tm_a_regression`: |
||
| 692 | +48 |
- )+ #' |
|
| 693 | +49 |
-
+ #' This module generates the following objects, which can be modified in place using decorators: |
|
| 694 | -! | +||
| 50 | +
- circle_plot <- ggplot(pca_rot) ++ #' - `plot` (`ggplot2`) |
||
| 695 | -! | +||
| 51 | +
- geom_point(aes_string(x = x_axis, y = y_axis)) ++ #' |
||
| 696 | -! | +||
| 52 | +
- geom_label(+ #' For additional details and examples of decorators, refer to the vignette |
||
| 697 | -! | +||
| 53 | +
- aes_string(x = x_axis, y = y_axis, label = "label"),+ #' `vignette("decorate-modules-output", package = "teal")` or the [`teal::teal_transform_module()`] documentation.
|
||
| 698 | -! | +||
| 54 | +
- nudge_x = 0.1, nudge_y = 0.05,+ #' |
||
| 699 | -! | +||
| 55 | +
- fontface = "bold"+ #' @examplesShinylive |
||
| 700 | +56 |
- ) ++ #' library(teal.modules.general) |
|
| 701 | -! | +||
| 57 | +
- geom_path(aes(x, y, group = 1), data = circle_data) ++ #' interactive <- function() TRUE |
||
| 702 | -! | +||
| 58 | +
- geom_point(aes(x = x, y = y), data = data.frame(x = 0, y = 0), shape = "x", size = 5) ++ #' {{ next_example }}
|
||
| 703 | -! | +||
| 59 | +
- labs ++ #' @examples |
||
| 704 | -! | +||
| 60 | +
- ggthemes ++ #' |
||
| 705 | -! | +||
| 61 | +
- themes+ #' # general data example |
||
| 706 | +62 |
- },+ #' data <- teal_data() |
|
| 707 | -! | +||
| 63 | +
- env = list(+ #' data <- within(data, {
|
||
| 708 | -! | +||
| 64 | +
- x_axis = x_axis,+ #' require(nestcolor) |
||
| 709 | -! | +||
| 65 | +
- y_axis = y_axis,+ #' CO2 <- CO2 |
||
| 710 | -! | +||
| 66 | +
- variables = variables,+ #' }) |
||
| 711 | -! | +||
| 67 | +
- ggthemes = parsed_ggplot2_args$ggtheme,+ #' |
||
| 712 | -! | +||
| 68 | +
- labs = `if`(is.null(parsed_ggplot2_args$labs), quote(labs()), parsed_ggplot2_args$labs),+ #' app <- init( |
||
| 713 | -! | +||
| 69 | +
- themes = parsed_ggplot2_args$theme+ #' data = data, |
||
| 714 | +70 |
- )+ #' modules = modules( |
|
| 715 | +71 |
- )+ #' tm_a_regression( |
|
| 716 | +72 |
- )+ #' label = "Regression", |
|
| 717 | +73 |
- }+ #' response = data_extract_spec( |
|
| 718 | +74 |
-
+ #' dataname = "CO2", |
|
| 719 | +75 |
- # plot biplot ----+ #' select = select_spec( |
|
| 720 | -! | -
- plot_biplot <- function(base_q) {
+ | |
| 76 | ++ |
+ #' label = "Select variable:", |
|
| 721 | -! | +||
| 77 | +
- qenv <- base_q+ #' choices = "uptake", |
||
| 722 | +78 |
-
+ #' selected = "uptake", |
|
| 723 | -! | +||
| 79 | +
- ANL <- qenv[["ANL"]]+ #' multiple = FALSE, |
||
| 724 | +80 |
-
+ #' fixed = TRUE |
|
| 725 | -! | +||
| 81 | +
- resp_col <- as.character(merged$anl_input_r()$columns_source$response)+ #' ) |
||
| 726 | -! | +||
| 82 | +
- dat_cols <- as.character(merged$anl_input_r()$columns_source$dat)+ #' ), |
||
| 727 | -! | +||
| 83 | +
- x_axis <- input$x_axis+ #' regressor = data_extract_spec( |
||
| 728 | -! | +||
| 84 | +
- y_axis <- input$y_axis+ #' dataname = "CO2", |
||
| 729 | -! | +||
| 85 | +
- variables <- input$variables+ #' select = select_spec( |
||
| 730 | -! | +||
| 86 | +
- pca <- qenv[["pca"]]+ #' label = "Select variables:", |
||
| 731 | +87 |
-
+ #' choices = variable_choices(data[["CO2"]], c("conc", "Treatment")),
|
|
| 732 | -! | +||
| 88 | +
- ggtheme <- input$ggtheme+ #' selected = "conc", |
||
| 733 | +89 |
-
+ #' multiple = TRUE, |
|
| 734 | -! | +||
| 90 | +
- rotate_xaxis_labels <- input$rotate_xaxis_labels+ #' fixed = FALSE |
||
| 735 | -! | +||
| 91 | +
- alpha <- input$alpha+ #' ) |
||
| 736 | -! | +||
| 92 | +
- size <- input$size+ #' ) |
||
| 737 | -! | +||
| 93 | +
- font_size <- input$font_size+ #' ) |
||
| 738 | +94 |
-
+ #' ) |
|
| 739 | -! | +||
| 95 | +
- qenv <- teal.code::eval_code(+ #' ) |
||
| 740 | -! | +||
| 96 | +
- qenv,+ #' if (interactive()) {
|
||
| 741 | -! | +||
| 97 | +
- substitute(+ #' shinyApp(app$ui, app$server) |
||
| 742 | -! | +||
| 98 | +
- expr = pca_rot <- dplyr::as_tibble(pca$x[, c(x_axis, y_axis)]),+ #' } |
||
| 743 | -! | +||
| 99 | +
- env = list(x_axis = x_axis, y_axis = y_axis)+ #' |
||
| 744 | +100 |
- )+ #' @examplesShinylive |
|
| 745 | +101 |
- )+ #' library(teal.modules.general) |
|
| 746 | +102 |
-
+ #' interactive <- function() TRUE |
|
| 747 | +103 |
- # rot_vars = data frame that displays arrows in the plot, need to be scaled to data+ #' {{ next_example }}
|
|
| 748 | -! | +||
| 104 | +
- if (!is.null(input$variables)) {
+ #' @examples |
||
| 749 | -! | +||
| 105 | +
- qenv <- teal.code::eval_code(+ #' # CDISC data example |
||
| 750 | -! | +||
| 106 | +
- qenv,+ #' data <- teal_data() |
||
| 751 | -! | +||
| 107 | +
- substitute(+ #' data <- within(data, {
|
||
| 752 | -! | +||
| 108 | +
- expr = {
+ #' require(nestcolor) |
||
| 753 | -! | +||
| 109 | +
- r <- sqrt(qchisq(0.69, df = 2)) * prod(colMeans(pca_rot ^ 2)) ^ (1 / 4) # styler: off+ #' ADSL <- teal.data::rADSL |
||
| 754 | -! | +||
| 110 | +
- v_scale <- rowSums(pca$rotation ^ 2) # styler: off+ #' }) |
||
| 755 | +111 |
-
+ #' join_keys(data) <- default_cdisc_join_keys[names(data)] |
|
| 756 | -! | +||
| 112 | +
- rot_vars <- pca$rotation[, c(x_axis, y_axis)] %>%+ #' |
||
| 757 | -! | +||
| 113 | +
- dplyr::as_tibble(rownames = "label") %>%+ #' app <- init( |
||
| 758 | -! | +||
| 114 | +
- dplyr::mutate_at(vars(c(x_axis, y_axis)), function(x) r * x / sqrt(max(v_scale)))+ #' data = data, |
||
| 759 | +115 |
- },+ #' modules = modules( |
|
| 760 | -! | +||
| 116 | +
- env = list(x_axis = x_axis, y_axis = y_axis)+ #' tm_a_regression( |
||
| 761 | +117 |
- )+ #' label = "Regression", |
|
| 762 | +118 |
- ) %>%+ #' response = data_extract_spec( |
|
| 763 | -! | +||
| 119 | +
- teal.code::eval_code(+ #' dataname = "ADSL", |
||
| 764 | -! | +||
| 120 | +
- if (is.logical(pca$center) && !pca$center) {
+ #' select = select_spec( |
||
| 765 | -! | +||
| 121 | +
- substitute(+ #' label = "Select variable:", |
||
| 766 | -! | +||
| 122 | +
- expr = {
+ #' choices = "BMRKR1", |
||
| 767 | -! | +||
| 123 | +
- rot_vars <- rot_vars %>%+ #' selected = "BMRKR1", |
||
| 768 | -! | +||
| 124 | +
- tibble::column_to_rownames("label") %>%
+ #' multiple = FALSE, |
||
| 769 | -! | +||
| 125 | +
- sweep(1, apply(ANL[keep_columns], 2, mean, na.rm = TRUE)) %>%+ #' fixed = TRUE |
||
| 770 | -! | +||
| 126 | +
- tibble::rownames_to_column("label") %>%
+ #' ) |
||
| 771 | -! | +||
| 127 | +
- dplyr::mutate(+ #' ), |
||
| 772 | -! | +||
| 128 | +
- xstart = mean(pca$x[, x_axis], na.rm = TRUE),+ #' regressor = data_extract_spec( |
||
| 773 | -! | +||
| 129 | +
- ystart = mean(pca$x[, y_axis], na.rm = TRUE)+ #' dataname = "ADSL", |
||
| 774 | +130 |
- )+ #' select = select_spec( |
|
| 775 | +131 |
- },+ #' label = "Select variables:", |
|
| 776 | -! | +||
| 132 | +
- env = list(x_axis = x_axis, y_axis = y_axis)+ #' choices = variable_choices(data[["ADSL"]], c("AGE", "SEX", "RACE")),
|
||
| 777 | +133 |
- )+ #' selected = "AGE", |
|
| 778 | +134 |
- } else {
+ #' multiple = TRUE, |
|
| 779 | -! | +||
| 135 | +
- quote(rot_vars <- rot_vars %>% dplyr::mutate(xstart = 0, ystart = 0))+ #' fixed = FALSE |
||
| 780 | +136 |
- }+ #' ) |
|
| 781 | +137 |
- ) %>%+ #' ) |
|
| 782 | -! | +||
| 138 | +
- teal.code::eval_code(+ #' ) |
||
| 783 | -! | +||
| 139 | +
- substitute(+ #' ) |
||
| 784 | -! | +||
| 140 | +
- expr = rot_vars <- rot_vars %>% dplyr::filter(label %in% variables),+ #' ) |
||
| 785 | -! | +||
| 141 | +
- env = list(variables = variables)+ #' if (interactive()) {
|
||
| 786 | +142 |
- )+ #' shinyApp(app$ui, app$server) |
|
| 787 | +143 |
- )+ #' } |
|
| 788 | +144 |
- }+ #' |
|
| 789 | +145 |
-
+ #' @export |
|
| 790 | -! | +||
| 146 | +
- pca_plot_biplot_expr <- list(quote(ggplot()))+ #' |
||
| 791 | +147 |
-
+ tm_a_regression <- function(label = "Regression Analysis", |
|
| 792 | -! | +||
| 148 | +
- if (length(resp_col) == 0) {
+ regressor, |
||
| 793 | -! | +||
| 149 | +
- pca_plot_biplot_expr <- c(+ response, |
||
| 794 | -! | +||
| 150 | +
- pca_plot_biplot_expr,+ plot_height = c(600, 200, 2000), |
||
| 795 | -! | +||
| 151 | +
- substitute(- |
- ||
| 796 | -! | -
- geom_point(aes_string(x = x_axis, y = y_axis), data = pca_rot, alpha = alpha, size = size),- |
- |
| 797 | -! | -
- list(x_axis = input$x_axis, y_axis = input$y_axis, alpha = input$alpha, size = input$size)+ plot_width = NULL, |
|
| 798 | +152 |
- )+ alpha = c(1, 0, 1), |
|
| 799 | +153 |
- )+ size = c(2, 1, 8), |
|
| 800 | -! | +||
| 154 | +
- dev_labs <- list()+ ggtheme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void"),
|
||
| 801 | +155 |
- } else {
+ ggplot2_args = teal.widgets::ggplot2_args(), |
|
| 802 | -! | +||
| 156 | +
- rp_keys <- setdiff(colnames(ANL), as.character(unlist(merged$anl_input_r()$columns_source)))+ pre_output = NULL, |
||
| 803 | +157 |
-
+ post_output = NULL, |
|
| 804 | -! | +||
| 158 | +
- response <- ANL[[resp_col]]+ default_plot_type = 1, |
||
| 805 | +159 |
-
+ default_outlier_label = "USUBJID", |
|
| 806 | -! | +||
| 160 | +
- aes_biplot <- substitute(+ label_segment_threshold = c(0.5, 0, 10), |
||
| 807 | -! | +||
| 161 | +
- aes_string(x = x_axis, y = y_axis, color = "response"),+ decorators = NULL) {
|
||
| 808 | +162 | ! |
- env = list(x_axis = x_axis, y_axis = y_axis)+ message("Initializing tm_a_regression")
|
| 809 | +163 |
- )+ |
|
| 810 | +164 |
-
+ # Normalize the parameters |
|
| 811 | +165 | ! |
- qenv <- teal.code::eval_code(+ if (inherits(regressor, "data_extract_spec")) regressor <- list(regressor) |
| 812 | +166 | ! |
- qenv,+ if (inherits(response, "data_extract_spec")) response <- list(response) |
| 813 | +167 | ! |
- substitute(response <- ANL[[resp_col]], env = list(resp_col = resp_col))+ if (inherits(ggplot2_args, "ggplot2_args")) ggplot2_args <- list(default = ggplot2_args) |
| 814 | +168 |
- )+ |
|
| 815 | +169 |
-
+ # Start of assertions |
|
| 816 | +170 | ! |
- dev_labs <- list(color = varname_w_label(resp_col, ANL))+ checkmate::assert_string(label)+ |
+
| 171 | +! | +
+ checkmate::assert_list(regressor, types = "data_extract_spec") |
|
| 817 | +172 | ||
| 818 | +173 | ! |
- scales_biplot <-+ checkmate::assert_list(response, types = "data_extract_spec") |
| 819 | +174 | ! |
- if (+ assert_single_selection(response) |
| 820 | -! | +||
| 175 | +
- is.character(response) ||+ |
||
| 821 | +176 | ! |
- is.factor(response) ||+ checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE) |
| 822 | +177 | ! |
- (is.numeric(response) && length(unique(response)) <= 6)+ checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height") |
| 823 | +178 |
- ) {
- |
- |
| 824 | -! | -
- qenv <- teal.code::eval_code(+ |
|
| 825 | +179 | ! |
- qenv,+ checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE) |
| 826 | +180 | ! |
- quote(pca_rot$response <- as.factor(response))- |
-
| 827 | -- |
- )+ checkmate::assert_numeric( |
|
| 828 | +181 | ! |
- quote(scale_color_brewer(palette = "Dark2"))+ plot_width[1], |
| 829 | +182 | ! |
- } else if (inherits(response, "Date")) {
+ lower = plot_width[2], |
| 830 | +183 | ! |
- qenv <- teal.code::eval_code(+ upper = plot_width[3], |
| 831 | +184 | ! |
- qenv,+ null.ok = TRUE, |
| 832 | +185 | ! |
- quote(pca_rot$response <- numeric(response))+ .var.name = "plot_width" |
| 833 | +186 |
- )+ ) |
|
| 834 | +187 | ||
| 835 | +188 | ! |
- quote(+ if (length(alpha) == 1) {
|
| 836 | +189 | ! |
- scale_color_gradient(+ checkmate::assert_numeric(alpha, any.missing = FALSE, finite = TRUE) |
| 837 | -! | +||
| 190 | +
- low = c(getOption("ggplot2.discrete.colour")[2], "darkred")[1],
+ } else {
|
||
| 838 | +191 | ! |
- high = c(getOption("ggplot2.discrete.colour"), "lightblue")[1],
+ checkmate::assert_numeric(alpha, len = 3, any.missing = FALSE, finite = TRUE) |
| 839 | +192 | ! |
- labels = function(x) as.Date(x, origin = "1970-01-01")- |
-
| 840 | -- |
- )+ checkmate::assert_numeric(alpha[1], lower = alpha[2], upper = alpha[3], .var.name = "alpha") |
|
| 841 | +193 |
- )+ } |
|
| 842 | +194 |
- } else {
- |
- |
| 843 | -! | -
- qenv <- teal.code::eval_code(+ |
|
| 844 | +195 | ! |
- qenv,+ if (length(size) == 1) {
|
| 845 | +196 | ! |
- quote(pca_rot$response <- response)+ checkmate::assert_numeric(size, any.missing = FALSE, finite = TRUE) |
| 846 | +197 |
- )- |
- |
| 847 | -! | -
- quote(scale_color_gradient(+ } else {
|
|
| 848 | +198 | ! |
- low = c(getOption("ggplot2.discrete.colour")[2], "darkred")[1],
+ checkmate::assert_numeric(size, len = 3, any.missing = FALSE, finite = TRUE) |
| 849 | +199 | ! |
- high = c(getOption("ggplot2.discrete.colour"), "lightblue")[1]
- |
-
| 850 | -- |
- ))+ checkmate::assert_numeric(size[1], lower = size[2], upper = size[3], .var.name = "size") |
|
| 851 | +200 |
- }+ } |
|
| 852 | +201 | ||
| 853 | +202 | ! |
- pca_plot_biplot_expr <- c(+ ggtheme <- match.arg(ggtheme) |
| 854 | -! | +||
| 203 | +
- pca_plot_biplot_expr,+ |
||
| 855 | +204 | ! |
- substitute(+ plot_choices <- c( |
| 856 | +205 | ! |
- geom_point(aes_biplot, data = pca_rot, alpha = alpha, size = size),+ "Response vs Regressor", "Residuals vs Fitted", "Normal Q-Q", "Scale-Location", |
| 857 | +206 | ! |
- env = list(aes_biplot = aes_biplot, alpha = alpha, size = size)+ "Cook's distance", "Residuals vs Leverage", "Cook's dist vs Leverage" |
| 858 | +207 |
- ),+ ) |
|
| 859 | +208 | ! |
- scales_biplot- |
-
| 860 | -- |
- )+ checkmate::assert_list(ggplot2_args, types = "ggplot2_args") |
|
| 861 | -+ | ||
| 209 | +! |
- }+ checkmate::assert_subset(names(ggplot2_args), c("default", plot_choices))
|
|
| 862 | +210 | ||
| 863 | -! | -
- if (!is.null(input$variables)) {
- |
- |
| 864 | -! | -
- pca_plot_biplot_expr <- c(- |
- |
| 865 | +211 | ! |
- pca_plot_biplot_expr,+ checkmate::assert_multi_class(pre_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
|
| 866 | +212 | ! |
- substitute(+ checkmate::assert_multi_class(post_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
|
| 867 | +213 | ! |
- geom_segment(+ checkmate::assert_choice(default_plot_type, seq.int(1L, length(plot_choices))) |
| 868 | +214 | ! |
- aes_string(x = "xstart", y = "ystart", xend = x_axis, yend = y_axis),+ checkmate::assert_string(default_outlier_label) |
| 869 | +215 | ! |
- data = rot_vars,+ checkmate::assert_list(decorators, "teal_transform_module", null.ok = TRUE) |
| 870 | -! | +||
| 216 | +
- lineend = "round", linejoin = "round",+ |
||
| 871 | +217 | ! |
- arrow = grid::arrow(length = grid::unit(0.5, "cm"))- |
-
| 872 | -- |
- ),+ if (length(label_segment_threshold) == 1) {
|
|
| 873 | +218 | ! |
- env = list(x_axis = x_axis, y_axis = y_axis)+ checkmate::assert_numeric(label_segment_threshold, any.missing = FALSE, finite = TRUE) |
| 874 | +219 |
- ),+ } else {
|
|
| 875 | +220 | ! |
- substitute(+ checkmate::assert_numeric(label_segment_threshold, len = 3, any.missing = FALSE, finite = TRUE) |
| 876 | +221 | ! |
- geom_label(+ checkmate::assert_numeric( |
| 877 | +222 | ! |
- aes_string(+ label_segment_threshold[1], |
| 878 | +223 | ! |
- x = x_axis,+ lower = label_segment_threshold[2], |
| 879 | +224 | ! |
- y = y_axis,+ upper = label_segment_threshold[3], |
| 880 | +225 | ! |
- label = "label"+ .var.name = "label_segment_threshold" |
| 881 | +226 |
- ),+ ) |
|
| 882 | -! | +||
| 227 | +
- data = rot_vars,+ } |
||
| 883 | +228 | ! |
- nudge_y = 0.1,+ decorators <- normalize_decorators(decorators) |
| 884 | +229 | ! |
- fontface = "bold"+ assert_decorators(decorators, "plot", null.ok = TRUE) |
| 885 | +230 |
- ),+ # End of assertions |
|
| 886 | -! | +||
| 231 | +
- env = list(x_axis = x_axis, y_axis = y_axis)+ |
||
| 887 | +232 |
- ),+ # Make UI args |
|
| 888 | +233 | ! |
- quote(geom_point(aes(x = xstart, y = ystart), data = rot_vars, shape = "x", size = 5))+ args <- as.list(environment()) |
| 889 | -+ | ||
| 234 | +! |
- )+ args[["plot_choices"]] <- plot_choices |
|
| 890 | -+ | ||
| 235 | +! |
- }+ data_extract_list <- list( |
|
| 891 | -+ | ||
| 236 | +! |
-
+ regressor = regressor, |
|
| 892 | +237 | ! |
- angle <- ifelse(isTRUE(rotate_xaxis_labels), 45, 0)+ response = response |
| 893 | -! | +||
| 238 | +
- hjust <- ifelse(isTRUE(rotate_xaxis_labels), 1, 0.5)+ ) |
||
| 894 | +239 | ||
| 895 | +240 | ! |
- dev_ggplot2_args <- teal.widgets::ggplot2_args(+ ans <- module( |
| 896 | +241 | ! |
- labs = dev_labs,+ label = label, |
| 897 | +242 | ! |
- theme = list(+ server = srv_a_regression, |
| 898 | +243 | ! |
- text = substitute(element_text(size = font_size), list(font_size = font_size)),+ ui = ui_a_regression, |
| 899 | +244 | ! |
- axis.text.x = substitute(+ ui_args = args, |
| 900 | +245 | ! |
- element_text(angle = angle_val, hjust = hjust_val),+ server_args = c( |
| 901 | +246 | ! |
- list(angle_val = angle, hjust_val = hjust)- |
-
| 902 | -- |
- )- |
- |
| 903 | -- |
- )+ data_extract_list, |
|
| 904 | -+ | ||
| 247 | +! |
- )+ list( |
|
| 905 | -+ | ||
| 248 | +! |
-
+ plot_height = plot_height, |
|
| 906 | +249 | ! |
- all_ggplot2_args <- teal.widgets::resolve_ggplot2_args(+ plot_width = plot_width, |
| 907 | +250 | ! |
- user_plot = ggplot2_args[["Biplot"]],+ default_outlier_label = default_outlier_label, |
| 908 | +251 | ! |
- user_default = ggplot2_args$default,+ ggplot2_args = ggplot2_args, |
| 909 | +252 | ! |
- module_plot = dev_ggplot2_args+ decorators = decorators |
| 910 | +253 |
) |
|
| 911 | +254 |
-
+ ), |
|
| 912 | +255 | ! |
- parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(+ datanames = teal.transform::get_extract_datanames(data_extract_list)+ |
+
| 256 | ++ |
+ ) |
|
| 913 | +257 | ! |
- all_ggplot2_args,+ attr(ans, "teal_bookmarkable") <- FALSE |
| 914 | +258 | ! |
- ggtheme = ggtheme+ ans |
| 915 | +259 |
- )+ } |
|
| 916 | +260 | ||
| 917 | -! | -
- pca_plot_biplot_expr <- c(- |
- |
| 918 | -! | -
- pca_plot_biplot_expr,- |
- |
| 919 | -! | -
- parsed_ggplot2_args- |
- |
| 920 | +261 |
- )+ # UI function for the regression module |
|
| 921 | +262 |
-
+ ui_a_regression <- function(id, ...) {
|
|
| 922 | +263 | ! |
- teal.code::eval_code(+ ns <- NS(id) |
| 923 | +264 | ! |
- qenv,+ args <- list(...) |
| 924 | +265 | ! |
- substitute(+ is_single_dataset_value <- teal.transform::is_single_dataset(args$regressor, args$response) |
| 925 | +266 | ! |
- expr = {
+ teal.widgets::standard_layout( |
| 926 | +267 | ! |
- biplot <- plot_call- |
-
| 927 | -- |
- },+ output = teal.widgets::white_small_well(tags$div( |
|
| 928 | +268 | ! |
- env = list(+ teal.widgets::plot_with_settings_ui(id = ns("myplot")),
|
| 929 | +269 | ! |
- plot_call = Reduce(function(x, y) call("+", x, y), pca_plot_biplot_expr)
+ tags$div(verbatimTextOutput(ns("text")))
|
| 930 | +270 |
- )+ )), |
|
| 931 | -+ | ||
| 271 | +! |
- )+ encoding = tags$div( |
|
| 932 | +272 |
- )+ ### Reporter |
|
| 933 | -+ | ||
| 273 | +! |
- }+ teal.reporter::simple_reporter_ui(ns("simple_reporter")),
|
|
| 934 | +274 |
-
+ ### |
|
| 935 | -+ | ||
| 275 | +! |
- # plot eigenvector_plot ----+ tags$label("Encodings", class = "text-primary"),
|
|
| 936 | +276 | ! |
- plot_eigenvector <- function(base_q) {
+ teal.transform::datanames_input(args[c("response", "regressor")]),
|
| 937 | +277 | ! |
- pc <- input$pc+ teal.transform::data_extract_ui( |
| 938 | +278 | ! |
- ggtheme <- input$ggtheme+ id = ns("response"),
|
| 939 | -+ | ||
| 279 | +! |
-
+ label = "Response variable", |
|
| 940 | +280 | ! |
- rotate_xaxis_labels <- input$rotate_xaxis_labels+ data_extract_spec = args$response, |
| 941 | +281 | ! |
- font_size <- input$font_size+ is_single_dataset = is_single_dataset_value |
| 942 | +282 |
-
+ ), |
|
| 943 | +283 | ! |
- angle <- ifelse(rotate_xaxis_labels, 45, 0)+ teal.transform::data_extract_ui( |
| 944 | +284 | ! |
- hjust <- ifelse(rotate_xaxis_labels, 1, 0.5)- |
-
| 945 | -- |
-
+ id = ns("regressor"),
|
|
| 946 | +285 | ! |
- dev_ggplot2_args <- teal.widgets::ggplot2_args(+ label = "Regressor variables", |
| 947 | +286 | ! |
- theme = list(+ data_extract_spec = args$regressor, |
| 948 | +287 | ! |
- text = substitute(element_text(size = font_size), list(font_size = font_size)),+ is_single_dataset = is_single_dataset_value |
| 949 | -! | +||
| 288 | +
- axis.text.x = substitute(+ ), |
||
| 950 | +289 | ! |
- element_text(angle = angle_val, hjust = hjust_val),+ radioButtons( |
| 951 | +290 | ! |
- list(angle_val = angle, hjust_val = hjust)+ ns("plot_type"),
|
| 952 | -+ | ||
| 291 | +! |
- )+ label = "Plot type:", |
|
| 953 | -+ | ||
| 292 | +! |
- )+ choices = args$plot_choices, |
|
| 954 | -+ | ||
| 293 | +! |
- )+ selected = args$plot_choices[args$default_plot_type] |
|
| 955 | +294 |
-
+ ), |
|
| 956 | +295 | ! |
- all_ggplot2_args <- teal.widgets::resolve_ggplot2_args(+ checkboxInput(ns("show_outlier"), label = "Display outlier labels", value = TRUE),
|
| 957 | +296 | ! |
- user_plot = ggplot2_args[["Eigenvector plot"]],+ conditionalPanel( |
| 958 | +297 | ! |
- user_default = ggplot2_args$default,+ condition = "input['show_outlier']", |
| 959 | +298 | ! |
- module_plot = dev_ggplot2_args- |
-
| 960 | -- |
- )- |
- |
| 961 | -- |
-
+ ns = ns, |
|
| 962 | +299 | ! |
- parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(+ teal.widgets::optionalSliderInput( |
| 963 | +300 | ! |
- all_ggplot2_args,+ ns("outlier"),
|
| 964 | +301 | ! |
- ggtheme = ggtheme- |
-
| 965 | -- |
- )+ tags$div( |
|
| 966 | -+ | ||
| 302 | +! |
-
+ class = "teal-tooltip", |
|
| 967 | +303 | ! |
- ggplot_exprs <- c(+ tagList( |
| 968 | +304 | ! |
- list(+ "Outlier definition:", |
| 969 | +305 | ! |
- quote(ggplot(pca_rot)),+ icon("circle-info"),
|
| 970 | +306 | ! |
- substitute(+ tags$span( |
| 971 | +307 | ! |
- geom_bar(+ class = "tooltiptext", |
| 972 | +308 | ! |
- aes_string(x = "Variable", y = pc),+ paste( |
| 973 | +309 | ! |
- stat = "identity",+ "Use the slider to choose the cut-off value to define outliers.", |
| 974 | +310 | ! |
- color = "black",+ "Points with a Cook's distance greater than", |
| 975 | +311 | ! |
- fill = c(getOption("ggplot2.discrete.colour"), "lightblue")[1]
+ "the value on the slider times the mean of the Cook's distance of the dataset will have labels." |
| 976 | +312 |
- ),+ ) |
|
| 977 | -! | +||
| 313 | +
- env = list(pc = pc)+ ) |
||
| 978 | +314 |
- ),+ ) |
|
| 979 | -! | +||
| 315 | +
- substitute(+ ), |
||
| 980 | +316 | ! |
- geom_text(+ min = 1, max = 10, value = 9, ticks = FALSE, step = .1 |
| 981 | -! | +||
| 317 | +
- aes(+ ), |
||
| 982 | +318 | ! |
- x = Variable,+ teal.widgets::optionalSelectInput( |
| 983 | +319 | ! |
- y = pc_name,+ ns("label_var"),
|
| 984 | +320 | ! |
- label = round(pc_name, 3),+ multiple = FALSE, |
| 985 | +321 | ! |
- vjust = ifelse(pc_name > 0, -0.5, 1.3)+ label = "Outlier label" |
| 986 | +322 |
- )+ ) |
|
| 987 | +323 |
- ),+ ), |
|
| 988 | +324 | ! |
- env = list(pc_name = as.name(pc))+ ui_decorate_teal_data(ns("decorator"), decorators = select_decorators(args$decorators, "plot")),
|
| 989 | -+ | ||
| 325 | +! |
- )+ teal.widgets::panel_group( |
|
| 990 | -+ | ||
| 326 | +! |
- ),+ teal.widgets::panel_item( |
|
| 991 | +327 | ! |
- parsed_ggplot2_args$labs,+ title = "Plot settings", |
| 992 | +328 | ! |
- parsed_ggplot2_args$ggtheme,+ teal.widgets::optionalSliderInputValMinMax(ns("alpha"), "Opacity:", args$alpha, ticks = FALSE),
|
| 993 | +329 | ! |
- parsed_ggplot2_args$theme+ teal.widgets::optionalSliderInputValMinMax(ns("size"), "Points size:", args$size, ticks = FALSE),
|
| 994 | -+ | ||
| 330 | +! |
- )+ teal.widgets::optionalSliderInputValMinMax( |
|
| 995 | -+ | ||
| 331 | +! |
-
+ inputId = ns("label_min_segment"),
|
|
| 996 | +332 | ! |
- teal.code::eval_code(+ label = tags$div( |
| 997 | +333 | ! |
- base_q,+ class = "teal-tooltip", |
| 998 | +334 | ! |
- substitute(+ tagList( |
| 999 | +335 | ! |
- expr = {
+ "Label min. segment:", |
| 1000 | +336 | ! |
- pca_rot <- pca$rotation[, pc, drop = FALSE] %>%+ icon("circle-info"),
|
| 1001 | +337 | ! |
- dplyr::as_tibble(rownames = "Variable")+ tags$span( |
| 1002 | +338 | ! |
- eigenvector_plot <- plot_call- |
-
| 1003 | -- |
- },+ class = "tooltiptext", |
|
| 1004 | +339 | ! |
- env = list(+ paste( |
| 1005 | +340 | ! |
- pc = pc,+ "Use the slider to choose the cut-off value to define minimum distance between label and point", |
| 1006 | +341 | ! |
- plot_call = Reduce(function(x, y) call("+", x, y), ggplot_exprs)
- |
-
| 1007 | -- |
- )+ "that generates a line segment.", |
|
| 1008 | -+ | ||
| 342 | +! |
- )+ "It's only valid when 'Display outlier labels' is checked." |
|
| 1009 | +343 |
- )+ ) |
|
| 1010 | +344 |
- }+ ) |
|
| 1011 | +345 |
-
+ ) |
|
| 1012 | +346 |
- # qenvs ---- |
- |
| 1013 | -! | -
- output_q <- lapply(+ ), |
|
| 1014 | +347 | ! |
- list(+ value_min_max = args$label_segment_threshold, |
| 1015 | -! | +||
| 348 | +
- elbow_plot = plot_elbow,+ # Extra parameters to sliderInput |
||
| 1016 | +349 | ! |
- circle_plot = plot_circle,+ ticks = FALSE, |
| 1017 | +350 | ! |
- biplot = plot_biplot,+ step = .1, |
| 1018 | +351 | ! |
- eigenvector_plot = plot_eigenvector+ round = FALSE |
| 1019 | +352 |
- ),+ ), |
|
| 1020 | +353 | ! |
- function(fun) {
+ selectInput( |
| 1021 | +354 | ! |
- reactive({
+ inputId = ns("ggtheme"),
|
| 1022 | +355 | ! |
- req(computation())+ label = "Theme (by ggplot):", |
| 1023 | +356 | ! |
- teal::validate_inputs(iv_r())+ choices = ggplot_themes, |
| 1024 | +357 | ! |
- teal::validate_inputs(iv_extra, header = "Plot settings are required")+ selected = args$ggtheme, |
| 1025 | +358 | ! |
- fun(computation())+ multiple = FALSE |
| 1026 | +359 |
- })+ ) |
|
| 1027 | +360 |
- }+ ) |
|
| 1028 | +361 |
- )+ ) |
|
| 1029 | +362 |
-
+ ), |
|
| 1030 | +363 | ! |
- decorated_q <- mapply(+ forms = tagList( |
| 1031 | +364 | ! |
- function(obj_name, q) {
+ teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code")
|
| 1032 | -! | +||
| 365 | +
- srv_decorate_teal_data(+ ), |
||
| 1033 | +366 | ! |
- id = sprintf("d_%s", obj_name),
+ pre_output = args$pre_output, |
| 1034 | +367 | ! |
- data = q,+ post_output = args$post_output |
| 1035 | -! | +||
| 368 | +
- decorators = select_decorators(decorators, obj_name),+ ) |
||
| 1036 | -! | +||
| 369 | +
- expr = reactive({
+ } |
||
| 1037 | -! | +||
| 370 | +
- substitute(print(.plot), env = list(.plot = as.name(obj_name)))+ |
||
| 1038 | +371 |
- }),+ # Server function for the regression module |
|
| 1039 | -! | +||
| 372 | +
- expr_is_reactive = TRUE+ srv_a_regression <- function(id, |
||
| 1040 | +373 |
- )+ data, |
|
| 1041 | +374 |
- },+ reporter, |
|
| 1042 | -! | +||
| 375 | +
- names(output_q),+ filter_panel_api, |
||
| 1043 | -! | +||
| 376 | +
- output_q+ response, |
||
| 1044 | +377 |
- )+ regressor, |
|
| 1045 | +378 |
-
+ plot_height, |
|
| 1046 | +379 |
- # plot final ----+ plot_width, |
|
| 1047 | -! | +||
| 380 | +
- decorated_output_q <- reactive({
+ ggplot2_args,+ |
+ ||
| 381 | ++ |
+ default_outlier_label,+ |
+ |
| 382 | ++ |
+ decorators) {
|
|
| 1048 | +383 | ! |
- switch(req(input$plot_type),+ with_reporter <- !missing(reporter) && inherits(reporter, "Reporter") |
| 1049 | +384 | ! |
- "Elbow plot" = decorated_q$elbow_plot(),+ with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI") |
| 1050 | +385 | ! |
- "Circle plot" = decorated_q$circle_plot(),+ checkmate::assert_class(data, "reactive") |
| 1051 | +386 | ! |
- "Biplot" = decorated_q$biplot(),+ checkmate::assert_class(isolate(data()), "teal_data") |
| 1052 | +387 | ! |
- "Eigenvector plot" = decorated_q$eigenvector_plot(),+ moduleServer(id, function(input, output, session) {
|
| 1053 | +388 | ! |
- stop("Unknown plot")
+ teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.general") |
| 1054 | +389 |
- )+ |
|
| 1055 | -+ | ||
| 390 | +! |
- })+ ns <- session$ns |
|
| 1056 | +391 | ||
| 1057 | +392 | ! |
- plot_r <- reactive({
+ rule_rvr1 <- function(value) {
|
| 1058 | +393 | ! |
- plot_name <- gsub(" ", "_", tolower(req(input$plot_type)))
+ if (isTRUE(input$plot_type == "Response vs Regressor")) {
|
| 1059 | +394 | ! |
- req(decorated_output_q())[[plot_name]]+ if (length(value) > 1L) {
+ |
+
| 395 | +! | +
+ "This plot can only have one regressor." |
|
| 1060 | +396 |
- })+ } |
|
| 1061 | +397 |
-
+ }+ |
+ |
| 398 | ++ |
+ } |
|
| 1062 | +399 | ! |
- pws <- teal.widgets::plot_with_settings_srv(+ rule_rvr2 <- function(other) {
|
| 1063 | +400 | ! |
- id = "pca_plot",+ function(value) {
|
| 1064 | +401 | ! |
- plot_r = plot_r,+ if (isTRUE(input$plot_type == "Response vs Regressor")) {
|
| 1065 | +402 | ! |
- height = plot_height,+ otherval <- selector_list()[[other]]()$select |
| 1066 | +403 | ! |
- width = plot_width,+ if (isTRUE(value == otherval)) {
|
| 1067 | +404 | ! |
- graph_align = "center"+ "Response and Regressor must be different." |
| 1068 | +405 |
- )+ } |
|
| 1069 | +406 |
-
+ } |
|
| 1070 | +407 |
- # tables ----+ } |
|
| 1071 | -! | +||
| 408 | +
- output$tbl_importance <- renderTable(+ }+ |
+ ||
| 409 | ++ | + | |
| 1072 | +410 | ! |
- expr = {
+ selector_list <- teal.transform::data_extract_multiple_srv( |
| 1073 | +411 | ! |
- req("importance" %in% input$tables_display, computation())
+ data_extract = list(response = response, regressor = regressor), |
| 1074 | +412 | ! |
- computation()[["tbl_importance"]]+ datasets = data, |
| 1075 | -+ | ||
| 413 | +! |
- },+ select_validation_rule = list( |
|
| 1076 | +414 | ! |
- bordered = TRUE,+ regressor = shinyvalidate::compose_rules( |
| 1077 | +415 | ! |
- align = "c",+ shinyvalidate::sv_required("At least one regressor should be selected."),
|
| 1078 | +416 | ! |
- digits = 3+ rule_rvr1, |
| 1079 | -+ | ||
| 417 | +! |
- )+ rule_rvr2("response")
|
|
| 1080 | +418 |
-
+ ), |
|
| 1081 | +419 | ! |
- output$tbl_importance_ui <- renderUI({
+ response = shinyvalidate::compose_rules( |
| 1082 | +420 | ! |
- req("importance" %in% input$tables_display)
+ shinyvalidate::sv_required("At least one response should be selected."),
|
| 1083 | +421 | ! |
- tags$div(+ rule_rvr2("regressor")
|
| 1084 | -! | +||
| 422 | +
- align = "center",+ ) |
||
| 1085 | -! | +||
| 423 | +
- tags$h4("Principal components importance"),
+ )+ |
+ ||
| 424 | ++ |
+ )+ |
+ |
| 425 | ++ | + | |
| 1086 | +426 | ! |
- tableOutput(session$ns("tbl_importance")),
+ iv_r <- reactive({
|
| 1087 | +427 | ! |
- tags$hr()+ iv <- shinyvalidate::InputValidator$new() |
| 1088 | -+ | ||
| 428 | +! |
- )+ teal.transform::compose_and_enable_validators(iv, selector_list) |
|
| 1089 | +429 |
}) |
|
| 1090 | +430 | ||
| 1091 | +431 | ! |
- output$tbl_eigenvector <- renderTable(+ iv_out <- shinyvalidate::InputValidator$new() |
| 1092 | +432 | ! |
- expr = {
+ iv_out$condition(~ isTRUE(input$show_outlier)) |
| 1093 | +433 | ! |
- req("eigenvector" %in% input$tables_display, req(computation()))
+ iv_out$add_rule("label_var", shinyvalidate::sv_required("Please provide an `Outlier label` variable"))
|
| 1094 | +434 | ! |
- computation()[["tbl_eigenvector"]]+ iv_out$enable() |
| 1095 | +435 |
- },+ |
|
| 1096 | +436 | ! |
- bordered = TRUE,+ anl_merged_input <- teal.transform::merge_expression_srv( |
| 1097 | +437 | ! |
- align = "c",+ selector_list = selector_list, |
| 1098 | +438 | ! |
- digits = 3+ datasets = data |
| 1099 | +439 |
) |
|
| 1100 | +440 | ||
| 1101 | +441 | ! |
- output$tbl_eigenvector_ui <- renderUI({
- |
-
| 1102 | -! | -
- req("eigenvector" %in% input$tables_display)
+ regression_var <- reactive({
|
|
| 1103 | +442 | ! |
- tags$div(+ teal::validate_inputs(iv_r()) |
| 1104 | -! | +||
| 443 | +
- align = "center",+ |
||
| 1105 | +444 | ! |
- tags$h4("Eigenvectors"),
+ list( |
| 1106 | +445 | ! |
- tableOutput(session$ns("tbl_eigenvector")),
+ response = as.vector(anl_merged_input()$columns_source$response), |
| 1107 | +446 | ! |
- tags$hr()+ regressor = as.vector(anl_merged_input()$columns_source$regressor) |
| 1108 | +447 |
) |
|
| 1109 | +448 |
}) |
|
| 1110 | +449 | ||
| 1111 | +450 | ! |
- output$all_plots <- renderUI({
+ anl_merged_q <- reactive({
|
| 1112 | +451 | ! |
- teal::validate_inputs(iv_r())+ req(anl_merged_input()) |
| 1113 | +452 | ! |
- teal::validate_inputs(iv_extra, header = "Plot settings are required")+ data() %>%+ |
+
| 453 | +! | +
+ teal.code::eval_code(as.expression(anl_merged_input()$expr)) |
|
| 1114 | +454 | ++ |
+ })+ |
+
| 455 | |||
| 456 | ++ |
+ # sets qenv object and populates it with data merge call and fit expression+ |
+ |
| 1115 | +457 | ! |
- validation()+ fit_r <- reactive({
|
| 1116 | +458 | ! |
- tags$div(+ ANL <- anl_merged_q()[["ANL"]] |
| 1117 | +459 | ! |
- class = "overflow-scroll",+ teal::validate_has_data(ANL, 10)+ |
+
| 460 | ++ | + | |
| 1118 | +461 | ! |
- uiOutput(session$ns("tbl_importance_ui")),
+ validate(need(is.numeric(ANL[regression_var()$response][[1]]), "Response variable should be numeric."))+ |
+
| 462 | ++ | + | |
| 1119 | +463 | ! |
- uiOutput(session$ns("tbl_eigenvector_ui")),
+ teal::validate_has_data( |
| 1120 | +464 | ! |
- teal.widgets::plot_with_settings_ui(id = session$ns("pca_plot"))
+ ANL[, c(regression_var()$response, regression_var()$regressor)], 10, |
| 1121 | -+ | ||
| 465 | +! |
- )+ complete = TRUE, allow_inf = FALSE |
|
| 1122 | +466 |
- })+ ) |
|
| 1123 | +467 | ||
| 1124 | +468 | ! |
- teal.widgets::verbatim_popup_srv(+ form <- stats::as.formula( |
| 1125 | +469 | ! |
- id = "rcode",+ paste( |
| 1126 | +470 | ! |
- verbatim_content = reactive(teal.code::get_code(req(decorated_output_q()))),+ regression_var()$response, |
| 1127 | +471 | ! |
- title = "R Code for PCA"+ paste(+ |
+
| 472 | +! | +
+ regression_var()$regressor,+ |
+ |
| 473 | +! | +
+ collapse = " + " |
|
| 1128 | +474 |
- )+ ),+ |
+ |
| 475 | +! | +
+ sep = " ~ " |
|
| 1129 | +476 |
-
+ ) |
|
| 1130 | +477 |
- ### REPORTER+ )+ |
+ |
| 478 | ++ | + | |
| 1131 | +479 | ! |
- if (with_reporter) {
+ if (input$show_outlier) {
|
| 1132 | +480 | ! |
- card_fun <- function(comment, label) {
+ opts <- teal.transform::variable_choices(ANL) |
| 1133 | +481 | ! |
- card <- teal::report_card_template(+ selected <- if (!is.null(isolate(input$label_var)) && isolate(input$label_var) %in% as.character(opts)) {
|
| 1134 | +482 | ! |
- title = "Principal Component Analysis Plot",+ isolate(input$label_var)+ |
+
| 483 | ++ |
+ } else {
|
|
| 1135 | +484 | ! |
- label = label,+ if (length(opts[as.character(opts) == default_outlier_label]) == 0) {
|
| 1136 | +485 | ! |
- with_filter = with_filter,+ opts[[1]]+ |
+
| 486 | ++ |
+ } else {
|
|
| 1137 | +487 | ! |
- filter_panel_api = filter_panel_api+ opts[as.character(opts) == default_outlier_label] |
| 1138 | +488 |
- )+ }+ |
+ |
| 489 | ++ |
+ } |
|
| 1139 | +490 | ! |
- card$append_text("Principal Components Table", "header3")
+ teal.widgets::updateOptionalSelectInput( |
| 1140 | +491 | ! |
- card$append_table(computation()[["tbl_importance"]])+ session = session, |
| 1141 | +492 | ! |
- card$append_text("Eigenvectors Table", "header3")
+ inputId = "label_var", |
| 1142 | +493 | ! |
- card$append_table(computation()[["tbl_eigenvector"]])+ choices = opts, |
| 1143 | +494 | ! |
- card$append_text("Plot", "header3")
+ selected = restoreInput(ns("label_var"), selected)
+ |
+
| 495 | ++ |
+ )+ |
+ |
| 496 | ++ | + | |
| 1144 | +497 | ! |
- card$append_plot(plot_r(), dim = pws$dim())+ data <- fortify(stats::lm(form, data = ANL)) |
| 1145 | +498 | ! |
- if (!comment == "") {
+ cooksd <- data$.cooksd[!is.nan(data$.cooksd)] |
| 1146 | +499 | ! |
- card$append_text("Comment", "header3")
+ max_outlier <- max(ceiling(max(cooksd) / mean(cooksd)), 2) |
| 1147 | +500 | ! |
- card$append_text(comment)+ cur_outlier <- isolate(input$outlier) |
| 1148 | -+ | ||
| 501 | +! |
- }+ updateSliderInput( |
|
| 1149 | +502 | ! |
- card$append_src(teal.code::get_code(req(decorated_output_q())))+ session = session, |
| 1150 | +503 | ! |
- card+ inputId = "outlier", |
| 1151 | -+ | ||
| 504 | +! |
- }+ min = 1, |
|
| 1152 | +505 | ! |
- teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
+ max = max_outlier, |
| 1153 | -+ | ||
| 506 | +! |
- }+ value = restoreInput(ns("outlier"), if (cur_outlier < max_outlier) cur_outlier else max_outlier * .9)
|
|
| 1154 | +507 |
- ###+ ) |
|
| 1155 | +508 |
- })+ } |
|
| 1156 | +509 |
- }+ |
| 1 | -+ | ||
| 510 | +! |
- #' `teal` module: Distribution analysis+ anl_merged_q() %>% |
|
| 2 | -+ | ||
| 511 | +! |
- #'+ teal.code::eval_code(substitute(fit <- stats::lm(form, data = ANL), env = list(form = form))) %>% |
|
| 3 | -+ | ||
| 512 | +! |
- #' Module is designed to explore the distribution of a single variable within a given dataset.+ teal.code::eval_code(quote({
|
|
| 4 | -+ | ||
| 513 | +! |
- #' It offers several tools, such as histograms, Q-Q plots, and various statistical tests to+ for (regressor in names(fit$contrasts)) {
|
|
| 5 | -+ | ||
| 514 | +! |
- #' visually and statistically analyze the variable's distribution.+ alts <- paste0(levels(ANL[[regressor]]), collapse = "|") |
|
| 6 | -+ | ||
| 515 | +! |
- #'+ names(fit$coefficients) <- gsub( |
|
| 7 | -+ | ||
| 516 | +! |
- #' @inheritParams teal::module+ paste0("^(", regressor, ")(", alts, ")$"), paste0("\\1", ": ", "\\2"), names(fit$coefficients)
|
|
| 8 | +517 |
- #' @inheritParams teal.widgets::standard_layout+ ) |
|
| 9 | +518 |
- #' @inheritParams shared_params+ } |
|
| 10 | +519 |
- #'+ })) %>% |
|
| 11 | -+ | ||
| 520 | +! |
- #' @param dist_var (`data_extract_spec` or `list` of multiple `data_extract_spec`)+ teal.code::eval_code(quote(summary(fit))) |
|
| 12 | +521 |
- #' Variable(s) for which the distribution will be analyzed.+ }) |
|
| 13 | +522 |
- #' @param strata_var (`data_extract_spec` or `list` of multiple `data_extract_spec`)+ |
|
| 14 | -+ | ||
| 523 | +! |
- #' Categorical variable used to split the distribution analysis.+ label_col <- reactive({
|
|
| 15 | -+ | ||
| 524 | +! |
- #' @param group_var (`data_extract_spec` or `list` of multiple `data_extract_spec`)+ teal::validate_inputs(iv_out) |
|
| 16 | +525 |
- #' Variable used for faceting plot into multiple panels.+ |
|
| 17 | -+ | ||
| 526 | +! |
- #' @param freq (`logical`) optional, whether to display frequency (`TRUE`) or density (`FALSE`).+ substitute( |
|
| 18 | -+ | ||
| 527 | +! |
- #' Defaults to density (`FALSE`).+ expr = dplyr::if_else( |
|
| 19 | -+ | ||
| 528 | +! |
- #' @param bins (`integer(1)` or `integer(3)`) optional, specifies the number of bins for the histogram.+ data$.cooksd > outliers * mean(data$.cooksd, na.rm = TRUE), |
|
| 20 | -+ | ||
| 529 | +! |
- #' - When the length of `bins` is one: The histogram bins will have a fixed size based on the `bins` provided.+ as.character(stats::na.omit(ANL)[[label_var]]), |
|
| 21 | +530 |
- #' - When the length of `bins` is three: The histogram bins are dynamically adjusted based on vector of `value`, `min`,+ "" |
|
| 22 | +531 |
- #' and `max`.+ ) %>% |
|
| 23 | -+ | ||
| 532 | +! |
- #' Defaults to `c(30L, 1L, 100L)`.+ dplyr::if_else(is.na(.), "cooksd == NaN", .), |
|
| 24 | -+ | ||
| 533 | +! |
- #'+ env = list(outliers = input$outlier, label_var = input$label_var) |
|
| 25 | +534 |
- #' @param ggplot2_args `r roxygen_ggplot2_args_param("Histogram", "QQplot")`
+ ) |
|
| 26 | +535 |
- #' @param decorators `r roxygen_decorators_param("tm_g_distribution")`
+ }) |
|
| 27 | +536 |
- #'+ |
|
| 28 | -+ | ||
| 537 | +! |
- #' @inherit shared_params return+ label_min_segment <- reactive({
|
|
| 29 | -+ | ||
| 538 | +! |
- #'+ input$label_min_segment |
|
| 30 | +539 |
- #' @section Decorating `tm_g_distribution`:+ }) |
|
| 31 | +540 |
- #'+ |
|
| 32 | -+ | ||
| 541 | +! |
- #' This module generates the following objects, which can be modified in place using decorators::+ outlier_label <- reactive({
|
|
| 33 | -+ | ||
| 542 | +! |
- #' - `histogram_plot` (`ggplot2`)+ substitute( |
|
| 34 | -+ | ||
| 543 | +! |
- #' - `qq_plot` (`data.frame`)+ expr = ggrepel::geom_text_repel( |
|
| 35 | -+ | ||
| 544 | +! |
- #' - `summary_table` (`data.frame`)+ label = label_col, |
|
| 36 | -+ | ||
| 545 | +! |
- #' - `test_table` (`data.frame`)+ color = "red", |
|
| 37 | -+ | ||
| 546 | +! |
- #'+ hjust = 0, |
|
| 38 | -+ | ||
| 547 | +! |
- #' Decorators can be applied to all outputs or only to specific objects using a+ vjust = 1, |
|
| 39 | -+ | ||
| 548 | +! |
- #' named list of `teal_transform_module` objects.+ max.overlaps = Inf, |
|
| 40 | -+ | ||
| 549 | +! |
- #' The `"default"` name is reserved for decorators that are applied to all outputs.+ min.segment.length = label_min_segment, |
|
| 41 | -+ | ||
| 550 | +! |
- #' See code snippet below:+ segment.alpha = 0.5, |
|
| 42 | -+ | ||
| 551 | +! |
- #'+ seed = 123 |
|
| 43 | +552 |
- #' ```+ ), |
|
| 44 | -+ | ||
| 553 | +! |
- #' tm_g_distribution(+ env = list(label_col = label_col(), label_min_segment = label_min_segment()) |
|
| 45 | +554 |
- #' ..., # arguments for module+ ) |
|
| 46 | +555 |
- #' decorators = list(+ }) |
|
| 47 | +556 |
- #' default = list(teal_transform_module(...)), # applied to all outputs+ |
|
| 48 | -+ | ||
| 557 | +! |
- #' histogram_plot = list(teal_transform_module(...)), # applied only to `histogram_plot` output+ output_plot_base <- reactive({
|
|
| 49 | -+ | ||
| 558 | +! |
- #' qq_plot = list(teal_transform_module(...)) # applied only to `qq_plot` output+ base_fit <- fit_r() |
|
| 50 | -+ | ||
| 559 | +! |
- #' summary_table = list(teal_transform_module(...)) # applied only to `summary_table` output+ teal.code::eval_code( |
|
| 51 | -+ | ||
| 560 | +! |
- #' test_table = list(teal_transform_module(...)) # applied only to `test_table` output+ base_fit, |
|
| 52 | -+ | ||
| 561 | +! |
- #' )+ quote({
|
|
| 53 | -+ | ||
| 562 | +! |
- #' )+ class(fit$residuals) <- NULL |
|
| 54 | +563 |
- #' ```+ |
|
| 55 | -+ | ||
| 564 | +! |
- #'+ data <- ggplot2::fortify(fit) |
|
| 56 | +565 |
- #' For additional details and examples of decorators, refer to the vignette+ |
|
| 57 | -+ | ||
| 566 | +! |
- #' `vignette("decorate-modules-output", package = "teal")` or the [`teal::teal_transform_module()`] documentation.
+ smooth <- function(x, y) {
|
|
| 58 | -+ | ||
| 567 | +! |
- #'+ as.data.frame(stats::lowess(x, y, f = 2 / 3, iter = 3)) |
|
| 59 | +568 |
- #' @examplesShinylive+ } |
|
| 60 | +569 |
- #' library(teal.modules.general)+ |
|
| 61 | -+ | ||
| 570 | +! |
- #' interactive <- function() TRUE+ smoothy_aes <- ggplot2::aes_string(x = "x", y = "y") |
|
| 62 | +571 |
- #' {{ next_example }}
+
|
|
| 63 | -+ | ||
| 572 | +! |
- # nolint start: line_length_linter.+ reg_form <- deparse(fit$call[[2]]) |
|
| 64 | +573 |
- #' @examplesIf require("ggpmisc", quietly = TRUE) && require("ggpp", quietly = TRUE) && require("goftest", quietly = TRUE) && require("MASS", quietly = TRUE) && require("broom", quietly = TRUE)
+ }) |
|
| 65 | +574 |
- # nolint end: line_length_linter.+ ) |
|
| 66 | +575 |
- #' # general data example+ }) |
|
| 67 | +576 |
- #' data <- teal_data()+ |
|
| 68 | -+ | ||
| 577 | +! |
- #' data <- within(data, {
+ output_plot_0 <- reactive({
|
|
| 69 | -+ | ||
| 578 | +! |
- #' iris <- iris+ fit <- fit_r()[["fit"]] |
|
| 70 | -+ | ||
| 579 | +! |
- #' })+ ANL <- anl_merged_q()[["ANL"]] |
|
| 71 | +580 |
- #'+ |
|
| 72 | -+ | ||
| 581 | +! |
- #' app <- init(+ stopifnot(ncol(fit$model) == 2) |
|
| 73 | +582 |
- #' data = data,+ |
|
| 74 | -+ | ||
| 583 | +! |
- #' modules = list(+ if (!is.factor(ANL[[regression_var()$regressor]])) {
|
|
| 75 | -+ | ||
| 584 | +! |
- #' tm_g_distribution(+ shinyjs::show("size")
|
|
| 76 | -+ | ||
| 585 | +! |
- #' dist_var = data_extract_spec(+ shinyjs::show("alpha")
|
|
| 77 | -+ | ||
| 586 | +! |
- #' dataname = "iris",+ plot <- substitute( |
|
| 78 | -+ | ||
| 587 | +! |
- #' select = select_spec(variable_choices("iris"), "Petal.Length")
+ expr = ggplot(fit$model[, 2:1], aes_string(regressor, response)) + |
|
| 79 | -+ | ||
| 588 | +! |
- #' )+ geom_point(size = size, alpha = alpha) + |
|
| 80 | -+ | ||
| 589 | +! |
- #' )+ stat_smooth(method = "lm", formula = y ~ x, se = FALSE), |
|
| 81 | -+ | ||
| 590 | +! |
- #' )+ env = list( |
|
| 82 | -+ | ||
| 591 | +! |
- #' )+ regressor = regression_var()$regressor, |
|
| 83 | -+ | ||
| 592 | +! |
- #' if (interactive()) {
+ response = regression_var()$response, |
|
| 84 | -+ | ||
| 593 | +! |
- #' shinyApp(app$ui, app$server)+ size = input$size, |
|
| 85 | -+ | ||
| 594 | +! |
- #' }+ alpha = input$alpha |
|
| 86 | +595 |
- #'+ ) |
|
| 87 | +596 |
- #' @examplesShinylive+ ) |
|
| 88 | -+ | ||
| 597 | +! |
- #' library(teal.modules.general)+ if (input$show_outlier) {
|
|
| 89 | -+ | ||
| 598 | +! |
- #' interactive <- function() TRUE+ plot <- substitute( |
|
| 90 | -+ | ||
| 599 | +! |
- #' {{ next_example }}
+ expr = plot + outlier_label, |
|
| 91 | -+ | ||
| 600 | +! |
- # nolint start: line_length_linter.+ env = list(plot = plot, outlier_label = outlier_label()) |
|
| 92 | +601 |
- #' @examplesIf require("ggpmisc", quietly = TRUE) && require("ggpp", quietly = TRUE) && require("goftest", quietly = TRUE) && require("MASS", quietly = TRUE) && require("broom", quietly = TRUE)
+ ) |
|
| 93 | +602 |
- # nolint end: line_length_linter.+ } |
|
| 94 | +603 |
- #' # CDISC data example+ } else {
|
|
| 95 | -+ | ||
| 604 | +! |
- #' data <- teal_data()+ shinyjs::hide("size")
|
|
| 96 | -+ | ||
| 605 | +! |
- #' data <- within(data, {
+ shinyjs::hide("alpha")
|
|
| 97 | -+ | ||
| 606 | +! |
- #' ADSL <- rADSL+ plot <- substitute( |
|
| 98 | -+ | ||
| 607 | +! |
- #' })+ expr = ggplot(fit$model[, 2:1], aes_string(regressor, response)) + |
|
| 99 | -+ | ||
| 608 | +! |
- #' join_keys(data) <- default_cdisc_join_keys[names(data)]+ geom_boxplot(), |
|
| 100 | -+ | ||
| 609 | +! |
- #'+ env = list(regressor = regression_var()$regressor, response = regression_var()$response) |
|
| 101 | +610 |
- #' vars1 <- choices_selected(+ ) |
|
| 102 | -+ | ||
| 611 | +! |
- #' variable_choices(data[["ADSL"]], c("ARM", "COUNTRY", "SEX")),
+ if (input$show_outlier) {
|
|
| 103 | -+ | ||
| 612 | +! |
- #' selected = NULL- |
- |
| 104 | -- |
- #' )- |
- |
| 105 | -- |
- #'+ plot <- substitute(expr = plot + outlier_label, env = list(plot = plot, outlier_label = outlier_label())) |
|
| 106 | +613 |
- #' app <- init(+ } |
|
| 107 | +614 |
- #' data = data,+ } |
|
| 108 | +615 |
- #' modules = modules(+ |
|
| 109 | -+ | ||
| 616 | +! |
- #' tm_g_distribution(+ parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args( |
|
| 110 | -+ | ||
| 617 | +! |
- #' dist_var = data_extract_spec(+ teal.widgets::resolve_ggplot2_args( |
|
| 111 | -+ | ||
| 618 | +! |
- #' dataname = "ADSL",+ user_plot = ggplot2_args[["Response vs Regressor"]], |
|
| 112 | -+ | ||
| 619 | +! |
- #' select = select_spec(+ user_default = ggplot2_args$default, |
|
| 113 | -+ | ||
| 620 | +! |
- #' choices = variable_choices(data[["ADSL"]], c("AGE", "BMRKR1")),
+ module_plot = teal.widgets::ggplot2_args( |
|
| 114 | -+ | ||
| 621 | +! |
- #' selected = "BMRKR1",+ labs = list( |
|
| 115 | -+ | ||
| 622 | +! |
- #' multiple = FALSE,+ title = "Response vs Regressor", |
|
| 116 | -+ | ||
| 623 | +! |
- #' fixed = FALSE+ x = varname_w_label(regression_var()$regressor, ANL), |
|
| 117 | -+ | ||
| 624 | +! |
- #' )+ y = varname_w_label(regression_var()$response, ANL) |
|
| 118 | +625 |
- #' ),+ ), |
|
| 119 | -+ | ||
| 626 | +! |
- #' strata_var = data_extract_spec(+ theme = list() |
|
| 120 | +627 |
- #' dataname = "ADSL",+ ) |
|
| 121 | +628 |
- #' filter = filter_spec(+ ), |
|
| 122 | -+ | ||
| 629 | +! |
- #' vars = vars1,+ ggtheme = input$ggtheme |
|
| 123 | +630 |
- #' multiple = TRUE+ ) |
|
| 124 | +631 |
- #' )+ |
|
| 125 | -+ | ||
| 632 | +! |
- #' ),+ teal.code::eval_code( |
|
| 126 | -+ | ||
| 633 | +! |
- #' group_var = data_extract_spec(+ fit_r(), |
|
| 127 | -+ | ||
| 634 | +! |
- #' dataname = "ADSL",+ substitute( |
|
| 128 | -+ | ||
| 635 | +! |
- #' filter = filter_spec(+ expr = {
|
|
| 129 | -+ | ||
| 636 | +! |
- #' vars = vars1,+ class(fit$residuals) <- NULL |
|
| 130 | -+ | ||
| 637 | +! |
- #' multiple = TRUE+ data <- fortify(fit) |
|
| 131 | -+ | ||
| 638 | +! |
- #' )+ plot <- graph |
|
| 132 | +639 |
- #' )+ }, |
|
| 133 | -+ | ||
| 640 | +! |
- #' )+ env = list( |
|
| 134 | -+ | ||
| 641 | +! |
- #' )+ graph = Reduce(function(x, y) call("+", x, y), c(plot, parsed_ggplot2_args))
|
|
| 135 | +642 |
- #' )+ ) |
|
| 136 | +643 |
- #' if (interactive()) {
+ ) |
|
| 137 | +644 |
- #' shinyApp(app$ui, app$server)+ ) |
|
| 138 | +645 |
- #' }+ }) |
|
| 139 | +646 |
- #'+ |
|
| 140 | -+ | ||
| 647 | +! |
- #' @export+ output_plot_1 <- reactive({
|
|
| 141 | -+ | ||
| 648 | +! |
- #'+ plot_base <- output_plot_base() |
|
| 142 | -+ | ||
| 649 | +! |
- tm_g_distribution <- function(label = "Distribution Module",+ shinyjs::show("size")
|
|
| 143 | -+ | ||
| 650 | +! |
- dist_var,+ shinyjs::show("alpha")
|
|
| 144 | -+ | ||
| 651 | +! |
- strata_var = NULL,+ plot <- substitute( |
|
| 145 | -+ | ||
| 652 | +! |
- group_var = NULL,+ expr = ggplot(data = data, aes(.fitted, .resid)) + |
|
| 146 | -+ | ||
| 653 | +! |
- freq = FALSE,+ geom_point(size = size, alpha = alpha) + |
|
| 147 | -+ | ||
| 654 | +! |
- ggtheme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void"),
+ geom_hline(yintercept = 0, linetype = "dashed", size = 1) + |
|
| 148 | -+ | ||
| 655 | +! |
- ggplot2_args = teal.widgets::ggplot2_args(),+ geom_line(data = smoothy, mapping = smoothy_aes), |
|
| 149 | -+ | ||
| 656 | +! |
- bins = c(30L, 1L, 100L),+ env = list(size = input$size, alpha = input$alpha) |
|
| 150 | +657 |
- plot_height = c(600, 200, 2000),+ ) |
|
| 151 | -+ | ||
| 658 | +! |
- plot_width = NULL,+ if (input$show_outlier) {
|
|
| 152 | -+ | ||
| 659 | +! |
- pre_output = NULL,+ plot <- substitute(expr = plot + outlier_label, env = list(plot = plot, outlier_label = outlier_label())) |
|
| 153 | +660 |
- post_output = NULL,+ } |
|
| 154 | +661 |
- decorators = NULL) {
+
|
|
| 155 | +662 | ! |
- message("Initializing tm_g_distribution")
+ parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args( |
| 156 | -+ | ||
| 663 | +! |
-
+ teal.widgets::resolve_ggplot2_args( |
|
| 157 | -+ | ||
| 664 | +! |
- # Requires Suggested packages+ user_plot = ggplot2_args[["Residuals vs Fitted"]], |
|
| 158 | +665 | ! |
- extra_packages <- c("ggpmisc", "ggpp", "goftest", "MASS", "broom")
+ user_default = ggplot2_args$default, |
| 159 | +666 | ! |
- missing_packages <- Filter(function(x) !requireNamespace(x, quietly = TRUE), extra_packages)+ module_plot = teal.widgets::ggplot2_args( |
| 160 | +667 | ! |
- if (length(missing_packages) > 0L) {
+ labs = list( |
| 161 | +668 | ! |
- stop(sprintf(+ x = quote(paste0("Fitted values\nlm(", reg_form, ")")),
|
| 162 | +669 | ! |
- "Cannot load package(s): %s.\nInstall or restart your session.",+ y = "Residuals", |
| 163 | +670 | ! |
- toString(missing_packages)+ title = "Residuals vs Fitted" |
| 164 | +671 |
- ))+ ) |
|
| 165 | +672 |
- }+ ) |
|
| 166 | +673 |
-
+ ),+ |
+ |
| 674 | +! | +
+ ggtheme = input$ggtheme |
|
| 167 | +675 |
- # Normalize the parameters+ ) |
|
| 168 | -! | +||
| 676 | +
- if (inherits(dist_var, "data_extract_spec")) dist_var <- list(dist_var)+ |
||
| 169 | +677 | ! |
- if (inherits(strata_var, "data_extract_spec")) strata_var <- list(strata_var)+ teal.code::eval_code( |
| 170 | +678 | ! |
- if (inherits(group_var, "data_extract_spec")) group_var <- list(group_var)+ plot_base, |
| 171 | +679 | ! |
- if (inherits(ggplot2_args, "ggplot2_args")) ggplot2_args <- list(default = ggplot2_args)+ substitute( |
| 172 | -+ | ||
| 680 | +! |
-
+ expr = {
|
|
| 173 | -+ | ||
| 681 | +! |
- # Start of assertions+ smoothy <- smooth(data$.fitted, data$.resid) |
|
| 174 | +682 | ! |
- checkmate::assert_string(label)+ plot <- graph |
| 175 | +683 |
-
+ }, |
|
| 176 | +684 | ! |
- checkmate::assert_list(dist_var, "data_extract_spec")+ env = list( |
| 177 | +685 | ! |
- checkmate::assert_false(dist_var[[1L]]$select$multiple)+ graph = Reduce(function(x, y) call("+", x, y), c(plot, parsed_ggplot2_args))
|
| 178 | +686 | - - | -|
| 179 | -! | -
- checkmate::assert_list(strata_var, types = "data_extract_spec", null.ok = TRUE)+ ) |
|
| 180 | -! | +||
| 687 | +
- checkmate::assert_list(group_var, types = "data_extract_spec", null.ok = TRUE)+ ) |
||
| 181 | -! | +||
| 688 | +
- checkmate::assert_flag(freq)+ ) |
||
| 182 | -! | +||
| 689 | +
- ggtheme <- match.arg(ggtheme)+ }) |
||
| 183 | +690 | ||
| 184 | +691 | ! |
- plot_choices <- c("Histogram", "QQplot")
+ output_plot_2 <- reactive({
|
| 185 | +692 | ! |
- checkmate::assert_list(ggplot2_args, types = "ggplot2_args")+ shinyjs::show("size")
|
| 186 | +693 | ! |
- checkmate::assert_subset(names(ggplot2_args), c("default", plot_choices))
+ shinyjs::show("alpha")
|
| 187 | -- | - + | |
| 694 | +! | +
+ plot_base <- output_plot_base() |
|
| 188 | +695 | ! |
- if (length(bins) == 1) {
+ plot <- substitute( |
| 189 | +696 | ! |
- checkmate::assert_numeric(bins, any.missing = FALSE, lower = 1)+ expr = ggplot(data = data, aes(sample = .stdresid)) + |
| 190 | -+ | ||
| 697 | +! |
- } else {
+ stat_qq(size = size, alpha = alpha) + |
|
| 191 | +698 | ! |
- checkmate::assert_numeric(bins, len = 3, any.missing = FALSE, lower = 1)+ geom_abline(linetype = "dashed"), |
| 192 | +699 | ! |
- checkmate::assert_numeric(bins[1], lower = bins[2], upper = bins[3], .var.name = "bins")+ env = list(size = input$size, alpha = input$alpha) |
| 193 | +700 |
- }+ ) |
|
| 194 | -+ | ||
| 701 | +! |
-
+ if (input$show_outlier) {
|
|
| 195 | +702 | ! |
- checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE)+ plot <- substitute( |
| 196 | +703 | ! |
- checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height")+ expr = plot + |
| 197 | +704 | ! |
- checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE)+ stat_qq( |
| 198 | +705 | ! |
- checkmate::assert_numeric(+ geom = ggrepel::GeomTextRepel, |
| 199 | +706 | ! |
- plot_width[1],+ label = label_col %>% |
| 200 | +707 | ! |
- lower = plot_width[2], upper = plot_width[3], null.ok = TRUE, .var.name = "plot_width"+ data.frame(label = .) %>% |
| 201 | -+ | ||
| 708 | +! |
- )+ dplyr::filter(label != "cooksd == NaN") %>% |
|
| 202 | -+ | ||
| 709 | +! |
-
+ unlist(), |
|
| 203 | +710 | ! |
- checkmate::assert_multi_class(pre_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
+ color = "red", |
| 204 | +711 | ! |
- checkmate::assert_multi_class(post_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
+ hjust = 0, |
| 205 | -+ | ||
| 712 | +! |
-
+ vjust = 0, |
|
| 206 | +713 | ! |
- available_decorators <- c("histogram_plot", "qq_plot", "test_table", "summary_table")
+ max.overlaps = Inf, |
| 207 | +714 | ! |
- decorators <- normalize_decorators(decorators)+ min.segment.length = label_min_segment, |
| 208 | +715 | ! |
- assert_decorators(decorators, null.ok = TRUE, names = available_decorators)+ segment.alpha = .5, |
| 209 | -+ | ||
| 716 | +! |
-
+ seed = 123 |
|
| 210 | +717 |
- # End of assertions+ ), |
|
| 211 | -+ | ||
| 718 | +! |
-
+ env = list(plot = plot, label_col = label_col(), label_min_segment = label_min_segment()) |
|
| 212 | +719 |
- # Make UI args+ ) |
|
| 213 | -! | +||
| 720 | +
- args <- as.list(environment())+ } |
||
| 214 | +721 | ||
| 215 | -! | -
- data_extract_list <- list(- |
- |
| 216 | +722 | ! |
- dist_var = dist_var,+ parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args( |
| 217 | +723 | ! |
- strata_var = strata_var,+ teal.widgets::resolve_ggplot2_args( |
| 218 | +724 | ! |
- group_var = group_var- |
-
| 219 | -- |
- )- |
- |
| 220 | -- |
-
+ user_plot = ggplot2_args[["Normal Q-Q"]], |
|
| 221 | +725 | ! |
- ans <- module(+ user_default = ggplot2_args$default, |
| 222 | +726 | ! |
- label = label,+ module_plot = teal.widgets::ggplot2_args( |
| 223 | +727 | ! |
- server = srv_distribution,+ labs = list( |
| 224 | +728 | ! |
- server_args = c(+ x = quote(paste0("Theoretical Quantiles\nlm(", reg_form, ")")),
|
| 225 | +729 | ! |
- data_extract_list,+ y = "Standardized residuals", |
| 226 | +730 | ! |
- list(+ title = "Normal Q-Q" |
| 227 | -! | +||
| 731 | +
- plot_height = plot_height,+ ) |
||
| 228 | -! | +||
| 732 | +
- plot_width = plot_width,+ ) |
||
| 229 | -! | +||
| 733 | +
- ggplot2_args = ggplot2_args,+ ), |
||
| 230 | +734 | ! |
- decorators = decorators+ ggtheme = input$ggtheme |
| 231 | +735 |
) |
|
| 232 | +736 |
- ),+ |
|
| 233 | +737 | ! |
- ui = ui_distribution,+ teal.code::eval_code( |
| 234 | +738 | ! |
- ui_args = args,+ plot_base, |
| 235 | +739 | ! |
- datanames = teal.transform::get_extract_datanames(data_extract_list)- |
-
| 236 | -- |
- )+ substitute( |
|
| 237 | +740 | ! |
- attr(ans, "teal_bookmarkable") <- TRUE+ expr = {
|
| 238 | +741 | ! |
- ans+ plot <- graph |
| 239 | +742 |
- }+ }, |
|
| 240 | -+ | ||
| 743 | +! |
-
+ env = list( |
|
| 241 | -+ | ||
| 744 | +! |
- # UI function for the distribution module+ graph = Reduce(function(x, y) call("+", x, y), c(plot, parsed_ggplot2_args))
|
|
| 242 | +745 |
- ui_distribution <- function(id, ...) {
+ ) |
|
| 243 | -! | +||
| 746 | +
- args <- list(...)+ ) |
||
| 244 | -! | +||
| 747 | +
- ns <- NS(id)+ ) |
||
| 245 | -! | +||
| 748 | +
- is_single_dataset_value <- teal.transform::is_single_dataset(args$dist_var, args$strata_var, args$group_var)+ }) |
||
| 246 | +749 | ||
| 247 | -! | -
- teal.widgets::standard_layout(- |
- |
| 248 | +750 | ! |
- output = teal.widgets::white_small_well(+ output_plot_3 <- reactive({
|
| 249 | +751 | ! |
- tabsetPanel(+ shinyjs::show("size")
|
| 250 | +752 | ! |
- id = ns("tabs"),
+ shinyjs::show("alpha")
|
| 251 | +753 | ! |
- tabPanel("Histogram", teal.widgets::plot_with_settings_ui(id = ns("hist_plot"))),
+ plot_base <- output_plot_base() |
| 252 | +754 | ! |
- tabPanel("QQplot", teal.widgets::plot_with_settings_ui(id = ns("qq_plot")))
- |
-
| 253 | -- |
- ),+ plot <- substitute( |
|
| 254 | +755 | ! |
- tags$h3("Statistics Table"),
+ expr = ggplot(data = data, aes(.fitted, sqrt(abs(.stdresid)))) + |
| 255 | +756 | ! |
- DT::dataTableOutput(ns("summary_table")),
+ geom_point(size = size, alpha = alpha) + |
| 256 | +757 | ! |
- tags$h3("Tests"),
+ geom_line(data = smoothy, mapping = smoothy_aes), |
| 257 | +758 | ! |
- DT::dataTableOutput(ns("t_stats"))
+ env = list(size = input$size, alpha = input$alpha) |
| 258 | +759 |
- ),+ ) |
|
| 259 | +760 | ! |
- encoding = tags$div(- |
-
| 260 | -- |
- ### Reporter+ if (input$show_outlier) {
|
|
| 261 | +761 | ! |
- teal.reporter::simple_reporter_ui(ns("simple_reporter")),
+ plot <- substitute(expr = plot + outlier_label, env = list(plot = plot, outlier_label = outlier_label())) |
| 262 | +762 |
- ###- |
- |
| 263 | -! | -
- tags$label("Encodings", class = "text-primary"),
- |
- |
| 264 | -! | -
- teal.transform::datanames_input(args[c("dist_var", "strata_var")]),
+ } |
|
| 265 | -! | +||
| 763 | +
- teal.transform::data_extract_ui(+ |
||
| 266 | +764 | ! |
- id = ns("dist_i"),
+ parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args( |
| 267 | +765 | ! |
- label = "Variable",+ teal.widgets::resolve_ggplot2_args( |
| 268 | +766 | ! |
- data_extract_spec = args$dist_var,+ user_plot = ggplot2_args[["Scale-Location"]], |
| 269 | +767 | ! |
- is_single_dataset = is_single_dataset_value- |
-
| 270 | -- |
- ),+ user_default = ggplot2_args$default, |
|
| 271 | +768 | ! |
- if (!is.null(args$group_var)) {
+ module_plot = teal.widgets::ggplot2_args( |
| 272 | +769 | ! |
- tagList(+ labs = list( |
| 273 | +770 | ! |
- teal.transform::data_extract_ui(+ x = quote(paste0("Fitted values\nlm(", reg_form, ")")),
|
| 274 | +771 | ! |
- id = ns("group_i"),
+ y = quote(expression(sqrt(abs(`Standardized residuals`)))), |
| 275 | +772 | ! |
- label = "Group by",+ title = "Scale-Location" |
| 276 | -! | +||
| 773 | +
- data_extract_spec = args$group_var,+ ) |
||
| 277 | -! | +||
| 774 | +
- is_single_dataset = is_single_dataset_value+ ) |
||
| 278 | +775 |
- ),+ ), |
|
| 279 | +776 | ! |
- uiOutput(ns("scales_types_ui"))
+ ggtheme = input$ggtheme |
| 280 | +777 |
- )+ ) |
|
| 281 | +778 |
- },+ |
|
| 282 | +779 | ! |
- if (!is.null(args$strata_var)) {
+ teal.code::eval_code( |
| 283 | +780 | ! |
- teal.transform::data_extract_ui(+ plot_base, |
| 284 | +781 | ! |
- id = ns("strata_i"),
+ substitute( |
| 285 | +782 | ! |
- label = "Stratify by",+ expr = {
|
| 286 | +783 | ! |
- data_extract_spec = args$strata_var,+ smoothy <- smooth(data$.fitted, sqrt(abs(data$.stdresid))) |
| 287 | +784 | ! |
- is_single_dataset = is_single_dataset_value+ plot <- graph |
| 288 | +785 |
- )+ }, |
|
| 289 | -+ | ||
| 786 | +! |
- },+ env = list( |
|
| 290 | +787 | ! |
- teal.widgets::panel_group(+ graph = Reduce(function(x, y) call("+", x, y), c(plot, parsed_ggplot2_args))
|
| 291 | -! | +||
| 788 | +
- conditionalPanel(+ ) |
||
| 292 | -! | +||
| 789 | +
- condition = paste0("input['", ns("tabs"), "'] == 'Histogram'"),
+ ) |
||
| 293 | -! | +||
| 790 | +
- teal.widgets::panel_item(+ ) |
||
| 294 | -! | +||
| 791 | +
- "Histogram",+ })+ |
+ ||
| 792 | ++ | + | |
| 295 | +793 | ! |
- teal.widgets::optionalSliderInputValMinMax(ns("bins"), "Bins", args$bins, ticks = FALSE, step = 1),
+ output_plot_4 <- reactive({
|
| 296 | +794 | ! |
- shinyWidgets::prettyRadioButtons(+ shinyjs::hide("size")
|
| 297 | +795 | ! |
- ns("main_type"),
+ shinyjs::show("alpha")
|
| 298 | +796 | ! |
- label = "Plot Type:",+ plot_base <- output_plot_base() |
| 299 | +797 | ! |
- choices = c("Density", "Frequency"),
+ plot <- substitute( |
| 300 | +798 | ! |
- selected = if (!args$freq) "Density" else "Frequency",+ expr = ggplot(data = data, aes(seq_along(.cooksd), .cooksd)) + |
| 301 | +799 | ! |
- bigger = FALSE,+ geom_col(alpha = alpha), |
| 302 | +800 | ! |
- inline = TRUE+ env = list(alpha = input$alpha) |
| 303 | +801 |
- ),+ ) |
|
| 304 | +802 | ! |
- checkboxInput(ns("add_dens"), label = "Overlay Density", value = TRUE),
+ if (input$show_outlier) {
|
| 305 | +803 | ! |
- ui_decorate_teal_data(+ plot <- substitute( |
| 306 | +804 | ! |
- ns("d_density"),
+ expr = plot + |
| 307 | +805 | ! |
- decorators = select_decorators(args$decorators, "histogram_plot")+ geom_hline( |
| 308 | -+ | ||
| 806 | +! |
- ),+ yintercept = c( |
|
| 309 | +807 | ! |
- collapsed = FALSE+ outlier * mean(data$.cooksd, na.rm = TRUE), |
| 310 | -+ | ||
| 808 | +! |
- )+ mean(data$.cooksd, na.rm = TRUE) |
|
| 311 | +809 |
- ),+ ), |
|
| 312 | +810 | ! |
- conditionalPanel(+ color = "red", |
| 313 | +811 | ! |
- condition = paste0("input['", ns("tabs"), "'] == 'QQplot'"),
+ linetype = "dashed"+ |
+
| 812 | ++ |
+ ) + |
|
| 314 | +813 | ! |
- teal.widgets::panel_item(+ geom_text( |
| 315 | +814 | ! |
- "QQ Plot",+ aes( |
| 316 | +815 | ! |
- checkboxInput(ns("qq_line"), label = "Add diagonal line(s)", TRUE),
+ x = 0, |
| 317 | +816 | ! |
- ui_decorate_teal_data(+ y = mean(data$.cooksd, na.rm = TRUE), |
| 318 | +817 | ! |
- ns("d_qq"),
+ label = paste("mu", "=", round(mean(data$.cooksd, na.rm = TRUE), 4)),
|
| 319 | +818 | ! |
- decorators = select_decorators(args$decorators, "qq_plot")+ vjust = -1, |
| 320 | -+ | ||
| 819 | +! |
- ),+ hjust = 0, |
|
| 321 | +820 | ! |
- collapsed = FALSE+ color = "red", |
| 322 | -+ | ||
| 821 | +! |
- )+ angle = 90 |
|
| 323 | +822 |
- ),- |
- |
| 324 | -! | -
- ui_decorate_teal_data(+ ), |
|
| 325 | +823 | ! |
- ns("d_summary"),
+ parse = TRUE, |
| 326 | +824 | ! |
- decorators = select_decorators(args$decorators, "summary_table")+ show.legend = FALSE |
| 327 | +825 |
- ),+ ) + |
|
| 328 | +826 | ! |
- ui_decorate_teal_data(+ outlier_label, |
| 329 | +827 | ! |
- ns("d_test"),
+ env = list(plot = plot, outlier = input$outlier, outlier_label = outlier_label()) |
| 330 | -! | +||
| 828 | +
- decorators = select_decorators(args$decorators, "test_table")+ ) |
||
| 331 | +829 |
- ),+ } |
|
| 332 | -! | +||
| 830 | +
- conditionalPanel(+ |
||
| 333 | +831 | ! |
- condition = paste0("input['", ns("main_type"), "'] == 'Density'"),
+ parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args( |
| 334 | +832 | ! |
- teal.widgets::panel_item(+ teal.widgets::resolve_ggplot2_args( |
| 335 | +833 | ! |
- "Theoretical Distribution",+ user_plot = ggplot2_args[["Cook's distance"]], |
| 336 | +834 | ! |
- teal.widgets::optionalSelectInput(+ user_default = ggplot2_args$default, |
| 337 | +835 | ! |
- ns("t_dist"),
+ module_plot = teal.widgets::ggplot2_args( |
| 338 | +836 | ! |
- tags$div(+ labs = list( |
| 339 | +837 | ! |
- class = "teal-tooltip",+ x = quote(paste0("Obs. number\nlm(", reg_form, ")")),
|
| 340 | +838 | ! |
- tagList(+ y = "Cook's distance", |
| 341 | +839 | ! |
- "Distribution:",+ title = "Cook's distance" |
| 342 | -! | +||
| 840 | +
- icon("circle-info"),
+ ) |
||
| 343 | -! | +||
| 841 | +
- tags$span(+ ) |
||
| 344 | -! | +||
| 842 | +
- class = "tooltiptext",+ ), |
||
| 345 | +843 | ! |
- "Default parameters are optimized with MASS::fitdistr function."- |
-
| 346 | -- |
- )+ ggtheme = input$ggtheme |
|
| 347 | +844 |
- )+ ) |
|
| 348 | +845 |
- ),+ |
|
| 349 | +846 | ! |
- choices = c("normal", "lognormal", "gamma", "unif"),
+ teal.code::eval_code( |
| 350 | +847 | ! |
- selected = NULL,+ plot_base, |
| 351 | +848 | ! |
- multiple = FALSE+ substitute( |
| 352 | -+ | ||
| 849 | +! |
- ),+ expr = {
|
|
| 353 | +850 | ! |
- numericInput(ns("dist_param1"), label = "param1", value = NULL),
+ plot <- graph |
| 354 | -! | +||
| 851 | +
- numericInput(ns("dist_param2"), label = "param2", value = NULL),
+ }, |
||
| 355 | +852 | ! |
- tags$span(actionButton(ns("params_reset"), "Default params")),
+ env = list( |
| 356 | +853 | ! |
- collapsed = FALSE+ graph = Reduce(function(x, y) call("+", x, y), c(plot, parsed_ggplot2_args))
|
| 357 | +854 |
) |
|
| 358 | +855 |
) |
|
| 359 | +856 |
- ),+ ) |
|
| 360 | -! | +||
| 857 | +
- teal.widgets::panel_item(+ }) |
||
| 361 | -! | +||
| 858 | +
- "Tests",+ |
||
| 362 | +859 | ! |
- teal.widgets::optionalSelectInput(+ output_plot_5 <- reactive({
|
| 363 | +860 | ! |
- ns("dist_tests"),
+ shinyjs::show("size")
|
| 364 | +861 | ! |
- "Tests:",+ shinyjs::show("alpha")
|
| 365 | +862 | ! |
- choices = c(+ plot_base <- output_plot_base() |
| 366 | +863 | ! |
- "Shapiro-Wilk",+ plot <- substitute( |
| 367 | +864 | ! |
- if (!is.null(args$strata_var)) "t-test (two-samples, not paired)",+ expr = ggplot(data = data, aes(.hat, .stdresid)) + |
| 368 | +865 | ! |
- if (!is.null(args$strata_var)) "one-way ANOVA",+ geom_vline( |
| 369 | +866 | ! |
- if (!is.null(args$strata_var)) "Fligner-Killeen",+ size = 1, |
| 370 | +867 | ! |
- if (!is.null(args$strata_var)) "F-test",+ colour = "black", |
| 371 | +868 | ! |
- "Kolmogorov-Smirnov (one-sample)",+ linetype = "dashed", |
| 372 | +869 | ! |
- "Anderson-Darling (one-sample)",+ xintercept = 0+ |
+
| 870 | ++ |
+ ) + |
|
| 373 | +871 | ! |
- "Cramer-von Mises (one-sample)",+ geom_hline( |
| 374 | +872 | ! |
- if (!is.null(args$strata_var)) "Kolmogorov-Smirnov (two-samples)"+ size = 1, |
| 375 | -+ | ||
| 873 | +! |
- ),+ colour = "black", |
|
| 376 | +874 | ! |
- selected = NULL+ linetype = "dashed", |
| 377 | -+ | ||
| 875 | +! |
- )+ yintercept = 0 |
|
| 378 | +876 |
- ),+ ) + |
|
| 379 | +877 | ! |
- teal.widgets::panel_item(+ geom_point(size = size, alpha = alpha) + |
| 380 | +878 | ! |
- "Statistics Table",+ geom_line(data = smoothy, mapping = smoothy_aes), |
| 381 | +879 | ! |
- sliderInput(ns("roundn"), "Round to n digits", min = 0, max = 10, value = 2)
+ env = list(size = input$size, alpha = input$alpha) |
| 382 | +880 |
- ),+ ) |
|
| 383 | +881 | ! |
- teal.widgets::panel_item(+ if (input$show_outlier) {
|
| 384 | +882 | ! |
- title = "Plot settings",+ plot <- substitute(expr = plot + outlier_label, env = list(plot = plot, outlier_label = outlier_label())) |
| 385 | -! | +||
| 883 | +
- selectInput(+ } |
||
| 386 | -! | +||
| 884 | +
- inputId = ns("ggtheme"),
+
|
||
| 387 | +885 | ! |
- label = "Theme (by ggplot):",+ parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args( |
| 388 | +886 | ! |
- choices = ggplot_themes,+ teal.widgets::resolve_ggplot2_args( |
| 389 | +887 | ! |
- selected = args$ggtheme,+ user_plot = ggplot2_args[["Residuals vs Leverage"]], |
| 390 | +888 | ! |
- multiple = FALSE+ user_default = ggplot2_args$default, |
| 391 | -+ | ||
| 889 | +! |
- )+ module_plot = teal.widgets::ggplot2_args( |
|
| 392 | -+ | ||
| 890 | +! |
- )+ labs = list( |
|
| 393 | -+ | ||
| 891 | +! |
- ),+ x = quote(paste0("Standardized residuals\nlm(", reg_form, ")")),
|
|
| 394 | +892 | ! |
- forms = tagList(+ y = "Leverage", |
| 395 | +893 | ! |
- teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code")
+ title = "Residuals vs Leverage" |
| 396 | +894 |
- ),+ ) |
|
| 397 | -! | +||
| 895 | +
- pre_output = args$pre_output,+ )+ |
+ ||
| 896 | ++ |
+ ), |
|
| 398 | +897 | ! |
- post_output = args$post_output+ ggtheme = input$ggtheme |
| 399 | +898 |
- )+ ) |
|
| 400 | +899 |
- }+ |
|
| 401 | -+ | ||
| 900 | +! |
-
+ teal.code::eval_code( |
|
| 402 | -+ | ||
| 901 | +! |
- # Server function for the distribution module+ plot_base, |
|
| 403 | -+ | ||
| 902 | +! |
- srv_distribution <- function(id,+ substitute( |
|
| 404 | -+ | ||
| 903 | +! |
- data,+ expr = {
|
|
| 405 | -+ | ||
| 904 | +! |
- reporter,+ smoothy <- smooth(data$.hat, data$.stdresid) |
|
| 406 | -+ | ||
| 905 | +! |
- filter_panel_api,+ plot <- graph |
|
| 407 | +906 |
- dist_var,+ }, |
|
| 408 | -+ | ||
| 907 | +! |
- strata_var,+ env = list(+ |
+ |
| 908 | +! | +
+ graph = Reduce(function(x, y) call("+", x, y), c(plot, parsed_ggplot2_args))
|
|
| 409 | +909 |
- group_var,+ ) |
|
| 410 | +910 |
- plot_height,+ ) |
|
| 411 | +911 |
- plot_width,+ ) |
|
| 412 | +912 |
- ggplot2_args,+ }) |
|
| 413 | +913 |
- decorators) {
+
|
|
| 414 | +914 | ! |
- with_reporter <- !missing(reporter) && inherits(reporter, "Reporter")+ output_plot_6 <- reactive({
|
| 415 | +915 | ! |
- with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI")+ shinyjs::show("size")
|
| 416 | +916 | ! |
- checkmate::assert_class(data, "reactive")+ shinyjs::show("alpha")
|
| 417 | +917 | ! |
- checkmate::assert_class(isolate(data()), "teal_data")+ plot_base <- output_plot_base() |
| 418 | +918 | ! |
- moduleServer(id, function(input, output, session) {
+ plot <- substitute( |
| 419 | +919 | ! |
- teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.general")- |
-
| 420 | -- |
-
+ expr = ggplot(data = data, aes(.hat, .cooksd)) + |
|
| 421 | +920 | ! |
- setBookmarkExclude("params_reset")
- |
-
| 422 | -- |
-
+ geom_vline(xintercept = 0, colour = NA) + |
|
| 423 | +921 | ! |
- ns <- session$ns+ geom_abline( |
| 424 | -+ | ||
| 922 | +! |
-
+ slope = seq(0, 3, by = 0.5), |
|
| 425 | +923 | ! |
- rule_req <- function(value) {
+ colour = "black", |
| 426 | +924 | ! |
- if (isTRUE(input$dist_tests %in% c(+ linetype = "dashed", |
| 427 | +925 | ! |
- "Fligner-Killeen",+ size = 1 |
| 428 | -! | +||
| 926 | +
- "t-test (two-samples, not paired)",+ ) + |
||
| 429 | +927 | ! |
- "F-test",+ geom_line(data = smoothy, mapping = smoothy_aes) + |
| 430 | +928 | ! |
- "Kolmogorov-Smirnov (two-samples)",+ geom_point(size = size, alpha = alpha), |
| 431 | +929 | ! |
- "one-way ANOVA"+ env = list(size = input$size, alpha = input$alpha) |
| 432 | +930 |
- ))) {
+ ) |
|
| 433 | +931 | ! |
- if (!shinyvalidate::input_provided(value)) {
+ if (input$show_outlier) {
|
| 434 | +932 | ! |
- "Please select stratify variable."+ plot <- substitute(expr = plot + outlier_label, env = list(plot = plot, outlier_label = outlier_label())) |
| 435 | +933 |
- }+ } |
|
| 436 | +934 |
- }+ |
|
| 437 | -+ | ||
| 935 | +! |
- }+ parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args( |
|
| 438 | +936 | ! |
- rule_dupl <- function(...) {
+ teal.widgets::resolve_ggplot2_args( |
| 439 | +937 | ! |
- if (identical(input$dist_tests, "Fligner-Killeen")) {
+ user_plot = ggplot2_args[["Cook's dist vs Leverage"]], |
| 440 | +938 | ! |
- strata <- selector_list()$strata_i()$select+ user_default = ggplot2_args$default, |
| 441 | +939 | ! |
- group <- selector_list()$group_i()$select+ module_plot = teal.widgets::ggplot2_args( |
| 442 | +940 | ! |
- if (isTRUE(strata == group)) {
+ labs = list( |
| 443 | +941 | ! |
- "Please select different variables for strata and group."+ x = quote(paste0("Leverage\nlm(", reg_form, ")")),
|
| 444 | -+ | ||
| 942 | +! |
- }+ y = "Cooks's distance",+ |
+ |
| 943 | +! | +
+ title = "Cook's dist vs Leverage" |
|
| 445 | +944 |
- }+ ) |
|
| 446 | +945 |
- }+ ) |
|
| 447 | +946 |
-
+ ), |
|
| 448 | +947 | ! |
- selector_list <- teal.transform::data_extract_multiple_srv(+ ggtheme = input$ggtheme |
| 449 | -! | +||
| 948 | +
- data_extract = list(+ ) |
||
| 450 | -! | +||
| 949 | +
- dist_i = dist_var,+ |
||
| 451 | +950 | ! |
- strata_i = strata_var,+ teal.code::eval_code( |
| 452 | +951 | ! |
- group_i = group_var- |
-
| 453 | -- |
- ),+ plot_base, |
|
| 454 | +952 | ! |
- data,+ substitute( |
| 455 | +953 | ! |
- select_validation_rule = list(+ expr = {
|
| 456 | +954 | ! |
- dist_i = shinyvalidate::sv_required("Please select a variable")
- |
-
| 457 | -- |
- ),+ smoothy <- smooth(data$.hat, data$.cooksd) |
|
| 458 | +955 | ! |
- filter_validation_rule = list(+ plot <- graph |
| 459 | -! | +||
| 956 | +
- strata_i = shinyvalidate::compose_rules(+ }, |
||
| 460 | +957 | ! |
- rule_req,+ env = list( |
| 461 | +958 | ! |
- rule_dupl+ graph = Reduce(function(x, y) call("+", x, y), c(plot, parsed_ggplot2_args))
|
| 462 | +959 |
- ),+ ) |
|
| 463 | -! | +||
| 960 | +
- group_i = rule_dupl+ ) |
||
| 464 | +961 |
) |
|
| 465 | +962 |
- )+ }) |
|
| 466 | +963 | ||
| 467 | +964 | ! |
- iv_r <- reactive({
+ output_q <- reactive({
|
| 468 | +965 | ! |
- iv <- shinyvalidate::InputValidator$new()+ teal::validate_inputs(iv_r()) |
| 469 | +966 | ! |
- teal.transform::compose_and_enable_validators(iv, selector_list, validator_names = "dist_i")+ switch(input$plot_type, |
| 470 | -+ | ||
| 967 | +! |
- })+ "Response vs Regressor" = output_plot_0(), |
|
| 471 | -+ | ||
| 968 | +! |
-
+ "Residuals vs Fitted" = output_plot_1(), |
|
| 472 | +969 | ! |
- iv_r_dist <- reactive({
+ "Normal Q-Q" = output_plot_2(), |
| 473 | +970 | ! |
- iv <- shinyvalidate::InputValidator$new()+ "Scale-Location" = output_plot_3(), |
| 474 | +971 | ! |
- teal.transform::compose_and_enable_validators(+ "Cook's distance" = output_plot_4(), |
| 475 | +972 | ! |
- iv, selector_list,+ "Residuals vs Leverage" = output_plot_5(), |
| 476 | +973 | ! |
- validator_names = c("strata_i", "group_i")
+ "Cook's dist vs Leverage" = output_plot_6() |
| 477 | +974 |
) |
|
| 478 | +975 |
}) |
|
| 479 | -! | +||
| 976 | +
- rule_dist_1 <- function(value) {
+
|
||
| 480 | +977 | ! |
- if (!is.null(input$t_dist)) {
+ decorated_output_q <- srv_decorate_teal_data( |
| 481 | +978 | ! |
- switch(input$t_dist,+ "decorator", |
| 482 | +979 | ! |
- "normal" = if (!shinyvalidate::input_provided(value)) "mean is required",+ data = output_q, |
| 483 | +980 | ! |
- "lognormal" = if (!shinyvalidate::input_provided(value)) "meanlog is required",+ decorators = select_decorators(decorators, "plot"), |
| 484 | +981 | ! |
- "gamma" = {
+ expr = print(plot) |
| 485 | -! | +||
| 982 | +
- if (!shinyvalidate::input_provided(value)) "shape is required" else if (value <= 0) "shape must be positive"+ ) |
||
| 486 | +983 |
- },+ |
|
| 487 | +984 | ! |
- "unif" = NULL+ fitted <- reactive({
|
| 488 | -+ | ||
| 985 | +! |
- )+ req(output_q()) |
|
| 489 | -+ | ||
| 986 | +! |
- }+ decorated_output_q()[["fit"]] |
|
| 490 | +987 |
- }+ }) |
|
| 491 | +988 | ! |
- rule_dist_2 <- function(value) {
+ plot_r <- reactive({
|
| 492 | +989 | ! |
- if (!is.null(input$t_dist)) {
+ req(output_q()) |
| 493 | +990 | ! |
- switch(input$t_dist,+ decorated_output_q()[["plot"]]+ |
+
| 991 | ++ |
+ })+ |
+ |
| 992 | ++ | + + | +|
| 993 | ++ |
+ # Insert the plot into a plot_with_settings module from teal.widgets |
|
| 494 | +994 | ! |
- "normal" = {
+ pws <- teal.widgets::plot_with_settings_srv( |
| 495 | +995 | ! |
- if (!shinyvalidate::input_provided(value)) {
+ id = "myplot", |
| 496 | +996 | ! |
- "sd is required"+ plot_r = plot_r, |
| 497 | +997 | ! |
- } else if (value < 0) {
+ height = plot_height, |
| 498 | +998 | ! |
- "sd must be non-negative"+ width = plot_width |
| 499 | +999 |
- }+ ) |
|
| 500 | +1000 |
- },+ |
|
| 501 | +1001 | ! |
- "lognormal" = {
+ output$text <- renderText({
|
| 502 | +1002 | ! |
- if (!shinyvalidate::input_provided(value)) {
+ req(iv_r()$is_valid()) |
| 503 | +1003 | ! |
- "sdlog is required"+ req(iv_out$is_valid()) |
| 504 | +1004 | ! |
- } else if (value < 0) {
+ paste(utils::capture.output(summary(teal.code::dev_suppress(fitted())))[-1], |
| 505 | +1005 | ! |
- "sdlog must be non-negative"+ collapse = "\n" |
| 506 | +1006 |
- }+ ) |
|
| 507 | +1007 |
- },- |
- |
| 508 | -! | -
- "gamma" = {
+ }) |
|
| 509 | -! | +||
| 1008 | +
- if (!shinyvalidate::input_provided(value)) {
+
|
||
| 510 | +1009 | ! |
- "rate is required"+ teal.widgets::verbatim_popup_srv( |
| 511 | +1010 | ! |
- } else if (value <= 0) {
+ id = "rcode", |
| 512 | +1011 | ! |
- "rate must be positive"- |
-
| 513 | -- |
- }- |
- |
| 514 | -- |
- },+ verbatim_content = reactive(teal.code::get_code(req(decorated_output_q()))), |
|
| 515 | +1012 | ! |
- "unif" = NULL+ title = "R code for the regression plot", |
| 516 | +1013 |
- )+ ) |
|
| 517 | +1014 |
- }+ |
|
| 518 | +1015 |
- }+ ### REPORTER |
|
| 519 | -+ | ||
| 1016 | +! |
-
+ if (with_reporter) {
|
|
| 520 | +1017 | ! |
- rule_dist <- function(value) {
+ card_fun <- function(comment, label) {
|
| 521 | +1018 | ! |
- if (isTRUE(input$tabs == "QQplot") ||+ card <- teal::report_card_template( |
| 522 | +1019 | ! |
- isTRUE(input$dist_tests %in% c(+ title = "Linear Regression Plot", |
| 523 | +1020 | ! |
- "Kolmogorov-Smirnov (one-sample)",+ label = label, |
| 524 | +1021 | ! |
- "Anderson-Darling (one-sample)",+ with_filter = with_filter, |
| 525 | +1022 | ! |
- "Cramer-von Mises (one-sample)"+ filter_panel_api = filter_panel_api |
| 526 | +1023 |
- ))) {
+ ) |
|
| 527 | +1024 | ! |
- if (!shinyvalidate::input_provided(value)) {
+ card$append_text("Plot", "header3")
|
| 528 | +1025 | ! |
- "Please select the theoretical distribution."+ card$append_plot(plot_r(), dim = pws$dim()) |
| 529 | -+ | ||
| 1026 | +! |
- }+ if (!comment == "") {
|
|
| 530 | -+ | ||
| 1027 | +! |
- }+ card$append_text("Comment", "header3")
|
|
| 531 | -+ | ||
| 1028 | +! |
- }+ card$append_text(comment) |
|
| 532 | +1029 |
-
+ } |
|
| 533 | +1030 | ! |
- iv_dist <- shinyvalidate::InputValidator$new()+ card$append_src(teal.code::get_code(req(decorated_output_q()))) |
| 534 | +1031 | ! |
- iv_dist$add_rule("t_dist", rule_dist)
+ card |
| 535 | -! | +||
| 1032 | +
- iv_dist$add_rule("dist_param1", rule_dist_1)
+ } |
||
| 536 | +1033 | ! |
- iv_dist$add_rule("dist_param2", rule_dist_2)
+ teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
|
| 537 | -! | +||
| 1034 | +
- iv_dist$enable()+ } |
||
| 538 | +1035 |
-
+ ### |
|
| 539 | -! | +||
| 1036 | +
- anl_merged_input <- teal.transform::merge_expression_srv(+ }) |
||
| 540 | -! | +||
| 1037 | +
- selector_list = selector_list,+ } |
||
| 541 | -! | +
| 1 | +
- datasets = data+ #' `teal` module: Missing data analysis |
||
| 542 | +2 |
- )+ #' |
|
| 543 | +3 |
-
+ #' This module analyzes missing data in `data.frame`s to help users explore missing observations and |
|
| 544 | -! | +||
| 4 | +
- anl_merged_q <- reactive({
+ #' gain insights into the completeness of their data. |
||
| 545 | -! | +||
| 5 | +
- req(anl_merged_input())+ #' It is useful for clinical data analysis within the context of `CDISC` standards and |
||
| 546 | -! | +||
| 6 | +
- data() %>%+ #' adaptable for general data analysis purposes. |
||
| 547 | -! | +||
| 7 | +
- teal.code::eval_code(as.expression(anl_merged_input()$expr))+ #' |
||
| 548 | +8 |
- })+ #' @inheritParams teal::module |
|
| 549 | +9 |
-
+ #' @inheritParams shared_params |
|
| 550 | -! | +||
| 10 | +
- merged <- list(+ #' @param parent_dataname (`character(1)`) Specifies the parent dataset name. Default is `ADSL` for `CDISC` data. |
||
| 551 | -! | +||
| 11 | +
- anl_input_r = anl_merged_input,+ #' If provided and exists, enables additional analysis "by subject". For non-`CDISC` data, this parameter can be |
||
| 552 | -! | +||
| 12 | +
- anl_q_r = anl_merged_q+ #' ignored. |
||
| 553 | +13 |
- )+ # nolint start: line_length. |
|
| 554 | +14 |
-
+ #' @param ggtheme (`character`) optional, specifies the default `ggplot2` theme for plots. Defaults to `classic`. |
|
| 555 | -! | +||
| 15 | +
- output$scales_types_ui <- renderUI({
+ #' @param ggplot2_args `r roxygen_ggplot2_args_param("Summary Obs", "Summary Patients", "Combinations Main", "Combinations Hist", "By Subject")`
|
||
| 556 | -! | +||
| 16 | +
- if ("group_i" %in% names(selector_list()) && length(selector_list()$group_i()$filters[[1]]$selected) > 0) {
+ # nolint end: line_length. |
||
| 557 | -! | +||
| 17 | +
- shinyWidgets::prettyRadioButtons(+ #' @param decorators `r roxygen_decorators_param("tm_missing_data")`
|
||
| 558 | -! | +||
| 18 | +
- ns("scales_type"),
+ #' |
||
| 559 | -! | +||
| 19 | +
- label = "Scales:",+ #' @inherit shared_params return |
||
| 560 | -! | +||
| 20 | +
- choices = c("Fixed", "Free"),
+ #' |
||
| 561 | -! | +||
| 21 | +
- selected = "Fixed",+ #' @section Decorating `tm_missing_data`: |
||
| 562 | -! | +||
| 22 | +
- bigger = FALSE,+ #' |
||
| 563 | -! | +||
| 23 | +
- inline = TRUE+ #' This module generates the following objects, which can be modified in place using decorators: |
||
| 564 | +24 |
- )+ #' - `summary_plot` (`grob` created with [ggplot2::ggplotGrob()]) |
|
| 565 | +25 |
- }+ #' - `combination_plot` (`grob` created with [ggplot2::ggplotGrob()]) |
|
| 566 | +26 |
- })+ #' - `by_subject_plot` (`ggplot2`) |
|
| 567 | +27 |
-
+ #' - `table` ([DT::datatable()]) |
|
| 568 | -! | +||
| 28 | +
- observeEvent(+ #' |
||
| 569 | -! | +||
| 29 | +
- eventExpr = list(+ #' Decorators can be applied to all outputs or only to specific objects using a |
||
| 570 | -! | +||
| 30 | +
- input$t_dist,+ #' named list of `teal_transform_module` objects. |
||
| 571 | -! | +||
| 31 | +
- input$params_reset,+ #' The `"default"` name is reserved for decorators that are applied to all outputs. |
||
| 572 | -! | +||
| 32 | +
- selector_list()$dist_i()$select+ #' See code snippet below: |
||
| 573 | +33 |
- ),+ #' |
|
| 574 | -! | +||
| 34 | +
- handlerExpr = {
+ #' ``` |
||
| 575 | -! | +||
| 35 | +
- params <-+ #' tm_missing_data( |
||
| 576 | -! | +||
| 36 | +
- if (length(input$t_dist) != 0) {
+ #' ..., # arguments for module |
||
| 577 | -! | +||
| 37 | +
- get_dist_params <- function(x, dist) {
+ #' decorators = list( |
||
| 578 | -! | +||
| 38 | +
- if (dist == "unif") {
+ #' default = list(teal_transform_module(...)), # applied to all outputs |
||
| 579 | -! | +||
| 39 | +
- return(stats::setNames(range(x, na.rm = TRUE), c("min", "max")))
+ #' summary_plot = list(teal_transform_module(...)), # applied only to `summary_plot` output |
||
| 580 | +40 |
- }+ #' combination_plot = list(teal_transform_module(...)) # applied only to `combination_plot` output |
|
| 581 | -! | +||
| 41 | +
- tryCatch(+ #' by_subject_plot = list(teal_transform_module(...)) # applied only to `by_subject_plot` output |
||
| 582 | -! | +||
| 42 | +
- MASS::fitdistr(x, densfun = dist)$estimate,+ #' table = list(teal_transform_module(...)) # applied only to `table` output |
||
| 583 | -! | +||
| 43 | +
- error = function(e) c(param1 = NA_real_, param2 = NA_real_)+ #' ) |
||
| 584 | +44 |
- )+ #' ) |
|
| 585 | +45 |
- }+ #' ``` |
|
| 586 | +46 |
-
+ #' |
|
| 587 | -! | +||
| 47 | +
- ANL <- merged$anl_q_r()[["ANL"]]+ #' For additional details and examples of decorators, refer to the vignette |
||
| 588 | -! | +||
| 48 | +
- round(get_dist_params(as.numeric(stats::na.omit(ANL[[merge_vars()$dist_var]])), input$t_dist), 2)+ #' `vignette("decorate-modules-output", package = "teal")` or the [`teal::teal_transform_module()`] documentation.
|
||
| 589 | +49 |
- } else {
+ #' |
|
| 590 | -! | +||
| 50 | +
- c("param1" = NA_real_, "param2" = NA_real_)
+ #' @examplesShinylive |
||
| 591 | +51 |
- }+ #' library(teal.modules.general) |
|
| 592 | +52 |
-
+ #' interactive <- function() TRUE |
|
| 593 | -! | +||
| 53 | +
- params_vals <- unname(params)+ #' {{ next_example }}
|
||
| 594 | -! | +||
| 54 | +
- params_names <- names(params)+ #' @examplesIf require("gridExtra", quietly = TRUE) && require("rlang", quietly = TRUE)
|
||
| 595 | +55 |
-
+ #' # general example data |
|
| 596 | -! | +||
| 56 | +
- updateNumericInput(+ #' data <- teal_data() |
||
| 597 | -! | +||
| 57 | +
- inputId = "dist_param1",+ #' data <- within(data, {
|
||
| 598 | -! | +||
| 58 | +
- label = params_names[1],+ #' require(nestcolor) |
||
| 599 | -! | +||
| 59 | +
- value = restoreInput(ns("dist_param1"), params_vals[1])
+ #' |
||
| 600 | +60 |
- )+ #' add_nas <- function(x) {
|
|
| 601 | -! | +||
| 61 | +
- updateNumericInput(+ #' x[sample(seq_along(x), floor(length(x) * runif(1, .05, .17)))] <- NA |
||
| 602 | -! | +||
| 62 | +
- inputId = "dist_param2",+ #' x |
||
| 603 | -! | +||
| 63 | +
- label = params_names[2],+ #' } |
||
| 604 | -! | +||
| 64 | +
- value = restoreInput(ns("dist_param1"), params_vals[2])
+ #' |
||
| 605 | +65 |
- )+ #' iris <- iris |
|
| 606 | +66 |
- },+ #' mtcars <- mtcars |
|
| 607 | -! | +||
| 67 | +
- ignoreInit = TRUE+ #' |
||
| 608 | +68 |
- )+ #' iris[] <- lapply(iris, add_nas) |
|
| 609 | +69 |
-
+ #' mtcars[] <- lapply(mtcars, add_nas) |
|
| 610 | -! | +||
| 70 | +
- observeEvent(input$params_reset, {
+ #' mtcars[["cyl"]] <- as.factor(mtcars[["cyl"]]) |
||
| 611 | -! | +||
| 71 | +
- updateActionButton(inputId = "params_reset", label = "Reset params")+ #' mtcars[["gear"]] <- as.factor(mtcars[["gear"]]) |
||
| 612 | +72 |
- })+ #' }) |
|
| 613 | +73 |
-
+ #' |
|
| 614 | -! | +||
| 74 | +
- merge_vars <- reactive({
+ #' app <- init( |
||
| 615 | -! | +||
| 75 | +
- teal::validate_inputs(iv_r())+ #' data = data, |
||
| 616 | +76 |
-
+ #' modules = modules( |
|
| 617 | -! | +||
| 77 | +
- dist_var <- as.vector(merged$anl_input_r()$columns_source$dist_i)+ #' tm_missing_data() |
||
| 618 | -! | +||
| 78 | +
- s_var <- as.vector(merged$anl_input_r()$columns_source$strata_i)+ #' ) |
||
| 619 | -! | +||
| 79 | +
- g_var <- as.vector(merged$anl_input_r()$columns_source$group_i)+ #' ) |
||
| 620 | +80 |
-
+ #' if (interactive()) {
|
|
| 621 | -! | +||
| 81 | +
- dist_var_name <- if (length(dist_var)) as.name(dist_var) else NULL+ #' shinyApp(app$ui, app$server) |
||
| 622 | -! | +||
| 82 | +
- s_var_name <- if (length(s_var)) as.name(s_var) else NULL+ #' } |
||
| 623 | -! | +||
| 83 | +
- g_var_name <- if (length(g_var)) as.name(g_var) else NULL+ #' |
||
| 624 | +84 |
-
+ #' @examplesShinylive |
|
| 625 | -! | +||
| 85 | +
- list(+ #' library(teal.modules.general) |
||
| 626 | -! | +||
| 86 | +
- dist_var = dist_var,+ #' interactive <- function() TRUE |
||
| 627 | -! | +||
| 87 | +
- s_var = s_var,+ #' {{ next_example }}
|
||
| 628 | -! | +||
| 88 | +
- g_var = g_var,+ #' @examplesIf require("gridExtra", quietly = TRUE) && require("rlang", quietly = TRUE)
|
||
| 629 | -! | +||
| 89 | +
- dist_var_name = dist_var_name,+ #' # CDISC example data |
||
| 630 | -! | +||
| 90 | +
- s_var_name = s_var_name,+ #' data <- teal_data() |
||
| 631 | -! | +||
| 91 | +
- g_var_name = g_var_name+ #' data <- within(data, {
|
||
| 632 | +92 |
- )+ #' require(nestcolor) |
|
| 633 | +93 |
- })+ #' ADSL <- teal.data::rADSL |
|
| 634 | +94 |
-
+ #' ADRS <- rADRS |
|
| 635 | +95 |
- # common qenv+ #' }) |
|
| 636 | -! | +||
| 96 | +
- common_q <- reactive({
+ #' join_keys(data) <- default_cdisc_join_keys[names(data)] |
||
| 637 | +97 |
- # Create a private stack for this function only.+ #' |
|
| 638 | +98 |
-
+ #' app <- init( |
|
| 639 | -! | +||
| 99 | +
- ANL <- merged$anl_q_r()[["ANL"]]+ #' data = data, |
||
| 640 | -! | +||
| 100 | +
- dist_var <- merge_vars()$dist_var+ #' modules = modules( |
||
| 641 | -! | +||
| 101 | +
- s_var <- merge_vars()$s_var+ #' tm_missing_data() |
||
| 642 | -! | +||
| 102 | +
- g_var <- merge_vars()$g_var+ #' ) |
||
| 643 | +103 |
-
+ #' ) |
|
| 644 | -! | +||
| 104 | +
- dist_var_name <- merge_vars()$dist_var_name+ #' if (interactive()) {
|
||
| 645 | -! | +||
| 105 | +
- s_var_name <- merge_vars()$s_var_name+ #' shinyApp(app$ui, app$server) |
||
| 646 | -! | +||
| 106 | +
- g_var_name <- merge_vars()$g_var_name+ #' } |
||
| 647 | +107 |
-
+ #' |
|
| 648 | -! | +||
| 108 | +
- roundn <- input$roundn+ #' @export |
||
| 649 | -! | +||
| 109 | +
- dist_param1 <- input$dist_param1+ #' |
||
| 650 | -! | +||
| 110 | +
- dist_param2 <- input$dist_param2+ tm_missing_data <- function(label = "Missing data", |
||
| 651 | +111 |
- # isolated as dist_param1/dist_param2 already triggered the reactivity+ plot_height = c(600, 400, 5000), |
|
| 652 | -! | +||
| 112 | +
- t_dist <- isolate(input$t_dist)+ plot_width = NULL, |
||
| 653 | +113 |
-
+ parent_dataname = "ADSL", |
|
| 654 | -! | +||
| 114 | +
- qenv <- merged$anl_q_r()+ ggtheme = c("classic", "gray", "bw", "linedraw", "light", "dark", "minimal", "void"),
|
||
| 655 | +115 |
-
+ ggplot2_args = list( |
|
| 656 | -! | +||
| 116 | +
- if (length(g_var) > 0) {
+ "Combinations Hist" = teal.widgets::ggplot2_args(labs = list(caption = NULL)), |
||
| 657 | -! | +||
| 117 | +
- validate(+ "Combinations Main" = teal.widgets::ggplot2_args(labs = list(title = NULL)) |
||
| 658 | -! | +||
| 118 | +
- need(+ ), |
||
| 659 | -! | +||
| 119 | +
- inherits(ANL[[g_var]], c("integer", "factor", "character")),
+ pre_output = NULL,+ |
+ ||
| 120 | ++ |
+ post_output = NULL,+ |
+ |
| 121 | ++ |
+ decorators = NULL) {
|
|
| 660 | +122 | ! |
- "Group by variable must be `factor`, `character`, or `integer`"+ message("Initializing tm_missing_data")
|
| 661 | +123 |
- )+ |
|
| 662 | +124 |
- )+ # Requires Suggested packages |
|
| 663 | +125 | ! |
- qenv <- teal.code::eval_code(+ if (!requireNamespace("gridExtra", quietly = TRUE)) {
|
| 664 | +126 | ! |
- qenv,+ stop("Cannot load gridExtra - please install the package or restart your session.")
|
| 665 | -! | +||
| 127 | +
- substitute(+ } |
||
| 666 | +128 | ! |
- expr = ANL[[g_var]] <- forcats::fct_na_value_to_level(as.factor(ANL[[g_var]]), "NA"),+ if (!requireNamespace("rlang", quietly = TRUE)) {
|
| 667 | +129 | ! |
- env = list(g_var = g_var)+ stop("Cannot load rlang - please install the package or restart your session.")
|
| 668 | +130 |
- )+ } |
|
| 669 | +131 |
- )+ |
|
| 670 | +132 |
- }+ # Normalize the parameters+ |
+ |
| 133 | +! | +
+ if (inherits(ggplot2_args, "ggplot2_args")) ggplot2_args <- list(default = ggplot2_args) |
|
| 671 | +134 | ||
| 672 | -! | +||
| 135 | +
- if (length(s_var) > 0) {
+ # Start of assertions |
||
| 673 | +136 | ! |
- validate(+ checkmate::assert_string(label) |
| 674 | -! | +||
| 137 | +
- need(+ |
||
| 675 | +138 | ! |
- inherits(ANL[[s_var]], c("integer", "factor", "character")),
+ checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE) |
| 676 | +139 | ! |
- "Stratify by variable must be `factor`, `character`, or `integer`"+ checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height") |
| 677 | -+ | ||
| 140 | +! |
- )+ checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE) |
|
| 678 | -+ | ||
| 141 | +! |
- )+ checkmate::assert_numeric( |
|
| 679 | +142 | ! |
- qenv <- teal.code::eval_code(+ plot_width[1], |
| 680 | +143 | ! |
- qenv,+ lower = plot_width[2], upper = plot_width[3], null.ok = TRUE, .var.name = "plot_width" |
| 681 | -! | +||
| 144 | +
- substitute(+ )+ |
+ ||
| 145 | ++ | + | |
| 682 | +146 | ! |
- expr = ANL[[s_var]] <- forcats::fct_na_value_to_level(as.factor(ANL[[s_var]]), "NA"),+ checkmate::assert_character(parent_dataname, min.len = 0, max.len = 1) |
| 683 | +147 | ! |
- env = list(s_var = s_var)+ ggtheme <- match.arg(ggtheme) |
| 684 | +148 |
- )+ |
|
| 685 | -+ | ||
| 149 | +! |
- )+ plot_choices <- c("Summary Obs", "Summary Patients", "Combinations Main", "Combinations Hist", "By Subject")
|
|
| 686 | -+ | ||
| 150 | +! |
- }+ checkmate::assert_list(ggplot2_args, types = "ggplot2_args")+ |
+ |
| 151 | +! | +
+ checkmate::assert_subset(names(ggplot2_args), c("default", plot_choices))
|
|
| 687 | +152 | ||
| 688 | +153 | ! |
- validate(need(is.numeric(ANL[[dist_var]]), "Please select a numeric variable."))+ checkmate::assert_multi_class(pre_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
|
| 689 | +154 | ! |
- teal::validate_has_data(ANL, 1, complete = TRUE)+ checkmate::assert_multi_class(post_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
|
| 690 | +155 | ||
| 691 | +156 | ! |
- if (length(t_dist) != 0) {
+ available_decorators <- c("summary_plot", "combination_plot", "by_subject_plot", "summary_table")
|
| 692 | +157 | ! |
- map_distr_nams <- list(+ decorators <- normalize_decorators(decorators) |
| 693 | +158 | ! |
- normal = c("mean", "sd"),
+ assert_decorators(decorators, null.ok = TRUE, names = available_decorators) |
| 694 | -! | +||
| 159 | +
- lognormal = c("meanlog", "sdlog"),
+ # End of assertions |
||
| 695 | -! | +||
| 160 | +
- gamma = c("shape", "rate"),
+
|
||
| 696 | +161 | ! |
- unif = c("min", "max")
+ ans <- module( |
| 697 | -+ | ||
| 162 | +! |
- )+ label, |
|
| 698 | +163 | ! |
- params_names_raw <- map_distr_nams[[t_dist]]+ server = srv_page_missing_data, |
| 699 | -+ | ||
| 164 | +! |
-
+ server_args = list( |
|
| 700 | +165 | ! |
- qenv <- teal.code::eval_code(+ parent_dataname = parent_dataname, |
| 701 | +166 | ! |
- qenv,+ plot_height = plot_height, |
| 702 | +167 | ! |
- substitute(+ plot_width = plot_width, |
| 703 | +168 | ! |
- expr = {
+ ggplot2_args = ggplot2_args, |
| 704 | +169 | ! |
- params <- as.list(c(dist_param1, dist_param2))+ ggtheme = ggtheme, |
| 705 | +170 | ! |
- names(params) <- params_names_raw+ decorators = decorators |
| 706 | +171 |
- },+ ), |
|
| 707 | +172 | ! |
- env = list(+ ui = ui_page_missing_data, |
| 708 | +173 | ! |
- dist_param1 = dist_param1,+ datanames = "all", |
| 709 | +174 | ! |
- dist_param2 = dist_param2,+ ui_args = list(pre_output = pre_output, post_output = post_output)+ |
+
| 175 | ++ |
+ ) |
|
| 710 | +176 | ! |
- params_names_raw = params_names_raw+ attr(ans, "teal_bookmarkable") <- TRUE |
| 711 | -+ | ||
| 177 | +! |
- )+ ans |
|
| 712 | +178 |
- )+ } |
|
| 713 | +179 |
- )+ |
|
| 714 | +180 |
- }+ # UI function for the missing data module (all datasets) |
|
| 715 | +181 |
-
+ ui_page_missing_data <- function(id, pre_output = NULL, post_output = NULL) {
|
|
| 716 | +182 | ! |
- qenv <- if (length(s_var) == 0 && length(g_var) == 0) {
+ ns <- NS(id) |
| 717 | +183 | ! |
- teal.code::eval_code(+ tagList( |
| 718 | +184 | ! |
- qenv,+ include_css_files("custom"),
|
| 719 | +185 | ! |
- substitute(+ teal.widgets::standard_layout( |
| 720 | +186 | ! |
- expr = {
+ output = teal.widgets::white_small_well( |
| 721 | +187 | ! |
- summary_table_data <- ANL %>%+ tags$div( |
| 722 | +188 | ! |
- dplyr::summarise(+ class = "flex", |
| 723 | +189 | ! |
- min = round(min(dist_var_name, na.rm = TRUE), roundn),+ column( |
| 724 | +190 | ! |
- median = round(stats::median(dist_var_name, na.rm = TRUE), roundn),+ width = 12, |
| 725 | +191 | ! |
- mean = round(mean(dist_var_name, na.rm = TRUE), roundn),+ uiOutput(ns("dataset_tabs"))
|
| 726 | -! | +||
| 192 | +
- max = round(max(dist_var_name, na.rm = TRUE), roundn),+ ) |
||
| 727 | -! | +||
| 193 | +
- sd = round(stats::sd(dist_var_name, na.rm = TRUE), roundn),+ )+ |
+ ||
| 194 | ++ |
+ ), |
|
| 728 | +195 | ! |
- count = dplyr::n()+ encoding = tags$div( |
| 729 | -+ | ||
| 196 | +! |
- )+ uiOutput(ns("dataset_encodings"))
|
|
| 730 | +197 |
- },+ ), |
|
| 731 | +198 | ! |
- env = list(+ uiOutput(ns("dataset_reporter")),
|
| 732 | +199 | ! |
- dist_var_name = as.name(dist_var),+ pre_output = pre_output, |
| 733 | +200 | ! |
- roundn = roundn+ post_output = post_output |
| 734 | +201 |
- )+ ) |
|
| 735 | +202 |
- )+ ) |
|
| 736 | +203 |
- )+ } |
|
| 737 | +204 |
- } else {
+
|
|
| 738 | -! | +||
| 205 | +
- teal.code::eval_code(+ # Server function for the missing data module (all datasets) |
||
| 739 | -! | +||
| 206 | +
- qenv,+ srv_page_missing_data <- function(id, data, reporter, filter_panel_api, parent_dataname, |
||
| 740 | -! | +||
| 207 | +
- substitute(+ plot_height, plot_width, ggplot2_args, ggtheme, decorators) {
|
||
| 741 | +208 | ! |
- expr = {
+ with_reporter <- !missing(reporter) && inherits(reporter, "Reporter") |
| 742 | +209 | ! |
- strata_vars <- strata_vars_raw+ with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI") |
| 743 | +210 | ! |
- summary_table_data <- ANL %>%+ moduleServer(id, function(input, output, session) {
|
| 744 | +211 | ! |
- dplyr::group_by_at(dplyr::vars(dplyr::any_of(strata_vars))) %>%+ teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.general") |
| 745 | -! | +||
| 212 | +
- dplyr::summarise(+ |
||
| 746 | +213 | ! |
- min = round(min(dist_var_name, na.rm = TRUE), roundn),+ datanames <- isolate(names(data())) |
| 747 | +214 | ! |
- median = round(stats::median(dist_var_name, na.rm = TRUE), roundn),+ datanames <- Filter( |
| 748 | +215 | ! |
- mean = round(mean(dist_var_name, na.rm = TRUE), roundn),+ function(name) is.data.frame(isolate(data())[[name]]), |
| 749 | +216 | ! |
- max = round(max(dist_var_name, na.rm = TRUE), roundn),+ datanames |
| 750 | -! | +||
| 217 | +
- sd = round(stats::sd(dist_var_name, na.rm = TRUE), roundn),+ ) |
||
| 751 | +218 | ! |
- count = dplyr::n()+ if_subject_plot <- length(parent_dataname) > 0 && parent_dataname %in% datanames |
| 752 | +219 |
- )+ + |
+ |
| 220 | +! | +
+ ns <- session$ns |
|
| 753 | +221 |
- },+ |
|
| 754 | +222 | ! |
- env = list(+ output$dataset_tabs <- renderUI({
|
| 755 | +223 | ! |
- dist_var_name = dist_var_name,+ do.call( |
| 756 | +224 | ! |
- strata_vars_raw = c(g_var, s_var),+ tabsetPanel, |
| 757 | +225 | ! |
- roundn = roundn- |
-
| 758 | -- |
- )- |
- |
| 759 | -- |
- )+ c( |
|
| 760 | -+ | ||
| 226 | +! |
- )+ id = ns("dataname_tab"),
|
|
| 761 | -+ | ||
| 227 | +! |
- }+ lapply( |
|
| 762 | +228 | ! |
- if (iv_r()$is_valid()) {
+ datanames, |
| 763 | +229 | ! |
- within(qenv, {
+ function(x) {
|
| 764 | +230 | ! |
- summary_table <- DT::datatable(+ tabPanel( |
| 765 | +231 | ! |
- summary_table_data,+ title = x, |
| 766 | +232 | ! |
- options = list(+ column( |
| 767 | +233 | ! |
- autoWidth = TRUE,+ width = 12, |
| 768 | +234 | ! |
- columnDefs = list(list(width = "200px", targets = "_all"))+ tags$div( |
| 769 | -+ | ||
| 235 | +! |
- ),+ class = "mt-4", |
|
| 770 | +236 | ! |
- rownames = FALSE+ ui_missing_data(id = ns(x), by_subject_plot = if_subject_plot) |
| 771 | +237 |
- )+ ) |
|
| 772 | +238 |
- })+ ) |
|
| 773 | +239 |
- } else {
+ ) |
|
| 774 | -! | +||
| 240 | +
- within(qenv, summary_table <- NULL)+ } |
||
| 775 | +241 |
- }+ ) |
|
| 776 | +242 |
- })+ ) |
|
| 777 | +243 |
-
+ ) |
|
| 778 | +244 |
- # distplot qenv ----+ }) |
|
| 779 | -! | +||
| 245 | +
- dist_q <- eventReactive(+ |
||
| 780 | +246 | ! |
- eventExpr = {
+ output$dataset_encodings <- renderUI({
|
| 781 | +247 | ! |
- common_q()+ tagList( |
| 782 | +248 | ! |
- input$scales_type+ lapply( |
| 783 | +249 | ! |
- input$main_type+ datanames, |
| 784 | +250 | ! |
- input$bins+ function(x) {
|
| 785 | +251 | ! |
- input$add_dens+ conditionalPanel( |
| 786 | +252 | ! |
- is.null(input$ggtheme)- |
-
| 787 | -- |
- },+ is_tab_active_js(ns("dataname_tab"), x),
|
|
| 788 | +253 | ! |
- valueExpr = {
+ encoding_missing_data( |
| 789 | +254 | ! |
- dist_var <- merge_vars()$dist_var+ id = ns(x), |
| 790 | +255 | ! |
- s_var <- merge_vars()$s_var+ summary_per_patient = if_subject_plot, |
| 791 | +256 | ! |
- g_var <- merge_vars()$g_var+ ggtheme = ggtheme, |
| 792 | +257 | ! |
- dist_var_name <- merge_vars()$dist_var_name+ datanames = datanames, |
| 793 | +258 | ! |
- s_var_name <- merge_vars()$s_var_name+ decorators = decorators |
| 794 | -! | +||
| 259 | +
- g_var_name <- merge_vars()$g_var_name+ ) |
||
| 795 | -! | +||
| 260 | +
- t_dist <- input$t_dist+ ) |
||
| 796 | -! | +||
| 261 | +
- dist_param1 <- input$dist_param1+ } |
||
| 797 | -! | +||
| 262 | +
- dist_param2 <- input$dist_param2+ ) |
||
| 798 | +263 |
-
+ ) |
|
| 799 | -! | +||
| 264 | +
- scales_type <- input$scales_type+ }) |
||
| 800 | +265 | ||
| 801 | +266 | ! |
- ndensity <- 512+ output$dataset_reporter <- renderUI({
|
| 802 | +267 | ! |
- main_type_var <- input$main_type+ lapply(datanames, function(x) {
|
| 803 | +268 | ! |
- bins_var <- input$bins+ dataname_ns <- NS(ns(x))+ |
+
| 269 | ++ | + | |
| 804 | +270 | ! |
- add_dens_var <- input$add_dens+ conditionalPanel( |
| 805 | +271 | ! |
- ggtheme <- input$ggtheme+ is_tab_active_js(ns("dataname_tab"), x),
|
| 806 | -+ | ||
| 272 | +! |
-
+ tagList( |
|
| 807 | +273 | ! |
- teal::validate_inputs(iv_dist)+ teal.widgets::verbatim_popup_ui(dataname_ns("rcode"), "Show R code")
|
| 808 | +274 |
-
+ ) |
|
| 809 | -! | +||
| 275 | +
- qenv <- common_q()+ ) |
||
| 810 | +276 |
-
+ }) |
|
| 811 | -! | +||
| 277 | +
- m_type <- if (main_type_var == "Density") "density" else "count"+ }) |
||
| 812 | +278 | ||
| 813 | +279 | ! |
- plot_call <- if (length(s_var) == 0 && length(g_var) == 0) {
+ lapply( |
| 814 | +280 | ! |
- substitute(+ datanames, |
| 815 | +281 | ! |
- expr = ggplot(ANL, aes(dist_var_name)) ++ function(x) {
|
| 816 | +282 | ! |
- geom_histogram(+ srv_missing_data( |
| 817 | +283 | ! |
- position = "identity", aes(y = after_stat(m_type)), bins = bins_var, alpha = 0.3- |
-
| 818 | -- |
- ),+ id = x, |
|
| 819 | +284 | ! |
- env = list(+ data = data, |
| 820 | +285 | ! |
- m_type = as.name(m_type), bins_var = bins_var, dist_var_name = as.name(dist_var)+ reporter = if (with_reporter) reporter, |
| 821 | -+ | ||
| 286 | +! |
- )+ filter_panel_api = if (with_filter) filter_panel_api, |
|
| 822 | -+ | ||
| 287 | +! |
- )+ dataname = x, |
|
| 823 | +288 | ! |
- } else if (length(s_var) != 0 && length(g_var) == 0) {
+ parent_dataname = parent_dataname, |
| 824 | +289 | ! |
- substitute(+ plot_height = plot_height, |
| 825 | +290 | ! |
- expr = ggplot(ANL, aes(dist_var_name, col = s_var_name)) ++ plot_width = plot_width, |
| 826 | +291 | ! |
- geom_histogram(+ ggplot2_args = ggplot2_args, |
| 827 | +292 | ! |
- position = "identity", aes(y = after_stat(m_type), fill = s_var), bins = bins_var, alpha = 0.3+ decorators = decorators |
| 828 | +293 |
- ),- |
- |
| 829 | -! | -
- env = list(+ ) |
|
| 830 | -! | +||
| 294 | +
- m_type = as.name(m_type),+ } |
||
| 831 | -! | +||
| 295 | +
- bins_var = bins_var,+ ) |
||
| 832 | -! | +||
| 296 | +
- dist_var_name = dist_var_name,+ }) |
||
| 833 | -! | +||
| 297 | +
- s_var = as.name(s_var),+ } |
||
| 834 | -! | +||
| 298 | +
- s_var_name = s_var_name+ |
||
| 835 | +299 |
- )+ # UI function for the missing data module (single dataset) |
|
| 836 | +300 |
- )+ ui_missing_data <- function(id, by_subject_plot = FALSE) {
|
|
| 837 | +301 | ! |
- } else if (length(s_var) == 0 && length(g_var) != 0) {
+ ns <- NS(id) |
| 838 | -! | +||
| 302 | +
- req(scales_type)+ |
||
| 839 | +303 | ! |
- substitute(+ tab_list <- list( |
| 840 | +304 | ! |
- expr = ggplot(ANL[ANL[[g_var]] != "NA", ], aes(dist_var_name)) ++ tabPanel( |
| 841 | +305 | ! |
- geom_histogram(+ "Summary", |
| 842 | +306 | ! |
- position = "identity", aes(y = after_stat(m_type)), bins = bins_var, alpha = 0.3- |
-
| 843 | -- |
- ) ++ teal.widgets::plot_with_settings_ui(id = ns("summary_plot")),
|
|
| 844 | +307 | ! |
- facet_wrap(~g_var_name, ncol = 1, scales = scales_raw),+ helpText( |
| 845 | +308 | ! |
- env = list(+ tags$p(paste( |
| 846 | +309 | ! |
- m_type = as.name(m_type),+ 'The "Summary" graph shows the number of missing values per variable (both absolute and percentage),', |
| 847 | +310 | ! |
- bins_var = bins_var,+ "sorted by magnitude." |
| 848 | -! | +||
| 311 | +
- dist_var_name = dist_var_name,+ )), |
||
| 849 | +312 | ! |
- g_var = g_var,+ tags$p( |
| 850 | +313 | ! |
- g_var_name = g_var_name,+ 'The "summary per patients" graph is showing how many subjects have at least one missing observation', |
| 851 | +314 | ! |
- scales_raw = tolower(scales_type)+ "for each variable. It will be most useful for panel datasets." |
| 852 | +315 |
- )+ ) |
|
| 853 | +316 |
- )+ ) |
|
| 854 | +317 |
- } else {
- |
- |
| 855 | -! | -
- req(scales_type)+ ), |
|
| 856 | +318 | ! |
- substitute(+ tabPanel( |
| 857 | +319 | ! |
- expr = ggplot(ANL[ANL[[g_var]] != "NA", ], aes(dist_var_name, col = s_var_name)) ++ "Combinations", |
| 858 | +320 | ! |
- geom_histogram(+ teal.widgets::plot_with_settings_ui(id = ns("combination_plot")),
|
| 859 | +321 | ! |
- position = "identity",+ helpText( |
| 860 | +322 | ! |
- aes(y = after_stat(m_type), fill = s_var), bins = bins_var, alpha = 0.3- |
-
| 861 | -- |
- ) ++ tags$p(paste( |
|
| 862 | +323 | ! |
- facet_wrap(~g_var_name, ncol = 1, scales = scales_raw),+ 'The "Combinations" graph is used to explore the relationship between the missing data within', |
| 863 | +324 | ! |
- env = list(+ "different columns of the dataset.", |
| 864 | +325 | ! |
- m_type = as.name(m_type),+ "It shows the different patterns of missingness in the rows of the data.", |
| 865 | +326 | ! |
- bins_var = bins_var,+ 'For example, suppose that 70 rows of the data have exactly columns "A" and "B" missing.', |
| 866 | +327 | ! |
- dist_var_name = dist_var_name,+ "In this case there would be a bar of height 70 in the top graph and", |
| 867 | +328 | ! |
- g_var = g_var,+ 'the column below this in the second graph would have rows "A" and "B" cells shaded red.' |
| 868 | -! | +||
| 329 | +
- s_var = as.name(s_var),+ )), |
||
| 869 | +330 | ! |
- g_var_name = g_var_name,+ tags$p(paste( |
| 870 | +331 | ! |
- s_var_name = s_var_name,+ "Due to the large number of missing data patterns possible, only those with a large set of observations", |
| 871 | +332 | ! |
- scales_raw = tolower(scales_type)+ 'are shown in the graph and the "Combination cut-off" slider can be used to adjust the number shown.' |
| 872 | +333 |
- )+ )) |
|
| 873 | +334 |
- )+ ) |
|
| 874 | +335 |
- }+ ), |
|
| 875 | -+ | ||
| 336 | +! |
-
+ tabPanel( |
|
| 876 | +337 | ! |
- if (add_dens_var) {
+ "By Variable Levels", |
| 877 | +338 | ! |
- plot_call <- substitute(+ teal.widgets::get_dt_rows(ns("levels_table"), ns("levels_table_rows")),
|
| 878 | +339 | ! |
- expr = plot_call ++ DT::dataTableOutput(ns("levels_table"))
|
| 879 | -! | +||
| 340 | +
- stat_density(+ ) |
||
| 880 | -! | +||
| 341 | +
- aes(y = after_stat(const * m_type2)),+ ) |
||
| 881 | +342 | ! |
- geom = "line",+ if (isTRUE(by_subject_plot)) {
|
| 882 | +343 | ! |
- position = "identity",+ tab_list <- append( |
| 883 | +344 | ! |
- alpha = 0.5,+ tab_list, |
| 884 | +345 | ! |
- size = 2,+ list(tabPanel( |
| 885 | +346 | ! |
- n = ndensity+ "Grouped by Subject", |
| 886 | -+ | ||
| 347 | +! |
- ),+ teal.widgets::plot_with_settings_ui(id = ns("by_subject_plot")),
|
|
| 887 | +348 | ! |
- env = list(+ helpText( |
| 888 | +349 | ! |
- plot_call = plot_call,+ tags$p(paste( |
| 889 | +350 | ! |
- const = if (main_type_var == "Density") {
+ "This graph shows the missingness with respect to subjects rather than individual rows of the", |
| 890 | +351 | ! |
- 1+ "dataset. Each row represents one dataset variable and each column a single subject. Only subjects", |
| 891 | -+ | ||
| 352 | +! |
- } else {
+ "with at least one record in this dataset are shown. For a given subject, if they have any missing", |
|
| 892 | +353 | ! |
- diff(range(qenv[["ANL"]][[dist_var]], na.rm = TRUE)) / bins_var+ "values of a specific variable then the appropriate cell in the graph is marked as missing." |
| 893 | +354 |
- },- |
- |
| 894 | -! | -
- m_type2 = if (main_type_var == "Density") as.name("density") else as.name("count"),
+ )) |
|
| 895 | -! | +||
| 355 | +
- ndensity = ndensity+ ) |
||
| 896 | +356 |
- )+ )) |
|
| 897 | +357 |
- )+ ) |
|
| 898 | +358 |
- }+ } |
|
| 899 | +359 | ||
| 900 | +360 | ! |
- if (length(t_dist) != 0 && main_type_var == "Density" && length(g_var) == 0 && length(s_var) == 0) {
+ do.call( |
| 901 | +361 | ! |
- qenv <- teal.code::eval_code(+ tabsetPanel, |
| 902 | +362 | ! |
- qenv,+ c( |
| 903 | +363 | ! |
- substitute(+ id = ns("summary_type"),
|
| 904 | +364 | ! |
- df_params <- as.data.frame(append(params, list(name = t_dist))),+ tab_list |
| 905 | -! | +||
| 365 | +
- env = list(t_dist = t_dist)+ ) |
||
| 906 | +366 |
- )+ ) |
|
| 907 | +367 |
- )+ } |
|
| 908 | -! | +||
| 368 | +
- datas <- quote(data.frame(x = 0.7, y = 1, tb = I(list(df_params = df_params))))+ |
||
| 909 | -! | +||
| 369 | +
- label <- quote(tb)+ # UI encoding for the missing data module (all datasets) |
||
| 910 | +370 |
-
+ encoding_missing_data <- function(id, summary_per_patient = FALSE, ggtheme, datanames, decorators) {
|
|
| 911 | +371 | ! |
- plot_call <- substitute(+ ns <- NS(id) |
| 912 | -! | +||
| 372 | +
- expr = plot_call + ggpp::geom_table_npc(+ |
||
| 913 | +373 | ! |
- data = data,+ tagList( |
| 914 | -! | +||
| 374 | +
- aes(npcx = x, npcy = y, label = label),+ ### Reporter |
||
| 915 | +375 | ! |
- hjust = 0, vjust = 1, size = 4+ teal.reporter::simple_reporter_ui(ns("simple_reporter")),
|
| 916 | +376 |
- ),+ ### |
|
| 917 | +377 | ! |
- env = list(plot_call = plot_call, data = datas, label = label)+ tags$label("Encodings", class = "text-primary"),
|
| 918 | -+ | ||
| 378 | +! |
- )+ helpText( |
|
| 919 | -+ | ||
| 379 | +! |
- }+ paste0("Dataset", `if`(length(datanames) > 1, "s", ""), ":"),
+ |
+ |
| 380 | +! | +
+ tags$code(paste(datanames, collapse = ", ")) |
|
| 920 | +381 |
-
+ ), |
|
| 921 | +382 | ! |
- if (+ uiOutput(ns("variables")),
|
| 922 | +383 | ! |
- length(s_var) == 0 &&+ actionButton( |
| 923 | +384 | ! |
- length(g_var) == 0 &&+ ns("filter_na"),
|
| 924 | +385 | ! |
- main_type_var == "Density" &&+ tags$span("Select only vars with missings", class = "whitespace-normal"),
|
| 925 | +386 | ! |
- length(t_dist) != 0 &&+ width = "100%", |
| 926 | +387 | ! |
- main_type_var == "Density"+ class = "mb-4" |
| 927 | +388 |
- ) {
+ ), |
|
| 928 | +389 | ! |
- map_dist <- stats::setNames(+ conditionalPanel( |
| 929 | +390 | ! |
- c("dnorm", "dlnorm", "dgamma", "dunif"),
+ is_tab_active_js(ns("summary_type"), "Summary"),
|
| 930 | +391 | ! |
- c("normal", "lognormal", "gamma", "unif")
+ checkboxInput( |
| 931 | -+ | ||
| 392 | +! |
- )+ ns("any_na"),
|
|
| 932 | +393 | ! |
- plot_call <- substitute(+ tags$div( |
| 933 | +394 | ! |
- expr = plot_call + stat_function(+ class = "teal-tooltip", |
| 934 | +395 | ! |
- data = data.frame(x = range(ANL[[dist_var]]), color = mapped_dist),+ tagList( |
| 935 | +396 | ! |
- aes(x, color = color),+ "Add **anyna** variable", |
| 936 | +397 | ! |
- fun = mapped_dist_name,+ icon("circle-info"),
|
| 937 | +398 | ! |
- n = ndensity,+ tags$span( |
| 938 | +399 | ! |
- size = 2,+ class = "tooltiptext", |
| 939 | +400 | ! |
- args = params+ "Describes the number of observations with at least one missing value in any variable." |
| 940 | +401 |
- ) ++ ) |
|
| 941 | -! | +||
| 402 | +
- scale_color_manual(values = stats::setNames("blue", mapped_dist), aesthetics = "color"),
+ ) |
||
| 942 | -! | +||
| 403 | +
- env = list(+ ), |
||
| 943 | +404 | ! |
- plot_call = plot_call,+ value = FALSE |
| 944 | -! | +||
| 405 | +
- dist_var = dist_var,+ ), |
||
| 945 | +406 | ! |
- ndensity = ndensity,+ if (summary_per_patient) {
|
| 946 | +407 | ! |
- mapped_dist = unname(map_dist[t_dist]),+ checkboxInput( |
| 947 | +408 | ! |
- mapped_dist_name = as.name(unname(map_dist[t_dist]))- |
-
| 948 | -- |
- )- |
- |
| 949 | -- |
- )- |
- |
| 950 | -- |
- }- |
- |
| 951 | -- | - - | -|
| 952 | -! | -
- all_ggplot2_args <- teal.widgets::resolve_ggplot2_args(+ ns("if_patients_plot"),
|
|
| 953 | +409 | ! |
- user_plot = ggplot2_args[["Histogram"]],+ tags$div( |
| 954 | +410 | ! |
- user_default = ggplot2_args$default- |
-
| 955 | -- |
- )- |
- |
| 956 | -- |
-
+ class = "teal-tooltip", |
|
| 957 | +411 | ! |
- parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(+ tagList( |
| 958 | +412 | ! |
- all_ggplot2_args,+ "Add summary per patients", |
| 959 | +413 | ! |
- ggtheme = ggtheme- |
-
| 960 | -- |
- )- |
- |
| 961 | -- |
-
+ icon("circle-info"),
|
|
| 962 | +414 | ! |
- teal.code::eval_code(+ tags$span( |
| 963 | +415 | ! |
- qenv,+ class = "tooltiptext", |
| 964 | +416 | ! |
- substitute(+ paste( |
| 965 | +417 | ! |
- expr = histogram_plot <- plot_call,+ "Displays the number of missing values per observation,", |
| 966 | +418 | ! |
- env = list(plot_call = Reduce(function(x, y) call("+", x, y), c(plot_call, parsed_ggplot2_args)))
+ "where the x-axis is sorted by observation appearance in the table." |
| 967 | +419 |
- )+ ) |
|
| 968 | +420 |
- )+ ) |
|
| 969 | +421 |
- }+ ) |
|
| 970 | +422 |
- )+ ), |
|
| 971 | -+ | ||
| 423 | +! |
-
+ value = FALSE |
|
| 972 | +424 |
- # qqplot qenv ----+ ) |
|
| 973 | -! | +||
| 425 | +
- qq_q <- eventReactive(+ }, |
||
| 974 | +426 | ! |
- eventExpr = {
+ ui_decorate_teal_data(ns("dec_summary_plot"), decorators = select_decorators(decorators, "summary_plot"))
|
| 975 | -! | +||
| 427 | +
- common_q()+ ), |
||
| 976 | +428 | ! |
- input$scales_type+ conditionalPanel( |
| 977 | +429 | ! |
- input$qq_line+ is_tab_active_js(ns("summary_type"), "Combinations"),
|
| 978 | +430 | ! |
- is.null(input$ggtheme)+ uiOutput(ns("cutoff")),
|
| 979 | +431 | ! |
- input$tabs+ ui_decorate_teal_data(ns("dec_combination_plot"), decorators = select_decorators(decorators, "combination_plot"))
|
| 980 | +432 |
- },+ ), |
|
| 981 | +433 | ! |
- valueExpr = {
+ conditionalPanel( |
| 982 | +434 | ! |
- dist_var <- merge_vars()$dist_var+ is_tab_active_js(ns("summary_type"), "Grouped by Subject"),
|
| 983 | +435 | ! |
- s_var <- merge_vars()$s_var+ ui_decorate_teal_data(ns("dec_by_subject_plot"), decorators = select_decorators(decorators, "by_subject_plot"))
|
| 984 | -! | +||
| 436 | +
- g_var <- merge_vars()$g_var+ ), |
||
| 985 | +437 | ! |
- dist_var_name <- merge_vars()$dist_var_name+ conditionalPanel( |
| 986 | +438 | ! |
- s_var_name <- merge_vars()$s_var_name+ is_tab_active_js(ns("summary_type"), "By Variable Levels"),
|
| 987 | +439 | ! |
- g_var_name <- merge_vars()$g_var_name+ uiOutput(ns("group_by_var_ui")),
|
| 988 | +440 | ! |
- dist_param1 <- input$dist_param1+ uiOutput(ns("group_by_vals_ui")),
|
| 989 | +441 | ! |
- dist_param2 <- input$dist_param2+ radioButtons( |
| 990 | -+ | ||
| 442 | +! |
-
+ ns("count_type"),
|
|
| 991 | +443 | ! |
- scales_type <- input$scales_type+ label = "Display missing as", |
| 992 | +444 | ! |
- ggtheme <- input$ggtheme+ choices = c("counts", "proportions"),
|
| 993 | -+ | ||
| 445 | +! |
-
+ selected = "counts", |
|
| 994 | +446 | ! |
- teal::validate_inputs(iv_r_dist(), iv_dist)+ inline = TRUE |
| 995 | -! | +||
| 447 | +
- t_dist <- req(input$t_dist) # Not validated when tab is not selected+ ), |
||
| 996 | +448 | ! |
- qenv <- common_q()+ ui_decorate_teal_data(ns("dec_summary_table"), decorators = select_decorators(decorators, "summary_table"))
|
| 997 | +449 |
-
+ ), |
|
| 998 | +450 | ! |
- plot_call <- if (length(s_var) == 0 && length(g_var) == 0) {
+ teal.widgets::panel_item( |
| 999 | +451 | ! |
- substitute(+ title = "Plot settings", |
| 1000 | +452 | ! |
- expr = ggplot(ANL, aes_string(sample = dist_var)),+ selectInput( |
| 1001 | +453 | ! |
- env = list(dist_var = dist_var)- |
-
| 1002 | -- |
- )+ inputId = ns("ggtheme"),
|
|
| 1003 | +454 | ! |
- } else if (length(s_var) != 0 && length(g_var) == 0) {
+ label = "Theme (by ggplot):", |
| 1004 | +455 | ! |
- substitute(+ choices = ggplot_themes, |
| 1005 | +456 | ! |
- expr = ggplot(ANL, aes_string(sample = dist_var, color = s_var)),+ selected = ggtheme, |
| 1006 | +457 | ! |
- env = list(dist_var = dist_var, s_var = s_var)+ multiple = FALSE |
| 1007 | +458 |
- )+ ) |
|
| 1008 | -! | +||
| 459 | +
- } else if (length(s_var) == 0 && length(g_var) != 0) {
+ ) |
||
| 1009 | -! | +||
| 460 | +
- substitute(+ ) |
||
| 1010 | -! | +||
| 461 | +
- expr = ggplot(ANL[ANL[[g_var]] != "NA", ], aes_string(sample = dist_var)) ++ } |
||
| 1011 | -! | +||
| 462 | +
- facet_wrap(~g_var_name, ncol = 1, scales = scales_raw),+ |
||
| 1012 | -! | +||
| 463 | +
- env = list(+ # Server function for the missing data (single dataset) |
||
| 1013 | -! | +||
| 464 | +
- dist_var = dist_var,+ srv_missing_data <- function(id, |
||
| 1014 | -! | +||
| 465 | +
- g_var = g_var,+ data, |
||
| 1015 | -! | +||
| 466 | +
- g_var_name = g_var_name,+ reporter, |
||
| 1016 | -! | +||
| 467 | +
- scales_raw = tolower(scales_type)+ filter_panel_api, |
||
| 1017 | +468 |
- )+ dataname, |
|
| 1018 | +469 |
- )+ parent_dataname, |
|
| 1019 | +470 |
- } else {
+ plot_height, |
|
| 1020 | -! | +||
| 471 | +
- substitute(+ plot_width, |
||
| 1021 | -! | +||
| 472 | +
- expr = ggplot(ANL[ANL[[g_var]] != "NA", ], aes_string(sample = dist_var, color = s_var)) ++ ggplot2_args, |
||
| 1022 | -! | +||
| 473 | +
- facet_wrap(~g_var_name, ncol = 1, scales = scales_raw),+ decorators) {
|
||
| 1023 | +474 | ! |
- env = list(+ with_reporter <- !missing(reporter) && inherits(reporter, "Reporter") |
| 1024 | +475 | ! |
- dist_var = dist_var,+ with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI") |
| 1025 | +476 | ! |
- g_var = g_var,+ checkmate::assert_class(data, "reactive") |
| 1026 | +477 | ! |
- s_var = s_var,+ checkmate::assert_class(isolate(data()), "teal_data") |
| 1027 | +478 | ! |
- g_var_name = g_var_name,+ moduleServer(id, function(input, output, session) {
|
| 1028 | +479 | ! |
- scales_raw = tolower(scales_type)- |
-
| 1029 | -- |
- )- |
- |
| 1030 | -- |
- )- |
- |
| 1031 | -- |
- }+ ns <- session$ns |
|
| 1032 | +480 | ||
| 1033 | +481 | ! |
- map_dist <- stats::setNames(+ prev_group_by_var <- reactiveVal("")
|
| 1034 | +482 | ! |
- c("qnorm", "qlnorm", "qgamma", "qunif"),
+ data_r <- reactive(data()[[dataname]]) |
| 1035 | +483 | ! |
- c("normal", "lognormal", "gamma", "unif")
- |
-
| 1036 | -- |
- )+ data_keys <- reactive(unlist(teal.data::join_keys(data())[[dataname]])) |
|
| 1037 | +484 | ||
| 1038 | +485 | ! |
- plot_call <- substitute(+ iv_r <- reactive({
|
| 1039 | +486 | ! |
- expr = plot_call ++ iv <- shinyvalidate::InputValidator$new() |
| 1040 | +487 | ! |
- stat_qq(distribution = mapped_dist, dparams = params),+ iv$add_rule( |
| 1041 | +488 | ! |
- env = list(plot_call = plot_call, mapped_dist = as.name(unname(map_dist[t_dist])))+ "variables_select", |
| 1042 | -+ | ||
| 489 | +! |
- )+ shinyvalidate::sv_required("At least one reference variable needs to be selected.")
|
|
| 1043 | +490 |
-
+ ) |
|
| 1044 | +491 | ! |
- if (length(t_dist) != 0 && length(g_var) == 0 && length(s_var) == 0) {
+ iv$add_rule( |
| 1045 | +492 | ! |
- qenv <- teal.code::eval_code(+ "variables_select", |
| 1046 | +493 | ! |
- qenv,+ ~ if (length(setdiff((.), data_keys())) < 1) "Please also select non-key columns." |
| 1047 | -! | +||
| 494 | +
- substitute(+ ) |
||
| 1048 | +495 | ! |
- df_params <- as.data.frame(append(params, list(name = t_dist))),+ iv_summary_table <- shinyvalidate::InputValidator$new() |
| 1049 | +496 | ! |
- env = list(t_dist = t_dist)+ iv_summary_table$condition(~ isTRUE(input$summary_type == "By Variable Levels")) |
| 1050 | -+ | ||
| 497 | +! |
- )+ iv_summary_table$add_rule("count_type", shinyvalidate::sv_required("Please select type of counts"))
|
|
| 1051 | -+ | ||
| 498 | +! |
- )+ iv_summary_table$add_rule( |
|
| 1052 | +499 | ! |
- datas <- quote(data.frame(x = 0.7, y = 1, tb = I(list(df_params = df_params))))+ "group_by_vals", |
| 1053 | +500 | ! |
- label <- quote(tb)+ shinyvalidate::sv_required("Please select both group-by variable and values")
|
| 1054 | +501 |
-
+ ) |
|
| 1055 | +502 | ! |
- plot_call <- substitute(+ iv_summary_table$add_rule( |
| 1056 | +503 | ! |
- expr = plot_call ++ "group_by_var", |
| 1057 | +504 | ! |
- ggpp::geom_table_npc(+ ~ if (length(.) > 0 && length(input$variables_select) == 1 && (.) == input$variables_select) {
|
| 1058 | +505 | ! |
- data = data,+ "If only one reference variable is selected it must not be the grouping variable."+ |
+
| 506 | ++ |
+ }+ |
+ |
| 507 | ++ |
+ ) |
|
| 1059 | +508 | ! |
- aes(npcx = x, npcy = y, label = label),+ iv_summary_table$add_rule( |
| 1060 | +509 | ! |
- hjust = 0,+ "variables_select", |
| 1061 | +510 | ! |
- vjust = 1,+ ~ if (length(input$group_by_var) > 0 && length(.) == 1 && (.) == input$group_by_var) {
|
| 1062 | +511 | ! |
- size = 4+ "If only one reference variable is selected it must not be the grouping variable." |
| 1063 | +512 |
- ),+ } |
|
| 1064 | -! | +||
| 513 | +
- env = list(+ ) |
||
| 1065 | +514 | ! |
- plot_call = plot_call,+ iv$add_validator(iv_summary_table) |
| 1066 | +515 | ! |
- data = datas,+ iv$enable() |
| 1067 | +516 | ! |
- label = label- |
-
| 1068 | -- |
- )- |
- |
| 1069 | -- |
- )+ iv |
|
| 1070 | +517 |
- }+ }) |
|
| 1071 | +518 | ||
| 1072 | +519 | ! |
- if (isTRUE(input$qq_line)) {
+ data_parent_keys <- reactive({
|
| 1073 | +520 | ! |
- plot_call <- substitute(+ if (length(parent_dataname) > 0 && parent_dataname %in% names(data())) {
|
| 1074 | +521 | ! |
- expr = plot_call ++ keys <- teal.data::join_keys(data())[[dataname]] |
| 1075 | +522 | ! |
- stat_qq_line(distribution = mapped_dist, dparams = params),+ if (parent_dataname %in% names(keys)) {
|
| 1076 | +523 | ! |
- env = list(plot_call = plot_call, mapped_dist = as.name(unname(map_dist[t_dist])))+ keys[[parent_dataname]] |
| 1077 | +524 |
- )+ } else {
|
|
| 1078 | -+ | ||
| 525 | +! |
- }+ keys[[dataname]] |
|
| 1079 | +526 | - - | -|
| 1080 | -! | -
- all_ggplot2_args <- teal.widgets::resolve_ggplot2_args(+ } |
|
| 1081 | -! | +||
| 527 | +
- user_plot = ggplot2_args[["QQplot"]],+ } else {
|
||
| 1082 | +528 | ! |
- user_default = ggplot2_args$default,+ NULL |
| 1083 | -! | +||
| 529 | +
- module_plot = teal.widgets::ggplot2_args(labs = list(x = "theoretical", y = "sample"))+ } |
||
| 1084 | +530 |
- )+ }) |
|
| 1085 | +531 | ||
| 1086 | +532 | ! |
- parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(+ common_code_q <- reactive({
|
| 1087 | +533 | ! |
- all_ggplot2_args,+ teal::validate_inputs(iv_r())+ |
+
| 534 | ++ | + | |
| 1088 | +535 | ! |
- ggtheme = ggtheme+ group_var <- input$group_by_var |
| 1089 | -+ | ||
| 536 | +! |
- )+ anl <- data_r() |
|
| 1090 | +537 | ||
| 1091 | +538 | +! | +
+ qenv <- if (!is.null(selected_vars()) && length(selected_vars()) != ncol(anl)) {
+ |
+
| 539 | ! |
teal.code::eval_code( |
|
| 1092 | +540 | ! |
- qenv,+ data(), |
| 1093 | +541 | ! |
substitute( |
| 1094 | +542 | ! |
- expr = qq_plot <- plot_call,+ expr = ANL <- anl_name[, selected_vars, drop = FALSE], |
| 1095 | +543 | ! |
- env = list(plot_call = Reduce(function(x, y) call("+", x, y), c(plot_call, parsed_ggplot2_args)))
+ env = list(anl_name = as.name(dataname), selected_vars = selected_vars()) |
| 1096 | +544 |
) |
|
| 1097 | +545 |
) |
|
| 1098 | +546 |
- }+ } else {
+ |
+ |
| 547 | +! | +
+ teal.code::eval_code(+ |
+ |
| 548 | +! | +
+ data(),+ |
+ |
| 549 | +! | +
+ substitute(expr = ANL <- anl_name, env = list(anl_name = as.name(dataname))) |
|
| 1099 | +550 |
- )+ ) |
|
| 1100 | +551 |
-
+ } |
|
| 1101 | +552 |
- # test qenv ----+ |
|
| 1102 | +553 | ! |
- test_q <- eventReactive(+ if (input$summary_type == "By Variable Levels" && !is.null(group_var) && !(group_var %in% selected_vars())) {
|
| 1103 | +554 | ! |
- ignoreNULL = FALSE,+ qenv <- teal.code::eval_code( |
| 1104 | +555 | ! |
- eventExpr = {
+ qenv, |
| 1105 | +556 | ! |
- common_q()+ substitute( |
| 1106 | +557 | ! |
- input$dist_param1+ expr = ANL[[group_var]] <- anl_name[[group_var]], |
| 1107 | +558 | ! |
- input$dist_param2+ env = list(group_var = group_var, anl_name = as.name(dataname)) |
| 1108 | -! | +||
| 559 | +
- input$dist_tests+ ) |
||
| 1109 | +560 |
- },+ ) |
|
| 1110 | -! | +||
| 561 | +
- valueExpr = {
+ } |
||
| 1111 | +562 |
- # Create a private stack for this function only.+ |
|
| 1112 | +563 | ! |
- ANL <- common_q()[["ANL"]]+ new_col_name <- "**anyna**" |
| 1113 | +564 | ||
| 1114 | -! | -
- dist_var <- merge_vars()$dist_var- |
- |
| 1115 | +565 | ! |
- s_var <- merge_vars()$s_var+ qenv <- teal.code::eval_code( |
| 1116 | +566 | ! |
- g_var <- merge_vars()$g_var- |
-
| 1117 | -- |
-
+ qenv, |
|
| 1118 | +567 | ! |
- dist_var_name <- merge_vars()$dist_var_name+ substitute( |
| 1119 | +568 | ! |
- s_var_name <- merge_vars()$s_var_name+ expr = |
| 1120 | +569 | ! |
- g_var_name <- merge_vars()$g_var_name- |
-
| 1121 | -- |
-
+ create_cols_labels <- function(cols, just_label = FALSE) {
|
|
| 1122 | +570 | ! |
- dist_param1 <- input$dist_param1+ column_labels <- column_labels_value |
| 1123 | +571 | ! |
- dist_param2 <- input$dist_param2+ column_labels[is.na(column_labels) | length(column_labels) == 0] <- "" |
| 1124 | +572 | ! |
- dist_tests <- input$dist_tests+ if (just_label) {
|
| 1125 | +573 | ! |
- t_dist <- input$t_dist+ labels <- column_labels[cols] |
| 1126 | +574 |
-
+ } else {
|
|
| 1127 | +575 | ! |
- validate(need(dist_tests, "Please select a test"))+ labels <- ifelse(cols == new_col_name | cols == "", cols, paste0(column_labels[cols], " [", cols, "]")) |
| 1128 | +576 |
-
+ } |
|
| 1129 | +577 | ! |
- teal::validate_inputs(iv_dist)+ labels |
| 1130 | +578 |
-
+ }, |
|
| 1131 | +579 | ! |
- if (length(s_var) > 0 || length(g_var) > 0) {
+ env = list( |
| 1132 | +580 | ! |
- counts <- ANL %>%+ new_col_name = new_col_name, |
| 1133 | +581 | ! |
- dplyr::group_by_at(dplyr::vars(dplyr::any_of(c(s_var, g_var)))) %>%+ column_labels_value = c(teal.data::col_labels(data_r())[selected_vars()], |
| 1134 | +582 | ! |
- dplyr::summarise(n = dplyr::n())+ new_col_name = new_col_name |
| 1135 | +583 | - - | -|
| 1136 | -! | -
- validate(need(all(counts$n > 5), "Please select strata*group with at least 5 observation each."))+ ) |
|
| 1137 | +584 |
- }+ ) |
|
| 1138 | +585 |
-
+ ) |
|
| 1139 | +586 |
-
+ ) |
|
| 1140 | +587 | ! |
- if (dist_tests %in% c(+ qenv |
| 1141 | -! | +||
| 588 | +
- "t-test (two-samples, not paired)",+ }) |
||
| 1142 | -! | +||
| 589 | +
- "F-test",+ |
||
| 1143 | +590 | ! |
- "Kolmogorov-Smirnov (two-samples)"+ selected_vars <- reactive({
|
| 1144 | -+ | ||
| 591 | +! |
- )) {
+ req(input$variables_select) |
|
| 1145 | +592 | ! |
- if (length(g_var) == 0 && length(s_var) > 0) {
+ keys <- data_keys() |
| 1146 | +593 | ! |
- validate(need(+ vars <- unique(c(keys, input$variables_select)) |
| 1147 | +594 | ! |
- length(unique(ANL[[s_var]])) == 2,- |
-
| 1148 | -! | -
- "Please select stratify variable with 2 levels."+ vars |
|
| 1149 | +595 |
- ))+ }) |
|
| 1150 | +596 |
- }+ |
|
| 1151 | +597 | ! |
- if (length(g_var) > 0 && length(s_var) > 0) {
+ vars_summary <- reactive({
|
| 1152 | +598 | ! |
- validate(need(+ na_count <- data_r() %>% |
| 1153 | +599 | ! |
- all(stats::na.omit(as.vector(+ sapply(function(x) mean(is.na(x)), USE.NAMES = TRUE) %>% |
| 1154 | +600 | ! |
- tapply(ANL[[s_var]], list(ANL[[g_var]]), function(x) length(unique(x))) == 2+ sort(decreasing = TRUE) |
| 1155 | +601 |
- ))),+ |
|
| 1156 | +602 | ! |
- "Please select stratify variable with 2 levels, per each group."+ tibble::tibble(+ |
+
| 603 | +! | +
+ key = names(na_count),+ |
+ |
| 604 | +! | +
+ value = unname(na_count),+ |
+ |
| 605 | +! | +
+ label = cut(na_count, breaks = seq(from = 0, to = 1, by = 0.1), include.lowest = TRUE) |
|
| 1157 | +606 |
- ))+ ) |
|
| 1158 | +607 |
- }+ }) |
|
| 1159 | +608 |
- }+ |
|
| 1160 | +609 |
-
+ # Keep encoding panel up-to-date |
|
| 1161 | +610 | ! |
- map_dist <- stats::setNames(+ output$variables <- renderUI({
|
| 1162 | +611 | ! |
- c("pnorm", "plnorm", "pgamma", "punif"),
+ choices <- split(x = vars_summary()$key, f = vars_summary()$label, drop = TRUE) %>% rev() |
| 1163 | +612 | ! |
- c("normal", "lognormal", "gamma", "unif")
+ selected <- choices <- unname(unlist(choices)) |
| 1164 | +613 |
- )+ |
|
| 1165 | +614 | ! |
- sks_args <- list(+ teal.widgets::optionalSelectInput( |
| 1166 | +615 | ! |
- test = quote(stats::ks.test),+ ns("variables_select"),
|
| 1167 | +616 | ! |
- args = bquote(append(list(.[[.(dist_var)]], .(map_dist[t_dist])), params)),+ label = "Select variables", |
| 1168 | +617 | ! |
- groups = c(g_var, s_var)+ label_help = HTML(paste0("Dataset: ", tags$code(dataname))),
|
| 1169 | -+ | ||
| 618 | +! |
- )+ choices = teal.transform::variable_choices(data_r(), choices), |
|
| 1170 | +619 | ! |
- ssw_args <- list(+ selected = selected, |
| 1171 | +620 | ! |
- test = quote(stats::shapiro.test),+ multiple = TRUE |
| 1172 | -! | +||
| 621 | +
- args = bquote(list(.[[.(dist_var)]])),+ ) |
||
| 1173 | -! | +||
| 622 | +
- groups = c(g_var, s_var)+ }) |
||
| 1174 | +623 |
- )+ |
|
| 1175 | +624 | ! |
- mfil_args <- list(+ observeEvent(input$filter_na, {
|
| 1176 | +625 | ! |
- test = quote(stats::fligner.test),+ choices <- vars_summary() %>% |
| 1177 | +626 | ! |
- args = bquote(list(.[[.(dist_var)]], .[[.(s_var)]])),+ dplyr::select(!!as.name("key")) %>%
|
| 1178 | +627 | ! |
- groups = c(g_var)+ getElement(name = 1) |
| 1179 | +628 |
- )+ |
|
| 1180 | +629 | ! |
- sad_args <- list(+ selected <- vars_summary() %>% |
| 1181 | +630 | ! |
- test = quote(goftest::ad.test),+ dplyr::filter(!!as.name("value") > 0) %>%
|
| 1182 | +631 | ! |
- args = bquote(append(list(.[[.(dist_var)]], .(map_dist[t_dist])), params)),+ dplyr::select(!!as.name("key")) %>%
|
| 1183 | +632 | ! |
- groups = c(g_var, s_var)+ getElement(name = 1) |
| 1184 | +633 |
- )+ |
|
| 1185 | +634 | ! |
- scvm_args <- list(+ teal.widgets::updateOptionalSelectInput( |
| 1186 | +635 | ! |
- test = quote(goftest::cvm.test),+ session = session, |
| 1187 | +636 | ! |
- args = bquote(append(list(.[[.(dist_var)]], .(map_dist[t_dist])), params)),+ inputId = "variables_select", |
| 1188 | +637 | ! |
- groups = c(g_var, s_var)- |
-
| 1189 | -- |
- )+ choices = teal.transform::variable_choices(data_r()), |
|
| 1190 | +638 | ! |
- manov_args <- list(+ selected = restoreInput(ns("variables_select"), selected)
|
| 1191 | -! | +||
| 639 | +
- test = quote(stats::aov),+ ) |
||
| 1192 | -! | +||
| 640 | +
- args = bquote(list(stats::formula(.(dist_var_name) ~ .(s_var_name)), .)),+ }) |
||
| 1193 | -! | +||
| 641 | +
- groups = c(g_var)+ |
||
| 1194 | -+ | ||
| 642 | +! |
- )+ output$group_by_var_ui <- renderUI({
|
|
| 1195 | +643 | ! |
- mt_args <- list(+ all_choices <- teal.transform::variable_choices(data_r()) |
| 1196 | +644 | ! |
- test = quote(stats::t.test),+ cat_choices <- all_choices[!sapply(data_r(), function(x) is.numeric(x) || inherits(x, "POSIXct"))] |
| 1197 | +645 | ! |
- args = bquote(unname(split(.[[.(dist_var)]], .[[.(s_var)]], drop = TRUE))),+ validate( |
| 1198 | +646 | ! |
- groups = c(g_var)+ need(cat_choices, "Dataset does not have any non-numeric or non-datetime variables to use to group data with") |
| 1199 | +647 |
- )+ ) |
|
| 1200 | +648 | ! |
- mv_args <- list(+ teal.widgets::optionalSelectInput( |
| 1201 | +649 | ! |
- test = quote(stats::var.test),+ ns("group_by_var"),
|
| 1202 | +650 | ! |
- args = bquote(unname(split(.[[.(dist_var)]], .[[.(s_var)]], drop = TRUE))),+ label = "Group by variable", |
| 1203 | +651 | ! |
- groups = c(g_var)- |
-
| 1204 | -- |
- )+ choices = cat_choices, |
|
| 1205 | +652 | ! |
- mks_args <- list(+ selected = `if`( |
| 1206 | +653 | ! |
- test = quote(stats::ks.test),+ is.null(isolate(input$group_by_var)), |
| 1207 | +654 | ! |
- args = bquote(unname(split(.[[.(dist_var)]], .[[.(s_var)]], drop = TRUE))),+ cat_choices[1], |
| 1208 | +655 | ! |
- groups = c(g_var)+ isolate(input$group_by_var) |
| 1209 | +656 |
- )+ ), |
|
| 1210 | -+ | ||
| 657 | +! |
-
+ multiple = FALSE, |
|
| 1211 | +658 | ! |
- tests_base <- switch(dist_tests,+ label_help = paste0("Dataset: ", dataname)
|
| 1212 | -! | +||
| 659 | +
- "Kolmogorov-Smirnov (one-sample)" = sks_args,+ ) |
||
| 1213 | -! | +||
| 660 | +
- "Shapiro-Wilk" = ssw_args,+ }) |
||
| 1214 | -! | +||
| 661 | +
- "Fligner-Killeen" = mfil_args,+ |
||
| 1215 | +662 | ! |
- "one-way ANOVA" = manov_args,+ output$group_by_vals_ui <- renderUI({
|
| 1216 | +663 | ! |
- "t-test (two-samples, not paired)" = mt_args,+ req(input$group_by_var) |
| 1217 | -! | +||
| 664 | +
- "F-test" = mv_args,+ |
||
| 1218 | +665 | ! |
- "Kolmogorov-Smirnov (two-samples)" = mks_args,+ choices <- teal.transform::value_choices(data_r(), input$group_by_var, input$group_by_var) |
| 1219 | +666 | ! |
- "Anderson-Darling (one-sample)" = sad_args,+ prev_choices <- isolate(input$group_by_vals) |
| 1220 | -! | +||
| 667 | +
- "Cramer-von Mises (one-sample)" = scvm_args+ |
||
| 1221 | +668 |
- )+ # determine selected value based on filtered data |
|
| 1222 | +669 |
-
+ # display those previously selected values that are still available |
|
| 1223 | +670 | ! |
- env <- list(+ selected <- if (!is.null(prev_choices) && any(prev_choices %in% choices)) {
|
| 1224 | +671 | ! |
- t_test = t_dist,+ prev_choices[match(choices[choices %in% prev_choices], prev_choices)] |
| 1225 | +672 | ! |
- dist_var = dist_var,+ } else if ( |
| 1226 | +673 | ! |
- g_var = g_var,+ !is.null(prev_choices) && |
| 1227 | +674 | ! |
- s_var = s_var,+ !any(prev_choices %in% choices) && |
| 1228 | +675 | ! |
- args = tests_base$args,+ isolate(prev_group_by_var()) == input$group_by_var |
| 1229 | -! | +||
| 676 | +
- groups = tests_base$groups,+ ) {
|
||
| 1230 | -! | +||
| 677 | +
- test = tests_base$test,+ # if not any previously selected value is available and the grouping variable is the same, |
||
| 1231 | -! | +||
| 678 | +
- dist_var_name = dist_var_name,+ # then display NULL |
||
| 1232 | +679 | ! |
- g_var_name = g_var_name,+ NULL |
| 1233 | -! | +||
| 680 | +
- s_var_name = s_var_name+ } else {
|
||
| 1234 | +681 |
- )+ # if new grouping variable (i.e. not any previously selected value is available), |
|
| 1235 | +682 |
-
+ # then display all choices |
|
| 1236 | +683 | ! |
- qenv <- common_q()+ choices |
| 1237 | +684 | ++ |
+ }+ |
+
| 685 | |||
| 1238 | +686 | ! |
- if (length(s_var) == 0 && length(g_var) == 0) {
+ prev_group_by_var(input$group_by_var) # set current group_by_var |
| 1239 | +687 | ! |
- qenv <- teal.code::eval_code(+ validate(need(length(choices) < 100, "Please select group-by variable with fewer than 100 unique values")) |
| 1240 | +688 | ! |
- qenv,+ teal.widgets::optionalSelectInput( |
| 1241 | +689 | ! |
- substitute(+ ns("group_by_vals"),
|
| 1242 | +690 | ! |
- expr = {
+ label = "Filter levels", |
| 1243 | +691 | ! |
- test_table_data <- ANL %>%+ choices = choices, |
| 1244 | +692 | ! |
- dplyr::select(dist_var) %>%+ selected = selected, |
| 1245 | +693 | ! |
- with(., broom::glance(do.call(test, args))) %>%+ multiple = TRUE, |
| 1246 | +694 | ! |
- dplyr::mutate_if(is.numeric, round, 3)+ label_help = paste0("Dataset: ", dataname)
|
| 1247 | +695 |
- },- |
- |
| 1248 | -! | -
- env = env+ ) |
|
| 1249 | -- |
- )- |
- |
| 1250 | +696 |
- )+ }) |
|
| 1251 | +697 |
- } else {
+
|
|
| 1252 | +698 | ! |
- qenv <- teal.code::eval_code(+ combination_cutoff_q <- reactive({
|
| 1253 | +699 | ! |
- qenv,+ req(common_code_q()) |
| 1254 | +700 | ! |
- substitute(+ teal.code::eval_code( |
| 1255 | +701 | ! |
- expr = {
+ common_code_q(), |
| 1256 | +702 | ! |
- test_table_data <- ANL %>%+ quote( |
| 1257 | +703 | ! |
- dplyr::select(dist_var, s_var, g_var) %>%+ combination_cutoff <- ANL %>% |
| 1258 | +704 | ! |
- dplyr::group_by_at(dplyr::vars(dplyr::any_of(groups))) %>%+ dplyr::mutate_all(is.na) %>% |
| 1259 | +705 | ! |
- dplyr::do(tests = broom::glance(do.call(test, args))) %>%+ dplyr::group_by_all() %>% |
| 1260 | +706 | ! |
- tidyr::unnest(tests) %>%+ dplyr::tally() %>% |
| 1261 | +707 | ! |
- dplyr::mutate_if(is.numeric, round, 3)+ dplyr::ungroup() |
| 1262 | +708 |
- },- |
- |
| 1263 | -! | -
- env = env+ ) |
|
| 1264 | +709 |
- )+ ) |
|
| 1265 | +710 |
- )+ }) |
|
| 1266 | +711 |
- }+ |
|
| 1267 | -+ | ||
| 712 | +! |
- }+ output$cutoff <- renderUI({
|
|
| 1268 | -+ | ||
| 713 | +! |
- )+ x <- combination_cutoff_q()[["combination_cutoff"]]$n |
|
| 1269 | +714 | ||
| 1270 | +715 |
- # outputs ----+ # select 10-th from the top |
|
| 1271 | -+ | ||
| 716 | +! |
- ## building main qenv+ n <- length(x) |
|
| 1272 | +717 | ! |
- output_common_q <- reactive({
+ idx <- max(1, n - 10) |
| 1273 | -+ | ||
| 718 | +! |
- # wrapped in if since could lead into validate error - we do want to continue+ prev_value <- isolate(input$combination_cutoff) |
|
| 1274 | +719 | ! |
- test_q_out <- try(test_q(), silent = TRUE)+ value <- if (is.null(prev_value) || prev_value > max(x) || prev_value < min(x)) {
|
| 1275 | +720 | ! |
- if (!inherits(test_q_out, c("try-error", "error"))) {
+ sort(x, partial = idx)[idx] |
| 1276 | -! | +||
| 721 | +
- c(+ } else {
|
||
| 1277 | +722 | ! |
- common_q(),+ prev_value |
| 1278 | -! | +||
| 723 | +
- within(test_q_out, {
+ } |
||
| 1279 | -! | +||
| 724 | +
- test_table <- DT::datatable(+ |
||
| 1280 | +725 | ! |
- test_table_data,+ teal.widgets::optionalSliderInputValMinMax( |
| 1281 | +726 | ! |
- options = list(scrollX = TRUE),+ ns("combination_cutoff"),
|
| 1282 | +727 | ! |
- rownames = FALSE+ "Combination cut-off", |
| 1283 | -+ | ||
| 728 | +! |
- )+ c(value, range(x)) |
|
| 1284 | +729 |
- })+ ) |
|
| 1285 | +730 |
- )+ }) |
|
| 1286 | +731 |
- } else {
- |
- |
| 1287 | -! | -
- within(common_q(), test_table <- NULL)+ |
|
| 1288 | +732 |
- }+ # Prepare qenvs for output objects |
|
| 1289 | +733 |
- })+ |
|
| 1290 | -+ | ||
| 734 | +! |
-
+ summary_plot_q <- reactive({
|
|
| 1291 | +735 | ! |
- output_dist_q <- reactive(c(output_common_q(), req(dist_q())))+ req(input$summary_type == "Summary") # needed to trigger show r code update on tab change |
| 1292 | +736 | ! |
- output_qq_q <- reactive(c(output_common_q(), req(qq_q())))+ teal::validate_has_data(data_r(), 1) |
| 1293 | +737 | ||
| 1294 | +738 | ! |
- decorated_output_dist_q <- srv_decorate_teal_data(+ qenv <- common_code_q() |
| 1295 | +739 | ! |
- "d_density",+ if (input$any_na) {
|
| 1296 | +740 | ! |
- data = output_dist_q,+ new_col_name <- "**anyna**" |
| 1297 | +741 | ! |
- decorators = select_decorators(decorators, "histogram_plot"),+ qenv <- teal.code::eval_code( |
| 1298 | +742 | ! |
- expr = print(histogram_plot)- |
-
| 1299 | -- |
- )- |
- |
| 1300 | -- |
-
+ qenv, |
|
| 1301 | +743 | ! |
- decorated_output_qq_q <- srv_decorate_teal_data(+ substitute( |
| 1302 | +744 | ! |
- "d_qq",+ expr = ANL[[new_col_name]] <- ifelse(rowSums(is.na(ANL)) > 0, NA, FALSE), |
| 1303 | +745 | ! |
- data = output_qq_q,+ env = list(new_col_name = new_col_name) |
| 1304 | -! | +||
| 746 | +
- decorators = select_decorators(decorators, "qq_plot"),+ ) |
||
| 1305 | -! | +||
| 747 | +
- expr = print(qq_plot)+ ) |
||
| 1306 | +748 |
- )+ } |
|
| 1307 | +749 | ||
| 1308 | +750 | ! |
- decorated_output_summary_q <- srv_decorate_teal_data(+ qenv <- teal.code::eval_code( |
| 1309 | +751 | ! |
- "d_summary",+ qenv, |
| 1310 | +752 | ! |
- data = output_common_q,+ substitute( |
| 1311 | +753 | ! |
- decorators = select_decorators(decorators, "summary_table"),+ expr = analysis_vars <- setdiff(colnames(ANL), data_keys), |
| 1312 | +754 | ! |
- expr = summary_table+ env = list(data_keys = data_keys()) |
| 1313 | +755 |
- )+ ) |
|
| 1314 | +756 |
-
+ ) %>% |
|
| 1315 | +757 | ! |
- decorated_output_test_q <- srv_decorate_teal_data(+ teal.code::eval_code( |
| 1316 | +758 | ! |
- "d_test",+ substitute( |
| 1317 | +759 | ! |
- data = output_common_q,+ expr = summary_plot_obs <- data_frame_call[, analysis_vars] %>% |
| 1318 | +760 | ! |
- decorators = select_decorators(decorators, "test_table"),+ dplyr::summarise_all(list(function(x) sum(is.na(x)))) %>% |
| 1319 | +761 | ! |
- expr = test_table- |
-
| 1320 | -- |
- )- |
- |
| 1321 | -- |
-
+ tidyr::pivot_longer(dplyr::everything(), names_to = "col", values_to = "n_na") %>% |
|
| 1322 | +762 | ! |
- decorated_output_q <- reactive({
+ dplyr::mutate(n_not_na = nrow(ANL) - n_na) %>% |
| 1323 | +763 | ! |
- tab <- req(input$tabs) # tab is NULL upon app launch, hence will crash without this statement+ tidyr::pivot_longer(-col, names_to = "isna", values_to = "n") %>% |
| 1324 | +764 | ! |
- test_q_out <- try(test_q(), silent = TRUE)+ dplyr::mutate(isna = isna == "n_na", n_pct = n / nrow(ANL) * 100), |
| 1325 | +765 | ! |
- decorated_test_q_out <- if (inherits(test_q_out, c("try-error", "error"))) {
+ env = list(data_frame_call = if (!inherits(data_r(), "tbl_df")) {
|
| 1326 | +766 | ! |
- teal.code::qenv()+ quote(tibble::as_tibble(ANL)) |
| 1327 | +767 |
- } else {
+ } else {
|
|
| 1328 | +768 | ! |
- decorated_output_test_q()+ quote(ANL) |
| 1329 | +769 |
- }+ }) |
|
| 1330 | +770 |
-
+ ) |
|
| 1331 | -! | +||
| 771 | +
- out_q <- switch(tab,+ ) %>% |
||
| 1332 | -! | +||
| 772 | +
- Histogram = decorated_output_dist_q(),+ # x axis ordering according to number of missing values and alphabet |
||
| 1333 | +773 | ! |
- QQplot = decorated_output_qq_q()+ teal.code::eval_code( |
| 1334 | -+ | ||
| 774 | +! |
- )+ quote( |
|
| 1335 | +775 | ! |
- c(out_q, decorated_output_summary_q(), decorated_test_q_out)+ expr = x_levels <- dplyr::filter(summary_plot_obs, isna) %>% |
| 1336 | -+ | ||
| 776 | +! |
- })+ dplyr::arrange(n_pct, dplyr::desc(col)) %>% |
|
| 1337 | -+ | ||
| 777 | +! |
-
+ dplyr::pull(col) %>% |
|
| 1338 | +778 | ! |
- dist_r <- reactive(req(decorated_output_dist_q())[["histogram_plot"]])+ create_cols_labels() |
| 1339 | +779 |
-
+ ) |
|
| 1340 | -! | +||
| 780 | +
- qq_r <- reactive(req(decorated_output_qq_q())[["qq_plot"]])+ ) |
||
| 1341 | +781 | ||
| 1342 | -! | -
- output$summary_table <- DT::renderDataTable(expr = decorated_output_summary_q()[["summary_table"]])- |
- |
| 1343 | +782 |
-
+ # always set "**anyna**" level as the last one |
|
| 1344 | +783 | ! |
- tests_r <- reactive({
+ if (isolate(input$any_na)) {
|
| 1345 | +784 | ! |
- req(iv_r()$is_valid())+ qenv <- teal.code::eval_code( |
| 1346 | +785 | ! |
- teal::validate_inputs(iv_r_dist())+ qenv, |
| 1347 | +786 | ! |
- req(test_q()) # Ensure original errors are displayed+ quote(x_levels <- c(setdiff(x_levels, "**anyna**"), "**anyna**")) |
| 1348 | -! | +||
| 787 | +
- decorated_output_test_q()[["test_table"]]+ ) |
||
| 1349 | +788 |
- })+ } |
|
| 1350 | +789 | ||
| 1351 | +790 | ! |
- pws1 <- teal.widgets::plot_with_settings_srv(+ dev_ggplot2_args <- teal.widgets::ggplot2_args( |
| 1352 | +791 | ! |
- id = "hist_plot",+ labs = list(x = "Variable", y = "Missing observations"), |
| 1353 | +792 | ! |
- plot_r = dist_r,+ theme = list(legend.position = "bottom", axis.text.x = quote(element_text(angle = 45, hjust = 1))) |
| 1354 | -! | +||
| 793 | +
- height = plot_height,+ )+ |
+ ||
| 794 | ++ | + | |
| 1355 | +795 | ! |
- width = plot_width,+ all_ggplot2_args <- teal.widgets::resolve_ggplot2_args( |
| 1356 | +796 | ! |
- brushing = FALSE+ user_plot = ggplot2_args[["Summary Obs"]],+ |
+
| 797 | +! | +
+ user_default = ggplot2_args$default,+ |
+ |
| 798 | +! | +
+ module_plot = dev_ggplot2_args |
|
| 1357 | +799 |
- )+ ) |
|
| 1358 | +800 | ||
| 1359 | +801 | ! |
- pws2 <- teal.widgets::plot_with_settings_srv(+ parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args( |
| 1360 | +802 | ! |
- id = "qq_plot",+ all_ggplot2_args, |
| 1361 | +803 | ! |
- plot_r = qq_r,+ ggtheme = input$ggtheme+ |
+
| 804 | ++ |
+ )+ |
+ |
| 805 | ++ | + | |
| 1362 | +806 | ! |
- height = plot_height,+ qenv <- teal.code::eval_code( |
| 1363 | +807 | ! |
- width = plot_width,+ qenv, |
| 1364 | +808 | ! |
- brushing = FALSE+ substitute( |
| 1365 | -+ | ||
| 809 | +! |
- )+ summary_plot_top <- summary_plot_obs %>% |
|
| 1366 | -+ | ||
| 810 | +! |
-
+ ggplot() + |
|
| 1367 | +811 | ! |
- output$t_stats <- DT::renderDataTable(+ aes( |
| 1368 | +812 | ! |
- expr = tests_r()+ x = factor(create_cols_labels(col), levels = x_levels), |
| 1369 | -+ | ||
| 813 | +! |
- )+ y = n_pct,+ |
+ |
| 814 | +! | +
+ fill = isna |
|
| 1370 | +815 |
-
+ ) + |
|
| 1371 | +816 | ! |
- teal.widgets::verbatim_popup_srv(+ geom_bar(position = "fill", stat = "identity") + |
| 1372 | +817 | ! |
- id = "rcode",+ scale_fill_manual( |
| 1373 | +818 | ! |
- verbatim_content = reactive(teal.code::get_code(req(decorated_output_q()))),+ name = "", |
| 1374 | +819 | ! |
- title = "R Code for distribution"+ values = c("grey90", c(getOption("ggplot2.discrete.colour")[2], "#ff2951ff")[1]),
|
| 1375 | -+ | ||
| 820 | +! |
- )+ labels = c("Present", "Missing")
|
|
| 1376 | +821 |
-
+ ) + |
|
| 1377 | -+ | ||
| 822 | +! |
- ### REPORTER+ scale_y_continuous( |
|
| 1378 | +823 | ! |
- if (with_reporter) {
+ labels = scales::percent_format(), |
| 1379 | +824 | ! |
- card_fun <- function(comment, label) {
+ breaks = seq(0, 1, by = 0.1), |
| 1380 | +825 | ! |
- card <- teal::report_card_template(+ expand = c(0, 0)+ |
+
| 826 | ++ |
+ ) + |
|
| 1381 | +827 | ! |
- title = "Distribution Plot",+ geom_text( |
| 1382 | +828 | ! |
- label = label,+ aes(label = ifelse(isna == TRUE, sprintf("%d [%.02f%%]", n, n_pct), ""), y = 1),
|
| 1383 | +829 | ! |
- with_filter = with_filter,+ hjust = 1, |
| 1384 | +830 | ! |
- filter_panel_api = filter_panel_api+ color = "black" |
| 1385 | +831 |
- )+ ) + |
|
| 1386 | +832 | ! |
- card$append_text("Plot", "header3")
+ labs + |
| 1387 | +833 | ! |
- if (input$tabs == "Histogram") {
+ ggthemes + |
| 1388 | +834 | ! |
- card$append_plot(dist_r(), dim = pws1$dim())+ themes + |
| 1389 | +835 | ! |
- } else if (input$tabs == "QQplot") {
+ coord_flip(), |
| 1390 | +836 | ! |
- card$append_plot(qq_r(), dim = pws2$dim())+ env = list( |
| 1391 | -+ | ||
| 837 | +! |
- }+ labs = parsed_ggplot2_args$labs, |
|
| 1392 | +838 | ! |
- card$append_text("Statistics table", "header3")
+ themes = parsed_ggplot2_args$theme,+ |
+
| 839 | +! | +
+ ggthemes = parsed_ggplot2_args$ggtheme |
|
| 1393 | +840 | ++ |
+ )+ |
+
| 841 | ++ |
+ )+ |
+ |
| 842 | ++ |
+ )+ |
+ |
| 843 | |||
| 1394 | +844 | ! |
- card$append_table(common_q()[["summary_table"]])+ if (isTRUE(input$if_patients_plot)) {
|
| 1395 | +845 | ! |
- tests_error <- tryCatch(expr = tests_r(), error = function(e) "error")+ qenv <- teal.code::eval_code( |
| 1396 | +846 | ! |
- if (inherits(tests_error, "data.frame")) {
+ qenv, |
| 1397 | +847 | ! |
- card$append_text("Tests table", "header3")
+ substitute( |
| 1398 | +848 | ! |
- card$append_table(tests_r())+ expr = parent_keys <- keys,+ |
+
| 849 | +! | +
+ env = list(keys = data_parent_keys()) |
|
| 1399 | +850 |
- }+ ) |
|
| 1400 | +851 |
-
+ ) %>% |
|
| 1401 | +852 | ! |
- if (!comment == "") {
+ teal.code::eval_code(quote(ndistinct_subjects <- dplyr::n_distinct(ANL[, parent_keys]))) %>% |
| 1402 | +853 | ! |
- card$append_text("Comment", "header3")
+ teal.code::eval_code( |
| 1403 | +854 | ! |
- card$append_text(comment)+ quote( |
| 1404 | -+ | ||
| 855 | +! |
- }+ summary_plot_patients <- ANL[, c(parent_keys, analysis_vars)] %>% |
|
| 1405 | +856 | ! |
- card$append_src(teal.code::get_code(req(decorated_output_q())))+ dplyr::group_by_at(parent_keys) %>% |
| 1406 | +857 | ! |
- card+ dplyr::summarise_all(anyNA) %>% |
| 1407 | -+ | ||
| 858 | +! |
- }+ tidyr::pivot_longer(cols = !dplyr::all_of(parent_keys), names_to = "col", values_to = "anyna") %>% |
|
| 1408 | +859 | ! |
- teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
+ dplyr::group_by_at(c("col")) %>%
|
| 1409 | -+ | ||
| 860 | +! |
- }+ dplyr::summarise(count_na = sum(anyna)) %>% |
|
| 1410 | -+ | ||
| 861 | +! |
- ###+ dplyr::mutate(count_not_na = ndistinct_subjects - count_na) %>% |
|
| 1411 | -+ | ||
| 862 | +! |
- })+ tidyr::pivot_longer(-c(col), names_to = "isna", values_to = "n") %>% |
|
| 1412 | -+ | ||
| 863 | +! |
- }+ dplyr::mutate(isna = isna == "count_na", n_pct = n / ndistinct_subjects * 100) %>% |
| 1 | -+ | ||
| 864 | +! |
- #' `teal` module: Stack plots of variables and show association with reference variable+ dplyr::arrange_at(c("isna", "n"), .funs = dplyr::desc)
|
|
| 2 | +865 |
- #'+ ) |
|
| 3 | +866 |
- #' Module provides functionality for visualizing the distribution of variables and+ ) |
|
| 4 | +867 |
- #' their association with a reference variable.+ |
|
| 5 | -+ | ||
| 868 | +! |
- #' It supports configuring the appearance of the plots, including themes and whether to show associations.+ dev_ggplot2_args <- teal.widgets::ggplot2_args( |
|
| 6 | -+ | ||
| 869 | +! |
- #'+ labs = list(x = "", y = "Missing patients"), |
|
| 7 | -+ | ||
| 870 | +! |
- #'+ theme = list( |
|
| 8 | -+ | ||
| 871 | +! |
- #' @note For more examples, please see the vignette "Using association plot" via+ legend.position = "bottom", |
|
| 9 | -+ | ||
| 872 | +! |
- #' `vignette("using-association-plot", package = "teal.modules.general")`.
+ axis.text.x = quote(element_text(angle = 45, hjust = 1)), |
|
| 10 | -+ | ||
| 873 | +! |
- #'+ axis.text.y = quote(element_blank()) |
|
| 11 | +874 |
- #' @inheritParams teal::module+ ) |
|
| 12 | +875 |
- #' @inheritParams shared_params+ ) |
|
| 13 | +876 |
- #' @param ref (`data_extract_spec` or `list` of multiple `data_extract_spec`)+ |
|
| 14 | -+ | ||
| 877 | +! |
- #' Reference variable, must accepts a `data_extract_spec` with `select_spec(multiple = FALSE)`+ all_ggplot2_args <- teal.widgets::resolve_ggplot2_args( |
|
| 15 | -+ | ||
| 878 | +! |
- #' to ensure single selection option.+ user_plot = ggplot2_args[["Summary Patients"]], |
|
| 16 | -+ | ||
| 879 | +! |
- #' @param vars (`data_extract_spec` or `list` of multiple `data_extract_spec`)+ user_default = ggplot2_args$default, |
|
| 17 | -+ | ||
| 880 | +! |
- #' Variables to be associated with the reference variable.+ module_plot = dev_ggplot2_args |
|
| 18 | +881 |
- #' @param show_association (`logical`) optional, whether show association of `vars`+ ) |
|
| 19 | +882 |
- #' with reference variable. Defaults to `TRUE`.+ |
|
| 20 | -+ | ||
| 883 | +! |
- #' @param distribution_theme,association_theme (`character`) optional, `ggplot2` themes to be used by default.+ parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args( |
|
| 21 | -+ | ||
| 884 | +! |
- #' Default to `"gray"`.+ all_ggplot2_args, |
|
| 22 | -+ | ||
| 885 | +! |
- #'+ ggtheme = input$ggtheme |
|
| 23 | +886 |
- #' @param ggplot2_args `r roxygen_ggplot2_args_param("Bivariate1", "Bivariate2")`
+ ) |
|
| 24 | +887 |
- #' @param decorators `r roxygen_decorators_param("tm_g_association")`
+
|
|
| 25 | -+ | ||
| 888 | +! |
- #'+ qenv <- teal.code::eval_code( |
|
| 26 | -+ | ||
| 889 | +! |
- #' @inherit shared_params return+ qenv, |
|
| 27 | -+ | ||
| 890 | +! |
- #'+ substitute( |
|
| 28 | -+ | ||
| 891 | +! |
- #' @section Decorating `tm_g_association`:+ summary_plot_bottom <- summary_plot_patients %>% |
|
| 29 | -+ | ||
| 892 | +! |
- #'+ ggplot() + |
|
| 30 | -+ | ||
| 893 | +! |
- #' This module generates the following objects, which can be modified in place using decorators:+ aes_( |
|
| 31 | -+ | ||
| 894 | +! |
- #' - `plot` (`grob` created with [ggplot2::ggplotGrob()])+ x = ~ factor(create_cols_labels(col), levels = x_levels), |
|
| 32 | -+ | ||
| 895 | +! |
- #'+ y = ~n_pct, |
|
| 33 | -+ | ||
| 896 | +! |
- #' For additional details and examples of decorators, refer to the vignette+ fill = ~isna |
|
| 34 | +897 |
- #' `vignette("decorate-modules-output", package = "teal")` or the [`teal::teal_transform_module()`] documentation.
+ ) + |
|
| 35 | -+ | ||
| 898 | +! |
- #'+ geom_bar(alpha = 1, stat = "identity", position = "fill") + |
|
| 36 | -+ | ||
| 899 | +! |
- #' @examplesShinylive+ scale_y_continuous( |
|
| 37 | -+ | ||
| 900 | +! |
- #' library(teal.modules.general)+ labels = scales::percent_format(), |
|
| 38 | -+ | ||
| 901 | +! |
- #' interactive <- function() TRUE+ breaks = seq(0, 1, by = 0.1), |
|
| 39 | -+ | ||
| 902 | +! |
- #' {{ next_example }}
+ expand = c(0, 0) |
|
| 40 | +903 |
- #' @examples+ ) + |
|
| 41 | -+ | ||
| 904 | +! |
- #' # general data example+ scale_fill_manual( |
|
| 42 | -+ | ||
| 905 | +! |
- #' data <- teal_data()+ name = "", |
|
| 43 | -+ | ||
| 906 | +! |
- #' data <- within(data, {
+ values = c("grey90", c(getOption("ggplot2.discrete.colour")[2], "#ff2951ff")[1]),
|
|
| 44 | -+ | ||
| 907 | +! |
- #' require(nestcolor)+ labels = c("Present", "Missing")
|
|
| 45 | +908 |
- #' CO2 <- CO2+ ) + |
|
| 46 | -+ | ||
| 909 | +! |
- #' factors <- names(Filter(isTRUE, vapply(CO2, is.factor, logical(1L))))+ geom_text( |
|
| 47 | -+ | ||
| 910 | +! |
- #' CO2[factors] <- lapply(CO2[factors], as.character)+ aes(label = ifelse(isna == TRUE, sprintf("%d [%.02f%%]", n, n_pct), ""), y = 1),
|
|
| 48 | -+ | ||
| 911 | +! |
- #' })+ hjust = 1, |
|
| 49 | -+ | ||
| 912 | +! |
- #'+ color = "black" |
|
| 50 | +913 |
- #' app <- init(+ ) + |
|
| 51 | -+ | ||
| 914 | +! |
- #' data = data,+ labs + |
|
| 52 | -+ | ||
| 915 | +! |
- #' modules = modules(+ ggthemes + |
|
| 53 | -+ | ||
| 916 | +! |
- #' tm_g_association(+ themes + |
|
| 54 | -+ | ||
| 917 | +! |
- #' ref = data_extract_spec(+ coord_flip(), |
|
| 55 | -+ | ||
| 918 | +! |
- #' dataname = "CO2",+ env = list( |
|
| 56 | -+ | ||
| 919 | +! |
- #' select = select_spec(+ labs = parsed_ggplot2_args$labs, |
|
| 57 | -+ | ||
| 920 | +! |
- #' label = "Select variable:",+ themes = parsed_ggplot2_args$theme, |
|
| 58 | -+ | ||
| 921 | +! |
- #' choices = variable_choices(data[["CO2"]], c("Plant", "Type", "Treatment")),
+ ggthemes = parsed_ggplot2_args$ggtheme |
|
| 59 | +922 |
- #' selected = "Plant",+ ) |
|
| 60 | +923 |
- #' fixed = FALSE+ ) |
|
| 61 | +924 |
- #' )+ ) |
|
| 62 | +925 |
- #' ),+ } |
|
| 63 | +926 |
- #' vars = data_extract_spec(+ |
|
| 64 | -+ | ||
| 927 | +! |
- #' dataname = "CO2",+ if (isTRUE(input$if_patients_plot)) {
|
|
| 65 | -+ | ||
| 928 | +! |
- #' select = select_spec(+ within(qenv, {
|
|
| 66 | -+ | ||
| 929 | +! |
- #' label = "Select variables:",+ g1 <- ggplotGrob(summary_plot_top) |
|
| 67 | -+ | ||
| 930 | +! |
- #' choices = variable_choices(data[["CO2"]], c("Plant", "Type", "Treatment")),
+ g2 <- ggplotGrob(summary_plot_bottom) |
|
| 68 | -+ | ||
| 931 | +! |
- #' selected = "Treatment",+ summary_plot <- gridExtra::gtable_cbind(g1, g2, size = "first") |
|
| 69 | -+ | ||
| 932 | +! |
- #' multiple = TRUE,+ summary_plot$heights <- grid::unit.pmax(g1$heights, g2$heights) |
|
| 70 | +933 |
- #' fixed = FALSE+ }) |
|
| 71 | +934 |
- #' )+ } else {
|
|
| 72 | -+ | ||
| 935 | +! |
- #' )+ within(qenv, {
|
|
| 73 | -+ | ||
| 936 | +! |
- #' )+ g1 <- ggplotGrob(summary_plot_top) |
|
| 74 | -+ | ||
| 937 | +! |
- #' )+ summary_plot <- g1 |
|
| 75 | +938 |
- #' )+ }) |
|
| 76 | +939 |
- #' if (interactive()) {
+ } |
|
| 77 | +940 |
- #' shinyApp(app$ui, app$server)+ }) |
|
| 78 | +941 |
- #' }+ |
|
| 79 | -+ | ||
| 942 | +! |
- #'+ combination_plot_q <- reactive({
|
|
| 80 | -+ | ||
| 943 | +! |
- #' @examplesShinylive+ req(input$summary_type == "Combinations", input$combination_cutoff, combination_cutoff_q()) |
|
| 81 | -+ | ||
| 944 | +! |
- #' library(teal.modules.general)+ teal::validate_has_data(data_r(), 1) |
|
| 82 | +945 |
- #' interactive <- function() TRUE+ |
|
| 83 | -+ | ||
| 946 | +! |
- #' {{ next_example }}
+ qenv <- teal.code::eval_code( |
|
| 84 | -+ | ||
| 947 | +! |
- #' @examples+ combination_cutoff_q(), |
|
| 85 | -+ | ||
| 948 | +! |
- #' # CDISC data example+ substitute( |
|
| 86 | -+ | ||
| 949 | +! |
- #' data <- teal_data()+ expr = data_combination_plot_cutoff <- combination_cutoff %>% |
|
| 87 | -+ | ||
| 950 | +! |
- #' data <- within(data, {
+ dplyr::filter(n >= combination_cutoff_value) %>% |
|
| 88 | -+ | ||
| 951 | +! |
- #' require(nestcolor)+ dplyr::mutate(id = rank(-n, ties.method = "first")) %>% |
|
| 89 | -+ | ||
| 952 | +! |
- #' ADSL <- rADSL+ tidyr::pivot_longer(-c(n, id), names_to = "key", values_to = "value") %>% |
|
| 90 | -+ | ||
| 953 | +! |
- #' })+ dplyr::arrange(n), |
|
| 91 | -+ | ||
| 954 | +! |
- #' join_keys(data) <- default_cdisc_join_keys[names(data)]+ env = list(combination_cutoff_value = input$combination_cutoff) |
|
| 92 | +955 |
- #'+ ) |
|
| 93 | +956 |
- #' app <- init(+ ) |
|
| 94 | +957 |
- #' data = data,+ |
|
| 95 | +958 |
- #' modules = modules(+ # find keys in dataset not selected in the UI and remove them from dataset |
|
| 96 | -+ | ||
| 959 | +! |
- #' tm_g_association(+ keys_not_selected <- setdiff(data_keys(), input$variables_select) |
|
| 97 | -+ | ||
| 960 | +! |
- #' ref = data_extract_spec(+ if (length(keys_not_selected) > 0) {
|
|
| 98 | -+ | ||
| 961 | +! |
- #' dataname = "ADSL",+ qenv <- teal.code::eval_code( |
|
| 99 | -+ | ||
| 962 | +! |
- #' select = select_spec(+ qenv, |
|
| 100 | -+ | ||
| 963 | +! |
- #' label = "Select variable:",+ substitute( |
|
| 101 | -+ | ||
| 964 | +! |
- #' choices = variable_choices(+ expr = data_combination_plot_cutoff <- data_combination_plot_cutoff %>% |
|
| 102 | -+ | ||
| 965 | +! |
- #' data[["ADSL"]],+ dplyr::filter(!key %in% keys_not_selected), |
|
| 103 | -+ | ||
| 966 | +! |
- #' c("SEX", "RACE", "COUNTRY", "ARM", "STRATA1", "STRATA2", "ITTFL", "BMRKR2")
+ env = list(keys_not_selected = keys_not_selected) |
|
| 104 | +967 |
- #' ),+ ) |
|
| 105 | +968 |
- #' selected = "RACE",+ ) |
|
| 106 | +969 |
- #' fixed = FALSE+ } |
|
| 107 | +970 |
- #' )+ |
|
| 108 | -+ | ||
| 971 | +! |
- #' ),+ qenv <- teal.code::eval_code( |
|
| 109 | -+ | ||
| 972 | +! |
- #' vars = data_extract_spec(+ qenv, |
|
| 110 | -+ | ||
| 973 | +! |
- #' dataname = "ADSL",+ quote( |
|
| 111 | -+ | ||
| 974 | +! |
- #' select = select_spec(+ labels <- data_combination_plot_cutoff %>% |
|
| 112 | -+ | ||
| 975 | +! |
- #' label = "Select variables:",+ dplyr::filter(key == key[[1]]) %>% |
|
| 113 | -+ | ||
| 976 | +! |
- #' choices = variable_choices(+ getElement(name = 1) |
|
| 114 | +977 |
- #' data[["ADSL"]],+ ) |
|
| 115 | +978 |
- #' c("SEX", "RACE", "COUNTRY", "ARM", "STRATA1", "STRATA2", "ITTFL", "BMRKR2")
+ ) |
|
| 116 | +979 |
- #' ),+ |
|
| 117 | -+ | ||
| 980 | +! |
- #' selected = "BMRKR2",+ dev_ggplot2_args1 <- teal.widgets::ggplot2_args( |
|
| 118 | -+ | ||
| 981 | +! |
- #' multiple = TRUE,+ labs = list(x = "", y = ""), |
|
| 119 | -+ | ||
| 982 | +! |
- #' fixed = FALSE+ theme = list( |
|
| 120 | -+ | ||
| 983 | +! |
- #' )+ legend.position = "bottom", |
|
| 121 | -+ | ||
| 984 | +! |
- #' )+ axis.text.x = quote(element_blank()) |
|
| 122 | +985 |
- #' )+ ) |
|
| 123 | +986 |
- #' )+ ) |
|
| 124 | +987 |
- #' )+ |
|
| 125 | -+ | ||
| 988 | +! |
- #' if (interactive()) {
+ all_ggplot2_args1 <- teal.widgets::resolve_ggplot2_args( |
|
| 126 | -+ | ||
| 989 | +! |
- #' shinyApp(app$ui, app$server)+ user_plot = ggplot2_args[["Combinations Hist"]], |
|
| 127 | -+ | ||
| 990 | +! |
- #' }+ user_default = ggplot2_args$default, |
|
| 128 | -+ | ||
| 991 | +! |
- #'+ module_plot = dev_ggplot2_args1 |
|
| 129 | +992 |
- #' @export+ ) |
|
| 130 | +993 |
- #'+ |
|
| 131 | -+ | ||
| 994 | +! |
- tm_g_association <- function(label = "Association",+ parsed_ggplot2_args1 <- teal.widgets::parse_ggplot2_args( |
|
| 132 | -+ | ||
| 995 | +! |
- ref,+ all_ggplot2_args1, |
|
| 133 | -+ | ||
| 996 | +! |
- vars,+ ggtheme = "void" |
|
| 134 | +997 |
- show_association = TRUE,+ ) |
|
| 135 | +998 |
- plot_height = c(600, 400, 5000),+ |
|
| 136 | -+ | ||
| 999 | +! |
- plot_width = NULL,+ dev_ggplot2_args2 <- teal.widgets::ggplot2_args( |
|
| 137 | -+ | ||
| 1000 | +! |
- distribution_theme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void"), # nolint: line_length.
+ labs = list(x = "", y = ""), |
|
| 138 | -+ | ||
| 1001 | +! |
- association_theme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void"), # nolint: line_length.
+ theme = list( |
|
| 139 | -+ | ||
| 1002 | +! |
- pre_output = NULL,+ legend.position = "bottom", |
|
| 140 | -+ | ||
| 1003 | +! |
- post_output = NULL,+ axis.text.x = quote(element_blank()), |
|
| 141 | -+ | ||
| 1004 | +! |
- ggplot2_args = teal.widgets::ggplot2_args(),+ axis.ticks = quote(element_blank()), |
|
| 142 | -+ | ||
| 1005 | +! |
- decorators = NULL) {
+ panel.grid.major = quote(element_blank()) |
|
| 143 | -! | +||
| 1006 | +
- message("Initializing tm_g_association")
+ ) |
||
| 144 | +1007 |
-
+ ) |
|
| 145 | +1008 |
- # Normalize the parameters+ |
|
| 146 | +1009 | ! |
- if (inherits(ref, "data_extract_spec")) ref <- list(ref)+ all_ggplot2_args2 <- teal.widgets::resolve_ggplot2_args( |
| 147 | +1010 | ! |
- if (inherits(vars, "data_extract_spec")) vars <- list(vars)+ user_plot = ggplot2_args[["Combinations Main"]], |
| 148 | +1011 | ! |
- if (inherits(ggplot2_args, "ggplot2_args")) ggplot2_args <- list(default = ggplot2_args)+ user_default = ggplot2_args$default, |
| 149 | -+ | ||
| 1012 | +! |
-
+ module_plot = dev_ggplot2_args2 |
|
| 150 | +1013 |
- # Start of assertions- |
- |
| 151 | -! | -
- checkmate::assert_string(label)+ ) |
|
| 152 | +1014 | ||
| 153 | +1015 | ! |
- checkmate::assert_list(ref, types = "data_extract_spec")+ parsed_ggplot2_args2 <- teal.widgets::parse_ggplot2_args( |
| 154 | +1016 | ! |
- if (!all(vapply(ref, function(x) !x$select$multiple, logical(1)))) {
+ all_ggplot2_args2, |
| 155 | +1017 | ! |
- stop("'ref' should not allow multiple selection")
+ ggtheme = input$ggtheme |
| 156 | +1018 |
- }+ ) |
|
| 157 | +1019 | ||
| 158 | +1020 | ! |
- checkmate::assert_list(vars, types = "data_extract_spec")+ qenv <- teal.code::eval_code( |
| 159 | +1021 | ! |
- checkmate::assert_flag(show_association)+ qenv, |
| 160 | -+ | ||
| 1022 | +! |
-
+ substitute( |
|
| 161 | +1023 | ! |
- checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE)+ expr = {
|
| 162 | +1024 | ! |
- checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height")+ combination_plot_top <- data_combination_plot_cutoff %>% |
| 163 | +1025 | ! |
- checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE)+ dplyr::select(id, n) %>% |
| 164 | +1026 | ! |
- checkmate::assert_numeric(+ dplyr::distinct() %>% |
| 165 | +1027 | ! |
- plot_width[1],+ ggplot(aes(x = id, y = n)) + |
| 166 | +1028 | ! |
- lower = plot_width[2], upper = plot_width[3], null.ok = TRUE, .var.name = "plot_width"+ geom_bar(stat = "identity", fill = c(getOption("ggplot2.discrete.colour")[2], "#ff2951ff")[1]) +
|
| 167 | -+ | ||
| 1029 | +! |
- )+ geom_text( |
|
| 168 | -+ | ||
| 1030 | +! |
-
+ aes(label = n), |
|
| 169 | +1031 | ! |
- distribution_theme <- match.arg(distribution_theme)+ position = position_dodge(width = 0.9), |
| 170 | +1032 | ! |
- association_theme <- match.arg(association_theme)+ vjust = -0.25 |
| 171 | +1033 | - - | -|
| 172 | -! | -
- checkmate::assert_multi_class(pre_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
+ ) + |
|
| 173 | +1034 | ! |
- checkmate::assert_multi_class(post_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
- |
-
| 174 | -- |
-
+ ylim(c(0, max(data_combination_plot_cutoff$n) * 1.5)) + |
|
| 175 | +1035 | ! |
- plot_choices <- c("Bivariate1", "Bivariate2")
+ labs1 + |
| 176 | +1036 | ! |
- checkmate::assert_list(ggplot2_args, types = "ggplot2_args")+ ggthemes1 + |
| 177 | +1037 | ! |
- checkmate::assert_subset(names(ggplot2_args), c("default", plot_choices))
+ themes1 |
| 178 | +1038 | ||
| 179 | +1039 | ! |
- decorators <- normalize_decorators(decorators)+ graph_number_rows <- length(unique(data_combination_plot_cutoff$id)) |
| 180 | +1040 | ! |
- assert_decorators(decorators, null.ok = TRUE, "plot")- |
-
| 181 | -- |
- # End of assertions+ graph_number_cols <- nrow(data_combination_plot_cutoff) / graph_number_rows |
|
| 182 | +1041 | ||
| 183 | -+ | ||
| 1042 | +! |
- # Make UI args+ combination_plot_bottom <- data_combination_plot_cutoff %>% ggplot() + |
|
| 184 | +1043 | ! |
- args <- as.list(environment())+ aes(x = create_cols_labels(key), y = id - 0.5, fill = value) + |
| 185 | -+ | ||
| 1044 | +! |
-
+ geom_tile(alpha = 0.85, height = 0.95) + |
|
| 186 | +1045 | ! |
- data_extract_list <- list(+ scale_fill_manual( |
| 187 | +1046 | ! |
- ref = ref,+ name = "", |
| 188 | +1047 | ! |
- vars = vars+ values = c("grey90", c(getOption("ggplot2.discrete.colour")[2], "#ff2951ff")[1]),
|
| 189 | -+ | ||
| 1048 | +! |
- )+ labels = c("Present", "Missing")
|
|
| 190 | +1049 |
-
+ ) + |
|
| 191 | +1050 | ! |
- ans <- module(+ geom_hline(yintercept = seq_len(1 + graph_number_rows) - 1) + |
| 192 | +1051 | ! |
- label = label,+ geom_vline(xintercept = seq_len(1 + graph_number_cols) - 0.5, linetype = "dotted") + |
| 193 | +1052 | ! |
- server = srv_tm_g_association,+ coord_flip() + |
| 194 | +1053 | ! |
- ui = ui_tm_g_association,+ labs2 + |
| 195 | +1054 | ! |
- ui_args = args,+ ggthemes2 + |
| 196 | +1055 | ! |
- server_args = c(+ themes2+ |
+
| 1056 | ++ |
+ }, |
|
| 197 | +1057 | ! |
- data_extract_list,+ env = list( |
| 198 | +1058 | ! |
- list(plot_height = plot_height, plot_width = plot_width, ggplot2_args = ggplot2_args, decorators = decorators)+ labs1 = parsed_ggplot2_args1$labs, |
| 199 | -+ | ||
| 1059 | +! |
- ),+ themes1 = parsed_ggplot2_args1$theme, |
|
| 200 | +1060 | ! |
- datanames = teal.transform::get_extract_datanames(data_extract_list)+ ggthemes1 = parsed_ggplot2_args1$ggtheme, |
| 201 | -+ | ||
| 1061 | +! |
- )+ labs2 = parsed_ggplot2_args2$labs, |
|
| 202 | +1062 | ! |
- attr(ans, "teal_bookmarkable") <- TRUE+ themes2 = parsed_ggplot2_args2$theme, |
| 203 | +1063 | ! |
- ans+ ggthemes2 = parsed_ggplot2_args2$ggtheme |
| 204 | +1064 |
- }+ ) |
|
| 205 | +1065 |
-
+ ) |
|
| 206 | +1066 |
- # UI function for the association module+ ) |
|
| 207 | +1067 |
- ui_tm_g_association <- function(id, ...) {
+
|
|
| 208 | +1068 | ! |
- ns <- NS(id)+ within(qenv, {
|
| 209 | +1069 | ! |
- args <- list(...)+ g1 <- ggplotGrob(combination_plot_top) |
| 210 | +1070 | ! |
- is_single_dataset_value <- teal.transform::is_single_dataset(args$ref, args$vars)+ g2 <- ggplotGrob(combination_plot_bottom) |
| 211 | +1071 | ||
| 212 | +1072 | ! |
- teal.widgets::standard_layout(+ combination_plot <- gridExtra::gtable_rbind(g1, g2, size = "last") |
| 213 | +1073 | ! |
- output = teal.widgets::white_small_well(+ combination_plot$heights[7] <- grid::unit(0.2, "null") # rescale to get the bar chart smaller+ |
+
| 1074 | ++ |
+ })+ |
+ |
| 1075 | ++ |
+ })+ |
+ |
| 1076 | ++ | + | |
| 214 | +1077 | ! |
- textOutput(ns("title")),
+ summary_table_q <- reactive({
|
| 215 | +1078 | ! |
- tags$br(),+ req( |
| 216 | +1079 | ! |
- teal.widgets::plot_with_settings_ui(id = ns("myplot"))
+ input$summary_type == "By Variable Levels", # needed to trigger show r code update on tab change+ |
+
| 1080 | +! | +
+ common_code_q() |
|
| 217 | +1081 |
- ),+ ) |
|
| 218 | +1082 | ! |
- encoding = tags$div(+ teal::validate_has_data(data_r(), 1) |
| 219 | +1083 |
- ### Reporter+ + |
+ |
| 1084 | ++ |
+ # extract the ANL dataset for use in further validation |
|
| 220 | +1085 | ! |
- teal.reporter::simple_reporter_ui(ns("simple_reporter")),
+ anl <- common_code_q()[["ANL"]] |
| 221 | +1086 |
- ###+ |
|
| 222 | +1087 | ! |
- tags$label("Encodings", class = "text-primary"),
+ group_var <- input$group_by_var |
| 223 | +1088 | ! |
- teal.transform::datanames_input(args[c("ref", "vars")]),
+ validate( |
| 224 | +1089 | ! |
- teal.transform::data_extract_ui(+ need( |
| 225 | +1090 | ! |
- id = ns("ref"),
+ is.null(group_var) || |
| 226 | +1091 | ! |
- label = "Reference variable",+ length(unique(anl[[group_var]])) < 100, |
| 227 | +1092 | ! |
- data_extract_spec = args$ref,+ "Please select group-by variable with fewer than 100 unique values" |
| 228 | -! | +||
| 1093 | +
- is_single_dataset = is_single_dataset_value+ ) |
||
| 229 | +1094 |
- ),+ ) |
|
| 230 | -! | +||
| 1095 | +
- teal.transform::data_extract_ui(+ |
||
| 231 | +1096 | ! |
- id = ns("vars"),
+ group_vals <- input$group_by_vals |
| 232 | +1097 | ! |
- label = "Associated variables",+ variables_select <- input$variables_select |
| 233 | +1098 | ! |
- data_extract_spec = args$vars,+ vars <- unique(variables_select, group_var) |
| 234 | +1099 | ! |
- is_single_dataset = is_single_dataset_value+ count_type <- input$count_type |
| 235 | +1100 |
- ),+ |
|
| 236 | +1101 | ! |
- checkboxInput(+ if (!is.null(selected_vars()) && length(selected_vars()) != ncol(anl)) {
|
| 237 | +1102 | ! |
- ns("association"),
+ variables <- selected_vars() |
| 238 | -! | +||
| 1103 | +
- "Association with reference variable",+ } else {
|
||
| 239 | +1104 | ! |
- value = args$show_association+ variables <- colnames(anl) |
| 240 | +1105 |
- ),+ } |
|
| 241 | -! | +||
| 1106 | +
- checkboxInput(+ |
||
| 242 | +1107 | ! |
- ns("show_dist"),
+ summ_fn <- if (input$count_type == "counts") {
|
| 243 | +1108 | ! |
- "Scaled frequencies",+ function(x) sum(is.na(x))+ |
+
| 1109 | ++ |
+ } else {
|
|
| 244 | +1110 | ! |
- value = FALSE+ function(x) round(sum(is.na(x)) / length(x), 4) |
| 245 | +1111 |
- ),+ } |
|
| 246 | -! | +||
| 1112 | +
- checkboxInput(+ |
||
| 247 | +1113 | ! |
- ns("log_transformation"),
+ qenv <- if (!is.null(group_var)) {
|
| 248 | +1114 | ! |
- "Log transformed",+ teal.code::eval_code( |
| 249 | +1115 | ! |
- value = FALSE- |
-
| 250 | -- |
- ),+ common_code_q(), |
|
| 251 | +1116 | ! |
- ui_decorate_teal_data(ns("decorator"), decorators = select_decorators(args$decorators, "plot")),
+ substitute( |
| 252 | +1117 | ! |
- teal.widgets::panel_group(+ expr = {
|
| 253 | +1118 | ! |
- teal.widgets::panel_item(+ summary_data <- ANL %>% |
| 254 | +1119 | ! |
- title = "Plot settings",+ dplyr::mutate(group_var_name := forcats::fct_na_value_to_level(as.factor(group_var_name), "NA")) %>% |
| 255 | +1120 | ! |
- teal.widgets::optionalSliderInputValMinMax(ns("alpha"), "Scatterplot opacity:", c(0.5, 0, 1), ticks = FALSE),
+ dplyr::group_by_at(group_var) %>% |
| 256 | +1121 | ! |
- teal.widgets::optionalSliderInputValMinMax(ns("size"), "Scatterplot points size:", c(2, 1, 8), ticks = FALSE),
+ dplyr::filter(group_var_name %in% group_vals) |
| 257 | -! | +||
| 1122 | +
- checkboxInput(ns("swap_axes"), "Swap axes", value = FALSE),
+
|
||
| 258 | +1123 | ! |
- checkboxInput(ns("rotate_xaxis_labels"), "Rotate X axis labels", value = FALSE),
+ count_data <- dplyr::summarise(summary_data, n = dplyr::n()) |
| 259 | -! | +||
| 1124 | +
- selectInput(+ |
||
| 260 | +1125 | ! |
- inputId = ns("distribution_theme"),
+ summary_data <- dplyr::summarise_all(summary_data, summ_fn) %>% |
| 261 | +1126 | ! |
- label = "Distribution theme (by ggplot):",+ dplyr::mutate(group_var_name := paste0(group_var, ":", group_var_name, "(N=", count_data$n, ")")) %>% |
| 262 | +1127 | ! |
- choices = ggplot_themes,+ tidyr::pivot_longer(!dplyr::all_of(group_var), names_to = "Variable", values_to = "out") %>% |
| 263 | +1128 | ! |
- selected = args$distribution_theme,+ tidyr::pivot_wider(names_from = group_var, values_from = "out") %>% |
| 264 | +1129 | ! |
- multiple = FALSE+ dplyr::mutate(`Variable label` = create_cols_labels(Variable, just_label = TRUE), .after = Variable) |
| 265 | +1130 |
- ),+ }, |
|
| 266 | +1131 | ! |
- selectInput(+ env = list( |
| 267 | +1132 | ! |
- inputId = ns("association_theme"),
+ group_var = group_var, group_var_name = as.name(group_var), group_vals = group_vals, summ_fn = summ_fn |
| 268 | -! | +||
| 1133 | +
- label = "Association theme (by ggplot):",+ ) |
||
| 269 | -! | +||
| 1134 | +
- choices = ggplot_themes,+ )+ |
+ ||
| 1135 | ++ |
+ )+ |
+ |
| 1136 | ++ |
+ } else {
|
|
| 270 | +1137 | ! |
- selected = args$association_theme,+ teal.code::eval_code( |
| 271 | +1138 | ! |
- multiple = FALSE+ common_code_q(), |
| 272 | -+ | ||
| 1139 | +! |
- )+ substitute( |
|
| 273 | -+ | ||
| 1140 | +! |
- )+ expr = summary_data <- ANL %>% |
|
| 274 | -+ | ||
| 1141 | +! |
- )+ dplyr::summarise_all(summ_fn) %>% |
|
| 275 | -+ | ||
| 1142 | +! |
- ),+ tidyr::pivot_longer(dplyr::everything(), |
|
| 276 | +1143 | ! |
- forms = tagList(+ names_to = "Variable", |
| 277 | +1144 | ! |
- teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code")
+ values_to = paste0("Missing (N=", nrow(ANL), ")")
|
| 278 | +1145 |
- ),+ ) %>% |
|
| 279 | +1146 | ! |
- pre_output = args$pre_output,+ dplyr::mutate(`Variable label` = create_cols_labels(Variable), .after = Variable), |
| 280 | +1147 | ! |
- post_output = args$post_output+ env = list(summ_fn = summ_fn) |
| 281 | +1148 |
- )+ ) |
|
| 282 | +1149 |
- }+ ) |
|
| 283 | -- | - - | -|
| 284 | +1150 |
- # Server function for the association module+ } |
|
| 285 | +1151 |
- srv_tm_g_association <- function(id,+ |
|
| 286 | -+ | ||
| 1152 | +! |
- data,+ within(qenv, table <- DT::datatable(summary_data)) |
|
| 287 | +1153 |
- reporter,+ }) |
|
| 288 | +1154 |
- filter_panel_api,+ |
|
| 289 | -+ | ||
| 1155 | +! |
- ref,+ by_subject_plot_q <- reactive({
|
|
| 290 | +1156 |
- vars,+ # needed to trigger show r code update on tab change |
|
| 291 | -+ | ||
| 1157 | +! |
- plot_height,+ req(input$summary_type == "Grouped by Subject", common_code_q()) |
|
| 292 | +1158 |
- plot_width,+ |
|
| 293 | -+ | ||
| 1159 | +! |
- ggplot2_args,+ teal::validate_has_data(data_r(), 1) |
|
| 294 | +1160 |
- decorators) {
+
|
|
| 295 | +1161 | ! |
- with_reporter <- !missing(reporter) && inherits(reporter, "Reporter")+ dev_ggplot2_args <- teal.widgets::ggplot2_args( |
| 296 | +1162 | ! |
- with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI")+ labs = list(x = "", y = ""), |
| 297 | +1163 | ! |
- checkmate::assert_class(data, "reactive")+ theme = list(legend.position = "bottom", axis.text.x = quote(element_blank())) |
| 298 | -! | +||
| 1164 | +
- checkmate::assert_class(isolate(data()), "teal_data")+ ) |
||
| 299 | +1165 | ||
| 300 | -! | -
- moduleServer(id, function(input, output, session) {
- |
- |
| 301 | +1166 | ! |
- teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.general")- |
-
| 302 | -- |
-
+ all_ggplot2_args <- teal.widgets::resolve_ggplot2_args( |
|
| 303 | +1167 | ! |
- selector_list <- teal.transform::data_extract_multiple_srv(+ user_plot = ggplot2_args[["By Subject"]], |
| 304 | +1168 | ! |
- data_extract = list(ref = ref, vars = vars),+ user_default = ggplot2_args$default, |
| 305 | +1169 | ! |
- datasets = data,+ module_plot = dev_ggplot2_args |
| 306 | -! | +||
| 1170 | +
- select_validation_rule = list(+ ) |
||
| 307 | -! | +||
| 1171 | +
- ref = shinyvalidate::compose_rules(+ |
||
| 308 | +1172 | ! |
- shinyvalidate::sv_required("A reference variable needs to be selected."),
+ parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args( |
| 309 | +1173 | ! |
- ~ if ((.) %in% selector_list()$vars()$select) {
+ all_ggplot2_args, |
| 310 | +1174 | ! |
- "Associated variables and reference variable cannot overlap"+ ggtheme = input$ggtheme |
| 311 | +1175 |
- }+ ) |
|
| 312 | +1176 |
- ),+ |
|
| 313 | +1177 | ! |
- vars = shinyvalidate::compose_rules(+ teal.code::eval_code( |
| 314 | +1178 | ! |
- shinyvalidate::sv_required("An associated variable needs to be selected."),
+ common_code_q(), |
| 315 | +1179 | ! |
- ~ if (length(selector_list()$ref()$select) != 0 && selector_list()$ref()$select %in% (.)) {
+ substitute( |
| 316 | +1180 | ! |
- "Associated variables and reference variable cannot overlap"+ expr = parent_keys <- keys, |
| 317 | -+ | ||
| 1181 | +! |
- }+ env = list(keys = data_parent_keys()) |
|
| 318 | +1182 |
) |
|
| 319 | -- |
- )- |
- |
| 320 | +1183 |
- )+ ) %>% |
|
| 321 | -+ | ||
| 1184 | +! |
-
+ teal.code::eval_code( |
|
| 322 | +1185 | ! |
- iv_r <- reactive({
+ substitute( |
| 323 | +1186 | ! |
- iv <- shinyvalidate::InputValidator$new()+ expr = analysis_vars <- setdiff(colnames(ANL), data_keys), |
| 324 | +1187 | ! |
- teal.transform::compose_and_enable_validators(iv, selector_list)+ env = list(data_keys = data_keys()) |
| 325 | +1188 |
- })+ ) |
|
| 326 | +1189 |
-
+ ) %>% |
|
| 327 | +1190 | ! |
- anl_merged_input <- teal.transform::merge_expression_srv(+ teal.code::eval_code( |
| 328 | +1191 | ! |
- datasets = data,+ quote({
|
| 329 | +1192 | ! |
- selector_list = selector_list+ summary_plot_patients <- ANL[, c(parent_keys, analysis_vars)] %>% |
| 330 | -+ | ||
| 1193 | +! |
- )+ dplyr::group_by_at(parent_keys) %>% |
|
| 331 | -+ | ||
| 1194 | +! |
-
+ dplyr::mutate(id = dplyr::cur_group_id()) %>% |
|
| 332 | +1195 | ! |
- anl_merged_q <- reactive({
+ dplyr::ungroup() %>% |
| 333 | +1196 | ! |
- req(anl_merged_input())+ dplyr::group_by_at(c(parent_keys, "id")) %>% |
| 334 | +1197 | ! |
- data() %>% teal.code::eval_code(as.expression(anl_merged_input()$expr))+ dplyr::summarise_all(anyNA) %>%+ |
+
| 1198 | +! | +
+ dplyr::ungroup() |
|
| 335 | +1199 |
- })+ |
|
| 336 | +1200 |
-
+ # order subjects by decreasing number of missing and then by |
|
| 337 | -! | +||
| 1201 | +
- merged <- list(+ # missingness pattern (defined using sha1) |
||
| 338 | +1202 | ! |
- anl_input_r = anl_merged_input,+ order_subjects <- summary_plot_patients %>% |
| 339 | +1203 | ! |
- anl_q_r = anl_merged_q+ dplyr::select(-"id", -dplyr::all_of(parent_keys)) %>% |
| 340 | -+ | ||
| 1204 | +! |
- )+ dplyr::transmute( |
|
| 341 | -+ | ||
| 1205 | +! |
-
+ id = dplyr::row_number(), |
|
| 342 | +1206 | ! |
- output_q <- reactive({
+ number_NA = apply(., 1, sum), |
| 343 | +1207 | ! |
- teal::validate_inputs(iv_r())+ sha = apply(., 1, rlang::hash) |
| 344 | +1208 |
-
+ ) %>% |
|
| 345 | +1209 | ! |
- ANL <- merged$anl_q_r()[["ANL"]]+ dplyr::arrange(dplyr::desc(number_NA), sha) %>% |
| 346 | +1210 | ! |
- teal::validate_has_data(ANL, 3)+ getElement(name = "id") |
| 347 | +1211 | ||
| 348 | -! | -
- vars_names <- merged$anl_input_r()$columns_source$vars- |
- |
| 349 | +1212 |
-
+ # order columns by decreasing percent of missing values |
|
| 350 | +1213 | ! |
- ref_name <- as.vector(merged$anl_input_r()$columns_source$ref)+ ordered_columns <- summary_plot_patients %>% |
| 351 | +1214 | ! |
- association <- input$association+ dplyr::select(-"id", -dplyr::all_of(parent_keys)) %>% |
| 352 | +1215 | ! |
- show_dist <- input$show_dist+ dplyr::summarise( |
| 353 | +1216 | ! |
- log_transformation <- input$log_transformation+ column = create_cols_labels(colnames(.)), |
| 354 | +1217 | ! |
- rotate_xaxis_labels <- input$rotate_xaxis_labels+ na_count = apply(., MARGIN = 2, FUN = sum), |
| 355 | +1218 | ! |
- swap_axes <- input$swap_axes+ na_percent = na_count / nrow(.) * 100 |
| 356 | -! | +||
| 1219 | +
- distribution_theme <- input$distribution_theme+ ) %>% |
||
| 357 | +1220 | ! |
- association_theme <- input$association_theme+ dplyr::arrange(na_percent, dplyr::desc(column)) |
| 358 | +1221 | ||
| 359 | +1222 | ! |
- is_scatterplot <- is.numeric(ANL[[ref_name]]) && any(vapply(ANL[vars_names], is.numeric, logical(1)))+ summary_plot_patients <- summary_plot_patients %>% |
| 360 | +1223 | ! |
- if (is_scatterplot) {
+ tidyr::gather("col", "isna", -"id", -dplyr::all_of(parent_keys)) %>%
|
| 361 | +1224 | ! |
- shinyjs::show("alpha")
+ dplyr::mutate(col = create_cols_labels(col)) |
| 362 | -! | +||
| 1225 | +
- shinyjs::show("size")
+ }) |
||
| 363 | -! | +||
| 1226 | +
- alpha <- input$alpha+ ) %>% |
||
| 364 | +1227 | ! |
- size <- input$size+ teal.code::eval_code( |
| 365 | -+ | ||
| 1228 | +! |
- } else {
+ substitute( |
|
| 366 | +1229 | ! |
- shinyjs::hide("alpha")
+ expr = {
|
| 367 | +1230 | ! |
- shinyjs::hide("size")
+ by_subject_plot <- ggplot(summary_plot_patients, aes( |
| 368 | +1231 | ! |
- alpha <- 0.5+ x = factor(id, levels = order_subjects), |
| 369 | +1232 | ! |
- size <- 2+ y = factor(col, levels = ordered_columns[["column"]]), |
| 370 | -+ | ||
| 1233 | +! |
- }+ fill = isna |
|
| 371 | +1234 |
-
+ )) + |
|
| 372 | +1235 | ! |
- teal::validate_has_data(ANL[, c(ref_name, vars_names)], 3, complete = TRUE, allow_inf = FALSE)- |
-
| 373 | -- |
-
+ geom_raster() + |
|
| 374 | -+ | ||
| 1236 | +! |
- # reference+ annotate( |
|
| 375 | +1237 | ! |
- ref_class <- class(ANL[[ref_name]])[1]+ "text", |
| 376 | +1238 | ! |
- if (is.numeric(ANL[[ref_name]]) && log_transformation) {
+ x = length(order_subjects), |
| 377 | -+ | ||
| 1239 | +! |
- # works for both integers and doubles+ y = seq_len(nrow(ordered_columns)), |
|
| 378 | +1240 | ! |
- ref_cl_name <- call("log", as.name(ref_name))
+ hjust = 1, |
| 379 | +1241 | ! |
- ref_cl_lbl <- varname_w_label(ref_name, ANL, prefix = "Log of ")+ label = sprintf("%d [%.02f%%]", ordered_columns[["na_count"]], ordered_columns[["na_percent"]])
|
| 380 | +1242 |
- } else {
+ ) + |
|
| 381 | -+ | ||
| 1243 | +! |
- # silently ignore when non-numeric even if `log` is selected because some+ scale_fill_manual( |
|
| 382 | -+ | ||
| 1244 | +! |
- # variables may be numeric and others not+ name = "", |
|
| 383 | +1245 | ! |
- ref_cl_name <- as.name(ref_name)+ values = c("grey90", c(getOption("ggplot2.discrete.colour")[2], "#ff2951ff")[1]),
|
| 384 | +1246 | ! |
- ref_cl_lbl <- varname_w_label(ref_name, ANL)- |
-
| 385 | -- |
- }+ labels = c("Present", "Missing (at least one)")
|
|
| 386 | +1247 |
-
+ ) + |
|
| 387 | +1248 | ! |
- user_ggplot2_args <- teal.widgets::resolve_ggplot2_args(+ labs + |
| 388 | +1249 | ! |
- user_plot = ggplot2_args[["Bivariate1"]],+ ggthemes + |
| 389 | +1250 | ! |
- user_default = ggplot2_args$default- |
-
| 390 | -- |
- )+ themes |
|
| 391 | +1251 | - - | -|
| 392 | -! | -
- ref_call <- bivariate_plot_call(- |
- |
| 393 | -! | -
- data_name = "ANL",- |
- |
| 394 | -! | -
- x = ref_cl_name,+ }, |
|
| 395 | +1252 | ! |
- x_class = ref_class,+ env = list( |
| 396 | +1253 | ! |
- x_label = ref_cl_lbl,+ labs = parsed_ggplot2_args$labs, |
| 397 | +1254 | ! |
- freq = !show_dist,+ themes = parsed_ggplot2_args$theme, |
| 398 | +1255 | ! |
- theme = distribution_theme,+ ggthemes = parsed_ggplot2_args$ggtheme |
| 399 | -! | +||
| 1256 | +
- rotate_xaxis_labels = rotate_xaxis_labels,+ ) |
||
| 400 | -! | +||
| 1257 | +
- swap_axes = FALSE,+ ) |
||
| 401 | -! | +||
| 1258 | +
- size = size,+ ) |
||
| 402 | -! | +||
| 1259 | +
- alpha = alpha,+ }) |
||
| 403 | -! | +||
| 1260 | +
- ggplot2_args = user_ggplot2_args+ |
||
| 404 | +1261 |
- )+ # Decorated outputs |
|
| 405 | +1262 | ||
| 406 | +1263 |
- # association+ # Summary_plot_q |
|
| 407 | +1264 | ! |
- ref_class_cov <- ifelse(association, ref_class, "NULL")- |
-
| 408 | -- |
-
+ decorated_summary_plot_q <- srv_decorate_teal_data( |
|
| 409 | +1265 | ! |
- var_calls <- lapply(vars_names, function(var_i) {
+ id = "dec_summary_plot", |
| 410 | +1266 | ! |
- var_class <- class(ANL[[var_i]])[1]+ data = summary_plot_q, |
| 411 | +1267 | ! |
- if (is.numeric(ANL[[var_i]]) && log_transformation) {
+ decorators = select_decorators(decorators, "summary_plot"), |
| 412 | -+ | ||
| 1268 | +! |
- # works for both integers and doubles+ expr = {
|
|
| 413 | +1269 | ! |
- var_cl_name <- call("log", as.name(var_i))
+ grid::grid.newpage() |
| 414 | +1270 | ! |
- var_cl_lbl <- varname_w_label(var_i, ANL, prefix = "Log of ")+ grid::grid.draw(summary_plot) |
| 415 | +1271 |
- } else {
+ } |
|
| 416 | +1272 |
- # silently ignore when non-numeric even if `log` is selected because some+ ) |
|
| 417 | +1273 |
- # variables may be numeric and others not+ |
|
| 418 | +1274 | ! |
- var_cl_name <- as.name(var_i)+ decorated_combination_plot_q <- srv_decorate_teal_data( |
| 419 | +1275 | ! |
- var_cl_lbl <- varname_w_label(var_i, ANL)+ id = "dec_combination_plot", |
| 420 | -+ | ||
| 1276 | +! |
- }+ data = combination_plot_q, |
|
| 421 | -+ | ||
| 1277 | +! |
-
+ decorators = select_decorators(decorators, "combination_plot"), |
|
| 422 | +1278 | ! |
- user_ggplot2_args <- teal.widgets::resolve_ggplot2_args(+ expr = {
|
| 423 | +1279 | ! |
- user_plot = ggplot2_args[["Bivariate2"]],+ grid::grid.newpage() |
| 424 | +1280 | ! |
- user_default = ggplot2_args$default+ grid::grid.draw(combination_plot) |
| 425 | +1281 |
- )+ } |
|
| 426 | +1282 | - - | -|
| 427 | -! | -
- bivariate_plot_call(- |
- |
| 428 | -! | -
- data_name = "ANL",+ ) |
|
| 429 | -! | +||
| 1283 | +
- x = ref_cl_name,+ |
||
| 430 | +1284 | ! |
- y = var_cl_name,+ decorated_summary_table_q <- srv_decorate_teal_data( |
| 431 | +1285 | ! |
- x_class = ref_class_cov,+ id = "dec_summary_table", |
| 432 | +1286 | ! |
- y_class = var_class,+ data = summary_table_q, |
| 433 | +1287 | ! |
- x_label = ref_cl_lbl,+ decorators = select_decorators(decorators, "summary_table"), |
| 434 | +1288 | ! |
- y_label = var_cl_lbl,+ expr = table |
| 435 | -! | +||
| 1289 | +
- theme = association_theme,+ ) |
||
| 436 | -! | +||
| 1290 | +
- freq = !show_dist,+ |
||
| 437 | +1291 | ! |
- rotate_xaxis_labels = rotate_xaxis_labels,+ decorated_by_subject_plot_q <- srv_decorate_teal_data( |
| 438 | +1292 | ! |
- swap_axes = swap_axes,+ id = "dec_by_subject_plot", |
| 439 | +1293 | ! |
- alpha = alpha,+ data = by_subject_plot_q, |
| 440 | +1294 | ! |
- size = size,+ decorators = select_decorators(decorators, "by_subject_plot"), |
| 441 | +1295 | ! |
- ggplot2_args = user_ggplot2_args+ expr = print(by_subject_plot) |
| 442 | +1296 |
- )+ ) |
|
| 443 | +1297 |
- })+ |
|
| 444 | +1298 |
-
+ # Plots & tables reactives |
|
| 445 | +1299 |
- # helper function to format variable name- |
- |
| 446 | -! | -
- format_varnames <- function(x) {
- |
- |
| 447 | -! | -
- if (is.numeric(ANL[[x]]) && log_transformation) {
+
|
|
| 448 | +1300 | ! |
- varname_w_label(x, ANL, prefix = "Log of ")- |
-
| 449 | -- |
- } else {
+ summary_plot_r <- reactive({
|
|
| 450 | +1301 | ! |
- varname_w_label(x, ANL)+ req(decorated_summary_plot_q())[["summary_plot"]] |
| 451 | +1302 |
- }+ }) |
|
| 452 | +1303 |
- }+ |
|
| 453 | +1304 | ! |
- new_title <-+ combination_plot_r <- reactive({
|
| 454 | +1305 | ! |
- if (association) {
+ req(decorated_combination_plot_q())[["combination_plot"]] |
| 455 | -! | +||
| 1306 | +
- switch(as.character(length(vars_names)),+ }) |
||
| 456 | -! | +||
| 1307 | +
- "0" = sprintf("Value distribution for %s", ref_cl_lbl),
+
|
||
| 457 | +1308 | ! |
- "1" = sprintf(+ summary_table_r <- reactive({
|
| 458 | +1309 | ! |
- "Association between %s and %s",+ req(decorated_summary_table_q()) |
| 459 | -! | +||
| 1310 | +
- ref_cl_lbl,+ |
||
| 460 | +1311 | ! |
- format_varnames(vars_names)+ if (length(input$variables_select) == 0) {
|
| 461 | +1312 |
- ),+ # so that zeroRecords message gets printed |
|
| 462 | -! | +||
| 1313 | +
- sprintf(+ # using tibble as it supports weird column names, such as " " |
||
| 463 | +1314 | ! |
- "Associations between %s and: %s",+ DT::datatable( |
| 464 | +1315 | ! |
- ref_cl_lbl,+ tibble::tibble(` ` = logical(0)), |
| 465 | +1316 | ! |
- paste(lapply(vars_names, format_varnames), collapse = ", ")- |
-
| 466 | -- |
- )+ options = list(language = list(zeroRecords = "No variable selected."), pageLength = input$levels_table_rows) |
|
| 467 | +1317 |
- )+ ) |
|
| 468 | +1318 |
- } else {
+ } else {
|
|
| 469 | +1319 | ! |
- switch(as.character(length(vars_names)),+ decorated_summary_table_q()[["table"]] |
| 470 | -! | +||
| 1320 | +
- "0" = sprintf("Value distribution for %s", ref_cl_lbl),
+ } |
||
| 471 | -! | +||
| 1321 | +
- sprintf(+ }) |
||
| 472 | -! | +||
| 1322 | +
- "Value distributions for %s and %s",+ |
||
| 473 | +1323 | ! |
- ref_cl_lbl,+ by_subject_plot_r <- reactive({
|
| 474 | +1324 | ! |
- paste(lapply(vars_names, format_varnames), collapse = ", ")+ req(decorated_by_subject_plot_q()[["by_subject_plot"]]) |
| 475 | +1325 |
- )+ }) |
|
| 476 | +1326 |
- )+ |
|
| 477 | +1327 |
- }+ # Generate output |
|
| 478 | +1328 | ! |
- teal.code::eval_code(+ pws1 <- teal.widgets::plot_with_settings_srv( |
| 479 | +1329 | ! |
- merged$anl_q_r(),+ id = "summary_plot", |
| 480 | +1330 | ! |
- substitute(+ plot_r = summary_plot_r, |
| 481 | +1331 | ! |
- expr = title <- new_title,+ height = plot_height, |
| 482 | +1332 | ! |
- env = list(new_title = new_title)+ width = plot_width |
| 483 | +1333 |
- )+ ) |
|
| 484 | +1334 |
- ) %>%+ |
|
| 485 | +1335 | ! |
- teal.code::eval_code(+ pws2 <- teal.widgets::plot_with_settings_srv( |
| 486 | +1336 | ! |
- substitute(+ id = "combination_plot", |
| 487 | +1337 | ! |
- expr = {
+ plot_r = combination_plot_r, |
| 488 | +1338 | ! |
- plot_top <- plot_calls[[1]]+ height = plot_height, |
| 489 | +1339 | ! |
- plot_bottom <- plot_calls[[1]]+ width = plot_width |
| 490 | -! | +||
| 1340 | +
- plot <- tern::stack_grobs(grobs = lapply(list(plot_top, plot_bottom), ggplotGrob))+ ) |
||
| 491 | +1341 |
- },+ |
|
| 492 | +1342 | ! |
- env = list(+ output$levels_table <- DT::renderDataTable(summary_table_r())+ |
+
| 1343 | ++ | + | |
| 493 | +1344 | ! |
- plot_calls = do.call(+ pws3 <- teal.widgets::plot_with_settings_srv( |
| 494 | +1345 | ! |
- "call",+ id = "by_subject_plot", |
| 495 | +1346 | ! |
- c(list("list", ref_call), var_calls),
+ plot_r = by_subject_plot_r, |
| 496 | +1347 | ! |
- quote = TRUE+ height = plot_height, |
| 497 | -+ | ||
| 1348 | +! |
- )+ width = plot_width |
|
| 498 | +1349 |
- )+ ) |
|
| 499 | +1350 |
- )+ |
|
| 500 | -+ | ||
| 1351 | +! |
- )+ decorated_final_q <- reactive({
|
|
| 501 | -+ | ||
| 1352 | +! |
- })+ sum_type <- req(input$summary_type) |
|
| 502 | -+ | ||
| 1353 | +! |
-
+ if (sum_type == "Summary") {
|
|
| 503 | +1354 | ! |
- decorated_output_grob_q <- srv_decorate_teal_data(+ decorated_summary_plot_q() |
| 504 | +1355 | ! |
- id = "decorator",+ } else if (sum_type == "Combinations") {
|
| 505 | +1356 | ! |
- data = output_q,+ decorated_combination_plot_q() |
| 506 | +1357 | ! |
- decorators = select_decorators(decorators, "plot"),+ } else if (sum_type == "By Variable Levels") {
|
| 507 | +1358 | ! |
- expr = {
+ decorated_summary_table_q() |
| 508 | +1359 | ! |
- grid::grid.newpage()+ } else if (sum_type == "Grouped by Subject") {
|
| 509 | +1360 | ! |
- grid::grid.draw(plot)+ decorated_by_subject_plot_q() |
| 510 | +1361 |
} |
|
| 511 | +1362 |
- )+ }) |
|
| 512 | +1363 | ||
| 513 | +1364 | ! |
- plot_r <- reactive({
+ teal.widgets::verbatim_popup_srv( |
| 514 | +1365 | ! |
- req(iv_r()$is_valid())+ id = "rcode", |
| 515 | +1366 | ! |
- req(decorated_output_grob_q())[["plot"]]+ verbatim_content = reactive(teal.code::get_code(req(decorated_final_q()))),+ |
+
| 1367 | +! | +
+ title = "Show R Code for Missing Data" |
|
| 516 | +1368 |
- })+ ) |
|
| 517 | +1369 | ||
| 518 | -! | +||
| 1370 | +
- pws <- teal.widgets::plot_with_settings_srv(+ ### REPORTER |
||
| 519 | +1371 | ! |
- id = "myplot",+ if (with_reporter) {
|
| 520 | +1372 | ! |
- plot_r = plot_r,+ card_fun <- function(comment, label) {
|
| 521 | +1373 | ! |
- height = plot_height,+ card <- teal::TealReportCard$new() |
| 522 | +1374 | ! |
- width = plot_width+ sum_type <- input$summary_type |
| 523 | -+ | ||
| 1375 | +! |
- )+ title <- if (sum_type == "By Variable Levels") paste0(sum_type, " Table") else paste0(sum_type, " Plot") |
|
| 524 | -+ | ||
| 1376 | +! |
-
+ title_dataname <- paste(title, dataname, sep = " - ") |
|
| 525 | +1377 | ! |
- output$title <- renderText({
+ label <- if (label == "") {
|
| 526 | +1378 | ! |
- teal.code::dev_suppress(output_q()[["title"]])+ paste("Missing Data", sum_type, dataname, sep = " - ")
|
| 527 | +1379 |
- })+ } else {
+ |
+ |
| 1380 | +! | +
+ label |
|
| 528 | +1381 |
-
+ } |
|
| 529 | +1382 | ! |
- teal.widgets::verbatim_popup_srv(+ card$set_name(label) |
| 530 | +1383 | ! |
- id = "rcode",+ card$append_text(title_dataname, "header2") |
| 531 | +1384 | ! |
- verbatim_content = reactive(teal.code::get_code(req(decorated_output_grob_q()))),+ if (with_filter) card$append_fs(filter_panel_api$get_filter_state()) |
| 532 | +1385 | ! |
- title = "Association Plot"- |
-
| 533 | -- |
- )+ if (sum_type == "Summary") {
|
|
| 534 | -+ | ||
| 1386 | +! |
-
+ card$append_text("Plot", "header3")
|
|
| 535 | -+ | ||
| 1387 | +! |
- ### REPORTER+ card$append_plot(summary_plot_r(), dim = pws1$dim()) |
|
| 536 | +1388 | ! |
- if (with_reporter) {
+ } else if (sum_type == "Combinations") {
|
| 537 | +1389 | ! |
- card_fun <- function(comment, label) {
+ card$append_text("Plot", "header3")
|
| 538 | +1390 | ! |
- card <- teal::report_card_template(+ card$append_plot(combination_plot_r(), dim = pws2$dim()) |
| 539 | +1391 | ! |
- title = "Association Plot",+ } else if (sum_type == "By Variable Levels") {
|
| 540 | +1392 | ! |
- label = label,+ card$append_text("Table", "header3")
|
| 541 | +1393 | ! |
- with_filter = with_filter,+ card$append_table(summary_table_r[["summary_data"]]) |
| 542 | +1394 | ! |
- filter_panel_api = filter_panel_api+ } else if (sum_type == "Grouped by Subject") {
|
| 543 | -+ | ||
| 1395 | +! |
- )+ card$append_text("Plot", "header3")
|
|
| 544 | +1396 | ! |
- card$append_text("Plot", "header3")
+ card$append_plot(by_subject_plot_r(), dim = pws3$dim()) |
| 545 | -! | +||
| 1397 | +
- card$append_plot(plot_r(), dim = pws$dim())+ } |
||
| 546 | +1398 | ! |
if (!comment == "") {
|
| 547 | +1399 | ! |
card$append_text("Comment", "header3")
|
| 548 | +1400 | ! |
card$append_text(comment) |
| 549 | +1401 |
} |
|
| 550 | +1402 | ! |
- card$append_src(teal.code::get_code(req(decorated_output_grob_q())))+ card$append_src(teal.code::get_code(req(decorated_final_q()))) |
| 551 | +1403 | ! |
card |
| 552 | +1404 |
} |
|
| 553 | +1405 | ! |
teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
|
| 554 | +1406 |
} |
|
| 555 | +1407 |
### |
|
| 556 | +1408 |
}) |
|
| 557 | +1409 |
}@@ -37094,14 +36542,14 @@ teal.modules.general coverage - 3.63% |
| 1 |
- #' `teal` module: Outliers analysis+ #' `teal` module: Univariate and bivariate visualizations |
||
| 3 |
- #' Module to analyze and identify outliers using different methods+ #' Module enables the creation of univariate and bivariate plots, |
||
| 4 |
- #' such as IQR, Z-score, and Percentiles, and offers visualizations including+ #' facilitating the exploration of data distributions and relationships between two variables. |
||
| 5 |
- #' box plots, density plots, and cumulative distribution plots to help interpret the outliers.+ #' |
||
| 6 |
- #'+ #' This is a general module to visualize 1 & 2 dimensional data. |
||
| 7 |
- #' @inheritParams teal::module+ #' |
||
| 8 |
- #' @inheritParams shared_params+ #' @note |
||
| 9 |
- #'+ #' For more examples, please see the vignette "Using bivariate plot" via |
||
| 10 |
- #' @param outlier_var (`data_extract_spec` or `list` of multiple `data_extract_spec`)+ #' `vignette("using-bivariate-plot", package = "teal.modules.general")`.
|
||
| 11 |
- #' Specifies variable(s) to be analyzed for outliers.+ #' |
||
| 12 |
- #' @param categorical_var (`data_extract_spec` or `list` of multiple `data_extract_spec`) optional,+ #' @inheritParams teal::module |
||
| 13 |
- #' specifies the categorical variable(s) to split the selected outlier variables on.+ #' @inheritParams shared_params |
||
| 14 |
- #' @param ggplot2_args `r roxygen_ggplot2_args_param("Boxplot", "Density Plot", "Cumulative Distribution Plot")`
+ #' @param x (`data_extract_spec` or `list` of multiple `data_extract_spec`) |
||
| 15 |
- #' @param decorators `r roxygen_decorators_param("tm_outliers")`
+ #' Variable names selected to plot along the x-axis by default. |
||
| 16 |
- #'+ #' Can be numeric, factor or character. |
||
| 17 |
- #' @inherit shared_params return+ #' No empty selections are allowed. |
||
| 18 |
- #'+ #' @param y (`data_extract_spec` or `list` of multiple `data_extract_spec`) |
||
| 19 |
- #' @section Decorating `tm_outliers`:+ #' Variable names selected to plot along the y-axis by default. |
||
| 20 |
- #'+ #' Can be numeric, factor or character. |
||
| 21 |
- #' This module generates the following objects, which can be modified in place using decorators:+ #' @param use_density (`logical`) optional, indicates whether to plot density (`TRUE`) or frequency (`FALSE`). |
||
| 22 |
- #' - `box_plot` (`ggplot2`)+ #' Defaults to frequency (`FALSE`). |
||
| 23 |
- #' - `density_plot` (`ggplot2`)+ #' @param row_facet (`data_extract_spec` or `list` of multiple `data_extract_spec`) optional, |
||
| 24 |
- #' - `cumulative_plot` (`ggplot2`)+ #' specification of the data variable(s) to use for faceting rows. |
||
| 25 |
- #' - `table` ([DT::datatable()])+ #' @param col_facet (`data_extract_spec` or `list` of multiple `data_extract_spec`) optional, |
||
| 26 |
- #'+ #' specification of the data variable(s) to use for faceting columns. |
||
| 27 |
- #' Decorators can be applied to all outputs or only to specific objects using a+ #' @param facet (`logical`) optional, specifies whether the facet encodings `ui` elements are toggled |
||
| 28 |
- #' named list of `teal_transform_module` objects.+ #' on and shown to the user by default. Defaults to `TRUE` if either `row_facet` or `column_facet` |
||
| 29 |
- #' The `"default"` name is reserved for decorators that are applied to all outputs.+ #' are supplied. |
||
| 30 |
- #' See code snippet below:+ #' @param color_settings (`logical`) Whether coloring, filling and size should be applied |
||
| 31 |
- #'+ #' and `UI` tool offered to the user. |
||
| 32 |
- #' ```+ #' @param color (`data_extract_spec` or `list` of multiple `data_extract_spec`) optional, |
||
| 33 |
- #' tm_outliers(+ #' specification of the data variable(s) selected for the outline color inside the coloring settings. |
||
| 34 |
- #' ..., # arguments for module+ #' It will be applied when `color_settings` is set to `TRUE`. |
||
| 35 |
- #' decorators = list(+ #' @param fill (`data_extract_spec` or `list` of multiple `data_extract_spec`) optional, |
||
| 36 |
- #' default = list(teal_transform_module(...)), # applied to all outputs+ #' specification of the data variable(s) selected for the fill color inside the coloring settings. |
||
| 37 |
- #' box_plot = list(teal_transform_module(...)), # applied only to `box_plot` output+ #' It will be applied when `color_settings` is set to `TRUE`. |
||
| 38 |
- #' density_plot = list(teal_transform_module(...)) # applied only to `density_plot` output+ #' @param size (`data_extract_spec` or `list` of multiple `data_extract_spec`) optional, |
||
| 39 |
- #' cumulative_plot = list(teal_transform_module(...)) # applied only to `cumulative_plot` output+ #' specification of the data variable(s) selected for the size of `geom_point` plots inside the coloring settings. |
||
| 40 |
- #' table = list(teal_transform_module(...)) # applied only to `table` output+ #' It will be applied when `color_settings` is set to `TRUE`. |
||
| 41 |
- #' )+ #' @param free_x_scales (`logical`) optional, whether X scaling shall be changeable. |
||
| 42 |
- #' )+ #' Does not allow scaling to be changed by default (`FALSE`). |
||
| 43 |
- #' ```+ #' @param free_y_scales (`logical`) optional, whether Y scaling shall be changeable. |
||
| 44 |
- #'+ #' Does not allow scaling to be changed by default (`FALSE`). |
||
| 45 |
- #' For additional details and examples of decorators, refer to the vignette+ #' @param swap_axes (`logical`) optional, whether to swap X and Y axes. Defaults to `FALSE`. |
||
| 46 |
- #' `vignette("decorate-modules-output", package = "teal")` or the [`teal::teal_transform_module()`] documentation.
+ #' @param decorators `r roxygen_decorators_param("tm_g_bivariate")`
|
||
| 48 |
- #' @examplesShinylive+ #' @inherit shared_params return |
||
| 49 |
- #' library(teal.modules.general)+ #' |
||
| 50 |
- #' interactive <- function() TRUE+ #' @section Decorating `tm_g_bivariate`: |
||
| 51 |
- #' {{ next_example }}
+ #' |
||
| 52 |
- #' @examples+ #' This module generates the following objects, which can be modified in place using decorators: |
||
| 53 |
- #'+ #' - `plot` (`ggplot2`) |
||
| 54 |
- #' # general data example+ #' |
||
| 55 |
- #' data <- teal_data()+ #' For additional details and examples of decorators, refer to the vignette |
||
| 56 |
- #' data <- within(data, {
+ #' `vignette("decorate-modules-output", package = "teal")` or the [`teal::teal_transform_module()`] documentation.
|
||
| 57 |
- #' CO2 <- CO2+ #' |
||
| 58 |
- #' CO2[["primary_key"]] <- seq_len(nrow(CO2))+ #' |
||
| 59 |
- #' })+ #' @examplesShinylive |
||
| 60 |
- #' join_keys(data) <- join_keys(join_key("CO2", "CO2", "primary_key"))
+ #' library(teal.modules.general) |
||
| 61 |
- #'+ #' interactive <- function() TRUE |
||
| 62 |
- #' vars <- choices_selected(variable_choices(data[["CO2"]], c("Plant", "Type", "Treatment")))
+ #' {{ next_example }}
|
||
| 63 |
- #'+ #' @examples |
||
| 64 |
- #' app <- init(+ #' # general data example |
||
| 65 |
- #' data = data,+ #' data <- teal_data() |
||
| 66 |
- #' modules = modules(+ #' data <- within(data, {
|
||
| 67 |
- #' tm_outliers(+ #' require(nestcolor) |
||
| 68 |
- #' outlier_var = list(+ #' CO2 <- data.frame(CO2) |
||
| 69 |
- #' data_extract_spec(+ #' }) |
||
| 70 |
- #' dataname = "CO2",+ #' |
||
| 71 |
- #' select = select_spec(+ #' app <- init( |
||
| 72 |
- #' label = "Select variable:",+ #' data = data, |
||
| 73 |
- #' choices = variable_choices(data[["CO2"]], c("conc", "uptake")),
+ #' modules = tm_g_bivariate( |
||
| 74 |
- #' selected = "uptake",+ #' x = data_extract_spec( |
||
| 75 |
- #' multiple = FALSE,+ #' dataname = "CO2", |
||
| 76 |
- #' fixed = FALSE+ #' select = select_spec( |
||
| 77 |
- #' )+ #' label = "Select variable:", |
||
| 78 |
- #' )+ #' choices = variable_choices(data[["CO2"]]), |
||
| 79 |
- #' ),+ #' selected = "conc", |
||
| 80 |
- #' categorical_var = list(+ #' fixed = FALSE |
||
| 81 |
- #' data_extract_spec(+ #' ) |
||
| 82 |
- #' dataname = "CO2",+ #' ), |
||
| 83 |
- #' filter = filter_spec(+ #' y = data_extract_spec( |
||
| 84 |
- #' vars = vars,+ #' dataname = "CO2", |
||
| 85 |
- #' choices = value_choices(data[["CO2"]], vars$selected),+ #' select = select_spec( |
||
| 86 |
- #' selected = value_choices(data[["CO2"]], vars$selected),+ #' label = "Select variable:", |
||
| 87 |
- #' multiple = TRUE+ #' choices = variable_choices(data[["CO2"]]), |
||
| 88 |
- #' )+ #' selected = "uptake", |
||
| 89 |
- #' )+ #' multiple = FALSE, |
||
| 90 |
- #' )+ #' fixed = FALSE |
||
| 91 |
- #' )+ #' ) |
||
| 92 |
- #' )+ #' ), |
||
| 93 |
- #' )+ #' row_facet = data_extract_spec( |
||
| 94 |
- #' if (interactive()) {
+ #' dataname = "CO2", |
||
| 95 |
- #' shinyApp(app$ui, app$server)+ #' select = select_spec( |
||
| 96 |
- #' }+ #' label = "Select variable:", |
||
| 97 |
- #'+ #' choices = variable_choices(data[["CO2"]]), |
||
| 98 |
- #' @examplesShinylive+ #' selected = "Type", |
||
| 99 |
- #' library(teal.modules.general)+ #' fixed = FALSE |
||
| 100 |
- #' interactive <- function() TRUE+ #' ) |
||
| 101 |
- #' {{ next_example }}
+ #' ), |
||
| 102 |
- #' @examples+ #' col_facet = data_extract_spec( |
||
| 103 |
- #'+ #' dataname = "CO2", |
||
| 104 |
- #' # CDISC data example+ #' select = select_spec( |
||
| 105 |
- #' data <- teal_data()+ #' label = "Select variable:", |
||
| 106 |
- #' data <- within(data, {
+ #' choices = variable_choices(data[["CO2"]]), |
||
| 107 |
- #' ADSL <- rADSL+ #' selected = "Treatment", |
||
| 108 |
- #' })+ #' fixed = FALSE |
||
| 109 |
- #' join_keys(data) <- default_cdisc_join_keys[names(data)]+ #' ) |
||
| 110 |
- #'+ #' ) |
||
| 111 |
- #' fact_vars_adsl <- names(Filter(isTRUE, sapply(data[["ADSL"]], is.factor)))+ #' ) |
||
| 112 |
- #' vars <- choices_selected(variable_choices(data[["ADSL"]], fact_vars_adsl))+ #' ) |
||
| 113 |
- #'+ #' if (interactive()) {
|
||
| 114 |
- #'+ #' shinyApp(app$ui, app$server) |
||
| 115 |
- #'+ #' } |
||
| 116 |
- #' app <- init(+ #' |
||
| 117 |
- #' data = data,+ #' @examplesShinylive |
||
| 118 |
- #' modules = modules(+ #' library(teal.modules.general) |
||
| 119 |
- #' tm_outliers(+ #' interactive <- function() TRUE |
||
| 120 |
- #' outlier_var = list(+ #' {{ next_example }}
|
||
| 121 |
- #' data_extract_spec(+ #' @examples |
||
| 122 |
- #' dataname = "ADSL",+ #' # CDISC data example |
||
| 123 |
- #' select = select_spec(+ #' data <- teal_data() |
||
| 124 |
- #' label = "Select variable:",+ #' data <- within(data, {
|
||
| 125 |
- #' choices = variable_choices(data[["ADSL"]], c("AGE", "BMRKR1")),
+ #' require(nestcolor) |
||
| 126 |
- #' selected = "AGE",+ #' ADSL <- teal.data::rADSL |
||
| 127 |
- #' multiple = FALSE,+ #' }) |
||
| 128 |
- #' fixed = FALSE+ #' join_keys(data) <- default_cdisc_join_keys[names(data)] |
||
| 129 |
- #' )+ #' |
||
| 130 |
- #' )+ #' app <- init( |
||
| 131 |
- #' ),+ #' data = data, |
||
| 132 |
- #' categorical_var = list(+ #' modules = tm_g_bivariate( |
||
| 133 |
- #' data_extract_spec(+ #' x = data_extract_spec( |
||
| 134 |
- #' dataname = "ADSL",+ #' dataname = "ADSL", |
||
| 135 |
- #' filter = filter_spec(+ #' select = select_spec( |
||
| 136 |
- #' vars = vars,+ #' label = "Select variable:", |
||
| 137 |
- #' choices = value_choices(data[["ADSL"]], vars$selected),+ #' choices = variable_choices(data[["ADSL"]]), |
||
| 138 |
- #' selected = value_choices(data[["ADSL"]], vars$selected),+ #' selected = "AGE", |
||
| 139 |
- #' multiple = TRUE+ #' fixed = FALSE |
||
| 140 |
- #' )+ #' ) |
||
| 141 |
- #' )+ #' ), |
||
| 142 |
- #' )+ #' y = data_extract_spec( |
||
| 143 |
- #' )+ #' dataname = "ADSL", |
||
| 144 |
- #' )+ #' select = select_spec( |
||
| 145 |
- #' )+ #' label = "Select variable:", |
||
| 146 |
- #' if (interactive()) {
+ #' choices = variable_choices(data[["ADSL"]]), |
||
| 147 |
- #' shinyApp(app$ui, app$server)+ #' selected = "SEX", |
||
| 148 |
- #' }+ #' multiple = FALSE, |
||
| 149 |
- #'+ #' fixed = FALSE |
||
| 150 |
- #' @export+ #' ) |
||
| 151 |
- #'+ #' ), |
||
| 152 |
- tm_outliers <- function(label = "Outliers Module",+ #' row_facet = data_extract_spec( |
||
| 153 |
- outlier_var,+ #' dataname = "ADSL", |
||
| 154 |
- categorical_var = NULL,+ #' select = select_spec( |
||
| 155 |
- ggtheme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void"),
+ #' label = "Select variable:", |
||
| 156 |
- ggplot2_args = teal.widgets::ggplot2_args(),+ #' choices = variable_choices(data[["ADSL"]]), |
||
| 157 |
- plot_height = c(600, 200, 2000),+ #' selected = "ARM", |
||
| 158 |
- plot_width = NULL,+ #' fixed = FALSE |
||
| 159 |
- pre_output = NULL,+ #' ) |
||
| 160 |
- post_output = NULL,+ #' ), |
||
| 161 |
- decorators = NULL) {
+ #' col_facet = data_extract_spec( |
||
| 162 | -! | +
- message("Initializing tm_outliers")
+ #' dataname = "ADSL", |
|
| 163 |
-
+ #' select = select_spec( |
||
| 164 |
- # Normalize the parameters+ #' label = "Select variable:", |
||
| 165 | -! | +
- if (inherits(outlier_var, "data_extract_spec")) outlier_var <- list(outlier_var)+ #' choices = variable_choices(data[["ADSL"]]), |
|
| 166 | -! | +
- if (inherits(categorical_var, "data_extract_spec")) categorical_var <- list(categorical_var)+ #' selected = "COUNTRY", |
|
| 167 | -! | +
- if (inherits(ggplot2_args, "ggplot2_args")) ggplot2_args <- list(default = ggplot2_args)+ #' fixed = FALSE |
|
| 168 |
-
+ #' ) |
||
| 169 |
- # Start of assertions+ #' ) |
||
| 170 | -! | +
- checkmate::assert_string(label)+ #' ) |
|
| 171 | -! | +
- checkmate::assert_list(outlier_var, types = "data_extract_spec")+ #' ) |
|
| 172 |
-
+ #' if (interactive()) {
|
||
| 173 | -! | +
- checkmate::assert_list(categorical_var, types = "data_extract_spec", null.ok = TRUE)+ #' shinyApp(app$ui, app$server) |
|
| 174 | -! | +
- if (is.list(categorical_var)) {
+ #' } |
|
| 175 | -! | +
- lapply(categorical_var, function(x) {
+ #' |
|
| 176 | -! | +
- if (length(x$filter) > 1L) {
+ #' @export |
|
| 177 | -! | +
- stop("tm_outliers: categorical_var data_extract_specs may only specify one filter_spec", call. = FALSE)
+ #' |
|
| 178 |
- }+ tm_g_bivariate <- function(label = "Bivariate Plots", |
||
| 179 |
- })+ x, |
||
| 180 |
- }+ y, |
||
| 181 |
-
+ row_facet = NULL, |
||
| 182 | -! | +
- ggtheme <- match.arg(ggtheme)+ col_facet = NULL, |
|
| 183 |
-
+ facet = !is.null(row_facet) || !is.null(col_facet), |
||
| 184 | -! | +
- plot_choices <- c("Boxplot", "Density Plot", "Cumulative Distribution Plot")
+ color = NULL, |
|
| 185 | -! | +
- checkmate::assert_list(ggplot2_args, types = "ggplot2_args")+ fill = NULL, |
|
| 186 | -! | +
- checkmate::assert_subset(names(ggplot2_args), c("default", plot_choices))
+ size = NULL, |
|
| 187 |
-
+ use_density = FALSE, |
||
| 188 | -! | +
- checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE)+ color_settings = FALSE, |
|
| 189 | -! | +
- checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height")+ free_x_scales = FALSE, |
|
| 190 | -! | +
- checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE)+ free_y_scales = FALSE, |
|
| 191 | -! | +
- checkmate::assert_numeric(+ plot_height = c(600, 200, 2000), |
|
| 192 | -! | +
- plot_width[1],+ plot_width = NULL, |
|
| 193 | -! | +
- lower = plot_width[2], upper = plot_width[3], null.ok = TRUE, .var.name = "plot_width"+ rotate_xaxis_labels = FALSE, |
|
| 194 |
- )+ swap_axes = FALSE, |
||
| 195 |
-
+ ggtheme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void"),
|
||
| 196 | -! | +
- checkmate::assert_multi_class(pre_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
+ ggplot2_args = teal.widgets::ggplot2_args(), |
|
| 197 | -! | +
- checkmate::assert_multi_class(post_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
+ pre_output = NULL, |
|
| 198 |
-
+ post_output = NULL, |
||
| 199 | -! | +
- available_decorators <- c("box_plot", "density_plot", "cumulative_plot", "table")
+ decorators = NULL) {
|
|
| 200 | -! | +18x |
- decorators <- normalize_decorators(decorators)+ message("Initializing tm_g_bivariate")
|
| 201 | -! | +
- assert_decorators(decorators, null.ok = TRUE, names = available_decorators)+ |
|
| 202 |
- # End of assertions+ # Normalize the parameters |
||
| 203 | -+ | 14x |
-
+ if (inherits(x, "data_extract_spec")) x <- list(x) |
| 204 | -+ | 13x |
- # Make UI args+ if (inherits(y, "data_extract_spec")) y <- list(y) |
| 205 | -! | +1x |
- args <- as.list(environment())+ if (inherits(row_facet, "data_extract_spec")) row_facet <- list(row_facet) |
| 206 | -+ | 1x |
-
+ if (inherits(col_facet, "data_extract_spec")) col_facet <- list(col_facet) |
| 207 | -! | +1x |
- data_extract_list <- list(+ if (inherits(color, "data_extract_spec")) color <- list(color) |
| 208 | -! | +1x |
- outlier_var = outlier_var,+ if (inherits(fill, "data_extract_spec")) fill <- list(fill) |
| 209 | -! | +1x |
- categorical_var = categorical_var+ if (inherits(size, "data_extract_spec")) size <- list(size) |
| 210 |
- )+ |
||
| 211 |
-
+ # Start of assertions |
||
| 212 | -+ | 18x |
-
+ checkmate::assert_string(label) |
| 213 | -! | +
- ans <- module(+ |
|
| 214 | -! | +18x |
- label = label,+ checkmate::assert_list(x, types = "data_extract_spec") |
| 215 | -! | +18x |
- server = srv_outliers,+ assert_single_selection(x) |
| 216 | -! | +
- server_args = c(+ |
|
| 217 | -! | +16x |
- data_extract_list,+ checkmate::assert_list(y, types = "data_extract_spec") |
| 218 | -! | +16x |
- list(+ assert_single_selection(y) |
| 219 | -! | +
- plot_height = plot_height, plot_width = plot_width, ggplot2_args = ggplot2_args,+ |
|
| 220 | -! | +14x |
- decorators = decorators+ checkmate::assert_list(row_facet, types = "data_extract_spec", null.ok = TRUE) |
| 221 | -+ | 14x |
- )+ assert_single_selection(row_facet) |
| 222 |
- ),+ |
||
| 223 | -! | +14x |
- ui = ui_outliers,+ checkmate::assert_list(col_facet, types = "data_extract_spec", null.ok = TRUE) |
| 224 | -! | +14x |
- ui_args = args,+ assert_single_selection(col_facet) |
| 225 | -! | +
- datanames = teal.transform::get_extract_datanames(data_extract_list)+ |
|
| 226 | -+ | 14x |
- )+ checkmate::assert_flag(facet) |
| 227 | -! | +
- attr(ans, "teal_bookmarkable") <- TRUE+ |
|
| 228 | -! | +14x |
- ans+ checkmate::assert_list(color, types = "data_extract_spec", null.ok = TRUE) |
| 229 | -+ | 14x |
- }+ assert_single_selection(color) |
| 231 | -+ | 14x |
- # UI function for the outliers module+ checkmate::assert_list(fill, types = "data_extract_spec", null.ok = TRUE) |
| 232 | -+ | 14x |
- ui_outliers <- function(id, ...) {
+ assert_single_selection(fill) |
| 233 | -! | +
- args <- list(...)+ |
|
| 234 | -! | +14x |
- ns <- NS(id)+ checkmate::assert_list(size, types = "data_extract_spec", null.ok = TRUE) |
| 235 | -! | +14x |
- is_single_dataset_value <- teal.transform::is_single_dataset(args$outlier_var, args$categorical_var)+ assert_single_selection(size) |
| 237 | -! | +14x |
- teal.widgets::standard_layout(+ checkmate::assert_flag(use_density) |
| 238 | -! | +
- output = teal.widgets::white_small_well(+ |
|
| 239 | -! | +
- uiOutput(ns("total_outliers")),
+ # Determines color, fill & size if they are not explicitly set |
|
| 240 | -! | +14x |
- DT::dataTableOutput(ns("summary_table")),
+ checkmate::assert_flag(color_settings) |
| 241 | -! | +14x |
- uiOutput(ns("total_missing")),
+ if (color_settings) {
|
| 242 | -! | +2x |
- tags$br(), tags$hr(),+ if (is.null(color)) {
|
| 243 | -! | +2x |
- tabsetPanel(+ color <- x |
| 244 | -! | +2x |
- id = ns("tabs"),
+ color[[1]]$select <- teal.transform::select_spec(choices = color[[1]]$select$choices, selected = NULL) |
| 245 | -! | +
- tabPanel(+ } |
|
| 246 | -! | +2x |
- "Boxplot",+ if (is.null(fill)) {
|
| 247 | -! | +2x |
- teal.widgets::plot_with_settings_ui(id = ns("box_plot"))
+ fill <- x |
| 248 | -+ | 2x |
- ),+ fill[[1]]$select <- teal.transform::select_spec(choices = fill[[1]]$select$choices, selected = NULL) |
| 249 | -! | +
- tabPanel(+ } |
|
| 250 | -! | +2x |
- "Density Plot",+ if (is.null(size)) {
|
| 251 | -! | +2x |
- teal.widgets::plot_with_settings_ui(id = ns("density_plot"))
+ size <- x |
| 252 | -+ | 2x |
- ),+ size[[1]]$select <- teal.transform::select_spec(choices = size[[1]]$select$choices, selected = NULL) |
| 253 | -! | +
- tabPanel(+ } |
|
| 254 | -! | +
- "Cumulative Distribution Plot",+ } else {
|
|
| 255 | -! | +12x |
- teal.widgets::plot_with_settings_ui(id = ns("cum_density_plot"))
+ if (!is.null(c(color, fill, size))) {
|
| 256 | -+ | 3x |
- )+ stop("'color_settings' argument needs to be set to TRUE if 'color', 'fill', and/or 'size' is/are supplied.")
|
| 257 |
- ),+ } |
||
| 258 | -! | +
- tags$br(), tags$hr(),+ } |
|
| 259 | -! | +
- uiOutput(ns("table_ui_wrap")),
+
|
|
| 260 | -! | +11x |
- DT::dataTableOutput(ns("table_ui"))
+ checkmate::assert_flag(free_x_scales) |
| 261 | -+ | 11x |
- ),+ checkmate::assert_flag(free_y_scales) |
| 262 | -! | +
- encoding = tags$div(+ |
|
| 263 | -+ | 11x |
- ### Reporter+ checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE) |
| 264 | -! | +10x |
- teal.reporter::simple_reporter_ui(ns("simple_reporter")),
+ checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height") |
| 265 | -+ | 8x |
- ###+ checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE) |
| 266 | -! | +7x |
- tags$label("Encodings", class = "text-primary"),
+ checkmate::assert_numeric( |
| 267 | -! | +7x |
- teal.transform::datanames_input(args[c("outlier_var", "categorical_var")]),
+ plot_width[1], |
| 268 | -! | +7x |
- teal.transform::data_extract_ui(+ lower = plot_width[2], upper = plot_width[3], null.ok = TRUE, .var.name = "plot_width" |
| 269 | -! | +
- id = ns("outlier_var"),
+ ) |
|
| 270 | -! | +
- label = "Variable",+ |
|
| 271 | -! | +5x |
- data_extract_spec = args$outlier_var,+ checkmate::assert_flag(rotate_xaxis_labels) |
| 272 | -! | +5x |
- is_single_dataset = is_single_dataset_value+ checkmate::assert_flag(swap_axes) |
| 273 |
- ),+ |
||
| 274 | -! | +5x |
- if (!is.null(args$categorical_var)) {
+ ggtheme <- match.arg(ggtheme) |
| 275 | -! | +5x |
- teal.transform::data_extract_ui(+ checkmate::assert_class(ggplot2_args, "ggplot2_args") |
| 276 | -! | +
- id = ns("categorical_var"),
+
|
|
| 277 | -! | +5x |
- label = "Categorical factor",+ checkmate::assert_multi_class(pre_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
|
| 278 | -! | +5x |
- data_extract_spec = args$categorical_var,+ checkmate::assert_multi_class(post_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
|
| 279 | -! | +
- is_single_dataset = is_single_dataset_value+ |
|
| 280 | -+ | 5x |
- )+ decorators <- normalize_decorators(decorators) |
| 281 | -+ | 5x |
- },+ assert_decorators(decorators, null.ok = TRUE, "plot") |
| 282 | -! | +
- conditionalPanel(+ # End of assertions |
|
| 283 | -! | +
- condition = paste0("input['", ns("tabs"), "'] == 'Boxplot'"),
+
|
|
| 284 | -! | +
- teal.widgets::optionalSelectInput(+ # Make UI args |
|
| 285 | -! | +5x |
- inputId = ns("boxplot_alts"),
+ args <- as.list(environment()) |
| 286 | -! | +
- label = "Plot type",+ |
|
| 287 | -! | +5x |
- choices = c("Box plot", "Violin plot"),
+ data_extract_list <- list( |
| 288 | -! | +5x |
- selected = "Box plot",+ x = x, |
| 289 | -! | +5x |
- multiple = FALSE+ y = y, |
| 290 | -+ | 5x |
- )+ row_facet = row_facet, |
| 291 | -+ | 5x |
- ),+ col_facet = col_facet, |
| 292 | -! | +5x |
- shinyjs::hidden(checkboxInput(ns("split_outliers"), "Define outliers based on group splitting", value = FALSE)),
+ color_settings = color_settings, |
| 293 | -! | +5x |
- shinyjs::hidden(checkboxInput(ns("order_by_outlier"), "Re-order categories by outliers [by %]", value = FALSE)),
+ color = color, |
| 294 | -! | +5x |
- teal.widgets::panel_group(+ fill = fill, |
| 295 | -! | +5x |
- teal.widgets::panel_item(+ size = size |
| 296 | -! | +
- title = "Method parameters",+ ) |
|
| 297 | -! | +
- collapsed = FALSE,+ |
|
| 298 | -! | +5x |
- teal.widgets::optionalSelectInput(+ ans <- module( |
| 299 | -! | +5x |
- inputId = ns("method"),
+ label = label, |
| 300 | -! | +5x |
- label = "Method",+ server = srv_g_bivariate, |
| 301 | -! | +5x |
- choices = c("IQR", "Z-score", "Percentile"),
+ ui = ui_g_bivariate, |
| 302 | -! | +5x |
- selected = "IQR",+ ui_args = args, |
| 303 | -! | +5x |
- multiple = FALSE+ server_args = c( |
| 304 | -+ | 5x |
- ),+ data_extract_list, |
| 305 | -! | +5x |
- conditionalPanel(+ list(plot_height = plot_height, plot_width = plot_width, ggplot2_args = ggplot2_args, decorators = decorators) |
| 306 | -! | +
- condition =+ ), |
|
| 307 | -! | +5x |
- paste0("input['", ns("method"), "'] == 'IQR'"),
+ datanames = teal.transform::get_extract_datanames(data_extract_list) |
| 308 | -! | +
- sliderInput(+ ) |
|
| 309 | -! | +5x |
- ns("iqr_slider"),
+ attr(ans, "teal_bookmarkable") <- TRUE |
| 310 | -! | +5x |
- "Outlier range:",+ ans |
| 311 | -! | +
- min = 1,+ } |
|
| 312 | -! | +
- max = 5,+ |
|
| 313 | -! | +
- value = 3,+ # UI function for the bivariate module |
|
| 314 | -! | +
- step = 0.5+ ui_g_bivariate <- function(id, ...) {
|
|
| 315 | -+ | ! |
- )+ args <- list(...) |
| 316 | -+ | ! |
- ),+ is_single_dataset_value <- teal.transform::is_single_dataset( |
| 317 | ! |
- conditionalPanel(+ args$x, args$y, args$row_facet, args$col_facet, args$color, args$fill, args$size |
|
| 318 | -! | +
- condition =+ ) |
|
| 319 | -! | +
- paste0("input['", ns("method"), "'] == 'Z-score'"),
+
|
|
| 320 | ! |
- sliderInput(+ ns <- NS(id) |
|
| 321 | ! |
- ns("zscore_slider"),
+ teal.widgets::standard_layout( |
|
| 322 | ! |
- "Outlier range:",+ output = teal.widgets::white_small_well( |
|
| 323 | ! |
- min = 1,+ tags$div(teal.widgets::plot_with_settings_ui(id = ns("myplot")))
|
|
| 324 | -! | +
- max = 5,+ ), |
|
| 325 | ! |
- value = 3,+ encoding = tags$div( |
|
| 326 | -! | +
- step = 0.5+ ### Reporter |
|
| 327 | -+ | ! |
- )+ teal.reporter::simple_reporter_ui(ns("simple_reporter")),
|
| 328 |
- ),+ ### |
||
| 329 | ! |
- conditionalPanel(+ tags$label("Encodings", class = "text-primary"),
|
|
| 330 | ! |
- condition =+ teal.transform::datanames_input(args[c("x", "y", "row_facet", "col_facet", "color", "fill", "size")]),
|
|
| 331 | ! |
- paste0("input['", ns("method"), "'] == 'Percentile'"),
+ teal.transform::data_extract_ui( |
|
| 332 | ! |
- sliderInput(+ id = ns("x"),
|
|
| 333 | ! |
- ns("percentile_slider"),
+ label = "X variable", |
|
| 334 | ! |
- "Outlier range:",+ data_extract_spec = args$x, |
|
| 335 | ! |
- min = 0.001,+ is_single_dataset = is_single_dataset_value |
|
| 336 | -! | +
- max = 0.5,+ ), |
|
| 337 | ! |
- value = 0.01,+ teal.transform::data_extract_ui( |
|
| 338 | ! |
- step = 0.001+ id = ns("y"),
|
|
| 339 | -+ | ! |
- )+ label = "Y variable", |
| 340 | -+ | ! |
- ),+ data_extract_spec = args$y, |
| 341 | ! |
- uiOutput(ns("ui_outlier_help"))
+ is_single_dataset = is_single_dataset_value |
|
| 342 |
- )+ ), |
||
| 343 | -+ | ! |
- ),+ conditionalPanel( |
| 344 | ! |
- conditionalPanel(+ condition = |
|
| 345 | ! |
- condition = paste0("input['", ns("tabs"), "'] == 'Boxplot'"),
+ "$(\"button[data-id*='-x-dataset'][data-id$='-select']\").text() == '- Nothing selected - ' || |
|
| 346 | ! |
- ui_decorate_teal_data(+ $(\"button[data-id*='-y-dataset'][data-id$='-select']\").text() == '- Nothing selected - ' ", |
|
| 347 | ! |
- ns("d_box_plot"),
+ shinyWidgets::radioGroupButtons( |
|
| 348 | ! |
- decorators = select_decorators(args$decorators, "box_plot")+ inputId = ns("use_density"),
|
|
| 349 | -+ | ! |
- )+ label = NULL, |
| 350 | -+ | ! |
- ),+ choices = c("frequency", "density"),
|
| 351 | ! |
- conditionalPanel(+ selected = ifelse(args$use_density, "density", "frequency"), |
|
| 352 | ! |
- condition = paste0("input['", ns("tabs"), "'] == 'Density Plot'"),
+ justified = TRUE |
|
| 353 | -! | +
- ui_decorate_teal_data(+ ) |
|
| 354 | -! | +
- ns("d_density_plot"),
+ ), |
|
| 355 | ! |
- decorators = select_decorators(args$decorators, "density_plot")+ ui_decorate_teal_data(ns("decorator"), decorators = select_decorators(args$decorators, "plot")),
|
|
| 356 | -+ | ! |
- )+ if (!is.null(args$row_facet) || !is.null(args$col_facet)) {
|
| 357 | -+ | ! |
- ),+ tags$div( |
| 358 | ! |
- conditionalPanel(+ class = "data-extract-box", |
|
| 359 | ! |
- condition = paste0("input['", ns("tabs"), "'] == 'Cumulative Distribution Plot'"),
+ tags$label("Facetting"),
|
|
| 360 | ! |
- ui_decorate_teal_data(+ shinyWidgets::switchInput(inputId = ns("facetting"), value = args$facet, size = "mini"),
|
|
| 361 | ! |
- ns("d_cumulative_plot"),
+ conditionalPanel( |
|
| 362 | ! |
- decorators = select_decorators(args$decorators, "cumulative_plot")+ condition = paste0("input['", ns("facetting"), "']"),
|
|
| 363 | -+ | ! |
- )+ tags$div( |
| 364 | -+ | ! |
- ),+ if (!is.null(args$row_facet)) {
|
| 365 | ! |
- ui_decorate_teal_data(ns("d_table"), decorators = select_decorators(args$decorators, "table")),
+ teal.transform::data_extract_ui( |
|
| 366 | ! |
- teal.widgets::panel_item(+ id = ns("row_facet"),
|
|
| 367 | ! |
- title = "Plot settings",+ label = "Row facetting variable", |
|
| 368 | ! |
- selectInput(+ data_extract_spec = args$row_facet, |
|
| 369 | ! |
- inputId = ns("ggtheme"),
+ is_single_dataset = is_single_dataset_value |
|
| 370 | -! | +
- label = "Theme (by ggplot):",+ ) |
|
| 371 | -! | +
- choices = ggplot_themes,+ }, |
|
| 372 | ! |
- selected = args$ggtheme,+ if (!is.null(args$col_facet)) {
|
|
| 373 | ! |
- multiple = FALSE+ teal.transform::data_extract_ui( |
|
| 374 | -+ | ! |
- )+ id = ns("col_facet"),
|
| 375 | -+ | ! |
- )+ label = "Column facetting variable", |
| 376 | -+ | ! |
- ),+ data_extract_spec = args$col_facet, |
| 377 | ! |
- forms = tagList(+ is_single_dataset = is_single_dataset_value |
|
| 378 | -! | +
- teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code")
+ ) |
|
| 379 |
- ),+ }, |
||
| 380 | ! |
- pre_output = args$pre_output,+ checkboxInput(ns("free_x_scales"), "free x scales", value = args$free_x_scales),
|
|
| 381 | ! |
- post_output = args$post_output+ checkboxInput(ns("free_y_scales"), "free y scales", value = args$free_y_scales)
|
|
| 382 |
- )+ ) |
||
| 383 |
- }+ ) |
||
| 384 |
-
+ ) |
||
| 385 |
- # Server function for the outliers module+ }, |
||
| 386 | -+ | ! |
- # Server function for the outliers module+ if (args$color_settings) {
|
| 387 |
- srv_outliers <- function(id, data, reporter, filter_panel_api, outlier_var,+ # Put a grey border around the coloring settings |
||
| 388 | -+ | ! |
- categorical_var, plot_height, plot_width, ggplot2_args, decorators) {
+ tags$div( |
| 389 | ! |
- with_reporter <- !missing(reporter) && inherits(reporter, "Reporter")+ class = "data-extract-box", |
|
| 390 | ! |
- with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI")+ tags$label("Color settings"),
|
|
| 391 | ! |
- checkmate::assert_class(data, "reactive")+ shinyWidgets::switchInput(inputId = ns("coloring"), value = TRUE, size = "mini"),
|
|
| 392 | ! |
- checkmate::assert_class(isolate(data()), "teal_data")+ conditionalPanel( |
|
| 393 | ! |
- moduleServer(id, function(input, output, session) {
+ condition = paste0("input['", ns("coloring"), "']"),
|
|
| 394 | ! |
- teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.general")+ tags$div( |
|
| 395 | -+ | ! |
-
+ teal.transform::data_extract_ui( |
| 396 | ! |
- ns <- session$ns+ id = ns("color"),
|
|
| 397 | -+ | ! |
-
+ label = "Outline color by variable", |
| 398 | ! |
- vars <- list(outlier_var = outlier_var, categorical_var = categorical_var)+ data_extract_spec = args$color, |
|
| 399 | -+ | ! |
-
+ is_single_dataset = is_single_dataset_value |
| 400 | -! | +
- rule_diff <- function(other) {
+ ), |
|
| 401 | ! |
- function(value) {
+ teal.transform::data_extract_ui( |
|
| 402 | ! |
- othervalue <- tryCatch(selector_list()[[other]]()[["select"]], error = function(e) NULL)+ id = ns("fill"),
|
|
| 403 | ! |
- if (!is.null(othervalue) && identical(othervalue, value)) {
+ label = "Fill color by variable", |
|
| 404 | ! |
- "`Variable` and `Categorical factor` cannot be the same"+ data_extract_spec = args$fill, |
|
| 405 | -+ | ! |
- }+ is_single_dataset = is_single_dataset_value |
| 406 |
- }+ ), |
||
| 407 | -+ | ! |
- }+ tags$div( |
| 408 | -+ | ! |
-
+ id = ns("size_settings"),
|
| 409 | ! |
- selector_list <- teal.transform::data_extract_multiple_srv(+ teal.transform::data_extract_ui( |
|
| 410 | ! |
- data_extract = vars,+ id = ns("size"),
|
|
| 411 | ! |
- datasets = data,+ label = "Size of points by variable (only if x and y are numeric)", |
|
| 412 | ! |
- select_validation_rule = list(+ data_extract_spec = args$size, |
|
| 413 | ! |
- outlier_var = shinyvalidate::compose_rules(+ is_single_dataset = is_single_dataset_value |
|
| 414 | -! | +
- shinyvalidate::sv_required("Please select a variable"),
+ ) |
|
| 415 | -! | +
- rule_diff("categorical_var")
+ ) |
|
| 416 |
- ),+ ) |
||
| 417 | -! | +
- categorical_var = rule_diff("outlier_var")
+ ) |
|
| 418 |
- )+ ) |
||
| 419 |
- )+ }, |
||
| 420 | -+ | ! |
-
+ teal.widgets::panel_group( |
| 421 | ! |
- iv_r <- reactive({
+ teal.widgets::panel_item( |
|
| 422 | ! |
- iv <- shinyvalidate::InputValidator$new()+ title = "Plot settings", |
|
| 423 | ! |
- iv$add_rule("method", shinyvalidate::sv_required("Please select a method"))
+ checkboxInput(ns("rotate_xaxis_labels"), "Rotate X axis labels", value = args$rotate_xaxis_labels),
|
|
| 424 | ! |
- iv$add_rule("boxplot_alts", shinyvalidate::sv_required("Please select Plot Type"))
+ checkboxInput(ns("swap_axes"), "Swap axes", value = args$swap_axes),
|
|
| 425 | ! |
- teal.transform::compose_and_enable_validators(iv, selector_list)+ selectInput( |
|
| 426 | -+ | ! |
- })+ inputId = ns("ggtheme"),
|
| 427 | -+ | ! |
-
+ label = "Theme (by ggplot):", |
| 428 | ! |
- reactive_select_input <- reactive({
+ choices = ggplot_themes, |
|
| 429 | ! |
- if (is.null(selector_list()$categorical_var) || length(selector_list()$categorical_var()$select) == 0) {
+ selected = args$ggtheme, |
|
| 430 | ! |
- selector_list()[names(selector_list()) != "categorical_var"]+ multiple = FALSE |
|
| 431 |
- } else {
+ ), |
||
| 432 | ! |
- selector_list()+ sliderInput( |
|
| 433 | -+ | ! |
- }+ ns("alpha"), "Opacity Scatterplot:",
|
| 434 | -+ | ! |
- })+ min = 0, max = 1, |
| 435 | -+ | ! |
-
+ step = .05, value = .5, ticks = FALSE |
| 436 | -! | +
- anl_merged_input <- teal.transform::merge_expression_srv(+ ), |
|
| 437 | ! |
- selector_list = reactive_select_input,+ sliderInput( |
|
| 438 | ! |
- datasets = data,+ ns("fixed_size"), "Scatterplot point size:",
|
|
| 439 | ! |
- merge_function = "dplyr::inner_join"+ min = 1, max = 8, |
|
| 440 | -+ | ! |
- )+ step = 1, value = 2, ticks = FALSE |
| 441 |
-
+ ), |
||
| 442 | ! |
- anl_merged_q <- reactive({
+ checkboxInput(ns("add_lines"), "Add lines"),
|
|
| 443 | -! | +
- req(anl_merged_input())+ ) |
|
| 444 | -! | +
- data() %>%+ ) |
|
| 445 | -! | +
- teal.code::eval_code(as.expression(anl_merged_input()$expr))+ ), |
|
| 446 | -+ | ! |
- })+ forms = tagList( |
| 447 | -+ | ! |
-
+ teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code")
|
| 448 | -! | +
- merged <- list(+ ), |
|
| 449 | ! |
- anl_input_r = anl_merged_input,+ pre_output = args$pre_output, |
|
| 450 | ! |
- anl_q_r = anl_merged_q+ post_output = args$post_output |
|
| 451 |
- )+ ) |
||
| 452 |
-
+ } |
||
| 453 | -! | +
- n_outlier_missing <- reactive({
+
|
|
| 454 | -! | +
- req(iv_r()$is_valid())+ # Server function for the bivariate module |
|
| 455 | -! | +
- outlier_var <- as.vector(merged$anl_input_r()$columns_source$outlier_var)+ srv_g_bivariate <- function(id, |
|
| 456 | -! | +
- ANL <- merged$anl_q_r()[["ANL"]]+ data, |
|
| 457 | -! | +
- sum(is.na(ANL[[outlier_var]]))+ reporter, |
|
| 458 |
- })+ filter_panel_api, |
||
| 459 |
-
+ x, |
||
| 460 |
- # Used to create outlier table and the dropdown with additional columns+ y, |
||
| 461 | -! | +
- dataname_first <- isolate(names(data())[[1]])+ row_facet, |
|
| 462 |
-
+ col_facet, |
||
| 463 | -! | +
- common_code_q <- reactive({
+ color_settings = FALSE, |
|
| 464 | -! | +
- req(iv_r()$is_valid())+ color, |
|
| 465 |
-
+ fill, |
||
| 466 | -! | +
- ANL <- merged$anl_q_r()[["ANL"]]+ size, |
|
| 467 | -! | +
- qenv <- merged$anl_q_r()+ plot_height, |
|
| 468 |
-
+ plot_width, |
||
| 469 | -! | +
- outlier_var <- as.vector(merged$anl_input_r()$columns_source$outlier_var)+ ggplot2_args, |
|
| 470 | -! | +
- categorical_var <- as.vector(merged$anl_input_r()$columns_source$categorical_var)+ decorators) {
|
|
| 471 | ! |
- order_by_outlier <- input$order_by_outlier+ with_reporter <- !missing(reporter) && inherits(reporter, "Reporter") |
|
| 472 | ! |
- method <- input$method+ with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI") |
|
| 473 | ! |
- split_outliers <- input$split_outliers+ checkmate::assert_class(data, "reactive") |
|
| 474 | ! |
- teal::validate_has_data(+ checkmate::assert_class(isolate(data()), "teal_data") |
|
| 475 | -+ | ! |
- # missing values in the categorical variable may be used to form a category of its own+ moduleServer(id, function(input, output, session) {
|
| 476 | ! |
- `if`(+ teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.general") |
|
| 477 | -! | +
- length(categorical_var) == 0,+ |
|
| 478 | ! |
- ANL,+ ns <- session$ns |
|
| 479 | -! | +
- ANL[, names(ANL) != categorical_var, drop = FALSE]+ |
|
| 480 | -+ | ! |
- ),+ data_extract <- list( |
| 481 | ! |
- min_nrow = 10,+ x = x, y = y, row_facet = row_facet, col_facet = col_facet, |
|
| 482 | ! |
- complete = TRUE,+ color = color, fill = fill, size = size |
|
| 483 | -! | +
- allow_inf = FALSE+ ) |
|
| 484 |
- )+ |
||
| 485 | ! |
- validate(need(is.numeric(ANL[[outlier_var]]), "`Variable` is not numeric"))+ rule_var <- function(other) {
|
|
| 486 | ! |
- validate(need(length(unique(ANL[[outlier_var]])) > 1, "Variable has no variation, i.e. only one unique value"))+ function(value) {
|
|
| 487 | -+ | ! |
-
+ othervalue <- selector_list()[[other]]()$select |
| 488 | -+ | ! |
- # show/hide split_outliers+ if (length(value) == 0L && length(othervalue) == 0L) {
|
| 489 | ! |
- if (length(categorical_var) == 0) {
+ "Please select at least one of x-variable or y-variable" |
|
| 490 | -! | +
- shinyjs::hide("split_outliers")
+ } |
|
| 491 | -! | +
- if (n_outlier_missing() > 0) {
+ } |
|
| 492 | -! | +
- qenv <- teal.code::eval_code(+ } |
|
| 493 | ! |
- qenv,+ rule_diff <- function(other) {
|
|
| 494 | ! |
- substitute(+ function(value) {
|
|
| 495 | ! |
- expr = ANL <- ANL %>% dplyr::filter(!is.na(outlier_var_name)),+ othervalue <- selector_list()[[other]]()[["select"]] |
|
| 496 | ! |
- env = list(outlier_var_name = as.name(outlier_var))+ if (!is.null(othervalue)) {
|
|
| 497 | -+ | ! |
- )+ if (identical(value, othervalue)) {
|
| 498 | -+ | ! |
- )+ "Row and column facetting variables must be different." |
| 499 |
- }+ } |
||
| 500 |
- } else {
+ } |
||
| 501 | -! | +
- validate(need(+ } |
|
| 502 | -! | +
- is.factor(ANL[[categorical_var]]) ||+ } |
|
| 503 | -! | +
- is.character(ANL[[categorical_var]]) ||+ |
|
| 504 | ! |
- is.integer(ANL[[categorical_var]]),+ selector_list <- teal.transform::data_extract_multiple_srv( |
|
| 505 | ! |
- "`Categorical factor` must be `factor`, `character`, or `integer`"+ data_extract = data_extract, |
|
| 506 | -+ | ! |
- ))+ datasets = data, |
| 507 | -+ | ! |
-
+ select_validation_rule = list( |
| 508 | ! |
- if (n_outlier_missing() > 0) {
+ x = rule_var("y"),
|
|
| 509 | ! |
- qenv <- teal.code::eval_code(+ y = rule_var("x"),
|
|
| 510 | ! |
- qenv,+ row_facet = shinyvalidate::compose_rules( |
|
| 511 | ! |
- substitute(+ shinyvalidate::sv_optional(), |
|
| 512 | ! |
- expr = ANL <- ANL %>% dplyr::filter(!is.na(outlier_var_name)),+ rule_diff("col_facet")
|
|
| 513 | -! | +
- env = list(outlier_var_name = as.name(outlier_var))+ ), |
|
| 514 | -+ | ! |
- )+ col_facet = shinyvalidate::compose_rules( |
| 515 | -+ | ! |
- )+ shinyvalidate::sv_optional(), |
| 516 | -+ | ! |
- }+ rule_diff("row_facet")
|
| 517 | -! | +
- shinyjs::show("split_outliers")
+ ) |
|
| 518 |
- }+ ) |
||
| 519 |
-
+ ) |
||
| 520 |
- # slider+ |
||
| 521 | ! |
- outlier_definition_param <- if (method == "IQR") {
+ iv_r <- reactive({
|
|
| 522 | ! |
- input$iqr_slider+ iv_facet <- shinyvalidate::InputValidator$new() |
|
| 523 | ! |
- } else if (method == "Z-score") {
+ iv_child <- teal.transform::compose_and_enable_validators(iv_facet, selector_list, |
|
| 524 | ! |
- input$zscore_slider+ validator_names = c("row_facet", "col_facet")
|
|
| 525 | -! | +
- } else if (method == "Percentile") {
+ ) |
|
| 526 | ! |
- input$percentile_slider+ iv_child$condition(~ isTRUE(input$facetting)) |
|
| 527 |
- }+ |
||
| 528 | -+ | ! |
-
+ iv <- shinyvalidate::InputValidator$new() |
| 529 | -+ | ! |
- # this is utils function that converts a %>% NULL %>% b into a %>% b+ iv$add_validator(iv_child) |
| 530 | ! |
- remove_pipe_null <- function(x) {
+ teal.transform::compose_and_enable_validators(iv, selector_list, validator_names = c("x", "y"))
|
|
| 531 | -! | +
- if (length(x) == 1) {
+ }) |
|
| 532 | -! | +
- return(x)+ |
|
| 533 | -+ | ! |
- }+ anl_merged_input <- teal.transform::merge_expression_srv( |
| 534 | ! |
- if (identical(x[[1]], as.name("%>%")) && is.null(x[[3]])) {
+ selector_list = selector_list, |
|
| 535 | ! |
- return(remove_pipe_null(x[[2]]))+ datasets = data |
|
| 536 |
- }+ ) |
||
| 537 | -! | +
- return(as.call(c(x[[1]], lapply(x[-1], remove_pipe_null))))+ |
|
| 538 | -+ | ! |
- }+ anl_merged_q <- reactive({
|
| 539 | -+ | ! |
-
+ req(anl_merged_input()) |
| 540 | ! |
- qenv <- teal.code::eval_code(+ data() %>% |
|
| 541 | ! |
- qenv,+ teal.code::eval_code(as.expression(anl_merged_input()$expr)) |
|
| 542 | -! | +
- substitute(+ }) |
|
| 543 | -! | +
- expr = {
+
|
|
| 544 | ! |
- ANL_OUTLIER <- ANL %>%+ merged <- list( |
|
| 545 | ! |
- group_expr %>% # styler: off+ anl_input_r = anl_merged_input, |
|
| 546 | ! |
- dplyr::mutate(is_outlier = {
+ anl_q_r = anl_merged_q |
|
| 547 | -! | +
- q1_q3 <- stats::quantile(outlier_var_name, probs = c(0.25, 0.75))+ ) |
|
| 548 | -! | +
- iqr <- q1_q3[2] - q1_q3[1]+ |
|
| 549 | ! |
- !(outlier_var_name >= q1_q3[1] - 1.5 * iqr & outlier_var_name <= q1_q3[2] + 1.5 * iqr)+ output_q <- reactive({
|
|
| 550 | -+ | ! |
- }) %>%+ teal::validate_inputs(iv_r()) |
| 551 | -! | +
- calculate_outliers %>% # styler: off+ |
|
| 552 | ! |
- ungroup_expr %>% # styler: off+ ANL <- merged$anl_q_r()[["ANL"]] |
|
| 553 | ! |
- dplyr::filter(is_outlier | is_outlier_selected) %>%+ teal::validate_has_data(ANL, 3) |
|
| 554 | -! | +
- dplyr::select(-is_outlier)+ |
|
| 555 | -+ | ! |
- },+ x_col_vec <- as.vector(merged$anl_input_r()$columns_source$x) |
| 556 | ! |
- env = list(+ x_name <- `if`(is.null(x_col_vec), character(0), x_col_vec) |
|
| 557 | ! |
- calculate_outliers = if (method == "IQR") {
+ y_col_vec <- as.vector(merged$anl_input_r()$columns_source$y) |
|
| 558 | ! |
- substitute(+ y_name <- `if`(is.null(y_col_vec), character(0), y_col_vec) |
|
| 559 | -! | +
- expr = dplyr::mutate(is_outlier_selected = {
+
|
|
| 560 | ! |
- q1_q3 <- stats::quantile(outlier_var_name, probs = c(0.25, 0.75))+ row_facet_name <- as.vector(merged$anl_input_r()$columns_source$row_facet) |
|
| 561 | ! |
- iqr <- q1_q3[2] - q1_q3[1]+ col_facet_name <- as.vector(merged$anl_input_r()$columns_source$col_facet) |
|
| 562 | -+ | ! |
- !(+ color_name <- if ("color" %in% names(merged$anl_input_r()$columns_source)) {
|
| 563 | ! |
- outlier_var_name >= q1_q3[1] - outlier_definition_param * iqr &+ as.vector(merged$anl_input_r()$columns_source$color) |
|
| 564 | -! | +
- outlier_var_name <= q1_q3[2] + outlier_definition_param * iqr+ } else {
|
|
| 565 | -+ | ! |
- )+ character(0) |
| 566 |
- }),+ } |
||
| 567 | ! |
- env = list(+ fill_name <- if ("fill" %in% names(merged$anl_input_r()$columns_source)) {
|
|
| 568 | ! |
- outlier_var_name = as.name(outlier_var),+ as.vector(merged$anl_input_r()$columns_source$fill) |
|
| 569 | -! | +
- outlier_definition_param = outlier_definition_param+ } else {
|
|
| 570 | -+ | ! |
- )+ character(0) |
| 571 |
- )+ } |
||
| 572 | ! |
- } else if (method == "Z-score") {
+ size_name <- if ("size" %in% names(merged$anl_input_r()$columns_source)) {
|
|
| 573 | ! |
- substitute(+ as.vector(merged$anl_input_r()$columns_source$size) |
|
| 574 | -! | +
- expr = dplyr::mutate(+ } else {
|
|
| 575 | ! |
- is_outlier_selected = abs(outlier_var_name - mean(outlier_var_name)) /+ character(0) |
|
| 576 | -! | +
- stats::sd(outlier_var_name) > outlier_definition_param+ } |
|
| 577 |
- ),+ |
||
| 578 | ! |
- env = list(+ use_density <- input$use_density == "density" |
|
| 579 | ! |
- outlier_var_name = as.name(outlier_var),+ free_x_scales <- input$free_x_scales |
|
| 580 | ! |
- outlier_definition_param = outlier_definition_param+ free_y_scales <- input$free_y_scales |
|
| 581 | -+ | ! |
- )+ ggtheme <- input$ggtheme |
| 582 | -+ | ! |
- )+ rotate_xaxis_labels <- input$rotate_xaxis_labels |
| 583 | ! |
- } else if (method == "Percentile") {
+ swap_axes <- input$swap_axes |
|
| 584 | -! | +
- substitute(+ |
|
| 585 | ! |
- expr = dplyr::mutate(+ is_scatterplot <- all(vapply(ANL[c(x_name, y_name)], is.numeric, logical(1))) && |
|
| 586 | ! |
- is_outlier_selected = outlier_var_name < stats::quantile(outlier_var_name, outlier_definition_param) |+ length(x_name) > 0 && length(y_name) > 0 |
|
| 587 | -! | +
- outlier_var_name > stats::quantile(outlier_var_name, 1 - outlier_definition_param)+ |
|
| 588 | -+ | ! |
- ),+ if (is_scatterplot) {
|
| 589 | ! |
- env = list(+ shinyjs::show("alpha")
|
|
| 590 | ! |
- outlier_var_name = as.name(outlier_var),+ alpha <- input$alpha |
|
| 591 | ! |
- outlier_definition_param = outlier_definition_param+ shinyjs::show("add_lines")
|
|
| 592 |
- )+ |
||
| 593 | -+ | ! |
- )+ if (color_settings && input$coloring) {
|
| 594 | -+ | ! |
- },+ shinyjs::hide("fixed_size")
|
| 595 | ! |
- outlier_var_name = as.name(outlier_var),+ shinyjs::show("size_settings")
|
|
| 596 | ! |
- group_expr = if (isTRUE(split_outliers) && length(categorical_var) != 0) {
+ size <- NULL |
|
| 597 | -! | +
- substitute(dplyr::group_by(x), list(x = as.name(categorical_var)))+ } else {
|
|
| 598 | -+ | ! |
- },+ shinyjs::show("fixed_size")
|
| 599 | ! |
- ungroup_expr = if (isTRUE(split_outliers) && length(categorical_var) != 0) {
+ size <- input$fixed_size |
|
| 600 | -! | +
- substitute(dplyr::ungroup())+ } |
|
| 601 |
- }+ } else {
|
||
| 602 | -+ | ! |
- )+ shinyjs::hide("add_lines")
|
| 603 | -+ | ! |
- ) %>%+ updateCheckboxInput(session, "add_lines", value = restoreInput(ns("add_lines"), FALSE))
|
| 604 | ! |
- remove_pipe_null()+ shinyjs::hide("alpha")
|
|
| 605 | -+ | ! |
- )+ shinyjs::hide("fixed_size")
|
| 606 | -+ | ! |
-
+ shinyjs::hide("size_settings")
|
| 607 | -+ | ! |
- # ANL_OUTLIER_EXTENDED is the base table+ alpha <- 1 |
| 608 | ! |
- qenv <- teal.code::eval_code(+ size <- NULL |
|
| 609 | -! | +
- qenv,+ } |
|
| 610 | -! | +
- substitute(+ |
|
| 611 | ! |
- expr = {
+ teal::validate_has_data(ANL[, c(x_name, y_name), drop = FALSE], 3, complete = TRUE, allow_inf = FALSE) |
|
| 612 | -! | +
- ANL_OUTLIER_EXTENDED <- dplyr::left_join(+ |
|
| 613 | ! |
- ANL_OUTLIER,+ cl <- bivariate_plot_call( |
|
| 614 | ! |
- dplyr::select(+ data_name = "ANL", |
|
| 615 | ! |
- dataname,+ x = x_name, |
|
| 616 | ! |
- dplyr::setdiff(names(dataname), dplyr::setdiff(names(ANL_OUTLIER), join_keys))+ y = y_name, |
|
| 617 | -+ | ! |
- ),+ x_class = ifelse(!identical(x_name, character(0)), class(ANL[[x_name]]), "NULL"), |
| 618 | ! |
- by = join_keys+ y_class = ifelse(!identical(y_name, character(0)), class(ANL[[y_name]]), "NULL"), |
|
| 619 | -+ | ! |
- )+ x_label = varname_w_label(x_name, ANL), |
| 620 | -+ | ! |
- },+ y_label = varname_w_label(y_name, ANL), |
| 621 | ! |
- env = list(+ freq = !use_density, |
|
| 622 | ! |
- dataname = as.name(dataname_first),+ theme = ggtheme, |
|
| 623 | ! |
- join_keys = as.character(teal.data::join_keys(data())[dataname_first, dataname_first])+ rotate_xaxis_labels = rotate_xaxis_labels, |
|
| 624 | -+ | ! |
- )+ swap_axes = swap_axes, |
| 625 | -+ | ! |
- )+ alpha = alpha, |
| 626 | -+ | ! |
- )+ size = size, |
| 627 | -+ | ! |
-
+ ggplot2_args = ggplot2_args |
| 628 | -! | +
- qenv <- if (length(categorical_var) > 0) {
+ ) |
|
| 629 | -! | +
- qenv <- teal.code::eval_code(+ |
|
| 630 | ! |
- qenv,+ facetting <- (isTRUE(input$facetting) && (!is.null(row_facet_name) || !is.null(col_facet_name))) |
|
| 631 | -! | +
- substitute(+ |
|
| 632 | ! |
- expr = summary_table_pre <- ANL_OUTLIER %>%+ if (facetting) {
|
|
| 633 | ! |
- dplyr::filter(is_outlier_selected) %>%+ facet_cl <- facet_ggplot_call(row_facet_name, col_facet_name, free_x_scales, free_y_scales) |
|
| 634 | -! | +
- dplyr::select(outlier_var_name, categorical_var_name) %>%+ |
|
| 635 | ! |
- dplyr::group_by(categorical_var_name) %>%+ if (!is.null(facet_cl)) {
|
|
| 636 | ! |
- dplyr::summarise(n_outliers = dplyr::n()) %>%+ cl <- call("+", cl, facet_cl)
|
|
| 637 | -! | +
- dplyr::right_join(+ } |
|
| 638 | -! | +
- ANL %>%+ } |
|
| 639 | -! | +
- dplyr::select(outlier_var_name, categorical_var_name) %>%+ |
|
| 640 | ! |
- dplyr::group_by(categorical_var_name) %>%+ if (input$add_lines) {
|
|
| 641 | ! |
- dplyr::summarise(+ cl <- call("+", cl, quote(geom_line(size = 1)))
|
|
| 642 | -! | +
- total_in_cat = dplyr::n(),+ } |
|
| 643 | -! | +
- n_na = sum(is.na(outlier_var_name) | is.na(categorical_var_name))+ |
|
| 644 | -+ | ! |
- ),+ coloring_cl <- NULL |
| 645 | ! |
- by = categorical_var+ if (color_settings) {
|
|
| 646 | -+ | ! |
- ) %>%+ if (input$coloring) {
|
| 647 | -+ | ! |
- # This is important as there may be categorical variables with natural orderings, e.g. AGE.+ coloring_cl <- coloring_ggplot_call( |
| 648 | -+ | ! |
- # The plots should be displayed by default in increasing order in these situations.+ colour = color_name, |
| 649 | -+ | ! |
- # dplyr::arrange will sort integer, factor, and character data types in the expected way.+ fill = fill_name, |
| 650 | ! |
- dplyr::arrange(categorical_var_name) %>%+ size = size_name, |
|
| 651 | ! |
- dplyr::mutate(+ is_point = any(grepl("geom_point", cl %>% deparse()))
|
|
| 652 | -! | +
- n_outliers = dplyr::if_else(is.na(n_outliers), 0, as.numeric(n_outliers)),+ ) |
|
| 653 | ! |
- display_str = dplyr::if_else(+ legend_lbls <- substitute( |
|
| 654 | ! |
- n_outliers > 0,+ expr = labs(color = color_name, fill = fill_name, size = size_name), |
|
| 655 | ! |
- sprintf("%d [%.02f%%]", n_outliers, 100 * n_outliers / total_in_cat),
+ env = list( |
|
| 656 | ! |
- "0"+ color_name = varname_w_label(color_name, ANL), |
|
| 657 | -+ | ! |
- ),+ fill_name = varname_w_label(fill_name, ANL), |
| 658 | ! |
- display_str_na = dplyr::if_else(+ size_name = varname_w_label(size_name, ANL) |
|
| 659 | -! | +
- n_na > 0,+ ) |
|
| 660 | -! | +
- sprintf("%d [%.02f%%]", n_na, 100 * n_na / total_in_cat),
+ ) |
|
| 661 | -! | +
- "0"+ } |
|
| 662 | -+ | ! |
- ),+ if (!is.null(coloring_cl)) {
|
| 663 | ! |
- order = seq_along(n_outliers)+ cl <- call("+", call("+", cl, coloring_cl), legend_lbls)
|
|
| 664 |
- ),+ } |
||
| 665 | -! | +
- env = list(+ } |
|
| 666 | -! | +
- categorical_var = categorical_var,+ |
|
| 667 | ! |
- categorical_var_name = as.name(categorical_var),+ teal.code::eval_code(merged$anl_q_r(), substitute(expr = plot <- cl, env = list(cl = cl))) |
|
| 668 | -! | +
- outlier_var_name = as.name(outlier_var)+ }) |
|
| 669 |
- )+ |
||
| 670 | -+ | ! |
- )+ decorated_output_q_facets <- srv_decorate_teal_data( |
| 671 | -+ | ! |
- )+ "decorator", |
| 672 | -+ | ! |
- # now to handle when user chooses to order based on amount of outliers+ data = output_q, |
| 673 | ! |
- if (order_by_outlier) {
+ decorators = select_decorators(decorators, "plot"), |
|
| 674 | ! |
- qenv <- teal.code::eval_code(+ expr = reactive({
|
|
| 675 | ! |
- qenv,+ ANL <- merged$anl_q_r()[["ANL"]] |
|
| 676 | ! |
- quote(+ row_facet_name <- as.vector(merged$anl_input_r()$columns_source$row_facet) |
|
| 677 | ! |
- summary_table_pre <- summary_table_pre %>%+ col_facet_name <- as.vector(merged$anl_input_r()$columns_source$col_facet) |
|
| 678 | -! | +
- dplyr::arrange(desc(n_outliers / total_in_cat)) %>%+ |
|
| 679 | -! | +
- dplyr::mutate(order = seq_len(nrow(summary_table_pre)))+ # Add labels to facets |
|
| 680 | -+ | ! |
- )+ nulled_row_facet_name <- varname_w_label(row_facet_name, ANL) |
| 681 | -+ | ! |
- )+ nulled_col_facet_name <- varname_w_label(col_facet_name, ANL) |
| 682 | -+ | ! |
- }+ facetting <- (isTRUE(input$facetting) && (!is.null(row_facet_name) || !is.null(col_facet_name))) |
| 683 | -+ | ! |
-
+ without_facet <- (is.null(nulled_row_facet_name) && is.null(nulled_col_facet_name)) || !facetting |
| 684 | -! | +
- teal.code::eval_code(+ |
|
| 685 | ! |
- qenv,+ print_call <- if (without_facet) {
|
|
| 686 | ! |
- substitute(+ quote(print(plot)) |
|
| 687 | -! | +
- expr = {
+ } else {
|
|
| 688 | -+ | ! |
- # In order for geom_rug to work properly when reordering takes place inside facet_grid,+ substitute( |
| 689 | -+ | ! |
- # all tables must have the column used for reording.+ expr = {
|
| 690 |
- # In this case, the column used for reordering is `order`.+ # Add facetting labels |
||
| 691 | -! | +
- ANL_OUTLIER <- dplyr::left_join(+ # optional: grid.newpage() # nolint: commented_code. |
|
| 692 | -! | +
- ANL_OUTLIER,+ # Prefixed with teal.modules.general as its usage will appear in "Show R code" |
|
| 693 | ! |
- summary_table_pre[, c("order", categorical_var)],
+ plot <- teal.modules.general::add_facet_labels( |
|
| 694 | ! |
- by = categorical_var+ plot, |
|
| 695 | -+ | ! |
- )+ xfacet_label = nulled_col_facet_name, |
| 696 | -+ | ! |
- # so that x axis of plot aligns with columns of summary table, from most outliers to least by percentage+ yfacet_label = nulled_row_facet_name |
| 697 | -! | +
- ANL <- ANL %>%+ ) |
|
| 698 | ! |
- dplyr::left_join(+ grid::grid.newpage() |
|
| 699 | ! |
- dplyr::select(summary_table_pre, categorical_var_name, order),+ grid::grid.draw(plot) |
|
| 700 | -! | +
- by = categorical_var+ }, |
|
| 701 | -+ | ! |
- ) %>%+ env = list(nulled_col_facet_name = nulled_col_facet_name, nulled_row_facet_name = nulled_row_facet_name) |
| 702 | -! | +
- dplyr::arrange(order)+ ) |
|
| 703 | -! | +
- summary_table <- summary_table_pre %>%+ } |
|
| 704 | ! |
- dplyr::select(+ print_call |
|
| 705 | -! | +
- categorical_var_name,+ }), |
|
| 706 | ! |
- Outliers = display_str, Missings = display_str_na, Total = total_in_cat+ expr_is_reactive = TRUE |
|
| 707 |
- ) %>%+ ) |
||
| 708 | -! | +
- dplyr::mutate_all(as.character) %>%+ |
|
| 709 | ! |
- tidyr::pivot_longer(-categorical_var_name) %>%+ plot_r <- reactive(req(decorated_output_q_facets())[["plot"]]) |
|
| 710 | -! | +
- tidyr::pivot_wider(names_from = categorical_var, values_from = value) %>%+ |
|
| 711 | ! |
- tibble::column_to_rownames("name")
+ pws <- teal.widgets::plot_with_settings_srv( |
|
| 712 | -+ | ! |
- },+ id = "myplot", |
| 713 | ! |
- env = list(+ plot_r = plot_r, |
|
| 714 | ! |
- categorical_var = categorical_var,+ height = plot_height, |
|
| 715 | ! |
- categorical_var_name = as.name(categorical_var)+ width = plot_width |
|
| 716 |
- )+ ) |
||
| 717 |
- )+ |
||
| 718 | -+ | ! |
- )+ teal.widgets::verbatim_popup_srv( |
| 719 | -+ | ! |
- } else {
+ id = "rcode", |
| 720 | ! |
- within(qenv, summary_table <- data.frame())+ verbatim_content = reactive(teal.code::get_code(req(decorated_output_q_facets()))), |
|
| 721 | -+ | ! |
- }+ title = "Bivariate Plot" |
| 722 |
-
+ ) |
||
| 723 |
- # Datatable is generated in qenv to allow for output decoration+ |
||
| 724 | -! | +
- qenv <- within(qenv, {
+ ### REPORTER |
|
| 725 | ! |
- table <- DT::datatable(+ if (with_reporter) {
|
|
| 726 | ! |
- summary_table,+ card_fun <- function(comment, label) {
|
|
| 727 | ! |
- options = list(+ card <- teal::report_card_template( |
|
| 728 | ! |
- dom = "t",+ title = "Bivariate Plot", |
|
| 729 | ! |
- autoWidth = TRUE,+ label = label, |
|
| 730 | ! |
- columnDefs = list(list(width = "200px", targets = "_all"))+ with_filter = with_filter, |
|
| 731 | -+ | ! |
- )+ filter_panel_api = filter_panel_api |
| 733 | -+ | ! |
- })+ card$append_text("Plot", "header3")
|
| 734 | -+ | ! |
-
+ card$append_plot(plot_r(), dim = pws$dim()) |
| 735 | ! |
- if (length(categorical_var) > 0 && nrow(qenv[["ANL_OUTLIER"]]) > 0) {
+ if (!comment == "") {
|
|
| 736 | ! |
- shinyjs::show("order_by_outlier")
+ card$append_text("Comment", "header3")
|
|
| 737 | -+ | ! |
- } else {
+ card$append_text(comment) |
| 738 | -! | +
- shinyjs::hide("order_by_outlier")
+ } |
|
| 739 | -+ | ! |
- }+ card$append_src(teal.code::get_code(req(decorated_output_q_facets))) |
| 740 | -+ | ! |
-
+ card |
| 741 | -! | +
- qenv+ } |
|
| 742 | -+ | ! |
- })+ teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
|
| 743 |
-
+ } |
||
| 744 |
- # boxplot/violinplot # nolint commented_code+ ### |
||
| 745 | -! | +
- box_plot_q <- reactive({
+ }) |
|
| 746 | -! | +
- req(common_code_q())+ } |
|
| 747 | -! | +
- ANL <- common_code_q()[["ANL"]]+ |
|
| 748 | -! | +
- ANL_OUTLIER <- common_code_q()[["ANL_OUTLIER"]]+ # Get Substituted ggplot call |
|
| 749 |
-
+ bivariate_plot_call <- function(data_name, |
||
| 750 | -! | +
- outlier_var <- as.vector(merged$anl_input_r()$columns_source$outlier_var)+ x = character(0), |
|
| 751 | -! | +
- categorical_var <- as.vector(merged$anl_input_r()$columns_source$categorical_var)+ y = character(0), |
|
| 752 |
-
+ x_class = "NULL", |
||
| 753 |
- # validation+ y_class = "NULL", |
||
| 754 | -! | +
- teal::validate_has_data(ANL, 1)+ x_label = NULL, |
|
| 755 |
-
+ y_label = NULL, |
||
| 756 |
- # boxplot+ freq = TRUE, |
||
| 757 | -! | +
- plot_call <- quote(ANL %>% ggplot())+ theme = "gray", |
|
| 758 |
-
+ rotate_xaxis_labels = FALSE, |
||
| 759 | -! | +
- plot_call <- if (input$boxplot_alts == "Box plot") {
+ swap_axes = FALSE, |
|
| 760 | -! | +
- substitute(expr = plot_call + geom_boxplot(outlier.shape = NA), env = list(plot_call = plot_call))+ alpha = double(0), |
|
| 761 | -! | +
- } else if (input$boxplot_alts == "Violin plot") {
+ size = 2, |
|
| 762 | -! | +
- substitute(expr = plot_call + geom_violin(), env = list(plot_call = plot_call))+ ggplot2_args = teal.widgets::ggplot2_args()) {
|
|
| 763 | -+ | ! |
- } else {
+ supported_types <- c("NULL", "numeric", "integer", "factor", "character", "logical", "ordered")
|
| 764 | ! |
- NULL+ validate(need(x_class %in% supported_types, paste0("Data type '", x_class, "' is not supported.")))
|
|
| 765 | -+ | ! |
- }+ validate(need(y_class %in% supported_types, paste0("Data type '", y_class, "' is not supported.")))
|
| 767 | -! | +
- plot_call <- if (identical(categorical_var, character(0)) || is.null(categorical_var)) {
+
|
|
| 768 | ! |
- inner_call <- substitute(+ if (identical(x, character(0))) {
|
|
| 769 | ! |
- expr = plot_call ++ x <- x_label <- "-" |
|
| 770 | -! | +
- aes(x = "Entire dataset", y = outlier_var_name) ++ } else {
|
|
| 771 | ! |
- scale_x_discrete(),+ x <- if (is.call(x)) x else as.name(x) |
|
| 772 | -! | +
- env = list(plot_call = plot_call, outlier_var_name = as.name(outlier_var))+ } |
|
| 773 | -+ | ! |
- )+ if (identical(y, character(0))) {
|
| 774 | ! |
- if (nrow(ANL_OUTLIER) > 0) {
+ y <- y_label <- "-" |
|
| 775 | -! | +
- substitute(+ } else {
|
|
| 776 | ! |
- expr = inner_call + geom_point(+ y <- if (is.call(y)) y else as.name(y) |
|
| 777 | -! | +
- data = ANL_OUTLIER,+ } |
|
| 778 | -! | +
- aes(x = "Entire dataset", y = outlier_var_name, color = is_outlier_selected)+ |
|
| 779 | -+ | ! |
- ),+ cl <- bivariate_ggplot_call( |
| 780 | ! |
- env = list(inner_call = inner_call, outlier_var_name = as.name(outlier_var))+ x_class = x_class, |
|
| 781 | -+ | ! |
- )+ y_class = y_class, |
| 782 | -+ | ! |
- } else {
+ freq = freq, |
| 783 | ! |
- inner_call+ theme = theme, |
|
| 784 | -+ | ! |
- }+ rotate_xaxis_labels = rotate_xaxis_labels, |
| 785 | -+ | ! |
- } else {
+ swap_axes = swap_axes, |
| 786 | ! |
- substitute(+ alpha = alpha, |
|
| 787 | ! |
- expr = plot_call ++ size = size, |
|
| 788 | ! |
- aes(y = outlier_var_name, x = reorder(categorical_var_name, order)) ++ ggplot2_args = ggplot2_args, |
|
| 789 | ! |
- xlab(categorical_var) ++ x = x, |
|
| 790 | ! |
- scale_x_discrete() ++ y = y, |
|
| 791 | ! |
- geom_point(+ xlab = x_label, |
|
| 792 | ! |
- data = ANL_OUTLIER,+ ylab = y_label, |
|
| 793 | ! |
- aes(x = as.factor(categorical_var_name), y = outlier_var_name, color = is_outlier_selected)+ data_name = data_name |
|
| 794 |
- ),+ ) |
||
| 795 | -! | +
- env = list(+ } |
|
| 796 | -! | +
- plot_call = plot_call,+ |
|
| 797 | -! | +
- outlier_var_name = as.name(outlier_var),+ # Create ggplot part of plot call |
|
| 798 | -! | +
- categorical_var_name = as.name(categorical_var),+ # Due to the type of the x and y variable the plot type is chosen |
|
| 799 | -! | +
- categorical_var = categorical_var+ bivariate_ggplot_call <- function(x_class, |
|
| 800 |
- )+ y_class, |
||
| 801 |
- )+ freq = TRUE, |
||
| 802 |
- }+ theme = "gray", |
||
| 803 |
-
+ rotate_xaxis_labels = FALSE, |
||
| 804 | -! | +
- dev_ggplot2_args <- teal.widgets::ggplot2_args(+ swap_axes = FALSE, |
|
| 805 | -! | +
- labs = list(color = "Is outlier?"),+ size = double(0), |
|
| 806 | -! | +
- theme = list(legend.position = "top")+ alpha = double(0), |
|
| 807 |
- )+ x = NULL, |
||
| 808 |
-
+ y = NULL, |
||
| 809 | -! | +
- all_ggplot2_args <- teal.widgets::resolve_ggplot2_args(+ xlab = "-", |
|
| 810 | -! | +
- user_plot = ggplot2_args[["Boxplot"]],+ ylab = "-", |
|
| 811 | -! | +
- user_default = ggplot2_args$default,+ data_name = "ANL", |
|
| 812 | -! | +
- module_plot = dev_ggplot2_args+ ggplot2_args = teal.widgets::ggplot2_args()) {
|
|
| 813 | -+ | 42x |
- )+ x_class <- switch(x_class, |
| 814 | -+ | 42x |
-
+ "character" = , |
| 815 | -! | +42x |
- parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(+ "ordered" = , |
| 816 | -! | +42x |
- all_ggplot2_args,+ "logical" = , |
| 817 | -! | +42x |
- ggtheme = input$ggtheme+ "factor" = "factor", |
| 818 | -+ | 42x |
- )+ "integer" = , |
| 819 | -+ | 42x |
-
+ "numeric" = "numeric", |
| 820 | -! | +42x |
- teal.code::eval_code(+ "NULL" = "NULL", |
| 821 | -! | +42x |
- common_code_q(),+ stop("unsupported x_class: ", x_class)
|
| 822 | -! | +
- substitute(+ ) |
|
| 823 | -! | +42x |
- expr = box_plot <- plot_call ++ y_class <- switch(y_class, |
| 824 | -! | +42x |
- scale_color_manual(values = c("TRUE" = "red", "FALSE" = "black")) +
+ "character" = , |
| 825 | -! | +42x |
- labs + ggthemes + themes,+ "ordered" = , |
| 826 | -! | +42x |
- env = list(+ "logical" = , |
| 827 | -! | +42x |
- plot_call = plot_call,+ "factor" = "factor", |
| 828 | -! | +42x |
- labs = parsed_ggplot2_args$labs,+ "integer" = , |
| 829 | -! | +42x |
- ggthemes = parsed_ggplot2_args$ggtheme,+ "numeric" = "numeric", |
| 830 | -! | +42x |
- themes = parsed_ggplot2_args$theme+ "NULL" = "NULL", |
| 831 | -+ | 42x |
- )+ stop("unsupported y_class: ", y_class)
|
| 832 |
- )+ ) |
||
| 833 |
- )+ |
||
| 834 | -+ | 42x |
- })+ if (all(c(x_class, y_class) == "NULL")) {
|
| 835 | -+ | ! |
-
+ stop("either x or y is required")
|
| 836 |
- # density plot+ } |
||
| 837 | -! | +
- density_plot_q <- reactive({
+
|
|
| 838 | -! | +42x |
- ANL <- common_code_q()[["ANL"]]+ reduce_plot_call <- function(...) {
|
| 839 | -! | +104x |
- ANL_OUTLIER <- common_code_q()[["ANL_OUTLIER"]]+ args <- Filter(Negate(is.null), list(...)) |
| 840 | -+ | 104x |
-
+ Reduce(function(x, y) call("+", x, y), args)
|
| 841 | -! | +
- outlier_var <- as.vector(merged$anl_input_r()$columns_source$outlier_var)+ } |
|
| 842 | -! | +
- categorical_var <- as.vector(merged$anl_input_r()$columns_source$categorical_var)+ |
|
| 843 | -+ | 42x |
-
+ plot_call <- substitute(ggplot(data_name), env = list(data_name = as.name(data_name))) |
| 844 |
- # validation+ |
||
| 845 | -! | +
- teal::validate_has_data(ANL, 1)+ # Single data plots |
|
| 846 | -+ | 42x |
- # plot+ if (x_class == "numeric" && y_class == "NULL") {
|
| 847 | -! | +6x |
- plot_call <- substitute(+ plot_call <- reduce_plot_call(plot_call, substitute(aes(x = xval), env = list(xval = x))) |
| 848 | -! | +
- expr = ANL %>%+ |
|
| 849 | -! | +6x |
- ggplot(aes(x = outlier_var_name)) ++ if (freq) {
|
| 850 | -! | +4x |
- geom_density() ++ plot_call <- reduce_plot_call( |
| 851 | -! | +4x |
- geom_rug(data = ANL_OUTLIER, aes(x = outlier_var_name, color = is_outlier_selected)) ++ plot_call, |
| 852 | -! | +4x |
- scale_color_manual(values = c("TRUE" = "red", "FALSE" = "black")),
+ quote(geom_histogram(bins = 30)), |
| 853 | -! | +4x |
- env = list(outlier_var_name = as.name(outlier_var))+ quote(ylab("Frequency"))
|
| 855 |
-
+ } else {
|
||
| 856 | -! | +2x |
- plot_call <- if (identical(categorical_var, character(0)) || is.null(categorical_var)) {
+ plot_call <- reduce_plot_call( |
| 857 | -! | +2x |
- substitute(expr = plot_call, env = list(plot_call = plot_call))+ plot_call, |
| 858 | -+ | 2x |
- } else {
+ quote(geom_histogram(bins = 30, aes(y = after_stat(density)))), |
| 859 | -! | +2x |
- substitute(+ quote(geom_density(aes(y = after_stat(density)))), |
| 860 | -! | +2x |
- expr = plot_call + facet_grid(~ reorder(categorical_var_name, order)),+ quote(ylab("Density"))
|
| 861 | -! | +
- env = list(plot_call = plot_call, categorical_var_name = as.name(categorical_var))+ ) |
|
| 862 |
- )+ } |
||
| 863 | -+ | 36x |
- }+ } else if (x_class == "NULL" && y_class == "numeric") {
|
| 864 | -+ | 6x |
-
+ plot_call <- reduce_plot_call(plot_call, substitute(aes(x = yval), env = list(yval = y))) |
| 865 | -! | +
- dev_ggplot2_args <- teal.widgets::ggplot2_args(+ |
|
| 866 | -! | +6x |
- labs = list(color = "Is outlier?"),+ if (freq) {
|
| 867 | -! | +4x |
- theme = list(legend.position = "top")+ plot_call <- reduce_plot_call( |
| 868 | -+ | 4x |
- )+ plot_call, |
| 869 | -+ | 4x |
-
+ quote(geom_histogram(bins = 30)), |
| 870 | -! | +4x |
- all_ggplot2_args <- teal.widgets::resolve_ggplot2_args(+ quote(ylab("Frequency"))
|
| 871 | -! | +
- user_plot = ggplot2_args[["Density Plot"]],+ ) |
|
| 872 | -! | +
- user_default = ggplot2_args$default,+ } else {
|
|
| 873 | -! | +2x |
- module_plot = dev_ggplot2_args+ plot_call <- reduce_plot_call( |
| 874 | -+ | 2x |
- )+ plot_call, |
| 875 | -+ | 2x |
-
+ quote(geom_histogram(bins = 30, aes(y = after_stat(density)))), |
| 876 | -! | +2x |
- parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(+ quote(geom_density(aes(y = after_stat(density)))), |
| 877 | -! | +2x |
- all_ggplot2_args,+ quote(ylab("Density"))
|
| 878 | -! | +
- ggtheme = input$ggtheme+ ) |
|
| 879 |
- )+ } |
||
| 880 | -+ | 30x |
-
+ } else if (x_class == "factor" && y_class == "NULL") {
|
| 881 | -! | +4x |
- teal.code::eval_code(+ plot_call <- reduce_plot_call(plot_call, substitute(aes(x = xval), env = list(xval = x))) |
| 882 | -! | +
- common_code_q(),+ |
|
| 883 | -! | +4x |
- substitute(+ if (freq) {
|
| 884 | -! | +2x |
- expr = density_plot <- plot_call + labs + ggthemes + themes,+ plot_call <- reduce_plot_call( |
| 885 | -! | +2x |
- env = list(+ plot_call, |
| 886 | -! | +2x |
- plot_call = plot_call,+ quote(geom_bar()), |
| 887 | -! | +2x |
- labs = parsed_ggplot2_args$labs,+ quote(ylab("Frequency"))
|
| 888 | -! | +
- themes = parsed_ggplot2_args$theme,+ ) |
|
| 889 | -! | +
- ggthemes = parsed_ggplot2_args$ggtheme+ } else {
|
|
| 890 | -+ | 2x |
- )+ plot_call <- reduce_plot_call( |
| 891 | -+ | 2x |
- )+ plot_call, |
| 892 | -+ | 2x |
- )+ quote(geom_bar(aes(y = after_stat(prop), group = 1))), |
| 893 | -+ | 2x |
- })+ quote(ylab("Fraction"))
|
| 894 |
-
+ ) |
||
| 895 |
- # Cumulative distribution plot+ } |
||
| 896 | -! | +26x |
- cumulative_plot_q <- reactive({
+ } else if (x_class == "NULL" && y_class == "factor") {
|
| 897 | -! | +4x |
- ANL <- common_code_q()[["ANL"]]+ plot_call <- reduce_plot_call(plot_call, substitute(aes(x = yval), env = list(yval = y))) |
| 898 | -! | +
- ANL_OUTLIER <- common_code_q()[["ANL_OUTLIER"]]+ |
|
| 899 | -+ | 4x |
-
+ if (freq) {
|
| 900 | -! | +2x |
- qenv <- common_code_q()+ plot_call <- reduce_plot_call( |
| 901 | -+ | 2x |
-
+ plot_call, |
| 902 | -! | +2x |
- outlier_var <- as.vector(merged$anl_input_r()$columns_source$outlier_var)+ quote(geom_bar()), |
| 903 | -! | +2x |
- categorical_var <- as.vector(merged$anl_input_r()$columns_source$categorical_var)+ quote(ylab("Frequency"))
|
| 904 |
-
+ ) |
||
| 905 |
- # validation+ } else {
|
||
| 906 | -! | +2x |
- teal::validate_has_data(ANL, 1)+ plot_call <- reduce_plot_call( |
| 907 | -+ | 2x |
-
+ plot_call, |
| 908 | -+ | 2x |
- # plot+ quote(geom_bar(aes(y = after_stat(prop), group = 1))), |
| 909 | -! | +2x |
- plot_call <- substitute(+ quote(ylab("Fraction"))
|
| 910 | -! | +
- expr = ANL %>% ggplot(aes(x = outlier_var_name)) ++ ) |
|
| 911 | -! | +
- stat_ecdf(),+ } |
|
| 912 | -! | +
- env = list(outlier_var_name = as.name(outlier_var))+ # Numeric Plots |
|
| 913 | -+ | 22x |
- )+ } else if (x_class == "numeric" && y_class == "numeric") {
|
| 914 | -! | +2x |
- if (length(categorical_var) == 0) {
+ plot_call <- reduce_plot_call( |
| 915 | -! | +2x |
- qenv <- teal.code::eval_code(+ plot_call, |
| 916 | -! | +2x |
- qenv,+ substitute(aes(x = xval, y = yval), env = list(xval = x, yval = y)), |
| 917 | -! | +
- substitute(+ # pch = 21 for consistent coloring behaviour b/w all geoms (outline and fill properties) |
|
| 918 | -! | +2x |
- expr = {
+ `if`( |
| 919 | -! | +2x |
- ecdf_df <- ANL %>%+ !is.null(size), |
| 920 | -! | +2x |
- dplyr::mutate(+ substitute( |
| 921 | -! | +2x |
- y = stats::ecdf(ANL[[outlier_var]])(ANL[[outlier_var]])+ geom_point(alpha = alphaval, size = sizeval, pch = 21), |
| 922 | -+ | 2x |
- )+ env = list(alphaval = alpha, sizeval = size) |
| 923 |
-
+ ), |
||
| 924 | -! | +2x |
- outlier_points <- dplyr::left_join(+ substitute( |
| 925 | -! | +2x |
- ecdf_df,+ geom_point(alpha = alphaval, pch = 21), |
| 926 | -! | +2x |
- ANL_OUTLIER,+ env = list(alphaval = alpha) |
| 927 | -! | +
- by = dplyr::setdiff(names(ecdf_df), "y")+ ) |
|
| 928 |
- ) %>%+ ) |
||
| 929 | -! | +
- dplyr::filter(!is.na(is_outlier_selected))+ ) |
|
| 930 | -+ | 20x |
- },+ } else if ((x_class == "numeric" && y_class == "factor") || (x_class == "factor" && y_class == "numeric")) {
|
| 931 | -! | +6x |
- env = list(outlier_var = outlier_var)+ plot_call <- reduce_plot_call( |
| 932 | -+ | 6x |
- )+ plot_call, |
| 933 | -+ | 6x |
- )+ substitute(aes(x = xval, y = yval), env = list(xval = x, yval = y)), |
| 934 | -+ | 6x |
- } else {
+ quote(geom_boxplot()) |
| 935 | -! | +
- qenv <- teal.code::eval_code(+ ) |
|
| 936 | -! | +
- qenv,+ # Factor and character plots |
|
| 937 | -! | +14x |
- substitute(+ } else if (x_class == "factor" && y_class == "factor") {
|
| 938 | -! | +14x |
- expr = {
+ plot_call <- reduce_plot_call( |
| 939 | -! | +14x |
- all_categories <- lapply(+ plot_call, |
| 940 | -! | +14x |
- unique(ANL[[categorical_var]]),+ substitute( |
| 941 | -! | +14x |
- function(x) {
+ ggmosaic::geom_mosaic(aes(x = ggmosaic::product(xval), fill = yval), na.rm = TRUE), |
| 942 | -! | +14x |
- ANL <- ANL %>% dplyr::filter(get(categorical_var) == x)+ env = list(xval = x, yval = y) |
| 943 | -! | +
- anl_outlier2 <- ANL_OUTLIER %>% dplyr::filter(get(categorical_var) == x)+ ) |
|
| 944 | -! | +
- ecdf_df <- ANL %>%+ ) |
|
| 945 | -! | +
- dplyr::mutate(y = stats::ecdf(ANL[[outlier_var]])(ANL[[outlier_var]]))+ } else {
|
|
| 946 | -+ | ! |
-
+ stop("x y type combination not allowed")
|
| 947 | -! | +
- dplyr::left_join(+ } |
|
| 948 | -! | +
- ecdf_df,+ |
|
| 949 | -! | +42x |
- anl_outlier2,+ labs_base <- if (x_class == "NULL") {
|
| 950 | -! | +10x |
- by = dplyr::setdiff(names(ecdf_df), "y")+ list(x = substitute(ylab, list(ylab = ylab))) |
| 951 | -+ | 42x |
- ) %>%+ } else if (y_class == "NULL") {
|
| 952 | -! | +10x |
- dplyr::filter(!is.na(is_outlier_selected))+ list(x = substitute(xlab, list(xlab = xlab))) |
| 953 |
- }+ } else {
|
||
| 954 | -+ | 22x |
- )+ list( |
| 955 | -! | +22x |
- outlier_points <- do.call(rbind, all_categories)+ x = substitute(xlab, list(xlab = xlab)), |
| 956 | -+ | 22x |
- },+ y = substitute(ylab, list(ylab = ylab)) |
| 957 | -! | +
- env = list(categorical_var = categorical_var, outlier_var = outlier_var)+ ) |
|
| 958 |
- )+ } |
||
| 959 |
- )+ |
||
| 960 | -! | +42x |
- plot_call <- substitute(+ dev_ggplot2_args <- teal.widgets::ggplot2_args(labs = labs_base) |
| 961 | -! | +
- expr = plot_call + facet_grid(~ reorder(categorical_var_name, order)),+ |
|
| 962 | -! | +42x |
- env = list(plot_call = plot_call, categorical_var_name = as.name(categorical_var))+ if (rotate_xaxis_labels) {
|
| 963 | -+ | ! |
- )+ dev_ggplot2_args$theme <- list(axis.text.x = quote(element_text(angle = 45, hjust = 1))) |
| 964 |
- }+ } |
||
| 966 | -! | +42x |
- dev_ggplot2_args <- teal.widgets::ggplot2_args(+ all_ggplot2_args <- teal.widgets::resolve_ggplot2_args( |
| 967 | -! | +42x |
- labs = list(color = "Is outlier?"),+ user_plot = ggplot2_args, |
| 968 | -! | +42x |
- theme = list(legend.position = "top")+ module_plot = dev_ggplot2_args |
| 969 |
- )+ ) |
||
| 971 | -! | +42x |
- all_ggplot2_args <- teal.widgets::resolve_ggplot2_args(+ parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(all_ggplot2_args, ggtheme = theme) |
| 972 | -! | +
- user_plot = ggplot2_args[["Cumulative Distribution Plot"]],+ |
|
| 973 | -! | +42x |
- user_default = ggplot2_args$default,+ plot_call <- reduce_plot_call( |
| 974 | -! | +42x |
- module_plot = dev_ggplot2_args+ plot_call, |
| 975 | -+ | 42x |
- )+ parsed_ggplot2_args$labs, |
| 976 | -+ | 42x |
-
+ parsed_ggplot2_args$ggtheme, |
| 977 | -! | +42x |
- parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(+ parsed_ggplot2_args$theme |
| 978 | -! | +
- all_ggplot2_args,+ ) |
|
| 979 | -! | +
- ggtheme = input$ggtheme+ |
|
| 980 | -+ | 42x |
- )+ if (swap_axes) {
|
| 981 | -+ | ! |
-
+ plot_call <- reduce_plot_call(plot_call, quote(coord_flip())) |
| 982 | -! | +
- teal.code::eval_code(+ } |
|
| 983 | -! | +
- qenv,+ |
|
| 984 | -! | +42x |
- substitute(+ plot_call |
| 985 | -! | +
- expr = cumulative_plot <- plot_call ++ } |
|
| 986 | -! | +
- geom_point(data = outlier_points, aes(x = outlier_var_name, y = y, color = is_outlier_selected)) ++ |
|
| 987 | -! | +
- scale_color_manual(values = c("TRUE" = "red", "FALSE" = "black")) +
+ # Create facet call |
|
| 988 | -! | +
- labs + ggthemes + themes,+ facet_ggplot_call <- function(row_facet = character(0), |
|
| 989 | -! | +
- env = list(+ col_facet = character(0), |
|
| 990 | -! | +
- plot_call = plot_call,+ free_x_scales = FALSE, |
|
| 991 | -! | +
- outlier_var_name = as.name(outlier_var),+ free_y_scales = FALSE) {
|
|
| 992 | ! |
- labs = parsed_ggplot2_args$labs,+ scales <- if (free_x_scales && free_y_scales) {
|
|
| 993 | ! |
- themes = parsed_ggplot2_args$theme,+ "free" |
|
| 994 | ! |
- ggthemes = parsed_ggplot2_args$ggtheme+ } else if (free_x_scales) {
|
|
| 995 | -+ | ! |
- )+ "free_x" |
| 996 | -+ | ! |
- )+ } else if (free_y_scales) {
|
| 997 | -+ | ! |
- )+ "free_y" |
| 998 |
- })+ } else {
|
||
| 999 | -+ | ! |
-
+ "fixed" |
| 1000 | -! | +
- current_tab_r <- reactive({
+ } |
|
| 1001 | -! | +
- switch(req(input$tabs),+ |
|
| 1002 | ! |
- "Boxplot" = "box_plot",+ if (identical(row_facet, character(0)) && identical(col_facet, character(0))) {
|
|
| 1003 | ! |
- "Density Plot" = "density_plot",+ NULL |
|
| 1004 | ! |
- "Cumulative Distribution Plot" = "cumulative_plot"+ } else if (!identical(row_facet, character(0)) && !identical(col_facet, character(0))) {
|
|
| 1005 | -+ | ! |
- )+ call( |
| 1006 | -+ | ! |
- })+ "facet_grid", |
| 1007 | -+ | ! |
-
+ rows = call_fun_dots("vars", row_facet),
|
| 1008 | ! |
- decorated_q <- mapply(+ cols = call_fun_dots("vars", col_facet),
|
|
| 1009 | ! |
- function(obj_name, q) {
+ scales = scales |
|
| 1010 | -! | +
- srv_decorate_teal_data(+ ) |
|
| 1011 | ! |
- id = sprintf("d_%s", obj_name),
+ } else if (identical(row_facet, character(0)) && !identical(col_facet, character(0))) {
|
|
| 1012 | ! |
- data = q,+ call("facet_grid", cols = call_fun_dots("vars", col_facet), scales = scales)
|
|
| 1013 | ! |
- decorators = select_decorators(decorators, obj_name),+ } else if (!identical(row_facet, character(0)) && identical(col_facet, character(0))) {
|
|
| 1014 | ! |
- expr = reactive({
+ call("facet_grid", rows = call_fun_dots("vars", row_facet), scales = scales)
|
|
| 1015 | -! | +
- substitute(+ } |
|
| 1016 | -! | +
- expr = {
+ } |
|
| 1017 | -! | +
- columns_index <- union(+ |
|
| 1018 | -! | +
- setdiff(names(ANL_OUTLIER), c("is_outlier_selected", "order")),
+ coloring_ggplot_call <- function(colour, |
|
| 1019 | -! | +
- table_columns+ fill, |
|
| 1020 |
- )+ size, |
||
| 1021 | -! | +
- ANL_OUTLIER_EXTENDED[ANL_OUTLIER_EXTENDED$is_outlier_selected, columns_index]+ is_point = FALSE) {
|
|
| 1022 | -! | +
- print(.plot)+ if ( |
|
| 1023 | -+ | 15x |
- },+ !identical(colour, character(0)) && |
| 1024 | -! | +15x |
- env = list(table_columns = input$table_ui_columns, .plot = as.name(obj_name))+ !identical(fill, character(0)) && |
| 1025 | -+ | 15x |
- )+ is_point && |
| 1026 | -+ | 15x |
- }),+ !identical(size, character(0)) |
| 1027 | -! | +
- expr_is_reactive = TRUE+ ) {
|
|
| 1028 | -+ | 1x |
- )+ substitute( |
| 1029 | -+ | 1x |
- },+ expr = aes(colour = colour_name, fill = fill_name, size = size_name), |
| 1030 | -! | +1x |
- rlang::set_names(c("box_plot", "density_plot", "cumulative_plot")),
+ env = list(colour_name = as.name(colour), fill_name = as.name(fill), size_name = as.name(size)) |
| 1031 | -! | +
- c(box_plot_q, density_plot_q, cumulative_plot_q)+ ) |
|
| 1032 |
- )+ } else if ( |
||
| 1033 | -+ | 14x |
-
+ identical(colour, character(0)) && |
| 1034 | -! | +14x |
- decorated_final_q_no_table <- reactive(decorated_q[[req(current_tab_r())]]())+ !identical(fill, character(0)) && |
| 1035 | -+ | 14x |
-
+ is_point && |
| 1036 | -! | +14x |
- decorated_final_q <- srv_decorate_teal_data(+ identical(size, character(0)) |
| 1037 | -! | +
- "d_table",+ ) {
|
|
| 1038 | -! | +1x |
- data = decorated_final_q_no_table,+ substitute(expr = aes(fill = fill_name), env = list(fill_name = as.name(fill))) |
| 1039 | -! | +
- decorators = select_decorators(decorators, "table"),+ } else if ( |
|
| 1040 | -! | +13x |
- expr = table+ !identical(colour, character(0)) && |
| 1041 | -+ | 13x |
- )+ !identical(fill, character(0)) && |
| 1042 | -+ | 13x |
-
+ (!is_point || identical(size, character(0))) |
| 1043 | -! | +
- output$summary_table <- DT::renderDataTable(+ ) {
|
|
| 1044 | -! | +3x |
- expr = {
+ substitute( |
| 1045 | -! | +3x |
- if (iv_r()$is_valid()) {
+ expr = aes(colour = colour_name, fill = fill_name), |
| 1046 | -! | +3x |
- categorical_var <- as.vector(merged$anl_input_r()$columns_source$categorical_var)+ env = list(colour_name = as.name(colour), fill_name = as.name(fill)) |
| 1047 | -! | +
- if (!is.null(categorical_var)) {
+ ) |
|
| 1048 | -! | +
- decorated_final_q()[["table"]]+ } else if ( |
|
| 1049 | -+ | 10x |
- }+ !identical(colour, character(0)) && |
| 1050 | -+ | 10x |
- }+ identical(fill, character(0)) && |
| 1051 | -+ | 10x |
- }+ (!is_point || identical(size, character(0))) |
| 1052 |
- )+ ) {
|
||
| 1053 | -+ | 1x |
-
+ substitute(expr = aes(colour = colour_name), env = list(colour_name = as.name(colour))) |
| 1054 |
- # slider text+ } else if ( |
||
| 1055 | -! | +9x |
- output$ui_outlier_help <- renderUI({
+ identical(colour, character(0)) && |
| 1056 | -! | +9x |
- req(input$method)+ !identical(fill, character(0)) && |
| 1057 | -! | +9x |
- if (input$method == "IQR") {
+ (!is_point || identical(size, character(0))) |
| 1058 | -! | +
- req(input$iqr_slider)+ ) {
|
|
| 1059 | -! | +2x |
- tags$small(+ substitute(expr = aes(fill = fill_name), env = list(fill_name = as.name(fill))) |
| 1060 | -! | +
- withMathJax(+ } else if ( |
|
| 1061 | -! | +7x |
- helpText(+ identical(colour, character(0)) && |
| 1062 | -! | +7x |
- "Outlier data points (\\(x \\lt Q1 - ", input$iqr_slider, "\\times IQR\\) or \\(+ identical(fill, character(0)) && |
| 1063 | -! | +7x |
- Q3 + ", input$iqr_slider, "\\times IQR \\lt x\\))+ is_point && |
| 1064 | -! | +7x |
- are displayed in red on the plot and can be visualized in the table below."+ !identical(size, character(0)) |
| 1065 |
- ),+ ) {
|
||
| 1066 | -! | +1x |
- if (input$split_outliers) {
+ substitute(expr = aes(size = size_name), env = list(size_name = as.name(size))) |
| 1067 | -! | +
- withMathJax(helpText("Note: Quantiles are calculated per group."))
+ } else if ( |
|
| 1068 | -+ | 6x |
- }+ !identical(colour, character(0)) && |
| 1069 | -+ | 6x |
- )+ identical(fill, character(0)) && |
| 1070 | -+ | 6x |
- )+ is_point && |
| 1071 | -! | +6x |
- } else if (input$method == "Z-score") {
+ !identical(size, character(0)) |
| 1072 | -! | +
- req(input$zscore_slider)+ ) {
|
|
| 1073 | -! | +1x |
- tags$small(+ substitute( |
| 1074 | -! | +1x |
- withMathJax(+ expr = aes(colour = colour_name, size = size_name), |
| 1075 | -! | +1x |
- helpText(+ env = list(colour_name = as.name(colour), size_name = as.name(size)) |
| 1076 | -! | +
- "Outlier data points (\\(Zscore(x) < -", input$zscore_slider,+ ) |
|
| 1077 | -! | +
- "\\) or \\(", input$zscore_slider, "< Zscore(x) \\))
+ } else if ( |
|
| 1078 | -! | +5x |
- are displayed in red on the plot and can be visualized in the table below."+ identical(colour, character(0)) && |
| 1079 | -+ | 5x |
- ),+ !identical(fill, character(0)) && |
| 1080 | -! | +5x |
- if (input$split_outliers) {
+ is_point && |
| 1081 | -! | +5x |
- withMathJax(helpText(" Note: Z-scores are calculated per group."))
+ !identical(size, character(0)) |
| 1082 |
- }+ ) {
|
||
| 1083 | -+ | 1x |
- )+ substitute( |
| 1084 | -+ | 1x |
- )+ expr = aes(colour = colour_name, fill = fill_name, size = size_name), |
| 1085 | -! | +1x |
- } else if (input$method == "Percentile") {
+ env = list(colour_name = as.name(fill), fill_name = as.name(fill), size_name = as.name(size)) |
| 1086 | -! | +
- req(input$percentile_slider)+ ) |
|
| 1087 | -! | +
- tags$small(+ } else {
|
|
| 1088 | -! | +4x |
- withMathJax(+ NULL |
| 1089 | -! | +
- helpText(+ } |
|
| 1090 | -! | +
- "Outlier/extreme data points (\\( Percentile(x) <", input$percentile_slider,+ } |
|
| 1091 | -! | +
| 1 | +
- "\\) or \\(", 1 - input$percentile_slider, " < Percentile(x) \\))
+ #' `teal` module: Variable browser |
||
| 1092 | -! | +||
| 2 | +
- are displayed in red on the plot and can be visualized in the table below."+ #' |
||
| 1093 | +3 |
- ),+ #' Module provides provides a detailed summary and visualization of variable distributions |
|
| 1094 | -! | +||
| 4 | +
- if (input$split_outliers) {
+ #' for `data.frame` objects, with interactive features to customize analysis. |
||
| 1095 | -! | +||
| 5 | +
- withMathJax(helpText("Note: Percentiles are calculated per group."))
+ #' |
||
| 1096 | +6 |
- }+ #' Numeric columns with fewer than 30 distinct values can be treated as either discrete |
|
| 1097 | +7 |
- )+ #' or continuous with a checkbox allowing users to switch how they are treated(if < 6 unique values |
|
| 1098 | +8 |
- )+ #' then the default is discrete, otherwise it is continuous). |
|
| 1099 | +9 |
- }+ #' |
|
| 1100 | +10 |
- })+ #' @inheritParams teal::module |
|
| 1101 | +11 |
-
+ #' @inheritParams shared_params |
|
| 1102 | -! | +||
| 12 | +
- box_plot_r <- reactive({
+ #' @param parent_dataname (`character(1)`) string specifying a parent dataset. |
||
| 1103 | -! | +||
| 13 | +
- teal::validate_inputs(iv_r())+ #' If it exists in `datasets_selected`then an extra checkbox will be shown to |
||
| 1104 | -! | +||
| 14 | +
- req(decorated_q$box_plot())[["box_plot"]]+ #' allow users to not show variables in other datasets which exist in this `dataname`. |
||
| 1105 | +15 |
- })+ #' This is typically used to remove `ADSL` columns in `CDISC` data. |
|
| 1106 | -! | +||
| 16 | +
- density_plot_r <- reactive({
+ #' In non `CDISC` data this can be ignored. Defaults to `"ADSL"`. |
||
| 1107 | -! | +||
| 17 | +
- teal::validate_inputs(iv_r())+ #' @param datasets_selected (`character`) vector of datasets which should be |
||
| 1108 | -! | +||
| 18 | +
- req(decorated_q$density_plot())[["density_plot"]]+ #' shown, in order. Names must correspond with datasets names. |
||
| 1109 | +19 |
- })+ #' If vector of length zero (default) then all datasets are shown. |
|
| 1110 | -! | +||
| 20 | +
- cumulative_plot_r <- reactive({
+ #' Note: Only `data.frame` objects are compatible; using other types will cause an error. |
||
| 1111 | -! | +||
| 21 | +
- teal::validate_inputs(iv_r())+ #' |
||
| 1112 | -! | +||
| 22 | +
- req(decorated_q$cumulative_plot())[["cumulative_plot"]]+ #' @inherit shared_params return |
||
| 1113 | +23 |
- })+ #' |
|
| 1114 | +24 |
-
+ #' @examplesShinylive |
|
| 1115 | -! | +||
| 25 | +
- box_pws <- teal.widgets::plot_with_settings_srv(+ #' library(teal.modules.general) |
||
| 1116 | -! | +||
| 26 | +
- id = "box_plot",+ #' interactive <- function() TRUE |
||
| 1117 | -! | +||
| 27 | +
- plot_r = box_plot_r,+ #' {{ next_example }}
|
||
| 1118 | -! | +||
| 28 | +
- height = plot_height,+ # nolint start: line_length_linter. |
||
| 1119 | -! | +||
| 29 | +
- width = plot_width,+ #' @examplesIf require("sparkline", quietly = TRUE) && require("htmlwidgets", quietly = TRUE) && require("jsonlite", quietly = TRUE)
|
||
| 1120 | -! | +||
| 30 | +
- brushing = TRUE+ # nolint end: line_length_linter. |
||
| 1121 | +31 |
- )+ #' # general data example |
|
| 1122 | +32 |
-
+ #' data <- teal_data() |
|
| 1123 | -! | +||
| 33 | +
- density_pws <- teal.widgets::plot_with_settings_srv(+ #' data <- within(data, {
|
||
| 1124 | -! | +||
| 34 | +
- id = "density_plot",+ #' iris <- iris |
||
| 1125 | -! | +||
| 35 | +
- plot_r = density_plot_r,+ #' mtcars <- mtcars |
||
| 1126 | -! | +||
| 36 | +
- height = plot_height,+ #' women <- women |
||
| 1127 | -! | +||
| 37 | +
- width = plot_width,+ #' faithful <- faithful |
||
| 1128 | -! | +||
| 38 | +
- brushing = TRUE+ #' CO2 <- CO2 |
||
| 1129 | +39 |
- )+ #' }) |
|
| 1130 | +40 |
-
+ #' |
|
| 1131 | -! | +||
| 41 | +
- cum_density_pws <- teal.widgets::plot_with_settings_srv(+ #' app <- init( |
||
| 1132 | -! | +||
| 42 | +
- id = "cum_density_plot",+ #' data = data, |
||
| 1133 | -! | +||
| 43 | +
- plot_r = cumulative_plot_r,+ #' modules = modules( |
||
| 1134 | -! | +||
| 44 | +
- height = plot_height,+ #' tm_variable_browser( |
||
| 1135 | -! | +||
| 45 | +
- width = plot_width,+ #' label = "Variable browser" |
||
| 1136 | -! | +||
| 46 | +
- brushing = TRUE+ #' ) |
||
| 1137 | +47 |
- )+ #' ) |
|
| 1138 | +48 |
-
+ #' ) |
|
| 1139 | -! | +||
| 49 | +
- choices <- reactive(teal.transform::variable_choices(data()[[dataname_first]]))+ #' if (interactive()) {
|
||
| 1140 | +50 |
-
+ #' shinyApp(app$ui, app$server) |
|
| 1141 | -! | +||
| 51 | +
- observeEvent(common_code_q(), {
+ #' } |
||
| 1142 | -! | +||
| 52 | +
- ANL_OUTLIER <- common_code_q()[["ANL_OUTLIER"]]+ #' |
||
| 1143 | -! | +||
| 53 | +
- teal.widgets::updateOptionalSelectInput(+ #' @examplesShinylive |
||
| 1144 | -! | +||
| 54 | +
- session,+ #' library(teal.modules.general) |
||
| 1145 | -! | +||
| 55 | +
- inputId = "table_ui_columns",+ #' interactive <- function() TRUE |
||
| 1146 | -! | +||
| 56 | +
- choices = dplyr::setdiff(choices(), names(ANL_OUTLIER)),+ #' {{ next_example }}
|
||
| 1147 | -! | +||
| 57 | +
- selected = restoreInput(ns("table_ui_columns"), isolate(input$table_ui_columns))
+ # nolint start: line_length_linter. |
||
| 1148 | +58 |
- )+ #' @examplesIf require("sparkline", quietly = TRUE) && require("htmlwidgets", quietly = TRUE) && require("jsonlite", quietly = TRUE)
|
|
| 1149 | +59 |
- })+ # nolint end: line_length_linter. |
|
| 1150 | +60 |
-
+ #' # CDISC example data |
|
| 1151 | -! | +||
| 61 | +
- output$table_ui <- DT::renderDataTable(+ #' library(sparkline) |
||
| 1152 | -! | +||
| 62 | +
- expr = {
+ #' data <- teal_data() |
||
| 1153 | -! | +||
| 63 | +
- tab <- input$tabs+ #' data <- within(data, {
|
||
| 1154 | -! | +||
| 64 | +
- req(tab) # tab is NULL upon app launch, hence will crash without this statement+ #' ADSL <- teal.data::rADSL |
||
| 1155 | -! | +||
| 65 | +
- req(iv_r()$is_valid()) # Same validation as output$table_ui_wrap+ #' ADTTE <- teal.data::rADTTE |
||
| 1156 | -! | +||
| 66 | +
- outlier_var <- as.vector(merged$anl_input_r()$columns_source$outlier_var)+ #' }) |
||
| 1157 | -! | +||
| 67 | +
- categorical_var <- as.vector(merged$anl_input_r()$columns_source$categorical_var)+ #' join_keys(data) <- default_cdisc_join_keys[names(data)] |
||
| 1158 | +68 |
-
+ #' |
|
| 1159 | -! | +||
| 69 | +
- ANL_OUTLIER <- common_code_q()[["ANL_OUTLIER"]]+ #' app <- init( |
||
| 1160 | -! | +||
| 70 | +
- ANL_OUTLIER_EXTENDED <- common_code_q()[["ANL_OUTLIER_EXTENDED"]]+ #' data = data, |
||
| 1161 | -! | +||
| 71 | +
- ANL <- common_code_q()[["ANL"]]+ #' modules = modules( |
||
| 1162 | +72 |
-
+ #' tm_variable_browser( |
|
| 1163 | -! | +||
| 73 | +
- plot_brush <- switch(current_tab_r(),+ #' label = "Variable browser" |
||
| 1164 | -! | +||
| 74 | +
- box_plot = {
+ #' ) |
||
| 1165 | -! | +||
| 75 | +
- box_plot_r()+ #' ) |
||
| 1166 | -! | +||
| 76 | +
- box_pws$brush()+ #' ) |
||
| 1167 | +77 |
- },+ #' if (interactive()) {
|
|
| 1168 | -! | +||
| 78 | +
- density_plot = {
+ #' shinyApp(app$ui, app$server) |
||
| 1169 | -! | +||
| 79 | +
- density_plot_r()+ #' } |
||
| 1170 | -! | +||
| 80 | +
- density_pws$brush()+ #' |
||
| 1171 | +81 |
- },+ #' @export |
|
| 1172 | -! | +||
| 82 | +
- cumulative_plot = {
+ #' |
||
| 1173 | -! | +||
| 83 | +
- cumulative_plot_r()+ tm_variable_browser <- function(label = "Variable Browser", |
||
| 1174 | -! | +||
| 84 | +
- cum_density_pws$brush()+ datasets_selected = character(0), |
||
| 1175 | +85 |
- }+ parent_dataname = "ADSL", |
|
| 1176 | +86 |
- )+ pre_output = NULL, |
|
| 1177 | +87 |
-
+ post_output = NULL, |
|
| 1178 | +88 |
- # removing unused column ASAP+ ggplot2_args = teal.widgets::ggplot2_args()) {
|
|
| 1179 | +89 | ! |
- ANL_OUTLIER$order <- ANL$order <- NULL+ message("Initializing tm_variable_browser")
|
| 1180 | +90 | ||
| 91 | ++ |
+ # Requires Suggested packages+ |
+ |
| 1181 | +92 | ! |
- display_table <- if (!is.null(plot_brush)) {
+ if (!requireNamespace("sparkline", quietly = TRUE)) {
|
| 1182 | +93 | ! |
- if (length(categorical_var) > 0) {
+ stop("Cannot load sparkline - please install the package or restart your session.")
|
| 1183 | +94 |
- # due to reordering, the x-axis label may be changed to something like "reorder(categorical_var, order)"+ } |
|
| 1184 | +95 | ! |
- if (tab == "Boxplot") {
+ if (!requireNamespace("htmlwidgets", quietly = TRUE)) {
|
| 1185 | +96 | ! |
- plot_brush$mapping$x <- categorical_var+ stop("Cannot load htmlwidgets - please install the package or restart your session.")
|
| 1186 | +97 |
- } else {
+ } |
|
| 1187 | -+ | ||
| 98 | +! |
- # the other plots use facetting+ if (!requireNamespace("jsonlite", quietly = TRUE)) {
|
|
| 1188 | -+ | ||
| 99 | +! |
- # so it is panelvar1 that gets relabelled to "reorder(categorical_var, order)"+ stop("Cannot load jsonlite - please install the package or restart your session.")
|
|
| 1189 | -! | +||
| 100 | +
- plot_brush$mapping$panelvar1 <- categorical_var+ } |
||
| 1190 | +101 |
- }+ |
|
| 1191 | +102 |
- } else {
+ # Start of assertions |
|
| 1192 | +103 | ! |
- if (tab == "Boxplot") {
+ checkmate::assert_string(label) |
| 1193 | -+ | ||
| 104 | +! |
- # in boxplot with no categorical variable, there is no column in ANL that would correspond to x-axis+ checkmate::assert_character(datasets_selected) |
|
| 1194 | -+ | ||
| 105 | +! |
- # so a column needs to be inserted with the value "Entire dataset" because that's the label used in plot+ checkmate::assert_character(parent_dataname, min.len = 0, max.len = 1) |
|
| 1195 | +106 | ! |
- ANL[[plot_brush$mapping$x]] <- "Entire dataset"+ checkmate::assert_multi_class(pre_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
|
| 1196 | -+ | ||
| 107 | +! |
- }+ checkmate::assert_multi_class(post_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
+ |
+ |
| 108 | +! | +
+ checkmate::assert_class(ggplot2_args, "ggplot2_args") |
|
| 1197 | +109 |
- }+ # End of assertions |
|
| 1198 | +110 | ||
| 1199 | -+ | ||
| 111 | +! |
- # in density and cumulative plots, ANL does not have a column corresponding to y-axis.+ datasets_selected <- unique(datasets_selected) |
|
| 1200 | +112 |
- # so they need to be computed and attached to ANL+ |
|
| 1201 | +113 | ! |
- if (tab == "Density Plot") {
+ ans <- module( |
| 1202 | +114 | ! |
- plot_brush$mapping$y <- "density"+ label, |
| 1203 | +115 | ! |
- ANL$density <- plot_brush$ymin+ server = srv_variable_browser, |
| 1204 | -+ | ||
| 116 | +! |
- # either ymin or ymax will work+ ui = ui_variable_browser, |
|
| 1205 | +117 | ! |
- } else if (tab == "Cumulative Distribution Plot") {
+ datanames = "all", |
| 1206 | +118 | ! |
- plot_brush$mapping$y <- "cdf"+ server_args = list( |
| 1207 | +119 | ! |
- if (length(categorical_var) > 0) {
+ datasets_selected = datasets_selected, |
| 1208 | +120 | ! |
- ANL <- ANL %>%+ parent_dataname = parent_dataname, |
| 1209 | +121 | ! |
- dplyr::group_by(!!as.name(plot_brush$mapping$panelvar1)) %>%+ ggplot2_args = ggplot2_args+ |
+
| 122 | ++ |
+ ), |
|
| 1210 | +123 | ! |
- dplyr::mutate(cdf = stats::ecdf(!!as.name(outlier_var))(!!as.name(outlier_var)))+ ui_args = list( |
| 1211 | -+ | ||
| 124 | +! |
- } else {
+ pre_output = pre_output, |
|
| 1212 | +125 | ! |
- ANL$cdf <- stats::ecdf(ANL[[outlier_var]])(ANL[[outlier_var]])+ post_output = post_output |
| 1213 | +126 |
- }+ ) |
|
| 1214 | +127 |
- }+ ) |
|
| 1215 | +128 |
-
+ # `shiny` inputs are stored properly but the majority of the module is state of `datatable` which is not stored. |
|
| 1216 | +129 | ! |
- brushed_rows <- brushedPoints(ANL, plot_brush)+ attr(ans, "teal_bookmarkable") <- NULL |
| 1217 | +130 | ! |
- if (nrow(brushed_rows) > 0) {
+ ans |
| 1218 | +131 |
- # now we need to remove extra column from ANL so that it will have the same columns as ANL_OUTLIER+ } |
|
| 1219 | +132 |
- # so that dplyr::intersect will work+ |
|
| 1220 | -! | +||
| 133 | +
- if (tab == "Density Plot") {
+ # UI function for the variable browser module |
||
| 1221 | -! | +||
| 134 | +
- brushed_rows$density <- NULL+ ui_variable_browser <- function(id, |
||
| 1222 | -! | +||
| 135 | +
- } else if (tab == "Cumulative Distribution Plot") {
+ pre_output = NULL, |
||
| 1223 | -! | +||
| 136 | +
- brushed_rows$cdf <- NULL+ post_output = NULL) {
|
||
| 1224 | +137 | ! |
- } else if (tab == "Boxplot" && length(categorical_var) == 0) {
+ ns <- NS(id)+ |
+
| 138 | ++ | + | |
| 1225 | +139 | ! |
- brushed_rows[[plot_brush$mapping$x]] <- NULL+ tagList( |
| 1226 | -+ | ||
| 140 | +! |
- }+ include_css_files("custom"),
|
|
| 1227 | -+ | ||
| 141 | +! |
- # is_outlier_selected is part of ANL_OUTLIER so needed here+ shinyjs::useShinyjs(), |
|
| 1228 | +142 | ! |
- brushed_rows$is_outlier_selected <- TRUE+ teal.widgets::standard_layout( |
| 1229 | +143 | ! |
- dplyr::intersect(ANL_OUTLIER, brushed_rows)+ output = fluidRow( |
| 1230 | -+ | ||
| 144 | +! |
- } else {
+ htmlwidgets::getDependency("sparkline"), # needed for sparklines to work
|
|
| 1231 | +145 | ! |
- ANL_OUTLIER[0, ]+ column( |
| 1232 | -+ | ||
| 146 | +! |
- }+ 6, |
|
| 1233 | +147 |
- } else {
+ # variable browser |
|
| 1234 | +148 | ! |
- ANL_OUTLIER[ANL_OUTLIER$is_outlier_selected, ]+ teal.widgets::white_small_well( |
| 1235 | -+ | ||
| 149 | +! |
- }+ uiOutput(ns("ui_variable_browser")),
|
|
| 1236 | -+ | ||
| 150 | +! |
-
+ shinyjs::hidden({
|
|
| 1237 | +151 | ! |
- display_table$is_outlier_selected <- NULL+ checkboxInput(ns("show_parent_vars"), "Show parent dataset variables", value = FALSE)
|
| 1238 | +152 |
-
+ }) |
|
| 1239 | +153 |
- # Extend the brushed ANL_OUTLIER with additional columns+ ) |
|
| 1240 | -! | +||
| 154 | +
- dplyr::left_join(+ ), |
||
| 1241 | +155 | ! |
- display_table,+ column( |
| 1242 | +156 | ! |
- dplyr::select(ANL_OUTLIER_EXTENDED, -"is_outlier_selected"),+ 6, |
| 1243 | +157 | ! |
- by = names(display_table)+ teal.widgets::white_small_well( |
| 1244 | +158 |
- ) %>%+ ### Reporter |
|
| 1245 | +159 | ! |
- dplyr::select(union(names(display_table), input$table_ui_columns))+ teal.reporter::simple_reporter_ui(ns("simple_reporter")),
|
| 1246 | +160 |
- },+ ### |
|
| 1247 | +161 | ! |
- options = list(+ tags$div( |
| 1248 | +162 | ! |
- searching = FALSE, language = list(+ class = "block", |
| 1249 | +163 | ! |
- zeroRecords = "The brushed area does not contain outlier observations for the currently defined threshold"+ uiOutput(ns("ui_histogram_display"))
|
| 1250 | +164 |
- ),+ ), |
|
| 1251 | +165 | ! |
- pageLength = input$table_ui_rows+ tags$div( |
| 1252 | -+ | ||
| 166 | +! |
- )+ class = "block", |
|
| 1253 | -+ | ||
| 167 | +! |
- )+ uiOutput(ns("ui_numeric_display"))
|
|
| 1254 | +168 |
-
+ ), |
|
| 1255 | +169 | ! |
- output$total_outliers <- renderUI({
+ teal.widgets::plot_with_settings_ui(ns("variable_plot")),
|
| 1256 | +170 | ! |
- req(iv_r()$is_valid())+ tags$br(),+ |
+
| 171 | ++ |
+ # input user-defined text size |
|
| 1257 | +172 | ! |
- ANL <- merged$anl_q_r()[["ANL"]]+ teal.widgets::panel_item( |
| 1258 | +173 | ! |
- ANL_OUTLIER <- common_code_q()[["ANL_OUTLIER"]]+ title = "Plot settings", |
| 1259 | +174 | ! |
- teal::validate_has_data(ANL, 1)+ collapsed = TRUE, |
| 1260 | +175 | ! |
- ANL_OUTLIER_SELECTED <- ANL_OUTLIER[ANL_OUTLIER$is_outlier_selected, ]+ selectInput( |
| 1261 | +176 | ! |
- tags$h5(+ inputId = ns("ggplot_theme"), label = "ggplot2 theme",
|
| 1262 | +177 | ! |
- sprintf(+ choices = ggplot_themes, |
| 1263 | +178 | ! |
- "%s %d / %d [%.02f%%]",+ selected = "grey"+ |
+
| 179 | ++ |
+ ), |
|
| 1264 | +180 | ! |
- "Total number of outlier(s):",+ fluidRow( |
| 1265 | +181 | ! |
- nrow(ANL_OUTLIER_SELECTED),+ column(6, sliderInput( |
| 1266 | +182 | ! |
- nrow(ANL),+ inputId = ns("font_size"), label = "font size",
|
| 1267 | +183 | ! |
- 100 * nrow(ANL_OUTLIER_SELECTED) / nrow(ANL)+ min = 5L, max = 30L, value = 15L, step = 1L, ticks = FALSE |
| 1268 | +184 |
- )+ )),+ |
+ |
| 185 | +! | +
+ column(6, sliderInput(+ |
+ |
| 186 | +! | +
+ inputId = ns("label_rotation"), label = "rotate x labels",
+ |
+ |
| 187 | +! | +
+ min = 0L, max = 90L, value = 45L, step = 1, ticks = FALSE |
|
| 1269 | +188 |
- )+ )) |
|
| 1270 | +189 |
- })+ ) |
|
| 1271 | +190 |
-
+ ), |
|
| 1272 | +191 | ! |
- output$total_missing <- renderUI({
+ tags$br(), |
| 1273 | +192 | ! |
- if (n_outlier_missing() > 0) {
+ teal.widgets::get_dt_rows(ns("variable_summary_table"), ns("variable_summary_table_rows")),
|
| 1274 | +193 | ! |
- ANL <- merged$anl_q_r()[["ANL"]]+ DT::dataTableOutput(ns("variable_summary_table"))
|
| 1275 | -! | +||
| 194 | +
- helpText(+ ) |
||
| 1276 | -! | +||
| 195 | +
- sprintf(+ ) |
||
| 1277 | -! | +||
| 196 | +
- "%s %d / %d [%.02f%%]",+ ), |
||
| 1278 | +197 | ! |
- "Total number of row(s) with missing values:",+ pre_output = pre_output, |
| 1279 | +198 | ! |
- n_outlier_missing(),+ post_output = post_output |
| 1280 | -! | +||
| 199 | +
- nrow(ANL),+ ) |
||
| 1281 | -! | +||
| 200 | +
- 100 * (n_outlier_missing()) / nrow(ANL)+ ) |
||
| 1282 | +201 |
- )+ } |
|
| 1283 | +202 |
- )+ |
|
| 1284 | +203 |
- }+ # Server function for the variable browser module |
|
| 1285 | +204 |
- })+ srv_variable_browser <- function(id, |
|
| 1286 | +205 |
-
+ data, |
|
| 1287 | -! | +||
| 206 | +
- output$table_ui_wrap <- renderUI({
+ reporter, |
||
| 1288 | -! | +||
| 207 | +
- req(iv_r()$is_valid())+ filter_panel_api, |
||
| 1289 | -! | +||
| 208 | +
- tagList(+ datasets_selected, parent_dataname, ggplot2_args) {
|
||
| 1290 | +209 | ! |
- teal.widgets::optionalSelectInput(+ with_reporter <- !missing(reporter) && inherits(reporter, "Reporter") |
| 1291 | +210 | ! |
- inputId = ns("table_ui_columns"),
+ with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI") |
| 1292 | +211 | ! |
- label = "Choose additional columns",+ checkmate::assert_class(data, "reactive") |
| 1293 | +212 | ! |
- choices = NULL,+ checkmate::assert_class(isolate(data()), "teal_data") |
| 1294 | +213 | ! |
- selected = NULL,+ moduleServer(id, function(input, output, session) {
|
| 1295 | +214 | ! |
- multiple = TRUE+ teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.general") |
| 1296 | +215 |
- ),- |
- |
| 1297 | -! | -
- tags$h4("Outlier Table"),
- |
- |
| 1298 | -! | -
- teal.widgets::get_dt_rows(ns("table_ui"), ns("table_ui_rows"))
+
|
|
| 1299 | +216 |
- )+ # if there are < this number of unique records then a numeric |
|
| 1300 | +217 |
- })+ # variable can be treated as a factor and all factors with < this groups |
|
| 1301 | +218 |
-
+ # have their values plotted |
|
| 1302 | +219 | ! |
- teal.widgets::verbatim_popup_srv(+ .unique_records_for_factor <- 30 |
| 1303 | -! | +||
| 220 | +
- id = "rcode",+ # if there are < this number of unique records then a numeric |
||
| 1304 | -! | +||
| 221 | +
- verbatim_content = reactive(teal.code::get_code(req(decorated_final_q()))),+ # variable is by default treated as a factor |
||
| 1305 | +222 | ! |
- title = "Show R Code for Outlier"+ .unique_records_default_as_factor <- 6 # nolint: object_length. |
| 1306 | +223 |
- )+ + |
+ |
| 224 | +! | +
+ varname_numeric_as_factor <- reactiveValues() |
|
| 1307 | +225 | ||
| 1308 | -+ | ||
| 226 | +! |
- ### REPORTER+ datanames <- isolate(names(data())) |
|
| 1309 | +227 | ! |
- if (with_reporter) {
+ datanames <- Filter(function(name) {
|
| 1310 | +228 | ! |
- card_fun <- function(comment, label) {
+ is.data.frame(isolate(data())[[name]]) |
| 1311 | +229 | ! |
- tab_type <- input$tabs+ }, datanames)+ |
+
| 230 | ++ | + | |
| 1312 | +231 | ! |
- card <- teal::report_card_template(+ checkmate::assert_character(datasets_selected) |
| 1313 | +232 | ! |
- title = paste0("Outliers - ", tab_type),
+ checkmate::assert_subset(datasets_selected, datanames) |
| 1314 | +233 | ! |
- label = label,+ if (!identical(datasets_selected, character(0))) {
|
| 1315 | +234 | ! |
- with_filter = with_filter,+ checkmate::assert_subset(datasets_selected, datanames) |
| 1316 | +235 | ! |
- filter_panel_api = filter_panel_api+ datanames <- datasets_selected |
| 1317 | +236 |
- )+ }+ |
+ |
| 237 | ++ | + | |
| 1318 | +238 | ! |
- categorical_var <- as.vector(merged$anl_input_r()$columns_source$categorical_var)+ output$ui_variable_browser <- renderUI({
|
| 1319 | +239 | ! |
- if (length(categorical_var) > 0) {
+ ns <- session$ns |
| 1320 | +240 | ! |
- summary_table <- common_code_q()[["summary_table"]]+ do.call( |
| 1321 | +241 | ! |
- card$append_text("Summary Table", "header3")
+ tabsetPanel, |
| 1322 | +242 | ! |
- card$append_table(summary_table)+ c( |
| 1323 | -+ | ||
| 243 | +! |
- }+ id = ns("tabset_panel"),
|
|
| 1324 | +244 | ! |
- card$append_text("Plot", "header3")
+ do.call( |
| 1325 | +245 | ! |
- if (tab_type == "Boxplot") {
+ tagList, |
| 1326 | +246 | ! |
- card$append_plot(box_plot_r(), dim = box_pws$dim())+ lapply(datanames, function(dataname) {
|
| 1327 | +247 | ! |
- } else if (tab_type == "Density Plot") {
+ tabPanel( |
| 1328 | +248 | ! |
- card$append_plot(density_plot_r(), dim = density_pws$dim())+ dataname, |
| 1329 | +249 | ! |
- } else if (tab_type == "Cumulative Distribution Plot") {
+ tags$div( |
| 1330 | +250 | ! |
- card$append_plot(cumulative_plot_r(), dim = cum_density_pws$dim())+ class = "mt-4",+ |
+
| 251 | +! | +
+ textOutput(ns(paste0("dataset_summary_", dataname)))
|
|
| 1331 | +252 |
- }+ ), |
|
| 1332 | +253 | ! |
- if (!comment == "") {
+ tags$div( |
| 1333 | +254 | ! |
- card$append_text("Comment", "header3")
+ class = "mt-4", |
| 1334 | +255 | ! |
- card$append_text(comment)- |
-
| 1335 | -- |
- }+ teal.widgets::get_dt_rows( |
|
| 1336 | +256 | ! |
- card$append_src(teal.code::get_code(req(decorated_final_q())))+ ns(paste0("variable_browser_", dataname)),
|
| 1337 | +257 | ! |
- card+ ns(paste0("variable_browser_", dataname, "_rows"))
|
| 1338 | +258 |
- }+ ), |
|
| 1339 | +259 | ! |
- teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
+ DT::dataTableOutput(ns(paste0("variable_browser_", dataname)), width = "100%")
|
| 1340 | +260 |
- }+ ) |
|
| 1341 | +261 |
- ###+ ) |
|
| 1342 | +262 |
- })+ }) |
|
| 1343 | +263 |
- }+ ) |
| 1 | +264 |
- #' `teal` module: Missing data analysis+ ) |
|
| 2 | +265 |
- #'+ ) |
|
| 3 | +266 |
- #' This module analyzes missing data in `data.frame`s to help users explore missing observations and+ }) |
|
| 4 | +267 |
- #' gain insights into the completeness of their data.+ |
|
| 5 | +268 |
- #' It is useful for clinical data analysis within the context of `CDISC` standards and+ # conditionally display checkbox |
|
| 6 | -+ | ||
| 269 | +! |
- #' adaptable for general data analysis purposes.+ shinyjs::toggle( |
|
| 7 | -+ | ||
| 270 | +! |
- #'+ id = "show_parent_vars", |
|
| 8 | -+ | ||
| 271 | +! |
- #' @inheritParams teal::module+ condition = length(parent_dataname) > 0 && parent_dataname %in% datanames |
|
| 9 | +272 |
- #' @inheritParams shared_params+ ) |
|
| 10 | +273 |
- #' @param parent_dataname (`character(1)`) Specifies the parent dataset name. Default is `ADSL` for `CDISC` data.+ |
|
| 11 | -+ | ||
| 274 | +! |
- #' If provided and exists, enables additional analysis "by subject". For non-`CDISC` data, this parameter can be+ columns_names <- new.env() |
|
| 12 | +275 |
- #' ignored.+ |
|
| 13 | +276 |
- # nolint start: line_length.+ # plot_var$data holds the name of the currently selected dataset |
|
| 14 | +277 |
- #' @param ggtheme (`character`) optional, specifies the default `ggplot2` theme for plots. Defaults to `classic`.+ # plot_var$variable[[<dataset_name>]] holds the name of the currently selected |
|
| 15 | +278 |
- #' @param ggplot2_args `r roxygen_ggplot2_args_param("Summary Obs", "Summary Patients", "Combinations Main", "Combinations Hist", "By Subject")`
+ # variable for dataset <dataset_name> |
|
| 16 | -+ | ||
| 279 | +! |
- # nolint end: line_length.+ plot_var <- reactiveValues(data = NULL, variable = list()) |
|
| 17 | +280 |
- #' @param decorators `r roxygen_decorators_param("tm_missing_data")`
+
|
|
| 18 | -+ | ||
| 281 | +! |
- #'+ establish_updating_selection(datanames, input, plot_var, columns_names) |
|
| 19 | +282 |
- #' @inherit shared_params return+ |
|
| 20 | +283 |
- #'+ # validations |
|
| 21 | -+ | ||
| 284 | +! |
- #' @section Decorating `tm_missing_data`:+ validation_checks <- validate_input(input, plot_var, data) |
|
| 22 | +285 |
- #'+ |
|
| 23 | +286 |
- #' This module generates the following objects, which can be modified in place using decorators:+ # data_for_analysis is a list with two elements: a column from a dataset and the column label |
|
| 24 | -+ | ||
| 287 | +! |
- #' - `summary_plot` (`grob` created with [ggplot2::ggplotGrob()])+ plotted_data <- reactive({
|
|
| 25 | -+ | ||
| 288 | +! |
- #' - `combination_plot` (`grob` created with [ggplot2::ggplotGrob()])+ validation_checks() |
|
| 26 | +289 |
- #' - `by_subject_plot` (`ggplot2`)+ |
|
| 27 | -+ | ||
| 290 | +! |
- #' - `table` ([DT::datatable()])+ get_plotted_data(input, plot_var, data) |
|
| 28 | +291 |
- #'+ }) |
|
| 29 | +292 |
- #' Decorators can be applied to all outputs or only to specific objects using a+ |
|
| 30 | -+ | ||
| 293 | +! |
- #' named list of `teal_transform_module` objects.+ treat_numeric_as_factor <- reactive({
|
|
| 31 | -+ | ||
| 294 | +! |
- #' The `"default"` name is reserved for decorators that are applied to all outputs.+ if (is_num_var_short(.unique_records_for_factor, input, plotted_data)) {
|
|
| 32 | -+ | ||
| 295 | +! |
- #' See code snippet below:+ input$numeric_as_factor |
|
| 33 | +296 |
- #'+ } else {
|
|
| 34 | -+ | ||
| 297 | +! |
- #' ```+ FALSE |
|
| 35 | +298 |
- #' tm_missing_data(+ } |
|
| 36 | +299 |
- #' ..., # arguments for module+ }) |
|
| 37 | +300 |
- #' decorators = list(+ |
|
| 38 | -+ | ||
| 301 | +! |
- #' default = list(teal_transform_module(...)), # applied to all outputs+ render_tabset_panel_content( |
|
| 39 | -+ | ||
| 302 | +! |
- #' summary_plot = list(teal_transform_module(...)), # applied only to `summary_plot` output+ input = input, |
|
| 40 | -+ | ||
| 303 | +! |
- #' combination_plot = list(teal_transform_module(...)) # applied only to `combination_plot` output+ output = output, |
|
| 41 | -+ | ||
| 304 | +! |
- #' by_subject_plot = list(teal_transform_module(...)) # applied only to `by_subject_plot` output+ data = data, |
|
| 42 | -+ | ||
| 305 | +! |
- #' table = list(teal_transform_module(...)) # applied only to `table` output+ datanames = datanames, |
|
| 43 | -+ | ||
| 306 | +! |
- #' )+ parent_dataname = parent_dataname, |
|
| 44 | -- |
- #' )+ | |
| 307 | +! | +
+ columns_names = columns_names, |
|
| 45 | -+ | ||
| 308 | +! |
- #' ```+ plot_var = plot_var |
|
| 46 | +309 |
- #'+ ) |
|
| 47 | +310 |
- #' For additional details and examples of decorators, refer to the vignette+ # add used-defined text size to ggplot arguments passed from caller frame |
|
| 48 | -+ | ||
| 311 | +! |
- #' `vignette("decorate-modules-output", package = "teal")` or the [`teal::teal_transform_module()`] documentation.
+ all_ggplot2_args <- reactive({
|
|
| 49 | -+ | ||
| 312 | +! |
- #'+ user_text <- teal.widgets::ggplot2_args( |
|
| 50 | -+ | ||
| 313 | +! |
- #' @examplesShinylive+ theme = list( |
|
| 51 | -+ | ||
| 314 | +! |
- #' library(teal.modules.general)+ "text" = ggplot2::element_text(size = input[["font_size"]]), |
|
| 52 | -+ | ||
| 315 | +! |
- #' interactive <- function() TRUE+ "axis.text.x" = ggplot2::element_text(angle = input[["label_rotation"]], hjust = 1) |
|
| 53 | +316 |
- #' {{ next_example }}
+ ) |
|
| 54 | +317 |
- #' @examplesIf require("gridExtra", quietly = TRUE) && require("rlang", quietly = TRUE)
+ ) |
|
| 55 | -+ | ||
| 318 | +! |
- #' # general example data+ user_theme <- utils::getFromNamespace(sprintf("theme_%s", input[["ggplot_theme"]]), ns = "ggplot2")
|
|
| 56 | -+ | ||
| 319 | +! |
- #' data <- teal_data()+ user_theme <- user_theme() |
|
| 57 | +320 |
- #' data <- within(data, {
+ # temporary fix to circumvent assertion issue with resolve_ggplot2_args |
|
| 58 | +321 |
- #' require(nestcolor)+ # drop problematic elements |
|
| 59 | -+ | ||
| 322 | +! |
- #'+ user_theme <- user_theme[grep("strip.text.y.left", names(user_theme), fixed = TRUE, invert = TRUE)]
|
|
| 60 | +323 |
- #' add_nas <- function(x) {
+
|
|
| 61 | -+ | ||
| 324 | +! |
- #' x[sample(seq_along(x), floor(length(x) * runif(1, .05, .17)))] <- NA+ teal.widgets::resolve_ggplot2_args( |
|
| 62 | -+ | ||
| 325 | +! |
- #' x+ user_plot = user_text, |
|
| 63 | -+ | ||
| 326 | +! |
- #' }+ user_default = teal.widgets::ggplot2_args(theme = user_theme), |
|
| 64 | -+ | ||
| 327 | +! |
- #'+ module_plot = ggplot2_args |
|
| 65 | +328 |
- #' iris <- iris+ ) |
|
| 66 | +329 |
- #' mtcars <- mtcars+ }) |
|
| 67 | +330 |
- #'+ |
|
| 68 | -+ | ||
| 331 | +! |
- #' iris[] <- lapply(iris, add_nas)+ output$ui_numeric_display <- renderUI({
|
|
| 69 | -+ | ||
| 332 | +! |
- #' mtcars[] <- lapply(mtcars, add_nas)+ validation_checks() |
|
| 70 | -+ | ||
| 333 | +! |
- #' mtcars[["cyl"]] <- as.factor(mtcars[["cyl"]])+ dataname <- input$tabset_panel |
|
| 71 | -+ | ||
| 334 | +! |
- #' mtcars[["gear"]] <- as.factor(mtcars[["gear"]])+ varname <- plot_var$variable[[dataname]] |
|
| 72 | -+ | ||
| 335 | +! |
- #' })+ df <- data()[[dataname]] |
|
| 73 | +336 |
- #'+ |
|
| 74 | -+ | ||
| 337 | +! |
- #' app <- init(+ numeric_ui <- tagList( |
|
| 75 | -+ | ||
| 338 | +! |
- #' data = data,+ fluidRow( |
|
| 76 | -+ | ||
| 339 | +! |
- #' modules = modules(+ tags$div( |
|
| 77 | -+ | ||
| 340 | +! |
- #' tm_missing_data()+ class = "col-md-4", |
|
| 78 | -+ | ||
| 341 | +! |
- #' )+ tags$br(), |
|
| 79 | -+ | ||
| 342 | +! |
- #' )+ shinyWidgets::switchInput( |
|
| 80 | -+ | ||
| 343 | +! |
- #' if (interactive()) {
+ inputId = session$ns("display_density"),
|
|
| 81 | -+ | ||
| 344 | +! |
- #' shinyApp(app$ui, app$server)+ label = "Show density", |
|
| 82 | -+ | ||
| 345 | +! |
- #' }+ value = `if`(is.null(isolate(input$display_density)), TRUE, isolate(input$display_density)), |
|
| 83 | -+ | ||
| 346 | +! |
- #'+ width = "50%", |
|
| 84 | -+ | ||
| 347 | +! |
- #' @examplesShinylive+ labelWidth = "100px", |
|
| 85 | -+ | ||
| 348 | +! |
- #' library(teal.modules.general)+ handleWidth = "50px" |
|
| 86 | +349 |
- #' interactive <- function() TRUE+ ) |
|
| 87 | +350 |
- #' {{ next_example }}
+ ), |
|
| 88 | -+ | ||
| 351 | +! |
- #' @examplesIf require("gridExtra", quietly = TRUE) && require("rlang", quietly = TRUE)
+ tags$div( |
|
| 89 | -+ | ||
| 352 | +! |
- #' # CDISC example data+ class = "col-md-4", |
|
| 90 | -+ | ||
| 353 | +! |
- #' data <- teal_data()+ tags$br(), |
|
| 91 | -+ | ||
| 354 | +! |
- #' data <- within(data, {
+ shinyWidgets::switchInput( |
|
| 92 | -+ | ||
| 355 | +! |
- #' require(nestcolor)+ inputId = session$ns("remove_outliers"),
|
|
| 93 | -+ | ||
| 356 | +! |
- #' ADSL <- rADSL+ label = "Remove outliers", |
|
| 94 | -+ | ||
| 357 | +! |
- #' ADRS <- rADRS+ value = `if`(is.null(isolate(input$remove_outliers)), FALSE, isolate(input$remove_outliers)), |
|
| 95 | -+ | ||
| 358 | +! |
- #' })+ width = "50%", |
|
| 96 | -+ | ||
| 359 | +! |
- #' join_keys(data) <- default_cdisc_join_keys[names(data)]+ labelWidth = "100px", |
|
| 97 | -+ | ||
| 360 | +! |
- #'+ handleWidth = "50px" |
|
| 98 | +361 |
- #' app <- init(+ ) |
|
| 99 | +362 |
- #' data = data,+ ), |
|
| 100 | -+ | ||
| 363 | +! |
- #' modules = modules(+ tags$div( |
|
| 101 | -+ | ||
| 364 | +! |
- #' tm_missing_data()+ class = "col-md-4", |
|
| 102 | -+ | ||
| 365 | +! |
- #' )+ uiOutput(session$ns("outlier_definition_slider_ui"))
|
|
| 103 | +366 |
- #' )+ ) |
|
| 104 | +367 |
- #' if (interactive()) {
+ ), |
|
| 105 | -+ | ||
| 368 | +! |
- #' shinyApp(app$ui, app$server)+ tags$div( |
|
| 106 | -+ | ||
| 369 | +! |
- #' }+ class = "ml-4", |
|
| 107 | -+ | ||
| 370 | +! |
- #'+ uiOutput(session$ns("ui_density_help")),
|
|
| 108 | -+ | ||
| 371 | +! |
- #' @export+ uiOutput(session$ns("ui_outlier_help"))
|
|
| 109 | +372 |
- #'+ ) |
|
| 110 | +373 |
- tm_missing_data <- function(label = "Missing data",+ ) |
|
| 111 | +374 |
- plot_height = c(600, 400, 5000),+ |
|
| 112 | -+ | ||
| 375 | +! |
- plot_width = NULL,+ observeEvent(input$numeric_as_factor, ignoreInit = TRUE, {
|
|
| 113 | -+ | ||
| 376 | +! |
- parent_dataname = "ADSL",+ varname_numeric_as_factor[[plot_var$variable[[dataname]]]] <- input$numeric_as_factor |
|
| 114 | +377 |
- ggtheme = c("classic", "gray", "bw", "linedraw", "light", "dark", "minimal", "void"),
+ }) |
|
| 115 | +378 |
- ggplot2_args = list(+ |
|
| 116 | -+ | ||
| 379 | +! |
- "Combinations Hist" = teal.widgets::ggplot2_args(labs = list(caption = NULL)),+ if (is.numeric(df[[varname]])) {
|
|
| 117 | -+ | ||
| 380 | +! |
- "Combinations Main" = teal.widgets::ggplot2_args(labs = list(title = NULL))+ unique_entries <- length(unique(df[[varname]])) |
|
| 118 | -+ | ||
| 381 | +! |
- ),+ if (unique_entries < .unique_records_for_factor && unique_entries > 0) {
|
|
| 119 | -+ | ||
| 382 | +! |
- pre_output = NULL,+ list( |
|
| 120 | -+ | ||
| 383 | +! |
- post_output = NULL,+ checkboxInput( |
|
| 121 | -+ | ||
| 384 | +! |
- decorators = NULL) {
+ session$ns("numeric_as_factor"),
|
|
| 122 | +385 | ! |
- message("Initializing tm_missing_data")
+ "Treat variable as factor", |
| 123 | -+ | ||
| 386 | +! |
-
+ value = `if`( |
|
| 124 | -+ | ||
| 387 | +! |
- # Requires Suggested packages+ is.null(varname_numeric_as_factor[[varname]]), |
|
| 125 | +388 | ! |
- if (!requireNamespace("gridExtra", quietly = TRUE)) {
+ unique_entries < .unique_records_default_as_factor, |
| 126 | +389 | ! |
- stop("Cannot load gridExtra - please install the package or restart your session.")
+ varname_numeric_as_factor[[varname]] |
| 127 | +390 |
- }+ ) |
|
| 128 | -! | +||
| 391 | +
- if (!requireNamespace("rlang", quietly = TRUE)) {
+ ), |
||
| 129 | +392 | ! |
- stop("Cannot load rlang - please install the package or restart your session.")
- |
-
| 130 | -- |
- }+ conditionalPanel("!input.numeric_as_factor", ns = session$ns, numeric_ui)
|
|
| 131 | +393 |
-
+ ) |
|
| 132 | -+ | ||
| 394 | +! |
- # Normalize the parameters+ } else if (unique_entries > 0) {
|
|
| 133 | +395 | ! |
- if (inherits(ggplot2_args, "ggplot2_args")) ggplot2_args <- list(default = ggplot2_args)+ numeric_ui |
| 134 | +396 |
-
+ } |
|
| 135 | +397 |
- # Start of assertions+ } else {
|
|
| 136 | +398 | ! |
- checkmate::assert_string(label)+ NULL |
| 137 | +399 |
-
+ } |
|
| 138 | -! | +||
| 400 | +
- checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE)+ }) |
||
| 139 | -! | +||
| 401 | +
- checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height")+ |
||
| 140 | +402 | ! |
- checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE)+ output$ui_histogram_display <- renderUI({
|
| 141 | +403 | ! |
- checkmate::assert_numeric(+ validation_checks() |
| 142 | +404 | ! |
- plot_width[1],+ dataname <- input$tabset_panel |
| 143 | +405 | ! |
- lower = plot_width[2], upper = plot_width[3], null.ok = TRUE, .var.name = "plot_width"+ varname <- plot_var$variable[[dataname]] |
| 144 | -+ | ||
| 406 | +! |
- )+ df <- data()[[dataname]] |
|
| 145 | +407 | ||
| 146 | +408 | ! |
- checkmate::assert_character(parent_dataname, min.len = 0, max.len = 1)+ numeric_ui <- tagList(fluidRow( |
| 147 | +409 | ! |
- ggtheme <- match.arg(ggtheme)- |
-
| 148 | -- |
-
+ tags$div( |
|
| 149 | +410 | ! |
- plot_choices <- c("Summary Obs", "Summary Patients", "Combinations Main", "Combinations Hist", "By Subject")
+ class = "col-md-4", |
| 150 | +411 | ! |
- checkmate::assert_list(ggplot2_args, types = "ggplot2_args")+ shinyWidgets::switchInput( |
| 151 | +412 | ! |
- checkmate::assert_subset(names(ggplot2_args), c("default", plot_choices))
- |
-
| 152 | -- |
-
+ inputId = session$ns("remove_NA_hist"),
|
|
| 153 | +413 | ! |
- checkmate::assert_multi_class(pre_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
+ label = "Remove NA values", |
| 154 | +414 | ! |
- checkmate::assert_multi_class(post_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
- |
-
| 155 | -- |
-
+ value = FALSE, |
|
| 156 | +415 | ! |
- available_decorators <- c("summary_plot", "combination_plot", "by_subject_plot", "summary_table")
+ width = "50%", |
| 157 | +416 | ! |
- decorators <- normalize_decorators(decorators)+ labelWidth = "100px", |
| 158 | +417 | ! |
- assert_decorators(decorators, null.ok = TRUE, names = available_decorators)+ handleWidth = "50px" |
| 159 | +418 |
- # End of assertions+ ) |
|
| 160 | +419 |
-
+ ) |
|
| 161 | -! | +||
| 420 | +
- ans <- module(+ )) |
||
| 162 | -! | +||
| 421 | +
- label,+ |
||
| 163 | +422 | ! |
- server = srv_page_missing_data,+ var <- df[[varname]] |
| 164 | +423 | ! |
- server_args = list(+ if (anyNA(var) && (is.factor(var) || is.character(var) || is.logical(var))) {
|
| 165 | +424 | ! |
- parent_dataname = parent_dataname,+ groups <- unique(as.character(var)) |
| 166 | +425 | ! |
- plot_height = plot_height,+ len_groups <- length(groups) |
| 167 | +426 | ! |
- plot_width = plot_width,+ if (len_groups >= .unique_records_for_factor) {
|
| 168 | +427 | ! |
- ggplot2_args = ggplot2_args,+ NULL |
| 169 | -! | +||
| 428 | +
- ggtheme = ggtheme,+ } else {
|
||
| 170 | +429 | ! |
- decorators = decorators+ numeric_ui |
| 171 | +430 |
- ),+ } |
|
| 172 | -! | +||
| 431 | +
- ui = ui_page_missing_data,+ } else {
|
||
| 173 | +432 | ! |
- datanames = "all",+ NULL |
| 174 | -! | +||
| 433 | +
- ui_args = list(pre_output = pre_output, post_output = post_output)+ } |
||
| 175 | +434 |
- )+ }) |
|
| 176 | -! | +||
| 435 | +
- attr(ans, "teal_bookmarkable") <- TRUE+ |
||
| 177 | +436 | ! |
- ans- |
-
| 178 | -- |
- }+ output$outlier_definition_slider_ui <- renderUI({
|
|
| 179 | -+ | ||
| 437 | +! |
-
+ req(input$remove_outliers) |
|
| 180 | -+ | ||
| 438 | +! |
- # UI function for the missing data module (all datasets)+ sliderInput( |
|
| 181 | -+ | ||
| 439 | +! |
- ui_page_missing_data <- function(id, pre_output = NULL, post_output = NULL) {
+ inputId = session$ns("outlier_definition_slider"),
|
|
| 182 | +440 | ! |
- ns <- NS(id)+ tags$div( |
| 183 | +441 | ! |
- tagList(+ class = "teal-tooltip", |
| 184 | +442 | ! |
- include_css_files("custom"),
+ tagList( |
| 185 | +443 | ! |
- teal.widgets::standard_layout(+ "Outlier definition:", |
| 186 | +444 | ! |
- output = teal.widgets::white_small_well(+ icon("circle-info"),
|
| 187 | +445 | ! |
- tags$div(+ tags$span( |
| 188 | +446 | ! |
- class = "flex",+ class = "tooltiptext", |
| 189 | +447 | ! |
- column(+ paste( |
| 190 | +448 | ! |
- width = 12,+ "Use the slider to choose the cut-off value to define outliers; the larger the value the", |
| 191 | +449 | ! |
- uiOutput(ns("dataset_tabs"))
+ "further below Q1/above Q3 points have to be in order to be classed as outliers" |
| 192 | +450 |
- )+ ) |
|
| 193 | +451 |
- )+ ) |
|
| 194 | +452 |
- ),- |
- |
| 195 | -! | -
- encoding = tags$div(- |
- |
| 196 | -! | -
- uiOutput(ns("dataset_encodings"))
+ ) |
|
| 197 | +453 |
- ),+ ), |
|
| 198 | +454 | ! |
- uiOutput(ns("dataset_reporter")),
+ min = 1, |
| 199 | +455 | ! |
- pre_output = pre_output,+ max = 5, |
| 200 | +456 | ! |
- post_output = post_output+ value = 3, |
| 201 | -+ | ||
| 457 | +! |
- )+ step = 0.5 |
|
| 202 | +458 |
- )+ ) |
|
| 203 | +459 |
- }+ }) |
|
| 204 | +460 | ||
| 205 | -- |
- # Server function for the missing data module (all datasets)- |
- |
| 206 | -+ | ||
| 461 | +! |
- srv_page_missing_data <- function(id, data, reporter, filter_panel_api, parent_dataname,+ output$ui_density_help <- renderUI({
|
|
| 207 | -+ | ||
| 462 | +! |
- plot_height, plot_width, ggplot2_args, ggtheme, decorators) {
+ req(is.logical(input$display_density)) |
|
| 208 | +463 | ! |
- with_reporter <- !missing(reporter) && inherits(reporter, "Reporter")+ if (input$display_density) {
|
| 209 | +464 | ! |
- with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI")+ tags$small(helpText(paste( |
| 210 | +465 | ! |
- moduleServer(id, function(input, output, session) {
+ "Kernel density estimation with gaussian kernel", |
| 211 | +466 | ! |
- teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.general")+ "and bandwidth function bw.nrd0 (R default)" |
| 212 | +467 |
-
+ ))) |
|
| 213 | -! | +||
| 468 | +
- datanames <- isolate(names(data()))+ } else {
|
||
| 214 | +469 | ! |
- datanames <- Filter(+ NULL |
| 215 | -! | +||
| 470 | +
- function(name) is.data.frame(isolate(data())[[name]]),+ } |
||
| 216 | -! | +||
| 471 | +
- datanames+ }) |
||
| 217 | -- |
- )- |
- |
| 218 | -! | -
- if_subject_plot <- length(parent_dataname) > 0 && parent_dataname %in% datanames- |
- |
| 219 | -- | - - | -|
| 220 | -! | -
- ns <- session$ns- |
- |
| 221 | +472 | ||
| 222 | +473 | ! |
- output$dataset_tabs <- renderUI({
+ output$ui_outlier_help <- renderUI({
|
| 223 | +474 | ! |
- do.call(+ req(is.logical(input$remove_outliers), input$outlier_definition_slider) |
| 224 | +475 | ! |
- tabsetPanel,+ if (input$remove_outliers) {
|
| 225 | +476 | ! |
- c(+ tags$small( |
| 226 | +477 | ! |
- id = ns("dataname_tab"),
+ helpText( |
| 227 | +478 | ! |
- lapply(+ withMathJax(paste0( |
| 228 | +479 | ! |
- datanames,+ "Outlier data points (\\( X \\lt Q1 - ", input$outlier_definition_slider, "\\times IQR \\) or |
| 229 | +480 | ! |
- function(x) {
+ \\(Q3 + ", input$outlier_definition_slider, "\\times IQR \\lt X\\)) |
| 230 | +481 | ! |
- tabPanel(+ have not been displayed on the graph and will not be used for any kernel density estimations, ", |
| 231 | +482 | ! |
- title = x,+ "although their values remain in the statisics table below." |
| 232 | -! | +||
| 483 | +
- column(+ )) |
||
| 233 | -! | +||
| 484 | +
- width = 12,+ ) |
||
| 234 | -! | +||
| 485 | +
- tags$div(+ ) |
||
| 235 | -! | +||
| 486 | +
- class = "mt-4",+ } else {
|
||
| 236 | +487 | ! |
- ui_missing_data(id = ns(x), by_subject_plot = if_subject_plot)+ NULL |
| 237 | +488 |
- )+ } |
|
| 238 | +489 |
- )+ }) |
|
| 239 | +490 |
- )+ |
|
| 240 | +491 |
- }+ |
|
| 241 | -+ | ||
| 492 | +! |
- )+ variable_plot_r <- reactive({
|
|
| 242 | -+ | ||
| 493 | +! |
- )+ display_density <- `if`(is.null(input$display_density), FALSE, input$display_density) |
|
| 243 | -+ | ||
| 494 | +! |
- )+ remove_outliers <- `if`(is.null(input$remove_outliers), FALSE, input$remove_outliers) |
|
| 244 | +495 |
- })+ |
|
| 245 | -+ | ||
| 496 | +! |
-
+ if (remove_outliers) {
|
|
| 246 | +497 | ! |
- output$dataset_encodings <- renderUI({
+ req(input$outlier_definition_slider) |
| 247 | +498 | ! |
- tagList(+ outlier_definition <- as.numeric(input$outlier_definition_slider)+ |
+
| 499 | ++ |
+ } else {
|
|
| 248 | +500 | ! |
- lapply(+ outlier_definition <- 0+ |
+
| 501 | ++ |
+ }+ |
+ |
| 502 | ++ | + | |
| 249 | +503 | ! |
- datanames,+ plot_var_summary( |
| 250 | +504 | ! |
- function(x) {
+ var = plotted_data()$data, |
| 251 | +505 | ! |
- conditionalPanel(+ var_lab = plotted_data()$var_description, |
| 252 | +506 | ! |
- is_tab_active_js(ns("dataname_tab"), x),
+ wrap_character = 15, |
| 253 | +507 | ! |
- encoding_missing_data(+ numeric_as_factor = treat_numeric_as_factor(), |
| 254 | +508 | ! |
- id = ns(x),+ remove_NA_hist = input$remove_NA_hist, |
| 255 | +509 | ! |
- summary_per_patient = if_subject_plot,+ display_density = display_density, |
| 256 | +510 | ! |
- ggtheme = ggtheme,+ outlier_definition = outlier_definition, |
| 257 | +511 | ! |
- datanames = datanames,+ records_for_factor = .unique_records_for_factor, |
| 258 | +512 | ! |
- decorators = decorators+ ggplot2_args = all_ggplot2_args() |
| 259 | +513 |
- )+ ) |
|
| 260 | +514 |
- )+ }) |
|
| 261 | +515 |
- }+ |
|
| 262 | -+ | ||
| 516 | +! |
- )+ pws <- teal.widgets::plot_with_settings_srv( |
|
| 263 | -+ | ||
| 517 | +! |
- )+ id = "variable_plot",+ |
+ |
| 518 | +! | +
+ plot_r = variable_plot_r,+ |
+ |
| 519 | +! | +
+ height = c(500, 200, 2000) |
|
| 264 | +520 |
- })+ ) |
|
| 265 | +521 | ||
| 266 | +522 | ! |
- output$dataset_reporter <- renderUI({
+ output$variable_summary_table <- DT::renderDataTable({
|
| 267 | +523 | ! |
- lapply(datanames, function(x) {
+ var_summary_table( |
| 268 | +524 | ! |
- dataname_ns <- NS(ns(x))+ plotted_data()$data, |
| 269 | -+ | ||
| 525 | +! |
-
+ treat_numeric_as_factor(), |
|
| 270 | +526 | ! |
- conditionalPanel(+ input$variable_summary_table_rows, |
| 271 | +527 | ! |
- is_tab_active_js(ns("dataname_tab"), x),
+ if (!is.null(input$remove_outliers) && input$remove_outliers) {
|
| 272 | +528 | ! |
- tagList(+ req(input$outlier_definition_slider) |
| 273 | +529 | ! |
- teal.widgets::verbatim_popup_ui(dataname_ns("rcode"), "Show R code")
+ as.numeric(input$outlier_definition_slider) |
| 274 | +530 |
- )+ } else {
+ |
+ |
| 531 | +! | +
+ 0 |
|
| 275 | +532 |
- )+ } |
|
| 276 | +533 |
- })+ ) |
|
| 277 | +534 |
}) |
|
| 278 | +535 | ||
| 279 | -! | +||
| 536 | +
- lapply(+ ### REPORTER |
||
| 280 | +537 | ! |
- datanames,+ if (with_reporter) {
|
| 281 | +538 | ! |
- function(x) {
+ card_fun <- function(comment) {
|
| 282 | +539 | ! |
- srv_missing_data(+ card <- teal::TealReportCard$new() |
| 283 | +540 | ! |
- id = x,+ card$set_name("Variable Browser Plot")
|
| 284 | +541 | ! |
- data = data,+ card$append_text("Variable Browser Plot", "header2")
|
| 285 | +542 | ! |
- reporter = if (with_reporter) reporter,+ if (with_filter) card$append_fs(filter_panel_api$get_filter_state()) |
| 286 | +543 | ! |
- filter_panel_api = if (with_filter) filter_panel_api,+ card$append_text("Plot", "header3")
|
| 287 | +544 | ! |
- dataname = x,+ card$append_plot(variable_plot_r(), dim = pws$dim()) |
| 288 | +545 | ! |
- parent_dataname = parent_dataname,+ if (!comment == "") {
|
| 289 | +546 | ! |
- plot_height = plot_height,+ card$append_text("Comment", "header3")
|
| 290 | +547 | ! |
- plot_width = plot_width,+ card$append_text(comment) |
| 291 | -! | +||
| 548 | +
- ggplot2_args = ggplot2_args,+ } |
||
| 292 | +549 | ! |
- decorators = decorators+ card |
| 293 | +550 |
- )+ }+ |
+ |
| 551 | +! | +
+ teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
|
|
| 294 | +552 |
- }+ } |
|
| 295 | +553 |
- )+ ### |
|
| 296 | +554 |
}) |
|
| 297 | +555 |
} |
|
| 298 | +556 | ||
| 299 | +557 |
- # UI function for the missing data module (single dataset)+ #' Summarize NAs. |
|
| 300 | +558 |
- ui_missing_data <- function(id, by_subject_plot = FALSE) {
+ #' |
|
| 301 | -! | +||
| 559 | +
- ns <- NS(id)+ #' Summarizes occurrence of missing values in vector. |
||
| 302 | +560 |
-
+ #' @param x vector of any type and length |
|
| 303 | -! | +||
| 561 | +
- tab_list <- list(+ #' @return Character string describing `NA` occurrence. |
||
| 304 | -! | +||
| 562 | +
- tabPanel(+ #' @keywords internal |
||
| 305 | -! | +||
| 563 | +
- "Summary",+ var_missings_info <- function(x) {
|
||
| 306 | +564 | ! |
- teal.widgets::plot_with_settings_ui(id = ns("summary_plot")),
+ sprintf("%s [%s%%]", sum(is.na(x)), round(mean(is.na(x) * 100), 2))
|
| 307 | -! | +||
| 565 | +
- helpText(+ } |
||
| 308 | -! | +||
| 566 | +
- tags$p(paste(+ |
||
| 309 | -! | +||
| 567 | +
- 'The "Summary" graph shows the number of missing values per variable (both absolute and percentage),',+ #' Summarizes variable |
||
| 310 | -! | +||
| 568 | +
- "sorted by magnitude."+ #' |
||
| 311 | +569 |
- )),+ #' Creates html summary with statistics relevant to data type. For numeric values it returns central |
|
| 312 | -! | -
- tags$p(- |
- |
| 313 | -! | +||
| 570 | +
- 'The "summary per patients" graph is showing how many subjects have at least one missing observation',+ #' tendency measures, for factor returns level counts, for Date date range, for other just |
||
| 314 | -! | +||
| 571 | +
- "for each variable. It will be most useful for panel datasets."+ #' number of levels. |
||
| 315 | +572 |
- )+ #' |
|
| 316 | +573 |
- )+ #' @param x vector of any type |
|
| 317 | +574 |
- ),+ #' @param numeric_as_factor `logical` should the numeric variable be treated as a factor |
|
| 318 | -! | +||
| 575 | +
- tabPanel(+ #' @param dt_rows `numeric` current/latest `DT` page length |
||
| 319 | -! | +||
| 576 | +
- "Combinations",+ #' @param outlier_definition If 0 no outliers are removed, otherwise |
||
| 320 | -! | +||
| 577 | +
- teal.widgets::plot_with_settings_ui(id = ns("combination_plot")),
+ #' outliers (those more than `outlier_definition*IQR below/above Q1/Q3` be removed) |
||
| 321 | -! | +||
| 578 | +
- helpText(+ #' @return text with simple statistics. |
||
| 322 | -! | +||
| 579 | +
- tags$p(paste(+ #' @keywords internal |
||
| 323 | -! | +||
| 580 | +
- 'The "Combinations" graph is used to explore the relationship between the missing data within',+ var_summary_table <- function(x, numeric_as_factor, dt_rows, outlier_definition) {
|
||
| 324 | +581 | ! |
- "different columns of the dataset.",+ if (is.null(dt_rows)) {
|
| 325 | +582 | ! |
- "It shows the different patterns of missingness in the rows of the data.",+ dt_rows <- 10 |
| 326 | -! | +||
| 583 | +
- 'For example, suppose that 70 rows of the data have exactly columns "A" and "B" missing.',+ } |
||
| 327 | +584 | ! |
- "In this case there would be a bar of height 70 in the top graph and",+ if (is.numeric(x) && !numeric_as_factor) {
|
| 328 | +585 | ! |
- 'the column below this in the second graph would have rows "A" and "B" cells shaded red.'+ req(!any(is.infinite(x))) |
| 329 | +586 |
- )),+ |
|
| 330 | +587 | ! |
- tags$p(paste(+ x <- remove_outliers_from(x, outlier_definition) |
| 331 | -! | +||
| 588 | +
- "Due to the large number of missing data patterns possible, only those with a large set of observations",+ |
||
| 332 | +589 | ! |
- 'are shown in the graph and the "Combination cut-off" slider can be used to adjust the number shown.'+ qvals <- round(stats::quantile(x, na.rm = TRUE, probs = c(0.25, 0.5, 0.75), type = 2), 2) |
| 333 | +590 |
- ))+ # classical central tendency measures |
|
| 334 | +591 |
- )+ |
|
| 335 | -+ | ||
| 592 | +! |
- ),+ summary <- |
|
| 336 | +593 | ! |
- tabPanel(+ data.frame( |
| 337 | +594 | ! |
- "By Variable Levels",+ Statistic = c("min", "Q1", "median", "mean", "Q3", "max", "sd", "n"),
|
| 338 | +595 | ! |
- teal.widgets::get_dt_rows(ns("levels_table"), ns("levels_table_rows")),
+ Value = c( |
| 339 | +596 | ! |
- DT::dataTableOutput(ns("levels_table"))
+ round(min(x, na.rm = TRUE), 2), |
| 340 | -+ | ||
| 597 | +! |
- )+ qvals[1], |
|
| 341 | -+ | ||
| 598 | +! |
- )+ qvals[2], |
|
| 342 | +599 | ! |
- if (isTRUE(by_subject_plot)) {
+ round(mean(x, na.rm = TRUE), 2), |
| 343 | +600 | ! |
- tab_list <- append(+ qvals[3], |
| 344 | +601 | ! |
- tab_list,+ round(max(x, na.rm = TRUE), 2), |
| 345 | +602 | ! |
- list(tabPanel(+ round(stats::sd(x, na.rm = TRUE), 2), |
| 346 | +603 | ! |
- "Grouped by Subject",+ length(x[!is.na(x)]) |
| 347 | -! | +||
| 604 | +
- teal.widgets::plot_with_settings_ui(id = ns("by_subject_plot")),
+ ) |
||
| 348 | -! | +||
| 605 | +
- helpText(+ ) |
||
| 349 | -! | +||
| 606 | +
- tags$p(paste(+ |
||
| 350 | +607 | ! |
- "This graph shows the missingness with respect to subjects rather than individual rows of the",+ DT::datatable(summary, rownames = FALSE, options = list(dom = "<t>", pageLength = dt_rows)) |
| 351 | +608 | ! |
- "dataset. Each row represents one dataset variable and each column a single subject. Only subjects",+ } else if (is.factor(x) || is.character(x) || (is.numeric(x) && numeric_as_factor) || is.logical(x)) {
|
| 352 | -! | +||
| 609 | +
- "with at least one record in this dataset are shown. For a given subject, if they have any missing",+ # make sure factor is ordered numeric |
||
| 353 | +610 | ! |
- "values of a specific variable then the appropriate cell in the graph is marked as missing."+ if (is.numeric(x)) {
|
| 354 | -+ | ||
| 611 | +! |
- ))+ x <- factor(x, levels = sort(unique(x))) |
|
| 355 | +612 |
- )+ } |
|
| 356 | +613 |
- ))+ |
|
| 357 | -+ | ||
| 614 | +! |
- )+ level_counts <- table(x) |
|
| 358 | -+ | ||
| 615 | +! |
- }+ max_levels_signif <- nchar(level_counts) |
|
| 359 | +616 | ||
| 360 | +617 | ! |
- do.call(+ if (!all(is.na(x))) {
|
| 361 | +618 | ! |
- tabsetPanel,+ levels <- names(level_counts) |
| 362 | +619 | ! |
- c(+ counts <- sprintf( |
| 363 | +620 | ! |
- id = ns("summary_type"),
+ "%s [%.2f%%]", |
| 364 | +621 | ! |
- tab_list+ format(level_counts, width = max_levels_signif), prop.table(level_counts) * 100 |
| 365 | +622 |
- )+ ) |
|
| 366 | +623 |
- )+ } else {
|
|
| 367 | -+ | ||
| 624 | +! |
- }+ levels <- character(0) |
|
| 368 | -+ | ||
| 625 | +! |
-
+ counts <- numeric(0) |
|
| 369 | +626 |
- # UI encoding for the missing data module (all datasets)+ } |
|
| 370 | +627 |
- encoding_missing_data <- function(id, summary_per_patient = FALSE, ggtheme, datanames, decorators) {
+
|
|
| 371 | +628 | ! |
- ns <- NS(id)+ summary <- data.frame( |
| 372 | -+ | ||
| 629 | +! |
-
+ Level = levels, |
|
| 373 | +630 | ! |
- tagList(+ Count = counts,+ |
+
| 631 | +! | +
+ stringsAsFactors = FALSE |
|
| 374 | +632 |
- ### Reporter+ ) |
|
| 375 | -! | +||
| 633 | +
- teal.reporter::simple_reporter_ui(ns("simple_reporter")),
+
|
||
| 376 | +634 |
- ###+ # sort the dataset in decreasing order of counts (needed as character variables default to alphabetical) |
|
| 377 | +635 | ! |
- tags$label("Encodings", class = "text-primary"),
+ summary <- summary[order(summary$Count, decreasing = TRUE), ] |
| 378 | -! | +||
| 636 | +
- helpText(+ |
||
| 379 | +637 | ! |
- paste0("Dataset", `if`(length(datanames) > 1, "s", ""), ":"),
+ dom_opts <- if (nrow(summary) <= 10) {
|
| 380 | +638 | ! |
- tags$code(paste(datanames, collapse = ", "))+ "<t>" |
| 381 | +639 |
- ),+ } else {
|
|
| 382 | +640 | ! |
- uiOutput(ns("variables")),
+ "<lf<t>ip>" |
| 383 | -! | +||
| 641 | +
- actionButton(+ } |
||
| 384 | +642 | ! |
- ns("filter_na"),
+ DT::datatable(summary, rownames = FALSE, options = list(dom = dom_opts, pageLength = dt_rows)) |
| 385 | +643 | ! |
- tags$span("Select only vars with missings", class = "whitespace-normal"),
+ } else if (inherits(x, "Date") || inherits(x, "POSIXct") || inherits(x, "POSIXlt")) {
|
| 386 | +644 | ! |
- width = "100%",+ summary <- |
| 387 | +645 | ! |
- class = "mb-4"- |
-
| 388 | -- |
- ),+ data.frame( |
|
| 389 | +646 | ! |
- conditionalPanel(+ Statistic = c("min", "median", "max"),
|
| 390 | +647 | ! |
- is_tab_active_js(ns("summary_type"), "Summary"),
+ Value = c( |
| 391 | +648 | ! |
- checkboxInput(+ min(x, na.rm = TRUE), |
| 392 | +649 | ! |
- ns("any_na"),
+ stats::median(x, na.rm = TRUE), |
| 393 | +650 | ! |
- tags$div(+ max(x, na.rm = TRUE) |
| 394 | -! | +||
| 651 | +
- class = "teal-tooltip",+ ) |
||
| 395 | -! | +||
| 652 | +
- tagList(+ ) |
||
| 396 | +653 | ! |
- "Add **anyna** variable",+ DT::datatable(summary, rownames = FALSE, options = list(dom = "<t>", pageLength = dt_rows)) |
| 397 | -! | +||
| 654 | +
- icon("circle-info"),
+ } else {
|
||
| 398 | +655 | ! |
- tags$span(+ NULL |
| 399 | -! | +||
| 656 | +
- class = "tooltiptext",+ } |
||
| 400 | -! | +||
| 657 | +
- "Describes the number of observations with at least one missing value in any variable."+ } |
||
| 401 | +658 |
- )+ |
|
| 402 | +659 |
- )+ #' Plot variable |
|
| 403 | +660 |
- ),+ #' |
|
| 404 | -! | +||
| 661 | +
- value = FALSE+ #' Creates summary plot with statistics relevant to data type. |
||
| 405 | +662 |
- ),+ #' |
|
| 406 | -! | +||
| 663 | +
- if (summary_per_patient) {
+ #' @inheritParams shared_params |
||
| 407 | -! | +||
| 664 | +
- checkboxInput(+ #' @param var vector of any type to be plotted. For numeric variables it produces histogram with |
||
| 408 | -! | +||
| 665 | +
- ns("if_patients_plot"),
+ #' density line, for factors it creates frequency plot |
||
| 409 | -! | +||
| 666 | +
- tags$div(+ #' @param var_lab text describing selected variable to be displayed on the plot |
||
| 410 | -! | +||
| 667 | +
- class = "teal-tooltip",+ #' @param wrap_character (`numeric`) number of characters at which to wrap text values of `var` |
||
| 411 | -! | +||
| 668 | +
- tagList(+ #' @param numeric_as_factor (`logical`) should the numeric variable be treated as a factor |
||
| 412 | -! | +||
| 669 | +
- "Add summary per patients",+ #' @param display_density (`logical`) should density estimation be displayed for numeric values |
||
| 413 | -! | +||
| 670 | +
- icon("circle-info"),
+ #' @param remove_NA_hist (`logical`) should `NA` values be removed for histogram of factor like variables |
||
| 414 | -! | +||
| 671 | +
- tags$span(+ #' @param outlier_definition if 0 no outliers are removed, otherwise |
||
| 415 | -! | +||
| 672 | +
- class = "tooltiptext",+ #' outliers (those more than outlier_definition*IQR below/above Q1/Q3 be removed) |
||
| 416 | -! | +||
| 673 | +
- paste(+ #' @param records_for_factor (`numeric`) if the number of factor levels is >= than this value then |
||
| 417 | -! | +||
| 674 | +
- "Displays the number of missing values per observation,",+ #' a graph of the factors isn't shown, only a list of values |
||
| 418 | -! | +||
| 675 | +
- "where the x-axis is sorted by observation appearance in the table."+ #' |
||
| 419 | +676 |
- )+ #' @return plot |
|
| 420 | +677 |
- )+ #' @keywords internal |
|
| 421 | +678 |
- )+ plot_var_summary <- function(var, |
|
| 422 | +679 |
- ),+ var_lab, |
|
| 423 | -! | +||
| 680 | +
- value = FALSE+ wrap_character = NULL, |
||
| 424 | +681 |
- )+ numeric_as_factor, |
|
| 425 | +682 |
- },+ display_density = is.numeric(var), |
|
| 426 | -! | +||
| 683 | +
- ui_decorate_teal_data(ns("dec_summary_plot"), decorators = select_decorators(decorators, "summary_plot"))
+ remove_NA_hist = FALSE, # nolint: object_name. |
||
| 427 | +684 |
- ),+ outlier_definition,+ |
+ |
| 685 | ++ |
+ records_for_factor,+ |
+ |
| 686 | ++ |
+ ggplot2_args) {
|
|
| 428 | +687 | ! |
- conditionalPanel(+ checkmate::assert_character(var_lab) |
| 429 | +688 | ! |
- is_tab_active_js(ns("summary_type"), "Combinations"),
+ checkmate::assert_numeric(wrap_character, null.ok = TRUE) |
| 430 | +689 | ! |
- uiOutput(ns("cutoff")),
+ checkmate::assert_flag(numeric_as_factor) |
| 431 | +690 | ! |
- ui_decorate_teal_data(ns("dec_combination_plot"), decorators = select_decorators(decorators, "combination_plot"))
+ checkmate::assert_flag(display_density) |
| 432 | -+ | ||
| 691 | +! |
- ),+ checkmate::assert_logical(remove_NA_hist, null.ok = TRUE) |
|
| 433 | +692 | ! |
- conditionalPanel(+ checkmate::assert_number(outlier_definition, lower = 0, finite = TRUE) |
| 434 | +693 | ! |
- is_tab_active_js(ns("summary_type"), "Grouped by Subject"),
+ checkmate::assert_integerish(records_for_factor, lower = 0, len = 1, any.missing = FALSE) |
| 435 | +694 | ! |
- ui_decorate_teal_data(ns("dec_by_subject_plot"), decorators = select_decorators(decorators, "by_subject_plot"))
+ checkmate::assert_class(ggplot2_args, "ggplot2_args") |
| 436 | +695 |
- ),+ |
|
| 437 | +696 | ! |
- conditionalPanel(+ grid::grid.newpage()+ |
+
| 697 | ++ | + | |
| 438 | +698 | ! |
- is_tab_active_js(ns("summary_type"), "By Variable Levels"),
+ plot_main <- if (is.factor(var) || is.character(var) || is.logical(var)) {
|
| 439 | +699 | ! |
- uiOutput(ns("group_by_var_ui")),
+ groups <- unique(as.character(var)) |
| 440 | +700 | ! |
- uiOutput(ns("group_by_vals_ui")),
+ len_groups <- length(groups) |
| 441 | +701 | ! |
- radioButtons(+ if (len_groups >= records_for_factor) {
|
| 442 | +702 | ! |
- ns("count_type"),
+ grid::textGrob( |
| 443 | +703 | ! |
- label = "Display missing as",+ sprintf( |
| 444 | +704 | ! |
- choices = c("counts", "proportions"),
+ "%s unique values\n%s:\n %s\n ...\n %s", |
| 445 | +705 | ! |
- selected = "counts",+ len_groups, |
| 446 | +706 | ! |
- inline = TRUE+ var_lab, |
| 447 | -+ | ||
| 707 | +! |
- ),+ paste(utils::head(groups), collapse = ",\n "), |
|
| 448 | +708 | ! |
- ui_decorate_teal_data(ns("dec_summary_table"), decorators = select_decorators(decorators, "summary_table"))
+ paste(utils::tail(groups), collapse = ",\n ") |
| 449 | +709 |
- ),- |
- |
| 450 | -! | -
- teal.widgets::panel_item(+ ), |
|
| 451 | +710 | ! |
- title = "Plot settings",+ x = grid::unit(1, "line"), |
| 452 | +711 | ! |
- selectInput(+ y = grid::unit(1, "npc") - grid::unit(1, "line"), |
| 453 | +712 | ! |
- inputId = ns("ggtheme"),
+ just = c("left", "top")
|
| 454 | -! | +||
| 713 | +
- label = "Theme (by ggplot):",+ ) |
||
| 455 | -! | +||
| 714 | +
- choices = ggplot_themes,+ } else {
|
||
| 456 | +715 | ! |
- selected = ggtheme,+ if (!is.null(wrap_character)) {
|
| 457 | +716 | ! |
- multiple = FALSE+ var <- stringr::str_wrap(var, width = wrap_character) |
| 458 | +717 |
- )+ } |
|
| 459 | -+ | ||
| 718 | +! |
- )+ var <- if (isTRUE(remove_NA_hist)) as.vector(stats::na.omit(var)) else var |
|
| 460 | -+ | ||
| 719 | +! |
- )+ ggplot(data.frame(var), aes(x = forcats::fct_infreq(as.factor(var)))) + |
|
| 461 | -+ | ||
| 720 | +! |
- }+ geom_bar( |
|
| 462 | -+ | ||
| 721 | +! |
-
+ stat = "count", aes(fill = ifelse(is.na(var), "withcolor", "")), show.legend = FALSE |
|
| 463 | +722 |
- # Server function for the missing data (single dataset)+ ) + |
|
| 464 | -+ | ||
| 723 | +! |
- srv_missing_data <- function(id,+ scale_fill_manual(values = c("gray50", "tan"))
|
|
| 465 | +724 |
- data,+ } |
|
| 466 | -+ | ||
| 725 | +! |
- reporter,+ } else if (is.numeric(var)) {
|
|
| 467 | -+ | ||
| 726 | +! |
- filter_panel_api,+ validate(need(any(!is.na(var)), "No data left to visualize.")) |
|
| 468 | +727 |
- dataname,+ |
|
| 469 | +728 |
- parent_dataname,+ # Filter out NA |
|
| 470 | -+ | ||
| 729 | +! |
- plot_height,+ var <- var[which(!is.na(var))] |
|
| 471 | +730 |
- plot_width,+ |
|
| 472 | -+ | ||
| 731 | +! |
- ggplot2_args,+ validate(need(!any(is.infinite(var)), "Cannot display graph when data includes infinite values")) |
|
| 473 | +732 |
- decorators) {
- |
- |
| 474 | -! | -
- with_reporter <- !missing(reporter) && inherits(reporter, "Reporter")+ |
|
| 475 | +733 | ! |
- with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI")+ if (numeric_as_factor) {
|
| 476 | +734 | ! |
- checkmate::assert_class(data, "reactive")+ var <- factor(var) |
| 477 | +735 | ! |
- checkmate::assert_class(isolate(data()), "teal_data")+ ggplot(NULL, aes(x = var)) + |
| 478 | +736 | ! |
- moduleServer(id, function(input, output, session) {
+ geom_histogram(stat = "count") |
| 479 | -! | +||
| 737 | +
- ns <- session$ns+ } else {
|
||
| 480 | +738 |
-
+ # remove outliers |
|
| 481 | +739 | ! |
- prev_group_by_var <- reactiveVal("")
+ if (outlier_definition != 0) {
|
| 482 | +740 | ! |
- data_r <- reactive(data()[[dataname]])+ number_records <- length(var) |
| 483 | +741 | ! |
- data_keys <- reactive(unlist(teal.data::join_keys(data())[[dataname]]))- |
-
| 484 | -- |
-
+ var <- remove_outliers_from(var, outlier_definition) |
|
| 485 | +742 | ! |
- iv_r <- reactive({
+ number_outliers <- number_records - length(var) |
| 486 | +743 | ! |
- iv <- shinyvalidate::InputValidator$new()+ outlier_text <- paste0( |
| 487 | +744 | ! |
- iv$add_rule(+ number_outliers, " outliers (",
|
| 488 | +745 | ! |
- "variables_select",+ round(number_outliers / number_records * 100, 2), |
| 489 | +746 | ! |
- shinyvalidate::sv_required("At least one reference variable needs to be selected.")
+ "% of non-missing records) not shown" |
| 490 | +747 |
- )+ ) |
|
| 491 | +748 | ! |
- iv$add_rule(+ validate(need( |
| 492 | +749 | ! |
- "variables_select",+ length(var) > 1, |
| 493 | +750 | ! |
- ~ if (length(setdiff((.), data_keys())) < 1) "Please also select non-key columns."+ "At least two data points must remain after removing outliers for this graph to be displayed" |
| 494 | +751 |
- )+ )) |
|
| 495 | -! | +||
| 752 | +
- iv_summary_table <- shinyvalidate::InputValidator$new()+ } |
||
| 496 | -! | +||
| 753 | +
- iv_summary_table$condition(~ isTRUE(input$summary_type == "By Variable Levels"))+ ## histogram |
||
| 497 | +754 | ! |
- iv_summary_table$add_rule("count_type", shinyvalidate::sv_required("Please select type of counts"))
+ binwidth <- get_bin_width(var) |
| 498 | +755 | ! |
- iv_summary_table$add_rule(+ p <- ggplot(data = data.frame(var = var), aes(x = var, y = after_stat(count))) + |
| 499 | +756 | ! |
- "group_by_vals",+ geom_histogram(binwidth = binwidth) + |
| 500 | +757 | ! |
- shinyvalidate::sv_required("Please select both group-by variable and values")
- |
-
| 501 | -- |
- )+ scale_y_continuous( |
|
| 502 | +758 | ! |
- iv_summary_table$add_rule(+ sec.axis = sec_axis( |
| 503 | +759 | ! |
- "group_by_var",+ trans = ~ . / nrow(data.frame(var = var)), |
| 504 | +760 | ! |
- ~ if (length(.) > 0 && length(input$variables_select) == 1 && (.) == input$variables_select) {
+ labels = scales::percent, |
| 505 | +761 | ! |
- "If only one reference variable is selected it must not be the grouping variable."+ name = "proportion (in %)" |
| 506 | +762 |
- }+ ) |
|
| 507 | +763 |
- )- |
- |
| 508 | -! | -
- iv_summary_table$add_rule(+ ) |
|
| 509 | -! | +||
| 764 | +
- "variables_select",+ |
||
| 510 | +765 | ! |
- ~ if (length(input$group_by_var) > 0 && length(.) == 1 && (.) == input$group_by_var) {
+ if (display_density) {
|
| 511 | +766 | ! |
- "If only one reference variable is selected it must not be the grouping variable."+ p <- p + geom_density(aes(y = after_stat(count * binwidth))) |
| 512 | +767 |
- }+ } |
|
| 513 | +768 |
- )- |
- |
| 514 | -! | -
- iv$add_validator(iv_summary_table)+ |
|
| 515 | +769 | ! |
- iv$enable()+ if (outlier_definition != 0) {
|
| 516 | +770 | ! |
- iv- |
-
| 517 | -- |
- })- |
- |
| 518 | -- |
-
+ p <- p + annotate( |
|
| 519 | +771 | ! |
- data_parent_keys <- reactive({
+ geom = "text", |
| 520 | +772 | ! |
- if (length(parent_dataname) > 0 && parent_dataname %in% names(data())) {
+ label = outlier_text, |
| 521 | +773 | ! |
- keys <- teal.data::join_keys(data())[[dataname]]+ x = Inf, y = Inf, |
| 522 | +774 | ! |
- if (parent_dataname %in% names(keys)) {
+ hjust = 1.02, vjust = 1.2, |
| 523 | +775 | ! |
- keys[[parent_dataname]]+ color = "black", |
| 524 | +776 |
- } else {
+ # explicitly modify geom text size according |
|
| 525 | +777 | ! |
- keys[[dataname]]+ size = ggplot2_args[["theme"]][["text"]][["size"]] / 3.5 |
| 526 | +778 |
- }+ ) |
|
| 527 | +779 |
- } else {
+ } |
|
| 528 | +780 | ! |
- NULL- |
-
| 529 | -- |
- }- |
- |
| 530 | -- |
- })+ p |
|
| 531 | +781 |
-
+ } |
|
| 532 | +782 | ! |
- common_code_q <- reactive({
+ } else if (inherits(var, "Date") || inherits(var, "POSIXct") || inherits(var, "POSIXlt")) {
|
| 533 | +783 | ! |
- teal::validate_inputs(iv_r())+ var_num <- as.numeric(var) |
| 534 | -+ | ||
| 784 | +! |
-
+ binwidth <- get_bin_width(var_num, 1) |
|
| 535 | +785 | ! |
- group_var <- input$group_by_var+ p <- ggplot(data = data.frame(var = var), aes(x = var, y = after_stat(count))) + |
| 536 | +786 | ! |
- anl <- data_r()+ geom_histogram(binwidth = binwidth) |
| 537 | +787 |
-
+ } else {
|
|
| 538 | +788 | ! |
- qenv <- if (!is.null(selected_vars()) && length(selected_vars()) != ncol(anl)) {
+ grid::textGrob( |
| 539 | +789 | ! |
- teal.code::eval_code(+ paste(strwrap( |
| 540 | +790 | ! |
- data(),+ utils::capture.output(utils::str(var)), |
| 541 | +791 | ! |
- substitute(+ width = .9 * grid::convertWidth(grid::unit(1, "npc"), "char", TRUE) |
| 542 | +792 | ! |
- expr = ANL <- anl_name[, selected_vars, drop = FALSE],+ ), collapse = "\n"), |
| 543 | +793 | ! |
- env = list(anl_name = as.name(dataname), selected_vars = selected_vars())+ x = grid::unit(1, "line"), y = grid::unit(1, "npc") - grid::unit(1, "line"), just = c("left", "top")
|
| 544 | +794 |
- )+ ) |
|
| 545 | +795 |
- )+ } |
|
| 546 | +796 |
- } else {
+
|
|
| 547 | +797 | ! |
- teal.code::eval_code(+ dev_ggplot2_args <- teal.widgets::ggplot2_args( |
| 548 | +798 | ! |
- data(),+ labs = list(x = var_lab) |
| 549 | -! | +||
| 799 | +
- substitute(expr = ANL <- anl_name, env = list(anl_name = as.name(dataname)))+ ) |
||
| 550 | +800 |
- )+ ###+ |
+ |
| 801 | +! | +
+ all_ggplot2_args <- teal.widgets::resolve_ggplot2_args(+ |
+ |
| 802 | +! | +
+ ggplot2_args,+ |
+ |
| 803 | +! | +
+ module_plot = dev_ggplot2_args |
|
| 551 | +804 |
- }+ ) |
|
| 552 | +805 | ||
| 553 | +806 | ! |
- if (input$summary_type == "By Variable Levels" && !is.null(group_var) && !(group_var %in% selected_vars())) {
+ if (is.ggplot(plot_main)) {
|
| 554 | +807 | ! |
- qenv <- teal.code::eval_code(+ if (is.numeric(var) && !numeric_as_factor) {
+ |
+
| 808 | ++ |
+ # numeric not as factor |
|
| 555 | +809 | ! |
- qenv,+ plot_main <- plot_main + |
| 556 | +810 | ! |
- substitute(+ theme_light() + |
| 557 | +811 | ! |
- expr = ANL[[group_var]] <- anl_name[[group_var]],+ list( |
| 558 | +812 | ! |
- env = list(group_var = group_var, anl_name = as.name(dataname))+ labs = do.call("labs", all_ggplot2_args$labs),
|
| 559 | -+ | ||
| 813 | +! |
- )+ theme = do.call("theme", all_ggplot2_args$theme)
|
|
| 560 | +814 |
) |
|
| 561 | +815 |
- }+ } else {
|
|
| 562 | +816 |
-
+ # factor low number of levels OR numeric as factor OR Date |
|
| 563 | +817 | ! |
- new_col_name <- "**anyna**"+ plot_main <- plot_main + |
| 564 | -+ | ||
| 818 | +! |
-
+ theme_light() + |
|
| 565 | +819 | ! |
- qenv <- teal.code::eval_code(+ list( |
| 566 | +820 | ! |
- qenv,+ labs = do.call("labs", all_ggplot2_args$labs),
|
| 567 | +821 | ! |
- substitute(+ theme = do.call("theme", all_ggplot2_args$theme)
|
| 568 | -! | +||
| 822 | +
- expr =+ ) |
||
| 569 | -! | +||
| 823 | +
- create_cols_labels <- function(cols, just_label = FALSE) {
+ } |
||
| 570 | +824 | ! |
- column_labels <- column_labels_value+ plot_main <- ggplotGrob(plot_main) |
| 571 | -! | +||
| 825 | +
- column_labels[is.na(column_labels) | length(column_labels) == 0] <- ""+ }+ |
+ ||
| 826 | ++ | + | |
| 572 | +827 | ! |
- if (just_label) {
+ grid::grid.draw(plot_main) |
| 573 | +828 | ! |
- labels <- column_labels[cols]+ plot_main |
| 574 | +829 |
- } else {
+ } |
|
| 575 | -! | +||
| 830 | +
- labels <- ifelse(cols == new_col_name | cols == "", cols, paste0(column_labels[cols], " [", cols, "]"))+ |
||
| 576 | +831 |
- }+ is_num_var_short <- function(.unique_records_for_factor, input, data_for_analysis) {
|
|
| 577 | +832 | ! |
- labels+ length(unique(data_for_analysis()$data)) < .unique_records_for_factor && !is.null(input$numeric_as_factor) |
| 578 | +833 |
- },- |
- |
| 579 | -! | -
- env = list(+ } |
|
| 580 | -! | +||
| 834 | +
- new_col_name = new_col_name,+ |
||
| 581 | -! | +||
| 835 | +
- column_labels_value = c(teal.data::col_labels(data_r())[selected_vars()],+ #' Validates the variable browser inputs |
||
| 582 | -! | +||
| 836 | +
- new_col_name = new_col_name+ #' |
||
| 583 | +837 |
- )+ #' @param input (`session$input`) the `shiny` session input |
|
| 584 | +838 |
- )+ #' @param plot_var (`list`) list of a data frame and an array of variable names |
|
| 585 | +839 |
- )+ #' @param data (`teal_data`) the datasets passed to the module |
|
| 586 | +840 |
- )+ #' |
|
| 587 | -! | +||
| 841 | +
- qenv+ #' @returns `logical` TRUE if validations pass; a `shiny` validation error otherwise |
||
| 588 | +842 |
- })+ #' @keywords internal |
|
| 589 | +843 |
-
+ validate_input <- function(input, plot_var, data) {
|
|
| 590 | +844 | ! |
- selected_vars <- reactive({
+ reactive({
|
| 591 | +845 | ! |
- req(input$variables_select)+ dataset_name <- req(input$tabset_panel) |
| 592 | +846 | ! |
- keys <- data_keys()+ varname <- plot_var$variable[[dataset_name]]+ |
+
| 847 | ++ | + | |
| 593 | +848 | ! |
- vars <- unique(c(keys, input$variables_select))+ validate(need(dataset_name, "No data selected")) |
| 594 | +849 | ! |
- vars- |
-
| 595 | -- |
- })- |
- |
| 596 | -- | - - | -|
| 597 | -! | -
- vars_summary <- reactive({
+ validate(need(varname, "No variable selected")) |
|
| 598 | +850 | ! |
- na_count <- data_r() %>%+ df <- data()[[dataset_name]] |
| 599 | +851 | ! |
- sapply(function(x) mean(is.na(x)), USE.NAMES = TRUE) %>%+ teal::validate_has_data(df, 1) |
| 600 | +852 | ! |
- sort(decreasing = TRUE)+ teal::validate_has_variable(varname = varname, data = df, "Variable not available") |
| 601 | +853 | ||
| 602 | -! | -
- tibble::tibble(- |
- |
| 603 | -! | -
- key = names(na_count),- |
- |
| 604 | -! | -
- value = unname(na_count),- |
- |
| 605 | +854 | ! |
- label = cut(na_count, breaks = seq(from = 0, to = 1, by = 0.1), include.lowest = TRUE)+ TRUE |
| 606 | +855 |
- )+ }) |
|
| 607 | +856 |
- })+ } |
|
| 608 | +857 | ||
| 609 | +858 |
- # Keep encoding panel up-to-date+ get_plotted_data <- function(input, plot_var, data) {
|
|
| 610 | +859 | ! |
- output$variables <- renderUI({
+ dataset_name <- input$tabset_panel |
| 611 | +860 | ! |
- choices <- split(x = vars_summary()$key, f = vars_summary()$label, drop = TRUE) %>% rev()+ varname <- plot_var$variable[[dataset_name]] |
| 612 | +861 | ! |
- selected <- choices <- unname(unlist(choices))+ df <- data()[[dataset_name]] |
| 613 | +862 | ||
| 614 | +863 | ! |
- teal.widgets::optionalSelectInput(+ var_description <- teal.data::col_labels(df)[[varname]] |
| 615 | +864 | ! |
- ns("variables_select"),
+ list(data = df[[varname]], var_description = var_description) |
| 616 | -! | +||
| 865 | +
- label = "Select variables",+ } |
||
| 617 | -! | +||
| 866 | +
- label_help = HTML(paste0("Dataset: ", tags$code(dataname))),
+
|
||
| 618 | -! | +||
| 867 | +
- choices = teal.transform::variable_choices(data_r(), choices),+ #' Renders the left-hand side `tabset` panel of the module |
||
| 619 | -! | +||
| 868 | +
- selected = selected,+ #' |
||
| 620 | -! | +||
| 869 | +
- multiple = TRUE+ #' @param datanames (`character`) the name of the dataset |
||
| 621 | +870 |
- )+ #' @param parent_dataname (`character`) the name of a parent `dataname` to filter out variables from |
|
| 622 | +871 |
- })+ #' @param data (`teal_data`) the object containing all datasets |
|
| 623 | +872 |
-
+ #' @param input (`session$input`) the `shiny` session input |
|
| 624 | -! | +||
| 873 | +
- observeEvent(input$filter_na, {
+ #' @param output (`session$output`) the `shiny` session output |
||
| 625 | -! | +||
| 874 | +
- choices <- vars_summary() %>%+ #' @param columns_names (`environment`) the environment containing bindings for each dataset |
||
| 626 | -! | +||
| 875 | +
- dplyr::select(!!as.name("key")) %>%
+ #' @param plot_var (`list`) the list containing the currently selected dataset (tab) and its column names |
||
| 627 | -! | +||
| 876 | +
- getElement(name = 1)+ #' @keywords internal |
||
| 628 | +877 |
-
+ render_tabset_panel_content <- function(datanames, parent_dataname, output, data, input, columns_names, plot_var) {
|
|
| 629 | +878 | ! |
- selected <- vars_summary() %>%+ lapply(datanames, render_single_tab, |
| 630 | +879 | ! |
- dplyr::filter(!!as.name("value") > 0) %>%
+ input = input, |
| 631 | +880 | ! |
- dplyr::select(!!as.name("key")) %>%
+ output = output, |
| 632 | +881 | ! |
- getElement(name = 1)+ data = data, |
| 633 | -+ | ||
| 882 | +! |
-
+ parent_dataname = parent_dataname, |
|
| 634 | +883 | ! |
- teal.widgets::updateOptionalSelectInput(+ columns_names = columns_names, |
| 635 | +884 | ! |
- session = session,+ plot_var = plot_var |
| 636 | -! | +||
| 885 | +
- inputId = "variables_select",+ ) |
||
| 637 | -! | +||
| 886 | +
- choices = teal.transform::variable_choices(data_r()),+ } |
||
| 638 | -! | +||
| 887 | +
- selected = restoreInput(ns("variables_select"), selected)
+
|
||
| 639 | +888 |
- )+ #' Renders a single tab in the left-hand side tabset panel |
|
| 640 | +889 |
- })+ #' |
|
| 641 | +890 |
-
+ #' Renders a single tab in the left-hand side tabset panel. The rendered tab contains |
|
| 642 | -! | +||
| 891 | +
- output$group_by_var_ui <- renderUI({
+ #' information about one dataset out of many presented in the module. |
||
| 643 | -! | +||
| 892 | +
- all_choices <- teal.transform::variable_choices(data_r())+ #' |
||
| 644 | -! | +||
| 893 | +
- cat_choices <- all_choices[!sapply(data_r(), function(x) is.numeric(x) || inherits(x, "POSIXct"))]+ #' @param dataset_name (`character`) the name of the dataset contained in the rendered tab |
||
| 645 | -! | +||
| 894 | +
- validate(+ #' @param parent_dataname (`character`) the name of a parent `dataname` to filter out variables from+ |
+ ||
| 895 | ++ |
+ #' @inheritParams render_tabset_panel_content+ |
+ |
| 896 | ++ |
+ #' @keywords internal+ |
+ |
| 897 | ++ |
+ render_single_tab <- function(dataset_name, parent_dataname, output, data, input, columns_names, plot_var) {
|
|
| 646 | +898 | ! |
- need(cat_choices, "Dataset does not have any non-numeric or non-datetime variables to use to group data with")+ render_tab_header(dataset_name, output, data) |
| 647 | +899 |
- )+ |
|
| 648 | +900 | ! |
- teal.widgets::optionalSelectInput(+ render_tab_table( |
| 649 | +901 | ! |
- ns("group_by_var"),
+ dataset_name = dataset_name, |
| 650 | +902 | ! |
- label = "Group by variable",+ parent_dataname = parent_dataname, |
| 651 | +903 | ! |
- choices = cat_choices,+ output = output, |
| 652 | +904 | ! |
- selected = `if`(+ data = data, |
| 653 | +905 | ! |
- is.null(isolate(input$group_by_var)),+ input = input, |
| 654 | +906 | ! |
- cat_choices[1],+ columns_names = columns_names, |
| 655 | +907 | ! |
- isolate(input$group_by_var)+ plot_var = plot_var |
| 656 | +908 |
- ),+ ) |
|
| 657 | -! | +||
| 909 | +
- multiple = FALSE,+ } |
||
| 658 | -! | +||
| 910 | +
- label_help = paste0("Dataset: ", dataname)
+
|
||
| 659 | +911 |
- )+ #' Renders the text headlining a single tab in the left-hand side tabset panel |
|
| 660 | +912 |
- })+ #' |
|
| 661 | +913 |
-
+ #' @param dataset_name (`character`) the name of the dataset of the tab |
|
| 662 | -! | +||
| 914 | +
- output$group_by_vals_ui <- renderUI({
+ #' @inheritParams render_tabset_panel_content |
||
| 663 | -! | +||
| 915 | +
- req(input$group_by_var)+ #' @keywords internal |
||
| 664 | +916 |
-
+ render_tab_header <- function(dataset_name, output, data) {
|
|
| 665 | +917 | ! |
- choices <- teal.transform::value_choices(data_r(), input$group_by_var, input$group_by_var)+ dataset_ui_id <- paste0("dataset_summary_", dataset_name)
|
| 666 | +918 | ! |
- prev_choices <- isolate(input$group_by_vals)+ output[[dataset_ui_id]] <- renderText({
|
| 667 | -+ | ||
| 919 | +! |
-
+ df <- data()[[dataset_name]] |
|
| 668 | -+ | ||
| 920 | +! |
- # determine selected value based on filtered data+ join_keys <- teal.data::join_keys(data()) |
|
| 669 | -+ | ||
| 921 | +! |
- # display those previously selected values that are still available+ if (!is.null(join_keys)) {
|
|
| 670 | +922 | ! |
- selected <- if (!is.null(prev_choices) && any(prev_choices %in% choices)) {
+ key <- teal.data::join_keys(data())[dataset_name, dataset_name]+ |
+
| 923 | ++ |
+ } else {
|
|
| 671 | +924 | ! |
- prev_choices[match(choices[choices %in% prev_choices], prev_choices)]+ key <- NULL+ |
+
| 925 | ++ |
+ } |
|
| 672 | +926 | ! |
- } else if (+ sprintf( |
| 673 | +927 | ! |
- !is.null(prev_choices) &&+ "Dataset with %s unique key rows and %s variables", |
| 674 | +928 | ! |
- !any(prev_choices %in% choices) &&+ nrow(unique(`if`(length(key) > 0, df[, key, drop = FALSE], df))), |
| 675 | +929 | ! |
- isolate(prev_group_by_var()) == input$group_by_var+ ncol(df) |
| 676 | +930 |
- ) {
+ ) |
|
| 677 | +931 |
- # if not any previously selected value is available and the grouping variable is the same,+ }) |
|
| 678 | +932 |
- # then display NULL+ } |
|
| 679 | -! | +||
| 933 | +
- NULL+ |
||
| 680 | +934 |
- } else {
+ #' Renders the table for a single dataset in the left-hand side tabset panel |
|
| 681 | +935 |
- # if new grouping variable (i.e. not any previously selected value is available),+ #' |
|
| 682 | +936 |
- # then display all choices+ #' The table contains column names, column labels, |
|
| 683 | -! | +||
| 937 | +
- choices+ #' small summary about NA values and `sparkline` (if appropriate). |
||
| 684 | +938 |
- }+ #' |
|
| 685 | +939 | ++ |
+ #' @param dataset_name (`character`) the name of the dataset+ |
+
| 940 | ++ |
+ #' @param parent_dataname (`character`) the name of a parent `dataname` to filter out variables from+ |
+ |
| 941 | ++ |
+ #' @inheritParams render_tabset_panel_content+ |
+ |
| 942 | ++ |
+ #' @keywords internal+ |
+ |
| 943 | ++ |
+ render_tab_table <- function(dataset_name, parent_dataname, output, data, input, columns_names, plot_var) {
+ |
+ |
| 944 | +! | +
+ table_ui_id <- paste0("variable_browser_", dataset_name)
+ |
+ |
| 945 | |||
| 686 | +946 | ! |
- prev_group_by_var(input$group_by_var) # set current group_by_var+ output[[table_ui_id]] <- DT::renderDataTable({
|
| 687 | +947 | ! |
- validate(need(length(choices) < 100, "Please select group-by variable with fewer than 100 unique values"))+ df <- data()[[dataset_name]]+ |
+
| 948 | ++ | + | |
| 688 | +949 | ! |
- teal.widgets::optionalSelectInput(+ get_vars_df <- function(input, dataset_name, parent_name, data) {
|
| 689 | +950 | ! |
- ns("group_by_vals"),
+ data_cols <- colnames(df) |
| 690 | +951 | ! |
- label = "Filter levels",+ if (isTRUE(input$show_parent_vars)) {
|
| 691 | +952 | ! |
- choices = choices,+ data_cols |
| 692 | +953 | ! |
- selected = selected,+ } else if (dataset_name != parent_name && parent_name %in% names(data)) {
|
| 693 | +954 | ! |
- multiple = TRUE,+ setdiff(data_cols, colnames(data()[[parent_name]]))+ |
+
| 955 | ++ |
+ } else {
|
|
| 694 | +956 | ! |
- label_help = paste0("Dataset: ", dataname)
+ data_cols |
| 695 | +957 |
- )+ } |
|
| 696 | +958 |
- })+ } |
|
| 697 | +959 | ||
| 698 | +960 | ! |
- combination_cutoff_q <- reactive({
+ if (length(parent_dataname) > 0) {
|
| 699 | +961 | ! |
- req(common_code_q())+ df_vars <- get_vars_df(input, dataset_name, parent_dataname, data) |
| 700 | +962 | ! |
- teal.code::eval_code(+ df <- df[df_vars]+ |
+
| 963 | ++ |
+ }+ |
+ |
| 964 | ++ | + | |
| 701 | +965 | ! |
- common_code_q(),+ if (is.null(df) || ncol(df) == 0) {
|
| 702 | +966 | ! |
- quote(+ columns_names[[dataset_name]] <- character(0) |
| 703 | +967 | ! |
- combination_cutoff <- ANL %>%+ df_output <- data.frame( |
| 704 | +968 | ! |
- dplyr::mutate_all(is.na) %>%+ Type = character(0), |
| 705 | +969 | ! |
- dplyr::group_by_all() %>%+ Variable = character(0), |
| 706 | +970 | ! |
- dplyr::tally() %>%+ Label = character(0), |
| 707 | +971 | ! |
- dplyr::ungroup()+ Missings = character(0), |
| 708 | -+ | ||
| 972 | +! |
- )+ Sparklines = character(0),+ |
+ |
| 973 | +! | +
+ stringsAsFactors = FALSE |
|
| 709 | +974 |
) |
|
| 710 | +975 |
- })+ } else {
|
|
| 711 | +976 |
-
+ # extract data variable labels |
|
| 712 | +977 | ! |
- output$cutoff <- renderUI({
+ labels <- teal.data::col_labels(df)+ |
+
| 978 | ++ | + | |
| 713 | +979 | ! |
- x <- combination_cutoff_q()[["combination_cutoff"]]$n+ columns_names[[dataset_name]] <- names(labels) |
| 714 | +980 | ||
| 715 | +981 |
- # select 10-th from the top+ # calculate number of missing values |
|
| 716 | +982 | ! |
- n <- length(x)+ missings <- vapply( |
| 717 | +983 | ! |
- idx <- max(1, n - 10)+ df, |
| 718 | +984 | ! |
- prev_value <- isolate(input$combination_cutoff)+ var_missings_info, |
| 719 | +985 | ! |
- value <- if (is.null(prev_value) || prev_value > max(x) || prev_value < min(x)) {
+ FUN.VALUE = character(1), |
| 720 | +986 | ! |
- sort(x, partial = idx)[idx]+ USE.NAMES = FALSE |
| 721 | +987 |
- } else {
- |
- |
| 722 | -! | -
- prev_value+ ) |
|
| 723 | +988 |
- }+ |
|
| 724 | +989 |
-
+ # get icons proper for the data types |
|
| 725 | +990 | ! |
- teal.widgets::optionalSliderInputValMinMax(+ icons <- vapply(df, function(x) class(x)[1L], character(1L))+ |
+
| 991 | ++ | + | |
| 726 | +992 | ! |
- ns("combination_cutoff"),
+ join_keys <- teal.data::join_keys(data()) |
| 727 | +993 | ! |
- "Combination cut-off",+ if (!is.null(join_keys)) {
|
| 728 | +994 | ! |
- c(value, range(x))+ icons[intersect(join_keys[dataset_name, dataset_name], colnames(df))] <- "primary_key" |
| 729 | +995 |
- )+ } |
|
| 730 | -+ | ||
| 996 | +! |
- })+ icons <- variable_type_icons(icons) |
|
| 731 | +997 | ||
| 732 | +998 |
- # Prepare qenvs for output objects+ # generate sparklines |
|
| 733 | -+ | ||
| 999 | +! |
-
+ sparklines_html <- vapply( |
|
| 734 | +1000 | ! |
- summary_plot_q <- reactive({
+ df, |
| 735 | +1001 | ! |
- req(input$summary_type == "Summary") # needed to trigger show r code update on tab change+ create_sparklines, |
| 736 | +1002 | ! |
- teal::validate_has_data(data_r(), 1)+ FUN.VALUE = character(1),+ |
+
| 1003 | +! | +
+ USE.NAMES = FALSE |
|
| 737 | +1004 |
-
+ ) |
|
| 738 | -! | +||
| 1005 | +
- qenv <- common_code_q()+ |
||
| 739 | +1006 | ! |
- if (input$any_na) {
+ df_output <- data.frame( |
| 740 | +1007 | ! |
- new_col_name <- "**anyna**"+ Type = icons, |
| 741 | +1008 | ! |
- qenv <- teal.code::eval_code(+ Variable = names(labels), |
| 742 | +1009 | ! |
- qenv,+ Label = labels, |
| 743 | +1010 | ! |
- substitute(+ Missings = missings, |
| 744 | +1011 | ! |
- expr = ANL[[new_col_name]] <- ifelse(rowSums(is.na(ANL)) > 0, NA, FALSE),+ Sparklines = sparklines_html, |
| 745 | +1012 | ! |
- env = list(new_col_name = new_col_name)+ stringsAsFactors = FALSE |
| 746 | +1013 |
- )+ ) |
|
| 747 | +1014 |
- )+ } |
|
| 748 | +1015 |
- }+ |
|
| 749 | +1016 | - - | -|
| 750 | -! | -
- qenv <- teal.code::eval_code(+ # Select row 1 as default / fallback |
|
| 751 | +1017 | ! |
- qenv,+ selected_ix <- 1 |
| 752 | -! | +||
| 1018 | +
- substitute(+ # Define starting page index (base-0 index of the first item on page |
||
| 753 | -! | +||
| 1019 | +
- expr = analysis_vars <- setdiff(colnames(ANL), data_keys),+ # note: in many cases it's not the item itself |
||
| 754 | +1020 | ! |
- env = list(data_keys = data_keys())+ selected_page_ix <- 0 |
| 755 | +1021 |
- )+ |
|
| 756 | +1022 |
- ) %>%+ # Retrieve current selected variable if any |
|
| 757 | +1023 | ! |
- teal.code::eval_code(+ isolated_variable <- isolate(plot_var$variable[[dataset_name]]) |
| 758 | -! | +||
| 1024 | +
- substitute(+ |
||
| 759 | +1025 | ! |
- expr = summary_plot_obs <- data_frame_call[, analysis_vars] %>%+ if (!is.null(isolated_variable)) {
|
| 760 | +1026 | ! |
- dplyr::summarise_all(list(function(x) sum(is.na(x)))) %>%+ index <- which(columns_names[[dataset_name]] == isolated_variable)[1] |
| 761 | +1027 | ! |
- tidyr::pivot_longer(dplyr::everything(), names_to = "col", values_to = "n_na") %>%+ if (!is.null(index) && !is.na(index) && length(index) > 0) selected_ix <- index |
| 762 | -! | +||
| 1028 | +
- dplyr::mutate(n_not_na = nrow(ANL) - n_na) %>%+ } |
||
| 763 | -! | +||
| 1029 | +
- tidyr::pivot_longer(-col, names_to = "isna", values_to = "n") %>%+ |
||
| 764 | -! | +||
| 1030 | +
- dplyr::mutate(isna = isna == "n_na", n_pct = n / nrow(ANL) * 100),+ # Retrieve the index of the first item of the current page |
||
| 765 | -! | +||
| 1031 | +
- env = list(data_frame_call = if (!inherits(data_r(), "tbl_df")) {
+ # it works with varying number of entries on the page (10, 25, ...) |
||
| 766 | +1032 | ! |
- quote(tibble::as_tibble(ANL))+ table_id_sel <- paste0("variable_browser_", dataset_name, "_state")
|
| 767 | -+ | ||
| 1033 | +! |
- } else {
+ dt_state <- isolate(input[[table_id_sel]]) |
|
| 768 | +1034 | ! |
- quote(ANL)+ if (selected_ix != 1 && !is.null(dt_state)) {
|
| 769 | -+ | ||
| 1035 | +! |
- })+ selected_page_ix <- floor(selected_ix / dt_state$length) * dt_state$length |
|
| 770 | +1036 |
- )+ } |
|
| 771 | +1037 |
- ) %>%+ |
|
| 772 | -+ | ||
| 1038 | +! |
- # x axis ordering according to number of missing values and alphabet+ DT::datatable( |
|
| 773 | +1039 | ! |
- teal.code::eval_code(+ df_output, |
| 774 | +1040 | ! |
- quote(+ escape = FALSE, |
| 775 | +1041 | ! |
- expr = x_levels <- dplyr::filter(summary_plot_obs, isna) %>%+ rownames = FALSE, |
| 776 | +1042 | ! |
- dplyr::arrange(n_pct, dplyr::desc(col)) %>%+ selection = list(mode = "single", target = "row", selected = selected_ix), |
| 777 | +1043 | ! |
- dplyr::pull(col) %>%+ options = list( |
| 778 | +1044 | ! |
- create_cols_labels()+ fnDrawCallback = htmlwidgets::JS("function() { HTMLWidgets.staticRender(); }"),
+ |
+
| 1045 | +! | +
+ pageLength = input[[paste0(table_ui_id, "_rows")]],+ |
+ |
| 1046 | +! | +
+ displayStart = selected_page_ix |
|
| 779 | +1047 |
- )+ ) |
|
| 780 | +1048 |
- )+ ) |
|
| 781 | +1049 |
-
+ }) |
|
| 782 | +1050 |
- # always set "**anyna**" level as the last one+ } |
|
| 783 | -! | +||
| 1051 | +
- if (isolate(input$any_na)) {
+
|
||
| 784 | -! | +||
| 1052 | +
- qenv <- teal.code::eval_code(+ #' Creates observers updating the currently selected column |
||
| 785 | -! | +||
| 1053 | +
- qenv,+ #' |
||
| 786 | -! | +||
| 1054 | +
- quote(x_levels <- c(setdiff(x_levels, "**anyna**"), "**anyna**"))+ #' The created observers update the column currently selected in the left-hand side |
||
| 787 | +1055 |
- )+ #' tabset panel. |
|
| 788 | +1056 |
- }+ #' |
|
| 789 | +1057 |
-
+ #' @note |
|
| 790 | -! | +||
| 1058 | +
- dev_ggplot2_args <- teal.widgets::ggplot2_args(+ #' Creates an observer for each dataset (each tab in the tabset panel). |
||
| 791 | -! | +||
| 1059 | +
- labs = list(x = "Variable", y = "Missing observations"),+ #' |
||
| 792 | -! | +||
| 1060 | +
- theme = list(legend.position = "bottom", axis.text.x = quote(element_text(angle = 45, hjust = 1)))+ #' @inheritParams render_tabset_panel_content |
||
| 793 | +1061 |
- )+ #' @keywords internal |
|
| 794 | +1062 |
-
+ establish_updating_selection <- function(datanames, input, plot_var, columns_names) {
|
|
| 795 | +1063 | ! |
- all_ggplot2_args <- teal.widgets::resolve_ggplot2_args(+ lapply(datanames, function(dataset_name) {
|
| 796 | +1064 | ! |
- user_plot = ggplot2_args[["Summary Obs"]],+ table_ui_id <- paste0("variable_browser_", dataset_name)
|
| 797 | +1065 | ! |
- user_default = ggplot2_args$default,+ table_id_sel <- paste0(table_ui_id, "_rows_selected") |
| 798 | +1066 | ! |
- module_plot = dev_ggplot2_args- |
-
| 799 | -- |
- )+ observeEvent(input[[table_id_sel]], {
|
|
| 800 | -+ | ||
| 1067 | +! |
-
+ plot_var$data <- dataset_name |
|
| 801 | +1068 | ! |
- parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(+ plot_var$variable[[dataset_name]] <- columns_names[[dataset_name]][input[[table_id_sel]]] |
| 802 | -! | +||
| 1069 | +
- all_ggplot2_args,+ }) |
||
| 803 | -! | +||
| 1070 | +
- ggtheme = input$ggtheme+ }) |
||
| 804 | +1071 |
- )+ } |
|
| 805 | +1072 | ||
| 806 | -! | +||
| 1073 | +
- qenv <- teal.code::eval_code(+ get_bin_width <- function(x_vec, scaling_factor = 2) {
|
||
| 807 | +1074 | ! |
- qenv,+ x_vec <- x_vec[!is.na(x_vec)] |
| 808 | +1075 | ! |
- substitute(+ qntls <- stats::quantile(x_vec, probs = c(0.1, 0.25, 0.75, 0.9), type = 2) |
| 809 | +1076 | ! |
- summary_plot_top <- summary_plot_obs %>%+ iqr <- qntls[3] - qntls[2] |
| 810 | +1077 | ! |
- ggplot() ++ binwidth <- max(scaling_factor * iqr / length(x_vec) ^ (1 / 3), sqrt(qntls[4] - qntls[1])) # styler: off |
| 811 | +1078 | ! |
- aes(+ binwidth <- ifelse(binwidth == 0, 1, binwidth) |
| 812 | -! | +||
| 1079 | +
- x = factor(create_cols_labels(col), levels = x_levels),+ # to ensure at least two bins when variable span is very small |
||
| 813 | +1080 | ! |
- y = n_pct,+ x_span <- diff(range(x_vec)) |
| 814 | +1081 | ! |
- fill = isna+ if (isTRUE(x_span / binwidth >= 2)) binwidth else x_span / 2 |
| 815 | +1082 |
- ) ++ } |
|
| 816 | -! | +||
| 1083 | +
- geom_bar(position = "fill", stat = "identity") ++ |
||
| 817 | -! | +||
| 1084 | +
- scale_fill_manual(+ #' Removes the outlier observation from an array |
||
| 818 | -! | +||
| 1085 | +
- name = "",+ #' |
||
| 819 | -! | +||
| 1086 | +
- values = c("grey90", c(getOption("ggplot2.discrete.colour")[2], "#ff2951ff")[1]),
+ #' @param var (`numeric`) a numeric vector |
||
| 820 | -! | +||
| 1087 | +
- labels = c("Present", "Missing")
+ #' @param outlier_definition (`numeric`) if `0` then no outliers are removed, otherwise |
||
| 821 | +1088 |
- ) ++ #' outliers (those more than `outlier_definition*IQR below/above Q1/Q3`) are removed |
|
| 822 | -! | +||
| 1089 | +
- scale_y_continuous(+ #' @returns (`numeric`) vector without the outlier values |
||
| 823 | -! | +||
| 1090 | +
- labels = scales::percent_format(),+ #' @keywords internal |
||
| 824 | -! | +||
| 1091 | +
- breaks = seq(0, 1, by = 0.1),+ remove_outliers_from <- function(var, outlier_definition) {
|
||
| 825 | -! | +||
| 1092 | +3x |
- expand = c(0, 0)+ if (outlier_definition == 0) {
|
|
| 826 | -+ | ||
| 1093 | +1x |
- ) ++ return(var) |
|
| 827 | -! | +||
| 1094 | +
- geom_text(+ } |
||
| 828 | -! | +||
| 1095 | +2x |
- aes(label = ifelse(isna == TRUE, sprintf("%d [%.02f%%]", n, n_pct), ""), y = 1),
+ q1_q3 <- stats::quantile(var, probs = c(0.25, 0.75), type = 2, na.rm = TRUE) |
|
| 829 | -! | +||
| 1096 | +2x |
- hjust = 1,+ iqr <- q1_q3[2] - q1_q3[1] |
|
| 830 | -! | +||
| 1097 | +2x |
- color = "black"+ var[var >= q1_q3[1] - outlier_definition * iqr & var <= q1_q3[2] + outlier_definition * iqr] |
|
| 831 | +1098 |
- ) ++ } |
|
| 832 | -! | +||
| 1099 | +
- labs ++ |
||
| 833 | -! | +||
| 1100 | +
- ggthemes ++ |
||
| 834 | -! | +||
| 1101 | +
- themes ++ # sparklines ---- |
||
| 835 | -! | +||
| 1102 | +
- coord_flip(),+ |
||
| 836 | -! | +||
| 1103 | +
- env = list(+ #' S3 generic for `sparkline` widget HTML |
||
| 837 | -! | +||
| 1104 | +
- labs = parsed_ggplot2_args$labs,+ #' |
||
| 838 | -! | +||
| 1105 | +
- themes = parsed_ggplot2_args$theme,+ #' Generates the `sparkline` HTML code corresponding to the input array. |
||
| 839 | -! | +||
| 1106 | +
- ggthemes = parsed_ggplot2_args$ggtheme+ #' For numeric variables creates a box plot, for character and factors - bar plot. |
||
| 840 | +1107 |
- )+ #' Produces an empty string for variables of other types. |
|
| 841 | +1108 |
- )+ #' |
|
| 842 | +1109 |
- )+ #' @param arr vector of any type and length |
|
| 843 | +1110 |
-
+ #' @param width `numeric` the width of the `sparkline` widget (pixels) |
|
| 844 | -! | +||
| 1111 | +
- if (isTRUE(input$if_patients_plot)) {
+ #' @param bar_spacing `numeric` the spacing between the bars (in pixels) |
||
| 845 | -! | +||
| 1112 | +
- qenv <- teal.code::eval_code(+ #' @param bar_width `numeric` the width of the bars (in pixels) |
||
| 846 | -! | +||
| 1113 | +
- qenv,+ #' @param ... `list` additional options passed to bar plots of `jquery.sparkline`; |
||
| 847 | -! | +||
| 1114 | +
- substitute(+ #' see [`jquery.sparkline docs`](https://omnipotent.net/jquery.sparkline/#common) |
||
| 848 | -! | +||
| 1115 | +
- expr = parent_keys <- keys,+ #' |
||
| 849 | -! | +||
| 1116 | +
- env = list(keys = data_parent_keys())+ #' @return Character string containing HTML code of the `sparkline` HTML widget. |
||
| 850 | +1117 |
- )+ #' @keywords internal |
|
| 851 | +1118 |
- ) %>%+ create_sparklines <- function(arr, width = 150, ...) {
|
|
| 852 | +1119 | ! |
- teal.code::eval_code(quote(ndistinct_subjects <- dplyr::n_distinct(ANL[, parent_keys]))) %>%+ if (all(is.null(arr))) {
|
| 853 | +1120 | ! |
- teal.code::eval_code(+ return("")
|
| 854 | -! | +||
| 1121 | +
- quote(+ } |
||
| 855 | +1122 | ! |
- summary_plot_patients <- ANL[, c(parent_keys, analysis_vars)] %>%+ UseMethod("create_sparklines")
|
| 856 | -! | +||
| 1123 | +
- dplyr::group_by_at(parent_keys) %>%+ } |
||
| 857 | -! | -
- dplyr::summarise_all(anyNA) %>%+ | |
| 1124 | ++ | + | |
| 858 | -! | +||
| 1125 | +
- tidyr::pivot_longer(cols = !dplyr::all_of(parent_keys), names_to = "col", values_to = "anyna") %>%+ #' @rdname create_sparklines |
||
| 859 | -! | +||
| 1126 | +
- dplyr::group_by_at(c("col")) %>%
+ #' @keywords internal |
||
| 860 | -! | +||
| 1127 | +
- dplyr::summarise(count_na = sum(anyna)) %>%+ #' @export |
||
| 861 | -! | +||
| 1128 | +
- dplyr::mutate(count_not_na = ndistinct_subjects - count_na) %>%+ create_sparklines.logical <- function(arr, ...) {
|
||
| 862 | +1129 | ! |
- tidyr::pivot_longer(-c(col), names_to = "isna", values_to = "n") %>%+ create_sparklines(as.factor(arr)) |
| 863 | -! | +||
| 1130 | +
- dplyr::mutate(isna = isna == "count_na", n_pct = n / ndistinct_subjects * 100) %>%+ } |
||
| 864 | -! | +||
| 1131 | +
- dplyr::arrange_at(c("isna", "n"), .funs = dplyr::desc)
+
|
||
| 865 | +1132 |
- )+ #' @rdname create_sparklines |
|
| 866 | +1133 |
- )+ #' @keywords internal |
|
| 867 | +1134 |
-
+ #' @export |
|
| 868 | -! | +||
| 1135 | +
- dev_ggplot2_args <- teal.widgets::ggplot2_args(+ create_sparklines.numeric <- function(arr, width = 150, ...) {
|
||
| 869 | +1136 | ! |
- labs = list(x = "", y = "Missing patients"),+ if (any(is.infinite(arr))) {
|
| 870 | +1137 | ! |
- theme = list(+ return(as.character(tags$code("infinite values", class = "text-blue")))
|
| 871 | -! | +||
| 1138 | +
- legend.position = "bottom",+ } |
||
| 872 | +1139 | ! |
- axis.text.x = quote(element_text(angle = 45, hjust = 1)),+ if (length(arr) > 100000) {
|
| 873 | +1140 | ! |
- axis.text.y = quote(element_blank())- |
-
| 874 | -- |
- )+ return(as.character(tags$code("Too many rows (>100000)", class = "text-blue")))
|
|
| 875 | +1141 |
- )+ } |
|
| 876 | +1142 | ||
| 877 | +1143 | ! |
- all_ggplot2_args <- teal.widgets::resolve_ggplot2_args(+ arr <- arr[!is.na(arr)] |
| 878 | +1144 | ! |
- user_plot = ggplot2_args[["Summary Patients"]],+ sparkline::spk_chr(unname(arr), type = "box", width = width, ...) |
| 879 | -! | +||
| 1145 | +
- user_default = ggplot2_args$default,+ } |
||
| 880 | -! | +||
| 1146 | +
- module_plot = dev_ggplot2_args+ |
||
| 881 | +1147 |
- )+ #' @rdname create_sparklines |
|
| 882 | +1148 |
-
+ #' @keywords internal |
|
| 883 | -! | +||
| 1149 | +
- parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(+ #' @export |
||
| 884 | -! | +||
| 1150 | +
- all_ggplot2_args,+ create_sparklines.character <- function(arr, ...) {
|
||
| 885 | +1151 | ! |
- ggtheme = input$ggtheme+ return(create_sparklines(as.factor(arr))) |
| 886 | +1152 |
- )+ } |
|
| 887 | +1153 | ||
| 888 | -! | +||
| 1154 | +
- qenv <- teal.code::eval_code(+ |
||
| 889 | -! | +||
| 1155 | +
- qenv,+ #' @rdname create_sparklines |
||
| 890 | -! | +||
| 1156 | +
- substitute(+ #' @keywords internal |
||
| 891 | -! | +||
| 1157 | +
- summary_plot_bottom <- summary_plot_patients %>%+ #' @export |
||
| 892 | -! | +||
| 1158 | +
- ggplot() ++ create_sparklines.factor <- function(arr, width = 150, bar_spacing = 5, bar_width = 20, ...) {
|
||
| 893 | +1159 | ! |
- aes_(+ decreasing_order <- TRUE |
| 894 | -! | +||
| 1160 | +
- x = ~ factor(create_cols_labels(col), levels = x_levels),+ |
||
| 895 | +1161 | ! |
- y = ~n_pct,+ counts <- table(arr) |
| 896 | +1162 | ! |
- fill = ~isna- |
-
| 897 | -- |
- ) ++ if (length(counts) >= 100) {
|
|
| 898 | +1163 | ! |
- geom_bar(alpha = 1, stat = "identity", position = "fill") ++ return(as.character(tags$code("> 99 levels", class = "text-blue")))
|
| 899 | +1164 | ! |
- scale_y_continuous(+ } else if (length(counts) == 0) {
|
| 900 | +1165 | ! |
- labels = scales::percent_format(),+ return(as.character(tags$code("no levels", class = "text-blue")))
|
| 901 | +1166 | ! |
- breaks = seq(0, 1, by = 0.1),+ } else if (length(counts) == 1) {
|
| 902 | +1167 | ! |
- expand = c(0, 0)+ return(as.character(tags$code("one level", class = "text-blue")))
|
| 903 | +1168 |
- ) ++ } |
|
| 904 | -! | +||
| 1169 | +
- scale_fill_manual(+ |
||
| 905 | -! | +||
| 1170 | +
- name = "",+ # Summarize the occurences of different levels |
||
| 906 | -! | +||
| 1171 | +
- values = c("grey90", c(getOption("ggplot2.discrete.colour")[2], "#ff2951ff")[1]),
+ # and get the maximum and minimum number of occurences |
||
| 907 | -! | +||
| 1172 | +
- labels = c("Present", "Missing")
+ # This is needed for the sparkline to correctly display the bar plots |
||
| 908 | +1173 |
- ) ++ # Otherwise they are cropped |
|
| 909 | +1174 | ! |
- geom_text(+ counts <- sort(counts, decreasing = decreasing_order, method = "radix") |
| 910 | +1175 | ! |
- aes(label = ifelse(isna == TRUE, sprintf("%d [%.02f%%]", n, n_pct), ""), y = 1),
+ max_value <- if (decreasing_order) counts[1] else counts[length[counts]] |
| 911 | +1176 | ! |
- hjust = 1,+ max_value <- unname(max_value) |
| 912 | -! | +||
| 1177 | +
- color = "black"+ |
||
| 913 | -+ | ||
| 1178 | +! |
- ) ++ sparkline::spk_chr( |
|
| 914 | +1179 | ! |
- labs ++ unname(counts), |
| 915 | +1180 | ! |
- ggthemes ++ type = "bar", |
| 916 | +1181 | ! |
- themes ++ chartRangeMin = 0, |
| 917 | +1182 | ! |
- coord_flip(),+ chartRangeMax = max_value, |
| 918 | +1183 | ! |
- env = list(+ width = width, |
| 919 | +1184 | ! |
- labs = parsed_ggplot2_args$labs,+ barWidth = bar_width, |
| 920 | +1185 | ! |
- themes = parsed_ggplot2_args$theme,+ barSpacing = bar_spacing, |
| 921 | +1186 | ! |
- ggthemes = parsed_ggplot2_args$ggtheme+ tooltipFormatter = custom_sparkline_formatter(names(counts), as.vector(counts)) |
| 922 | +1187 |
- )+ ) |
|
| 923 | +1188 |
- )+ } |
|
| 924 | +1189 |
- )+ |
|
| 925 | +1190 |
- }+ #' @rdname create_sparklines |
|
| 926 | +1191 |
-
+ #' @keywords internal |
|
| 927 | -! | +||
| 1192 | +
- if (isTRUE(input$if_patients_plot)) {
+ #' @export |
||
| 928 | -! | +||
| 1193 | +
- within(qenv, {
+ create_sparklines.Date <- function(arr, width = 150, bar_spacing = 5, bar_width = 20, ...) {
|
||
| 929 | +1194 | ! |
- g1 <- ggplotGrob(summary_plot_top)+ arr_num <- as.numeric(arr) |
| 930 | +1195 | ! |
- g2 <- ggplotGrob(summary_plot_bottom)+ arr_num <- sort(arr_num, decreasing = FALSE, method = "radix") |
| 931 | +1196 | ! |
- summary_plot <- gridExtra::gtable_cbind(g1, g2, size = "first")+ binwidth <- get_bin_width(arr_num, 1) |
| 932 | +1197 | ! |
- summary_plot$heights <- grid::unit.pmax(g1$heights, g2$heights)- |
-
| 933 | -- |
- })+ bins <- floor(diff(range(arr_num)) / binwidth) + 1 |
|
| 934 | -+ | ||
| 1198 | +! |
- } else {
+ if (all(is.na(bins))) {
|
|
| 935 | +1199 | ! |
- within(qenv, {
+ return(as.character(tags$code("only NA", class = "text-blue")))
|
| 936 | +1200 | ! |
- g1 <- ggplotGrob(summary_plot_top)+ } else if (bins == 1) {
|
| 937 | +1201 | ! |
- summary_plot <- g1+ return(as.character(tags$code("one date", class = "text-blue")))
|
| 938 | +1202 |
- })+ } |
|
| 939 | -+ | ||
| 1203 | +! |
- }+ counts <- as.vector(unname(base::table(cut(arr_num, breaks = bins)))) |
|
| 940 | -+ | ||
| 1204 | +! |
- })+ max_value <- max(counts) |
|
| 941 | +1205 | ||
| 942 | +1206 | ! |
- combination_plot_q <- reactive({
+ start_bins <- as.integer(seq(1, length(arr_num), length.out = bins)) |
| 943 | +1207 | ! |
- req(input$summary_type == "Combinations", input$combination_cutoff, combination_cutoff_q())+ labels_start <- as.character(as.Date(arr_num[start_bins], origin = as.Date("1970-01-01")))
|
| 944 | +1208 | ! |
- teal::validate_has_data(data_r(), 1)+ labels <- paste("Start:", labels_start)
|
| 945 | +1209 | ||
| 946 | +1210 | ! |
- qenv <- teal.code::eval_code(+ sparkline::spk_chr( |
| 947 | +1211 | ! |
- combination_cutoff_q(),+ unname(counts), |
| 948 | +1212 | ! |
- substitute(+ type = "bar", |
| 949 | +1213 | ! |
- expr = data_combination_plot_cutoff <- combination_cutoff %>%+ chartRangeMin = 0, |
| 950 | +1214 | ! |
- dplyr::filter(n >= combination_cutoff_value) %>%+ chartRangeMax = max_value, |
| 951 | +1215 | ! |
- dplyr::mutate(id = rank(-n, ties.method = "first")) %>%+ width = width, |
| 952 | +1216 | ! |
- tidyr::pivot_longer(-c(n, id), names_to = "key", values_to = "value") %>%+ barWidth = bar_width, |
| 953 | +1217 | ! |
- dplyr::arrange(n),+ barSpacing = bar_spacing, |
| 954 | +1218 | ! |
- env = list(combination_cutoff_value = input$combination_cutoff)+ tooltipFormatter = custom_sparkline_formatter(labels, counts) |
| 955 | +1219 |
- )+ ) |
|
| 956 | +1220 |
- )+ } |
|
| 957 | +1221 | ||
| 958 | +1222 |
- # find keys in dataset not selected in the UI and remove them from dataset+ #' @rdname create_sparklines |
|
| 959 | -! | +||
| 1223 | +
- keys_not_selected <- setdiff(data_keys(), input$variables_select)+ #' @keywords internal |
||
| 960 | -! | +||
| 1224 | +
- if (length(keys_not_selected) > 0) {
+ #' @export |
||
| 961 | -! | +||
| 1225 | +
- qenv <- teal.code::eval_code(+ create_sparklines.POSIXct <- function(arr, width = 150, bar_spacing = 5, bar_width = 20, ...) {
|
||
| 962 | +1226 | ! |
- qenv,+ arr_num <- as.numeric(arr) |
| 963 | +1227 | ! |
- substitute(+ arr_num <- sort(arr_num, decreasing = FALSE, method = "radix") |
| 964 | +1228 | ! |
- expr = data_combination_plot_cutoff <- data_combination_plot_cutoff %>%+ binwidth <- get_bin_width(arr_num, 1) |
| 965 | +1229 | ! |
- dplyr::filter(!key %in% keys_not_selected),+ bins <- floor(diff(range(arr_num)) / binwidth) + 1 |
| 966 | +1230 | ! |
- env = list(keys_not_selected = keys_not_selected)+ if (all(is.na(bins))) {
|
| 967 | -+ | ||
| 1231 | +! |
- )+ return(as.character(tags$code("only NA", class = "text-blue")))
|
|
| 968 | -+ | ||
| 1232 | +! |
- )+ } else if (bins == 1) {
|
|
| 969 | -+ | ||
| 1233 | +! |
- }+ return(as.character(tags$code("one date-time", class = "text-blue")))
|
|
| 970 | +1234 |
-
+ } |
|
| 971 | +1235 | ! |
- qenv <- teal.code::eval_code(+ counts <- as.vector(unname(base::table(cut(arr_num, breaks = bins)))) |
| 972 | +1236 | ! |
- qenv,+ max_value <- max(counts) |
| 973 | -! | +||
| 1237 | +
- quote(+ |
||
| 974 | +1238 | ! |
- labels <- data_combination_plot_cutoff %>%+ start_bins <- as.integer(seq(1, length(arr_num), length.out = bins)) |
| 975 | +1239 | ! |
- dplyr::filter(key == key[[1]]) %>%+ labels_start <- as.character(format(as.POSIXct(arr_num[start_bins], origin = as.Date("1970-01-01")), "%Y-%m-%d"))
|
| 976 | +1240 | ! |
- getElement(name = 1)- |
-
| 977 | -- |
- )- |
- |
| 978 | -- |
- )+ labels <- paste("Start:", labels_start)
|
|
| 979 | +1241 | ||
| 980 | +1242 | ! |
- dev_ggplot2_args1 <- teal.widgets::ggplot2_args(+ sparkline::spk_chr( |
| 981 | +1243 | ! |
- labs = list(x = "", y = ""),+ unname(counts), |
| 982 | +1244 | ! |
- theme = list(+ type = "bar", |
| 983 | +1245 | ! |
- legend.position = "bottom",+ chartRangeMin = 0, |
| 984 | +1246 | ! |
- axis.text.x = quote(element_blank())- |
-
| 985 | -- |
- )- |
- |
| 986 | -- |
- )- |
- |
| 987 | -- |
-
+ chartRangeMax = max_value, |
|
| 988 | +1247 | ! |
- all_ggplot2_args1 <- teal.widgets::resolve_ggplot2_args(+ width = width, |
| 989 | +1248 | ! |
- user_plot = ggplot2_args[["Combinations Hist"]],+ barWidth = bar_width, |
| 990 | +1249 | ! |
- user_default = ggplot2_args$default,+ barSpacing = bar_spacing, |
| 991 | +1250 | ! |
- module_plot = dev_ggplot2_args1+ tooltipFormatter = custom_sparkline_formatter(labels, counts) |
| 992 | +1251 |
- )+ ) |
|
| 993 | +1252 |
-
+ } |
|
| 994 | -! | +||
| 1253 | +
- parsed_ggplot2_args1 <- teal.widgets::parse_ggplot2_args(+ |
||
| 995 | -! | +||
| 1254 | +
- all_ggplot2_args1,+ #' @rdname create_sparklines |
||
| 996 | -! | +||
| 1255 | +
- ggtheme = "void"+ #' @keywords internal |
||
| 997 | +1256 |
- )+ #' @export |
|
| 998 | +1257 |
-
+ create_sparklines.POSIXlt <- function(arr, width = 150, bar_spacing = 5, bar_width = 20, ...) {
|
|
| 999 | +1258 | ! |
- dev_ggplot2_args2 <- teal.widgets::ggplot2_args(+ arr_num <- as.numeric(arr) |
| 1000 | +1259 | ! |
- labs = list(x = "", y = ""),+ arr_num <- sort(arr_num, decreasing = FALSE, method = "radix") |
| 1001 | +1260 | ! |
- theme = list(+ binwidth <- get_bin_width(arr_num, 1) |
| 1002 | +1261 | ! |
- legend.position = "bottom",+ bins <- floor(diff(range(arr_num)) / binwidth) + 1 |
| 1003 | +1262 | ! |
- axis.text.x = quote(element_blank()),+ if (all(is.na(bins))) {
|
| 1004 | +1263 | ! |
- axis.ticks = quote(element_blank()),+ return(as.character(tags$code("only NA", class = "text-blue")))
|
| 1005 | +1264 | ! |
- panel.grid.major = quote(element_blank())- |
-
| 1006 | -- |
- )- |
- |
| 1007 | -- |
- )- |
- |
| 1008 | -- |
-
+ } else if (bins == 1) {
|
|
| 1009 | +1265 | ! |
- all_ggplot2_args2 <- teal.widgets::resolve_ggplot2_args(+ return(as.character(tags$code("one date-time", class = "text-blue")))
|
| 1010 | -! | +||
| 1266 | +
- user_plot = ggplot2_args[["Combinations Main"]],+ } |
||
| 1011 | +1267 | ! |
- user_default = ggplot2_args$default,+ counts <- as.vector(unname(base::table(cut(arr_num, breaks = bins)))) |
| 1012 | +1268 | ! |
- module_plot = dev_ggplot2_args2- |
-
| 1013 | -- |
- )+ max_value <- max(counts) |
|
| 1014 | +1269 | ||
| 1015 | +1270 | ! |
- parsed_ggplot2_args2 <- teal.widgets::parse_ggplot2_args(+ start_bins <- as.integer(seq(1, length(arr_num), length.out = bins)) |
| 1016 | +1271 | ! |
- all_ggplot2_args2,+ labels_start <- as.character(format(as.POSIXct(arr_num[start_bins], origin = as.Date("1970-01-01")), "%Y-%m-%d"))
|
| 1017 | +1272 | ! |
- ggtheme = input$ggtheme- |
-
| 1018 | -- |
- )+ labels <- paste("Start:", labels_start)
|
|
| 1019 | +1273 | ||
| 1020 | +1274 | ! |
- qenv <- teal.code::eval_code(+ sparkline::spk_chr( |
| 1021 | +1275 | ! |
- qenv,+ unname(counts), |
| 1022 | +1276 | ! |
- substitute(+ type = "bar", |
| 1023 | +1277 | ! |
- expr = {
+ chartRangeMin = 0, |
| 1024 | +1278 | ! |
- combination_plot_top <- data_combination_plot_cutoff %>%+ chartRangeMax = max_value, |
| 1025 | +1279 | ! |
- dplyr::select(id, n) %>%+ width = width, |
| 1026 | +1280 | ! |
- dplyr::distinct() %>%+ barWidth = bar_width, |
| 1027 | +1281 | ! |
- ggplot(aes(x = id, y = n)) ++ barSpacing = bar_spacing, |
| 1028 | +1282 | ! |
- geom_bar(stat = "identity", fill = c(getOption("ggplot2.discrete.colour")[2], "#ff2951ff")[1]) +
+ tooltipFormatter = custom_sparkline_formatter(labels, counts) |
| 1029 | -! | +||
| 1283 | +
- geom_text(+ ) |
||
| 1030 | -! | +||
| 1284 | +
- aes(label = n),+ } |
||
| 1031 | -! | +||
| 1285 | +
- position = position_dodge(width = 0.9),+ |
||
| 1032 | -! | +||
| 1286 | +
- vjust = -0.25+ #' @rdname create_sparklines |
||
| 1033 | +1287 |
- ) ++ #' @keywords internal |
|
| 1034 | -! | +||
| 1288 | +
- ylim(c(0, max(data_combination_plot_cutoff$n) * 1.5)) ++ #' @export |
||
| 1035 | -! | +||
| 1289 | +
- labs1 ++ create_sparklines.default <- function(arr, width = 150, ...) {
|
||
| 1036 | +1290 | ! |
- ggthemes1 ++ as.character(tags$code("unsupported variable type", class = "text-blue"))
|
| 1037 | -! | +||
| 1291 | +
- themes1+ } |
||
| 1038 | +1292 | ||
| 1039 | -! | -
- graph_number_rows <- length(unique(data_combination_plot_cutoff$id))- |
- |
| 1040 | -! | +||
| 1293 | +
- graph_number_cols <- nrow(data_combination_plot_cutoff) / graph_number_rows+ |
||
| 1041 | +1294 |
-
+ custom_sparkline_formatter <- function(labels, counts) {
|
|
| 1042 | +1295 | ! |
- combination_plot_bottom <- data_combination_plot_cutoff %>% ggplot() ++ htmlwidgets::JS( |
| 1043 | +1296 | ! |
- aes(x = create_cols_labels(key), y = id - 0.5, fill = value) ++ sprintf( |
| 1044 | +1297 | ! |
- geom_tile(alpha = 0.85, height = 0.95) ++ "function(sparkline, options, field) {
|
| 1045 | +1298 | ! |
- scale_fill_manual(+ return 'ID: ' + %s[field[0].offset] + '<br>' + 'Count: ' + %s[field[0].offset]; |
| 1046 | -! | +||
| 1299 | +
- name = "",+ }", |
||
| 1047 | +1300 | ! |
- values = c("grey90", c(getOption("ggplot2.discrete.colour")[2], "#ff2951ff")[1]),
+ jsonlite::toJSON(labels), |
| 1048 | +1301 | ! |
- labels = c("Present", "Missing")
+ jsonlite::toJSON(counts) |
| 1049 | +1302 |
- ) ++ ) |
|
| 1050 | -! | +||
| 1303 | +
- geom_hline(yintercept = seq_len(1 + graph_number_rows) - 1) ++ ) |
||
| 1051 | -! | +||
| 1304 | +
- geom_vline(xintercept = seq_len(1 + graph_number_cols) - 0.5, linetype = "dotted") ++ } |
||
| 1052 | -! | +
| 1 | +
- coord_flip() ++ #' `teal` module: Front page |
||
| 1053 | -! | +||
| 2 | +
- labs2 ++ #' |
||
| 1054 | -! | +||
| 3 | +
- ggthemes2 ++ #' Creates a simple front page for `teal` applications, displaying |
||
| 1055 | -! | +||
| 4 | +
- themes2+ #' introductory text, tables, additional `html` or `shiny` tags, and footnotes. |
||
| 1056 | +5 |
- },+ #' |
|
| 1057 | -! | +||
| 6 | +
- env = list(+ #' @inheritParams teal::module |
||
| 1058 | -! | +||
| 7 | +
- labs1 = parsed_ggplot2_args1$labs,+ #' @param header_text (`character` vector) text to be shown at the top of the module, for each |
||
| 1059 | -! | +||
| 8 | +
- themes1 = parsed_ggplot2_args1$theme,+ #' element, if named the name is shown first in bold as a header followed by the value. The first |
||
| 1060 | -! | +||
| 9 | +
- ggthemes1 = parsed_ggplot2_args1$ggtheme,+ #' element's header is displayed larger than the others. |
||
| 1061 | -! | +||
| 10 | +
- labs2 = parsed_ggplot2_args2$labs,+ #' @param tables (`named list` of `data.frame`s) tables to be shown in the module. |
||
| 1062 | -! | +||
| 11 | +
- themes2 = parsed_ggplot2_args2$theme,+ #' @param additional_tags (`shiny.tag.list` or `html`) additional `shiny` tags or `html` to be included after the table, |
||
| 1063 | -! | +||
| 12 | +
- ggthemes2 = parsed_ggplot2_args2$ggtheme+ #' for example to include an image, `tagList(tags$img(src = "image.png"))` or to include further `html`, |
||
| 1064 | +13 |
- )+ #' `HTML("html text here")`.
|
|
| 1065 | +14 |
- )+ #' @param footnotes (`character` vector) of text to be shown at the bottom of the module, for each |
|
| 1066 | +15 |
- )+ #' element, if named the name is shown first in bold, followed by the value. |
|
| 1067 | +16 |
-
+ #' @param show_metadata (`logical`) indicating whether the metadata of the datasets be available on the module. |
|
| 1068 | -! | +||
| 17 | +
- within(qenv, {
+ #' |
||
| 1069 | -! | +||
| 18 | +
- g1 <- ggplotGrob(combination_plot_top)+ #' @inherit shared_params return |
||
| 1070 | -! | +||
| 19 | +
- g2 <- ggplotGrob(combination_plot_bottom)+ #' |
||
| 1071 | +20 |
-
+ #' @examplesShinylive |
|
| 1072 | -! | +||
| 21 | +
- combination_plot <- gridExtra::gtable_rbind(g1, g2, size = "last")+ #' library(teal.modules.general) |
||
| 1073 | -! | +||
| 22 | +
- combination_plot$heights[7] <- grid::unit(0.2, "null") # rescale to get the bar chart smaller+ #' interactive <- function() TRUE |
||
| 1074 | +23 |
- })+ #' {{ next_example }}
|
|
| 1075 | +24 |
- })+ #' @examples |
|
| 1076 | +25 |
-
+ #' data <- teal_data() |
|
| 1077 | -! | +||
| 26 | +
- summary_table_q <- reactive({
+ #' data <- within(data, {
|
||
| 1078 | -! | +||
| 27 | +
- req(+ #' require(nestcolor) |
||
| 1079 | -! | +||
| 28 | +
- input$summary_type == "By Variable Levels", # needed to trigger show r code update on tab change+ #' ADSL <- teal.data::rADSL |
||
| 1080 | -! | +||
| 29 | +
- common_code_q()+ #' attr(ADSL, "metadata") <- list("Author" = "NEST team", "data_source" = "synthetic data")
|
||
| 1081 | +30 |
- )+ #' }) |
|
| 1082 | -! | +||
| 31 | +
- teal::validate_has_data(data_r(), 1)+ #' join_keys(data) <- default_cdisc_join_keys[names(data)] |
||
| 1083 | +32 |
-
+ #' |
|
| 1084 | +33 |
- # extract the ANL dataset for use in further validation+ #' table_1 <- data.frame(Info = c("A", "B"), Text = c("A", "B"))
|
|
| 1085 | -! | +||
| 34 | +
- anl <- common_code_q()[["ANL"]]+ #' table_2 <- data.frame(`Column 1` = c("C", "D"), `Column 2` = c(5.5, 6.6), `Column 3` = c("A", "B"))
|
||
| 1086 | +35 |
-
+ #' table_3 <- data.frame(Info = c("E", "F"), Text = c("G", "H"))
|
|
| 1087 | -! | +||
| 36 | +
- group_var <- input$group_by_var+ #' |
||
| 1088 | -! | +||
| 37 | +
- validate(+ #' table_input <- list( |
||
| 1089 | -! | +||
| 38 | +
- need(+ #' "Table 1" = table_1, |
||
| 1090 | -! | +||
| 39 | +
- is.null(group_var) ||+ #' "Table 2" = table_2, |
||
| 1091 | -! | +||
| 40 | +
- length(unique(anl[[group_var]])) < 100,+ #' "Table 3" = table_3 |
||
| 1092 | -! | +||
| 41 | +
- "Please select group-by variable with fewer than 100 unique values"+ #' ) |
||
| 1093 | +42 |
- )+ #' |
|
| 1094 | +43 |
- )+ #' app <- init( |
|
| 1095 | +44 |
-
+ #' data = data, |
|
| 1096 | -! | +||
| 45 | +
- group_vals <- input$group_by_vals+ #' modules = modules( |
||
| 1097 | -! | +||
| 46 | +
- variables_select <- input$variables_select+ #' tm_front_page( |
||
| 1098 | -! | +||
| 47 | +
- vars <- unique(variables_select, group_var)+ #' header_text = c( |
||
| 1099 | -! | +||
| 48 | +
- count_type <- input$count_type+ #' "Important information" = "It can go here.", |
||
| 1100 | +49 |
-
+ #' "Other information" = "Can go here." |
|
| 1101 | -! | +||
| 50 | +
- if (!is.null(selected_vars()) && length(selected_vars()) != ncol(anl)) {
+ #' ), |
||
| 1102 | -! | +||
| 51 | +
- variables <- selected_vars()+ #' tables = table_input, |
||
| 1103 | +52 |
- } else {
+ #' additional_tags = HTML("Additional HTML or shiny tags go here <br>"),
|
|
| 1104 | -! | +||
| 53 | +
- variables <- colnames(anl)+ #' footnotes = c("X" = "is the first footnote", "Y is the second footnote"),
|
||
| 1105 | +54 |
- }+ #' show_metadata = TRUE |
|
| 1106 | +55 |
-
+ #' ) |
|
| 1107 | -! | +||
| 56 | +
- summ_fn <- if (input$count_type == "counts") {
+ #' ), |
||
| 1108 | -! | +||
| 57 | +
- function(x) sum(is.na(x))+ #' header = tags$h1("Sample Application"),
|
||
| 1109 | +58 |
- } else {
+ #' footer = tags$p("Application footer"),
|
|
| 1110 | -! | +||
| 59 | +
- function(x) round(sum(is.na(x)) / length(x), 4)+ #' ) |
||
| 1111 | +60 |
- }+ #' |
|
| 1112 | +61 |
-
+ #' if (interactive()) {
|
|
| 1113 | -! | +||
| 62 | +
- qenv <- if (!is.null(group_var)) {
+ #' shinyApp(app$ui, app$server) |
||
| 1114 | -! | +||
| 63 | +
- teal.code::eval_code(+ #' } |
||
| 1115 | -! | +||
| 64 | +
- common_code_q(),+ #' |
||
| 1116 | -! | +||
| 65 | +
- substitute(+ #' @export |
||
| 1117 | -! | +||
| 66 | +
- expr = {
+ #' |
||
| 1118 | -! | +||
| 67 | +
- summary_data <- ANL %>%+ tm_front_page <- function(label = "Front page", |
||
| 1119 | -! | +||
| 68 | +
- dplyr::mutate(group_var_name := forcats::fct_na_value_to_level(as.factor(group_var_name), "NA")) %>%+ header_text = character(0), |
||
| 1120 | -! | +||
| 69 | +
- dplyr::group_by_at(group_var) %>%+ tables = list(), |
||
| 1121 | -! | +||
| 70 | +
- dplyr::filter(group_var_name %in% group_vals)+ additional_tags = tagList(), |
||
| 1122 | +71 |
-
+ footnotes = character(0),+ |
+ |
| 72 | ++ |
+ show_metadata = FALSE) {
|
|
| 1123 | +73 | ! |
- count_data <- dplyr::summarise(summary_data, n = dplyr::n())+ message("Initializing tm_front_page")
|
| 1124 | +74 | ||
| 1125 | -! | +||
| 75 | +
- summary_data <- dplyr::summarise_all(summary_data, summ_fn) %>%+ # Start of assertions |
||
| 1126 | +76 | ! |
- dplyr::mutate(group_var_name := paste0(group_var, ":", group_var_name, "(N=", count_data$n, ")")) %>%+ checkmate::assert_string(label) |
| 1127 | +77 | ! |
- tidyr::pivot_longer(!dplyr::all_of(group_var), names_to = "Variable", values_to = "out") %>%+ checkmate::assert_character(header_text, min.len = 0, any.missing = FALSE) |
| 1128 | +78 | ! |
- tidyr::pivot_wider(names_from = group_var, values_from = "out") %>%+ checkmate::assert_list(tables, types = "data.frame", names = "named", any.missing = FALSE) |
| 1129 | +79 | ! |
- dplyr::mutate(`Variable label` = create_cols_labels(Variable, just_label = TRUE), .after = Variable)- |
-
| 1130 | -- |
- },+ checkmate::assert_multi_class(additional_tags, classes = c("shiny.tag.list", "html"))
|
|
| 1131 | +80 | ! |
- env = list(+ checkmate::assert_character(footnotes, min.len = 0, any.missing = FALSE) |
| 1132 | +81 | ! |
- group_var = group_var, group_var_name = as.name(group_var), group_vals = group_vals, summ_fn = summ_fn+ checkmate::assert_flag(show_metadata) |
| 1133 | +82 |
- )+ # End of assertions |
|
| 1134 | +83 |
- )+ |
|
| 1135 | +84 |
- )+ # Make UI args |
|
| 1136 | -+ | ||
| 85 | +! |
- } else {
+ args <- as.list(environment()) |
|
| 1137 | -! | +||
| 86 | +
- teal.code::eval_code(+ |
||
| 1138 | +87 | ! |
- common_code_q(),+ ans <- module( |
| 1139 | +88 | ! |
- substitute(+ label = label, |
| 1140 | +89 | ! |
- expr = summary_data <- ANL %>%+ server = srv_front_page, |
| 1141 | +90 | ! |
- dplyr::summarise_all(summ_fn) %>%+ ui = ui_front_page, |
| 1142 | +91 | ! |
- tidyr::pivot_longer(dplyr::everything(),+ ui_args = args, |
| 1143 | +92 | ! |
- names_to = "Variable",+ server_args = list(tables = tables, show_metadata = show_metadata), |
| 1144 | +93 | ! |
- values_to = paste0("Missing (N=", nrow(ANL), ")")
+ datanames = if (show_metadata) "all" else NULL |
| 1145 | +94 |
- ) %>%+ ) |
|
| 1146 | +95 | ! |
- dplyr::mutate(`Variable label` = create_cols_labels(Variable), .after = Variable),+ attr(ans, "teal_bookmarkable") <- TRUE |
| 1147 | +96 | ! |
- env = list(summ_fn = summ_fn)+ ans |
| 1148 | +97 |
- )+ } |
|
| 1149 | +98 |
- )+ |
|
| 1150 | +99 |
- }+ # UI function for the front page module |
|
| 1151 | +100 |
-
+ ui_front_page <- function(id, ...) {
|
|
| 1152 | +101 | ! |
- within(qenv, table <- DT::datatable(summary_data))+ args <- list(...) |
| 1153 | -+ | ||
| 102 | +! |
- })+ ns <- NS(id) |
|
| 1154 | +103 | ||
| 1155 | +104 | ! |
- by_subject_plot_q <- reactive({
- |
-
| 1156 | -- |
- # needed to trigger show r code update on tab change+ tagList( |
|
| 1157 | +105 | ! |
- req(input$summary_type == "Grouped by Subject", common_code_q())- |
-
| 1158 | -- |
-
+ include_css_files("custom"),
|
|
| 1159 | +106 | ! |
- teal::validate_has_data(data_r(), 1)+ tags$div( |
| 1160 | -+ | ||
| 107 | +! |
-
+ id = "front_page_content", |
|
| 1161 | +108 | ! |
- dev_ggplot2_args <- teal.widgets::ggplot2_args(+ class = "ml-8", |
| 1162 | +109 | ! |
- labs = list(x = "", y = ""),+ tags$div( |
| 1163 | +110 | ! |
- theme = list(legend.position = "bottom", axis.text.x = quote(element_blank()))+ id = "front_page_headers", |
| 1164 | -+ | ||
| 111 | +! |
- )+ get_header_tags(args$header_text) |
|
| 1165 | +112 |
-
+ ), |
|
| 1166 | +113 | ! |
- all_ggplot2_args <- teal.widgets::resolve_ggplot2_args(+ tags$div( |
| 1167 | +114 | ! |
- user_plot = ggplot2_args[["By Subject"]],+ id = "front_page_tables", |
| 1168 | +115 | ! |
- user_default = ggplot2_args$default,+ class = "ml-4", |
| 1169 | +116 | ! |
- module_plot = dev_ggplot2_args- |
-
| 1170 | -- |
- )+ get_table_tags(args$tables, ns) |
|
| 1171 | +117 |
-
+ ), |
|
| 1172 | +118 | ! |
- parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(+ tags$div( |
| 1173 | +119 | ! |
- all_ggplot2_args,+ id = "front_page_custom_html", |
| 1174 | +120 | ! |
- ggtheme = input$ggtheme+ class = "my-4", |
| 1175 | -+ | ||
| 121 | +! |
- )+ args$additional_tags |
|
| 1176 | +122 |
-
+ ), |
|
| 1177 | +123 | ! |
- teal.code::eval_code(+ if (args$show_metadata) {
|
| 1178 | +124 | ! |
- common_code_q(),+ tags$div( |
| 1179 | +125 | ! |
- substitute(+ id = "front_page_metabutton", |
| 1180 | +126 | ! |
- expr = parent_keys <- keys,+ class = "m-4", |
| 1181 | +127 | ! |
- env = list(keys = data_parent_keys())+ actionButton(ns("metadata_button"), "Show metadata")
|
| 1182 | +128 |
) |
|
| 1183 | +129 |
- ) %>%+ }, |
|
| 1184 | +130 | ! |
- teal.code::eval_code(+ tags$footer( |
| 1185 | +131 | ! |
- substitute(+ class = ".small", |
| 1186 | +132 | ! |
- expr = analysis_vars <- setdiff(colnames(ANL), data_keys),+ get_footer_tags(args$footnotes) |
| 1187 | -! | +||
| 133 | +
- env = list(data_keys = data_keys())+ ) |
||
| 1188 | +134 |
- )+ ) |
|
| 1189 | +135 |
- ) %>%+ ) |
|
| 1190 | -! | +||
| 136 | +
- teal.code::eval_code(+ } |
||
| 1191 | -! | +||
| 137 | +
- quote({
+
|
||
| 1192 | -! | +||
| 138 | +
- summary_plot_patients <- ANL[, c(parent_keys, analysis_vars)] %>%+ # Server function for the front page module |
||
| 1193 | -! | +||
| 139 | +
- dplyr::group_by_at(parent_keys) %>%+ srv_front_page <- function(id, data, tables, show_metadata) {
|
||
| 1194 | +140 | ! |
- dplyr::mutate(id = dplyr::cur_group_id()) %>%+ checkmate::assert_class(data, "reactive") |
| 1195 | +141 | ! |
- dplyr::ungroup() %>%+ checkmate::assert_class(isolate(data()), "teal_data") |
| 1196 | +142 | ! |
- dplyr::group_by_at(c(parent_keys, "id")) %>%+ moduleServer(id, function(input, output, session) {
|
| 1197 | +143 | ! |
- dplyr::summarise_all(anyNA) %>%+ teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.general")+ |
+
| 144 | ++ | + | |
| 1198 | +145 | ! |
- dplyr::ungroup()+ ns <- session$ns |
| 1199 | +146 | ||
| 1200 | -+ | ||
| 147 | +! |
- # order subjects by decreasing number of missing and then by+ setBookmarkExclude("metadata_button")
|
|
| 1201 | +148 |
- # missingness pattern (defined using sha1)+ |
|
| 1202 | +149 | ! |
- order_subjects <- summary_plot_patients %>%+ lapply(seq_along(tables), function(idx) {
|
| 1203 | +150 | ! |
- dplyr::select(-"id", -dplyr::all_of(parent_keys)) %>%+ output[[paste0("table_", idx)]] <- renderTable(
|
| 1204 | +151 | ! |
- dplyr::transmute(+ tables[[idx]], |
| 1205 | +152 | ! |
- id = dplyr::row_number(),+ bordered = TRUE, |
| 1206 | +153 | ! |
- number_NA = apply(., 1, sum),+ caption = names(tables)[idx], |
| 1207 | +154 | ! |
- sha = apply(., 1, rlang::hash)+ caption.placement = "top" |
| 1208 | +155 |
- ) %>%- |
- |
| 1209 | -! | -
- dplyr::arrange(dplyr::desc(number_NA), sha) %>%- |
- |
| 1210 | -! | -
- getElement(name = "id")+ ) |
|
| 1211 | +156 |
-
+ }) |
|
| 1212 | +157 |
- # order columns by decreasing percent of missing values+ |
|
| 1213 | +158 | ! |
- ordered_columns <- summary_plot_patients %>%+ if (show_metadata) {
|
| 1214 | +159 | ! |
- dplyr::select(-"id", -dplyr::all_of(parent_keys)) %>%+ observeEvent( |
| 1215 | +160 | ! |
- dplyr::summarise(+ input$metadata_button, showModal( |
| 1216 | +161 | ! |
- column = create_cols_labels(colnames(.)),+ modalDialog( |
| 1217 | +162 | ! |
- na_count = apply(., MARGIN = 2, FUN = sum),+ title = "Metadata", |
| 1218 | +163 | ! |
- na_percent = na_count / nrow(.) * 100- |
-
| 1219 | -- |
- ) %>%+ dataTableOutput(ns("metadata_table")),
|
|
| 1220 | +164 | ! |
- dplyr::arrange(na_percent, dplyr::desc(column))- |
-
| 1221 | -- |
-
+ size = "l", |
|
| 1222 | +165 | ! |
- summary_plot_patients <- summary_plot_patients %>%+ easyClose = TRUE |
| 1223 | -! | +||
| 166 | +
- tidyr::gather("col", "isna", -"id", -dplyr::all_of(parent_keys)) %>%
+ ) |
||
| 1224 | -! | +||
| 167 | +
- dplyr::mutate(col = create_cols_labels(col))+ ) |
||
| 1225 | +168 |
- })+ ) |
|
| 1226 | +169 |
- ) %>%+ |
|
| 1227 | +170 | ! |
- teal.code::eval_code(+ metadata_data_frame <- reactive({
|
| 1228 | +171 | ! |
- substitute(+ datanames <- names(data()) |
| 1229 | +172 | ! |
- expr = {
+ convert_metadata_to_dataframe( |
| 1230 | +173 | ! |
- by_subject_plot <- ggplot(summary_plot_patients, aes(+ lapply(datanames, function(dataname) attr(data()[[dataname]], "metadata")), |
| 1231 | +174 | ! |
- x = factor(id, levels = order_subjects),+ datanames |
| 1232 | -! | +||
| 175 | +
- y = factor(col, levels = ordered_columns[["column"]]),+ ) |
||
| 1233 | -! | +||
| 176 | +
- fill = isna+ }) |
||
| 1234 | +177 |
- )) ++ |
|
| 1235 | +178 | ! |
- geom_raster() ++ output$metadata_table <- renderDataTable({
|
| 1236 | +179 | ! |
- annotate(+ validate(need(nrow(metadata_data_frame()) > 0, "The data has no associated metadata")) |
| 1237 | +180 | ! |
- "text",+ metadata_data_frame() |
| 1238 | -! | -
- x = length(order_subjects),- |
- |
| 1239 | -! | -
- y = seq_len(nrow(ordered_columns)),- |
- |
| 1240 | -! | +||
| 181 | +
- hjust = 1,+ }) |
||
| 1241 | -! | +||
| 182 | +
- label = sprintf("%d [%.02f%%]", ordered_columns[["na_count"]], ordered_columns[["na_percent"]])
+ } |
||
| 1242 | +183 |
- ) ++ }) |
|
| 1243 | -! | +||
| 184 | +
- scale_fill_manual(+ } |
||
| 1244 | -! | +||
| 185 | +
- name = "",+ |
||
| 1245 | -! | +||
| 186 | +
- values = c("grey90", c(getOption("ggplot2.discrete.colour")[2], "#ff2951ff")[1]),
+ ## utils functions |
||
| 1246 | -! | +||
| 187 | +
- labels = c("Present", "Missing (at least one)")
+
|
||
| 1247 | +188 |
- ) ++ get_header_tags <- function(header_text) {
|
|
| 1248 | +189 | ! |
- labs ++ if (length(header_text) == 0) {
|
| 1249 | +190 | ! |
- ggthemes ++ return(list()) |
| 1250 | -! | +||
| 191 | +
- themes+ } |
||
| 1251 | +192 |
- },+ |
|
| 1252 | +193 | ! |
- env = list(+ get_single_header_tags <- function(header_text, p_text, header_tag = tags$h4) {
|
| 1253 | +194 | ! |
- labs = parsed_ggplot2_args$labs,+ tagList( |
| 1254 | +195 | ! |
- themes = parsed_ggplot2_args$theme,+ tags$div( |
| 1255 | +196 | ! |
- ggthemes = parsed_ggplot2_args$ggtheme+ if (!is.null(header_text) && nchar(header_text) > 0) header_tag(header_text), |
| 1256 | -+ | ||
| 197 | +! |
- )+ tags$p(p_text) |
|
| 1257 | +198 |
- )+ ) |
|
| 1258 | +199 |
- )+ ) |
|
| 1259 | +200 |
- })+ } |
|
| 1260 | +201 | ||
| 1261 | -+ | ||
| 202 | +! |
- # Decorated outputs+ header_tags <- get_single_header_tags(names(header_text[1]), header_text[1], header_tag = tags$h3)+ |
+ |
| 203 | +! | +
+ c(header_tags, mapply(get_single_header_tags, utils::tail(names(header_text), -1), utils::tail(header_text, -1))) |
|
| 1262 | +204 |
-
+ } |
|
| 1263 | +205 |
- # Summary_plot_q+ |
|
| 1264 | -! | +||
| 206 | +
- decorated_summary_plot_q <- srv_decorate_teal_data(+ get_table_tags <- function(tables, ns) {
|
||
| 1265 | +207 | ! |
- id = "dec_summary_plot",+ if (length(tables) == 0) {
|
| 1266 | +208 | ! |
- data = summary_plot_q,+ return(list()) |
| 1267 | -! | +||
| 209 | +
- decorators = select_decorators(decorators, "summary_plot"),+ } |
||
| 1268 | +210 | ! |
- expr = {
+ table_tags <- c(lapply(seq_along(tables), function(idx) {
|
| 1269 | +211 | ! |
- grid::grid.newpage()+ list( |
| 1270 | +212 | ! |
- grid::grid.draw(summary_plot)- |
-
| 1271 | -- |
- }+ tableOutput(ns(paste0("table_", idx)))
|
|
| 1272 | +213 |
) |
|
| 1273 | +214 | - - | -|
| 1274 | -! | -
- decorated_combination_plot_q <- srv_decorate_teal_data(+ })) |
|
| 1275 | +215 | ! |
- id = "dec_combination_plot",+ return(table_tags) |
| 1276 | -! | +||
| 216 | +
- data = combination_plot_q,+ } |
||
| 1277 | -! | +||
| 217 | +
- decorators = select_decorators(decorators, "combination_plot"),+ |
||
| 1278 | -! | +||
| 218 | +
- expr = {
+ get_footer_tags <- function(footnotes) {
|
||
| 1279 | +219 | ! |
- grid::grid.newpage()+ if (length(footnotes) == 0) {
|
| 1280 | +220 | ! |
- grid::grid.draw(combination_plot)+ return(list()) |
| 1281 | +221 |
- }+ } |
|
| 1282 | -+ | ||
| 222 | +! |
- )+ bold_texts <- if (is.null(names(footnotes))) rep("", length(footnotes)) else names(footnotes)
|
|
| 1283 | -+ | ||
| 223 | +! |
-
+ footnote_tags <- mapply(function(bold_text, value) {
|
|
| 1284 | +224 | ! |
- decorated_summary_table_q <- srv_decorate_teal_data(+ list( |
| 1285 | +225 | ! |
- id = "dec_summary_table",+ tags$div( |
| 1286 | +226 | ! |
- data = summary_table_q,+ tags$b(bold_text), |
| 1287 | +227 | ! |
- decorators = select_decorators(decorators, "summary_table"),+ value, |
| 1288 | +228 | ! |
- expr = table+ tags$br() |
| 1289 | +229 |
- )+ ) |
|
| 1290 | +230 | - - | -|
| 1291 | -! | -
- decorated_by_subject_plot_q <- srv_decorate_teal_data(+ ) |
|
| 1292 | +231 | ! |
- id = "dec_by_subject_plot",+ }, bold_text = bold_texts, value = footnotes) |
| 1293 | -! | +||
| 232 | +
- data = by_subject_plot_q,+ } |
||
| 1294 | -! | +||
| 233 | +
- decorators = select_decorators(decorators, "by_subject_plot"),+ |
||
| 1295 | -! | +||
| 234 | +
- expr = print(by_subject_plot)+ # take a list of metadata, one item per dataset (raw_metadata each element from datasets$get_metadata()) |
||
| 1296 | +235 |
- )+ # and the corresponding datanames and output a data.frame with columns {Dataset, Name, Value}.
|
|
| 1297 | +236 |
-
+ # which are, the Dataset the metadata came from, the metadata's name and value |
|
| 1298 | +237 |
- # Plots & tables reactives+ convert_metadata_to_dataframe <- function(raw_metadata, datanames) {
|
|
| 1299 | -+ | ||
| 238 | +4x |
-
+ output <- mapply(function(metadata, dataname) {
|
|
| 1300 | -! | +||
| 239 | +6x |
- summary_plot_r <- reactive({
+ if (is.null(metadata)) {
|
|
| 1301 | -! | +||
| 240 | +2x |
- req(decorated_summary_plot_q())[["summary_plot"]]+ return(data.frame(Dataset = character(0), Name = character(0), Value = character(0))) |
|
| 1302 | +241 |
- })+ } |
|
| 1303 | -+ | ||
| 242 | +4x |
-
+ return(data.frame( |
|
| 1304 | -! | +||
| 243 | +4x |
- combination_plot_r <- reactive({
+ Dataset = dataname, |
|
| 1305 | -! | +||
| 244 | +4x |
- req(decorated_combination_plot_q())[["combination_plot"]]+ Name = names(metadata), |
|
| 1306 | -+ | ||
| 245 | +4x |
- })+ Value = unname(unlist(lapply(metadata, as.character))) |
|
| 1307 | +246 |
-
+ )) |
|
| 1308 | -! | +||
| 247 | +4x |
- summary_table_r <- reactive({
+ }, raw_metadata, datanames, SIMPLIFY = FALSE) |
|
| 1309 | -! | +||
| 248 | +4x |
- req(decorated_summary_table_q())+ do.call(rbind, output) |
|
| 1310 | +249 |
-
+ } |
|
| 1311 | -! | +
| 1 | +
- if (length(input$variables_select) == 0) {
+ #' `teal` module: Principal component analysis |
||
| 1312 | +2 |
- # so that zeroRecords message gets printed+ #' |
|
| 1313 | +3 |
- # using tibble as it supports weird column names, such as " "+ #' Module conducts principal component analysis (PCA) on a given dataset and offers different |
|
| 1314 | -! | +||
| 4 | +
- DT::datatable(+ #' ways of visualizing the outcomes, including elbow plot, circle plot, biplot, and eigenvector plot. |
||
| 1315 | -! | +||
| 5 | +
- tibble::tibble(` ` = logical(0)),+ #' Additionally, it enables dynamic customization of plot aesthetics, such as opacity, size, and |
||
| 1316 | -! | +||
| 6 | +
- options = list(language = list(zeroRecords = "No variable selected."), pageLength = input$levels_table_rows)+ #' font size, through UI inputs. |
||
| 1317 | +7 |
- )+ #' |
|
| 1318 | +8 |
- } else {
+ #' @inheritParams teal::module |
|
| 1319 | -! | +||
| 9 | +
- decorated_summary_table_q()[["table"]]+ #' @inheritParams shared_params |
||
| 1320 | +10 |
- }+ #' @param dat (`data_extract_spec` or `list` of multiple `data_extract_spec`) |
|
| 1321 | +11 |
- })+ #' specifying columns used to compute PCA. |
|
| 1322 | +12 |
-
+ #' @param font_size (`numeric`) optional, specifies font size. |
|
| 1323 | -! | +||
| 13 | +
- by_subject_plot_r <- reactive({
+ #' It controls the font size for plot titles, axis labels, and legends. |
||
| 1324 | -! | +||
| 14 | +
- req(decorated_by_subject_plot_q()[["by_subject_plot"]])+ #' - If vector of `length == 1` then the font sizes will have a fixed size. |
||
| 1325 | +15 |
- })+ #' - while vector of `value`, `min`, and `max` allows dynamic adjustment. |
|
| 1326 | +16 |
-
+ #' @param ggplot2_args `r roxygen_ggplot2_args_param("Elbow plot", "Circle plot", "Biplot", "Eigenvector plot")`
|
|
| 1327 | +17 |
- # Generate output+ #' @param decorators `r roxygen_decorators_param("tm_a_pca")`
|
|
| 1328 | -! | +||
| 18 | +
- pws1 <- teal.widgets::plot_with_settings_srv(+ #' |
||
| 1329 | -! | +||
| 19 | +
- id = "summary_plot",+ #' @inherit shared_params return |
||
| 1330 | -! | +||
| 20 | +
- plot_r = summary_plot_r,+ #' |
||
| 1331 | -! | +||
| 21 | +
- height = plot_height,+ #' @section Decorating `tm_a_pca`: |
||
| 1332 | -! | +||
| 22 | +
- width = plot_width+ #' |
||
| 1333 | +23 |
- )+ #' This module generates the following objects, which can be modified in place using decorators: |
|
| 1334 | +24 |
-
+ #' - `elbow_plot` (`ggplot2`) |
|
| 1335 | -! | +||
| 25 | +
- pws2 <- teal.widgets::plot_with_settings_srv(+ #' - `circle_plot` (`ggplot2`) |
||
| 1336 | -! | +||
| 26 | +
- id = "combination_plot",+ #' - `biplot` (`ggplot2`) |
||
| 1337 | -! | +||
| 27 | +
- plot_r = combination_plot_r,+ #' - `eigenvector_plot` (`ggplot2`) |
||
| 1338 | -! | +||
| 28 | +
- height = plot_height,+ #' |
||
| 1339 | -! | +||
| 29 | +
- width = plot_width+ #' Decorators can be applied to all outputs or only to specific objects using a |
||
| 1340 | +30 |
- )+ #' named list of `teal_transform_module` objects. |
|
| 1341 | +31 |
-
+ #' The `"default"` name is reserved for decorators that are applied to all outputs. |
|
| 1342 | -! | +||
| 32 | +
- output$levels_table <- DT::renderDataTable(summary_table_r())+ #' See code snippet below: |
||
| 1343 | +33 |
-
+ #' |
|
| 1344 | -! | +||
| 34 | +
- pws3 <- teal.widgets::plot_with_settings_srv(+ #' ``` |
||
| 1345 | -! | +||
| 35 | +
- id = "by_subject_plot",+ #' tm_a_pca( |
||
| 1346 | -! | +||
| 36 | +
- plot_r = by_subject_plot_r,+ #' ..., # arguments for module |
||
| 1347 | -! | +||
| 37 | +
- height = plot_height,+ #' decorators = list( |
||
| 1348 | -! | +||
| 38 | +
- width = plot_width+ #' default = list(teal_transform_module(...)), # applied to all outputs |
||
| 1349 | +39 |
- )+ #' elbow_plot = list(teal_transform_module(...)), # applied only to `elbow_plot` output |
|
| 1350 | +40 |
-
+ #' circle_plot = list(teal_transform_module(...)) # applied only to `circle_plot` output |
|
| 1351 | -! | +||
| 41 | +
- decorated_final_q <- reactive({
+ #' biplot = list(teal_transform_module(...)) # applied only to `biplot` output |
||
| 1352 | -! | +||
| 42 | +
- sum_type <- req(input$summary_type)+ #' eigenvector_plot = list(teal_transform_module(...)) # applied only to `eigenvector_plot` output |
||
| 1353 | -! | +||
| 43 | +
- if (sum_type == "Summary") {
+ #' ) |
||
| 1354 | -! | +||
| 44 | +
- decorated_summary_plot_q()+ #' ) |
||
| 1355 | -! | +||
| 45 | +
- } else if (sum_type == "Combinations") {
+ #' ``` |
||
| 1356 | -! | +||
| 46 | +
- decorated_combination_plot_q()+ #' |
||
| 1357 | -! | +||
| 47 | +
- } else if (sum_type == "By Variable Levels") {
+ #' For additional details and examples of decorators, refer to the vignette |
||
| 1358 | -! | +||
| 48 | +
- decorated_summary_table_q()+ #' `vignette("decorate-modules-output", package = "teal")` or the [`teal::teal_transform_module()`] documentation.
|
||
| 1359 | -! | +||
| 49 | +
- } else if (sum_type == "Grouped by Subject") {
+ #' |
||
| 1360 | -! | +||
| 50 | +
- decorated_by_subject_plot_q()+ #' @examplesShinylive |
||
| 1361 | +51 |
- }+ #' library(teal.modules.general) |
|
| 1362 | +52 |
- })+ #' interactive <- function() TRUE |
|
| 1363 | +53 |
-
+ #' {{ next_example }}
|
|
| 1364 | -! | +||
| 54 | +
- teal.widgets::verbatim_popup_srv(+ #' @examples |
||
| 1365 | -! | +||
| 55 | +
- id = "rcode",+ #' |
||
| 1366 | -! | +||
| 56 | +
- verbatim_content = reactive(teal.code::get_code(req(decorated_final_q()))),+ #' # general data example |
||
| 1367 | -! | +||
| 57 | +
- title = "Show R Code for Missing Data"+ #' data <- teal_data() |
||
| 1368 | +58 |
- )+ #' data <- within(data, {
|
|
| 1369 | +59 |
-
+ #' require(nestcolor) |
|
| 1370 | +60 |
- ### REPORTER+ #' USArrests <- USArrests |
|
| 1371 | -! | +||
| 61 | +
- if (with_reporter) {
+ #' }) |
||
| 1372 | -! | +||
| 62 | +
- card_fun <- function(comment, label) {
+ #' |
||
| 1373 | -! | +||
| 63 | +
- card <- teal::TealReportCard$new()+ #' app <- init( |
||
| 1374 | -! | +||
| 64 | +
- sum_type <- input$summary_type+ #' data = data, |
||
| 1375 | -! | +||
| 65 | +
- title <- if (sum_type == "By Variable Levels") paste0(sum_type, " Table") else paste0(sum_type, " Plot")+ #' modules = modules( |
||
| 1376 | -! | +||
| 66 | +
- title_dataname <- paste(title, dataname, sep = " - ")+ #' tm_a_pca( |
||
| 1377 | -! | +||
| 67 | +
- label <- if (label == "") {
+ #' "PCA", |
||
| 1378 | -! | +||
| 68 | +
- paste("Missing Data", sum_type, dataname, sep = " - ")
+ #' dat = data_extract_spec( |
||
| 1379 | +69 |
- } else {
+ #' dataname = "USArrests", |
|
| 1380 | -! | +||
| 70 | +
- label+ #' select = select_spec( |
||
| 1381 | +71 |
- }+ #' choices = variable_choices( |
|
| 1382 | -! | +||
| 72 | +
- card$set_name(label)+ #' data = data[["USArrests"]], c("Murder", "Assault", "UrbanPop", "Rape")
|
||
| 1383 | -! | +||
| 73 | +
- card$append_text(title_dataname, "header2")+ #' ), |
||
| 1384 | -! | +||
| 74 | +
- if (with_filter) card$append_fs(filter_panel_api$get_filter_state())+ #' selected = c("Murder", "Assault"),
|
||
| 1385 | -! | +||
| 75 | +
- if (sum_type == "Summary") {
+ #' multiple = TRUE |
||
| 1386 | -! | +||
| 76 | +
- card$append_text("Plot", "header3")
+ #' ), |
||
| 1387 | -! | +||
| 77 | +
- card$append_plot(summary_plot_r(), dim = pws1$dim())+ #' filter = NULL |
||
| 1388 | -! | +||
| 78 | +
- } else if (sum_type == "Combinations") {
+ #' ) |
||
| 1389 | -! | +||
| 79 | +
- card$append_text("Plot", "header3")
+ #' ) |
||
| 1390 | -! | +||
| 80 | +
- card$append_plot(combination_plot_r(), dim = pws2$dim())+ #' ) |
||
| 1391 | -! | +||
| 81 | +
- } else if (sum_type == "By Variable Levels") {
+ #' ) |
||
| 1392 | -! | +||
| 82 | +
- card$append_text("Table", "header3")
+ #' if (interactive()) {
|
||
| 1393 | -! | +||
| 83 | +
- card$append_table(summary_table_r[["summary_data"]])+ #' shinyApp(app$ui, app$server) |
||
| 1394 | -! | +||
| 84 | +
- } else if (sum_type == "Grouped by Subject") {
+ #' } |
||
| 1395 | -! | +||
| 85 | +
- card$append_text("Plot", "header3")
+ #' |
||
| 1396 | -! | +||
| 86 | +
- card$append_plot(by_subject_plot_r(), dim = pws3$dim())+ #' @examplesShinylive |
||
| 1397 | +87 |
- }+ #' library(teal.modules.general) |
|
| 1398 | -! | +||
| 88 | +
- if (!comment == "") {
- |
- ||
| 1399 | -! | -
- card$append_text("Comment", "header3")
- |
- |
| 1400 | -! | -
- card$append_text(comment)+ #' interactive <- function() TRUE |
|
| 1401 | +89 |
- }- |
- |
| 1402 | -! | -
- card$append_src(teal.code::get_code(req(decorated_final_q())))- |
- |
| 1403 | -! | -
- card+ #' {{ next_example }}
|
|
| 1404 | +90 |
- }- |
- |
| 1405 | -! | -
- teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
+ #' @examples |
|
| 1406 | +91 |
- }+ #' |
|
| 1407 | +92 |
- ###+ #' # CDISC data example |
|
| 1408 | +93 |
- })+ #' data <- teal_data() |
|
| 1409 | +94 |
- }+ #' data <- within(data, {
|
| 1 | +95 |
- #' `teal` module: Univariate and bivariate visualizations+ #' require(nestcolor) |
|
| 2 | +96 |
- #'+ #' ADSL <- teal.data::rADSL |
|
| 3 | +97 |
- #' Module enables the creation of univariate and bivariate plots,+ #' }) |
|
| 4 | +98 |
- #' facilitating the exploration of data distributions and relationships between two variables.+ #' join_keys(data) <- default_cdisc_join_keys[names(data)] |
|
| 5 | +99 |
#' |
|
| 6 | +100 |
- #' This is a general module to visualize 1 & 2 dimensional data.+ #' app <- init( |
|
| 7 | +101 |
- #'+ #' data = data, |
|
| 8 | +102 |
- #' @note+ #' modules = modules( |
|
| 9 | +103 |
- #' For more examples, please see the vignette "Using bivariate plot" via+ #' tm_a_pca( |
|
| 10 | +104 |
- #' `vignette("using-bivariate-plot", package = "teal.modules.general")`.
+ #' "PCA", |
|
| 11 | +105 |
- #'+ #' dat = data_extract_spec( |
|
| 12 | +106 |
- #' @inheritParams teal::module+ #' dataname = "ADSL", |
|
| 13 | +107 |
- #' @inheritParams shared_params+ #' select = select_spec( |
|
| 14 | +108 |
- #' @param x (`data_extract_spec` or `list` of multiple `data_extract_spec`)+ #' choices = variable_choices( |
|
| 15 | +109 |
- #' Variable names selected to plot along the x-axis by default.+ #' data = data[["ADSL"]], c("BMRKR1", "AGE", "EOSDY")
|
|
| 16 | +110 |
- #' Can be numeric, factor or character.+ #' ), |
|
| 17 | +111 |
- #' No empty selections are allowed.+ #' selected = c("BMRKR1", "AGE"),
|
|
| 18 | +112 |
- #' @param y (`data_extract_spec` or `list` of multiple `data_extract_spec`)+ #' multiple = TRUE |
|
| 19 | +113 |
- #' Variable names selected to plot along the y-axis by default.+ #' ), |
|
| 20 | +114 |
- #' Can be numeric, factor or character.+ #' filter = NULL |
|
| 21 | +115 |
- #' @param use_density (`logical`) optional, indicates whether to plot density (`TRUE`) or frequency (`FALSE`).+ #' ) |
|
| 22 | +116 |
- #' Defaults to frequency (`FALSE`).+ #' ) |
|
| 23 | +117 |
- #' @param row_facet (`data_extract_spec` or `list` of multiple `data_extract_spec`) optional,+ #' ) |
|
| 24 | +118 |
- #' specification of the data variable(s) to use for faceting rows.+ #' ) |
|
| 25 | +119 |
- #' @param col_facet (`data_extract_spec` or `list` of multiple `data_extract_spec`) optional,+ #' if (interactive()) {
|
|
| 26 | +120 |
- #' specification of the data variable(s) to use for faceting columns.+ #' shinyApp(app$ui, app$server) |
|
| 27 | +121 |
- #' @param facet (`logical`) optional, specifies whether the facet encodings `ui` elements are toggled+ #' } |
|
| 28 | +122 |
- #' on and shown to the user by default. Defaults to `TRUE` if either `row_facet` or `column_facet`+ #' |
|
| 29 | +123 |
- #' are supplied.+ #' @export |
|
| 30 | +124 |
- #' @param color_settings (`logical`) Whether coloring, filling and size should be applied+ #' |
|
| 31 | +125 |
- #' and `UI` tool offered to the user.+ tm_a_pca <- function(label = "Principal Component Analysis", |
|
| 32 | +126 |
- #' @param color (`data_extract_spec` or `list` of multiple `data_extract_spec`) optional,+ dat, |
|
| 33 | +127 |
- #' specification of the data variable(s) selected for the outline color inside the coloring settings.+ plot_height = c(600, 200, 2000), |
|
| 34 | +128 |
- #' It will be applied when `color_settings` is set to `TRUE`.+ plot_width = NULL, |
|
| 35 | +129 |
- #' @param fill (`data_extract_spec` or `list` of multiple `data_extract_spec`) optional,+ ggtheme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void"),
|
|
| 36 | +130 |
- #' specification of the data variable(s) selected for the fill color inside the coloring settings.+ ggplot2_args = teal.widgets::ggplot2_args(), |
|
| 37 | +131 |
- #' It will be applied when `color_settings` is set to `TRUE`.+ rotate_xaxis_labels = FALSE, |
|
| 38 | +132 |
- #' @param size (`data_extract_spec` or `list` of multiple `data_extract_spec`) optional,+ font_size = c(12, 8, 20), |
|
| 39 | +133 |
- #' specification of the data variable(s) selected for the size of `geom_point` plots inside the coloring settings.+ alpha = c(1, 0, 1), |
|
| 40 | +134 |
- #' It will be applied when `color_settings` is set to `TRUE`.+ size = c(2, 1, 8), |
|
| 41 | +135 |
- #' @param free_x_scales (`logical`) optional, whether X scaling shall be changeable.+ pre_output = NULL, |
|
| 42 | +136 |
- #' Does not allow scaling to be changed by default (`FALSE`).+ post_output = NULL, |
|
| 43 | +137 |
- #' @param free_y_scales (`logical`) optional, whether Y scaling shall be changeable.+ decorators = NULL) {
|
|
| 44 | -+ | ||
| 138 | +! |
- #' Does not allow scaling to be changed by default (`FALSE`).+ message("Initializing tm_a_pca")
|
|
| 45 | +139 |
- #' @param swap_axes (`logical`) optional, whether to swap X and Y axes. Defaults to `FALSE`.+ |
|
| 46 | +140 |
- #' @param decorators `r roxygen_decorators_param("tm_g_bivariate")`
+ # Normalize the parameters |
|
| 47 | -+ | ||
| 141 | +! |
- #'+ if (inherits(dat, "data_extract_spec")) dat <- list(dat) |
|
| 48 | -+ | ||
| 142 | +! |
- #' @inherit shared_params return+ if (inherits(ggplot2_args, "ggplot2_args")) ggplot2_args <- list(default = ggplot2_args) |
|
| 49 | +143 |
- #'+ |
|
| 50 | +144 |
- #' @section Decorating `tm_g_bivariate`:+ # Start of assertions |
|
| 51 | -+ | ||
| 145 | +! |
- #'+ checkmate::assert_string(label) |
|
| 52 | -+ | ||
| 146 | +! |
- #' This module generates the following objects, which can be modified in place using decorators:+ checkmate::assert_list(dat, types = "data_extract_spec") |
|
| 53 | +147 |
- #' - `plot` (`ggplot2`)+ |
|
| 54 | -+ | ||
| 148 | +! |
- #'+ checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE) |
|
| 55 | -+ | ||
| 149 | +! |
- #' For additional details and examples of decorators, refer to the vignette+ checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height") |
|
| 56 | -+ | ||
| 150 | +! |
- #' `vignette("decorate-modules-output", package = "teal")` or the [`teal::teal_transform_module()`] documentation.
+ checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE) |
|
| 57 | -+ | ||
| 151 | +! |
- #'+ checkmate::assert_numeric( |
|
| 58 | -+ | ||
| 152 | +! |
- #'+ plot_width[1], |
|
| 59 | -+ | ||
| 153 | +! |
- #' @examplesShinylive+ lower = plot_width[2], upper = plot_width[3], null.ok = TRUE, .var.name = "plot_width" |
|
| 60 | +154 |
- #' library(teal.modules.general)+ ) |
|
| 61 | +155 |
- #' interactive <- function() TRUE+ |
|
| 62 | -+ | ||
| 156 | +! |
- #' {{ next_example }}
+ ggtheme <- match.arg(ggtheme) |
|
| 63 | +157 |
- #' @examples+ |
|
| 64 | -+ | ||
| 158 | +! |
- #' # general data example+ plot_choices <- c("Elbow plot", "Circle plot", "Biplot", "Eigenvector plot")
|
|
| 65 | -+ | ||
| 159 | +! |
- #' data <- teal_data()+ checkmate::assert_list(ggplot2_args, types = "ggplot2_args") |
|
| 66 | -+ | ||
| 160 | +! |
- #' data <- within(data, {
+ checkmate::assert_subset(names(ggplot2_args), c("default", plot_choices))
|
|
| 67 | +161 |
- #' require(nestcolor)+ |
|
| 68 | -+ | ||
| 162 | +! |
- #' CO2 <- data.frame(CO2)+ checkmate::assert_flag(rotate_xaxis_labels) |
|
| 69 | +163 |
- #' })+ |
|
| 70 | -+ | ||
| 164 | +! |
- #'+ if (length(font_size) == 1) {
|
|
| 71 | -+ | ||
| 165 | +! |
- #' app <- init(+ checkmate::assert_numeric(font_size, any.missing = FALSE, finite = TRUE, lower = 8, upper = 20) |
|
| 72 | +166 |
- #' data = data,+ } else {
|
|
| 73 | -+ | ||
| 167 | +! |
- #' modules = tm_g_bivariate(+ checkmate::assert_numeric(font_size, len = 3, any.missing = FALSE, finite = TRUE, lower = 8, upper = 20) |
|
| 74 | -+ | ||
| 168 | +! |
- #' x = data_extract_spec(+ checkmate::assert_numeric(font_size[1], lower = font_size[2], upper = font_size[3], .var.name = "font_size") |
|
| 75 | +169 |
- #' dataname = "CO2",+ } |
|
| 76 | +170 |
- #' select = select_spec(+ |
|
| 77 | -+ | ||
| 171 | +! |
- #' label = "Select variable:",+ if (length(alpha) == 1) {
|
|
| 78 | -+ | ||
| 172 | +! |
- #' choices = variable_choices(data[["CO2"]]),+ checkmate::assert_numeric(alpha, any.missing = FALSE, finite = TRUE, lower = 0, upper = 1) |
|
| 79 | +173 |
- #' selected = "conc",+ } else {
|
|
| 80 | -+ | ||
| 174 | +! |
- #' fixed = FALSE+ checkmate::assert_numeric(alpha, len = 3, any.missing = FALSE, finite = TRUE, lower = 0, upper = 1) |
|
| 81 | -+ | ||
| 175 | +! |
- #' )+ checkmate::assert_numeric(alpha[1], lower = alpha[2], upper = alpha[3], .var.name = "alpha") |
|
| 82 | +176 |
- #' ),+ } |
|
| 83 | +177 |
- #' y = data_extract_spec(+ |
|
| 84 | -+ | ||
| 178 | +! |
- #' dataname = "CO2",+ if (length(size) == 1) {
|
|
| 85 | -+ | ||
| 179 | +! |
- #' select = select_spec(+ checkmate::assert_numeric(size, any.missing = FALSE, finite = TRUE, lower = 1, upper = 8) |
|
| 86 | +180 |
- #' label = "Select variable:",+ } else {
|
|
| 87 | -+ | ||
| 181 | +! |
- #' choices = variable_choices(data[["CO2"]]),+ checkmate::assert_numeric(size, len = 3, any.missing = FALSE, finite = TRUE, lower = 1, upper = 8) |
|
| 88 | -+ | ||
| 182 | +! |
- #' selected = "uptake",+ checkmate::assert_numeric(size[1], lower = size[2], upper = size[3], .var.name = "size") |
|
| 89 | +183 |
- #' multiple = FALSE,+ } |
|
| 90 | +184 |
- #' fixed = FALSE+ |
|
| 91 | -+ | ||
| 185 | +! |
- #' )+ checkmate::assert_multi_class(pre_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
|
|
| 92 | -+ | ||
| 186 | +! |
- #' ),+ checkmate::assert_multi_class(post_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
|
|
| 93 | +187 |
- #' row_facet = data_extract_spec(+ |
|
| 94 | -+ | ||
| 188 | +! |
- #' dataname = "CO2",+ available_decorators <- c("elbow_plot", "circle_plot", "biplot", "eigenvector_plot")
|
|
| 95 | -+ | ||
| 189 | +! |
- #' select = select_spec(+ decorators <- normalize_decorators(decorators) |
|
| 96 | -+ | ||
| 190 | +! |
- #' label = "Select variable:",+ assert_decorators(decorators, null.ok = TRUE, available_decorators) |
|
| 97 | +191 |
- #' choices = variable_choices(data[["CO2"]]),+ # End of assertions |
|
| 98 | +192 |
- #' selected = "Type",+ |
|
| 99 | +193 |
- #' fixed = FALSE+ # Make UI args |
|
| 100 | -+ | ||
| 194 | +! |
- #' )+ args <- as.list(environment()) |
|
| 101 | +195 |
- #' ),+ |
|
| 102 | -+ | ||
| 196 | +! |
- #' col_facet = data_extract_spec(+ data_extract_list <- list(dat = dat) |
|
| 103 | +197 |
- #' dataname = "CO2",+ |
|
| 104 | -+ | ||
| 198 | +! |
- #' select = select_spec(+ ans <- module( |
|
| 105 | -+ | ||
| 199 | +! |
- #' label = "Select variable:",+ label = label, |
|
| 106 | -+ | ||
| 200 | +! |
- #' choices = variable_choices(data[["CO2"]]),+ server = srv_a_pca, |
|
| 107 | -+ | ||
| 201 | +! |
- #' selected = "Treatment",+ ui = ui_a_pca, |
|
| 108 | -+ | ||
| 202 | +! |
- #' fixed = FALSE+ ui_args = args, |
|
| 109 | -+ | ||
| 203 | +! |
- #' )+ server_args = c( |
|
| 110 | -+ | ||
| 204 | +! |
- #' )+ data_extract_list, |
|
| 111 | -+ | ||
| 205 | +! |
- #' )+ list( |
|
| 112 | -+ | ||
| 206 | +! |
- #' )+ plot_height = plot_height, |
|
| 113 | -+ | ||
| 207 | +! |
- #' if (interactive()) {
+ plot_width = plot_width, |
|
| 114 | -+ | ||
| 208 | +! |
- #' shinyApp(app$ui, app$server)+ ggplot2_args = ggplot2_args, |
|
| 115 | -+ | ||
| 209 | +! |
- #' }+ decorators = decorators |
|
| 116 | +210 |
- #'+ ) |
|
| 117 | +211 |
- #' @examplesShinylive+ ), |
|
| 118 | -+ | ||
| 212 | +! |
- #' library(teal.modules.general)+ datanames = teal.transform::get_extract_datanames(data_extract_list) |
|
| 119 | +213 |
- #' interactive <- function() TRUE+ ) |
|
| 120 | -+ | ||
| 214 | +! |
- #' {{ next_example }}
+ attr(ans, "teal_bookmarkable") <- FALSE |
|
| 121 | -+ | ||
| 215 | +! |
- #' @examples+ ans |
|
| 122 | +216 |
- #' # CDISC data example+ } |
|
| 123 | +217 |
- #' data <- teal_data()+ |
|
| 124 | +218 |
- #' data <- within(data, {
+ # UI function for the PCA module |
|
| 125 | +219 |
- #' require(nestcolor)+ ui_a_pca <- function(id, ...) {
|
|
| 126 | -+ | ||
| 220 | +! |
- #' ADSL <- rADSL+ ns <- NS(id) |
|
| 127 | -+ | ||
| 221 | +! |
- #' })+ args <- list(...) |
|
| 128 | -+ | ||
| 222 | +! |
- #' join_keys(data) <- default_cdisc_join_keys[names(data)]+ is_single_dataset_value <- teal.transform::is_single_dataset(args$dat) |
|
| 129 | +223 |
- #'+ |
|
| 130 | -+ | ||
| 224 | +! |
- #' app <- init(+ color_selector <- args$dat |
|
| 131 | -+ | ||
| 225 | +! |
- #' data = data,+ for (i in seq_along(color_selector)) {
|
|
| 132 | -+ | ||
| 226 | +! |
- #' modules = tm_g_bivariate(+ color_selector[[i]]$select$multiple <- FALSE |
|
| 133 | -+ | ||
| 227 | +! |
- #' x = data_extract_spec(+ color_selector[[i]]$select$always_selected <- NULL |
|
| 134 | -+ | ||
| 228 | +! |
- #' dataname = "ADSL",+ color_selector[[i]]$select$selected <- NULL |
|
| 135 | +229 |
- #' select = select_spec(+ } |
|
| 136 | +230 |
- #' label = "Select variable:",+ |
|
| 137 | -+ | ||
| 231 | +! |
- #' choices = variable_choices(data[["ADSL"]]),+ tagList( |
|
| 138 | -+ | ||
| 232 | +! |
- #' selected = "AGE",+ include_css_files("custom"),
|
|
| 139 | -+ | ||
| 233 | +! |
- #' fixed = FALSE+ teal.widgets::standard_layout( |
|
| 140 | -+ | ||
| 234 | +! |
- #' )+ output = teal.widgets::white_small_well( |
|
| 141 | -+ | ||
| 235 | +! |
- #' ),+ uiOutput(ns("all_plots"))
|
|
| 142 | +236 |
- #' y = data_extract_spec(+ ), |
|
| 143 | -+ | ||
| 237 | +! |
- #' dataname = "ADSL",+ encoding = tags$div( |
|
| 144 | +238 |
- #' select = select_spec(+ ### Reporter |
|
| 145 | -+ | ||
| 239 | +! |
- #' label = "Select variable:",+ teal.reporter::simple_reporter_ui(ns("simple_reporter")),
|
|
| 146 | +240 |
- #' choices = variable_choices(data[["ADSL"]]),+ ### |
|
| 147 | -+ | ||
| 241 | +! |
- #' selected = "SEX",+ tags$label("Encodings", class = "text-primary"),
|
|
| 148 | -+ | ||
| 242 | +! |
- #' multiple = FALSE,+ teal.transform::datanames_input(args["dat"]), |
|
| 149 | -+ | ||
| 243 | +! |
- #' fixed = FALSE+ teal.transform::data_extract_ui( |
|
| 150 | -+ | ||
| 244 | +! |
- #' )+ id = ns("dat"),
|
|
| 151 | -+ | ||
| 245 | +! |
- #' ),+ label = "Data selection", |
|
| 152 | -+ | ||
| 246 | +! |
- #' row_facet = data_extract_spec(+ data_extract_spec = args$dat, |
|
| 153 | -+ | ||
| 247 | +! |
- #' dataname = "ADSL",+ is_single_dataset = is_single_dataset_value |
|
| 154 | +248 |
- #' select = select_spec(+ ), |
|
| 155 | -+ | ||
| 249 | +! |
- #' label = "Select variable:",+ teal.widgets::panel_group( |
|
| 156 | -+ | ||
| 250 | +! |
- #' choices = variable_choices(data[["ADSL"]]),+ teal.widgets::panel_item( |
|
| 157 | -+ | ||
| 251 | +! |
- #' selected = "ARM",+ title = "Display", |
|
| 158 | -+ | ||
| 252 | +! |
- #' fixed = FALSE+ collapsed = FALSE, |
|
| 159 | -+ | ||
| 253 | +! |
- #' )+ checkboxGroupInput( |
|
| 160 | -+ | ||
| 254 | +! |
- #' ),+ ns("tables_display"),
|
|
| 161 | -+ | ||
| 255 | +! |
- #' col_facet = data_extract_spec(+ "Tables display", |
|
| 162 | -+ | ||
| 256 | +! |
- #' dataname = "ADSL",+ choices = c("PC importance" = "importance", "Eigenvectors" = "eigenvector"),
|
|
| 163 | -+ | ||
| 257 | +! |
- #' select = select_spec(+ selected = c("importance", "eigenvector")
|
|
| 164 | +258 |
- #' label = "Select variable:",+ ), |
|
| 165 | -+ | ||
| 259 | +! |
- #' choices = variable_choices(data[["ADSL"]]),+ radioButtons( |
|
| 166 | -+ | ||
| 260 | +! |
- #' selected = "COUNTRY",+ ns("plot_type"),
|
|
| 167 | -+ | ||
| 261 | +! |
- #' fixed = FALSE+ label = "Plot type", |
|
| 168 | -+ | ||
| 262 | +! |
- #' )+ choices = args$plot_choices, |
|
| 169 | -+ | ||
| 263 | +! |
- #' )+ selected = args$plot_choices[1] |
|
| 170 | +264 |
- #' )+ ), |
|
| 171 | -+ | ||
| 265 | +! |
- #' )+ conditionalPanel( |
|
| 172 | -+ | ||
| 266 | +! |
- #' if (interactive()) {
+ condition = sprintf("input['%s'] == 'Elbow plot'", ns("plot_type")),
|
|
| 173 | -+ | ||
| 267 | +! |
- #' shinyApp(app$ui, app$server)+ ui_decorate_teal_data( |
|
| 174 | -+ | ||
| 268 | +! |
- #' }+ ns("d_elbow_plot"),
|
|
| 175 | -+ | ||
| 269 | +! |
- #'+ decorators = select_decorators(args$decorators, "elbow_plot") |
|
| 176 | +270 |
- #' @export+ ) |
|
| 177 | +271 |
- #'+ ), |
|
| 178 | -+ | ||
| 272 | +! |
- tm_g_bivariate <- function(label = "Bivariate Plots",+ conditionalPanel( |
|
| 179 | -+ | ||
| 273 | +! |
- x,+ condition = sprintf("input['%s'] == 'Circle plot'", ns("plot_type")),
|
|
| 180 | -+ | ||
| 274 | +! |
- y,+ ui_decorate_teal_data( |
|
| 181 | -+ | ||
| 275 | +! |
- row_facet = NULL,+ ns("d_circle_plot"),
|
|
| 182 | -+ | ||
| 276 | +! |
- col_facet = NULL,+ decorators = select_decorators(args$decorators, "circle_plot") |
|
| 183 | +277 |
- facet = !is.null(row_facet) || !is.null(col_facet),+ ) |
|
| 184 | +278 |
- color = NULL,+ ), |
|
| 185 | -+ | ||
| 279 | +! |
- fill = NULL,+ conditionalPanel( |
|
| 186 | -+ | ||
| 280 | +! |
- size = NULL,+ condition = sprintf("input['%s'] == 'Biplot'", ns("plot_type")),
|
|
| 187 | -+ | ||
| 281 | +! |
- use_density = FALSE,+ ui_decorate_teal_data( |
|
| 188 | -+ | ||
| 282 | +! |
- color_settings = FALSE,+ ns("d_biplot"),
|
|
| 189 | -+ | ||
| 283 | +! |
- free_x_scales = FALSE,+ decorators = select_decorators(args$decorators, "biplot") |
|
| 190 | +284 |
- free_y_scales = FALSE,+ ) |
|
| 191 | +285 |
- plot_height = c(600, 200, 2000),+ ), |
|
| 192 | -+ | ||
| 286 | +! |
- plot_width = NULL,+ conditionalPanel( |
|
| 193 | -+ | ||
| 287 | +! |
- rotate_xaxis_labels = FALSE,+ condition = sprintf("input['%s'] == 'Eigenvector plot'", ns("plot_type")),
|
|
| 194 | -+ | ||
| 288 | +! |
- swap_axes = FALSE,+ ui_decorate_teal_data( |
|
| 195 | -+ | ||
| 289 | +! |
- ggtheme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void"),
+ ns("d_eigenvector_plot"),
|
|
| 196 | -+ | ||
| 290 | +! |
- ggplot2_args = teal.widgets::ggplot2_args(),+ decorators = select_decorators(args$decorators, "eigenvector_plot") |
|
| 197 | +291 |
- pre_output = NULL,+ ) |
|
| 198 | +292 |
- post_output = NULL,+ ) |
|
| 199 | +293 |
- decorators = NULL) {
+ ), |
|
| 200 | -18x | +||
| 294 | +! |
- message("Initializing tm_g_bivariate")
+ teal.widgets::panel_item( |
|
| 201 | -+ | ||
| 295 | +! |
-
+ title = "Pre-processing", |
|
| 202 | -+ | ||
| 296 | +! |
- # Normalize the parameters+ radioButtons( |
|
| 203 | -14x | +||
| 297 | +! |
- if (inherits(x, "data_extract_spec")) x <- list(x)+ ns("standardization"), "Standardization",
|
|
| 204 | -13x | +||
| 298 | +! |
- if (inherits(y, "data_extract_spec")) y <- list(y)+ choices = c("None" = "none", "Center" = "center", "Center & Scale" = "center_scale"),
|
|
| 205 | -1x | +||
| 299 | +! |
- if (inherits(row_facet, "data_extract_spec")) row_facet <- list(row_facet)+ selected = "center_scale" |
|
| 206 | -1x | +||
| 300 | +
- if (inherits(col_facet, "data_extract_spec")) col_facet <- list(col_facet)+ ), |
||
| 207 | -1x | +||
| 301 | +! |
- if (inherits(color, "data_extract_spec")) color <- list(color)+ radioButtons( |
|
| 208 | -1x | +||
| 302 | +! |
- if (inherits(fill, "data_extract_spec")) fill <- list(fill)+ ns("na_action"), "NA action",
|
|
| 209 | -1x | +||
| 303 | +! |
- if (inherits(size, "data_extract_spec")) size <- list(size)+ choices = c("None" = "none", "Drop" = "drop"),
|
|
| 210 | -+ | ||
| 304 | +! |
-
+ selected = "none" |
|
| 211 | +305 |
- # Start of assertions+ ) |
|
| 212 | -18x | +||
| 306 | +
- checkmate::assert_string(label)+ ), |
||
| 213 | -+ | ||
| 307 | +! |
-
+ teal.widgets::panel_item( |
|
| 214 | -18x | +||
| 308 | +! |
- checkmate::assert_list(x, types = "data_extract_spec")+ title = "Selected plot specific settings", |
|
| 215 | -18x | +||
| 309 | +! |
- assert_single_selection(x)+ collapsed = FALSE, |
|
| 216 | -+ | ||
| 310 | +! |
-
+ uiOutput(ns("plot_settings")),
|
|
| 217 | -16x | +||
| 311 | +! |
- checkmate::assert_list(y, types = "data_extract_spec")+ conditionalPanel( |
|
| 218 | -16x | +||
| 312 | +! |
- assert_single_selection(y)+ condition = sprintf("input['%s'] == 'Biplot'", ns("plot_type")),
|
|
| 219 | -+ | ||
| 313 | +! |
-
+ list( |
|
| 220 | -14x | +||
| 314 | +! |
- checkmate::assert_list(row_facet, types = "data_extract_spec", null.ok = TRUE)+ teal.transform::data_extract_ui( |
|
| 221 | -14x | +||
| 315 | +! |
- assert_single_selection(row_facet)+ id = ns("response"),
|
|
| 222 | -+ | ||
| 316 | +! |
-
+ label = "Color by", |
|
| 223 | -14x | +||
| 317 | +! |
- checkmate::assert_list(col_facet, types = "data_extract_spec", null.ok = TRUE)+ data_extract_spec = color_selector, |
|
| 224 | -14x | +||
| 318 | +! |
- assert_single_selection(col_facet)+ is_single_dataset = is_single_dataset_value |
|
| 225 | +319 |
-
+ ), |
|
| 226 | -14x | +||
| 320 | +! |
- checkmate::assert_flag(facet)+ teal.widgets::optionalSliderInputValMinMax(ns("alpha"), "Opacity:", args$alpha, ticks = FALSE),
|
|
| 227 | -+ | ||
| 321 | +! |
-
+ teal.widgets::optionalSliderInputValMinMax(ns("size"), "Points size:", args$size, ticks = FALSE)
|
|
| 228 | -14x | +||
| 322 | +
- checkmate::assert_list(color, types = "data_extract_spec", null.ok = TRUE)+ ) |
||
| 229 | -14x | +||
| 323 | +
- assert_single_selection(color)+ ) |
||
| 230 | +324 |
-
+ ), |
|
| 231 | -14x | +||
| 325 | +! |
- checkmate::assert_list(fill, types = "data_extract_spec", null.ok = TRUE)+ teal.widgets::panel_item( |
|
| 232 | -14x | +||
| 326 | +! |
- assert_single_selection(fill)+ title = "Plot settings", |
|
| 233 | -+ | ||
| 327 | +! |
-
+ collapsed = TRUE, |
|
| 234 | -14x | +||
| 328 | +! |
- checkmate::assert_list(size, types = "data_extract_spec", null.ok = TRUE)+ conditionalPanel( |
|
| 235 | -14x | +||
| 329 | +! |
- assert_single_selection(size)+ condition = sprintf( |
|
| 236 | -+ | ||
| 330 | +! |
-
+ "input['%s'] == 'Elbow plot' || input['%s'] == 'Eigenvector plot'", |
|
| 237 | -14x | +||
| 331 | +! |
- checkmate::assert_flag(use_density)+ ns("plot_type"),
|
|
| 238 | -+ | ||
| 332 | +! |
-
+ ns("plot_type")
|
|
| 239 | +333 |
- # Determines color, fill & size if they are not explicitly set+ ), |
|
| 240 | -14x | +||
| 334 | +! |
- checkmate::assert_flag(color_settings)+ list(checkboxInput(ns("rotate_xaxis_labels"), "Rotate X axis labels", value = args$rotate_xaxis_labels))
|
|
| 241 | -14x | +||
| 335 | +
- if (color_settings) {
+ ), |
||
| 242 | -2x | +||
| 336 | +! |
- if (is.null(color)) {
+ selectInput( |
|
| 243 | -2x | +||
| 337 | +! |
- color <- x+ inputId = ns("ggtheme"),
|
|
| 244 | -2x | +||
| 338 | +! |
- color[[1]]$select <- teal.transform::select_spec(choices = color[[1]]$select$choices, selected = NULL)+ label = "Theme (by ggplot):", |
|
| 245 | -+ | ||
| 339 | +! |
- }+ choices = ggplot_themes, |
|
| 246 | -2x | +||
| 340 | +! |
- if (is.null(fill)) {
+ selected = args$ggtheme, |
|
| 247 | -2x | +||
| 341 | +! |
- fill <- x+ multiple = FALSE |
|
| 248 | -2x | +||
| 342 | +
- fill[[1]]$select <- teal.transform::select_spec(choices = fill[[1]]$select$choices, selected = NULL)+ ),+ |
+ ||
| 343 | +! | +
+ teal.widgets::optionalSliderInputValMinMax(ns("font_size"), "Font Size", args$font_size, ticks = FALSE)
|
|
| 249 | +344 |
- }+ ) |
|
| 250 | -2x | +||
| 345 | +
- if (is.null(size)) {
+ ) |
||
| 251 | -2x | +||
| 346 | +
- size <- x+ ), |
||
| 252 | -2x | +||
| 347 | +! |
- size[[1]]$select <- teal.transform::select_spec(choices = size[[1]]$select$choices, selected = NULL)+ forms = tagList( |
|
| 253 | -+ | ||
| 348 | +! |
- }+ teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code")
|
|
| 254 | +349 |
- } else {
+ ), |
|
| 255 | -12x | +||
| 350 | +! |
- if (!is.null(c(color, fill, size))) {
+ pre_output = args$pre_output, |
|
| 256 | -3x | +||
| 351 | +! |
- stop("'color_settings' argument needs to be set to TRUE if 'color', 'fill', and/or 'size' is/are supplied.")
+ post_output = args$post_output |
|
| 257 | +352 |
- }+ ) |
|
| 258 | +353 |
- }+ ) |
|
| 259 | +354 | - - | -|
| 260 | -11x | -
- checkmate::assert_flag(free_x_scales)+ } |
|
| 261 | -11x | +||
| 355 | +
- checkmate::assert_flag(free_y_scales)+ |
||
| 262 | +356 |
-
+ # Server function for the PCA module |
|
| 263 | -11x | +||
| 357 | +
- checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE)+ srv_a_pca <- function(id, data, reporter, filter_panel_api, dat, plot_height, plot_width, ggplot2_args, decorators) {
|
||
| 264 | -10x | +||
| 358 | +! |
- checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height")+ with_reporter <- !missing(reporter) && inherits(reporter, "Reporter") |
|
| 265 | -8x | +||
| 359 | +! |
- checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE)+ with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI") |
|
| 266 | -7x | +||
| 360 | +! |
- checkmate::assert_numeric(+ checkmate::assert_class(data, "reactive") |
|
| 267 | -7x | +||
| 361 | +! |
- plot_width[1],+ checkmate::assert_class(isolate(data()), "teal_data") |
|
| 268 | -7x | +||
| 362 | +! |
- lower = plot_width[2], upper = plot_width[3], null.ok = TRUE, .var.name = "plot_width"+ moduleServer(id, function(input, output, session) {
|
|
| 269 | -+ | ||
| 363 | +! |
- )+ teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.general") |
|
| 270 | +364 | ||
| 271 | -5x | -
- checkmate::assert_flag(rotate_xaxis_labels)- |
- |
| 272 | -5x | +||
| 365 | +! |
- checkmate::assert_flag(swap_axes)+ response <- dat |
|
| 273 | +366 | ||
| 274 | -5x | +||
| 367 | +! |
- ggtheme <- match.arg(ggtheme)+ for (i in seq_along(response)) {
|
|
| 275 | -5x | +||
| 368 | +! |
- checkmate::assert_class(ggplot2_args, "ggplot2_args")+ response[[i]]$select$multiple <- FALSE |
|
| 276 | -+ | ||
| 369 | +! |
-
+ response[[i]]$select$always_selected <- NULL |
|
| 277 | -5x | +||
| 370 | +! |
- checkmate::assert_multi_class(pre_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
+ response[[i]]$select$selected <- NULL |
|
| 278 | -5x | +||
| 371 | +! |
- checkmate::assert_multi_class(post_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
+ all_cols <- teal.data::col_labels(isolate(data())[[response[[i]]$dataname]]) |
|
| 279 | -+ | ||
| 372 | +! |
-
+ ignore_cols <- unlist(teal.data::join_keys(isolate(data()))[[response[[i]]$dataname]]) |
|
| 280 | -5x | +||
| 373 | +! |
- decorators <- normalize_decorators(decorators)+ color_cols <- all_cols[!names(all_cols) %in% ignore_cols] |
|
| 281 | -5x | +||
| 374 | +! |
- assert_decorators(decorators, null.ok = TRUE, "plot")+ response[[i]]$select$choices <- teal.transform::choices_labeled(names(color_cols), color_cols) |
|
| 282 | +375 |
- # End of assertions+ } |
|
| 283 | +376 | ||
| 284 | -+ | ||
| 377 | +! |
- # Make UI args+ selector_list <- teal.transform::data_extract_multiple_srv( |
|
| 285 | -5x | +||
| 378 | +! |
- args <- as.list(environment())+ data_extract = list(dat = dat, response = response), |
|
| 286 | -+ | ||
| 379 | +! |
-
+ datasets = data, |
|
| 287 | -5x | +||
| 380 | +! |
- data_extract_list <- list(+ select_validation_rule = list( |
|
| 288 | -5x | +||
| 381 | +! |
- x = x,+ dat = ~ if (length(.) < 2L) "Please select more than 1 variable to perform PCA.", |
|
| 289 | -5x | +||
| 382 | +! |
- y = y,+ response = shinyvalidate::compose_rules( |
|
| 290 | -5x | +||
| 383 | +! |
- row_facet = row_facet,+ shinyvalidate::sv_optional(), |
|
| 291 | -5x | +||
| 384 | +! |
- col_facet = col_facet,+ ~ if (isTRUE(is.element(., selector_list()$dat()$select))) {
|
|
| 292 | -5x | +||
| 385 | +! |
- color_settings = color_settings,+ "Response must not have been used for PCA." |
|
| 293 | -5x | +||
| 386 | +
- color = color,+ } |
||
| 294 | -5x | +||
| 387 | +
- fill = fill,+ ) |
||
| 295 | -5x | +||
| 388 | +
- size = size+ ) |
||
| 296 | +389 |
- )+ ) |
|
| 297 | +390 | ||
| 298 | -5x | +||
| 391 | +! |
- ans <- module(+ iv_r <- reactive({
|
|
| 299 | -5x | +||
| 392 | +! |
- label = label,+ iv <- shinyvalidate::InputValidator$new() |
|
| 300 | -5x | +||
| 393 | +! |
- server = srv_g_bivariate,+ teal.transform::compose_and_enable_validators(iv, selector_list) |
|
| 301 | -5x | +||
| 394 | +
- ui = ui_g_bivariate,+ }) |
||
| 302 | -5x | +||
| 395 | +
- ui_args = args,+ |
||
| 303 | -5x | +||
| 396 | +! |
- server_args = c(+ iv_extra <- shinyvalidate::InputValidator$new() |
|
| 304 | -5x | +||
| 397 | +! |
- data_extract_list,+ iv_extra$add_rule("x_axis", function(value) {
|
|
| 305 | -5x | +||
| 398 | +! |
- list(plot_height = plot_height, plot_width = plot_width, ggplot2_args = ggplot2_args, decorators = decorators)+ if (isTRUE(input$plot_type %in% c("Circle plot", "Biplot"))) {
+ |
+ |
| 399 | +! | +
+ if (!shinyvalidate::input_provided(value)) {
+ |
+ |
| 400 | +! | +
+ "Need X axis" |
|
| 306 | +401 |
- ),+ } |
|
| 307 | -5x | +||
| 402 | +
- datanames = teal.transform::get_extract_datanames(data_extract_list)+ } |
||
| 308 | +403 |
- )+ }) |
|
| 309 | -5x | +||
| 404 | +! |
- attr(ans, "teal_bookmarkable") <- TRUE+ iv_extra$add_rule("y_axis", function(value) {
|
|
| 310 | -5x | +||
| 405 | +! |
- ans+ if (isTRUE(input$plot_type %in% c("Circle plot", "Biplot"))) {
|
|
| 311 | -+ | ||
| 406 | +! |
- }+ if (!shinyvalidate::input_provided(value)) {
+ |
+ |
| 407 | +! | +
+ "Need Y axis" |
|
| 312 | +408 |
-
+ } |
|
| 313 | +409 |
- # UI function for the bivariate module+ } |
|
| 314 | +410 |
- ui_g_bivariate <- function(id, ...) {
+ }) |
|
| 315 | +411 | ! |
- args <- list(...)+ rule_dupl <- function(...) {
|
| 316 | +412 | ! |
- is_single_dataset_value <- teal.transform::is_single_dataset(+ if (isTRUE(input$plot_type %in% c("Circle plot", "Biplot"))) {
|
| 317 | +413 | ! |
- args$x, args$y, args$row_facet, args$col_facet, args$color, args$fill, args$size+ if (isTRUE(input$x_axis == input$y_axis)) {
+ |
+
| 414 | +! | +
+ "Please choose different X and Y axes." |
|
| 318 | +415 |
- )+ } |
|
| 319 | +416 |
-
+ }+ |
+ |
| 417 | ++ |
+ } |
|
| 320 | +418 | ! |
- ns <- NS(id)+ iv_extra$add_rule("x_axis", rule_dupl)
|
| 321 | +419 | ! |
- teal.widgets::standard_layout(+ iv_extra$add_rule("y_axis", rule_dupl)
|
| 322 | +420 | ! |
- output = teal.widgets::white_small_well(+ iv_extra$add_rule("variables", function(value) {
|
| 323 | +421 | ! |
- tags$div(teal.widgets::plot_with_settings_ui(id = ns("myplot")))
+ if (identical(input$plot_type, "Circle plot")) {
|
| 324 | -+ | ||
| 422 | +! |
- ),+ if (!shinyvalidate::input_provided(value)) {
|
|
| 325 | +423 | ! |
- encoding = tags$div(+ "Need Original Coordinates" |
| 326 | +424 |
- ### Reporter- |
- |
| 327 | -! | -
- teal.reporter::simple_reporter_ui(ns("simple_reporter")),
+ } |
|
| 328 | +425 |
- ###+ } |
|
| 329 | -! | +||
| 426 | +
- tags$label("Encodings", class = "text-primary"),
+ }) |
||
| 330 | +427 | ! |
- teal.transform::datanames_input(args[c("x", "y", "row_facet", "col_facet", "color", "fill", "size")]),
+ iv_extra$add_rule("pc", function(value) {
|
| 331 | +428 | ! |
- teal.transform::data_extract_ui(+ if (identical(input$plot_type, "Eigenvector plot")) {
|
| 332 | +429 | ! |
- id = ns("x"),
+ if (!shinyvalidate::input_provided(value)) {
|
| 333 | +430 | ! |
- label = "X variable",+ "Need PC" |
| 334 | -! | +||
| 431 | +
- data_extract_spec = args$x,+ } |
||
| 335 | -! | +||
| 432 | +
- is_single_dataset = is_single_dataset_value+ } |
||
| 336 | +433 |
- ),+ }) |
|
| 337 | +434 | ! |
- teal.transform::data_extract_ui(+ iv_extra$enable() |
| 338 | -! | +||
| 435 | +
- id = ns("y"),
+
|
||
| 339 | +436 | ! |
- label = "Y variable",+ anl_merged_input <- teal.transform::merge_expression_srv( |
| 340 | +437 | ! |
- data_extract_spec = args$y,+ selector_list = selector_list, |
| 341 | +438 | ! |
- is_single_dataset = is_single_dataset_value+ datasets = data |
| 342 | +439 |
- ),+ ) |
|
| 343 | -! | +||
| 440 | +
- conditionalPanel(+ |
||
| 344 | +441 | ! |
- condition =+ anl_merged_q <- reactive({
|
| 345 | +442 | ! |
- "$(\"button[data-id*='-x-dataset'][data-id$='-select']\").text() == '- Nothing selected - ' ||+ req(anl_merged_input()) |
| 346 | +443 | ! |
- $(\"button[data-id*='-y-dataset'][data-id$='-select']\").text() == '- Nothing selected - ' ",+ data() %>% |
| 347 | +444 | ! |
- shinyWidgets::radioGroupButtons(+ teal.code::eval_code(as.expression(anl_merged_input()$expr)) |
| 348 | -! | +||
| 445 | +
- inputId = ns("use_density"),
+ }) |
||
| 349 | -! | +||
| 446 | +
- label = NULL,+ |
||
| 350 | +447 | ! |
- choices = c("frequency", "density"),
+ merged <- list( |
| 351 | +448 | ! |
- selected = ifelse(args$use_density, "density", "frequency"),+ anl_input_r = anl_merged_input, |
| 352 | +449 | ! |
- justified = TRUE+ anl_q_r = anl_merged_q |
| 353 | +450 |
- )+ ) |
|
| 354 | +451 |
- ),+ |
|
| 355 | +452 | ! |
- ui_decorate_teal_data(ns("decorator"), decorators = select_decorators(args$decorators, "plot")),
+ validation <- reactive({
|
| 356 | +453 | ! |
- if (!is.null(args$row_facet) || !is.null(args$col_facet)) {
+ req(merged$anl_q_r()) |
| 357 | -! | +||
| 454 | +
- tags$div(+ # inputs |
||
| 358 | +455 | ! |
- class = "data-extract-box",+ keep_cols <- as.character(merged$anl_input_r()$columns_source$dat) |
| 359 | +456 | ! |
- tags$label("Facetting"),
+ na_action <- input$na_action |
| 360 | +457 | ! |
- shinyWidgets::switchInput(inputId = ns("facetting"), value = args$facet, size = "mini"),
+ standardization <- input$standardization |
| 361 | +458 | ! |
- conditionalPanel(+ center <- standardization %in% c("center", "center_scale")
|
| 362 | +459 | ! |
- condition = paste0("input['", ns("facetting"), "']"),
+ scale <- standardization == "center_scale" |
| 363 | +460 | ! |
- tags$div(+ ANL <- merged$anl_q_r()[["ANL"]]+ |
+
| 461 | ++ | + | |
| 364 | +462 | ! |
- if (!is.null(args$row_facet)) {
+ teal::validate_has_data(ANL, 10) |
| 365 | +463 | ! |
- teal.transform::data_extract_ui(+ validate(need( |
| 366 | +464 | ! |
- id = ns("row_facet"),
+ na_action != "none" | !anyNA(ANL[keep_cols]), |
| 367 | +465 | ! |
- label = "Row facetting variable",+ paste( |
| 368 | +466 | ! |
- data_extract_spec = args$row_facet,+ "There are NAs in the dataset. Please deal with them in preprocessing", |
| 369 | +467 | ! |
- is_single_dataset = is_single_dataset_value+ "or select \"Drop\" in the NA actions inside the encodings panel (left)." |
| 370 | +468 |
- )+ ) |
|
| 371 | +469 |
- },+ )) |
|
| 372 | +470 | ! |
- if (!is.null(args$col_facet)) {
+ if (scale) {
|
| 373 | +471 | ! |
- teal.transform::data_extract_ui(+ not_single <- vapply(ANL[keep_cols], function(column) length(unique(column)) != 1, FUN.VALUE = logical(1)) |
| 374 | -! | +||
| 472 | +
- id = ns("col_facet"),
+
|
||
| 375 | +473 | ! |
- label = "Column facetting variable",+ msg <- paste0( |
| 376 | +474 | ! |
- data_extract_spec = args$col_facet,+ "You have selected `Center & Scale` under `Standardization` in the `Pre-processing` panel, ", |
| 377 | +475 | ! |
- is_single_dataset = is_single_dataset_value- |
-
| 378 | -- |
- )+ "but one or more of your columns has/have a variance value of zero, indicating all values are identical" |
|
| 379 | +476 |
- },+ ) |
|
| 380 | +477 | ! |
- checkboxInput(ns("free_x_scales"), "free x scales", value = args$free_x_scales),
+ validate(need(all(not_single), msg)) |
| 381 | -! | +||
| 478 | +
- checkboxInput(ns("free_y_scales"), "free y scales", value = args$free_y_scales)
+ } |
||
| 382 | +479 |
- )+ }) |
|
| 383 | +480 |
- )+ |
|
| 384 | +481 |
- )+ # computation ---- |
|
| 385 | -+ | ||
| 482 | +! |
- },+ computation <- reactive({
|
|
| 386 | +483 | ! |
- if (args$color_settings) {
+ validation() |
| 387 | +484 |
- # Put a grey border around the coloring settings+ |
|
| 388 | -! | +||
| 485 | +
- tags$div(+ # inputs |
||
| 389 | +486 | ! |
- class = "data-extract-box",+ keep_cols <- as.character(merged$anl_input_r()$columns_source$dat) |
| 390 | +487 | ! |
- tags$label("Color settings"),
+ na_action <- input$na_action |
| 391 | +488 | ! |
- shinyWidgets::switchInput(inputId = ns("coloring"), value = TRUE, size = "mini"),
+ standardization <- input$standardization |
| 392 | +489 | ! |
- conditionalPanel(+ center <- standardization %in% c("center", "center_scale")
|
| 393 | +490 | ! |
- condition = paste0("input['", ns("coloring"), "']"),
+ scale <- standardization == "center_scale" |
| 394 | +491 | ! |
- tags$div(+ ANL <- merged$anl_q_r()[["ANL"]] |
| 395 | -! | +||
| 492 | +
- teal.transform::data_extract_ui(+ |
||
| 396 | +493 | ! |
- id = ns("color"),
+ qenv <- teal.code::eval_code( |
| 397 | +494 | ! |
- label = "Outline color by variable",+ merged$anl_q_r(), |
| 398 | +495 | ! |
- data_extract_spec = args$color,+ substitute( |
| 399 | +496 | ! |
- is_single_dataset = is_single_dataset_value+ expr = keep_columns <- keep_cols, |
| 400 | +|||
| 497 | +! | +
+ env = list(keep_cols = keep_cols)+ |
+ |
| 498 |
- ),+ ) |
||
| 401 | -! | +||
| 499 | +
- teal.transform::data_extract_ui(+ )+ |
+ ||
| 500 | ++ | + | |
| 402 | +501 | ! |
- id = ns("fill"),
+ if (na_action == "drop") {
|
| 403 | +502 | ! |
- label = "Fill color by variable",+ qenv <- teal.code::eval_code( |
| 404 | +503 | ! |
- data_extract_spec = args$fill,+ qenv, |
| 405 | +504 | ! |
- is_single_dataset = is_single_dataset_value+ quote(ANL <- tidyr::drop_na(ANL, keep_columns)) |
| 406 | +505 |
- ),+ ) |
|
| 407 | -! | +||
| 506 | +
- tags$div(+ } |
||
| 408 | -! | +||
| 507 | +
- id = ns("size_settings"),
+
|
||
| 409 | +508 | ! |
- teal.transform::data_extract_ui(+ qenv <- teal.code::eval_code( |
| 410 | +509 | ! |
- id = ns("size"),
+ qenv, |
| 411 | +510 | ! |
- label = "Size of points by variable (only if x and y are numeric)",+ substitute( |
| 412 | +511 | ! |
- data_extract_spec = args$size,+ expr = pca <- summary(stats::prcomp(ANL[keep_columns], center = center, scale. = scale, retx = TRUE)), |
| 413 | +512 | ! |
- is_single_dataset = is_single_dataset_value+ env = list(center = center, scale = scale) |
| 414 | +513 |
- )+ ) |
|
| 415 | +514 |
- )+ ) |
|
| 416 | +515 |
- )+ |
|
| 417 | -+ | ||
| 516 | +! |
- )+ qenv <- teal.code::eval_code( |
|
| 418 | -+ | ||
| 517 | +! |
- )+ qenv, |
|
| 419 | -+ | ||
| 518 | +! |
- },+ quote({
|
|
| 420 | +519 | ! |
- teal.widgets::panel_group(+ tbl_importance <- dplyr::as_tibble(pca$importance, rownames = "Metric") |
| 421 | +520 | ! |
- teal.widgets::panel_item(+ tbl_importance |
| 422 | -! | +||
| 521 | +
- title = "Plot settings",+ }) |
||
| 423 | -! | +||
| 522 | +
- checkboxInput(ns("rotate_xaxis_labels"), "Rotate X axis labels", value = args$rotate_xaxis_labels),
+ ) |
||
| 424 | -! | +||
| 523 | +
- checkboxInput(ns("swap_axes"), "Swap axes", value = args$swap_axes),
+
|
||
| 425 | +524 | ! |
- selectInput(+ teal.code::eval_code( |
| 426 | +525 | ! |
- inputId = ns("ggtheme"),
+ qenv, |
| 427 | +526 | ! |
- label = "Theme (by ggplot):",+ quote({
|
| 428 | +527 | ! |
- choices = ggplot_themes,+ tbl_eigenvector <- dplyr::as_tibble(pca$rotation, rownames = "Variable") |
| 429 | +528 | ! |
- selected = args$ggtheme,+ tbl_eigenvector |
| 430 | -! | +||
| 529 | +
- multiple = FALSE+ }) |
||
| 431 | +530 |
- ),+ )+ |
+ |
| 531 | ++ |
+ })+ |
+ |
| 532 | ++ | + + | +|
| 533 | ++ |
+ # plot args ---- |
|
| 432 | +534 | ! |
- sliderInput(+ output$plot_settings <- renderUI({
+ |
+
| 535 | ++ |
+ # reactivity triggers |
|
| 433 | +536 | ! |
- ns("alpha"), "Opacity Scatterplot:",
+ req(iv_r()$is_valid()) |
| 434 | +537 | ! |
- min = 0, max = 1,+ req(computation()) |
| 435 | +538 | ! |
- step = .05, value = .5, ticks = FALSE+ qenv <- computation() |
| 436 | +539 |
- ),+ |
|
| 437 | +540 | ! |
- sliderInput(+ ns <- session$ns+ |
+
| 541 | ++ | + | |
| 438 | +542 | ! |
- ns("fixed_size"), "Scatterplot point size:",
+ pca <- qenv[["pca"]] |
| 439 | +543 | ! |
- min = 1, max = 8,+ chcs_pcs <- colnames(pca$rotation) |
| 440 | +544 | ! |
- step = 1, value = 2, ticks = FALSE+ chcs_vars <- qenv[["keep_columns"]] |
| 441 | +545 |
- ),+ |
|
| 442 | +546 | ! |
- checkboxInput(ns("add_lines"), "Add lines"),
- |
-
| 443 | -- |
- )+ tagList( |
|
| 444 | -+ | ||
| 547 | +! |
- )+ conditionalPanel( |
|
| 445 | -+ | ||
| 548 | +! |
- ),+ condition = sprintf( |
|
| 446 | +549 | ! |
- forms = tagList(+ "input['%s'] == 'Biplot' || input['%s'] == 'Circle plot'", |
| 447 | +550 | ! |
- teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code")
+ ns("plot_type"), ns("plot_type")
|
| 448 | +551 |
- ),+ ), |
|
| 449 | +552 | ! |
- pre_output = args$pre_output,+ list( |
| 450 | +553 | ! |
- post_output = args$post_output+ teal.widgets::optionalSelectInput(ns("x_axis"), "X axis", choices = chcs_pcs, selected = chcs_pcs[1]),
|
| 451 | -+ | ||
| 554 | +! |
- )+ teal.widgets::optionalSelectInput(ns("y_axis"), "Y axis", choices = chcs_pcs, selected = chcs_pcs[2]),
|
|
| 452 | -+ | ||
| 555 | +! |
- }+ teal.widgets::optionalSelectInput( |
|
| 453 | -+ | ||
| 556 | +! |
-
+ ns("variables"), "Original coordinates",
|
|
| 454 | -+ | ||
| 557 | +! |
- # Server function for the bivariate module+ choices = chcs_vars, selected = chcs_vars, |
|
| 455 | -+ | ||
| 558 | +! |
- srv_g_bivariate <- function(id,+ multiple = TRUE |
|
| 456 | +559 |
- data,+ ) |
|
| 457 | +560 |
- reporter,+ ) |
|
| 458 | +561 |
- filter_panel_api,+ ), |
|
| 459 | -+ | ||
| 562 | +! |
- x,+ conditionalPanel( |
|
| 460 | -+ | ||
| 563 | +! |
- y,+ condition = sprintf("input['%s'] == 'Elbow plot'", ns("plot_type")),
|
|
| 461 | -+ | ||
| 564 | +! |
- row_facet,+ helpText("No plot specific settings available.")
|
|
| 462 | +565 |
- col_facet,+ ), |
|
| 463 | -+ | ||
| 566 | +! |
- color_settings = FALSE,+ conditionalPanel( |
|
| 464 | -+ | ||
| 567 | +! |
- color,+ condition = paste0("input['", ns("plot_type"), "'] == 'Eigenvector plot'"),
|
|
| 465 | -+ | ||
| 568 | +! |
- fill,+ teal.widgets::optionalSelectInput(ns("pc"), "PC", choices = chcs_pcs, selected = chcs_pcs[1])
|
|
| 466 | +569 |
- size,+ ) |
|
| 467 | +570 |
- plot_height,+ ) |
|
| 468 | +571 |
- plot_width,+ }) |
|
| 469 | +572 |
- ggplot2_args,+ |
|
| 470 | +573 |
- decorators) {
+ # plot elbow ---- |
|
| 471 | +574 | ! |
- with_reporter <- !missing(reporter) && inherits(reporter, "Reporter")+ plot_elbow <- function(base_q) {
|
| 472 | +575 | ! |
- with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI")+ ggtheme <- input$ggtheme |
| 473 | +576 | ! |
- checkmate::assert_class(data, "reactive")+ rotate_xaxis_labels <- input$rotate_xaxis_labels |
| 474 | +577 | ! |
- checkmate::assert_class(isolate(data()), "teal_data")+ font_size <- input$font_size |
| 475 | -! | +||
| 578 | +
- moduleServer(id, function(input, output, session) {
+
|
||
| 476 | +579 | ! |
- teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.general")- |
-
| 477 | -- |
-
+ angle_value <- ifelse(isTRUE(rotate_xaxis_labels), 45, 0) |
|
| 478 | +580 | ! |
- ns <- session$ns+ hjust_value <- ifelse(isTRUE(rotate_xaxis_labels), 1, 0.5) |
| 479 | +581 | ||
| 480 | +582 | ! |
- data_extract <- list(+ dev_ggplot2_args <- teal.widgets::ggplot2_args( |
| 481 | +583 | ! |
- x = x, y = y, row_facet = row_facet, col_facet = col_facet,+ labs = list(x = "Principal component", y = "Proportion of variance explained", color = "", fill = "Legend"), |
| 482 | +584 | ! |
- color = color, fill = fill, size = size- |
-
| 483 | -- |
- )+ theme = list( |
|
| 484 | -+ | ||
| 585 | +! |
-
+ legend.position = "right", |
|
| 485 | +586 | ! |
- rule_var <- function(other) {
+ legend.spacing.y = quote(grid::unit(-5, "pt")), |
| 486 | +587 | ! |
- function(value) {
+ legend.title = quote(element_text(vjust = 25)), |
| 487 | +588 | ! |
- othervalue <- selector_list()[[other]]()$select+ axis.text.x = substitute( |
| 488 | +589 | ! |
- if (length(value) == 0L && length(othervalue) == 0L) {
+ element_text(angle = angle_value, hjust = hjust_value), |
| 489 | +590 | ! |
- "Please select at least one of x-variable or y-variable"+ list(angle_value = angle_value, hjust_value = hjust_value) |
| 490 | +591 |
- }+ ),+ |
+ |
| 592 | +! | +
+ text = substitute(element_text(size = font_size), list(font_size = font_size)) |
|
| 491 | +593 |
- }+ ) |
|
| 492 | +594 |
- }+ ) |
|
| 493 | -! | +||
| 595 | +
- rule_diff <- function(other) {
+
|
||
| 494 | +596 | ! |
- function(value) {
+ parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args( |
| 495 | +597 | ! |
- othervalue <- selector_list()[[other]]()[["select"]]+ teal.widgets::resolve_ggplot2_args( |
| 496 | +598 | ! |
- if (!is.null(othervalue)) {
+ user_plot = ggplot2_args[["Elbow plot"]], |
| 497 | +599 | ! |
- if (identical(value, othervalue)) {
+ user_default = ggplot2_args$default, |
| 498 | +600 | ! |
- "Row and column facetting variables must be different."- |
-
| 499 | -- |
- }+ module_plot = dev_ggplot2_args |
|
| 500 | +601 |
- }+ ), |
|
| 501 | -+ | ||
| 602 | +! |
- }+ ggtheme = ggtheme |
|
| 502 | +603 |
- }+ ) |
|
| 503 | +604 | ||
| 504 | +605 | ! |
- selector_list <- teal.transform::data_extract_multiple_srv(+ teal.code::eval_code( |
| 505 | +606 | ! |
- data_extract = data_extract,+ base_q, |
| 506 | +607 | ! |
- datasets = data,+ substitute( |
| 507 | +608 | ! |
- select_validation_rule = list(+ expr = {
|
| 508 | +609 | ! |
- x = rule_var("y"),
+ elb_dat <- pca$importance[c("Proportion of Variance", "Cumulative Proportion"), ] %>%
|
| 509 | +610 | ! |
- y = rule_var("x"),
+ dplyr::as_tibble(rownames = "metric") %>% |
| 510 | +611 | ! |
- row_facet = shinyvalidate::compose_rules(+ tidyr::gather("component", "value", -metric) %>%
|
| 511 | +612 | ! |
- shinyvalidate::sv_optional(),+ dplyr::mutate( |
| 512 | +613 | ! |
- rule_diff("col_facet")
+ component = factor(component, levels = unique(stringr::str_sort(component, numeric = TRUE))) |
| 513 | +614 |
- ),+ ) |
|
| 514 | -! | +||
| 615 | +
- col_facet = shinyvalidate::compose_rules(+ |
||
| 515 | +616 | ! |
- shinyvalidate::sv_optional(),+ cols <- c(getOption("ggplot2.discrete.colour"), c("lightblue", "darkred", "black"))[1:3]
|
| 516 | +617 | ! |
- rule_diff("row_facet")
- |
-
| 517 | -- |
- )+ elbow_plot <- ggplot(mapping = aes_string(x = "component", y = "value")) + |
|
| 518 | -+ | ||
| 618 | +! |
- )+ geom_bar( |
|
| 519 | -+ | ||
| 619 | +! |
- )+ aes(fill = "Single variance"), |
|
| 520 | -+ | ||
| 620 | +! |
-
+ data = dplyr::filter(elb_dat, metric == "Proportion of Variance"), |
|
| 521 | +621 | ! |
- iv_r <- reactive({
+ color = "black", |
| 522 | +622 | ! |
- iv_facet <- shinyvalidate::InputValidator$new()+ stat = "identity" |
| 523 | -! | +||
| 623 | +
- iv_child <- teal.transform::compose_and_enable_validators(iv_facet, selector_list,+ ) + |
||
| 524 | +624 | ! |
- validator_names = c("row_facet", "col_facet")
+ geom_point( |
| 525 | -+ | ||
| 625 | +! |
- )+ aes(color = "Cumulative variance"), |
|
| 526 | +626 | ! |
- iv_child$condition(~ isTRUE(input$facetting))+ data = dplyr::filter(elb_dat, metric == "Cumulative Proportion") |
| 527 | +627 |
-
+ ) + |
|
| 528 | +628 | ! |
- iv <- shinyvalidate::InputValidator$new()+ geom_line( |
| 529 | +629 | ! |
- iv$add_validator(iv_child)+ aes(group = 1, color = "Cumulative variance"), |
| 530 | +630 | ! |
- teal.transform::compose_and_enable_validators(iv, selector_list, validator_names = c("x", "y"))
+ data = dplyr::filter(elb_dat, metric == "Cumulative Proportion") |
| 531 | +631 |
- })+ ) + |
|
| 532 | -+ | ||
| 632 | +! |
-
+ labs + |
|
| 533 | +633 | ! |
- anl_merged_input <- teal.transform::merge_expression_srv(+ scale_color_manual(values = c("Cumulative variance" = cols[2], "Single variance" = cols[3])) +
|
| 534 | +634 | ! |
- selector_list = selector_list,+ scale_fill_manual(values = c("Cumulative variance" = cols[2], "Single variance" = cols[1])) +
|
| 535 | +635 | ! |
- datasets = data+ ggthemes + |
| 536 | -+ | ||
| 636 | +! |
- )+ themes |
|
| 537 | +637 |
-
+ }, |
|
| 538 | +638 | ! |
- anl_merged_q <- reactive({
+ env = list( |
| 539 | +639 | ! |
- req(anl_merged_input())+ ggthemes = parsed_ggplot2_args$ggtheme, |
| 540 | +640 | ! |
- data() %>%+ labs = parsed_ggplot2_args$labs, |
| 541 | +641 | ! |
- teal.code::eval_code(as.expression(anl_merged_input()$expr))+ themes = parsed_ggplot2_args$theme |
| 542 | +642 |
- })+ ) |
|
| 543 | +643 | - - | -|
| 544 | -! | -
- merged <- list(+ ) |
|
| 545 | -! | +||
| 644 | +
- anl_input_r = anl_merged_input,+ ) |
||
| 546 | -! | +||
| 645 | +
- anl_q_r = anl_merged_q+ } |
||
| 547 | +646 |
- )+ |
|
| 548 | +647 |
-
+ # plot circle ---- |
|
| 549 | +648 | ! |
- output_q <- reactive({
+ plot_circle <- function(base_q) {
|
| 550 | +649 | ! |
- teal::validate_inputs(iv_r())+ x_axis <- input$x_axis |
| 551 | -+ | ||
| 650 | +! |
-
+ y_axis <- input$y_axis |
|
| 552 | +651 | ! |
- ANL <- merged$anl_q_r()[["ANL"]]+ variables <- input$variables |
| 553 | +652 | ! |
- teal::validate_has_data(ANL, 3)+ ggtheme <- input$ggtheme |
| 554 | +653 | ||
| 555 | +654 | ! |
- x_col_vec <- as.vector(merged$anl_input_r()$columns_source$x)+ rotate_xaxis_labels <- input$rotate_xaxis_labels |
| 556 | +655 | ! |
- x_name <- `if`(is.null(x_col_vec), character(0), x_col_vec)+ font_size <- input$font_size+ |
+
| 656 | ++ | + | |
| 557 | +657 | ! |
- y_col_vec <- as.vector(merged$anl_input_r()$columns_source$y)+ angle <- ifelse(isTRUE(rotate_xaxis_labels), 45, 0) |
| 558 | +658 | ! |
- y_name <- `if`(is.null(y_col_vec), character(0), y_col_vec)+ hjust <- ifelse(isTRUE(rotate_xaxis_labels), 1, 0.5) |
| 559 | +659 | ||
| 560 | +660 | ! |
- row_facet_name <- as.vector(merged$anl_input_r()$columns_source$row_facet)+ dev_ggplot2_args <- teal.widgets::ggplot2_args( |
| 561 | +661 | ! |
- col_facet_name <- as.vector(merged$anl_input_r()$columns_source$col_facet)+ theme = list( |
| 562 | +662 | ! |
- color_name <- if ("color" %in% names(merged$anl_input_r()$columns_source)) {
+ text = substitute(element_text(size = font_size), list(font_size = font_size)), |
| 563 | +663 | ! |
- as.vector(merged$anl_input_r()$columns_source$color)- |
-
| 564 | -- |
- } else {
+ axis.text.x = substitute( |
|
| 565 | +664 | ! |
- character(0)- |
-
| 566 | -- |
- }+ element_text(angle = angle_val, hjust = hjust_val), |
|
| 567 | +665 | ! |
- fill_name <- if ("fill" %in% names(merged$anl_input_r()$columns_source)) {
+ list(angle_val = angle, hjust_val = hjust) |
| 568 | -! | +||
| 666 | +
- as.vector(merged$anl_input_r()$columns_source$fill)+ ) |
||
| 569 | +667 |
- } else {
+ ) |
|
| 570 | -! | +||
| 668 | +
- character(0)+ ) |
||
| 571 | +669 |
- }+ |
|
| 572 | +670 | ! |
- size_name <- if ("size" %in% names(merged$anl_input_r()$columns_source)) {
+ all_ggplot2_args <- teal.widgets::resolve_ggplot2_args( |
| 573 | +671 | ! |
- as.vector(merged$anl_input_r()$columns_source$size)+ user_plot = ggplot2_args[["Circle plot"]], |
| 574 | -+ | ||
| 672 | +! |
- } else {
+ user_default = ggplot2_args$default, |
|
| 575 | +673 | ! |
- character(0)+ module_plot = dev_ggplot2_args |
| 576 | +674 |
- }+ ) |
|
| 577 | +675 | ||
| 578 | -! | -
- use_density <- input$use_density == "density"- |
- |
| 579 | -! | -
- free_x_scales <- input$free_x_scales- |
- |
| 580 | +676 | ! |
- free_y_scales <- input$free_y_scales+ parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args( |
| 581 | +677 | ! |
- ggtheme <- input$ggtheme+ all_ggplot2_args, |
| 582 | +678 | ! |
- rotate_xaxis_labels <- input$rotate_xaxis_labels+ ggtheme = ggtheme |
| 583 | -! | +||
| 679 | +
- swap_axes <- input$swap_axes+ ) |
||
| 584 | +680 | ||
| 585 | +681 | ! |
- is_scatterplot <- all(vapply(ANL[c(x_name, y_name)], is.numeric, logical(1))) &&+ teal.code::eval_code( |
| 586 | +682 | ! |
- length(x_name) > 0 && length(y_name) > 0+ base_q, |
| 587 | -+ | ||
| 683 | +! |
-
+ substitute( |
|
| 588 | +684 | ! |
- if (is_scatterplot) {
+ expr = {
|
| 589 | +685 | ! |
- shinyjs::show("alpha")
+ pca_rot <- pca$rotation[, c(x_axis, y_axis)] %>% |
| 590 | +686 | ! |
- alpha <- input$alpha+ dplyr::as_tibble(rownames = "label") %>% |
| 591 | +687 | ! |
- shinyjs::show("add_lines")
+ dplyr::filter(label %in% variables) |
| 592 | +688 | ||
| 593 | +689 | ! |
- if (color_settings && input$coloring) {
+ circle_data <- data.frame( |
| 594 | +690 | ! |
- shinyjs::hide("fixed_size")
+ x = cos(seq(0, 2 * pi, length.out = 100)), |
| 595 | +691 | ! |
- shinyjs::show("size_settings")
+ y = sin(seq(0, 2 * pi, length.out = 100)) |
| 596 | -! | +||
| 692 | +
- size <- NULL+ ) |
||
| 597 | +693 |
- } else {
+
|
|
| 598 | +694 | ! |
- shinyjs::show("fixed_size")
+ circle_plot <- ggplot(pca_rot) + |
| 599 | +695 | ! |
- size <- input$fixed_size- |
-
| 600 | -- |
- }- |
- |
| 601 | -- |
- } else {
+ geom_point(aes_string(x = x_axis, y = y_axis)) + |
|
| 602 | +696 | ! |
- shinyjs::hide("add_lines")
+ geom_label( |
| 603 | +697 | ! |
- updateCheckboxInput(session, "add_lines", value = restoreInput(ns("add_lines"), FALSE))
+ aes_string(x = x_axis, y = y_axis, label = "label"), |
| 604 | +698 | ! |
- shinyjs::hide("alpha")
+ nudge_x = 0.1, nudge_y = 0.05, |
| 605 | +699 | ! |
- shinyjs::hide("fixed_size")
+ fontface = "bold" |
| 606 | -! | +||
| 700 | +
- shinyjs::hide("size_settings")
+ ) + |
||
| 607 | +701 | ! |
- alpha <- 1+ geom_path(aes(x, y, group = 1), data = circle_data) + |
| 608 | +702 | ! |
- size <- NULL+ geom_point(aes(x = x, y = y), data = data.frame(x = 0, y = 0), shape = "x", size = 5) + |
| 609 | -+ | ||
| 703 | +! |
- }+ labs + |
|
| 610 | -+ | ||
| 704 | +! |
-
+ ggthemes + |
|
| 611 | +705 | ! |
- teal::validate_has_data(ANL[, c(x_name, y_name), drop = FALSE], 3, complete = TRUE, allow_inf = FALSE)+ themes |
| 612 | +706 |
-
+ }, |
|
| 613 | +707 | ! |
- cl <- bivariate_plot_call(+ env = list( |
| 614 | +708 | ! |
- data_name = "ANL",+ x_axis = x_axis, |
| 615 | +709 | ! |
- x = x_name,+ y_axis = y_axis, |
| 616 | +710 | ! |
- y = y_name,+ variables = variables, |
| 617 | +711 | ! |
- x_class = ifelse(!identical(x_name, character(0)), class(ANL[[x_name]]), "NULL"),+ ggthemes = parsed_ggplot2_args$ggtheme, |
| 618 | +712 | ! |
- y_class = ifelse(!identical(y_name, character(0)), class(ANL[[y_name]]), "NULL"),+ labs = `if`(is.null(parsed_ggplot2_args$labs), quote(labs()), parsed_ggplot2_args$labs), |
| 619 | +713 | ! |
- x_label = varname_w_label(x_name, ANL),+ themes = parsed_ggplot2_args$theme |
| 620 | -! | +||
| 714 | +
- y_label = varname_w_label(y_name, ANL),+ ) |
||
| 621 | -! | +||
| 715 | +
- freq = !use_density,+ ) |
||
| 622 | -! | +||
| 716 | +
- theme = ggtheme,+ ) |
||
| 623 | -! | +||
| 717 | +
- rotate_xaxis_labels = rotate_xaxis_labels,+ } |
||
| 624 | -! | +||
| 718 | +
- swap_axes = swap_axes,+ |
||
| 625 | -! | +||
| 719 | +
- alpha = alpha,+ # plot biplot ---- |
||
| 626 | +720 | ! |
- size = size,+ plot_biplot <- function(base_q) {
|
| 627 | +721 | ! |
- ggplot2_args = ggplot2_args- |
-
| 628 | -- |
- )+ qenv <- base_q |
|
| 629 | +722 | ||
| 630 | +723 | ! |
- facetting <- (isTRUE(input$facetting) && (!is.null(row_facet_name) || !is.null(col_facet_name)))+ ANL <- qenv[["ANL"]] |
| 631 | +724 | ||
| 632 | +725 | ! |
- if (facetting) {
+ resp_col <- as.character(merged$anl_input_r()$columns_source$response) |
| 633 | +726 | ! |
- facet_cl <- facet_ggplot_call(row_facet_name, col_facet_name, free_x_scales, free_y_scales)+ dat_cols <- as.character(merged$anl_input_r()$columns_source$dat) |
| 634 | -+ | ||
| 727 | +! |
-
+ x_axis <- input$x_axis |
|
| 635 | +728 | ! |
- if (!is.null(facet_cl)) {
+ y_axis <- input$y_axis |
| 636 | +729 | ! |
- cl <- call("+", cl, facet_cl)
+ variables <- input$variables |
| 637 | -+ | ||
| 730 | +! |
- }+ pca <- qenv[["pca"]] |
|
| 638 | +731 |
- }+ + |
+ |
| 732 | +! | +
+ ggtheme <- input$ggtheme |
|
| 639 | +733 | ||
| 640 | +734 | ! |
- if (input$add_lines) {
+ rotate_xaxis_labels <- input$rotate_xaxis_labels |
| 641 | +735 | ! |
- cl <- call("+", cl, quote(geom_line(size = 1)))
+ alpha <- input$alpha |
| 642 | -+ | ||
| 736 | +! |
- }+ size <- input$size+ |
+ |
| 737 | +! | +
+ font_size <- input$font_size |
|
| 643 | +738 | ||
| 644 | +739 | ! |
- coloring_cl <- NULL+ qenv <- teal.code::eval_code( |
| 645 | +740 | ! |
- if (color_settings) {
+ qenv, |
| 646 | +741 | ! |
- if (input$coloring) {
+ substitute( |
| 647 | +742 | ! |
- coloring_cl <- coloring_ggplot_call(+ expr = pca_rot <- dplyr::as_tibble(pca$x[, c(x_axis, y_axis)]), |
| 648 | +743 | ! |
- colour = color_name,+ env = list(x_axis = x_axis, y_axis = y_axis) |
| 649 | -! | +||
| 744 | +
- fill = fill_name,+ ) |
||
| 650 | -! | +||
| 745 | +
- size = size_name,+ ) |
||
| 651 | -! | +||
| 746 | +
- is_point = any(grepl("geom_point", cl %>% deparse()))
+
|
||
| 652 | +747 |
- )+ # rot_vars = data frame that displays arrows in the plot, need to be scaled to data |
|
| 653 | +748 | ! |
- legend_lbls <- substitute(+ if (!is.null(input$variables)) {
|
| 654 | +749 | ! |
- expr = labs(color = color_name, fill = fill_name, size = size_name),+ qenv <- teal.code::eval_code( |
| 655 | +750 | ! |
- env = list(+ qenv, |
| 656 | +751 | ! |
- color_name = varname_w_label(color_name, ANL),+ substitute( |
| 657 | +752 | ! |
- fill_name = varname_w_label(fill_name, ANL),+ expr = {
|
| 658 | +753 | ! |
- size_name = varname_w_label(size_name, ANL)+ r <- sqrt(qchisq(0.69, df = 2)) * prod(colMeans(pca_rot ^ 2)) ^ (1 / 4) # styler: off |
| 659 | -+ | ||
| 754 | +! |
- )+ v_scale <- rowSums(pca$rotation ^ 2) # styler: off |
|
| 660 | +755 |
- )+ |
|
| 661 | -+ | ||
| 756 | +! |
- }+ rot_vars <- pca$rotation[, c(x_axis, y_axis)] %>% |
|
| 662 | +757 | ! |
- if (!is.null(coloring_cl)) {
+ dplyr::as_tibble(rownames = "label") %>% |
| 663 | +758 | ! |
- cl <- call("+", call("+", cl, coloring_cl), legend_lbls)
+ dplyr::mutate_at(vars(c(x_axis, y_axis)), function(x) r * x / sqrt(max(v_scale))) |
| 664 | +759 |
- }+ },+ |
+ |
| 760 | +! | +
+ env = list(x_axis = x_axis, y_axis = y_axis) |
|
| 665 | +761 |
- }+ ) |
|
| 666 | +762 |
-
+ ) %>% |
|
| 667 | +763 | ! |
- teal.code::eval_code(merged$anl_q_r(), substitute(expr = plot <- cl, env = list(cl = cl)))+ teal.code::eval_code( |
| 668 | -+ | ||
| 764 | +! |
- })+ if (is.logical(pca$center) && !pca$center) {
|
|
| 669 | -+ | ||
| 765 | +! |
-
+ substitute( |
|
| 670 | +766 | ! |
- decorated_output_q_facets <- srv_decorate_teal_data(+ expr = {
|
| 671 | +767 | ! |
- "decorator",+ rot_vars <- rot_vars %>% |
| 672 | +768 | ! |
- data = output_q,+ tibble::column_to_rownames("label") %>%
|
| 673 | +769 | ! |
- decorators = select_decorators(decorators, "plot"),+ sweep(1, apply(ANL[keep_columns], 2, mean, na.rm = TRUE)) %>% |
| 674 | +770 | ! |
- expr = reactive({
+ tibble::rownames_to_column("label") %>%
|
| 675 | +771 | ! |
- ANL <- merged$anl_q_r()[["ANL"]]+ dplyr::mutate( |
| 676 | +772 | ! |
- row_facet_name <- as.vector(merged$anl_input_r()$columns_source$row_facet)+ xstart = mean(pca$x[, x_axis], na.rm = TRUE), |
| 677 | +773 | ! |
- col_facet_name <- as.vector(merged$anl_input_r()$columns_source$col_facet)+ ystart = mean(pca$x[, y_axis], na.rm = TRUE) |
| 678 | +774 |
-
+ ) |
|
| 679 | +775 |
- # Add labels to facets+ }, |
|
| 680 | +776 | ! |
- nulled_row_facet_name <- varname_w_label(row_facet_name, ANL)+ env = list(x_axis = x_axis, y_axis = y_axis) |
| 681 | -! | +||
| 777 | +
- nulled_col_facet_name <- varname_w_label(col_facet_name, ANL)+ ) |
||
| 682 | -! | +||
| 778 | +
- facetting <- (isTRUE(input$facetting) && (!is.null(row_facet_name) || !is.null(col_facet_name)))+ } else {
|
||
| 683 | +779 | ! |
- without_facet <- (is.null(nulled_row_facet_name) && is.null(nulled_col_facet_name)) || !facetting+ quote(rot_vars <- rot_vars %>% dplyr::mutate(xstart = 0, ystart = 0)) |
| 684 | +780 |
-
+ } |
|
| 685 | -! | +||
| 781 | +
- print_call <- if (without_facet) {
+ ) %>% |
||
| 686 | +782 | ! |
- quote(print(plot))+ teal.code::eval_code( |
| 687 | -+ | ||
| 783 | +! |
- } else {
+ substitute( |
|
| 688 | +784 | ! |
- substitute(+ expr = rot_vars <- rot_vars %>% dplyr::filter(label %in% variables), |
| 689 | +785 | ! |
- expr = {
+ env = list(variables = variables) |
| 690 | +786 |
- # Add facetting labels+ ) |
|
| 691 | +787 |
- # optional: grid.newpage() # nolint: commented_code.+ ) |
|
| 692 | +788 |
- # Prefixed with teal.modules.general as its usage will appear in "Show R code"+ } |
|
| 693 | -! | +||
| 789 | +
- plot <- teal.modules.general::add_facet_labels(+ |
||
| 694 | +790 | ! |
- plot,+ pca_plot_biplot_expr <- list(quote(ggplot())) |
| 695 | -! | +||
| 791 | +
- xfacet_label = nulled_col_facet_name,+ |
||
| 696 | +792 | ! |
- yfacet_label = nulled_row_facet_name+ if (length(resp_col) == 0) {
|
| 697 | -+ | ||
| 793 | +! |
- )+ pca_plot_biplot_expr <- c( |
|
| 698 | +794 | ! |
- grid::grid.newpage()+ pca_plot_biplot_expr, |
| 699 | +795 | ! |
- grid::grid.draw(plot)+ substitute( |
| 700 | -+ | ||
| 796 | +! |
- },+ geom_point(aes_string(x = x_axis, y = y_axis), data = pca_rot, alpha = alpha, size = size), |
|
| 701 | +797 | ! |
- env = list(nulled_col_facet_name = nulled_col_facet_name, nulled_row_facet_name = nulled_row_facet_name)+ list(x_axis = input$x_axis, y_axis = input$y_axis, alpha = input$alpha, size = input$size) |
| 702 | +798 |
) |
|
| 703 | +799 |
- }+ ) |
|
| 704 | +800 | ! |
- print_call+ dev_labs <- list() |
| 705 | +801 |
- }),+ } else {
|
|
| 706 | +802 | ! |
- expr_is_reactive = TRUE- |
-
| 707 | -- |
- )+ rp_keys <- setdiff(colnames(ANL), as.character(unlist(merged$anl_input_r()$columns_source))) |
|
| 708 | +803 | ||
| 709 | +804 | ! |
- plot_r <- reactive(req(decorated_output_q_facets())[["plot"]])+ response <- ANL[[resp_col]] |
| 710 | +805 | ||
| 711 | -! | -
- pws <- teal.widgets::plot_with_settings_srv(- |
- |
| 712 | -! | -
- id = "myplot",- |
- |
| 713 | +806 | ! |
- plot_r = plot_r,+ aes_biplot <- substitute( |
| 714 | +807 | ! |
- height = plot_height,+ aes_string(x = x_axis, y = y_axis, color = "response"), |
| 715 | +808 | ! |
- width = plot_width+ env = list(x_axis = x_axis, y_axis = y_axis) |
| 716 | +809 |
- )+ ) |
|
| 717 | +810 | ||
| 718 | +811 | ! |
- teal.widgets::verbatim_popup_srv(+ qenv <- teal.code::eval_code( |
| 719 | +812 | ! |
- id = "rcode",+ qenv, |
| 720 | +813 | ! |
- verbatim_content = reactive(teal.code::get_code(req(decorated_output_q_facets()))),+ substitute(response <- ANL[[resp_col]], env = list(resp_col = resp_col)) |
| 721 | -! | +||
| 814 | +
- title = "Bivariate Plot"+ ) |
||
| 722 | +815 |
- )+ + |
+ |
| 816 | +! | +
+ dev_labs <- list(color = varname_w_label(resp_col, ANL)) |
|
| 723 | +817 | ||
| 724 | -+ | ||
| 818 | +! |
- ### REPORTER+ scales_biplot <- |
|
| 725 | +819 | ! |
- if (with_reporter) {
+ if ( |
| 726 | +820 | ! |
- card_fun <- function(comment, label) {
+ is.character(response) || |
| 727 | +821 | ! |
- card <- teal::report_card_template(+ is.factor(response) || |
| 728 | +822 | ! |
- title = "Bivariate Plot",+ (is.numeric(response) && length(unique(response)) <= 6)+ |
+
| 823 | ++ |
+ ) {
|
|
| 729 | +824 | ! |
- label = label,+ qenv <- teal.code::eval_code( |
| 730 | +825 | ! |
- with_filter = with_filter,+ qenv, |
| 731 | +826 | ! |
- filter_panel_api = filter_panel_api+ quote(pca_rot$response <- as.factor(response)) |
| 732 | +827 |
- )+ ) |
|
| 733 | +828 | ! |
- card$append_text("Plot", "header3")
+ quote(scale_color_brewer(palette = "Dark2")) |
| 734 | +829 | ! |
- card$append_plot(plot_r(), dim = pws$dim())+ } else if (inherits(response, "Date")) {
|
| 735 | +830 | ! |
- if (!comment == "") {
+ qenv <- teal.code::eval_code( |
| 736 | +831 | ! |
- card$append_text("Comment", "header3")
+ qenv, |
| 737 | +832 | ! |
- card$append_text(comment)+ quote(pca_rot$response <- numeric(response)) |
| 738 | +833 |
- }+ )+ |
+ |
| 834 | ++ | + | |
| 739 | +835 | ! |
- card$append_src(teal.code::get_code(req(decorated_output_q_facets)))+ quote( |
| 740 | +836 | ! |
- card+ scale_color_gradient( |
| 741 | -+ | ||
| 837 | +! |
- }+ low = c(getOption("ggplot2.discrete.colour")[2], "darkred")[1],
|
|
| 742 | +838 | ! |
- teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
+ high = c(getOption("ggplot2.discrete.colour"), "lightblue")[1],
|
| 743 | -+ | ||
| 839 | +! |
- }+ labels = function(x) as.Date(x, origin = "1970-01-01") |
|
| 744 | +840 |
- ###+ ) |
|
| 745 | +841 |
- })+ ) |
|
| 746 | +842 |
- }+ } else {
|
|
| 747 | -+ | ||
| 843 | +! |
-
+ qenv <- teal.code::eval_code( |
|
| 748 | -+ | ||
| 844 | +! |
- # Get Substituted ggplot call+ qenv, |
|
| 749 | -+ | ||
| 845 | +! |
- bivariate_plot_call <- function(data_name,+ quote(pca_rot$response <- response) |
|
| 750 | +846 |
- x = character(0),+ ) |
|
| 751 | -+ | ||
| 847 | +! |
- y = character(0),+ quote(scale_color_gradient( |
|
| 752 | -+ | ||
| 848 | +! |
- x_class = "NULL",+ low = c(getOption("ggplot2.discrete.colour")[2], "darkred")[1],
|
|
| 753 | -+ | ||
| 849 | +! |
- y_class = "NULL",+ high = c(getOption("ggplot2.discrete.colour"), "lightblue")[1]
|
|
| 754 | +850 |
- x_label = NULL,+ )) |
|
| 755 | +851 |
- y_label = NULL,+ } |
|
| 756 | +852 |
- freq = TRUE,+ |
|
| 757 | -+ | ||
| 853 | +! |
- theme = "gray",+ pca_plot_biplot_expr <- c( |
|
| 758 | -+ | ||
| 854 | +! |
- rotate_xaxis_labels = FALSE,+ pca_plot_biplot_expr, |
|
| 759 | -+ | ||
| 855 | +! |
- swap_axes = FALSE,+ substitute( |
|
| 760 | -+ | ||
| 856 | +! |
- alpha = double(0),+ geom_point(aes_biplot, data = pca_rot, alpha = alpha, size = size), |
|
| 761 | -+ | ||
| 857 | +! |
- size = 2,+ env = list(aes_biplot = aes_biplot, alpha = alpha, size = size) |
|
| 762 | +858 |
- ggplot2_args = teal.widgets::ggplot2_args()) {
- |
- |
| 763 | -! | -
- supported_types <- c("NULL", "numeric", "integer", "factor", "character", "logical", "ordered")
+ ), |
|
| 764 | +859 | ! |
- validate(need(x_class %in% supported_types, paste0("Data type '", x_class, "' is not supported.")))
+ scales_biplot |
| 765 | -! | +||
| 860 | +
- validate(need(y_class %in% supported_types, paste0("Data type '", y_class, "' is not supported.")))
+ ) |
||
| 766 | +861 |
-
+ } |
|
| 767 | +862 | ||
| 768 | +863 | ! |
- if (identical(x, character(0))) {
+ if (!is.null(input$variables)) {
|
| 769 | +864 | ! |
- x <- x_label <- "-"+ pca_plot_biplot_expr <- c( |
| 770 | -+ | ||
| 865 | +! |
- } else {
+ pca_plot_biplot_expr, |
|
| 771 | +866 | ! |
- x <- if (is.call(x)) x else as.name(x)+ substitute( |
| 772 | -+ | ||
| 867 | +! |
- }+ geom_segment( |
|
| 773 | +868 | ! |
- if (identical(y, character(0))) {
+ aes_string(x = "xstart", y = "ystart", xend = x_axis, yend = y_axis), |
| 774 | +869 | ! |
- y <- y_label <- "-"+ data = rot_vars, |
| 775 | -+ | ||
| 870 | +! |
- } else {
+ lineend = "round", linejoin = "round", |
|
| 776 | +871 | ! |
- y <- if (is.call(y)) y else as.name(y)+ arrow = grid::arrow(length = grid::unit(0.5, "cm")) |
| 777 | +872 |
- }+ ),+ |
+ |
| 873 | +! | +
+ env = list(x_axis = x_axis, y_axis = y_axis) |
|
| 778 | +874 |
-
+ ), |
|
| 779 | +875 | ! |
- cl <- bivariate_ggplot_call(+ substitute( |
| 780 | +876 | ! |
- x_class = x_class,+ geom_label( |
| 781 | +877 | ! |
- y_class = y_class,+ aes_string( |
| 782 | +878 | ! |
- freq = freq,+ x = x_axis, |
| 783 | +879 | ! |
- theme = theme,+ y = y_axis, |
| 784 | +880 | ! |
- rotate_xaxis_labels = rotate_xaxis_labels,+ label = "label" |
| 785 | -! | +||
| 881 | +
- swap_axes = swap_axes,+ ), |
||
| 786 | +882 | ! |
- alpha = alpha,+ data = rot_vars, |
| 787 | +883 | ! |
- size = size,+ nudge_y = 0.1, |
| 788 | +884 | ! |
- ggplot2_args = ggplot2_args,- |
-
| 789 | -! | -
- x = x,+ fontface = "bold" |
|
| 790 | -! | +||
| 885 | +
- y = y,+ ), |
||
| 791 | +886 | ! |
- xlab = x_label,+ env = list(x_axis = x_axis, y_axis = y_axis) |
| 792 | -! | +||
| 887 | +
- ylab = y_label,+ ), |
||
| 793 | +888 | ! |
- data_name = data_name+ quote(geom_point(aes(x = xstart, y = ystart), data = rot_vars, shape = "x", size = 5)) |
| 794 | +889 |
- )+ ) |
|
| 795 | +890 |
- }+ } |
|
| 796 | +891 | ||
| 797 | -- |
- # Create ggplot part of plot call- |
- |
| 798 | -+ | ||
| 892 | +! |
- # Due to the type of the x and y variable the plot type is chosen+ angle <- ifelse(isTRUE(rotate_xaxis_labels), 45, 0) |
|
| 799 | -+ | ||
| 893 | +! |
- bivariate_ggplot_call <- function(x_class,+ hjust <- ifelse(isTRUE(rotate_xaxis_labels), 1, 0.5) |
|
| 800 | +894 |
- y_class,+ |
|
| 801 | -+ | ||
| 895 | +! |
- freq = TRUE,+ dev_ggplot2_args <- teal.widgets::ggplot2_args( |
|
| 802 | -+ | ||
| 896 | +! |
- theme = "gray",+ labs = dev_labs, |
|
| 803 | -+ | ||
| 897 | +! |
- rotate_xaxis_labels = FALSE,+ theme = list( |
|
| 804 | -+ | ||
| 898 | +! |
- swap_axes = FALSE,+ text = substitute(element_text(size = font_size), list(font_size = font_size)), |
|
| 805 | -+ | ||
| 899 | +! |
- size = double(0),+ axis.text.x = substitute( |
|
| 806 | -+ | ||
| 900 | +! |
- alpha = double(0),+ element_text(angle = angle_val, hjust = hjust_val), |
|
| 807 | -+ | ||
| 901 | +! |
- x = NULL,+ list(angle_val = angle, hjust_val = hjust) |
|
| 808 | +902 |
- y = NULL,+ ) |
|
| 809 | +903 |
- xlab = "-",+ ) |
|
| 810 | +904 |
- ylab = "-",+ ) |
|
| 811 | +905 |
- data_name = "ANL",+ |
|
| 812 | -+ | ||
| 906 | +! |
- ggplot2_args = teal.widgets::ggplot2_args()) {
+ all_ggplot2_args <- teal.widgets::resolve_ggplot2_args( |
|
| 813 | -42x | +||
| 907 | +! |
- x_class <- switch(x_class,+ user_plot = ggplot2_args[["Biplot"]], |
|
| 814 | -42x | +||
| 908 | +! |
- "character" = ,+ user_default = ggplot2_args$default, |
|
| 815 | -42x | +||
| 909 | +! |
- "ordered" = ,+ module_plot = dev_ggplot2_args |
|
| 816 | -42x | +||
| 910 | +
- "logical" = ,+ ) |
||
| 817 | -42x | +||
| 911 | +
- "factor" = "factor",+ |
||
| 818 | -42x | +||
| 912 | +! |
- "integer" = ,+ parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args( |
|
| 819 | -42x | +||
| 913 | +! |
- "numeric" = "numeric",+ all_ggplot2_args, |
|
| 820 | -42x | +||
| 914 | +! |
- "NULL" = "NULL",+ ggtheme = ggtheme |
|
| 821 | -42x | +||
| 915 | +
- stop("unsupported x_class: ", x_class)
+ ) |
||
| 822 | +916 |
- )+ |
|
| 823 | -42x | +||
| 917 | +! |
- y_class <- switch(y_class,+ pca_plot_biplot_expr <- c( |
|
| 824 | -42x | +||
| 918 | +! |
- "character" = ,+ pca_plot_biplot_expr, |
|
| 825 | -42x | +||
| 919 | +! |
- "ordered" = ,+ parsed_ggplot2_args |
|
| 826 | -42x | +||
| 920 | +
- "logical" = ,+ ) |
||
| 827 | -42x | +||
| 921 | +
- "factor" = "factor",+ |
||
| 828 | -42x | +||
| 922 | +! |
- "integer" = ,+ teal.code::eval_code( |
|
| 829 | -42x | +||
| 923 | +! |
- "numeric" = "numeric",+ qenv, |
|
| 830 | -42x | +||
| 924 | +! |
- "NULL" = "NULL",+ substitute( |
|
| 831 | -42x | +||
| 925 | +! |
- stop("unsupported y_class: ", y_class)
+ expr = {
|
|
| 832 | -+ | ||
| 926 | +! |
- )+ biplot <- plot_call |
|
| 833 | +927 |
-
+ }, |
|
| 834 | -42x | +||
| 928 | +! |
- if (all(c(x_class, y_class) == "NULL")) {
+ env = list( |
|
| 835 | +929 | ! |
- stop("either x or y is required")
+ plot_call = Reduce(function(x, y) call("+", x, y), pca_plot_biplot_expr)
|
| 836 | +930 |
- }+ ) |
|
| 837 | +931 | - - | -|
| 838 | -42x | -
- reduce_plot_call <- function(...) {
- |
- |
| 839 | -104x | -
- args <- Filter(Negate(is.null), list(...))+ ) |
|
| 840 | -104x | +||
| 932 | +
- Reduce(function(x, y) call("+", x, y), args)
+ ) |
||
| 841 | +933 |
- }+ } |
|
| 842 | +934 | ||
| 843 | -42x | -
- plot_call <- substitute(ggplot(data_name), env = list(data_name = as.name(data_name)))- |
- |
| 844 | +935 |
-
+ # plot eigenvector_plot ---- |
|
| 845 | -+ | ||
| 936 | +! |
- # Single data plots+ plot_eigenvector <- function(base_q) {
|
|
| 846 | -42x | +||
| 937 | +! |
- if (x_class == "numeric" && y_class == "NULL") {
+ pc <- input$pc |
|
| 847 | -6x | +||
| 938 | +! |
- plot_call <- reduce_plot_call(plot_call, substitute(aes(x = xval), env = list(xval = x)))+ ggtheme <- input$ggtheme |
|
| 848 | +939 | ||
| 849 | -6x | +||
| 940 | +! |
- if (freq) {
+ rotate_xaxis_labels <- input$rotate_xaxis_labels |
|
| 850 | -4x | +||
| 941 | +! |
- plot_call <- reduce_plot_call(+ font_size <- input$font_size |
|
| 851 | -4x | +||
| 942 | +
- plot_call,+ |
||
| 852 | -4x | +||
| 943 | +! |
- quote(geom_histogram(bins = 30)),+ angle <- ifelse(rotate_xaxis_labels, 45, 0) |
|
| 853 | -4x | +||
| 944 | +! |
- quote(ylab("Frequency"))
+ hjust <- ifelse(rotate_xaxis_labels, 1, 0.5) |
|
| 854 | +945 |
- )+ |
|
| 855 | -+ | ||
| 946 | +! |
- } else {
+ dev_ggplot2_args <- teal.widgets::ggplot2_args( |
|
| 856 | -2x | +||
| 947 | +! |
- plot_call <- reduce_plot_call(+ theme = list( |
|
| 857 | -2x | +||
| 948 | +! |
- plot_call,+ text = substitute(element_text(size = font_size), list(font_size = font_size)), |
|
| 858 | -2x | +||
| 949 | +! |
- quote(geom_histogram(bins = 30, aes(y = after_stat(density)))),+ axis.text.x = substitute( |
|
| 859 | -2x | +||
| 950 | +! |
- quote(geom_density(aes(y = after_stat(density)))),+ element_text(angle = angle_val, hjust = hjust_val), |
|
| 860 | -2x | +||
| 951 | +! |
- quote(ylab("Density"))
+ list(angle_val = angle, hjust_val = hjust) |
|
| 861 | +952 |
- )+ ) |
|
| 862 | +953 |
- }- |
- |
| 863 | -36x | -
- } else if (x_class == "NULL" && y_class == "numeric") {
+ ) |
|
| 864 | -6x | +||
| 954 | +
- plot_call <- reduce_plot_call(plot_call, substitute(aes(x = yval), env = list(yval = y)))+ ) |
||
| 865 | +955 | ||
| 866 | -6x | +||
| 956 | +! |
- if (freq) {
+ all_ggplot2_args <- teal.widgets::resolve_ggplot2_args( |
|
| 867 | -4x | +||
| 957 | +! |
- plot_call <- reduce_plot_call(+ user_plot = ggplot2_args[["Eigenvector plot"]], |
|
| 868 | -4x | +||
| 958 | +! |
- plot_call,+ user_default = ggplot2_args$default, |
|
| 869 | -4x | +||
| 959 | +! |
- quote(geom_histogram(bins = 30)),+ module_plot = dev_ggplot2_args |
|
| 870 | -4x | +||
| 960 | +
- quote(ylab("Frequency"))
+ ) |
||
| 871 | +961 | ++ | + + | +
| 962 | +! | +
+ parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(+ |
+ |
| 963 | +! | +
+ all_ggplot2_args,+ |
+ |
| 964 | +! | +
+ ggtheme = ggtheme+ |
+ |
| 965 |
) |
||
| 872 | +966 |
- } else {
+
|
|
| 873 | -2x | +||
| 967 | +! |
- plot_call <- reduce_plot_call(+ ggplot_exprs <- c( |
|
| 874 | -2x | +||
| 968 | +! |
- plot_call,+ list( |
|
| 875 | -2x | +||
| 969 | +! |
- quote(geom_histogram(bins = 30, aes(y = after_stat(density)))),+ quote(ggplot(pca_rot)), |
|
| 876 | -2x | +||
| 970 | +! |
- quote(geom_density(aes(y = after_stat(density)))),+ substitute( |
|
| 877 | -2x | +||
| 971 | +! |
- quote(ylab("Density"))
+ geom_bar(+ |
+ |
| 972 | +! | +
+ aes_string(x = "Variable", y = pc),+ |
+ |
| 973 | +! | +
+ stat = "identity",+ |
+ |
| 974 | +! | +
+ color = "black",+ |
+ |
| 975 | +! | +
+ fill = c(getOption("ggplot2.discrete.colour"), "lightblue")[1]
|
|
| 878 | +976 |
- )+ ),+ |
+ |
| 977 | +! | +
+ env = list(pc = pc) |
|
| 879 | +978 |
- }+ ), |
|
| 880 | -30x | +||
| 979 | +! |
- } else if (x_class == "factor" && y_class == "NULL") {
+ substitute( |
|
| 881 | -4x | +||
| 980 | +! |
- plot_call <- reduce_plot_call(plot_call, substitute(aes(x = xval), env = list(xval = x)))+ geom_text(+ |
+ |
| 981 | +! | +
+ aes(+ |
+ |
| 982 | +! | +
+ x = Variable,+ |
+ |
| 983 | +! | +
+ y = pc_name,+ |
+ |
| 984 | +! | +
+ label = round(pc_name, 3),+ |
+ |
| 985 | +! | +
+ vjust = ifelse(pc_name > 0, -0.5, 1.3) |
|
| 882 | +986 |
-
+ ) |
|
| 883 | -4x | +||
| 987 | +
- if (freq) {
+ ), |
||
| 884 | -2x | +||
| 988 | +! |
- plot_call <- reduce_plot_call(+ env = list(pc_name = as.name(pc)) |
|
| 885 | -2x | +||
| 989 | +
- plot_call,+ ) |
||
| 886 | -2x | +||
| 990 | +
- quote(geom_bar()),+ ), |
||
| 887 | -2x | +||
| 991 | +! |
- quote(ylab("Frequency"))
+ parsed_ggplot2_args$labs,+ |
+ |
| 992 | +! | +
+ parsed_ggplot2_args$ggtheme,+ |
+ |
| 993 | +! | +
+ parsed_ggplot2_args$theme |
|
| 888 | +994 |
) |
|
| 889 | +995 |
- } else {
+
|
|
| 890 | -2x | +||
| 996 | +! |
- plot_call <- reduce_plot_call(+ teal.code::eval_code( |
|
| 891 | -2x | +||
| 997 | +! |
- plot_call,+ base_q, |
|
| 892 | -2x | +||
| 998 | +! |
- quote(geom_bar(aes(y = after_stat(prop), group = 1))),+ substitute( |
|
| 893 | -2x | +||
| 999 | +! |
- quote(ylab("Fraction"))
+ expr = {
+ |
+ |
| 1000 | +! | +
+ pca_rot <- pca$rotation[, pc, drop = FALSE] %>%+ |
+ |
| 1001 | +! | +
+ dplyr::as_tibble(rownames = "Variable")+ |
+ |
| 1002 | +! | +
+ eigenvector_plot <- plot_call |
|
| 894 | +1003 | ++ |
+ },+ |
+
| 1004 | +! | +
+ env = list(+ |
+ |
| 1005 | +! | +
+ pc = pc,+ |
+ |
| 1006 | +! | +
+ plot_call = Reduce(function(x, y) call("+", x, y), ggplot_exprs)
+ |
+ |
| 1007 | ++ |
+ )+ |
+ |
| 1008 | ++ |
+ )+ |
+ |
| 1009 |
) |
||
| 895 | +1010 |
} |
|
| 896 | -26x | +||
| 1011 | +
- } else if (x_class == "NULL" && y_class == "factor") {
+
|
||
| 897 | -4x | +||
| 1012 | +
- plot_call <- reduce_plot_call(plot_call, substitute(aes(x = yval), env = list(yval = y)))+ # qenvs ---+ |
+ ||
| 1013 | +! | +
+ output_q <- lapply(+ |
+ |
| 1014 | +! | +
+ list(+ |
+ |
| 1015 | +! | +
+ elbow_plot = plot_elbow,+ |
+ |
| 1016 | +! | +
+ circle_plot = plot_circle,+ |
+ |
| 1017 | +! | +
+ biplot = plot_biplot,+ |
+ |
| 1018 | +! | +
+ eigenvector_plot = plot_eigenvector |
|
| 898 | +1019 |
-
+ ), |
|
| 899 | -4x | +||
| 1020 | +! |
- if (freq) {
+ function(fun) {
|
|
| 900 | -2x | +||
| 1021 | +! |
- plot_call <- reduce_plot_call(+ reactive({
|
|
| 901 | -2x | +||
| 1022 | +! |
- plot_call,+ req(computation()) |
|
| 902 | -2x | +||
| 1023 | +! |
- quote(geom_bar()),+ teal::validate_inputs(iv_r()) |
|
| 903 | -2x | +||
| 1024 | +! |
- quote(ylab("Frequency"))
+ teal::validate_inputs(iv_extra, header = "Plot settings are required")+ |
+ |
| 1025 | +! | +
+ fun(computation()) |
|
| 904 | +1026 |
- )+ }) |
|
| 905 | +1027 |
- } else {
+ } |
|
| 906 | -2x | +||
| 1028 | +
- plot_call <- reduce_plot_call(+ ) |
||
| 907 | -2x | +||
| 1029 | +
- plot_call,+ |
||
| 908 | -2x | +||
| 1030 | +! |
- quote(geom_bar(aes(y = after_stat(prop), group = 1))),+ decorated_q <- mapply( |
|
| 909 | -2x | +||
| 1031 | +! |
- quote(ylab("Fraction"))
+ function(obj_name, q) {
+ |
+ |
| 1032 | +! | +
+ srv_decorate_teal_data(+ |
+ |
| 1033 | +! | +
+ id = sprintf("d_%s", obj_name),
+ |
+ |
| 1034 | +! | +
+ data = q,+ |
+ |
| 1035 | +! | +
+ decorators = select_decorators(decorators, obj_name),+ |
+ |
| 1036 | +! | +
+ expr = reactive({
+ |
+ |
| 1037 | +! | +
+ substitute(print(.plot), env = list(.plot = as.name(obj_name))) |
|
| 910 | +1038 |
- )+ }),+ |
+ |
| 1039 | +! | +
+ expr_is_reactive = TRUE |
|
| 911 | +1040 |
- }+ ) |
|
| 912 | +1041 |
- # Numeric Plots+ }, |
|
| 913 | -22x | +||
| 1042 | +! |
- } else if (x_class == "numeric" && y_class == "numeric") {
+ names(output_q), |
|
| 914 | -2x | +||
| 1043 | +! |
- plot_call <- reduce_plot_call(+ output_q |
|
| 915 | -2x | +||
| 1044 | +
- plot_call,+ ) |
||
| 916 | -2x | +||
| 1045 | +
- substitute(aes(x = xval, y = yval), env = list(xval = x, yval = y)),+ |
||
| 917 | +1046 |
- # pch = 21 for consistent coloring behaviour b/w all geoms (outline and fill properties)+ # plot final ---- |
|
| 918 | -2x | +||
| 1047 | +! |
- `if`(+ decorated_output_q <- reactive({
+ |
+ |
| 1048 | +! | +
+ switch(req(input$plot_type),+ |
+ |
| 1049 | +! | +
+ "Elbow plot" = decorated_q$elbow_plot(),+ |
+ |
| 1050 | +! | +
+ "Circle plot" = decorated_q$circle_plot(),+ |
+ |
| 1051 | +! | +
+ "Biplot" = decorated_q$biplot(), |
|
| 919 | -2x | +||
| 1052 | +! |
- !is.null(size),+ "Eigenvector plot" = decorated_q$eigenvector_plot(), |
|
| 920 | -2x | +||
| 1053 | +! |
- substitute(+ stop("Unknown plot")
|
|
| 921 | -2x | +||
| 1054 | +
- geom_point(alpha = alphaval, size = sizeval, pch = 21),+ ) |
||
| 922 | -2x | +||
| 1055 | +
- env = list(alphaval = alpha, sizeval = size)+ }) |
||
| 923 | +1056 |
- ),+ |
|
| 924 | -2x | +||
| 1057 | +! |
- substitute(+ plot_r <- reactive({
|
|
| 925 | -2x | +||
| 1058 | +! |
- geom_point(alpha = alphaval, pch = 21),+ plot_name <- gsub(" ", "_", tolower(req(input$plot_type)))
|
|
| 926 | -2x | +||
| 1059 | +! |
- env = list(alphaval = alpha)+ req(decorated_output_q())[[plot_name]] |
|
| 927 | +1060 |
- )+ }) |
|
| 928 | +1061 |
- )+ |
|
| 929 | -+ | ||
| 1062 | +! |
- )+ pws <- teal.widgets::plot_with_settings_srv( |
|
| 930 | -20x | +||
| 1063 | +! |
- } else if ((x_class == "numeric" && y_class == "factor") || (x_class == "factor" && y_class == "numeric")) {
+ id = "pca_plot", |
|
| 931 | -6x | +||
| 1064 | +! |
- plot_call <- reduce_plot_call(+ plot_r = plot_r, |
|
| 932 | -6x | +||
| 1065 | +! |
- plot_call,+ height = plot_height, |
|
| 933 | -6x | +||
| 1066 | +! |
- substitute(aes(x = xval, y = yval), env = list(xval = x, yval = y)),+ width = plot_width, |
|
| 934 | -6x | +||
| 1067 | +! |
- quote(geom_boxplot())+ graph_align = "center" |
|
| 935 | +1068 |
) |
|
| 936 | +1069 |
- # Factor and character plots- |
- |
| 937 | -14x | -
- } else if (x_class == "factor" && y_class == "factor") {
+
|
|
| 938 | -14x | +||
| 1070 | +
- plot_call <- reduce_plot_call(+ # tables ---- |
||
| 939 | -14x | +||
| 1071 | +! |
- plot_call,+ output$tbl_importance <- renderTable( |
|
| 940 | -14x | +||
| 1072 | +! |
- substitute(+ expr = {
|
|
| 941 | -14x | +||
| 1073 | +! |
- ggmosaic::geom_mosaic(aes(x = ggmosaic::product(xval), fill = yval), na.rm = TRUE),+ req("importance" %in% input$tables_display, computation())
|
|
| 942 | -14x | +||
| 1074 | +! |
- env = list(xval = x, yval = y)+ computation()[["tbl_importance"]] |
|
| 943 | +1075 |
- )+ }, |
|
| 944 | -+ | ||
| 1076 | +! |
- )+ bordered = TRUE, |
|
| 945 | -+ | ||
| 1077 | +! |
- } else {
+ align = "c", |
|
| 946 | +1078 | ! |
- stop("x y type combination not allowed")
+ digits = 3 |
| 947 | +1079 |
- }+ ) |
|
| 948 | +1080 | ||
| 949 | -42x | -
- labs_base <- if (x_class == "NULL") {
- |
- |
| 950 | -10x | +||
| 1081 | +! |
- list(x = substitute(ylab, list(ylab = ylab)))+ output$tbl_importance_ui <- renderUI({
|
|
| 951 | -42x | +||
| 1082 | +! |
- } else if (y_class == "NULL") {
+ req("importance" %in% input$tables_display)
|
|
| 952 | -10x | +||
| 1083 | +! |
- list(x = substitute(xlab, list(xlab = xlab)))+ tags$div( |
|
| 953 | -+ | ||
| 1084 | +! |
- } else {
+ align = "center", |
|
| 954 | -22x | +||
| 1085 | +! |
- list(+ tags$h4("Principal components importance"),
|
|
| 955 | -22x | +||
| 1086 | +! |
- x = substitute(xlab, list(xlab = xlab)),+ tableOutput(session$ns("tbl_importance")),
|
|
| 956 | -22x | +||
| 1087 | +! |
- y = substitute(ylab, list(ylab = ylab))+ tags$hr() |
|
| 957 | +1088 |
- )+ ) |
|
| 958 | +1089 |
- }+ }) |
|
| 959 | +1090 | ||
| 960 | -42x | -
- dev_ggplot2_args <- teal.widgets::ggplot2_args(labs = labs_base)- |
- |
| 961 | -+ | ||
| 1091 | +! |
-
+ output$tbl_eigenvector <- renderTable( |
|
| 962 | -42x | +||
| 1092 | +! |
- if (rotate_xaxis_labels) {
+ expr = {
|
|
| 963 | +1093 | ! |
- dev_ggplot2_args$theme <- list(axis.text.x = quote(element_text(angle = 45, hjust = 1)))+ req("eigenvector" %in% input$tables_display, req(computation()))
|
| 964 | -+ | ||
| 1094 | +! |
- }+ computation()[["tbl_eigenvector"]] |
|
| 965 | +1095 |
-
+ }, |
|
| 966 | -42x | +||
| 1096 | +! |
- all_ggplot2_args <- teal.widgets::resolve_ggplot2_args(+ bordered = TRUE, |
|
| 967 | -42x | +||
| 1097 | +! |
- user_plot = ggplot2_args,+ align = "c", |
|
| 968 | -42x | +||
| 1098 | +! |
- module_plot = dev_ggplot2_args+ digits = 3 |
|
| 969 | +1099 |
- )+ ) |
|
| 970 | +1100 | ||
| 971 | -42x | +||
| 1101 | +! |
- parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(all_ggplot2_args, ggtheme = theme)+ output$tbl_eigenvector_ui <- renderUI({
|
|
| 972 | -+ | ||
| 1102 | +! |
-
+ req("eigenvector" %in% input$tables_display)
|
|
| 973 | -42x | +||
| 1103 | +! |
- plot_call <- reduce_plot_call(+ tags$div( |
|
| 974 | -42x | +||
| 1104 | +! |
- plot_call,+ align = "center", |
|
| 975 | -42x | +||
| 1105 | +! |
- parsed_ggplot2_args$labs,+ tags$h4("Eigenvectors"),
|
|
| 976 | -42x | +||
| 1106 | +! |
- parsed_ggplot2_args$ggtheme,+ tableOutput(session$ns("tbl_eigenvector")),
|
|
| 977 | -42x | +||
| 1107 | +! |
- parsed_ggplot2_args$theme+ tags$hr() |
|
| 978 | +1108 |
- )+ ) |
|
| 979 | +1109 | ++ |
+ })+ |
+
| 1110 | |||
| 980 | -42x | +||
| 1111 | +! |
- if (swap_axes) {
+ output$all_plots <- renderUI({
|
|
| 981 | +1112 | ! |
- plot_call <- reduce_plot_call(plot_call, quote(coord_flip()))+ teal::validate_inputs(iv_r()) |
| 982 | -+ | ||
| 1113 | +! |
- }+ teal::validate_inputs(iv_extra, header = "Plot settings are required") |
|
| 983 | +1114 | ||
| 984 | -42x | +||
| 1115 | +! |
- plot_call+ validation() |
|
| 985 | -+ | ||
| 1116 | +! |
- }+ tags$div(+ |
+ |
| 1117 | +! | +
+ class = "overflow-scroll",+ |
+ |
| 1118 | +! | +
+ uiOutput(session$ns("tbl_importance_ui")),
+ |
+ |
| 1119 | +! | +
+ uiOutput(session$ns("tbl_eigenvector_ui")),
+ |
+ |
| 1120 | +! | +
+ teal.widgets::plot_with_settings_ui(id = session$ns("pca_plot"))
|
|
| 986 | +1121 |
-
+ ) |
|
| 987 | +1122 |
- # Create facet call+ }) |
|
| 988 | +1123 |
- facet_ggplot_call <- function(row_facet = character(0),+ + |
+ |
| 1124 | +! | +
+ teal.widgets::verbatim_popup_srv(+ |
+ |
| 1125 | +! | +
+ id = "rcode",+ |
+ |
| 1126 | +! | +
+ verbatim_content = reactive(teal.code::get_code(req(decorated_output_q()))),+ |
+ |
| 1127 | +! | +
+ title = "R Code for PCA" |
|
| 989 | +1128 |
- col_facet = character(0),+ ) |
|
| 990 | +1129 |
- free_x_scales = FALSE,+ |
|
| 991 | +1130 |
- free_y_scales = FALSE) {
+ ### REPORTER |
|
| 992 | +1131 | ! |
- scales <- if (free_x_scales && free_y_scales) {
+ if (with_reporter) {
|
| 993 | +1132 | ! |
- "free"+ card_fun <- function(comment, label) {
|
| 994 | +1133 | ! |
- } else if (free_x_scales) {
+ card <- teal::report_card_template( |
| 995 | +1134 | ! |
- "free_x"+ title = "Principal Component Analysis Plot", |
| 996 | +1135 | ! |
- } else if (free_y_scales) {
+ label = label, |
| 997 | +1136 | ! |
- "free_y"- |
-
| 998 | -- |
- } else {
+ with_filter = with_filter, |
|
| 999 | +1137 | ! |
- "fixed"+ filter_panel_api = filter_panel_api |
| 1000 | +1138 |
- }+ ) |
|
| 1001 | -+ | ||
| 1139 | +! |
-
+ card$append_text("Principal Components Table", "header3")
|
|
| 1002 | +1140 | ! |
- if (identical(row_facet, character(0)) && identical(col_facet, character(0))) {
+ card$append_table(computation()[["tbl_importance"]]) |
| 1003 | +1141 | ! |
- NULL+ card$append_text("Eigenvectors Table", "header3")
|
| 1004 | +1142 | ! |
- } else if (!identical(row_facet, character(0)) && !identical(col_facet, character(0))) {
+ card$append_table(computation()[["tbl_eigenvector"]]) |
| 1005 | +1143 | ! |
- call(+ card$append_text("Plot", "header3")
|
| 1006 | +1144 | ! |
- "facet_grid",+ card$append_plot(plot_r(), dim = pws$dim()) |
| 1007 | +1145 | ! |
- rows = call_fun_dots("vars", row_facet),
+ if (!comment == "") {
|
| 1008 | +1146 | ! |
- cols = call_fun_dots("vars", col_facet),
+ card$append_text("Comment", "header3")
|
| 1009 | +1147 | ! |
- scales = scales+ card$append_text(comment) |
| 1010 | +1148 |
- )+ } |
|
| 1011 | +1149 | ! |
- } else if (identical(row_facet, character(0)) && !identical(col_facet, character(0))) {
+ card$append_src(teal.code::get_code(req(decorated_output_q()))) |
| 1012 | +1150 | ! |
- call("facet_grid", cols = call_fun_dots("vars", col_facet), scales = scales)
+ card |
| 1013 | -! | +||
| 1151 | +
- } else if (!identical(row_facet, character(0)) && identical(col_facet, character(0))) {
+ } |
||
| 1014 | +1152 | ! |
- call("facet_grid", rows = call_fun_dots("vars", row_facet), scales = scales)
+ teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
|
| 1015 | +1153 |
- }+ } |
|
| 1016 | +1154 |
- }+ ### |
|
| 1017 | +1155 |
-
+ }) |
|
| 1018 | +1156 |
- coloring_ggplot_call <- function(colour,+ } |
| 1019 | +1 |
- fill,+ #' `teal` module: Outliers analysis |
|
| 1020 | +2 |
- size,+ #' |
|
| 1021 | +3 |
- is_point = FALSE) {
+ #' Module to analyze and identify outliers using different methods |
|
| 1022 | +4 |
- if (- |
- |
| 1023 | -15x | -
- !identical(colour, character(0)) &&- |
- |
| 1024 | -15x | -
- !identical(fill, character(0)) &&- |
- |
| 1025 | -15x | -
- is_point &&- |
- |
| 1026 | -15x | -
- !identical(size, character(0))+ #' such as IQR, Z-score, and Percentiles, and offers visualizations including |
|
| 1027 | +5 |
- ) {
- |
- |
| 1028 | -1x | -
- substitute(- |
- |
| 1029 | -1x | -
- expr = aes(colour = colour_name, fill = fill_name, size = size_name),- |
- |
| 1030 | -1x | -
- env = list(colour_name = as.name(colour), fill_name = as.name(fill), size_name = as.name(size))+ #' box plots, density plots, and cumulative distribution plots to help interpret the outliers. |
|
| 1031 | +6 |
- )+ #' |
|
| 1032 | +7 |
- } else if (- |
- |
| 1033 | -14x | -
- identical(colour, character(0)) &&+ #' @inheritParams teal::module |
|
| 1034 | -14x | +||
| 8 | +
- !identical(fill, character(0)) &&+ #' @inheritParams shared_params |
||
| 1035 | -14x | +||
| 9 | +
- is_point &&+ #' |
||
| 1036 | -14x | +||
| 10 | +
- identical(size, character(0))+ #' @param outlier_var (`data_extract_spec` or `list` of multiple `data_extract_spec`) |
||
| 1037 | +11 |
- ) {
+ #' Specifies variable(s) to be analyzed for outliers. |
|
| 1038 | -1x | +||
| 12 | +
- substitute(expr = aes(fill = fill_name), env = list(fill_name = as.name(fill)))+ #' @param categorical_var (`data_extract_spec` or `list` of multiple `data_extract_spec`) optional, |
||
| 1039 | +13 |
- } else if (+ #' specifies the categorical variable(s) to split the selected outlier variables on. |
|
| 1040 | -13x | +||
| 14 | +
- !identical(colour, character(0)) &&+ #' @param ggplot2_args `r roxygen_ggplot2_args_param("Boxplot", "Density Plot", "Cumulative Distribution Plot")`
|
||
| 1041 | -13x | +||
| 15 | +
- !identical(fill, character(0)) &&+ #' @param decorators `r roxygen_decorators_param("tm_outliers")`
|
||
| 1042 | -13x | +||
| 16 | +
- (!is_point || identical(size, character(0)))+ #' |
||
| 1043 | +17 |
- ) {
+ #' @inherit shared_params return |
|
| 1044 | -3x | +||
| 18 | +
- substitute(+ #' |
||
| 1045 | -3x | +||
| 19 | +
- expr = aes(colour = colour_name, fill = fill_name),+ #' @section Decorating `tm_outliers`: |
||
| 1046 | -3x | +||
| 20 | +
- env = list(colour_name = as.name(colour), fill_name = as.name(fill))+ #' |
||
| 1047 | +21 |
- )+ #' This module generates the following objects, which can be modified in place using decorators: |
|
| 1048 | +22 |
- } else if (+ #' - `box_plot` (`ggplot2`) |
|
| 1049 | -10x | +||
| 23 | +
- !identical(colour, character(0)) &&+ #' - `density_plot` (`ggplot2`) |
||
| 1050 | -10x | +||
| 24 | +
- identical(fill, character(0)) &&+ #' - `cumulative_plot` (`ggplot2`) |
||
| 1051 | -10x | +||
| 25 | +
- (!is_point || identical(size, character(0)))+ #' - `table` ([DT::datatable()]) |
||
| 1052 | +26 |
- ) {
+ #' |
|
| 1053 | -1x | +||
| 27 | +
- substitute(expr = aes(colour = colour_name), env = list(colour_name = as.name(colour)))+ #' Decorators can be applied to all outputs or only to specific objects using a |
||
| 1054 | +28 |
- } else if (+ #' named list of `teal_transform_module` objects. |
|
| 1055 | -9x | +||
| 29 | +
- identical(colour, character(0)) &&+ #' The `"default"` name is reserved for decorators that are applied to all outputs. |
||
| 1056 | -9x | +||
| 30 | +
- !identical(fill, character(0)) &&+ #' See code snippet below: |
||
| 1057 | -9x | +||
| 31 | +
- (!is_point || identical(size, character(0)))+ #' |
||
| 1058 | +32 |
- ) {
+ #' ``` |
|
| 1059 | -2x | +||
| 33 | +
- substitute(expr = aes(fill = fill_name), env = list(fill_name = as.name(fill)))+ #' tm_outliers( |
||
| 1060 | +34 |
- } else if (+ #' ..., # arguments for module |
|
| 1061 | -7x | +||
| 35 | +
- identical(colour, character(0)) &&+ #' decorators = list( |
||
| 1062 | -7x | +||
| 36 | +
- identical(fill, character(0)) &&+ #' default = list(teal_transform_module(...)), # applied to all outputs |
||
| 1063 | -7x | +||
| 37 | +
- is_point &&+ #' box_plot = list(teal_transform_module(...)), # applied only to `box_plot` output |
||
| 1064 | -7x | +||
| 38 | +
- !identical(size, character(0))+ #' density_plot = list(teal_transform_module(...)) # applied only to `density_plot` output |
||
| 1065 | +39 |
- ) {
+ #' cumulative_plot = list(teal_transform_module(...)) # applied only to `cumulative_plot` output |
|
| 1066 | -1x | +||
| 40 | +
- substitute(expr = aes(size = size_name), env = list(size_name = as.name(size)))+ #' table = list(teal_transform_module(...)) # applied only to `table` output |
||
| 1067 | +41 |
- } else if (+ #' ) |
|
| 1068 | -6x | +||
| 42 | +
- !identical(colour, character(0)) &&+ #' ) |
||
| 1069 | -6x | +||
| 43 | +
- identical(fill, character(0)) &&+ #' ``` |
||
| 1070 | -6x | +||
| 44 | +
- is_point &&+ #' |
||
| 1071 | -6x | +||
| 45 | +
- !identical(size, character(0))+ #' For additional details and examples of decorators, refer to the vignette |
||
| 1072 | +46 |
- ) {
+ #' `vignette("decorate-modules-output", package = "teal")` or the [`teal::teal_transform_module()`] documentation.
|
|
| 1073 | -1x | +||
| 47 | +
- substitute(+ #' |
||
| 1074 | -1x | +||
| 48 | +
- expr = aes(colour = colour_name, size = size_name),+ #' @examplesShinylive |
||
| 1075 | -1x | +||
| 49 | +
- env = list(colour_name = as.name(colour), size_name = as.name(size))+ #' library(teal.modules.general) |
||
| 1076 | +50 |
- )+ #' interactive <- function() TRUE |
|
| 1077 | +51 |
- } else if (+ #' {{ next_example }}
|
|
| 1078 | -5x | +||
| 52 | +
- identical(colour, character(0)) &&+ #' @examples |
||
| 1079 | -5x | +||
| 53 | +
- !identical(fill, character(0)) &&+ #' |
||
| 1080 | -5x | +||
| 54 | +
- is_point &&+ #' # general data example |
||
| 1081 | -5x | +||
| 55 | +
- !identical(size, character(0))+ #' data <- teal_data() |
||
| 1082 | +56 |
- ) {
+ #' data <- within(data, {
|
|
| 1083 | -1x | +||
| 57 | +
- substitute(+ #' CO2 <- CO2 |
||
| 1084 | -1x | +||
| 58 | +
- expr = aes(colour = colour_name, fill = fill_name, size = size_name),+ #' CO2[["primary_key"]] <- seq_len(nrow(CO2)) |
||
| 1085 | -1x | +||
| 59 | +
- env = list(colour_name = as.name(fill), fill_name = as.name(fill), size_name = as.name(size))+ #' }) |
||
| 1086 | +60 |
- )+ #' join_keys(data) <- join_keys(join_key("CO2", "CO2", "primary_key"))
|
|
| 1087 | +61 |
- } else {
+ #' |
|
| 1088 | -4x | +||
| 62 | +
- NULL+ #' vars <- choices_selected(variable_choices(data[["CO2"]], c("Plant", "Type", "Treatment")))
|
||
| 1089 | +63 |
- }+ #' |
|
| 1090 | +64 |
- }+ #' app <- init( |
| 1 | +65 |
- #' `teal` module: Front page+ #' data = data, |
|
| 2 | +66 |
- #'+ #' modules = modules( |
|
| 3 | +67 |
- #' Creates a simple front page for `teal` applications, displaying+ #' tm_outliers( |
|
| 4 | +68 |
- #' introductory text, tables, additional `html` or `shiny` tags, and footnotes.+ #' outlier_var = list( |
|
| 5 | +69 |
- #'+ #' data_extract_spec( |
|
| 6 | +70 |
- #' @inheritParams teal::module+ #' dataname = "CO2", |
|
| 7 | +71 |
- #' @param header_text (`character` vector) text to be shown at the top of the module, for each+ #' select = select_spec( |
|
| 8 | +72 |
- #' element, if named the name is shown first in bold as a header followed by the value. The first+ #' label = "Select variable:", |
|
| 9 | +73 |
- #' element's header is displayed larger than the others.+ #' choices = variable_choices(data[["CO2"]], c("conc", "uptake")),
|
|
| 10 | +74 |
- #' @param tables (`named list` of `data.frame`s) tables to be shown in the module.+ #' selected = "uptake", |
|
| 11 | +75 |
- #' @param additional_tags (`shiny.tag.list` or `html`) additional `shiny` tags or `html` to be included after the table,+ #' multiple = FALSE, |
|
| 12 | +76 |
- #' for example to include an image, `tagList(tags$img(src = "image.png"))` or to include further `html`,+ #' fixed = FALSE |
|
| 13 | +77 |
- #' `HTML("html text here")`.
+ #' ) |
|
| 14 | +78 |
- #' @param footnotes (`character` vector) of text to be shown at the bottom of the module, for each+ #' ) |
|
| 15 | +79 |
- #' element, if named the name is shown first in bold, followed by the value.+ #' ), |
|
| 16 | +80 |
- #' @param show_metadata (`logical`) indicating whether the metadata of the datasets be available on the module.+ #' categorical_var = list( |
|
| 17 | +81 |
- #'+ #' data_extract_spec( |
|
| 18 | +82 |
- #' @inherit shared_params return+ #' dataname = "CO2", |
|
| 19 | +83 |
- #'+ #' filter = filter_spec( |
|
| 20 | +84 |
- #' @examplesShinylive+ #' vars = vars, |
|
| 21 | +85 |
- #' library(teal.modules.general)+ #' choices = value_choices(data[["CO2"]], vars$selected), |
|
| 22 | +86 |
- #' interactive <- function() TRUE+ #' selected = value_choices(data[["CO2"]], vars$selected), |
|
| 23 | +87 |
- #' {{ next_example }}
+ #' multiple = TRUE |
|
| 24 | +88 |
- #' @examples+ #' ) |
|
| 25 | +89 |
- #' data <- teal_data()+ #' ) |
|
| 26 | +90 |
- #' data <- within(data, {
+ #' ) |
|
| 27 | +91 |
- #' require(nestcolor)+ #' ) |
|
| 28 | +92 |
- #' ADSL <- rADSL+ #' ) |
|
| 29 | +93 |
- #' attr(ADSL, "metadata") <- list("Author" = "NEST team", "data_source" = "synthetic data")
+ #' ) |
|
| 30 | +94 |
- #' })+ #' if (interactive()) {
|
|
| 31 | +95 |
- #' join_keys(data) <- default_cdisc_join_keys[names(data)]+ #' shinyApp(app$ui, app$server) |
|
| 32 | +96 |
- #'+ #' } |
|
| 33 | +97 |
- #' table_1 <- data.frame(Info = c("A", "B"), Text = c("A", "B"))
+ #' |
|
| 34 | +98 |
- #' table_2 <- data.frame(`Column 1` = c("C", "D"), `Column 2` = c(5.5, 6.6), `Column 3` = c("A", "B"))
+ #' @examplesShinylive |
|
| 35 | +99 |
- #' table_3 <- data.frame(Info = c("E", "F"), Text = c("G", "H"))
+ #' library(teal.modules.general) |
|
| 36 | +100 |
- #'+ #' interactive <- function() TRUE |
|
| 37 | +101 |
- #' table_input <- list(+ #' {{ next_example }}
|
|
| 38 | +102 |
- #' "Table 1" = table_1,+ #' @examples |
|
| 39 | +103 |
- #' "Table 2" = table_2,+ #' |
|
| 40 | +104 |
- #' "Table 3" = table_3+ #' # CDISC data example |
|
| 41 | +105 |
- #' )+ #' data <- teal_data() |
|
| 42 | +106 |
- #'+ #' data <- within(data, {
|
|
| 43 | +107 |
- #' app <- init(+ #' ADSL <- teal.data::rADSL |
|
| 44 | +108 |
- #' data = data,+ #' }) |
|
| 45 | +109 |
- #' modules = modules(+ #' join_keys(data) <- default_cdisc_join_keys[names(data)] |
|
| 46 | +110 |
- #' tm_front_page(+ #' |
|
| 47 | +111 |
- #' header_text = c(+ #' fact_vars_adsl <- names(Filter(isTRUE, sapply(data[["ADSL"]], is.factor))) |
|
| 48 | +112 |
- #' "Important information" = "It can go here.",+ #' vars <- choices_selected(variable_choices(data[["ADSL"]], fact_vars_adsl)) |
|
| 49 | +113 |
- #' "Other information" = "Can go here."+ #' |
|
| 50 | +114 |
- #' ),+ #' |
|
| 51 | +115 |
- #' tables = table_input,+ #' |
|
| 52 | +116 |
- #' additional_tags = HTML("Additional HTML or shiny tags go here <br>"),
+ #' app <- init( |
|
| 53 | +117 |
- #' footnotes = c("X" = "is the first footnote", "Y is the second footnote"),
+ #' data = data, |
|
| 54 | +118 |
- #' show_metadata = TRUE+ #' modules = modules( |
|
| 55 | +119 |
- #' )+ #' tm_outliers( |
|
| 56 | +120 |
- #' ),+ #' outlier_var = list( |
|
| 57 | +121 |
- #' header = tags$h1("Sample Application"),
+ #' data_extract_spec( |
|
| 58 | +122 |
- #' footer = tags$p("Application footer"),
+ #' dataname = "ADSL", |
|
| 59 | +123 |
- #' )+ #' select = select_spec( |
|
| 60 | +124 |
- #'+ #' label = "Select variable:", |
|
| 61 | +125 |
- #' if (interactive()) {
+ #' choices = variable_choices(data[["ADSL"]], c("AGE", "BMRKR1")),
|
|
| 62 | +126 |
- #' shinyApp(app$ui, app$server)+ #' selected = "AGE", |
|
| 63 | +127 |
- #' }+ #' multiple = FALSE, |
|
| 64 | +128 |
- #'+ #' fixed = FALSE |
|
| 65 | +129 |
- #' @export+ #' ) |
|
| 66 | +130 |
- #'+ #' ) |
|
| 67 | +131 |
- tm_front_page <- function(label = "Front page",+ #' ), |
|
| 68 | +132 |
- header_text = character(0),+ #' categorical_var = list( |
|
| 69 | +133 |
- tables = list(),+ #' data_extract_spec( |
|
| 70 | +134 |
- additional_tags = tagList(),+ #' dataname = "ADSL", |
|
| 71 | +135 |
- footnotes = character(0),+ #' filter = filter_spec( |
|
| 72 | +136 |
- show_metadata = FALSE) {
+ #' vars = vars, |
|
| 73 | -! | +||
| 137 | +
- message("Initializing tm_front_page")
+ #' choices = value_choices(data[["ADSL"]], vars$selected), |
||
| 74 | +138 |
-
+ #' selected = value_choices(data[["ADSL"]], vars$selected), |
|
| 75 | +139 |
- # Start of assertions+ #' multiple = TRUE |
|
| 76 | -! | +||
| 140 | +
- checkmate::assert_string(label)+ #' ) |
||
| 77 | -! | +||
| 141 | +
- checkmate::assert_character(header_text, min.len = 0, any.missing = FALSE)+ #' ) |
||
| 78 | -! | +||
| 142 | +
- checkmate::assert_list(tables, types = "data.frame", names = "named", any.missing = FALSE)+ #' ) |
||
| 79 | -! | +||
| 143 | +
- checkmate::assert_multi_class(additional_tags, classes = c("shiny.tag.list", "html"))
+ #' ) |
||
| 80 | -! | +||
| 144 | +
- checkmate::assert_character(footnotes, min.len = 0, any.missing = FALSE)+ #' ) |
||
| 81 | -! | +||
| 145 | +
- checkmate::assert_flag(show_metadata)+ #' ) |
||
| 82 | +146 |
- # End of assertions+ #' if (interactive()) {
|
|
| 83 | +147 |
-
+ #' shinyApp(app$ui, app$server) |
|
| 84 | +148 |
- # Make UI args+ #' } |
|
| 85 | -! | +||
| 149 | +
- args <- as.list(environment())+ #' |
||
| 86 | +150 |
-
+ #' @export |
|
| 87 | -! | +||
| 151 | +
- ans <- module(+ #' |
||
| 88 | -! | +||
| 152 | +
- label = label,+ tm_outliers <- function(label = "Outliers Module", |
||
| 89 | -! | +||
| 153 | +
- server = srv_front_page,+ outlier_var, |
||
| 90 | -! | +||
| 154 | +
- ui = ui_front_page,+ categorical_var = NULL, |
||
| 91 | -! | +||
| 155 | +
- ui_args = args,+ ggtheme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void"),
|
||
| 92 | -! | +||
| 156 | +
- server_args = list(tables = tables, show_metadata = show_metadata),+ ggplot2_args = teal.widgets::ggplot2_args(), |
||
| 93 | -! | +||
| 157 | +
- datanames = if (show_metadata) "all" else NULL+ plot_height = c(600, 200, 2000), |
||
| 94 | +158 |
- )+ plot_width = NULL, |
|
| 95 | -! | +||
| 159 | +
- attr(ans, "teal_bookmarkable") <- TRUE+ pre_output = NULL, |
||
| 96 | -! | +||
| 160 | +
- ans+ post_output = NULL, |
||
| 97 | +161 |
- }+ decorators = NULL) {
+ |
+ |
| 162 | +! | +
+ message("Initializing tm_outliers")
|
|
| 98 | +163 | ||
| 99 | +164 |
- # UI function for the front page module+ # Normalize the parameters |
|
| 100 | -+ | ||
| 165 | +! |
- ui_front_page <- function(id, ...) {
+ if (inherits(outlier_var, "data_extract_spec")) outlier_var <- list(outlier_var) |
|
| 101 | +166 | ! |
- args <- list(...)+ if (inherits(categorical_var, "data_extract_spec")) categorical_var <- list(categorical_var) |
| 102 | +167 | ! |
- ns <- NS(id)+ if (inherits(ggplot2_args, "ggplot2_args")) ggplot2_args <- list(default = ggplot2_args) |
| 103 | +168 | ||
| 104 | -! | +||
| 169 | +
- tagList(+ # Start of assertions |
||
| 105 | +170 | ! |
- include_css_files("custom"),
+ checkmate::assert_string(label) |
| 106 | +171 | ! |
- tags$div(+ checkmate::assert_list(outlier_var, types = "data_extract_spec")+ |
+
| 172 | ++ | + | |
| 107 | +173 | ! |
- id = "front_page_content",+ checkmate::assert_list(categorical_var, types = "data_extract_spec", null.ok = TRUE) |
| 108 | +174 | ! |
- class = "ml-8",+ if (is.list(categorical_var)) {
|
| 109 | +175 | ! |
- tags$div(+ lapply(categorical_var, function(x) {
|
| 110 | +176 | ! |
- id = "front_page_headers",+ if (length(x$filter) > 1L) {
|
| 111 | +177 | ! |
- get_header_tags(args$header_text)+ stop("tm_outliers: categorical_var data_extract_specs may only specify one filter_spec", call. = FALSE)
|
| 112 | +178 |
- ),+ } |
|
| 113 | -! | +||
| 179 | +
- tags$div(+ }) |
||
| 114 | -! | +||
| 180 | +
- id = "front_page_tables",+ } |
||
| 115 | -! | +||
| 181 | +
- class = "ml-4",+ |
||
| 116 | +182 | ! |
- get_table_tags(args$tables, ns)+ ggtheme <- match.arg(ggtheme) |
| 117 | +183 |
- ),+ |
|
| 118 | +184 | ! |
- tags$div(+ plot_choices <- c("Boxplot", "Density Plot", "Cumulative Distribution Plot")
|
| 119 | +185 | ! |
- id = "front_page_custom_html",+ checkmate::assert_list(ggplot2_args, types = "ggplot2_args") |
| 120 | +186 | ! |
- class = "my-4",+ checkmate::assert_subset(names(ggplot2_args), c("default", plot_choices))
|
| 121 | -! | +||
| 187 | +
- args$additional_tags+ |
||
| 122 | -+ | ||
| 188 | +! |
- ),+ checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE) |
|
| 123 | +189 | ! |
- if (args$show_metadata) {
+ checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height") |
| 124 | +190 | ! |
- tags$div(+ checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE) |
| 125 | +191 | ! |
- id = "front_page_metabutton",+ checkmate::assert_numeric( |
| 126 | +192 | ! |
- class = "m-4",+ plot_width[1], |
| 127 | +193 | ! |
- actionButton(ns("metadata_button"), "Show metadata")
+ lower = plot_width[2], upper = plot_width[3], null.ok = TRUE, .var.name = "plot_width" |
| 128 | +194 |
- )+ ) |
|
| 129 | +195 |
- },+ |
|
| 130 | +196 | ! |
- tags$footer(+ checkmate::assert_multi_class(pre_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
|
| 131 | +197 | ! |
- class = ".small",+ checkmate::assert_multi_class(post_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
+ |
+
| 198 | ++ | + | |
| 132 | +199 | ! |
- get_footer_tags(args$footnotes)+ available_decorators <- c("box_plot", "density_plot", "cumulative_plot", "table")
|
| 133 | -+ | ||
| 200 | +! |
- )+ decorators <- normalize_decorators(decorators) |
|
| 134 | -+ | ||
| 201 | +! |
- )+ assert_decorators(decorators, null.ok = TRUE, names = available_decorators) |
|
| 135 | +202 |
- )+ # End of assertions |
|
| 136 | +203 |
- }+ |
|
| 137 | +204 |
-
+ # Make UI args |
|
| 138 | -+ | ||
| 205 | +! |
- # Server function for the front page module+ args <- as.list(environment()) |
|
| 139 | +206 |
- srv_front_page <- function(id, data, tables, show_metadata) {
+
|
|
| 140 | +207 | ! |
- checkmate::assert_class(data, "reactive")+ data_extract_list <- list( |
| 141 | +208 | ! |
- checkmate::assert_class(isolate(data()), "teal_data")+ outlier_var = outlier_var, |
| 142 | +209 | ! |
- moduleServer(id, function(input, output, session) {
+ categorical_var = categorical_var |
| 143 | -! | +||
| 210 | +
- teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.general")+ ) |
||
| 144 | +211 | ||
| 145 | -! | -
- ns <- session$ns- |
- |
| 146 | +212 | ||
| 147 | +213 | ! |
- setBookmarkExclude("metadata_button")
+ ans <- module( |
| 148 | -+ | ||
| 214 | +! |
-
+ label = label, |
|
| 149 | +215 | ! |
- lapply(seq_along(tables), function(idx) {
+ server = srv_outliers, |
| 150 | +216 | ! |
- output[[paste0("table_", idx)]] <- renderTable(
+ server_args = c( |
| 151 | +217 | ! |
- tables[[idx]],+ data_extract_list, |
| 152 | +218 | ! |
- bordered = TRUE,+ list( |
| 153 | +219 | ! |
- caption = names(tables)[idx],+ plot_height = plot_height, plot_width = plot_width, ggplot2_args = ggplot2_args, |
| 154 | +220 | ! |
- caption.placement = "top"+ decorators = decorators |
| 155 | +221 |
) |
|
| 156 | -- |
- })- |
- |
| 157 | +222 | - - | -|
| 158 | -! | -
- if (show_metadata) {
- |
- |
| 159 | -! | -
- observeEvent(+ ), |
|
| 160 | +223 | ! |
- input$metadata_button, showModal(+ ui = ui_outliers, |
| 161 | +224 | ! |
- modalDialog(+ ui_args = args, |
| 162 | +225 | ! |
- title = "Metadata",+ datanames = teal.transform::get_extract_datanames(data_extract_list) |
| 163 | -! | +||
| 226 | +
- dataTableOutput(ns("metadata_table")),
+ ) |
||
| 164 | +227 | ! |
- size = "l",+ attr(ans, "teal_bookmarkable") <- TRUE |
| 165 | +228 | ! |
- easyClose = TRUE+ ans |
| 166 | +229 |
- )+ } |
|
| 167 | +230 |
- )+ |
|
| 168 | +231 |
- )+ # UI function for the outliers module |
|
| 169 | +232 |
-
+ ui_outliers <- function(id, ...) {
|
|
| 170 | +233 | ! |
- metadata_data_frame <- reactive({
+ args <- list(...) |
| 171 | +234 | ! |
- datanames <- names(data())+ ns <- NS(id) |
| 172 | +235 | ! |
- convert_metadata_to_dataframe(+ is_single_dataset_value <- teal.transform::is_single_dataset(args$outlier_var, args$categorical_var)+ |
+
| 236 | ++ | + | |
| 173 | +237 | ! |
- lapply(datanames, function(dataname) attr(data()[[dataname]], "metadata")),+ teal.widgets::standard_layout( |
| 174 | +238 | ! |
- datanames+ output = teal.widgets::white_small_well( |
| 175 | -+ | ||
| 239 | +! |
- )+ uiOutput(ns("total_outliers")),
|
|
| 176 | -+ | ||
| 240 | +! |
- })+ DT::dataTableOutput(ns("summary_table")),
|
|
| 177 | -+ | ||
| 241 | +! |
-
+ uiOutput(ns("total_missing")),
|
|
| 178 | +242 | ! |
- output$metadata_table <- renderDataTable({
+ tags$br(), tags$hr(), |
| 179 | +243 | ! |
- validate(need(nrow(metadata_data_frame()) > 0, "The data has no associated metadata"))+ tabsetPanel( |
| 180 | +244 | ! |
- metadata_data_frame()+ id = ns("tabs"),
|
| 181 | -+ | ||
| 245 | +! |
- })+ tabPanel( |
|
| 182 | -+ | ||
| 246 | +! |
- }+ "Boxplot", |
|
| 183 | -+ | ||
| 247 | +! |
- })+ teal.widgets::plot_with_settings_ui(id = ns("box_plot"))
|
|
| 184 | +248 |
- }+ ), |
|
| 185 | -+ | ||
| 249 | +! |
-
+ tabPanel( |
|
| 186 | -+ | ||
| 250 | +! | +
+ "Density Plot",+ |
+ |
| 251 | +! |
- ## utils functions+ teal.widgets::plot_with_settings_ui(id = ns("density_plot"))
|
|
| 187 | +252 |
-
+ ), |
|
| 188 | -+ | ||
| 253 | +! |
- get_header_tags <- function(header_text) {
+ tabPanel( |
|
| 189 | +254 | ! |
- if (length(header_text) == 0) {
+ "Cumulative Distribution Plot", |
| 190 | +255 | ! |
- return(list())+ teal.widgets::plot_with_settings_ui(id = ns("cum_density_plot"))
|
| 191 | +256 |
- }+ ) |
|
| 192 | +257 |
-
+ ), |
|
| 193 | +258 | ! |
- get_single_header_tags <- function(header_text, p_text, header_tag = tags$h4) {
+ tags$br(), tags$hr(), |
| 194 | +259 | ! |
- tagList(+ uiOutput(ns("table_ui_wrap")),
|
| 195 | +260 | ! |
- tags$div(+ DT::dataTableOutput(ns("table_ui"))
|
| 196 | -! | +||
| 261 | +
- if (!is.null(header_text) && nchar(header_text) > 0) header_tag(header_text),+ ), |
||
| 197 | +262 | ! |
- tags$p(p_text)- |
-
| 198 | -- |
- )+ encoding = tags$div( |
|
| 199 | +263 |
- )+ ### Reporter |
|
| 200 | -+ | ||
| 264 | +! |
- }+ teal.reporter::simple_reporter_ui(ns("simple_reporter")),
|
|
| 201 | +265 |
-
+ ### |
|
| 202 | +266 | ! |
- header_tags <- get_single_header_tags(names(header_text[1]), header_text[1], header_tag = tags$h3)+ tags$label("Encodings", class = "text-primary"),
|
| 203 | +267 | ! |
- c(header_tags, mapply(get_single_header_tags, utils::tail(names(header_text), -1), utils::tail(header_text, -1)))+ teal.transform::datanames_input(args[c("outlier_var", "categorical_var")]),
|
| 204 | -+ | ||
| 268 | +! |
- }+ teal.transform::data_extract_ui( |
|
| 205 | -+ | ||
| 269 | +! |
-
+ id = ns("outlier_var"),
|
|
| 206 | -+ | ||
| 270 | +! |
- get_table_tags <- function(tables, ns) {
+ label = "Variable", |
|
| 207 | +271 | ! |
- if (length(tables) == 0) {
+ data_extract_spec = args$outlier_var, |
| 208 | +272 | ! |
- return(list())+ is_single_dataset = is_single_dataset_value |
| 209 | +273 |
- }+ ), |
|
| 210 | +274 | ! |
- table_tags <- c(lapply(seq_along(tables), function(idx) {
+ if (!is.null(args$categorical_var)) {
|
| 211 | +275 | ! |
- list(+ teal.transform::data_extract_ui( |
| 212 | +276 | ! |
- tableOutput(ns(paste0("table_", idx)))
+ id = ns("categorical_var"),
|
| 213 | -+ | ||
| 277 | +! |
- )+ label = "Categorical factor", |
|
| 214 | -+ | ||
| 278 | +! |
- }))+ data_extract_spec = args$categorical_var, |
|
| 215 | +279 | ! |
- return(table_tags)+ is_single_dataset = is_single_dataset_value |
| 216 | +280 |
- }+ ) |
|
| 217 | +281 |
-
+ }, |
|
| 218 | -+ | ||
| 282 | +! |
- get_footer_tags <- function(footnotes) {
+ conditionalPanel( |
|
| 219 | +283 | ! |
- if (length(footnotes) == 0) {
+ condition = paste0("input['", ns("tabs"), "'] == 'Boxplot'"),
|
| 220 | +284 | ! |
- return(list())+ teal.widgets::optionalSelectInput( |
| 221 | -+ | ||
| 285 | +! |
- }+ inputId = ns("boxplot_alts"),
|
|
| 222 | +286 | ! |
- bold_texts <- if (is.null(names(footnotes))) rep("", length(footnotes)) else names(footnotes)
+ label = "Plot type", |
| 223 | +287 | ! |
- footnote_tags <- mapply(function(bold_text, value) {
+ choices = c("Box plot", "Violin plot"),
|
| 224 | +288 | ! |
- list(+ selected = "Box plot", |
| 225 | +289 | ! |
- tags$div(+ multiple = FALSE+ |
+
| 290 | ++ |
+ )+ |
+ |
| 291 | ++ |
+ ), |
|
| 226 | +292 | ! |
- tags$b(bold_text),+ shinyjs::hidden(checkboxInput(ns("split_outliers"), "Define outliers based on group splitting", value = FALSE)),
|
| 227 | +293 | ! |
- value,+ shinyjs::hidden(checkboxInput(ns("order_by_outlier"), "Re-order categories by outliers [by %]", value = FALSE)),
|
| 228 | +294 | ! |
- tags$br()+ teal.widgets::panel_group( |
| 229 | -+ | ||
| 295 | +! |
- )+ teal.widgets::panel_item( |
|
| 230 | -+ | ||
| 296 | +! |
- )+ title = "Method parameters", |
|
| 231 | +297 | ! |
- }, bold_text = bold_texts, value = footnotes)+ collapsed = FALSE, |
| 232 | -+ | ||
| 298 | +! |
- }+ teal.widgets::optionalSelectInput( |
|
| 233 | -+ | ||
| 299 | +! |
-
+ inputId = ns("method"),
|
|
| 234 | -+ | ||
| 300 | +! |
- # take a list of metadata, one item per dataset (raw_metadata each element from datasets$get_metadata())+ label = "Method", |
|
| 235 | -+ | ||
| 301 | +! |
- # and the corresponding datanames and output a data.frame with columns {Dataset, Name, Value}.
+ choices = c("IQR", "Z-score", "Percentile"),
|
|
| 236 | -+ | ||
| 302 | +! |
- # which are, the Dataset the metadata came from, the metadata's name and value+ selected = "IQR", |
|
| 237 | -+ | ||
| 303 | +! |
- convert_metadata_to_dataframe <- function(raw_metadata, datanames) {
+ multiple = FALSE |
|
| 238 | -4x | +||
| 304 | +
- output <- mapply(function(metadata, dataname) {
+ ), |
||
| 239 | -6x | +||
| 305 | +! |
- if (is.null(metadata)) {
+ conditionalPanel( |
|
| 240 | -2x | +||
| 306 | +! |
- return(data.frame(Dataset = character(0), Name = character(0), Value = character(0)))+ condition = |
|
| 241 | -+ | ||
| 307 | +! |
- }+ paste0("input['", ns("method"), "'] == 'IQR'"),
|
|
| 242 | -4x | +||
| 308 | +! |
- return(data.frame(+ sliderInput( |
|
| 243 | -4x | +||
| 309 | +! |
- Dataset = dataname,+ ns("iqr_slider"),
|
|
| 244 | -4x | +||
| 310 | +! |
- Name = names(metadata),+ "Outlier range:", |
|
| 245 | -4x | +||
| 311 | +! |
- Value = unname(unlist(lapply(metadata, as.character)))+ min = 1, |
|
| 246 | -+ | ||
| 312 | +! |
- ))+ max = 5, |
|
| 247 | -4x | +||
| 313 | +! |
- }, raw_metadata, datanames, SIMPLIFY = FALSE)+ value = 3, |
|
| 248 | -4x | +||
| 314 | +! |
- do.call(rbind, output)+ step = 0.5 |
|
| 249 | +315 |
- }+ ) |
| 1 | +316 |
- #' `teal` module: Response plot+ ), |
|
| 2 | -+ | ||
| 317 | +! |
- #'+ conditionalPanel( |
|
| 3 | -+ | ||
| 318 | +! |
- #' Generates a response plot for a given `response` and `x` variables.+ condition = |
|
| 4 | -+ | ||
| 319 | +! |
- #' This module allows users customize and add annotations to the plot depending+ paste0("input['", ns("method"), "'] == 'Z-score'"),
|
|
| 5 | -+ | ||
| 320 | +! |
- #' on the module's arguments.+ sliderInput( |
|
| 6 | -+ | ||
| 321 | +! |
- #' It supports showing the counts grouped by other variable facets (by row / column),+ ns("zscore_slider"),
|
|
| 7 | -+ | ||
| 322 | +! |
- #' swapping the coordinates, show count annotations and displaying the response plot+ "Outlier range:", |
|
| 8 | -+ | ||
| 323 | +! |
- #' as frequency or density.+ min = 1, |
|
| 9 | -+ | ||
| 324 | +! |
- #'+ max = 5, |
|
| 10 | -+ | ||
| 325 | +! |
- #' @inheritParams teal::module+ value = 3, |
|
| 11 | -+ | ||
| 326 | +! |
- #' @inheritParams shared_params+ step = 0.5 |
|
| 12 | +327 |
- #' @param response (`data_extract_spec` or `list` of multiple `data_extract_spec`)+ ) |
|
| 13 | +328 |
- #' Which variable to use as the response.+ ), |
|
| 14 | -+ | ||
| 329 | +! |
- #' You can define one fixed column by setting `fixed = TRUE` inside the `select_spec`.+ conditionalPanel( |
|
| 15 | -+ | ||
| 330 | +! |
- #'+ condition = |
|
| 16 | -+ | ||
| 331 | +! |
- #' The `data_extract_spec` must not allow multiple selection in this case.+ paste0("input['", ns("method"), "'] == 'Percentile'"),
|
|
| 17 | -+ | ||
| 332 | +! |
- #' @param x (`data_extract_spec` or `list` of multiple `data_extract_spec`)+ sliderInput( |
|
| 18 | -+ | ||
| 333 | +! |
- #' Specifies which variable to use on the X-axis of the response plot.+ ns("percentile_slider"),
|
|
| 19 | -+ | ||
| 334 | +! |
- #' Allow the user to select multiple columns from the `data` allowed in teal.+ "Outlier range:", |
|
| 20 | -+ | ||
| 335 | +! |
- #'+ min = 0.001, |
|
| 21 | -+ | ||
| 336 | +! |
- #' The `data_extract_spec` must not allow multiple selection in this case.+ max = 0.5, |
|
| 22 | -+ | ||
| 337 | +! |
- #' @param row_facet (`data_extract_spec` or `list` of multiple `data_extract_spec`)+ value = 0.01, |
|
| 23 | -+ | ||
| 338 | +! |
- #' optional specification of the data variable(s) to use for faceting rows.+ step = 0.001 |
|
| 24 | +339 |
- #' @param col_facet (`data_extract_spec` or `list` of multiple `data_extract_spec`)+ ) |
|
| 25 | +340 |
- #' optional specification of the data variable(s) to use for faceting columns.+ ), |
|
| 26 | -+ | ||
| 341 | +! |
- #' @param coord_flip (`logical(1)`)+ uiOutput(ns("ui_outlier_help"))
|
|
| 27 | +342 |
- #' Indicates whether to flip coordinates between `x` and `response`.+ ) |
|
| 28 | +343 |
- #' The default value is `FALSE` and it will show the `x` variable on the x-axis+ ), |
|
| 29 | -+ | ||
| 344 | +! |
- #' and the `response` variable on the y-axis.+ conditionalPanel( |
|
| 30 | -+ | ||
| 345 | +! |
- #' @param count_labels (`logical(1)`)+ condition = paste0("input['", ns("tabs"), "'] == 'Boxplot'"),
|
|
| 31 | -+ | ||
| 346 | +! |
- #' Indicates whether to show count labels.+ ui_decorate_teal_data( |
|
| 32 | -+ | ||
| 347 | +! |
- #' Defaults to `TRUE`.+ ns("d_box_plot"),
|
|
| 33 | -+ | ||
| 348 | +! |
- #' @param freq (`logical(1)`)+ decorators = select_decorators(args$decorators, "box_plot") |
|
| 34 | +349 |
- #' Indicates whether to display frequency (`TRUE`) or density (`FALSE`).+ ) |
|
| 35 | +350 |
- #' Defaults to density (`FALSE`).+ ), |
|
| 36 | -+ | ||
| 351 | +! |
- #' @param decorators `r roxygen_decorators_param("tm_g_response")`
+ conditionalPanel( |
|
| 37 | -+ | ||
| 352 | +! |
- #'+ condition = paste0("input['", ns("tabs"), "'] == 'Density Plot'"),
|
|
| 38 | -+ | ||
| 353 | +! |
- #' @inherit shared_params return+ ui_decorate_teal_data( |
|
| 39 | -+ | ||
| 354 | +! |
- #'+ ns("d_density_plot"),
|
|
| 40 | -+ | ||
| 355 | +! |
- #' @note For more examples, please see the vignette "Using response plot" via+ decorators = select_decorators(args$decorators, "density_plot") |
|
| 41 | +356 |
- #' `vignette("using-response-plot", package = "teal.modules.general")`.
+ ) |
|
| 42 | +357 |
- #'+ ), |
|
| 43 | -+ | ||
| 358 | +! |
- #' @section Decorating `tm_g_response`:+ conditionalPanel( |
|
| 44 | -+ | ||
| 359 | +! |
- #'+ condition = paste0("input['", ns("tabs"), "'] == 'Cumulative Distribution Plot'"),
|
|
| 45 | -+ | ||
| 360 | +! |
- #' This module generates the following objects, which can be modified in place using decorators:+ ui_decorate_teal_data( |
|
| 46 | -+ | ||
| 361 | +! |
- #' - `plot` (`ggplot2`)+ ns("d_cumulative_plot"),
|
|
| 47 | -+ | ||
| 362 | +! |
- #'+ decorators = select_decorators(args$decorators, "cumulative_plot") |
|
| 48 | +363 |
- #' For additional details and examples of decorators, refer to the vignette+ ) |
|
| 49 | +364 |
- #' `vignette("decorate-modules-output", package = "teal")` or the [`teal::teal_transform_module()`] documentation.
+ ), |
|
| 50 | -+ | ||
| 365 | +! |
- #'+ ui_decorate_teal_data(ns("d_table"), decorators = select_decorators(args$decorators, "table")),
|
|
| 51 | -+ | ||
| 366 | +! |
- #' @examplesShinylive+ teal.widgets::panel_item( |
|
| 52 | -+ | ||
| 367 | +! |
- #' library(teal.modules.general)+ title = "Plot settings", |
|
| 53 | -+ | ||
| 368 | +! |
- #' interactive <- function() TRUE+ selectInput( |
|
| 54 | -+ | ||
| 369 | +! |
- #' {{ next_example }}
+ inputId = ns("ggtheme"),
|
|
| 55 | -+ | ||
| 370 | +! |
- #' @examples+ label = "Theme (by ggplot):", |
|
| 56 | -+ | ||
| 371 | +! |
- #' # general data example+ choices = ggplot_themes, |
|
| 57 | -+ | ||
| 372 | +! |
- #' data <- teal_data()+ selected = args$ggtheme, |
|
| 58 | -+ | ||
| 373 | +! |
- #' data <- within(data, {
+ multiple = FALSE |
|
| 59 | +374 |
- #' require(nestcolor)+ ) |
|
| 60 | +375 |
- #' mtcars <- mtcars+ ) |
|
| 61 | +376 |
- #' for (v in c("cyl", "vs", "am", "gear")) {
+ ), |
|
| 62 | -+ | ||
| 377 | +! |
- #' mtcars[[v]] <- as.factor(mtcars[[v]])+ forms = tagList( |
|
| 63 | -+ | ||
| 378 | +! |
- #' }+ teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code")
|
|
| 64 | +379 |
- #' })+ ), |
|
| 65 | -+ | ||
| 380 | +! |
- #'+ pre_output = args$pre_output, |
|
| 66 | -+ | ||
| 381 | +! |
- #' app <- init(+ post_output = args$post_output |
|
| 67 | +382 |
- #' data = data,+ ) |
|
| 68 | +383 |
- #' modules = modules(+ } |
|
| 69 | +384 |
- #' tm_g_response(+ |
|
| 70 | +385 |
- #' label = "Response Plots",+ # Server function for the outliers module |
|
| 71 | +386 |
- #' response = data_extract_spec(+ # Server function for the outliers module |
|
| 72 | +387 |
- #' dataname = "mtcars",+ srv_outliers <- function(id, data, reporter, filter_panel_api, outlier_var, |
|
| 73 | +388 |
- #' select = select_spec(+ categorical_var, plot_height, plot_width, ggplot2_args, decorators) {
|
|
| 74 | -+ | ||
| 389 | +! |
- #' label = "Select variable:",+ with_reporter <- !missing(reporter) && inherits(reporter, "Reporter") |
|
| 75 | -+ | ||
| 390 | +! |
- #' choices = variable_choices(data[["mtcars"]], c("cyl", "gear")),
+ with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI") |
|
| 76 | -+ | ||
| 391 | +! |
- #' selected = "cyl",+ checkmate::assert_class(data, "reactive") |
|
| 77 | -+ | ||
| 392 | +! |
- #' multiple = FALSE,+ checkmate::assert_class(isolate(data()), "teal_data") |
|
| 78 | -+ | ||
| 393 | +! |
- #' fixed = FALSE+ moduleServer(id, function(input, output, session) {
|
|
| 79 | -+ | ||
| 394 | +! |
- #' )+ teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.general") |
|
| 80 | +395 |
- #' ),+ |
|
| 81 | -+ | ||
| 396 | +! |
- #' x = data_extract_spec(+ ns <- session$ns |
|
| 82 | +397 |
- #' dataname = "mtcars",+ |
|
| 83 | -+ | ||
| 398 | +! |
- #' select = select_spec(+ vars <- list(outlier_var = outlier_var, categorical_var = categorical_var) |
|
| 84 | +399 |
- #' label = "Select variable:",+ |
|
| 85 | -+ | ||
| 400 | +! |
- #' choices = variable_choices(data[["mtcars"]], c("vs", "am")),
+ rule_diff <- function(other) {
|
|
| 86 | -+ | ||
| 401 | +! |
- #' selected = "vs",+ function(value) {
|
|
| 87 | -+ | ||
| 402 | +! |
- #' multiple = FALSE,+ othervalue <- tryCatch(selector_list()[[other]]()[["select"]], error = function(e) NULL) |
|
| 88 | -+ | ||
| 403 | +! |
- #' fixed = FALSE+ if (!is.null(othervalue) && identical(othervalue, value)) {
|
|
| 89 | -+ | ||
| 404 | +! |
- #' )+ "`Variable` and `Categorical factor` cannot be the same" |
|
| 90 | +405 |
- #' )+ } |
|
| 91 | +406 |
- #' )+ } |
|
| 92 | +407 |
- #' )+ } |
|
| 93 | +408 |
- #' )+ |
|
| 94 | -+ | ||
| 409 | +! |
- #' if (interactive()) {
+ selector_list <- teal.transform::data_extract_multiple_srv( |
|
| 95 | -+ | ||
| 410 | +! |
- #' shinyApp(app$ui, app$server)+ data_extract = vars, |
|
| 96 | -+ | ||
| 411 | +! |
- #' }+ datasets = data, |
|
| 97 | -+ | ||
| 412 | +! |
- #'+ select_validation_rule = list( |
|
| 98 | -+ | ||
| 413 | +! |
- #' @examplesShinylive+ outlier_var = shinyvalidate::compose_rules( |
|
| 99 | -+ | ||
| 414 | +! |
- #' library(teal.modules.general)+ shinyvalidate::sv_required("Please select a variable"),
|
|
| 100 | -+ | ||
| 415 | +! |
- #' interactive <- function() TRUE+ rule_diff("categorical_var")
|
|
| 101 | +416 |
- #' {{ next_example }}
+ ), |
|
| 102 | -+ | ||
| 417 | +! |
- #' @examples+ categorical_var = rule_diff("outlier_var")
|
|
| 103 | +418 |
- #' # CDISC data example+ ) |
|
| 104 | +419 |
- #' data <- teal_data()+ ) |
|
| 105 | +420 |
- #' data <- within(data, {
+
|
|
| 106 | -+ | ||
| 421 | +! |
- #' require(nestcolor)+ iv_r <- reactive({
|
|
| 107 | -+ | ||
| 422 | +! |
- #' ADSL <- rADSL+ iv <- shinyvalidate::InputValidator$new() |
|
| 108 | -+ | ||
| 423 | +! |
- #' })+ iv$add_rule("method", shinyvalidate::sv_required("Please select a method"))
|
|
| 109 | -+ | ||
| 424 | +! |
- #' join_keys(data) <- default_cdisc_join_keys[names(data)]+ iv$add_rule("boxplot_alts", shinyvalidate::sv_required("Please select Plot Type"))
|
|
| 110 | -+ | ||
| 425 | +! |
- #'+ teal.transform::compose_and_enable_validators(iv, selector_list) |
|
| 111 | +426 |
- #' app <- init(+ }) |
|
| 112 | +427 |
- #' data = data,+ |
|
| 113 | -+ | ||
| 428 | +! |
- #' modules = modules(+ reactive_select_input <- reactive({
|
|
| 114 | -+ | ||
| 429 | +! |
- #' tm_g_response(+ if (is.null(selector_list()$categorical_var) || length(selector_list()$categorical_var()$select) == 0) {
|
|
| 115 | -+ | ||
| 430 | +! |
- #' label = "Response Plots",+ selector_list()[names(selector_list()) != "categorical_var"] |
|
| 116 | +431 |
- #' response = data_extract_spec(+ } else {
|
|
| 117 | -+ | ||
| 432 | +! |
- #' dataname = "ADSL",+ selector_list() |
|
| 118 | +433 |
- #' select = select_spec(+ } |
|
| 119 | +434 |
- #' label = "Select variable:",+ }) |
|
| 120 | +435 |
- #' choices = variable_choices(data[["ADSL"]], c("BMRKR2", "COUNTRY")),
+
|
|
| 121 | -+ | ||
| 436 | +! |
- #' selected = "BMRKR2",+ anl_merged_input <- teal.transform::merge_expression_srv( |
|
| 122 | -+ | ||
| 437 | +! |
- #' multiple = FALSE,+ selector_list = reactive_select_input, |
|
| 123 | -+ | ||
| 438 | +! |
- #' fixed = FALSE+ datasets = data, |
|
| 124 | -+ | ||
| 439 | +! |
- #' )+ merge_function = "dplyr::inner_join" |
|
| 125 | +440 |
- #' ),+ ) |
|
| 126 | +441 |
- #' x = data_extract_spec(+ |
|
| 127 | -+ | ||
| 442 | +! |
- #' dataname = "ADSL",+ anl_merged_q <- reactive({
|
|
| 128 | -+ | ||
| 443 | +! |
- #' select = select_spec(+ req(anl_merged_input()) |
|
| 129 | -+ | ||
| 444 | +! |
- #' label = "Select variable:",+ data() %>% |
|
| 130 | -+ | ||
| 445 | +! |
- #' choices = variable_choices(data[["ADSL"]], c("SEX", "RACE")),
+ teal.code::eval_code(as.expression(anl_merged_input()$expr)) |
|
| 131 | +446 |
- #' selected = "RACE",+ }) |
|
| 132 | +447 |
- #' multiple = FALSE,+ |
|
| 133 | -+ | ||
| 448 | +! |
- #' fixed = FALSE+ merged <- list( |
|
| 134 | -+ | ||
| 449 | +! |
- #' )+ anl_input_r = anl_merged_input, |
|
| 135 | -+ | ||
| 450 | +! |
- #' )+ anl_q_r = anl_merged_q |
|
| 136 | +451 |
- #' )+ ) |
|
| 137 | +452 |
- #' )+ |
|
| 138 | -+ | ||
| 453 | +! |
- #' )+ n_outlier_missing <- reactive({
|
|
| 139 | -+ | ||
| 454 | +! |
- #' if (interactive()) {
+ req(iv_r()$is_valid()) |
|
| 140 | -+ | ||
| 455 | +! |
- #' shinyApp(app$ui, app$server)+ outlier_var <- as.vector(merged$anl_input_r()$columns_source$outlier_var) |
|
| 141 | -+ | ||
| 456 | +! |
- #' }+ ANL <- merged$anl_q_r()[["ANL"]] |
|
| 142 | -+ | ||
| 457 | +! |
- #'+ sum(is.na(ANL[[outlier_var]])) |
|
| 143 | +458 |
- #' @export+ }) |
|
| 144 | +459 |
- #'+ |
|
| 145 | +460 |
- tm_g_response <- function(label = "Response Plot",+ # Used to create outlier table and the dropdown with additional columns |
|
| 146 | -+ | ||
| 461 | +! |
- response,+ dataname_first <- isolate(names(data())[[1]]) |
|
| 147 | +462 |
- x,+ |
|
| 148 | -+ | ||
| 463 | +! |
- row_facet = NULL,+ common_code_q <- reactive({
|
|
| 149 | -+ | ||
| 464 | +! |
- col_facet = NULL,+ req(iv_r()$is_valid()) |
|
| 150 | +465 |
- coord_flip = FALSE,+ |
|
| 151 | -+ | ||
| 466 | +! |
- count_labels = TRUE,+ ANL <- merged$anl_q_r()[["ANL"]] |
|
| 152 | -+ | ||
| 467 | +! |
- rotate_xaxis_labels = FALSE,+ qenv <- merged$anl_q_r() |
|
| 153 | +468 |
- freq = FALSE,+ |
|
| 154 | -+ | ||
| 469 | +! |
- plot_height = c(600, 400, 5000),+ outlier_var <- as.vector(merged$anl_input_r()$columns_source$outlier_var) |
|
| 155 | -+ | ||
| 470 | +! |
- plot_width = NULL,+ categorical_var <- as.vector(merged$anl_input_r()$columns_source$categorical_var) |
|
| 156 | -+ | ||
| 471 | +! |
- ggtheme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void"),
+ order_by_outlier <- input$order_by_outlier |
|
| 157 | -+ | ||
| 472 | +! |
- ggplot2_args = teal.widgets::ggplot2_args(),+ method <- input$method |
|
| 158 | -+ | ||
| 473 | +! |
- pre_output = NULL,+ split_outliers <- input$split_outliers |
|
| 159 | -+ | ||
| 474 | +! |
- post_output = NULL,+ teal::validate_has_data( |
|
| 160 | +475 |
- decorators = NULL) {
+ # missing values in the categorical variable may be used to form a category of its own |
|
| 161 | +476 | ! |
- message("Initializing tm_g_response")
+ `if`( |
| 162 | -+ | ||
| 477 | +! |
-
+ length(categorical_var) == 0, |
|
| 163 | -+ | ||
| 478 | +! |
- # Normalize the parameters+ ANL, |
|
| 164 | +479 | ! |
- if (inherits(response, "data_extract_spec")) response <- list(response)+ ANL[, names(ANL) != categorical_var, drop = FALSE]+ |
+
| 480 | ++ |
+ ), |
|
| 165 | +481 | ! |
- if (inherits(x, "data_extract_spec")) x <- list(x)+ min_nrow = 10, |
| 166 | +482 | ! |
- if (inherits(row_facet, "data_extract_spec")) row_facet <- list(row_facet)+ complete = TRUE, |
| 167 | +483 | ! |
- if (inherits(col_facet, "data_extract_spec")) col_facet <- list(col_facet)+ allow_inf = FALSE |
| 168 | +484 |
-
+ ) |
|
| 169 | -+ | ||
| 485 | +! |
- # Start of assertions+ validate(need(is.numeric(ANL[[outlier_var]]), "`Variable` is not numeric")) |
|
| 170 | +486 | ! |
- checkmate::assert_string(label)+ validate(need(length(unique(ANL[[outlier_var]])) > 1, "Variable has no variation, i.e. only one unique value")) |
| 171 | +487 | ||
| 488 | ++ |
+ # show/hide split_outliers+ |
+ |
| 172 | +489 | ! |
- checkmate::assert_list(response, types = "data_extract_spec")+ if (length(categorical_var) == 0) {
|
| 173 | +490 | ! |
- if (!all(vapply(response, function(x) !("" %in% x$select$choices), logical(1)))) {
+ shinyjs::hide("split_outliers")
|
| 174 | +491 | ! |
- stop("'response' should not allow empty values")
+ if (n_outlier_missing() > 0) {
|
| 175 | -+ | ||
| 492 | +! |
- }+ qenv <- teal.code::eval_code( |
|
| 176 | +493 | ! |
- assert_single_selection(response)+ qenv, |
| 177 | -+ | ||
| 494 | +! |
-
+ substitute( |
|
| 178 | +495 | ! |
- checkmate::assert_list(x, types = "data_extract_spec")+ expr = ANL <- ANL %>% dplyr::filter(!is.na(outlier_var_name)), |
| 179 | +496 | ! |
- if (!all(vapply(x, function(x) !("" %in% x$select$choices), logical(1)))) {
+ env = list(outlier_var_name = as.name(outlier_var)) |
| 180 | -! | +||
| 497 | +
- stop("'x' should not allow empty values")
+ ) |
||
| 181 | +498 |
- }+ ) |
|
| 182 | -! | +||
| 499 | +
- assert_single_selection(x)+ } |
||
| 183 | +500 |
-
+ } else {
|
|
| 184 | +501 | ! |
- checkmate::assert_list(row_facet, types = "data_extract_spec", null.ok = TRUE)+ validate(need( |
| 185 | +502 | ! |
- checkmate::assert_list(col_facet, types = "data_extract_spec", null.ok = TRUE)+ is.factor(ANL[[categorical_var]]) || |
| 186 | +503 | ! |
- checkmate::assert_flag(coord_flip)+ is.character(ANL[[categorical_var]]) || |
| 187 | +504 | ! |
- checkmate::assert_flag(count_labels)+ is.integer(ANL[[categorical_var]]), |
| 188 | +505 | ! |
- checkmate::assert_flag(rotate_xaxis_labels)+ "`Categorical factor` must be `factor`, `character`, or `integer`" |
| 189 | -! | +||
| 506 | +
- checkmate::assert_flag(freq)+ )) |
||
| 190 | +507 | ||
| 191 | +508 | ! |
- checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE)+ if (n_outlier_missing() > 0) {
|
| 192 | +509 | ! |
- checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height")+ qenv <- teal.code::eval_code( |
| 193 | +510 | ! |
- checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE)+ qenv, |
| 194 | +511 | ! |
- checkmate::assert_numeric(+ substitute( |
| 195 | +512 | ! |
- plot_width[1],+ expr = ANL <- ANL %>% dplyr::filter(!is.na(outlier_var_name)), |
| 196 | +513 | ! |
- lower = plot_width[2], upper = plot_width[3], null.ok = TRUE, .var.name = "plot_width"+ env = list(outlier_var_name = as.name(outlier_var)) |
| 197 | +514 |
- )+ ) |
|
| 198 | +515 |
-
+ ) |
|
| 199 | -! | +||
| 516 | +
- ggtheme <- match.arg(ggtheme)+ } |
||
| 200 | +517 | ! |
- checkmate::assert_class(ggplot2_args, "ggplot2_args")+ shinyjs::show("split_outliers")
|
| 201 | +518 | ++ |
+ }+ |
+
| 519 | |||
| 520 | ++ |
+ # slider+ |
+ |
| 202 | +521 | ! |
- checkmate::assert_multi_class(pre_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
+ outlier_definition_param <- if (method == "IQR") {
|
| 203 | +522 | ! |
- checkmate::assert_multi_class(post_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
+ input$iqr_slider |
| 204 | -+ | ||
| 523 | +! |
-
+ } else if (method == "Z-score") {
|
|
| 205 | +524 | ! |
- decorators <- normalize_decorators(decorators)+ input$zscore_slider |
| 206 | +525 | ! |
- assert_decorators(decorators, null.ok = TRUE, "plot")+ } else if (method == "Percentile") {
+ |
+
| 526 | +! | +
+ input$percentile_slider |
|
| 207 | +527 |
- # End of assertions+ } |
|
| 208 | +528 | ||
| 209 | +529 |
- # Make UI args+ # this is utils function that converts a %>% NULL %>% b into a %>% b |
|
| 210 | +530 | ! |
- args <- as.list(environment())+ remove_pipe_null <- function(x) {
|
| 211 | -+ | ||
| 531 | +! |
-
+ if (length(x) == 1) {
|
|
| 212 | +532 | ! |
- data_extract_list <- list(+ return(x) |
| 213 | -! | +||
| 533 | +
- response = response,+ } |
||
| 214 | +534 | ! |
- x = x,+ if (identical(x[[1]], as.name("%>%")) && is.null(x[[3]])) {
|
| 215 | +535 | ! |
- row_facet = row_facet,+ return(remove_pipe_null(x[[2]]))+ |
+
| 536 | ++ |
+ } |
|
| 216 | +537 | ! |
- col_facet = col_facet+ return(as.call(c(x[[1]], lapply(x[-1], remove_pipe_null)))) |
| 217 | +538 |
- )+ } |
|
| 218 | +539 | ||
| 219 | +540 | ! |
- ans <- module(+ qenv <- teal.code::eval_code( |
| 220 | +541 | ! |
- label = label,+ qenv, |
| 221 | +542 | ! |
- server = srv_g_response,+ substitute( |
| 222 | +543 | ! |
- ui = ui_g_response,+ expr = {
|
| 223 | +544 | ! |
- ui_args = args,+ ANL_OUTLIER <- ANL %>% |
| 224 | +545 | ! |
- server_args = c(+ group_expr %>% # styler: off |
| 225 | +546 | ! |
- data_extract_list,+ dplyr::mutate(is_outlier = {
|
| 226 | +547 | ! |
- list(+ q1_q3 <- stats::quantile(outlier_var_name, probs = c(0.25, 0.75)) |
| 227 | +548 | ! |
- plot_height = plot_height,+ iqr <- q1_q3[2] - q1_q3[1] |
| 228 | +549 | ! |
- plot_width = plot_width,+ !(outlier_var_name >= q1_q3[1] - 1.5 * iqr & outlier_var_name <= q1_q3[2] + 1.5 * iqr) |
| 229 | -! | +||
| 550 | +
- ggplot2_args = ggplot2_args,+ }) %>% |
||
| 230 | +551 | ! |
- decorators = decorators+ calculate_outliers %>% # styler: off |
| 231 | -+ | ||
| 552 | +! |
- )+ ungroup_expr %>% # styler: off |
|
| 232 | -+ | ||
| 553 | +! |
- ),+ dplyr::filter(is_outlier | is_outlier_selected) %>% |
|
| 233 | +554 | ! |
- datanames = teal.transform::get_extract_datanames(data_extract_list)+ dplyr::select(-is_outlier) |
| 234 | +555 |
- )+ }, |
|
| 235 | +556 | ! |
- attr(ans, "teal_bookmarkable") <- TRUE+ env = list( |
| 236 | +557 | ! |
- ans+ calculate_outliers = if (method == "IQR") {
|
| 237 | -+ | ||
| 558 | +! |
- }+ substitute( |
|
| 238 | -+ | ||
| 559 | +! |
-
+ expr = dplyr::mutate(is_outlier_selected = {
|
|
| 239 | -+ | ||
| 560 | +! |
- # UI function for the response module+ q1_q3 <- stats::quantile(outlier_var_name, probs = c(0.25, 0.75))+ |
+ |
| 561 | +! | +
+ iqr <- q1_q3[2] - q1_q3[1] |
|
| 240 | +562 |
- ui_g_response <- function(id, ...) {
+ !( |
|
| 241 | +563 | ! |
- ns <- NS(id)+ outlier_var_name >= q1_q3[1] - outlier_definition_param * iqr & |
| 242 | +564 | ! |
- args <- list(...)+ outlier_var_name <= q1_q3[2] + outlier_definition_param * iqr |
| 243 | -! | +||
| 565 | +
- is_single_dataset_value <- teal.transform::is_single_dataset(args$response, args$x, args$row_facet, args$col_facet)+ ) |
||
| 244 | +566 |
-
+ }), |
|
| 245 | +567 | ! |
- teal.widgets::standard_layout(+ env = list( |
| 246 | +568 | ! |
- output = teal.widgets::white_small_well(+ outlier_var_name = as.name(outlier_var), |
| 247 | +569 | ! |
- teal.widgets::plot_with_settings_ui(id = ns("myplot"))
+ outlier_definition_param = outlier_definition_param |
| 248 | +570 |
- ),- |
- |
| 249 | -! | -
- encoding = tags$div(+ ) |
|
| 250 | +571 |
- ### Reporter+ ) |
|
| 251 | +572 | ! |
- teal.reporter::simple_reporter_ui(ns("simple_reporter")),
+ } else if (method == "Z-score") {
|
| 252 | -+ | ||
| 573 | +! |
- ###+ substitute( |
|
| 253 | +574 | ! |
- tags$label("Encodings", class = "text-primary"),
+ expr = dplyr::mutate( |
| 254 | +575 | ! |
- teal.transform::datanames_input(args[c("response", "x", "row_facet", "col_facet")]),
+ is_outlier_selected = abs(outlier_var_name - mean(outlier_var_name)) / |
| 255 | +576 | ! |
- teal.transform::data_extract_ui(+ stats::sd(outlier_var_name) > outlier_definition_param |
| 256 | -! | +||
| 577 | +
- id = ns("response"),
+ ), |
||
| 257 | +578 | ! |
- label = "Response variable",+ env = list( |
| 258 | +579 | ! |
- data_extract_spec = args$response,+ outlier_var_name = as.name(outlier_var), |
| 259 | +580 | ! |
- is_single_dataset = is_single_dataset_value+ outlier_definition_param = outlier_definition_param |
| 260 | +581 |
- ),+ ) |
|
| 261 | -! | +||
| 582 | +
- teal.transform::data_extract_ui(+ ) |
||
| 262 | +583 | ! |
- id = ns("x"),
+ } else if (method == "Percentile") {
|
| 263 | +584 | ! |
- label = "X variable",+ substitute( |
| 264 | +585 | ! |
- data_extract_spec = args$x,+ expr = dplyr::mutate( |
| 265 | +586 | ! |
- is_single_dataset = is_single_dataset_value- |
-
| 266 | -- |
- ),+ is_outlier_selected = outlier_var_name < stats::quantile(outlier_var_name, outlier_definition_param) | |
|
| 267 | +587 | ! |
- if (!is.null(args$row_facet)) {
+ outlier_var_name > stats::quantile(outlier_var_name, 1 - outlier_definition_param) |
| 268 | -! | +||
| 588 | +
- teal.transform::data_extract_ui(+ ), |
||
| 269 | +589 | ! |
- id = ns("row_facet"),
+ env = list( |
| 270 | +590 | ! |
- label = "Row facetting",+ outlier_var_name = as.name(outlier_var), |
| 271 | +591 | ! |
- data_extract_spec = args$row_facet,+ outlier_definition_param = outlier_definition_param |
| 272 | -! | +||
| 592 | +
- is_single_dataset = is_single_dataset_value+ ) |
||
| 273 | +593 |
- )+ ) |
|
| 274 | +594 |
- },+ }, |
|
| 275 | +595 | ! |
- if (!is.null(args$col_facet)) {
+ outlier_var_name = as.name(outlier_var), |
| 276 | +596 | ! |
- teal.transform::data_extract_ui(+ group_expr = if (isTRUE(split_outliers) && length(categorical_var) != 0) {
|
| 277 | +597 | ! |
- id = ns("col_facet"),
+ substitute(dplyr::group_by(x), list(x = as.name(categorical_var))) |
| 278 | -! | +||
| 598 | +
- label = "Column facetting",+ }, |
||
| 279 | +599 | ! |
- data_extract_spec = args$col_facet,+ ungroup_expr = if (isTRUE(split_outliers) && length(categorical_var) != 0) {
|
| 280 | +600 | ! |
- is_single_dataset = is_single_dataset_value+ substitute(dplyr::ungroup()) |
| 281 | +601 |
- )+ } |
|
| 282 | +602 |
- },+ ) |
|
| 283 | -! | +||
| 603 | +
- shinyWidgets::radioGroupButtons(+ ) %>% |
||
| 284 | +604 | ! |
- inputId = ns("freq"),
+ remove_pipe_null() |
| 285 | -! | +||
| 605 | +
- label = NULL,+ ) |
||
| 286 | -! | +||
| 606 | +
- choices = c("frequency", "density"),
+
|
||
| 287 | -! | +||
| 607 | +
- selected = ifelse(args$freq, "frequency", "density"),+ # ANL_OUTLIER_EXTENDED is the base table |
||
| 288 | +608 | ! |
- justified = TRUE+ qenv <- teal.code::eval_code( |
| 289 | -+ | ||
| 609 | +! |
- ),+ qenv, |
|
| 290 | +610 | ! |
- ui_decorate_teal_data(ns("decorator"), decorators = select_decorators(args$decorators, "plot")),
+ substitute( |
| 291 | +611 | ! |
- teal.widgets::panel_group(+ expr = {
|
| 292 | +612 | ! |
- teal.widgets::panel_item(+ ANL_OUTLIER_EXTENDED <- dplyr::left_join( |
| 293 | +613 | ! |
- title = "Plot settings",+ ANL_OUTLIER, |
| 294 | +614 | ! |
- checkboxInput(ns("count_labels"), "Add count labels", value = args$count_labels),
+ dplyr::select( |
| 295 | +615 | ! |
- checkboxInput(ns("coord_flip"), "Swap axes", value = args$coord_flip),
+ dataname, |
| 296 | +616 | ! |
- checkboxInput(ns("rotate_xaxis_labels"), "Rotate X axis labels", value = args$rotate_xaxis_labels),
+ dplyr::setdiff(names(dataname), dplyr::setdiff(names(ANL_OUTLIER), join_keys)) |
| 297 | -! | +||
| 617 | +
- selectInput(+ ), |
||
| 298 | +618 | ! |
- inputId = ns("ggtheme"),
+ by = join_keys |
| 299 | -! | +||
| 619 | +
- label = "Theme (by ggplot):",+ )+ |
+ ||
| 620 | ++ |
+ }, |
|
| 300 | +621 | ! |
- choices = ggplot_themes,+ env = list( |
| 301 | +622 | ! |
- selected = args$ggtheme,+ dataname = as.name(dataname_first), |
| 302 | +623 | ! |
- multiple = FALSE+ join_keys = as.character(teal.data::join_keys(data())[dataname_first, dataname_first]) |
| 303 | +624 |
) |
|
| 304 | +625 |
) |
|
| 305 | +626 |
) |
|
| 306 | +627 |
- ),+ |
|
| 307 | +628 | ! |
- forms = tagList(+ qenv <- if (length(categorical_var) > 0) {
|
| 308 | +629 | ! |
- teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code")
+ qenv <- teal.code::eval_code( |
| 309 | -+ | ||
| 630 | +! |
- ),+ qenv, |
|
| 310 | +631 | ! |
- pre_output = args$pre_output,+ substitute( |
| 311 | +632 | ! |
- post_output = args$post_output+ expr = summary_table_pre <- ANL_OUTLIER %>% |
| 312 | -+ | ||
| 633 | +! |
- )+ dplyr::filter(is_outlier_selected) %>% |
|
| 313 | -+ | ||
| 634 | +! |
- }+ dplyr::select(outlier_var_name, categorical_var_name) %>% |
|
| 314 | -+ | ||
| 635 | +! |
-
+ dplyr::group_by(categorical_var_name) %>% |
|
| 315 | -+ | ||
| 636 | +! |
- # Server function for the response module+ dplyr::summarise(n_outliers = dplyr::n()) %>% |
|
| 316 | -+ | ||
| 637 | +! |
- srv_g_response <- function(id,+ dplyr::right_join( |
|
| 317 | -+ | ||
| 638 | +! |
- data,+ ANL %>% |
|
| 318 | -+ | ||
| 639 | +! |
- reporter,+ dplyr::select(outlier_var_name, categorical_var_name) %>% |
|
| 319 | -+ | ||
| 640 | +! |
- filter_panel_api,+ dplyr::group_by(categorical_var_name) %>% |
|
| 320 | -+ | ||
| 641 | +! |
- response,+ dplyr::summarise( |
|
| 321 | -+ | ||
| 642 | +! |
- x,+ total_in_cat = dplyr::n(), |
|
| 322 | -+ | ||
| 643 | +! |
- row_facet,+ n_na = sum(is.na(outlier_var_name) | is.na(categorical_var_name)) |
|
| 323 | +644 |
- col_facet,+ ),+ |
+ |
| 645 | +! | +
+ by = categorical_var |
|
| 324 | +646 |
- plot_height,+ ) %>% |
|
| 325 | +647 |
- plot_width,+ # This is important as there may be categorical variables with natural orderings, e.g. AGE. |
|
| 326 | +648 |
- ggplot2_args,+ # The plots should be displayed by default in increasing order in these situations. |
|
| 327 | +649 |
- decorators) {
+ # dplyr::arrange will sort integer, factor, and character data types in the expected way. |
|
| 328 | +650 | ! |
- with_reporter <- !missing(reporter) && inherits(reporter, "Reporter")+ dplyr::arrange(categorical_var_name) %>% |
| 329 | +651 | ! |
- with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI")+ dplyr::mutate( |
| 330 | +652 | ! |
- checkmate::assert_class(data, "reactive")+ n_outliers = dplyr::if_else(is.na(n_outliers), 0, as.numeric(n_outliers)), |
| 331 | +653 | ! |
- checkmate::assert_class(isolate(data()), "teal_data")+ display_str = dplyr::if_else( |
| 332 | +654 | ! |
- moduleServer(id, function(input, output, session) {
+ n_outliers > 0, |
| 333 | +655 | ! |
- teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.general")+ sprintf("%d [%.02f%%]", n_outliers, 100 * n_outliers / total_in_cat),
+ |
+
| 656 | +! | +
+ "0" |
|
| 334 | +657 |
-
+ ), |
|
| 335 | +658 | ! |
- data_extract <- list(response = response, x = x, row_facet = row_facet, col_facet = col_facet)+ display_str_na = dplyr::if_else( |
| 336 | -+ | ||
| 659 | +! |
-
+ n_na > 0, |
|
| 337 | +660 | ! |
- rule_diff <- function(other) {
+ sprintf("%d [%.02f%%]", n_na, 100 * n_na / total_in_cat),
|
| 338 | +661 | ! |
- function(value) {
+ "0" |
| 339 | -! | +||
| 662 | +
- if (other %in% names(selector_list())) {
+ ), |
||
| 340 | +663 | ! |
- othervalue <- selector_list()[[other]]()[["select"]]+ order = seq_along(n_outliers)+ |
+
| 664 | ++ |
+ ), |
|
| 341 | +665 | ! |
- if (!is.null(othervalue)) {
+ env = list( |
| 342 | +666 | ! |
- if (identical(value, othervalue)) {
+ categorical_var = categorical_var, |
| 343 | +667 | ! |
- "Row and column facetting variables must be different."+ categorical_var_name = as.name(categorical_var), |
| 344 | -+ | ||
| 668 | +! |
- }+ outlier_var_name = as.name(outlier_var) |
|
| 345 | +669 |
- }+ ) |
|
| 346 | +670 |
- }+ ) |
|
| 347 | +671 |
- }+ ) |
|
| 348 | +672 |
- }+ # now to handle when user chooses to order based on amount of outliers |
|
| 349 | -+ | ||
| 673 | +! |
-
+ if (order_by_outlier) {
|
|
| 350 | +674 | ! |
- selector_list <- teal.transform::data_extract_multiple_srv(+ qenv <- teal.code::eval_code( |
| 351 | +675 | ! |
- data_extract = data_extract,+ qenv, |
| 352 | +676 | ! |
- datasets = data,+ quote( |
| 353 | +677 | ! |
- select_validation_rule = list(+ summary_table_pre <- summary_table_pre %>% |
| 354 | +678 | ! |
- response = shinyvalidate::sv_required("Please define a column for the response variable"),
+ dplyr::arrange(desc(n_outliers / total_in_cat)) %>% |
| 355 | +679 | ! |
- x = shinyvalidate::sv_required("Please define a column for X variable"),
+ dplyr::mutate(order = seq_len(nrow(summary_table_pre)))+ |
+
| 680 | ++ |
+ )+ |
+ |
| 681 | ++ |
+ )+ |
+ |
| 682 | ++ |
+ }+ |
+ |
| 683 | ++ | + | |
| 356 | +684 | ! |
- row_facet = shinyvalidate::compose_rules(+ teal.code::eval_code( |
| 357 | +685 | ! |
- shinyvalidate::sv_optional(),+ qenv, |
| 358 | +686 | ! |
- ~ if (length(.) > 1) "There must be 1 or no row facetting variable.",+ substitute( |
| 359 | +687 | ! |
- rule_diff("col_facet")
+ expr = {
|
| 360 | +688 | ++ |
+ # In order for geom_rug to work properly when reordering takes place inside facet_grid,+ |
+
| 689 | ++ |
+ # all tables must have the column used for reording.+ |
+ |
| 690 |
- ),+ # In this case, the column used for reordering is `order`. |
||
| 361 | +691 | ! |
- col_facet = shinyvalidate::compose_rules(+ ANL_OUTLIER <- dplyr::left_join( |
| 362 | +692 | ! |
- shinyvalidate::sv_optional(),+ ANL_OUTLIER, |
| 363 | +693 | ! |
- ~ if (length(.) > 1) "There must be 1 or no column facetting variable.",+ summary_table_pre[, c("order", categorical_var)],
|
| 364 | +694 | ! |
- rule_diff("row_facet")
- |
-
| 365 | -- |
- )- |
- |
| 366 | -- |
- )+ by = categorical_var |
|
| 367 | +695 |
- )+ ) |
|
| 368 | +696 |
-
+ # so that x axis of plot aligns with columns of summary table, from most outliers to least by percentage |
|
| 369 | +697 | ! |
- iv_r <- reactive({
+ ANL <- ANL %>% |
| 370 | +698 | ! |
- iv <- shinyvalidate::InputValidator$new()+ dplyr::left_join( |
| 371 | +699 | ! |
- iv$add_rule("ggtheme", shinyvalidate::sv_required("Please select a theme"))
+ dplyr::select(summary_table_pre, categorical_var_name, order), |
| 372 | +700 | ! |
- teal.transform::compose_and_enable_validators(iv, selector_list)+ by = categorical_var |
| 373 | +701 |
- })+ ) %>% |
|
| 374 | -+ | ||
| 702 | +! |
-
+ dplyr::arrange(order) |
|
| 375 | +703 | ! |
- anl_merged_input <- teal.transform::merge_expression_srv(+ summary_table <- summary_table_pre %>% |
| 376 | +704 | ! |
- selector_list = selector_list,+ dplyr::select( |
| 377 | +705 | ! |
- datasets = data+ categorical_var_name, |
| 378 | -+ | ||
| 706 | +! |
- )+ Outliers = display_str, Missings = display_str_na, Total = total_in_cat |
|
| 379 | +707 |
-
+ ) %>% |
|
| 380 | +708 | ! |
- anl_merged_q <- reactive({
+ dplyr::mutate_all(as.character) %>% |
| 381 | +709 | ! |
- req(anl_merged_input())+ tidyr::pivot_longer(-categorical_var_name) %>% |
| 382 | +710 | ! |
- data() %>%+ tidyr::pivot_wider(names_from = categorical_var, values_from = value) %>% |
| 383 | +711 | ! |
- teal.code::eval_code(as.expression(anl_merged_input()$expr))+ tibble::column_to_rownames("name")
|
| 384 | +712 |
- })+ }, |
|
| 385 | -+ | ||
| 713 | +! |
-
+ env = list( |
|
| 386 | +714 | ! |
- merged <- list(+ categorical_var = categorical_var, |
| 387 | +715 | ! |
- anl_input_r = anl_merged_input,+ categorical_var_name = as.name(categorical_var) |
| 388 | -! | +||
| 716 | +
- anl_q_r = anl_merged_q+ ) |
||
| 389 | +717 |
- )+ ) |
|
| 390 | +718 |
-
+ ) |
|
| 391 | -! | +||
| 719 | +
- output_q <- reactive({
+ } else {
|
||
| 392 | +720 | ! |
- teal::validate_inputs(iv_r())+ within(qenv, summary_table <- data.frame()) |
| 393 | +721 | ++ |
+ }+ |
+
| 722 | |||
| 394 | -! | +||
| 723 | +
- qenv <- merged$anl_q_r()+ # Datatable is generated in qenv to allow for output decoration |
||
| 395 | +724 | ! |
- ANL <- qenv[["ANL"]]+ qenv <- within(qenv, {
|
| 396 | +725 | ! |
- resp_var <- as.vector(merged$anl_input_r()$columns_source$response)+ table <- DT::datatable( |
| 397 | +726 | ! |
- x <- as.vector(merged$anl_input_r()$columns_source$x)+ summary_table, |
| 398 | -+ | ||
| 727 | +! |
-
+ options = list( |
|
| 399 | +728 | ! |
- validate(need(is.factor(ANL[[resp_var]]), "Please select a factor variable as the response."))+ dom = "t", |
| 400 | +729 | ! |
- validate(need(is.factor(ANL[[x]]), "Please select a factor variable as the X-Variable."))+ autoWidth = TRUE, |
| 401 | +730 | ! |
- teal::validate_has_data(ANL, 10)+ columnDefs = list(list(width = "200px", targets = "_all")) |
| 402 | -! | +||
| 731 | +
- teal::validate_has_data(ANL[, c(resp_var, x)], 10, complete = TRUE, allow_inf = FALSE)+ ) |
||
| 403 | +732 | ++ |
+ )+ |
+
| 733 | ++ |
+ })+ |
+ |
| 734 | |||
| 404 | +735 | ! |
- row_facet_name <- if (length(merged$anl_input_r()$columns_source$row_facet) == 0) {
+ if (length(categorical_var) > 0 && nrow(qenv[["ANL_OUTLIER"]]) > 0) {
|
| 405 | +736 | ! |
- character(0)+ shinyjs::show("order_by_outlier")
|
| 406 | +737 |
} else {
|
|
| 407 | +738 | ! |
- as.vector(merged$anl_input_r()$columns_source$row_facet)+ shinyjs::hide("order_by_outlier")
|
| 408 | +739 |
} |
|
| 409 | -! | +||
| 740 | +
- col_facet_name <- if (length(merged$anl_input_r()$columns_source$col_facet) == 0) {
+
|
||
| 410 | +741 | ! |
- character(0)+ qenv |
| 411 | +742 |
- } else {
+ }) |
|
| 412 | -! | +||
| 743 | +
- as.vector(merged$anl_input_r()$columns_source$col_facet)+ |
||
| 413 | +744 |
- }+ # boxplot/violinplot # nolint commented_code |
|
| 414 | -+ | ||
| 745 | +! |
-
+ box_plot_q <- reactive({
|
|
| 415 | +746 | ! |
- freq <- input$freq == "frequency"+ req(common_code_q()) |
| 416 | +747 | ! |
- swap_axes <- input$coord_flip+ ANL <- common_code_q()[["ANL"]] |
| 417 | +748 | ! |
- counts <- input$count_labels+ ANL_OUTLIER <- common_code_q()[["ANL_OUTLIER"]]+ |
+
| 749 | ++ | + | |
| 418 | +750 | ! |
- rotate_xaxis_labels <- input$rotate_xaxis_labels+ outlier_var <- as.vector(merged$anl_input_r()$columns_source$outlier_var) |
| 419 | +751 | ! |
- ggtheme <- input$ggtheme+ categorical_var <- as.vector(merged$anl_input_r()$columns_source$categorical_var) |
| 420 | +752 | ||
| 753 | ++ |
+ # validation+ |
+ |
| 421 | +754 | ! |
- arg_position <- if (freq) "stack" else "fill"+ teal::validate_has_data(ANL, 1) |
| 422 | +755 | ||
| 756 | ++ |
+ # boxplot+ |
+ |
| 423 | +757 | ! |
- rowf <- if (length(row_facet_name) != 0) as.name(row_facet_name)+ plot_call <- quote(ANL %>% ggplot())+ |
+
| 758 | ++ | + | |
| 424 | +759 | ! |
- colf <- if (length(col_facet_name) != 0) as.name(col_facet_name)+ plot_call <- if (input$boxplot_alts == "Box plot") {
|
| 425 | +760 | ! |
- resp_cl <- as.name(resp_var)+ substitute(expr = plot_call + geom_boxplot(outlier.shape = NA), env = list(plot_call = plot_call)) |
| 426 | +761 | ! |
- x_cl <- as.name(x)+ } else if (input$boxplot_alts == "Violin plot") {
+ |
+
| 762 | +! | +
+ substitute(expr = plot_call + geom_violin(), env = list(plot_call = plot_call)) |
|
| 427 | +763 |
-
+ } else {
|
|
| 428 | +764 | ! |
- if (swap_axes) {
+ NULL+ |
+
| 765 | ++ |
+ }+ |
+ |
| 766 | ++ | + | |
| 429 | +767 | ! |
- qenv <- teal.code::eval_code(+ plot_call <- if (identical(categorical_var, character(0)) || is.null(categorical_var)) {
|
| 430 | +768 | ! |
- qenv,+ inner_call <- substitute( |
| 431 | +769 | ! |
- substitute(+ expr = plot_call + |
| 432 | +770 | ! |
- expr = ANL[[x]] <- with(ANL, forcats::fct_rev(x_cl)),+ aes(x = "Entire dataset", y = outlier_var_name) + |
| 433 | +771 | ! |
- env = list(x = x, x_cl = x_cl)+ scale_x_discrete(), |
| 434 | -+ | ||
| 772 | +! |
- )+ env = list(plot_call = plot_call, outlier_var_name = as.name(outlier_var)) |
|
| 435 | +773 |
) |
|
| 436 | -+ | ||
| 774 | +! |
- }+ if (nrow(ANL_OUTLIER) > 0) {
|
|
| 437 | -+ | ||
| 775 | +! |
-
+ substitute( |
|
| 438 | +776 | ! |
- qenv <- teal.code::eval_code(+ expr = inner_call + geom_point( |
| 439 | +777 | ! |
- qenv,+ data = ANL_OUTLIER, |
| 440 | +778 | ! |
- substitute(+ aes(x = "Entire dataset", y = outlier_var_name, color = is_outlier_selected) |
| 441 | -! | +||
| 779 | +
- expr = ANL[[resp_var]] <- factor(ANL[[resp_var]]),+ ), |
||
| 442 | +780 | ! |
- env = list(resp_var = resp_var)+ env = list(inner_call = inner_call, outlier_var_name = as.name(outlier_var)) |
| 443 | +781 |
- )+ ) |
|
| 444 | +782 |
- ) %>%+ } else {
+ |
+ |
| 783 | +! | +
+ inner_call |
|
| 445 | +784 |
- # rowf and colf will be a NULL if not set by a user+ } |
|
| 446 | -! | +||
| 785 | +
- teal.code::eval_code(+ } else {
|
||
| 447 | +786 | ! |
- substitute(+ substitute( |
| 448 | +787 | ! |
- expr = ANL2 <- ANL %>%+ expr = plot_call + |
| 449 | +788 | ! |
- dplyr::group_by_at(dplyr::vars(x_cl, resp_cl, rowf, colf)) %>%+ aes(y = outlier_var_name, x = reorder(categorical_var_name, order)) + |
| 450 | +789 | ! |
- dplyr::summarise(ns = dplyr::n()) %>%+ xlab(categorical_var) + |
| 451 | +790 | ! |
- dplyr::group_by_at(dplyr::vars(x_cl, rowf, colf)) %>%+ scale_x_discrete() + |
| 452 | +791 | ! |
- dplyr::mutate(sums = sum(ns), percent = round(ns / sums * 100, 1)),+ geom_point( |
| 453 | +792 | ! |
- env = list(x_cl = x_cl, resp_cl = resp_cl, rowf = rowf, colf = colf)+ data = ANL_OUTLIER, |
| 454 | -+ | ||
| 793 | +! |
- )+ aes(x = as.factor(categorical_var_name), y = outlier_var_name, color = is_outlier_selected) |
|
| 455 | +794 |
- ) %>%+ ), |
|
| 456 | +795 | ! |
- teal.code::eval_code(+ env = list( |
| 457 | +796 | ! |
- substitute(+ plot_call = plot_call, |
| 458 | +797 | ! |
- expr = ANL3 <- ANL %>%+ outlier_var_name = as.name(outlier_var), |
| 459 | +798 | ! |
- dplyr::group_by_at(dplyr::vars(x_cl, rowf, colf)) %>%+ categorical_var_name = as.name(categorical_var), |
| 460 | +799 | ! |
- dplyr::summarise(ns = dplyr::n()),+ categorical_var = categorical_var |
| 461 | -! | +||
| 800 | +
- env = list(x_cl = x_cl, rowf = rowf, colf = colf)+ ) |
||
| 462 | +801 |
- )+ ) |
|
| 463 | +802 |
- )+ } |
|
| 464 | +803 | ||
| 465 | +804 | ! |
- plot_call <- substitute(+ dev_ggplot2_args <- teal.widgets::ggplot2_args( |
| 466 | +805 | ! |
- expr = ggplot(ANL2, aes(x = x_cl, y = ns)) ++ labs = list(color = "Is outlier?"), |
| 467 | +806 | ! |
- geom_bar(aes(fill = resp_cl), stat = "identity", position = arg_position),+ theme = list(legend.position = "top") |
| 468 | -! | +||
| 807 | +
- env = list(+ )+ |
+ ||
| 808 | ++ | + | |
| 469 | +809 | ! |
- x_cl = x_cl,+ all_ggplot2_args <- teal.widgets::resolve_ggplot2_args( |
| 470 | +810 | ! |
- resp_cl = resp_cl,+ user_plot = ggplot2_args[["Boxplot"]], |
| 471 | +811 | ! |
- arg_position = arg_position+ user_default = ggplot2_args$default, |
| 472 | -+ | ||
| 812 | +! |
- )+ module_plot = dev_ggplot2_args |
|
| 473 | +813 |
) |
|
| 474 | +814 | ||
| 475 | -! | -
- if (!freq) {
- |
- |
| 476 | +815 | ! |
- plot_call <- substitute(+ parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args( |
| 477 | +816 | ! |
- plot_call + expand_limits(y = c(0, 1.1)),+ all_ggplot2_args, |
| 478 | +817 | ! |
- env = list(plot_call = plot_call)- |
-
| 479 | -- |
- )+ ggtheme = input$ggtheme |
|
| 480 | +818 |
- }+ ) |
|
| 481 | +819 | ||
| 482 | -! | -
- if (counts) {
- |
- |
| 483 | -! | -
- plot_call <- substitute(- |
- |
| 484 | +820 | ! |
- expr = plot_call ++ teal.code::eval_code( |
| 485 | +821 | ! |
- geom_text(+ common_code_q(), |
| 486 | +822 | ! |
- data = ANL2,+ substitute( |
| 487 | +823 | ! |
- aes(label = ns, x = x_cl, y = ns, group = resp_cl),+ expr = box_plot <- plot_call + |
| 488 | +824 | ! |
- col = "white",+ scale_color_manual(values = c("TRUE" = "red", "FALSE" = "black")) +
|
| 489 | +825 | ! |
- vjust = "middle",+ labs + ggthemes + themes, |
| 490 | +826 | ! |
- hjust = "middle",+ env = list( |
| 491 | +827 | ! |
- position = position_anl2_value- |
-
| 492 | -- |
- ) ++ plot_call = plot_call, |
|
| 493 | +828 | ! |
- geom_text(+ labs = parsed_ggplot2_args$labs, |
| 494 | +829 | ! |
- data = ANL3, aes(label = ns, x = x_cl, y = anl3_y),+ ggthemes = parsed_ggplot2_args$ggtheme, |
| 495 | +830 | ! |
- hjust = hjust_value,+ themes = parsed_ggplot2_args$theme |
| 496 | -! | +||
| 831 | +
- vjust = vjust_value,+ ) |
||
| 497 | -! | +||
| 832 | +
- position = position_anl3_value+ ) |
||
| 498 | +833 |
- ),+ ) |
|
| 499 | -! | +||
| 834 | +
- env = list(+ }) |
||
| 500 | -! | +||
| 835 | +
- plot_call = plot_call,+ |
||
| 501 | -! | +||
| 836 | +
- x_cl = x_cl,+ # density plot |
||
| 502 | +837 | ! |
- resp_cl = resp_cl,+ density_plot_q <- reactive({
|
| 503 | +838 | ! |
- hjust_value = if (swap_axes) "left" else "middle",+ ANL <- common_code_q()[["ANL"]] |
| 504 | +839 | ! |
- vjust_value = if (swap_axes) "middle" else -1,+ ANL_OUTLIER <- common_code_q()[["ANL_OUTLIER"]] |
| 505 | -! | +||
| 840 | +
- position_anl2_value = if (!freq) quote(position_fill(0.5)) else quote(position_stack(0.5)), # nolint: line_length.+ |
||
| 506 | +841 | ! |
- anl3_y = if (!freq) 1.1 else as.name("ns"),
+ outlier_var <- as.vector(merged$anl_input_r()$columns_source$outlier_var) |
| 507 | +842 | ! |
- position_anl3_value = if (!freq) "fill" else "stack"+ categorical_var <- as.vector(merged$anl_input_r()$columns_source$categorical_var) |
| 508 | +843 |
- )+ |
|
| 509 | +844 |
- )+ # validation |
|
| 510 | -+ | ||
| 845 | +! |
- }+ teal::validate_has_data(ANL, 1) |
|
| 511 | +846 |
-
+ # plot |
|
| 512 | +847 | ! |
- if (swap_axes) {
+ plot_call <- substitute( |
| 513 | +848 | ! |
- plot_call <- substitute(plot_call + coord_flip(), env = list(plot_call = plot_call))- |
-
| 514 | -- |
- }+ expr = ANL %>% |
|
| 515 | -+ | ||
| 849 | +! |
-
+ ggplot(aes(x = outlier_var_name)) + |
|
| 516 | +850 | ! |
- facet_cl <- facet_ggplot_call(row_facet_name, col_facet_name)+ geom_density() + |
| 517 | -+ | ||
| 851 | +! |
-
+ geom_rug(data = ANL_OUTLIER, aes(x = outlier_var_name, color = is_outlier_selected)) + |
|
| 518 | +852 | ! |
- if (!is.null(facet_cl)) {
+ scale_color_manual(values = c("TRUE" = "red", "FALSE" = "black")),
|
| 519 | +853 | ! |
- plot_call <- substitute(expr = plot_call + facet_cl, env = list(plot_call = plot_call, facet_cl = facet_cl))+ env = list(outlier_var_name = as.name(outlier_var)) |
| 520 | +854 |
- }+ ) |
|
| 521 | +855 | ||
| 522 | +856 | ! |
- dev_ggplot2_args <- teal.widgets::ggplot2_args(+ plot_call <- if (identical(categorical_var, character(0)) || is.null(categorical_var)) {
|
| 523 | +857 | ! |
- labs = list(+ substitute(expr = plot_call, env = list(plot_call = plot_call))+ |
+
| 858 | ++ |
+ } else {
|
|
| 524 | +859 | ! |
- x = varname_w_label(x, ANL),+ substitute( |
| 525 | +860 | ! |
- y = varname_w_label(resp_var, ANL, prefix = "Proportion of "),+ expr = plot_call + facet_grid(~ reorder(categorical_var_name, order)), |
| 526 | +861 | ! |
- fill = varname_w_label(resp_var, ANL)+ env = list(plot_call = plot_call, categorical_var_name = as.name(categorical_var)) |
| 527 | +862 |
- ),- |
- |
| 528 | -! | -
- theme = list(legend.position = "bottom")+ ) |
|
| 529 | +863 |
- )+ } |
|
| 530 | +864 | ||
| 531 | +865 | ! |
- if (rotate_xaxis_labels) {
+ dev_ggplot2_args <- teal.widgets::ggplot2_args( |
| 532 | +866 | ! |
- dev_ggplot2_args$theme[["axis.text.x"]] <- quote(element_text(angle = 45, hjust = 1))+ labs = list(color = "Is outlier?"),+ |
+
| 867 | +! | +
+ theme = list(legend.position = "top") |
|
| 533 | +868 |
- }+ ) |
|
| 534 | +869 | ||
| 535 | +870 | ! |
all_ggplot2_args <- teal.widgets::resolve_ggplot2_args( |
| 536 | +871 | ! |
- user_plot = ggplot2_args,+ user_plot = ggplot2_args[["Density Plot"]], |
| 537 | +872 | +! | +
+ user_default = ggplot2_args$default,+ |
+
| 873 | ! |
module_plot = dev_ggplot2_args |
|
| 538 | +874 |
) |
|
| 539 | +875 | ||
| 540 | +876 | ! |
parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args( |
| 541 | +877 | ! |
all_ggplot2_args, |
| 542 | +878 | ! |
- ggtheme = ggtheme+ ggtheme = input$ggtheme |
| 543 | +879 |
) |
|
| 544 | +880 | ||
| 545 | +881 | ! |
- plot_call <- substitute(expr = {
+ teal.code::eval_code( |
| 546 | +882 | ! |
- plot <- plot_call + labs + ggthemes + themes+ common_code_q(), |
| 547 | +883 | ! |
- }, env = list(+ substitute( |
| 548 | +884 | ! |
- plot_call = plot_call,+ expr = density_plot <- plot_call + labs + ggthemes + themes, |
| 549 | +885 | ! |
- labs = parsed_ggplot2_args$labs,+ env = list( |
| 550 | +886 | ! |
- themes = parsed_ggplot2_args$theme,+ plot_call = plot_call, |
| 551 | +887 | ! |
- ggthemes = parsed_ggplot2_args$ggtheme+ labs = parsed_ggplot2_args$labs,+ |
+
| 888 | +! | +
+ themes = parsed_ggplot2_args$theme,+ |
+ |
| 889 | +! | +
+ ggthemes = parsed_ggplot2_args$ggtheme |
|
| 552 | +890 |
- ))+ ) |
|
| 553 | +891 | ++ |
+ )+ |
+
| 892 | ++ |
+ )+ |
+ |
| 893 | ++ |
+ })+ |
+ |
| 894 | ++ | + + | +|
| 895 |
-
+ # Cumulative distribution plot+ |
+ ||
| 896 | +! | +
+ cumulative_plot_q <- reactive({
|
|
| 554 | +897 | ! |
- teal.code::eval_code(qenv, plot_call)+ ANL <- common_code_q()[["ANL"]] |
| 555 | -+ | ||
| 898 | +! |
- })+ ANL_OUTLIER <- common_code_q()[["ANL_OUTLIER"]] |
|
| 556 | +899 | ||
| 557 | -! | -
- decorated_output_plot_q <- srv_decorate_teal_data(- |
- |
| 558 | +900 | ! |
- id = "decorator",+ qenv <- common_code_q() |
| 559 | -! | +||
| 901 | +
- data = output_q,+ |
||
| 560 | +902 | ! |
- decorators = select_decorators(decorators, "plot"),+ outlier_var <- as.vector(merged$anl_input_r()$columns_source$outlier_var) |
| 561 | +903 | ! |
- expr = print(plot)+ categorical_var <- as.vector(merged$anl_input_r()$columns_source$categorical_var) |
| 562 | +904 |
- )+ |
|
| 563 | +905 |
-
+ # validation |
|
| 564 | +906 | ! |
- plot_r <- reactive(req(decorated_output_plot_q())[["plot"]])+ teal::validate_has_data(ANL, 1) |
| 565 | +907 | ||
| 566 | +908 |
- # Insert the plot into a plot_with_settings module from teal.widgets+ # plot |
|
| 567 | +909 | ! |
- pws <- teal.widgets::plot_with_settings_srv(+ plot_call <- substitute( |
| 568 | +910 | ! |
- id = "myplot",+ expr = ANL %>% ggplot(aes(x = outlier_var_name)) + |
| 569 | +911 | ! |
- plot_r = plot_r,+ stat_ecdf(), |
| 570 | +912 | ! |
- height = plot_height,+ env = list(outlier_var_name = as.name(outlier_var))+ |
+
| 913 | ++ |
+ ) |
|
| 571 | +914 | ! |
- width = plot_width+ if (length(categorical_var) == 0) {
|
| 572 | -+ | ||
| 915 | +! |
- )+ qenv <- teal.code::eval_code( |
|
| 573 | -+ | ||
| 916 | +! |
-
+ qenv, |
|
| 574 | +917 | ! |
- teal.widgets::verbatim_popup_srv(+ substitute( |
| 575 | +918 | ! |
- id = "rcode",+ expr = {
|
| 576 | +919 | ! |
- verbatim_content = reactive(teal.code::get_code(req(decorated_output_plot_q()))),+ ecdf_df <- ANL %>% |
| 577 | +920 | ! |
- title = "Show R Code for Response"+ dplyr::mutate( |
| 578 | -+ | ||
| 921 | +! |
- )+ y = stats::ecdf(ANL[[outlier_var]])(ANL[[outlier_var]]) |
|
| 579 | +922 |
-
+ ) |
|
| 580 | +923 |
- ### REPORTER+ |
|
| 581 | +924 | ! |
- if (with_reporter) {
+ outlier_points <- dplyr::left_join( |
| 582 | +925 | ! |
- card_fun <- function(comment, label) {
+ ecdf_df, |
| 583 | +926 | ! |
- card <- teal::report_card_template(+ ANL_OUTLIER, |
| 584 | +927 | ! |
- title = "Response Plot",+ by = dplyr::setdiff(names(ecdf_df), "y") |
| 585 | -! | +||
| 928 | +
- label = label,+ ) %>% |
||
| 586 | +929 | ! |
- with_filter = with_filter,+ dplyr::filter(!is.na(is_outlier_selected))+ |
+
| 930 | ++ |
+ }, |
|
| 587 | +931 | ! |
- filter_panel_api = filter_panel_api+ env = list(outlier_var = outlier_var) |
| 588 | +932 |
- )+ ) |
|
| 589 | -! | +||
| 933 | +
- card$append_text("Plot", "header3")
+ ) |
||
| 590 | -! | +||
| 934 | +
- card$append_plot(plot_r(), dim = pws$dim())+ } else {
|
||
| 591 | +935 | ! |
- if (!comment == "") {
+ qenv <- teal.code::eval_code( |
| 592 | +936 | ! |
- card$append_text("Comment", "header3")
+ qenv, |
| 593 | +937 | ! |
- card$append_text(comment)+ substitute( |
| 594 | -+ | ||
| 938 | +! |
- }+ expr = {
|
|
| 595 | +939 | ! |
- card$append_src(teal.code::get_code(req(decorated_output_plot_q())))+ all_categories <- lapply( |
| 596 | +940 | ! |
- card+ unique(ANL[[categorical_var]]), |
| 597 | -+ | ||
| 941 | +! |
- }+ function(x) {
|
|
| 598 | +942 | ! |
- teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
+ ANL <- ANL %>% dplyr::filter(get(categorical_var) == x) |
| 599 | -+ | ||
| 943 | +! |
- }+ anl_outlier2 <- ANL_OUTLIER %>% dplyr::filter(get(categorical_var) == x) |
|
| 600 | -+ | ||
| 944 | +! |
- ###+ ecdf_df <- ANL %>% |
|
| 601 | -+ | ||
| 945 | +! |
- })+ dplyr::mutate(y = stats::ecdf(ANL[[outlier_var]])(ANL[[outlier_var]])) |
|
| 602 | +946 |
- }+ |
| 1 | -+ | ||
| 947 | +! |
- #' `teal` module: Data table viewer+ dplyr::left_join( |
|
| 2 | -+ | ||
| 948 | +! |
- #'+ ecdf_df, |
|
| 3 | -+ | ||
| 949 | +! |
- #' Module provides a dynamic and interactive way to view `data.frame`s in a `teal` application.+ anl_outlier2, |
|
| 4 | -+ | ||
| 950 | +! |
- #' It uses the `DT` package to display data tables in a paginated, searchable, and sortable format,+ by = dplyr::setdiff(names(ecdf_df), "y") |
|
| 5 | +951 |
- #' which helps to enhance data exploration and analysis.+ ) %>% |
|
| 6 | -+ | ||
| 952 | +! |
- #'+ dplyr::filter(!is.na(is_outlier_selected)) |
|
| 7 | +953 |
- #' The `DT` package has an option `DT.TOJSON_ARGS` to show `Inf` and `NA` in data tables.+ } |
|
| 8 | +954 |
- #' Configure the `DT.TOJSON_ARGS` option via+ ) |
|
| 9 | -+ | ||
| 955 | +! |
- #' `options(DT.TOJSON_ARGS = list(na = "string"))` before running the module.+ outlier_points <- do.call(rbind, all_categories) |
|
| 10 | +956 |
- #' Note though that sorting of numeric columns with `NA`/`Inf` will be lexicographic not numerical.+ }, |
|
| 11 | -+ | ||
| 957 | +! |
- #'+ env = list(categorical_var = categorical_var, outlier_var = outlier_var) |
|
| 12 | +958 |
- #' @inheritParams teal::module+ ) |
|
| 13 | +959 |
- #' @inheritParams shared_params+ ) |
|
| 14 | -+ | ||
| 960 | +! |
- #' @param variables_selected (`named list`) Character vectors of the variables (i.e. columns)+ plot_call <- substitute( |
|
| 15 | -+ | ||
| 961 | +! |
- #' which should be initially shown for each dataset.+ expr = plot_call + facet_grid(~ reorder(categorical_var_name, order)), |
|
| 16 | -+ | ||
| 962 | +! |
- #' Names of list elements should correspond to the names of the datasets available in the app.+ env = list(plot_call = plot_call, categorical_var_name = as.name(categorical_var)) |
|
| 17 | +963 |
- #' If no entry is specified for a dataset, the first six variables from that+ ) |
|
| 18 | +964 |
- #' dataset will initially be shown.+ } |
|
| 19 | +965 |
- #' @param datasets_selected (`character`) A vector of datasets which should be+ |
|
| 20 | -+ | ||
| 966 | +! |
- #' shown and in what order. Names in the vector have to correspond with datasets names.+ dev_ggplot2_args <- teal.widgets::ggplot2_args( |
|
| 21 | -+ | ||
| 967 | +! |
- #' If vector of `length == 0` (default) then all datasets are shown.+ labs = list(color = "Is outlier?"), |
|
| 22 | -+ | ||
| 968 | +! |
- #' Note: Only datasets of the `data.frame` class are compatible.+ theme = list(legend.position = "top") |
|
| 23 | +969 |
- #' @param dt_args (`named list`) Additional arguments to be passed to [DT::datatable()]+ ) |
|
| 24 | +970 |
- #' (must not include `data` or `options`).+ |
|
| 25 | -+ | ||
| 971 | +! |
- #' @param dt_options (`named list`) The `options` argument to `DT::datatable`. By default+ all_ggplot2_args <- teal.widgets::resolve_ggplot2_args( |
|
| 26 | -+ | ||
| 972 | +! |
- #' `list(searching = FALSE, pageLength = 30, lengthMenu = c(5, 15, 30, 100), scrollX = TRUE)`+ user_plot = ggplot2_args[["Cumulative Distribution Plot"]], |
|
| 27 | -+ | ||
| 973 | +! |
- #' @param server_rendering (`logical`) should the data table be rendered server side+ user_default = ggplot2_args$default, |
|
| 28 | -+ | ||
| 974 | +! |
- #' (see `server` argument of [DT::renderDataTable()])+ module_plot = dev_ggplot2_args |
|
| 29 | +975 |
- #' @param decorators `r roxygen_decorators_param("tm_data_table")`
+ ) |
|
| 30 | +976 |
- #'+ |
|
| 31 | -+ | ||
| 977 | +! |
- #' @inherit shared_params return+ parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args( |
|
| 32 | -+ | ||
| 978 | +! |
- #'+ all_ggplot2_args, |
|
| 33 | -+ | ||
| 979 | +! |
- #' @section Decorating `tm_data_table`:+ ggtheme = input$ggtheme |
|
| 34 | +980 |
- #'+ ) |
|
| 35 | +981 |
- #' This module generates the following objects, which can be modified in place using decorators:+ |
|
| 36 | -+ | ||
| 982 | +! |
- #' - `table` ([DT::datatable()])+ teal.code::eval_code( |
|
| 37 | -+ | ||
| 983 | +! |
- #'+ qenv, |
|
| 38 | -+ | ||
| 984 | +! |
- #' For additional details and examples of decorators, refer to the vignette+ substitute( |
|
| 39 | -+ | ||
| 985 | +! |
- #' `vignette("decorate-modules-output", package = "teal")` or the [`teal::teal_transform_module()`] documentation.
+ expr = cumulative_plot <- plot_call + |
|
| 40 | -+ | ||
| 986 | +! |
- #'+ geom_point(data = outlier_points, aes(x = outlier_var_name, y = y, color = is_outlier_selected)) + |
|
| 41 | -+ | ||
| 987 | +! |
- #' @examplesShinylive+ scale_color_manual(values = c("TRUE" = "red", "FALSE" = "black")) +
|
|
| 42 | -+ | ||
| 988 | +! |
- #' library(teal.modules.general)+ labs + ggthemes + themes, |
|
| 43 | -+ | ||
| 989 | +! |
- #' interactive <- function() TRUE+ env = list( |
|
| 44 | -+ | ||
| 990 | +! |
- #' {{ next_example }}
+ plot_call = plot_call, |
|
| 45 | -+ | ||
| 991 | +! |
- #' @examples+ outlier_var_name = as.name(outlier_var), |
|
| 46 | -+ | ||
| 992 | +! |
- #' # general data example+ labs = parsed_ggplot2_args$labs, |
|
| 47 | -+ | ||
| 993 | +! |
- #' data <- teal_data()+ themes = parsed_ggplot2_args$theme, |
|
| 48 | -+ | ||
| 994 | +! |
- #' data <- within(data, {
+ ggthemes = parsed_ggplot2_args$ggtheme |
|
| 49 | +995 |
- #' require(nestcolor)+ ) |
|
| 50 | +996 |
- #' iris <- iris+ ) |
|
| 51 | +997 |
- #' })+ ) |
|
| 52 | +998 |
- #'+ }) |
|
| 53 | +999 |
- #' app <- init(+ |
|
| 54 | -+ | ||
| 1000 | +! |
- #' data = data,+ current_tab_r <- reactive({
|
|
| 55 | -+ | ||
| 1001 | +! |
- #' modules = modules(+ switch(req(input$tabs), |
|
| 56 | -+ | ||
| 1002 | +! |
- #' tm_data_table(+ "Boxplot" = "box_plot", |
|
| 57 | -+ | ||
| 1003 | +! |
- #' variables_selected = list(+ "Density Plot" = "density_plot", |
|
| 58 | -+ | ||
| 1004 | +! |
- #' iris = c("Sepal.Length", "Sepal.Width", "Petal.Length", "Petal.Width", "Species")
+ "Cumulative Distribution Plot" = "cumulative_plot" |
|
| 59 | +1005 |
- #' ),+ ) |
|
| 60 | +1006 |
- #' dt_args = list(caption = "IRIS Table Caption")+ }) |
|
| 61 | +1007 |
- #' )+ |
|
| 62 | -+ | ||
| 1008 | +! |
- #' )+ decorated_q <- mapply( |
|
| 63 | -+ | ||
| 1009 | +! |
- #' )+ function(obj_name, q) {
|
|
| 64 | -+ | ||
| 1010 | +! |
- #' if (interactive()) {
+ srv_decorate_teal_data( |
|
| 65 | -+ | ||
| 1011 | +! |
- #' shinyApp(app$ui, app$server)+ id = sprintf("d_%s", obj_name),
|
|
| 66 | -+ | ||
| 1012 | +! |
- #' }+ data = q, |
|
| 67 | -+ | ||
| 1013 | +! |
- #'+ decorators = select_decorators(decorators, obj_name), |
|
| 68 | -+ | ||
| 1014 | +! |
- #' @examplesShinylive+ expr = reactive({
|
|
| 69 | -+ | ||
| 1015 | +! |
- #' library(teal.modules.general)+ substitute( |
|
| 70 | -+ | ||
| 1016 | +! |
- #' interactive <- function() TRUE+ expr = {
|
|
| 71 | -+ | ||
| 1017 | +! |
- #' {{ next_example }}
+ columns_index <- union( |
|
| 72 | -+ | ||
| 1018 | +! |
- #' @examples+ setdiff(names(ANL_OUTLIER), c("is_outlier_selected", "order")),
|
|
| 73 | -+ | ||
| 1019 | +! |
- #' # CDISC data example+ table_columns |
|
| 74 | +1020 |
- #' data <- teal_data()+ ) |
|
| 75 | -+ | ||
| 1021 | +! |
- #' data <- within(data, {
+ ANL_OUTLIER_EXTENDED[ANL_OUTLIER_EXTENDED$is_outlier_selected, columns_index] |
|
| 76 | -+ | ||
| 1022 | +! |
- #' require(nestcolor)+ print(.plot) |
|
| 77 | +1023 |
- #' ADSL <- rADSL+ }, |
|
| 78 | -+ | ||
| 1024 | +! |
- #' })+ env = list(table_columns = input$table_ui_columns, .plot = as.name(obj_name)) |
|
| 79 | +1025 |
- #' join_keys(data) <- default_cdisc_join_keys[names(data)]+ ) |
|
| 80 | +1026 |
- #'+ }), |
|
| 81 | -+ | ||
| 1027 | +! |
- #' app <- init(+ expr_is_reactive = TRUE |
|
| 82 | +1028 |
- #' data = data,+ ) |
|
| 83 | +1029 |
- #' modules = modules(+ }, |
|
| 84 | -+ | ||
| 1030 | +! |
- #' tm_data_table(+ rlang::set_names(c("box_plot", "density_plot", "cumulative_plot")),
|
|
| 85 | -+ | ||
| 1031 | +! |
- #' variables_selected = list(ADSL = c("STUDYID", "USUBJID", "SUBJID", "SITEID", "AGE", "SEX")),
+ c(box_plot_q, density_plot_q, cumulative_plot_q) |
|
| 86 | +1032 |
- #' dt_args = list(caption = "ADSL Table Caption")+ ) |
|
| 87 | +1033 |
- #' )+ |
|
| 88 | -+ | ||
| 1034 | +! |
- #' )+ decorated_final_q_no_table <- reactive(decorated_q[[req(current_tab_r())]]()) |
|
| 89 | +1035 |
- #' )+ |
|
| 90 | -+ | ||
| 1036 | +! |
- #' if (interactive()) {
+ decorated_final_q <- srv_decorate_teal_data( |
|
| 91 | -+ | ||
| 1037 | +! |
- #' shinyApp(app$ui, app$server)+ "d_table", |
|
| 92 | -+ | ||
| 1038 | +! |
- #' }+ data = decorated_final_q_no_table, |
|
| 93 | -+ | ||
| 1039 | +! |
- #'+ decorators = select_decorators(decorators, "table"), |
|
| 94 | -+ | ||
| 1040 | +! |
- #' @export+ expr = table |
|
| 95 | +1041 |
- #'+ ) |
|
| 96 | +1042 |
- tm_data_table <- function(label = "Data Table",+ |
|
| 97 | -+ | ||
| 1043 | +! |
- variables_selected = list(),+ output$summary_table <- DT::renderDataTable( |
|
| 98 | -+ | ||
| 1044 | +! |
- datasets_selected = character(0),+ expr = {
|
|
| 99 | -+ | ||
| 1045 | +! |
- dt_args = list(),+ if (iv_r()$is_valid()) {
|
|
| 100 | -+ | ||
| 1046 | +! |
- dt_options = list(+ categorical_var <- as.vector(merged$anl_input_r()$columns_source$categorical_var) |
|
| 101 | -+ | ||
| 1047 | +! |
- searching = FALSE,+ if (!is.null(categorical_var)) {
|
|
| 102 | -+ | ||
| 1048 | +! |
- pageLength = 30,+ decorated_final_q()[["table"]] |
|
| 103 | +1049 |
- lengthMenu = c(5, 15, 30, 100),+ } |
|
| 104 | +1050 |
- scrollX = TRUE+ } |
|
| 105 | +1051 |
- ),+ } |
|
| 106 | +1052 |
- server_rendering = FALSE,+ ) |
|
| 107 | +1053 |
- pre_output = NULL,+ |
|
| 108 | +1054 |
- post_output = NULL,+ # slider text |
|
| 109 | -+ | ||
| 1055 | +! |
- decorators = NULL) {
+ output$ui_outlier_help <- renderUI({
|
|
| 110 | +1056 | ! |
- message("Initializing tm_data_table")
+ req(input$method) |
| 111 | -+ | ||
| 1057 | +! |
-
+ if (input$method == "IQR") {
|
|
| 112 | -+ | ||
| 1058 | +! |
- # Start of assertions+ req(input$iqr_slider) |
|
| 113 | +1059 | ! |
- checkmate::assert_string(label)+ tags$small( |
| 114 | -+ | ||
| 1060 | +! |
-
+ withMathJax( |
|
| 115 | +1061 | ! |
- checkmate::assert_list(variables_selected, min.len = 0, types = "character", names = "named")+ helpText( |
| 116 | +1062 | ! |
- if (length(variables_selected) > 0) {
+ "Outlier data points (\\(x \\lt Q1 - ", input$iqr_slider, "\\times IQR\\) or \\( |
| 117 | +1063 | ! |
- lapply(seq_along(variables_selected), function(i) {
+ Q3 + ", input$iqr_slider, "\\times IQR \\lt x\\)) |
| 118 | +1064 | ! |
- checkmate::assert_character(variables_selected[[i]], min.chars = 1, min.len = 1)+ are displayed in red on the plot and can be visualized in the table below." |
| 119 | -! | +||
| 1065 | +
- if (!is.null(names(variables_selected[[i]]))) {
+ ), |
||
| 120 | +1066 | ! |
- checkmate::assert_names(names(variables_selected[[i]]))+ if (input$split_outliers) {
|
| 121 | -+ | ||
| 1067 | +! |
- }+ withMathJax(helpText("Note: Quantiles are calculated per group."))
|
|
| 122 | +1068 |
- })+ } |
|
| 123 | +1069 |
- }+ ) |
|
| 124 | +1070 |
-
+ ) |
|
| 125 | +1071 | ! |
- checkmate::assert_character(datasets_selected, min.len = 0, min.chars = 1)+ } else if (input$method == "Z-score") {
|
| 126 | +1072 | ! |
- checkmate::assert(+ req(input$zscore_slider) |
| 127 | +1073 | ! |
- checkmate::check_list(dt_args, len = 0),+ tags$small( |
| 128 | +1074 | ! |
- checkmate::check_subset(names(dt_args), choices = names(formals(DT::datatable)))- |
-
| 129 | -- |
- )+ withMathJax( |
|
| 130 | +1075 | ! |
- checkmate::assert_list(dt_options, names = "named")+ helpText( |
| 131 | +1076 | ! |
- checkmate::assert_flag(server_rendering)+ "Outlier data points (\\(Zscore(x) < -", input$zscore_slider, |
| 132 | +1077 | ! |
- checkmate::assert_multi_class(pre_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
+ "\\) or \\(", input$zscore_slider, "< Zscore(x) \\))
|
| 133 | +1078 | ! |
- checkmate::assert_multi_class(post_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
+ are displayed in red on the plot and can be visualized in the table below." |
| 134 | +1079 |
-
+ ), |
|
| 135 | +1080 | ! |
- decorators <- normalize_decorators(decorators)+ if (input$split_outliers) {
|
| 136 | +1081 | ! |
- assert_decorators(decorators, null.ok = TRUE, "table")+ withMathJax(helpText(" Note: Z-scores are calculated per group."))
|
| 137 | +1082 |
- # End of assertions+ } |
|
| 138 | +1083 |
-
+ ) |
|
| 139 | -! | +||
| 1084 | +
- ans <- module(+ ) |
||
| 140 | +1085 | ! |
- label,+ } else if (input$method == "Percentile") {
|
| 141 | +1086 | ! |
- server = srv_page_data_table,+ req(input$percentile_slider) |
| 142 | +1087 | ! |
- ui = ui_page_data_table,+ tags$small( |
| 143 | +1088 | ! |
- datanames = if (length(datasets_selected) == 0) "all" else datasets_selected,+ withMathJax( |
| 144 | +1089 | ! |
- server_args = list(+ helpText( |
| 145 | +1090 | ! |
- variables_selected = variables_selected,+ "Outlier/extreme data points (\\( Percentile(x) <", input$percentile_slider, |
| 146 | +1091 | ! |
- datasets_selected = datasets_selected,+ "\\) or \\(", 1 - input$percentile_slider, " < Percentile(x) \\))
|
| 147 | +1092 | ! |
- dt_args = dt_args,+ are displayed in red on the plot and can be visualized in the table below." |
| 148 | -! | +||
| 1093 | +
- dt_options = dt_options,+ ), |
||
| 149 | +1094 | ! |
- server_rendering = server_rendering,+ if (input$split_outliers) {
|
| 150 | +1095 | ! |
- decorators = decorators+ withMathJax(helpText("Note: Percentiles are calculated per group."))
|
| 151 | +1096 |
- ),+ } |
|
| 152 | -! | +||
| 1097 | +
- ui_args = list(+ ) |
||
| 153 | -! | +||
| 1098 | +
- pre_output = pre_output,+ ) |
||
| 154 | -! | +||
| 1099 | +
- post_output = post_output+ } |
||
| 155 | +1100 |
- )+ }) |
|
| 156 | +1101 |
- )+ |
|
| 157 | +1102 | ! |
- attr(ans, "teal_bookmarkable") <- TRUE+ box_plot_r <- reactive({
|
| 158 | +1103 | ! |
- ans+ teal::validate_inputs(iv_r()) |
| 159 | -+ | ||
| 1104 | +! |
- }+ req(decorated_q$box_plot())[["box_plot"]] |
|
| 160 | +1105 |
-
+ }) |
|
| 161 | -+ | ||
| 1106 | +! |
- # UI page module+ density_plot_r <- reactive({
|
|
| 162 | -+ | ||
| 1107 | +! |
- ui_page_data_table <- function(id, pre_output = NULL, post_output = NULL) {
+ teal::validate_inputs(iv_r()) |
|
| 163 | +1108 | ! |
- ns <- NS(id)+ req(decorated_q$density_plot())[["density_plot"]] |
| 164 | +1109 |
-
+ }) |
|
| 165 | +1110 | ! |
- tagList(+ cumulative_plot_r <- reactive({
|
| 166 | +1111 | ! |
- include_css_files("custom"),
+ teal::validate_inputs(iv_r()) |
| 167 | +1112 | ! |
- teal.widgets::standard_layout(+ req(decorated_q$cumulative_plot())[["cumulative_plot"]] |
| 168 | -! | +||
| 1113 | +
- output = teal.widgets::white_small_well(+ }) |
||
| 169 | -! | +||
| 1114 | +
- fluidRow(+ |
||
| 170 | +1115 | ! |
- column(+ box_pws <- teal.widgets::plot_with_settings_srv( |
| 171 | +1116 | ! |
- width = 12,+ id = "box_plot", |
| 172 | +1117 | ! |
- checkboxInput(+ plot_r = box_plot_r, |
| 173 | +1118 | ! |
- ns("if_distinct"),
+ height = plot_height, |
| 174 | +1119 | ! |
- "Show only distinct rows:",+ width = plot_width, |
| 175 | +1120 | ! |
- value = FALSE+ brushing = TRUE |
| 176 | +1121 |
- )+ ) |
|
| 177 | +1122 |
- )+ |
|
| 178 | -+ | ||
| 1123 | +! |
- ),+ density_pws <- teal.widgets::plot_with_settings_srv( |
|
| 179 | +1124 | ! |
- fluidRow(+ id = "density_plot", |
| 180 | +1125 | ! |
- class = "mb-8",+ plot_r = density_plot_r, |
| 181 | +1126 | ! |
- column(+ height = plot_height, |
| 182 | +1127 | ! |
- width = 12,+ width = plot_width, |
| 183 | +1128 | ! |
- uiOutput(ns("dataset_table"))
+ brushing = TRUE |
| 184 | +1129 |
- )+ ) |
|
| 185 | +1130 |
- )+ |
|
| 186 | -+ | ||
| 1131 | +! |
- ),+ cum_density_pws <- teal.widgets::plot_with_settings_srv( |
|
| 187 | +1132 | ! |
- pre_output = pre_output,+ id = "cum_density_plot", |
| 188 | +1133 | ! |
- post_output = post_output+ plot_r = cumulative_plot_r,+ |
+
| 1134 | +! | +
+ height = plot_height,+ |
+ |
| 1135 | +! | +
+ width = plot_width,+ |
+ |
| 1136 | +! | +
+ brushing = TRUE |
|
| 189 | +1137 |
) |
|
| 190 | +1138 |
- )+ |
|
| 191 | -+ | ||
| 1139 | +! |
- }+ choices <- reactive(teal.transform::variable_choices(data()[[dataname_first]])) |
|
| 192 | +1140 | ||
| 193 | -+ | ||
| 1141 | +! |
- # Server page module+ observeEvent(common_code_q(), {
|
|
| 194 | -+ | ||
| 1142 | +! |
- srv_page_data_table <- function(id,+ ANL_OUTLIER <- common_code_q()[["ANL_OUTLIER"]] |
|
| 195 | -+ | ||
| 1143 | +! |
- data,+ teal.widgets::updateOptionalSelectInput( |
|
| 196 | -+ | ||
| 1144 | +! |
- datasets_selected,+ session, |
|
| 197 | -+ | ||
| 1145 | +! |
- variables_selected,+ inputId = "table_ui_columns", |
|
| 198 | -+ | ||
| 1146 | +! |
- dt_args,+ choices = dplyr::setdiff(choices(), names(ANL_OUTLIER)),+ |
+ |
| 1147 | +! | +
+ selected = restoreInput(ns("table_ui_columns"), isolate(input$table_ui_columns))
|
|
| 199 | +1148 |
- dt_options,+ ) |
|
| 200 | +1149 |
- server_rendering,+ }) |
|
| 201 | +1150 |
- decorators) {
+
|
|
| 202 | +1151 | ! |
- checkmate::assert_class(data, "reactive")+ output$table_ui <- DT::renderDataTable( |
| 203 | +1152 | ! |
- checkmate::assert_class(isolate(data()), "teal_data")+ expr = {
|
| 204 | +1153 | ! |
- moduleServer(id, function(input, output, session) {
+ tab <- input$tabs |
| 205 | +1154 | ! |
- teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.general")+ req(tab) # tab is NULL upon app launch, hence will crash without this statement+ |
+
| 1155 | +! | +
+ req(iv_r()$is_valid()) # Same validation as output$table_ui_wrap+ |
+ |
| 1156 | +! | +
+ outlier_var <- as.vector(merged$anl_input_r()$columns_source$outlier_var)+ |
+ |
| 1157 | +! | +
+ categorical_var <- as.vector(merged$anl_input_r()$columns_source$categorical_var) |
|
| 206 | +1158 | ||
| 207 | +1159 | ! |
- if_filtered <- reactive(as.logical(input$if_filtered))+ ANL_OUTLIER <- common_code_q()[["ANL_OUTLIER"]] |
| 208 | +1160 | ! |
- if_distinct <- reactive(as.logical(input$if_distinct))+ ANL_OUTLIER_EXTENDED <- common_code_q()[["ANL_OUTLIER_EXTENDED"]]+ |
+
| 1161 | +! | +
+ ANL <- common_code_q()[["ANL"]] |
|
| 209 | +1162 | ||
| 210 | +1163 | ! |
- datanames <- isolate(names(data()))+ plot_brush <- switch(current_tab_r(), |
| 211 | +1164 | ! |
- datanames <- Filter(function(name) {
+ box_plot = {
|
| 212 | +1165 | ! |
- is.data.frame(isolate(data())[[name]])+ box_plot_r() |
| 213 | +1166 | ! |
- }, datanames)+ box_pws$brush() |
| 214 | +1167 |
-
+ }, |
|
| 215 | +1168 | ! |
- if (!identical(datasets_selected, character(0))) {
+ density_plot = {
|
| 216 | +1169 | ! |
- checkmate::assert_subset(datasets_selected, datanames)+ density_plot_r() |
| 217 | +1170 | ! |
- datanames <- datasets_selected+ density_pws$brush() |
| 218 | +1171 |
- }+ }, |
|
| 219 | -+ | ||
| 1172 | +! |
-
+ cumulative_plot = {
|
|
| 220 | +1173 | ! |
- output$dataset_table <- renderUI({
+ cumulative_plot_r() |
| 221 | +1174 | ! |
- do.call(+ cum_density_pws$brush() |
| 222 | -! | +||
| 1175 | +
- tabsetPanel,+ } |
||
| 223 | -! | +||
| 1176 | +
- c(+ ) |
||
| 224 | -! | +||
| 1177 | +
- list(id = session$ns("dataname_tab")),
+
|
||
| 225 | -! | +||
| 1178 | +
- lapply(+ # removing unused column ASAP |
||
| 226 | +1179 | ! |
- datanames,+ ANL_OUTLIER$order <- ANL$order <- NULL |
| 227 | -! | +||
| 1180 | +
- function(x) {
+
|
||
| 228 | +1181 | ! |
- dataset <- isolate(data()[[x]])+ display_table <- if (!is.null(plot_brush)) {
|
| 229 | +1182 | ! |
- choices <- names(dataset)+ if (length(categorical_var) > 0) {
|
| 230 | -! | +||
| 1183 | +
- labels <- vapply(+ # due to reordering, the x-axis label may be changed to something like "reorder(categorical_var, order)" |
||
| 231 | +1184 | ! |
- dataset,+ if (tab == "Boxplot") {
|
| 232 | +1185 | ! |
- function(x) ifelse(is.null(attr(x, "label")), "", attr(x, "label")),+ plot_brush$mapping$x <- categorical_var |
| 233 | -! | +||
| 1186 | +
- character(1)+ } else {
|
||
| 234 | +1187 |
- )+ # the other plots use facetting |
|
| 235 | -! | +||
| 1188 | +
- names(choices) <- ifelse(+ # so it is panelvar1 that gets relabelled to "reorder(categorical_var, order)" |
||
| 236 | +1189 | ! |
- is.na(labels) | labels == "",+ plot_brush$mapping$panelvar1 <- categorical_var |
| 237 | -! | +||
| 1190 | +
- choices,+ }+ |
+ ||
| 1191 | ++ |
+ } else {
|
|
| 238 | +1192 | ! |
- paste(choices, labels, sep = ": ")+ if (tab == "Boxplot") {
|
| 239 | +1193 |
- )+ # in boxplot with no categorical variable, there is no column in ANL that would correspond to x-axis |
|
| 240 | -! | +||
| 1194 | +
- variables_selected <- if (!is.null(variables_selected[[x]])) {
+ # so a column needs to be inserted with the value "Entire dataset" because that's the label used in plot |
||
| 241 | +1195 | ! |
- variables_selected[[x]]+ ANL[[plot_brush$mapping$x]] <- "Entire dataset" |
| 242 | +1196 |
- } else {
+ } |
|
| 243 | -! | +||
| 1197 | +
- utils::head(choices)+ } |
||
| 244 | +1198 |
- }+ |
|
| 245 | -! | +||
| 1199 | +
- tabPanel(+ # in density and cumulative plots, ANL does not have a column corresponding to y-axis. |
||
| 246 | -! | +||
| 1200 | +
- title = x,+ # so they need to be computed and attached to ANL |
||
| 247 | +1201 | ! |
- column(+ if (tab == "Density Plot") {
|
| 248 | +1202 | ! |
- width = 12,+ plot_brush$mapping$y <- "density" |
| 249 | +1203 | ! |
- div(+ ANL$density <- plot_brush$ymin |
| 250 | -! | +||
| 1204 | +
- class = "mt-4",+ # either ymin or ymax will work |
||
| 251 | +1205 | ! |
- ui_data_table(+ } else if (tab == "Cumulative Distribution Plot") {
|
| 252 | +1206 | ! |
- id = session$ns(x),+ plot_brush$mapping$y <- "cdf" |
| 253 | +1207 | ! |
- choices = choices,+ if (length(categorical_var) > 0) {
|
| 254 | +1208 | ! |
- selected = variables_selected,+ ANL <- ANL %>% |
| 255 | +1209 | ! |
- decorators = decorators+ dplyr::group_by(!!as.name(plot_brush$mapping$panelvar1)) %>% |
| 256 | -+ | ||
| 1210 | +! |
- )+ dplyr::mutate(cdf = stats::ecdf(!!as.name(outlier_var))(!!as.name(outlier_var))) |
|
| 257 | +1211 |
- )+ } else {
|
|
| 258 | -+ | ||
| 1212 | +! |
- )+ ANL$cdf <- stats::ecdf(ANL[[outlier_var]])(ANL[[outlier_var]]) |
|
| 259 | +1213 |
- )+ } |
|
| 260 | +1214 |
- }+ } |
|
| 261 | +1215 |
- )+ |
|
| 262 | -+ | ||
| 1216 | +! |
- )+ brushed_rows <- brushedPoints(ANL, plot_brush) |
|
| 263 | -+ | ||
| 1217 | +! |
- )+ if (nrow(brushed_rows) > 0) {
|
|
| 264 | +1218 |
- })+ # now we need to remove extra column from ANL so that it will have the same columns as ANL_OUTLIER |
|
| 265 | +1219 |
-
+ # so that dplyr::intersect will work |
|
| 266 | +1220 | ! |
- lapply(+ if (tab == "Density Plot") {
|
| 267 | +1221 | ! |
- datanames,+ brushed_rows$density <- NULL |
| 268 | +1222 | ! |
- function(x) {
+ } else if (tab == "Cumulative Distribution Plot") {
|
| 269 | +1223 | ! |
- srv_data_table(+ brushed_rows$cdf <- NULL |
| 270 | +1224 | ! |
- id = x,+ } else if (tab == "Boxplot" && length(categorical_var) == 0) {
|
| 271 | +1225 | ! |
- data = data,+ brushed_rows[[plot_brush$mapping$x]] <- NULL |
| 272 | -! | +||
| 1226 | +
- dataname = x,+ } |
||
| 273 | -! | +||
| 1227 | +
- if_filtered = if_filtered,+ # is_outlier_selected is part of ANL_OUTLIER so needed here |
||
| 274 | +1228 | ! |
- if_distinct = if_distinct,+ brushed_rows$is_outlier_selected <- TRUE |
| 275 | +1229 | ! |
- dt_args = dt_args,+ dplyr::intersect(ANL_OUTLIER, brushed_rows) |
| 276 | -! | +||
| 1230 | +
- dt_options = dt_options,+ } else {
|
||
| 277 | +1231 | ! |
- server_rendering = server_rendering,+ ANL_OUTLIER[0, ] |
| 278 | -! | +||
| 1232 | +
- decorators = decorators+ } |
||
| 279 | +1233 |
- )+ } else {
|
|
| 280 | -+ | ||
| 1234 | +! |
- }+ ANL_OUTLIER[ANL_OUTLIER$is_outlier_selected, ] |
|
| 281 | +1235 |
- )+ } |
|
| 282 | +1236 |
- })+ |
|
| 283 | -+ | ||
| 1237 | +! |
- }+ display_table$is_outlier_selected <- NULL |
|
| 284 | +1238 | ||
| 285 | +1239 |
- # UI function for the data_table module+ # Extend the brushed ANL_OUTLIER with additional columns |
|
| 286 | -+ | ||
| 1240 | +! |
- ui_data_table <- function(id,+ dplyr::left_join( |
|
| 287 | -+ | ||
| 1241 | +! |
- choices,+ display_table, |
|
| 288 | -+ | ||
| 1242 | +! |
- selected,+ dplyr::select(ANL_OUTLIER_EXTENDED, -"is_outlier_selected"),+ |
+ |
| 1243 | +! | +
+ by = names(display_table) |
|
| 289 | +1244 |
- decorators) {
+ ) %>% |
|
| 290 | +1245 | ! |
- ns <- NS(id)+ dplyr::select(union(names(display_table), input$table_ui_columns)) |
| 291 | +1246 |
-
+ }, |
|
| 292 | +1247 | ! |
- if (!is.null(selected)) {
+ options = list( |
| 293 | +1248 | ! |
- all_choices <- choices+ searching = FALSE, language = list( |
| 294 | +1249 | ! |
- choices <- c(selected, setdiff(choices, selected))+ zeroRecords = "The brushed area does not contain outlier observations for the currently defined threshold"+ |
+
| 1250 | ++ |
+ ), |
|
| 295 | +1251 | ! |
- names(choices) <- names(all_choices)[match(choices, all_choices)]+ pageLength = input$table_ui_rows |
| 296 | +1252 |
- }+ ) |
|
| 297 | +1253 | ++ |
+ )+ |
+
| 1254 | |||
| 298 | +1255 | ! |
- tagList(+ output$total_outliers <- renderUI({
|
| 299 | +1256 | ! |
- teal.widgets::get_dt_rows(ns("data_table"), ns("dt_rows")),
+ req(iv_r()$is_valid()) |
| 300 | +1257 | ! |
- fluidRow(+ ANL <- merged$anl_q_r()[["ANL"]]+ |
+
| 1258 | +! | +
+ ANL_OUTLIER <- common_code_q()[["ANL_OUTLIER"]]+ |
+ |
| 1259 | +! | +
+ teal::validate_has_data(ANL, 1)+ |
+ |
| 1260 | +! | +
+ ANL_OUTLIER_SELECTED <- ANL_OUTLIER[ANL_OUTLIER$is_outlier_selected, ] |
|
| 301 | +1261 | ! |
- ui_decorate_teal_data(ns("decorator"), decorators = select_decorators(decorators, "table")),
+ tags$h5( |
| 302 | +1262 | ! |
- teal.widgets::optionalSelectInput(+ sprintf( |
| 303 | +1263 | ! |
- ns("variables"),
+ "%s %d / %d [%.02f%%]", |
| 304 | +1264 | ! |
- "Select variables:",+ "Total number of outlier(s):", |
| 305 | +1265 | ! |
- choices = choices,+ nrow(ANL_OUTLIER_SELECTED), |
| 306 | +1266 | ! |
- selected = selected,+ nrow(ANL), |
| 307 | +1267 | ! |
- multiple = TRUE,+ 100 * nrow(ANL_OUTLIER_SELECTED) / nrow(ANL) |
| 308 | -! | +||
| 1268 | +
- width = "100%"+ ) |
||
| 309 | +1269 |
) |
|
| 310 | +1270 |
- ),+ })+ |
+ |
| 1271 | ++ | + | |
| 311 | +1272 | ! |
- fluidRow(+ output$total_missing <- renderUI({
|
| 312 | +1273 | ! |
- DT::dataTableOutput(ns("data_table"), width = "100%")
+ if (n_outlier_missing() > 0) {
|
| 313 | -+ | ||
| 1274 | +! |
- )+ ANL <- merged$anl_q_r()[["ANL"]] |
|
| 314 | -+ | ||
| 1275 | +! |
- )+ helpText( |
|
| 315 | -+ | ||
| 1276 | +! |
- }+ sprintf( |
|
| 316 | -+ | ||
| 1277 | +! |
-
+ "%s %d / %d [%.02f%%]", |
|
| 317 | -+ | ||
| 1278 | +! |
- # Server function for the data_table module+ "Total number of row(s) with missing values:", |
|
| 318 | -+ | ||
| 1279 | +! |
- srv_data_table <- function(id,+ n_outlier_missing(), |
|
| 319 | -+ | ||
| 1280 | +! |
- data,+ nrow(ANL), |
|
| 320 | -+ | ||
| 1281 | +! |
- dataname,+ 100 * (n_outlier_missing()) / nrow(ANL) |
|
| 321 | +1282 |
- if_filtered,+ ) |
|
| 322 | +1283 |
- if_distinct,+ ) |
|
| 323 | +1284 |
- dt_args,+ } |
|
| 324 | +1285 |
- dt_options,+ }) |
|
| 325 | +1286 |
- server_rendering,+ |
|
| 326 | -+ | ||
| 1287 | +! |
- decorators) {
+ output$table_ui_wrap <- renderUI({
|
|
| 327 | +1288 | ! |
- moduleServer(id, function(input, output, session) {
+ req(iv_r()$is_valid()) |
| 328 | +1289 | ! |
- iv <- shinyvalidate::InputValidator$new()+ tagList( |
| 329 | +1290 | ! |
- iv$add_rule("variables", shinyvalidate::sv_required("Please select valid variable names"))
+ teal.widgets::optionalSelectInput( |
| 330 | +1291 | ! |
- iv$add_rule("variables", shinyvalidate::sv_in_set(
+ inputId = ns("table_ui_columns"),
|
| 331 | +1292 | ! |
- set = names(isolate(data())[[dataname]]), message_fmt = "Not all selected variables exist in the data"+ label = "Choose additional columns", |
| 332 | -+ | ||
| 1293 | +! |
- ))+ choices = NULL, |
|
| 333 | +1294 | ! |
- iv$enable()+ selected = NULL,+ |
+
| 1295 | +! | +
+ multiple = TRUE |
|
| 334 | +1296 |
-
+ ), |
|
| 335 | +1297 | ! |
- data_table_data <- reactive({
+ tags$h4("Outlier Table"),
|
| 336 | +1298 | ! |
- df <- data()[[dataname]]+ teal.widgets::get_dt_rows(ns("table_ui"), ns("table_ui_rows"))
|
| 337 | +1299 |
-
+ ) |
|
| 338 | -! | +||
| 1300 | +
- teal::validate_has_data(df, min_nrow = 1L, msg = paste("data", dataname, "is empty"))
+ }) |
||
| 339 | +1301 | ||
| 340 | +1302 | ! |
- teal.code::eval_code(+ teal.widgets::verbatim_popup_srv( |
| 341 | +1303 | ! |
- data(),+ id = "rcode", |
| 342 | +1304 | ! |
- substitute(+ verbatim_content = reactive(teal.code::get_code(req(decorated_final_q()))), |
| 343 | +1305 | ! |
- expr = {
+ title = "Show R Code for Outlier" |
| 344 | -! | +||
| 1306 | +
- variables <- vars+ ) |
||
| 345 | -! | +||
| 1307 | +
- dataframe_selected <- if (if_distinct) {
+
+ |
+ ||
| 1308 | ++ |
+ ### REPORTER |
|
| 346 | +1309 | ! |
- dplyr::count(dataname, dplyr::across(dplyr::all_of(variables)))+ if (with_reporter) {
|
| 347 | -+ | ||
| 1310 | +! |
- } else {
+ card_fun <- function(comment, label) {
|
|
| 348 | +1311 | ! |
- dataname[variables]+ tab_type <- input$tabs |
| 349 | -+ | ||
| 1312 | +! |
- }+ card <- teal::report_card_template( |
|
| 350 | +1313 | ! |
- dt_args <- args+ title = paste0("Outliers - ", tab_type),
|
| 351 | +1314 | ! |
- dt_args$options <- dt_options+ label = label, |
| 352 | +1315 | ! |
- if (!is.null(dt_rows)) {
+ with_filter = with_filter, |
| 353 | +1316 | ! |
- dt_args$options$pageLength <- dt_rows+ filter_panel_api = filter_panel_api |
| 354 | +1317 |
- }+ ) |
|
| 355 | +1318 | ! |
- dt_args$data <- dataframe_selected+ categorical_var <- as.vector(merged$anl_input_r()$columns_source$categorical_var) |
| 356 | +1319 | ! |
- table <- do.call(DT::datatable, dt_args)+ if (length(categorical_var) > 0) {
|
| 357 | -+ | ||
| 1320 | +! |
- },+ summary_table <- common_code_q()[["summary_table"]] |
|
| 358 | +1321 | ! |
- env = list(+ card$append_text("Summary Table", "header3")
|
| 359 | +1322 | ! |
- dataname = as.name(dataname),+ card$append_table(summary_table) |
| 360 | -! | +||
| 1323 | +
- if_distinct = if_distinct(),+ } |
||
| 361 | +1324 | ! |
- vars = input$variables,+ card$append_text("Plot", "header3")
|
| 362 | +1325 | ! |
- args = dt_args,+ if (tab_type == "Boxplot") {
|
| 363 | +1326 | ! |
- dt_options = dt_options,+ card$append_plot(box_plot_r(), dim = box_pws$dim()) |
| 364 | +1327 | ! |
- dt_rows = input$dt_rows+ } else if (tab_type == "Density Plot") {
|
| 365 | -+ | ||
| 1328 | +! |
- )+ card$append_plot(density_plot_r(), dim = density_pws$dim()) |
|
| 366 | -+ | ||
| 1329 | +! |
- )+ } else if (tab_type == "Cumulative Distribution Plot") {
|
|
| 367 | -+ | ||
| 1330 | +! |
- )+ card$append_plot(cumulative_plot_r(), dim = cum_density_pws$dim()) |
|
| 368 | +1331 |
- })+ } |
|
| 369 | -+ | ||
| 1332 | +! |
-
+ if (!comment == "") {
|
|
| 370 | +1333 | ! |
- decorated_data_table_data <- srv_decorate_teal_data(+ card$append_text("Comment", "header3")
|
| 371 | +1334 | ! |
- id = "decorator",+ card$append_text(comment) |
| 372 | -! | +||
| 1335 | +
- data = data_table_data,+ } |
||
| 373 | +1336 | ! |
- decorators = select_decorators(decorators, "table")+ card$append_src(teal.code::get_code(req(decorated_final_q()))) |
| 374 | -+ | ||
| 1337 | +! |
- )+ card |
|
| 375 | +1338 | - - | -|
| 376 | -! | -
- output$data_table <- DT::renderDataTable(server = server_rendering, {
+ } |
|
| 377 | +1339 | ! |
- teal::validate_inputs(iv)+ teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
|
| 378 | -! | +||
| 1340 | +
- req(decorated_data_table_data())[["table"]]+ } |
||
| 379 | +1341 |
- })+ ### |
|
| 380 | +1342 |
}) |
|
| 381 | +1343 |
}@@ -72648,14 +72566,14 @@ teal.modules.general coverage - 3.63% |
| 1 |
- #' `teal` module: Scatterplot and regression analysis+ #' `teal` module: Stack plots of variables and show association with reference variable |
||
| 3 |
- #' Module for visualizing regression analysis, including scatterplots and+ #' Module provides functionality for visualizing the distribution of variables and |
||
| 4 |
- #' various regression diagnostics plots.+ #' their association with a reference variable. |
||
| 5 |
- #' It allows users to explore the relationship between a set of regressors and a response variable,+ #' It supports configuring the appearance of the plots, including themes and whether to show associations. |
||
| 6 |
- #' visualize residuals, and identify outliers.+ #' |
||
| 8 |
- #' @note For more examples, please see the vignette "Using regression plots" via+ #' @note For more examples, please see the vignette "Using association plot" via |
||
| 9 |
- #' `vignette("using-regression-plots", package = "teal.modules.general")`.
+ #' `vignette("using-association-plot", package = "teal.modules.general")`.
|
||
| 13 |
- #' @param regressor (`data_extract_spec` or `list` of multiple `data_extract_spec`)+ #' @param ref (`data_extract_spec` or `list` of multiple `data_extract_spec`) |
||
| 14 |
- #' Regressor variables from an incoming dataset with filtering and selecting.+ #' Reference variable, must accepts a `data_extract_spec` with `select_spec(multiple = FALSE)` |
||
| 15 |
- #' @param response (`data_extract_spec` or `list` of multiple `data_extract_spec`)+ #' to ensure single selection option. |
||
| 16 |
- #' Response variables from an incoming dataset with filtering and selecting.+ #' @param vars (`data_extract_spec` or `list` of multiple `data_extract_spec`) |
||
| 17 |
- #' @param default_outlier_label (`character`) optional, default column selected to label outliers.+ #' Variables to be associated with the reference variable. |
||
| 18 |
- #' @param default_plot_type (`numeric`) optional, defaults to "Response vs Regressor".+ #' @param show_association (`logical`) optional, whether show association of `vars` |
||
| 19 |
- #' 1. Response vs Regressor+ #' with reference variable. Defaults to `TRUE`. |
||
| 20 |
- #' 2. Residuals vs Fitted+ #' @param distribution_theme,association_theme (`character`) optional, `ggplot2` themes to be used by default. |
||
| 21 |
- #' 3. Normal Q-Q+ #' Default to `"gray"`. |
||
| 22 |
- #' 4. Scale-Location+ #' |
||
| 23 |
- #' 5. Cook's distance+ #' @param ggplot2_args `r roxygen_ggplot2_args_param("Bivariate1", "Bivariate2")`
|
||
| 24 |
- #' 6. Residuals vs Leverage+ #' @param decorators `r roxygen_decorators_param("tm_g_association")`
|
||
| 25 |
- #' 7. Cook's dist vs Leverage+ #' |
||
| 26 |
- #' @param label_segment_threshold (`numeric(1)` or `numeric(3)`)+ #' @inherit shared_params return |
||
| 27 |
- #' Minimum distance between label and point on the plot that triggers the creation of+ #' |
||
| 28 |
- #' a line segment between the two.+ #' @section Decorating `tm_g_association`: |
||
| 29 |
- #' This may happen when the label cannot be placed next to the point as it overlaps another+ #' |
||
| 30 |
- #' label or point.+ #' This module generates the following objects, which can be modified in place using decorators: |
||
| 31 |
- #' The value is used as the `min.segment.length` parameter to the [ggrepel::geom_text_repel()] function.+ #' - `plot` (`grob` created with [ggplot2::ggplotGrob()]) |
||
| 33 |
- #' It can take the following forms:+ #' For additional details and examples of decorators, refer to the vignette |
||
| 34 |
- #' - `numeric(1)`: Fixed value used for the minimum distance and the slider is not presented in the UI.+ #' `vignette("decorate-modules-output", package = "teal")` or the [`teal::teal_transform_module()`] documentation.
|
||
| 35 |
- #' - `numeric(3)`: A slider is presented in the UI (under "Plot settings") to adjust the minimum distance dynamically.+ #' |
||
| 36 |
- #'+ #' @examplesShinylive |
||
| 37 |
- #' It takes the form of `c(value, min, max)` and it is passed to the `value_min_max`+ #' library(teal.modules.general) |
||
| 38 |
- #' argument in `teal.widgets::optionalSliderInputValMinMax`.+ #' interactive <- function() TRUE |
||
| 39 |
- #'+ #' {{ next_example }}
|
||
| 40 |
- # nolint start: line_length.+ #' @examples |
||
| 41 |
- #' @param ggplot2_args `r roxygen_ggplot2_args_param("Response vs Regressor", "Residuals vs Fitted", "Scale-Location", "Cook's distance", "Residuals vs Leverage", "Cook's dist vs Leverage")`
+ #' # general data example |
||
| 42 |
- # nolint end: line_length.+ #' data <- teal_data() |
||
| 43 |
- #' @param decorators `r roxygen_decorators_param("tm_a_regression")`
+ #' data <- within(data, {
|
||
| 44 |
- #'+ #' require(nestcolor) |
||
| 45 |
- #' @inherit shared_params return+ #' CO2 <- CO2 |
||
| 46 |
- #'+ #' factors <- names(Filter(isTRUE, vapply(CO2, is.factor, logical(1L)))) |
||
| 47 |
- #' @section Decorating `tm_a_regression`:+ #' CO2[factors] <- lapply(CO2[factors], as.character) |
||
| 48 |
- #'+ #' }) |
||
| 49 |
- #' This module generates the following objects, which can be modified in place using decorators:+ #' |
||
| 50 |
- #' - `plot` (`ggplot2`)+ #' app <- init( |
||
| 51 |
- #'+ #' data = data, |
||
| 52 |
- #' For additional details and examples of decorators, refer to the vignette+ #' modules = modules( |
||
| 53 |
- #' `vignette("decorate-modules-output", package = "teal")` or the [`teal::teal_transform_module()`] documentation.
+ #' tm_g_association( |
||
| 54 |
- #'+ #' ref = data_extract_spec( |
||
| 55 |
- #' @examplesShinylive+ #' dataname = "CO2", |
||
| 56 |
- #' library(teal.modules.general)+ #' select = select_spec( |
||
| 57 |
- #' interactive <- function() TRUE+ #' label = "Select variable:", |
||
| 58 |
- #' {{ next_example }}
+ #' choices = variable_choices(data[["CO2"]], c("Plant", "Type", "Treatment")),
|
||
| 59 |
- #' @examples+ #' selected = "Plant", |
||
| 60 |
- #'+ #' fixed = FALSE |
||
| 61 |
- #' # general data example+ #' ) |
||
| 62 |
- #' data <- teal_data()+ #' ), |
||
| 63 |
- #' data <- within(data, {
+ #' vars = data_extract_spec( |
||
| 64 |
- #' require(nestcolor)+ #' dataname = "CO2", |
||
| 65 |
- #' CO2 <- CO2+ #' select = select_spec( |
||
| 66 |
- #' })+ #' label = "Select variables:", |
||
| 67 |
- #'+ #' choices = variable_choices(data[["CO2"]], c("Plant", "Type", "Treatment")),
|
||
| 68 |
- #' app <- init(+ #' selected = "Treatment", |
||
| 69 |
- #' data = data,+ #' multiple = TRUE, |
||
| 70 |
- #' modules = modules(+ #' fixed = FALSE |
||
| 71 |
- #' tm_a_regression(+ #' ) |
||
| 72 |
- #' label = "Regression",+ #' ) |
||
| 73 |
- #' response = data_extract_spec(+ #' ) |
||
| 74 |
- #' dataname = "CO2",+ #' ) |
||
| 75 |
- #' select = select_spec(+ #' ) |
||
| 76 |
- #' label = "Select variable:",+ #' if (interactive()) {
|
||
| 77 |
- #' choices = "uptake",+ #' shinyApp(app$ui, app$server) |
||
| 78 |
- #' selected = "uptake",+ #' } |
||
| 79 |
- #' multiple = FALSE,+ #' |
||
| 80 |
- #' fixed = TRUE+ #' @examplesShinylive |
||
| 81 |
- #' )+ #' library(teal.modules.general) |
||
| 82 |
- #' ),+ #' interactive <- function() TRUE |
||
| 83 |
- #' regressor = data_extract_spec(+ #' {{ next_example }}
|
||
| 84 |
- #' dataname = "CO2",+ #' @examples |
||
| 85 |
- #' select = select_spec(+ #' # CDISC data example |
||
| 86 |
- #' label = "Select variables:",+ #' data <- teal_data() |
||
| 87 |
- #' choices = variable_choices(data[["CO2"]], c("conc", "Treatment")),
+ #' data <- within(data, {
|
||
| 88 |
- #' selected = "conc",+ #' require(nestcolor) |
||
| 89 |
- #' multiple = TRUE,+ #' ADSL <- teal.data::rADSL |
||
| 90 |
- #' fixed = FALSE+ #' }) |
||
| 91 |
- #' )+ #' join_keys(data) <- default_cdisc_join_keys[names(data)] |
||
| 92 |
- #' )+ #' |
||
| 93 |
- #' )+ #' app <- init( |
||
| 94 |
- #' )+ #' data = data, |
||
| 95 |
- #' )+ #' modules = modules( |
||
| 96 |
- #' if (interactive()) {
+ #' tm_g_association( |
||
| 97 |
- #' shinyApp(app$ui, app$server)+ #' ref = data_extract_spec( |
||
| 98 |
- #' }+ #' dataname = "ADSL", |
||
| 99 |
- #'+ #' select = select_spec( |
||
| 100 |
- #' @examplesShinylive+ #' label = "Select variable:", |
||
| 101 |
- #' library(teal.modules.general)+ #' choices = variable_choices( |
||
| 102 |
- #' interactive <- function() TRUE+ #' data[["ADSL"]], |
||
| 103 |
- #' {{ next_example }}
+ #' c("SEX", "RACE", "COUNTRY", "ARM", "STRATA1", "STRATA2", "ITTFL", "BMRKR2")
|
||
| 104 |
- #' @examples+ #' ), |
||
| 105 |
- #' # CDISC data example+ #' selected = "RACE", |
||
| 106 |
- #' data <- teal_data()+ #' fixed = FALSE |
||
| 107 |
- #' data <- within(data, {
+ #' ) |
||
| 108 |
- #' require(nestcolor)+ #' ), |
||
| 109 |
- #' ADSL <- rADSL+ #' vars = data_extract_spec( |
||
| 110 |
- #' })+ #' dataname = "ADSL", |
||
| 111 |
- #' join_keys(data) <- default_cdisc_join_keys[names(data)]+ #' select = select_spec( |
||
| 112 |
- #'+ #' label = "Select variables:", |
||
| 113 |
- #' app <- init(+ #' choices = variable_choices( |
||
| 114 |
- #' data = data,+ #' data[["ADSL"]], |
||
| 115 |
- #' modules = modules(+ #' c("SEX", "RACE", "COUNTRY", "ARM", "STRATA1", "STRATA2", "ITTFL", "BMRKR2")
|
||
| 116 |
- #' tm_a_regression(+ #' ), |
||
| 117 |
- #' label = "Regression",+ #' selected = "BMRKR2", |
||
| 118 |
- #' response = data_extract_spec(+ #' multiple = TRUE, |
||
| 119 |
- #' dataname = "ADSL",+ #' fixed = FALSE |
||
| 120 |
- #' select = select_spec(+ #' ) |
||
| 121 |
- #' label = "Select variable:",+ #' ) |
||
| 122 |
- #' choices = "BMRKR1",+ #' ) |
||
| 123 |
- #' selected = "BMRKR1",+ #' ) |
||
| 124 |
- #' multiple = FALSE,+ #' ) |
||
| 125 |
- #' fixed = TRUE+ #' if (interactive()) {
|
||
| 126 |
- #' )+ #' shinyApp(app$ui, app$server) |
||
| 127 |
- #' ),+ #' } |
||
| 128 |
- #' regressor = data_extract_spec(+ #' |
||
| 129 |
- #' dataname = "ADSL",+ #' @export |
||
| 130 |
- #' select = select_spec(+ #' |
||
| 131 |
- #' label = "Select variables:",+ tm_g_association <- function(label = "Association", |
||
| 132 |
- #' choices = variable_choices(data[["ADSL"]], c("AGE", "SEX", "RACE")),
+ ref, |
||
| 133 |
- #' selected = "AGE",+ vars, |
||
| 134 |
- #' multiple = TRUE,+ show_association = TRUE, |
||
| 135 |
- #' fixed = FALSE+ plot_height = c(600, 400, 5000), |
||
| 136 |
- #' )+ plot_width = NULL, |
||
| 137 |
- #' )+ distribution_theme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void"), # nolint: line_length.
|
||
| 138 |
- #' )+ association_theme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void"), # nolint: line_length.
|
||
| 139 |
- #' )+ pre_output = NULL, |
||
| 140 |
- #' )+ post_output = NULL, |
||
| 141 |
- #' if (interactive()) {
+ ggplot2_args = teal.widgets::ggplot2_args(), |
||
| 142 |
- #' shinyApp(app$ui, app$server)+ decorators = NULL) {
|
||
| 143 | -+ | ! |
- #' }+ message("Initializing tm_g_association")
|
| 144 |
- #'+ |
||
| 145 |
- #' @export+ # Normalize the parameters |
||
| 146 | -+ | ! |
- #'+ if (inherits(ref, "data_extract_spec")) ref <- list(ref) |
| 147 | -+ | ! |
- tm_a_regression <- function(label = "Regression Analysis",+ if (inherits(vars, "data_extract_spec")) vars <- list(vars) |
| 148 | -+ | ! |
- regressor,+ if (inherits(ggplot2_args, "ggplot2_args")) ggplot2_args <- list(default = ggplot2_args) |
| 149 |
- response,+ |
||
| 150 |
- plot_height = c(600, 200, 2000),+ # Start of assertions |
||
| 151 | -+ | ! |
- plot_width = NULL,+ checkmate::assert_string(label) |
| 152 |
- alpha = c(1, 0, 1),+ |
||
| 153 | -+ | ! |
- size = c(2, 1, 8),+ checkmate::assert_list(ref, types = "data_extract_spec") |
| 154 | -+ | ! |
- ggtheme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void"),
+ if (!all(vapply(ref, function(x) !x$select$multiple, logical(1)))) {
|
| 155 | -+ | ! |
- ggplot2_args = teal.widgets::ggplot2_args(),+ stop("'ref' should not allow multiple selection")
|
| 156 |
- pre_output = NULL,+ } |
||
| 157 |
- post_output = NULL,+ |
||
| 158 | -+ | ! |
- default_plot_type = 1,+ checkmate::assert_list(vars, types = "data_extract_spec") |
| 159 | -+ | ! |
- default_outlier_label = "USUBJID",+ checkmate::assert_flag(show_association) |
| 160 |
- label_segment_threshold = c(0.5, 0, 10),+ |
||
| 161 | -+ | ! |
- decorators = NULL) {
+ checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE) |
| 162 | ! |
- message("Initializing tm_a_regression")
+ checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height") |
|
| 163 | -+ | ! |
-
+ checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE) |
| 164 | -+ | ! |
- # Normalize the parameters+ checkmate::assert_numeric( |
| 165 | ! |
- if (inherits(regressor, "data_extract_spec")) regressor <- list(regressor)+ plot_width[1], |
|
| 166 | ! |
- if (inherits(response, "data_extract_spec")) response <- list(response)+ lower = plot_width[2], upper = plot_width[3], null.ok = TRUE, .var.name = "plot_width" |
|
| 167 | -! | +
- if (inherits(ggplot2_args, "ggplot2_args")) ggplot2_args <- list(default = ggplot2_args)+ ) |
|
| 169 | -- |
- # Start of assertions- |
- |
| 170 | +169 | ! |
- checkmate::assert_string(label)+ distribution_theme <- match.arg(distribution_theme) |
| 171 | +170 | ! |
- checkmate::assert_list(regressor, types = "data_extract_spec")+ association_theme <- match.arg(association_theme) |
| 172 | +171 | ||
| 173 | +172 | ! |
- checkmate::assert_list(response, types = "data_extract_spec")+ checkmate::assert_multi_class(pre_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
|
| 174 | +173 | ! |
- assert_single_selection(response)+ checkmate::assert_multi_class(post_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
|
| 175 | +174 | ||
| 175 | +! | +
+ plot_choices <- c("Bivariate1", "Bivariate2")
+ |
+ |
| 176 | ! |
- checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE)+ checkmate::assert_list(ggplot2_args, types = "ggplot2_args") |
|
| 177 | ! |
- checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height")+ checkmate::assert_subset(names(ggplot2_args), c("default", plot_choices))
|
|
| 179 | ! |
- checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE)+ decorators <- normalize_decorators(decorators) |
|
| 180 | ! |
- checkmate::assert_numeric(+ assert_decorators(decorators, null.ok = TRUE, "plot") |
|
| 181 | -! | +
- plot_width[1],+ # End of assertions |
|
| 182 | -! | +
- lower = plot_width[2],+ |
|
| 183 | -! | +
- upper = plot_width[3],+ # Make UI args |
|
| 184 | ! |
- null.ok = TRUE,+ args <- as.list(environment()) |
|
| 185 | -! | +
- .var.name = "plot_width"+ |
|
| 186 | -+ | ! |
- )+ data_extract_list <- list( |
| 187 | -+ | ! |
-
+ ref = ref, |
| 188 | ! |
- if (length(alpha) == 1) {
+ vars = vars |
|
| 189 | -! | +
- checkmate::assert_numeric(alpha, any.missing = FALSE, finite = TRUE)+ ) |
|
| 190 |
- } else {
+
|
||
| 191 | ! |
- checkmate::assert_numeric(alpha, len = 3, any.missing = FALSE, finite = TRUE)+ ans <- module( |
|
| 192 | ! |
- checkmate::assert_numeric(alpha[1], lower = alpha[2], upper = alpha[3], .var.name = "alpha")+ label = label, |
|
| 193 | -+ | ! |
- }+ server = srv_tm_g_association, |
| 194 | -+ | ! |
-
+ ui = ui_tm_g_association, |
| 195 | ! |
- if (length(size) == 1) {
+ ui_args = args, |
|
| 196 | ! |
- checkmate::assert_numeric(size, any.missing = FALSE, finite = TRUE)+ server_args = c( |
|
| 197 | -+ | ! |
- } else {
+ data_extract_list, |
| 198 | ! |
- checkmate::assert_numeric(size, len = 3, any.missing = FALSE, finite = TRUE)+ list(plot_height = plot_height, plot_width = plot_width, ggplot2_args = ggplot2_args, decorators = decorators) |
|
| 199 | -! | +
- checkmate::assert_numeric(size[1], lower = size[2], upper = size[3], .var.name = "size")+ ), |
|
| 200 | -+ | ! |
- }+ datanames = teal.transform::get_extract_datanames(data_extract_list) |
| 201 |
-
+ ) |
||
| 202 | ! |
- ggtheme <- match.arg(ggtheme)+ attr(ans, "teal_bookmarkable") <- TRUE |
|
| 203 | -+ | ! |
-
+ ans |
| 204 | -! | +
- plot_choices <- c(+ } |
|
| 205 | -! | +
- "Response vs Regressor", "Residuals vs Fitted", "Normal Q-Q", "Scale-Location",+ |
|
| 206 | -! | +
- "Cook's distance", "Residuals vs Leverage", "Cook's dist vs Leverage"+ # UI function for the association module |
|
| 207 |
- )+ ui_tm_g_association <- function(id, ...) {
|
||
| 208 | ! |
- checkmate::assert_list(ggplot2_args, types = "ggplot2_args")+ ns <- NS(id) |
|
| 209 | ! |
- checkmate::assert_subset(names(ggplot2_args), c("default", plot_choices))
+ args <- list(...) |
|
| 210 | -+ | ! |
-
+ is_single_dataset_value <- teal.transform::is_single_dataset(args$ref, args$vars) |
| 211 | -! | +
- checkmate::assert_multi_class(pre_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
+
|
|
| 212 | ! |
- checkmate::assert_multi_class(post_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
+ teal.widgets::standard_layout( |
|
| 213 | ! |
- checkmate::assert_choice(default_plot_type, seq.int(1L, length(plot_choices)))+ output = teal.widgets::white_small_well( |
|
| 214 | ! |
- checkmate::assert_string(default_outlier_label)+ textOutput(ns("title")),
|
|
| 215 | ! |
- checkmate::assert_list(decorators, "teal_transform_module", null.ok = TRUE)+ tags$br(), |
|
| 216 | -+ | ! |
-
+ teal.widgets::plot_with_settings_ui(id = ns("myplot"))
|
| 217 | -! | +
- if (length(label_segment_threshold) == 1) {
+ ), |
|
| 218 | ! |
- checkmate::assert_numeric(label_segment_threshold, any.missing = FALSE, finite = TRUE)+ encoding = tags$div( |
|
| 219 |
- } else {
+ ### Reporter |
||
| 220 | ! |
- checkmate::assert_numeric(label_segment_threshold, len = 3, any.missing = FALSE, finite = TRUE)+ teal.reporter::simple_reporter_ui(ns("simple_reporter")),
|
|
| 221 | -! | +
- checkmate::assert_numeric(+ ### |
|
| 222 | ! |
- label_segment_threshold[1],+ tags$label("Encodings", class = "text-primary"),
|
|
| 223 | ! |
- lower = label_segment_threshold[2],+ teal.transform::datanames_input(args[c("ref", "vars")]),
|
|
| 224 | ! |
- upper = label_segment_threshold[3],+ teal.transform::data_extract_ui( |
|
| 225 | ! |
- .var.name = "label_segment_threshold"+ id = ns("ref"),
|
|
| 226 | -+ | ! |
- )+ label = "Reference variable", |
| 227 | -+ | ! |
- }+ data_extract_spec = args$ref, |
| 228 | ! |
- decorators <- normalize_decorators(decorators)+ is_single_dataset = is_single_dataset_value |
|
| 229 | -! | +
- assert_decorators(decorators, "plot", null.ok = TRUE)+ ), |
|
| 230 | -+ | ! |
- # End of assertions+ teal.transform::data_extract_ui( |
| 231 | -+ | ! |
-
+ id = ns("vars"),
|
| 232 | -+ | ! |
- # Make UI args+ label = "Associated variables", |
| 233 | ! |
- args <- as.list(environment())+ data_extract_spec = args$vars, |
|
| 234 | ! |
- args[["plot_choices"]] <- plot_choices+ is_single_dataset = is_single_dataset_value |
|
| 235 | -! | +
- data_extract_list <- list(+ ), |
|
| 236 | ! |
- regressor = regressor,+ checkboxInput( |
|
| 237 | ! |
- response = response+ ns("association"),
|
|
| 238 | -+ | ! |
- )+ "Association with reference variable", |
| 239 | -+ | ! |
-
+ value = args$show_association |
| 240 | -! | +
- ans <- module(+ ), |
|
| 241 | ! |
- label = label,+ checkboxInput( |
|
| 242 | ! |
- server = srv_a_regression,+ ns("show_dist"),
|
|
| 243 | ! |
- ui = ui_a_regression,+ "Scaled frequencies", |
|
| 244 | ! |
- ui_args = args,+ value = FALSE |
|
| 245 | -! | +
- server_args = c(+ ), |
|
| 246 | ! |
- data_extract_list,+ checkboxInput( |
|
| 247 | ! |
- list(+ ns("log_transformation"),
|
|
| 248 | ! |
- plot_height = plot_height,+ "Log transformed", |
|
| 249 | ! |
- plot_width = plot_width,+ value = FALSE |
|
| 250 | -! | +
- default_outlier_label = default_outlier_label,+ ), |
|
| 251 | ! |
- ggplot2_args = ggplot2_args,+ ui_decorate_teal_data(ns("decorator"), decorators = select_decorators(args$decorators, "plot")),
|
|
| 252 | ! |
- decorators = decorators+ teal.widgets::panel_group( |
|
| 253 | -+ | ! |
- )+ teal.widgets::panel_item( |
| 254 | -+ | ! |
- ),+ title = "Plot settings", |
| 255 | ! |
- datanames = teal.transform::get_extract_datanames(data_extract_list)+ teal.widgets::optionalSliderInputValMinMax(ns("alpha"), "Scatterplot opacity:", c(0.5, 0, 1), ticks = FALSE),
|
|
| 256 | -+ | ! |
- )+ teal.widgets::optionalSliderInputValMinMax(ns("size"), "Scatterplot points size:", c(2, 1, 8), ticks = FALSE),
|
| 257 | ! |
- attr(ans, "teal_bookmarkable") <- FALSE+ checkboxInput(ns("swap_axes"), "Swap axes", value = FALSE),
|
|
| 258 | ! |
- ans+ checkboxInput(ns("rotate_xaxis_labels"), "Rotate X axis labels", value = FALSE),
|
|
| 259 | -+ | ! |
- }+ selectInput( |
| 260 | -+ | ! |
-
+ inputId = ns("distribution_theme"),
|
| 261 | -+ | ! |
- # UI function for the regression module+ label = "Distribution theme (by ggplot):", |
| 262 | -+ | ! |
- ui_a_regression <- function(id, ...) {
+ choices = ggplot_themes, |
| 263 | ! |
- ns <- NS(id)+ selected = args$distribution_theme, |
|
| 264 | ! |
- args <- list(...)+ multiple = FALSE |
|
| 265 | -! | +
- is_single_dataset_value <- teal.transform::is_single_dataset(args$regressor, args$response)+ ), |
|
| 266 | ! |
- teal.widgets::standard_layout(+ selectInput( |
|
| 267 | ! |
- output = teal.widgets::white_small_well(tags$div(+ inputId = ns("association_theme"),
|
|
| 268 | ! |
- teal.widgets::plot_with_settings_ui(id = ns("myplot")),
+ label = "Association theme (by ggplot):", |
|
| 269 | ! |
- tags$div(verbatimTextOutput(ns("text")))
+ choices = ggplot_themes, |
|
| 270 | -+ | ! |
- )),+ selected = args$association_theme, |
| 271 | ! |
- encoding = tags$div(+ multiple = FALSE |
|
| 272 |
- ### Reporter+ ) |
||
| 273 | -! | +
- teal.reporter::simple_reporter_ui(ns("simple_reporter")),
+ ) |
|
| 274 |
- ###+ ) |
||
| 275 | -! | +
- tags$label("Encodings", class = "text-primary"),
+ ), |
|
| 276 | ! |
- teal.transform::datanames_input(args[c("response", "regressor")]),
+ forms = tagList( |
|
| 277 | ! |
- teal.transform::data_extract_ui(+ teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code")
|
|
| 278 | -! | +
- id = ns("response"),
+ ), |
|
| 279 | ! |
- label = "Response variable",+ pre_output = args$pre_output, |
|
| 280 | ! |
- data_extract_spec = args$response,+ post_output = args$post_output |
|
| 281 | -! | +
- is_single_dataset = is_single_dataset_value+ ) |
|
| 282 |
- ),+ } |
||
| 283 | -! | +
- teal.transform::data_extract_ui(+ |
|
| 284 | -! | +
- id = ns("regressor"),
+ # Server function for the association module |
|
| 285 | -! | +
- label = "Regressor variables",+ srv_tm_g_association <- function(id, |
|
| 286 | -! | +
- data_extract_spec = args$regressor,+ data, |
|
| 287 | -! | +
- is_single_dataset = is_single_dataset_value+ reporter, |
|
| 288 |
- ),+ filter_panel_api, |
||
| 289 | -! | +
- radioButtons(+ ref, |
|
| 290 | -! | +
- ns("plot_type"),
+ vars, |
|
| 291 | -! | +
- label = "Plot type:",+ plot_height, |
|
| 292 | -! | +
- choices = args$plot_choices,+ plot_width, |
|
| 293 | -! | +
- selected = args$plot_choices[args$default_plot_type]+ ggplot2_args, |
|
| 294 |
- ),+ decorators) {
|
||
| 295 | ! |
- checkboxInput(ns("show_outlier"), label = "Display outlier labels", value = TRUE),
+ with_reporter <- !missing(reporter) && inherits(reporter, "Reporter") |
|
| 296 | ! |
- conditionalPanel(+ with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI") |
|
| 297 | ! |
- condition = "input['show_outlier']",+ checkmate::assert_class(data, "reactive") |
|
| 298 | ! |
- ns = ns,+ checkmate::assert_class(isolate(data()), "teal_data") |
|
| 299 | -! | +
- teal.widgets::optionalSliderInput(+ |
|
| 300 | ! |
- ns("outlier"),
+ moduleServer(id, function(input, output, session) {
|
|
| 301 | ! |
- tags$div(+ teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.general") |
|
| 302 | -! | +
- class = "teal-tooltip",+ |
|
| 303 | ! |
- tagList(+ selector_list <- teal.transform::data_extract_multiple_srv( |
|
| 304 | ! |
- "Outlier definition:",+ data_extract = list(ref = ref, vars = vars), |
|
| 305 | ! |
- icon("circle-info"),
+ datasets = data, |
|
| 306 | ! |
- tags$span(+ select_validation_rule = list( |
|
| 307 | ! |
- class = "tooltiptext",+ ref = shinyvalidate::compose_rules( |
|
| 308 | ! |
- paste(+ shinyvalidate::sv_required("A reference variable needs to be selected."),
|
|
| 309 | ! |
- "Use the slider to choose the cut-off value to define outliers.",+ ~ if ((.) %in% selector_list()$vars()$select) {
|
|
| 310 | ! |
- "Points with a Cook's distance greater than",+ "Associated variables and reference variable cannot overlap" |
|
| 311 | -! | +
- "the value on the slider times the mean of the Cook's distance of the dataset will have labels."+ } |
|
| 312 |
- )+ ), |
||
| 313 | -+ | ! |
- )+ vars = shinyvalidate::compose_rules( |
| 314 | -+ | ! |
- )+ shinyvalidate::sv_required("An associated variable needs to be selected."),
|
| 315 | -+ | ! |
- ),+ ~ if (length(selector_list()$ref()$select) != 0 && selector_list()$ref()$select %in% (.)) {
|
| 316 | ! |
- min = 1, max = 10, value = 9, ticks = FALSE, step = .1+ "Associated variables and reference variable cannot overlap" |
|
| 317 |
- ),+ } |
||
| 318 | -! | +
- teal.widgets::optionalSelectInput(+ ) |
|
| 319 | -! | +
- ns("label_var"),
+ ) |
|
| 320 | -! | +
- multiple = FALSE,+ ) |
|
| 321 | -! | +
- label = "Outlier label"+ |
|
| 322 | -+ | ! |
- )+ iv_r <- reactive({
|
| 323 | -+ | ! |
- ),+ iv <- shinyvalidate::InputValidator$new() |
| 324 | ! |
- ui_decorate_teal_data(ns("decorator"), decorators = select_decorators(args$decorators, "plot")),
+ teal.transform::compose_and_enable_validators(iv, selector_list) |
|
| 325 | -! | +
- teal.widgets::panel_group(+ }) |
|
| 326 | -! | +
- teal.widgets::panel_item(+ |
|
| 327 | ! |
- title = "Plot settings",+ anl_merged_input <- teal.transform::merge_expression_srv( |
|
| 328 | ! |
- teal.widgets::optionalSliderInputValMinMax(ns("alpha"), "Opacity:", args$alpha, ticks = FALSE),
+ datasets = data, |
|
| 329 | ! |
- teal.widgets::optionalSliderInputValMinMax(ns("size"), "Points size:", args$size, ticks = FALSE),
+ selector_list = selector_list |
|
| 330 | -! | +
- teal.widgets::optionalSliderInputValMinMax(+ ) |
|
| 331 | -! | +
- inputId = ns("label_min_segment"),
+
|
|
| 332 | ! |
- label = tags$div(+ anl_merged_q <- reactive({
|
|
| 333 | ! |
- class = "teal-tooltip",+ req(anl_merged_input()) |
|
| 334 | ! |
- tagList(+ data() %>% teal.code::eval_code(as.expression(anl_merged_input()$expr)) |
|
| 335 | -! | +
- "Label min. segment:",+ }) |
|
| 336 | -! | +
- icon("circle-info"),
+
|
|
| 337 | ! |
- tags$span(+ merged <- list( |
|
| 338 | ! |
- class = "tooltiptext",+ anl_input_r = anl_merged_input, |
|
| 339 | ! |
- paste(+ anl_q_r = anl_merged_q |
|
| 340 | -! | +
- "Use the slider to choose the cut-off value to define minimum distance between label and point",+ ) |
|
| 341 | -! | +
- "that generates a line segment.",+ |
|
| 342 | ! |
- "It's only valid when 'Display outlier labels' is checked."+ output_q <- reactive({
|
|
| 343 | -+ | ! |
- )+ teal::validate_inputs(iv_r()) |
| 344 |
- )+ |
||
| 345 | -+ | ! |
- )+ ANL <- merged$anl_q_r()[["ANL"]] |
| 346 | -+ | ! |
- ),+ teal::validate_has_data(ANL, 3) |
| 347 | -! | +
- value_min_max = args$label_segment_threshold,+ |
|
| 348 | -+ | ! |
- # Extra parameters to sliderInput+ vars_names <- merged$anl_input_r()$columns_source$vars |
| 349 | -! | +
- ticks = FALSE,+ |
|
| 350 | ! |
- step = .1,+ ref_name <- as.vector(merged$anl_input_r()$columns_source$ref) |
|
| 351 | ! |
- round = FALSE+ association <- input$association |
|
| 352 | -+ | ! |
- ),+ show_dist <- input$show_dist |
| 353 | ! |
- selectInput(+ log_transformation <- input$log_transformation |
|
| 354 | ! |
- inputId = ns("ggtheme"),
+ rotate_xaxis_labels <- input$rotate_xaxis_labels |
|
| 355 | ! |
- label = "Theme (by ggplot):",+ swap_axes <- input$swap_axes |
|
| 356 | ! |
- choices = ggplot_themes,+ distribution_theme <- input$distribution_theme |
|
| 357 | ! |
- selected = args$ggtheme,+ association_theme <- input$association_theme |
|
| 358 | -! | +
- multiple = FALSE+ |
|
| 359 | -+ | ! |
- )+ is_scatterplot <- is.numeric(ANL[[ref_name]]) && any(vapply(ANL[vars_names], is.numeric, logical(1))) |
| 360 | -+ | ! |
- )+ if (is_scatterplot) {
|
| 361 | -+ | ! |
- )+ shinyjs::show("alpha")
|
| 362 | -+ | ! |
- ),+ shinyjs::show("size")
|
| 363 | ! |
- forms = tagList(+ alpha <- input$alpha |
|
| 364 | ! |
- teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code")
+ size <- input$size |
|
| 365 |
- ),+ } else {
|
||
| 366 | ! |
- pre_output = args$pre_output,+ shinyjs::hide("alpha")
|
|
| 367 | ! |
- post_output = args$post_output+ shinyjs::hide("size")
|
|
| 368 | -+ | ! |
- )+ alpha <- 0.5 |
| 369 | -+ | ! |
- }+ size <- 2 |
| 370 |
-
+ } |
||
| 371 |
- # Server function for the regression module+ |
||
| 372 | -+ | ! |
- srv_a_regression <- function(id,+ teal::validate_has_data(ANL[, c(ref_name, vars_names)], 3, complete = TRUE, allow_inf = FALSE) |
| 373 |
- data,+ |
||
| 374 |
- reporter,+ # reference |
||
| 375 | -+ | ! |
- filter_panel_api,+ ref_class <- class(ANL[[ref_name]])[1] |
| 376 | -+ | ! |
- response,+ if (is.numeric(ANL[[ref_name]]) && log_transformation) {
|
| 377 |
- regressor,+ # works for both integers and doubles |
||
| 378 | -+ | ! |
- plot_height,+ ref_cl_name <- call("log", as.name(ref_name))
|
| 379 | -+ | ! |
- plot_width,+ ref_cl_lbl <- varname_w_label(ref_name, ANL, prefix = "Log of ") |
| 380 |
- ggplot2_args,+ } else {
|
||
| 381 |
- default_outlier_label,+ # silently ignore when non-numeric even if `log` is selected because some |
||
| 382 |
- decorators) {
+ # variables may be numeric and others not |
||
| 383 | ! |
- with_reporter <- !missing(reporter) && inherits(reporter, "Reporter")+ ref_cl_name <- as.name(ref_name) |
|
| 384 | ! |
- with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI")+ ref_cl_lbl <- varname_w_label(ref_name, ANL) |
|
| 385 | -! | +
- checkmate::assert_class(data, "reactive")+ } |
|
| 386 | -! | +
- checkmate::assert_class(isolate(data()), "teal_data")+ |
|
| 387 | ! |
- moduleServer(id, function(input, output, session) {
+ user_ggplot2_args <- teal.widgets::resolve_ggplot2_args( |
|
| 388 | ! |
- teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.general")+ user_plot = ggplot2_args[["Bivariate1"]], |
|
| 389 | -+ | ! |
-
+ user_default = ggplot2_args$default |
| 390 | -! | +
- ns <- session$ns+ ) |
|
| 392 | ! |
- rule_rvr1 <- function(value) {
+ ref_call <- bivariate_plot_call( |
|
| 393 | ! |
- if (isTRUE(input$plot_type == "Response vs Regressor")) {
+ data_name = "ANL", |
|
| 394 | ! |
- if (length(value) > 1L) {
+ x = ref_cl_name, |
|
| 395 | ! |
- "This plot can only have one regressor."+ x_class = ref_class, |
|
| 396 | -+ | ! |
- }+ x_label = ref_cl_lbl, |
| 397 | -+ | ! |
- }+ freq = !show_dist, |
| 398 | -+ | ! |
- }+ theme = distribution_theme, |
| 399 | ! |
- rule_rvr2 <- function(other) {
+ rotate_xaxis_labels = rotate_xaxis_labels, |
|
| 400 | ! |
- function(value) {
+ swap_axes = FALSE, |
|
| 401 | ! |
- if (isTRUE(input$plot_type == "Response vs Regressor")) {
+ size = size, |
|
| 402 | ! |
- otherval <- selector_list()[[other]]()$select+ alpha = alpha, |
|
| 403 | ! |
- if (isTRUE(value == otherval)) {
+ ggplot2_args = user_ggplot2_args |
|
| 404 | -! | +
- "Response and Regressor must be different."+ ) |
|
| 405 |
- }+ |
||
| 406 |
- }+ # association |
||
| 407 | -+ | ! |
- }+ ref_class_cov <- ifelse(association, ref_class, "NULL") |
| 408 |
- }+ |
||
| 409 | -+ | ! |
-
+ var_calls <- lapply(vars_names, function(var_i) {
|
| 410 | ! |
- selector_list <- teal.transform::data_extract_multiple_srv(+ var_class <- class(ANL[[var_i]])[1] |
|
| 411 | ! |
- data_extract = list(response = response, regressor = regressor),+ if (is.numeric(ANL[[var_i]]) && log_transformation) {
|
|
| 412 | -! | +
- datasets = data,+ # works for both integers and doubles |
|
| 413 | ! |
- select_validation_rule = list(+ var_cl_name <- call("log", as.name(var_i))
|
|
| 414 | ! |
- regressor = shinyvalidate::compose_rules(+ var_cl_lbl <- varname_w_label(var_i, ANL, prefix = "Log of ") |
|
| 415 | -! | +
- shinyvalidate::sv_required("At least one regressor should be selected."),
+ } else {
|
|
| 416 | -! | +
- rule_rvr1,+ # silently ignore when non-numeric even if `log` is selected because some |
|
| 417 | -! | +
- rule_rvr2("response")
+ # variables may be numeric and others not |
|
| 418 | -+ | ! |
- ),+ var_cl_name <- as.name(var_i) |
| 419 | ! |
- response = shinyvalidate::compose_rules(+ var_cl_lbl <- varname_w_label(var_i, ANL) |
|
| 420 | -! | +
- shinyvalidate::sv_required("At least one response should be selected."),
+ } |
|
| 421 | -! | +
- rule_rvr2("regressor")
+
|
|
| 422 | -+ | ! |
- )+ user_ggplot2_args <- teal.widgets::resolve_ggplot2_args( |
| 423 | -+ | ! |
- )+ user_plot = ggplot2_args[["Bivariate2"]], |
| 424 | -+ | ! |
- )+ user_default = ggplot2_args$default |
| 425 |
-
+ ) |
||
| 426 | -! | +
- iv_r <- reactive({
+
|
|
| 427 | ! |
- iv <- shinyvalidate::InputValidator$new()+ bivariate_plot_call( |
|
| 428 | ! |
- teal.transform::compose_and_enable_validators(iv, selector_list)+ data_name = "ANL", |
|
| 429 | -+ | ! |
- })+ x = ref_cl_name, |
| 430 | -+ | ! |
-
+ y = var_cl_name, |
| 431 | ! |
- iv_out <- shinyvalidate::InputValidator$new()+ x_class = ref_class_cov, |
|
| 432 | ! |
- iv_out$condition(~ isTRUE(input$show_outlier))+ y_class = var_class, |
|
| 433 | ! |
- iv_out$add_rule("label_var", shinyvalidate::sv_required("Please provide an `Outlier label` variable"))
+ x_label = ref_cl_lbl, |
|
| 434 | ! |
- iv_out$enable()+ y_label = var_cl_lbl, |
|
| 435 | -+ | ! |
-
+ theme = association_theme, |
| 436 | ! |
- anl_merged_input <- teal.transform::merge_expression_srv(+ freq = !show_dist, |
|
| 437 | ! |
- selector_list = selector_list,+ rotate_xaxis_labels = rotate_xaxis_labels, |
|
| 438 | ! |
- datasets = data+ swap_axes = swap_axes, |
|
| 439 | -+ | ! |
- )+ alpha = alpha, |
| 440 | -+ | ! |
-
+ size = size, |
| 441 | ! |
- regression_var <- reactive({
+ ggplot2_args = user_ggplot2_args |
|
| 442 | -! | +
- teal::validate_inputs(iv_r())+ ) |
|
| 443 |
-
+ }) |
||
| 444 | -! | +
- list(+ |
|
| 445 | -! | +
- response = as.vector(anl_merged_input()$columns_source$response),+ # helper function to format variable name |
|
| 446 | ! |
- regressor = as.vector(anl_merged_input()$columns_source$regressor)+ format_varnames <- function(x) {
|
|
| 447 | -+ | ! |
- )+ if (is.numeric(ANL[[x]]) && log_transformation) {
|
| 448 | -+ | ! |
- })+ varname_w_label(x, ANL, prefix = "Log of ") |
| 449 |
-
+ } else {
|
||
| 450 | ! |
- anl_merged_q <- reactive({
+ varname_w_label(x, ANL) |
|
| 451 | -! | +
- req(anl_merged_input())+ } |
|
| 452 | -! | +
- data() %>%+ } |
|
| 453 | ! |
- teal.code::eval_code(as.expression(anl_merged_input()$expr))+ new_title <- |
|
| 454 | -+ | ! |
- })+ if (association) {
|
| 455 | -+ | ! |
-
+ switch(as.character(length(vars_names)), |
| 456 | -+ | ! |
- # sets qenv object and populates it with data merge call and fit expression+ "0" = sprintf("Value distribution for %s", ref_cl_lbl),
|
| 457 | ! |
- fit_r <- reactive({
+ "1" = sprintf( |
|
| 458 | ! |
- ANL <- anl_merged_q()[["ANL"]]+ "Association between %s and %s", |
|
| 459 | ! |
- teal::validate_has_data(ANL, 10)+ ref_cl_lbl, |
|
| 460 | -+ | ! |
-
+ format_varnames(vars_names) |
| 461 | -! | +
- validate(need(is.numeric(ANL[regression_var()$response][[1]]), "Response variable should be numeric."))+ ), |
|
| 462 | -+ | ! |
-
+ sprintf( |
| 463 | ! |
- teal::validate_has_data(+ "Associations between %s and: %s", |
|
| 464 | ! |
- ANL[, c(regression_var()$response, regression_var()$regressor)], 10,+ ref_cl_lbl, |
|
| 465 | ! |
- complete = TRUE, allow_inf = FALSE+ paste(lapply(vars_names, format_varnames), collapse = ", ") |
|
| 466 |
- )+ ) |
||
| 467 |
-
+ ) |
||
| 468 | -! | +
- form <- stats::as.formula(+ } else {
|
|
| 469 | ! |
- paste(+ switch(as.character(length(vars_names)), |
|
| 470 | ! |
- regression_var()$response,+ "0" = sprintf("Value distribution for %s", ref_cl_lbl),
|
|
| 471 | ! |
- paste(+ sprintf( |
|
| 472 | ! |
- regression_var()$regressor,+ "Value distributions for %s and %s", |
|
| 473 | ! |
- collapse = " + "+ ref_cl_lbl, |
|
| 474 | -+ | ! |
- ),+ paste(lapply(vars_names, format_varnames), collapse = ", ") |
| 475 | -! | +
- sep = " ~ "+ ) |
|
| 476 |
- )+ ) |
||
| 477 |
- )+ } |
||
| 478 | -+ | ! |
-
+ teal.code::eval_code( |
| 479 | ! |
- if (input$show_outlier) {
+ merged$anl_q_r(), |
|
| 480 | ! |
- opts <- teal.transform::variable_choices(ANL)+ substitute( |
|
| 481 | ! |
- selected <- if (!is.null(isolate(input$label_var)) && isolate(input$label_var) %in% as.character(opts)) {
+ expr = title <- new_title, |
|
| 482 | ! |
- isolate(input$label_var)+ env = list(new_title = new_title) |
|
| 483 |
- } else {
+ ) |
||
| 484 | -! | +
- if (length(opts[as.character(opts) == default_outlier_label]) == 0) {
+ ) %>% |
|
| 485 | ! |
- opts[[1]]+ teal.code::eval_code( |
|
| 486 | -+ | ! |
- } else {
+ substitute( |
| 487 | ! |
- opts[as.character(opts) == default_outlier_label]+ expr = {
|
|
| 488 | -+ | ! |
- }+ plot_top <- plot_calls[[1]] |
| 489 | -+ | ! |
- }+ plot_bottom <- plot_calls[[1]] |
| 490 | ! |
- teal.widgets::updateOptionalSelectInput(+ plot <- tern::stack_grobs(grobs = lapply(list(plot_top, plot_bottom), ggplotGrob)) |
|
| 491 | -! | +
- session = session,+ }, |
|
| 492 | ! |
- inputId = "label_var",+ env = list( |
|
| 493 | ! |
- choices = opts,+ plot_calls = do.call( |
|
| 494 | ! |
- selected = restoreInput(ns("label_var"), selected)
+ "call", |
|
| 495 | -+ | ! |
- )+ c(list("list", ref_call), var_calls),
|
| 496 | -+ | ! |
-
+ quote = TRUE |
| 497 | -! | +
- data <- fortify(stats::lm(form, data = ANL))+ ) |
|
| 498 | -! | +
- cooksd <- data$.cooksd[!is.nan(data$.cooksd)]+ ) |
|
| 499 | -! | +
- max_outlier <- max(ceiling(max(cooksd) / mean(cooksd)), 2)+ ) |
|
| 500 | -! | +
- cur_outlier <- isolate(input$outlier)+ ) |
|
| 501 | -! | +
- updateSliderInput(+ }) |
|
| 502 | -! | +
- session = session,+ |
|
| 503 | ! |
- inputId = "outlier",+ decorated_output_grob_q <- srv_decorate_teal_data( |
|
| 504 | ! |
- min = 1,+ id = "decorator", |
|
| 505 | ! |
- max = max_outlier,+ data = output_q, |
|
| 506 | ! |
- value = restoreInput(ns("outlier"), if (cur_outlier < max_outlier) cur_outlier else max_outlier * .9)
+ decorators = select_decorators(decorators, "plot"), |
|
| 507 | -+ | ! |
- )+ expr = {
|
| 508 | -+ | ! |
- }+ grid::grid.newpage() |
| 509 | -+ | ! |
-
+ grid::grid.draw(plot) |
| 510 | -! | +
- anl_merged_q() %>%+ } |
|
| 511 | -! | +
- teal.code::eval_code(substitute(fit <- stats::lm(form, data = ANL), env = list(form = form))) %>%+ ) |
|
| 512 | -! | +
- teal.code::eval_code(quote({
+
|
|
| 513 | ! |
- for (regressor in names(fit$contrasts)) {
+ plot_r <- reactive({
|
|
| 514 | ! |
- alts <- paste0(levels(ANL[[regressor]]), collapse = "|")+ req(iv_r()$is_valid()) |
|
| 515 | ! |
- names(fit$coefficients) <- gsub(+ req(decorated_output_grob_q())[["plot"]] |
|
| 516 | -! | +
- paste0("^(", regressor, ")(", alts, ")$"), paste0("\\1", ": ", "\\2"), names(fit$coefficients)
+ }) |
|
| 517 |
- )+ |
||
| 518 | -+ | ! |
- }+ pws <- teal.widgets::plot_with_settings_srv( |
| 519 | -+ | ! |
- })) %>%+ id = "myplot", |
| 520 | ! |
- teal.code::eval_code(quote(summary(fit)))+ plot_r = plot_r, |
|
| 521 | -+ | ! |
- })+ height = plot_height, |
| 522 | -+ | ! |
-
+ width = plot_width |
| 523 | -! | +
- label_col <- reactive({
+ ) |
|
| 524 | -! | +
- teal::validate_inputs(iv_out)+ |
|
| 525 | -+ | ! |
-
+ output$title <- renderText({
|
| 526 | ! |
- substitute(+ teal.code::dev_suppress(output_q()[["title"]]) |
|
| 527 | -! | +
- expr = dplyr::if_else(+ }) |
|
| 528 | -! | +
- data$.cooksd > outliers * mean(data$.cooksd, na.rm = TRUE),+ |
|
| 529 | ! |
- as.character(stats::na.omit(ANL)[[label_var]]),+ teal.widgets::verbatim_popup_srv( |
|
| 530 | -+ | ! |
- ""+ id = "rcode", |
| 531 | -+ | ! |
- ) %>%+ verbatim_content = reactive(teal.code::get_code(req(decorated_output_grob_q()))), |
| 532 | ! |
- dplyr::if_else(is.na(.), "cooksd == NaN", .),+ title = "Association Plot" |
|
| 533 | -! | +
- env = list(outliers = input$outlier, label_var = input$label_var)+ ) |
|
| 534 |
- )+ |
||
| 535 |
- })+ ### REPORTER |
||
| 536 | -+ | ! |
-
+ if (with_reporter) {
|
| 537 | ! |
- label_min_segment <- reactive({
+ card_fun <- function(comment, label) {
|
|
| 538 | ! |
- input$label_min_segment+ card <- teal::report_card_template( |
|
| 539 | -+ | ! |
- })+ title = "Association Plot", |
| 540 | -+ | ! |
-
+ label = label, |
| 541 | ! |
- outlier_label <- reactive({
+ with_filter = with_filter, |
|
| 542 | ! |
- substitute(+ filter_panel_api = filter_panel_api |
|
| 543 | -! | +
- expr = ggrepel::geom_text_repel(+ ) |
|
| 544 | ! |
- label = label_col,+ card$append_text("Plot", "header3")
|
|
| 545 | ! |
- color = "red",+ card$append_plot(plot_r(), dim = pws$dim()) |
|
| 546 | ! |
- hjust = 0,+ if (!comment == "") {
|
|
| 547 | ! |
- vjust = 1,+ card$append_text("Comment", "header3")
|
|
| 548 | ! |
- max.overlaps = Inf,+ card$append_text(comment) |
|
| 549 | -! | +
- min.segment.length = label_min_segment,+ } |
|
| 550 | ! |
- segment.alpha = 0.5,+ card$append_src(teal.code::get_code(req(decorated_output_grob_q()))) |
|
| 551 | ! |
- seed = 123+ card |
|
| 552 |
- ),+ } |
||
| 553 | ! |
- env = list(label_col = label_col(), label_min_segment = label_min_segment())+ teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
|
|
| 554 |
- )+ } |
||
| 555 |
- })+ ### |
||
| 556 |
-
+ }) |
||
| 557 | -! | -
- output_plot_base <- reactive({
- |
- |
| 558 | -! | -
- base_fit <- fit_r()- |
- |
| 559 | -! | -
- teal.code::eval_code(- |
- |
| 560 | -! | -
- base_fit,- |
- |
| 561 | -! | -
- quote({
- |
- |
| 562 | -! | +
- class(fit$residuals) <- NULL+ } |
| 563 | +1 | - - | -||
| 564 | -! | -
- data <- ggplot2::fortify(fit)+ #' `teal` module: Cross-table |
||
| 565 | +2 | - - | -||
| 566 | -! | -
- smooth <- function(x, y) {
- |
- ||
| 567 | -! | -
- as.data.frame(stats::lowess(x, y, f = 2 / 3, iter = 3))+ #' |
||
| 568 | +3 |
- }+ #' Generates a simple cross-table of two variables from a dataset with custom |
||
| 569 | +4 | - - | -||
| 570 | -! | -
- smoothy_aes <- ggplot2::aes_string(x = "x", y = "y")+ #' options for showing percentages and sub-totals. |
||
| 571 | +5 | - - | -||
| 572 | -! | -
- reg_form <- deparse(fit$call[[2]])+ #' |
||
| 573 | +6 |
- })+ #' @inheritParams teal::module |
||
| 574 | +7 |
- )+ #' @inheritParams shared_params |
||
| 575 | +8 |
- })+ #' @param x (`data_extract_spec` or `list` of multiple `data_extract_spec`) |
||
| 576 | +9 | - - | -||
| 577 | -! | -
- output_plot_0 <- reactive({
- |
- ||
| 578 | -! | -
- fit <- fit_r()[["fit"]]- |
- ||
| 579 | -! | -
- ANL <- anl_merged_q()[["ANL"]]+ #' Object with all available choices with pre-selected option for variable X - row values. |
||
| 580 | +10 | - - | -||
| 581 | -! | -
- stopifnot(ncol(fit$model) == 2)+ #' In case of `data_extract_spec` use `select_spec(..., ordered = TRUE)` if table elements should be |
||
| 582 | +11 | - - | -||
| 583 | -! | -
- if (!is.factor(ANL[[regression_var()$regressor]])) {
- |
- ||
| 584 | -! | -
- shinyjs::show("size")
- |
- ||
| 585 | -! | -
- shinyjs::show("alpha")
+ #' rendered according to selection order. |
||
| 586 | -! | +|||
| 12 | +
- plot <- substitute(+ #' @param y (`data_extract_spec` or `list` of multiple `data_extract_spec`) |
|||
| 587 | -! | +|||
| 13 | +
- expr = ggplot(fit$model[, 2:1], aes_string(regressor, response)) ++ #' Object with all available choices with pre-selected option for variable Y - column values. |
|||
| 588 | -! | +|||
| 14 | +
- geom_point(size = size, alpha = alpha) ++ #' |
|||
| 589 | -! | +|||
| 15 | +
- stat_smooth(method = "lm", formula = y ~ x, se = FALSE),+ #' `data_extract_spec` must not allow multiple selection in this case. |
|||
| 590 | -! | +|||
| 16 | +
- env = list(+ #' @param show_percentage (`logical(1)`) |
|||
| 591 | -! | +|||
| 17 | +
- regressor = regression_var()$regressor,+ #' Indicates whether to show percentages (relevant only when `x` is a `factor`). |
|||
| 592 | -! | +|||
| 18 | +
- response = regression_var()$response,+ #' Defaults to `TRUE`. |
|||
| 593 | -! | +|||
| 19 | +
- size = input$size,+ #' @param show_total (`logical(1)`) |
|||
| 594 | -! | +|||
| 20 | +
- alpha = input$alpha+ #' Indicates whether to show total column. |
|||
| 595 | +21 |
- )+ #' Defaults to `TRUE`. |
||
| 596 | +22 |
- )+ #' @param decorators `r roxygen_decorators_param("tm_t_crosstable")`
|
||
| 597 | -! | +|||
| 23 | +
- if (input$show_outlier) {
+ #' |
|||
| 598 | -! | +|||
| 24 | +
- plot <- substitute(+ #' @note For more examples, please see the vignette "Using cross table" via |
|||
| 599 | -! | +|||
| 25 | +
- expr = plot + outlier_label,+ #' `vignette("using-cross-table", package = "teal.modules.general")`.
|
|||
| 600 | -! | +|||
| 26 | +
- env = list(plot = plot, outlier_label = outlier_label())+ #' |
|||
| 601 | +27 |
- )+ #' @inherit shared_params return |
||
| 602 | +28 |
- }+ #' |
||
| 603 | +29 |
- } else {
+ #' @section Decorating `tm_t_crosstable`: |
||
| 604 | -! | +|||
| 30 | +
- shinyjs::hide("size")
+ #' |
|||
| 605 | -! | +|||
| 31 | +
- shinyjs::hide("alpha")
+ #' This module generates the following objects, which can be modified in place using decorators: |
|||
| 606 | -! | +|||
| 32 | +
- plot <- substitute(+ #' - `table` (`ElementaryTable` - output of `rtables::build_table`) |
|||
| 607 | -! | +|||
| 33 | +
- expr = ggplot(fit$model[, 2:1], aes_string(regressor, response)) ++ #' |
|||
| 608 | -! | +|||
| 34 | +
- geom_boxplot(),+ #' For additional details and examples of decorators, refer to the vignette |
|||
| 609 | -! | +|||
| 35 | +
- env = list(regressor = regression_var()$regressor, response = regression_var()$response)+ #' `vignette("decorate-modules-output", package = "teal")` or the [`teal::teal_transform_module()`] documentation.
|
|||
| 610 | +36 |
- )+ #' |
||
| 611 | -! | +|||
| 37 | +
- if (input$show_outlier) {
+ #' @examplesShinylive |
|||
| 612 | -! | +|||
| 38 | +
- plot <- substitute(expr = plot + outlier_label, env = list(plot = plot, outlier_label = outlier_label()))+ #' library(teal.modules.general) |
|||
| 613 | +39 |
- }+ #' interactive <- function() TRUE |
||
| 614 | +40 |
- }+ #' {{ next_example }}
|
||
| 615 | +41 |
-
+ #' @examplesIf require("rtables", quietly = TRUE)
|
||
| 616 | -! | +|||
| 42 | +
- parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(+ #' # general data example |
|||
| 617 | -! | +|||
| 43 | +
- teal.widgets::resolve_ggplot2_args(+ #' data <- teal_data() |
|||
| 618 | -! | +|||
| 44 | +
- user_plot = ggplot2_args[["Response vs Regressor"]],+ #' data <- within(data, {
|
|||
| 619 | -! | +|||
| 45 | +
- user_default = ggplot2_args$default,+ #' mtcars <- mtcars |
|||
| 620 | -! | +|||
| 46 | +
- module_plot = teal.widgets::ggplot2_args(+ #' for (v in c("cyl", "vs", "am", "gear")) {
|
|||
| 621 | -! | +|||
| 47 | +
- labs = list(+ #' mtcars[[v]] <- as.factor(mtcars[[v]]) |
|||
| 622 | -! | +|||
| 48 | +
- title = "Response vs Regressor",+ #' } |
|||
| 623 | -! | +|||
| 49 | +
- x = varname_w_label(regression_var()$regressor, ANL),+ #' mtcars[["primary_key"]] <- seq_len(nrow(mtcars)) |
|||
| 624 | -! | +|||
| 50 | +
- y = varname_w_label(regression_var()$response, ANL)+ #' }) |
|||
| 625 | +51 |
- ),+ #' join_keys(data) <- join_keys(join_key("mtcars", "mtcars", "primary_key"))
|
||
| 626 | -! | +|||
| 52 | +
- theme = list()+ #' |
|||
| 627 | +53 |
- )+ #' app <- init( |
||
| 628 | +54 |
- ),+ #' data = data, |
||
| 629 | -! | +|||
| 55 | +
- ggtheme = input$ggtheme+ #' modules = modules( |
|||
| 630 | +56 |
- )+ #' tm_t_crosstable( |
||
| 631 | +57 |
-
+ #' label = "Cross Table", |
||
| 632 | -! | +|||
| 58 | +
- teal.code::eval_code(+ #' x = data_extract_spec( |
|||
| 633 | -! | +|||
| 59 | +
- fit_r(),+ #' dataname = "mtcars", |
|||
| 634 | -! | +|||
| 60 | +
- substitute(+ #' select = select_spec( |
|||
| 635 | -! | +|||
| 61 | +
- expr = {
+ #' label = "Select variable:", |
|||
| 636 | -! | +|||
| 62 | +
- class(fit$residuals) <- NULL+ #' choices = variable_choices(data[["mtcars"]], c("cyl", "vs", "am", "gear")),
|
|||
| 637 | -! | +|||
| 63 | +
- data <- fortify(fit)+ #' selected = c("cyl", "gear"),
|
|||
| 638 | -! | +|||
| 64 | +
- plot <- graph+ #' multiple = TRUE, |
|||
| 639 | +65 |
- },+ #' ordered = TRUE, |
||
| 640 | -! | +|||
| 66 | +
- env = list(+ #' fixed = FALSE |
|||
| 641 | -! | +|||
| 67 | +
- graph = Reduce(function(x, y) call("+", x, y), c(plot, parsed_ggplot2_args))
+ #' ) |
|||
| 642 | +68 |
- )+ #' ), |
||
| 643 | +69 |
- )+ #' y = data_extract_spec( |
||
| 644 | +70 |
- )+ #' dataname = "mtcars", |
||
| 645 | +71 |
- })+ #' select = select_spec( |
||
| 646 | +72 |
-
+ #' label = "Select variable:", |
||
| 647 | -! | +|||
| 73 | +
- output_plot_1 <- reactive({
+ #' choices = variable_choices(data[["mtcars"]], c("cyl", "vs", "am", "gear")),
|
|||
| 648 | -! | +|||
| 74 | +
- plot_base <- output_plot_base()+ #' selected = "vs", |
|||
| 649 | -! | +|||
| 75 | +
- shinyjs::show("size")
+ #' multiple = FALSE, |
|||
| 650 | -! | +|||
| 76 | +
- shinyjs::show("alpha")
+ #' fixed = FALSE |
|||
| 651 | -! | +|||
| 77 | +
- plot <- substitute(+ #' ) |
|||
| 652 | -! | +|||
| 78 | +
- expr = ggplot(data = data, aes(.fitted, .resid)) ++ #' ) |
|||
| 653 | -! | +|||
| 79 | +
- geom_point(size = size, alpha = alpha) ++ #' ) |
|||
| 654 | -! | +|||
| 80 | +
- geom_hline(yintercept = 0, linetype = "dashed", size = 1) ++ #' ) |
|||
| 655 | -! | +|||
| 81 | +
- geom_line(data = smoothy, mapping = smoothy_aes),+ #' ) |
|||
| 656 | -! | +|||
| 82 | +
- env = list(size = input$size, alpha = input$alpha)+ #' if (interactive()) {
|
|||
| 657 | +83 |
- )+ #' shinyApp(app$ui, app$server) |
||
| 658 | -! | +|||
| 84 | +
- if (input$show_outlier) {
+ #' } |
|||
| 659 | -! | +|||
| 85 | +
- plot <- substitute(expr = plot + outlier_label, env = list(plot = plot, outlier_label = outlier_label()))+ #' |
|||
| 660 | +86 |
- }+ #' @examplesShinylive |
||
| 661 | +87 |
-
+ #' library(teal.modules.general) |
||
| 662 | -! | +|||
| 88 | +
- parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(+ #' interactive <- function() TRUE |
|||
| 663 | -! | +|||
| 89 | +
- teal.widgets::resolve_ggplot2_args(+ #' {{ next_example }}
|
|||
| 664 | -! | +|||
| 90 | +
- user_plot = ggplot2_args[["Residuals vs Fitted"]],+ #' @examplesIf require("rtables", quietly = TRUE)
|
|||
| 665 | -! | +|||
| 91 | +
- user_default = ggplot2_args$default,+ #' # CDISC data example |
|||
| 666 | -! | +|||
| 92 | +
- module_plot = teal.widgets::ggplot2_args(+ #' data <- teal_data() |
|||
| 667 | -! | +|||
| 93 | +
- labs = list(+ #' data <- within(data, {
|
|||
| 668 | -! | +|||
| 94 | +
- x = quote(paste0("Fitted values\nlm(", reg_form, ")")),
+ #' ADSL <- teal.data::rADSL |
|||
| 669 | -! | +|||
| 95 | +
- y = "Residuals",+ #' }) |
|||
| 670 | -! | +|||
| 96 | +
- title = "Residuals vs Fitted"+ #' join_keys(data) <- default_cdisc_join_keys[names(data)] |
|||
| 671 | +97 |
- )+ #' |
||
| 672 | +98 |
- )+ #' app <- init( |
||
| 673 | +99 |
- ),+ #' data = data, |
||
| 674 | -! | +|||
| 100 | +
- ggtheme = input$ggtheme+ #' modules = modules( |
|||
| 675 | +101 |
- )+ #' tm_t_crosstable( |
||
| 676 | +102 |
-
+ #' label = "Cross Table", |
||
| 677 | -! | +|||
| 103 | +
- teal.code::eval_code(+ #' x = data_extract_spec( |
|||
| 678 | -! | +|||
| 104 | +
- plot_base,+ #' dataname = "ADSL", |
|||
| 679 | -! | +|||
| 105 | +
- substitute(+ #' select = select_spec( |
|||
| 680 | -! | +|||
| 106 | +
- expr = {
+ #' label = "Select variable:", |
|||
| 681 | -! | +|||
| 107 | +
- smoothy <- smooth(data$.fitted, data$.resid)+ #' choices = variable_choices(data[["ADSL"]], subset = function(data) {
|
|||
| 682 | -! | +|||
| 108 | +
- plot <- graph+ #' idx <- !vapply(data, inherits, logical(1), c("Date", "POSIXct", "POSIXlt"))
|
|||
| 683 | +109 |
- },+ #' return(names(data)[idx]) |
||
| 684 | -! | +|||
| 110 | +
- env = list(+ #' }), |
|||
| 685 | -! | +|||
| 111 | +
- graph = Reduce(function(x, y) call("+", x, y), c(plot, parsed_ggplot2_args))
+ #' selected = "COUNTRY", |
|||
| 686 | +112 |
- )+ #' multiple = TRUE, |
||
| 687 | +113 |
- )+ #' ordered = TRUE, |
||
| 688 | +114 |
- )+ #' fixed = FALSE |
||
| 689 | +115 |
- })+ #' ) |
||
| 690 | +116 |
-
+ #' ), |
||
| 691 | -! | +|||
| 117 | +
- output_plot_2 <- reactive({
+ #' y = data_extract_spec( |
|||
| 692 | -! | +|||
| 118 | +
- shinyjs::show("size")
+ #' dataname = "ADSL", |
|||
| 693 | -! | +|||
| 119 | +
- shinyjs::show("alpha")
+ #' select = select_spec( |
|||
| 694 | -! | +|||
| 120 | +
- plot_base <- output_plot_base()+ #' label = "Select variable:", |
|||
| 695 | -! | +|||
| 121 | +
- plot <- substitute(+ #' choices = variable_choices(data[["ADSL"]], subset = function(data) {
|
|||
| 696 | -! | +|||
| 122 | +
- expr = ggplot(data = data, aes(sample = .stdresid)) ++ #' idx <- vapply(data, is.factor, logical(1)) |
|||
| 697 | -! | +|||
| 123 | +
- stat_qq(size = size, alpha = alpha) ++ #' return(names(data)[idx]) |
|||
| 698 | -! | +|||
| 124 | +
- geom_abline(linetype = "dashed"),+ #' }), |
|||
| 699 | -! | +|||
| 125 | +
- env = list(size = input$size, alpha = input$alpha)+ #' selected = "SEX", |
|||
| 700 | +126 |
- )+ #' multiple = FALSE, |
||
| 701 | -! | +|||
| 127 | +
- if (input$show_outlier) {
+ #' fixed = FALSE |
|||
| 702 | -! | +|||
| 128 | +
- plot <- substitute(+ #' ) |
|||
| 703 | -! | +|||
| 129 | +
- expr = plot ++ #' ) |
|||
| 704 | -! | +|||
| 130 | +
- stat_qq(+ #' ) |
|||
| 705 | -! | +|||
| 131 | +
- geom = ggrepel::GeomTextRepel,+ #' ) |
|||
| 706 | -! | +|||
| 132 | +
- label = label_col %>%+ #' ) |
|||
| 707 | -! | +|||
| 133 | +
- data.frame(label = .) %>%+ #' if (interactive()) {
|
|||
| 708 | -! | +|||
| 134 | +
- dplyr::filter(label != "cooksd == NaN") %>%+ #' shinyApp(app$ui, app$server) |
|||
| 709 | -! | +|||
| 135 | +
- unlist(),+ #' } |
|||
| 710 | -! | +|||
| 136 | +
- color = "red",+ #' |
|||
| 711 | -! | +|||
| 137 | +
- hjust = 0,+ #' @export |
|||
| 712 | -! | +|||
| 138 | +
- vjust = 0,+ #' |
|||
| 713 | -! | +|||
| 139 | +
- max.overlaps = Inf,+ tm_t_crosstable <- function(label = "Cross Table", |
|||
| 714 | -! | +|||
| 140 | +
- min.segment.length = label_min_segment,+ x, |
|||
| 715 | -! | +|||
| 141 | +
- segment.alpha = .5,+ y, |
|||
| 716 | -! | +|||
| 142 | +
- seed = 123+ show_percentage = TRUE, |
|||
| 717 | +143 |
- ),+ show_total = TRUE, |
||
| 718 | -! | +|||
| 144 | +
- env = list(plot = plot, label_col = label_col(), label_min_segment = label_min_segment())+ pre_output = NULL, |
|||
| 719 | +145 |
- )+ post_output = NULL, |
||
| 720 | +146 |
- }+ basic_table_args = teal.widgets::basic_table_args(), |
||
| 721 | +147 |
-
+ decorators = NULL) {
|
||
| 722 | +148 | ! |
- parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(+ message("Initializing tm_t_crosstable")
|
|
| 723 | -! | +|||
| 149 | +
- teal.widgets::resolve_ggplot2_args(+ |
|||
| 724 | -! | +|||
| 150 | +
- user_plot = ggplot2_args[["Normal Q-Q"]],+ # Requires Suggested packages |
|||
| 725 | +151 | ! |
- user_default = ggplot2_args$default,+ if (!requireNamespace("rtables", quietly = TRUE)) {
|
|
| 726 | +152 | ! |
- module_plot = teal.widgets::ggplot2_args(+ stop("Cannot load rtables - please install the package or restart your session.")
|
|
| 727 | -! | +|||
| 153 | +
- labs = list(+ } |
|||
| 728 | -! | +|||
| 154 | +
- x = quote(paste0("Theoretical Quantiles\nlm(", reg_form, ")")),
+
|
|||
| 729 | -! | +|||
| 155 | +
- y = "Standardized residuals",+ # Normalize the parameters |
|||
| 730 | +156 | ! |
- title = "Normal Q-Q"+ if (inherits(x, "data_extract_spec")) x <- list(x) |
|
| 731 | -+ | |||
| 157 | +! |
- )+ if (inherits(y, "data_extract_spec")) y <- list(y) |
||
| 732 | +158 |
- )+ |
||
| 733 | +159 |
- ),+ # Start of assertions |
||
| 734 | +160 | ! |
- ggtheme = input$ggtheme+ checkmate::assert_string(label) |
|
| 735 | -+ | |||
| 161 | +! |
- )+ checkmate::assert_list(x, types = "data_extract_spec") |
||
| 736 | +162 | |||
| 737 | +163 | ! |
- teal.code::eval_code(+ checkmate::assert_list(y, types = "data_extract_spec") |
|
| 738 | +164 | ! |
- plot_base,+ assert_single_selection(y) |
|
| 739 | -! | +|||
| 165 | +
- substitute(+ |
|||
| 740 | +166 | ! |
- expr = {
+ checkmate::assert_flag(show_percentage) |
|
| 741 | +167 | ! |
- plot <- graph+ checkmate::assert_flag(show_total) |
|
| 742 | -+ | |||
| 168 | +! |
- },+ checkmate::assert_multi_class(pre_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
|
||
| 743 | +169 | ! |
- env = list(+ checkmate::assert_multi_class(post_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
|
|
| 744 | +170 | ! |
- graph = Reduce(function(x, y) call("+", x, y), c(plot, parsed_ggplot2_args))
+ checkmate::assert_class(basic_table_args, classes = "basic_table_args") |
|
| 745 | +171 |
- )+ |
||
| 746 | -+ | |||
| 172 | +! |
- )+ decorators <- normalize_decorators(decorators) |
||
| 747 | -+ | |||
| 173 | +! |
- )+ assert_decorators(decorators, null.ok = TRUE, "plot") |
||
| 748 | +174 |
- })+ # End of assertions |
||
| 749 | -- | - - | -||
| 750 | -! | -
- output_plot_3 <- reactive({
- |
- ||
| 751 | -! | +175 | +
- shinyjs::show("size")
+
|
|
| 752 | -! | +|||
| 176 | +
- shinyjs::show("alpha")
+ # Make UI args |
|||
| 753 | +177 | ! |
- plot_base <- output_plot_base()+ ui_args <- as.list(environment()) |
|
| 754 | -! | +|||
| 178 | +
- plot <- substitute(+ |
|||
| 755 | +179 | ! |
- expr = ggplot(data = data, aes(.fitted, sqrt(abs(.stdresid)))) ++ server_args <- list( |
|
| 756 | +180 | ! |
- geom_point(size = size, alpha = alpha) ++ label = label, |
|
| 757 | +181 | ! |
- geom_line(data = smoothy, mapping = smoothy_aes),+ x = x, |
|
| 758 | +182 | ! |
- env = list(size = input$size, alpha = input$alpha)- |
- |
| 759 | -- |
- )+ y = y, |
||
| 760 | +183 | ! |
- if (input$show_outlier) {
+ basic_table_args = basic_table_args, |
|
| 761 | +184 | ! |
- plot <- substitute(expr = plot + outlier_label, env = list(plot = plot, outlier_label = outlier_label()))+ decorators = decorators |
|
| 762 | +185 |
- }+ ) |
||
| 763 | +186 | |||
| 764 | +187 | ! |
- parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(+ ans <- module( |
|
| 765 | +188 | ! |
- teal.widgets::resolve_ggplot2_args(+ label = label, |
|
| 766 | +189 | ! |
- user_plot = ggplot2_args[["Scale-Location"]],+ server = srv_t_crosstable, |
|
| 767 | +190 | ! |
- user_default = ggplot2_args$default,+ ui = ui_t_crosstable, |
|
| 768 | +191 | ! |
- module_plot = teal.widgets::ggplot2_args(+ ui_args = ui_args, |
|
| 769 | +192 | ! |
- labs = list(+ server_args = server_args, |
|
| 770 | +193 | ! |
- x = quote(paste0("Fitted values\nlm(", reg_form, ")")),
+ datanames = teal.transform::get_extract_datanames(list(x = x, y = y)) |
|
| 771 | -! | +|||
| 194 | +
- y = quote(expression(sqrt(abs(`Standardized residuals`)))),+ ) |
|||
| 772 | +195 | ! |
- title = "Scale-Location"+ attr(ans, "teal_bookmarkable") <- TRUE |
|
| 773 | -+ | |||
| 196 | +! |
- )+ ans |
||
| 774 | +197 |
- )+ } |
||
| 775 | +198 |
- ),- |
- ||
| 776 | -! | -
- ggtheme = input$ggtheme+ |
||
| 777 | +199 |
- )+ # UI function for the cross-table module |
||
| 778 | +200 |
-
+ ui_t_crosstable <- function(id, x, y, show_percentage, show_total, pre_output, post_output, ...) {
|
||
| 779 | +201 | ! |
- teal.code::eval_code(+ args <- list(...) |
|
| 780 | +202 | ! |
- plot_base,+ ns <- NS(id) |
|
| 781 | +203 | ! |
- substitute(+ is_single_dataset <- teal.transform::is_single_dataset(x, y) |
|
| 782 | -! | +|||
| 204 | +
- expr = {
+
|
|||
| 783 | +205 | ! |
- smoothy <- smooth(data$.fitted, sqrt(abs(data$.stdresid)))+ join_default_options <- c( |
|
| 784 | +206 | ! |
- plot <- graph- |
- |
| 785 | -- |
- },+ "Full Join" = "dplyr::full_join", |
||
| 786 | +207 | ! |
- env = list(+ "Inner Join" = "dplyr::inner_join", |
|
| 787 | +208 | ! |
- graph = Reduce(function(x, y) call("+", x, y), c(plot, parsed_ggplot2_args))
- |
- |
| 788 | -- |
- )- |
- ||
| 789 | -- |
- )+ "Left Join" = "dplyr::left_join", |
||
| 790 | -+ | |||
| 209 | +! |
- )+ "Right Join" = "dplyr::right_join" |
||
| 791 | +210 |
- })+ ) |
||
| 792 | +211 | |||
| 793 | +212 | ! |
- output_plot_4 <- reactive({
+ teal.widgets::standard_layout( |
|
| 794 | +213 | ! |
- shinyjs::hide("size")
+ output = teal.widgets::white_small_well( |
|
| 795 | +214 | ! |
- shinyjs::show("alpha")
+ textOutput(ns("title")),
|
|
| 796 | +215 | ! |
- plot_base <- output_plot_base()+ teal.widgets::table_with_settings_ui(ns("table"))
|
|
| 797 | -! | +|||
| 216 | +
- plot <- substitute(+ ), |
|||
| 798 | +217 | ! |
- expr = ggplot(data = data, aes(seq_along(.cooksd), .cooksd)) ++ encoding = tags$div( |
|
| 799 | -! | +|||
| 218 | +
- geom_col(alpha = alpha),+ ### Reporter |
|||
| 800 | +219 | ! |
- env = list(alpha = input$alpha)+ teal.reporter::simple_reporter_ui(ns("simple_reporter")),
|
|
| 801 | +220 |
- )+ ### |
||
| 802 | +221 | ! |
- if (input$show_outlier) {
+ tags$label("Encodings", class = "text-primary"),
|
|
| 803 | +222 | ! |
- plot <- substitute(+ teal.transform::datanames_input(list(x, y)), |
|
| 804 | +223 | ! |
- expr = plot ++ teal.transform::data_extract_ui(ns("x"), label = "Row values", x, is_single_dataset = is_single_dataset),
|
|
| 805 | +224 | ! |
- geom_hline(+ teal.transform::data_extract_ui(ns("y"), label = "Column values", y, is_single_dataset = is_single_dataset),
|
|
| 806 | +225 | ! |
- yintercept = c(+ teal.widgets::optionalSelectInput( |
|
| 807 | +226 | ! |
- outlier * mean(data$.cooksd, na.rm = TRUE),+ ns("join_fun"),
|
|
| 808 | +227 | ! |
- mean(data$.cooksd, na.rm = TRUE)+ label = "Row to Column type of join", |
|
| 809 | -+ | |||
| 228 | +! |
- ),+ choices = join_default_options, |
||
| 810 | +229 | ! |
- color = "red",+ selected = join_default_options[1], |
|
| 811 | +230 | ! |
- linetype = "dashed"+ multiple = FALSE |
|
| 812 | +231 |
- ) ++ ), |
||
| 813 | +232 | ! |
- geom_text(+ tags$hr(), |
|
| 814 | +233 | ! |
- aes(+ teal.widgets::panel_group( |
|
| 815 | +234 | ! |
- x = 0,+ teal.widgets::panel_item( |
|
| 816 | +235 | ! |
- y = mean(data$.cooksd, na.rm = TRUE),+ title = "Table settings", |
|
| 817 | +236 | ! |
- label = paste("mu", "=", round(mean(data$.cooksd, na.rm = TRUE), 4)),
+ checkboxInput(ns("show_percentage"), "Show column percentage", value = show_percentage),
|
|
| 818 | +237 | ! |
- vjust = -1,+ checkboxInput(ns("show_total"), "Show total column", value = show_total)
|
|
| 819 | -! | +|||
| 238 | +
- hjust = 0,+ ) |
|||
| 820 | -! | +|||
| 239 | +
- color = "red",+ ), |
|||
| 821 | +240 | ! |
- angle = 90+ ui_decorate_teal_data(ns("decorator"), decorators = select_decorators(args$decorators, "plot"))
|
|
| 822 | +241 |
- ),+ ), |
||
| 823 | +242 | ! |
- parse = TRUE,+ forms = tagList( |
|
| 824 | +243 | ! |
- show.legend = FALSE+ teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code")
|
|
| 825 | +244 |
- ) ++ ), |
||
| 826 | +245 | ! |
- outlier_label,+ pre_output = pre_output, |
|
| 827 | +246 | ! |
- env = list(plot = plot, outlier = input$outlier, outlier_label = outlier_label())+ post_output = post_output |
|
| 828 | +247 |
- )+ ) |
||
| 829 | +248 |
- }+ } |
||
| 830 | +249 | |||
| 831 | -! | +|||
| 250 | +
- parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(+ # Server function for the cross-table module+ |
+ |||
| 251 | ++ |
+ srv_t_crosstable <- function(id, data, reporter, filter_panel_api, label, x, y, basic_table_args, decorators) {
|
||
| 832 | +252 | ! |
- teal.widgets::resolve_ggplot2_args(+ with_reporter <- !missing(reporter) && inherits(reporter, "Reporter") |
|
| 833 | +253 | ! |
- user_plot = ggplot2_args[["Cook's distance"]],+ with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI") |
|
| 834 | +254 | ! |
- user_default = ggplot2_args$default,+ checkmate::assert_class(data, "reactive") |
|
| 835 | +255 | ! |
- module_plot = teal.widgets::ggplot2_args(+ checkmate::assert_class(isolate(data()), "teal_data") |
|
| 836 | +256 | ! |
- labs = list(+ moduleServer(id, function(input, output, session) {
|
|
| 837 | +257 | ! |
- x = quote(paste0("Obs. number\nlm(", reg_form, ")")),
+ teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.general")+ |
+ |
| 258 | ++ | + | ||
| 838 | +259 | ! |
- y = "Cook's distance",+ selector_list <- teal.transform::data_extract_multiple_srv( |
|
| 839 | +260 | ! |
- title = "Cook's distance"+ data_extract = list(x = x, y = y), |
|
| 840 | -+ | |||
| 261 | +! |
- )+ datasets = data, |
||
| 841 | -+ | |||
| 262 | +! |
- )+ select_validation_rule = list( |
||
| 842 | -+ | |||
| 263 | +! |
- ),+ x = shinyvalidate::sv_required("Please define column for row variable."),
|
||
| 843 | +264 | ! |
- ggtheme = input$ggtheme+ y = shinyvalidate::sv_required("Please define column for column variable.")
|
|
| 844 | +265 |
) |
||
| 845 | +266 | - - | -||
| 846 | -! | -
- teal.code::eval_code(+ ) |
||
| 847 | -! | +|||
| 267 | +
- plot_base,+ |
|||
| 848 | +268 | ! |
- substitute(+ iv_r <- reactive({
|
|
| 849 | +269 | ! |
- expr = {
+ iv <- shinyvalidate::InputValidator$new() |
|
| 850 | +270 | ! |
- plot <- graph- |
- |
| 851 | -- |
- },+ iv$add_rule("join_fun", function(value) {
|
||
| 852 | +271 | ! |
- env = list(+ if (!identical(selector_list()$x()$dataname, selector_list()$y()$dataname)) {
|
|
| 853 | +272 | ! |
- graph = Reduce(function(x, y) call("+", x, y), c(plot, parsed_ggplot2_args))
- |
- |
| 854 | -- |
- )+ if (!shinyvalidate::input_provided(value)) {
|
||
| 855 | -+ | |||
| 273 | +! |
- )+ "Please select a joining function." |
||
| 856 | +274 |
- )+ } |
||
| 857 | +275 |
- })+ } |
||
| 858 | +276 |
-
+ }) |
||
| 859 | +277 | ! |
- output_plot_5 <- reactive({
+ teal.transform::compose_and_enable_validators(iv, selector_list) |
|
| 860 | -! | +|||
| 278 | +
- shinyjs::show("size")
+ }) |
|||
| 861 | -! | +|||
| 279 | +
- shinyjs::show("alpha")
+
|
|||
| 862 | +280 | ! |
- plot_base <- output_plot_base()+ observeEvent( |
|
| 863 | +281 | ! |
- plot <- substitute(+ eventExpr = {
|
|
| 864 | +282 | ! |
- expr = ggplot(data = data, aes(.hat, .stdresid)) ++ req(!is.null(selector_list()$x()) && !is.null(selector_list()$y())) |
|
| 865 | +283 | ! |
- geom_vline(+ list(selector_list()$x(), selector_list()$y()) |
|
| 866 | -! | +|||
| 284 | +
- size = 1,+ }, |
|||
| 867 | +285 | ! |
- colour = "black",+ handlerExpr = {
|
|
| 868 | +286 | ! |
- linetype = "dashed",+ if (identical(selector_list()$x()$dataname, selector_list()$y()$dataname)) {
|
|
| 869 | +287 | ! |
- xintercept = 0+ shinyjs::hide("join_fun")
|
|
| 870 | +288 |
- ) +- |
- ||
| 871 | -! | -
- geom_hline(+ } else {
|
||
| 872 | +289 | ! |
- size = 1,+ shinyjs::show("join_fun")
|
|
| 873 | -! | +|||
| 290 | +
- colour = "black",+ } |
|||
| 874 | -! | +|||
| 291 | +
- linetype = "dashed",+ } |
|||
| 875 | -! | +|||
| 292 | +
- yintercept = 0+ ) |
|||
| 876 | +293 |
- ) ++ |
||
| 877 | +294 | ! |
- geom_point(size = size, alpha = alpha) ++ merge_function <- reactive({
|
|
| 878 | +295 | ! |
- geom_line(data = smoothy, mapping = smoothy_aes),+ if (is.null(input$join_fun)) {
|
|
| 879 | +296 | ! |
- env = list(size = input$size, alpha = input$alpha)+ "dplyr::full_join" |
|
| 880 | +297 |
- )+ } else {
|
||
| 881 | +298 | ! |
- if (input$show_outlier) {
+ input$join_fun |
|
| 882 | -! | +|||
| 299 | +
- plot <- substitute(expr = plot + outlier_label, env = list(plot = plot, outlier_label = outlier_label()))+ } |
|||
| 883 | +300 |
- }+ }) |
||
| 884 | +301 | |||
| 885 | +302 | ! |
- parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(+ anl_merged_input <- teal.transform::merge_expression_srv( |
|
| 886 | +303 | ! |
- teal.widgets::resolve_ggplot2_args(+ datasets = data, |
|
| 887 | +304 | ! |
- user_plot = ggplot2_args[["Residuals vs Leverage"]],+ selector_list = selector_list, |
|
| 888 | +305 | ! |
- user_default = ggplot2_args$default,+ merge_function = merge_function |
|
| 889 | -! | +|||
| 306 | +
- module_plot = teal.widgets::ggplot2_args(+ )+ |
+ |||
| 307 | ++ | + | ||
| 890 | +308 | ! |
- labs = list(+ anl_merged_q <- reactive({
|
|
| 891 | +309 | ! |
- x = quote(paste0("Standardized residuals\nlm(", reg_form, ")")),
+ req(anl_merged_input()) |
|
| 892 | +310 | ! |
- y = "Leverage",+ data() %>% |
|
| 893 | +311 | ! |
- title = "Residuals vs Leverage"+ teal.code::eval_code(as.expression(anl_merged_input()$expr)) |
|
| 894 | +312 |
- )+ }) |
||
| 895 | +313 |
- )+ |
||
| 896 | -+ | |||
| 314 | +! |
- ),+ merged <- list( |
||
| 897 | +315 | ! |
- ggtheme = input$ggtheme+ anl_input_r = anl_merged_input, |
|
| 898 | -+ | |||
| 316 | +! |
- )+ anl_q_r = anl_merged_q |
||
| 899 | +317 | - - | -||
| 900 | -! | -
- teal.code::eval_code(+ ) |
||
| 901 | -! | +|||
| 318 | +
- plot_base,+ |
|||
| 902 | +319 | ! |
- substitute(+ output_q <- reactive({
|
|
| 903 | +320 | ! |
- expr = {
+ teal::validate_inputs(iv_r()) |
|
| 904 | +321 | ! |
- smoothy <- smooth(data$.hat, data$.stdresid)+ ANL <- merged$anl_q_r()[["ANL"]] |
|
| 905 | -! | +|||
| 322 | +
- plot <- graph+ |
|||
| 906 | +323 |
- },+ # As this is a summary |
||
| 907 | +324 | ! |
- env = list(+ x_name <- as.vector(merged$anl_input_r()$columns_source$x) |
|
| 908 | +325 | ! |
- graph = Reduce(function(x, y) call("+", x, y), c(plot, parsed_ggplot2_args))
- |
- |
| 909 | -- |
- )+ y_name <- as.vector(merged$anl_input_r()$columns_source$y) |
||
| 910 | +326 |
- )+ |
||
| 911 | -+ | |||
| 327 | +! |
- )+ teal::validate_has_data(ANL, 3) |
||
| 912 | -+ | |||
| 328 | +! |
- })+ teal::validate_has_data(ANL[, c(x_name, y_name)], 3, complete = TRUE, allow_inf = FALSE) |
||
| 913 | +329 | |||
| 914 | +330 | ! |
- output_plot_6 <- reactive({
+ is_allowed_class <- function(x) is.numeric(x) || is.factor(x) || is.character(x) || is.logical(x) |
|
| 915 | +331 | ! |
- shinyjs::show("size")
+ validate(need( |
|
| 916 | +332 | ! |
- shinyjs::show("alpha")
+ all(vapply(ANL[x_name], is_allowed_class, logical(1))), |
|
| 917 | +333 | ! |
- plot_base <- output_plot_base()+ "Selected row variable has an unsupported data type." |
|
| 918 | -! | +|||
| 334 | +
- plot <- substitute(+ )) |
|||
| 919 | +335 | ! |
- expr = ggplot(data = data, aes(.hat, .cooksd)) ++ validate(need( |
|
| 920 | +336 | ! |
- geom_vline(xintercept = 0, colour = NA) ++ is_allowed_class(ANL[[y_name]]), |
|
| 921 | +337 | ! |
- geom_abline(+ "Selected column variable has an unsupported data type." |
|
| 922 | -! | +|||
| 338 | +
- slope = seq(0, 3, by = 0.5),+ )) |
|||
| 923 | -! | +|||
| 339 | +
- colour = "black",+ |
|||
| 924 | +340 | ! |
- linetype = "dashed",+ show_percentage <- input$show_percentage |
|
| 925 | +341 | ! |
- size = 1+ show_total <- input$show_total |
|
| 926 | +342 |
- ) ++ |
||
| 927 | +343 | ! |
- geom_line(data = smoothy, mapping = smoothy_aes) ++ plot_title <- paste( |
|
| 928 | +344 | ! |
- geom_point(size = size, alpha = alpha),+ "Cross-Table of", |
|
| 929 | +345 | ! |
- env = list(size = input$size, alpha = input$alpha)+ paste0(varname_w_label(x_name, ANL), collapse = ", "), |
|
| 930 | -+ | |||
| 346 | +! |
- )+ "(rows)", "vs.", |
||
| 931 | +347 | ! |
- if (input$show_outlier) {
+ varname_w_label(y_name, ANL), |
|
| 932 | +348 | ! |
- plot <- substitute(expr = plot + outlier_label, env = list(plot = plot, outlier_label = outlier_label()))+ "(columns)" |
|
| 933 | +349 |
- }+ ) |
||
| 934 | +350 | |||
| 935 | +351 | ! |
- parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(+ labels_vec <- vapply( |
|
| 936 | +352 | ! |
- teal.widgets::resolve_ggplot2_args(+ x_name, |
|
| 937 | +353 | ! |
- user_plot = ggplot2_args[["Cook's dist vs Leverage"]],+ varname_w_label, |
|
| 938 | +354 | ! |
- user_default = ggplot2_args$default,+ character(1), |
|
| 939 | +355 | ! |
- module_plot = teal.widgets::ggplot2_args(+ ANL |
|
| 940 | -! | +|||
| 356 | +
- labs = list(+ )+ |
+ |||
| 357 | ++ | + | ||
| 941 | +358 | ! |
- x = quote(paste0("Leverage\nlm(", reg_form, ")")),
+ teal.code::eval_code( |
|
| 942 | +359 | ! |
- y = "Cooks's distance",+ merged$anl_q_r(), |
|
| 943 | +360 | ! |
- title = "Cook's dist vs Leverage"+ substitute( |
|
| 944 | -+ | |||
| 361 | +! |
- )+ expr = {
|
||
| 945 | -+ | |||
| 362 | +! |
- )+ title <- plot_title |
||
| 946 | +363 |
- ),+ }, |
||
| 947 | +364 | ! |
- ggtheme = input$ggtheme+ env = list(plot_title = plot_title) |
|
| 948 | +365 |
- )+ ) |
||
| 949 | +366 |
-
+ ) %>% |
||
| 950 | +367 | ! |
- teal.code::eval_code(+ teal.code::eval_code( |
|
| 951 | +368 | ! |
- plot_base,+ substitute( |
|
| 952 | +369 | ! |
- substitute(+ expr = {
|
|
| 953 | +370 | ! |
- expr = {
+ table <- basic_tables %>% |
|
| 954 | +371 | ! |
- smoothy <- smooth(data$.hat, data$.cooksd)+ split_call %>% # styler: off |
|
| 955 | +372 | ! |
- plot <- graph+ rtables::add_colcounts() %>% |
|
| 956 | -+ | |||
| 373 | +! |
- },+ tern::analyze_vars( |
||
| 957 | +374 | ! |
- env = list(+ vars = x_name, |
|
| 958 | +375 | ! |
- graph = Reduce(function(x, y) call("+", x, y), c(plot, parsed_ggplot2_args))
+ var_labels = labels_vec, |
|
| 959 | -+ | |||
| 376 | +! |
- )+ na.rm = FALSE, |
||
| 960 | -+ | |||
| 377 | +! |
- )+ denom = "N_col", |
||
| 961 | -+ | |||
| 378 | +! |
- )+ .stats = c("mean_sd", "median", "range", count_value)
|
||
| 962 | +379 |
- })+ ) |
||
| 963 | +380 |
-
+ }, |
||
| 964 | +381 | ! |
- output_q <- reactive({
+ env = list( |
|
| 965 | +382 | ! |
- teal::validate_inputs(iv_r())+ basic_tables = teal.widgets::parse_basic_table_args( |
|
| 966 | +383 | ! |
- switch(input$plot_type,+ basic_table_args = teal.widgets::resolve_basic_table_args(basic_table_args) |
|
| 967 | -! | +|||
| 384 | +
- "Response vs Regressor" = output_plot_0(),+ ), |
|||
| 968 | +385 | ! |
- "Residuals vs Fitted" = output_plot_1(),+ split_call = if (show_total) {
|
|
| 969 | +386 | ! |
- "Normal Q-Q" = output_plot_2(),+ substitute( |
|
| 970 | +387 | ! |
- "Scale-Location" = output_plot_3(),+ expr = rtables::split_cols_by( |
|
| 971 | +388 | ! |
- "Cook's distance" = output_plot_4(),+ y_name, |
|
| 972 | +389 | ! |
- "Residuals vs Leverage" = output_plot_5(),+ split_fun = rtables::add_overall_level(label = "Total", first = FALSE) |
|
| 973 | -! | +|||
| 390 | +
- "Cook's dist vs Leverage" = output_plot_6()+ ), |
|||
| 974 | -+ | |||
| 391 | +! |
- )+ env = list(y_name = y_name) |
||
| 975 | +392 |
- })+ ) |
||
| 976 | +393 |
-
+ } else {
|
||
| 977 | +394 | ! |
- decorated_output_q <- srv_decorate_teal_data(+ substitute(rtables::split_cols_by(y_name), env = list(y_name = y_name)) |
|
| 978 | -! | +|||
| 395 | +
- "decorator",+ }, |
|||
| 979 | +396 | ! |
- data = output_q,+ x_name = x_name, |
|
| 980 | +397 | ! |
- decorators = select_decorators(decorators, "plot"),+ labels_vec = labels_vec, |
|
| 981 | +398 | ! |
- expr = print(plot)+ count_value = ifelse(show_percentage, "count_fraction", "count") |
|
| 982 | +399 |
- )+ ) |
||
| 983 | +400 |
-
+ ) |
||
| 984 | -! | +|||
| 401 | +
- fitted <- reactive({
+ ) %>% |
|||
| 985 | +402 | ! |
- req(output_q())+ teal.code::eval_code( |
|
| 986 | +403 | ! |
- decorated_output_q()[["fit"]]+ substitute( |
|
| 987 | -+ | |||
| 404 | +! |
- })+ expr = {
|
||
| 988 | +405 | ! |
- plot_r <- reactive({
+ ANL <- tern::df_explicit_na(ANL) |
|
| 989 | +406 | ! |
- req(output_q())+ table <- rtables::build_table(lyt = table, df = ANL[order(ANL[[y_name]]), ])+ |
+ |
| 407 | ++ |
+ }, |
||
| 990 | +408 | ! |
- decorated_output_q()[["plot"]]+ env = list(y_name = y_name) |
|
| 991 | +409 |
- })+ ) |
||
| 992 | +410 |
-
+ ) |
||
| 993 | +411 |
- # Insert the plot into a plot_with_settings module from teal.widgets+ })+ |
+ ||
| 412 | ++ | + | ||
| 994 | +413 | ! |
- pws <- teal.widgets::plot_with_settings_srv(+ decorated_output_q <- srv_decorate_teal_data( |
|
| 995 | +414 | ! |
- id = "myplot",+ id = "decorator", |
|
| 996 | +415 | ! |
- plot_r = plot_r,+ data = output_q, |
|
| 997 | +416 | ! |
- height = plot_height,+ decorators = select_decorators(decorators, "plot"), |
|
| 998 | +417 | ! |
- width = plot_width+ expr = table |
|
| 999 | +418 |
) |
||
| 1000 | +419 | |||
| 1001 | +420 | ! |
- output$text <- renderText({
+ output$title <- renderText(req(decorated_output_q())[["title"]])+ |
+ |
| 421 | ++ | + | ||
| 1002 | +422 | +! | +
+ table_r <- reactive({
+ |
+ |
| 423 | ! |
req(iv_r()$is_valid()) |
||
| 1003 | +424 | ! |
- req(iv_out$is_valid())+ req(decorated_output_q())[["table"]]+ |
+ |
| 425 | ++ |
+ })+ |
+ ||
| 426 | ++ | + | ||
| 1004 | +427 | ! |
- paste(utils::capture.output(summary(teal.code::dev_suppress(fitted())))[-1],+ teal.widgets::table_with_settings_srv( |
|
| 1005 | +428 | ! |
- collapse = "\n"+ id = "table", |
|
| 1006 | -+ | |||
| 429 | +! |
- )+ table_r = table_r |
||
| 1007 | +430 |
- })+ ) |
||
| 1008 | +431 | |||
| 1009 | +432 | ! |
teal.widgets::verbatim_popup_srv( |
|
| 1010 | +433 | ! |
id = "rcode", |
|
| 1011 | +434 | ! |
verbatim_content = reactive(teal.code::get_code(req(decorated_output_q()))), |
|
| 1012 | +435 | ! |
- title = "R code for the regression plot",+ title = "Show R Code for Cross-Table" |
|
| 1013 | +436 |
) |
||
| 1014 | +437 | |||
| 1015 | +438 |
### REPORTER |
||
| 1016 | +439 | ! |
if (with_reporter) {
|
|
| 1017 | +440 | ! |
card_fun <- function(comment, label) {
|
|
| 1018 | +441 | ! |
card <- teal::report_card_template( |
|
| 1019 | +442 | ! |
- title = "Linear Regression Plot",+ title = "Cross Table", |
|
| 1020 | +443 | ! |
label = label, |
|
| 1021 | +444 | ! |
with_filter = with_filter, |
|
| 1022 | +445 | ! |
filter_panel_api = filter_panel_api |
|
| 1023 | +446 |
) |
||
| 1024 | +447 | ! |
- card$append_text("Plot", "header3")
+ card$append_text("Table", "header3")
|
|
| 1025 | +448 | ! |
- card$append_plot(plot_r(), dim = pws$dim())+ card$append_table(table_r()) |
|
| 1026 | +449 | ! |
if (!comment == "") {
|
|
| 1027 | +450 | ! |
card$append_text("Comment", "header3")
|
|
| 1028 | +451 | ! |
card$append_text(comment) |
|
| 1029 | +452 |
} |
||
| 1030 | +453 | ! |
card$append_src(teal.code::get_code(req(decorated_output_q()))) |
|
| 1031 | +454 | ! |
card |
|
| 1032 | +455 |
} |
||
| 1033 | +456 | ! |
teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
|
|
| 1034 | +457 |
} |
||
| 1035 | +458 |
### |
||
| 1036 | +459 |
}) |
||
| 1037 | +460 |
}@@ -79913,14 +79697,14 @@ teal.modules.general coverage - 3.63% |
| 1 |
- #' `teal` module: Scatterplot+ #' `teal` module: Response plot |
||
| 3 |
- #' Generates a customizable scatterplot using `ggplot2`.+ #' Generates a response plot for a given `response` and `x` variables. |
||
| 4 |
- #' This module allows users to select variables for the x and y axes,+ #' This module allows users customize and add annotations to the plot depending |
||
| 5 |
- #' color and size encodings, faceting options, and more. It supports log transformations,+ #' on the module's arguments. |
||
| 6 |
- #' trend line additions, and dynamic adjustments of point opacity and size through UI controls.+ #' It supports showing the counts grouped by other variable facets (by row / column), |
||
| 7 |
- #'+ #' swapping the coordinates, show count annotations and displaying the response plot |
||
| 8 |
- #' @note For more examples, please see the vignette "Using scatterplot" via+ #' as frequency or density. |
||
| 9 |
- #' `vignette("using-scatterplot", package = "teal.modules.general")`.
+ #' |
||
| 10 |
- #'+ #' @inheritParams teal::module |
||
| 11 |
- #' @inheritParams teal::module+ #' @inheritParams shared_params |
||
| 12 |
- #' @inheritParams shared_params+ #' @param response (`data_extract_spec` or `list` of multiple `data_extract_spec`) |
||
| 13 |
- #' @param x (`data_extract_spec` or `list` of multiple `data_extract_spec`) Specifies+ #' Which variable to use as the response. |
||
| 14 |
- #' variable names selected to plot along the x-axis by default.+ #' You can define one fixed column by setting `fixed = TRUE` inside the `select_spec`. |
||
| 15 |
- #' @param y (`data_extract_spec` or `list` of multiple `data_extract_spec`) Specifies+ #' |
||
| 16 |
- #' variable names selected to plot along the y-axis by default.+ #' The `data_extract_spec` must not allow multiple selection in this case. |
||
| 17 |
- #' @param color_by (`data_extract_spec` or `list` of multiple `data_extract_spec`) optional,+ #' @param x (`data_extract_spec` or `list` of multiple `data_extract_spec`) |
||
| 18 |
- #' defines the color encoding. If `NULL` then no color encoding option will be displayed.+ #' Specifies which variable to use on the X-axis of the response plot. |
||
| 19 |
- #' @param size_by (`data_extract_spec` or `list` of multiple `data_extract_spec`) optional,+ #' Allow the user to select multiple columns from the `data` allowed in teal. |
||
| 20 |
- #' defines the point size encoding. If `NULL` then no size encoding option will be displayed.+ #' |
||
| 21 |
- #' @param row_facet (`data_extract_spec` or `list` of multiple `data_extract_spec`) optional,+ #' The `data_extract_spec` must not allow multiple selection in this case. |
||
| 22 |
- #' specifies the variable(s) for faceting rows.+ #' @param row_facet (`data_extract_spec` or `list` of multiple `data_extract_spec`) |
||
| 23 |
- #' @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 rows. |
||
| 24 |
- #' specifies the variable(s) for faceting columns.+ #' @param col_facet (`data_extract_spec` or `list` of multiple `data_extract_spec`) |
||
| 25 |
- #' @param shape (`character`) optional, character vector with the names of the+ #' optional specification of the data variable(s) to use for faceting columns. |
||
| 26 |
- #' shape, e.g. `c("triangle", "square", "circle")`. It defaults to `shape_names`. This is a complete list from
+ #' @param coord_flip (`logical(1)`) |
||
| 27 |
- #' `vignette("ggplot2-specs", package="ggplot2")`.
+ #' Indicates whether to flip coordinates between `x` and `response`. |
||
| 28 |
- #' @param max_deg (`integer`) optional, maximum degree for the polynomial trend line. Must not be less than 1.+ #' The default value is `FALSE` and it will show the `x` variable on the x-axis |
||
| 29 |
- #' @param table_dec (`integer`) optional, number of decimal places used to round numeric values in the table.+ #' and the `response` variable on the y-axis. |
||
| 30 |
- #' @param decorators `r roxygen_decorators_param("tm_g_scatterplot")`
+ #' @param count_labels (`logical(1)`) |
||
| 31 |
- #'+ #' Indicates whether to show count labels. |
||
| 32 |
- #' @inherit shared_params return+ #' Defaults to `TRUE`. |
||
| 33 |
- #'+ #' @param freq (`logical(1)`) |
||
| 34 |
- #' @section Decorating `tm_g_scatterplot`:+ #' Indicates whether to display frequency (`TRUE`) or density (`FALSE`). |
||
| 35 |
- #'+ #' Defaults to density (`FALSE`). |
||
| 36 |
- #' This module generates the following objects, which can be modified in place using decorators:+ #' @param decorators `r roxygen_decorators_param("tm_g_response")`
|
||
| 37 |
- #' - `plot` (`ggplot2`)+ #' |
||
| 38 |
- #'+ #' @inherit shared_params return |
||
| 39 |
- #' For additional details and examples of decorators, refer to the vignette+ #' |
||
| 40 |
- #' `vignette("decorate-modules-output", package = "teal")` or the [`teal::teal_transform_module()`] documentation.
+ #' @note For more examples, please see the vignette "Using response plot" via |
||
| 41 |
- #'+ #' `vignette("using-response-plot", package = "teal.modules.general")`.
|
||
| 43 |
- #' @examplesShinylive+ #' @section Decorating `tm_g_response`: |
||
| 44 |
- #' library(teal.modules.general)+ #' |
||
| 45 |
- #' interactive <- function() TRUE+ #' This module generates the following objects, which can be modified in place using decorators: |
||
| 46 |
- #' {{ next_example }}
+ #' - `plot` (`ggplot2`) |
||
| 47 |
- # nolint start: line_length_linter.+ #' |
||
| 48 |
- #' @examplesIf require("ggpmisc", quietly = TRUE) && require("ggExtra", quietly = TRUE) && require("colourpicker", quietly = TRUE)
+ #' For additional details and examples of decorators, refer to the vignette |
||
| 49 |
- # nolint end: line_length_linter.+ #' `vignette("decorate-modules-output", package = "teal")` or the [`teal::teal_transform_module()`] documentation.
|
||
| 50 |
- #' # general data example+ #' |
||
| 51 |
- #' data <- teal_data()+ #' @examplesShinylive |
||
| 52 |
- #' data <- within(data, {
+ #' library(teal.modules.general) |
||
| 53 |
- #' require(nestcolor)+ #' interactive <- function() TRUE |
||
| 54 |
- #' CO2 <- CO2+ #' {{ next_example }}
|
||
| 55 |
- #' })+ #' @examples |
||
| 56 |
- #'+ #' # general data example |
||
| 57 |
- #' app <- init(+ #' data <- teal_data() |
||
| 58 |
- #' data = data,+ #' data <- within(data, {
|
||
| 59 |
- #' modules = modules(+ #' require(nestcolor) |
||
| 60 |
- #' tm_g_scatterplot(+ #' mtcars <- mtcars |
||
| 61 |
- #' label = "Scatterplot Choices",+ #' for (v in c("cyl", "vs", "am", "gear")) {
|
||
| 62 |
- #' x = data_extract_spec(+ #' mtcars[[v]] <- as.factor(mtcars[[v]]) |
||
| 63 |
- #' dataname = "CO2",+ #' } |
||
| 64 |
- #' select = select_spec(+ #' }) |
||
| 65 |
- #' label = "Select variable:",+ #' |
||
| 66 |
- #' choices = variable_choices(data[["CO2"]], c("conc", "uptake")),
+ #' app <- init( |
||
| 67 |
- #' selected = "conc",+ #' data = data, |
||
| 68 |
- #' multiple = FALSE,+ #' modules = modules( |
||
| 69 |
- #' fixed = FALSE+ #' tm_g_response( |
||
| 70 |
- #' )+ #' label = "Response Plots", |
||
| 71 |
- #' ),+ #' response = data_extract_spec( |
||
| 72 |
- #' y = data_extract_spec(+ #' dataname = "mtcars", |
||
| 73 |
- #' dataname = "CO2",+ #' select = select_spec( |
||
| 74 |
- #' select = select_spec(+ #' label = "Select variable:", |
||
| 75 |
- #' label = "Select variable:",+ #' choices = variable_choices(data[["mtcars"]], c("cyl", "gear")),
|
||
| 76 |
- #' choices = variable_choices(data[["CO2"]], c("conc", "uptake")),
+ #' selected = "cyl", |
||
| 77 |
- #' selected = "uptake",+ #' multiple = FALSE, |
||
| 78 |
- #' multiple = FALSE,+ #' fixed = FALSE |
||
| 79 |
- #' fixed = FALSE+ #' ) |
||
| 80 |
- #' )+ #' ), |
||
| 81 |
- #' ),+ #' x = data_extract_spec( |
||
| 82 |
- #' color_by = data_extract_spec(+ #' dataname = "mtcars", |
||
| 83 |
- #' dataname = "CO2",+ #' select = select_spec( |
||
| 84 |
- #' select = select_spec(+ #' label = "Select variable:", |
||
| 85 |
- #' label = "Select variable:",+ #' choices = variable_choices(data[["mtcars"]], c("vs", "am")),
|
||
| 86 |
- #' choices = variable_choices(+ #' selected = "vs", |
||
| 87 |
- #' data[["CO2"]],+ #' multiple = FALSE, |
||
| 88 |
- #' c("Plant", "Type", "Treatment", "conc", "uptake")
+ #' fixed = FALSE |
||
| 89 |
- #' ),+ #' ) |
||
| 90 |
- #' selected = NULL,+ #' ) |
||
| 91 |
- #' multiple = FALSE,+ #' ) |
||
| 92 |
- #' fixed = FALSE+ #' ) |
||
| 93 |
- #' )+ #' ) |
||
| 94 |
- #' ),+ #' if (interactive()) {
|
||
| 95 |
- #' size_by = data_extract_spec(+ #' shinyApp(app$ui, app$server) |
||
| 96 |
- #' dataname = "CO2",+ #' } |
||
| 97 |
- #' select = select_spec(+ #' |
||
| 98 |
- #' label = "Select variable:",+ #' @examplesShinylive |
||
| 99 |
- #' choices = variable_choices(data[["CO2"]], c("conc", "uptake")),
+ #' library(teal.modules.general) |
||
| 100 |
- #' selected = "uptake",+ #' interactive <- function() TRUE |
||
| 101 |
- #' multiple = FALSE,+ #' {{ next_example }}
|
||
| 102 |
- #' fixed = FALSE+ #' @examples |
||
| 103 |
- #' )+ #' # CDISC data example |
||
| 104 |
- #' ),+ #' data <- teal_data() |
||
| 105 |
- #' row_facet = data_extract_spec(+ #' data <- within(data, {
|
||
| 106 |
- #' dataname = "CO2",+ #' require(nestcolor) |
||
| 107 |
- #' select = select_spec(+ #' ADSL <- teal.data::rADSL |
||
| 108 |
- #' label = "Select variable:",+ #' }) |
||
| 109 |
- #' choices = variable_choices(data[["CO2"]], c("Plant", "Type", "Treatment")),
+ #' join_keys(data) <- default_cdisc_join_keys[names(data)] |
||
| 110 |
- #' selected = NULL,+ #' |
||
| 111 |
- #' multiple = FALSE,+ #' app <- init( |
||
| 112 |
- #' fixed = FALSE+ #' data = data, |
||
| 113 |
- #' )+ #' modules = modules( |
||
| 114 |
- #' ),+ #' tm_g_response( |
||
| 115 |
- #' col_facet = data_extract_spec(+ #' label = "Response Plots", |
||
| 116 |
- #' dataname = "CO2",+ #' response = data_extract_spec( |
||
| 117 |
- #' select = select_spec(+ #' dataname = "ADSL", |
||
| 118 |
- #' label = "Select variable:",+ #' select = select_spec( |
||
| 119 |
- #' choices = variable_choices(data[["CO2"]], c("Plant", "Type", "Treatment")),
+ #' label = "Select variable:", |
||
| 120 |
- #' selected = NULL,+ #' choices = variable_choices(data[["ADSL"]], c("BMRKR2", "COUNTRY")),
|
||
| 121 |
- #' multiple = FALSE,+ #' selected = "BMRKR2", |
||
| 122 |
- #' fixed = FALSE+ #' multiple = FALSE, |
||
| 123 |
- #' )+ #' fixed = FALSE |
||
| 124 |
- #' )+ #' ) |
||
| 125 |
- #' )+ #' ), |
||
| 126 |
- #' )+ #' x = data_extract_spec( |
||
| 127 |
- #' )+ #' dataname = "ADSL", |
||
| 128 |
- #' if (interactive()) {
+ #' select = select_spec( |
||
| 129 |
- #' shinyApp(app$ui, app$server)+ #' label = "Select variable:", |
||
| 130 |
- #' }+ #' choices = variable_choices(data[["ADSL"]], c("SEX", "RACE")),
|
||
| 131 |
- #'+ #' selected = "RACE", |
||
| 132 |
- #' @examplesShinylive+ #' multiple = FALSE, |
||
| 133 |
- #' library(teal.modules.general)+ #' fixed = FALSE |
||
| 134 |
- #' interactive <- function() TRUE+ #' ) |
||
| 135 |
- #' {{ next_example }}
+ #' ) |
||
| 136 |
- # nolint start: line_length_linter.+ #' ) |
||
| 137 |
- #' @examplesIf require("ggpmisc", quietly = TRUE) && require("ggExtra", quietly = TRUE) && require("colourpicker", quietly = TRUE)
+ #' ) |
||
| 138 |
- # nolint end: line_length_linter.+ #' ) |
||
| 139 |
- #' # CDISC data example+ #' if (interactive()) {
|
||
| 140 |
- #' data <- teal_data()+ #' shinyApp(app$ui, app$server) |
||
| 141 |
- #' data <- within(data, {
+ #' } |
||
| 142 |
- #' require(nestcolor)+ #' |
||
| 143 |
- #' ADSL <- rADSL+ #' @export |
||
| 144 |
- #' })+ #' |
||
| 145 |
- #' join_keys(data) <- default_cdisc_join_keys[names(data)]+ tm_g_response <- function(label = "Response Plot", |
||
| 146 |
- #'+ response, |
||
| 147 |
- #' app <- init(+ x, |
||
| 148 |
- #' data = data,+ row_facet = NULL, |
||
| 149 |
- #' modules = modules(+ col_facet = NULL, |
||
| 150 |
- #' tm_g_scatterplot(+ coord_flip = FALSE, |
||
| 151 |
- #' label = "Scatterplot Choices",+ count_labels = TRUE, |
||
| 152 |
- #' x = data_extract_spec(+ rotate_xaxis_labels = FALSE, |
||
| 153 |
- #' dataname = "ADSL",+ freq = FALSE, |
||
| 154 |
- #' select = select_spec(+ plot_height = c(600, 400, 5000), |
||
| 155 |
- #' label = "Select variable:",+ plot_width = NULL, |
||
| 156 |
- #' choices = variable_choices(data[["ADSL"]], c("AGE", "BMRKR1", "BMRKR2")),
+ ggtheme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void"),
|
||
| 157 |
- #' selected = "AGE",+ ggplot2_args = teal.widgets::ggplot2_args(), |
||
| 158 |
- #' multiple = FALSE,+ pre_output = NULL, |
||
| 159 |
- #' fixed = FALSE+ post_output = NULL, |
||
| 160 |
- #' )+ decorators = NULL) {
|
||
| 161 | -+ | ! |
- #' ),+ message("Initializing tm_g_response")
|
| 162 |
- #' y = data_extract_spec(+ |
||
| 163 |
- #' dataname = "ADSL",+ # Normalize the parameters |
||
| 164 | -+ | ! |
- #' select = select_spec(+ if (inherits(response, "data_extract_spec")) response <- list(response) |
| 165 | -+ | ! |
- #' label = "Select variable:",+ if (inherits(x, "data_extract_spec")) x <- list(x) |
| 166 | -+ | ! |
- #' choices = variable_choices(data[["ADSL"]], c("AGE", "BMRKR1", "BMRKR2")),
+ if (inherits(row_facet, "data_extract_spec")) row_facet <- list(row_facet) |
| 167 | -+ | ! |
- #' selected = "BMRKR1",+ if (inherits(col_facet, "data_extract_spec")) col_facet <- list(col_facet) |
| 168 |
- #' multiple = FALSE,+ |
||
| 169 |
- #' fixed = FALSE+ # Start of assertions |
||
| 170 | -+ | ! |
- #' )+ checkmate::assert_string(label) |
| 171 |
- #' ),+ |
||
| 172 | -+ | ! |
- #' color_by = data_extract_spec(+ checkmate::assert_list(response, types = "data_extract_spec") |
| 173 | -+ | ! |
- #' dataname = "ADSL",+ if (!all(vapply(response, function(x) !("" %in% x$select$choices), logical(1)))) {
|
| 174 | -+ | ! |
- #' select = select_spec(+ stop("'response' should not allow empty values")
|
| 175 |
- #' label = "Select variable:",+ } |
||
| 176 | -+ | ! |
- #' choices = variable_choices(+ assert_single_selection(response) |
| 177 |
- #' data[["ADSL"]],+ |
||
| 178 | -+ | ! |
- #' c("AGE", "BMRKR1", "BMRKR2", "RACE", "REGION1")
+ checkmate::assert_list(x, types = "data_extract_spec") |
| 179 | -+ | ! |
- #' ),+ if (!all(vapply(x, function(x) !("" %in% x$select$choices), logical(1)))) {
|
| 180 | -+ | ! |
- #' selected = NULL,+ stop("'x' should not allow empty values")
|
| 181 |
- #' multiple = FALSE,+ } |
||
| 182 | -+ | ! |
- #' fixed = FALSE+ assert_single_selection(x) |
| 183 |
- #' )+ |
||
| 184 | -+ | ! |
- #' ),+ checkmate::assert_list(row_facet, types = "data_extract_spec", null.ok = TRUE) |
| 185 | -+ | ! |
- #' size_by = data_extract_spec(+ checkmate::assert_list(col_facet, types = "data_extract_spec", null.ok = TRUE) |
| 186 | -+ | ! |
- #' dataname = "ADSL",+ checkmate::assert_flag(coord_flip) |
| 187 | -+ | ! |
- #' select = select_spec(+ checkmate::assert_flag(count_labels) |
| 188 | -+ | ! |
- #' label = "Select variable:",+ checkmate::assert_flag(rotate_xaxis_labels) |
| 189 | -+ | ! |
- #' choices = variable_choices(data[["ADSL"]], c("AGE", "BMRKR1")),
+ checkmate::assert_flag(freq) |
| 190 |
- #' selected = "AGE",+ |
||
| 191 | -+ | ! |
- #' multiple = FALSE,+ checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE) |
| 192 | -+ | ! |
- #' fixed = FALSE+ checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height") |
| 193 | -+ | ! |
- #' )+ checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE) |
| 194 | -+ | ! |
- #' ),+ checkmate::assert_numeric( |
| 195 | -+ | ! |
- #' row_facet = data_extract_spec(+ plot_width[1], |
| 196 | -+ | ! |
- #' dataname = "ADSL",+ lower = plot_width[2], upper = plot_width[3], null.ok = TRUE, .var.name = "plot_width" |
| 197 |
- #' select = select_spec(+ ) |
||
| 198 |
- #' label = "Select variable:",+ |
||
| 199 | -+ | ! |
- #' choices = variable_choices(data[["ADSL"]], c("BMRKR2", "RACE", "REGION1")),
+ ggtheme <- match.arg(ggtheme) |
| 200 | -+ | ! |
- #' selected = NULL,+ checkmate::assert_class(ggplot2_args, "ggplot2_args") |
| 201 |
- #' multiple = FALSE,+ |
||
| 202 | -+ | ! |
- #' fixed = FALSE+ checkmate::assert_multi_class(pre_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
|
| 203 | -+ | ! |
- #' )+ checkmate::assert_multi_class(post_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
|
| 204 |
- #' ),+ |
||
| 205 | -+ | ! |
- #' col_facet = data_extract_spec(+ decorators <- normalize_decorators(decorators) |
| 206 | -+ | ! |
- #' dataname = "ADSL",+ assert_decorators(decorators, null.ok = TRUE, "plot") |
| 207 |
- #' select = select_spec(+ # End of assertions |
||
| 208 |
- #' label = "Select variable:",+ |
||
| 209 |
- #' choices = variable_choices(data[["ADSL"]], c("BMRKR2", "RACE", "REGION1")),
+ # Make UI args |
||
| 210 | -+ | ! |
- #' selected = NULL,+ args <- as.list(environment()) |
| 211 |
- #' multiple = FALSE,+ |
||
| 212 | -+ | ! |
- #' fixed = FALSE+ data_extract_list <- list( |
| 213 | -+ | ! |
- #' )+ response = response, |
| 214 | -+ | ! |
- #' )+ x = x, |
| 215 | -+ | ! |
- #' )+ row_facet = row_facet, |
| 216 | -+ | ! |
- #' )+ col_facet = col_facet |
| 217 |
- #' )+ ) |
||
| 218 |
- #' if (interactive()) {
+
|
||
| 219 | -+ | ! |
- #' shinyApp(app$ui, app$server)+ ans <- module( |
| 220 | -+ | ! |
- #' }+ label = label, |
| 221 | -+ | ! |
- #'+ server = srv_g_response, |
| 222 | -+ | ! |
- #' @export+ ui = ui_g_response, |
| 223 | -+ | ! |
- #'+ ui_args = args, |
| 224 | -+ | ! |
- tm_g_scatterplot <- function(label = "Scatterplot",+ server_args = c( |
| 225 | -+ | ! |
- x,+ data_extract_list, |
| 226 | -+ | ! |
- y,+ list( |
| 227 | -+ | ! |
- color_by = NULL,+ plot_height = plot_height, |
| 228 | -+ | ! |
- size_by = NULL,+ plot_width = plot_width, |
| 229 | -+ | ! |
- row_facet = NULL,+ ggplot2_args = ggplot2_args, |
| 230 | -+ | ! |
- col_facet = NULL,+ decorators = decorators |
| 231 |
- plot_height = c(600, 200, 2000),+ ) |
||
| 232 |
- plot_width = NULL,+ ), |
||
| 233 | -+ | ! |
- alpha = c(1, 0, 1),+ datanames = teal.transform::get_extract_datanames(data_extract_list) |
| 234 |
- shape = shape_names,+ ) |
||
| 235 | -+ | ! |
- size = c(5, 1, 15),+ attr(ans, "teal_bookmarkable") <- TRUE |
| 236 | -+ | ! |
- max_deg = 5L,+ ans |
| 237 |
- rotate_xaxis_labels = FALSE,+ } |
||
| 238 |
- ggtheme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void"),
+
|
||
| 239 |
- pre_output = NULL,+ # UI function for the response module |
||
| 240 |
- post_output = NULL,+ ui_g_response <- function(id, ...) {
|
||
| 241 | -+ | ! |
- table_dec = 4,+ ns <- NS(id) |
| 242 | -+ | ! |
- ggplot2_args = teal.widgets::ggplot2_args(),+ args <- list(...) |
| 243 | -+ | ! |
- decorators = NULL) {
+ is_single_dataset_value <- teal.transform::is_single_dataset(args$response, args$x, args$row_facet, args$col_facet) |
| 244 | -! | +
- message("Initializing tm_g_scatterplot")
+
|
|
| 245 | -+ | ! |
-
+ teal.widgets::standard_layout( |
| 246 | -+ | ! |
- # Requires Suggested packages+ output = teal.widgets::white_small_well( |
| 247 | ! |
- extra_packages <- c("ggpmisc", "ggExtra", "colourpicker")
+ teal.widgets::plot_with_settings_ui(id = ns("myplot"))
|
|
| 248 | -! | +
- missing_packages <- Filter(function(x) !requireNamespace(x, quietly = TRUE), extra_packages)+ ), |
|
| 249 | ! |
- if (length(missing_packages) > 0L) {
+ encoding = tags$div( |
|
| 250 | -! | +
- stop(sprintf(+ ### Reporter |
|
| 251 | ! |
- "Cannot load package(s): %s.\nInstall or restart your session.",+ teal.reporter::simple_reporter_ui(ns("simple_reporter")),
|
|
| 252 | -! | +
- toString(missing_packages)+ ### |
|
| 253 | -+ | ! |
- ))+ tags$label("Encodings", class = "text-primary"),
|
| 254 | -+ | ! |
- }+ teal.transform::datanames_input(args[c("response", "x", "row_facet", "col_facet")]),
|
| 255 | -+ | ! |
-
+ teal.transform::data_extract_ui( |
| 256 | -+ | ! |
- # Normalize the parameters+ id = ns("response"),
|
| 257 | ! |
- if (inherits(x, "data_extract_spec")) x <- list(x)+ label = "Response variable", |
|
| 258 | ! |
- if (inherits(y, "data_extract_spec")) y <- list(y)+ data_extract_spec = args$response, |
|
| 259 | ! |
- if (inherits(color_by, "data_extract_spec")) color_by <- list(color_by)+ is_single_dataset = is_single_dataset_value |
|
| 260 | -! | +
- if (inherits(size_by, "data_extract_spec")) size_by <- list(size_by)+ ), |
|
| 261 | ! |
- if (inherits(row_facet, "data_extract_spec")) row_facet <- list(row_facet)+ teal.transform::data_extract_ui( |
|
| 262 | ! |
- if (inherits(col_facet, "data_extract_spec")) col_facet <- list(col_facet)+ id = ns("x"),
|
|
| 263 | ! |
- if (is.double(max_deg)) max_deg <- as.integer(max_deg)+ label = "X variable", |
|
| 264 | -+ | ! |
-
+ data_extract_spec = args$x, |
| 265 | -+ | ! |
- # Start of assertions+ is_single_dataset = is_single_dataset_value |
| 266 | -! | +
- checkmate::assert_string(label)+ ), |
|
| 267 | ! |
- checkmate::assert_list(x, types = "data_extract_spec")+ if (!is.null(args$row_facet)) {
|
|
| 268 | ! |
- checkmate::assert_list(y, types = "data_extract_spec")+ teal.transform::data_extract_ui( |
|
| 269 | ! |
- checkmate::assert_list(color_by, types = "data_extract_spec", null.ok = TRUE)+ id = ns("row_facet"),
|
|
| 270 | ! |
- checkmate::assert_list(size_by, types = "data_extract_spec", null.ok = TRUE)+ label = "Row facetting", |
|
| 271 | -+ | ! |
-
+ data_extract_spec = args$row_facet, |
| 272 | ! |
- checkmate::assert_list(row_facet, types = "data_extract_spec", null.ok = TRUE)+ is_single_dataset = is_single_dataset_value |
|
| 273 | -! | +
- assert_single_selection(row_facet)+ ) |
|
| 274 |
-
+ }, |
||
| 275 | ! |
- checkmate::assert_list(col_facet, types = "data_extract_spec", null.ok = TRUE)+ if (!is.null(args$col_facet)) {
|
|
| 276 | ! |
- assert_single_selection(col_facet)+ teal.transform::data_extract_ui( |
|
| 277 | -+ | ! |
-
+ id = ns("col_facet"),
|
| 278 | ! |
- checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE)+ label = "Column facetting", |
|
| 279 | ! |
- checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height")+ data_extract_spec = args$col_facet, |
|
| 280 | ! |
- checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE)+ is_single_dataset = is_single_dataset_value |
|
| 281 | -! | +
- checkmate::assert_numeric(+ ) |
|
| 282 | -! | +
- plot_width[1],+ }, |
|
| 283 | ! |
- lower = plot_width[2], upper = plot_width[3], null.ok = TRUE, .var.name = "plot_width"+ shinyWidgets::radioGroupButtons( |
|
| 284 | -+ | ! |
- )+ inputId = ns("freq"),
|
| 285 | -+ | ! |
-
+ label = NULL, |
| 286 | ! |
- if (length(alpha) == 1) {
+ choices = c("frequency", "density"),
|
|
| 287 | ! |
- checkmate::assert_numeric(alpha, any.missing = FALSE, finite = TRUE)+ selected = ifelse(args$freq, "frequency", "density"), |
|
| 288 | -+ | ! |
- } else {
+ justified = TRUE |
| 289 | -! | +
- checkmate::assert_numeric(alpha, len = 3, any.missing = FALSE, finite = TRUE)+ ), |
|
| 290 | ! |
- checkmate::assert_numeric(alpha[1], lower = alpha[2], upper = alpha[3], .var.name = "alpha")+ ui_decorate_teal_data(ns("decorator"), decorators = select_decorators(args$decorators, "plot")),
|
|
| 291 | -+ | ! |
- }+ teal.widgets::panel_group( |
| 292 | -+ | ! |
-
+ teal.widgets::panel_item( |
| 293 | ! |
- checkmate::assert_character(shape)+ title = "Plot settings", |
|
| 294 | -+ | ! |
-
+ checkboxInput(ns("count_labels"), "Add count labels", value = args$count_labels),
|
| 295 | ! |
- if (length(size) == 1) {
+ checkboxInput(ns("coord_flip"), "Swap axes", value = args$coord_flip),
|
|
| 296 | ! |
- checkmate::assert_numeric(size, any.missing = FALSE, finite = TRUE)+ checkboxInput(ns("rotate_xaxis_labels"), "Rotate X axis labels", value = args$rotate_xaxis_labels),
|
|
| 297 | -+ | ! |
- } else {
+ selectInput( |
| 298 | ! |
- checkmate::assert_numeric(size, len = 3, any.missing = FALSE, finite = TRUE)+ inputId = ns("ggtheme"),
|
|
| 299 | ! |
- checkmate::assert_numeric(size[1], lower = size[2], upper = size[3], .var.name = "size")+ label = "Theme (by ggplot):", |
|
| 300 | -+ | ! |
- }+ choices = ggplot_themes, |
| 301 | -+ | ! |
-
+ selected = args$ggtheme, |
| 302 | ! |
- checkmate::assert_int(max_deg, lower = 1L)+ multiple = FALSE |
|
| 303 | -! | +
- checkmate::assert_flag(rotate_xaxis_labels)+ ) |
|
| 304 | -! | +
- ggtheme <- match.arg(ggtheme)+ ) |
|
| 305 |
-
+ ) |
||
| 306 | -! | +
- checkmate::assert_multi_class(pre_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
+ ), |
|
| 307 | ! |
- checkmate::assert_multi_class(post_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
+ forms = tagList( |
|
| 308 | -+ | ! |
-
+ teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code")
|
| 309 | -! | +
- checkmate::assert_scalar(table_dec)+ ), |
|
| 310 | ! |
- checkmate::assert_class(ggplot2_args, "ggplot2_args")+ pre_output = args$pre_output, |
|
| 311 | -+ | ! |
-
+ post_output = args$post_output |
| 312 | -! | +
- decorators <- normalize_decorators(decorators)+ ) |
|
| 313 | -! | +
- assert_decorators(decorators, null.ok = TRUE, "plot")+ } |
|
| 315 |
- # End of assertions+ # Server function for the response module |
||
| 316 |
-
+ srv_g_response <- function(id, |
||
| 317 |
- # Make UI args+ data, |
||
| 318 | -! | +
- args <- as.list(environment())+ reporter, |
|
| 319 |
-
+ filter_panel_api, |
||
| 320 | -! | +
- data_extract_list <- list(+ response, |
|
| 321 | -! | +
- x = x,+ x, |
|
| 322 | -! | +
- y = y,+ row_facet, |
|
| 323 | -! | +
- color_by = color_by,+ col_facet, |
|
| 324 | -! | +
- size_by = size_by,+ plot_height, |
|
| 325 | -! | +
- row_facet = row_facet,+ plot_width, |
|
| 326 | -! | +
- col_facet = col_facet+ ggplot2_args, |
|
| 327 |
- )+ decorators) {
|
||
| 328 | -+ | ! |
-
+ with_reporter <- !missing(reporter) && inherits(reporter, "Reporter") |
| 329 | ! |
- ans <- module(+ with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI") |
|
| 330 | ! |
- label = label,+ checkmate::assert_class(data, "reactive") |
|
| 331 | ! |
- server = srv_g_scatterplot,+ checkmate::assert_class(isolate(data()), "teal_data") |
|
| 332 | ! |
- ui = ui_g_scatterplot,+ moduleServer(id, function(input, output, session) {
|
|
| 333 | ! |
- ui_args = args,+ teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.general") |
|
| 334 | -! | +
- server_args = c(+ |
|
| 335 | ! |
- data_extract_list,+ data_extract <- list(response = response, x = x, row_facet = row_facet, col_facet = col_facet) |
|
| 336 | -! | +
- list(+ |
|
| 337 | ! |
- plot_height = plot_height,+ rule_diff <- function(other) {
|
|
| 338 | ! |
- plot_width = plot_width,+ function(value) {
|
|
| 339 | ! |
- table_dec = table_dec,+ if (other %in% names(selector_list())) {
|
|
| 340 | ! |
- ggplot2_args = ggplot2_args,+ othervalue <- selector_list()[[other]]()[["select"]] |
|
| 341 | ! |
- decorators = decorators+ if (!is.null(othervalue)) {
|
|
| 342 | -+ | ! |
- )+ if (identical(value, othervalue)) {
|
| 343 | -+ | ! |
- ),+ "Row and column facetting variables must be different." |
| 344 | -! | +
- datanames = teal.transform::get_extract_datanames(data_extract_list)+ } |
|
| 345 |
- )+ } |
||
| 346 | -! | +
- attr(ans, "teal_bookmarkable") <- TRUE+ } |
|
| 347 | -! | +
- ans+ } |
|
| 348 |
- }+ } |
||
| 350 | -+ | ! |
- # UI function for the scatterplot module+ selector_list <- teal.transform::data_extract_multiple_srv( |
| 351 | -+ | ! |
- ui_g_scatterplot <- function(id, ...) {
+ data_extract = data_extract, |
| 352 | ! |
- args <- list(...)+ datasets = data, |
|
| 353 | ! |
- ns <- NS(id)+ select_validation_rule = list( |
|
| 354 | ! |
- is_single_dataset_value <- teal.transform::is_single_dataset(+ response = shinyvalidate::sv_required("Please define a column for the response variable"),
|
|
| 355 | ! |
- args$x, args$y, args$color_by, args$size_by, args$row_facet, args$col_facet+ x = shinyvalidate::sv_required("Please define a column for X variable"),
|
|
| 356 | -+ | ! |
- )+ row_facet = shinyvalidate::compose_rules( |
| 357 | -+ | ! |
-
+ shinyvalidate::sv_optional(), |
| 358 | ! |
- tagList(+ ~ if (length(.) > 1) "There must be 1 or no row facetting variable.", |
|
| 359 | ! |
- include_css_files("custom"),
+ rule_diff("col_facet")
|
|
| 360 | -! | +
- teal.widgets::standard_layout(+ ), |
|
| 361 | ! |
- output = teal.widgets::white_small_well(+ col_facet = shinyvalidate::compose_rules( |
|
| 362 | ! |
- teal.widgets::plot_with_settings_ui(id = ns("scatter_plot")),
+ shinyvalidate::sv_optional(), |
|
| 363 | ! |
- tags$h1(tags$strong("Selected points:"), class = "text-center font-150p"),
+ ~ if (length(.) > 1) "There must be 1 or no column facetting variable.", |
|
| 364 | ! |
- teal.widgets::get_dt_rows(ns("data_table"), ns("data_table_rows")),
+ rule_diff("row_facet")
|
|
| 365 | -! | +
- DT::dataTableOutput(ns("data_table"), width = "100%")
+ ) |
|
| 366 |
- ),+ ) |
||
| 367 | -! | +
- encoding = tags$div(+ ) |
|
| 368 |
- ### Reporter+ |
||
| 369 | ! |
- teal.reporter::simple_reporter_ui(ns("simple_reporter")),
+ iv_r <- reactive({
|
|
| 370 | -+ | ! |
- ###+ iv <- shinyvalidate::InputValidator$new() |
| 371 | ! |
- tags$label("Encodings", class = "text-primary"),
+ iv$add_rule("ggtheme", shinyvalidate::sv_required("Please select a theme"))
|
|
| 372 | ! |
- teal.transform::datanames_input(args[c("x", "y", "color_by", "size_by", "row_facet", "col_facet")]),
+ teal.transform::compose_and_enable_validators(iv, selector_list) |
|
| 373 | -! | +
- teal.transform::data_extract_ui(+ }) |
|
| 374 | -! | +
- id = ns("x"),
+
|
|
| 375 | ! |
- label = "X variable",+ anl_merged_input <- teal.transform::merge_expression_srv( |
|
| 376 | ! |
- data_extract_spec = args$x,+ selector_list = selector_list, |
|
| 377 | ! |
- is_single_dataset = is_single_dataset_value+ datasets = data |
|
| 378 |
- ),+ ) |
||
| 379 | -! | +
- checkboxInput(ns("log_x"), "Use log transformation", value = FALSE),
+
|
|
| 380 | ! |
- conditionalPanel(+ anl_merged_q <- reactive({
|
|
| 381 | ! |
- condition = paste0("input['", ns("log_x"), "'] == true"),
+ req(anl_merged_input()) |
|
| 382 | ! |
- radioButtons(+ data() %>% |
|
| 383 | ! |
- ns("log_x_base"),
+ teal.code::eval_code(as.expression(anl_merged_input()$expr)) |
|
| 384 | -! | +
- label = NULL,+ }) |
|
| 385 | -! | +
- inline = TRUE,+ |
|
| 386 | ! |
- choices = c("Natural" = "log", "Base 10" = "log10", "Base 2" = "log2")
+ merged <- list( |
|
| 387 | -+ | ! |
- )+ anl_input_r = anl_merged_input, |
| 388 | -+ | ! |
- ),+ anl_q_r = anl_merged_q |
| 389 | -! | +
- teal.transform::data_extract_ui(+ ) |
|
| 390 | -! | +
- id = ns("y"),
+
|
|
| 391 | ! |
- label = "Y variable",+ output_q <- reactive({
|
|
| 392 | ! |
- data_extract_spec = args$y,+ teal::validate_inputs(iv_r()) |
|
| 393 | -! | +
- is_single_dataset = is_single_dataset_value+ |
|
| 394 | -+ | ! |
- ),+ qenv <- merged$anl_q_r() |
| 395 | ! |
- checkboxInput(ns("log_y"), "Use log transformation", value = FALSE),
+ ANL <- qenv[["ANL"]] |
|
| 396 | ! |
- conditionalPanel(+ resp_var <- as.vector(merged$anl_input_r()$columns_source$response) |
|
| 397 | ! |
- condition = paste0("input['", ns("log_y"), "'] == true"),
+ x <- as.vector(merged$anl_input_r()$columns_source$x) |
|
| 398 | -! | +
- radioButtons(+ |
|
| 399 | ! |
- ns("log_y_base"),
+ validate(need(is.factor(ANL[[resp_var]]), "Please select a factor variable as the response.")) |
|
| 400 | ! |
- label = NULL,+ validate(need(is.factor(ANL[[x]]), "Please select a factor variable as the X-Variable.")) |
|
| 401 | ! |
- inline = TRUE,+ teal::validate_has_data(ANL, 10) |
|
| 402 | ! |
- choices = c("Natural" = "log", "Base 10" = "log10", "Base 2" = "log2")
+ teal::validate_has_data(ANL[, c(resp_var, x)], 10, complete = TRUE, allow_inf = FALSE) |
|
| 403 |
- )+ |
||
| 404 | -+ | ! |
- ),+ row_facet_name <- if (length(merged$anl_input_r()$columns_source$row_facet) == 0) {
|
| 405 | ! |
- if (!is.null(args$color_by)) {
+ character(0) |
|
| 406 | -! | +
- teal.transform::data_extract_ui(+ } else {
|
|
| 407 | ! |
- id = ns("color_by"),
+ as.vector(merged$anl_input_r()$columns_source$row_facet) |
|
| 408 | -! | +
- label = "Color by variable",+ } |
|
| 409 | ! |
- data_extract_spec = args$color_by,+ col_facet_name <- if (length(merged$anl_input_r()$columns_source$col_facet) == 0) {
|
|
| 410 | ! |
- is_single_dataset = is_single_dataset_value+ character(0) |
|
| 411 |
- )+ } else {
|
||
| 412 | -+ | ! |
- },+ as.vector(merged$anl_input_r()$columns_source$col_facet) |
| 413 | -! | +
- if (!is.null(args$size_by)) {
+ } |
|
| 414 | -! | +
- teal.transform::data_extract_ui(+ |
|
| 415 | ! |
- id = ns("size_by"),
+ freq <- input$freq == "frequency" |
|
| 416 | ! |
- label = "Size by variable",+ swap_axes <- input$coord_flip |
|
| 417 | ! |
- data_extract_spec = args$size_by,+ counts <- input$count_labels |
|
| 418 | ! |
- is_single_dataset = is_single_dataset_value+ rotate_xaxis_labels <- input$rotate_xaxis_labels |
|
| 419 | -+ | ! |
- )+ ggtheme <- input$ggtheme |
| 420 |
- },+ |
||
| 421 | ! |
- if (!is.null(args$row_facet)) {
+ arg_position <- if (freq) "stack" else "fill" |
|
| 422 | -! | +
- teal.transform::data_extract_ui(+ |
|
| 423 | ! |
- id = ns("row_facet"),
+ rowf <- if (length(row_facet_name) != 0) as.name(row_facet_name) |
|
| 424 | ! |
- label = "Row facetting",+ colf <- if (length(col_facet_name) != 0) as.name(col_facet_name) |
|
| 425 | ! |
- data_extract_spec = args$row_facet,+ resp_cl <- as.name(resp_var) |
|
| 426 | ! |
- is_single_dataset = is_single_dataset_value+ x_cl <- as.name(x) |
|
| 427 |
- )+ |
||
| 428 | -+ | ! |
- },+ if (swap_axes) {
|
| 429 | ! |
- if (!is.null(args$col_facet)) {
+ qenv <- teal.code::eval_code( |
|
| 430 | ! |
- teal.transform::data_extract_ui(+ qenv, |
|
| 431 | ! |
- id = ns("col_facet"),
+ substitute( |
|
| 432 | ! |
- label = "Column facetting",+ expr = ANL[[x]] <- with(ANL, forcats::fct_rev(x_cl)), |
|
| 433 | ! |
- data_extract_spec = args$col_facet,+ env = list(x = x, x_cl = x_cl) |
|
| 434 | -! | +
- is_single_dataset = is_single_dataset_value+ ) |
|
| 435 |
- )+ ) |
||
| 436 |
- },+ } |
||
| 437 | -! | +
- ui_decorate_teal_data(ns("decorator"), decorators = select_decorators(args$decorators, "plot")),
+
|
|
| 438 | ! |
- teal.widgets::panel_group(+ qenv <- teal.code::eval_code( |
|
| 439 | ! |
- teal.widgets::panel_item(+ qenv, |
|
| 440 | ! |
- title = "Plot settings",+ substitute( |
|
| 441 | ! |
- teal.widgets::optionalSliderInputValMinMax(ns("alpha"), "Opacity:", args$alpha, ticks = FALSE),
+ expr = ANL[[resp_var]] <- factor(ANL[[resp_var]]), |
|
| 442 | ! |
- teal.widgets::optionalSelectInput(+ env = list(resp_var = resp_var) |
|
| 443 | -! | +
- inputId = ns("shape"),
+ ) |
|
| 444 | -! | +
- label = "Points shape:",+ ) %>% |
|
| 445 | -! | +
- choices = args$shape,+ # rowf and colf will be a NULL if not set by a user |
|
| 446 | ! |
- selected = args$shape[1],+ teal.code::eval_code( |
|
| 447 | ! |
- multiple = FALSE+ substitute( |
|
| 448 | -+ | ! |
- ),+ expr = ANL2 <- ANL %>% |
| 449 | ! |
- colourpicker::colourInput(ns("color"), "Points color:", "black"),
+ dplyr::group_by_at(dplyr::vars(x_cl, resp_cl, rowf, colf)) %>% |
|
| 450 | ! |
- teal.widgets::optionalSliderInputValMinMax(ns("size"), "Points size:", args$size, ticks = FALSE, step = .1),
+ dplyr::summarise(ns = dplyr::n()) %>% |
|
| 451 | ! |
- checkboxInput(ns("rotate_xaxis_labels"), "Rotate X axis labels", value = args$rotate_xaxis_labels),
+ dplyr::group_by_at(dplyr::vars(x_cl, rowf, colf)) %>% |
|
| 452 | ! |
- checkboxInput(ns("add_density"), "Add marginal density", value = FALSE),
+ dplyr::mutate(sums = sum(ns), percent = round(ns / sums * 100, 1)), |
|
| 453 | ! |
- checkboxInput(ns("rug_plot"), "Include rug plot", value = FALSE),
+ env = list(x_cl = x_cl, resp_cl = resp_cl, rowf = rowf, colf = colf) |
|
| 454 | -! | +
- checkboxInput(ns("show_count"), "Show N (number of observations)", value = FALSE),
+ ) |
|
| 455 | -! | +
- shinyjs::hidden(helpText(id = ns("line_msg"), "Trendline needs numeric X and Y variables")),
+ ) %>% |
|
| 456 | ! |
- teal.widgets::optionalSelectInput(ns("smoothing_degree"), "Smoothing degree", seq_len(args$max_deg)),
+ teal.code::eval_code( |
|
| 457 | ! |
- shinyjs::hidden(teal.widgets::optionalSelectInput(ns("color_sub"), label = "", multiple = TRUE)),
+ substitute( |
|
| 458 | ! |
- teal.widgets::optionalSliderInputValMinMax(ns("ci"), "Confidence", c(.95, .8, .99), ticks = FALSE),
+ expr = ANL3 <- ANL %>% |
|
| 459 | ! |
- shinyjs::hidden(checkboxInput(ns("show_form"), "Show formula", value = TRUE)),
+ dplyr::group_by_at(dplyr::vars(x_cl, rowf, colf)) %>% |
|
| 460 | ! |
- shinyjs::hidden(checkboxInput(ns("show_r2"), "Show adj-R Squared", value = TRUE)),
+ dplyr::summarise(ns = dplyr::n()), |
|
| 461 | ! |
- uiOutput(ns("num_na_removed")),
+ env = list(x_cl = x_cl, rowf = rowf, colf = colf) |
|
| 462 | -! | +
- tags$div(+ ) |
|
| 463 | -! | +
- id = ns("label_pos"),
+ ) |
|
| 464 | -! | +
- tags$div(tags$strong("Stats position")),
+
|
|
| 465 | ! |
- tags$div(class = "inline-block w-10", helpText("Left")),
+ plot_call <- substitute( |
|
| 466 | ! |
- tags$div(+ expr = ggplot(ANL2, aes(x = x_cl, y = ns)) + |
|
| 467 | ! |
- class = "inline-block w-70",+ geom_bar(aes(fill = resp_cl), stat = "identity", position = arg_position), |
|
| 468 | ! |
- teal.widgets::optionalSliderInput(+ env = list( |
|
| 469 | ! |
- ns("pos"),
+ x_cl = x_cl, |
|
| 470 | ! |
- label = NULL,+ resp_cl = resp_cl, |
|
| 471 | ! |
- min = 0, max = 1, value = .99, ticks = FALSE, step = .01+ arg_position = arg_position |
|
| 472 |
- )+ ) |
||
| 473 |
- ),+ ) |
||
| 474 | -! | +
- tags$div(class = "inline-block w-10", helpText("Right"))
+
|
|
| 475 | -+ | ! |
- ),+ if (!freq) {
|
| 476 | ! |
- teal.widgets::optionalSliderInput(+ plot_call <- substitute( |
|
| 477 | ! |
- ns("label_size"), "Stats font size",
+ plot_call + expand_limits(y = c(0, 1.1)), |
|
| 478 | ! |
- min = 3, max = 10, value = 5, ticks = FALSE, step = .1+ env = list(plot_call = plot_call) |
|
| 479 |
- ),+ ) |
||
| 480 | -! | +
- if (!is.null(args$row_facet) || !is.null(args$col_facet)) {
+ } |
|
| 481 | -! | +
- checkboxInput(ns("free_scales"), "Free scales", value = FALSE)
+
|
|
| 482 | -+ | ! |
- },+ if (counts) {
|
| 483 | ! |
- selectInput(+ plot_call <- substitute( |
|
| 484 | ! |
- inputId = ns("ggtheme"),
+ expr = plot_call + |
|
| 485 | ! |
- label = "Theme (by ggplot):",+ geom_text( |
|
| 486 | ! |
- choices = ggplot_themes,+ data = ANL2, |
|
| 487 | ! |
- selected = args$ggtheme,+ aes(label = ns, x = x_cl, y = ns, group = resp_cl), |
|
| 488 | ! |
- multiple = FALSE+ col = "white", |
|
| 489 | -+ | ! |
- )+ vjust = "middle", |
| 490 | -+ | ! |
- )+ hjust = "middle", |
| 491 | -+ | ! |
- )+ position = position_anl2_value |
| 492 |
- ),+ ) + |
||
| 493 | ! |
- forms = tagList(+ geom_text( |
|
| 494 | ! |
- teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code")
+ data = ANL3, aes(label = ns, x = x_cl, y = anl3_y), |
|
| 495 | -+ | ! |
- ),+ hjust = hjust_value, |
| 496 | ! |
- pre_output = args$pre_output,+ vjust = vjust_value, |
|
| 497 | ! |
- post_output = args$post_output+ position = position_anl3_value |
|
| 498 |
- )+ ), |
||
| 499 | -+ | ! |
- )+ env = list( |
| 500 | -+ | ! |
- }+ plot_call = plot_call, |
| 501 | -+ | ! |
-
+ x_cl = x_cl, |
| 502 | -+ | ! |
- # Server function for the scatterplot module+ resp_cl = resp_cl, |
| 503 | -+ | ! |
- srv_g_scatterplot <- function(id,+ hjust_value = if (swap_axes) "left" else "middle", |
| 504 | -+ | ! |
- data,+ vjust_value = if (swap_axes) "middle" else -1, |
| 505 | -+ | ! |
- reporter,+ position_anl2_value = if (!freq) quote(position_fill(0.5)) else quote(position_stack(0.5)), # nolint: line_length. |
| 506 | -+ | ! |
- filter_panel_api,+ anl3_y = if (!freq) 1.1 else as.name("ns"),
|
| 507 | -+ | ! |
- x,+ position_anl3_value = if (!freq) "fill" else "stack" |
| 508 |
- y,+ ) |
||
| 509 |
- color_by,+ ) |
||
| 510 |
- size_by,+ } |
||
| 511 |
- row_facet,+ |
||
| 512 | -+ | ! |
- col_facet,+ if (swap_axes) {
|
| 513 | -+ | ! |
- plot_height,+ plot_call <- substitute(plot_call + coord_flip(), env = list(plot_call = plot_call)) |
| 514 |
- plot_width,+ } |
||
| 515 |
- table_dec,+ |
||
| 516 | -+ | ! |
- ggplot2_args,+ facet_cl <- facet_ggplot_call(row_facet_name, col_facet_name) |
| 517 |
- decorators) {
+
|
||
| 518 | ! |
- with_reporter <- !missing(reporter) && inherits(reporter, "Reporter")+ if (!is.null(facet_cl)) {
|
|
| 519 | ! |
- with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI")+ plot_call <- substitute(expr = plot_call + facet_cl, env = list(plot_call = plot_call, facet_cl = facet_cl)) |
|
| 520 | -! | +
- checkmate::assert_class(data, "reactive")+ } |
|
| 521 | -! | +
- checkmate::assert_class(isolate(data()), "teal_data")+ |
|
| 522 | ! |
- moduleServer(id, function(input, output, session) {
+ dev_ggplot2_args <- teal.widgets::ggplot2_args( |
|
| 523 | ! |
- teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.general")+ labs = list( |
|
| 524 | -+ | ! |
-
+ x = varname_w_label(x, ANL), |
| 525 | ! |
- data_extract <- list(+ y = varname_w_label(resp_var, ANL, prefix = "Proportion of "), |
|
| 526 | ! |
- x = x,+ fill = varname_w_label(resp_var, ANL) |
|
| 527 | -! | +
- y = y,+ ), |
|
| 528 | ! |
- color_by = color_by,+ theme = list(legend.position = "bottom") |
|
| 529 | -! | +
- size_by = size_by,+ ) |
|
| 530 | -! | +
- row_facet = row_facet,+ |
|
| 531 | ! |
- col_facet = col_facet+ if (rotate_xaxis_labels) {
|
|
| 532 | -+ | ! |
- )+ dev_ggplot2_args$theme[["axis.text.x"]] <- quote(element_text(angle = 45, hjust = 1)) |
| 533 |
-
+ } |
||
| 534 | -! | +
- rule_diff <- function(other) {
+
|
|
| 535 | ! |
- function(value) {
+ all_ggplot2_args <- teal.widgets::resolve_ggplot2_args( |
|
| 536 | ! |
- othervalue <- selector_list()[[other]]()[["select"]]+ user_plot = ggplot2_args, |
|
| 537 | ! |
- if (!is.null(othervalue)) {
+ module_plot = dev_ggplot2_args |
|
| 538 | -! | +
- if (identical(value, othervalue)) {
+ ) |
|
| 539 | -! | +
- "Row and column facetting variables must be different."+ |
|
| 540 | -+ | ! |
- }+ parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args( |
| 541 | -+ | ! |
- }+ all_ggplot2_args, |
| 542 | -+ | ! |
- }+ ggtheme = ggtheme |
| 543 |
- }+ ) |
||
| 545 | ! |
- selector_list <- teal.transform::data_extract_multiple_srv(+ plot_call <- substitute(expr = {
|
|
| 546 | ! |
- data_extract = data_extract,+ plot <- plot_call + labs + ggthemes + themes |
|
| 547 | ! |
- datasets = data,+ }, env = list( |
|
| 548 | ! |
- select_validation_rule = list(+ plot_call = plot_call, |
|
| 549 | ! |
- x = ~ if (length(.) != 1) "Please select exactly one x var.",+ labs = parsed_ggplot2_args$labs, |
|
| 550 | ! |
- y = ~ if (length(.) != 1) "Please select exactly one y var.",+ themes = parsed_ggplot2_args$theme, |
|
| 551 | ! |
- color_by = ~ if (length(.) > 1) "There cannot be more than 1 color variable.",+ ggthemes = parsed_ggplot2_args$ggtheme |
|
| 552 | -! | +
- size_by = ~ if (length(.) > 1) "There cannot be more than 1 size variable.",+ )) |
|
| 553 | -! | +
- row_facet = shinyvalidate::compose_rules(+ |
|
| 554 | ! |
- shinyvalidate::sv_optional(),+ teal.code::eval_code(qenv, plot_call) |
|
| 555 | -! | +
- rule_diff("col_facet")
+ }) |
|
| 556 |
- ),+ |
||
| 557 | ! |
- col_facet = shinyvalidate::compose_rules(+ decorated_output_plot_q <- srv_decorate_teal_data( |
|
| 558 | ! |
- shinyvalidate::sv_optional(),+ id = "decorator", |
|
| 559 | ! |
- rule_diff("row_facet")
+ data = output_q, |
|
| 560 | -+ | ! |
- )+ decorators = select_decorators(decorators, "plot"), |
| 561 | -+ | ! |
- )+ expr = print(plot) |
| 564 | ! |
- iv_r <- reactive({
+ plot_r <- reactive(req(decorated_output_plot_q())[["plot"]]) |
|
| 565 | -! | +
- iv_facet <- shinyvalidate::InputValidator$new()+ |
|
| 566 | -! | +
- iv <- shinyvalidate::InputValidator$new()+ # Insert the plot into a plot_with_settings module from teal.widgets |
|
| 567 | ! |
- teal.transform::compose_and_enable_validators(iv, selector_list)+ pws <- teal.widgets::plot_with_settings_srv( |
|
| 568 | -+ | ! |
- })+ id = "myplot", |
| 569 | ! |
- iv_facet <- shinyvalidate::InputValidator$new()+ plot_r = plot_r, |
|
| 570 | ! |
- iv_facet$add_rule("add_density", ~ if (
+ height = plot_height, |
|
| 571 | ! |
- isTRUE(.) &&+ width = plot_width |
|
| 572 |
- (+ ) |
||
| 573 | -! | +
- length(selector_list()$row_facet()$select) > 0L ||+ |
|
| 574 | ! |
- length(selector_list()$col_facet()$select) > 0L+ teal.widgets::verbatim_popup_srv( |
|
| 575 | -+ | ! |
- )+ id = "rcode", |
| 576 | -+ | ! |
- ) {
+ verbatim_content = reactive(teal.code::get_code(req(decorated_output_plot_q()))), |
| 577 | ! |
- "Cannot add marginal density when Row or Column facetting has been selected"+ title = "Show R Code for Response" |
|
| 578 |
- })+ ) |
||
| 579 | -! | +
- iv_facet$enable()+ |
|
| 580 |
-
+ ### REPORTER |
||
| 581 | ! |
- anl_merged_input <- teal.transform::merge_expression_srv(+ if (with_reporter) {
|
|
| 582 | ! |
- selector_list = selector_list,+ card_fun <- function(comment, label) {
|
|
| 583 | ! |
- datasets = data,+ card <- teal::report_card_template( |
|
| 584 | ! |
- merge_function = "dplyr::inner_join"+ title = "Response Plot", |
|
| 585 | -+ | ! |
- )+ label = label, |
| 586 | -+ | ! |
-
+ with_filter = with_filter, |
| 587 | ! |
- anl_merged_q <- reactive({
+ filter_panel_api = filter_panel_api |
|
| 588 | -! | +
- req(anl_merged_input())+ ) |
|
| 589 | ! |
- data() %>%+ card$append_text("Plot", "header3")
|
|
| 590 | ! |
- teal.code::eval_code(as.expression(anl_merged_input()$expr)) %>%+ card$append_plot(plot_r(), dim = pws$dim()) |
|
| 591 | ! |
- teal.code::eval_code(quote(ANL)) # used to display table when running show-r-code code+ if (!comment == "") {
|
|
| 592 | -+ | ! |
- })+ card$append_text("Comment", "header3")
|
| 593 | -+ | ! |
-
+ card$append_text(comment) |
| 594 | -! | +
- merged <- list(+ } |
|
| 595 | ! |
- anl_input_r = anl_merged_input,+ card$append_src(teal.code::get_code(req(decorated_output_plot_q()))) |
|
| 596 | ! |
- anl_q_r = anl_merged_q+ card |
|
| 597 |
- )+ } |
||
| 598 | -+ | ! |
-
+ teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
|
| 599 | -! | +
- trend_line_is_applicable <- reactive({
+ } |
|
| 600 | -! | +
- ANL <- merged$anl_q_r()[["ANL"]]+ ### |
|
| 601 | -! | +
- x_var <- as.vector(merged$anl_input_r()$columns_source$x)+ }) |
|
| 602 | -! | +
- y_var <- as.vector(merged$anl_input_r()$columns_source$y)+ } |
|
| 603 | -! | +
| 1 | +
- length(x_var) > 0 && length(y_var) > 0 && is.numeric(ANL[[x_var]]) && is.numeric(ANL[[y_var]])+ #' Shared parameters documentation+ |
+ ||
| 2 | ++ |
+ #'+ |
+ |
| 3 | ++ |
+ #' Defines common arguments shared across multiple functions in the package+ |
+ |
| 4 | ++ |
+ #' to avoid repetition by using `inheritParams`.+ |
+ |
| 5 | ++ |
+ #'+ |
+ |
| 6 | ++ |
+ #' @param plot_height (`numeric`) optional, specifies the plot height as a three-element vector of+ |
+ |
| 7 | ++ |
+ #' `value`, `min`, and `max` intended for use with a slider UI element.+ |
+ |
| 8 | ++ |
+ #' @param plot_width (`numeric`) optional, specifies the plot width as a three-element vector of+ |
+ |
| 9 | ++ |
+ #' `value`, `min`, and `max` for a slider encoding the plot width.+ |
+ |
| 10 | ++ |
+ #' @param rotate_xaxis_labels (`logical`) optional, whether to rotate plot X axis labels. Does not+ |
+ |
| 11 | ++ |
+ #' rotate by default (`FALSE`).+ |
+ |
| 12 | ++ |
+ #' @param ggtheme (`character`) optional, `ggplot2` theme to be used by default. Defaults to `"gray"`.+ |
+ |
| 13 | ++ |
+ #' @param ggplot2_args (`ggplot2_args`) object created by [teal.widgets::ggplot2_args()]+ |
+ |
| 14 | ++ |
+ #' with settings for the module plot.+ |
+ |
| 15 | ++ |
+ #' The argument is merged with options variable `teal.ggplot2_args` and default module setup.+ |
+ |
| 16 | ++ |
+ #'+ |
+ |
| 17 | ++ |
+ #' For more details see the vignette: `vignette("custom-ggplot2-arguments", package = "teal.widgets")`
+ |
+ |
| 18 | ++ |
+ #' @param basic_table_args (`basic_table_args`) object created by [teal.widgets::basic_table_args()]+ |
+ |
| 19 | ++ |
+ #' with settings for the module table.+ |
+ |
| 20 | ++ |
+ #' The argument is merged with options variable `teal.basic_table_args` and default module setup.+ |
+ |
| 21 | ++ |
+ #'+ |
+ |
| 22 | ++ |
+ #' For more details see the vignette: `vignette("custom-basic-table-arguments", package = "teal.widgets")`
+ |
+ |
| 23 | ++ |
+ #' @param pre_output (`shiny.tag`) optional, text or UI element to be displayed before the module's output,+ |
+ |
| 24 | ++ |
+ #' providing context or a title.+ |
+ |
| 25 | ++ |
+ #' with text placed before the output to put the output into context. For example a title.+ |
+ |
| 26 | ++ |
+ #' @param post_output (`shiny.tag`) optional, text or UI element to be displayed after the module's output,+ |
+ |
| 27 | ++ |
+ #' adding context or further instructions. Elements like `shiny::helpText()` are useful. |
|
| 604 | +28 |
- })+ #' @param alpha (`integer(1)` or `integer(3)`) optional, specifies point opacity. |
|
| 605 | +29 |
-
+ #' - When the length of `alpha` is one: the plot points will have a fixed opacity. |
|
| 606 | -! | +||
| 30 | +
- add_trend_line <- reactive({
+ #' - When the length of `alpha` is three: the plot points opacity are dynamically adjusted based on |
||
| 607 | -! | +||
| 31 | +
- smoothing_degree <- as.integer(input$smoothing_degree)+ #' vector of `value`, `min`, and `max`. |
||
| 608 | -! | +||
| 32 | +
- trend_line_is_applicable() && length(smoothing_degree) > 0+ #' @param size (`integer(1)` or `integer(3)`) optional, specifies point size. |
||
| 609 | +33 |
- })+ #' - When the length of `size` is one: the plot point sizes will have a fixed size. |
|
| 610 | +34 |
-
+ #' - When the length of `size` is three: the plot points size are dynamically adjusted based on |
|
| 611 | -! | +||
| 35 | +
- if (!is.null(color_by)) {
+ #' vector of `value`, `min`, and `max`. |
||
| 612 | -! | +||
| 36 | +
- observeEvent(+ #' |
||
| 613 | -! | +||
| 37 | +
- eventExpr = merged$anl_input_r()$columns_source$color_by,+ #' @return Object of class `teal_module` to be used in `teal` applications. |
||
| 614 | -! | +||
| 38 | +
- handlerExpr = {
+ #' |
||
| 615 | -! | +||
| 39 | +
- color_by_var <- as.vector(merged$anl_input_r()$columns_source$color_by)+ #' @name shared_params |
||
| 616 | -! | +||
| 40 | +
- if (length(color_by_var) > 0) {
+ #' @keywords internal |
||
| 617 | -! | +||
| 41 | +
- shinyjs::hide("color")
+ NULL |
||
| 618 | +42 |
- } else {
+
|
|
| 619 | -! | +||
| 43 | +
- shinyjs::show("color")
+ #' Add labels for facets to a `ggplot2` object |
||
| 620 | +44 |
- }+ #' |
|
| 621 | +45 |
- }+ #' Enhances a `ggplot2` plot by adding labels that describe |
|
| 622 | +46 |
- )+ #' the faceting variables along the x and y axes. |
|
| 623 | +47 |
- }+ #' |
|
| 624 | +48 |
-
+ #' @param p (`ggplot2`) object to which facet labels will be added. |
|
| 625 | -! | +||
| 49 | +
- output$num_na_removed <- renderUI({
+ #' @param xfacet_label (`character`) Label for the facet along the x-axis. |
||
| 626 | -! | +||
| 50 | +
- if (add_trend_line()) {
+ #' If `NULL`, no label is added. If a vector, labels are joined with " & ". |
||
| 627 | -! | +||
| 51 | +
- ANL <- merged$anl_q_r()[["ANL"]]+ #' @param yfacet_label (`character`) Label for the facet along the y-axis. |
||
| 628 | -! | +||
| 52 | +
- x_var <- as.vector(merged$anl_input_r()$columns_source$x)+ #' Similar behavior to `xfacet_label`. |
||
| 629 | -! | +||
| 53 | +
- y_var <- as.vector(merged$anl_input_r()$columns_source$y)+ #' |
||
| 630 | -! | +||
| 54 | +
- if ((num_total_na <- nrow(ANL) - nrow(stats::na.omit(ANL[, c(x_var, y_var)]))) > 0) {
+ #' @return Returns `grid` or `grob` object (to be drawn with `grid.draw`) |
||
| 631 | -! | +||
| 55 | +
- tags$div(paste(num_total_na, "row(s) with missing values were removed"), tags$hr())+ #' |
||
| 632 | +56 |
- }+ #' @examples |
|
| 633 | +57 |
- }+ #' library(ggplot2) |
|
| 634 | +58 |
- })+ #' library(grid) |
|
| 635 | +59 |
-
+ #' |
|
| 636 | -! | +||
| 60 | +
- observeEvent(+ #' p <- ggplot(mtcars) + |
||
| 637 | -! | +||
| 61 | +
- eventExpr = merged$anl_input_r()$columns_source[c("col_facet", "row_facet")],
+ #' aes(x = mpg, y = disp) + |
||
| 638 | -! | +||
| 62 | +
- handlerExpr = {
+ #' geom_point() + |
||
| 639 | -! | +||
| 63 | +
- if (+ #' facet_grid(gear ~ cyl) |
||
| 640 | -! | +||
| 64 | +
- length(merged$anl_input_r()$columns_source$col_facet) == 0 &&+ #' |
||
| 641 | -! | +||
| 65 | +
- length(merged$anl_input_r()$columns_source$row_facet) == 0+ #' xfacet_label <- "cylinders" |
||
| 642 | +66 |
- ) {
+ #' yfacet_label <- "gear" |
|
| 643 | -! | +||
| 67 | +
- shinyjs::hide("free_scales")
+ #' res <- add_facet_labels(p, xfacet_label, yfacet_label) |
||
| 644 | +68 |
- } else {
+ #' grid.newpage() |
|
| 645 | -! | +||
| 69 | +
- shinyjs::show("free_scales")
+ #' grid.draw(res) |
||
| 646 | +70 |
- }+ #' |
|
| 647 | +71 |
- }+ #' grid.newpage() |
|
| 648 | +72 |
- )+ #' grid.draw(add_facet_labels(p, xfacet_label = NULL, yfacet_label)) |
|
| 649 | +73 |
-
+ #' grid.newpage() |
|
| 650 | -! | +||
| 74 | +
- output_q <- reactive({
+ #' grid.draw(add_facet_labels(p, xfacet_label, yfacet_label = NULL)) |
||
| 651 | -! | +||
| 75 | +
- teal::validate_inputs(iv_r(), iv_facet)+ #' grid.newpage() |
||
| 652 | +76 |
-
+ #' grid.draw(add_facet_labels(p, xfacet_label = NULL, yfacet_label = NULL)) |
|
| 653 | -! | +||
| 77 | +
- ANL <- merged$anl_q_r()[["ANL"]]+ #' |
||
| 654 | +78 |
-
+ #' @export |
|
| 655 | -! | +||
| 79 | +
- x_var <- as.vector(merged$anl_input_r()$columns_source$x)+ #' |
||
| 656 | -! | +||
| 80 | +
- y_var <- as.vector(merged$anl_input_r()$columns_source$y)+ add_facet_labels <- function(p, xfacet_label = NULL, yfacet_label = NULL) {
|
||
| 657 | +81 | ! |
- color_by_var <- as.vector(merged$anl_input_r()$columns_source$color_by)+ checkmate::assert_class(p, classes = "ggplot") |
| 658 | +82 | ! |
- size_by_var <- as.vector(merged$anl_input_r()$columns_source$size_by)+ checkmate::assert_character(xfacet_label, null.ok = TRUE, min.len = 1) |
| 659 | +83 | ! |
- row_facet_name <- if (length(merged$anl_input_r()$columns_source$row_facet) == 0) {
+ checkmate::assert_character(yfacet_label, null.ok = TRUE, min.len = 1) |
| 660 | +84 | ! |
- character(0)- |
-
| 661 | -- |
- } else {
+ if (is.null(xfacet_label) && is.null(yfacet_label)) {
|
|
| 662 | +85 | ! |
- as.vector(merged$anl_input_r()$columns_source$row_facet)+ return(ggplotGrob(p)) |
| 663 | +86 |
- }+ } |
|
| 664 | +87 | ! |
- col_facet_name <- if (length(merged$anl_input_r()$columns_source$col_facet) == 0) {
+ grid::grid.grabExpr({
|
| 665 | +88 | ! |
- character(0)+ g <- ggplotGrob(p) |
| 666 | +89 |
- } else {
- |
- |
| 667 | -! | -
- as.vector(merged$anl_input_r()$columns_source$col_facet)+ |
|
| 668 | +90 |
- }- |
- |
| 669 | -! | -
- alpha <- input$alpha- |
- |
| 670 | -! | -
- size <- input$size+ # we are going to replace these, so we make sure they have nothing in them |
|
| 671 | +91 | ! |
- rotate_xaxis_labels <- input$rotate_xaxis_labels+ checkmate::assert_class(g$grobs[[grep("xlab-t", g$layout$name, fixed = TRUE)]], "zeroGrob")
|
| 672 | +92 | ! |
- add_density <- input$add_density+ checkmate::assert_class(g$grobs[[grep("ylab-r", g$layout$name, fixed = TRUE)]], "zeroGrob")
|
| 673 | -! | +||
| 93 | +
- ggtheme <- input$ggtheme+ |
||
| 674 | +94 | ! |
- rug_plot <- input$rug_plot+ xaxis_label_grob <- g$grobs[[grep("xlab-b", g$layout$name, fixed = TRUE)]]
|
| 675 | +95 | ! |
- color <- input$color+ xaxis_label_grob$children[[1]]$label <- paste(xfacet_label, collapse = " & ") |
| 676 | +96 | ! |
- shape <- `if`(is.null(input$shape) || identical(input$shape, ""), "circle", input$shape)+ yaxis_label_grob <- g$grobs[[grep("ylab-l", g$layout$name, fixed = TRUE)]]
|
| 677 | +97 | ! |
- smoothing_degree <- as.integer(input$smoothing_degree)+ yaxis_label_grob$children[[1]]$label <- paste(yfacet_label, collapse = " & ") |
| 678 | +98 | ! |
- ci <- input$ci+ yaxis_label_grob$children[[1]]$rot <- 270 |
| 679 | +99 | ||
| 680 | +100 | ! |
- log_x <- input$log_x+ top_height <- if (is.null(xfacet_label)) 0 else grid::unit(2, "line") |
| 681 | +101 | ! |
- log_y <- input$log_y+ right_width <- if (is.null(yfacet_label)) 0 else grid::unit(2, "line") |
| 682 | +102 | ||
| 683 | +103 | ! |
- validate(need(+ grid::grid.newpage() |
| 684 | +104 | ! |
- length(row_facet_name) == 0 || inherits(ANL[[row_facet_name]], c("character", "factor", "Date", "integer")),
+ grid::pushViewport(grid::plotViewport(margins = c(0, 0, top_height, right_width), name = "ggplot")) |
| 685 | +105 | ! |
- "`Row facetting` variable must be of class `character`, `factor`, `Date`, or `integer`"+ grid::grid.draw(g)+ |
+
| 106 | +! | +
+ grid::upViewport(1) |
|
| 686 | +107 |
- ))+ |
|
| 687 | -! | +||
| 108 | +
- validate(need(+ # draw x facet |
||
| 688 | +109 | ! |
- length(col_facet_name) == 0 || inherits(ANL[[col_facet_name]], c("character", "factor", "Date", "integer")),
+ if (!is.null(xfacet_label)) {
|
| 689 | +110 | ! |
- "`Column facetting` variable must be of class `character`, `factor`, `Date`, or `integer`"- |
-
| 690 | -- |
- ))- |
- |
| 691 | -- |
-
+ grid::pushViewport(grid::viewport( |
|
| 692 | +111 | ! |
- if (add_density && length(color_by_var) > 0) {
+ x = 0, y = grid::unit(1, "npc") - top_height, width = grid::unit(1, "npc"), |
| 693 | +112 | ! |
- validate(need(+ height = top_height, just = c("left", "bottom"), name = "topxaxis"
|
| 694 | -! | +||
| 113 | +
- !is.numeric(ANL[[color_by_var]]),+ )) |
||
| 695 | +114 | ! |
- "Marginal plots cannot be produced when the points are colored by numeric variables.+ grid::grid.draw(xaxis_label_grob) |
| 696 | +115 | ! |
- \n Uncheck the 'Add marginal density' checkbox to display the plot."+ grid::upViewport(1) |
| 697 | +116 |
- ))+ } |
|
| 698 | -! | +||
| 117 | +
- validate(need(+ |
||
| 699 | +118 |
- !(+ # draw y facet |
|
| 700 | +119 | ! |
- inherits(ANL[[color_by_var]], "Date") ||+ if (!is.null(yfacet_label)) {
|
| 701 | +120 | ! |
- inherits(ANL[[color_by_var]], "POSIXct") ||+ grid::pushViewport(grid::viewport( |
| 702 | +121 | ! |
- inherits(ANL[[color_by_var]], "POSIXlt")+ x = grid::unit(1, "npc") - grid::unit(as.numeric(right_width) / 2, "line"), y = 0, width = right_width,+ |
+
| 122 | +! | +
+ height = grid::unit(1, "npc"), just = c("left", "bottom"), name = "rightyaxis"
|
|
| 703 | +123 |
- ),+ )) |
|
| 704 | +124 | ! |
- "Marginal plots cannot be produced when the points are colored by Date or POSIX variables.+ grid::grid.draw(yaxis_label_grob) |
| 705 | +125 | ! |
- \n Uncheck the 'Add marginal density' checkbox to display the plot."+ grid::upViewport(1) |
| 706 | +126 |
- ))+ } |
|
| 707 | +127 |
- }+ }) |
|
| 708 | +128 | - - | -|
| 709 | -! | -
- teal::validate_has_data(ANL[, c(x_var, y_var)], 10, complete = TRUE, allow_inf = FALSE)+ } |
|
| 710 | +129 | ||
| 711 | -! | +||
| 130 | +
- if (log_x) {
+ #' Call a function with a character vector for the `...` argument |
||
| 712 | -! | +||
| 131 | +
- validate(+ #' |
||
| 713 | -! | +||
| 132 | +
- need(+ #' @param fun (`character`) Name of a function where the `...` argument shall be replaced by values from `str_args`. |
||
| 714 | -! | +||
| 133 | +
- is.numeric(ANL[[x_var]]) && all(+ #' @param str_args (`character`) A character vector that the function shall be executed with |
||
| 715 | -! | +||
| 134 | +
- ANL[[x_var]] > 0 | is.na(ANL[[x_var]])+ #' |
||
| 716 | +135 |
- ),+ #' @return |
|
| 717 | -! | +||
| 136 | +
- "X variable can only be log transformed if variable is numeric and all values are positive."+ #' Value of call to `fun` with arguments specified in `str_args`. |
||
| 718 | +137 |
- )+ #' |
|
| 719 | +138 |
- )+ #' @keywords internal |
|
| 720 | +139 |
- }+ call_fun_dots <- function(fun, str_args) {
|
|
| 721 | +140 | ! |
- if (log_y) {
+ do.call("call", c(list(fun), lapply(str_args, as.name)), quote = TRUE)
|
| 722 | -! | +||
| 141 | +
- validate(+ } |
||
| 723 | -! | +||
| 142 | +
- need(+ |
||
| 724 | -! | +||
| 143 | +
- is.numeric(ANL[[y_var]]) && all(+ #' Generate a string for a variable including its label |
||
| 725 | -! | +||
| 144 | +
- ANL[[y_var]] > 0 | is.na(ANL[[y_var]])+ #' |
||
| 726 | +145 |
- ),+ #' @param var_names (`character`) Name of variable to extract labels from. |
|
| 727 | -! | +||
| 146 | +
- "Y variable can only be log transformed if variable is numeric and all values are positive."+ #' @param dataset (`dataset`) Name of analysis dataset. |
||
| 728 | +147 |
- )+ #' @param prefix,suffix (`character`) String to paste to the beginning/end of the variable name with label. |
|
| 729 | +148 |
- )+ #' @param wrap_width (`numeric`) Number of characters to wrap original label to. Defaults to 80. |
|
| 730 | +149 |
- }+ #' |
|
| 731 | +150 |
-
+ #' @return (`character`) String with variable name and label. |
|
| 732 | -! | +||
| 151 | +
- facet_cl <- facet_ggplot_call(+ #' |
||
| 733 | -! | +||
| 152 | +
- row_facet_name,+ #' @keywords internal |
||
| 734 | -! | +||
| 153 | +
- col_facet_name,+ #' |
||
| 735 | -! | +||
| 154 | +
- free_x_scales = isTRUE(input$free_scales),+ varname_w_label <- function(var_names, |
||
| 736 | -! | +||
| 155 | +
- free_y_scales = isTRUE(input$free_scales)+ dataset, |
||
| 737 | +156 |
- )+ wrap_width = 80, |
|
| 738 | +157 |
-
+ prefix = NULL, |
|
| 739 | -! | +||
| 158 | +
- point_sizes <- if (length(size_by_var) > 0) {
+ suffix = NULL) {
|
||
| 740 | +159 | ! |
- validate(need(is.numeric(ANL[[size_by_var]]), "Variable to size by must be numeric"))+ add_label <- function(var_names) {
|
| 741 | +160 | ! |
- substitute(+ label <- vapply( |
| 742 | +161 | ! |
- expr = size * ANL[[size_by_var]] / max(ANL[[size_by_var]], na.rm = TRUE),+ dataset[var_names], function(x) {
|
| 743 | +162 | ! |
- env = list(size = size, size_by_var = size_by_var)+ attr_label <- attr(x, "label") |
| 744 | -+ | ||
| 163 | +! |
- )+ `if`(is.null(attr_label), "", attr_label) |
|
| 745 | +164 |
- } else {
+ }, |
|
| 746 | +165 | ! |
- size+ character(1) |
| 747 | +166 |
- }+ ) |
|
| 748 | +167 | ||
| 749 | +168 | ! |
- plot_q <- merged$anl_q_r()+ if (length(label) == 1 && !is.na(label) && !identical(label, "")) {
+ |
+
| 169 | +! | +
+ paste0(prefix, label, " [", var_names, "]", suffix) |
|
| 750 | +170 |
-
+ } else {
|
|
| 751 | +171 | ! |
- if (log_x) {
+ var_names |
| 752 | -! | +||
| 172 | +
- log_x_fn <- input$log_x_base+ } |
||
| 753 | -! | +||
| 173 | +
- plot_q <- teal.code::eval_code(+ } |
||
| 754 | -! | +||
| 174 | +
- object = plot_q,+ |
||
| 755 | +175 | ! |
- code = substitute(+ if (length(var_names) < 1) {
|
| 756 | +176 | ! |
- expr = ANL[, log_x_var] <- log_x_fn(ANL[, x_var]),+ NULL |
| 757 | +177 | ! |
- env = list(+ } else if (length(var_names) == 1) {
|
| 758 | +178 | ! |
- x_var = x_var,+ stringr::str_wrap(add_label(var_names), width = wrap_width) |
| 759 | +179 | ! |
- log_x_fn = as.name(log_x_fn),+ } else if (length(var_names) > 1) {
|
| 760 | +180 | ! |
- log_x_var = paste0(log_x_fn, "_", x_var)+ stringr::str_wrap(vapply(var_names, add_label, character(1)), width = wrap_width) |
| 761 | +181 |
- )+ } |
|
| 762 | +182 |
- )+ } |
|
| 763 | +183 |
- )+ |
|
| 764 | +184 |
- }+ # see vignette("ggplot2-specs", package="ggplot2")
|
|
| 765 | +185 |
-
+ shape_names <- c( |
|
| 766 | -! | +||
| 186 | +
- if (log_y) {
+ "circle", paste("circle", c("open", "filled", "cross", "plus", "small")), "bullet",
|
||
| 767 | -! | +||
| 187 | +
- log_y_fn <- input$log_y_base+ "square", paste("square", c("open", "filled", "cross", "plus", "triangle")),
|
||
| 768 | -! | +||
| 188 | +
- plot_q <- teal.code::eval_code(+ "diamond", paste("diamond", c("open", "filled", "plus")),
|
||
| 769 | -! | +||
| 189 | +
- object = plot_q,+ "triangle", paste("triangle", c("open", "filled", "square")),
|
||
| 770 | -! | +||
| 190 | +
- code = substitute(+ paste("triangle down", c("open", "filled")),
|
||
| 771 | -! | +||
| 191 | +
- expr = ANL[, log_y_var] <- log_y_fn(ANL[, y_var]),+ "plus", "cross", "asterisk" |
||
| 772 | -! | +||
| 192 | +
- env = list(+ ) |
||
| 773 | -! | +||
| 193 | +
- y_var = y_var,+ |
||
| 774 | -! | +||
| 194 | +
- log_y_fn = as.name(log_y_fn),+ #' Get icons to represent variable types in dataset |
||
| 775 | -! | +||
| 195 | +
- log_y_var = paste0(log_y_fn, "_", y_var)+ #' |
||
| 776 | +196 |
- )+ #' @param var_type (`character`) of R internal types (classes). |
|
| 777 | +197 |
- )+ #' @return (`character`) vector of HTML icons corresponding to data type in each column. |
|
| 778 | +198 |
- )+ #' @keywords internal |
|
| 779 | +199 |
- }+ variable_type_icons <- function(var_type) {
+ |
+ |
| 200 | +! | +
+ checkmate::assert_character(var_type, any.missing = FALSE) |
|
| 780 | +201 | ||
| 781 | +202 | ! |
- pre_pro_anl <- if (input$show_count) {
+ class_to_icon <- list( |
| 782 | +203 | +! | +
+ numeric = "arrow-up-1-9",+ |
+
| 204 | ! |
- paste0(+ integer = "arrow-up-1-9", |
|
| 783 | +205 | ! |
- "ANL %>% dplyr::group_by(",
+ logical = "pause", |
| 784 | +206 | ! |
- paste(+ Date = "calendar", |
| 785 | +207 | ! |
- c(+ POSIXct = "calendar", |
| 786 | +208 | ! |
- if (length(color_by_var) > 0 && inherits(ANL[[color_by_var]], c("factor", "character"))) color_by_var,
+ POSIXlt = "calendar", |
| 787 | +209 | ! |
- row_facet_name,+ factor = "chart-bar", |
| 788 | +210 | ! |
- col_facet_name+ character = "keyboard", |
| 789 | -+ | ||
| 211 | +! |
- ),+ primary_key = "key", |
|
| 790 | +212 | ! |
- collapse = ", "+ unknown = "circle-question" |
| 791 | +213 |
- ),+ ) |
|
| 792 | +214 | ! |
- ") %>% dplyr::mutate(n = dplyr::n()) %>% dplyr::ungroup()"+ class_to_icon <- lapply(class_to_icon, function(icon_name) toString(icon(icon_name, lib = "font-awesome"))) |
| 793 | +215 |
- )+ |
|
| 794 | -+ | ||
| 216 | +! |
- } else {
+ unname(vapply( |
|
| 795 | +217 | ! |
- "ANL"+ var_type, |
| 796 | -+ | ||
| 218 | +! |
- }+ FUN.VALUE = character(1), |
|
| 797 | -+ | ||
| 219 | +! |
-
+ FUN = function(class) {
|
|
| 798 | +220 | ! |
- plot_call <- substitute(expr = pre_pro_anl %>% ggplot(), env = list(pre_pro_anl = str2lang(pre_pro_anl)))+ if (class == "") {
|
| 799 | -+ | ||
| 221 | +! |
-
+ class |
|
| 800 | +222 | ! |
- plot_call <- if (length(color_by_var) == 0) {
+ } else if (is.null(class_to_icon[[class]])) {
|
| 801 | +223 | ! |
- substitute(+ class_to_icon[["unknown"]] |
| 802 | -! | +||
| 224 | +
- expr = plot_call ++ } else {
|
||
| 803 | +225 | ! |
- ggplot2::aes(x = x_name, y = y_name) ++ class_to_icon[[class]] |
| 804 | -! | +||
| 226 | +
- ggplot2::geom_point(alpha = alpha_value, size = point_sizes, shape = shape_value, color = color_value),+ } |
||
| 805 | -! | +||
| 227 | +
- env = list(+ } |
||
| 806 | -! | +||
| 228 | +
- plot_call = plot_call,+ )) |
||
| 807 | -! | +||
| 229 | +
- x_name = if (log_x) as.name(paste0(log_x_fn, "_", x_var)) else as.name(x_var),+ } |
||
| 808 | -! | +||
| 230 | +
- y_name = if (log_y) as.name(paste0(log_y_fn, "_", y_var)) else as.name(y_var),+ |
||
| 809 | -! | +||
| 231 | +
- alpha_value = alpha,+ #' Include `CSS` files from `/inst/css/` package directory to application header |
||
| 810 | -! | +||
| 232 | +
- point_sizes = point_sizes,+ #' |
||
| 811 | -! | +||
| 233 | +
- shape_value = shape,+ #' `system.file` should not be used to access files in other packages, it does |
||
| 812 | -! | +||
| 234 | +
- color_value = color+ #' not work with `devtools`. Therefore, we redefine this method in each package |
||
| 813 | +235 |
- )+ #' as needed. Thus, we do not export this method |
|
| 814 | +236 |
- )+ #' |
|
| 815 | +237 |
- } else {
+ #' @param pattern (`character`) optional, regular expression to match the file names to be included. |
|
| 816 | -! | +||
| 238 | +
- substitute(+ #' |
||
| 817 | -! | +||
| 239 | +
- expr = plot_call ++ #' @return HTML code that includes `CSS` files. |
||
| 818 | -! | +||
| 240 | +
- ggplot2::aes(x = x_name, y = y_name, color = color_by_var_name) ++ #' @keywords internal |
||
| 819 | -! | +||
| 241 | +
- ggplot2::geom_point(alpha = alpha_value, size = point_sizes, shape = shape_value),+ #' |
||
| 820 | -! | +||
| 242 | +
- env = list(+ include_css_files <- function(pattern = "*") {
|
||
| 821 | +243 | ! |
- plot_call = plot_call,+ css_files <- list.files( |
| 822 | +244 | ! |
- x_name = if (log_x) as.name(paste0(log_x_fn, "_", x_var)) else as.name(x_var),+ system.file("css", package = "teal.modules.general", mustWork = TRUE),
|
| 823 | +245 | ! |
- y_name = if (log_y) as.name(paste0(log_y_fn, "_", y_var)) else as.name(y_var),+ pattern = pattern, full.names = TRUE |
| 824 | -! | +||
| 246 | +
- color_by_var_name = as.name(color_by_var),+ ) |
||
| 825 | +247 | ! |
- alpha_value = alpha,+ if (length(css_files) == 0) {
|
| 826 | +248 | ! |
- point_sizes = point_sizes,+ return(NULL)+ |
+
| 249 | ++ |
+ } |
|
| 827 | +250 | ! |
- shape_value = shape+ singleton(tags$head(lapply(css_files, includeCSS))) |
| 828 | +251 |
- )+ } |
|
| 829 | +252 |
- )+ |
|
| 830 | +253 |
- }+ #' JavaScript condition to check if a specific tab is active |
|
| 831 | +254 |
-
+ #' |
|
| 832 | -! | +||
| 255 | +
- if (rug_plot) plot_call <- substitute(expr = plot_call + geom_rug(), env = list(plot_call = plot_call))+ #' @param id (`character(1)`) the id of the tab panel with tabs. |
||
| 833 | +256 |
-
+ #' @param name (`character(1)`) the name of the tab. |
|
| 834 | -! | +||
| 257 | +
- plot_label_generator <- function(rhs_formula = quote(y ~ 1),+ #' @return JavaScript expression to be used in `shiny::conditionalPanel()` to determine |
||
| 835 | -! | +||
| 258 | +
- show_form = input$show_form,+ #' if the specified tab is active. |
||
| 836 | -! | +||
| 259 | +
- show_r2 = input$show_r2,+ #' @keywords internal |
||
| 837 | -! | +||
| 260 | +
- show_count = input$show_count,+ #' |
||
| 838 | -! | +||
| 261 | +
- pos = input$pos,+ is_tab_active_js <- function(id, name) {
|
||
| 839 | -! | +||
| 262 | +
- label_size = input$label_size) {
+ # supporting the bs3 and higher version at the same time |
||
| 840 | +263 | ! |
- stopifnot(sum(show_form, show_r2, show_count) >= 1)+ sprintf( |
| 841 | +264 | ! |
- aes_label <- paste0(+ "$(\"#%1$s > li.active\").text().trim() == '%2$s' || $(\"#%1$s > li a.active\").text().trim() == '%2$s'", |
| 842 | +265 | ! |
- "aes(",
+ id, name |
| 843 | -! | +||
| 266 | +
- if (show_count) "n = n, ",+ ) |
||
| 844 | -! | +||
| 267 | +
- "label = ",+ } |
||
| 845 | -! | +||
| 268 | +
- if (sum(show_form, show_r2, show_count) > 1) "paste(",
+
|
||
| 846 | -! | +||
| 269 | +
- paste(+ #' Assert single selection on `data_extract_spec` object |
||
| 847 | -! | +||
| 270 | +
- c(+ #' Helper to reduce code in assertions |
||
| 848 | -! | +||
| 271 | +
- if (show_form) "stat(eq.label)",+ #' @noRd |
||
| 849 | -! | +||
| 272 | +
- if (show_r2) "stat(adj.rr.label)",+ #' |
||
| 850 | -! | +||
| 273 | +
- if (show_count) "paste('N ~`=`~', n)"
+ assert_single_selection <- function(x, |
||
| 851 | +274 |
- ),+ .var.name = checkmate::vname(x)) { # nolint: object_name.
|
|
| 852 | -! | +||
| 275 | +104x |
- collapse = ", "+ if (any(vapply(x, function(.x) .x$select$multiple, logical(1)))) {
+ |
+ |
| 276 | +4x | +
+ stop("'", .var.name, "' should not allow multiple selection")
|
|
| 853 | +277 |
- ),+ } |
|
| 854 | -! | +||
| 278 | +100x |
- if (sum(show_form, show_r2, show_count) > 1) ", sep = '*\", \"*'))" else ")"+ invisible(TRUE) |
|
| 855 | +279 |
- )+ } |
|
| 856 | -! | +||
| 280 | +
- label_geom <- substitute(+ |
||
| 857 | -! | +||
| 281 | +
- expr = ggpmisc::stat_poly_eq(+ #' Wrappers around `srv_transform_teal_data` that allows to decorate the data |
||
| 858 | -! | +||
| 282 | +
- mapping = aes_label,+ #' @inheritParams teal::srv_transform_teal_data |
||
| 859 | -! | +||
| 283 | +
- formula = rhs_formula,+ #' @param expr (`expression` or `reactive`) to evaluate on the output of the decoration. |
||
| 860 | -! | +||
| 284 | +
- parse = TRUE,+ #' When an expression it must be inline code. See [within()] |
||
| 861 | -! | +||
| 285 | ++ |
+ #' Default is `NULL` which won't evaluate any appending code.+ |
+ |
| 286 | +
- label.x = pos,+ #' @param expr_is_reactive (`logical(1)`) whether `expr` is a reactive expression |
||
| 862 | -! | +||
| 287 | +
- size = label_size+ #' that skips defusing the argument. |
||
| 863 | +288 |
- ),+ #' @details |
|
| 864 | -! | +||
| 289 | +
- env = list(+ #' `srv_decorate_teal_data` is a wrapper around `srv_transform_teal_data` that |
||
| 865 | -! | +||
| 290 | +
- rhs_formula = rhs_formula,+ #' allows to decorate the data with additional expressions. |
||
| 866 | -! | +||
| 291 | +
- pos = pos,+ #' When original `teal_data` object is in error state, it will show that error |
||
| 867 | -! | +||
| 292 | +
- aes_label = str2lang(aes_label),+ #' first. |
||
| 868 | -! | +||
| 293 | +
- label_size = label_size+ #' |
||
| 869 | +294 |
- )+ #' @keywords internal |
|
| 870 | +295 |
- )+ srv_decorate_teal_data <- function(id, data, decorators, expr, expr_is_reactive = FALSE) {
|
|
| 871 | +296 | ! |
- substitute(+ checkmate::assert_class(data, classes = "reactive") |
| 872 | +297 | ! |
- expr = plot_call + label_geom,+ checkmate::assert_list(decorators, "teal_transform_module") |
| 873 | +298 | ! |
- env = list(+ checkmate::assert_flag(expr_is_reactive) |
| 874 | -! | +||
| 299 | +
- plot_call = plot_call,+ |
||
| 875 | +300 | ! |
- label_geom = label_geom+ missing_expr <- missing(expr) |
| 876 | -+ | ||
| 301 | +! |
- )+ if (!missing_expr && !expr_is_reactive) {
|
|
| 877 | -+ | ||
| 302 | +! |
- )+ expr <- rlang::enexpr(expr) |
|
| 878 | +303 |
- }+ } |
|
| 879 | +304 | ||
| 880 | +305 | ! |
- if (trend_line_is_applicable()) {
+ moduleServer(id, function(input, output, session) {
|
| 881 | +306 | ! |
- shinyjs::hide("line_msg")
+ decorated_output <- srv_transform_teal_data("inner", data = data, transformators = decorators)
|
| 882 | -! | +||
| 307 | +
- shinyjs::show("smoothing_degree")
+
|
||
| 883 | +308 | ! |
- if (!add_trend_line()) {
+ reactive({
|
| 884 | -! | +||
| 309 | +
- shinyjs::hide("ci")
+ # ensure original errors are displayed and `eval_code` is never executed with NULL |
||
| 885 | +310 | ! |
- shinyjs::hide("color_sub")
+ req(data(), decorated_output()) |
| 886 | +311 | ! |
- shinyjs::hide("show_form")
+ if (missing_expr) {
|
| 887 | +312 | ! |
- shinyjs::hide("show_r2")
+ decorated_output() |
| 888 | +313 | ! |
- if (input$show_count) {
+ } else if (expr_is_reactive) {
|
| 889 | +314 | ! |
- plot_call <- plot_label_generator(show_form = FALSE, show_r2 = FALSE)+ teal.code::eval_code(decorated_output(), expr()) |
| 890 | -! | +||
| 315 | +
- shinyjs::show("label_pos")
+ } else {
|
||
| 891 | +316 | ! |
- shinyjs::show("label_size")
+ teal.code::eval_code(decorated_output(), expr) |
| 892 | +317 |
- } else {
+ } |
|
| 893 | -! | +||
| 318 | +
- shinyjs::hide("label_pos")
+ }) |
||
| 894 | -! | +||
| 319 | +
- shinyjs::hide("label_size")
+ }) |
||
| 895 | +320 |
- }+ } |
|
| 896 | +321 |
- } else {
+
|
|
| 897 | -! | +||
| 322 | +
- shinyjs::show("ci")
+ #' @rdname srv_decorate_teal_data |
||
| 898 | -! | +||
| 323 | +
- shinyjs::show("show_form")
+ #' @details |
||
| 899 | -! | +||
| 324 | +
- shinyjs::show("show_r2")
+ #' `ui_decorate_teal_data` is a wrapper around `ui_transform_teal_data`. |
||
| 900 | -! | +||
| 325 | +
- if (nrow(ANL) - nrow(stats::na.omit(ANL[, c(x_var, y_var)])) > 0) {
+ #' @keywords internal |
||
| 901 | -! | +||
| 326 | +
- plot_q <- teal.code::eval_code(+ ui_decorate_teal_data <- function(id, decorators, ...) {
|
||
| 902 | +327 | ! |
- plot_q,+ teal::ui_transform_teal_data(NS(id, "inner"), transformators = decorators, ...) |
| 903 | -! | +||
| 328 | +
- substitute(+ } |
||
| 904 | -! | +||
| 329 | +
- expr = ANL <- dplyr::filter(ANL, !is.na(x_var) & !is.na(y_var)),+ |
||
| 905 | -! | +||
| 330 | +
- env = list(x_var = as.name(x_var), y_var = as.name(y_var))+ #' Internal function to check if decorators is a valid object |
||
| 906 | +331 |
- )+ #' @noRd |
|
| 907 | +332 |
- )+ check_decorators <- function(x, names = NULL, null.ok = FALSE) { # nolint: object_name.
+ |
+ |
| 333 | +5x | +
+ checkmate::qassert(null.ok, "B1") |
|
| 908 | +334 |
- }+ |
|
| 909 | -! | +||
| 335 | +5x |
- rhs_formula <- substitute(+ check_message <- checkmate::check_list( |
|
| 910 | -! | +||
| 336 | +5x |
- expr = y ~ poly(x, smoothing_degree, raw = TRUE),+ x, |
|
| 911 | -! | +||
| 337 | +5x |
- env = list(smoothing_degree = smoothing_degree)+ null.ok = null.ok,+ |
+ |
| 338 | +5x | +
+ names = "named" |
|
| 912 | +339 |
- )+ ) |
|
| 913 | -! | +||
| 340 | +
- if (input$show_form || input$show_r2 || input$show_count) {
+
|
||
| 914 | -! | +||
| 341 | +5x |
- plot_call <- plot_label_generator(rhs_formula = rhs_formula)+ if (!is.null(names)) {
|
|
| 915 | -! | +||
| 342 | +5x |
- shinyjs::show("label_pos")
+ check_message <- if (isTRUE(check_message)) {
|
|
| 916 | -! | +||
| 343 | +5x |
- shinyjs::show("label_size")
+ out_message <- checkmate::check_names(names(x), subset.of = c("default", names))
|
|
| 917 | +344 |
- } else {
+ # see https://github.com/insightsengineering/teal.logger/issues/101 |
|
| 918 | -! | +||
| 345 | +5x |
- shinyjs::hide("label_pos")
+ if (isTRUE(out_message)) {
|
|
| 919 | -! | +||
| 346 | +5x |
- shinyjs::hide("label_size")
+ out_message |
|
| 920 | +347 |
- }+ } else {
|
|
| 921 | +348 | ! |
- plot_call <- substitute(+ gsub("\\{", "(", gsub("\\}", ")", out_message))
|
| 922 | -! | +||
| 349 | +
- expr = plot_call + ggplot2::geom_smooth(formula = rhs_formula, se = TRUE, level = ci, method = "lm"),+ }+ |
+ ||
| 350 | ++ |
+ } else {
|
|
| 923 | +351 | ! |
- env = list(plot_call = plot_call, rhs_formula = rhs_formula, ci = ci)+ check_message |
| 924 | +352 |
- )+ } |
|
| 925 | +353 |
- }+ } |
|
| 926 | +354 |
- } else {
+
|
|
| 927 | -! | +||
| 355 | +5x |
- shinyjs::hide("smoothing_degree")
+ if (!isTRUE(check_message)) {
|
|
| 928 | +356 | ! |
- shinyjs::hide("ci")
+ return(check_message) |
| 929 | -! | +||
| 357 | +
- shinyjs::hide("color_sub")
+ } |
||
| 930 | -! | +||
| 358 | +
- shinyjs::hide("show_form")
+
|
||
| 931 | -! | +||
| 359 | +5x |
- shinyjs::hide("show_r2")
+ valid_elements <- vapply( |
|
| 932 | -! | +||
| 360 | +5x |
- if (input$show_count) {
+ x, |
|
| 933 | -! | +||
| 361 | +5x |
- plot_call <- plot_label_generator(show_form = FALSE, show_r2 = FALSE)+ checkmate::test_list, |
|
| 934 | -! | +||
| 362 | +5x |
- shinyjs::show("label_pos")
+ types = "teal_transform_module", |
|
| 935 | -! | +||
| 363 | +5x |
- shinyjs::show("label_size")
+ null.ok = TRUE,+ |
+ |
| 364 | +5x | +
+ FUN.VALUE = logical(1L) |
|
| 936 | +365 |
- } else {
+ ) |
|
| 937 | -! | +||
| 366 | +
- shinyjs::hide("label_pos")
+
|
||
| 938 | -! | +||
| 367 | +5x | +
+ if (all(valid_elements)) {
+ |
+ |
| 368 | +5x | +
+ return(TRUE)+ |
+ |
| 369 | +
- shinyjs::hide("label_size")
+ } |
||
| 939 | +370 |
- }+ |
|
| 940 | +371 | ! |
- shinyjs::show("line_msg")
+ "May only contain the type 'teal_transform_module' or a named list of 'teal_transform_module'." |
| 941 | +372 |
- }+ } |
|
| 942 | +373 | ||
| 943 | -! | +||
| 374 | +
- if (!is.null(facet_cl)) {
+ #' Internal assertion on decorators |
||
| 944 | -! | +||
| 375 | +
- plot_call <- substitute(expr = plot_call + facet_cl, env = list(plot_call = plot_call, facet_cl = facet_cl))+ #' @noRd |
||
| 945 | +376 |
- }+ assert_decorators <- checkmate::makeAssertionFunction(check_decorators) |
|
| 946 | +377 | ||
| 947 | -! | -
- y_label <- varname_w_label(- |
- |
| 948 | -! | +||
| 378 | +
- y_var,+ #' Subset decorators based on the scope |
||
| 949 | -! | +||
| 379 | +
- ANL,+ #' |
||
| 950 | -! | +||
| 380 | +
- prefix = if (log_y) paste(log_y_fn, "(") else NULL,
+ #' `default` is a protected decorator name that is always included in the output, |
||
| 951 | -! | +||
| 381 | +
- suffix = if (log_y) ")" else NULL+ #' if it exists |
||
| 952 | +382 |
- )+ #' |
|
| 953 | -! | +||
| 383 | +
- x_label <- varname_w_label(+ #' @param scope (`character`) a character vector of decorator names to include. |
||
| 954 | -! | +||
| 384 | +
- x_var,+ #' @param decorators (named `list`) of list decorators to subset. |
||
| 955 | -! | +||
| 385 | +
- ANL,+ #' |
||
| 956 | -! | +||
| 386 | +
- prefix = if (log_x) paste(log_x_fn, "(") else NULL,
+ #' @return A flat list with all decorators to include. |
||
| 957 | -! | +||
| 387 | +
- suffix = if (log_x) ")" else NULL+ #' It can be an empty list if none of the scope exists in `decorators` argument. |
||
| 958 | +388 |
- )+ #' @keywords internal |
|
| 959 | +389 |
-
+ select_decorators <- function(decorators, scope) {
|
|
| 960 | +390 | ! |
- dev_ggplot2_args <- teal.widgets::ggplot2_args(+ checkmate::assert_character(scope, null.ok = TRUE) |
| 961 | +391 | ! |
- labs = list(y = y_label, x = x_label),+ scope <- intersect(union("default", scope), names(decorators))
|
| 962 | +392 | ! |
- theme = list(legend.position = "bottom")+ c(list(), unlist(decorators[scope], recursive = FALSE)) |
| 963 | +393 |
- )+ } |
|
| 964 | +394 | ||
| 965 | -! | -
- if (rotate_xaxis_labels) {
- |
- |
| 966 | -! | -
- dev_ggplot2_args$theme[["axis.text.x"]] <- quote(element_text(angle = 45, hjust = 1))- |
- |
| 967 | +395 |
- }+ #' Convert flat list of `teal_transform_module` to named lists |
|
| 968 | +396 | - - | -|
| 969 | -! | -
- all_ggplot2_args <- teal.widgets::resolve_ggplot2_args(- |
- |
| 970 | -! | -
- user_plot = ggplot2_args,- |
- |
| 971 | -! | -
- module_plot = dev_ggplot2_args+ #' |
|
| 972 | +397 |
- )+ #' @param decorators (list of `teal_transform_module`) to normalize. |
|
| 973 | +398 | - - | -|
| 974 | -! | -
- parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(all_ggplot2_args, ggtheme = ggtheme)+ #' @return A named list of lists with `teal_transform_module` objects. |
|
| 975 | +399 |
-
+ #' @keywords internal |
|
| 976 | +400 |
-
+ normalize_decorators <- function(decorators) {
|
|
| 977 | -! | +||
| 401 | +5x |
- if (add_density) {
+ if (checkmate::test_list(decorators, "teal_transform_module", null.ok = TRUE)) {
|
|
| 978 | -! | +||
| 402 | +5x |
- plot_call <- substitute(+ if (checkmate::test_names(names(decorators))) {
|
|
| 979 | +403 | ! |
- expr = ggExtra::ggMarginal(+ lapply(decorators, list) |
| 980 | -! | +||
| 404 | +
- plot_call + labs + ggthemes + themes,+ } else {
|
||
| 981 | -! | +||
| 405 | +5x |
- type = "density",+ list(default = decorators) |
|
| 982 | -! | +||
| 406 | +
- groupColour = group_colour+ } |
||
| 983 | +407 |
- ),+ } else {
|
|
| 984 | +408 | ! |
- env = list(+ decorators |
| 985 | -! | +||
| 409 | +
- plot_call = plot_call,+ } |
||
| 986 | -! | +||
| 410 | +
- group_colour = if (length(color_by_var) > 0) TRUE else FALSE,+ } |
||
| 987 | -! | +
| 1 | +
- labs = parsed_ggplot2_args$labs,+ #' `teal` module: Scatterplot matrix |
||
| 988 | -! | +||
| 2 | +
- ggthemes = parsed_ggplot2_args$ggtheme,+ #' |
||
| 989 | -! | +||
| 3 | +
- themes = parsed_ggplot2_args$theme+ #' Generates a scatterplot matrix from selected `variables` from datasets. |
||
| 990 | +4 |
- )+ #' Each plot within the matrix represents the relationship between two variables, |
|
| 991 | +5 |
- )+ #' providing the overview of correlations and distributions across selected data. |
|
| 992 | +6 |
- } else {
+ #' |
|
| 993 | -! | +||
| 7 | +
- plot_call <- substitute(+ #' @note For more examples, please see the vignette "Using scatterplot matrix" via |
||
| 994 | -! | +||
| 8 | +
- expr = plot_call ++ #' `vignette("using-scatterplot-matrix", package = "teal.modules.general")`.
|
||
| 995 | -! | +||
| 9 | +
- labs ++ #' |
||
| 996 | -! | +||
| 10 | +
- ggthemes ++ #' @inheritParams teal::module |
||
| 997 | -! | +||
| 11 | +
- themes,+ #' @inheritParams tm_g_scatterplot |
||
| 998 | -! | +||
| 12 | +
- env = list(+ #' @inheritParams shared_params |
||
| 999 | -! | +||
| 13 | +
- plot_call = plot_call,+ #' |
||
| 1000 | -! | +||
| 14 | +
- labs = parsed_ggplot2_args$labs,+ #' @param variables (`data_extract_spec` or `list` of multiple `data_extract_spec`) |
||
| 1001 | -! | +||
| 15 | +
- ggthemes = parsed_ggplot2_args$ggtheme,+ #' Specifies plotting variables from an incoming dataset with filtering and selecting. In case of |
||
| 1002 | -! | +||
| 16 | +
- themes = parsed_ggplot2_args$theme+ #' `data_extract_spec` use `select_spec(..., ordered = TRUE)` if plot elements should be |
||
| 1003 | +17 |
- )+ #' rendered according to selection order. |
|
| 1004 | +18 |
- )+ #' @param decorators `r roxygen_decorators_param("tm_g_scatterplotmatrix")`
|
|
| 1005 | +19 |
- }+ #' |
|
| 1006 | +20 |
-
+ #' @inherit shared_params return |
|
| 1007 | -! | +||
| 21 | +
- plot_call <- substitute(expr = plot <- plot_call, env = list(plot_call = plot_call))+ #' |
||
| 1008 | +22 |
-
+ #' @section Decorating `tm_g_scatterplotmatrix`: |
|
| 1009 | -! | +||
| 23 | +
- teal.code::eval_code(plot_q, plot_call)+ #' |
||
| 1010 | +24 |
- })+ #' This module generates the following objects, which can be modified in place using decorators: |
|
| 1011 | +25 |
-
+ #' - `plot` (`trellis` - output of `lattice::splom`) |
|
| 1012 | -! | +||
| 26 | +
- decorated_output_plot_q <- srv_decorate_teal_data(+ #' |
||
| 1013 | -! | +||
| 27 | +
- id = "decorator",+ #' For additional details and examples of decorators, refer to the vignette |
||
| 1014 | -! | +||
| 28 | +
- data = output_q,+ #' `vignette("decorate-modules-output", package = "teal")` or the [`teal::teal_transform_module()`] documentation.
|
||
| 1015 | -! | +||
| 29 | +
- decorators = select_decorators(decorators, "plot"),+ #' |
||
| 1016 | -! | +||
| 30 | +
- expr = print(plot)+ #' @examplesShinylive |
||
| 1017 | +31 |
- )+ #' library(teal.modules.general) |
|
| 1018 | +32 |
-
+ #' interactive <- function() TRUE |
|
| 1019 | -! | +||
| 33 | ++ |
+ #' {{ next_example }}
+ |
+ |
| 34 | +
- plot_r <- reactive(req(decorated_output_plot_q())[["plot"]])+ #' @examplesIf require("lattice", quietly = TRUE)
|
||
| 1020 | +35 |
-
+ #' # general data example |
|
| 1021 | +36 |
- # Insert the plot into a plot_with_settings module from teal.widgets+ #' data <- teal_data() |
|
| 1022 | -! | +||
| 37 | +
- pws <- teal.widgets::plot_with_settings_srv(+ #' data <- within(data, {
|
||
| 1023 | -! | +||
| 38 | +
- id = "scatter_plot",+ #' countries <- data.frame( |
||
| 1024 | -! | +||
| 39 | +
- plot_r = plot_r,+ #' id = c("DE", "FR", "IT", "ES", "PT", "GR", "NL", "BE", "LU", "AT"),
|
||
| 1025 | -! | +||
| 40 | +
- height = plot_height,+ #' government = factor( |
||
| 1026 | -! | +||
| 41 | +
- width = plot_width,+ #' c(2, 2, 2, 1, 2, 2, 1, 1, 1, 2), |
||
| 1027 | -! | +||
| 42 | +
- brushing = TRUE+ #' labels = c("Monarchy", "Republic")
|
||
| 1028 | +43 |
- )+ #' ), |
|
| 1029 | +44 |
-
+ #' language_family = factor( |
|
| 1030 | -! | +||
| 45 | +
- output$data_table <- DT::renderDataTable({
+ #' c(1, 3, 3, 3, 3, 2, 1, 1, 3, 1), |
||
| 1031 | -! | +||
| 46 | +
- plot_brush <- pws$brush()+ #' labels = c("Germanic", "Hellenic", "Romance")
|
||
| 1032 | +47 |
-
+ #' ), |
|
| 1033 | -! | +||
| 48 | +
- if (!is.null(plot_brush)) {
+ #' population = c(83, 67, 60, 47, 10, 11, 17, 11, 0.6, 9), |
||
| 1034 | -! | +||
| 49 | +
- validate(need(!input$add_density, "Brushing feature is currently not supported when plot has marginal density"))+ #' area = c(357, 551, 301, 505, 92, 132, 41, 30, 2.6, 83), |
||
| 1035 | +50 |
- }+ #' gdp = c(3.4, 2.7, 2.1, 1.4, 0.3, 0.2, 0.7, 0.5, 0.1, 0.4), |
|
| 1036 | +51 |
-
+ #' debt = c(2.1, 2.3, 2.4, 2.6, 2.3, 2.4, 2.3, 2.4, 2.3, 2.4) |
|
| 1037 | -! | +||
| 52 | +
- merged_data <- isolate(teal.code::dev_suppress(output_q()[["ANL"]]))+ #' ) |
||
| 1038 | +53 |
-
+ #' sales <- data.frame( |
|
| 1039 | -! | +||
| 54 | +
- brushed_df <- teal.widgets::clean_brushedPoints(merged_data, plot_brush)+ #' id = 1:50, |
||
| 1040 | -! | +||
| 55 | +
- numeric_cols <- names(brushed_df)[+ #' country_id = sample( |
||
| 1041 | -! | +||
| 56 | +
- vapply(brushed_df, function(x) is.numeric(x) && !is.integer(x), FUN.VALUE = logical(1))+ #' c("DE", "FR", "IT", "ES", "PT", "GR", "NL", "BE", "LU", "AT"),
|
||
| 1042 | +57 |
- ]+ #' size = 50, |
|
| 1043 | +58 |
-
+ #' replace = TRUE |
|
| 1044 | -! | +||
| 59 | +
- if (length(numeric_cols) > 0) {
+ #' ), |
||
| 1045 | -! | +||
| 60 | +
- DT::formatRound(+ #' year = sort(sample(2010:2020, 50, replace = TRUE)), |
||
| 1046 | -! | +||
| 61 | +
- DT::datatable(brushed_df,+ #' venue = sample(c("small", "medium", "large", "online"), 50, replace = TRUE),
|
||
| 1047 | -! | +||
| 62 | +
- rownames = FALSE,+ #' cancelled = sample(c(TRUE, FALSE), 50, replace = TRUE), |
||
| 1048 | -! | +||
| 63 | +
- options = list(scrollX = TRUE, pageLength = input$data_table_rows)+ #' quantity = rnorm(50, 100, 20), |
||
| 1049 | +64 |
- ),+ #' costs = rnorm(50, 80, 20), |
|
| 1050 | -! | +||
| 65 | +
- numeric_cols,+ #' profit = rnorm(50, 20, 10) |
||
| 1051 | -! | +||
| 66 | +
- table_dec+ #' ) |
||
| 1052 | +67 |
- )+ #' }) |
|
| 1053 | +68 |
- } else {
+ #' join_keys(data) <- join_keys( |
|
| 1054 | -! | +||
| 69 | +
- DT::datatable(brushed_df, rownames = FALSE, options = list(scrollX = TRUE, pageLength = input$data_table_rows))+ #' join_key("countries", "countries", "id"),
|
||
| 1055 | +70 |
- }+ #' join_key("sales", "sales", "id"),
|
|
| 1056 | +71 |
- })+ #' join_key("countries", "sales", c("id" = "country_id"))
|
|
| 1057 | +72 |
-
+ #' ) |
|
| 1058 | -! | +||
| 73 | +
- teal.widgets::verbatim_popup_srv(+ #' |
||
| 1059 | -! | +||
| 74 | +
- id = "rcode",+ #' app <- init( |
||
| 1060 | -! | +||
| 75 | +
- verbatim_content = reactive(teal.code::get_code(req(decorated_output_plot_q()))),+ #' data = data, |
||
| 1061 | -! | +||
| 76 | +
- title = "R Code for scatterplot"+ #' modules = modules( |
||
| 1062 | +77 |
- )+ #' tm_g_scatterplotmatrix( |
|
| 1063 | +78 |
-
+ #' label = "Scatterplot matrix", |
|
| 1064 | +79 |
- ### REPORTER+ #' variables = list( |
|
| 1065 | -! | +||
| 80 | +
- if (with_reporter) {
+ #' data_extract_spec( |
||
| 1066 | -! | +||
| 81 | +
- card_fun <- function(comment, label) {
+ #' dataname = "countries", |
||
| 1067 | -! | +||
| 82 | +
- card <- teal::report_card_template(+ #' select = select_spec( |
||
| 1068 | -! | +||
| 83 | +
- title = "Scatter Plot",+ #' label = "Select variables:", |
||
| 1069 | -! | +||
| 84 | +
- label = label,+ #' choices = variable_choices(data[["countries"]]), |
||
| 1070 | -! | +||
| 85 | +
- with_filter = with_filter,+ #' selected = c("area", "gdp", "debt"),
|
||
| 1071 | -! | +||
| 86 | +
- filter_panel_api = filter_panel_api+ #' multiple = TRUE, |
||
| 1072 | +87 |
- )+ #' ordered = TRUE, |
|
| 1073 | -! | +||
| 88 | +
- card$append_text("Plot", "header3")
+ #' fixed = FALSE |
||
| 1074 | -! | +||
| 89 | +
- card$append_plot(plot_r(), dim = pws$dim())+ #' ) |
||
| 1075 | -! | +||
| 90 | +
- if (!comment == "") {
+ #' ), |
||
| 1076 | -! | +||
| 91 | +
- card$append_text("Comment", "header3")
+ #' data_extract_spec( |
||
| 1077 | -! | +||
| 92 | +
- card$append_text(comment)+ #' dataname = "sales", |
||
| 1078 | +93 |
- }+ #' filter = filter_spec( |
|
| 1079 | -! | +||
| 94 | +
- card$append_src(teal.code::get_code(req(decorated_output_plot_q())))+ #' label = "Select variable:", |
||
| 1080 | -! | +||
| 95 | +
- card+ #' vars = "country_id", |
||
| 1081 | +96 |
- }+ #' choices = value_choices(data[["sales"]], "country_id"), |
|
| 1082 | -! | +||
| 97 | +
- teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
+ #' selected = c("DE", "FR", "IT", "ES", "PT", "GR", "NL", "BE", "LU", "AT"),
|
||
| 1083 | +98 |
- }+ #' multiple = TRUE |
|
| 1084 | +99 |
- ###+ #' ), |
|
| 1085 | +100 |
- })+ #' select = select_spec( |
|
| 1086 | +101 |
- }+ #' label = "Select variables:", |
| 1 | +102 |
- #' Shared parameters documentation+ #' choices = variable_choices(data[["sales"]], c("quantity", "costs", "profit")),
|
|
| 2 | +103 |
- #'+ #' selected = c("quantity", "costs", "profit"),
|
|
| 3 | +104 |
- #' Defines common arguments shared across multiple functions in the package+ #' multiple = TRUE, |
|
| 4 | +105 |
- #' to avoid repetition by using `inheritParams`.+ #' ordered = TRUE, |
|
| 5 | +106 |
- #'+ #' fixed = FALSE |
|
| 6 | +107 |
- #' @param plot_height (`numeric`) optional, specifies the plot height as a three-element vector of+ #' ) |
|
| 7 | +108 |
- #' `value`, `min`, and `max` intended for use with a slider UI element.+ #' ) |
|
| 8 | +109 |
- #' @param plot_width (`numeric`) optional, specifies the plot width as a three-element vector of+ #' ) |
|
| 9 | +110 |
- #' `value`, `min`, and `max` for a slider encoding the plot width.+ #' ) |
|
| 10 | +111 |
- #' @param rotate_xaxis_labels (`logical`) optional, whether to rotate plot X axis labels. Does not+ #' ) |
|
| 11 | +112 |
- #' rotate by default (`FALSE`).+ #' ) |
|
| 12 | +113 |
- #' @param ggtheme (`character`) optional, `ggplot2` theme to be used by default. Defaults to `"gray"`.+ #' if (interactive()) {
|
|
| 13 | +114 |
- #' @param ggplot2_args (`ggplot2_args`) object created by [teal.widgets::ggplot2_args()]+ #' shinyApp(app$ui, app$server) |
|
| 14 | +115 |
- #' with settings for the module plot.+ #' } |
|
| 15 | +116 |
- #' The argument is merged with options variable `teal.ggplot2_args` and default module setup.+ #' |
|
| 16 | +117 |
- #'+ #' @examplesShinylive |
|
| 17 | +118 |
- #' For more details see the vignette: `vignette("custom-ggplot2-arguments", package = "teal.widgets")`
+ #' library(teal.modules.general) |
|
| 18 | +119 |
- #' @param basic_table_args (`basic_table_args`) object created by [teal.widgets::basic_table_args()]+ #' interactive <- function() TRUE |
|
| 19 | +120 |
- #' with settings for the module table.+ #' {{ next_example }}
|
|
| 20 | +121 |
- #' The argument is merged with options variable `teal.basic_table_args` and default module setup.+ #' @examplesIf require("lattice", quietly = TRUE)
|
|
| 21 | +122 |
- #'+ #' # CDISC data example |
|
| 22 | +123 |
- #' For more details see the vignette: `vignette("custom-basic-table-arguments", package = "teal.widgets")`
+ #' data <- teal_data() |
|
| 23 | +124 |
- #' @param pre_output (`shiny.tag`) optional, text or UI element to be displayed before the module's output,+ #' data <- within(data, {
|
|
| 24 | +125 |
- #' providing context or a title.+ #' ADSL <- teal.data::rADSL |
|
| 25 | +126 |
- #' with text placed before the output to put the output into context. For example a title.+ #' ADRS <- teal.data::rADRS |
|
| 26 | +127 |
- #' @param post_output (`shiny.tag`) optional, text or UI element to be displayed after the module's output,+ #' }) |
|
| 27 | +128 |
- #' adding context or further instructions. Elements like `shiny::helpText()` are useful.+ #' join_keys(data) <- default_cdisc_join_keys[names(data)] |
|
| 28 | +129 |
- #' @param alpha (`integer(1)` or `integer(3)`) optional, specifies point opacity.+ #' |
|
| 29 | +130 |
- #' - When the length of `alpha` is one: the plot points will have a fixed opacity.+ #' app <- init( |
|
| 30 | +131 |
- #' - When the length of `alpha` is three: the plot points opacity are dynamically adjusted based on+ #' data = data, |
|
| 31 | +132 |
- #' vector of `value`, `min`, and `max`.+ #' modules = modules( |
|
| 32 | +133 |
- #' @param size (`integer(1)` or `integer(3)`) optional, specifies point size.+ #' tm_g_scatterplotmatrix( |
|
| 33 | +134 |
- #' - When the length of `size` is one: the plot point sizes will have a fixed size.+ #' label = "Scatterplot matrix", |
|
| 34 | +135 |
- #' - When the length of `size` is three: the plot points size are dynamically adjusted based on+ #' variables = list( |
|
| 35 | +136 |
- #' vector of `value`, `min`, and `max`.+ #' data_extract_spec( |
|
| 36 | +137 |
- #'+ #' dataname = "ADSL", |
|
| 37 | +138 |
- #' @return Object of class `teal_module` to be used in `teal` applications.+ #' select = select_spec( |
|
| 38 | +139 |
- #'+ #' label = "Select variables:", |
|
| 39 | +140 |
- #' @name shared_params+ #' choices = variable_choices(data[["ADSL"]]), |
|
| 40 | +141 |
- #' @keywords internal+ #' selected = c("AGE", "RACE", "SEX"),
|
|
| 41 | +142 |
- NULL+ #' multiple = TRUE, |
|
| 42 | +143 |
-
+ #' ordered = TRUE, |
|
| 43 | +144 |
- #' Add labels for facets to a `ggplot2` object+ #' fixed = FALSE |
|
| 44 | +145 |
- #'+ #' ) |
|
| 45 | +146 |
- #' Enhances a `ggplot2` plot by adding labels that describe+ #' ), |
|
| 46 | +147 |
- #' the faceting variables along the x and y axes.+ #' data_extract_spec( |
|
| 47 | +148 |
- #'+ #' dataname = "ADRS", |
|
| 48 | +149 |
- #' @param p (`ggplot2`) object to which facet labels will be added.+ #' filter = filter_spec( |
|
| 49 | +150 |
- #' @param xfacet_label (`character`) Label for the facet along the x-axis.+ #' label = "Select endpoints:", |
|
| 50 | +151 |
- #' If `NULL`, no label is added. If a vector, labels are joined with " & ".+ #' vars = c("PARAMCD", "AVISIT"),
|
|
| 51 | +152 |
- #' @param yfacet_label (`character`) Label for the facet along the y-axis.+ #' choices = value_choices(data[["ADRS"]], c("PARAMCD", "AVISIT"), c("PARAM", "AVISIT")),
|
|
| 52 | +153 |
- #' Similar behavior to `xfacet_label`.+ #' selected = "INVET - END OF INDUCTION", |
|
| 53 | +154 |
- #'+ #' multiple = TRUE |
|
| 54 | +155 |
- #' @return Returns `grid` or `grob` object (to be drawn with `grid.draw`)+ #' ), |
|
| 55 | +156 |
- #'+ #' select = select_spec( |
|
| 56 | +157 |
- #' @examples+ #' label = "Select variables:", |
|
| 57 | +158 |
- #' library(ggplot2)+ #' choices = variable_choices(data[["ADRS"]]), |
|
| 58 | +159 |
- #' library(grid)+ #' selected = c("AGE", "AVAL", "ADY"),
|
|
| 59 | +160 |
- #'+ #' multiple = TRUE, |
|
| 60 | +161 |
- #' p <- ggplot(mtcars) ++ #' ordered = TRUE, |
|
| 61 | +162 |
- #' aes(x = mpg, y = disp) ++ #' fixed = FALSE |
|
| 62 | +163 |
- #' geom_point() ++ #' ) |
|
| 63 | +164 |
- #' facet_grid(gear ~ cyl)+ #' ) |
|
| 64 | +165 |
- #'+ #' ) |
|
| 65 | +166 |
- #' xfacet_label <- "cylinders"+ #' ) |
|
| 66 | +167 |
- #' yfacet_label <- "gear"+ #' ) |
|
| 67 | +168 |
- #' res <- add_facet_labels(p, xfacet_label, yfacet_label)+ #' ) |
|
| 68 | +169 |
- #' grid.newpage()+ #' if (interactive()) {
|
|
| 69 | +170 |
- #' grid.draw(res)+ #' shinyApp(app$ui, app$server) |
|
| 70 | +171 |
- #'+ #' } |
|
| 71 | +172 |
- #' grid.newpage()+ #' |
|
| 72 | +173 |
- #' grid.draw(add_facet_labels(p, xfacet_label = NULL, yfacet_label))+ #' @export |
|
| 73 | +174 |
- #' grid.newpage()+ #' |
|
| 74 | +175 |
- #' grid.draw(add_facet_labels(p, xfacet_label, yfacet_label = NULL))+ tm_g_scatterplotmatrix <- function(label = "Scatterplot Matrix", |
|
| 75 | +176 |
- #' grid.newpage()+ variables, |
|
| 76 | +177 |
- #' grid.draw(add_facet_labels(p, xfacet_label = NULL, yfacet_label = NULL))+ plot_height = c(600, 200, 2000), |
|
| 77 | +178 |
- #'+ plot_width = NULL, |
|
| 78 | +179 |
- #' @export+ pre_output = NULL, |
|
| 79 | +180 |
- #'+ post_output = NULL, |
|
| 80 | +181 |
- add_facet_labels <- function(p, xfacet_label = NULL, yfacet_label = NULL) {
+ decorators = NULL) {
|
|
| 81 | +182 | ! |
- checkmate::assert_class(p, classes = "ggplot")+ message("Initializing tm_g_scatterplotmatrix")
|
| 82 | -! | +||
| 183 | +
- checkmate::assert_character(xfacet_label, null.ok = TRUE, min.len = 1)+ |
||
| 83 | -! | +||
| 184 | +
- checkmate::assert_character(yfacet_label, null.ok = TRUE, min.len = 1)+ # Requires Suggested packages |
||
| 84 | +185 | ! |
- if (is.null(xfacet_label) && is.null(yfacet_label)) {
+ if (!requireNamespace("lattice", quietly = TRUE)) {
|
| 85 | +186 | ! |
- return(ggplotGrob(p))+ stop("Cannot load lattice - please install the package or restart your session.")
|
| 86 | +187 |
} |
|
| 87 | -! | +||
| 188 | +
- grid::grid.grabExpr({
+
+ |
+ ||
| 189 | ++ |
+ # Normalize the parameters |
|
| 88 | +190 | ! |
- g <- ggplotGrob(p)+ if (inherits(variables, "data_extract_spec")) variables <- list(variables) |
| 89 | +191 | ||
| 90 | +192 |
- # we are going to replace these, so we make sure they have nothing in them+ # Start of assertions |
|
| 91 | +193 | ! |
- checkmate::assert_class(g$grobs[[grep("xlab-t", g$layout$name, fixed = TRUE)]], "zeroGrob")
+ checkmate::assert_string(label) |
| 92 | +194 | ! |
- checkmate::assert_class(g$grobs[[grep("ylab-r", g$layout$name, fixed = TRUE)]], "zeroGrob")
+ checkmate::assert_list(variables, types = "data_extract_spec") |
| 93 | +195 | ||
| 94 | +196 | ! |
- xaxis_label_grob <- g$grobs[[grep("xlab-b", g$layout$name, fixed = TRUE)]]
+ checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE) |
| 95 | +197 | ! |
- xaxis_label_grob$children[[1]]$label <- paste(xfacet_label, collapse = " & ")+ checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height") |
| 96 | +198 | ! |
- yaxis_label_grob <- g$grobs[[grep("ylab-l", g$layout$name, fixed = TRUE)]]
+ checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE) |
| 97 | +199 | ! |
- yaxis_label_grob$children[[1]]$label <- paste(yfacet_label, collapse = " & ")+ checkmate::assert_numeric( |
| 98 | +200 | ! |
- yaxis_label_grob$children[[1]]$rot <- 270- |
-
| 99 | -- |
-
+ plot_width[1], |
|
| 100 | +201 | ! |
- top_height <- if (is.null(xfacet_label)) 0 else grid::unit(2, "line")+ lower = plot_width[2], upper = plot_width[3], null.ok = TRUE, .var.name = "plot_width" |
| 101 | -! | +||
| 202 | +
- right_width <- if (is.null(yfacet_label)) 0 else grid::unit(2, "line")+ ) |
||
| 102 | +203 | ||
| 103 | -! | -
- grid::grid.newpage()- |
- |
| 104 | -! | -
- grid::pushViewport(grid::plotViewport(margins = c(0, 0, top_height, right_width), name = "ggplot"))- |
- |
| 105 | +204 | ! |
- grid::grid.draw(g)+ checkmate::assert_multi_class(pre_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
|
| 106 | +205 | ! |
- grid::upViewport(1)+ checkmate::assert_multi_class(post_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
|
| 107 | +206 | ||
| 108 | -- |
- # draw x facet- |
- |
| 109 | -! | -
- if (!is.null(xfacet_label)) {
- |
- |
| 110 | +207 | ! |
- grid::pushViewport(grid::viewport(+ decorators <- normalize_decorators(decorators) |
| 111 | +208 | ! |
- x = 0, y = grid::unit(1, "npc") - top_height, width = grid::unit(1, "npc"),+ assert_decorators(decorators, null.ok = TRUE, "plot") |
| 112 | -! | +||
| 209 | +
- height = top_height, just = c("left", "bottom"), name = "topxaxis"
+ # End of assertions |
||
| 113 | +210 |
- ))+ |
|
| 114 | -! | +||
| 211 | +
- grid::grid.draw(xaxis_label_grob)+ # Make UI args |
||
| 115 | +212 | ! |
- grid::upViewport(1)- |
-
| 116 | -- |
- }+ args <- as.list(environment()) |
|
| 117 | +213 | ||
| 118 | -+ | ||
| 214 | +! |
- # draw y facet+ ans <- module( |
|
| 119 | +215 | ! |
- if (!is.null(yfacet_label)) {
+ label = label, |
| 120 | +216 | ! |
- grid::pushViewport(grid::viewport(+ server = srv_g_scatterplotmatrix, |
| 121 | +217 | ! |
- x = grid::unit(1, "npc") - grid::unit(as.numeric(right_width) / 2, "line"), y = 0, width = right_width,+ ui = ui_g_scatterplotmatrix, |
| 122 | +218 | ! |
- height = grid::unit(1, "npc"), just = c("left", "bottom"), name = "rightyaxis"
+ ui_args = args, |
| 123 | -+ | ||
| 219 | +! |
- ))+ server_args = list( |
|
| 124 | +220 | ! |
- grid::grid.draw(yaxis_label_grob)+ variables = variables, |
| 125 | +221 | ! |
- grid::upViewport(1)+ plot_height = plot_height, |
| 126 | -+ | ||
| 222 | +! |
- }+ plot_width = plot_width, |
|
| 127 | -+ | ||
| 223 | +! |
- })+ decorators = decorators |
|
| 128 | +224 |
- }+ ), |
|
| 129 | -+ | ||
| 225 | +! |
-
+ datanames = teal.transform::get_extract_datanames(variables) |
|
| 130 | +226 |
- #' Call a function with a character vector for the `...` argument+ ) |
|
| 131 | -+ | ||
| 227 | +! |
- #'+ attr(ans, "teal_bookmarkable") <- TRUE |
|
| 132 | -+ | ||
| 228 | +! |
- #' @param fun (`character`) Name of a function where the `...` argument shall be replaced by values from `str_args`.+ ans |
|
| 133 | +229 |
- #' @param str_args (`character`) A character vector that the function shall be executed with+ } |
|
| 134 | +230 |
- #'+ |
|
| 135 | +231 |
- #' @return+ # UI function for the scatterplot matrix module |
|
| 136 | +232 |
- #' Value of call to `fun` with arguments specified in `str_args`.+ ui_g_scatterplotmatrix <- function(id, ...) {
|
|
| 137 | -+ | ||
| 233 | +! |
- #'+ args <- list(...) |
|
| 138 | -+ | ||
| 234 | +! |
- #' @keywords internal+ is_single_dataset_value <- teal.transform::is_single_dataset(args$variables) |
|
| 139 | -+ | ||
| 235 | +! |
- call_fun_dots <- function(fun, str_args) {
+ ns <- NS(id) |
|
| 140 | +236 | ! |
- do.call("call", c(list(fun), lapply(str_args, as.name)), quote = TRUE)
+ teal.widgets::standard_layout( |
| 141 | -+ | ||
| 237 | +! |
- }+ output = teal.widgets::white_small_well( |
|
| 142 | -+ | ||
| 238 | +! |
-
+ textOutput(ns("message")),
|
|
| 143 | -+ | ||
| 239 | +! |
- #' Generate a string for a variable including its label+ tags$br(), |
|
| 144 | -+ | ||
| 240 | +! |
- #'+ teal.widgets::plot_with_settings_ui(id = ns("myplot"))
|
|
| 145 | +241 |
- #' @param var_names (`character`) Name of variable to extract labels from.+ ), |
|
| 146 | -+ | ||
| 242 | +! |
- #' @param dataset (`dataset`) Name of analysis dataset.+ encoding = tags$div( |
|
| 147 | +243 |
- #' @param prefix,suffix (`character`) String to paste to the beginning/end of the variable name with label.+ ### Reporter |
|
| 148 | -+ | ||
| 244 | +! |
- #' @param wrap_width (`numeric`) Number of characters to wrap original label to. Defaults to 80.+ teal.reporter::simple_reporter_ui(ns("simple_reporter")),
|
|
| 149 | +245 |
- #'+ ### |
|
| 150 | -+ | ||
| 246 | +! |
- #' @return (`character`) String with variable name and label.+ tags$label("Encodings", class = "text-primary"),
|
|
| 151 | -+ | ||
| 247 | +! |
- #'+ teal.transform::datanames_input(args$variables), |
|
| 152 | -+ | ||
| 248 | +! |
- #' @keywords internal+ teal.transform::data_extract_ui( |
|
| 153 | -+ | ||
| 249 | +! |
- #'+ id = ns("variables"),
|
|
| 154 | -+ | ||
| 250 | +! |
- varname_w_label <- function(var_names,+ label = "Variables", |
|
| 155 | -+ | ||
| 251 | +! |
- dataset,+ data_extract_spec = args$variables, |
|
| 156 | -+ | ||
| 252 | +! |
- wrap_width = 80,+ is_single_dataset = is_single_dataset_value |
|
| 157 | +253 |
- prefix = NULL,+ ), |
|
| 158 | -+ | ||
| 254 | +! |
- suffix = NULL) {
+ tags$hr(), |
|
| 159 | +255 | ! |
- add_label <- function(var_names) {
+ ui_decorate_teal_data(ns("decorator"), decorators = select_decorators(args$decorators, "plot")),
|
| 160 | +256 | ! |
- label <- vapply(+ teal.widgets::panel_group( |
| 161 | +257 | ! |
- dataset[var_names], function(x) {
+ teal.widgets::panel_item( |
| 162 | +258 | ! |
- attr_label <- attr(x, "label")+ title = "Plot settings", |
| 163 | +259 | ! |
- `if`(is.null(attr_label), "", attr_label)+ sliderInput( |
| 164 | -+ | ||
| 260 | +! |
- },+ ns("alpha"), "Opacity:",
|
|
| 165 | +261 | ! |
- character(1)+ min = 0, max = 1, |
| 166 | -+ | ||
| 262 | +! |
- )+ step = .05, value = .5, ticks = FALSE |
|
| 167 | +263 |
-
+ ), |
|
| 168 | +264 | ! |
- if (length(label) == 1 && !is.na(label) && !identical(label, "")) {
+ sliderInput( |
| 169 | +265 | ! |
- paste0(prefix, label, " [", var_names, "]", suffix)+ ns("cex"), "Points size:",
|
| 170 | -+ | ||
| 266 | +! |
- } else {
+ min = 0.2, max = 3, |
|
| 171 | +267 | ! |
- var_names+ step = .05, value = .65, ticks = FALSE |
| 172 | +268 |
- }+ ), |
|
| 173 | -+ | ||
| 269 | +! |
- }+ checkboxInput(ns("cor"), "Add Correlation", value = FALSE),
|
|
| 174 | -+ | ||
| 270 | +! |
-
+ radioButtons( |
|
| 175 | +271 | ! |
- if (length(var_names) < 1) {
+ ns("cor_method"), "Select Correlation Method",
|
| 176 | +272 | ! |
- NULL+ choiceNames = c("Pearson", "Kendall", "Spearman"),
|
| 177 | +273 | ! |
- } else if (length(var_names) == 1) {
+ choiceValues = c("pearson", "kendall", "spearman"),
|
| 178 | +274 | ! |
- stringr::str_wrap(add_label(var_names), width = wrap_width)+ inline = TRUE |
| 179 | -! | +||
| 275 | +
- } else if (length(var_names) > 1) {
+ ), |
||
| 180 | +276 | ! |
- stringr::str_wrap(vapply(var_names, add_label, character(1)), width = wrap_width)+ checkboxInput(ns("cor_na_omit"), "Omit Missing Values", value = TRUE)
|
| 181 | +277 |
- }+ ) |
|
| 182 | +278 |
- }+ ) |
|
| 183 | +279 |
-
+ ), |
|
| 184 | -+ | ||
| 280 | +! |
- # see vignette("ggplot2-specs", package="ggplot2")
+ forms = tagList( |
|
| 185 | -+ | ||
| 281 | +! |
- shape_names <- c(+ teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code")
|
|
| 186 | +282 |
- "circle", paste("circle", c("open", "filled", "cross", "plus", "small")), "bullet",
+ ), |
|
| 187 | -+ | ||
| 283 | +! |
- "square", paste("square", c("open", "filled", "cross", "plus", "triangle")),
+ pre_output = args$pre_output, |
|
| 188 | -+ | ||
| 284 | +! |
- "diamond", paste("diamond", c("open", "filled", "plus")),
+ post_output = args$post_output |
|
| 189 | +285 |
- "triangle", paste("triangle", c("open", "filled", "square")),
+ ) |
|
| 190 | +286 |
- paste("triangle down", c("open", "filled")),
+ } |
|
| 191 | +287 |
- "plus", "cross", "asterisk"+ |
|
| 192 | +288 |
- )+ # Server function for the scatterplot matrix module |
|
| 193 | +289 |
-
+ srv_g_scatterplotmatrix <- function(id, |
|
| 194 | +290 |
- #' Get icons to represent variable types in dataset+ data, |
|
| 195 | +291 |
- #'+ reporter, |
|
| 196 | +292 |
- #' @param var_type (`character`) of R internal types (classes).+ filter_panel_api, |
|
| 197 | +293 |
- #' @return (`character`) vector of HTML icons corresponding to data type in each column.+ variables, |
|
| 198 | +294 |
- #' @keywords internal+ plot_height, |
|
| 199 | +295 |
- variable_type_icons <- function(var_type) {
- |
- |
| 200 | -! | -
- checkmate::assert_character(var_type, any.missing = FALSE)+ plot_width, |
|
| 201 | +296 |
-
+ decorators) {
|
|
| 202 | +297 | ! |
- class_to_icon <- list(+ with_reporter <- !missing(reporter) && inherits(reporter, "Reporter") |
| 203 | +298 | ! |
- numeric = "arrow-up-1-9",+ with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI") |
| 204 | +299 | ! |
- integer = "arrow-up-1-9",+ checkmate::assert_class(data, "reactive") |
| 205 | +300 | ! |
- logical = "pause",+ checkmate::assert_class(isolate(data()), "teal_data") |
| 206 | +301 | ! |
- Date = "calendar",+ moduleServer(id, function(input, output, session) {
|
| 207 | +302 | ! |
- POSIXct = "calendar",+ teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.general")+ |
+
| 303 | ++ | + | |
| 208 | +304 | ! |
- POSIXlt = "calendar",+ selector_list <- teal.transform::data_extract_multiple_srv( |
| 209 | +305 | ! |
- factor = "chart-bar",+ data_extract = list(variables = variables), |
| 210 | +306 | ! |
- character = "keyboard",+ datasets = data, |
| 211 | +307 | ! |
- primary_key = "key",+ select_validation_rule = list( |
| 212 | +308 | ! |
- unknown = "circle-question"+ variables = ~ if (length(.) <= 1) "Please select at least 2 columns." |
| 213 | +309 |
- )+ ) |
|
| 214 | -! | +||
| 310 | +
- class_to_icon <- lapply(class_to_icon, function(icon_name) toString(icon(icon_name, lib = "font-awesome")))+ ) |
||
| 215 | +311 | ||
| 216 | +312 | ! |
- unname(vapply(+ iv_r <- reactive({
|
| 217 | +313 | ! |
- var_type,+ iv <- shinyvalidate::InputValidator$new() |
| 218 | +314 | ! |
- FUN.VALUE = character(1),+ teal.transform::compose_and_enable_validators(iv, selector_list)+ |
+
| 315 | ++ |
+ })+ |
+ |
| 316 | ++ | + | |
| 219 | +317 | ! |
- FUN = function(class) {
+ anl_merged_input <- teal.transform::merge_expression_srv( |
| 220 | +318 | ! |
- if (class == "") {
+ datasets = data, |
| 221 | +319 | ! |
- class+ selector_list = selector_list+ |
+
| 320 | ++ |
+ )+ |
+ |
| 321 | ++ | + | |
| 222 | +322 | ! |
- } else if (is.null(class_to_icon[[class]])) {
+ anl_merged_q <- reactive({
|
| 223 | +323 | ! |
- class_to_icon[["unknown"]]+ req(anl_merged_input()) |
| 224 | -+ | ||
| 324 | +! |
- } else {
+ data() %>% |
|
| 225 | +325 | ! |
- class_to_icon[[class]]+ teal.code::eval_code(as.expression(anl_merged_input()$expr)) |
| 226 | +326 |
- }+ }) |
|
| 227 | +327 |
- }+ |
|
| 228 | -+ | ||
| 328 | +! |
- ))+ merged <- list( |
|
| 229 | -+ | ||
| 329 | +! |
- }+ anl_input_r = anl_merged_input, |
|
| 230 | -+ | ||
| 330 | +! |
-
+ anl_q_r = anl_merged_q |
|
| 231 | +331 |
- #' Include `CSS` files from `/inst/css/` package directory to application header+ ) |
|
| 232 | +332 |
- #'+ |
|
| 233 | +333 |
- #' `system.file` should not be used to access files in other packages, it does+ # plot |
|
| 234 | -+ | ||
| 334 | +! |
- #' not work with `devtools`. Therefore, we redefine this method in each package+ output_q <- reactive({
|
|
| 235 | -+ | ||
| 335 | +! |
- #' as needed. Thus, we do not export this method+ teal::validate_inputs(iv_r()) |
|
| 236 | +336 |
- #'+ |
|
| 237 | -+ | ||
| 337 | +! |
- #' @param pattern (`character`) optional, regular expression to match the file names to be included.+ qenv <- merged$anl_q_r() |
|
| 238 | -+ | ||
| 338 | +! |
- #'+ ANL <- qenv[["ANL"]] |
|
| 239 | +339 |
- #' @return HTML code that includes `CSS` files.+ |
|
| 240 | -+ | ||
| 340 | +! |
- #' @keywords internal+ cols_names <- merged$anl_input_r()$columns_source$variables |
|
| 241 | -+ | ||
| 341 | +! |
- #'+ alpha <- input$alpha |
|
| 242 | -+ | ||
| 342 | +! |
- include_css_files <- function(pattern = "*") {
+ cex <- input$cex |
|
| 243 | +343 | ! |
- css_files <- list.files(+ add_cor <- input$cor |
| 244 | +344 | ! |
- system.file("css", package = "teal.modules.general", mustWork = TRUE),
+ cor_method <- input$cor_method |
| 245 | +345 | ! |
- pattern = pattern, full.names = TRUE+ cor_na_omit <- input$cor_na_omit |
| 246 | +346 |
- )+ |
|
| 247 | +347 | ! |
- if (length(css_files) == 0) {
+ cor_na_action <- if (isTruthy(cor_na_omit)) {
|
| 248 | +348 | ! |
- return(NULL)+ "na.omit" |
| 249 | +349 |
- }+ } else {
|
|
| 250 | +350 | ! |
- singleton(tags$head(lapply(css_files, includeCSS)))+ "na.fail" |
| 251 | +351 |
- }+ } |
|
| 252 | +352 | ||
| 253 | -+ | ||
| 353 | +! |
- #' JavaScript condition to check if a specific tab is active+ teal::validate_has_data(ANL, 10) |
|
| 254 | -+ | ||
| 354 | +! |
- #'+ teal::validate_has_data(ANL[, cols_names, drop = FALSE], 10, complete = TRUE, allow_inf = FALSE) |
|
| 255 | +355 |
- #' @param id (`character(1)`) the id of the tab panel with tabs.+ |
|
| 256 | +356 |
- #' @param name (`character(1)`) the name of the tab.+ # get labels and proper variable names |
|
| 257 | -+ | ||
| 357 | +! |
- #' @return JavaScript expression to be used in `shiny::conditionalPanel()` to determine+ varnames <- varname_w_label(cols_names, ANL, wrap_width = 20) |
|
| 258 | +358 |
- #' if the specified tab is active.+ |
|
| 259 | +359 |
- #' @keywords internal+ # check character columns. If any, then those are converted to factors |
|
| 260 | -+ | ||
| 360 | +! |
- #'+ check_char <- vapply(ANL[, cols_names], is.character, logical(1)) |
|
| 261 | -+ | ||
| 361 | +! |
- is_tab_active_js <- function(id, name) {
+ if (any(check_char)) {
|
|
| 262 | -+ | ||
| 362 | +! |
- # supporting the bs3 and higher version at the same time+ qenv <- teal.code::eval_code( |
|
| 263 | +363 | ! |
- sprintf(+ qenv, |
| 264 | +364 | ! |
- "$(\"#%1$s > li.active\").text().trim() == '%2$s' || $(\"#%1$s > li a.active\").text().trim() == '%2$s'",+ substitute( |
| 265 | +365 | ! |
- id, name+ expr = ANL <- ANL[, cols_names] %>% |
| 266 | -+ | ||
| 366 | +! |
- )+ dplyr::mutate_if(is.character, as.factor) %>% |
|
| 267 | -+ | ||
| 367 | +! |
- }+ droplevels(), |
|
| 268 | -+ | ||
| 368 | +! |
-
+ env = list(cols_names = cols_names) |
|
| 269 | +369 |
- #' Assert single selection on `data_extract_spec` object+ ) |
|
| 270 | +370 |
- #' Helper to reduce code in assertions+ ) |
|
| 271 | +371 |
- #' @noRd+ } else {
|
|
| 272 | -+ | ||
| 372 | +! |
- #'+ qenv <- teal.code::eval_code( |
|
| 273 | -+ | ||
| 373 | +! |
- assert_single_selection <- function(x,+ qenv, |
|
| 274 | -+ | ||
| 374 | +! |
- .var.name = checkmate::vname(x)) { # nolint: object_name.
+ substitute( |
|
| 275 | -104x | +||
| 375 | +! |
- if (any(vapply(x, function(.x) .x$select$multiple, logical(1)))) {
+ expr = ANL <- ANL[, cols_names] %>% |
|
| 276 | -4x | +||
| 376 | +! |
- stop("'", .var.name, "' should not allow multiple selection")
+ droplevels(),+ |
+ |
| 377 | +! | +
+ env = list(cols_names = cols_names) |
|
| 277 | +378 |
- }+ ) |
|
| 278 | -100x | +||
| 379 | +
- invisible(TRUE)+ ) |
||
| 279 | +380 |
- }+ } |
|
| 280 | +381 | ||
| 281 | +382 |
- #' Wrappers around `srv_transform_teal_data` that allows to decorate the data+ |
|
| 282 | +383 |
- #' @inheritParams teal::srv_transform_teal_data+ # create plot |
|
| 283 | -+ | ||
| 384 | +! |
- #' @param expr (`expression` or `reactive`) to evaluate on the output of the decoration.+ if (add_cor) {
|
|
| 284 | -+ | ||
| 385 | +! |
- #' When an expression it must be inline code. See [within()]+ shinyjs::show("cor_method")
|
|
| 285 | -+ | ||
| 386 | +! |
- #' Default is `NULL` which won't evaluate any appending code.+ shinyjs::show("cor_use")
|
|
| 286 | -+ | ||
| 387 | +! |
- #' @param expr_is_reactive (`logical(1)`) whether `expr` is a reactive expression+ shinyjs::show("cor_na_omit")
|
|
| 287 | +388 |
- #' that skips defusing the argument.+ |
|
| 288 | -+ | ||
| 389 | +! |
- #' @details+ qenv <- teal.code::eval_code( |
|
| 289 | -+ | ||
| 390 | +! |
- #' `srv_decorate_teal_data` is a wrapper around `srv_transform_teal_data` that+ qenv, |
|
| 290 | -+ | ||
| 391 | +! |
- #' allows to decorate the data with additional expressions.+ substitute( |
|
| 291 | -+ | ||
| 392 | +! |
- #' When original `teal_data` object is in error state, it will show that error+ expr = {
|
|
| 292 | -+ | ||
| 393 | +! |
- #' first.+ plot <- lattice::splom( |
|
| 293 | -+ | ||
| 394 | +! |
- #'+ ANL, |
|
| 294 | -+ | ||
| 395 | +! |
- #' @keywords internal+ varnames = varnames_value, |
|
| 295 | -+ | ||
| 396 | +! |
- srv_decorate_teal_data <- function(id, data, decorators, expr, expr_is_reactive = FALSE) {
+ panel = function(x, y, ...) {
|
|
| 296 | +397 | ! |
- checkmate::assert_class(data, classes = "reactive")+ lattice::panel.splom(x = x, y = y, ...) |
| 297 | +398 | ! |
- checkmate::assert_list(decorators, "teal_transform_module")+ cpl <- lattice::current.panel.limits() |
| 298 | +399 | ! |
- checkmate::assert_flag(expr_is_reactive)+ lattice::panel.text( |
| 299 | -+ | ||
| 400 | +! |
-
+ mean(cpl$xlim), |
|
| 300 | +401 | ! |
- missing_expr <- missing(expr)+ mean(cpl$ylim), |
| 301 | +402 | ! |
- if (!missing_expr && !expr_is_reactive) {
+ get_scatterplotmatrix_stats( |
| 302 | +403 | ! |
- expr <- rlang::enexpr(expr)+ x, |
| 303 | -+ | ||
| 404 | +! |
- }+ y, |
|
| 304 | -+ | ||
| 405 | +! |
-
+ .f = stats::cor.test, |
|
| 305 | +406 | ! |
- moduleServer(id, function(input, output, session) {
+ .f_args = list(method = cor_method, na.action = cor_na_action)+ |
+
| 407 | ++ |
+ ), |
|
| 306 | +408 | ! |
- decorated_output <- srv_transform_teal_data("inner", data = data, transformators = decorators)
+ alpha = 0.6, |
| 307 | -+ | ||
| 409 | +! |
-
+ fontsize = 18, |
|
| 308 | +410 | ! |
- reactive({
+ fontface = "bold" |
| 309 | +411 |
- # ensure original errors are displayed and `eval_code` is never executed with NULL+ ) |
|
| 310 | -! | +||
| 412 | +
- req(data(), decorated_output())+ }, |
||
| 311 | +413 | ! |
- if (missing_expr) {
+ pch = 16, |
| 312 | +414 | ! |
- decorated_output()+ alpha = alpha_value, |
| 313 | +415 | ! |
- } else if (expr_is_reactive) {
+ cex = cex_value |
| 314 | -! | +||
| 416 | +
- teal.code::eval_code(decorated_output(), expr())+ ) |
||
| 315 | +417 |
- } else {
+ }, |
|
| 316 | +418 | ! |
- teal.code::eval_code(decorated_output(), expr)+ env = list( |
| 317 | -+ | ||
| 419 | +! |
- }+ varnames_value = varnames, |
|
| 318 | -+ | ||
| 420 | +! |
- })+ cor_method = cor_method, |
|
| 319 | -+ | ||
| 421 | +! |
- })+ cor_na_action = cor_na_action, |
|
| 320 | -+ | ||
| 422 | +! |
- }+ alpha_value = alpha, |
|
| 321 | -+ | ||
| 423 | +! |
-
+ cex_value = cex |
|
| 322 | +424 |
- #' @rdname srv_decorate_teal_data+ ) |
|
| 323 | +425 |
- #' @details+ ) |
|
| 324 | +426 |
- #' `ui_decorate_teal_data` is a wrapper around `ui_transform_teal_data`.+ ) |
|
| 325 | +427 |
- #' @keywords internal+ } else {
|
|
| 326 | -+ | ||
| 428 | +! |
- ui_decorate_teal_data <- function(id, decorators, ...) {
+ shinyjs::hide("cor_method")
|
|
| 327 | +429 | ! |
- teal::ui_transform_teal_data(NS(id, "inner"), transformators = decorators, ...)+ shinyjs::hide("cor_use")
|
| 328 | -+ | ||
| 430 | +! |
- }+ shinyjs::hide("cor_na_omit")
|
|
| 329 | -+ | ||
| 431 | +! |
-
+ qenv <- teal.code::eval_code( |
|
| 330 | -+ | ||
| 432 | +! |
- #' Internal function to check if decorators is a valid object+ qenv, |
|
| 331 | -+ | ||
| 433 | +! |
- #' @noRd+ substitute( |
|
| 332 | -+ | ||
| 434 | +! |
- check_decorators <- function(x, names = NULL, null.ok = FALSE) { # nolint: object_name.
+ expr = {
|
|
| 333 | -5x | +||
| 435 | +! |
- checkmate::qassert(null.ok, "B1")+ plot <- lattice::splom( |
|
| 334 | -+ | ||
| 436 | +! |
-
+ ANL, |
|
| 335 | -5x | +||
| 437 | +! |
- check_message <- checkmate::check_list(+ varnames = varnames_value, |
|
| 336 | -5x | +||
| 438 | +! |
- x,+ pch = 16, |
|
| 337 | -5x | +||
| 439 | +! |
- null.ok = null.ok,+ alpha = alpha_value, |
|
| 338 | -5x | +||
| 440 | +! |
- names = "named"+ cex = cex_value |
|
| 339 | +441 |
- )+ ) |
|
| 340 | +442 |
-
+ }, |
|
| 341 | -5x | +||
| 443 | +! |
- if (!is.null(names)) {
+ env = list(varnames_value = varnames, alpha_value = alpha, cex_value = cex) |
|
| 342 | -5x | +||
| 444 | +
- check_message <- if (isTRUE(check_message)) {
+ ) |
||
| 343 | -5x | +||
| 445 | +
- out_message <- checkmate::check_names(names(x), subset.of = c("default", names))
+ ) |
||
| 344 | +446 |
- # see https://github.com/insightsengineering/teal.logger/issues/101+ } |
|
| 345 | -5x | +||
| 447 | +! |
- if (isTRUE(out_message)) {
+ qenv |
|
| 346 | -5x | +||
| 448 | +
- out_message+ }) |
||
| 347 | +449 |
- } else {
+
|
|
| 348 | +450 | ! |
- gsub("\\{", "(", gsub("\\}", ")", out_message))
+ decorated_output_q <- srv_decorate_teal_data( |
| 349 | -+ | ||
| 451 | +! |
- }+ id = "decorator", |
|
| 350 | -+ | ||
| 452 | +! |
- } else {
+ data = output_q, |
|
| 351 | +453 | ! |
- check_message+ decorators = select_decorators(decorators, "plot"), |
| 352 | -+ | ||
| 454 | +! |
- }+ expr = print(plot) |
|
| 353 | +455 |
- }+ ) |
|
| 354 | +456 | ||
| 355 | -5x | -
- if (!isTRUE(check_message)) {
- |
- |
| 356 | +457 | ! |
- return(check_message)+ plot_r <- reactive(req(decorated_output_q())[["plot"]]) |
| 357 | +458 |
- }+ |
|
| 358 | +459 | - - | -|
| 359 | -5x | -
- valid_elements <- vapply(+ # Insert the plot into a plot_with_settings module |
|
| 360 | -5x | +||
| 460 | +! |
- x,+ pws <- teal.widgets::plot_with_settings_srv( |
|
| 361 | -5x | +||
| 461 | +! |
- checkmate::test_list,+ id = "myplot", |
|
| 362 | -5x | +||
| 462 | +! |
- types = "teal_transform_module",+ plot_r = plot_r, |
|
| 363 | -5x | +||
| 463 | +! |
- null.ok = TRUE,+ height = plot_height, |
|
| 364 | -5x | +||
| 464 | +! |
- FUN.VALUE = logical(1L)+ width = plot_width |
|
| 365 | +465 |
- )+ ) |
|
| 366 | +466 | ||
| 367 | -5x | +||
| 467 | +
- if (all(valid_elements)) {
+ # show a message if conversion to factors took place |
||
| 368 | -5x | +||
| 468 | +! |
- return(TRUE)+ output$message <- renderText({
|
|
| 369 | -+ | ||
| 469 | +! |
- }+ req(iv_r()$is_valid()) |
|
| 370 | -+ | ||
| 470 | +! |
-
+ req(selector_list()$variables()) |
|
| 371 | +471 | ! |
- "May only contain the type 'teal_transform_module' or a named list of 'teal_transform_module'."+ ANL <- merged$anl_q_r()[["ANL"]] |
| 372 | -+ | ||
| 472 | +! |
- }+ cols_names <- unique(unname(do.call(c, merged$anl_input_r()$columns_source))) |
|
| 373 | -+ | ||
| 473 | +! |
-
+ check_char <- vapply(ANL[, cols_names], is.character, logical(1)) |
|
| 374 | -+ | ||
| 474 | +! |
- #' Internal assertion on decorators+ if (any(check_char)) {
|
|
| 375 | -+ | ||
| 475 | +! |
- #' @noRd+ is_single <- sum(check_char) == 1 |
|
| 376 | -+ | ||
| 476 | +! |
- assert_decorators <- checkmate::makeAssertionFunction(check_decorators)+ paste( |
|
| 377 | -+ | ||
| 477 | +! |
-
+ "Character", |
|
| 378 | -+ | ||
| 478 | +! |
- #' Subset decorators based on the scope+ ifelse(is_single, "variable", "variables"), |
|
| 379 | -+ | ||
| 479 | +! |
- #'+ paste0("(", paste(cols_names[check_char], collapse = ", "), ")"),
|
|
| 380 | -+ | ||
| 480 | +! |
- #' `default` is a protected decorator name that is always included in the output,+ ifelse(is_single, "was", "were"), |
|
| 381 | -+ | ||
| 481 | +! |
- #' if it exists+ "converted to", |
|
| 382 | -+ | ||
| 482 | +! |
- #'+ ifelse(is_single, "factor.", "factors.") |
|
| 383 | +483 |
- #' @param scope (`character`) a character vector of decorator names to include.+ ) |
|
| 384 | +484 |
- #' @param decorators (named `list`) of list decorators to subset.+ } else {
|
|
| 385 | +485 |
- #'+ "" |
|
| 386 | +486 |
- #' @return A flat list with all decorators to include.+ } |
|
| 387 | +487 |
- #' It can be an empty list if none of the scope exists in `decorators` argument.+ }) |
|
| 388 | +488 |
- #' @keywords internal+ |
|
| 389 | -+ | ||
| 489 | +! |
- select_decorators <- function(decorators, scope) {
+ teal.widgets::verbatim_popup_srv( |
|
| 390 | +490 | ! |
- checkmate::assert_character(scope, null.ok = TRUE)+ id = "rcode", |
| 391 | +491 | ! |
- scope <- intersect(union("default", scope), names(decorators))
+ verbatim_content = reactive(teal.code::get_code(req(decorated_output_q()))), |
| 392 | +492 | ! |
- c(list(), unlist(decorators[scope], recursive = FALSE))+ title = "Show R Code for Scatterplotmatrix" |
| 393 | +493 |
- }+ ) |
|
| 394 | +494 | ||
| 395 | +495 |
- #' Convert flat list of `teal_transform_module` to named lists+ ### REPORTER |
|
| 396 | -+ | ||
| 496 | +! |
- #'+ if (with_reporter) {
|
|
| 397 | -+ | ||
| 497 | +! |
- #' @param decorators (list of `teal_transform_module`) to normalize.+ card_fun <- function(comment, label) {
|
|
| 398 | -+ | ||
| 498 | +! |
- #' @return A named list of lists with `teal_transform_module` objects.+ card <- teal::report_card_template( |
|
| 399 | -+ | ||
| 499 | +! |
- #' @keywords internal+ title = "Scatter Plot Matrix",+ |
+ |
| 500 | +! | +
+ label = label,+ |
+ |
| 501 | +! | +
+ with_filter = with_filter,+ |
+ |
| 502 | +! | +
+ filter_panel_api = filter_panel_api |
|
| 400 | +503 |
- normalize_decorators <- function(decorators) {
+ ) |
|
| 401 | -5x | +||
| 504 | +! |
- if (checkmate::test_list(decorators, "teal_transform_module", null.ok = TRUE)) {
+ card$append_text("Plot", "header3")
|
|
| 402 | -5x | +||
| 505 | +! |
- if (checkmate::test_names(names(decorators))) {
+ card$append_plot(plot_r(), dim = pws$dim()) |
|
| 403 | +506 | ! |
- lapply(decorators, list)+ if (!comment == "") {
|
| 404 | -+ | ||
| 507 | +! |
- } else {
+ card$append_text("Comment", "header3")
|
|
| 405 | -5x | +||
| 508 | +! |
- list(default = decorators)+ card$append_text(comment) |
|
| 406 | +509 |
- }+ } |
|
| 407 | -+ | ||
| 510 | +! |
- } else {
+ card$append_src(teal.code::get_code(req(decorated_output_q()))) |
|
| 408 | +511 | ! |
- decorators+ card |
| 409 | +512 |
- }+ } |
|
| 410 | -+ | ||
| 513 | +! |
- }+ teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
|
| 1 | +514 |
- #' `teal` module: Cross-table+ } |
|
| 2 | +515 |
- #'+ ### |
|
| 3 | +516 |
- #' Generates a simple cross-table of two variables from a dataset with custom+ }) |
|
| 4 | +517 |
- #' options for showing percentages and sub-totals.+ } |
|
| 5 | +518 |
- #'+ |
|
| 6 | +519 |
- #' @inheritParams teal::module+ #' Get stats for x-y pairs in scatterplot matrix |
|
| 7 | +520 |
- #' @inheritParams shared_params+ #' |
|
| 8 | +521 |
- #' @param x (`data_extract_spec` or `list` of multiple `data_extract_spec`)+ #' Uses [stats::cor.test()] per default for all numerical input variables and converts results |
|
| 9 | +522 |
- #' Object with all available choices with pre-selected option for variable X - row values.+ #' to character vector. |
|
| 10 | +523 |
- #' In case of `data_extract_spec` use `select_spec(..., ordered = TRUE)` if table elements should be+ #' Could be extended if different stats for different variable types are needed. |
|
| 11 | +524 |
- #' rendered according to selection order.+ #' Meant to be called from [lattice::panel.text()]. |
|
| 12 | +525 |
- #' @param y (`data_extract_spec` or `list` of multiple `data_extract_spec`)+ #' |
|
| 13 | +526 |
- #' Object with all available choices with pre-selected option for variable Y - column values.+ #' Presently we need to use a formula input for `stats::cor.test` because |
|
| 14 | +527 |
- #'+ #' `na.fail` only gets evaluated when a formula is passed (see below). |
|
| 15 | +528 |
- #' `data_extract_spec` must not allow multiple selection in this case.+ #' ``` |
|
| 16 | +529 |
- #' @param show_percentage (`logical(1)`)+ #' x = c(1,3,5,7,NA) |
|
| 17 | +530 |
- #' Indicates whether to show percentages (relevant only when `x` is a `factor`).+ #' y = c(3,6,7,8,1) |
|
| 18 | +531 |
- #' Defaults to `TRUE`.+ #' stats::cor.test(x, y, na.action = "na.fail") |
|
| 19 | +532 |
- #' @param show_total (`logical(1)`)+ #' stats::cor.test(~ x + y, na.action = "na.fail") |
|
| 20 | +533 |
- #' Indicates whether to show total column.+ #' ``` |
|
| 21 | +534 |
- #' Defaults to `TRUE`.+ #' |
|
| 22 | +535 |
- #' @param decorators `r roxygen_decorators_param("tm_t_crosstable")`
+ #' @param x,y (`numeric`) vectors of data values. `x` and `y` must have the same length. |
|
| 23 | +536 |
- #'+ #' @param .f (`function`) function that accepts x and y as formula input `~ x + y`. |
|
| 24 | +537 |
- #' @note For more examples, please see the vignette "Using cross table" via+ #' Default `stats::cor.test`. |
|
| 25 | +538 |
- #' `vignette("using-cross-table", package = "teal.modules.general")`.
+ #' @param .f_args (`list`) of arguments to be passed to `.f`. |
|
| 26 | +539 |
- #'+ #' @param round_stat (`integer(1)`) optional, number of decimal places to use when rounding the estimate. |
|
| 27 | +540 |
- #' @inherit shared_params return+ #' @param round_pval (`integer(1)`) optional, number of decimal places to use when rounding the p-value. |
|
| 28 | +541 |
#' |
|
| 29 | +542 |
- #' @section Decorating `tm_t_crosstable`:+ #' @return Character with stats. For [stats::cor.test()] correlation coefficient and p-value. |
|
| 30 | +543 |
#' |
|
| 31 | +544 |
- #' This module generates the following objects, which can be modified in place using decorators:+ #' @examples |
|
| 32 | +545 |
- #' - `table` (`ElementaryTable` - output of `rtables::build_table`)+ #' set.seed(1) |
|
| 33 | +546 |
- #'+ #' x <- runif(25, 0, 1) |
|
| 34 | +547 |
- #' For additional details and examples of decorators, refer to the vignette+ #' y <- runif(25, 0, 1) |
|
| 35 | +548 |
- #' `vignette("decorate-modules-output", package = "teal")` or the [`teal::teal_transform_module()`] documentation.
+ #' x[c(3, 10, 18)] <- NA |
|
| 36 | +549 |
#' |
|
| 37 | +550 |
- #' @examplesShinylive+ #' get_scatterplotmatrix_stats(x, y, .f = stats::cor.test, .f_args = list(method = "pearson")) |
|
| 38 | +551 |
- #' library(teal.modules.general)+ #' get_scatterplotmatrix_stats(x, y, .f = stats::cor.test, .f_args = list( |
|
| 39 | +552 |
- #' interactive <- function() TRUE+ #' method = "pearson", |
|
| 40 | +553 |
- #' {{ next_example }}
+ #' na.action = na.fail |
|
| 41 | +554 |
- #' @examplesIf require("rtables", quietly = TRUE)
+ #' )) |
|
| 42 | +555 |
- #' # general data example+ #' |
|
| 43 | +556 |
- #' data <- teal_data()+ #' @export |
|
| 44 | +557 |
- #' data <- within(data, {
+ #' |
|
| 45 | +558 |
- #' mtcars <- mtcars+ get_scatterplotmatrix_stats <- function(x, y, |
|
| 46 | +559 |
- #' for (v in c("cyl", "vs", "am", "gear")) {
+ .f = stats::cor.test, |
|
| 47 | +560 |
- #' mtcars[[v]] <- as.factor(mtcars[[v]])+ .f_args = list(), |
|
| 48 | +561 |
- #' }+ round_stat = 2, |
|
| 49 | +562 |
- #' mtcars[["primary_key"]] <- seq_len(nrow(mtcars))+ round_pval = 4) {
|
|
| 50 | -+ | ||
| 563 | +6x |
- #' })+ if (is.numeric(x) && is.numeric(y)) {
|
|
| 51 | -+ | ||
| 564 | +3x |
- #' join_keys(data) <- join_keys(join_key("mtcars", "mtcars", "primary_key"))
+ stat <- tryCatch(do.call(.f, c(list(~ x + y), .f_args)), error = function(e) NA) |
|
| 52 | +565 |
- #'+ |
|
| 53 | -+ | ||
| 566 | +3x |
- #' app <- init(+ if (anyNA(stat)) {
|
|
| 54 | -+ | ||
| 567 | +1x |
- #' data = data,+ return("NA")
|
|
| 55 | -+ | ||
| 568 | +2x |
- #' modules = modules(+ } else if (all(c("estimate", "p.value") %in% names(stat))) {
|
|
| 56 | -+ | ||
| 569 | +2x |
- #' tm_t_crosstable(+ return(paste(+ |
+ |
| 570 | +2x | +
+ c(+ |
+ |
| 571 | +2x | +
+ paste0(names(stat$estimate), ":", round(stat$estimate, round_stat)),+ |
+ |
| 572 | +2x | +
+ paste0("P:", round(stat$p.value, round_pval))
|
|
| 57 | +573 |
- #' label = "Cross Table",+ ),+ |
+ |
| 574 | +2x | +
+ collapse = "\n" |
|
| 58 | +575 |
- #' x = data_extract_spec(+ )) |
|
| 59 | +576 |
- #' dataname = "mtcars",+ } else {
+ |
+ |
| 577 | +! | +
+ stop("function not supported")
|
|
| 60 | +578 |
- #' select = select_spec(+ } |
|
| 61 | +579 |
- #' label = "Select variable:",+ } else {
+ |
+ |
| 580 | +3x | +
+ if ("method" %in% names(.f_args)) {
+ |
+ |
| 581 | +3x | +
+ if (.f_args$method == "pearson") {
+ |
+ |
| 582 | +1x | +
+ return("cor:-")
|
|
| 62 | +583 |
- #' choices = variable_choices(data[["mtcars"]], c("cyl", "vs", "am", "gear")),
+ }+ |
+ |
| 584 | +2x | +
+ if (.f_args$method == "kendall") {
+ |
+ |
| 585 | +1x | +
+ return("tau:-")
|
|
| 63 | +586 |
- #' selected = c("cyl", "gear"),
+ }+ |
+ |
| 587 | +1x | +
+ if (.f_args$method == "spearman") {
|
|
| 64 | -+ | ||
| 588 | +1x |
- #' multiple = TRUE,+ return("rho:-")
|
|
| 65 | +589 |
- #' ordered = TRUE,+ } |
|
| 66 | +590 |
- #' fixed = FALSE+ } |
|
| 67 | -+ | ||
| 591 | +! |
- #' )+ return("-")
|
|
| 68 | +592 |
- #' ),+ } |
|
| 69 | +593 |
- #' y = data_extract_spec(+ } |
| 70 | +1 |
- #' dataname = "mtcars",+ #' `teal` module: Data table viewer |
|
| 71 | +2 |
- #' select = select_spec(+ #' |
|
| 72 | +3 |
- #' label = "Select variable:",+ #' Module provides a dynamic and interactive way to view `data.frame`s in a `teal` application. |
|
| 73 | +4 |
- #' choices = variable_choices(data[["mtcars"]], c("cyl", "vs", "am", "gear")),
+ #' It uses the `DT` package to display data tables in a paginated, searchable, and sortable format, |
|
| 74 | +5 |
- #' selected = "vs",+ #' which helps to enhance data exploration and analysis. |
|
| 75 | +6 |
- #' multiple = FALSE,+ #' |
|
| 76 | +7 |
- #' fixed = FALSE+ #' The `DT` package has an option `DT.TOJSON_ARGS` to show `Inf` and `NA` in data tables. |
|
| 77 | +8 |
- #' )+ #' Configure the `DT.TOJSON_ARGS` option via |
|
| 78 | +9 |
- #' )+ #' `options(DT.TOJSON_ARGS = list(na = "string"))` before running the module. |
|
| 79 | +10 |
- #' )+ #' Note though that sorting of numeric columns with `NA`/`Inf` will be lexicographic not numerical. |
|
| 80 | +11 |
- #' )+ #' |
|
| 81 | +12 |
- #' )+ #' @inheritParams teal::module |
|
| 82 | +13 |
- #' if (interactive()) {
+ #' @inheritParams shared_params |
|
| 83 | +14 |
- #' shinyApp(app$ui, app$server)+ #' @param variables_selected (`named list`) Character vectors of the variables (i.e. columns) |
|
| 84 | +15 |
- #' }+ #' which should be initially shown for each dataset. |
|
| 85 | +16 |
- #'+ #' Names of list elements should correspond to the names of the datasets available in the app. |
|
| 86 | +17 |
- #' @examplesShinylive+ #' If no entry is specified for a dataset, the first six variables from that |
|
| 87 | +18 |
- #' library(teal.modules.general)+ #' dataset will initially be shown. |
|
| 88 | +19 |
- #' interactive <- function() TRUE+ #' @param datasets_selected (`character`) A vector of datasets which should be |
|
| 89 | +20 |
- #' {{ next_example }}
+ #' shown and in what order. Names in the vector have to correspond with datasets names. |
|
| 90 | +21 |
- #' @examplesIf require("rtables", quietly = TRUE)
+ #' If vector of `length == 0` (default) then all datasets are shown. |
|
| 91 | +22 |
- #' # CDISC data example+ #' Note: Only datasets of the `data.frame` class are compatible. |
|
| 92 | +23 |
- #' data <- teal_data()+ #' @param dt_args (`named list`) Additional arguments to be passed to [DT::datatable()] |
|
| 93 | +24 |
- #' data <- within(data, {
+ #' (must not include `data` or `options`). |
|
| 94 | +25 |
- #' ADSL <- rADSL+ #' @param dt_options (`named list`) The `options` argument to `DT::datatable`. By default |
|
| 95 | +26 |
- #' })+ #' `list(searching = FALSE, pageLength = 30, lengthMenu = c(5, 15, 30, 100), scrollX = TRUE)` |
|
| 96 | +27 |
- #' join_keys(data) <- default_cdisc_join_keys[names(data)]+ #' @param server_rendering (`logical`) should the data table be rendered server side |
|
| 97 | +28 |
- #'+ #' (see `server` argument of [DT::renderDataTable()]) |
|
| 98 | +29 |
- #' app <- init(+ #' @param decorators `r roxygen_decorators_param("tm_data_table")`
|
|
| 99 | +30 |
- #' data = data,+ #' |
|
| 100 | +31 |
- #' modules = modules(+ #' @inherit shared_params return |
|
| 101 | +32 |
- #' tm_t_crosstable(+ #' |
|
| 102 | +33 |
- #' label = "Cross Table",+ #' @section Decorating `tm_data_table`: |
|
| 103 | +34 |
- #' x = data_extract_spec(+ #' |
|
| 104 | +35 |
- #' dataname = "ADSL",+ #' This module generates the following objects, which can be modified in place using decorators: |
|
| 105 | +36 |
- #' select = select_spec(+ #' - `table` ([DT::datatable()]) |
|
| 106 | +37 |
- #' label = "Select variable:",+ #' |
|
| 107 | +38 |
- #' choices = variable_choices(data[["ADSL"]], subset = function(data) {
+ #' For additional details and examples of decorators, refer to the vignette |
|
| 108 | +39 |
- #' idx <- !vapply(data, inherits, logical(1), c("Date", "POSIXct", "POSIXlt"))
+ #' `vignette("decorate-modules-output", package = "teal")` or the [`teal::teal_transform_module()`] documentation.
|
|
| 109 | +40 |
- #' return(names(data)[idx])+ #' |
|
| 110 | +41 |
- #' }),+ #' @examplesShinylive |
|
| 111 | +42 |
- #' selected = "COUNTRY",+ #' library(teal.modules.general) |
|
| 112 | +43 |
- #' multiple = TRUE,+ #' interactive <- function() TRUE |
|
| 113 | +44 |
- #' ordered = TRUE,+ #' {{ next_example }}
|
|
| 114 | +45 |
- #' fixed = FALSE+ #' @examples |
|
| 115 | +46 |
- #' )+ #' # general data example |
|
| 116 | +47 |
- #' ),+ #' data <- teal_data() |
|
| 117 | +48 |
- #' y = data_extract_spec(+ #' data <- within(data, {
|
|
| 118 | +49 |
- #' dataname = "ADSL",+ #' require(nestcolor) |
|
| 119 | +50 |
- #' select = select_spec(+ #' iris <- iris |
|
| 120 | +51 |
- #' label = "Select variable:",+ #' }) |
|
| 121 | +52 |
- #' choices = variable_choices(data[["ADSL"]], subset = function(data) {
+ #' |
|
| 122 | +53 |
- #' idx <- vapply(data, is.factor, logical(1))+ #' app <- init( |
|
| 123 | +54 |
- #' return(names(data)[idx])+ #' data = data, |
|
| 124 | +55 |
- #' }),+ #' modules = modules( |
|
| 125 | +56 |
- #' selected = "SEX",+ #' tm_data_table( |
|
| 126 | +57 |
- #' multiple = FALSE,+ #' variables_selected = list( |
|
| 127 | +58 |
- #' fixed = FALSE+ #' iris = c("Sepal.Length", "Sepal.Width", "Petal.Length", "Petal.Width", "Species")
|
|
| 128 | +59 |
- #' )+ #' ), |
|
| 129 | +60 |
- #' )+ #' dt_args = list(caption = "IRIS Table Caption") |
|
| 130 | +61 |
#' ) |
|
| 131 | +62 |
#' ) |
|
| 132 | +63 |
#' ) |
|
| 133 | +64 |
#' if (interactive()) {
|
|
| 134 | +65 |
#' shinyApp(app$ui, app$server) |
|
| 135 | +66 |
#' } |
|
| 136 | +67 |
#' |
|
| 137 | +68 |
- #' @export+ #' @examplesShinylive |
|
| 138 | +69 |
- #'+ #' library(teal.modules.general) |
|
| 139 | +70 |
- tm_t_crosstable <- function(label = "Cross Table",+ #' interactive <- function() TRUE |
|
| 140 | +71 |
- x,+ #' {{ next_example }}
|
|
| 141 | +72 |
- y,+ #' @examples |
|
| 142 | +73 |
- show_percentage = TRUE,+ #' # CDISC data example |
|
| 143 | +74 |
- show_total = TRUE,+ #' data <- teal_data() |
|
| 144 | +75 |
- pre_output = NULL,+ #' data <- within(data, {
|
|
| 145 | +76 |
- post_output = NULL,+ #' require(nestcolor) |
|
| 146 | +77 |
- basic_table_args = teal.widgets::basic_table_args(),+ #' ADSL <- teal.data::rADSL |
|
| 147 | +78 |
- decorators = NULL) {
- |
- |
| 148 | -! | -
- message("Initializing tm_t_crosstable")
+ #' }) |
|
| 149 | +79 |
-
+ #' join_keys(data) <- default_cdisc_join_keys[names(data)] |
|
| 150 | +80 |
- # Requires Suggested packages- |
- |
| 151 | -! | -
- if (!requireNamespace("rtables", quietly = TRUE)) {
- |
- |
| 152 | -! | -
- stop("Cannot load rtables - please install the package or restart your session.")
+ #' |
|
| 153 | +81 |
- }+ #' app <- init( |
|
| 154 | +82 |
-
+ #' data = data, |
|
| 155 | +83 |
- # Normalize the parameters- |
- |
| 156 | -! | -
- if (inherits(x, "data_extract_spec")) x <- list(x)- |
- |
| 157 | -! | -
- if (inherits(y, "data_extract_spec")) y <- list(y)+ #' modules = modules( |
|
| 158 | +84 |
-
+ #' tm_data_table( |
|
| 159 | +85 |
- # Start of assertions+ #' variables_selected = list(ADSL = c("STUDYID", "USUBJID", "SUBJID", "SITEID", "AGE", "SEX")),
|
|
| 160 | -! | +||
| 86 | +
- checkmate::assert_string(label)+ #' dt_args = list(caption = "ADSL Table Caption") |
||
| 161 | -! | +||
| 87 | +
- checkmate::assert_list(x, types = "data_extract_spec")+ #' ) |
||
| 162 | +88 |
-
+ #' ) |
|
| 163 | -! | +||
| 89 | +
- checkmate::assert_list(y, types = "data_extract_spec")+ #' ) |
||
| 164 | -! | +||
| 90 | +
- assert_single_selection(y)+ #' if (interactive()) {
|
||
| 165 | +91 |
-
+ #' shinyApp(app$ui, app$server) |
|
| 166 | -! | +||
| 92 | +
- checkmate::assert_flag(show_percentage)+ #' } |
||
| 167 | -! | +||
| 93 | +
- checkmate::assert_flag(show_total)+ #' |
||
| 168 | -! | +||
| 94 | +
- checkmate::assert_multi_class(pre_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
+ #' @export |
||
| 169 | -! | +||
| 95 | +
- checkmate::assert_multi_class(post_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
+ #' |
||
| 170 | -! | +||
| 96 | +
- checkmate::assert_class(basic_table_args, classes = "basic_table_args")+ tm_data_table <- function(label = "Data Table", |
||
| 171 | +97 |
-
+ variables_selected = list(), |
|
| 172 | -! | +||
| 98 | +
- decorators <- normalize_decorators(decorators)+ datasets_selected = character(0), |
||
| 173 | -! | +||
| 99 | +
- assert_decorators(decorators, null.ok = TRUE, "plot")+ dt_args = list(), |
||
| 174 | +100 |
- # End of assertions+ dt_options = list( |
|
| 175 | +101 |
-
+ searching = FALSE, |
|
| 176 | +102 |
- # Make UI args+ pageLength = 30, |
|
| 177 | -! | +||
| 103 | +
- ui_args <- as.list(environment())+ lengthMenu = c(5, 15, 30, 100), |
||
| 178 | +104 |
-
+ scrollX = TRUE |
|
| 179 | -! | +||
| 105 | +
- server_args <- list(+ ), |
||
| 180 | -! | +||
| 106 | +
- label = label,+ server_rendering = FALSE, |
||
| 181 | -! | +||
| 107 | +
- x = x,+ pre_output = NULL, |
||
| 182 | -! | +||
| 108 | +
- y = y,+ post_output = NULL, |
||
| 183 | -! | +||
| 109 | +
- basic_table_args = basic_table_args,+ decorators = NULL) {
|
||
| 184 | +110 | ! |
- decorators = decorators+ message("Initializing tm_data_table")
|
| 185 | +111 |
- )+ |
|
| 186 | +112 | - - | -|
| 187 | -! | -
- ans <- module(+ # Start of assertions |
|
| 188 | +113 | ! |
- label = label,+ checkmate::assert_string(label) |
| 189 | -! | +||
| 114 | +
- server = srv_t_crosstable,+ |
||
| 190 | +115 | ! |
- ui = ui_t_crosstable,+ checkmate::assert_list(variables_selected, min.len = 0, types = "character", names = "named") |
| 191 | +116 | ! |
- ui_args = ui_args,+ if (length(variables_selected) > 0) {
|
| 192 | +117 | ! |
- server_args = server_args,+ lapply(seq_along(variables_selected), function(i) {
|
| 193 | +118 | ! |
- datanames = teal.transform::get_extract_datanames(list(x = x, y = y))- |
-
| 194 | -- |
- )+ checkmate::assert_character(variables_selected[[i]], min.chars = 1, min.len = 1) |
|
| 195 | +119 | ! |
- attr(ans, "teal_bookmarkable") <- TRUE+ if (!is.null(names(variables_selected[[i]]))) {
|
| 196 | +120 | ! |
- ans+ checkmate::assert_names(names(variables_selected[[i]])) |
| 197 | +121 |
- }+ } |
|
| 198 | +122 |
-
+ }) |
|
| 199 | +123 |
- # UI function for the cross-table module+ } |
|
| 200 | +124 |
- ui_t_crosstable <- function(id, x, y, show_percentage, show_total, pre_output, post_output, ...) {
+
|
|
| 201 | +125 | ! |
- args <- list(...)+ checkmate::assert_character(datasets_selected, min.len = 0, min.chars = 1) |
| 202 | +126 | ! |
- ns <- NS(id)+ checkmate::assert( |
| 203 | +127 | ! |
- is_single_dataset <- teal.transform::is_single_dataset(x, y)- |
-
| 204 | -- |
-
+ checkmate::check_list(dt_args, len = 0), |
|
| 205 | +128 | ! |
- join_default_options <- c(+ checkmate::check_subset(names(dt_args), choices = names(formals(DT::datatable))) |
| 206 | -! | +||
| 129 | +
- "Full Join" = "dplyr::full_join",+ ) |
||
| 207 | +130 | ! |
- "Inner Join" = "dplyr::inner_join",+ checkmate::assert_list(dt_options, names = "named") |
| 208 | +131 | ! |
- "Left Join" = "dplyr::left_join",+ checkmate::assert_flag(server_rendering) |
| 209 | +132 | ! |
- "Right Join" = "dplyr::right_join"+ checkmate::assert_multi_class(pre_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
|
| 210 | -+ | ||
| 133 | +! |
- )+ checkmate::assert_multi_class(post_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
|
|
| 211 | +134 | ||
| 212 | -! | -
- teal.widgets::standard_layout(- |
- |
| 213 | -! | -
- output = teal.widgets::white_small_well(- |
- |
| 214 | +135 | ! |
- textOutput(ns("title")),
+ decorators <- normalize_decorators(decorators) |
| 215 | +136 | ! |
- teal.widgets::table_with_settings_ui(ns("table"))
+ assert_decorators(decorators, null.ok = TRUE, "table") |
| 216 | +137 |
- ),- |
- |
| 217 | -! | -
- encoding = tags$div(+ # End of assertions |
|
| 218 | +138 |
- ### Reporter+ |
|
| 219 | +139 | ! |
- teal.reporter::simple_reporter_ui(ns("simple_reporter")),
+ ans <- module( |
| 220 | -+ | ||
| 140 | +! |
- ###+ label, |
|
| 221 | +141 | ! |
- tags$label("Encodings", class = "text-primary"),
+ server = srv_page_data_table, |
| 222 | +142 | ! |
- teal.transform::datanames_input(list(x, y)),+ ui = ui_page_data_table, |
| 223 | +143 | ! |
- teal.transform::data_extract_ui(ns("x"), label = "Row values", x, is_single_dataset = is_single_dataset),
+ datanames = if (length(datasets_selected) == 0) "all" else datasets_selected, |
| 224 | +144 | ! |
- teal.transform::data_extract_ui(ns("y"), label = "Column values", y, is_single_dataset = is_single_dataset),
+ server_args = list( |
| 225 | +145 | ! |
- teal.widgets::optionalSelectInput(+ variables_selected = variables_selected, |
| 226 | +146 | ! |
- ns("join_fun"),
+ datasets_selected = datasets_selected, |
| 227 | +147 | ! |
- label = "Row to Column type of join",+ dt_args = dt_args, |
| 228 | +148 | ! |
- choices = join_default_options,+ dt_options = dt_options, |
| 229 | +149 | ! |
- selected = join_default_options[1],+ server_rendering = server_rendering, |
| 230 | +150 | ! |
- multiple = FALSE+ decorators = decorators |
| 231 | +151 |
- ),+ ), |
|
| 232 | +152 | ! |
- tags$hr(),+ ui_args = list( |
| 233 | +153 | ! |
- teal.widgets::panel_group(+ pre_output = pre_output, |
| 234 | +154 | ! |
- teal.widgets::panel_item(+ post_output = post_output |
| 235 | -! | +||
| 155 | +
- title = "Table settings",+ )+ |
+ ||
| 156 | ++ |
+ ) |
|
| 236 | +157 | ! |
- checkboxInput(ns("show_percentage"), "Show column percentage", value = show_percentage),
+ attr(ans, "teal_bookmarkable") <- TRUE |
| 237 | +158 | ! |
- checkboxInput(ns("show_total"), "Show total column", value = show_total)
+ ans |
| 238 | +159 |
- )+ } |
|
| 239 | +160 |
- ),- |
- |
| 240 | -! | -
- ui_decorate_teal_data(ns("decorator"), decorators = select_decorators(args$decorators, "plot"))
+
|
|
| 241 | +161 |
- ),+ # UI page module |
|
| 242 | -! | +||
| 162 | +
- forms = tagList(+ ui_page_data_table <- function(id, pre_output = NULL, post_output = NULL) {
|
||
| 243 | +163 | ! |
- teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code")
+ ns <- NS(id) |
| 244 | +164 |
- ),+ |
|
| 245 | +165 | ! |
- pre_output = pre_output,+ tagList( |
| 246 | +166 | ! |
- post_output = post_output- |
-
| 247 | -- |
- )+ include_css_files("custom"),
|
|
| 248 | -+ | ||
| 167 | +! |
- }+ teal.widgets::standard_layout( |
|
| 249 | -+ | ||
| 168 | +! |
-
+ output = teal.widgets::white_small_well( |
|
| 250 | -+ | ||
| 169 | +! |
- # Server function for the cross-table module+ fluidRow( |
|
| 251 | -+ | ||
| 170 | +! |
- srv_t_crosstable <- function(id, data, reporter, filter_panel_api, label, x, y, basic_table_args, decorators) {
+ column( |
|
| 252 | +171 | ! |
- with_reporter <- !missing(reporter) && inherits(reporter, "Reporter")+ width = 12, |
| 253 | +172 | ! |
- with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI")+ checkboxInput( |
| 254 | +173 | ! |
- checkmate::assert_class(data, "reactive")+ ns("if_distinct"),
|
| 255 | +174 | ! |
- checkmate::assert_class(isolate(data()), "teal_data")+ "Show only distinct rows:", |
| 256 | +175 | ! |
- moduleServer(id, function(input, output, session) {
+ value = FALSE |
| 257 | -! | +||
| 176 | +
- teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.general")+ ) |
||
| 258 | +177 |
-
+ ) |
|
| 259 | -! | +||
| 178 | +
- selector_list <- teal.transform::data_extract_multiple_srv(+ ), |
||
| 260 | +179 | ! |
- data_extract = list(x = x, y = y),+ fluidRow( |
| 261 | +180 | ! |
- datasets = data,+ class = "mb-8", |
| 262 | +181 | ! |
- select_validation_rule = list(+ column( |
| 263 | +182 | ! |
- x = shinyvalidate::sv_required("Please define column for row variable."),
+ width = 12, |
| 264 | +183 | ! |
- y = shinyvalidate::sv_required("Please define column for column variable.")
+ uiOutput(ns("dataset_table"))
|
| 265 | +184 |
- )+ ) |
|
| 266 | +185 |
- )+ ) |
|
| 267 | +186 |
-
+ ), |
|
| 268 | +187 | ! |
- iv_r <- reactive({
+ pre_output = pre_output, |
| 269 | +188 | ! |
- iv <- shinyvalidate::InputValidator$new()+ post_output = post_output |
| 270 | -! | +||
| 189 | +
- iv$add_rule("join_fun", function(value) {
+ ) |
||
| 271 | -! | +||
| 190 | +
- if (!identical(selector_list()$x()$dataname, selector_list()$y()$dataname)) {
+ ) |
||
| 272 | -! | +||
| 191 | ++ |
+ }+ |
+ |
| 192 | ++ | + + | +|
| 193 | ++ |
+ # Server page module+ |
+ |
| 194 | +
- if (!shinyvalidate::input_provided(value)) {
+ srv_page_data_table <- function(id, |
||
| 273 | -! | +||
| 195 | +
- "Please select a joining function."+ data, |
||
| 274 | +196 |
- }+ datasets_selected, |
|
| 275 | +197 |
- }+ variables_selected, |
|
| 276 | +198 |
- })+ dt_args, |
|
| 277 | -! | +||
| 199 | +
- teal.transform::compose_and_enable_validators(iv, selector_list)+ dt_options, |
||
| 278 | +200 |
- })+ server_rendering, |
|
| 279 | +201 |
-
+ decorators) {
|
|
| 280 | +202 | ! |
- observeEvent(+ checkmate::assert_class(data, "reactive") |
| 281 | +203 | ! |
- eventExpr = {
+ checkmate::assert_class(isolate(data()), "teal_data") |
| 282 | +204 | ! |
- req(!is.null(selector_list()$x()) && !is.null(selector_list()$y()))+ moduleServer(id, function(input, output, session) {
|
| 283 | +205 | ! |
- list(selector_list()$x(), selector_list()$y())+ teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.general") |
| 284 | +206 |
- },- |
- |
| 285 | -! | -
- handlerExpr = {
+
|
|
| 286 | +207 | ! |
- if (identical(selector_list()$x()$dataname, selector_list()$y()$dataname)) {
+ if_filtered <- reactive(as.logical(input$if_filtered)) |
| 287 | +208 | ! |
- shinyjs::hide("join_fun")
+ if_distinct <- reactive(as.logical(input$if_distinct)) |
| 288 | +209 |
- } else {
+
|
|
| 289 | +210 | ! |
- shinyjs::show("join_fun")
+ datanames <- isolate(names(data())) |
| 290 | -+ | ||
| 211 | +! |
- }+ datanames <- Filter(function(name) {
|
|
| 291 | -+ | ||
| 212 | +! |
- }+ is.data.frame(isolate(data())[[name]]) |
|
| 292 | -+ | ||
| 213 | +! |
- )+ }, datanames) |
|
| 293 | +214 | ||
| 294 | +215 | ! |
- merge_function <- reactive({
+ if (!identical(datasets_selected, character(0))) {
|
| 295 | +216 | ! |
- if (is.null(input$join_fun)) {
+ checkmate::assert_subset(datasets_selected, datanames) |
| 296 | +217 | ! |
- "dplyr::full_join"+ datanames <- datasets_selected |
| 297 | +218 |
- } else {
+ } |
|
| 298 | -! | +||
| 219 | +
- input$join_fun+ |
||
| 299 | -+ | ||
| 220 | +! |
- }+ output$dataset_table <- renderUI({
|
|
| 300 | -+ | ||
| 221 | +! |
- })+ do.call( |
|
| 301 | -+ | ||
| 222 | +! |
-
+ tabsetPanel, |
|
| 302 | +223 | ! |
- anl_merged_input <- teal.transform::merge_expression_srv(+ c( |
| 303 | +224 | ! |
- datasets = data,+ list(id = session$ns("dataname_tab")),
|
| 304 | +225 | ! |
- selector_list = selector_list,+ lapply( |
| 305 | +226 | ! |
- merge_function = merge_function+ datanames, |
| 306 | -+ | ||
| 227 | +! |
- )+ function(x) {
|
|
| 307 | -+ | ||
| 228 | +! |
-
+ dataset <- isolate(data()[[x]]) |
|
| 308 | +229 | ! |
- anl_merged_q <- reactive({
+ choices <- names(dataset) |
| 309 | +230 | ! |
- req(anl_merged_input())+ labels <- vapply( |
| 310 | +231 | ! |
- data() %>%+ dataset, |
| 311 | +232 | ! |
- teal.code::eval_code(as.expression(anl_merged_input()$expr))+ function(x) ifelse(is.null(attr(x, "label")), "", attr(x, "label")), |
| 312 | -+ | ||
| 233 | +! |
- })+ character(1) |
|
| 313 | +234 |
-
+ ) |
|
| 314 | +235 | ! |
- merged <- list(+ names(choices) <- ifelse( |
| 315 | +236 | ! |
- anl_input_r = anl_merged_input,+ is.na(labels) | labels == "", |
| 316 | +237 | ! |
- anl_q_r = anl_merged_q+ choices, |
| 317 | -+ | ||
| 238 | +! |
- )+ paste(choices, labels, sep = ": ") |
|
| 318 | +239 |
-
+ ) |
|
| 319 | +240 | ! |
- output_q <- reactive({
+ variables_selected <- if (!is.null(variables_selected[[x]])) {
|
| 320 | +241 | ! |
- teal::validate_inputs(iv_r())+ variables_selected[[x]]+ |
+
| 242 | ++ |
+ } else {
|
|
| 321 | +243 | ! |
- ANL <- merged$anl_q_r()[["ANL"]]+ utils::head(choices) |
| 322 | +244 |
-
+ } |
|
| 323 | -+ | ||
| 245 | +! |
- # As this is a summary+ tabPanel( |
|
| 324 | +246 | ! |
- x_name <- as.vector(merged$anl_input_r()$columns_source$x)+ title = x, |
| 325 | +247 | ! |
- y_name <- as.vector(merged$anl_input_r()$columns_source$y)+ column( |
| 326 | -+ | ||
| 248 | +! |
-
+ width = 12, |
|
| 327 | +249 | ! |
- teal::validate_has_data(ANL, 3)+ div( |
| 328 | +250 | ! |
- teal::validate_has_data(ANL[, c(x_name, y_name)], 3, complete = TRUE, allow_inf = FALSE)+ class = "mt-4", |
| 329 | -+ | ||
| 251 | +! |
-
+ ui_data_table( |
|
| 330 | +252 | ! |
- is_allowed_class <- function(x) is.numeric(x) || is.factor(x) || is.character(x) || is.logical(x)+ id = session$ns(x), |
| 331 | +253 | ! |
- validate(need(+ choices = choices, |
| 332 | +254 | ! |
- all(vapply(ANL[x_name], is_allowed_class, logical(1))),+ selected = variables_selected, |
| 333 | +255 | ! |
- "Selected row variable has an unsupported data type."+ decorators = decorators |
| 334 | +256 |
- ))+ ) |
|
| 335 | -! | +||
| 257 | +
- validate(need(+ ) |
||
| 336 | -! | +||
| 258 | +
- is_allowed_class(ANL[[y_name]]),+ ) |
||
| 337 | -! | +||
| 259 | +
- "Selected column variable has an unsupported data type."+ ) |
||
| 338 | +260 |
- ))+ } |
|
| 339 | +261 |
-
+ ) |
|
| 340 | -! | +||
| 262 | +
- show_percentage <- input$show_percentage+ ) |
||
| 341 | -! | +||
| 263 | +
- show_total <- input$show_total+ ) |
||
| 342 | +264 | ++ |
+ })+ |
+
| 265 | |||
| 343 | +266 | ! |
- plot_title <- paste(+ lapply( |
| 344 | +267 | ! |
- "Cross-Table of",+ datanames, |
| 345 | +268 | ! |
- paste0(varname_w_label(x_name, ANL), collapse = ", "),+ function(x) {
|
| 346 | +269 | ! |
- "(rows)", "vs.",+ srv_data_table( |
| 347 | +270 | ! |
- varname_w_label(y_name, ANL),+ id = x, |
| 348 | +271 | ! |
- "(columns)"+ data = data, |
| 349 | -+ | ||
| 272 | +! |
- )+ dataname = x, |
|
| 350 | -+ | ||
| 273 | +! |
-
+ if_filtered = if_filtered, |
|
| 351 | +274 | ! |
- labels_vec <- vapply(+ if_distinct = if_distinct, |
| 352 | +275 | ! |
- x_name,+ dt_args = dt_args, |
| 353 | +276 | ! |
- varname_w_label,+ dt_options = dt_options, |
| 354 | +277 | ! |
- character(1),+ server_rendering = server_rendering, |
| 355 | +278 | ! |
- ANL+ decorators = decorators |
| 356 | +279 |
- )+ ) |
|
| 357 | +280 |
-
+ } |
|
| 358 | -! | +||
| 281 | +
- teal.code::eval_code(+ ) |
||
| 359 | -! | +||
| 282 | +
- merged$anl_q_r(),+ }) |
||
| 360 | -! | +||
| 283 | +
- substitute(+ } |
||
| 361 | -! | +||
| 284 | +
- expr = {
+
|
||
| 362 | -! | +||
| 285 | +
- title <- plot_title+ # UI function for the data_table module+ |
+ ||
| 286 | ++ |
+ ui_data_table <- function(id,+ |
+ |
| 287 | ++ |
+ choices,+ |
+ |
| 288 | ++ |
+ selected, |
|
| 363 | +289 |
- },+ decorators) {
|
|
| 364 | +290 | ! |
- env = list(plot_title = plot_title)- |
-
| 365 | -- |
- )+ ns <- NS(id) |
|
| 366 | +291 |
- ) %>%+ |
|
| 367 | +292 | ! |
- teal.code::eval_code(+ if (!is.null(selected)) {
|
| 368 | +293 | ! |
- substitute(+ all_choices <- choices |
| 369 | +294 | ! |
- expr = {
+ choices <- c(selected, setdiff(choices, selected)) |
| 370 | +295 | ! |
- table <- basic_tables %>%+ names(choices) <- names(all_choices)[match(choices, all_choices)] |
| 371 | -! | +||
| 296 | +
- split_call %>% # styler: off+ } |
||
| 372 | -! | +||
| 297 | +
- rtables::add_colcounts() %>%+ |
||
| 373 | +298 | ! |
- tern::analyze_vars(+ tagList( |
| 374 | +299 | ! |
- vars = x_name,+ teal.widgets::get_dt_rows(ns("data_table"), ns("dt_rows")),
|
| 375 | +300 | ! |
- var_labels = labels_vec,+ fluidRow( |
| 376 | +301 | ! |
- na.rm = FALSE,+ ui_decorate_teal_data(ns("decorator"), decorators = select_decorators(decorators, "table")),
|
| 377 | +302 | ! |
- denom = "N_col",+ teal.widgets::optionalSelectInput( |
| 378 | +303 | ! |
- .stats = c("mean_sd", "median", "range", count_value)
+ ns("variables"),
|
| 379 | -+ | ||
| 304 | +! |
- )+ "Select variables:", |
|
| 380 | -+ | ||
| 305 | +! |
- },+ choices = choices, |
|
| 381 | +306 | ! |
- env = list(+ selected = selected, |
| 382 | +307 | ! |
- basic_tables = teal.widgets::parse_basic_table_args(+ multiple = TRUE, |
| 383 | +308 | ! |
- basic_table_args = teal.widgets::resolve_basic_table_args(basic_table_args)+ width = "100%" |
| 384 | +309 |
- ),+ ) |
|
| 385 | -! | +||
| 310 | +
- split_call = if (show_total) {
+ ), |
||
| 386 | +311 | ! |
- substitute(+ fluidRow( |
| 387 | +312 | ! |
- expr = rtables::split_cols_by(+ DT::dataTableOutput(ns("data_table"), width = "100%")
|
| 388 | -! | +||
| 313 | +
- y_name,+ ) |
||
| 389 | -! | +||
| 314 | +
- split_fun = rtables::add_overall_level(label = "Total", first = FALSE)+ ) |
||
| 390 | +315 |
- ),+ } |
|
| 391 | -! | +||
| 316 | +
- env = list(y_name = y_name)+ |
||
| 392 | +317 |
- )+ # Server function for the data_table module |
|
| 393 | +318 |
- } else {
+ srv_data_table <- function(id, |
|
| 394 | -! | +||
| 319 | +
- substitute(rtables::split_cols_by(y_name), env = list(y_name = y_name))+ data, |
||
| 395 | +320 |
- },+ dataname, |
|
| 396 | -! | +||
| 321 | +
- x_name = x_name,+ if_filtered, |
||
| 397 | -! | +||
| 322 | +
- labels_vec = labels_vec,+ if_distinct, |
||
| 398 | -! | +||
| 323 | +
- count_value = ifelse(show_percentage, "count_fraction", "count")+ dt_args, |
||
| 399 | +324 |
- )+ dt_options, |
|
| 400 | +325 |
- )+ server_rendering, |
|
| 401 | +326 |
- ) %>%+ decorators) {
|
|
| 402 | +327 | ! |
- teal.code::eval_code(+ moduleServer(id, function(input, output, session) {
|
| 403 | +328 | ! |
- substitute(+ iv <- shinyvalidate::InputValidator$new() |
| 404 | +329 | ! |
- expr = {
+ iv$add_rule("variables", shinyvalidate::sv_required("Please select valid variable names"))
|
| 405 | +330 | ! |
- ANL <- tern::df_explicit_na(ANL)+ iv$add_rule("variables", shinyvalidate::sv_in_set(
|
| 406 | +331 | ! |
- table <- rtables::build_table(lyt = table, df = ANL[order(ANL[[y_name]]), ])+ set = names(isolate(data())[[dataname]]), message_fmt = "Not all selected variables exist in the data" |
| 407 | +332 |
- },+ )) |
|
| 408 | +333 | ! |
- env = list(y_name = y_name)+ iv$enable() |
| 409 | +334 |
- )+ |
|
| 410 | -+ | ||
| 335 | +! |
- )+ data_table_data <- reactive({
|
|
| 411 | -+ | ||
| 336 | +! |
- })+ df <- data()[[dataname]] |
|
| 412 | +337 | ||
| 413 | +338 | ! |
- decorated_output_q <- srv_decorate_teal_data(+ teal::validate_has_data(df, min_nrow = 1L, msg = paste("data", dataname, "is empty"))
|
| 414 | -! | +||
| 339 | +
- id = "decorator",+ |
||
| 415 | +340 | ! |
- data = output_q,+ teal.code::eval_code( |
| 416 | +341 | ! |
- decorators = select_decorators(decorators, "plot"),+ data(), |
| 417 | +342 | ! |
- expr = table- |
-
| 418 | -- |
- )- |
- |
| 419 | -- |
-
+ substitute( |
|
| 420 | +343 | ! |
- output$title <- renderText(req(decorated_output_q())[["title"]])- |
-
| 421 | -- |
-
+ expr = {
|
|
| 422 | +344 | ! |
- table_r <- reactive({
+ variables <- vars |
| 423 | +345 | ! |
- req(iv_r()$is_valid())+ dataframe_selected <- if (if_distinct) {
|
| 424 | +346 | ! |
- req(decorated_output_q())[["table"]]+ dplyr::count(dataname, dplyr::across(dplyr::all_of(variables))) |
| 425 | +347 |
- })+ } else {
+ |
+ |
| 348 | +! | +
+ dataname[variables] |
|
| 426 | +349 |
-
+ } |
|
| 427 | +350 | ! |
- teal.widgets::table_with_settings_srv(+ dt_args <- args |
| 428 | +351 | ! |
- id = "table",+ dt_args$options <- dt_options |
| 429 | +352 | ! |
- table_r = table_r+ if (!is.null(dt_rows)) {
|
| 430 | -+ | ||
| 353 | +! |
- )+ dt_args$options$pageLength <- dt_rows |
|
| 431 | +354 |
-
+ } |
|
| 432 | +355 | ! |
- teal.widgets::verbatim_popup_srv(+ dt_args$data <- dataframe_selected |
| 433 | +356 | ! |
- id = "rcode",+ table <- do.call(DT::datatable, dt_args) |
| 434 | -! | +||
| 357 | +
- verbatim_content = reactive(teal.code::get_code(req(decorated_output_q()))),+ }, |
||
| 435 | +358 | ! |
- title = "Show R Code for Cross-Table"- |
-
| 436 | -- |
- )+ env = list( |
|
| 437 | -+ | ||
| 359 | +! |
-
+ dataname = as.name(dataname), |
|
| 438 | -+ | ||
| 360 | +! |
- ### REPORTER+ if_distinct = if_distinct(), |
|
| 439 | +361 | ! |
- if (with_reporter) {
+ vars = input$variables, |
| 440 | +362 | ! |
- card_fun <- function(comment, label) {
+ args = dt_args, |
| 441 | +363 | ! |
- card <- teal::report_card_template(+ dt_options = dt_options, |
| 442 | +364 | ! |
- title = "Cross Table",+ dt_rows = input$dt_rows |
| 443 | -! | +||
| 365 | +
- label = label,+ ) |
||
| 444 | -! | +||
| 366 | +
- with_filter = with_filter,+ ) |
||
| 445 | -! | +||
| 367 | +
- filter_panel_api = filter_panel_api+ ) |
||
| 446 | +368 |
- )+ }) |
|
| 447 | -! | +||
| 369 | +
- card$append_text("Table", "header3")
+
|
||
| 448 | +370 | ! |
- card$append_table(table_r())+ decorated_data_table_data <- srv_decorate_teal_data( |
| 449 | +371 | ! |
- if (!comment == "") {
+ id = "decorator", |
| 450 | +372 | ! |
- card$append_text("Comment", "header3")
+ data = data_table_data, |
| 451 | +373 | ! |
- card$append_text(comment)+ decorators = select_decorators(decorators, "table") |
| 452 | +374 |
- }+ ) |
|
| 453 | -! | +||
| 375 | +
- card$append_src(teal.code::get_code(req(decorated_output_q())))+ |
||
| 454 | +376 | ! |
- card- |
-
| 455 | -- |
- }+ output$data_table <- DT::renderDataTable(server = server_rendering, {
|
|
| 456 | +377 | ! |
- teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
+ teal::validate_inputs(iv) |
| 457 | -+ | ||
| 378 | +! |
- }+ req(decorated_data_table_data())[["table"]] |
|
| 458 | +379 |
- ###+ }) |
|
| 459 | +380 |
}) |
|
| 460 | +381 |
} |