| 1 | ++ |
+ #' `teal` module: Distribution analysis+ |
+
| 2 | ++ |
+ #'+ |
+
| 3 | ++ |
+ #' Module is designed to explore the distribution of a single variable within a given dataset.+ |
+
| 4 | ++ |
+ #' It offers several tools, such as histograms, Q-Q plots, and various statistical tests to+ |
+
| 5 | ++ |
+ #' visually and statistically analyze the variable's distribution.+ |
+
| 6 | ++ |
+ #'+ |
+
| 7 | ++ |
+ #' @inheritParams teal::module+ |
+
| 8 | ++ |
+ #' @inheritParams teal.widgets::standard_layout+ |
+
| 9 | ++ |
+ #' @inheritParams shared_params+ |
+
| 10 | ++ |
+ #'+ |
+
| 11 | ++ |
+ #' @param dist_var (`data_extract_spec` or `list` of multiple `data_extract_spec`)+ |
+
| 12 | ++ |
+ #' Variable(s) for which the distribution will be analyzed.+ |
+
| 13 | ++ |
+ #' @param strata_var (`data_extract_spec` or `list` of multiple `data_extract_spec`)+ |
+
| 14 | ++ |
+ #' Categorical variable used to split the distribution analysis.+ |
+
| 15 | ++ |
+ #' @param group_var (`data_extract_spec` or `list` of multiple `data_extract_spec`)+ |
+
| 16 | ++ |
+ #' Variable used for faceting plot into multiple panels.+ |
+
| 17 | ++ |
+ #' @param freq (`logical`) optional, whether to display frequency (`TRUE`) or density (`FALSE`).+ |
+
| 18 | ++ |
+ #' Defaults to density (`FALSE`).+ |
+
| 19 | ++ |
+ #' @param bins (`integer(1)` or `integer(3)`) optional, specifies the number of bins for the histogram.+ |
+
| 20 | ++ |
+ #' - 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 | ++ |
+ #' and `max`.+ |
+
| 23 | ++ |
+ #' Defaults to `c(30L, 1L, 100L)`.+ |
+
| 24 | ++ |
+ #'+ |
+
| 25 | ++ |
+ #' @templateVar ggnames "Histogram", "QQplot"+ |
+
| 26 | ++ |
+ #' @template ggplot2_args_multi+ |
+
| 27 | ++ |
+ #'+ |
+
| 28 | ++ |
+ #' @inherit shared_params return+ |
+
| 29 | ++ |
+ #'+ |
+
| 30 | ++ |
+ #' @examples+ |
+
| 31 | ++ |
+ #' library(teal.widgets)+ |
+
| 32 | ++ |
+ #'+ |
+
| 33 | ++ |
+ #' # general data example+ |
+
| 34 | ++ |
+ #' data <- teal_data()+ |
+
| 35 | ++ |
+ #' data <- within(data, {
+ |
+
| 36 | ++ |
+ #' iris <- iris+ |
+
| 37 | ++ |
+ #' })+ |
+
| 38 | ++ |
+ #' datanames(data) <- "iris"+ |
+
| 39 | ++ |
+ #'+ |
+
| 40 | ++ |
+ #' app <- init(+ |
+
| 41 | ++ |
+ #' data = data,+ |
+
| 42 | ++ |
+ #' modules = list(+ |
+
| 43 | ++ |
+ #' tm_g_distribution(+ |
+
| 44 | ++ |
+ #' dist_var = data_extract_spec(+ |
+
| 45 | ++ |
+ #' dataname = "iris",+ |
+
| 46 | ++ |
+ #' select = select_spec(variable_choices("iris"), "Petal.Length")
+ |
+
| 47 | ++ |
+ #' ),+ |
+
| 48 | ++ |
+ #' ggplot2_args = ggplot2_args(+ |
+
| 49 | ++ |
+ #' labs = list(subtitle = "Plot generated by Distribution Module")+ |
+
| 50 | ++ |
+ #' )+ |
+
| 51 | ++ |
+ #' )+ |
+
| 52 | ++ |
+ #' )+ |
+
| 53 | ++ |
+ #' )+ |
+
| 54 | ++ |
+ #' if (interactive()) {
+ |
+
| 55 | ++ |
+ #' shinyApp(app$ui, app$server)+ |
+
| 56 | ++ |
+ #' }+ |
+
| 57 | ++ |
+ #'+ |
+
| 58 | ++ |
+ #' # CDISC data example+ |
+
| 59 | ++ |
+ #' data <- teal_data()+ |
+
| 60 | ++ |
+ #' data <- within(data, {
+ |
+
| 61 | ++ |
+ #' ADSL <- rADSL+ |
+
| 62 | ++ |
+ #' })+ |
+
| 63 | ++ |
+ #' datanames(data) <- c("ADSL")
+ |
+
| 64 | ++ |
+ #' join_keys(data) <- default_cdisc_join_keys[datanames(data)]+ |
+
| 65 | ++ |
+ #'+ |
+
| 66 | ++ |
+ #' vars1 <- choices_selected(+ |
+
| 67 | ++ |
+ #' variable_choices(data[["ADSL"]], c("ARM", "COUNTRY", "SEX")),
+ |
+
| 68 | ++ |
+ #' selected = NULL+ |
+
| 69 | ++ |
+ #' )+ |
+
| 70 | ++ |
+ #'+ |
+
| 71 | ++ |
+ #' app <- init(+ |
+
| 72 | ++ |
+ #' data = data,+ |
+
| 73 | ++ |
+ #' modules = modules(+ |
+
| 74 | ++ |
+ #' tm_g_distribution(+ |
+
| 75 | ++ |
+ #' dist_var = data_extract_spec(+ |
+
| 76 | ++ |
+ #' dataname = "ADSL",+ |
+
| 77 | ++ |
+ #' select = select_spec(+ |
+
| 78 | ++ |
+ #' choices = variable_choices(data[["ADSL"]], c("AGE", "BMRKR1")),
+ |
+
| 79 | ++ |
+ #' selected = "BMRKR1",+ |
+
| 80 | ++ |
+ #' multiple = FALSE,+ |
+
| 81 | ++ |
+ #' fixed = FALSE+ |
+
| 82 | ++ |
+ #' )+ |
+
| 83 | ++ |
+ #' ),+ |
+
| 84 | ++ |
+ #' strata_var = data_extract_spec(+ |
+
| 85 | ++ |
+ #' dataname = "ADSL",+ |
+
| 86 | ++ |
+ #' filter = filter_spec(+ |
+
| 87 | ++ |
+ #' vars = vars1,+ |
+
| 88 | ++ |
+ #' multiple = TRUE+ |
+
| 89 | ++ |
+ #' )+ |
+
| 90 | ++ |
+ #' ),+ |
+
| 91 | ++ |
+ #' group_var = data_extract_spec(+ |
+
| 92 | ++ |
+ #' dataname = "ADSL",+ |
+
| 93 | ++ |
+ #' filter = filter_spec(+ |
+
| 94 | ++ |
+ #' vars = vars1,+ |
+
| 95 | ++ |
+ #' multiple = TRUE+ |
+
| 96 | ++ |
+ #' )+ |
+
| 97 | ++ |
+ #' ),+ |
+
| 98 | ++ |
+ #' ggplot2_args = ggplot2_args(+ |
+
| 99 | ++ |
+ #' labs = list(subtitle = "Plot generated by Distribution Module")+ |
+
| 100 | ++ |
+ #' )+ |
+
| 101 | ++ |
+ #' )+ |
+
| 102 | ++ |
+ #' )+ |
+
| 103 | ++ |
+ #' )+ |
+
| 104 | ++ |
+ #' if (interactive()) {
+ |
+
| 105 | ++ |
+ #' shinyApp(app$ui, app$server)+ |
+
| 106 | ++ |
+ #' }+ |
+
| 107 | ++ |
+ #'+ |
+
| 108 | ++ |
+ #' @export+ |
+
| 109 | ++ |
+ #'+ |
+
| 110 | ++ |
+ tm_g_distribution <- function(label = "Distribution Module",+ |
+
| 111 | ++ |
+ dist_var,+ |
+
| 112 | ++ |
+ strata_var = NULL,+ |
+
| 113 | ++ |
+ group_var = NULL,+ |
+
| 114 | ++ |
+ freq = FALSE,+ |
+
| 115 | ++ |
+ ggtheme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void"),
+ |
+
| 116 | ++ |
+ ggplot2_args = teal.widgets::ggplot2_args(),+ |
+
| 117 | ++ |
+ bins = c(30L, 1L, 100L),+ |
+
| 118 | ++ |
+ plot_height = c(600, 200, 2000),+ |
+
| 119 | ++ |
+ plot_width = NULL,+ |
+
| 120 | ++ |
+ pre_output = NULL,+ |
+
| 121 | ++ |
+ post_output = NULL) {
+ |
+
| 122 | +! | +
+ logger::log_info("Initializing tm_g_distribution")
+ |
+
| 123 | ++ | + + | +
| 124 | ++ |
+ # Requires Suggested packages+ |
+
| 125 | +! | +
+ extra_packages <- c("ggpmisc", "ggpp", "goftest", "MASS", "broom")
+ |
+
| 126 | +! | +
+ missing_packages <- Filter(function(x) !requireNamespace(x, quietly = TRUE), extra_packages)+ |
+
| 127 | +! | +
+ if (length(missing_packages) > 0L) {
+ |
+
| 128 | +! | +
+ stop(sprintf(+ |
+
| 129 | +! | +
+ "Cannot load package(s): %s.\nInstall or restart your session.",+ |
+
| 130 | +! | +
+ toString(missing_packages)+ |
+
| 131 | ++ |
+ ))+ |
+
| 132 | ++ |
+ }+ |
+
| 133 | ++ | + + | +
| 134 | ++ |
+ # Normalize the parameters+ |
+
| 135 | +! | +
+ if (inherits(dist_var, "data_extract_spec")) dist_var <- list(dist_var)+ |
+
| 136 | +! | +
+ if (inherits(strata_var, "data_extract_spec")) strata_var <- list(strata_var)+ |
+
| 137 | +! | +
+ if (inherits(group_var, "data_extract_spec")) group_var <- list(group_var)+ |
+
| 138 | +! | +
+ if (inherits(ggplot2_args, "ggplot2_args")) ggplot2_args <- list(default = ggplot2_args)+ |
+
| 139 | ++ | + + | +
| 140 | ++ |
+ # Start of assertions+ |
+
| 141 | +! | +
+ checkmate::assert_string(label)+ |
+
| 142 | ++ | + + | +
| 143 | +! | +
+ checkmate::assert_list(dist_var, "data_extract_spec")+ |
+
| 144 | +! | +
+ checkmate::assert_false(dist_var[[1L]]$select$multiple)+ |
+
| 145 | ++ | + + | +
| 146 | +! | +
+ checkmate::assert_list(strata_var, types = "data_extract_spec", null.ok = TRUE)+ |
+
| 147 | +! | +
+ checkmate::assert_list(group_var, types = "data_extract_spec", null.ok = TRUE)+ |
+
| 148 | +! | +
+ checkmate::assert_flag(freq)+ |
+
| 149 | +! | +
+ ggtheme <- match.arg(ggtheme)+ |
+
| 150 | ++ | + + | +
| 151 | +! | +
+ plot_choices <- c("Histogram", "QQplot")
+ |
+
| 152 | +! | +
+ checkmate::assert_list(ggplot2_args, types = "ggplot2_args")+ |
+
| 153 | +! | +
+ checkmate::assert_subset(names(ggplot2_args), c("default", plot_choices))
+ |
+
| 154 | ++ | + + | +
| 155 | +! | +
+ if (length(bins) == 1) {
+ |
+
| 156 | +! | +
+ checkmate::assert_numeric(bins, any.missing = FALSE, lower = 1)+ |
+
| 157 | ++ |
+ } else {
+ |
+
| 158 | +! | +
+ checkmate::assert_numeric(bins, len = 3, any.missing = FALSE, lower = 1)+ |
+
| 159 | +! | +
+ checkmate::assert_numeric(bins[1], lower = bins[2], upper = bins[3], .var.name = "bins")+ |
+
| 160 | ++ |
+ }+ |
+
| 161 | ++ | + + | +
| 162 | +! | +
+ checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE)+ |
+
| 163 | +! | +
+ checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height")+ |
+
| 164 | +! | +
+ checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE)+ |
+
| 165 | +! | +
+ checkmate::assert_numeric(+ |
+
| 166 | +! | +
+ plot_width[1],+ |
+
| 167 | +! | +
+ lower = plot_width[2], upper = plot_width[3], null.ok = TRUE, .var.name = "plot_width"+ |
+
| 168 | ++ |
+ )+ |
+
| 169 | ++ | + + | +
| 170 | +! | +
+ checkmate::assert_multi_class(pre_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
+ |
+
| 171 | +! | +
+ checkmate::assert_multi_class(post_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
+ |
+
| 172 | ++ |
+ # End of assertions+ |
+
| 173 | ++ | + + | +
| 174 | ++ |
+ # Make UI args+ |
+
| 175 | +! | +
+ args <- as.list(environment())+ |
+
| 176 | ++ | + + | +
| 177 | +! | +
+ data_extract_list <- list(+ |
+
| 178 | +! | +
+ dist_var = dist_var,+ |
+
| 179 | +! | +
+ strata_var = strata_var,+ |
+
| 180 | +! | +
+ group_var = group_var+ |
+
| 181 | ++ |
+ )+ |
+
| 182 | ++ | + + | +
| 183 | +! | +
+ module(+ |
+
| 184 | +! | +
+ label = label,+ |
+
| 185 | +! | +
+ server = srv_distribution,+ |
+
| 186 | +! | +
+ server_args = c(+ |
+
| 187 | +! | +
+ data_extract_list,+ |
+
| 188 | +! | +
+ list(plot_height = plot_height, plot_width = plot_width, ggplot2_args = ggplot2_args)+ |
+
| 189 | ++ |
+ ),+ |
+
| 190 | +! | +
+ ui = ui_distribution,+ |
+
| 191 | +! | +
+ ui_args = args,+ |
+
| 192 | +! | +
+ datanames = teal.transform::get_extract_datanames(data_extract_list)+ |
+
| 193 | ++ |
+ )+ |
+
| 194 | ++ |
+ }+ |
+
| 195 | ++ | + + | +
| 196 | ++ |
+ # UI function for the distribution module+ |
+
| 197 | ++ |
+ ui_distribution <- function(id, ...) {
+ |
+
| 198 | +! | +
+ args <- list(...)+ |
+
| 199 | +! | +
+ ns <- NS(id)+ |
+
| 200 | +! | +
+ is_single_dataset_value <- teal.transform::is_single_dataset(args$dist_var, args$strata_var, args$group_var)+ |
+
| 201 | ++ | + + | +
| 202 | +! | +
+ teal.widgets::standard_layout(+ |
+
| 203 | +! | +
+ output = teal.widgets::white_small_well(+ |
+
| 204 | +! | +
+ tabsetPanel(+ |
+
| 205 | +! | +
+ id = ns("tabs"),
+ |
+
| 206 | +! | +
+ tabPanel("Histogram", teal.widgets::plot_with_settings_ui(id = ns("hist_plot"))),
+ |
+
| 207 | +! | +
+ tabPanel("QQplot", teal.widgets::plot_with_settings_ui(id = ns("qq_plot")))
+ |
+
| 208 | ++ |
+ ),+ |
+
| 209 | +! | +
+ h3("Statistics Table"),
+ |
+
| 210 | +! | +
+ DT::dataTableOutput(ns("summary_table")),
+ |
+
| 211 | +! | +
+ h3("Tests"),
+ |
+
| 212 | +! | +
+ DT::dataTableOutput(ns("t_stats"))
+ |
+
| 213 | ++ |
+ ),+ |
+
| 214 | +! | +
+ encoding = div(+ |
+
| 215 | ++ |
+ ### Reporter+ |
+
| 216 | +! | +
+ teal.reporter::simple_reporter_ui(ns("simple_reporter")),
+ |
+
| 217 | ++ |
+ ###+ |
+
| 218 | +! | +
+ tags$label("Encodings", class = "text-primary"),
+ |
+
| 219 | +! | +
+ teal.transform::datanames_input(args[c("dist_var", "strata_var")]),
+ |
+
| 220 | +! | +
+ teal.transform::data_extract_ui(+ |
+
| 221 | +! | +
+ id = ns("dist_i"),
+ |
+
| 222 | +! | +
+ label = "Variable",+ |
+
| 223 | +! | +
+ data_extract_spec = args$dist_var,+ |
+
| 224 | +! | +
+ is_single_dataset = is_single_dataset_value+ |
+
| 225 | ++ |
+ ),+ |
+
| 226 | +! | +
+ if (!is.null(args$group_var)) {
+ |
+
| 227 | +! | +
+ tagList(+ |
+
| 228 | +! | +
+ teal.transform::data_extract_ui(+ |
+
| 229 | +! | +
+ id = ns("group_i"),
+ |
+
| 230 | +! | +
+ label = "Group by",+ |
+
| 231 | +! | +
+ data_extract_spec = args$group_var,+ |
+
| 232 | +! | +
+ is_single_dataset = is_single_dataset_value+ |
+
| 233 | ++ |
+ ),+ |
+
| 234 | +! | +
+ uiOutput(ns("scales_types_ui"))
+ |
+
| 235 | ++ |
+ )+ |
+
| 236 | ++ |
+ },+ |
+
| 237 | +! | +
+ if (!is.null(args$strata_var)) {
+ |
+
| 238 | +! | +
+ teal.transform::data_extract_ui(+ |
+
| 239 | +! | +
+ id = ns("strata_i"),
+ |
+
| 240 | +! | +
+ label = "Stratify by",+ |
+
| 241 | +! | +
+ data_extract_spec = args$strata_var,+ |
+
| 242 | +! | +
+ is_single_dataset = is_single_dataset_value+ |
+
| 243 | ++ |
+ )+ |
+
| 244 | ++ |
+ },+ |
+
| 245 | +! | +
+ teal.widgets::panel_group(+ |
+
| 246 | +! | +
+ conditionalPanel(+ |
+
| 247 | +! | +
+ condition = paste0("input['", ns("tabs"), "'] == 'Histogram'"),
+ |
+
| 248 | +! | +
+ teal.widgets::panel_item(+ |
+
| 249 | +! | +
+ "Histogram",+ |
+
| 250 | +! | +
+ teal.widgets::optionalSliderInputValMinMax(ns("bins"), "Bins", args$bins, ticks = FALSE, step = 1),
+ |
+
| 251 | +! | +
+ shinyWidgets::prettyRadioButtons(+ |
+
| 252 | +! | +
+ ns("main_type"),
+ |
+
| 253 | +! | +
+ label = "Plot Type:",+ |
+
| 254 | +! | +
+ choices = c("Density", "Frequency"),
+ |
+
| 255 | +! | +
+ selected = if (!args$freq) "Density" else "Frequency",+ |
+
| 256 | +! | +
+ bigger = FALSE,+ |
+
| 257 | +! | +
+ inline = TRUE+ |
+
| 258 | ++ |
+ ),+ |
+
| 259 | +! | +
+ checkboxInput(ns("add_dens"), label = "Overlay Density", value = TRUE),
+ |
+
| 260 | +! | +
+ collapsed = FALSE+ |
+
| 261 | ++ |
+ )+ |
+
| 262 | ++ |
+ ),+ |
+
| 263 | +! | +
+ conditionalPanel(+ |
+
| 264 | +! | +
+ condition = paste0("input['", ns("tabs"), "'] == 'QQplot'"),
+ |
+
| 265 | +! | +
+ teal.widgets::panel_item(+ |
+
| 266 | +! | +
+ "QQ Plot",+ |
+
| 267 | +! | +
+ checkboxInput(ns("qq_line"), label = "Add diagonal line(s)", TRUE),
+ |
+
| 268 | +! | +
+ collapsed = FALSE+ |
+
| 269 | ++ |
+ )+ |
+
| 270 | ++ |
+ ),+ |
+
| 271 | +! | +
+ conditionalPanel(+ |
+
| 272 | +! | +
+ condition = paste0("input['", ns("main_type"), "'] == 'Density'"),
+ |
+
| 273 | +! | +
+ teal.widgets::panel_item(+ |
+
| 274 | +! | +
+ "Theoretical Distribution",+ |
+
| 275 | +! | +
+ teal.widgets::optionalSelectInput(+ |
+
| 276 | +! | +
+ ns("t_dist"),
+ |
+
| 277 | +! | +
+ div(+ |
+
| 278 | +! | +
+ class = "teal-tooltip",+ |
+
| 279 | +! | +
+ tagList(+ |
+
| 280 | +! | +
+ "Distribution:",+ |
+
| 281 | +! | +
+ icon("circle-info"),
+ |
+
| 282 | +! | +
+ span(+ |
+
| 283 | +! | +
+ class = "tooltiptext",+ |
+
| 284 | +! | +
+ "Default parameters are optimized with MASS::fitdistr function."+ |
+
| 285 | ++ |
+ )+ |
+
| 286 | ++ |
+ )+ |
+
| 287 | ++ |
+ ),+ |
+
| 288 | +! | +
+ choices = c("normal", "lognormal", "gamma", "unif"),
+ |
+
| 289 | +! | +
+ selected = NULL,+ |
+
| 290 | +! | +
+ multiple = FALSE+ |
+
| 291 | ++ |
+ ),+ |
+
| 292 | +! | +
+ numericInput(ns("dist_param1"), label = "param1", value = NULL),
+ |
+
| 293 | +! | +
+ numericInput(ns("dist_param2"), label = "param2", value = NULL),
+ |
+
| 294 | +! | +
+ span(actionButton(ns("params_reset"), "Reset params")),
+ |
+
| 295 | +! | +
+ collapsed = FALSE+ |
+
| 296 | ++ |
+ )+ |
+
| 297 | ++ |
+ )+ |
+
| 298 | ++ |
+ ),+ |
+
| 299 | +! | +
+ teal.widgets::panel_item(+ |
+
| 300 | +! | +
+ "Tests",+ |
+
| 301 | +! | +
+ teal.widgets::optionalSelectInput(+ |
+
| 302 | +! | +
+ ns("dist_tests"),
+ |
+
| 303 | +! | +
+ "Tests:",+ |
+
| 304 | +! | +
+ choices = c(+ |
+
| 305 | +! | +
+ "Shapiro-Wilk",+ |
+
| 306 | +! | +
+ if (!is.null(args$strata_var)) "t-test (two-samples, not paired)",+ |
+
| 307 | +! | +
+ if (!is.null(args$strata_var)) "one-way ANOVA",+ |
+
| 308 | +! | +
+ if (!is.null(args$strata_var)) "Fligner-Killeen",+ |
+
| 309 | +! | +
+ if (!is.null(args$strata_var)) "F-test",+ |
+
| 310 | +! | +
+ "Kolmogorov-Smirnov (one-sample)",+ |
+
| 311 | +! | +
+ "Anderson-Darling (one-sample)",+ |
+
| 312 | +! | +
+ "Cramer-von Mises (one-sample)",+ |
+
| 313 | +! | +
+ if (!is.null(args$strata_var)) "Kolmogorov-Smirnov (two-samples)"+ |
+
| 314 | ++ |
+ ),+ |
+
| 315 | +! | +
+ selected = NULL+ |
+
| 316 | ++ |
+ )+ |
+
| 317 | ++ |
+ ),+ |
+
| 318 | +! | +
+ teal.widgets::panel_item(+ |
+
| 319 | +! | +
+ "Statistics Table",+ |
+
| 320 | +! | +
+ sliderInput(ns("roundn"), "Round to n digits", min = 0, max = 10, value = 2)
+ |
+
| 321 | ++ |
+ ),+ |
+
| 322 | +! | +
+ teal.widgets::panel_item(+ |
+
| 323 | +! | +
+ title = "Plot settings",+ |
+
| 324 | +! | +
+ selectInput(+ |
+
| 325 | +! | +
+ inputId = ns("ggtheme"),
+ |
+
| 326 | +! | +
+ label = "Theme (by ggplot):",+ |
+
| 327 | +! | +
+ choices = ggplot_themes,+ |
+
| 328 | +! | +
+ selected = args$ggtheme,+ |
+
| 329 | +! | +
+ multiple = FALSE+ |
+
| 330 | ++ |
+ )+ |
+
| 331 | ++ |
+ )+ |
+
| 332 | ++ |
+ ),+ |
+
| 333 | +! | +
+ forms = tagList(+ |
+
| 334 | +! | +
+ teal.widgets::verbatim_popup_ui(ns("warning"), "Show Warnings"),
+ |
+
| 335 | +! | +
+ teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code")
+ |
+
| 336 | ++ |
+ ),+ |
+
| 337 | +! | +
+ pre_output = args$pre_output,+ |
+
| 338 | +! | +
+ post_output = args$post_output+ |
+
| 339 | ++ |
+ )+ |
+
| 340 | ++ |
+ }+ |
+
| 341 | ++ | + + | +
| 342 | ++ |
+ # Server function for the distribution module+ |
+
| 343 | ++ |
+ srv_distribution <- function(id,+ |
+
| 344 | ++ |
+ data,+ |
+
| 345 | ++ |
+ reporter,+ |
+
| 346 | ++ |
+ filter_panel_api,+ |
+
| 347 | ++ |
+ dist_var,+ |
+
| 348 | ++ |
+ strata_var,+ |
+
| 349 | ++ |
+ group_var,+ |
+
| 350 | ++ |
+ plot_height,+ |
+
| 351 | ++ |
+ plot_width,+ |
+
| 352 | ++ |
+ ggplot2_args) {
+ |
+
| 353 | +! | +
+ with_reporter <- !missing(reporter) && inherits(reporter, "Reporter")+ |
+
| 354 | +! | +
+ with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI")+ |
+
| 355 | +! | +
+ checkmate::assert_class(data, "reactive")+ |
+
| 356 | +! | +
+ checkmate::assert_class(isolate(data()), "teal_data")+ |
+
| 357 | +! | +
+ moduleServer(id, function(input, output, session) {
+ |
+
| 358 | +! | +
+ rule_req <- function(value) {
+ |
+
| 359 | +! | +
+ if (isTRUE(input$dist_tests %in% c(+ |
+
| 360 | +! | +
+ "Fligner-Killeen",+ |
+
| 361 | +! | +
+ "t-test (two-samples, not paired)",+ |
+
| 362 | +! | +
+ "F-test",+ |
+
| 363 | +! | +
+ "Kolmogorov-Smirnov (two-samples)",+ |
+
| 364 | +! | +
+ "one-way ANOVA"+ |
+
| 365 | ++ |
+ ))) {
+ |
+
| 366 | +! | +
+ if (!shinyvalidate::input_provided(value)) {
+ |
+
| 367 | +! | +
+ "Please select stratify variable."+ |
+
| 368 | ++ |
+ }+ |
+
| 369 | ++ |
+ }+ |
+
| 370 | ++ |
+ }+ |
+
| 371 | +! | +
+ rule_dupl <- function(...) {
+ |
+
| 372 | +! | +
+ if (identical(input$dist_tests, "Fligner-Killeen")) {
+ |
+
| 373 | +! | +
+ strata <- selector_list()$strata_i()$select+ |
+
| 374 | +! | +
+ group <- selector_list()$group_i()$select+ |
+
| 375 | +! | +
+ if (isTRUE(strata == group)) {
+ |
+
| 376 | +! | +
+ "Please select different variables for strata and group."+ |
+
| 377 | ++ |
+ }+ |
+
| 378 | ++ |
+ }+ |
+
| 379 | ++ |
+ }+ |
+
| 380 | ++ | + + | +
| 381 | +! | +
+ selector_list <- teal.transform::data_extract_multiple_srv(+ |
+
| 382 | +! | +
+ data_extract = list(+ |
+
| 383 | +! | +
+ dist_i = dist_var,+ |
+
| 384 | +! | +
+ strata_i = strata_var,+ |
+
| 385 | +! | +
+ group_i = group_var+ |
+
| 386 | ++ |
+ ),+ |
+
| 387 | +! | +
+ data,+ |
+
| 388 | +! | +
+ select_validation_rule = list(+ |
+
| 389 | +! | +
+ dist_i = shinyvalidate::sv_required("Please select a variable")
+ |
+
| 390 | ++ |
+ ),+ |
+
| 391 | +! | +
+ filter_validation_rule = list(+ |
+
| 392 | +! | +
+ strata_i = shinyvalidate::compose_rules(+ |
+
| 393 | +! | +
+ rule_req,+ |
+
| 394 | +! | +
+ rule_dupl+ |
+
| 395 | ++ |
+ ),+ |
+
| 396 | +! | +
+ group_i = rule_dupl+ |
+
| 397 | ++ |
+ )+ |
+
| 398 | ++ |
+ )+ |
+
| 399 | ++ | + + | +
| 400 | +! | +
+ iv_r <- reactive({
+ |
+
| 401 | +! | +
+ iv <- shinyvalidate::InputValidator$new()+ |
+
| 402 | +! | +
+ teal.transform::compose_and_enable_validators(iv, selector_list, validator_names = "dist_i")+ |
+
| 403 | ++ |
+ })+ |
+
| 404 | ++ | + + | +
| 405 | +! | +
+ iv_r_dist <- reactive({
+ |
+
| 406 | +! | +
+ iv <- shinyvalidate::InputValidator$new()+ |
+
| 407 | +! | +
+ teal.transform::compose_and_enable_validators(+ |
+
| 408 | +! | +
+ iv, selector_list,+ |
+
| 409 | +! | +
+ validator_names = c("strata_i", "group_i")
+ |
+
| 410 | ++ |
+ )+ |
+
| 411 | ++ |
+ })+ |
+
| 412 | +! | +
+ rule_dist_1 <- function(value) {
+ |
+
| 413 | +! | +
+ if (!is.null(input$t_dist)) {
+ |
+
| 414 | +! | +
+ switch(input$t_dist,+ |
+
| 415 | +! | +
+ "normal" = if (!shinyvalidate::input_provided(value)) "mean is required",+ |
+
| 416 | +! | +
+ "lognormal" = if (!shinyvalidate::input_provided(value)) "meanlog is required",+ |
+
| 417 | +! | +
+ "gamma" = {
+ |
+
| 418 | +! | +
+ if (!shinyvalidate::input_provided(value)) "shape is required" else if (value <= 0) "shape must be positive"+ |
+
| 419 | ++ |
+ },+ |
+
| 420 | +! | +
+ "unif" = NULL+ |
+
| 421 | ++ |
+ )+ |
+
| 422 | ++ |
+ }+ |
+
| 423 | ++ |
+ }+ |
+
| 424 | +! | +
+ rule_dist_2 <- function(value) {
+ |
+
| 425 | +! | +
+ if (!is.null(input$t_dist)) {
+ |
+
| 426 | +! | +
+ switch(input$t_dist,+ |
+
| 427 | +! | +
+ "normal" = {
+ |
+
| 428 | +! | +
+ if (!shinyvalidate::input_provided(value)) {
+ |
+
| 429 | +! | +
+ "sd is required"+ |
+
| 430 | +! | +
+ } else if (value < 0) {
+ |
+
| 431 | +! | +
+ "sd must be non-negative"+ |
+
| 432 | ++ |
+ }+ |
+
| 433 | ++ |
+ },+ |
+
| 434 | +! | +
+ "lognormal" = {
+ |
+
| 435 | +! | +
+ if (!shinyvalidate::input_provided(value)) {
+ |
+
| 436 | +! | +
+ "sdlog is required"+ |
+
| 437 | +! | +
+ } else if (value < 0) {
+ |
+
| 438 | +! | +
+ "sdlog must be non-negative"+ |
+
| 439 | ++ |
+ }+ |
+
| 440 | ++ |
+ },+ |
+
| 441 | +! | +
+ "gamma" = {
+ |
+
| 442 | +! | +
+ if (!shinyvalidate::input_provided(value)) {
+ |
+
| 443 | +! | +
+ "rate is required"+ |
+
| 444 | +! | +
+ } else if (value <= 0) {
+ |
+
| 445 | +! | +
+ "rate must be positive"+ |
+
| 446 | ++ |
+ }+ |
+
| 447 | ++ |
+ },+ |
+
| 448 | +! | +
+ "unif" = NULL+ |
+
| 449 | ++ |
+ )+ |
+
| 450 | ++ |
+ }+ |
+
| 451 | ++ |
+ }+ |
+
| 452 | +! | +
+ rule_dist <- function(value) {
+ |
+
| 453 | +! | +
+ if (isTRUE(input$tabs == "QQplot" ||+ |
+
| 454 | +! | +
+ input$dist_tests %in% c(+ |
+
| 455 | +! | +
+ "Kolmogorov-Smirnov (one-sample)",+ |
+
| 456 | +! | +
+ "Anderson-Darling (one-sample)",+ |
+
| 457 | +! | +
+ "Cramer-von Mises (one-sample)"+ |
+
| 458 | ++ |
+ ))) {
+ |
+
| 459 | +! | +
+ if (!shinyvalidate::input_provided(value)) {
+ |
+
| 460 | +! | +
+ "Please select the theoretical distribution."+ |
+
| 461 | ++ |
+ }+ |
+
| 462 | ++ |
+ }+ |
+
| 463 | ++ |
+ }+ |
+
| 464 | +! | +
+ iv_dist <- shinyvalidate::InputValidator$new()+ |
+
| 465 | +! | +
+ iv_dist$add_rule("t_dist", rule_dist)
+ |
+
| 466 | +! | +
+ iv_dist$add_rule("dist_param1", rule_dist_1)
+ |
+
| 467 | +! | +
+ iv_dist$add_rule("dist_param2", rule_dist_2)
+ |
+
| 468 | +! | +
+ iv_dist$enable()+ |
+
| 469 | ++ | + + | +
| 470 | +! | +
+ anl_merged_input <- teal.transform::merge_expression_srv(+ |
+
| 471 | +! | +
+ selector_list = selector_list,+ |
+
| 472 | +! | +
+ datasets = data+ |
+
| 473 | ++ |
+ )+ |
+
| 474 | ++ | + + | +
| 475 | +! | +
+ anl_merged_q <- reactive({
+ |
+
| 476 | +! | +
+ req(anl_merged_input())+ |
+
| 477 | +! | +
+ data() %>%+ |
+
| 478 | +! | +
+ teal.code::eval_code(as.expression(anl_merged_input()$expr))+ |
+
| 479 | ++ |
+ })+ |
+
| 480 | ++ | + + | +
| 481 | +! | +
+ merged <- list(+ |
+
| 482 | +! | +
+ anl_input_r = anl_merged_input,+ |
+
| 483 | +! | +
+ anl_q_r = anl_merged_q+ |
+
| 484 | ++ |
+ )+ |
+
| 485 | ++ | + + | +
| 486 | +! | +
+ output$scales_types_ui <- renderUI({
+ |
+
| 487 | +! | +
+ if ("group_i" %in% names(selector_list()) && length(selector_list()$group_i()$filters[[1]]$selected) > 0) {
+ |
+
| 488 | +! | +
+ shinyWidgets::prettyRadioButtons(+ |
+
| 489 | +! | +
+ session$ns("scales_type"),
+ |
+
| 490 | +! | +
+ label = "Scales:",+ |
+
| 491 | +! | +
+ choices = c("Fixed", "Free"),
+ |
+
| 492 | +! | +
+ selected = "Fixed",+ |
+
| 493 | +! | +
+ bigger = FALSE,+ |
+
| 494 | +! | +
+ inline = TRUE+ |
+
| 495 | ++ |
+ )+ |
+
| 496 | ++ |
+ }+ |
+
| 497 | ++ |
+ })+ |
+
| 498 | ++ | + + | +
| 499 | +! | +
+ observeEvent(+ |
+
| 500 | +! | +
+ eventExpr = list(+ |
+
| 501 | +! | +
+ input$t_dist,+ |
+
| 502 | +! | +
+ input$params_reset,+ |
+
| 503 | +! | +
+ selector_list()$dist_i()$select+ |
+
| 504 | ++ |
+ ),+ |
+
| 505 | +! | +
+ handlerExpr = {
+ |
+
| 506 | +! | +
+ if (length(input$t_dist) != 0) {
+ |
+
| 507 | +! | +
+ dist_var2 <- as.vector(merged$anl_input_r()$columns_source$dist_i)+ |
+
| 508 | ++ | + + | +
| 509 | +! | +
+ get_dist_params <- function(x, dist) {
+ |
+
| 510 | +! | +
+ if (dist == "unif") {
+ |
+
| 511 | +! | +
+ res <- as.list(range(x))+ |
+
| 512 | +! | +
+ names(res) <- c("min", "max")
+ |
+
| 513 | +! | +
+ return(res)+ |
+
| 514 | ++ |
+ }+ |
+
| 515 | +! | +
+ tryCatch(+ |
+
| 516 | +! | +
+ as.list(MASS::fitdistr(x, densfun = dist)$estimate),+ |
+
| 517 | +! | +
+ error = function(e) list(param1 = NA, param2 = NA)+ |
+
| 518 | ++ |
+ )+ |
+
| 519 | ++ |
+ }+ |
+
| 520 | ++ | + + | +
| 521 | +! | +
+ ANL <- merged$anl_q_r()[[as.character(dist_var[[1]]$dataname)]]+ |
+
| 522 | +! | +
+ params <- get_dist_params(as.numeric(stats::na.omit(ANL[[dist_var2]])), input$t_dist)+ |
+
| 523 | +! | +
+ params_vec <- round(unname(unlist(params)), 2)+ |
+
| 524 | +! | +
+ params_names <- names(params)+ |
+
| 525 | ++ | + + | +
| 526 | +! | +
+ updateNumericInput(session, "dist_param1", label = params_names[1], value = params_vec[1])+ |
+
| 527 | +! | +
+ updateNumericInput(session, "dist_param2", label = params_names[2], value = params_vec[2])+ |
+
| 528 | ++ |
+ } else {
+ |
+
| 529 | +! | +
+ updateNumericInput(session, "dist_param1", label = "param1", value = NA)+ |
+
| 530 | +! | +
+ updateNumericInput(session, "dist_param2", label = "param2", value = NA)+ |
+
| 531 | ++ |
+ }+ |
+
| 532 | ++ |
+ },+ |
+
| 533 | +! | +
+ ignoreInit = TRUE+ |
+
| 534 | ++ |
+ )+ |
+
| 535 | ++ | + + | +
| 536 | +! | +
+ merge_vars <- reactive({
+ |
+
| 537 | +! | +
+ teal::validate_inputs(iv_r())+ |
+
| 538 | ++ | + + | +
| 539 | +! | +
+ dist_var <- as.vector(merged$anl_input_r()$columns_source$dist_i)+ |
+
| 540 | +! | +
+ s_var <- as.vector(merged$anl_input_r()$columns_source$strata_i)+ |
+
| 541 | +! | +
+ g_var <- as.vector(merged$anl_input_r()$columns_source$group_i)+ |
+
| 542 | ++ | + + | +
| 543 | +! | +
+ dist_var_name <- if (length(dist_var)) as.name(dist_var) else NULL+ |
+
| 544 | +! | +
+ s_var_name <- if (length(s_var)) as.name(s_var) else NULL+ |
+
| 545 | +! | +
+ g_var_name <- if (length(g_var)) as.name(g_var) else NULL+ |
+
| 546 | ++ | + + | +
| 547 | +! | +
+ list(+ |
+
| 548 | +! | +
+ dist_var = dist_var,+ |
+
| 549 | +! | +
+ s_var = s_var,+ |
+
| 550 | +! | +
+ g_var = g_var,+ |
+
| 551 | +! | +
+ dist_var_name = dist_var_name,+ |
+
| 552 | +! | +
+ s_var_name = s_var_name,+ |
+
| 553 | +! | +
+ g_var_name = g_var_name+ |
+
| 554 | ++ |
+ )+ |
+
| 555 | ++ |
+ })+ |
+
| 556 | ++ | + + | +
| 557 | ++ |
+ # common qenv+ |
+
| 558 | +! | +
+ common_q <- reactive({
+ |
+
| 559 | ++ |
+ # Create a private stack for this function only.+ |
+
| 560 | ++ | + + | +
| 561 | +! | +
+ ANL <- merged$anl_q_r()[["ANL"]]+ |
+
| 562 | +! | +
+ dist_var <- merge_vars()$dist_var+ |
+
| 563 | +! | +
+ s_var <- merge_vars()$s_var+ |
+
| 564 | +! | +
+ g_var <- merge_vars()$g_var+ |
+
| 565 | ++ | + + | +
| 566 | +! | +
+ dist_var_name <- merge_vars()$dist_var_name+ |
+
| 567 | +! | +
+ s_var_name <- merge_vars()$s_var_name+ |
+
| 568 | +! | +
+ g_var_name <- merge_vars()$g_var_name+ |
+
| 569 | ++ | + + | +
| 570 | +! | +
+ roundn <- input$roundn+ |
+
| 571 | +! | +
+ dist_param1 <- input$dist_param1+ |
+
| 572 | +! | +
+ dist_param2 <- input$dist_param2+ |
+
| 573 | ++ |
+ # isolated as dist_param1/dist_param2 already triggered the reactivity+ |
+
| 574 | +! | +
+ t_dist <- isolate(input$t_dist)+ |
+
| 575 | ++ | + + | +
| 576 | +! | +
+ qenv <- merged$anl_q_r()+ |
+
| 577 | ++ | + + | +
| 578 | +! | +
+ if (length(g_var) > 0) {
+ |
+
| 579 | +! | +
+ validate(+ |
+
| 580 | +! | +
+ need(+ |
+
| 581 | +! | +
+ inherits(ANL[[g_var]], c("integer", "factor", "character")),
+ |
+
| 582 | +! | +
+ "Group by variable must be `factor`, `character`, or `integer`"+ |
+
| 583 | ++ |
+ )+ |
+
| 584 | ++ |
+ )+ |
+
| 585 | +! | +
+ qenv <- teal.code::eval_code(+ |
+
| 586 | +! | +
+ qenv,+ |
+
| 587 | +! | +
+ substitute(+ |
+
| 588 | +! | +
+ expr = ANL[[g_var]] <- forcats::fct_na_value_to_level(as.factor(ANL[[g_var]]), "NA"),+ |
+
| 589 | +! | +
+ env = list(g_var = g_var)+ |
+
| 590 | ++ |
+ )+ |
+
| 591 | ++ |
+ )+ |
+
| 592 | ++ |
+ }+ |
+
| 593 | ++ | + + | +
| 594 | +! | +
+ if (length(s_var) > 0) {
+ |
+
| 595 | +! | +
+ validate(+ |
+
| 596 | +! | +
+ need(+ |
+
| 597 | +! | +
+ inherits(ANL[[s_var]], c("integer", "factor", "character")),
+ |
+
| 598 | +! | +
+ "Stratify by variable must be `factor`, `character`, or `integer`"+ |
+
| 599 | ++ |
+ )+ |
+
| 600 | ++ |
+ )+ |
+
| 601 | +! | +
+ qenv <- teal.code::eval_code(+ |
+
| 602 | +! | +
+ qenv,+ |
+
| 603 | +! | +
+ substitute(+ |
+
| 604 | +! | +
+ expr = ANL[[s_var]] <- forcats::fct_na_value_to_level(as.factor(ANL[[s_var]]), "NA"),+ |
+
| 605 | +! | +
+ env = list(s_var = s_var)+ |
+
| 606 | ++ |
+ )+ |
+
| 607 | ++ |
+ )+ |
+
| 608 | ++ |
+ }+ |
+
| 609 | ++ | + + | +
| 610 | +! | +
+ validate(need(is.numeric(ANL[[dist_var]]), "Please select a numeric variable."))+ |
+
| 611 | +! | +
+ teal::validate_has_data(ANL, 1, complete = TRUE)+ |
+
| 612 | ++ | + + | +
| 613 | +! | +
+ if (length(t_dist) != 0) {
+ |
+
| 614 | +! | +
+ map_distr_nams <- list(+ |
+
| 615 | +! | +
+ normal = c("mean", "sd"),
+ |
+
| 616 | +! | +
+ lognormal = c("meanlog", "sdlog"),
+ |
+
| 617 | +! | +
+ gamma = c("shape", "rate"),
+ |
+
| 618 | +! | +
+ unif = c("min", "max")
+ |
+
| 619 | ++ |
+ )+ |
+
| 620 | +! | +
+ params_names_raw <- map_distr_nams[[t_dist]]+ |
+
| 621 | ++ | + + | +
| 622 | +! | +
+ qenv <- teal.code::eval_code(+ |
+
| 623 | +! | +
+ qenv,+ |
+
| 624 | +! | +
+ substitute(+ |
+
| 625 | +! | +
+ expr = {
+ |
+
| 626 | +! | +
+ params <- as.list(c(dist_param1, dist_param2))+ |
+
| 627 | +! | +
+ names(params) <- params_names_raw+ |
+
| 628 | ++ |
+ },+ |
+
| 629 | +! | +
+ env = list(+ |
+
| 630 | +! | +
+ dist_param1 = dist_param1,+ |
+
| 631 | +! | +
+ dist_param2 = dist_param2,+ |
+
| 632 | +! | +
+ params_names_raw = params_names_raw+ |
+
| 633 | ++ |
+ )+ |
+
| 634 | ++ |
+ )+ |
+
| 635 | ++ |
+ )+ |
+
| 636 | ++ |
+ }+ |
+
| 637 | ++ | + + | +
| 638 | +! | +
+ if (length(s_var) == 0 && length(g_var) == 0) {
+ |
+
| 639 | +! | +
+ qenv <- teal.code::eval_code(+ |
+
| 640 | +! | +
+ qenv,+ |
+
| 641 | +! | +
+ substitute(+ |
+
| 642 | +! | +
+ expr = {
+ |
+
| 643 | +! | +
+ summary_table <- ANL %>%+ |
+
| 644 | +! | +
+ dplyr::summarise(+ |
+
| 645 | +! | +
+ min = round(min(dist_var_name, na.rm = TRUE), roundn),+ |
+
| 646 | +! | +
+ median = round(stats::median(dist_var_name, na.rm = TRUE), roundn),+ |
+
| 647 | +! | +
+ mean = round(mean(dist_var_name, na.rm = TRUE), roundn),+ |
+
| 648 | +! | +
+ max = round(max(dist_var_name, na.rm = TRUE), roundn),+ |
+
| 649 | +! | +
+ sd = round(stats::sd(dist_var_name, na.rm = TRUE), roundn),+ |
+
| 650 | +! | +
+ count = dplyr::n()+ |
+
| 651 | ++ |
+ )+ |
+
| 652 | ++ |
+ },+ |
+
| 653 | +! | +
+ env = list(+ |
+
| 654 | +! | +
+ dist_var_name = as.name(dist_var),+ |
+
| 655 | +! | +
+ roundn = roundn+ |
+
| 656 | ++ |
+ )+ |
+
| 657 | ++ |
+ )+ |
+
| 658 | ++ |
+ )+ |
+
| 659 | ++ |
+ } else {
+ |
+
| 660 | +! | +
+ qenv <- teal.code::eval_code(+ |
+
| 661 | +! | +
+ qenv,+ |
+
| 662 | +! | +
+ substitute(+ |
+
| 663 | +! | +
+ expr = {
+ |
+
| 664 | +! | +
+ strata_vars <- strata_vars_raw+ |
+
| 665 | +! | +
+ summary_table <- ANL %>%+ |
+
| 666 | +! | +
+ dplyr::group_by_at(dplyr::vars(dplyr::any_of(strata_vars))) %>%+ |
+
| 667 | +! | +
+ dplyr::summarise(+ |
+
| 668 | +! | +
+ min = round(min(dist_var_name, na.rm = TRUE), roundn),+ |
+
| 669 | +! | +
+ median = round(stats::median(dist_var_name, na.rm = TRUE), roundn),+ |
+
| 670 | +! | +
+ mean = round(mean(dist_var_name, na.rm = TRUE), roundn),+ |
+
| 671 | +! | +
+ max = round(max(dist_var_name, na.rm = TRUE), roundn),+ |
+
| 672 | +! | +
+ sd = round(stats::sd(dist_var_name, na.rm = TRUE), roundn),+ |
+
| 673 | +! | +
+ count = dplyr::n()+ |
+
| 674 | ++ |
+ )+ |
+
| 675 | +! | +
+ summary_table # used to display table when running show-r-code code+ |
+
| 676 | ++ |
+ },+ |
+
| 677 | +! | +
+ env = list(+ |
+
| 678 | +! | +
+ dist_var_name = dist_var_name,+ |
+
| 679 | +! | +
+ strata_vars_raw = c(g_var, s_var),+ |
+
| 680 | +! | +
+ roundn = roundn+ |
+
| 681 | ++ |
+ )+ |
+
| 682 | ++ |
+ )+ |
+
| 683 | ++ |
+ )+ |
+
| 684 | ++ |
+ }+ |
+
| 685 | ++ |
+ })+ |
+
| 686 | ++ | + + | +
| 687 | ++ |
+ # distplot qenv ----+ |
+
| 688 | +! | +
+ dist_q <- eventReactive(+ |
+
| 689 | +! | +
+ eventExpr = {
+ |
+
| 690 | +! | +
+ common_q()+ |
+
| 691 | +! | +
+ input$scales_type+ |
+
| 692 | +! | +
+ input$main_type+ |
+
| 693 | +! | +
+ input$bins+ |
+
| 694 | +! | +
+ input$add_dens+ |
+
| 695 | +! | +
+ is.null(input$ggtheme)+ |
+
| 696 | ++ |
+ },+ |
+
| 697 | +! | +
+ valueExpr = {
+ |
+
| 698 | +! | +
+ dist_var <- merge_vars()$dist_var+ |
+
| 699 | +! | +
+ s_var <- merge_vars()$s_var+ |
+
| 700 | +! | +
+ g_var <- merge_vars()$g_var+ |
+
| 701 | +! | +
+ dist_var_name <- merge_vars()$dist_var_name+ |
+
| 702 | +! | +
+ s_var_name <- merge_vars()$s_var_name+ |
+
| 703 | +! | +
+ g_var_name <- merge_vars()$g_var_name+ |
+
| 704 | +! | +
+ t_dist <- input$t_dist+ |
+
| 705 | +! | +
+ dist_param1 <- input$dist_param1+ |
+
| 706 | +! | +
+ dist_param2 <- input$dist_param2+ |
+
| 707 | ++ | + + | +
| 708 | +! | +
+ scales_type <- input$scales_type+ |
+
| 709 | ++ | + + | +
| 710 | +! | +
+ ndensity <- 512+ |
+
| 711 | +! | +
+ main_type_var <- input$main_type+ |
+
| 712 | +! | +
+ bins_var <- input$bins+ |
+
| 713 | +! | +
+ add_dens_var <- input$add_dens+ |
+
| 714 | +! | +
+ ggtheme <- input$ggtheme+ |
+
| 715 | ++ | + + | +
| 716 | +! | +
+ teal::validate_inputs(iv_dist)+ |
+
| 717 | ++ | + + | +
| 718 | +! | +
+ qenv <- common_q()+ |
+
| 719 | ++ | + + | +
| 720 | +! | +
+ m_type <- if (main_type_var == "Density") "density" else "count"+ |
+
| 721 | ++ | + + | +
| 722 | +! | +
+ plot_call <- if (length(s_var) == 0 && length(g_var) == 0) {
+ |
+
| 723 | +! | +
+ substitute(+ |
+
| 724 | +! | +
+ expr = ggplot(ANL, aes(dist_var_name)) ++ |
+
| 725 | +! | +
+ geom_histogram(+ |
+
| 726 | +! | +
+ position = "identity", aes(y = after_stat(m_type)), bins = bins_var, alpha = 0.3+ |
+
| 727 | ++ |
+ ),+ |
+
| 728 | +! | +
+ env = list(+ |
+
| 729 | +! | +
+ m_type = as.name(m_type), bins_var = bins_var, dist_var_name = as.name(dist_var)+ |
+
| 730 | ++ |
+ )+ |
+
| 731 | ++ |
+ )+ |
+
| 732 | +! | +
+ } else if (length(s_var) != 0 && length(g_var) == 0) {
+ |
+
| 733 | +! | +
+ substitute(+ |
+
| 734 | +! | +
+ expr = ggplot(ANL, aes(dist_var_name, col = s_var_name)) ++ |
+
| 735 | +! | +
+ geom_histogram(+ |
+
| 736 | +! | +
+ position = "identity", aes(y = after_stat(m_type), fill = s_var), bins = bins_var, alpha = 0.3+ |
+
| 737 | ++ |
+ ),+ |
+
| 738 | +! | +
+ env = list(+ |
+
| 739 | +! | +
+ m_type = as.name(m_type),+ |
+
| 740 | +! | +
+ bins_var = bins_var,+ |
+
| 741 | +! | +
+ dist_var_name = dist_var_name,+ |
+
| 742 | +! | +
+ s_var = as.name(s_var),+ |
+
| 743 | +! | +
+ s_var_name = s_var_name+ |
+
| 744 | ++ |
+ )+ |
+
| 745 | ++ |
+ )+ |
+
| 746 | +! | +
+ } else if (length(s_var) == 0 && length(g_var) != 0) {
+ |
+
| 747 | +! | +
+ req(scales_type)+ |
+
| 748 | +! | +
+ substitute(+ |
+
| 749 | +! | +
+ expr = ggplot(ANL[ANL[[g_var]] != "NA", ], aes(dist_var_name)) ++ |
+
| 750 | +! | +
+ geom_histogram(+ |
+
| 751 | +! | +
+ position = "identity", aes(y = after_stat(m_type)), bins = bins_var, alpha = 0.3+ |
+
| 752 | ++ |
+ ) ++ |
+
| 753 | +! | +
+ facet_wrap(~g_var_name, ncol = 1, scales = scales_raw),+ |
+
| 754 | +! | +
+ env = list(+ |
+
| 755 | +! | +
+ m_type = as.name(m_type),+ |
+
| 756 | +! | +
+ bins_var = bins_var,+ |
+
| 757 | +! | +
+ dist_var_name = dist_var_name,+ |
+
| 758 | +! | +
+ g_var = g_var,+ |
+
| 759 | +! | +
+ g_var_name = g_var_name,+ |
+
| 760 | +! | +
+ scales_raw = tolower(scales_type)+ |
+
| 761 | ++ |
+ )+ |
+
| 762 | ++ |
+ )+ |
+
| 763 | ++ |
+ } else {
+ |
+
| 764 | +! | +
+ req(scales_type)+ |
+
| 765 | +! | +
+ substitute(+ |
+
| 766 | +! | +
+ expr = ggplot(ANL[ANL[[g_var]] != "NA", ], aes(dist_var_name, col = s_var_name)) ++ |
+
| 767 | +! | +
+ geom_histogram(+ |
+
| 768 | +! | +
+ position = "identity",+ |
+
| 769 | +! | +
+ aes(y = after_stat(m_type), fill = s_var), bins = bins_var, alpha = 0.3+ |
+
| 770 | ++ |
+ ) ++ |
+
| 771 | +! | +
+ facet_wrap(~g_var_name, ncol = 1, scales = scales_raw),+ |
+
| 772 | +! | +
+ env = list(+ |
+
| 773 | +! | +
+ m_type = as.name(m_type),+ |
+
| 774 | +! | +
+ bins_var = bins_var,+ |
+
| 775 | +! | +
+ dist_var_name = dist_var_name,+ |
+
| 776 | +! | +
+ g_var = g_var,+ |
+
| 777 | +! | +
+ s_var = as.name(s_var),+ |
+
| 778 | +! | +
+ g_var_name = g_var_name,+ |
+
| 779 | +! | +
+ s_var_name = s_var_name,+ |
+
| 780 | +! | +
+ scales_raw = tolower(scales_type)+ |
+
| 781 | ++ |
+ )+ |
+
| 782 | ++ |
+ )+ |
+
| 783 | ++ |
+ }+ |
+
| 784 | ++ | + + | +
| 785 | +! | +
+ if (add_dens_var) {
+ |
+
| 786 | +! | +
+ plot_call <- substitute(+ |
+
| 787 | +! | +
+ expr = plot_call ++ |
+
| 788 | +! | +
+ stat_density(+ |
+
| 789 | +! | +
+ aes(y = after_stat(const * m_type2)),+ |
+
| 790 | +! | +
+ geom = "line",+ |
+
| 791 | +! | +
+ position = "identity",+ |
+
| 792 | +! | +
+ alpha = 0.5,+ |
+
| 793 | +! | +
+ size = 2,+ |
+
| 794 | +! | +
+ n = ndensity+ |
+
| 795 | ++ |
+ ),+ |
+
| 796 | +! | +
+ env = list(+ |
+
| 797 | +! | +
+ plot_call = plot_call,+ |
+
| 798 | +! | +
+ const = if (main_type_var == "Density") {
+ |
+
| 799 | +! | +
+ 1+ |
+
| 800 | ++ |
+ } else {
+ |
+
| 801 | +! | +
+ diff(range(qenv[["ANL"]][[dist_var]], na.rm = TRUE)) / bins_var+ |
+
| 802 | ++ |
+ },+ |
+
| 803 | +! | +
+ m_type2 = if (main_type_var == "Density") as.name("density") else as.name("count"),
+ |
+
| 804 | +! | +
+ ndensity = ndensity+ |
+
| 805 | ++ |
+ )+ |
+
| 806 | ++ |
+ )+ |
+
| 807 | ++ |
+ }+ |
+
| 808 | ++ | + + | +
| 809 | +! | +
+ if (length(t_dist) != 0 && main_type_var == "Density" && length(g_var) == 0 && length(s_var) == 0) {
+ |
+
| 810 | +! | +
+ qenv <- teal.code::eval_code(+ |
+
| 811 | +! | +
+ qenv,+ |
+
| 812 | +! | +
+ substitute(+ |
+
| 813 | +! | +
+ df_params <- as.data.frame(append(params, list(name = t_dist))),+ |
+
| 814 | +! | +
+ env = list(t_dist = t_dist)+ |
+
| 815 | ++ |
+ )+ |
+
| 816 | ++ |
+ )+ |
+
| 817 | +! | +
+ datas <- quote(data.frame(x = 0.7, y = 1, tb = I(list(df_params = df_params))))+ |
+
| 818 | +! | +
+ label <- quote(tb)+ |
+
| 819 | ++ | + + | +
| 820 | +! | +
+ plot_call <- substitute(+ |
+
| 821 | +! | +
+ expr = plot_call + ggpp::geom_table_npc(+ |
+
| 822 | +! | +
+ data = data,+ |
+
| 823 | +! | +
+ aes(npcx = x, npcy = y, label = label),+ |
+
| 824 | +! | +
+ hjust = 0, vjust = 1, size = 4+ |
+
| 825 | ++ |
+ ),+ |
+
| 826 | +! | +
+ env = list(plot_call = plot_call, data = datas, label = label)+ |
+
| 827 | ++ |
+ )+ |
+
| 828 | ++ |
+ }+ |
+
| 829 | ++ | + + | +
| 830 | +! | +
+ if (+ |
+
| 831 | +! | +
+ length(s_var) == 0 &&+ |
+
| 832 | +! | +
+ length(g_var) == 0 &&+ |
+
| 833 | +! | +
+ main_type_var == "Density" &&+ |
+
| 834 | +! | +
+ length(t_dist) != 0 &&+ |
+
| 835 | +! | +
+ main_type_var == "Density"+ |
+
| 836 | ++ |
+ ) {
+ |
+
| 837 | +! | +
+ map_dist <- stats::setNames(+ |
+
| 838 | +! | +
+ c("dnorm", "dlnorm", "dgamma", "dunif"),
+ |
+
| 839 | +! | +
+ c("normal", "lognormal", "gamma", "unif")
+ |
+
| 840 | ++ |
+ )+ |
+
| 841 | +! | +
+ plot_call <- substitute(+ |
+
| 842 | +! | +
+ expr = plot_call + stat_function(+ |
+
| 843 | +! | +
+ data = data.frame(x = range(ANL[[dist_var]]), color = mapped_dist),+ |
+
| 844 | +! | +
+ aes(x, color = color),+ |
+
| 845 | +! | +
+ fun = mapped_dist_name,+ |
+
| 846 | +! | +
+ n = ndensity,+ |
+
| 847 | +! | +
+ size = 2,+ |
+
| 848 | +! | +
+ args = params+ |
+
| 849 | ++ |
+ ) ++ |
+
| 850 | +! | +
+ scale_color_manual(values = stats::setNames("blue", mapped_dist), aesthetics = "color"),
+ |
+
| 851 | +! | +
+ env = list(+ |
+
| 852 | +! | +
+ plot_call = plot_call,+ |
+
| 853 | +! | +
+ dist_var = dist_var,+ |
+
| 854 | +! | +
+ ndensity = ndensity,+ |
+
| 855 | +! | +
+ mapped_dist = unname(map_dist[t_dist]),+ |
+
| 856 | +! | +
+ mapped_dist_name = as.name(unname(map_dist[t_dist]))+ |
+
| 857 | ++ |
+ )+ |
+
| 858 | ++ |
+ )+ |
+
| 859 | ++ |
+ }+ |
+
| 860 | ++ | + + | +
| 861 | +! | +
+ all_ggplot2_args <- teal.widgets::resolve_ggplot2_args(+ |
+
| 862 | +! | +
+ user_plot = ggplot2_args[["Histogram"]],+ |
+
| 863 | +! | +
+ user_default = ggplot2_args$default+ |
+
| 864 | ++ |
+ )+ |
+
| 865 | ++ | + + | +
| 866 | +! | +
+ parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(+ |
+
| 867 | +! | +
+ all_ggplot2_args,+ |
+
| 868 | +! | +
+ ggtheme = ggtheme+ |
+
| 869 | ++ |
+ )+ |
+
| 870 | ++ | + + | +
| 871 | +! | +
+ teal.code::eval_code(+ |
+
| 872 | +! | +
+ qenv,+ |
+
| 873 | +! | +
+ substitute(+ |
+
| 874 | +! | +
+ expr = {
+ |
+
| 875 | +! | +
+ g <- plot_call+ |
+
| 876 | +! | +
+ print(g)+ |
+
| 877 | ++ |
+ },+ |
+
| 878 | +! | +
+ env = list(plot_call = Reduce(function(x, y) call("+", x, y), c(plot_call, parsed_ggplot2_args)))
+ |
+
| 879 | ++ |
+ )+ |
+
| 880 | ++ |
+ )+ |
+
| 881 | ++ |
+ }+ |
+
| 882 | ++ |
+ )+ |
+
| 883 | ++ | + + | +
| 884 | ++ |
+ # qqplot qenv ----+ |
+
| 885 | +! | +
+ qq_q <- eventReactive(+ |
+
| 886 | +! | +
+ eventExpr = {
+ |
+
| 887 | +! | +
+ common_q()+ |
+
| 888 | +! | +
+ input$scales_type+ |
+
| 889 | +! | +
+ input$qq_line+ |
+
| 890 | +! | +
+ is.null(input$ggtheme)+ |
+
| 891 | ++ |
+ },+ |
+
| 892 | +! | +
+ valueExpr = {
+ |
+
| 893 | +! | +
+ dist_var <- merge_vars()$dist_var+ |
+
| 894 | +! | +
+ s_var <- merge_vars()$s_var+ |
+
| 895 | +! | +
+ g_var <- merge_vars()$g_var+ |
+
| 896 | +! | +
+ dist_var_name <- merge_vars()$dist_var_name+ |
+
| 897 | +! | +
+ s_var_name <- merge_vars()$s_var_name+ |
+
| 898 | +! | +
+ g_var_name <- merge_vars()$g_var_name+ |
+
| 899 | +! | +
+ t_dist <- input$t_dist+ |
+
| 900 | +! | +
+ dist_param1 <- input$dist_param1+ |
+
| 901 | +! | +
+ dist_param2 <- input$dist_param2+ |
+
| 902 | ++ | + + | +
| 903 | +! | +
+ scales_type <- input$scales_type+ |
+
| 904 | +! | +
+ ggtheme <- input$ggtheme+ |
+
| 905 | ++ | + + | +
| 906 | +! | +
+ teal::validate_inputs(iv_r_dist(), iv_dist)+ |
+
| 907 | ++ | + + | +
| 908 | +! | +
+ qenv <- common_q()+ |
+
| 909 | ++ | + + | +
| 910 | +! | +
+ plot_call <- if (length(s_var) == 0 && length(g_var) == 0) {
+ |
+
| 911 | +! | +
+ substitute(+ |
+
| 912 | +! | +
+ expr = ggplot(ANL, aes_string(sample = dist_var)),+ |
+
| 913 | +! | +
+ env = list(dist_var = dist_var)+ |
+
| 914 | ++ |
+ )+ |
+
| 915 | +! | +
+ } else if (length(s_var) != 0 && length(g_var) == 0) {
+ |
+
| 916 | +! | +
+ substitute(+ |
+
| 917 | +! | +
+ expr = ggplot(ANL, aes_string(sample = dist_var, color = s_var)),+ |
+
| 918 | +! | +
+ env = list(dist_var = dist_var, s_var = s_var)+ |
+
| 919 | ++ |
+ )+ |
+
| 920 | +! | +
+ } else if (length(s_var) == 0 && length(g_var) != 0) {
+ |
+
| 921 | +! | +
+ substitute(+ |
+
| 922 | +! | +
+ expr = ggplot(ANL[ANL[[g_var]] != "NA", ], aes_string(sample = dist_var)) ++ |
+
| 923 | +! | +
+ facet_wrap(~g_var_name, ncol = 1, scales = scales_raw),+ |
+
| 924 | +! | +
+ env = list(+ |
+
| 925 | +! | +
+ dist_var = dist_var,+ |
+
| 926 | +! | +
+ g_var = g_var,+ |
+
| 927 | +! | +
+ g_var_name = g_var_name,+ |
+
| 928 | +! | +
+ scales_raw = tolower(scales_type)+ |
+
| 929 | ++ |
+ )+ |
+
| 930 | ++ |
+ )+ |
+
| 931 | ++ |
+ } else {
+ |
+
| 932 | +! | +
+ substitute(+ |
+
| 933 | +! | +
+ expr = ggplot(ANL[ANL[[g_var]] != "NA", ], aes_string(sample = dist_var, color = s_var)) ++ |
+
| 934 | +! | +
+ facet_wrap(~g_var_name, ncol = 1, scales = scales_raw),+ |
+
| 935 | +! | +
+ env = list(+ |
+
| 936 | +! | +
+ dist_var = dist_var,+ |
+
| 937 | +! | +
+ g_var = g_var,+ |
+
| 938 | +! | +
+ s_var = s_var,+ |
+
| 939 | +! | +
+ g_var_name = g_var_name,+ |
+
| 940 | +! | +
+ scales_raw = tolower(scales_type)+ |
+
| 941 | ++ |
+ )+ |
+
| 942 | ++ |
+ )+ |
+
| 943 | ++ |
+ }+ |
+
| 944 | ++ | + + | +
| 945 | +! | +
+ map_dist <- stats::setNames(+ |
+
| 946 | +! | +
+ c("qnorm", "qlnorm", "qgamma", "qunif"),
+ |
+
| 947 | +! | +
+ c("normal", "lognormal", "gamma", "unif")
+ |
+
| 948 | ++ |
+ )+ |
+
| 949 | ++ | + + | +
| 950 | +! | +
+ plot_call <- substitute(+ |
+
| 951 | +! | +
+ expr = plot_call ++ |
+
| 952 | +! | +
+ stat_qq(distribution = mapped_dist, dparams = params),+ |
+
| 953 | +! | +
+ env = list(plot_call = plot_call, mapped_dist = as.name(unname(map_dist[t_dist])))+ |
+
| 954 | ++ |
+ )+ |
+
| 955 | ++ | + + | +
| 956 | +! | +
+ if (length(t_dist) != 0 && length(g_var) == 0 && length(s_var) == 0) {
+ |
+
| 957 | +! | +
+ qenv <- teal.code::eval_code(+ |
+
| 958 | +! | +
+ qenv,+ |
+
| 959 | +! | +
+ substitute(+ |
+
| 960 | +! | +
+ df_params <- as.data.frame(append(params, list(name = t_dist))),+ |
+
| 961 | +! | +
+ env = list(t_dist = t_dist)+ |
+
| 962 | ++ |
+ )+ |
+
| 963 | ++ |
+ )+ |
+
| 964 | +! | +
+ datas <- quote(data.frame(x = 0.7, y = 1, tb = I(list(df_params = df_params))))+ |
+
| 965 | +! | +
+ label <- quote(tb)+ |
+
| 966 | ++ | + + | +
| 967 | +! | +
+ plot_call <- substitute(+ |
+
| 968 | +! | +
+ expr = plot_call ++ |
+
| 969 | +! | +
+ ggpp::geom_table_npc(+ |
+
| 970 | +! | +
+ data = data,+ |
+
| 971 | +! | +
+ aes(npcx = x, npcy = y, label = label),+ |
+
| 972 | +! | +
+ hjust = 0,+ |
+
| 973 | +! | +
+ vjust = 1,+ |
+
| 974 | +! | +
+ size = 4+ |
+
| 975 | ++ |
+ ),+ |
+
| 976 | +! | +
+ env = list(+ |
+
| 977 | +! | +
+ plot_call = plot_call,+ |
+
| 978 | +! | +
+ data = datas,+ |
+
| 979 | +! | +
+ label = label+ |
+
| 980 | ++ |
+ )+ |
+
| 981 | ++ |
+ )+ |
+
| 982 | ++ |
+ }+ |
+
| 983 | ++ | + + | +
| 984 | +! | +
+ if (isTRUE(input$qq_line)) {
+ |
+
| 985 | +! | +
+ plot_call <- substitute(+ |
+
| 986 | +! | +
+ expr = plot_call ++ |
+
| 987 | +! | +
+ stat_qq_line(distribution = mapped_dist, dparams = params),+ |
+
| 988 | +! | +
+ env = list(plot_call = plot_call, mapped_dist = as.name(unname(map_dist[t_dist])))+ |
+
| 989 | ++ |
+ )+ |
+
| 990 | ++ |
+ }+ |
+
| 991 | ++ | + + | +
| 992 | +! | +
+ all_ggplot2_args <- teal.widgets::resolve_ggplot2_args(+ |
+
| 993 | +! | +
+ user_plot = ggplot2_args[["QQplot"]],+ |
+
| 994 | +! | +
+ user_default = ggplot2_args$default,+ |
+
| 995 | +! | +
+ module_plot = teal.widgets::ggplot2_args(labs = list(x = "theoretical", y = "sample"))+ |
+
| 996 | ++ |
+ )+ |
+
| 997 | ++ | + + | +
| 998 | +! | +
+ parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(+ |
+
| 999 | +! | +
+ all_ggplot2_args,+ |
+
| 1000 | +! | +
+ ggtheme = ggtheme+ |
+
| 1001 | ++ |
+ )+ |
+
| 1002 | ++ | + + | +
| 1003 | +! | +
+ teal.code::eval_code(+ |
+
| 1004 | +! | +
+ qenv,+ |
+
| 1005 | +! | +
+ substitute(+ |
+
| 1006 | +! | +
+ expr = {
+ |
+
| 1007 | +! | +
+ g <- plot_call+ |
+
| 1008 | +! | +
+ print(g)+ |
+
| 1009 | ++ |
+ },+ |
+
| 1010 | +! | +
+ env = list(plot_call = Reduce(function(x, y) call("+", x, y), c(plot_call, parsed_ggplot2_args)))
+ |
+
| 1011 | ++ |
+ )+ |
+
| 1012 | ++ |
+ )+ |
+
| 1013 | ++ |
+ }+ |
+
| 1014 | ++ |
+ )+ |
+
| 1015 | ++ | + + | +
| 1016 | ++ |
+ # test qenv ----+ |
+
| 1017 | +! | +
+ test_q <- eventReactive(+ |
+
| 1018 | +! | +
+ ignoreNULL = FALSE,+ |
+
| 1019 | +! | +
+ eventExpr = {
+ |
+
| 1020 | +! | +
+ common_q()+ |
+
| 1021 | +! | +
+ input$dist_param1+ |
+
| 1022 | +! | +
+ input$dist_param2+ |
+
| 1023 | +! | +
+ input$dist_tests+ |
+
| 1024 | ++ |
+ },+ |
+
| 1025 | +! | +
+ valueExpr = {
+ |
+
| 1026 | ++ |
+ # Create a private stack for this function only.+ |
+
| 1027 | +! | +
+ ANL <- common_q()[["ANL"]]+ |
+
| 1028 | ++ | + + | +
| 1029 | +! | +
+ dist_var <- merge_vars()$dist_var+ |
+
| 1030 | +! | +
+ s_var <- merge_vars()$s_var+ |
+
| 1031 | +! | +
+ g_var <- merge_vars()$g_var+ |
+
| 1032 | ++ | + + | +
| 1033 | +! | +
+ dist_var_name <- merge_vars()$dist_var_name+ |
+
| 1034 | +! | +
+ s_var_name <- merge_vars()$s_var_name+ |
+
| 1035 | +! | +
+ g_var_name <- merge_vars()$g_var_name+ |
+
| 1036 | ++ | + + | +
| 1037 | +! | +
+ dist_param1 <- input$dist_param1+ |
+
| 1038 | +! | +
+ dist_param2 <- input$dist_param2+ |
+
| 1039 | +! | +
+ dist_tests <- input$dist_tests+ |
+
| 1040 | +! | +
+ t_dist <- input$t_dist+ |
+
| 1041 | ++ | + + | +
| 1042 | +! | +
+ validate(need(dist_tests, "Please select a test"))+ |
+
| 1043 | ++ | + + | +
| 1044 | +! | +
+ teal::validate_inputs(iv_dist)+ |
+
| 1045 | ++ | + + | +
| 1046 | +! | +
+ if (length(s_var) > 0 || length(g_var) > 0) {
+ |
+
| 1047 | +! | +
+ counts <- ANL %>%+ |
+
| 1048 | +! | +
+ dplyr::group_by_at(dplyr::vars(dplyr::any_of(c(s_var, g_var)))) %>%+ |
+
| 1049 | +! | +
+ dplyr::summarise(n = dplyr::n())+ |
+
| 1050 | ++ | + + | +
| 1051 | +! | +
+ validate(need(all(counts$n > 5), "Please select strata*group with at least 5 observation each."))+ |
+
| 1052 | ++ |
+ }+ |
+
| 1053 | ++ | + + | +
| 1054 | ++ | + + | +
| 1055 | +! | +
+ if (dist_tests %in% c(+ |
+
| 1056 | +! | +
+ "t-test (two-samples, not paired)",+ |
+
| 1057 | +! | +
+ "F-test",+ |
+
| 1058 | +! | +
+ "Kolmogorov-Smirnov (two-samples)"+ |
+
| 1059 | ++ |
+ )) {
+ |
+
| 1060 | +! | +
+ if (length(g_var) == 0 && length(s_var) > 0) {
+ |
+
| 1061 | +! | +
+ validate(need(+ |
+
| 1062 | +! | +
+ length(unique(ANL[[s_var]])) == 2,+ |
+
| 1063 | +! | +
+ "Please select stratify variable with 2 levels."+ |
+
| 1064 | ++ |
+ ))+ |
+
| 1065 | ++ |
+ }+ |
+
| 1066 | +! | +
+ if (length(g_var) > 0 && length(s_var) > 0) {
+ |
+
| 1067 | +! | +
+ validate(need(+ |
+
| 1068 | +! | +
+ all(stats::na.omit(as.vector(+ |
+
| 1069 | +! | +
+ tapply(ANL[[s_var]], list(ANL[[g_var]]), function(x) length(unique(x))) == 2+ |
+
| 1070 | ++ |
+ ))),+ |
+
| 1071 | +! | +
+ "Please select stratify variable with 2 levels, per each group."+ |
+
| 1072 | ++ |
+ ))+ |
+
| 1073 | ++ |
+ }+ |
+
| 1074 | ++ |
+ }+ |
+
| 1075 | ++ | + + | +
| 1076 | +! | +
+ map_dist <- stats::setNames(+ |
+
| 1077 | +! | +
+ c("pnorm", "plnorm", "pgamma", "punif"),
+ |
+
| 1078 | +! | +
+ c("normal", "lognormal", "gamma", "unif")
+ |
+
| 1079 | ++ |
+ )+ |
+
| 1080 | +! | +
+ sks_args <- list(+ |
+
| 1081 | +! | +
+ test = quote(stats::ks.test),+ |
+
| 1082 | +! | +
+ args = bquote(append(list(.[[.(dist_var)]], .(map_dist[t_dist])), params)),+ |
+
| 1083 | +! | +
+ groups = c(g_var, s_var)+ |
+
| 1084 | ++ |
+ )+ |
+
| 1085 | +! | +
+ ssw_args <- list(+ |
+
| 1086 | +! | +
+ test = quote(stats::shapiro.test),+ |
+
| 1087 | +! | +
+ args = bquote(list(.[[.(dist_var)]])),+ |
+
| 1088 | +! | +
+ groups = c(g_var, s_var)+ |
+
| 1089 | ++ |
+ )+ |
+
| 1090 | +! | +
+ mfil_args <- list(+ |
+
| 1091 | +! | +
+ test = quote(stats::fligner.test),+ |
+
| 1092 | +! | +
+ args = bquote(list(.[[.(dist_var)]], .[[.(s_var)]])),+ |
+
| 1093 | +! | +
+ groups = c(g_var)+ |
+
| 1094 | ++ |
+ )+ |
+
| 1095 | +! | +
+ sad_args <- list(+ |
+
| 1096 | +! | +
+ test = quote(goftest::ad.test),+ |
+
| 1097 | +! | +
+ args = bquote(append(list(.[[.(dist_var)]], .(map_dist[t_dist])), params)),+ |
+
| 1098 | +! | +
+ groups = c(g_var, s_var)+ |
+
| 1099 | ++ |
+ )+ |
+
| 1100 | +! | +
+ scvm_args <- list(+ |
+
| 1101 | +! | +
+ test = quote(goftest::cvm.test),+ |
+
| 1102 | +! | +
+ args = bquote(append(list(.[[.(dist_var)]], .(map_dist[t_dist])), params)),+ |
+
| 1103 | +! | +
+ groups = c(g_var, s_var)+ |
+
| 1104 | ++ |
+ )+ |
+
| 1105 | +! | +
+ manov_args <- list(+ |
+
| 1106 | +! | +
+ test = quote(stats::aov),+ |
+
| 1107 | +! | +
+ args = bquote(list(stats::formula(.(dist_var_name) ~ .(s_var_name)), .)),+ |
+
| 1108 | +! | +
+ groups = c(g_var)+ |
+
| 1109 | ++ |
+ )+ |
+
| 1110 | +! | +
+ mt_args <- list(+ |
+
| 1111 | +! | +
+ test = quote(stats::t.test),+ |
+
| 1112 | +! | +
+ args = bquote(unname(split(.[[.(dist_var)]], .[[.(s_var)]], drop = TRUE))),+ |
+
| 1113 | +! | +
+ groups = c(g_var)+ |
+
| 1114 | ++ |
+ )+ |
+
| 1115 | +! | +
+ mv_args <- list(+ |
+
| 1116 | +! | +
+ test = quote(stats::var.test),+ |
+
| 1117 | +! | +
+ args = bquote(unname(split(.[[.(dist_var)]], .[[.(s_var)]], drop = TRUE))),+ |
+
| 1118 | +! | +
+ groups = c(g_var)+ |
+
| 1119 | ++ |
+ )+ |
+
| 1120 | +! | +
+ mks_args <- list(+ |
+
| 1121 | +! | +
+ test = quote(stats::ks.test),+ |
+
| 1122 | +! | +
+ args = bquote(unname(split(.[[.(dist_var)]], .[[.(s_var)]], drop = TRUE))),+ |
+
| 1123 | +! | +
+ groups = c(g_var)+ |
+
| 1124 | ++ |
+ )+ |
+
| 1125 | ++ | + + | +
| 1126 | +! | +
+ tests_base <- switch(dist_tests,+ |
+
| 1127 | +! | +
+ "Kolmogorov-Smirnov (one-sample)" = sks_args,+ |
+
| 1128 | +! | +
+ "Shapiro-Wilk" = ssw_args,+ |
+
| 1129 | +! | +
+ "Fligner-Killeen" = mfil_args,+ |
+
| 1130 | +! | +
+ "one-way ANOVA" = manov_args,+ |
+
| 1131 | +! | +
+ "t-test (two-samples, not paired)" = mt_args,+ |
+
| 1132 | +! | +
+ "F-test" = mv_args,+ |
+
| 1133 | +! | +
+ "Kolmogorov-Smirnov (two-samples)" = mks_args,+ |
+
| 1134 | +! | +
+ "Anderson-Darling (one-sample)" = sad_args,+ |
+
| 1135 | +! | +
+ "Cramer-von Mises (one-sample)" = scvm_args+ |
+
| 1136 | ++ |
+ )+ |
+
| 1137 | ++ | + + | +
| 1138 | +! | +
+ env <- list(+ |
+
| 1139 | +! | +
+ t_test = t_dist,+ |
+
| 1140 | +! | +
+ dist_var = dist_var,+ |
+
| 1141 | +! | +
+ g_var = g_var,+ |
+
| 1142 | +! | +
+ s_var = s_var,+ |
+
| 1143 | +! | +
+ args = tests_base$args,+ |
+
| 1144 | +! | +
+ groups = tests_base$groups,+ |
+
| 1145 | +! | +
+ test = tests_base$test,+ |
+
| 1146 | +! | +
+ dist_var_name = dist_var_name,+ |
+
| 1147 | +! | +
+ g_var_name = g_var_name,+ |
+
| 1148 | +! | +
+ s_var_name = s_var_name+ |
+
| 1149 | ++ |
+ )+ |
+
| 1150 | ++ | + + | +
| 1151 | +! | +
+ qenv <- common_q()+ |
+
| 1152 | ++ | + + | +
| 1153 | +! | +
+ if (length(s_var) == 0 && length(g_var) == 0) {
+ |
+
| 1154 | +! | +
+ qenv <- teal.code::eval_code(+ |
+
| 1155 | +! | +
+ qenv,+ |
+
| 1156 | +! | +
+ substitute(+ |
+
| 1157 | +! | +
+ expr = {
+ |
+
| 1158 | +! | +
+ test_stats <- ANL %>%+ |
+
| 1159 | +! | +
+ dplyr::select(dist_var) %>%+ |
+
| 1160 | +! | +
+ with(., broom::glance(do.call(test, args))) %>%+ |
+
| 1161 | +! | +
+ dplyr::mutate_if(is.numeric, round, 3)+ |
+
| 1162 | ++ |
+ },+ |
+
| 1163 | +! | +
+ env = env+ |
+
| 1164 | ++ |
+ )+ |
+
| 1165 | ++ |
+ )+ |
+
| 1166 | ++ |
+ } else {
+ |
+
| 1167 | +! | +
+ qenv <- teal.code::eval_code(+ |
+
| 1168 | +! | +
+ qenv,+ |
+
| 1169 | +! | +
+ substitute(+ |
+
| 1170 | +! | +
+ expr = {
+ |
+
| 1171 | +! | +
+ test_stats <- ANL %>%+ |
+
| 1172 | +! | +
+ dplyr::select(dist_var, s_var, g_var) %>%+ |
+
| 1173 | +! | +
+ dplyr::group_by_at(dplyr::vars(dplyr::any_of(groups))) %>%+ |
+
| 1174 | +! | +
+ dplyr::do(tests = broom::glance(do.call(test, args))) %>%+ |
+
| 1175 | +! | +
+ tidyr::unnest(tests) %>%+ |
+
| 1176 | +! | +
+ dplyr::mutate_if(is.numeric, round, 3)+ |
+
| 1177 | ++ |
+ },+ |
+
| 1178 | +! | +
+ env = env+ |
+
| 1179 | ++ |
+ )+ |
+
| 1180 | ++ |
+ )+ |
+
| 1181 | ++ |
+ }+ |
+
| 1182 | +! | +
+ qenv %>%+ |
+
| 1183 | ++ |
+ # used to display table when running show-r-code code+ |
+
| 1184 | +! | +
+ teal.code::eval_code(quote(test_stats))+ |
+
| 1185 | ++ |
+ }+ |
+
| 1186 | ++ |
+ )+ |
+
| 1187 | ++ | + + | +
| 1188 | ++ |
+ # outputs ----+ |
+
| 1189 | ++ |
+ ## building main qenv+ |
+
| 1190 | +! | +
+ output_q <- reactive({
+ |
+
| 1191 | +! | +
+ tab <- input$tabs+ |
+
| 1192 | +! | +
+ req(tab) # tab is NULL upon app launch, hence will crash without this statement+ |
+
| 1193 | ++ | + + | +
| 1194 | +! | +
+ qenv_final <- common_q()+ |
+
| 1195 | ++ |
+ # wrapped in if since could lead into validate error - we do want to continue+ |
+
| 1196 | +! | +
+ test_r_qenv_out <- try(test_q(), silent = TRUE)+ |
+
| 1197 | +! | +
+ if (!inherits(test_r_qenv_out, c("try-error", "error"))) {
+ |
+
| 1198 | +! | +
+ qenv_final <- teal.code::join(qenv_final, test_q())+ |
+
| 1199 | ++ |
+ }+ |
+
| 1200 | ++ | + + | +
| 1201 | +! | +
+ qenv_final <- if (tab == "Histogram") {
+ |
+
| 1202 | +! | +
+ req(dist_q())+ |
+
| 1203 | +! | +
+ teal.code::join(qenv_final, dist_q())+ |
+
| 1204 | +! | +
+ } else if (tab == "QQplot") {
+ |
+
| 1205 | +! | +
+ req(qq_q())+ |
+
| 1206 | +! | +
+ teal.code::join(qenv_final, qq_q())+ |
+
| 1207 | ++ |
+ }+ |
+
| 1208 | +! | +
+ qenv_final+ |
+
| 1209 | ++ |
+ })+ |
+
| 1210 | ++ | + + | +
| 1211 | +! | +
+ dist_r <- reactive(dist_q()[["g"]])+ |
+
| 1212 | ++ | + + | +
| 1213 | +! | +
+ qq_r <- reactive(qq_q()[["g"]])+ |
+
| 1214 | ++ | + + | +
| 1215 | +! | +
+ output$summary_table <- DT::renderDataTable(+ |
+
| 1216 | +! | +
+ expr = if (iv_r()$is_valid()) common_q()[["summary_table"]] else NULL,+ |
+
| 1217 | +! | +
+ options = list(+ |
+
| 1218 | +! | +
+ autoWidth = TRUE,+ |
+
| 1219 | +! | +
+ columnDefs = list(list(width = "200px", targets = "_all"))+ |
+
| 1220 | ++ |
+ ),+ |
+
| 1221 | +! | +
+ rownames = FALSE+ |
+
| 1222 | ++ |
+ )+ |
+
| 1223 | ++ | + + | +
| 1224 | +! | +
+ tests_r <- reactive({
+ |
+
| 1225 | +! | +
+ req(iv_r()$is_valid())+ |
+
| 1226 | +! | +
+ teal::validate_inputs(iv_r_dist())+ |
+
| 1227 | +! | +
+ test_q()[["test_stats"]]+ |
+
| 1228 | ++ |
+ })+ |
+
| 1229 | ++ | + + | +
| 1230 | +! | +
+ pws1 <- teal.widgets::plot_with_settings_srv(+ |
+
| 1231 | +! | +
+ id = "hist_plot",+ |
+
| 1232 | +! | +
+ plot_r = dist_r,+ |
+
| 1233 | +! | +
+ height = plot_height,+ |
+
| 1234 | +! | +
+ width = plot_width,+ |
+
| 1235 | +! | +
+ brushing = FALSE+ |
+
| 1236 | ++ |
+ )+ |
+
| 1237 | ++ | + + | +
| 1238 | +! | +
+ pws2 <- teal.widgets::plot_with_settings_srv(+ |
+
| 1239 | +! | +
+ id = "qq_plot",+ |
+
| 1240 | +! | +
+ plot_r = qq_r,+ |
+
| 1241 | +! | +
+ height = plot_height,+ |
+
| 1242 | +! | +
+ width = plot_width,+ |
+
| 1243 | +! | +
+ brushing = FALSE+ |
+
| 1244 | ++ |
+ )+ |
+
| 1245 | ++ | + + | +
| 1246 | +! | +
+ output$t_stats <- DT::renderDataTable(+ |
+
| 1247 | +! | +
+ expr = tests_r(),+ |
+
| 1248 | +! | +
+ options = list(scrollX = TRUE),+ |
+
| 1249 | +! | +
+ rownames = FALSE+ |
+
| 1250 | ++ |
+ )+ |
+
| 1251 | ++ | + + | +
| 1252 | +! | +
+ teal.widgets::verbatim_popup_srv(+ |
+
| 1253 | +! | +
+ id = "warning",+ |
+
| 1254 | +! | +
+ verbatim_content = reactive(teal.code::get_warnings(output_q())),+ |
+
| 1255 | +! | +
+ title = "Warning",+ |
+
| 1256 | +! | +
+ disabled = reactive(is.null(teal.code::get_warnings(output_q())))+ |
+
| 1257 | ++ |
+ )+ |
+
| 1258 | ++ | + + | +
| 1259 | +! | +
+ teal.widgets::verbatim_popup_srv(+ |
+
| 1260 | +! | +
+ id = "rcode",+ |
+
| 1261 | +! | +
+ verbatim_content = reactive(teal.code::get_code(output_q())),+ |
+
| 1262 | +! | +
+ title = "R Code for distribution"+ |
+
| 1263 | ++ |
+ )+ |
+
| 1264 | ++ | + + | +
| 1265 | ++ |
+ ### REPORTER+ |
+
| 1266 | +! | +
+ if (with_reporter) {
+ |
+
| 1267 | +! | +
+ card_fun <- function(comment, label) {
+ |
+
| 1268 | +! | +
+ card <- teal::report_card_template(+ |
+
| 1269 | +! | +
+ title = "Distribution Plot",+ |
+
| 1270 | +! | +
+ label = label,+ |
+
| 1271 | +! | +
+ with_filter = with_filter,+ |
+
| 1272 | +! | +
+ filter_panel_api = filter_panel_api+ |
+
| 1273 | ++ |
+ )+ |
+
| 1274 | +! | +
+ card$append_text("Plot", "header3")
+ |
+
| 1275 | +! | +
+ if (input$tabs == "Histogram") {
+ |
+
| 1276 | +! | +
+ card$append_plot(dist_r(), dim = pws1$dim())+ |
+
| 1277 | +! | +
+ } else if (input$tabs == "QQplot") {
+ |
+
| 1278 | +! | +
+ card$append_plot(qq_r(), dim = pws2$dim())+ |
+
| 1279 | ++ |
+ }+ |
+
| 1280 | +! | +
+ card$append_text("Statistics table", "header3")
+ |
+
| 1281 | ++ | + + | +
| 1282 | +! | +
+ card$append_table(common_q()[["summary_table"]])+ |
+
| 1283 | +! | +
+ tests_error <- tryCatch(expr = tests_r(), error = function(e) "error")+ |
+
| 1284 | +! | +
+ if (inherits(tests_error, "data.frame")) {
+ |
+
| 1285 | +! | +
+ card$append_text("Tests table", "header3")
+ |
+
| 1286 | +! | +
+ card$append_table(tests_r())+ |
+
| 1287 | ++ |
+ }+ |
+
| 1288 | ++ | + + | +
| 1289 | +! | +
+ if (!comment == "") {
+ |
+
| 1290 | +! | +
+ card$append_text("Comment", "header3")
+ |
+
| 1291 | +! | +
+ card$append_text(comment)+ |
+
| 1292 | ++ |
+ }+ |
+
| 1293 | +! | +
+ card$append_src(teal.code::get_code(output_q()))+ |
+
| 1294 | +! | +
+ card+ |
+
| 1295 | ++ |
+ }+ |
+
| 1296 | +! | +
+ teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
+ |
+
| 1297 | ++ |
+ }+ |
+
| 1298 | ++ |
+ ###+ |
+
| 1299 | ++ |
+ })+ |
+
| 1300 | ++ |
+ }+ |
+
| 1 | ++ |
+ #' `teal` module: Univariate and bivariate visualizations+ |
+
| 2 | ++ |
+ #'+ |
+
| 3 | ++ |
+ #' Module enables the creation of univariate and bivariate plots,+ |
+
| 4 | ++ |
+ #' facilitating the exploration of data distributions and relationships between two variables.+ |
+
| 5 | ++ |
+ #'+ |
+
| 6 | ++ |
+ #' This is a general module to visualize 1 & 2 dimensional data.+ |
+
| 7 | ++ |
+ #'+ |
+
| 8 | ++ |
+ #' @note+ |
+
| 9 | ++ |
+ #' For more examples, please see the vignette "Using bivariate plot" via+ |
+
| 10 | ++ |
+ #' `vignette("using-bivariate-plot", package = "teal.modules.general")`.
+ |
+
| 11 | ++ |
+ #'+ |
+
| 12 | ++ |
+ #' @inheritParams teal::module+ |
+
| 13 | ++ |
+ #' @inheritParams shared_params+ |
+
| 14 | ++ |
+ #' @param x (`data_extract_spec` or `list` of multiple `data_extract_spec`)+ |
+
| 15 | ++ |
+ #' Variable names selected to plot along the x-axis by default.+ |
+
| 16 | ++ |
+ #' Can be numeric, factor or character.+ |
+
| 17 | ++ |
+ #' No empty selections are allowed.+ |
+
| 18 | ++ |
+ #' @param y (`data_extract_spec` or `list` of multiple `data_extract_spec`)+ |
+
| 19 | ++ |
+ #' Variable names selected to plot along the y-axis by default.+ |
+
| 20 | ++ |
+ #' Can be numeric, factor or character.+ |
+
| 21 | ++ |
+ #' @param use_density (`logical`) optional, indicates whether to plot density (`TRUE`) or frequency (`FALSE`).+ |
+
| 22 | ++ |
+ #' Defaults to frequency (`FALSE`).+ |
+
| 23 | ++ |
+ #' @param row_facet (`data_extract_spec` or `list` of multiple `data_extract_spec`) optional,+ |
+
| 24 | ++ |
+ #' specification of the data variable(s) to use for faceting rows.+ |
+
| 25 | ++ |
+ #' @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 | ++ |
+ #' @param facet (`logical`) optional, specifies whether the facet encodings `ui` elements are toggled+ |
+
| 28 | ++ |
+ #' on and shown to the user by default. Defaults to `TRUE` if either `row_facet` or `column_facet`+ |
+
| 29 | ++ |
+ #' are supplied.+ |
+
| 30 | ++ |
+ #' @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 | ++ |
+ #' specification of the data variable(s) selected for the outline color inside the coloring settings.+ |
+
| 34 | ++ |
+ #' It will be applied when `color_settings` is set to `TRUE`.+ |
+
| 35 | ++ |
+ #' @param fill (`data_extract_spec` or `list` of multiple `data_extract_spec`) optional,+ |
+
| 36 | ++ |
+ #' specification of the data variable(s) selected for the fill color inside the coloring settings.+ |
+
| 37 | ++ |
+ #' It will be applied when `color_settings` is set to `TRUE`.+ |
+
| 38 | ++ |
+ #' @param size (`data_extract_spec` or `list` of multiple `data_extract_spec`) optional,+ |
+
| 39 | ++ |
+ #' specification of the data variable(s) selected for the size of `geom_point` plots inside the coloring settings.+ |
+
| 40 | ++ |
+ #' 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 | ++ |
+ #' @param swap_axes (`logical`) optional, whether to swap X and Y axes. Defaults to `FALSE`.+ |
+
| 46 | ++ |
+ #'+ |
+
| 47 | ++ |
+ #' @inherit shared_params return+ |
+
| 48 | ++ |
+ #'+ |
+
| 49 | ++ |
+ #' @examples+ |
+
| 50 | ++ |
+ #' library(teal.widgets)+ |
+
| 51 | ++ |
+ #'+ |
+
| 52 | ++ |
+ #' # general data example+ |
+
| 53 | ++ |
+ #' data <- teal_data()+ |
+
| 54 | ++ |
+ #' data <- within(data, {
+ |
+
| 55 | ++ |
+ #' require(nestcolor)+ |
+
| 56 | ++ |
+ #' CO2 <- data.frame(CO2)+ |
+
| 57 | ++ |
+ #' })+ |
+
| 58 | ++ |
+ #' datanames(data) <- c("CO2")
+ |
+
| 59 | ++ |
+ #' join_keys(data) <- default_cdisc_join_keys[datanames(data)]+ |
+
| 60 | ++ |
+ #'+ |
+
| 61 | ++ |
+ #' app <- init(+ |
+
| 62 | ++ |
+ #' data = data,+ |
+
| 63 | ++ |
+ #' modules = modules(+ |
+
| 64 | ++ |
+ #' tm_g_bivariate(+ |
+
| 65 | ++ |
+ #' x = data_extract_spec(+ |
+
| 66 | ++ |
+ #' dataname = "CO2",+ |
+
| 67 | ++ |
+ #' select = select_spec(+ |
+
| 68 | ++ |
+ #' label = "Select variable:",+ |
+
| 69 | ++ |
+ #' choices = variable_choices(data[["CO2"]]),+ |
+
| 70 | ++ |
+ #' selected = "conc",+ |
+
| 71 | ++ |
+ #' fixed = FALSE+ |
+
| 72 | ++ |
+ #' )+ |
+
| 73 | ++ |
+ #' ),+ |
+
| 74 | ++ |
+ #' y = data_extract_spec(+ |
+
| 75 | ++ |
+ #' dataname = "CO2",+ |
+
| 76 | ++ |
+ #' select = select_spec(+ |
+
| 77 | ++ |
+ #' label = "Select variable:",+ |
+
| 78 | ++ |
+ #' choices = variable_choices(data[["CO2"]]),+ |
+
| 79 | ++ |
+ #' selected = "uptake",+ |
+
| 80 | ++ |
+ #' multiple = FALSE,+ |
+
| 81 | ++ |
+ #' fixed = FALSE+ |
+
| 82 | ++ |
+ #' )+ |
+
| 83 | ++ |
+ #' ),+ |
+
| 84 | ++ |
+ #' row_facet = data_extract_spec(+ |
+
| 85 | ++ |
+ #' dataname = "CO2",+ |
+
| 86 | ++ |
+ #' select = select_spec(+ |
+
| 87 | ++ |
+ #' label = "Select variable:",+ |
+
| 88 | ++ |
+ #' choices = variable_choices(data[["CO2"]]),+ |
+
| 89 | ++ |
+ #' selected = "Type",+ |
+
| 90 | ++ |
+ #' fixed = FALSE+ |
+
| 91 | ++ |
+ #' )+ |
+
| 92 | ++ |
+ #' ),+ |
+
| 93 | ++ |
+ #' col_facet = data_extract_spec(+ |
+
| 94 | ++ |
+ #' dataname = "CO2",+ |
+
| 95 | ++ |
+ #' select = select_spec(+ |
+
| 96 | ++ |
+ #' label = "Select variable:",+ |
+
| 97 | ++ |
+ #' choices = variable_choices(data[["CO2"]]),+ |
+
| 98 | ++ |
+ #' selected = "Treatment",+ |
+
| 99 | ++ |
+ #' fixed = FALSE+ |
+
| 100 | ++ |
+ #' )+ |
+
| 101 | ++ |
+ #' ),+ |
+
| 102 | ++ |
+ #' ggplot2_args = ggplot2_args(+ |
+
| 103 | ++ |
+ #' labs = list(subtitle = "Plot generated by Bivariate Module")+ |
+
| 104 | ++ |
+ #' )+ |
+
| 105 | ++ |
+ #' )+ |
+
| 106 | ++ |
+ #' )+ |
+
| 107 | ++ |
+ #' )+ |
+
| 108 | ++ |
+ #' if (interactive()) {
+ |
+
| 109 | ++ |
+ #' shinyApp(app$ui, app$server)+ |
+
| 110 | ++ |
+ #' }+ |
+
| 111 | ++ |
+ #'+ |
+
| 112 | ++ |
+ #'+ |
+
| 113 | ++ |
+ #' # CDISC data example+ |
+
| 114 | ++ |
+ #' data <- teal_data()+ |
+
| 115 | ++ |
+ #' data <- within(data, {
+ |
+
| 116 | ++ |
+ #' require(nestcolor)+ |
+
| 117 | ++ |
+ #' ADSL <- rADSL+ |
+
| 118 | ++ |
+ #' })+ |
+
| 119 | ++ |
+ #' datanames(data) <- c("ADSL")
+ |
+
| 120 | ++ |
+ #' join_keys(data) <- default_cdisc_join_keys[datanames(data)]+ |
+
| 121 | ++ |
+ #'+ |
+
| 122 | ++ |
+ #' app <- init(+ |
+
| 123 | ++ |
+ #' data = data,+ |
+
| 124 | ++ |
+ #' modules = modules(+ |
+
| 125 | ++ |
+ #' tm_g_bivariate(+ |
+
| 126 | ++ |
+ #' x = data_extract_spec(+ |
+
| 127 | ++ |
+ #' dataname = "ADSL",+ |
+
| 128 | ++ |
+ #' select = select_spec(+ |
+
| 129 | ++ |
+ #' label = "Select variable:",+ |
+
| 130 | ++ |
+ #' choices = variable_choices(data[["ADSL"]]),+ |
+
| 131 | ++ |
+ #' selected = "AGE",+ |
+
| 132 | ++ |
+ #' fixed = FALSE+ |
+
| 133 | ++ |
+ #' )+ |
+
| 134 | ++ |
+ #' ),+ |
+
| 135 | ++ |
+ #' y = data_extract_spec(+ |
+
| 136 | ++ |
+ #' dataname = "ADSL",+ |
+
| 137 | ++ |
+ #' select = select_spec(+ |
+
| 138 | ++ |
+ #' label = "Select variable:",+ |
+
| 139 | ++ |
+ #' choices = variable_choices(data[["ADSL"]]),+ |
+
| 140 | ++ |
+ #' selected = "SEX",+ |
+
| 141 | ++ |
+ #' multiple = FALSE,+ |
+
| 142 | ++ |
+ #' fixed = FALSE+ |
+
| 143 | ++ |
+ #' )+ |
+
| 144 | ++ |
+ #' ),+ |
+
| 145 | ++ |
+ #' row_facet = data_extract_spec(+ |
+
| 146 | ++ |
+ #' dataname = "ADSL",+ |
+
| 147 | ++ |
+ #' select = select_spec(+ |
+
| 148 | ++ |
+ #' label = "Select variable:",+ |
+
| 149 | ++ |
+ #' choices = variable_choices(data[["ADSL"]]),+ |
+
| 150 | ++ |
+ #' selected = "ARM",+ |
+
| 151 | ++ |
+ #' fixed = FALSE+ |
+
| 152 | ++ |
+ #' )+ |
+
| 153 | ++ |
+ #' ),+ |
+
| 154 | ++ |
+ #' col_facet = data_extract_spec(+ |
+
| 155 | ++ |
+ #' dataname = "ADSL",+ |
+
| 156 | ++ |
+ #' select = select_spec(+ |
+
| 157 | ++ |
+ #' label = "Select variable:",+ |
+
| 158 | ++ |
+ #' choices = variable_choices(data[["ADSL"]]),+ |
+
| 159 | ++ |
+ #' selected = "COUNTRY",+ |
+
| 160 | ++ |
+ #' fixed = FALSE+ |
+
| 161 | ++ |
+ #' )+ |
+
| 162 | ++ |
+ #' ),+ |
+
| 163 | ++ |
+ #' ggplot2_args = ggplot2_args(+ |
+
| 164 | ++ |
+ #' labs = list(subtitle = "Plot generated by Bivariate Module")+ |
+
| 165 | ++ |
+ #' )+ |
+
| 166 | ++ |
+ #' )+ |
+
| 167 | ++ |
+ #' )+ |
+
| 168 | ++ |
+ #' )+ |
+
| 169 | ++ |
+ #' if (interactive()) {
+ |
+
| 170 | ++ |
+ #' shinyApp(app$ui, app$server)+ |
+
| 171 | ++ |
+ #' }+ |
+
| 172 | ++ |
+ #'+ |
+
| 173 | ++ |
+ #' @export+ |
+
| 174 | ++ |
+ #'+ |
+
| 175 | ++ |
+ tm_g_bivariate <- function(label = "Bivariate Plots",+ |
+
| 176 | ++ |
+ x,+ |
+
| 177 | ++ |
+ y,+ |
+
| 178 | ++ |
+ row_facet = NULL,+ |
+
| 179 | ++ |
+ col_facet = NULL,+ |
+
| 180 | ++ |
+ facet = !is.null(row_facet) || !is.null(col_facet),+ |
+
| 181 | ++ |
+ color = NULL,+ |
+
| 182 | ++ |
+ fill = NULL,+ |
+
| 183 | ++ |
+ size = NULL,+ |
+
| 184 | ++ |
+ use_density = FALSE,+ |
+
| 185 | ++ |
+ color_settings = FALSE,+ |
+
| 186 | ++ |
+ free_x_scales = FALSE,+ |
+
| 187 | ++ |
+ free_y_scales = FALSE,+ |
+
| 188 | ++ |
+ plot_height = c(600, 200, 2000),+ |
+
| 189 | ++ |
+ plot_width = NULL,+ |
+
| 190 | ++ |
+ rotate_xaxis_labels = FALSE,+ |
+
| 191 | ++ |
+ swap_axes = FALSE,+ |
+
| 192 | ++ |
+ ggtheme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void"),
+ |
+
| 193 | ++ |
+ ggplot2_args = teal.widgets::ggplot2_args(),+ |
+
| 194 | ++ |
+ pre_output = NULL,+ |
+
| 195 | ++ |
+ post_output = NULL) {
+ |
+
| 196 | +18x | +
+ logger::log_info("Initializing tm_g_bivariate")
+ |
+
| 197 | ++ | + + | +
| 198 | ++ |
+ # Normalize the parameters+ |
+
| 199 | +14x | +
+ if (inherits(x, "data_extract_spec")) x <- list(x)+ |
+
| 200 | +13x | +
+ if (inherits(y, "data_extract_spec")) y <- list(y)+ |
+
| 201 | +1x | +
+ if (inherits(row_facet, "data_extract_spec")) row_facet <- list(row_facet)+ |
+
| 202 | +1x | +
+ if (inherits(col_facet, "data_extract_spec")) col_facet <- list(col_facet)+ |
+
| 203 | +1x | +
+ if (inherits(color, "data_extract_spec")) color <- list(color)+ |
+
| 204 | +1x | +
+ if (inherits(fill, "data_extract_spec")) fill <- list(fill)+ |
+
| 205 | +1x | +
+ if (inherits(size, "data_extract_spec")) size <- list(size)+ |
+
| 206 | ++ | + + | +
| 207 | ++ |
+ # Start of assertions+ |
+
| 208 | +18x | +
+ checkmate::assert_string(label)+ |
+
| 209 | ++ | + + | +
| 210 | +18x | +
+ checkmate::assert_list(x, types = "data_extract_spec")+ |
+
| 211 | +18x | +
+ assert_single_selection(x)+ |
+
| 212 | ++ | + + | +
| 213 | +16x | +
+ checkmate::assert_list(y, types = "data_extract_spec")+ |
+
| 214 | +16x | +
+ assert_single_selection(y)+ |
+
| 215 | ++ | + + | +
| 216 | +14x | +
+ checkmate::assert_list(row_facet, types = "data_extract_spec", null.ok = TRUE)+ |
+
| 217 | +14x | +
+ assert_single_selection(row_facet)+ |
+
| 218 | ++ | + + | +
| 219 | +14x | +
+ checkmate::assert_list(col_facet, types = "data_extract_spec", null.ok = TRUE)+ |
+
| 220 | +14x | +
+ assert_single_selection(col_facet)+ |
+
| 221 | ++ | + + | +
| 222 | +14x | +
+ checkmate::assert_flag(facet)+ |
+
| 223 | ++ | + + | +
| 224 | +14x | +
+ checkmate::assert_list(color, types = "data_extract_spec", null.ok = TRUE)+ |
+
| 225 | +14x | +
+ assert_single_selection(color)+ |
+
| 226 | ++ | + + | +
| 227 | +14x | +
+ checkmate::assert_list(fill, types = "data_extract_spec", null.ok = TRUE)+ |
+
| 228 | +14x | +
+ assert_single_selection(fill)+ |
+
| 229 | ++ | + + | +
| 230 | +14x | +
+ checkmate::assert_list(size, types = "data_extract_spec", null.ok = TRUE)+ |
+
| 231 | +14x | +
+ assert_single_selection(size)+ |
+
| 232 | ++ | + + | +
| 233 | +14x | +
+ checkmate::assert_flag(use_density)+ |
+
| 234 | ++ | + + | +
| 235 | ++ |
+ # Determines color, fill & size if they are not explicitly set+ |
+
| 236 | +14x | +
+ checkmate::assert_flag(color_settings)+ |
+
| 237 | +14x | +
+ if (color_settings) {
+ |
+
| 238 | +2x | +
+ if (is.null(color)) {
+ |
+
| 239 | +2x | +
+ color <- x+ |
+
| 240 | +2x | +
+ color[[1]]$select <- teal.transform::select_spec(choices = color[[1]]$select$choices, selected = NULL)+ |
+
| 241 | ++ |
+ }+ |
+
| 242 | +2x | +
+ if (is.null(fill)) {
+ |
+
| 243 | +2x | +
+ fill <- x+ |
+
| 244 | +2x | +
+ fill[[1]]$select <- teal.transform::select_spec(choices = fill[[1]]$select$choices, selected = NULL)+ |
+
| 245 | ++ |
+ }+ |
+
| 246 | +2x | +
+ if (is.null(size)) {
+ |
+
| 247 | +2x | +
+ size <- x+ |
+
| 248 | +2x | +
+ size[[1]]$select <- teal.transform::select_spec(choices = size[[1]]$select$choices, selected = NULL)+ |
+
| 249 | ++ |
+ }+ |
+
| 250 | ++ |
+ } else {
+ |
+
| 251 | +12x | +
+ if (!is.null(c(color, fill, size))) {
+ |
+
| 252 | +3x | +
+ stop("'color_settings' argument needs to be set to TRUE if 'color', 'fill', and/or 'size' is/are supplied.")
+ |
+
| 253 | ++ |
+ }+ |
+
| 254 | ++ |
+ }+ |
+
| 255 | ++ | + + | +
| 256 | +11x | +
+ checkmate::assert_flag(free_x_scales)+ |
+
| 257 | +11x | +
+ checkmate::assert_flag(free_y_scales)+ |
+
| 258 | ++ | + + | +
| 259 | +11x | +
+ checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE)+ |
+
| 260 | +10x | +
+ checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height")+ |
+
| 261 | +8x | +
+ checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE)+ |
+
| 262 | +7x | +
+ checkmate::assert_numeric(+ |
+
| 263 | +7x | +
+ plot_width[1],+ |
+
| 264 | +7x | +
+ lower = plot_width[2], upper = plot_width[3], null.ok = TRUE, .var.name = "plot_width"+ |
+
| 265 | ++ |
+ )+ |
+
| 266 | ++ | + + | +
| 267 | +5x | +
+ checkmate::assert_flag(rotate_xaxis_labels)+ |
+
| 268 | +5x | +
+ checkmate::assert_flag(swap_axes)+ |
+
| 269 | ++ | + + | +
| 270 | +5x | +
+ ggtheme <- match.arg(ggtheme)+ |
+
| 271 | +5x | +
+ checkmate::assert_class(ggplot2_args, "ggplot2_args")+ |
+
| 272 | ++ | + + | +
| 273 | +5x | +
+ checkmate::assert_multi_class(pre_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
+ |
+
| 274 | +5x | +
+ checkmate::assert_multi_class(post_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
+ |
+
| 275 | ++ |
+ # End of assertions+ |
+
| 276 | ++ | + + | +
| 277 | ++ |
+ # Make UI args+ |
+
| 278 | +5x | +
+ args <- as.list(environment())+ |
+
| 279 | ++ | + + | +
| 280 | +5x | +
+ data_extract_list <- list(+ |
+
| 281 | +5x | +
+ x = x,+ |
+
| 282 | +5x | +
+ y = y,+ |
+
| 283 | +5x | +
+ row_facet = row_facet,+ |
+
| 284 | +5x | +
+ col_facet = col_facet,+ |
+
| 285 | +5x | +
+ color_settings = color_settings,+ |
+
| 286 | +5x | +
+ color = color,+ |
+
| 287 | +5x | +
+ fill = fill,+ |
+
| 288 | +5x | +
+ size = size+ |
+
| 289 | ++ |
+ )+ |
+
| 290 | ++ | + + | +
| 291 | +5x | +
+ module(+ |
+
| 292 | +5x | +
+ label = label,+ |
+
| 293 | +5x | +
+ server = srv_g_bivariate,+ |
+
| 294 | +5x | +
+ ui = ui_g_bivariate,+ |
+
| 295 | +5x | +
+ ui_args = args,+ |
+
| 296 | +5x | +
+ server_args = c(+ |
+
| 297 | +5x | +
+ data_extract_list,+ |
+
| 298 | +5x | +
+ list(plot_height = plot_height, plot_width = plot_width, ggplot2_args = ggplot2_args)+ |
+
| 299 | ++ |
+ ),+ |
+
| 300 | +5x | +
+ datanames = teal.transform::get_extract_datanames(data_extract_list)+ |
+
| 301 | ++ |
+ )+ |
+
| 302 | ++ |
+ }+ |
+
| 303 | ++ | + + | +
| 304 | ++ |
+ # UI function for the bivariate module+ |
+
| 305 | ++ |
+ ui_g_bivariate <- function(id, ...) {
+ |
+
| 306 | +! | +
+ args <- list(...)+ |
+
| 307 | +! | +
+ is_single_dataset_value <- teal.transform::is_single_dataset(+ |
+
| 308 | +! | +
+ args$x, args$y, args$row_facet, args$col_facet, args$color, args$fill, args$size+ |
+
| 309 | ++ |
+ )+ |
+
| 310 | ++ | + + | +
| 311 | +! | +
+ ns <- NS(id)+ |
+
| 312 | +! | +
+ teal.widgets::standard_layout(+ |
+
| 313 | +! | +
+ output = teal.widgets::white_small_well(+ |
+
| 314 | +! | +
+ tags$div(teal.widgets::plot_with_settings_ui(id = ns("myplot")))
+ |
+
| 315 | ++ |
+ ),+ |
+
| 316 | +! | +
+ encoding = div(+ |
+
| 317 | ++ |
+ ### Reporter+ |
+
| 318 | +! | +
+ teal.reporter::simple_reporter_ui(ns("simple_reporter")),
+ |
+
| 319 | ++ |
+ ###+ |
+
| 320 | +! | +
+ tags$label("Encodings", class = "text-primary"),
+ |
+
| 321 | +! | +
+ teal.transform::datanames_input(args[c("x", "y", "row_facet", "col_facet", "color", "fill", "size")]),
+ |
+
| 322 | +! | +
+ teal.transform::data_extract_ui(+ |
+
| 323 | +! | +
+ id = ns("x"),
+ |
+
| 324 | +! | +
+ label = "X variable",+ |
+
| 325 | +! | +
+ data_extract_spec = args$x,+ |
+
| 326 | +! | +
+ is_single_dataset = is_single_dataset_value+ |
+
| 327 | ++ |
+ ),+ |
+
| 328 | +! | +
+ teal.transform::data_extract_ui(+ |
+
| 329 | +! | +
+ id = ns("y"),
+ |
+
| 330 | +! | +
+ label = "Y variable",+ |
+
| 331 | +! | +
+ data_extract_spec = args$y,+ |
+
| 332 | +! | +
+ is_single_dataset = is_single_dataset_value+ |
+
| 333 | ++ |
+ ),+ |
+
| 334 | +! | +
+ conditionalPanel(+ |
+
| 335 | +! | +
+ condition =+ |
+
| 336 | +! | +
+ "$(\"button[data-id*='-x-dataset'][data-id$='-select']\").text() == '- Nothing selected - ' ||+ |
+
| 337 | +! | +
+ $(\"button[data-id*='-y-dataset'][data-id$='-select']\").text() == '- Nothing selected - ' ",+ |
+
| 338 | +! | +
+ shinyWidgets::radioGroupButtons(+ |
+
| 339 | +! | +
+ inputId = ns("use_density"),
+ |
+
| 340 | +! | +
+ label = NULL,+ |
+
| 341 | +! | +
+ choices = c("frequency", "density"),
+ |
+
| 342 | +! | +
+ selected = ifelse(args$use_density, "density", "frequency"),+ |
+
| 343 | +! | +
+ justified = TRUE+ |
+
| 344 | ++ |
+ )+ |
+
| 345 | ++ |
+ ),+ |
+
| 346 | +! | +
+ if (!is.null(args$row_facet) || !is.null(args$col_facet)) {
+ |
+
| 347 | +! | +
+ div(+ |
+
| 348 | +! | +
+ class = "data-extract-box",+ |
+
| 349 | +! | +
+ tags$label("Facetting"),
+ |
+
| 350 | +! | +
+ shinyWidgets::switchInput(inputId = ns("facetting"), value = args$facet, size = "mini"),
+ |
+
| 351 | +! | +
+ conditionalPanel(+ |
+
| 352 | +! | +
+ condition = paste0("input['", ns("facetting"), "']"),
+ |
+
| 353 | +! | +
+ div(+ |
+
| 354 | +! | +
+ if (!is.null(args$row_facet)) {
+ |
+
| 355 | +! | +
+ teal.transform::data_extract_ui(+ |
+
| 356 | +! | +
+ id = ns("row_facet"),
+ |
+
| 357 | +! | +
+ label = "Row facetting variable",+ |
+
| 358 | +! | +
+ data_extract_spec = args$row_facet,+ |
+
| 359 | +! | +
+ is_single_dataset = is_single_dataset_value+ |
+
| 360 | ++ |
+ )+ |
+
| 361 | ++ |
+ },+ |
+
| 362 | +! | +
+ if (!is.null(args$col_facet)) {
+ |
+
| 363 | +! | +
+ teal.transform::data_extract_ui(+ |
+
| 364 | +! | +
+ id = ns("col_facet"),
+ |
+
| 365 | +! | +
+ label = "Column facetting variable",+ |
+
| 366 | +! | +
+ data_extract_spec = args$col_facet,+ |
+
| 367 | +! | +
+ is_single_dataset = is_single_dataset_value+ |
+
| 368 | ++ |
+ )+ |
+
| 369 | ++ |
+ },+ |
+
| 370 | +! | +
+ checkboxInput(ns("free_x_scales"), "free x scales", value = args$free_x_scales),
+ |
+
| 371 | +! | +
+ checkboxInput(ns("free_y_scales"), "free y scales", value = args$free_y_scales)
+ |
+
| 372 | ++ |
+ )+ |
+
| 373 | ++ |
+ )+ |
+
| 374 | ++ |
+ )+ |
+
| 375 | ++ |
+ },+ |
+
| 376 | +! | +
+ if (args$color_settings) {
+ |
+
| 377 | ++ |
+ # Put a grey border around the coloring settings+ |
+
| 378 | +! | +
+ div(+ |
+
| 379 | +! | +
+ class = "data-extract-box",+ |
+
| 380 | +! | +
+ tags$label("Color settings"),
+ |
+
| 381 | +! | +
+ shinyWidgets::switchInput(inputId = ns("coloring"), value = TRUE, size = "mini"),
+ |
+
| 382 | +! | +
+ conditionalPanel(+ |
+
| 383 | +! | +
+ condition = paste0("input['", ns("coloring"), "']"),
+ |
+
| 384 | +! | +
+ div(+ |
+
| 385 | +! | +
+ teal.transform::data_extract_ui(+ |
+
| 386 | +! | +
+ id = ns("color"),
+ |
+
| 387 | +! | +
+ label = "Outline color by variable",+ |
+
| 388 | +! | +
+ data_extract_spec = args$color,+ |
+
| 389 | +! | +
+ is_single_dataset = is_single_dataset_value+ |
+
| 390 | ++ |
+ ),+ |
+
| 391 | +! | +
+ teal.transform::data_extract_ui(+ |
+
| 392 | +! | +
+ id = ns("fill"),
+ |
+
| 393 | +! | +
+ label = "Fill color by variable",+ |
+
| 394 | +! | +
+ data_extract_spec = args$fill,+ |
+
| 395 | +! | +
+ is_single_dataset = is_single_dataset_value+ |
+
| 396 | ++ |
+ ),+ |
+
| 397 | +! | +
+ div(+ |
+
| 398 | +! | +
+ id = ns("size_settings"),
+ |
+
| 399 | +! | +
+ teal.transform::data_extract_ui(+ |
+
| 400 | +! | +
+ id = ns("size"),
+ |
+
| 401 | +! | +
+ label = "Size of points by variable (only if x and y are numeric)",+ |
+
| 402 | +! | +
+ data_extract_spec = args$size,+ |
+
| 403 | +! | +
+ is_single_dataset = is_single_dataset_value+ |
+
| 404 | ++ |
+ )+ |
+
| 405 | ++ |
+ )+ |
+
| 406 | ++ |
+ )+ |
+
| 407 | ++ |
+ )+ |
+
| 408 | ++ |
+ )+ |
+
| 409 | ++ |
+ },+ |
+
| 410 | +! | +
+ teal.widgets::panel_group(+ |
+
| 411 | +! | +
+ teal.widgets::panel_item(+ |
+
| 412 | +! | +
+ title = "Plot settings",+ |
+
| 413 | +! | +
+ checkboxInput(ns("rotate_xaxis_labels"), "Rotate X axis labels", value = args$rotate_xaxis_labels),
+ |
+
| 414 | +! | +
+ checkboxInput(ns("swap_axes"), "Swap axes", value = args$swap_axes),
+ |
+
| 415 | +! | +
+ selectInput(+ |
+
| 416 | +! | +
+ inputId = ns("ggtheme"),
+ |
+
| 417 | +! | +
+ label = "Theme (by ggplot):",+ |
+
| 418 | +! | +
+ choices = ggplot_themes,+ |
+
| 419 | +! | +
+ selected = args$ggtheme,+ |
+
| 420 | +! | +
+ multiple = FALSE+ |
+
| 421 | ++ |
+ ),+ |
+
| 422 | +! | +
+ sliderInput(+ |
+
| 423 | +! | +
+ ns("alpha"), "Opacity Scatterplot:",
+ |
+
| 424 | +! | +
+ min = 0, max = 1,+ |
+
| 425 | +! | +
+ step = .05, value = .5, ticks = FALSE+ |
+
| 426 | ++ |
+ ),+ |
+
| 427 | +! | +
+ sliderInput(+ |
+
| 428 | +! | +
+ ns("fixed_size"), "Scatterplot point size:",
+ |
+
| 429 | +! | +
+ min = 1, max = 8,+ |
+
| 430 | +! | +
+ step = 1, value = 2, ticks = FALSE+ |
+
| 431 | ++ |
+ ),+ |
+
| 432 | +! | +
+ checkboxInput(ns("add_lines"), "Add lines"),
+ |
+
| 433 | ++ |
+ )+ |
+
| 434 | ++ |
+ )+ |
+
| 435 | ++ |
+ ),+ |
+
| 436 | +! | +
+ forms = tagList(+ |
+
| 437 | +! | +
+ teal.widgets::verbatim_popup_ui(ns("warning"), button_label = "Show Warnings"),
+ |
+
| 438 | +! | +
+ teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code")
+ |
+
| 439 | ++ |
+ ),+ |
+
| 440 | +! | +
+ pre_output = args$pre_output,+ |
+
| 441 | +! | +
+ post_output = args$post_output+ |
+
| 442 | ++ |
+ )+ |
+
| 443 | ++ |
+ }+ |
+
| 444 | ++ | + + | +
| 445 | ++ |
+ # Server function for the bivariate module+ |
+
| 446 | ++ |
+ srv_g_bivariate <- function(id,+ |
+
| 447 | ++ |
+ data,+ |
+
| 448 | ++ |
+ reporter,+ |
+
| 449 | ++ |
+ filter_panel_api,+ |
+
| 450 | ++ |
+ x,+ |
+
| 451 | ++ |
+ y,+ |
+
| 452 | ++ |
+ row_facet,+ |
+
| 453 | ++ |
+ col_facet,+ |
+
| 454 | ++ |
+ color_settings = FALSE,+ |
+
| 455 | ++ |
+ color,+ |
+
| 456 | ++ |
+ fill,+ |
+
| 457 | ++ |
+ size,+ |
+
| 458 | ++ |
+ plot_height,+ |
+
| 459 | ++ |
+ plot_width,+ |
+
| 460 | ++ |
+ ggplot2_args) {
+ |
+
| 461 | +! | +
+ with_reporter <- !missing(reporter) && inherits(reporter, "Reporter")+ |
+
| 462 | +! | +
+ with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI")+ |
+
| 463 | +! | +
+ checkmate::assert_class(data, "reactive")+ |
+
| 464 | +! | +
+ checkmate::assert_class(isolate(data()), "teal_data")+ |
+
| 465 | +! | +
+ moduleServer(id, function(input, output, session) {
+ |
+
| 466 | +! | +
+ data_extract <- list(+ |
+
| 467 | +! | +
+ x = x, y = y, row_facet = row_facet, col_facet = col_facet,+ |
+
| 468 | +! | +
+ color = color, fill = fill, size = size+ |
+
| 469 | ++ |
+ )+ |
+
| 470 | ++ | + + | +
| 471 | +! | +
+ rule_var <- function(other) {
+ |
+
| 472 | +! | +
+ function(value) {
+ |
+
| 473 | +! | +
+ othervalue <- selector_list()[[other]]()$select+ |
+
| 474 | +! | +
+ if (length(value) == 0L && length(othervalue) == 0L) {
+ |
+
| 475 | +! | +
+ "Please select at least one of x-variable or y-variable"+ |
+
| 476 | ++ |
+ }+ |
+
| 477 | ++ |
+ }+ |
+
| 478 | ++ |
+ }+ |
+
| 479 | +! | +
+ rule_diff <- function(other) {
+ |
+
| 480 | +! | +
+ function(value) {
+ |
+
| 481 | +! | +
+ othervalue <- selector_list()[[other]]()[["select"]]+ |
+
| 482 | +! | +
+ if (!is.null(othervalue)) {
+ |
+
| 483 | +! | +
+ if (identical(value, othervalue)) {
+ |
+
| 484 | +! | +
+ "Row and column facetting variables must be different."+ |
+
| 485 | ++ |
+ }+ |
+
| 486 | ++ |
+ }+ |
+
| 487 | ++ |
+ }+ |
+
| 488 | ++ |
+ }+ |
+
| 489 | ++ | + + | +
| 490 | +! | +
+ selector_list <- teal.transform::data_extract_multiple_srv(+ |
+
| 491 | +! | +
+ data_extract = data_extract,+ |
+
| 492 | +! | +
+ datasets = data,+ |
+
| 493 | +! | +
+ select_validation_rule = list(+ |
+
| 494 | +! | +
+ x = rule_var("y"),
+ |
+
| 495 | +! | +
+ y = rule_var("x"),
+ |
+
| 496 | +! | +
+ row_facet = shinyvalidate::compose_rules(+ |
+
| 497 | +! | +
+ shinyvalidate::sv_optional(),+ |
+
| 498 | +! | +
+ rule_diff("col_facet")
+ |
+
| 499 | ++ |
+ ),+ |
+
| 500 | +! | +
+ col_facet = shinyvalidate::compose_rules(+ |
+
| 501 | +! | +
+ shinyvalidate::sv_optional(),+ |
+
| 502 | +! | +
+ rule_diff("row_facet")
+ |
+
| 503 | ++ |
+ )+ |
+
| 504 | ++ |
+ )+ |
+
| 505 | ++ |
+ )+ |
+
| 506 | ++ | + + | +
| 507 | +! | +
+ iv_r <- reactive({
+ |
+
| 508 | +! | +
+ iv_facet <- shinyvalidate::InputValidator$new()+ |
+
| 509 | +! | +
+ iv_child <- teal.transform::compose_and_enable_validators(iv_facet, selector_list,+ |
+
| 510 | +! | +
+ validator_names = c("row_facet", "col_facet")
+ |
+
| 511 | ++ |
+ )+ |
+
| 512 | +! | +
+ iv_child$condition(~ isTRUE(input$facetting))+ |
+
| 513 | ++ | + + | +
| 514 | +! | +
+ iv <- shinyvalidate::InputValidator$new()+ |
+
| 515 | +! | +
+ iv$add_validator(iv_child)+ |
+
| 516 | +! | +
+ teal.transform::compose_and_enable_validators(iv, selector_list, validator_names = c("x", "y"))
+ |
+
| 517 | ++ |
+ })+ |
+
| 518 | ++ | + + | +
| 519 | +! | +
+ anl_merged_input <- teal.transform::merge_expression_srv(+ |
+
| 520 | +! | +
+ selector_list = selector_list,+ |
+
| 521 | +! | +
+ datasets = data+ |
+
| 522 | ++ |
+ )+ |
+
| 523 | ++ | + + | +
| 524 | +! | +
+ anl_merged_q <- reactive({
+ |
+
| 525 | +! | +
+ req(anl_merged_input())+ |
+
| 526 | +! | +
+ data() %>%+ |
+
| 527 | +! | +
+ teal.code::eval_code(as.expression(anl_merged_input()$expr))+ |
+
| 528 | ++ |
+ })+ |
+
| 529 | ++ | + + | +
| 530 | +! | +
+ merged <- list(+ |
+
| 531 | +! | +
+ anl_input_r = anl_merged_input,+ |
+
| 532 | +! | +
+ anl_q_r = anl_merged_q+ |
+
| 533 | ++ |
+ )+ |
+
| 534 | ++ | + + | +
| 535 | +! | +
+ output_q <- reactive({
+ |
+
| 536 | +! | +
+ teal::validate_inputs(iv_r())+ |
+
| 537 | ++ | + + | +
| 538 | +! | +
+ ANL <- merged$anl_q_r()[["ANL"]]+ |
+
| 539 | +! | +
+ teal::validate_has_data(ANL, 3)+ |
+
| 540 | ++ | + + | +
| 541 | +! | +
+ x_col_vec <- as.vector(merged$anl_input_r()$columns_source$x)+ |
+
| 542 | +! | +
+ x_name <- `if`(is.null(x_col_vec), character(0), x_col_vec)+ |
+
| 543 | +! | +
+ y_col_vec <- as.vector(merged$anl_input_r()$columns_source$y)+ |
+
| 544 | +! | +
+ y_name <- `if`(is.null(y_col_vec), character(0), y_col_vec)+ |
+
| 545 | ++ | + + | +
| 546 | +! | +
+ row_facet_name <- as.vector(merged$anl_input_r()$columns_source$row_facet)+ |
+
| 547 | +! | +
+ col_facet_name <- as.vector(merged$anl_input_r()$columns_source$col_facet)+ |
+
| 548 | +! | +
+ color_name <- if ("color" %in% names(merged$anl_input_r()$columns_source)) {
+ |
+
| 549 | +! | +
+ as.vector(merged$anl_input_r()$columns_source$color)+ |
+
| 550 | ++ |
+ } else {
+ |
+
| 551 | +! | +
+ character(0)+ |
+
| 552 | ++ |
+ }+ |
+
| 553 | +! | +
+ fill_name <- if ("fill" %in% names(merged$anl_input_r()$columns_source)) {
+ |
+
| 554 | +! | +
+ as.vector(merged$anl_input_r()$columns_source$fill)+ |
+
| 555 | ++ |
+ } else {
+ |
+
| 556 | +! | +
+ character(0)+ |
+
| 557 | ++ |
+ }+ |
+
| 558 | +! | +
+ size_name <- if ("size" %in% names(merged$anl_input_r()$columns_source)) {
+ |
+
| 559 | +! | +
+ as.vector(merged$anl_input_r()$columns_source$size)+ |
+
| 560 | ++ |
+ } else {
+ |
+
| 561 | +! | +
+ character(0)+ |
+
| 562 | ++ |
+ }+ |
+
| 563 | ++ | + + | +
| 564 | +! | +
+ use_density <- input$use_density == "density"+ |
+
| 565 | +! | +
+ free_x_scales <- input$free_x_scales+ |
+
| 566 | +! | +
+ free_y_scales <- input$free_y_scales+ |
+
| 567 | +! | +
+ ggtheme <- input$ggtheme+ |
+
| 568 | +! | +
+ rotate_xaxis_labels <- input$rotate_xaxis_labels+ |
+
| 569 | +! | +
+ swap_axes <- input$swap_axes+ |
+
| 570 | ++ | + + | +
| 571 | +! | +
+ is_scatterplot <- all(vapply(ANL[c(x_name, y_name)], is.numeric, logical(1))) &&+ |
+
| 572 | +! | +
+ length(x_name) > 0 && length(y_name) > 0+ |
+
| 573 | ++ | + + | +
| 574 | +! | +
+ if (is_scatterplot) {
+ |
+
| 575 | +! | +
+ shinyjs::show("alpha")
+ |
+
| 576 | +! | +
+ alpha <- input$alpha+ |
+
| 577 | +! | +
+ shinyjs::show("add_lines")
+ |
+
| 578 | ++ | + + | +
| 579 | +! | +
+ if (color_settings && input$coloring) {
+ |
+
| 580 | +! | +
+ shinyjs::hide("fixed_size")
+ |
+
| 581 | +! | +
+ shinyjs::show("size_settings")
+ |
+
| 582 | +! | +
+ size <- NULL+ |
+
| 583 | ++ |
+ } else {
+ |
+
| 584 | +! | +
+ shinyjs::show("fixed_size")
+ |
+
| 585 | +! | +
+ size <- input$fixed_size+ |
+
| 586 | ++ |
+ }+ |
+
| 587 | ++ |
+ } else {
+ |
+
| 588 | +! | +
+ shinyjs::hide("add_lines")
+ |
+
| 589 | +! | +
+ updateCheckboxInput(session, "add_lines", value = FALSE)+ |
+
| 590 | +! | +
+ shinyjs::hide("alpha")
+ |
+
| 591 | +! | +
+ shinyjs::hide("fixed_size")
+ |
+
| 592 | +! | +
+ shinyjs::hide("size_settings")
+ |
+
| 593 | +! | +
+ alpha <- 1+ |
+
| 594 | +! | +
+ size <- NULL+ |
+
| 595 | ++ |
+ }+ |
+
| 596 | ++ | + + | +
| 597 | +! | +
+ teal::validate_has_data(ANL[, c(x_name, y_name), drop = FALSE], 3, complete = TRUE, allow_inf = FALSE)+ |
+
| 598 | ++ | + + | +
| 599 | +! | +
+ cl <- bivariate_plot_call(+ |
+
| 600 | +! | +
+ data_name = "ANL",+ |
+
| 601 | +! | +
+ x = x_name,+ |
+
| 602 | +! | +
+ y = y_name,+ |
+
| 603 | +! | +
+ x_class = ifelse(!identical(x_name, character(0)), class(ANL[[x_name]]), "NULL"),+ |
+
| 604 | +! | +
+ y_class = ifelse(!identical(y_name, character(0)), class(ANL[[y_name]]), "NULL"),+ |
+
| 605 | +! | +
+ x_label = varname_w_label(x_name, ANL),+ |
+
| 606 | +! | +
+ y_label = varname_w_label(y_name, ANL),+ |
+
| 607 | +! | +
+ freq = !use_density,+ |
+
| 608 | +! | +
+ theme = ggtheme,+ |
+
| 609 | +! | +
+ rotate_xaxis_labels = rotate_xaxis_labels,+ |
+
| 610 | +! | +
+ swap_axes = swap_axes,+ |
+
| 611 | +! | +
+ alpha = alpha,+ |
+
| 612 | +! | +
+ size = size,+ |
+
| 613 | +! | +
+ ggplot2_args = ggplot2_args+ |
+
| 614 | ++ |
+ )+ |
+
| 615 | ++ | + + | +
| 616 | +! | +
+ facetting <- (isTRUE(input$facetting) && (!is.null(row_facet_name) || !is.null(col_facet_name)))+ |
+
| 617 | ++ | + + | +
| 618 | +! | +
+ if (facetting) {
+ |
+
| 619 | +! | +
+ facet_cl <- facet_ggplot_call(row_facet_name, col_facet_name, free_x_scales, free_y_scales)+ |
+
| 620 | ++ | + + | +
| 621 | +! | +
+ if (!is.null(facet_cl)) {
+ |
+
| 622 | +! | +
+ cl <- call("+", cl, facet_cl)
+ |
+
| 623 | ++ |
+ }+ |
+
| 624 | ++ |
+ }+ |
+
| 625 | ++ | + + | +
| 626 | +! | +
+ if (input$add_lines) {
+ |
+
| 627 | +! | +
+ cl <- call("+", cl, quote(geom_line(size = 1)))
+ |
+
| 628 | ++ |
+ }+ |
+
| 629 | ++ | + + | +
| 630 | +! | +
+ coloring_cl <- NULL+ |
+
| 631 | +! | +
+ if (color_settings) {
+ |
+
| 632 | +! | +
+ if (input$coloring) {
+ |
+
| 633 | +! | +
+ coloring_cl <- coloring_ggplot_call(+ |
+
| 634 | +! | +
+ colour = color_name,+ |
+
| 635 | +! | +
+ fill = fill_name,+ |
+
| 636 | +! | +
+ size = size_name,+ |
+
| 637 | +! | +
+ is_point = any(grepl("geom_point", cl %>% deparse()))
+ |
+
| 638 | ++ |
+ )+ |
+
| 639 | +! | +
+ legend_lbls <- substitute(+ |
+
| 640 | +! | +
+ expr = labs(color = color_name, fill = fill_name, size = size_name),+ |
+
| 641 | +! | +
+ env = list(+ |
+
| 642 | +! | +
+ color_name = varname_w_label(color_name, ANL),+ |
+
| 643 | +! | +
+ fill_name = varname_w_label(fill_name, ANL),+ |
+
| 644 | +! | +
+ size_name = varname_w_label(size_name, ANL)+ |
+
| 645 | ++ |
+ )+ |
+
| 646 | ++ |
+ )+ |
+
| 647 | ++ |
+ }+ |
+
| 648 | +! | +
+ if (!is.null(coloring_cl)) {
+ |
+
| 649 | +! | +
+ cl <- call("+", call("+", cl, coloring_cl), legend_lbls)
+ |
+
| 650 | ++ |
+ }+ |
+
| 651 | ++ |
+ }+ |
+
| 652 | ++ | + + | +
| 653 | ++ |
+ # Add labels to facets+ |
+
| 654 | +! | +
+ nulled_row_facet_name <- varname_w_label(row_facet_name, ANL)+ |
+
| 655 | +! | +
+ nulled_col_facet_name <- varname_w_label(col_facet_name, ANL)+ |
+
| 656 | +! | +
+ without_facet <- (is.null(nulled_row_facet_name) && is.null(nulled_col_facet_name)) || !facetting+ |
+
| 657 | ++ | + + | +
| 658 | +! | +
+ print_call <- if (without_facet) {
+ |
+
| 659 | +! | +
+ quote(print(p))+ |
+
| 660 | ++ |
+ } else {
+ |
+
| 661 | +! | +
+ substitute(+ |
+
| 662 | +! | +
+ expr = {
+ |
+
| 663 | ++ |
+ # Add facetting labels+ |
+
| 664 | ++ |
+ # optional: grid.newpage() # nolint: commented_code.+ |
+
| 665 | +! | +
+ p <- add_facet_labels(p, xfacet_label = nulled_col_facet_name, yfacet_label = nulled_row_facet_name)+ |
+
| 666 | +! | +
+ grid::grid.newpage()+ |
+
| 667 | +! | +
+ grid::grid.draw(p)+ |
+
| 668 | ++ |
+ },+ |
+
| 669 | +! | +
+ env = list(nulled_col_facet_name = nulled_col_facet_name, nulled_row_facet_name = nulled_row_facet_name)+ |
+
| 670 | ++ |
+ )+ |
+
| 671 | ++ |
+ }+ |
+
| 672 | ++ | + + | +
| 673 | +! | +
+ teal.code::eval_code(merged$anl_q_r(), substitute(expr = p <- cl, env = list(cl = cl))) %>%+ |
+
| 674 | +! | +
+ teal.code::eval_code(print_call)+ |
+
| 675 | ++ |
+ })+ |
+
| 676 | ++ | + + | +
| 677 | +! | +
+ plot_r <- shiny::reactive({
+ |
+
| 678 | +! | +
+ output_q()[["p"]]+ |
+
| 679 | ++ |
+ })+ |
+
| 680 | ++ | + + | +
| 681 | +! | +
+ pws <- teal.widgets::plot_with_settings_srv(+ |
+
| 682 | +! | +
+ id = "myplot",+ |
+
| 683 | +! | +
+ plot_r = plot_r,+ |
+
| 684 | +! | +
+ height = plot_height,+ |
+
| 685 | +! | +
+ width = plot_width+ |
+
| 686 | ++ |
+ )+ |
+
| 687 | ++ | + + | +
| 688 | +! | +
+ teal.widgets::verbatim_popup_srv(+ |
+
| 689 | +! | +
+ id = "warning",+ |
+
| 690 | +! | +
+ verbatim_content = reactive(teal.code::get_warnings(output_q())),+ |
+
| 691 | +! | +
+ title = "Warning",+ |
+
| 692 | +! | +
+ disabled = reactive(is.null(teal.code::get_warnings(output_q())))+ |
+
| 693 | ++ |
+ )+ |
+
| 694 | ++ | + + | +
| 695 | +! | +
+ teal.widgets::verbatim_popup_srv(+ |
+
| 696 | +! | +
+ id = "rcode",+ |
+
| 697 | +! | +
+ verbatim_content = reactive(teal.code::get_code(output_q())),+ |
+
| 698 | +! | +
+ title = "Bivariate Plot"+ |
+
| 699 | ++ |
+ )+ |
+
| 700 | ++ | + + | +
| 701 | ++ |
+ ### REPORTER+ |
+
| 702 | +! | +
+ if (with_reporter) {
+ |
+
| 703 | +! | +
+ card_fun <- function(comment, label) {
+ |
+
| 704 | +! | +
+ card <- teal::report_card_template(+ |
+
| 705 | +! | +
+ title = "Bivariate Plot",+ |
+
| 706 | +! | +
+ label = label,+ |
+
| 707 | +! | +
+ with_filter = with_filter,+ |
+
| 708 | +! | +
+ filter_panel_api = filter_panel_api+ |
+
| 709 | ++ |
+ )+ |
+
| 710 | +! | +
+ card$append_text("Plot", "header3")
+ |
+
| 711 | +! | +
+ card$append_plot(plot_r(), dim = pws$dim())+ |
+
| 712 | +! | +
+ if (!comment == "") {
+ |
+
| 713 | +! | +
+ card$append_text("Comment", "header3")
+ |
+
| 714 | +! | +
+ card$append_text(comment)+ |
+
| 715 | ++ |
+ }+ |
+
| 716 | +! | +
+ card$append_src(teal.code::get_code(output_q()))+ |
+
| 717 | +! | +
+ card+ |
+
| 718 | ++ |
+ }+ |
+
| 719 | +! | +
+ teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
+ |
+
| 720 | ++ |
+ }+ |
+
| 721 | ++ |
+ ###+ |
+
| 722 | ++ |
+ })+ |
+
| 723 | ++ |
+ }+ |
+
| 724 | ++ | + + | +
| 725 | ++ |
+ # Get Substituted ggplot call+ |
+
| 726 | ++ |
+ bivariate_plot_call <- function(data_name,+ |
+
| 727 | ++ |
+ x = character(0),+ |
+
| 728 | ++ |
+ y = character(0),+ |
+
| 729 | ++ |
+ x_class = "NULL",+ |
+
| 730 | ++ |
+ y_class = "NULL",+ |
+
| 731 | ++ |
+ x_label = NULL,+ |
+
| 732 | ++ |
+ y_label = NULL,+ |
+
| 733 | ++ |
+ freq = TRUE,+ |
+
| 734 | ++ |
+ theme = "gray",+ |
+
| 735 | ++ |
+ rotate_xaxis_labels = FALSE,+ |
+
| 736 | ++ |
+ swap_axes = FALSE,+ |
+
| 737 | ++ |
+ alpha = double(0),+ |
+
| 738 | ++ |
+ size = 2,+ |
+
| 739 | ++ |
+ ggplot2_args = teal.widgets::ggplot2_args()) {
+ |
+
| 740 | +! | +
+ supported_types <- c("NULL", "numeric", "integer", "factor", "character", "logical", "ordered")
+ |
+
| 741 | +! | +
+ validate(need(x_class %in% supported_types, paste0("Data type '", x_class, "' is not supported.")))
+ |
+
| 742 | +! | +
+ validate(need(y_class %in% supported_types, paste0("Data type '", y_class, "' is not supported.")))
+ |
+
| 743 | ++ | + + | +
| 744 | ++ | + + | +
| 745 | +! | +
+ if (identical(x, character(0))) {
+ |
+
| 746 | +! | +
+ x <- x_label <- "-"+ |
+
| 747 | ++ |
+ } else {
+ |
+
| 748 | +! | +
+ x <- if (is.call(x)) x else as.name(x)+ |
+
| 749 | ++ |
+ }+ |
+
| 750 | +! | +
+ if (identical(y, character(0))) {
+ |
+
| 751 | +! | +
+ y <- y_label <- "-"+ |
+
| 752 | ++ |
+ } else {
+ |
+
| 753 | +! | +
+ y <- if (is.call(y)) y else as.name(y)+ |
+
| 754 | ++ |
+ }+ |
+
| 755 | ++ | + + | +
| 756 | +! | +
+ cl <- bivariate_ggplot_call(+ |
+
| 757 | +! | +
+ x_class = x_class,+ |
+
| 758 | +! | +
+ y_class = y_class,+ |
+
| 759 | +! | +
+ freq = freq,+ |
+
| 760 | +! | +
+ theme = theme,+ |
+
| 761 | +! | +
+ rotate_xaxis_labels = rotate_xaxis_labels,+ |
+
| 762 | +! | +
+ swap_axes = swap_axes,+ |
+
| 763 | +! | +
+ alpha = alpha,+ |
+
| 764 | +! | +
+ size = size,+ |
+
| 765 | +! | +
+ ggplot2_args = ggplot2_args,+ |
+
| 766 | +! | +
+ x = x,+ |
+
| 767 | +! | +
+ y = y,+ |
+
| 768 | +! | +
+ xlab = x_label,+ |
+
| 769 | +! | +
+ ylab = y_label,+ |
+
| 770 | +! | +
+ data_name = data_name+ |
+
| 771 | ++ |
+ )+ |
+
| 772 | ++ |
+ }+ |
+
| 773 | ++ | + + | +
| 774 | ++ |
+ # Create ggplot part of plot call+ |
+
| 775 | ++ |
+ # Due to the type of the x and y variable the plot type is chosen+ |
+
| 776 | ++ |
+ bivariate_ggplot_call <- function(x_class,+ |
+
| 777 | ++ |
+ y_class,+ |
+
| 778 | ++ |
+ freq = TRUE,+ |
+
| 779 | ++ |
+ theme = "gray",+ |
+
| 780 | ++ |
+ rotate_xaxis_labels = FALSE,+ |
+
| 781 | ++ |
+ swap_axes = FALSE,+ |
+
| 782 | ++ |
+ size = double(0),+ |
+
| 783 | ++ |
+ alpha = double(0),+ |
+
| 784 | ++ |
+ x = NULL,+ |
+
| 785 | ++ |
+ y = NULL,+ |
+
| 786 | ++ |
+ xlab = "-",+ |
+
| 787 | ++ |
+ ylab = "-",+ |
+
| 788 | ++ |
+ data_name = "ANL",+ |
+
| 789 | ++ |
+ ggplot2_args = teal.widgets::ggplot2_args()) {
+ |
+
| 790 | +42x | +
+ x_class <- switch(x_class,+ |
+
| 791 | +42x | +
+ "character" = ,+ |
+
| 792 | +42x | +
+ "ordered" = ,+ |
+
| 793 | +42x | +
+ "logical" = ,+ |
+
| 794 | +42x | +
+ "factor" = "factor",+ |
+
| 795 | +42x | +
+ "integer" = ,+ |
+
| 796 | +42x | +
+ "numeric" = "numeric",+ |
+
| 797 | +42x | +
+ "NULL" = "NULL",+ |
+
| 798 | +42x | +
+ stop("unsupported x_class: ", x_class)
+ |
+
| 799 | ++ |
+ )+ |
+
| 800 | +42x | +
+ y_class <- switch(y_class,+ |
+
| 801 | +42x | +
+ "character" = ,+ |
+
| 802 | +42x | +
+ "ordered" = ,+ |
+
| 803 | +42x | +
+ "logical" = ,+ |
+
| 804 | +42x | +
+ "factor" = "factor",+ |
+
| 805 | +42x | +
+ "integer" = ,+ |
+
| 806 | +42x | +
+ "numeric" = "numeric",+ |
+
| 807 | +42x | +
+ "NULL" = "NULL",+ |
+
| 808 | +42x | +
+ stop("unsupported y_class: ", y_class)
+ |
+
| 809 | ++ |
+ )+ |
+
| 810 | ++ | + + | +
| 811 | +42x | +
+ if (all(c(x_class, y_class) == "NULL")) {
+ |
+
| 812 | +! | +
+ stop("either x or y is required")
+ |
+
| 813 | ++ |
+ }+ |
+
| 814 | ++ | + + | +
| 815 | +42x | +
+ reduce_plot_call <- function(...) {
+ |
+
| 816 | +104x | +
+ args <- Filter(Negate(is.null), list(...))+ |
+
| 817 | +104x | +
+ Reduce(function(x, y) call("+", x, y), args)
+ |
+
| 818 | ++ |
+ }+ |
+
| 819 | ++ | + + | +
| 820 | +42x | +
+ plot_call <- substitute(ggplot(data_name), env = list(data_name = as.name(data_name)))+ |
+
| 821 | ++ | + + | +
| 822 | ++ |
+ # Single data plots+ |
+
| 823 | +42x | +
+ if (x_class == "numeric" && y_class == "NULL") {
+ |
+
| 824 | +6x | +
+ plot_call <- reduce_plot_call(plot_call, substitute(aes(x = xval), env = list(xval = x)))+ |
+
| 825 | ++ | + + | +
| 826 | +6x | +
+ if (freq) {
+ |
+
| 827 | +4x | +
+ plot_call <- reduce_plot_call(+ |
+
| 828 | +4x | +
+ plot_call,+ |
+
| 829 | +4x | +
+ quote(geom_histogram(bins = 30)),+ |
+
| 830 | +4x | +
+ quote(ylab("Frequency"))
+ |
+
| 831 | ++ |
+ )+ |
+
| 832 | ++ |
+ } else {
+ |
+
| 833 | +2x | +
+ plot_call <- reduce_plot_call(+ |
+
| 834 | +2x | +
+ plot_call,+ |
+
| 835 | +2x | +
+ quote(geom_histogram(bins = 30, aes(y = after_stat(density)))),+ |
+
| 836 | +2x | +
+ quote(geom_density(aes(y = after_stat(density)))),+ |
+
| 837 | +2x | +
+ quote(ylab("Density"))
+ |
+
| 838 | ++ |
+ )+ |
+
| 839 | ++ |
+ }+ |
+
| 840 | +36x | +
+ } else if (x_class == "NULL" && y_class == "numeric") {
+ |
+
| 841 | +6x | +
+ plot_call <- reduce_plot_call(plot_call, substitute(aes(x = yval), env = list(yval = y)))+ |
+
| 842 | ++ | + + | +
| 843 | +6x | +
+ if (freq) {
+ |
+
| 844 | +4x | +
+ plot_call <- reduce_plot_call(+ |
+
| 845 | +4x | +
+ plot_call,+ |
+
| 846 | +4x | +
+ quote(geom_histogram(bins = 30)),+ |
+
| 847 | +4x | +
+ quote(ylab("Frequency"))
+ |
+
| 848 | ++ |
+ )+ |
+
| 849 | ++ |
+ } else {
+ |
+
| 850 | +2x | +
+ plot_call <- reduce_plot_call(+ |
+
| 851 | +2x | +
+ plot_call,+ |
+
| 852 | +2x | +
+ quote(geom_histogram(bins = 30, aes(y = after_stat(density)))),+ |
+
| 853 | +2x | +
+ quote(geom_density(aes(y = after_stat(density)))),+ |
+
| 854 | +2x | +
+ quote(ylab("Density"))
+ |
+
| 855 | ++ |
+ )+ |
+
| 856 | ++ |
+ }+ |
+
| 857 | +30x | +
+ } else if (x_class == "factor" && y_class == "NULL") {
+ |
+
| 858 | +4x | +
+ plot_call <- reduce_plot_call(plot_call, substitute(aes(x = xval), env = list(xval = x)))+ |
+
| 859 | ++ | + + | +
| 860 | +4x | +
+ if (freq) {
+ |
+
| 861 | +2x | +
+ plot_call <- reduce_plot_call(+ |
+
| 862 | +2x | +
+ plot_call,+ |
+
| 863 | +2x | +
+ quote(geom_bar()),+ |
+
| 864 | +2x | +
+ quote(ylab("Frequency"))
+ |
+
| 865 | ++ |
+ )+ |
+
| 866 | ++ |
+ } else {
+ |
+
| 867 | +2x | +
+ plot_call <- reduce_plot_call(+ |
+
| 868 | +2x | +
+ plot_call,+ |
+
| 869 | +2x | +
+ quote(geom_bar(aes(y = after_stat(prop), group = 1))),+ |
+
| 870 | +2x | +
+ quote(ylab("Fraction"))
+ |
+
| 871 | ++ |
+ )+ |
+
| 872 | ++ |
+ }+ |
+
| 873 | +26x | +
+ } else if (x_class == "NULL" && y_class == "factor") {
+ |
+
| 874 | +4x | +
+ plot_call <- reduce_plot_call(plot_call, substitute(aes(x = yval), env = list(yval = y)))+ |
+
| 875 | ++ | + + | +
| 876 | +4x | +
+ if (freq) {
+ |
+
| 877 | +2x | +
+ plot_call <- reduce_plot_call(+ |
+
| 878 | +2x | +
+ plot_call,+ |
+
| 879 | +2x | +
+ quote(geom_bar()),+ |
+
| 880 | +2x | +
+ quote(ylab("Frequency"))
+ |
+
| 881 | ++ |
+ )+ |
+
| 882 | ++ |
+ } else {
+ |
+
| 883 | +2x | +
+ plot_call <- reduce_plot_call(+ |
+
| 884 | +2x | +
+ plot_call,+ |
+
| 885 | +2x | +
+ quote(geom_bar(aes(y = after_stat(prop), group = 1))),+ |
+
| 886 | +2x | +
+ quote(ylab("Fraction"))
+ |
+
| 887 | ++ |
+ )+ |
+
| 888 | ++ |
+ }+ |
+
| 889 | ++ |
+ # Numeric Plots+ |
+
| 890 | +22x | +
+ } else if (x_class == "numeric" && y_class == "numeric") {
+ |
+
| 891 | +2x | +
+ plot_call <- reduce_plot_call(+ |
+
| 892 | +2x | +
+ plot_call,+ |
+
| 893 | +2x | +
+ substitute(aes(x = xval, y = yval), env = list(xval = x, yval = y)),+ |
+
| 894 | ++ |
+ # pch = 21 for consistent coloring behaviour b/w all geoms (outline and fill properties)+ |
+
| 895 | +2x | +
+ `if`(+ |
+
| 896 | +2x | +
+ !is.null(size),+ |
+
| 897 | +2x | +
+ substitute(+ |
+
| 898 | +2x | +
+ geom_point(alpha = alphaval, size = sizeval, pch = 21),+ |
+
| 899 | +2x | +
+ env = list(alphaval = alpha, sizeval = size)+ |
+
| 900 | ++ |
+ ),+ |
+
| 901 | +2x | +
+ substitute(+ |
+
| 902 | +2x | +
+ geom_point(alpha = alphaval, pch = 21),+ |
+
| 903 | +2x | +
+ env = list(alphaval = alpha)+ |
+
| 904 | ++ |
+ )+ |
+
| 905 | ++ |
+ )+ |
+
| 906 | ++ |
+ )+ |
+
| 907 | +20x | +
+ } else if ((x_class == "numeric" && y_class == "factor") || (x_class == "factor" && y_class == "numeric")) {
+ |
+
| 908 | +6x | +
+ plot_call <- reduce_plot_call(+ |
+
| 909 | +6x | +
+ plot_call,+ |
+
| 910 | +6x | +
+ substitute(aes(x = xval, y = yval), env = list(xval = x, yval = y)),+ |
+
| 911 | +6x | +
+ quote(geom_boxplot())+ |
+
| 912 | ++ |
+ )+ |
+
| 913 | ++ |
+ # Factor and character plots+ |
+
| 914 | +14x | +
+ } else if (x_class == "factor" && y_class == "factor") {
+ |
+
| 915 | +14x | +
+ plot_call <- reduce_plot_call(+ |
+
| 916 | +14x | +
+ plot_call,+ |
+
| 917 | +14x | +
+ substitute(+ |
+
| 918 | +14x | +
+ ggmosaic::geom_mosaic(aes(x = ggmosaic::product(xval), fill = yval), na.rm = TRUE),+ |
+
| 919 | +14x | +
+ env = list(xval = x, yval = y)+ |
+
| 920 | ++ |
+ )+ |
+
| 921 | ++ |
+ )+ |
+
| 922 | ++ |
+ } else {
+ |
+
| 923 | +! | +
+ stop("x y type combination not allowed")
+ |
+
| 924 | ++ |
+ }+ |
+
| 925 | ++ | + + | +
| 926 | +42x | +
+ labs_base <- if (x_class == "NULL") {
+ |
+
| 927 | +10x | +
+ list(x = substitute(ylab, list(ylab = ylab)))+ |
+
| 928 | +42x | +
+ } else if (y_class == "NULL") {
+ |
+
| 929 | +10x | +
+ list(x = substitute(xlab, list(xlab = xlab)))+ |
+
| 930 | ++ |
+ } else {
+ |
+
| 931 | +22x | +
+ list(+ |
+
| 932 | +22x | +
+ x = substitute(xlab, list(xlab = xlab)),+ |
+
| 933 | +22x | +
+ y = substitute(ylab, list(ylab = ylab))+ |
+
| 934 | ++ |
+ )+ |
+
| 935 | ++ |
+ }+ |
+
| 936 | ++ | + + | +
| 937 | +42x | +
+ dev_ggplot2_args <- teal.widgets::ggplot2_args(labs = labs_base)+ |
+
| 938 | ++ | + + | +
| 939 | +42x | +
+ if (rotate_xaxis_labels) {
+ |
+
| 940 | +! | +
+ dev_ggplot2_args$theme <- list(axis.text.x = quote(element_text(angle = 45, hjust = 1)))+ |
+
| 941 | ++ |
+ }+ |
+
| 942 | ++ | + + | +
| 943 | +42x | +
+ all_ggplot2_args <- teal.widgets::resolve_ggplot2_args(+ |
+
| 944 | +42x | +
+ user_plot = ggplot2_args,+ |
+
| 945 | +42x | +
+ module_plot = dev_ggplot2_args+ |
+
| 946 | ++ |
+ )+ |
+
| 947 | ++ | + + | +
| 948 | +42x | +
+ parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(all_ggplot2_args, ggtheme = theme)+ |
+
| 949 | ++ | + + | +
| 950 | +42x | +
+ plot_call <- reduce_plot_call(+ |
+
| 951 | +42x | +
+ plot_call,+ |
+
| 952 | +42x | +
+ parsed_ggplot2_args$labs,+ |
+
| 953 | +42x | +
+ parsed_ggplot2_args$ggtheme,+ |
+
| 954 | +42x | +
+ parsed_ggplot2_args$theme+ |
+
| 955 | ++ |
+ )+ |
+
| 956 | ++ | + + | +
| 957 | +42x | +
+ if (swap_axes) {
+ |
+
| 958 | +! | +
+ plot_call <- reduce_plot_call(plot_call, quote(coord_flip()))+ |
+
| 959 | ++ |
+ }+ |
+
| 960 | ++ | + + | +
| 961 | +42x | +
+ plot_call+ |
+
| 962 | ++ |
+ }+ |
+
| 963 | ++ | + + | +
| 964 | ++ |
+ # Create facet call+ |
+
| 965 | ++ |
+ facet_ggplot_call <- function(row_facet = character(0),+ |
+
| 966 | ++ |
+ col_facet = character(0),+ |
+
| 967 | ++ |
+ free_x_scales = FALSE,+ |
+
| 968 | ++ |
+ free_y_scales = FALSE) {
+ |
+
| 969 | +! | +
+ scales <- if (free_x_scales && free_y_scales) {
+ |
+
| 970 | +! | +
+ "free"+ |
+
| 971 | +! | +
+ } else if (free_x_scales) {
+ |
+
| 972 | +! | +
+ "free_x"+ |
+
| 973 | +! | +
+ } else if (free_y_scales) {
+ |
+
| 974 | +! | +
+ "free_y"+ |
+
| 975 | ++ |
+ } else {
+ |
+
| 976 | +! | +
+ "fixed"+ |
+
| 977 | ++ |
+ }+ |
+
| 978 | ++ | + + | +
| 979 | +! | +
+ if (identical(row_facet, character(0)) && identical(col_facet, character(0))) {
+ |
+
| 980 | +! | +
+ NULL+ |
+
| 981 | +! | +
+ } else if (!identical(row_facet, character(0)) && !identical(col_facet, character(0))) {
+ |
+
| 982 | +! | +
+ call(+ |
+
| 983 | +! | +
+ "facet_grid",+ |
+
| 984 | +! | +
+ rows = call_fun_dots("vars", row_facet),
+ |
+
| 985 | +! | +
+ cols = call_fun_dots("vars", col_facet),
+ |
+
| 986 | +! | +
+ scales = scales+ |
+
| 987 | ++ |
+ )+ |
+
| 988 | +! | +
+ } else if (identical(row_facet, character(0)) && !identical(col_facet, character(0))) {
+ |
+
| 989 | +! | +
+ call("facet_grid", cols = call_fun_dots("vars", col_facet), scales = scales)
+ |
+
| 990 | +! | +
+ } else if (!identical(row_facet, character(0)) && identical(col_facet, character(0))) {
+ |
+
| 991 | +! | +
+ call("facet_grid", rows = call_fun_dots("vars", row_facet), scales = scales)
+ |
+
| 992 | ++ |
+ }+ |
+
| 993 | ++ |
+ }+ |
+
| 994 | ++ | + + | +
| 995 | ++ |
+ coloring_ggplot_call <- function(colour,+ |
+
| 996 | ++ |
+ fill,+ |
+
| 997 | ++ |
+ size,+ |
+
| 998 | ++ |
+ is_point = FALSE) {
+ |
+
| 999 | ++ |
+ if (+ |
+
| 1000 | +15x | +
+ !identical(colour, character(0)) &&+ |
+
| 1001 | +15x | +
+ !identical(fill, character(0)) &&+ |
+
| 1002 | +15x | +
+ is_point &&+ |
+
| 1003 | +15x | +
+ !identical(size, character(0))+ |
+
| 1004 | ++ |
+ ) {
+ |
+
| 1005 | +1x | +
+ substitute(+ |
+
| 1006 | +1x | +
+ expr = aes(colour = colour_name, fill = fill_name, size = size_name),+ |
+
| 1007 | +1x | +
+ env = list(colour_name = as.name(colour), fill_name = as.name(fill), size_name = as.name(size))+ |
+
| 1008 | ++ |
+ )+ |
+
| 1009 | ++ |
+ } else if (+ |
+
| 1010 | +14x | +
+ identical(colour, character(0)) &&+ |
+
| 1011 | +14x | +
+ !identical(fill, character(0)) &&+ |
+
| 1012 | +14x | +
+ is_point &&+ |
+
| 1013 | +14x | +
+ identical(size, character(0))+ |
+
| 1014 | ++ |
+ ) {
+ |
+
| 1015 | +1x | +
+ substitute(expr = aes(fill = fill_name), env = list(fill_name = as.name(fill)))+ |
+
| 1016 | ++ |
+ } else if (+ |
+
| 1017 | +13x | +
+ !identical(colour, character(0)) &&+ |
+
| 1018 | +13x | +
+ !identical(fill, character(0)) &&+ |
+
| 1019 | +13x | +
+ (!is_point || identical(size, character(0)))+ |
+
| 1020 | ++ |
+ ) {
+ |
+
| 1021 | +3x | +
+ substitute(+ |
+
| 1022 | +3x | +
+ expr = aes(colour = colour_name, fill = fill_name),+ |
+
| 1023 | +3x | +
+ env = list(colour_name = as.name(colour), fill_name = as.name(fill))+ |
+
| 1024 | ++ |
+ )+ |
+
| 1025 | ++ |
+ } else if (+ |
+
| 1026 | +10x | +
+ !identical(colour, character(0)) &&+ |
+
| 1027 | +10x | +
+ identical(fill, character(0)) &&+ |
+
| 1028 | +10x | +
+ (!is_point || identical(size, character(0)))+ |
+
| 1029 | ++ |
+ ) {
+ |
+
| 1030 | +1x | +
+ substitute(expr = aes(colour = colour_name), env = list(colour_name = as.name(colour)))+ |
+
| 1031 | ++ |
+ } else if (+ |
+
| 1032 | +9x | +
+ identical(colour, character(0)) &&+ |
+
| 1033 | +9x | +
+ !identical(fill, character(0)) &&+ |
+
| 1034 | +9x | +
+ (!is_point || identical(size, character(0)))+ |
+
| 1035 | ++ |
+ ) {
+ |
+
| 1036 | +2x | +
+ substitute(expr = aes(fill = fill_name), env = list(fill_name = as.name(fill)))+ |
+
| 1037 | ++ |
+ } else if (+ |
+
| 1038 | +7x | +
+ identical(colour, character(0)) &&+ |
+
| 1039 | +7x | +
+ identical(fill, character(0)) &&+ |
+
| 1040 | +7x | +
+ is_point &&+ |
+
| 1041 | +7x | +
+ !identical(size, character(0))+ |
+
| 1042 | ++ |
+ ) {
+ |
+
| 1043 | +1x | +
+ substitute(expr = aes(size = size_name), env = list(size_name = as.name(size)))+ |
+
| 1044 | ++ |
+ } else if (+ |
+
| 1045 | +6x | +
+ !identical(colour, character(0)) &&+ |
+
| 1046 | +6x | +
+ identical(fill, character(0)) &&+ |
+
| 1047 | +6x | +
+ is_point &&+ |
+
| 1048 | +6x | +
+ !identical(size, character(0))+ |
+
| 1049 | ++ |
+ ) {
+ |
+
| 1050 | +1x | +
+ substitute(+ |
+
| 1051 | +1x | +
+ expr = aes(colour = colour_name, size = size_name),+ |
+
| 1052 | +1x | +
+ env = list(colour_name = as.name(colour), size_name = as.name(size))+ |
+
| 1053 | ++ |
+ )+ |
+
| 1054 | ++ |
+ } else if (+ |
+
| 1055 | +5x | +
+ identical(colour, character(0)) &&+ |
+
| 1056 | +5x | +
+ !identical(fill, character(0)) &&+ |
+
| 1057 | +5x | +
+ is_point &&+ |
+
| 1058 | +5x | +
+ !identical(size, character(0))+ |
+
| 1059 | ++ |
+ ) {
+ |
+
| 1060 | +1x | +
+ substitute(+ |
+
| 1061 | +1x | +
+ expr = aes(colour = colour_name, fill = fill_name, size = size_name),+ |
+
| 1062 | +1x | +
+ env = list(colour_name = as.name(fill), fill_name = as.name(fill), size_name = as.name(size))+ |
+
| 1063 | ++ |
+ )+ |
+
| 1064 | ++ |
+ } else {
+ |
+
| 1065 | +4x | +
+ NULL+ |
+
| 1066 | ++ |
+ }+ |
+
| 1067 | ++ |
+ }+ |
+
| 1 | ++ |
+ #' `teal` module: Response plot+ |
+
| 2 | ++ |
+ #'+ |
+
| 3 | ++ |
+ #' Generates a response plot for a given `response` and `x` variables.+ |
+
| 4 | ++ |
+ #' This module allows users customize and add annotations to the plot depending+ |
+
| 5 | ++ |
+ #' on the module's arguments.+ |
+
| 6 | ++ |
+ #' It supports showing the counts grouped by other variable facets (by row / column),+ |
+
| 7 | ++ |
+ #' swapping the coordinates, show count annotations and displaying the response plot+ |
+
| 8 | ++ |
+ #' as frequency or density.+ |
+
| 9 | ++ |
+ #'+ |
+
| 10 | ++ |
+ #' @inheritParams teal::module+ |
+
| 11 | ++ |
+ #' @inheritParams shared_params+ |
+
| 12 | ++ |
+ #' @param response (`data_extract_spec` or `list` of multiple `data_extract_spec`)+ |
+
| 13 | ++ |
+ #' Which variable to use as the response.+ |
+
| 14 | ++ |
+ #' You can define one fixed column by setting `fixed = TRUE` inside the `select_spec`.+ |
+
| 15 | ++ |
+ #'+ |
+
| 16 | ++ |
+ #' The `data_extract_spec` must not allow multiple selection in this case.+ |
+
| 17 | ++ |
+ #' @param x (`data_extract_spec` or `list` of multiple `data_extract_spec`)+ |
+
| 18 | ++ |
+ #' Specifies which variable to use on the X-axis of the response plot.+ |
+
| 19 | ++ |
+ #' Allow the user to select multiple columns from the `data` allowed in teal.+ |
+
| 20 | ++ |
+ #'+ |
+
| 21 | ++ |
+ #' The `data_extract_spec` must not allow multiple selection in this case.+ |
+
| 22 | ++ |
+ #' @param row_facet (`data_extract_spec` or `list` of multiple `data_extract_spec`)+ |
+
| 23 | ++ |
+ #' optional specification of the data variable(s) to use for faceting rows.+ |
+
| 24 | ++ |
+ #' @param col_facet (`data_extract_spec` or `list` of multiple `data_extract_spec`)+ |
+
| 25 | ++ |
+ #' optional specification of the data variable(s) to use for faceting columns.+ |
+
| 26 | ++ |
+ #' @param coord_flip (`logical(1)`)+ |
+
| 27 | ++ |
+ #' Indicates whether to flip coordinates between `x` and `response`.+ |
+
| 28 | ++ |
+ #' The default value is `FALSE` and it will show the `x` variable on the x-axis+ |
+
| 29 | ++ |
+ #' and the `response` variable on the y-axis.+ |
+
| 30 | ++ |
+ #' @param count_labels (`logical(1)`)+ |
+
| 31 | ++ |
+ #' Indicates whether to show count labels.+ |
+
| 32 | ++ |
+ #' Defaults to `TRUE`.+ |
+
| 33 | ++ |
+ #' @param freq (`logical(1)`)+ |
+
| 34 | ++ |
+ #' Indicates whether to display frequency (`TRUE`) or density (`FALSE`).+ |
+
| 35 | ++ |
+ #' Defaults to density (`FALSE`).+ |
+
| 36 | ++ |
+ #'+ |
+
| 37 | ++ |
+ #' @inherit shared_params return+ |
+
| 38 | ++ |
+ #'+ |
+
| 39 | ++ |
+ #' @note For more examples, please see the vignette "Using response plot" via+ |
+
| 40 | ++ |
+ #' `vignette("using-response-plot", package = "teal.modules.general")`.
+ |
+
| 41 | ++ |
+ #'+ |
+
| 42 | ++ |
+ #' @examples+ |
+
| 43 | ++ |
+ #' # general data example+ |
+
| 44 | ++ |
+ #' library(teal.widgets)+ |
+
| 45 | ++ |
+ #'+ |
+
| 46 | ++ |
+ #' data <- teal_data()+ |
+
| 47 | ++ |
+ #' data <- within(data, {
+ |
+
| 48 | ++ |
+ #' require(nestcolor)+ |
+
| 49 | ++ |
+ #' mtcars <- mtcars+ |
+
| 50 | ++ |
+ #' for (v in c("cyl", "vs", "am", "gear")) {
+ |
+
| 51 | ++ |
+ #' mtcars[[v]] <- as.factor(mtcars[[v]])+ |
+
| 52 | ++ |
+ #' }+ |
+
| 53 | ++ |
+ #' })+ |
+
| 54 | ++ |
+ #' datanames(data) <- "mtcars"+ |
+
| 55 | ++ |
+ #'+ |
+
| 56 | ++ |
+ #' app <- init(+ |
+
| 57 | ++ |
+ #' data = data,+ |
+
| 58 | ++ |
+ #' modules = modules(+ |
+
| 59 | ++ |
+ #' tm_g_response(+ |
+
| 60 | ++ |
+ #' label = "Response Plots",+ |
+
| 61 | ++ |
+ #' response = data_extract_spec(+ |
+
| 62 | ++ |
+ #' dataname = "mtcars",+ |
+
| 63 | ++ |
+ #' select = select_spec(+ |
+
| 64 | ++ |
+ #' label = "Select variable:",+ |
+
| 65 | ++ |
+ #' choices = variable_choices(data[["mtcars"]], c("cyl", "gear")),
+ |
+
| 66 | ++ |
+ #' selected = "cyl",+ |
+
| 67 | ++ |
+ #' multiple = FALSE,+ |
+
| 68 | ++ |
+ #' fixed = FALSE+ |
+
| 69 | ++ |
+ #' )+ |
+
| 70 | ++ |
+ #' ),+ |
+
| 71 | ++ |
+ #' x = data_extract_spec(+ |
+
| 72 | ++ |
+ #' dataname = "mtcars",+ |
+
| 73 | ++ |
+ #' select = select_spec(+ |
+
| 74 | ++ |
+ #' label = "Select variable:",+ |
+
| 75 | ++ |
+ #' choices = variable_choices(data[["mtcars"]], c("vs", "am")),
+ |
+
| 76 | ++ |
+ #' selected = "vs",+ |
+
| 77 | ++ |
+ #' multiple = FALSE,+ |
+
| 78 | ++ |
+ #' fixed = FALSE+ |
+
| 79 | ++ |
+ #' )+ |
+
| 80 | ++ |
+ #' ),+ |
+
| 81 | ++ |
+ #' ggplot2_args = ggplot2_args(+ |
+
| 82 | ++ |
+ #' labs = list(subtitle = "Plot generated by Response Module")+ |
+
| 83 | ++ |
+ #' )+ |
+
| 84 | ++ |
+ #' )+ |
+
| 85 | ++ |
+ #' )+ |
+
| 86 | ++ |
+ #' )+ |
+
| 87 | ++ |
+ #' if (interactive()) {
+ |
+
| 88 | ++ |
+ #' shinyApp(app$ui, app$server)+ |
+
| 89 | ++ |
+ #' }+ |
+
| 90 | ++ |
+ #'+ |
+
| 91 | ++ |
+ #' # CDISC data example+ |
+
| 92 | ++ |
+ #' library(teal.widgets)+ |
+
| 93 | ++ |
+ #'+ |
+
| 94 | ++ |
+ #' data <- teal_data()+ |
+
| 95 | ++ |
+ #' data <- within(data, {
+ |
+
| 96 | ++ |
+ #' require(nestcolor)+ |
+
| 97 | ++ |
+ #' ADSL <- rADSL+ |
+
| 98 | ++ |
+ #' })+ |
+
| 99 | ++ |
+ #' datanames(data) <- c("ADSL")
+ |
+
| 100 | ++ |
+ #' join_keys(data) <- default_cdisc_join_keys[datanames(data)]+ |
+
| 101 | ++ |
+ #'+ |
+
| 102 | ++ |
+ #' app <- init(+ |
+
| 103 | ++ |
+ #' data = data,+ |
+
| 104 | ++ |
+ #' modules = modules(+ |
+
| 105 | ++ |
+ #' tm_g_response(+ |
+
| 106 | ++ |
+ #' label = "Response Plots",+ |
+
| 107 | ++ |
+ #' response = data_extract_spec(+ |
+
| 108 | ++ |
+ #' dataname = "ADSL",+ |
+
| 109 | ++ |
+ #' select = select_spec(+ |
+
| 110 | ++ |
+ #' label = "Select variable:",+ |
+
| 111 | ++ |
+ #' choices = variable_choices(data[["ADSL"]], c("BMRKR2", "COUNTRY")),
+ |
+
| 112 | ++ |
+ #' selected = "BMRKR2",+ |
+
| 113 | ++ |
+ #' multiple = FALSE,+ |
+
| 114 | ++ |
+ #' fixed = FALSE+ |
+
| 115 | ++ |
+ #' )+ |
+
| 116 | ++ |
+ #' ),+ |
+
| 117 | ++ |
+ #' x = data_extract_spec(+ |
+
| 118 | ++ |
+ #' dataname = "ADSL",+ |
+
| 119 | ++ |
+ #' select = select_spec(+ |
+
| 120 | ++ |
+ #' label = "Select variable:",+ |
+
| 121 | ++ |
+ #' choices = variable_choices(data[["ADSL"]], c("SEX", "RACE")),
+ |
+
| 122 | ++ |
+ #' selected = "RACE",+ |
+
| 123 | ++ |
+ #' multiple = FALSE,+ |
+
| 124 | ++ |
+ #' fixed = FALSE+ |
+
| 125 | ++ |
+ #' )+ |
+
| 126 | ++ |
+ #' ),+ |
+
| 127 | ++ |
+ #' ggplot2_args = ggplot2_args(+ |
+
| 128 | ++ |
+ #' labs = list(subtitle = "Plot generated by Response Module")+ |
+
| 129 | ++ |
+ #' )+ |
+
| 130 | ++ |
+ #' )+ |
+
| 131 | ++ |
+ #' )+ |
+
| 132 | ++ |
+ #' )+ |
+
| 133 | ++ |
+ #' if (interactive()) {
+ |
+
| 134 | ++ |
+ #' shinyApp(app$ui, app$server)+ |
+
| 135 | ++ |
+ #' }+ |
+
| 136 | ++ |
+ #'+ |
+
| 137 | ++ |
+ #' @export+ |
+
| 138 | ++ |
+ #'+ |
+
| 139 | ++ |
+ tm_g_response <- function(label = "Response Plot",+ |
+
| 140 | ++ |
+ response,+ |
+
| 141 | ++ |
+ x,+ |
+
| 142 | ++ |
+ row_facet = NULL,+ |
+
| 143 | ++ |
+ col_facet = NULL,+ |
+
| 144 | ++ |
+ coord_flip = FALSE,+ |
+
| 145 | ++ |
+ count_labels = TRUE,+ |
+
| 146 | ++ |
+ rotate_xaxis_labels = FALSE,+ |
+
| 147 | ++ |
+ freq = FALSE,+ |
+
| 148 | ++ |
+ plot_height = c(600, 400, 5000),+ |
+
| 149 | ++ |
+ plot_width = NULL,+ |
+
| 150 | ++ |
+ ggtheme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void"),
+ |
+
| 151 | ++ |
+ ggplot2_args = teal.widgets::ggplot2_args(),+ |
+
| 152 | ++ |
+ pre_output = NULL,+ |
+
| 153 | ++ |
+ post_output = NULL) {
+ |
+
| 154 | +! | +
+ logger::log_info("Initializing tm_g_response")
+ |
+
| 155 | ++ | + + | +
| 156 | ++ |
+ # Normalize the parameters+ |
+
| 157 | +! | +
+ if (inherits(response, "data_extract_spec")) response <- list(response)+ |
+
| 158 | +! | +
+ if (inherits(x, "data_extract_spec")) x <- list(x)+ |
+
| 159 | +! | +
+ if (inherits(row_facet, "data_extract_spec")) row_facet <- list(row_facet)+ |
+
| 160 | +! | +
+ if (inherits(col_facet, "data_extract_spec")) col_facet <- list(col_facet)+ |
+
| 161 | ++ | + + | +
| 162 | ++ |
+ # Start of assertions+ |
+
| 163 | +! | +
+ checkmate::assert_string(label)+ |
+
| 164 | ++ | + + | +
| 165 | +! | +
+ checkmate::assert_list(response, types = "data_extract_spec")+ |
+
| 166 | +! | +
+ if (!all(vapply(response, function(x) !("" %in% x$select$choices), logical(1)))) {
+ |
+
| 167 | +! | +
+ stop("'response' should not allow empty values")
+ |
+
| 168 | ++ |
+ }+ |
+
| 169 | +! | +
+ assert_single_selection(response)+ |
+
| 170 | ++ | + + | +
| 171 | +! | +
+ checkmate::assert_list(x, types = "data_extract_spec")+ |
+
| 172 | +! | +
+ if (!all(vapply(x, function(x) !("" %in% x$select$choices), logical(1)))) {
+ |
+
| 173 | +! | +
+ stop("'x' should not allow empty values")
+ |
+
| 174 | ++ |
+ }+ |
+
| 175 | +! | +
+ assert_single_selection(x)+ |
+
| 176 | ++ | + + | +
| 177 | +! | +
+ checkmate::assert_list(row_facet, types = "data_extract_spec", null.ok = TRUE)+ |
+
| 178 | +! | +
+ checkmate::assert_list(col_facet, types = "data_extract_spec", null.ok = TRUE)+ |
+
| 179 | +! | +
+ checkmate::assert_flag(coord_flip)+ |
+
| 180 | +! | +
+ checkmate::assert_flag(count_labels)+ |
+
| 181 | +! | +
+ checkmate::assert_flag(rotate_xaxis_labels)+ |
+
| 182 | +! | +
+ checkmate::assert_flag(freq)+ |
+
| 183 | ++ | + + | +
| 184 | +! | +
+ checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE)+ |
+
| 185 | +! | +
+ checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height")+ |
+
| 186 | +! | +
+ checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE)+ |
+
| 187 | +! | +
+ checkmate::assert_numeric(+ |
+
| 188 | +! | +
+ plot_width[1],+ |
+
| 189 | +! | +
+ lower = plot_width[2], upper = plot_width[3], null.ok = TRUE, .var.name = "plot_width"+ |
+
| 190 | ++ |
+ )+ |
+
| 191 | ++ | + + | +
| 192 | +! | +
+ ggtheme <- match.arg(ggtheme)+ |
+
| 193 | +! | +
+ checkmate::assert_class(ggplot2_args, "ggplot2_args")+ |
+
| 194 | ++ | + + | +
| 195 | +! | +
+ checkmate::assert_multi_class(pre_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
+ |
+
| 196 | +! | +
+ checkmate::assert_multi_class(post_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
+ |
+
| 197 | ++ |
+ # End of assertions+ |
+
| 198 | ++ | + + | +
| 199 | ++ |
+ # Make UI args+ |
+
| 200 | +! | +
+ args <- as.list(environment())+ |
+
| 201 | ++ | + + | +
| 202 | +! | +
+ data_extract_list <- list(+ |
+
| 203 | +! | +
+ response = response,+ |
+
| 204 | +! | +
+ x = x,+ |
+
| 205 | +! | +
+ row_facet = row_facet,+ |
+
| 206 | +! | +
+ col_facet = col_facet+ |
+
| 207 | ++ |
+ )+ |
+
| 208 | ++ | + + | +
| 209 | +! | +
+ module(+ |
+
| 210 | +! | +
+ label = label,+ |
+
| 211 | +! | +
+ server = srv_g_response,+ |
+
| 212 | +! | +
+ ui = ui_g_response,+ |
+
| 213 | +! | +
+ ui_args = args,+ |
+
| 214 | +! | +
+ server_args = c(+ |
+
| 215 | +! | +
+ data_extract_list,+ |
+
| 216 | +! | +
+ list(plot_height = plot_height, plot_width = plot_width, ggplot2_args = ggplot2_args)+ |
+
| 217 | ++ |
+ ),+ |
+
| 218 | +! | +
+ datanames = teal.transform::get_extract_datanames(data_extract_list)+ |
+
| 219 | ++ |
+ )+ |
+
| 220 | ++ |
+ }+ |
+
| 221 | ++ | + + | +
| 222 | ++ |
+ # UI function for the response module+ |
+
| 223 | ++ |
+ ui_g_response <- function(id, ...) {
+ |
+
| 224 | +! | +
+ ns <- NS(id)+ |
+
| 225 | +! | +
+ args <- list(...)+ |
+
| 226 | +! | +
+ is_single_dataset_value <- teal.transform::is_single_dataset(args$response, args$x, args$row_facet, args$col_facet)+ |
+
| 227 | ++ | + + | +
| 228 | +! | +
+ teal.widgets::standard_layout(+ |
+
| 229 | +! | +
+ output = teal.widgets::white_small_well(+ |
+
| 230 | +! | +
+ teal.widgets::plot_with_settings_ui(id = ns("myplot"))
+ |
+
| 231 | ++ |
+ ),+ |
+
| 232 | +! | +
+ encoding = div(+ |
+
| 233 | ++ |
+ ### Reporter+ |
+
| 234 | +! | +
+ teal.reporter::simple_reporter_ui(ns("simple_reporter")),
+ |
+
| 235 | ++ |
+ ###+ |
+
| 236 | +! | +
+ tags$label("Encodings", class = "text-primary"),
+ |
+
| 237 | +! | +
+ teal.transform::datanames_input(args[c("response", "x", "row_facet", "col_facet")]),
+ |
+
| 238 | +! | +
+ teal.transform::data_extract_ui(+ |
+
| 239 | +! | +
+ id = ns("response"),
+ |
+
| 240 | +! | +
+ label = "Response variable",+ |
+
| 241 | +! | +
+ data_extract_spec = args$response,+ |
+
| 242 | +! | +
+ is_single_dataset = is_single_dataset_value+ |
+
| 243 | ++ |
+ ),+ |
+
| 244 | +! | +
+ teal.transform::data_extract_ui(+ |
+
| 245 | +! | +
+ id = ns("x"),
+ |
+
| 246 | +! | +
+ label = "X variable",+ |
+
| 247 | +! | +
+ data_extract_spec = args$x,+ |
+
| 248 | +! | +
+ is_single_dataset = is_single_dataset_value+ |
+
| 249 | ++ |
+ ),+ |
+
| 250 | +! | +
+ if (!is.null(args$row_facet)) {
+ |
+
| 251 | +! | +
+ teal.transform::data_extract_ui(+ |
+
| 252 | +! | +
+ id = ns("row_facet"),
+ |
+
| 253 | +! | +
+ label = "Row facetting",+ |
+
| 254 | +! | +
+ data_extract_spec = args$row_facet,+ |
+
| 255 | +! | +
+ is_single_dataset = is_single_dataset_value+ |
+
| 256 | ++ |
+ )+ |
+
| 257 | ++ |
+ },+ |
+
| 258 | +! | +
+ if (!is.null(args$col_facet)) {
+ |
+
| 259 | +! | +
+ teal.transform::data_extract_ui(+ |
+
| 260 | +! | +
+ id = ns("col_facet"),
+ |
+
| 261 | +! | +
+ label = "Column facetting",+ |
+
| 262 | +! | +
+ data_extract_spec = args$col_facet,+ |
+
| 263 | +! | +
+ is_single_dataset = is_single_dataset_value+ |
+
| 264 | ++ |
+ )+ |
+
| 265 | ++ |
+ },+ |
+
| 266 | +! | +
+ shinyWidgets::radioGroupButtons(+ |
+
| 267 | +! | +
+ inputId = ns("freq"),
+ |
+
| 268 | +! | +
+ label = NULL,+ |
+
| 269 | +! | +
+ choices = c("frequency", "density"),
+ |
+
| 270 | +! | +
+ selected = ifelse(args$freq, "frequency", "density"),+ |
+
| 271 | +! | +
+ justified = TRUE+ |
+
| 272 | ++ |
+ ),+ |
+
| 273 | +! | +
+ teal.widgets::panel_group(+ |
+
| 274 | +! | +
+ teal.widgets::panel_item(+ |
+
| 275 | +! | +
+ title = "Plot settings",+ |
+
| 276 | +! | +
+ checkboxInput(ns("count_labels"), "Add count labels", value = args$count_labels),
+ |
+
| 277 | +! | +
+ checkboxInput(ns("coord_flip"), "Swap axes", value = args$coord_flip),
+ |
+
| 278 | +! | +
+ checkboxInput(ns("rotate_xaxis_labels"), "Rotate X axis labels", value = args$rotate_xaxis_labels),
+ |
+
| 279 | +! | +
+ selectInput(+ |
+
| 280 | +! | +
+ inputId = ns("ggtheme"),
+ |
+
| 281 | +! | +
+ label = "Theme (by ggplot):",+ |
+
| 282 | +! | +
+ choices = ggplot_themes,+ |
+
| 283 | +! | +
+ selected = args$ggtheme,+ |
+
| 284 | +! | +
+ multiple = FALSE+ |
+
| 285 | ++ |
+ )+ |
+
| 286 | ++ |
+ )+ |
+
| 287 | ++ |
+ )+ |
+
| 288 | ++ |
+ ),+ |
+
| 289 | +! | +
+ forms = tagList(+ |
+
| 290 | +! | +
+ teal.widgets::verbatim_popup_ui(ns("warning"), button_label = "Show Warnings"),
+ |
+
| 291 | +! | +
+ teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code")
+ |
+
| 292 | ++ |
+ ),+ |
+
| 293 | +! | +
+ pre_output = args$pre_output,+ |
+
| 294 | +! | +
+ post_output = args$post_output+ |
+
| 295 | ++ |
+ )+ |
+
| 296 | ++ |
+ }+ |
+
| 297 | ++ | + + | +
| 298 | ++ |
+ # Server function for the response module+ |
+
| 299 | ++ |
+ srv_g_response <- function(id,+ |
+
| 300 | ++ |
+ data,+ |
+
| 301 | ++ |
+ reporter,+ |
+
| 302 | ++ |
+ filter_panel_api,+ |
+
| 303 | ++ |
+ response,+ |
+
| 304 | ++ |
+ x,+ |
+
| 305 | ++ |
+ row_facet,+ |
+
| 306 | ++ |
+ col_facet,+ |
+
| 307 | ++ |
+ plot_height,+ |
+
| 308 | ++ |
+ plot_width,+ |
+
| 309 | ++ |
+ ggplot2_args) {
+ |
+
| 310 | +! | +
+ with_reporter <- !missing(reporter) && inherits(reporter, "Reporter")+ |
+
| 311 | +! | +
+ with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI")+ |
+
| 312 | +! | +
+ checkmate::assert_class(data, "reactive")+ |
+
| 313 | +! | +
+ checkmate::assert_class(isolate(data()), "teal_data")+ |
+
| 314 | +! | +
+ moduleServer(id, function(input, output, session) {
+ |
+
| 315 | +! | +
+ data_extract <- list(response = response, x = x, row_facet = row_facet, col_facet = col_facet)+ |
+
| 316 | ++ | + + | +
| 317 | +! | +
+ rule_diff <- function(other) {
+ |
+
| 318 | +! | +
+ function(value) {
+ |
+
| 319 | +! | +
+ if (other %in% names(selector_list())) {
+ |
+
| 320 | +! | +
+ othervalue <- selector_list()[[other]]()[["select"]]+ |
+
| 321 | +! | +
+ if (!is.null(othervalue)) {
+ |
+
| 322 | +! | +
+ if (identical(value, othervalue)) {
+ |
+
| 323 | +! | +
+ "Row and column facetting variables must be different."+ |
+
| 324 | ++ |
+ }+ |
+
| 325 | ++ |
+ }+ |
+
| 326 | ++ |
+ }+ |
+
| 327 | ++ |
+ }+ |
+
| 328 | ++ |
+ }+ |
+
| 329 | ++ | + + | +
| 330 | +! | +
+ selector_list <- teal.transform::data_extract_multiple_srv(+ |
+
| 331 | +! | +
+ data_extract = data_extract,+ |
+
| 332 | +! | +
+ datasets = data,+ |
+
| 333 | +! | +
+ select_validation_rule = list(+ |
+
| 334 | +! | +
+ response = shinyvalidate::sv_required("Please define a column for the response variable"),
+ |
+
| 335 | +! | +
+ x = shinyvalidate::sv_required("Please define a column for X variable"),
+ |
+
| 336 | +! | +
+ row_facet = shinyvalidate::compose_rules(+ |
+
| 337 | +! | +
+ shinyvalidate::sv_optional(),+ |
+
| 338 | +! | +
+ ~ if (length(.) > 1) "There must be 1 or no row facetting variable.",+ |
+
| 339 | +! | +
+ rule_diff("col_facet")
+ |
+
| 340 | ++ |
+ ),+ |
+
| 341 | +! | +
+ col_facet = shinyvalidate::compose_rules(+ |
+
| 342 | +! | +
+ shinyvalidate::sv_optional(),+ |
+
| 343 | +! | +
+ ~ if (length(.) > 1) "There must be 1 or no column facetting variable.",+ |
+
| 344 | +! | +
+ rule_diff("row_facet")
+ |
+
| 345 | ++ |
+ )+ |
+
| 346 | ++ |
+ )+ |
+
| 347 | ++ |
+ )+ |
+
| 348 | ++ | + + | +
| 349 | +! | +
+ iv_r <- reactive({
+ |
+
| 350 | +! | +
+ iv <- shinyvalidate::InputValidator$new()+ |
+
| 351 | +! | +
+ iv$add_rule("ggtheme", shinyvalidate::sv_required("Please select a theme"))
+ |
+
| 352 | +! | +
+ teal.transform::compose_and_enable_validators(iv, selector_list)+ |
+
| 353 | ++ |
+ })+ |
+
| 354 | ++ | + + | +
| 355 | +! | +
+ anl_merged_input <- teal.transform::merge_expression_srv(+ |
+
| 356 | +! | +
+ selector_list = selector_list,+ |
+
| 357 | +! | +
+ datasets = data+ |
+
| 358 | ++ |
+ )+ |
+
| 359 | ++ | + + | +
| 360 | +! | +
+ anl_merged_q <- reactive({
+ |
+
| 361 | +! | +
+ req(anl_merged_input())+ |
+
| 362 | +! | +
+ data() %>%+ |
+
| 363 | +! | +
+ teal.code::eval_code(as.expression(anl_merged_input()$expr))+ |
+
| 364 | ++ |
+ })+ |
+
| 365 | ++ | + + | +
| 366 | +! | +
+ merged <- list(+ |
+
| 367 | +! | +
+ anl_input_r = anl_merged_input,+ |
+
| 368 | +! | +
+ anl_q_r = anl_merged_q+ |
+
| 369 | ++ |
+ )+ |
+
| 370 | ++ | + + | +
| 371 | +! | +
+ output_q <- reactive({
+ |
+
| 372 | +! | +
+ teal::validate_inputs(iv_r())+ |
+
| 373 | ++ | + + | +
| 374 | +! | +
+ qenv <- merged$anl_q_r()+ |
+
| 375 | +! | +
+ ANL <- qenv[["ANL"]]+ |
+
| 376 | +! | +
+ resp_var <- as.vector(merged$anl_input_r()$columns_source$response)+ |
+
| 377 | +! | +
+ x <- as.vector(merged$anl_input_r()$columns_source$x)+ |
+
| 378 | ++ | + + | +
| 379 | +! | +
+ validate(need(is.factor(ANL[[resp_var]]), "Please select a factor variable as the response."))+ |
+
| 380 | +! | +
+ validate(need(is.factor(ANL[[x]]), "Please select a factor variable as the X-Variable."))+ |
+
| 381 | +! | +
+ teal::validate_has_data(ANL, 10)+ |
+
| 382 | +! | +
+ teal::validate_has_data(ANL[, c(resp_var, x)], 10, complete = TRUE, allow_inf = FALSE)+ |
+
| 383 | ++ | + + | +
| 384 | +! | +
+ row_facet_name <- if (length(merged$anl_input_r()$columns_source$row_facet) == 0) {
+ |
+
| 385 | +! | +
+ character(0)+ |
+
| 386 | ++ |
+ } else {
+ |
+
| 387 | +! | +
+ as.vector(merged$anl_input_r()$columns_source$row_facet)+ |
+
| 388 | ++ |
+ }+ |
+
| 389 | +! | +
+ col_facet_name <- if (length(merged$anl_input_r()$columns_source$col_facet) == 0) {
+ |
+
| 390 | +! | +
+ character(0)+ |
+
| 391 | ++ |
+ } else {
+ |
+
| 392 | +! | +
+ as.vector(merged$anl_input_r()$columns_source$col_facet)+ |
+
| 393 | ++ |
+ }+ |
+
| 394 | ++ | + + | +
| 395 | +! | +
+ freq <- input$freq == "frequency"+ |
+
| 396 | +! | +
+ swap_axes <- input$coord_flip+ |
+
| 397 | +! | +
+ counts <- input$count_labels+ |
+
| 398 | +! | +
+ rotate_xaxis_labels <- input$rotate_xaxis_labels+ |
+
| 399 | +! | +
+ ggtheme <- input$ggtheme+ |
+
| 400 | ++ | + + | +
| 401 | +! | +
+ arg_position <- if (freq) "stack" else "fill"+ |
+
| 402 | ++ | + + | +
| 403 | +! | +
+ rowf <- if (length(row_facet_name) != 0) as.name(row_facet_name)+ |
+
| 404 | +! | +
+ colf <- if (length(col_facet_name) != 0) as.name(col_facet_name)+ |
+
| 405 | +! | +
+ resp_cl <- as.name(resp_var)+ |
+
| 406 | +! | +
+ x_cl <- as.name(x)+ |
+
| 407 | ++ | + + | +
| 408 | +! | +
+ if (swap_axes) {
+ |
+
| 409 | +! | +
+ qenv <- teal.code::eval_code(+ |
+
| 410 | +! | +
+ qenv,+ |
+
| 411 | +! | +
+ substitute(+ |
+
| 412 | +! | +
+ expr = ANL[[x]] <- with(ANL, forcats::fct_rev(x_cl)),+ |
+
| 413 | +! | +
+ env = list(x = x, x_cl = x_cl)+ |
+
| 414 | ++ |
+ )+ |
+
| 415 | ++ |
+ )+ |
+
| 416 | ++ |
+ }+ |
+
| 417 | ++ | + + | +
| 418 | +! | +
+ qenv <- teal.code::eval_code(+ |
+
| 419 | +! | +
+ qenv,+ |
+
| 420 | +! | +
+ substitute(+ |
+
| 421 | +! | +
+ expr = ANL[[resp_var]] <- factor(ANL[[resp_var]]),+ |
+
| 422 | +! | +
+ env = list(resp_var = resp_var)+ |
+
| 423 | ++ |
+ )+ |
+
| 424 | ++ |
+ ) %>%+ |
+
| 425 | ++ |
+ # rowf and colf will be a NULL if not set by a user+ |
+
| 426 | +! | +
+ teal.code::eval_code(+ |
+
| 427 | +! | +
+ substitute(+ |
+
| 428 | +! | +
+ expr = ANL2 <- ANL %>%+ |
+
| 429 | +! | +
+ dplyr::group_by_at(dplyr::vars(x_cl, resp_cl, rowf, colf)) %>%+ |
+
| 430 | +! | +
+ dplyr::summarise(ns = dplyr::n()) %>%+ |
+
| 431 | +! | +
+ dplyr::group_by_at(dplyr::vars(x_cl, rowf, colf)) %>%+ |
+
| 432 | +! | +
+ dplyr::mutate(sums = sum(ns), percent = round(ns / sums * 100, 1)),+ |
+
| 433 | +! | +
+ env = list(x_cl = x_cl, resp_cl = resp_cl, rowf = rowf, colf = colf)+ |
+
| 434 | ++ |
+ )+ |
+
| 435 | ++ |
+ ) %>%+ |
+
| 436 | +! | +
+ teal.code::eval_code(+ |
+
| 437 | +! | +
+ substitute(+ |
+
| 438 | +! | +
+ expr = ANL3 <- ANL %>%+ |
+
| 439 | +! | +
+ dplyr::group_by_at(dplyr::vars(x_cl, rowf, colf)) %>%+ |
+
| 440 | +! | +
+ dplyr::summarise(ns = dplyr::n()),+ |
+
| 441 | +! | +
+ env = list(x_cl = x_cl, rowf = rowf, colf = colf)+ |
+
| 442 | ++ |
+ )+ |
+
| 443 | ++ |
+ )+ |
+
| 444 | ++ | + + | +
| 445 | +! | +
+ plot_call <- substitute(+ |
+
| 446 | +! | +
+ expr = ggplot(ANL2, aes(x = x_cl, y = ns)) ++ |
+
| 447 | +! | +
+ geom_bar(aes(fill = resp_cl), stat = "identity", position = arg_position),+ |
+
| 448 | +! | +
+ env = list(+ |
+
| 449 | +! | +
+ x_cl = x_cl,+ |
+
| 450 | +! | +
+ resp_cl = resp_cl,+ |
+
| 451 | +! | +
+ arg_position = arg_position+ |
+
| 452 | ++ |
+ )+ |
+
| 453 | ++ |
+ )+ |
+
| 454 | ++ | + + | +
| 455 | +! | +
+ if (!freq) plot_call <- substitute(plot_call + expand_limits(y = c(0, 1.1)), env = list(plot_call = plot_call))+ |
+
| 456 | ++ | + + | +
| 457 | +! | +
+ if (counts) {
+ |
+
| 458 | +! | +
+ plot_call <- substitute(+ |
+
| 459 | +! | +
+ expr = plot_call ++ |
+
| 460 | +! | +
+ geom_text(+ |
+
| 461 | +! | +
+ data = ANL2,+ |
+
| 462 | +! | +
+ aes(label = ns, x = x_cl, y = ns, group = resp_cl),+ |
+
| 463 | +! | +
+ col = "white",+ |
+
| 464 | +! | +
+ vjust = "middle",+ |
+
| 465 | +! | +
+ hjust = "middle",+ |
+
| 466 | +! | +
+ position = position_anl2_value+ |
+
| 467 | ++ |
+ ) ++ |
+
| 468 | +! | +
+ geom_text(+ |
+
| 469 | +! | +
+ data = ANL3, aes(label = ns, x = x_cl, y = anl3_y),+ |
+
| 470 | +! | +
+ hjust = hjust_value,+ |
+
| 471 | +! | +
+ vjust = vjust_value,+ |
+
| 472 | +! | +
+ position = position_anl3_value+ |
+
| 473 | ++ |
+ ),+ |
+
| 474 | +! | +
+ env = list(+ |
+
| 475 | +! | +
+ plot_call = plot_call,+ |
+
| 476 | +! | +
+ x_cl = x_cl,+ |
+
| 477 | +! | +
+ resp_cl = resp_cl,+ |
+
| 478 | +! | +
+ hjust_value = if (swap_axes) "left" else "middle",+ |
+
| 479 | +! | +
+ vjust_value = if (swap_axes) "middle" else -1,+ |
+
| 480 | +! | +
+ position_anl2_value = if (!freq) quote(position_fill(0.5)) else quote(position_stack(0.5)),+ |
+
| 481 | +! | +
+ anl3_y = if (!freq) 1.1 else as.name("ns"),
+ |
+
| 482 | +! | +
+ position_anl3_value = if (!freq) "fill" else "stack"+ |
+
| 483 | ++ |
+ )+ |
+
| 484 | ++ |
+ )+ |
+
| 485 | ++ |
+ }+ |
+
| 486 | ++ | + + | +
| 487 | +! | +
+ if (swap_axes) {
+ |
+
| 488 | +! | +
+ plot_call <- substitute(plot_call + coord_flip(), env = list(plot_call = plot_call))+ |
+
| 489 | ++ |
+ }+ |
+
| 490 | ++ | + + | +
| 491 | +! | +
+ facet_cl <- facet_ggplot_call(row_facet_name, col_facet_name)+ |
+
| 492 | ++ | + + | +
| 493 | +! | +
+ if (!is.null(facet_cl)) {
+ |
+
| 494 | +! | +
+ plot_call <- substitute(expr = plot_call + facet_cl, env = list(plot_call = plot_call, facet_cl = facet_cl))+ |
+
| 495 | ++ |
+ }+ |
+
| 496 | ++ | + + | +
| 497 | +! | +
+ dev_ggplot2_args <- teal.widgets::ggplot2_args(+ |
+
| 498 | +! | +
+ labs = list(+ |
+
| 499 | +! | +
+ x = varname_w_label(x, ANL),+ |
+
| 500 | +! | +
+ y = varname_w_label(resp_var, ANL, prefix = "Proportion of "),+ |
+
| 501 | +! | +
+ fill = varname_w_label(resp_var, ANL)+ |
+
| 502 | ++ |
+ ),+ |
+
| 503 | +! | +
+ theme = list(legend.position = "bottom")+ |
+
| 504 | ++ |
+ )+ |
+
| 505 | ++ | + + | +
| 506 | +! | +
+ if (rotate_xaxis_labels) {
+ |
+
| 507 | +! | +
+ dev_ggplot2_args$theme[["axis.text.x"]] <- quote(element_text(angle = 45, hjust = 1))+ |
+
| 508 | ++ |
+ }+ |
+
| 509 | ++ | + + | +
| 510 | +! | +
+ all_ggplot2_args <- teal.widgets::resolve_ggplot2_args(+ |
+
| 511 | +! | +
+ user_plot = ggplot2_args,+ |
+
| 512 | +! | +
+ module_plot = dev_ggplot2_args+ |
+
| 513 | ++ |
+ )+ |
+
| 514 | ++ | + + | +
| 515 | +! | +
+ parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(+ |
+
| 516 | +! | +
+ all_ggplot2_args,+ |
+
| 517 | +! | +
+ ggtheme = ggtheme+ |
+
| 518 | ++ |
+ )+ |
+
| 519 | ++ | + + | +
| 520 | +! | +
+ plot_call <- substitute(expr = {
+ |
+
| 521 | +! | +
+ p <- plot_call + labs + ggthemes + themes+ |
+
| 522 | +! | +
+ print(p)+ |
+
| 523 | +! | +
+ }, env = list(+ |
+
| 524 | +! | +
+ plot_call = plot_call,+ |
+
| 525 | +! | +
+ labs = parsed_ggplot2_args$labs,+ |
+
| 526 | +! | +
+ themes = parsed_ggplot2_args$theme,+ |
+
| 527 | +! | +
+ ggthemes = parsed_ggplot2_args$ggtheme+ |
+
| 528 | ++ |
+ ))+ |
+
| 529 | ++ | + + | +
| 530 | +! | +
+ teal.code::eval_code(qenv, plot_call)+ |
+
| 531 | ++ |
+ })+ |
+
| 532 | ++ | + + | +
| 533 | +! | +
+ plot_r <- reactive(output_q()[["p"]])+ |
+
| 534 | ++ | + + | +
| 535 | ++ |
+ # Insert the plot into a plot_with_settings module from teal.widgets+ |
+
| 536 | +! | +
+ pws <- teal.widgets::plot_with_settings_srv(+ |
+
| 537 | +! | +
+ id = "myplot",+ |
+
| 538 | +! | +
+ plot_r = plot_r,+ |
+
| 539 | +! | +
+ height = plot_height,+ |
+
| 540 | +! | +
+ width = plot_width+ |
+
| 541 | ++ |
+ )+ |
+
| 542 | ++ | + + | +
| 543 | +! | +
+ teal.widgets::verbatim_popup_srv(+ |
+
| 544 | +! | +
+ id = "warning",+ |
+
| 545 | +! | +
+ verbatim_content = reactive(teal.code::get_warnings(output_q())),+ |
+
| 546 | +! | +
+ title = "Warning",+ |
+
| 547 | +! | +
+ disabled = reactive(is.null(teal.code::get_warnings(output_q())))+ |
+
| 548 | ++ |
+ )+ |
+
| 549 | ++ | + + | +
| 550 | +! | +
+ teal.widgets::verbatim_popup_srv(+ |
+
| 551 | +! | +
+ id = "rcode",+ |
+
| 552 | +! | +
+ verbatim_content = reactive(teal.code::get_code(output_q())),+ |
+
| 553 | +! | +
+ title = "Show R Code for Response"+ |
+
| 554 | ++ |
+ )+ |
+
| 555 | ++ | + + | +
| 556 | ++ |
+ ### REPORTER+ |
+
| 557 | +! | +
+ if (with_reporter) {
+ |
+
| 558 | +! | +
+ card_fun <- function(comment, label) {
+ |
+
| 559 | +! | +
+ card <- teal::report_card_template(+ |
+
| 560 | +! | +
+ title = "Response Plot",+ |
+
| 561 | +! | +
+ label = label,+ |
+
| 562 | +! | +
+ with_filter = with_filter,+ |
+
| 563 | +! | +
+ filter_panel_api = filter_panel_api+ |
+
| 564 | ++ |
+ )+ |
+
| 565 | +! | +
+ card$append_text("Plot", "header3")
+ |
+
| 566 | +! | +
+ card$append_plot(plot_r(), dim = pws$dim())+ |
+
| 567 | +! | +
+ if (!comment == "") {
+ |
+
| 568 | +! | +
+ card$append_text("Comment", "header3")
+ |
+
| 569 | +! | +
+ card$append_text(comment)+ |
+
| 570 | ++ |
+ }+ |
+
| 571 | +! | +
+ card$append_src(teal.code::get_code(output_q()))+ |
+
| 572 | +! | +
+ card+ |
+
| 573 | ++ |
+ }+ |
+
| 574 | +! | +
+ teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
+ |
+
| 575 | ++ |
+ }+ |
+
| 576 | ++ |
+ ###+ |
+
| 577 | ++ |
+ })+ |
+
| 578 | ++ |
+ }+ |
+
| 1 | ++ |
+ #' `teal` module: Principal component analysis+ |
+
| 2 | ++ |
+ #'+ |
+
| 3 | ++ |
+ #' Module conducts principal component analysis (PCA) on a given dataset and offers different+ |
+
| 4 | ++ |
+ #' ways of visualizing the outcomes, including elbow plot, circle plot, biplot, and eigenvector plot.+ |
+
| 5 | ++ |
+ #' Additionally, it enables dynamic customization of plot aesthetics, such as opacity, size, and+ |
+
| 6 | ++ |
+ #' font size, through UI inputs.+ |
+
| 7 | ++ |
+ #'+ |
+
| 8 | ++ |
+ #' @inheritParams teal::module+ |
+
| 9 | ++ |
+ #' @inheritParams shared_params+ |
+
| 10 | ++ |
+ #' @param dat (`data_extract_spec` or `list` of multiple `data_extract_spec`)+ |
+
| 11 | ++ |
+ #' specifying columns used to compute PCA.+ |
+
| 12 | ++ |
+ #' @param font_size (`numeric`) optional, specifies font size.+ |
+
| 13 | ++ |
+ #' It controls the font size for plot titles, axis labels, and legends.+ |
+
| 14 | ++ |
+ #' - If vector of `length == 1` then the font sizes will have a fixed size.+ |
+
| 15 | ++ |
+ #' - while vector of `value`, `min`, and `max` allows dynamic adjustment.+ |
+
| 16 | ++ |
+ #' @templateVar ggnames "Elbow plot", "Circle plot", "Biplot", "Eigenvector plot"+ |
+
| 17 | ++ |
+ #' @template ggplot2_args_multi+ |
+
| 18 | ++ |
+ #'+ |
+
| 19 | ++ |
+ #' @inherit shared_params return+ |
+
| 20 | ++ |
+ #'+ |
+
| 21 | ++ |
+ #' @examples+ |
+
| 22 | ++ |
+ #' library(teal.widgets)+ |
+
| 23 | ++ |
+ #'+ |
+
| 24 | ++ |
+ #' # general data example+ |
+
| 25 | ++ |
+ #' data <- teal_data()+ |
+
| 26 | ++ |
+ #' data <- within(data, {
+ |
+
| 27 | ++ |
+ #' require(nestcolor)+ |
+
| 28 | ++ |
+ #' USArrests <- USArrests+ |
+
| 29 | ++ |
+ #' })+ |
+
| 30 | ++ |
+ #'+ |
+
| 31 | ++ |
+ #' datanames(data) <- "USArrests"+ |
+
| 32 | ++ |
+ #'+ |
+
| 33 | ++ |
+ #' app <- init(+ |
+
| 34 | ++ |
+ #' data = data,+ |
+
| 35 | ++ |
+ #' modules = modules(+ |
+
| 36 | ++ |
+ #' tm_a_pca(+ |
+
| 37 | ++ |
+ #' "PCA",+ |
+
| 38 | ++ |
+ #' dat = data_extract_spec(+ |
+
| 39 | ++ |
+ #' dataname = "USArrests",+ |
+
| 40 | ++ |
+ #' select = select_spec(+ |
+
| 41 | ++ |
+ #' choices = variable_choices(+ |
+
| 42 | ++ |
+ #' data = data[["USArrests"]], c("Murder", "Assault", "UrbanPop", "Rape")
+ |
+
| 43 | ++ |
+ #' ),+ |
+
| 44 | ++ |
+ #' selected = c("Murder", "Assault"),
+ |
+
| 45 | ++ |
+ #' multiple = TRUE+ |
+
| 46 | ++ |
+ #' ),+ |
+
| 47 | ++ |
+ #' filter = NULL+ |
+
| 48 | ++ |
+ #' ),+ |
+
| 49 | ++ |
+ #' ggplot2_args = ggplot2_args(+ |
+
| 50 | ++ |
+ #' labs = list(subtitle = "Plot generated by PCA Module")+ |
+
| 51 | ++ |
+ #' )+ |
+
| 52 | ++ |
+ #' )+ |
+
| 53 | ++ |
+ #' )+ |
+
| 54 | ++ |
+ #' )+ |
+
| 55 | ++ |
+ #' if (interactive()) {
+ |
+
| 56 | ++ |
+ #' shinyApp(app$ui, app$server)+ |
+
| 57 | ++ |
+ #' }+ |
+
| 58 | ++ |
+ #'+ |
+
| 59 | ++ |
+ #' # CDISC data example+ |
+
| 60 | ++ |
+ #' data <- teal_data()+ |
+
| 61 | ++ |
+ #' data <- within(data, {
+ |
+
| 62 | ++ |
+ #' require(nestcolor)+ |
+
| 63 | ++ |
+ #' ADSL <- rADSL+ |
+
| 64 | ++ |
+ #' })+ |
+
| 65 | ++ |
+ #' datanames(data) <- "ADSL"+ |
+
| 66 | ++ |
+ #' join_keys(data) <- default_cdisc_join_keys[datanames(data)]+ |
+
| 67 | ++ |
+ #'+ |
+
| 68 | ++ |
+ #' app <- init(+ |
+
| 69 | ++ |
+ #' data = data,+ |
+
| 70 | ++ |
+ #' modules = modules(+ |
+
| 71 | ++ |
+ #' tm_a_pca(+ |
+
| 72 | ++ |
+ #' "PCA",+ |
+
| 73 | ++ |
+ #' dat = data_extract_spec(+ |
+
| 74 | ++ |
+ #' dataname = "ADSL",+ |
+
| 75 | ++ |
+ #' select = select_spec(+ |
+
| 76 | ++ |
+ #' choices = variable_choices(+ |
+
| 77 | ++ |
+ #' data = data[["ADSL"]], c("BMRKR1", "AGE", "EOSDY")
+ |
+
| 78 | ++ |
+ #' ),+ |
+
| 79 | ++ |
+ #' selected = c("BMRKR1", "AGE"),
+ |
+
| 80 | ++ |
+ #' multiple = TRUE+ |
+
| 81 | ++ |
+ #' ),+ |
+
| 82 | ++ |
+ #' filter = NULL+ |
+
| 83 | ++ |
+ #' ),+ |
+
| 84 | ++ |
+ #' ggplot2_args = ggplot2_args(+ |
+
| 85 | ++ |
+ #' labs = list(subtitle = "Plot generated by PCA Module")+ |
+
| 86 | ++ |
+ #' )+ |
+
| 87 | ++ |
+ #' )+ |
+
| 88 | ++ |
+ #' )+ |
+
| 89 | ++ |
+ #' )+ |
+
| 90 | ++ |
+ #' if (interactive()) {
+ |
+
| 91 | ++ |
+ #' shinyApp(app$ui, app$server)+ |
+
| 92 | ++ |
+ #' }+ |
+
| 93 | ++ |
+ #'+ |
+
| 94 | ++ |
+ #' @export+ |
+
| 95 | ++ |
+ #'+ |
+
| 96 | ++ |
+ tm_a_pca <- function(label = "Principal Component Analysis",+ |
+
| 97 | ++ |
+ dat,+ |
+
| 98 | ++ |
+ plot_height = c(600, 200, 2000),+ |
+
| 99 | ++ |
+ plot_width = NULL,+ |
+
| 100 | ++ |
+ ggtheme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void"),
+ |
+
| 101 | ++ |
+ ggplot2_args = teal.widgets::ggplot2_args(),+ |
+
| 102 | ++ |
+ rotate_xaxis_labels = FALSE,+ |
+
| 103 | ++ |
+ font_size = c(12, 8, 20),+ |
+
| 104 | ++ |
+ alpha = c(1, 0, 1),+ |
+
| 105 | ++ |
+ size = c(2, 1, 8),+ |
+
| 106 | ++ |
+ pre_output = NULL,+ |
+
| 107 | ++ |
+ post_output = NULL) {
+ |
+
| 108 | +! | +
+ logger::log_info("Initializing tm_a_pca")
+ |
+
| 109 | ++ | + + | +
| 110 | ++ |
+ # Normalize the parameters+ |
+
| 111 | +! | +
+ if (inherits(dat, "data_extract_spec")) dat <- list(dat)+ |
+
| 112 | +! | +
+ if (inherits(ggplot2_args, "ggplot2_args")) ggplot2_args <- list(default = ggplot2_args)+ |
+
| 113 | ++ | + + | +
| 114 | ++ |
+ # Start of assertions+ |
+
| 115 | +! | +
+ checkmate::assert_string(label)+ |
+
| 116 | +! | +
+ checkmate::assert_list(dat, types = "data_extract_spec")+ |
+
| 117 | ++ | + + | +
| 118 | +! | +
+ checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE)+ |
+
| 119 | +! | +
+ checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height")+ |
+
| 120 | +! | +
+ checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE)+ |
+
| 121 | +! | +
+ checkmate::assert_numeric(+ |
+
| 122 | +! | +
+ plot_width[1],+ |
+
| 123 | +! | +
+ lower = plot_width[2], upper = plot_width[3], null.ok = TRUE, .var.name = "plot_width"+ |
+
| 124 | ++ |
+ )+ |
+
| 125 | ++ | + + | +
| 126 | +! | +
+ ggtheme <- match.arg(ggtheme)+ |
+
| 127 | ++ | + + | +
| 128 | +! | +
+ plot_choices <- c("Elbow plot", "Circle plot", "Biplot", "Eigenvector plot")
+ |
+
| 129 | +! | +
+ checkmate::assert_list(ggplot2_args, types = "ggplot2_args")+ |
+
| 130 | +! | +
+ checkmate::assert_subset(names(ggplot2_args), c("default", plot_choices))
+ |
+
| 131 | ++ | + + | +
| 132 | +! | +
+ checkmate::assert_flag(rotate_xaxis_labels)+ |
+
| 133 | ++ | + + | +
| 134 | +! | +
+ if (length(font_size) == 1) {
+ |
+
| 135 | +! | +
+ checkmate::assert_numeric(font_size, any.missing = FALSE, finite = TRUE, lower = 8, upper = 20)+ |
+
| 136 | ++ |
+ } else {
+ |
+
| 137 | +! | +
+ checkmate::assert_numeric(font_size, len = 3, any.missing = FALSE, finite = TRUE, lower = 8, upper = 20)+ |
+
| 138 | +! | +
+ checkmate::assert_numeric(font_size[1], lower = font_size[2], upper = font_size[3], .var.name = "font_size")+ |
+
| 139 | ++ |
+ }+ |
+
| 140 | ++ | + + | +
| 141 | +! | +
+ if (length(alpha) == 1) {
+ |
+
| 142 | +! | +
+ checkmate::assert_numeric(alpha, any.missing = FALSE, finite = TRUE, lower = 0, upper = 1)+ |
+
| 143 | ++ |
+ } else {
+ |
+
| 144 | +! | +
+ checkmate::assert_numeric(alpha, len = 3, any.missing = FALSE, finite = TRUE, lower = 0, upper = 1)+ |
+
| 145 | +! | +
+ checkmate::assert_numeric(alpha[1], lower = alpha[2], upper = alpha[3], .var.name = "alpha")+ |
+
| 146 | ++ |
+ }+ |
+
| 147 | ++ | + + | +
| 148 | +! | +
+ if (length(size) == 1) {
+ |
+
| 149 | +! | +
+ checkmate::assert_numeric(size, any.missing = FALSE, finite = TRUE, lower = 1, upper = 8)+ |
+
| 150 | ++ |
+ } else {
+ |
+
| 151 | +! | +
+ checkmate::assert_numeric(size, len = 3, any.missing = FALSE, finite = TRUE, lower = 1, upper = 8)+ |
+
| 152 | +! | +
+ checkmate::assert_numeric(size[1], lower = size[2], upper = size[3], .var.name = "size")+ |
+
| 153 | ++ |
+ }+ |
+
| 154 | ++ | + + | +
| 155 | +! | +
+ checkmate::assert_multi_class(pre_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
+ |
+
| 156 | +! | +
+ checkmate::assert_multi_class(post_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
+ |
+
| 157 | ++ |
+ # End of assertions+ |
+
| 158 | ++ | + + | +
| 159 | ++ |
+ # Make UI args+ |
+
| 160 | +! | +
+ args <- as.list(environment())+ |
+
| 161 | ++ | + + | +
| 162 | +! | +
+ data_extract_list <- list(dat = dat)+ |
+
| 163 | ++ | + + | +
| 164 | +! | +
+ module(+ |
+
| 165 | +! | +
+ label = label,+ |
+
| 166 | +! | +
+ server = srv_a_pca,+ |
+
| 167 | +! | +
+ ui = ui_a_pca,+ |
+
| 168 | +! | +
+ ui_args = args,+ |
+
| 169 | +! | +
+ server_args = c(+ |
+
| 170 | +! | +
+ data_extract_list,+ |
+
| 171 | +! | +
+ list(+ |
+
| 172 | +! | +
+ plot_height = plot_height,+ |
+
| 173 | +! | +
+ plot_width = plot_width,+ |
+
| 174 | +! | +
+ ggplot2_args = ggplot2_args+ |
+
| 175 | ++ |
+ )+ |
+
| 176 | ++ |
+ ),+ |
+
| 177 | +! | +
+ datanames = teal.transform::get_extract_datanames(data_extract_list)+ |
+
| 178 | ++ |
+ )+ |
+
| 179 | ++ |
+ }+ |
+
| 180 | ++ | + + | +
| 181 | ++ |
+ # UI function for the PCA module+ |
+
| 182 | ++ |
+ ui_a_pca <- function(id, ...) {
+ |
+
| 183 | +! | +
+ ns <- NS(id)+ |
+
| 184 | +! | +
+ args <- list(...)+ |
+
| 185 | +! | +
+ is_single_dataset_value <- teal.transform::is_single_dataset(args$dat)+ |
+
| 186 | ++ | + + | +
| 187 | +! | +
+ color_selector <- args$dat+ |
+
| 188 | +! | +
+ for (i in seq_along(color_selector)) {
+ |
+
| 189 | +! | +
+ color_selector[[i]]$select$multiple <- FALSE+ |
+
| 190 | +! | +
+ color_selector[[i]]$select$always_selected <- NULL+ |
+
| 191 | +! | +
+ color_selector[[i]]$select$selected <- NULL+ |
+
| 192 | ++ |
+ }+ |
+
| 193 | ++ | + + | +
| 194 | +! | +
+ shiny::tagList(+ |
+
| 195 | +! | +
+ include_css_files("custom"),
+ |
+
| 196 | +! | +
+ teal.widgets::standard_layout(+ |
+
| 197 | +! | +
+ output = teal.widgets::white_small_well(+ |
+
| 198 | +! | +
+ uiOutput(ns("all_plots"))
+ |
+
| 199 | ++ |
+ ),+ |
+
| 200 | +! | +
+ encoding = div(+ |
+
| 201 | ++ |
+ ### Reporter+ |
+
| 202 | +! | +
+ teal.reporter::simple_reporter_ui(ns("simple_reporter")),
+ |
+
| 203 | ++ |
+ ###+ |
+
| 204 | +! | +
+ tags$label("Encodings", class = "text-primary"),
+ |
+
| 205 | +! | +
+ teal.transform::datanames_input(args["dat"]),+ |
+
| 206 | +! | +
+ teal.transform::data_extract_ui(+ |
+
| 207 | +! | +
+ id = ns("dat"),
+ |
+
| 208 | +! | +
+ label = "Data selection",+ |
+
| 209 | +! | +
+ data_extract_spec = args$dat,+ |
+
| 210 | +! | +
+ is_single_dataset = is_single_dataset_value+ |
+
| 211 | ++ |
+ ),+ |
+
| 212 | +! | +
+ teal.widgets::panel_group(+ |
+
| 213 | +! | +
+ teal.widgets::panel_item(+ |
+
| 214 | +! | +
+ title = "Display",+ |
+
| 215 | +! | +
+ collapsed = FALSE,+ |
+
| 216 | +! | +
+ checkboxGroupInput(+ |
+
| 217 | +! | +
+ ns("tables_display"),
+ |
+
| 218 | +! | +
+ "Tables display",+ |
+
| 219 | +! | +
+ choices = c("PC importance" = "importance", "Eigenvectors" = "eigenvector"),
+ |
+
| 220 | +! | +
+ selected = c("importance", "eigenvector")
+ |
+
| 221 | ++ |
+ ),+ |
+
| 222 | +! | +
+ radioButtons(+ |
+
| 223 | +! | +
+ ns("plot_type"),
+ |
+
| 224 | +! | +
+ label = "Plot type",+ |
+
| 225 | +! | +
+ choices = args$plot_choices,+ |
+
| 226 | +! | +
+ selected = args$plot_choices[1]+ |
+
| 227 | ++ |
+ )+ |
+
| 228 | ++ |
+ ),+ |
+
| 229 | +! | +
+ teal.widgets::panel_item(+ |
+
| 230 | +! | +
+ title = "Pre-processing",+ |
+
| 231 | +! | +
+ radioButtons(+ |
+
| 232 | +! | +
+ ns("standardization"), "Standardization",
+ |
+
| 233 | +! | +
+ choices = c("None" = "none", "Center" = "center", "Center & Scale" = "center_scale"),
+ |
+
| 234 | +! | +
+ selected = "center_scale"+ |
+
| 235 | ++ |
+ ),+ |
+
| 236 | +! | +
+ radioButtons(+ |
+
| 237 | +! | +
+ ns("na_action"), "NA action",
+ |
+
| 238 | +! | +
+ choices = c("None" = "none", "Drop" = "drop"),
+ |
+
| 239 | +! | +
+ selected = "none"+ |
+
| 240 | ++ |
+ )+ |
+
| 241 | ++ |
+ ),+ |
+
| 242 | +! | +
+ teal.widgets::panel_item(+ |
+
| 243 | +! | +
+ title = "Selected plot specific settings",+ |
+
| 244 | +! | +
+ collapsed = FALSE,+ |
+
| 245 | +! | +
+ uiOutput(ns("plot_settings")),
+ |
+
| 246 | +! | +
+ conditionalPanel(+ |
+
| 247 | +! | +
+ condition = sprintf("input['%s'] == 'Biplot'", ns("plot_type")),
+ |
+
| 248 | +! | +
+ list(+ |
+
| 249 | +! | +
+ teal.transform::data_extract_ui(+ |
+
| 250 | +! | +
+ id = ns("response"),
+ |
+
| 251 | +! | +
+ label = "Color by",+ |
+
| 252 | +! | +
+ data_extract_spec = color_selector,+ |
+
| 253 | +! | +
+ is_single_dataset = is_single_dataset_value+ |
+
| 254 | ++ |
+ ),+ |
+
| 255 | +! | +
+ teal.widgets::optionalSliderInputValMinMax(ns("alpha"), "Opacity:", args$alpha, ticks = FALSE),
+ |
+
| 256 | +! | +
+ teal.widgets::optionalSliderInputValMinMax(ns("size"), "Points size:", args$size, ticks = FALSE)
+ |
+
| 257 | ++ |
+ )+ |
+
| 258 | ++ |
+ )+ |
+
| 259 | ++ |
+ ),+ |
+
| 260 | +! | +
+ teal.widgets::panel_item(+ |
+
| 261 | +! | +
+ title = "Plot settings",+ |
+
| 262 | +! | +
+ collapsed = TRUE,+ |
+
| 263 | +! | +
+ conditionalPanel(+ |
+
| 264 | +! | +
+ condition = sprintf(+ |
+
| 265 | +! | +
+ "input['%s'] == 'Elbow Plot' || input['%s'] == 'Eigenvector plot'",+ |
+
| 266 | +! | +
+ ns("plot_type"),
+ |
+
| 267 | +! | +
+ ns("plot_type")
+ |
+
| 268 | ++ |
+ ),+ |
+
| 269 | +! | +
+ list(checkboxInput(ns("rotate_xaxis_labels"), "Rotate X axis labels", value = args$rotate_xaxis_labels))
+ |
+
| 270 | ++ |
+ ),+ |
+
| 271 | +! | +
+ selectInput(+ |
+
| 272 | +! | +
+ inputId = ns("ggtheme"),
+ |
+
| 273 | +! | +
+ label = "Theme (by ggplot):",+ |
+
| 274 | +! | +
+ choices = ggplot_themes,+ |
+
| 275 | +! | +
+ selected = args$ggtheme,+ |
+
| 276 | +! | +
+ multiple = FALSE+ |
+
| 277 | ++ |
+ ),+ |
+
| 278 | +! | +
+ teal.widgets::optionalSliderInputValMinMax(ns("font_size"), "Font Size", args$font_size, ticks = FALSE)
+ |
+
| 279 | ++ |
+ )+ |
+
| 280 | ++ |
+ )+ |
+
| 281 | ++ |
+ ),+ |
+
| 282 | +! | +
+ forms = tagList(+ |
+
| 283 | +! | +
+ teal.widgets::verbatim_popup_ui(ns("warning"), "Show Warnings"),
+ |
+
| 284 | +! | +
+ teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code")
+ |
+
| 285 | ++ |
+ ),+ |
+
| 286 | +! | +
+ pre_output = args$pre_output,+ |
+
| 287 | +! | +
+ post_output = args$post_output+ |
+
| 288 | ++ |
+ )+ |
+
| 289 | ++ |
+ )+ |
+
| 290 | ++ |
+ }+ |
+
| 291 | ++ | + + | +
| 292 | ++ |
+ # Server function for the PCA module+ |
+
| 293 | ++ |
+ srv_a_pca <- function(id, data, reporter, filter_panel_api, dat, plot_height, plot_width, ggplot2_args) {
+ |
+
| 294 | +! | +
+ with_reporter <- !missing(reporter) && inherits(reporter, "Reporter")+ |
+
| 295 | +! | +
+ with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI")+ |
+
| 296 | +! | +
+ checkmate::assert_class(data, "reactive")+ |
+
| 297 | +! | +
+ checkmate::assert_class(isolate(data()), "teal_data")+ |
+
| 298 | +! | +
+ moduleServer(id, function(input, output, session) {
+ |
+
| 299 | +! | +
+ response <- dat+ |
+
| 300 | ++ | + + | +
| 301 | +! | +
+ for (i in seq_along(response)) {
+ |
+
| 302 | +! | +
+ response[[i]]$select$multiple <- FALSE+ |
+
| 303 | +! | +
+ response[[i]]$select$always_selected <- NULL+ |
+
| 304 | +! | +
+ response[[i]]$select$selected <- NULL+ |
+
| 305 | +! | +
+ all_cols <- teal.data::col_labels(isolate(data())[[response[[i]]$dataname]])+ |
+
| 306 | +! | +
+ ignore_cols <- unlist(teal.data::join_keys(isolate(data()))[[response[[i]]$dataname]])+ |
+
| 307 | +! | +
+ color_cols <- all_cols[!names(all_cols) %in% ignore_cols]+ |
+
| 308 | +! | +
+ response[[i]]$select$choices <- choices_labeled(names(color_cols), color_cols)+ |
+
| 309 | ++ |
+ }+ |
+
| 310 | ++ | + + | +
| 311 | +! | +
+ selector_list <- teal.transform::data_extract_multiple_srv(+ |
+
| 312 | +! | +
+ data_extract = list(dat = dat, response = response),+ |
+
| 313 | +! | +
+ datasets = data,+ |
+
| 314 | +! | +
+ select_validation_rule = list(+ |
+
| 315 | +! | +
+ dat = ~ if (length(.) < 2L) "Please select more than 1 variable to perform PCA.",+ |
+
| 316 | +! | +
+ response = shinyvalidate::compose_rules(+ |
+
| 317 | +! | +
+ shinyvalidate::sv_optional(),+ |
+
| 318 | +! | +
+ ~ if (isTRUE(is.element(., selector_list()$dat()$select))) {
+ |
+
| 319 | +! | +
+ "Response must not have been used for PCA."+ |
+
| 320 | ++ |
+ }+ |
+
| 321 | ++ |
+ )+ |
+
| 322 | ++ |
+ )+ |
+
| 323 | ++ |
+ )+ |
+
| 324 | ++ | + + | +
| 325 | +! | +
+ iv_r <- reactive({
+ |
+
| 326 | +! | +
+ iv <- shinyvalidate::InputValidator$new()+ |
+
| 327 | +! | +
+ teal.transform::compose_and_enable_validators(iv, selector_list)+ |
+
| 328 | ++ |
+ })+ |
+
| 329 | ++ | + + | +
| 330 | +! | +
+ iv_extra <- shinyvalidate::InputValidator$new()+ |
+
| 331 | +! | +
+ iv_extra$add_rule("x_axis", function(value) {
+ |
+
| 332 | +! | +
+ if (isTRUE(input$plot_type %in% c("Circle plot", "Biplot"))) {
+ |
+
| 333 | +! | +
+ if (!shinyvalidate::input_provided(value)) {
+ |
+
| 334 | +! | +
+ "Need X axis"+ |
+
| 335 | ++ |
+ }+ |
+
| 336 | ++ |
+ }+ |
+
| 337 | ++ |
+ })+ |
+
| 338 | +! | +
+ iv_extra$add_rule("y_axis", function(value) {
+ |
+
| 339 | +! | +
+ if (isTRUE(input$plot_type %in% c("Circle plot", "Biplot"))) {
+ |
+
| 340 | +! | +
+ if (!shinyvalidate::input_provided(value)) {
+ |
+
| 341 | +! | +
+ "Need Y axis"+ |
+
| 342 | ++ |
+ }+ |
+
| 343 | ++ |
+ }+ |
+
| 344 | ++ |
+ })+ |
+
| 345 | +! | +
+ rule_dupl <- function(...) {
+ |
+
| 346 | +! | +
+ if (isTRUE(input$plot_type %in% c("Circle plot", "Biplot"))) {
+ |
+
| 347 | +! | +
+ if (isTRUE(input$x_axis == input$y_axis)) {
+ |
+
| 348 | +! | +
+ "Please choose different X and Y axes."+ |
+
| 349 | ++ |
+ }+ |
+
| 350 | ++ |
+ }+ |
+
| 351 | ++ |
+ }+ |
+
| 352 | +! | +
+ iv_extra$add_rule("x_axis", rule_dupl)
+ |
+
| 353 | +! | +
+ iv_extra$add_rule("y_axis", rule_dupl)
+ |
+
| 354 | +! | +
+ iv_extra$add_rule("variables", function(value) {
+ |
+
| 355 | +! | +
+ if (identical(input$plot_type, "Circle plot")) {
+ |
+
| 356 | +! | +
+ if (!shinyvalidate::input_provided(value)) {
+ |
+
| 357 | +! | +
+ "Need Original Coordinates"+ |
+
| 358 | ++ |
+ }+ |
+
| 359 | ++ |
+ }+ |
+
| 360 | ++ |
+ })+ |
+
| 361 | +! | +
+ iv_extra$add_rule("pc", function(value) {
+ |
+
| 362 | +! | +
+ if (identical(input$plot_type, "Eigenvector plot")) {
+ |
+
| 363 | +! | +
+ if (!shinyvalidate::input_provided(value)) {
+ |
+
| 364 | +! | +
+ "Need PC"+ |
+
| 365 | ++ |
+ }+ |
+
| 366 | ++ |
+ }+ |
+
| 367 | ++ |
+ })+ |
+
| 368 | +! | +
+ iv_extra$enable()+ |
+
| 369 | ++ | + + | +
| 370 | +! | +
+ anl_merged_input <- teal.transform::merge_expression_srv(+ |
+
| 371 | +! | +
+ selector_list = selector_list,+ |
+
| 372 | +! | +
+ datasets = data+ |
+
| 373 | ++ |
+ )+ |
+
| 374 | ++ | + + | +
| 375 | +! | +
+ anl_merged_q <- reactive({
+ |
+
| 376 | +! | +
+ req(anl_merged_input())+ |
+
| 377 | +! | +
+ data() %>%+ |
+
| 378 | +! | +
+ teal.code::eval_code(as.expression(anl_merged_input()$expr))+ |
+
| 379 | ++ |
+ })+ |
+
| 380 | ++ | + + | +
| 381 | +! | +
+ merged <- list(+ |
+
| 382 | +! | +
+ anl_input_r = anl_merged_input,+ |
+
| 383 | +! | +
+ anl_q_r = anl_merged_q+ |
+
| 384 | ++ |
+ )+ |
+
| 385 | ++ | + + | +
| 386 | +! | +
+ validation <- reactive({
+ |
+
| 387 | +! | +
+ req(merged$anl_q_r())+ |
+
| 388 | ++ |
+ # inputs+ |
+
| 389 | +! | +
+ keep_cols <- as.character(merged$anl_input_r()$columns_source$dat)+ |
+
| 390 | +! | +
+ na_action <- input$na_action+ |
+
| 391 | +! | +
+ standardization <- input$standardization+ |
+
| 392 | +! | +
+ center <- standardization %in% c("center", "center_scale")
+ |
+
| 393 | +! | +
+ scale <- standardization == "center_scale"+ |
+
| 394 | +! | +
+ ANL <- merged$anl_q_r()[["ANL"]]+ |
+
| 395 | ++ | + + | +
| 396 | +! | +
+ teal::validate_has_data(ANL, 10)+ |
+
| 397 | +! | +
+ validate(need(+ |
+
| 398 | +! | +
+ na_action != "none" | !anyNA(ANL[keep_cols]),+ |
+
| 399 | +! | +
+ paste(+ |
+
| 400 | +! | +
+ "There are NAs in the dataset. Please deal with them in preprocessing",+ |
+
| 401 | +! | +
+ "or select \"Drop\" in the NA actions inside the encodings panel (left)."+ |
+
| 402 | ++ |
+ )+ |
+
| 403 | ++ |
+ ))+ |
+
| 404 | +! | +
+ if (scale) {
+ |
+
| 405 | +! | +
+ not_single <- vapply(ANL[keep_cols], function(column) length(unique(column)) != 1, FUN.VALUE = logical(1))+ |
+
| 406 | ++ | + + | +
| 407 | +! | +
+ msg <- paste0(+ |
+
| 408 | +! | +
+ "You have selected `Center & Scale` under `Standardization` in the `Pre-processing` panel, ",+ |
+
| 409 | +! | +
+ "but one or more of your columns has/have a variance value of zero, indicating all values are identical"+ |
+
| 410 | ++ |
+ )+ |
+
| 411 | +! | +
+ validate(need(all(not_single), msg))+ |
+
| 412 | ++ |
+ }+ |
+
| 413 | ++ |
+ })+ |
+
| 414 | ++ | + + | +
| 415 | ++ |
+ # computation ----+ |
+
| 416 | +! | +
+ computation <- reactive({
+ |
+
| 417 | +! | +
+ validation()+ |
+
| 418 | ++ | + + | +
| 419 | ++ |
+ # inputs+ |
+
| 420 | +! | +
+ keep_cols <- as.character(merged$anl_input_r()$columns_source$dat)+ |
+
| 421 | +! | +
+ na_action <- input$na_action+ |
+
| 422 | +! | +
+ standardization <- input$standardization+ |
+
| 423 | +! | +
+ center <- standardization %in% c("center", "center_scale")
+ |
+
| 424 | +! | +
+ scale <- standardization == "center_scale"+ |
+
| 425 | +! | +
+ ANL <- merged$anl_q_r()[["ANL"]]+ |
+
| 426 | ++ | + + | +
| 427 | +! | +
+ qenv <- teal.code::eval_code(+ |
+
| 428 | +! | +
+ merged$anl_q_r(),+ |
+
| 429 | +! | +
+ substitute(+ |
+
| 430 | +! | +
+ expr = keep_columns <- keep_cols,+ |
+
| 431 | +! | +
+ env = list(keep_cols = keep_cols)+ |
+
| 432 | ++ |
+ )+ |
+
| 433 | ++ |
+ )+ |
+
| 434 | ++ | + + | +
| 435 | +! | +
+ if (na_action == "drop") {
+ |
+
| 436 | +! | +
+ qenv <- teal.code::eval_code(+ |
+
| 437 | +! | +
+ qenv,+ |
+
| 438 | +! | +
+ quote(ANL <- tidyr::drop_na(ANL, keep_columns))+ |
+
| 439 | ++ |
+ )+ |
+
| 440 | ++ |
+ }+ |
+
| 441 | ++ | + + | +
| 442 | +! | +
+ qenv <- teal.code::eval_code(+ |
+
| 443 | +! | +
+ qenv,+ |
+
| 444 | +! | +
+ substitute(+ |
+
| 445 | +! | +
+ expr = pca <- summary(stats::prcomp(ANL[keep_columns], center = center, scale. = scale, retx = TRUE)),+ |
+
| 446 | +! | +
+ env = list(center = center, scale = scale)+ |
+
| 447 | ++ |
+ )+ |
+
| 448 | ++ |
+ )+ |
+
| 449 | ++ | + + | +
| 450 | +! | +
+ qenv <- teal.code::eval_code(+ |
+
| 451 | +! | +
+ qenv,+ |
+
| 452 | +! | +
+ quote({
+ |
+
| 453 | +! | +
+ tbl_importance <- dplyr::as_tibble(pca$importance, rownames = "Metric")+ |
+
| 454 | +! | +
+ tbl_importance+ |
+
| 455 | ++ |
+ })+ |
+
| 456 | ++ |
+ )+ |
+
| 457 | ++ | + + | +
| 458 | +! | +
+ teal.code::eval_code(+ |
+
| 459 | +! | +
+ qenv,+ |
+
| 460 | +! | +
+ quote({
+ |
+
| 461 | +! | +
+ tbl_eigenvector <- dplyr::as_tibble(pca$rotation, rownames = "Variable")+ |
+
| 462 | +! | +
+ tbl_eigenvector+ |
+
| 463 | ++ |
+ })+ |
+
| 464 | ++ |
+ )+ |
+
| 465 | ++ |
+ })+ |
+
| 466 | ++ | + + | +
| 467 | ++ |
+ # plot args ----+ |
+
| 468 | +! | +
+ output$plot_settings <- renderUI({
+ |
+
| 469 | ++ |
+ # reactivity triggers+ |
+
| 470 | +! | +
+ req(iv_r()$is_valid())+ |
+
| 471 | +! | +
+ req(computation())+ |
+
| 472 | +! | +
+ qenv <- computation()+ |
+
| 473 | ++ | + + | +
| 474 | +! | +
+ ns <- session$ns+ |
+
| 475 | ++ | + + | +
| 476 | +! | +
+ pca <- qenv[["pca"]]+ |
+
| 477 | +! | +
+ chcs_pcs <- colnames(pca$rotation)+ |
+
| 478 | +! | +
+ chcs_vars <- qenv[["keep_columns"]]+ |
+
| 479 | ++ | + + | +
| 480 | +! | +
+ tagList(+ |
+
| 481 | +! | +
+ conditionalPanel(+ |
+
| 482 | +! | +
+ condition = sprintf(+ |
+
| 483 | +! | +
+ "input['%s'] == 'Biplot' || input['%s'] == 'Circle plot'",+ |
+
| 484 | +! | +
+ ns("plot_type"), ns("plot_type")
+ |
+
| 485 | ++ |
+ ),+ |
+
| 486 | +! | +
+ list(+ |
+
| 487 | +! | +
+ teal.widgets::optionalSelectInput(ns("x_axis"), "X axis", choices = chcs_pcs, selected = chcs_pcs[1]),
+ |
+
| 488 | +! | +
+ teal.widgets::optionalSelectInput(ns("y_axis"), "Y axis", choices = chcs_pcs, selected = chcs_pcs[2]),
+ |
+
| 489 | +! | +
+ teal.widgets::optionalSelectInput(+ |
+
| 490 | +! | +
+ ns("variables"), "Original coordinates",
+ |
+
| 491 | +! | +
+ choices = chcs_vars, selected = chcs_vars,+ |
+
| 492 | +! | +
+ multiple = TRUE+ |
+
| 493 | ++ |
+ )+ |
+
| 494 | ++ |
+ )+ |
+
| 495 | ++ |
+ ),+ |
+
| 496 | +! | +
+ conditionalPanel(+ |
+
| 497 | +! | +
+ condition = sprintf("input['%s'] == 'Elbow plot'", ns("plot_type")),
+ |
+
| 498 | +! | +
+ helpText("No plot specific settings available.")
+ |
+
| 499 | ++ |
+ ),+ |
+
| 500 | +! | +
+ conditionalPanel(+ |
+
| 501 | +! | +
+ condition = paste0("input['", ns("plot_type"), "'] == 'Eigenvector plot'"),
+ |
+
| 502 | +! | +
+ teal.widgets::optionalSelectInput(ns("pc"), "PC", choices = chcs_pcs, selected = chcs_pcs[1])
+ |
+
| 503 | ++ |
+ )+ |
+
| 504 | ++ |
+ )+ |
+
| 505 | ++ |
+ })+ |
+
| 506 | ++ | + + | +
| 507 | ++ |
+ # plot elbow ----+ |
+
| 508 | +! | +
+ plot_elbow <- function(base_q) {
+ |
+
| 509 | +! | +
+ ggtheme <- input$ggtheme+ |
+
| 510 | +! | +
+ rotate_xaxis_labels <- input$rotate_xaxis_labels+ |
+
| 511 | +! | +
+ font_size <- input$font_size+ |
+
| 512 | ++ | + + | +
| 513 | +! | +
+ angle_value <- ifelse(isTRUE(rotate_xaxis_labels), 45, 0)+ |
+
| 514 | +! | +
+ hjust_value <- ifelse(isTRUE(rotate_xaxis_labels), 1, 0.5)+ |
+
| 515 | ++ | + + | +
| 516 | +! | +
+ dev_ggplot2_args <- teal.widgets::ggplot2_args(+ |
+
| 517 | +! | +
+ labs = list(x = "Principal component", y = "Proportion of variance explained", color = "", fill = "Legend"),+ |
+
| 518 | +! | +
+ theme = list(+ |
+
| 519 | +! | +
+ legend.position = "right",+ |
+
| 520 | +! | +
+ legend.spacing.y = quote(grid::unit(-5, "pt")),+ |
+
| 521 | +! | +
+ legend.title = quote(element_text(vjust = 25)),+ |
+
| 522 | +! | +
+ axis.text.x = substitute(+ |
+
| 523 | +! | +
+ element_text(angle = angle_value, hjust = hjust_value),+ |
+
| 524 | +! | +
+ list(angle_value = angle_value, hjust_value = hjust_value)+ |
+
| 525 | ++ |
+ ),+ |
+
| 526 | +! | +
+ text = substitute(element_text(size = font_size), list(font_size = font_size))+ |
+
| 527 | ++ |
+ )+ |
+
| 528 | ++ |
+ )+ |
+
| 529 | ++ | + + | +
| 530 | +! | +
+ parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(+ |
+
| 531 | +! | +
+ teal.widgets::resolve_ggplot2_args(+ |
+
| 532 | +! | +
+ user_plot = ggplot2_args[["Elbow plot"]],+ |
+
| 533 | +! | +
+ user_default = ggplot2_args$default,+ |
+
| 534 | +! | +
+ module_plot = dev_ggplot2_args+ |
+
| 535 | ++ |
+ ),+ |
+
| 536 | +! | +
+ ggtheme = ggtheme+ |
+
| 537 | ++ |
+ )+ |
+
| 538 | ++ | + + | +
| 539 | +! | +
+ teal.code::eval_code(+ |
+
| 540 | +! | +
+ base_q,+ |
+
| 541 | +! | +
+ substitute(+ |
+
| 542 | +! | +
+ expr = {
+ |
+
| 543 | +! | +
+ elb_dat <- pca$importance[c("Proportion of Variance", "Cumulative Proportion"), ] %>%
+ |
+
| 544 | +! | +
+ dplyr::as_tibble(rownames = "metric") %>%+ |
+
| 545 | +! | +
+ tidyr::gather("component", "value", -metric) %>%
+ |
+
| 546 | +! | +
+ dplyr::mutate(+ |
+
| 547 | +! | +
+ component = factor(component, levels = unique(stringr::str_sort(component, numeric = TRUE)))+ |
+
| 548 | ++ |
+ )+ |
+
| 549 | ++ | + + | +
| 550 | +! | +
+ cols <- c(getOption("ggplot2.discrete.colour"), c("lightblue", "darkred", "black"))[1:3]
+ |
+
| 551 | +! | +
+ g <- ggplot(mapping = aes_string(x = "component", y = "value")) ++ |
+
| 552 | +! | +
+ geom_bar(+ |
+
| 553 | +! | +
+ aes(fill = "Single variance"),+ |
+
| 554 | +! | +
+ data = dplyr::filter(elb_dat, metric == "Proportion of Variance"),+ |
+
| 555 | +! | +
+ color = "black",+ |
+
| 556 | +! | +
+ stat = "identity"+ |
+
| 557 | ++ |
+ ) ++ |
+
| 558 | +! | +
+ geom_point(+ |
+
| 559 | +! | +
+ aes(color = "Cumulative variance"),+ |
+
| 560 | +! | +
+ data = dplyr::filter(elb_dat, metric == "Cumulative Proportion")+ |
+
| 561 | ++ |
+ ) ++ |
+
| 562 | +! | +
+ geom_line(+ |
+
| 563 | +! | +
+ aes(group = 1, color = "Cumulative variance"),+ |
+
| 564 | +! | +
+ data = dplyr::filter(elb_dat, metric == "Cumulative Proportion")+ |
+
| 565 | ++ |
+ ) ++ |
+
| 566 | +! | +
+ labs ++ |
+
| 567 | +! | +
+ scale_color_manual(values = c("Cumulative variance" = cols[2], "Single variance" = cols[3])) +
+ |
+
| 568 | +! | +
+ scale_fill_manual(values = c("Cumulative variance" = cols[2], "Single variance" = cols[1])) +
+ |
+
| 569 | +! | +
+ ggthemes ++ |
+
| 570 | +! | +
+ themes+ |
+
| 571 | ++ | + + | +
| 572 | +! | +
+ print(g)+ |
+
| 573 | ++ |
+ },+ |
+
| 574 | +! | +
+ env = list(+ |
+
| 575 | +! | +
+ ggthemes = parsed_ggplot2_args$ggtheme,+ |
+
| 576 | +! | +
+ labs = parsed_ggplot2_args$labs,+ |
+
| 577 | +! | +
+ themes = parsed_ggplot2_args$theme+ |
+
| 578 | ++ |
+ )+ |
+
| 579 | ++ |
+ )+ |
+
| 580 | ++ |
+ )+ |
+
| 581 | ++ |
+ }+ |
+
| 582 | ++ | + + | +
| 583 | ++ |
+ # plot circle ----+ |
+
| 584 | +! | +
+ plot_circle <- function(base_q) {
+ |
+
| 585 | +! | +
+ x_axis <- input$x_axis+ |
+
| 586 | +! | +
+ y_axis <- input$y_axis+ |
+
| 587 | +! | +
+ variables <- input$variables+ |
+
| 588 | +! | +
+ ggtheme <- input$ggtheme+ |
+
| 589 | ++ | + + | +
| 590 | +! | +
+ rotate_xaxis_labels <- input$rotate_xaxis_labels+ |
+
| 591 | +! | +
+ font_size <- input$font_size+ |
+
| 592 | ++ | + + | +
| 593 | +! | +
+ angle <- ifelse(isTRUE(rotate_xaxis_labels), 45, 0)+ |
+
| 594 | +! | +
+ hjust <- ifelse(isTRUE(rotate_xaxis_labels), 1, 0.5)+ |
+
| 595 | ++ | + + | +
| 596 | +! | +
+ dev_ggplot2_args <- teal.widgets::ggplot2_args(+ |
+
| 597 | +! | +
+ theme = list(+ |
+
| 598 | +! | +
+ text = substitute(element_text(size = font_size), list(font_size = font_size)),+ |
+
| 599 | +! | +
+ axis.text.x = substitute(+ |
+
| 600 | +! | +
+ element_text(angle = angle_val, hjust = hjust_val),+ |
+
| 601 | +! | +
+ list(angle_val = angle, hjust_val = hjust)+ |
+
| 602 | ++ |
+ )+ |
+
| 603 | ++ |
+ )+ |
+
| 604 | ++ |
+ )+ |
+
| 605 | ++ | + + | +
| 606 | +! | +
+ all_ggplot2_args <- teal.widgets::resolve_ggplot2_args(+ |
+
| 607 | +! | +
+ user_plot = ggplot2_args[["Circle plot"]],+ |
+
| 608 | +! | +
+ user_default = ggplot2_args$default,+ |
+
| 609 | +! | +
+ module_plot = dev_ggplot2_args+ |
+
| 610 | ++ |
+ )+ |
+
| 611 | ++ | + + | +
| 612 | +! | +
+ parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(+ |
+
| 613 | +! | +
+ all_ggplot2_args,+ |
+
| 614 | +! | +
+ ggtheme = ggtheme+ |
+
| 615 | ++ |
+ )+ |
+
| 616 | ++ | + + | +
| 617 | +! | +
+ teal.code::eval_code(+ |
+
| 618 | +! | +
+ base_q,+ |
+
| 619 | +! | +
+ substitute(+ |
+
| 620 | +! | +
+ expr = {
+ |
+
| 621 | +! | +
+ pca_rot <- pca$rotation[, c(x_axis, y_axis)] %>%+ |
+
| 622 | +! | +
+ dplyr::as_tibble(rownames = "label") %>%+ |
+
| 623 | +! | +
+ dplyr::filter(label %in% variables)+ |
+
| 624 | ++ | + + | +
| 625 | +! | +
+ circle_data <- data.frame(+ |
+
| 626 | +! | +
+ x = cos(seq(0, 2 * pi, length.out = 100)),+ |
+
| 627 | +! | +
+ y = sin(seq(0, 2 * pi, length.out = 100))+ |
+
| 628 | ++ |
+ )+ |
+
| 629 | ++ | + + | +
| 630 | +! | +
+ g <- ggplot(pca_rot) ++ |
+
| 631 | +! | +
+ geom_point(aes_string(x = x_axis, y = y_axis)) ++ |
+
| 632 | +! | +
+ geom_label(+ |
+
| 633 | +! | +
+ aes_string(x = x_axis, y = y_axis, label = "label"),+ |
+
| 634 | +! | +
+ nudge_x = 0.1, nudge_y = 0.05,+ |
+
| 635 | +! | +
+ fontface = "bold"+ |
+
| 636 | ++ |
+ ) ++ |
+
| 637 | +! | +
+ geom_path(aes(x, y, group = 1), data = circle_data) ++ |
+
| 638 | +! | +
+ geom_point(aes(x = x, y = y), data = data.frame(x = 0, y = 0), shape = "x", size = 5) ++ |
+
| 639 | +! | +
+ labs ++ |
+
| 640 | +! | +
+ ggthemes ++ |
+
| 641 | +! | +
+ themes+ |
+
| 642 | +! | +
+ print(g)+ |
+
| 643 | ++ |
+ },+ |
+
| 644 | +! | +
+ env = list(+ |
+
| 645 | +! | +
+ x_axis = x_axis,+ |
+
| 646 | +! | +
+ y_axis = y_axis,+ |
+
| 647 | +! | +
+ variables = variables,+ |
+
| 648 | +! | +
+ ggthemes = parsed_ggplot2_args$ggtheme,+ |
+
| 649 | +! | +
+ labs = `if`(is.null(parsed_ggplot2_args$labs), quote(labs()), parsed_ggplot2_args$labs),+ |
+
| 650 | +! | +
+ themes = parsed_ggplot2_args$theme+ |
+
| 651 | ++ |
+ )+ |
+
| 652 | ++ |
+ )+ |
+
| 653 | ++ |
+ )+ |
+
| 654 | ++ |
+ }+ |
+
| 655 | ++ | + + | +
| 656 | ++ |
+ # plot biplot ----+ |
+
| 657 | +! | +
+ plot_biplot <- function(base_q) {
+ |
+
| 658 | +! | +
+ qenv <- base_q+ |
+
| 659 | ++ | + + | +
| 660 | +! | +
+ ANL <- qenv[["ANL"]]+ |
+
| 661 | ++ | + + | +
| 662 | +! | +
+ resp_col <- as.character(merged$anl_input_r()$columns_source$response)+ |
+
| 663 | +! | +
+ dat_cols <- as.character(merged$anl_input_r()$columns_source$dat)+ |
+
| 664 | +! | +
+ x_axis <- input$x_axis+ |
+
| 665 | +! | +
+ y_axis <- input$y_axis+ |
+
| 666 | +! | +
+ variables <- input$variables+ |
+
| 667 | +! | +
+ pca <- qenv[["pca"]]+ |
+
| 668 | ++ | + + | +
| 669 | +! | +
+ ggtheme <- input$ggtheme+ |
+
| 670 | ++ | + + | +
| 671 | +! | +
+ rotate_xaxis_labels <- input$rotate_xaxis_labels+ |
+
| 672 | +! | +
+ alpha <- input$alpha+ |
+
| 673 | +! | +
+ size <- input$size+ |
+
| 674 | +! | +
+ font_size <- input$font_size+ |
+
| 675 | ++ | + + | +
| 676 | +! | +
+ qenv <- teal.code::eval_code(+ |
+
| 677 | +! | +
+ qenv,+ |
+
| 678 | +! | +
+ substitute(+ |
+
| 679 | +! | +
+ expr = pca_rot <- dplyr::as_tibble(pca$x[, c(x_axis, y_axis)]),+ |
+
| 680 | +! | +
+ env = list(x_axis = x_axis, y_axis = y_axis)+ |
+
| 681 | ++ |
+ )+ |
+
| 682 | ++ |
+ )+ |
+
| 683 | ++ | + + | +
| 684 | ++ |
+ # rot_vars = data frame that displays arrows in the plot, need to be scaled to data+ |
+
| 685 | +! | +
+ if (!is.null(input$variables)) {
+ |
+
| 686 | +! | +
+ qenv <- teal.code::eval_code(+ |
+
| 687 | +! | +
+ qenv,+ |
+
| 688 | +! | +
+ substitute(+ |
+
| 689 | +! | +
+ expr = {
+ |
+
| 690 | +! | +
+ r <- sqrt(qchisq(0.69, df = 2)) * prod(colMeans(pca_rot ^ 2)) ^ (1 / 4) # styler: off+ |
+
| 691 | +! | +
+ v_scale <- rowSums(pca$rotation ^ 2) # styler: off+ |
+
| 692 | ++ | + + | +
| 693 | +! | +
+ rot_vars <- pca$rotation[, c(x_axis, y_axis)] %>%+ |
+
| 694 | +! | +
+ dplyr::as_tibble(rownames = "label") %>%+ |
+
| 695 | +! | +
+ dplyr::mutate_at(vars(c(x_axis, y_axis)), function(x) r * x / sqrt(max(v_scale)))+ |
+
| 696 | ++ |
+ },+ |
+
| 697 | +! | +
+ env = list(x_axis = x_axis, y_axis = y_axis)+ |
+
| 698 | ++ |
+ )+ |
+
| 699 | ++ |
+ ) %>%+ |
+
| 700 | +! | +
+ teal.code::eval_code(+ |
+
| 701 | +! | +
+ if (is.logical(pca$center) && !pca$center) {
+ |
+
| 702 | +! | +
+ substitute(+ |
+
| 703 | +! | +
+ expr = {
+ |
+
| 704 | +! | +
+ rot_vars <- rot_vars %>%+ |
+
| 705 | +! | +
+ tibble::column_to_rownames("label") %>%
+ |
+
| 706 | +! | +
+ sweep(1, apply(ANL[keep_columns], 2, mean, na.rm = TRUE)) %>%+ |
+
| 707 | +! | +
+ tibble::rownames_to_column("label") %>%
+ |
+
| 708 | +! | +
+ dplyr::mutate(+ |
+
| 709 | +! | +
+ xstart = mean(pca$x[, x_axis], na.rm = TRUE),+ |
+
| 710 | +! | +
+ ystart = mean(pca$x[, y_axis], na.rm = TRUE)+ |
+
| 711 | ++ |
+ )+ |
+
| 712 | ++ |
+ },+ |
+
| 713 | +! | +
+ env = list(x_axis = x_axis, y_axis = y_axis)+ |
+
| 714 | ++ |
+ )+ |
+
| 715 | ++ |
+ } else {
+ |
+
| 716 | +! | +
+ quote(rot_vars <- rot_vars %>% dplyr::mutate(xstart = 0, ystart = 0))+ |
+
| 717 | ++ |
+ }+ |
+
| 718 | ++ |
+ ) %>%+ |
+
| 719 | +! | +
+ teal.code::eval_code(+ |
+
| 720 | +! | +
+ substitute(+ |
+
| 721 | +! | +
+ expr = rot_vars <- rot_vars %>% dplyr::filter(label %in% variables),+ |
+
| 722 | +! | +
+ env = list(variables = variables)+ |
+
| 723 | ++ |
+ )+ |
+
| 724 | ++ |
+ )+ |
+
| 725 | ++ |
+ }+ |
+
| 726 | ++ | + + | +
| 727 | +! | +
+ pca_plot_biplot_expr <- list(quote(ggplot()))+ |
+
| 728 | ++ | + + | +
| 729 | +! | +
+ if (length(resp_col) == 0) {
+ |
+
| 730 | +! | +
+ pca_plot_biplot_expr <- c(+ |
+
| 731 | +! | +
+ pca_plot_biplot_expr,+ |
+
| 732 | +! | +
+ substitute(+ |
+
| 733 | +! | +
+ geom_point(aes_string(x = x_axis, y = y_axis), data = pca_rot, alpha = alpha, size = size),+ |
+
| 734 | +! | +
+ list(x_axis = input$x_axis, y_axis = input$y_axis, alpha = input$alpha, size = input$size)+ |
+
| 735 | ++ |
+ )+ |
+
| 736 | ++ |
+ )+ |
+
| 737 | +! | +
+ dev_labs <- list()+ |
+
| 738 | ++ |
+ } else {
+ |
+
| 739 | +! | +
+ rp_keys <- setdiff(colnames(ANL), as.character(unlist(merged$anl_input_r()$columns_source)))+ |
+
| 740 | ++ | + + | +
| 741 | +! | +
+ response <- ANL[[resp_col]]+ |
+
| 742 | ++ | + + | +
| 743 | +! | +
+ aes_biplot <- substitute(+ |
+
| 744 | +! | +
+ aes_string(x = x_axis, y = y_axis, color = "response"),+ |
+
| 745 | +! | +
+ env = list(x_axis = x_axis, y_axis = y_axis)+ |
+
| 746 | ++ |
+ )+ |
+
| 747 | ++ | + + | +
| 748 | +! | +
+ qenv <- teal.code::eval_code(+ |
+
| 749 | +! | +
+ qenv,+ |
+
| 750 | +! | +
+ substitute(response <- ANL[[resp_col]], env = list(resp_col = resp_col))+ |
+
| 751 | ++ |
+ )+ |
+
| 752 | ++ | + + | +
| 753 | +! | +
+ dev_labs <- list(color = varname_w_label(resp_col, ANL))+ |
+
| 754 | ++ | + + | +
| 755 | +! | +
+ scales_biplot <-+ |
+
| 756 | +! | +
+ if (is.character(response) || is.factor(response) || (is.numeric(response) && length(unique(response)) <= 6)) { # nolint: line_length.
+ |
+
| 757 | +! | +
+ qenv <- teal.code::eval_code(+ |
+
| 758 | +! | +
+ qenv,+ |
+
| 759 | +! | +
+ quote(pca_rot$response <- as.factor(response))+ |
+
| 760 | ++ |
+ )+ |
+
| 761 | +! | +
+ quote(scale_color_brewer(palette = "Dark2"))+ |
+
| 762 | +! | +
+ } else if (inherits(response, "Date")) {
+ |
+
| 763 | +! | +
+ qenv <- teal.code::eval_code(+ |
+
| 764 | +! | +
+ qenv,+ |
+
| 765 | +! | +
+ quote(pca_rot$response <- numeric(response))+ |
+
| 766 | ++ |
+ )+ |
+
| 767 | ++ | + + | +
| 768 | +! | +
+ quote(+ |
+
| 769 | +! | +
+ scale_color_gradient(+ |
+
| 770 | +! | +
+ low = c(getOption("ggplot2.discrete.colour")[2], "darkred")[1],
+ |
+
| 771 | +! | +
+ high = c(getOption("ggplot2.discrete.colour"), "lightblue")[1],
+ |
+
| 772 | +! | +
+ labels = function(x) as.Date(x, origin = "1970-01-01")+ |
+
| 773 | ++ |
+ )+ |
+
| 774 | ++ |
+ )+ |
+
| 775 | ++ |
+ } else {
+ |
+
| 776 | +! | +
+ qenv <- teal.code::eval_code(+ |
+
| 777 | +! | +
+ qenv,+ |
+
| 778 | +! | +
+ quote(pca_rot$response <- response)+ |
+
| 779 | ++ |
+ )+ |
+
| 780 | +! | +
+ quote(scale_color_gradient(+ |
+
| 781 | +! | +
+ low = c(getOption("ggplot2.discrete.colour")[2], "darkred")[1],
+ |
+
| 782 | +! | +
+ high = c(getOption("ggplot2.discrete.colour"), "lightblue")[1]
+ |
+
| 783 | ++ |
+ ))+ |
+
| 784 | ++ |
+ }+ |
+
| 785 | ++ | + + | +
| 786 | +! | +
+ pca_plot_biplot_expr <- c(+ |
+
| 787 | +! | +
+ pca_plot_biplot_expr,+ |
+
| 788 | +! | +
+ substitute(+ |
+
| 789 | +! | +
+ geom_point(aes_biplot, data = pca_rot, alpha = alpha, size = size),+ |
+
| 790 | +! | +
+ env = list(aes_biplot = aes_biplot, alpha = alpha, size = size)+ |
+
| 791 | ++ |
+ ),+ |
+
| 792 | +! | +
+ scales_biplot+ |
+
| 793 | ++ |
+ )+ |
+
| 794 | ++ |
+ }+ |
+
| 795 | ++ | + + | +
| 796 | +! | +
+ if (!is.null(input$variables)) {
+ |
+
| 797 | +! | +
+ pca_plot_biplot_expr <- c(+ |
+
| 798 | +! | +
+ pca_plot_biplot_expr,+ |
+
| 799 | +! | +
+ substitute(+ |
+
| 800 | +! | +
+ geom_segment(+ |
+
| 801 | +! | +
+ aes_string(x = "xstart", y = "ystart", xend = x_axis, yend = y_axis),+ |
+
| 802 | +! | +
+ data = rot_vars,+ |
+
| 803 | +! | +
+ lineend = "round", linejoin = "round",+ |
+
| 804 | +! | +
+ arrow = grid::arrow(length = grid::unit(0.5, "cm"))+ |
+
| 805 | ++ |
+ ),+ |
+
| 806 | +! | +
+ env = list(x_axis = x_axis, y_axis = y_axis)+ |
+
| 807 | ++ |
+ ),+ |
+
| 808 | +! | +
+ substitute(+ |
+
| 809 | +! | +
+ geom_label(+ |
+
| 810 | +! | +
+ aes_string(+ |
+
| 811 | +! | +
+ x = x_axis,+ |
+
| 812 | +! | +
+ y = y_axis,+ |
+
| 813 | +! | +
+ label = "label"+ |
+
| 814 | ++ |
+ ),+ |
+
| 815 | +! | +
+ data = rot_vars,+ |
+
| 816 | +! | +
+ nudge_y = 0.1,+ |
+
| 817 | +! | +
+ fontface = "bold"+ |
+
| 818 | ++ |
+ ),+ |
+
| 819 | +! | +
+ env = list(x_axis = x_axis, y_axis = y_axis)+ |
+
| 820 | ++ |
+ ),+ |
+
| 821 | +! | +
+ quote(geom_point(aes(x = xstart, y = ystart), data = rot_vars, shape = "x", size = 5))+ |
+
| 822 | ++ |
+ )+ |
+
| 823 | ++ |
+ }+ |
+
| 824 | ++ | + + | +
| 825 | +! | +
+ angle <- ifelse(isTRUE(rotate_xaxis_labels), 45, 0)+ |
+
| 826 | +! | +
+ hjust <- ifelse(isTRUE(rotate_xaxis_labels), 1, 0.5)+ |
+
| 827 | ++ | + + | +
| 828 | +! | +
+ dev_ggplot2_args <- teal.widgets::ggplot2_args(+ |
+
| 829 | +! | +
+ labs = dev_labs,+ |
+
| 830 | +! | +
+ theme = list(+ |
+
| 831 | +! | +
+ text = substitute(element_text(size = font_size), list(font_size = font_size)),+ |
+
| 832 | +! | +
+ axis.text.x = substitute(+ |
+
| 833 | +! | +
+ element_text(angle = angle_val, hjust = hjust_val),+ |
+
| 834 | +! | +
+ list(angle_val = angle, hjust_val = hjust)+ |
+
| 835 | ++ |
+ )+ |
+
| 836 | ++ |
+ )+ |
+
| 837 | ++ |
+ )+ |
+
| 838 | ++ | + + | +
| 839 | +! | +
+ all_ggplot2_args <- teal.widgets::resolve_ggplot2_args(+ |
+
| 840 | +! | +
+ user_plot = ggplot2_args[["Biplot"]],+ |
+
| 841 | +! | +
+ user_default = ggplot2_args$default,+ |
+
| 842 | +! | +
+ module_plot = dev_ggplot2_args+ |
+
| 843 | ++ |
+ )+ |
+
| 844 | ++ | + + | +
| 845 | +! | +
+ parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(+ |
+
| 846 | +! | +
+ all_ggplot2_args,+ |
+
| 847 | +! | +
+ ggtheme = ggtheme+ |
+
| 848 | ++ |
+ )+ |
+
| 849 | ++ | + + | +
| 850 | +! | +
+ pca_plot_biplot_expr <- c(+ |
+
| 851 | +! | +
+ pca_plot_biplot_expr,+ |
+
| 852 | +! | +
+ parsed_ggplot2_args+ |
+
| 853 | ++ |
+ )+ |
+
| 854 | ++ | + + | +
| 855 | +! | +
+ teal.code::eval_code(+ |
+
| 856 | +! | +
+ qenv,+ |
+
| 857 | +! | +
+ substitute(+ |
+
| 858 | +! | +
+ expr = {
+ |
+
| 859 | +! | +
+ g <- plot_call+ |
+
| 860 | +! | +
+ print(g)+ |
+
| 861 | ++ |
+ },+ |
+
| 862 | +! | +
+ env = list(+ |
+
| 863 | +! | +
+ plot_call = Reduce(function(x, y) call("+", x, y), pca_plot_biplot_expr)
+ |
+
| 864 | ++ |
+ )+ |
+
| 865 | ++ |
+ )+ |
+
| 866 | ++ |
+ )+ |
+
| 867 | ++ |
+ }+ |
+
| 868 | ++ | + + | +
| 869 | ++ |
+ # plot pc_var ----+ |
+
| 870 | +! | +
+ plot_pc_var <- function(base_q) {
+ |
+
| 871 | +! | +
+ pc <- input$pc+ |
+
| 872 | +! | +
+ ggtheme <- input$ggtheme+ |
+
| 873 | ++ | + + | +
| 874 | +! | +
+ rotate_xaxis_labels <- input$rotate_xaxis_labels+ |
+
| 875 | +! | +
+ font_size <- input$font_size+ |
+
| 876 | ++ | + + | +
| 877 | +! | +
+ angle <- ifelse(rotate_xaxis_labels, 45, 0)+ |
+
| 878 | +! | +
+ hjust <- ifelse(rotate_xaxis_labels, 1, 0.5)+ |
+
| 879 | ++ | + + | +
| 880 | +! | +
+ dev_ggplot2_args <- teal.widgets::ggplot2_args(+ |
+
| 881 | +! | +
+ theme = list(+ |
+
| 882 | +! | +
+ text = substitute(element_text(size = font_size), list(font_size = font_size)),+ |
+
| 883 | +! | +
+ axis.text.x = substitute(+ |
+
| 884 | +! | +
+ element_text(angle = angle_val, hjust = hjust_val),+ |
+
| 885 | +! | +
+ list(angle_val = angle, hjust_val = hjust)+ |
+
| 886 | ++ |
+ )+ |
+
| 887 | ++ |
+ )+ |
+
| 888 | ++ |
+ )+ |
+
| 889 | ++ | + + | +
| 890 | +! | +
+ all_ggplot2_args <- teal.widgets::resolve_ggplot2_args(+ |
+
| 891 | +! | +
+ user_plot = ggplot2_args[["Eigenvector plot"]],+ |
+
| 892 | +! | +
+ user_default = ggplot2_args$default,+ |
+
| 893 | +! | +
+ module_plot = dev_ggplot2_args+ |
+
| 894 | ++ |
+ )+ |
+
| 895 | ++ | + + | +
| 896 | +! | +
+ parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(+ |
+
| 897 | +! | +
+ all_ggplot2_args,+ |
+
| 898 | +! | +
+ ggtheme = ggtheme+ |
+
| 899 | ++ |
+ )+ |
+
| 900 | ++ | + + | +
| 901 | +! | +
+ ggplot_exprs <- c(+ |
+
| 902 | +! | +
+ list(+ |
+
| 903 | +! | +
+ quote(ggplot(pca_rot)),+ |
+
| 904 | +! | +
+ substitute(+ |
+
| 905 | +! | +
+ geom_bar(+ |
+
| 906 | +! | +
+ aes_string(x = "Variable", y = pc),+ |
+
| 907 | +! | +
+ stat = "identity",+ |
+
| 908 | +! | +
+ color = "black",+ |
+
| 909 | +! | +
+ fill = c(getOption("ggplot2.discrete.colour"), "lightblue")[1]
+ |
+
| 910 | ++ |
+ ),+ |
+
| 911 | +! | +
+ env = list(pc = pc)+ |
+
| 912 | ++ |
+ ),+ |
+
| 913 | +! | +
+ substitute(+ |
+
| 914 | +! | +
+ geom_text(+ |
+
| 915 | +! | +
+ aes(+ |
+
| 916 | +! | +
+ x = Variable,+ |
+
| 917 | +! | +
+ y = pc_name,+ |
+
| 918 | +! | +
+ label = round(pc_name, 3),+ |
+
| 919 | +! | +
+ vjust = ifelse(pc_name > 0, -0.5, 1.3)+ |
+
| 920 | ++ |
+ )+ |
+
| 921 | ++ |
+ ),+ |
+
| 922 | +! | +
+ env = list(pc_name = as.name(pc))+ |
+
| 923 | ++ |
+ )+ |
+
| 924 | ++ |
+ ),+ |
+
| 925 | +! | +
+ parsed_ggplot2_args$labs,+ |
+
| 926 | +! | +
+ parsed_ggplot2_args$ggtheme,+ |
+
| 927 | +! | +
+ parsed_ggplot2_args$theme+ |
+
| 928 | ++ |
+ )+ |
+
| 929 | ++ | + + | +
| 930 | +! | +
+ teal.code::eval_code(+ |
+
| 931 | +! | +
+ base_q,+ |
+
| 932 | +! | +
+ substitute(+ |
+
| 933 | +! | +
+ expr = {
+ |
+
| 934 | +! | +
+ pca_rot <- pca$rotation[, pc, drop = FALSE] %>%+ |
+
| 935 | +! | +
+ dplyr::as_tibble(rownames = "Variable")+ |
+
| 936 | ++ | + + | +
| 937 | +! | +
+ g <- plot_call+ |
+
| 938 | ++ | + + | +
| 939 | +! | +
+ print(g)+ |
+
| 940 | ++ |
+ },+ |
+
| 941 | +! | +
+ env = list(+ |
+
| 942 | +! | +
+ pc = pc,+ |
+
| 943 | +! | +
+ plot_call = Reduce(function(x, y) call("+", x, y), ggplot_exprs)
+ |
+
| 944 | ++ |
+ )+ |
+
| 945 | ++ |
+ )+ |
+
| 946 | ++ |
+ )+ |
+
| 947 | ++ |
+ }+ |
+
| 948 | ++ | + + | +
| 949 | ++ |
+ # plot final ----+ |
+
| 950 | +! | +
+ output_q <- reactive({
+ |
+
| 951 | +! | +
+ req(computation())+ |
+
| 952 | +! | +
+ teal::validate_inputs(iv_r())+ |
+
| 953 | +! | +
+ teal::validate_inputs(iv_extra, header = "Plot settings are required")+ |
+
| 954 | ++ | + + | +
| 955 | +! | +
+ switch(input$plot_type,+ |
+
| 956 | +! | +
+ "Elbow plot" = plot_elbow(computation()),+ |
+
| 957 | +! | +
+ "Circle plot" = plot_circle(computation()),+ |
+
| 958 | +! | +
+ "Biplot" = plot_biplot(computation()),+ |
+
| 959 | +! | +
+ "Eigenvector plot" = plot_pc_var(computation()),+ |
+
| 960 | +! | +
+ stop("Unknown plot")
+ |
+
| 961 | ++ |
+ )+ |
+
| 962 | ++ |
+ })+ |
+
| 963 | ++ | + + | +
| 964 | +! | +
+ plot_r <- reactive({
+ |
+
| 965 | +! | +
+ output_q()[["g"]]+ |
+
| 966 | ++ |
+ })+ |
+
| 967 | ++ | + + | +
| 968 | +! | +
+ pws <- teal.widgets::plot_with_settings_srv(+ |
+
| 969 | +! | +
+ id = "pca_plot",+ |
+
| 970 | +! | +
+ plot_r = plot_r,+ |
+
| 971 | +! | +
+ height = plot_height,+ |
+
| 972 | +! | +
+ width = plot_width,+ |
+
| 973 | +! | +
+ graph_align = "center"+ |
+
| 974 | ++ |
+ )+ |
+
| 975 | ++ | + + | +
| 976 | ++ |
+ # tables ----+ |
+
| 977 | +! | +
+ output$tbl_importance <- renderTable(+ |
+
| 978 | +! | +
+ expr = {
+ |
+
| 979 | +! | +
+ req("importance" %in% input$tables_display, computation())
+ |
+
| 980 | +! | +
+ computation()[["tbl_importance"]]+ |
+
| 981 | ++ |
+ },+ |
+
| 982 | +! | +
+ bordered = TRUE,+ |
+
| 983 | +! | +
+ align = "c",+ |
+
| 984 | +! | +
+ digits = 3+ |
+
| 985 | ++ |
+ )+ |
+
| 986 | ++ | + + | +
| 987 | +! | +
+ output$tbl_importance_ui <- renderUI({
+ |
+
| 988 | +! | +
+ req("importance" %in% input$tables_display)
+ |
+
| 989 | +! | +
+ div(+ |
+
| 990 | +! | +
+ align = "center",+ |
+
| 991 | +! | +
+ tags$h4("Principal components importance"),
+ |
+
| 992 | +! | +
+ tableOutput(session$ns("tbl_importance")),
+ |
+
| 993 | +! | +
+ hr()+ |
+
| 994 | ++ |
+ )+ |
+
| 995 | ++ |
+ })+ |
+
| 996 | ++ | + + | +
| 997 | +! | +
+ output$tbl_eigenvector <- renderTable(+ |
+
| 998 | +! | +
+ expr = {
+ |
+
| 999 | +! | +
+ req("eigenvector" %in% input$tables_display, req(computation()))
+ |
+
| 1000 | +! | +
+ computation()[["tbl_eigenvector"]]+ |
+
| 1001 | ++ |
+ },+ |
+
| 1002 | +! | +
+ bordered = TRUE,+ |
+
| 1003 | +! | +
+ align = "c",+ |
+
| 1004 | +! | +
+ digits = 3+ |
+
| 1005 | ++ |
+ )+ |
+
| 1006 | ++ | + + | +
| 1007 | +! | +
+ output$tbl_eigenvector_ui <- renderUI({
+ |
+
| 1008 | +! | +
+ req("eigenvector" %in% input$tables_display)
+ |
+
| 1009 | +! | +
+ div(+ |
+
| 1010 | +! | +
+ align = "center",+ |
+
| 1011 | +! | +
+ tags$h4("Eigenvectors"),
+ |
+
| 1012 | +! | +
+ tableOutput(session$ns("tbl_eigenvector")),
+ |
+
| 1013 | +! | +
+ hr()+ |
+
| 1014 | ++ |
+ )+ |
+
| 1015 | ++ |
+ })+ |
+
| 1016 | ++ | + + | +
| 1017 | +! | +
+ output$all_plots <- renderUI({
+ |
+
| 1018 | +! | +
+ teal::validate_inputs(iv_r())+ |
+
| 1019 | +! | +
+ teal::validate_inputs(iv_extra, header = "Plot settings are required")+ |
+
| 1020 | ++ | + + | +
| 1021 | +! | +
+ validation()+ |
+
| 1022 | +! | +
+ tags$div(+ |
+
| 1023 | +! | +
+ class = "overflow-scroll",+ |
+
| 1024 | +! | +
+ uiOutput(session$ns("tbl_importance_ui")),
+ |
+
| 1025 | +! | +
+ uiOutput(session$ns("tbl_eigenvector_ui")),
+ |
+
| 1026 | +! | +
+ teal.widgets::plot_with_settings_ui(id = session$ns("pca_plot"))
+ |
+
| 1027 | ++ |
+ )+ |
+
| 1028 | ++ |
+ })+ |
+
| 1029 | ++ | + + | +
| 1030 | +! | +
+ teal.widgets::verbatim_popup_srv(+ |
+
| 1031 | +! | +
+ id = "warning",+ |
+
| 1032 | +! | +
+ verbatim_content = reactive(teal.code::get_warnings(output_q())),+ |
+
| 1033 | +! | +
+ title = "Warning",+ |
+
| 1034 | +! | +
+ disabled = reactive(is.null(teal.code::get_warnings(output_q())))+ |
+
| 1035 | ++ |
+ )+ |
+
| 1036 | ++ | + + | +
| 1037 | +! | +
+ teal.widgets::verbatim_popup_srv(+ |
+
| 1038 | +! | +
+ id = "rcode",+ |
+
| 1039 | +! | +
+ verbatim_content = reactive(teal.code::get_code(output_q())),+ |
+
| 1040 | +! | +
+ title = "R Code for PCA"+ |
+
| 1041 | ++ |
+ )+ |
+
| 1042 | ++ | + + | +
| 1043 | ++ |
+ ### REPORTER+ |
+
| 1044 | +! | +
+ if (with_reporter) {
+ |
+
| 1045 | +! | +
+ card_fun <- function(comment, label) {
+ |
+
| 1046 | +! | +
+ card <- teal::report_card_template(+ |
+
| 1047 | +! | +
+ title = "Principal Component Analysis Plot",+ |
+
| 1048 | +! | +
+ label = label,+ |
+
| 1049 | +! | +
+ with_filter = with_filter,+ |
+
| 1050 | +! | +
+ filter_panel_api = filter_panel_api+ |
+
| 1051 | ++ |
+ )+ |
+
| 1052 | +! | +
+ card$append_text("Principal Components Table", "header3")
+ |
+
| 1053 | +! | +
+ card$append_table(computation()[["tbl_importance"]])+ |
+
| 1054 | +! | +
+ card$append_text("Eigenvectors Table", "header3")
+ |
+
| 1055 | +! | +
+ card$append_table(computation()[["tbl_eigenvector"]])+ |
+
| 1056 | +! | +
+ card$append_text("Plot", "header3")
+ |
+
| 1057 | +! | +
+ card$append_plot(plot_r(), dim = pws$dim())+ |
+
| 1058 | +! | +
+ if (!comment == "") {
+ |
+
| 1059 | +! | +
+ card$append_text("Comment", "header3")
+ |
+
| 1060 | +! | +
+ card$append_text(comment)+ |
+
| 1061 | ++ |
+ }+ |
+
| 1062 | +! | +
+ card$append_src(teal.code::get_code(output_q()))+ |
+
| 1063 | +! | +
+ card+ |
+
| 1064 | ++ |
+ }+ |
+
| 1065 | +! | +
+ teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
+ |
+
| 1066 | ++ |
+ }+ |
+
| 1067 | ++ |
+ ###+ |
+
| 1068 | ++ |
+ })+ |
+
| 1069 | ++ |
+ }+ |
+
| 1 | ++ |
+ #' `teal` module: Scatterplot+ |
+
| 2 | ++ |
+ #'+ |
+
| 3 | ++ |
+ #' Generates a customizable scatterplot using `ggplot2`.+ |
+
| 4 | ++ |
+ #' This module allows users to select variables for the x and y axes,+ |
+
| 5 | ++ |
+ #' color and size encodings, faceting options, and more. It supports log transformations,+ |
+
| 6 | ++ |
+ #' trend line additions, and dynamic adjustments of point opacity and size through UI controls.+ |
+
| 7 | ++ |
+ #'+ |
+
| 8 | ++ |
+ #' @note For more examples, please see the vignette "Using scatterplot" via+ |
+
| 9 | ++ |
+ #' `vignette("using-scatterplot", package = "teal.modules.general")`.
+ |
+
| 10 | ++ |
+ #'+ |
+
| 11 | ++ |
+ #' @inheritParams teal::module+ |
+
| 12 | ++ |
+ #' @inheritParams shared_params+ |
+
| 13 | ++ |
+ #' @param x (`data_extract_spec` or `list` of multiple `data_extract_spec`) Specifies+ |
+
| 14 | ++ |
+ #' variable names selected to plot along the x-axis by default.+ |
+
| 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.+ |
+
| 17 | ++ |
+ #' @param color_by (`data_extract_spec` or `list` of multiple `data_extract_spec`) optional,+ |
+
| 18 | ++ |
+ #' defines the color encoding. If `NULL` then no color encoding option will be displayed.+ |
+
| 19 | ++ |
+ #' @param size_by (`data_extract_spec` or `list` of multiple `data_extract_spec`) optional,+ |
+
| 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,+ |
+
| 22 | ++ |
+ #' specifies the variable(s) for faceting rows.+ |
+
| 23 | ++ |
+ #' @param col_facet (`data_extract_spec` or `list` of multiple `data_extract_spec`) optional,+ |
+
| 24 | ++ |
+ #' specifies the variable(s) for faceting columns.+ |
+
| 25 | ++ |
+ #' @param shape (`character`) optional, character vector with the names of the+ |
+
| 26 | ++ |
+ #' shape, e.g. `c("triangle", "square", "circle")`. It defaults to `shape_names`. This is a complete list from
+ |
+
| 27 | ++ |
+ #' `vignette("ggplot2-specs", package="ggplot2")`.
+ |
+
| 28 | ++ |
+ #' @param max_deg (`integer`) optional, maximum degree for the polynomial trend line. Must not be less than 1.+ |
+
| 29 | ++ |
+ #' @param table_dec (`integer`) optional, number of decimal places used to round numeric values in the table.+ |
+
| 30 | ++ |
+ #'+ |
+
| 31 | ++ |
+ #' @inherit shared_params return+ |
+
| 32 | ++ |
+ #'+ |
+
| 33 | ++ |
+ #' @examples+ |
+
| 34 | ++ |
+ #' library(teal.widgets)+ |
+
| 35 | ++ |
+ #'+ |
+
| 36 | ++ |
+ #' # general data example+ |
+
| 37 | ++ |
+ #' data <- teal_data()+ |
+
| 38 | ++ |
+ #' data <- within(data, {
+ |
+
| 39 | ++ |
+ #' require(nestcolor)+ |
+
| 40 | ++ |
+ #' CO2 <- CO2+ |
+
| 41 | ++ |
+ #' })+ |
+
| 42 | ++ |
+ #' datanames(data) <- "CO2"+ |
+
| 43 | ++ |
+ #'+ |
+
| 44 | ++ |
+ #' app <- init(+ |
+
| 45 | ++ |
+ #' data = data,+ |
+
| 46 | ++ |
+ #' modules = modules(+ |
+
| 47 | ++ |
+ #' tm_g_scatterplot(+ |
+
| 48 | ++ |
+ #' label = "Scatterplot Choices",+ |
+
| 49 | ++ |
+ #' x = data_extract_spec(+ |
+
| 50 | ++ |
+ #' dataname = "CO2",+ |
+
| 51 | ++ |
+ #' select = select_spec(+ |
+
| 52 | ++ |
+ #' label = "Select variable:",+ |
+
| 53 | ++ |
+ #' choices = variable_choices(data[["CO2"]], c("conc", "uptake")),
+ |
+
| 54 | ++ |
+ #' selected = "conc",+ |
+
| 55 | ++ |
+ #' multiple = FALSE,+ |
+
| 56 | ++ |
+ #' fixed = FALSE+ |
+
| 57 | ++ |
+ #' )+ |
+
| 58 | ++ |
+ #' ),+ |
+
| 59 | ++ |
+ #' y = data_extract_spec(+ |
+
| 60 | ++ |
+ #' dataname = "CO2",+ |
+
| 61 | ++ |
+ #' select = select_spec(+ |
+
| 62 | ++ |
+ #' label = "Select variable:",+ |
+
| 63 | ++ |
+ #' choices = variable_choices(data[["CO2"]], c("conc", "uptake")),
+ |
+
| 64 | ++ |
+ #' selected = "uptake",+ |
+
| 65 | ++ |
+ #' multiple = FALSE,+ |
+
| 66 | ++ |
+ #' fixed = FALSE+ |
+
| 67 | ++ |
+ #' )+ |
+
| 68 | ++ |
+ #' ),+ |
+
| 69 | ++ |
+ #' color_by = data_extract_spec(+ |
+
| 70 | ++ |
+ #' dataname = "CO2",+ |
+
| 71 | ++ |
+ #' select = select_spec(+ |
+
| 72 | ++ |
+ #' label = "Select variable:",+ |
+
| 73 | ++ |
+ #' choices = variable_choices(+ |
+
| 74 | ++ |
+ #' data[["CO2"]],+ |
+
| 75 | ++ |
+ #' c("Plant", "Type", "Treatment", "conc", "uptake")
+ |
+
| 76 | ++ |
+ #' ),+ |
+
| 77 | ++ |
+ #' selected = NULL,+ |
+
| 78 | ++ |
+ #' multiple = FALSE,+ |
+
| 79 | ++ |
+ #' fixed = FALSE+ |
+
| 80 | ++ |
+ #' )+ |
+
| 81 | ++ |
+ #' ),+ |
+
| 82 | ++ |
+ #' size_by = data_extract_spec(+ |
+
| 83 | ++ |
+ #' dataname = "CO2",+ |
+
| 84 | ++ |
+ #' select = select_spec(+ |
+
| 85 | ++ |
+ #' label = "Select variable:",+ |
+
| 86 | ++ |
+ #' choices = variable_choices(data[["CO2"]], c("conc", "uptake")),
+ |
+
| 87 | ++ |
+ #' selected = "uptake",+ |
+
| 88 | ++ |
+ #' multiple = FALSE,+ |
+
| 89 | ++ |
+ #' fixed = FALSE+ |
+
| 90 | ++ |
+ #' )+ |
+
| 91 | ++ |
+ #' ),+ |
+
| 92 | ++ |
+ #' row_facet = data_extract_spec(+ |
+
| 93 | ++ |
+ #' dataname = "CO2",+ |
+
| 94 | ++ |
+ #' select = select_spec(+ |
+
| 95 | ++ |
+ #' label = "Select variable:",+ |
+
| 96 | ++ |
+ #' choices = variable_choices(data[["CO2"]], c("Plant", "Type", "Treatment")),
+ |
+
| 97 | ++ |
+ #' selected = NULL,+ |
+
| 98 | ++ |
+ #' multiple = FALSE,+ |
+
| 99 | ++ |
+ #' fixed = FALSE+ |
+
| 100 | ++ |
+ #' )+ |
+
| 101 | ++ |
+ #' ),+ |
+
| 102 | ++ |
+ #' col_facet = data_extract_spec(+ |
+
| 103 | ++ |
+ #' dataname = "CO2",+ |
+
| 104 | ++ |
+ #' select = select_spec(+ |
+
| 105 | ++ |
+ #' label = "Select variable:",+ |
+
| 106 | ++ |
+ #' choices = variable_choices(data[["CO2"]], c("Plant", "Type", "Treatment")),
+ |
+
| 107 | ++ |
+ #' selected = NULL,+ |
+
| 108 | ++ |
+ #' multiple = FALSE,+ |
+
| 109 | ++ |
+ #' fixed = FALSE+ |
+
| 110 | ++ |
+ #' )+ |
+
| 111 | ++ |
+ #' ),+ |
+
| 112 | ++ |
+ #' ggplot2_args = ggplot2_args(+ |
+
| 113 | ++ |
+ #' labs = list(subtitle = "Plot generated by Scatterplot Module")+ |
+
| 114 | ++ |
+ #' )+ |
+
| 115 | ++ |
+ #' )+ |
+
| 116 | ++ |
+ #' )+ |
+
| 117 | ++ |
+ #' )+ |
+
| 118 | ++ |
+ #' if (interactive()) {
+ |
+
| 119 | ++ |
+ #' shinyApp(app$ui, app$server)+ |
+
| 120 | ++ |
+ #' }+ |
+
| 121 | ++ |
+ #'+ |
+
| 122 | ++ |
+ #' # CDISC data example+ |
+
| 123 | ++ |
+ #' data <- teal_data()+ |
+
| 124 | ++ |
+ #' data <- within(data, {
+ |
+
| 125 | ++ |
+ #' require(nestcolor)+ |
+
| 126 | ++ |
+ #' ADSL <- rADSL+ |
+
| 127 | ++ |
+ #' })+ |
+
| 128 | ++ |
+ #' datanames(data) <- c("ADSL")
+ |
+
| 129 | ++ |
+ #' join_keys(data) <- default_cdisc_join_keys[datanames(data)]+ |
+
| 130 | ++ |
+ #'+ |
+
| 131 | ++ |
+ #' app <- init(+ |
+
| 132 | ++ |
+ #' data = data,+ |
+
| 133 | ++ |
+ #' modules = modules(+ |
+
| 134 | ++ |
+ #' tm_g_scatterplot(+ |
+
| 135 | ++ |
+ #' label = "Scatterplot Choices",+ |
+
| 136 | ++ |
+ #' x = data_extract_spec(+ |
+
| 137 | ++ |
+ #' dataname = "ADSL",+ |
+
| 138 | ++ |
+ #' select = select_spec(+ |
+
| 139 | ++ |
+ #' label = "Select variable:",+ |
+
| 140 | ++ |
+ #' choices = variable_choices(data[["ADSL"]], c("AGE", "BMRKR1", "BMRKR2")),
+ |
+
| 141 | ++ |
+ #' selected = "AGE",+ |
+
| 142 | ++ |
+ #' multiple = FALSE,+ |
+
| 143 | ++ |
+ #' fixed = FALSE+ |
+
| 144 | ++ |
+ #' )+ |
+
| 145 | ++ |
+ #' ),+ |
+
| 146 | ++ |
+ #' y = data_extract_spec(+ |
+
| 147 | ++ |
+ #' dataname = "ADSL",+ |
+
| 148 | ++ |
+ #' select = select_spec(+ |
+
| 149 | ++ |
+ #' label = "Select variable:",+ |
+
| 150 | ++ |
+ #' choices = variable_choices(data[["ADSL"]], c("AGE", "BMRKR1", "BMRKR2")),
+ |
+
| 151 | ++ |
+ #' selected = "BMRKR1",+ |
+
| 152 | ++ |
+ #' multiple = FALSE,+ |
+
| 153 | ++ |
+ #' fixed = FALSE+ |
+
| 154 | ++ |
+ #' )+ |
+
| 155 | ++ |
+ #' ),+ |
+
| 156 | ++ |
+ #' color_by = data_extract_spec(+ |
+
| 157 | ++ |
+ #' dataname = "ADSL",+ |
+
| 158 | ++ |
+ #' select = select_spec(+ |
+
| 159 | ++ |
+ #' label = "Select variable:",+ |
+
| 160 | ++ |
+ #' choices = variable_choices(+ |
+
| 161 | ++ |
+ #' data[["ADSL"]],+ |
+
| 162 | ++ |
+ #' c("AGE", "BMRKR1", "BMRKR2", "RACE", "REGION1")
+ |
+
| 163 | ++ |
+ #' ),+ |
+
| 164 | ++ |
+ #' selected = NULL,+ |
+
| 165 | ++ |
+ #' multiple = FALSE,+ |
+
| 166 | ++ |
+ #' fixed = FALSE+ |
+
| 167 | ++ |
+ #' )+ |
+
| 168 | ++ |
+ #' ),+ |
+
| 169 | ++ |
+ #' size_by = data_extract_spec(+ |
+
| 170 | ++ |
+ #' dataname = "ADSL",+ |
+
| 171 | ++ |
+ #' select = select_spec(+ |
+
| 172 | ++ |
+ #' label = "Select variable:",+ |
+
| 173 | ++ |
+ #' choices = variable_choices(data[["ADSL"]], c("AGE", "BMRKR1")),
+ |
+
| 174 | ++ |
+ #' selected = "AGE",+ |
+
| 175 | ++ |
+ #' multiple = FALSE,+ |
+
| 176 | ++ |
+ #' fixed = FALSE+ |
+
| 177 | ++ |
+ #' )+ |
+
| 178 | ++ |
+ #' ),+ |
+
| 179 | ++ |
+ #' row_facet = data_extract_spec(+ |
+
| 180 | ++ |
+ #' dataname = "ADSL",+ |
+
| 181 | ++ |
+ #' select = select_spec(+ |
+
| 182 | ++ |
+ #' label = "Select variable:",+ |
+
| 183 | ++ |
+ #' choices = variable_choices(data[["ADSL"]], c("BMRKR2", "RACE", "REGION1")),
+ |
+
| 184 | ++ |
+ #' selected = NULL,+ |
+
| 185 | ++ |
+ #' multiple = FALSE,+ |
+
| 186 | ++ |
+ #' fixed = FALSE+ |
+
| 187 | ++ |
+ #' )+ |
+
| 188 | ++ |
+ #' ),+ |
+
| 189 | ++ |
+ #' col_facet = data_extract_spec(+ |
+
| 190 | ++ |
+ #' dataname = "ADSL",+ |
+
| 191 | ++ |
+ #' select = select_spec(+ |
+
| 192 | ++ |
+ #' label = "Select variable:",+ |
+
| 193 | ++ |
+ #' choices = variable_choices(data[["ADSL"]], c("BMRKR2", "RACE", "REGION1")),
+ |
+
| 194 | ++ |
+ #' selected = NULL,+ |
+
| 195 | ++ |
+ #' multiple = FALSE,+ |
+
| 196 | ++ |
+ #' fixed = FALSE+ |
+
| 197 | ++ |
+ #' )+ |
+
| 198 | ++ |
+ #' ),+ |
+
| 199 | ++ |
+ #' ggplot2_args = ggplot2_args(+ |
+
| 200 | ++ |
+ #' labs = list(subtitle = "Plot generated by Scatterplot Module")+ |
+
| 201 | ++ |
+ #' )+ |
+
| 202 | ++ |
+ #' )+ |
+
| 203 | ++ |
+ #' )+ |
+
| 204 | ++ |
+ #' )+ |
+
| 205 | ++ |
+ #' if (interactive()) {
+ |
+
| 206 | ++ |
+ #' shinyApp(app$ui, app$server)+ |
+
| 207 | ++ |
+ #' }+ |
+
| 208 | ++ |
+ #'+ |
+
| 209 | ++ |
+ #' @export+ |
+
| 210 | ++ |
+ #'+ |
+
| 211 | ++ |
+ tm_g_scatterplot <- function(label = "Scatterplot",+ |
+
| 212 | ++ |
+ x,+ |
+
| 213 | ++ |
+ y,+ |
+
| 214 | ++ |
+ color_by = NULL,+ |
+
| 215 | ++ |
+ size_by = NULL,+ |
+
| 216 | ++ |
+ row_facet = NULL,+ |
+
| 217 | ++ |
+ col_facet = NULL,+ |
+
| 218 | ++ |
+ plot_height = c(600, 200, 2000),+ |
+
| 219 | ++ |
+ plot_width = NULL,+ |
+
| 220 | ++ |
+ alpha = c(1, 0, 1),+ |
+
| 221 | ++ |
+ shape = shape_names,+ |
+
| 222 | ++ |
+ size = c(5, 1, 15),+ |
+
| 223 | ++ |
+ max_deg = 5L,+ |
+
| 224 | ++ |
+ rotate_xaxis_labels = FALSE,+ |
+
| 225 | ++ |
+ ggtheme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void"),
+ |
+
| 226 | ++ |
+ pre_output = NULL,+ |
+
| 227 | ++ |
+ post_output = NULL,+ |
+
| 228 | ++ |
+ table_dec = 4,+ |
+
| 229 | ++ |
+ ggplot2_args = teal.widgets::ggplot2_args()) {
+ |
+
| 230 | +! | +
+ logger::log_info("Initializing tm_g_scatterplot")
+ |
+
| 231 | ++ | + + | +
| 232 | ++ |
+ # Requires Suggested packages+ |
+
| 233 | +! | +
+ extra_packages <- c("ggpmisc", "ggExtra", "colourpicker")
+ |
+
| 234 | +! | +
+ missing_packages <- Filter(function(x) !requireNamespace(x, quietly = TRUE), extra_packages)+ |
+
| 235 | +! | +
+ if (length(missing_packages) > 0L) {
+ |
+
| 236 | +! | +
+ stop(sprintf(+ |
+
| 237 | +! | +
+ "Cannot load package(s): %s.\nInstall or restart your session.",+ |
+
| 238 | +! | +
+ toString(missing_packages)+ |
+
| 239 | ++ |
+ ))+ |
+
| 240 | ++ |
+ }+ |
+
| 241 | ++ | + + | +
| 242 | ++ |
+ # Normalize the parameters+ |
+
| 243 | +! | +
+ if (inherits(x, "data_extract_spec")) x <- list(x)+ |
+
| 244 | +! | +
+ if (inherits(y, "data_extract_spec")) y <- list(y)+ |
+
| 245 | +! | +
+ if (inherits(color_by, "data_extract_spec")) color_by <- list(color_by)+ |
+
| 246 | +! | +
+ if (inherits(size_by, "data_extract_spec")) size_by <- list(size_by)+ |
+
| 247 | +! | +
+ if (inherits(row_facet, "data_extract_spec")) row_facet <- list(row_facet)+ |
+
| 248 | +! | +
+ if (inherits(col_facet, "data_extract_spec")) col_facet <- list(col_facet)+ |
+
| 249 | +! | +
+ if (is.double(max_deg)) max_deg <- as.integer(max_deg)+ |
+
| 250 | ++ | + + | +
| 251 | ++ |
+ # Start of assertions+ |
+
| 252 | +! | +
+ checkmate::assert_string(label)+ |
+
| 253 | +! | +
+ checkmate::assert_list(x, types = "data_extract_spec")+ |
+
| 254 | +! | +
+ checkmate::assert_list(y, types = "data_extract_spec")+ |
+
| 255 | +! | +
+ checkmate::assert_list(color_by, types = "data_extract_spec", null.ok = TRUE)+ |
+
| 256 | +! | +
+ checkmate::assert_list(size_by, types = "data_extract_spec", null.ok = TRUE)+ |
+
| 257 | ++ | + + | +
| 258 | +! | +
+ checkmate::assert_list(row_facet, types = "data_extract_spec", null.ok = TRUE)+ |
+
| 259 | +! | +
+ assert_single_selection(row_facet)+ |
+
| 260 | ++ | + + | +
| 261 | +! | +
+ checkmate::assert_list(col_facet, types = "data_extract_spec", null.ok = TRUE)+ |
+
| 262 | +! | +
+ assert_single_selection(col_facet)+ |
+
| 263 | ++ | + + | +
| 264 | +! | +
+ checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE)+ |
+
| 265 | +! | +
+ checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height")+ |
+
| 266 | +! | +
+ checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE)+ |
+
| 267 | +! | +
+ checkmate::assert_numeric(+ |
+
| 268 | +! | +
+ plot_width[1],+ |
+
| 269 | +! | +
+ lower = plot_width[2], upper = plot_width[3], null.ok = TRUE, .var.name = "plot_width"+ |
+
| 270 | ++ |
+ )+ |
+
| 271 | ++ | + + | +
| 272 | +! | +
+ if (length(alpha) == 1) {
+ |
+
| 273 | +! | +
+ checkmate::assert_numeric(alpha, any.missing = FALSE, finite = TRUE)+ |
+
| 274 | ++ |
+ } else {
+ |
+
| 275 | +! | +
+ checkmate::assert_numeric(alpha, len = 3, any.missing = FALSE, finite = TRUE)+ |
+
| 276 | +! | +
+ checkmate::assert_numeric(alpha[1], lower = alpha[2], upper = alpha[3], .var.name = "alpha")+ |
+
| 277 | ++ |
+ }+ |
+
| 278 | ++ | + + | +
| 279 | +! | +
+ checkmate::assert_character(shape)+ |
+
| 280 | ++ | + + | +
| 281 | +! | +
+ if (length(size) == 1) {
+ |
+
| 282 | +! | +
+ checkmate::assert_numeric(size, any.missing = FALSE, finite = TRUE)+ |
+
| 283 | ++ |
+ } else {
+ |
+
| 284 | +! | +
+ checkmate::assert_numeric(size, len = 3, any.missing = FALSE, finite = TRUE)+ |
+
| 285 | +! | +
+ checkmate::assert_numeric(size[1], lower = size[2], upper = size[3], .var.name = "size")+ |
+
| 286 | ++ |
+ }+ |
+
| 287 | ++ | + + | +
| 288 | +! | +
+ checkmate::assert_int(max_deg, lower = 1L)+ |
+
| 289 | +! | +
+ checkmate::assert_flag(rotate_xaxis_labels)+ |
+
| 290 | +! | +
+ ggtheme <- match.arg(ggtheme)+ |
+
| 291 | ++ | + + | +
| 292 | +! | +
+ checkmate::assert_multi_class(pre_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
+ |
+
| 293 | +! | +
+ checkmate::assert_multi_class(post_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
+ |
+
| 294 | ++ | + + | +
| 295 | +! | +
+ checkmate::assert_scalar(table_dec)+ |
+
| 296 | +! | +
+ checkmate::assert_class(ggplot2_args, "ggplot2_args")+ |
+
| 297 | ++ |
+ # End of assertions+ |
+
| 298 | ++ | + + | +
| 299 | ++ |
+ # Make UI args+ |
+
| 300 | +! | +
+ args <- as.list(environment())+ |
+
| 301 | ++ | + + | +
| 302 | +! | +
+ data_extract_list <- list(+ |
+
| 303 | +! | +
+ x = x,+ |
+
| 304 | +! | +
+ y = y,+ |
+
| 305 | +! | +
+ color_by = color_by,+ |
+
| 306 | +! | +
+ size_by = size_by,+ |
+
| 307 | +! | +
+ row_facet = row_facet,+ |
+
| 308 | +! | +
+ col_facet = col_facet+ |
+
| 309 | ++ |
+ )+ |
+
| 310 | ++ | + + | +
| 311 | +! | +
+ module(+ |
+
| 312 | +! | +
+ label = label,+ |
+
| 313 | +! | +
+ server = srv_g_scatterplot,+ |
+
| 314 | +! | +
+ ui = ui_g_scatterplot,+ |
+
| 315 | +! | +
+ ui_args = args,+ |
+
| 316 | +! | +
+ server_args = c(+ |
+
| 317 | +! | +
+ data_extract_list,+ |
+
| 318 | +! | +
+ list(plot_height = plot_height, plot_width = plot_width, table_dec = table_dec, ggplot2_args = ggplot2_args)+ |
+
| 319 | ++ |
+ ),+ |
+
| 320 | +! | +
+ datanames = teal.transform::get_extract_datanames(data_extract_list)+ |
+
| 321 | ++ |
+ )+ |
+
| 322 | ++ |
+ }+ |
+
| 323 | ++ | + + | +
| 324 | ++ |
+ # UI function for the scatterplot module+ |
+
| 325 | ++ |
+ ui_g_scatterplot <- function(id, ...) {
+ |
+
| 326 | +! | +
+ args <- list(...)+ |
+
| 327 | +! | +
+ ns <- NS(id)+ |
+
| 328 | +! | +
+ is_single_dataset_value <- teal.transform::is_single_dataset(+ |
+
| 329 | +! | +
+ args$x, args$y, args$color_by, args$size_by, args$row_facet, args$col_facet+ |
+
| 330 | ++ |
+ )+ |
+
| 331 | ++ | + + | +
| 332 | +! | +
+ shiny::tagList(+ |
+
| 333 | +! | +
+ include_css_files("custom"),
+ |
+
| 334 | +! | +
+ teal.widgets::standard_layout(+ |
+
| 335 | +! | +
+ output = teal.widgets::white_small_well(+ |
+
| 336 | +! | +
+ teal.widgets::plot_with_settings_ui(id = ns("scatter_plot")),
+ |
+
| 337 | +! | +
+ tags$h1(tags$strong("Selected points:"), class = "text-center font-150p"),
+ |
+
| 338 | +! | +
+ teal.widgets::get_dt_rows(ns("data_table"), ns("data_table_rows")),
+ |
+
| 339 | +! | +
+ DT::dataTableOutput(ns("data_table"), width = "100%")
+ |
+
| 340 | ++ |
+ ),+ |
+
| 341 | +! | +
+ encoding = div(+ |
+
| 342 | ++ |
+ ### Reporter+ |
+
| 343 | +! | +
+ teal.reporter::simple_reporter_ui(ns("simple_reporter")),
+ |
+
| 344 | ++ |
+ ###+ |
+
| 345 | +! | +
+ tags$label("Encodings", class = "text-primary"),
+ |
+
| 346 | +! | +
+ teal.transform::datanames_input(args[c("x", "y", "color_by", "size_by", "row_facet", "col_facet")]),
+ |
+
| 347 | +! | +
+ teal.transform::data_extract_ui(+ |
+
| 348 | +! | +
+ id = ns("x"),
+ |
+
| 349 | +! | +
+ label = "X variable",+ |
+
| 350 | +! | +
+ data_extract_spec = args$x,+ |
+
| 351 | +! | +
+ is_single_dataset = is_single_dataset_value+ |
+
| 352 | ++ |
+ ),+ |
+
| 353 | +! | +
+ checkboxInput(ns("log_x"), "Use log transformation", value = FALSE),
+ |
+
| 354 | +! | +
+ conditionalPanel(+ |
+
| 355 | +! | +
+ condition = paste0("input['", ns("log_x"), "'] == true"),
+ |
+
| 356 | +! | +
+ radioButtons(+ |
+
| 357 | +! | +
+ ns("log_x_base"),
+ |
+
| 358 | +! | +
+ label = NULL,+ |
+
| 359 | +! | +
+ inline = TRUE,+ |
+
| 360 | +! | +
+ choices = c("Natural" = "log", "Base 10" = "log10", "Base 2" = "log2")
+ |
+
| 361 | ++ |
+ )+ |
+
| 362 | ++ |
+ ),+ |
+
| 363 | +! | +
+ teal.transform::data_extract_ui(+ |
+
| 364 | +! | +
+ id = ns("y"),
+ |
+
| 365 | +! | +
+ label = "Y variable",+ |
+
| 366 | +! | +
+ data_extract_spec = args$y,+ |
+
| 367 | +! | +
+ is_single_dataset = is_single_dataset_value+ |
+
| 368 | ++ |
+ ),+ |
+
| 369 | +! | +
+ checkboxInput(ns("log_y"), "Use log transformation", value = FALSE),
+ |
+
| 370 | +! | +
+ conditionalPanel(+ |
+
| 371 | +! | +
+ condition = paste0("input['", ns("log_y"), "'] == true"),
+ |
+
| 372 | +! | +
+ radioButtons(+ |
+
| 373 | +! | +
+ ns("log_y_base"),
+ |
+
| 374 | +! | +
+ label = NULL,+ |
+
| 375 | +! | +
+ inline = TRUE,+ |
+
| 376 | +! | +
+ choices = c("Natural" = "log", "Base 10" = "log10", "Base 2" = "log2")
+ |
+
| 377 | ++ |
+ )+ |
+
| 378 | ++ |
+ ),+ |
+
| 379 | +! | +
+ if (!is.null(args$color_by)) {
+ |
+
| 380 | +! | +
+ teal.transform::data_extract_ui(+ |
+
| 381 | +! | +
+ id = ns("color_by"),
+ |
+
| 382 | +! | +
+ label = "Color by variable",+ |
+
| 383 | +! | +
+ data_extract_spec = args$color_by,+ |
+
| 384 | +! | +
+ is_single_dataset = is_single_dataset_value+ |
+
| 385 | ++ |
+ )+ |
+
| 386 | ++ |
+ },+ |
+
| 387 | +! | +
+ if (!is.null(args$size_by)) {
+ |
+
| 388 | +! | +
+ teal.transform::data_extract_ui(+ |
+
| 389 | +! | +
+ id = ns("size_by"),
+ |
+
| 390 | +! | +
+ label = "Size by variable",+ |
+
| 391 | +! | +
+ data_extract_spec = args$size_by,+ |
+
| 392 | +! | +
+ is_single_dataset = is_single_dataset_value+ |
+
| 393 | ++ |
+ )+ |
+
| 394 | ++ |
+ },+ |
+
| 395 | +! | +
+ if (!is.null(args$row_facet)) {
+ |
+
| 396 | +! | +
+ teal.transform::data_extract_ui(+ |
+
| 397 | +! | +
+ id = ns("row_facet"),
+ |
+
| 398 | +! | +
+ label = "Row facetting",+ |
+
| 399 | +! | +
+ data_extract_spec = args$row_facet,+ |
+
| 400 | +! | +
+ is_single_dataset = is_single_dataset_value+ |
+
| 401 | ++ |
+ )+ |
+
| 402 | ++ |
+ },+ |
+
| 403 | +! | +
+ if (!is.null(args$col_facet)) {
+ |
+
| 404 | +! | +
+ teal.transform::data_extract_ui(+ |
+
| 405 | +! | +
+ id = ns("col_facet"),
+ |
+
| 406 | +! | +
+ label = "Column facetting",+ |
+
| 407 | +! | +
+ data_extract_spec = args$col_facet,+ |
+
| 408 | +! | +
+ is_single_dataset = is_single_dataset_value+ |
+
| 409 | ++ |
+ )+ |
+
| 410 | ++ |
+ },+ |
+
| 411 | +! | +
+ teal.widgets::panel_group(+ |
+
| 412 | +! | +
+ teal.widgets::panel_item(+ |
+
| 413 | +! | +
+ title = "Plot settings",+ |
+
| 414 | +! | +
+ teal.widgets::optionalSliderInputValMinMax(ns("alpha"), "Opacity:", args$alpha, ticks = FALSE),
+ |
+
| 415 | +! | +
+ teal.widgets::optionalSelectInput(+ |
+
| 416 | +! | +
+ inputId = ns("shape"),
+ |
+
| 417 | +! | +
+ label = "Points shape:",+ |
+
| 418 | +! | +
+ choices = args$shape,+ |
+
| 419 | +! | +
+ selected = args$shape[1],+ |
+
| 420 | +! | +
+ multiple = FALSE+ |
+
| 421 | ++ |
+ ),+ |
+
| 422 | +! | +
+ colourpicker::colourInput(ns("color"), "Points color:", "black"),
+ |
+
| 423 | +! | +
+ teal.widgets::optionalSliderInputValMinMax(ns("size"), "Points size:", args$size, ticks = FALSE, step = .1),
+ |
+
| 424 | +! | +
+ checkboxInput(ns("rotate_xaxis_labels"), "Rotate X axis labels", value = args$rotate_xaxis_labels),
+ |
+
| 425 | +! | +
+ checkboxInput(ns("add_density"), "Add marginal density", value = FALSE),
+ |
+
| 426 | +! | +
+ checkboxInput(ns("rug_plot"), "Include rug plot", value = FALSE),
+ |
+
| 427 | +! | +
+ checkboxInput(ns("show_count"), "Show N (number of observations)", value = FALSE),
+ |
+
| 428 | +! | +
+ shinyjs::hidden(helpText(id = ns("line_msg"), "Trendline needs numeric X and Y variables")),
+ |
+
| 429 | +! | +
+ teal.widgets::optionalSelectInput(ns("smoothing_degree"), "Smoothing degree", seq_len(args$max_deg)),
+ |
+
| 430 | +! | +
+ shinyjs::hidden(teal.widgets::optionalSelectInput(ns("color_sub"), label = "", multiple = TRUE)),
+ |
+
| 431 | +! | +
+ teal.widgets::optionalSliderInputValMinMax(ns("ci"), "Confidence", c(.95, .8, .99), ticks = FALSE),
+ |
+
| 432 | +! | +
+ shinyjs::hidden(checkboxInput(ns("show_form"), "Show formula", value = TRUE)),
+ |
+
| 433 | +! | +
+ shinyjs::hidden(checkboxInput(ns("show_r2"), "Show adj-R Squared", value = TRUE)),
+ |
+
| 434 | +! | +
+ uiOutput(ns("num_na_removed")),
+ |
+
| 435 | +! | +
+ div(+ |
+
| 436 | +! | +
+ id = ns("label_pos"),
+ |
+
| 437 | +! | +
+ div(strong("Stats position")),
+ |
+
| 438 | +! | +
+ div(class = "inline-block w-10", helpText("Left")),
+ |
+
| 439 | +! | +
+ div(+ |
+
| 440 | +! | +
+ class = "inline-block w-70",+ |
+
| 441 | +! | +
+ teal.widgets::optionalSliderInput(+ |
+
| 442 | +! | +
+ ns("pos"),
+ |
+
| 443 | +! | +
+ label = NULL,+ |
+
| 444 | +! | +
+ min = 0, max = 1, value = .99, ticks = FALSE, step = .01+ |
+
| 445 | ++ |
+ )+ |
+
| 446 | ++ |
+ ),+ |
+
| 447 | +! | +
+ div(class = "inline-block w-10", helpText("Right"))
+ |
+
| 448 | ++ |
+ ),+ |
+
| 449 | +! | +
+ teal.widgets::optionalSliderInput(+ |
+
| 450 | +! | +
+ ns("label_size"), "Stats font size",
+ |
+
| 451 | +! | +
+ min = 3, max = 10, value = 5, ticks = FALSE, step = .1+ |
+
| 452 | ++ |
+ ),+ |
+
| 453 | +! | +
+ if (!is.null(args$row_facet) || !is.null(args$col_facet)) {
+ |
+
| 454 | +! | +
+ checkboxInput(ns("free_scales"), "Free scales", value = FALSE)
+ |
+
| 455 | ++ |
+ },+ |
+
| 456 | +! | +
+ selectInput(+ |
+
| 457 | +! | +
+ inputId = ns("ggtheme"),
+ |
+
| 458 | +! | +
+ label = "Theme (by ggplot):",+ |
+
| 459 | +! | +
+ choices = ggplot_themes,+ |
+
| 460 | +! | +
+ selected = args$ggtheme,+ |
+
| 461 | +! | +
+ multiple = FALSE+ |
+
| 462 | ++ |
+ )+ |
+
| 463 | ++ |
+ )+ |
+
| 464 | ++ |
+ )+ |
+
| 465 | ++ |
+ ),+ |
+
| 466 | +! | +
+ forms = tagList(+ |
+
| 467 | +! | +
+ teal.widgets::verbatim_popup_ui(ns("warning"), button_label = "Show Warnings"),
+ |
+
| 468 | +! | +
+ teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code")
+ |
+
| 469 | ++ |
+ ),+ |
+
| 470 | +! | +
+ pre_output = args$pre_output,+ |
+
| 471 | +! | +
+ post_output = args$post_output+ |
+
| 472 | ++ |
+ )+ |
+
| 473 | ++ |
+ )+ |
+
| 474 | ++ |
+ }+ |
+
| 475 | ++ | + + | +
| 476 | ++ |
+ # Server function for the scatterplot module+ |
+
| 477 | ++ |
+ srv_g_scatterplot <- function(id,+ |
+
| 478 | ++ |
+ data,+ |
+
| 479 | ++ |
+ reporter,+ |
+
| 480 | ++ |
+ filter_panel_api,+ |
+
| 481 | ++ |
+ x,+ |
+
| 482 | ++ |
+ y,+ |
+
| 483 | ++ |
+ color_by,+ |
+
| 484 | ++ |
+ size_by,+ |
+
| 485 | ++ |
+ row_facet,+ |
+
| 486 | ++ |
+ col_facet,+ |
+
| 487 | ++ |
+ plot_height,+ |
+
| 488 | ++ |
+ plot_width,+ |
+
| 489 | ++ |
+ table_dec,+ |
+
| 490 | ++ |
+ ggplot2_args) {
+ |
+
| 491 | +! | +
+ with_reporter <- !missing(reporter) && inherits(reporter, "Reporter")+ |
+
| 492 | +! | +
+ with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI")+ |
+
| 493 | +! | +
+ checkmate::assert_class(data, "reactive")+ |
+
| 494 | +! | +
+ checkmate::assert_class(isolate(data()), "teal_data")+ |
+
| 495 | +! | +
+ moduleServer(id, function(input, output, session) {
+ |
+
| 496 | +! | +
+ data_extract <- list(+ |
+
| 497 | +! | +
+ x = x,+ |
+
| 498 | +! | +
+ y = y,+ |
+
| 499 | +! | +
+ color_by = color_by,+ |
+
| 500 | +! | +
+ size_by = size_by,+ |
+
| 501 | +! | +
+ row_facet = row_facet,+ |
+
| 502 | +! | +
+ col_facet = col_facet+ |
+
| 503 | ++ |
+ )+ |
+
| 504 | ++ | + + | +
| 505 | +! | +
+ rule_diff <- function(other) {
+ |
+
| 506 | +! | +
+ function(value) {
+ |
+
| 507 | +! | +
+ othervalue <- selector_list()[[other]]()[["select"]]+ |
+
| 508 | +! | +
+ if (!is.null(othervalue)) {
+ |
+
| 509 | +! | +
+ if (identical(value, othervalue)) {
+ |
+
| 510 | +! | +
+ "Row and column facetting variables must be different."+ |
+
| 511 | ++ |
+ }+ |
+
| 512 | ++ |
+ }+ |
+
| 513 | ++ |
+ }+ |
+
| 514 | ++ |
+ }+ |
+
| 515 | ++ | + + | +
| 516 | +! | +
+ selector_list <- teal.transform::data_extract_multiple_srv(+ |
+
| 517 | +! | +
+ data_extract = data_extract,+ |
+
| 518 | +! | +
+ datasets = data,+ |
+
| 519 | +! | +
+ select_validation_rule = list(+ |
+
| 520 | +! | +
+ x = ~ if (length(.) != 1) "Please select exactly one x var.",+ |
+
| 521 | +! | +
+ y = ~ if (length(.) != 1) "Please select exactly one y var.",+ |
+
| 522 | +! | +
+ color_by = ~ if (length(.) > 1) "There cannot be more than 1 color variable.",+ |
+
| 523 | +! | +
+ size_by = ~ if (length(.) > 1) "There cannot be more than 1 size variable.",+ |
+
| 524 | +! | +
+ row_facet = shinyvalidate::compose_rules(+ |
+
| 525 | +! | +
+ shinyvalidate::sv_optional(),+ |
+
| 526 | +! | +
+ rule_diff("col_facet")
+ |
+
| 527 | ++ |
+ ),+ |
+
| 528 | +! | +
+ col_facet = shinyvalidate::compose_rules(+ |
+
| 529 | +! | +
+ shinyvalidate::sv_optional(),+ |
+
| 530 | +! | +
+ rule_diff("row_facet")
+ |
+
| 531 | ++ |
+ )+ |
+
| 532 | ++ |
+ )+ |
+
| 533 | ++ |
+ )+ |
+
| 534 | ++ | + + | +
| 535 | +! | +
+ iv_r <- reactive({
+ |
+
| 536 | +! | +
+ iv_facet <- shinyvalidate::InputValidator$new()+ |
+
| 537 | +! | +
+ iv <- shinyvalidate::InputValidator$new()+ |
+
| 538 | +! | +
+ teal.transform::compose_and_enable_validators(iv, selector_list)+ |
+
| 539 | ++ |
+ })+ |
+
| 540 | +! | +
+ iv_facet <- shinyvalidate::InputValidator$new()+ |
+
| 541 | +! | +
+ iv_facet$add_rule("add_density", ~ if (
+ |
+
| 542 | +! | +
+ isTRUE(.) &&+ |
+
| 543 | ++ |
+ (+ |
+
| 544 | +! | +
+ length(selector_list()$row_facet()$select) > 0L ||+ |
+
| 545 | +! | +
+ length(selector_list()$col_facet()$select) > 0L+ |
+
| 546 | ++ |
+ )+ |
+
| 547 | ++ |
+ ) {
+ |
+
| 548 | +! | +
+ "Cannot add marginal density when Row or Column facetting has been selected"+ |
+
| 549 | ++ |
+ })+ |
+
| 550 | +! | +
+ iv_facet$enable()+ |
+
| 551 | ++ | + + | +
| 552 | +! | +
+ anl_merged_input <- teal.transform::merge_expression_srv(+ |
+
| 553 | +! | +
+ selector_list = selector_list,+ |
+
| 554 | +! | +
+ datasets = data,+ |
+
| 555 | +! | +
+ merge_function = "dplyr::inner_join"+ |
+
| 556 | ++ |
+ )+ |
+
| 557 | ++ | + + | +
| 558 | +! | +
+ anl_merged_q <- reactive({
+ |
+
| 559 | +! | +
+ req(anl_merged_input())+ |
+
| 560 | +! | +
+ data() %>%+ |
+
| 561 | +! | +
+ teal.code::eval_code(as.expression(anl_merged_input()$expr)) %>%+ |
+
| 562 | +! | +
+ teal.code::eval_code(quote(ANL)) # used to display table when running show-r-code code+ |
+
| 563 | ++ |
+ })+ |
+
| 564 | ++ | + + | +
| 565 | +! | +
+ merged <- list(+ |
+
| 566 | +! | +
+ anl_input_r = anl_merged_input,+ |
+
| 567 | +! | +
+ anl_q_r = anl_merged_q+ |
+
| 568 | ++ |
+ )+ |
+
| 569 | ++ | + + | +
| 570 | +! | +
+ trend_line_is_applicable <- reactive({
+ |
+
| 571 | +! | +
+ ANL <- merged$anl_q_r()[["ANL"]]+ |
+
| 572 | +! | +
+ x_var <- as.vector(merged$anl_input_r()$columns_source$x)+ |
+
| 573 | +! | +
+ y_var <- as.vector(merged$anl_input_r()$columns_source$y)+ |
+
| 574 | +! | +
+ length(x_var) > 0 && length(y_var) > 0 && is.numeric(ANL[[x_var]]) && is.numeric(ANL[[y_var]])+ |
+
| 575 | ++ |
+ })+ |
+
| 576 | ++ | + + | +
| 577 | +! | +
+ add_trend_line <- reactive({
+ |
+
| 578 | +! | +
+ smoothing_degree <- as.integer(input$smoothing_degree)+ |
+
| 579 | +! | +
+ trend_line_is_applicable() && length(smoothing_degree) > 0+ |
+
| 580 | ++ |
+ })+ |
+
| 581 | ++ | + + | +
| 582 | +! | +
+ if (!is.null(color_by)) {
+ |
+
| 583 | +! | +
+ observeEvent(+ |
+
| 584 | +! | +
+ eventExpr = merged$anl_input_r()$columns_source$color_by,+ |
+
| 585 | +! | +
+ handlerExpr = {
+ |
+
| 586 | +! | +
+ color_by_var <- as.vector(merged$anl_input_r()$columns_source$color_by)+ |
+
| 587 | +! | +
+ if (length(color_by_var) > 0) {
+ |
+
| 588 | +! | +
+ shinyjs::hide("color")
+ |
+
| 589 | ++ |
+ } else {
+ |
+
| 590 | +! | +
+ shinyjs::show("color")
+ |
+
| 591 | ++ |
+ }+ |
+
| 592 | ++ |
+ }+ |
+
| 593 | ++ |
+ )+ |
+
| 594 | ++ |
+ }+ |
+
| 595 | ++ | + + | +
| 596 | +! | +
+ output$num_na_removed <- renderUI({
+ |
+
| 597 | +! | +
+ if (add_trend_line()) {
+ |
+
| 598 | +! | +
+ ANL <- merged$anl_q_r()[["ANL"]]+ |
+
| 599 | +! | +
+ x_var <- as.vector(merged$anl_input_r()$columns_source$x)+ |
+
| 600 | +! | +
+ y_var <- as.vector(merged$anl_input_r()$columns_source$y)+ |
+
| 601 | +! | +
+ if ((num_total_na <- nrow(ANL) - nrow(stats::na.omit(ANL[, c(x_var, y_var)]))) > 0) {
+ |
+
| 602 | +! | +
+ shiny::tags$div(paste(num_total_na, "row(s) with missing values were removed"), shiny::tags$hr())+ |
+
| 603 | ++ |
+ }+ |
+
| 604 | ++ |
+ }+ |
+
| 605 | ++ |
+ })+ |
+
| 606 | ++ | + + | +
| 607 | +! | +
+ observeEvent(+ |
+
| 608 | +! | +
+ eventExpr = merged$anl_input_r()$columns_source[c("col_facet", "row_facet")],
+ |
+
| 609 | +! | +
+ handlerExpr = {
+ |
+
| 610 | +! | +
+ if (+ |
+
| 611 | +! | +
+ length(merged$anl_input_r()$columns_source$col_facet) == 0 &&+ |
+
| 612 | +! | +
+ length(merged$anl_input_r()$columns_source$row_facet) == 0+ |
+
| 613 | ++ |
+ ) {
+ |
+
| 614 | +! | +
+ shinyjs::hide("free_scales")
+ |
+
| 615 | ++ |
+ } else {
+ |
+
| 616 | +! | +
+ shinyjs::show("free_scales")
+ |
+
| 617 | ++ |
+ }+ |
+
| 618 | ++ |
+ }+ |
+
| 619 | ++ |
+ )+ |
+
| 620 | ++ | + + | +
| 621 | +! | +
+ output_q <- reactive({
+ |
+
| 622 | +! | +
+ teal::validate_inputs(iv_r(), iv_facet)+ |
+
| 623 | ++ | + + | +
| 624 | +! | +
+ ANL <- merged$anl_q_r()[["ANL"]]+ |
+
| 625 | ++ | + + | +
| 626 | +! | +
+ x_var <- as.vector(merged$anl_input_r()$columns_source$x)+ |
+
| 627 | +! | +
+ y_var <- as.vector(merged$anl_input_r()$columns_source$y)+ |
+
| 628 | +! | +
+ color_by_var <- as.vector(merged$anl_input_r()$columns_source$color_by)+ |
+
| 629 | +! | +
+ size_by_var <- as.vector(merged$anl_input_r()$columns_source$size_by)+ |
+
| 630 | +! | +
+ row_facet_name <- if (length(merged$anl_input_r()$columns_source$row_facet) == 0) {
+ |
+
| 631 | +! | +
+ character(0)+ |
+
| 632 | ++ |
+ } else {
+ |
+
| 633 | +! | +
+ as.vector(merged$anl_input_r()$columns_source$row_facet)+ |
+
| 634 | ++ |
+ }+ |
+
| 635 | +! | +
+ col_facet_name <- if (length(merged$anl_input_r()$columns_source$col_facet) == 0) {
+ |
+
| 636 | +! | +
+ character(0)+ |
+
| 637 | ++ |
+ } else {
+ |
+
| 638 | +! | +
+ as.vector(merged$anl_input_r()$columns_source$col_facet)+ |
+
| 639 | ++ |
+ }+ |
+
| 640 | +! | +
+ alpha <- input$alpha+ |
+
| 641 | +! | +
+ size <- input$size+ |
+
| 642 | +! | +
+ rotate_xaxis_labels <- input$rotate_xaxis_labels+ |
+
| 643 | +! | +
+ add_density <- input$add_density+ |
+
| 644 | +! | +
+ ggtheme <- input$ggtheme+ |
+
| 645 | +! | +
+ rug_plot <- input$rug_plot+ |
+
| 646 | +! | +
+ color <- input$color+ |
+
| 647 | +! | +
+ shape <- `if`(is.null(input$shape) || identical(input$shape, ""), "circle", input$shape)+ |
+
| 648 | +! | +
+ smoothing_degree <- as.integer(input$smoothing_degree)+ |
+
| 649 | +! | +
+ ci <- input$ci+ |
+
| 650 | ++ | + + | +
| 651 | +! | +
+ log_x <- input$log_x+ |
+
| 652 | +! | +
+ log_y <- input$log_y+ |
+
| 653 | ++ | + + | +
| 654 | +! | +
+ validate(need(+ |
+
| 655 | +! | +
+ length(row_facet_name) == 0 || inherits(ANL[[row_facet_name]], c("character", "factor", "Date", "integer")),
+ |
+
| 656 | +! | +
+ "`Row facetting` variable must be of class `character`, `factor`, `Date`, or `integer`"+ |
+
| 657 | ++ |
+ ))+ |
+
| 658 | +! | +
+ validate(need(+ |
+
| 659 | +! | +
+ length(col_facet_name) == 0 || inherits(ANL[[col_facet_name]], c("character", "factor", "Date", "integer")),
+ |
+
| 660 | +! | +
+ "`Column facetting` variable must be of class `character`, `factor`, `Date`, or `integer`"+ |
+
| 661 | ++ |
+ ))+ |
+
| 662 | ++ | + + | +
| 663 | +! | +
+ if (add_density && length(color_by_var) > 0) {
+ |
+
| 664 | +! | +
+ validate(need(+ |
+
| 665 | +! | +
+ !is.numeric(ANL[[color_by_var]]),+ |
+
| 666 | +! | +
+ "Marginal plots cannot be produced when the points are colored by numeric variables.+ |
+
| 667 | +! | +
+ \n Uncheck the 'Add marginal density' checkbox to display the plot."+ |
+
| 668 | ++ |
+ ))+ |
+
| 669 | +! | +
+ validate(need(+ |
+
| 670 | ++ |
+ !(+ |
+
| 671 | +! | +
+ inherits(ANL[[color_by_var]], "Date") ||+ |
+
| 672 | +! | +
+ inherits(ANL[[color_by_var]], "POSIXct") ||+ |
+
| 673 | +! | +
+ inherits(ANL[[color_by_var]], "POSIXlt")+ |
+
| 674 | ++ |
+ ),+ |
+
| 675 | +! | +
+ "Marginal plots cannot be produced when the points are colored by Date or POSIX variables.+ |
+
| 676 | +! | +
+ \n Uncheck the 'Add marginal density' checkbox to display the plot."+ |
+
| 677 | ++ |
+ ))+ |
+
| 678 | ++ |
+ }+ |
+
| 679 | ++ | + + | +
| 680 | +! | +
+ teal::validate_has_data(ANL[, c(x_var, y_var)], 10, complete = TRUE, allow_inf = FALSE)+ |
+
| 681 | ++ | + + | +
| 682 | +! | +
+ if (log_x) {
+ |
+
| 683 | +! | +
+ validate(+ |
+
| 684 | +! | +
+ need(+ |
+
| 685 | +! | +
+ is.numeric(ANL[[x_var]]) && all(+ |
+
| 686 | +! | +
+ ANL[[x_var]] > 0 | is.na(ANL[[x_var]])+ |
+
| 687 | ++ |
+ ),+ |
+
| 688 | +! | +
+ "X variable can only be log transformed if variable is numeric and all values are positive."+ |
+
| 689 | ++ |
+ )+ |
+
| 690 | ++ |
+ )+ |
+
| 691 | ++ |
+ }+ |
+
| 692 | +! | +
+ if (log_y) {
+ |
+
| 693 | +! | +
+ validate(+ |
+
| 694 | +! | +
+ need(+ |
+
| 695 | +! | +
+ is.numeric(ANL[[y_var]]) && all(+ |
+
| 696 | +! | +
+ ANL[[y_var]] > 0 | is.na(ANL[[y_var]])+ |
+
| 697 | ++ |
+ ),+ |
+
| 698 | +! | +
+ "Y variable can only be log transformed if variable is numeric and all values are positive."+ |
+
| 699 | ++ |
+ )+ |
+
| 700 | ++ |
+ )+ |
+
| 701 | ++ |
+ }+ |
+
| 702 | ++ | + + | +
| 703 | +! | +
+ facet_cl <- facet_ggplot_call(+ |
+
| 704 | +! | +
+ row_facet_name,+ |
+
| 705 | +! | +
+ col_facet_name,+ |
+
| 706 | +! | +
+ free_x_scales = isTRUE(input$free_scales),+ |
+
| 707 | +! | +
+ free_y_scales = isTRUE(input$free_scales)+ |
+
| 708 | ++ |
+ )+ |
+
| 709 | ++ | + + | +
| 710 | +! | +
+ point_sizes <- if (length(size_by_var) > 0) {
+ |
+
| 711 | +! | +
+ validate(need(is.numeric(ANL[[size_by_var]]), "Variable to size by must be numeric"))+ |
+
| 712 | +! | +
+ substitute(+ |
+
| 713 | +! | +
+ expr = size * ANL[[size_by_var]] / max(ANL[[size_by_var]], na.rm = TRUE),+ |
+
| 714 | +! | +
+ env = list(size = size, size_by_var = size_by_var)+ |
+
| 715 | ++ |
+ )+ |
+
| 716 | ++ |
+ } else {
+ |
+
| 717 | +! | +
+ size+ |
+
| 718 | ++ |
+ }+ |
+
| 719 | ++ | + + | +
| 720 | +! | +
+ plot_q <- merged$anl_q_r()+ |
+
| 721 | ++ | + + | +
| 722 | +! | +
+ if (log_x) {
+ |
+
| 723 | +! | +
+ log_x_fn <- input$log_x_base+ |
+
| 724 | +! | +
+ plot_q <- teal.code::eval_code(+ |
+
| 725 | +! | +
+ object = plot_q,+ |
+
| 726 | +! | +
+ code = substitute(+ |
+
| 727 | +! | +
+ expr = ANL[, log_x_var] <- log_x_fn(ANL[, x_var]),+ |
+
| 728 | +! | +
+ env = list(+ |
+
| 729 | +! | +
+ x_var = x_var,+ |
+
| 730 | +! | +
+ log_x_fn = as.name(log_x_fn),+ |
+
| 731 | +! | +
+ log_x_var = paste0(log_x_fn, "_", x_var)+ |
+
| 732 | ++ |
+ )+ |
+
| 733 | ++ |
+ )+ |
+
| 734 | ++ |
+ )+ |
+
| 735 | ++ |
+ }+ |
+
| 736 | ++ | + + | +
| 737 | +! | +
+ if (log_y) {
+ |
+
| 738 | +! | +
+ log_y_fn <- input$log_y_base+ |
+
| 739 | +! | +
+ plot_q <- teal.code::eval_code(+ |
+
| 740 | +! | +
+ object = plot_q,+ |
+
| 741 | +! | +
+ code = substitute(+ |
+
| 742 | +! | +
+ expr = ANL[, log_y_var] <- log_y_fn(ANL[, y_var]),+ |
+
| 743 | +! | +
+ env = list(+ |
+
| 744 | +! | +
+ y_var = y_var,+ |
+
| 745 | +! | +
+ log_y_fn = as.name(log_y_fn),+ |
+
| 746 | +! | +
+ log_y_var = paste0(log_y_fn, "_", y_var)+ |
+
| 747 | ++ |
+ )+ |
+
| 748 | ++ |
+ )+ |
+
| 749 | ++ |
+ )+ |
+
| 750 | ++ |
+ }+ |
+
| 751 | ++ | + + | +
| 752 | +! | +
+ pre_pro_anl <- if (input$show_count) {
+ |
+
| 753 | +! | +
+ paste0(+ |
+
| 754 | +! | +
+ "ANL %>% dplyr::group_by(",
+ |
+
| 755 | +! | +
+ paste(+ |
+
| 756 | +! | +
+ c(+ |
+
| 757 | +! | +
+ if (length(color_by_var) > 0 && inherits(ANL[[color_by_var]], c("factor", "character"))) color_by_var,
+ |
+
| 758 | +! | +
+ row_facet_name,+ |
+
| 759 | +! | +
+ col_facet_name+ |
+
| 760 | ++ |
+ ),+ |
+
| 761 | +! | +
+ collapse = ", "+ |
+
| 762 | ++ |
+ ),+ |
+
| 763 | +! | +
+ ") %>% dplyr::mutate(n = dplyr::n()) %>% dplyr::ungroup()"+ |
+
| 764 | ++ |
+ )+ |
+
| 765 | ++ |
+ } else {
+ |
+
| 766 | +! | +
+ "ANL"+ |
+
| 767 | ++ |
+ }+ |
+
| 768 | ++ | + + | +
| 769 | +! | +
+ plot_call <- substitute(expr = pre_pro_anl %>% ggplot(), env = list(pre_pro_anl = str2lang(pre_pro_anl)))+ |
+
| 770 | ++ | + + | +
| 771 | +! | +
+ plot_call <- if (length(color_by_var) == 0) {
+ |
+
| 772 | +! | +
+ substitute(+ |
+
| 773 | +! | +
+ expr = plot_call ++ |
+
| 774 | +! | +
+ ggplot2::aes(x = x_name, y = y_name) ++ |
+
| 775 | +! | +
+ ggplot2::geom_point(alpha = alpha_value, size = point_sizes, shape = shape_value, color = color_value),+ |
+
| 776 | +! | +
+ env = list(+ |
+
| 777 | +! | +
+ plot_call = plot_call,+ |
+
| 778 | +! | +
+ x_name = if (log_x) as.name(paste0(log_x_fn, "_", x_var)) else as.name(x_var),+ |
+
| 779 | +! | +
+ y_name = if (log_y) as.name(paste0(log_y_fn, "_", y_var)) else as.name(y_var),+ |
+
| 780 | +! | +
+ alpha_value = alpha,+ |
+
| 781 | +! | +
+ point_sizes = point_sizes,+ |
+
| 782 | +! | +
+ shape_value = shape,+ |
+
| 783 | +! | +
+ color_value = color+ |
+
| 784 | ++ |
+ )+ |
+
| 785 | ++ |
+ )+ |
+
| 786 | ++ |
+ } else {
+ |
+
| 787 | +! | +
+ substitute(+ |
+
| 788 | +! | +
+ expr = plot_call ++ |
+
| 789 | +! | +
+ ggplot2::aes(x = x_name, y = y_name, color = color_by_var_name) ++ |
+
| 790 | +! | +
+ ggplot2::geom_point(alpha = alpha_value, size = point_sizes, shape = shape_value),+ |
+
| 791 | +! | +
+ env = list(+ |
+
| 792 | +! | +
+ plot_call = plot_call,+ |
+
| 793 | +! | +
+ x_name = if (log_x) as.name(paste0(log_x_fn, "_", x_var)) else as.name(x_var),+ |
+
| 794 | +! | +
+ y_name = if (log_y) as.name(paste0(log_y_fn, "_", y_var)) else as.name(y_var),+ |
+
| 795 | +! | +
+ color_by_var_name = as.name(color_by_var),+ |
+
| 796 | +! | +
+ alpha_value = alpha,+ |
+
| 797 | +! | +
+ point_sizes = point_sizes,+ |
+
| 798 | +! | +
+ shape_value = shape+ |
+
| 799 | ++ |
+ )+ |
+
| 800 | ++ |
+ )+ |
+
| 801 | ++ |
+ }+ |
+
| 802 | ++ | + + | +
| 803 | +! | +
+ if (rug_plot) plot_call <- substitute(expr = plot_call + geom_rug(), env = list(plot_call = plot_call))+ |
+
| 804 | ++ | + + | +
| 805 | +! | +
+ plot_label_generator <- function(rhs_formula = quote(y ~ 1),+ |
+
| 806 | +! | +
+ show_form = input$show_form,+ |
+
| 807 | +! | +
+ show_r2 = input$show_r2,+ |
+
| 808 | +! | +
+ show_count = input$show_count,+ |
+
| 809 | +! | +
+ pos = input$pos,+ |
+
| 810 | +! | +
+ label_size = input$label_size) {
+ |
+
| 811 | +! | +
+ stopifnot(sum(show_form, show_r2, show_count) >= 1)+ |
+
| 812 | +! | +
+ aes_label <- paste0(+ |
+
| 813 | +! | +
+ "aes(",
+ |
+
| 814 | +! | +
+ if (show_count) "n = n, ",+ |
+
| 815 | +! | +
+ "label = ",+ |
+
| 816 | +! | +
+ if (sum(show_form, show_r2, show_count) > 1) "paste(",
+ |
+
| 817 | +! | +
+ paste(+ |
+
| 818 | +! | +
+ c(+ |
+
| 819 | +! | +
+ if (show_form) "stat(eq.label)",+ |
+
| 820 | +! | +
+ if (show_r2) "stat(adj.rr.label)",+ |
+
| 821 | +! | +
+ if (show_count) "paste('N ~`=`~', n)"
+ |
+
| 822 | ++ |
+ ),+ |
+
| 823 | +! | +
+ collapse = ", "+ |
+
| 824 | ++ |
+ ),+ |
+
| 825 | +! | +
+ if (sum(show_form, show_r2, show_count) > 1) ", sep = '*\", \"*'))" else ")"+ |
+
| 826 | ++ |
+ )+ |
+
| 827 | +! | +
+ label_geom <- substitute(+ |
+
| 828 | +! | +
+ expr = ggpmisc::stat_poly_eq(+ |
+
| 829 | +! | +
+ mapping = aes_label,+ |
+
| 830 | +! | +
+ formula = rhs_formula,+ |
+
| 831 | +! | +
+ parse = TRUE,+ |
+
| 832 | +! | +
+ label.x = pos,+ |
+
| 833 | +! | +
+ size = label_size+ |
+
| 834 | ++ |
+ ),+ |
+
| 835 | +! | +
+ env = list(+ |
+
| 836 | +! | +
+ rhs_formula = rhs_formula,+ |
+
| 837 | +! | +
+ pos = pos,+ |
+
| 838 | +! | +
+ aes_label = str2lang(aes_label),+ |
+
| 839 | +! | +
+ label_size = label_size+ |
+
| 840 | ++ |
+ )+ |
+
| 841 | ++ |
+ )+ |
+
| 842 | +! | +
+ substitute(+ |
+
| 843 | +! | +
+ expr = plot_call + label_geom,+ |
+
| 844 | +! | +
+ env = list(+ |
+
| 845 | +! | +
+ plot_call = plot_call,+ |
+
| 846 | +! | +
+ label_geom = label_geom+ |
+
| 847 | ++ |
+ )+ |
+
| 848 | ++ |
+ )+ |
+
| 849 | ++ |
+ }+ |
+
| 850 | ++ | + + | +
| 851 | +! | +
+ if (trend_line_is_applicable()) {
+ |
+
| 852 | +! | +
+ shinyjs::hide("line_msg")
+ |
+
| 853 | +! | +
+ shinyjs::show("smoothing_degree")
+ |
+
| 854 | +! | +
+ if (!add_trend_line()) {
+ |
+
| 855 | +! | +
+ shinyjs::hide("ci")
+ |
+
| 856 | +! | +
+ shinyjs::hide("color_sub")
+ |
+
| 857 | +! | +
+ shinyjs::hide("show_form")
+ |
+
| 858 | +! | +
+ shinyjs::hide("show_r2")
+ |
+
| 859 | +! | +
+ if (input$show_count) {
+ |
+
| 860 | +! | +
+ plot_call <- plot_label_generator(show_form = FALSE, show_r2 = FALSE)+ |
+
| 861 | +! | +
+ shinyjs::show("label_pos")
+ |
+
| 862 | +! | +
+ shinyjs::show("label_size")
+ |
+
| 863 | ++ |
+ } else {
+ |
+
| 864 | +! | +
+ shinyjs::hide("label_pos")
+ |
+
| 865 | +! | +
+ shinyjs::hide("label_size")
+ |
+
| 866 | ++ |
+ }+ |
+
| 867 | ++ |
+ } else {
+ |
+
| 868 | +! | +
+ shinyjs::show("ci")
+ |
+
| 869 | +! | +
+ shinyjs::show("show_form")
+ |
+
| 870 | +! | +
+ shinyjs::show("show_r2")
+ |
+
| 871 | +! | +
+ if (nrow(ANL) - nrow(stats::na.omit(ANL[, c(x_var, y_var)])) > 0) {
+ |
+
| 872 | +! | +
+ plot_q <- teal.code::eval_code(+ |
+
| 873 | +! | +
+ plot_q,+ |
+
| 874 | +! | +
+ substitute(+ |
+
| 875 | +! | +
+ expr = ANL <- dplyr::filter(ANL, !is.na(x_var) & !is.na(y_var)),+ |
+
| 876 | +! | +
+ env = list(x_var = as.name(x_var), y_var = as.name(y_var))+ |
+
| 877 | ++ |
+ )+ |
+
| 878 | ++ |
+ )+ |
+
| 879 | ++ |
+ }+ |
+
| 880 | +! | +
+ rhs_formula <- substitute(+ |
+
| 881 | +! | +
+ expr = y ~ poly(x, smoothing_degree, raw = TRUE),+ |
+
| 882 | +! | +
+ env = list(smoothing_degree = smoothing_degree)+ |
+
| 883 | ++ |
+ )+ |
+
| 884 | +! | +
+ if (input$show_form || input$show_r2 || input$show_count) {
+ |
+
| 885 | +! | +
+ plot_call <- plot_label_generator(rhs_formula = rhs_formula)+ |
+
| 886 | +! | +
+ shinyjs::show("label_pos")
+ |
+
| 887 | +! | +
+ shinyjs::show("label_size")
+ |
+
| 888 | ++ |
+ } else {
+ |
+
| 889 | +! | +
+ shinyjs::hide("label_pos")
+ |
+
| 890 | +! | +
+ shinyjs::hide("label_size")
+ |
+
| 891 | ++ |
+ }+ |
+
| 892 | +! | +
+ plot_call <- substitute(+ |
+
| 893 | +! | +
+ expr = plot_call + ggplot2::geom_smooth(formula = rhs_formula, se = TRUE, level = ci, method = "lm"),+ |
+
| 894 | +! | +
+ env = list(plot_call = plot_call, rhs_formula = rhs_formula, ci = ci)+ |
+
| 895 | ++ |
+ )+ |
+
| 896 | ++ |
+ }+ |
+
| 897 | ++ |
+ } else {
+ |
+
| 898 | +! | +
+ shinyjs::hide("smoothing_degree")
+ |
+
| 899 | +! | +
+ shinyjs::hide("ci")
+ |
+
| 900 | +! | +
+ shinyjs::hide("color_sub")
+ |
+
| 901 | +! | +
+ shinyjs::hide("show_form")
+ |
+
| 902 | +! | +
+ shinyjs::hide("show_r2")
+ |
+
| 903 | +! | +
+ if (input$show_count) {
+ |
+
| 904 | +! | +
+ plot_call <- plot_label_generator(show_form = FALSE, show_r2 = FALSE)+ |
+
| 905 | +! | +
+ shinyjs::show("label_pos")
+ |
+
| 906 | +! | +
+ shinyjs::show("label_size")
+ |
+
| 907 | ++ |
+ } else {
+ |
+
| 908 | +! | +
+ shinyjs::hide("label_pos")
+ |
+
| 909 | +! | +
+ shinyjs::hide("label_size")
+ |
+
| 910 | ++ |
+ }+ |
+
| 911 | +! | +
+ shinyjs::show("line_msg")
+ |
+
| 912 | ++ |
+ }+ |
+
| 913 | ++ | + + | +
| 914 | +! | +
+ if (!is.null(facet_cl)) {
+ |
+
| 915 | +! | +
+ plot_call <- substitute(expr = plot_call + facet_cl, env = list(plot_call = plot_call, facet_cl = facet_cl))+ |
+
| 916 | ++ |
+ }+ |
+
| 917 | ++ | + + | +
| 918 | +! | +
+ y_label <- varname_w_label(+ |
+
| 919 | +! | +
+ y_var,+ |
+
| 920 | +! | +
+ ANL,+ |
+
| 921 | +! | +
+ prefix = if (log_y) paste(log_y_fn, "(") else NULL,
+ |
+
| 922 | +! | +
+ suffix = if (log_y) ")" else NULL+ |
+
| 923 | ++ |
+ )+ |
+
| 924 | +! | +
+ x_label <- varname_w_label(+ |
+
| 925 | +! | +
+ x_var,+ |
+
| 926 | +! | +
+ ANL,+ |
+
| 927 | +! | +
+ prefix = if (log_x) paste(log_x_fn, "(") else NULL,
+ |
+
| 928 | +! | +
+ suffix = if (log_x) ")" else NULL+ |
+
| 929 | ++ |
+ )+ |
+
| 930 | ++ | + + | +
| 931 | +! | +
+ dev_ggplot2_args <- teal.widgets::ggplot2_args(+ |
+
| 932 | +! | +
+ labs = list(y = y_label, x = x_label),+ |
+
| 933 | +! | +
+ theme = list(legend.position = "bottom")+ |
+
| 934 | ++ |
+ )+ |
+
| 935 | ++ | + + | +
| 936 | +! | +
+ if (rotate_xaxis_labels) {
+ |
+
| 937 | +! | +
+ dev_ggplot2_args$theme[["axis.text.x"]] <- quote(element_text(angle = 45, hjust = 1))+ |
+
| 938 | ++ |
+ }+ |
+
| 939 | ++ | + + | +
| 940 | +! | +
+ all_ggplot2_args <- teal.widgets::resolve_ggplot2_args(+ |
+
| 941 | +! | +
+ user_plot = ggplot2_args,+ |
+
| 942 | +! | +
+ module_plot = dev_ggplot2_args+ |
+
| 943 | ++ |
+ )+ |
+
| 944 | ++ | + + | +
| 945 | +! | +
+ parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(all_ggplot2_args, ggtheme = ggtheme)+ |
+
| 946 | ++ | + + | +
| 947 | ++ | + + | +
| 948 | +! | +
+ if (add_density) {
+ |
+
| 949 | +! | +
+ plot_call <- substitute(+ |
+
| 950 | +! | +
+ expr = ggExtra::ggMarginal(+ |
+
| 951 | +! | +
+ plot_call + labs + ggthemes + themes,+ |
+
| 952 | +! | +
+ type = "density",+ |
+
| 953 | +! | +
+ groupColour = group_colour+ |
+
| 954 | ++ |
+ ),+ |
+
| 955 | +! | +
+ env = list(+ |
+
| 956 | +! | +
+ plot_call = plot_call,+ |
+
| 957 | +! | +
+ group_colour = if (length(color_by_var) > 0) TRUE else FALSE,+ |
+
| 958 | +! | +
+ labs = parsed_ggplot2_args$labs,+ |
+
| 959 | +! | +
+ ggthemes = parsed_ggplot2_args$ggtheme,+ |
+
| 960 | +! | +
+ themes = parsed_ggplot2_args$theme+ |
+
| 961 | ++ |
+ )+ |
+
| 962 | ++ |
+ )+ |
+
| 963 | ++ |
+ } else {
+ |
+
| 964 | +! | +
+ plot_call <- substitute(+ |
+
| 965 | +! | +
+ expr = plot_call ++ |
+
| 966 | +! | +
+ labs ++ |
+
| 967 | +! | +
+ ggthemes ++ |
+
| 968 | +! | +
+ themes,+ |
+
| 969 | +! | +
+ env = list(+ |
+
| 970 | +! | +
+ plot_call = plot_call,+ |
+
| 971 | +! | +
+ labs = parsed_ggplot2_args$labs,+ |
+
| 972 | +! | +
+ ggthemes = parsed_ggplot2_args$ggtheme,+ |
+
| 973 | +! | +
+ themes = parsed_ggplot2_args$theme+ |
+
| 974 | ++ |
+ )+ |
+
| 975 | ++ |
+ )+ |
+
| 976 | ++ |
+ }+ |
+
| 977 | ++ | + + | +
| 978 | +! | +
+ plot_call <- substitute(expr = p <- plot_call, env = list(plot_call = plot_call))+ |
+
| 979 | ++ | + + | +
| 980 | +! | +
+ teal.code::eval_code(plot_q, plot_call) %>%+ |
+
| 981 | +! | +
+ teal.code::eval_code(quote(print(p)))+ |
+
| 982 | ++ |
+ })+ |
+
| 983 | ++ | + + | +
| 984 | +! | +
+ plot_r <- reactive(output_q()[["p"]])+ |
+
| 985 | ++ | + + | +
| 986 | ++ |
+ # Insert the plot into a plot_with_settings module from teal.widgets+ |
+
| 987 | +! | +
+ pws <- teal.widgets::plot_with_settings_srv(+ |
+
| 988 | +! | +
+ id = "scatter_plot",+ |
+
| 989 | +! | +
+ plot_r = plot_r,+ |
+
| 990 | +! | +
+ height = plot_height,+ |
+
| 991 | +! | +
+ width = plot_width,+ |
+
| 992 | +! | +
+ brushing = TRUE+ |
+
| 993 | ++ |
+ )+ |
+
| 994 | ++ | + + | +
| 995 | +! | +
+ output$data_table <- DT::renderDataTable({
+ |
+
| 996 | +! | +
+ plot_brush <- pws$brush()+ |
+
| 997 | ++ | + + | +
| 998 | +! | +
+ if (!is.null(plot_brush)) {
+ |
+
| 999 | +! | +
+ validate(need(!input$add_density, "Brushing feature is currently not supported when plot has marginal density"))+ |
+
| 1000 | ++ |
+ }+ |
+
| 1001 | ++ | + + | +
| 1002 | +! | +
+ merged_data <- isolate(teal.code::dev_suppress(output_q()[["ANL"]]))+ |
+
| 1003 | ++ | + + | +
| 1004 | +! | +
+ brushed_df <- teal.widgets::clean_brushedPoints(merged_data, plot_brush)+ |
+
| 1005 | +! | +
+ numeric_cols <- names(brushed_df)[+ |
+
| 1006 | +! | +
+ vapply(brushed_df, function(x) is.numeric(x) && !is.integer(x), FUN.VALUE = logical(1))+ |
+
| 1007 | ++ |
+ ]+ |
+
| 1008 | ++ | + + | +
| 1009 | +! | +
+ if (length(numeric_cols) > 0) {
+ |
+
| 1010 | +! | +
+ DT::formatRound(+ |
+
| 1011 | +! | +
+ DT::datatable(brushed_df,+ |
+
| 1012 | +! | +
+ rownames = FALSE,+ |
+
| 1013 | +! | +
+ options = list(scrollX = TRUE, pageLength = input$data_table_rows)+ |
+
| 1014 | ++ |
+ ),+ |
+
| 1015 | +! | +
+ numeric_cols,+ |
+
| 1016 | +! | +
+ table_dec+ |
+
| 1017 | ++ |
+ )+ |
+
| 1018 | ++ |
+ } else {
+ |
+
| 1019 | +! | +
+ DT::datatable(brushed_df, rownames = FALSE, options = list(scrollX = TRUE, pageLength = input$data_table_rows))+ |
+
| 1020 | ++ |
+ }+ |
+
| 1021 | ++ |
+ })+ |
+
| 1022 | ++ | + + | +
| 1023 | +! | +
+ teal.widgets::verbatim_popup_srv(+ |
+
| 1024 | +! | +
+ id = "warning",+ |
+
| 1025 | +! | +
+ verbatim_content = reactive(teal.code::get_warnings(output_q())),+ |
+
| 1026 | +! | +
+ title = "Warning",+ |
+
| 1027 | +! | +
+ disabled = reactive(is.null(teal.code::get_warnings(output_q())))+ |
+
| 1028 | ++ |
+ )+ |
+
| 1029 | ++ | + + | +
| 1030 | +! | +
+ teal.widgets::verbatim_popup_srv(+ |
+
| 1031 | +! | +
+ id = "rcode",+ |
+
| 1032 | +! | +
+ verbatim_content = reactive(teal.code::get_code(output_q())),+ |
+
| 1033 | +! | +
+ title = "R Code for scatterplot"+ |
+
| 1034 | ++ |
+ )+ |
+
| 1035 | ++ | + + | +
| 1036 | ++ |
+ ### REPORTER+ |
+
| 1037 | +! | +
+ if (with_reporter) {
+ |
+
| 1038 | +! | +
+ card_fun <- function(comment, label) {
+ |
+
| 1039 | +! | +
+ card <- teal::report_card_template(+ |
+
| 1040 | +! | +
+ title = "Scatter Plot",+ |
+
| 1041 | +! | +
+ label = label,+ |
+
| 1042 | +! | +
+ with_filter = with_filter,+ |
+
| 1043 | +! | +
+ filter_panel_api = filter_panel_api+ |
+
| 1044 | ++ |
+ )+ |
+
| 1045 | +! | +
+ card$append_text("Plot", "header3")
+ |
+
| 1046 | +! | +
+ card$append_plot(plot_r(), dim = pws$dim())+ |
+
| 1047 | +! | +
+ if (!comment == "") {
+ |
+
| 1048 | +! | +
+ card$append_text("Comment", "header3")
+ |
+
| 1049 | +! | +
+ card$append_text(comment)+ |
+
| 1050 | ++ |
+ }+ |
+
| 1051 | +! | +
+ card$append_src(teal.code::get_code(output_q()))+ |
+
| 1052 | +! | +
+ card+ |
+
| 1053 | ++ |
+ }+ |
+
| 1054 | +! | +
+ teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
+ |
+
| 1055 | ++ |
+ }+ |
+
| 1056 | ++ |
+ ###+ |
+
| 1057 | ++ |
+ })+ |
+
| 1058 | ++ |
+ }+ |
+
| 1 | ++ |
+ #' `teal` module: Front page+ |
+
| 2 | ++ |
+ #'+ |
+
| 3 | ++ |
+ #' Creates a simple front page for `teal` applications, displaying+ |
+
| 4 | ++ |
+ #' introductory text, tables, additional `html` or `shiny` tags, and footnotes.+ |
+
| 5 | ++ |
+ #'+ |
+
| 6 | ++ |
+ #' @inheritParams teal::module+ |
+
| 7 | ++ |
+ #' @param header_text (`character` vector) text to be shown at the top of the module, for each+ |
+
| 8 | ++ |
+ #' element, if named the name is shown first in bold as a header followed by the value. The first+ |
+
| 9 | ++ |
+ #' element's header is displayed larger than the others.+ |
+
| 10 | ++ |
+ #' @param tables (`named list` of `data.frame`s) tables to be shown in the module.+ |
+
| 11 | ++ |
+ #' @param additional_tags (`shiny.tag.list` or `html`) additional `shiny` tags or `html` to be included after the table,+ |
+
| 12 | ++ |
+ #' for example to include an image, `tagList(tags$img(src = "image.png"))` or to include further `html`,+ |
+
| 13 | ++ |
+ #' `HTML("html text here")`.
+ |
+
| 14 | ++ |
+ #' @param footnotes (`character` vector) of text to be shown at the bottom of the module, for each+ |
+
| 15 | ++ |
+ #' element, if named the name is shown first in bold, followed by the value.+ |
+
| 16 | ++ |
+ #' @param show_metadata (`logical`) indicating whether the metadata of the datasets be available on the module.+ |
+
| 17 | ++ |
+ #'+ |
+
| 18 | ++ |
+ #' @inherit shared_params return+ |
+
| 19 | ++ |
+ #'+ |
+
| 20 | ++ |
+ #' @examples+ |
+
| 21 | ++ |
+ #' data <- teal_data()+ |
+
| 22 | ++ |
+ #' data <- within(data, {
+ |
+
| 23 | ++ |
+ #' require(nestcolor)+ |
+
| 24 | ++ |
+ #' ADSL <- rADSL+ |
+
| 25 | ++ |
+ #' attr(ADSL, "metadata") <- list("Author" = "NEST team", "data_source" = "synthetic data")
+ |
+
| 26 | ++ |
+ #' })+ |
+
| 27 | ++ |
+ #' datanames(data) <- "ADSL"+ |
+
| 28 | ++ |
+ #' join_keys(data) <- default_cdisc_join_keys[datanames(data)]+ |
+
| 29 | ++ |
+ #'+ |
+
| 30 | ++ |
+ #' table_1 <- data.frame(Info = c("A", "B"), Text = c("A", "B"))
+ |
+
| 31 | ++ |
+ #' table_2 <- data.frame(`Column 1` = c("C", "D"), `Column 2` = c(5.5, 6.6), `Column 3` = c("A", "B"))
+ |
+
| 32 | ++ |
+ #' table_3 <- data.frame(Info = c("E", "F"), Text = c("G", "H"))
+ |
+
| 33 | ++ |
+ #'+ |
+
| 34 | ++ |
+ #' table_input <- list(+ |
+
| 35 | ++ |
+ #' "Table 1" = table_1,+ |
+
| 36 | ++ |
+ #' "Table 2" = table_2,+ |
+
| 37 | ++ |
+ #' "Table 3" = table_3+ |
+
| 38 | ++ |
+ #' )+ |
+
| 39 | ++ |
+ #'+ |
+
| 40 | ++ |
+ #' app <- init(+ |
+
| 41 | ++ |
+ #' data = data,+ |
+
| 42 | ++ |
+ #' modules = modules(+ |
+
| 43 | ++ |
+ #' tm_front_page(+ |
+
| 44 | ++ |
+ #' header_text = c(+ |
+
| 45 | ++ |
+ #' "Important information" = "It can go here.",+ |
+
| 46 | ++ |
+ #' "Other information" = "Can go here."+ |
+
| 47 | ++ |
+ #' ),+ |
+
| 48 | ++ |
+ #' tables = table_input,+ |
+
| 49 | ++ |
+ #' additional_tags = HTML("Additional HTML or shiny tags go here <br>"),
+ |
+
| 50 | ++ |
+ #' footnotes = c("X" = "is the first footnote", "Y is the second footnote"),
+ |
+
| 51 | ++ |
+ #' show_metadata = TRUE+ |
+
| 52 | ++ |
+ #' )+ |
+
| 53 | ++ |
+ #' ),+ |
+
| 54 | ++ |
+ #' header = tags$h1("Sample Application"),
+ |
+
| 55 | ++ |
+ #' footer = tags$p("Application footer"),
+ |
+
| 56 | ++ |
+ #' )+ |
+
| 57 | ++ |
+ #'+ |
+
| 58 | ++ |
+ #' if (interactive()) {
+ |
+
| 59 | ++ |
+ #' shinyApp(app$ui, app$server)+ |
+
| 60 | ++ |
+ #' }+ |
+
| 61 | ++ |
+ #'+ |
+
| 62 | ++ |
+ #' @export+ |
+
| 63 | ++ |
+ #'+ |
+
| 64 | ++ |
+ tm_front_page <- function(label = "Front page",+ |
+
| 65 | ++ |
+ header_text = character(0),+ |
+
| 66 | ++ |
+ tables = list(),+ |
+
| 67 | ++ |
+ additional_tags = tagList(),+ |
+
| 68 | ++ |
+ footnotes = character(0),+ |
+
| 69 | ++ |
+ show_metadata = FALSE) {
+ |
+
| 70 | +! | +
+ logger::log_info("Initializing tm_front_page")
+ |
+
| 71 | ++ | + + | +
| 72 | ++ |
+ # Start of assertions+ |
+
| 73 | +! | +
+ checkmate::assert_string(label)+ |
+
| 74 | +! | +
+ checkmate::assert_character(header_text, min.len = 0, any.missing = FALSE)+ |
+
| 75 | +! | +
+ checkmate::assert_list(tables, types = "data.frame", names = "named", any.missing = FALSE)+ |
+
| 76 | +! | +
+ checkmate::assert_multi_class(additional_tags, classes = c("shiny.tag.list", "html"))
+ |
+
| 77 | +! | +
+ checkmate::assert_character(footnotes, min.len = 0, any.missing = FALSE)+ |
+
| 78 | +! | +
+ checkmate::assert_flag(show_metadata)+ |
+
| 79 | ++ |
+ # End of assertions+ |
+
| 80 | ++ | + + | +
| 81 | ++ |
+ # Make UI args+ |
+
| 82 | +! | +
+ args <- as.list(environment())+ |
+
| 83 | ++ | + + | +
| 84 | +! | +
+ module(+ |
+
| 85 | +! | +
+ label = label,+ |
+
| 86 | +! | +
+ server = srv_front_page,+ |
+
| 87 | +! | +
+ ui = ui_front_page,+ |
+
| 88 | +! | +
+ ui_args = args,+ |
+
| 89 | +! | +
+ server_args = list(tables = tables, show_metadata = show_metadata),+ |
+
| 90 | +! | +
+ datanames = if (show_metadata) "all" else NULL+ |
+
| 91 | ++ |
+ )+ |
+
| 92 | ++ |
+ }+ |
+
| 93 | ++ | + + | +
| 94 | ++ |
+ # UI function for the front page module+ |
+
| 95 | ++ |
+ ui_front_page <- function(id, ...) {
+ |
+
| 96 | +! | +
+ args <- list(...)+ |
+
| 97 | +! | +
+ ns <- NS(id)+ |
+
| 98 | ++ | + + | +
| 99 | +! | +
+ tagList(+ |
+
| 100 | +! | +
+ include_css_files("custom"),
+ |
+
| 101 | +! | +
+ tags$div(+ |
+
| 102 | +! | +
+ id = "front_page_content",+ |
+
| 103 | +! | +
+ class = "ml-8",+ |
+
| 104 | +! | +
+ tags$div(+ |
+
| 105 | +! | +
+ id = "front_page_headers",+ |
+
| 106 | +! | +
+ get_header_tags(args$header_text)+ |
+
| 107 | ++ |
+ ),+ |
+
| 108 | +! | +
+ tags$div(+ |
+
| 109 | +! | +
+ id = "front_page_tables",+ |
+
| 110 | +! | +
+ class = "ml-4",+ |
+
| 111 | +! | +
+ get_table_tags(args$tables, ns)+ |
+
| 112 | ++ |
+ ),+ |
+
| 113 | +! | +
+ tags$div(+ |
+
| 114 | +! | +
+ id = "front_page_custom_html",+ |
+
| 115 | +! | +
+ class = "my-4",+ |
+
| 116 | +! | +
+ args$additional_tags+ |
+
| 117 | ++ |
+ ),+ |
+
| 118 | +! | +
+ if (args$show_metadata) {
+ |
+
| 119 | +! | +
+ tags$div(+ |
+
| 120 | +! | +
+ id = "front_page_metabutton",+ |
+
| 121 | +! | +
+ class = "m-4",+ |
+
| 122 | +! | +
+ actionButton(ns("metadata_button"), "Show metadata")
+ |
+
| 123 | ++ |
+ )+ |
+
| 124 | ++ |
+ },+ |
+
| 125 | +! | +
+ tags$footer(+ |
+
| 126 | +! | +
+ class = ".small",+ |
+
| 127 | +! | +
+ get_footer_tags(args$footnotes)+ |
+
| 128 | ++ |
+ )+ |
+
| 129 | ++ |
+ )+ |
+
| 130 | ++ |
+ )+ |
+
| 131 | ++ |
+ }+ |
+
| 132 | ++ | + + | +
| 133 | ++ |
+ # Server function for the front page module+ |
+
| 134 | ++ |
+ srv_front_page <- function(id, data, tables, show_metadata) {
+ |
+
| 135 | +! | +
+ checkmate::assert_class(data, "reactive")+ |
+
| 136 | +! | +
+ checkmate::assert_class(isolate(data()), "teal_data")+ |
+
| 137 | +! | +
+ moduleServer(id, function(input, output, session) {
+ |
+
| 138 | +! | +
+ ns <- session$ns+ |
+
| 139 | ++ | + + | +
| 140 | +! | +
+ lapply(seq_along(tables), function(idx) {
+ |
+
| 141 | +! | +
+ output[[paste0("table_", idx)]] <- renderTable(
+ |
+
| 142 | +! | +
+ tables[[idx]],+ |
+
| 143 | +! | +
+ bordered = TRUE,+ |
+
| 144 | +! | +
+ caption = names(tables)[idx],+ |
+
| 145 | +! | +
+ caption.placement = "top"+ |
+
| 146 | ++ |
+ )+ |
+
| 147 | ++ |
+ })+ |
+
| 148 | ++ | + + | +
| 149 | +! | +
+ if (show_metadata) {
+ |
+
| 150 | +! | +
+ observeEvent(+ |
+
| 151 | +! | +
+ input$metadata_button, showModal(+ |
+
| 152 | +! | +
+ modalDialog(+ |
+
| 153 | +! | +
+ title = "Metadata",+ |
+
| 154 | +! | +
+ dataTableOutput(ns("metadata_table")),
+ |
+
| 155 | +! | +
+ size = "l",+ |
+
| 156 | +! | +
+ easyClose = TRUE+ |
+
| 157 | ++ |
+ )+ |
+
| 158 | ++ |
+ )+ |
+
| 159 | ++ |
+ )+ |
+
| 160 | ++ | + + | +
| 161 | +! | +
+ metadata_data_frame <- reactive({
+ |
+
| 162 | +! | +
+ datanames <- teal.data::datanames(data())+ |
+
| 163 | +! | +
+ convert_metadata_to_dataframe(+ |
+
| 164 | +! | +
+ lapply(datanames, function(dataname) attr(data()[[dataname]], "metadata")),+ |
+
| 165 | +! | +
+ datanames+ |
+
| 166 | ++ |
+ )+ |
+
| 167 | ++ |
+ })+ |
+
| 168 | ++ | + + | +
| 169 | +! | +
+ output$metadata_table <- renderDataTable({
+ |
+
| 170 | +! | +
+ validate(need(nrow(metadata_data_frame()) > 0, "The data has no associated metadata"))+ |
+
| 171 | +! | +
+ metadata_data_frame()+ |
+
| 172 | ++ |
+ })+ |
+
| 173 | ++ |
+ }+ |
+
| 174 | ++ |
+ })+ |
+
| 175 | ++ |
+ }+ |
+
| 176 | ++ | + + | +
| 177 | ++ |
+ ## utils functions+ |
+
| 178 | ++ | + + | +
| 179 | ++ |
+ get_header_tags <- function(header_text) {
+ |
+
| 180 | +! | +
+ if (length(header_text) == 0) {
+ |
+
| 181 | +! | +
+ return(list())+ |
+
| 182 | ++ |
+ }+ |
+
| 183 | ++ | + + | +
| 184 | +! | +
+ get_single_header_tags <- function(header_text, p_text, header_tag = tags$h4) {
+ |
+
| 185 | +! | +
+ tagList(+ |
+
| 186 | +! | +
+ tags$div(+ |
+
| 187 | +! | +
+ if (!is.null(header_text) && nchar(header_text) > 0) header_tag(header_text),+ |
+
| 188 | +! | +
+ tags$p(p_text)+ |
+
| 189 | ++ |
+ )+ |
+
| 190 | ++ |
+ )+ |
+
| 191 | ++ |
+ }+ |
+
| 192 | ++ | + + | +
| 193 | +! | +
+ header_tags <- get_single_header_tags(names(header_text[1]), header_text[1], header_tag = tags$h3)+ |
+
| 194 | +! | +
+ c(header_tags, mapply(get_single_header_tags, utils::tail(names(header_text), -1), utils::tail(header_text, -1)))+ |
+
| 195 | ++ |
+ }+ |
+
| 196 | ++ | + + | +
| 197 | ++ |
+ get_table_tags <- function(tables, ns) {
+ |
+
| 198 | +! | +
+ if (length(tables) == 0) {
+ |
+
| 199 | +! | +
+ return(list())+ |
+
| 200 | ++ |
+ }+ |
+
| 201 | +! | +
+ table_tags <- c(lapply(seq_along(tables), function(idx) {
+ |
+
| 202 | +! | +
+ list(+ |
+
| 203 | +! | +
+ tableOutput(ns(paste0("table_", idx)))
+ |
+
| 204 | ++ |
+ )+ |
+
| 205 | ++ |
+ }))+ |
+
| 206 | +! | +
+ return(table_tags)+ |
+
| 207 | ++ |
+ }+ |
+
| 208 | ++ | + + | +
| 209 | ++ |
+ get_footer_tags <- function(footnotes) {
+ |
+
| 210 | +! | +
+ if (length(footnotes) == 0) {
+ |
+
| 211 | +! | +
+ return(list())+ |
+
| 212 | ++ |
+ }+ |
+
| 213 | +! | +
+ bold_texts <- if (is.null(names(footnotes))) rep("", length(footnotes)) else names(footnotes)
+ |
+
| 214 | +! | +
+ footnote_tags <- mapply(function(bold_text, value) {
+ |
+
| 215 | +! | +
+ list(+ |
+
| 216 | +! | +
+ tags$div(+ |
+
| 217 | +! | +
+ tags$b(bold_text),+ |
+
| 218 | +! | +
+ value,+ |
+
| 219 | +! | +
+ tags$br()+ |
+
| 220 | ++ |
+ )+ |
+
| 221 | ++ |
+ )+ |
+
| 222 | +! | +
+ }, bold_text = bold_texts, value = footnotes)+ |
+
| 223 | ++ |
+ }+ |
+
| 224 | ++ | + + | +
| 225 | ++ |
+ # take a list of metadata, one item per dataset (raw_metadata each element from datasets$get_metadata())+ |
+
| 226 | ++ |
+ # and the corresponding datanames and output a data.frame with columns {Dataset, Name, Value}.
+ |
+
| 227 | ++ |
+ # which are, the Dataset the metadata came from, the metadata's name and value+ |
+
| 228 | ++ |
+ convert_metadata_to_dataframe <- function(raw_metadata, datanames) {
+ |
+
| 229 | +4x | +
+ output <- mapply(function(metadata, dataname) {
+ |
+
| 230 | +6x | +
+ if (is.null(metadata)) {
+ |
+
| 231 | +2x | +
+ return(data.frame(Dataset = character(0), Name = character(0), Value = character(0)))+ |
+
| 232 | ++ |
+ }+ |
+
| 233 | +4x | +
+ return(data.frame(+ |
+
| 234 | +4x | +
+ Dataset = dataname,+ |
+
| 235 | +4x | +
+ Name = names(metadata),+ |
+
| 236 | +4x | +
+ Value = unname(unlist(lapply(metadata, as.character)))+ |
+
| 237 | ++ |
+ ))+ |
+
| 238 | +4x | +
+ }, raw_metadata, datanames, SIMPLIFY = FALSE)+ |
+
| 239 | +4x | +
+ do.call(rbind, output)+ |
+
| 240 | ++ |
+ }+ |
+
| 1 | ++ |
+ #' `teal` module: Scatterplot and regression analysis+ |
+
| 2 | ++ |
+ #'+ |
+
| 3 | ++ |
+ #' Module for visualizing regression analysis, including scatterplots and+ |
+
| 4 | ++ |
+ #' various regression diagnostics plots.+ |
+
| 5 | ++ |
+ #' It allows users to explore the relationship between a set of regressors and a response variable,+ |
+
| 6 | ++ |
+ #' visualize residuals, and identify outliers.+ |
+
| 7 | ++ |
+ #'+ |
+
| 8 | ++ |
+ #' @note For more examples, please see the vignette "Using regression plots" via+ |
+
| 9 | ++ |
+ #' `vignette("using-regression-plots", package = "teal.modules.general")`.
+ |
+
| 10 | ++ |
+ #'+ |
+
| 11 | ++ |
+ #' @inheritParams teal::module+ |
+
| 12 | ++ |
+ #' @inheritParams shared_params+ |
+
| 13 | ++ |
+ #' @param regressor (`data_extract_spec` or `list` of multiple `data_extract_spec`)+ |
+
| 14 | ++ |
+ #' Regressor variables from an incoming dataset with filtering and selecting.+ |
+
| 15 | ++ |
+ #' @param response (`data_extract_spec` or `list` of multiple `data_extract_spec`)+ |
+
| 16 | ++ |
+ #' Response variables from an incoming dataset with filtering and selecting.+ |
+
| 17 | ++ |
+ #' @param default_outlier_label (`character`) optional, default column selected to label outliers.+ |
+
| 18 | ++ |
+ #' @param default_plot_type (`numeric`) optional, defaults to "Response vs Regressor".+ |
+
| 19 | ++ |
+ #' 1. Response vs Regressor+ |
+
| 20 | ++ |
+ #' 2. Residuals vs Fitted+ |
+
| 21 | ++ |
+ #' 3. Normal Q-Q+ |
+
| 22 | ++ |
+ #' 4. Scale-Location+ |
+
| 23 | ++ |
+ #' 5. Cook's distance+ |
+
| 24 | ++ |
+ #' 6. Residuals vs Leverage+ |
+
| 25 | ++ |
+ #' 7. Cook's dist vs Leverage+ |
+
| 26 | ++ |
+ #' @param label_segment_threshold (`numeric(1)` or `numeric(3)`)+ |
+
| 27 | ++ |
+ #' Minimum distance between label and point on the plot that triggers the creation of+ |
+
| 28 | ++ |
+ #' a line segment between the two.+ |
+
| 29 | ++ |
+ #' This may happen when the label cannot be placed next to the point as it overlaps another+ |
+
| 30 | ++ |
+ #' label or point.+ |
+
| 31 | ++ |
+ #' The value is used as the `min.segment.length` parameter to the [ggrepel::geom_text_repel()] function.+ |
+
| 32 | ++ |
+ #'+ |
+
| 33 | ++ |
+ #' It can take the following forms:+ |
+
| 34 | ++ |
+ #' - `numeric(1)`: Fixed value used for the minimum distance and the slider is not presented in the UI.+ |
+
| 35 | ++ |
+ #' - `numeric(3)`: A slider is presented in the UI (under "Plot settings") to adjust the minimum distance dynamically.+ |
+
| 36 | ++ |
+ #'+ |
+
| 37 | ++ |
+ #' It takes the form of `c(value, min, max)` and it is passed to the `value_min_max`+ |
+
| 38 | ++ |
+ #' argument in `teal.widgets::optionalSliderInputValMinMax`.+ |
+
| 39 | ++ |
+ #'+ |
+
| 40 | ++ |
+ #' @templateVar ggnames `r regression_names`+ |
+
| 41 | ++ |
+ #' @template ggplot2_args_multi+ |
+
| 42 | ++ |
+ #'+ |
+
| 43 | ++ |
+ #' @inherit shared_params return+ |
+
| 44 | ++ |
+ #'+ |
+
| 45 | ++ |
+ #' @examples+ |
+
| 46 | ++ |
+ #' # general data example+ |
+
| 47 | ++ |
+ #' library(teal.widgets)+ |
+
| 48 | ++ |
+ #'+ |
+
| 49 | ++ |
+ #' data <- teal_data()+ |
+
| 50 | ++ |
+ #' data <- within(data, {
+ |
+
| 51 | ++ |
+ #' require(nestcolor)+ |
+
| 52 | ++ |
+ #' CO2 <- CO2+ |
+
| 53 | ++ |
+ #' })+ |
+
| 54 | ++ |
+ #' datanames(data) <- c("CO2")
+ |
+
| 55 | ++ |
+ #'+ |
+
| 56 | ++ |
+ #' app <- init(+ |
+
| 57 | ++ |
+ #' data = data,+ |
+
| 58 | ++ |
+ #' modules = modules(+ |
+
| 59 | ++ |
+ #' tm_a_regression(+ |
+
| 60 | ++ |
+ #' label = "Regression",+ |
+
| 61 | ++ |
+ #' response = data_extract_spec(+ |
+
| 62 | ++ |
+ #' dataname = "CO2",+ |
+
| 63 | ++ |
+ #' select = select_spec(+ |
+
| 64 | ++ |
+ #' label = "Select variable:",+ |
+
| 65 | ++ |
+ #' choices = "uptake",+ |
+
| 66 | ++ |
+ #' selected = "uptake",+ |
+
| 67 | ++ |
+ #' multiple = FALSE,+ |
+
| 68 | ++ |
+ #' fixed = TRUE+ |
+
| 69 | ++ |
+ #' )+ |
+
| 70 | ++ |
+ #' ),+ |
+
| 71 | ++ |
+ #' regressor = data_extract_spec(+ |
+
| 72 | ++ |
+ #' dataname = "CO2",+ |
+
| 73 | ++ |
+ #' select = select_spec(+ |
+
| 74 | ++ |
+ #' label = "Select variables:",+ |
+
| 75 | ++ |
+ #' choices = variable_choices(data[["CO2"]], c("conc", "Treatment")),
+ |
+
| 76 | ++ |
+ #' selected = "conc",+ |
+
| 77 | ++ |
+ #' multiple = TRUE,+ |
+
| 78 | ++ |
+ #' fixed = FALSE+ |
+
| 79 | ++ |
+ #' )+ |
+
| 80 | ++ |
+ #' ),+ |
+
| 81 | ++ |
+ #' ggplot2_args = ggplot2_args(+ |
+
| 82 | ++ |
+ #' labs = list(subtitle = "Plot generated by Regression Module")+ |
+
| 83 | ++ |
+ #' )+ |
+
| 84 | ++ |
+ #' )+ |
+
| 85 | ++ |
+ #' )+ |
+
| 86 | ++ |
+ #' )+ |
+
| 87 | ++ |
+ #' if (interactive()) {
+ |
+
| 88 | ++ |
+ #' shinyApp(app$ui, app$server)+ |
+
| 89 | ++ |
+ #' }+ |
+
| 90 | ++ |
+ #'+ |
+
| 91 | ++ |
+ #' # CDISC data example+ |
+
| 92 | ++ |
+ #' library(teal.widgets)+ |
+
| 93 | ++ |
+ #'+ |
+
| 94 | ++ |
+ #' data <- teal_data()+ |
+
| 95 | ++ |
+ #' data <- within(data, {
+ |
+
| 96 | ++ |
+ #' require(nestcolor)+ |
+
| 97 | ++ |
+ #' ADSL <- rADSL+ |
+
| 98 | ++ |
+ #' })+ |
+
| 99 | ++ |
+ #' datanames(data) <- "ADSL"+ |
+
| 100 | ++ |
+ #' join_keys(data) <- default_cdisc_join_keys[datanames(data)]+ |
+
| 101 | ++ |
+ #'+ |
+
| 102 | ++ |
+ #' app <- init(+ |
+
| 103 | ++ |
+ #' data = data,+ |
+
| 104 | ++ |
+ #' modules = modules(+ |
+
| 105 | ++ |
+ #' tm_a_regression(+ |
+
| 106 | ++ |
+ #' label = "Regression",+ |
+
| 107 | ++ |
+ #' response = data_extract_spec(+ |
+
| 108 | ++ |
+ #' dataname = "ADSL",+ |
+
| 109 | ++ |
+ #' select = select_spec(+ |
+
| 110 | ++ |
+ #' label = "Select variable:",+ |
+
| 111 | ++ |
+ #' choices = "BMRKR1",+ |
+
| 112 | ++ |
+ #' selected = "BMRKR1",+ |
+
| 113 | ++ |
+ #' multiple = FALSE,+ |
+
| 114 | ++ |
+ #' fixed = TRUE+ |
+
| 115 | ++ |
+ #' )+ |
+
| 116 | ++ |
+ #' ),+ |
+
| 117 | ++ |
+ #' regressor = data_extract_spec(+ |
+
| 118 | ++ |
+ #' dataname = "ADSL",+ |
+
| 119 | ++ |
+ #' select = select_spec(+ |
+
| 120 | ++ |
+ #' label = "Select variables:",+ |
+
| 121 | ++ |
+ #' choices = variable_choices(data[["ADSL"]], c("AGE", "SEX", "RACE")),
+ |
+
| 122 | ++ |
+ #' selected = "AGE",+ |
+
| 123 | ++ |
+ #' multiple = TRUE,+ |
+
| 124 | ++ |
+ #' fixed = FALSE+ |
+
| 125 | ++ |
+ #' )+ |
+
| 126 | ++ |
+ #' ),+ |
+
| 127 | ++ |
+ #' ggplot2_args = ggplot2_args(+ |
+
| 128 | ++ |
+ #' labs = list(subtitle = "Plot generated by Regression Module")+ |
+
| 129 | ++ |
+ #' )+ |
+
| 130 | ++ |
+ #' )+ |
+
| 131 | ++ |
+ #' )+ |
+
| 132 | ++ |
+ #' )+ |
+
| 133 | ++ |
+ #' if (interactive()) {
+ |
+
| 134 | ++ |
+ #' shinyApp(app$ui, app$server)+ |
+
| 135 | ++ |
+ #' }+ |
+
| 136 | ++ |
+ #'+ |
+
| 137 | ++ |
+ #' @export+ |
+
| 138 | ++ |
+ #'+ |
+
| 139 | ++ |
+ tm_a_regression <- function(label = "Regression Analysis",+ |
+
| 140 | ++ |
+ regressor,+ |
+
| 141 | ++ |
+ response,+ |
+
| 142 | ++ |
+ plot_height = c(600, 200, 2000),+ |
+
| 143 | ++ |
+ plot_width = NULL,+ |
+
| 144 | ++ |
+ alpha = c(1, 0, 1),+ |
+
| 145 | ++ |
+ size = c(2, 1, 8),+ |
+
| 146 | ++ |
+ ggtheme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void"),
+ |
+
| 147 | ++ |
+ ggplot2_args = teal.widgets::ggplot2_args(),+ |
+
| 148 | ++ |
+ pre_output = NULL,+ |
+
| 149 | ++ |
+ post_output = NULL,+ |
+
| 150 | ++ |
+ default_plot_type = 1,+ |
+
| 151 | ++ |
+ default_outlier_label = "USUBJID",+ |
+
| 152 | ++ |
+ label_segment_threshold = c(0.5, 0, 10)) {
+ |
+
| 153 | +! | +
+ logger::log_info("Initializing tm_a_regression")
+ |
+
| 154 | ++ | + + | +
| 155 | ++ |
+ # Normalize the parameters+ |
+
| 156 | +! | +
+ if (inherits(regressor, "data_extract_spec")) regressor <- list(regressor)+ |
+
| 157 | +! | +
+ if (inherits(response, "data_extract_spec")) response <- list(response)+ |
+
| 158 | +! | +
+ if (inherits(ggplot2_args, "ggplot2_args")) ggplot2_args <- list(default = ggplot2_args)+ |
+
| 159 | ++ | + + | +
| 160 | ++ |
+ # Start of assertions+ |
+
| 161 | +! | +
+ checkmate::assert_string(label)+ |
+
| 162 | +! | +
+ checkmate::assert_list(regressor, types = "data_extract_spec")+ |
+
| 163 | ++ | + + | +
| 164 | +! | +
+ checkmate::assert_list(response, types = "data_extract_spec")+ |
+
| 165 | +! | +
+ assert_single_selection(response)+ |
+
| 166 | ++ | + + | +
| 167 | +! | +
+ checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE)+ |
+
| 168 | +! | +
+ checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height")+ |
+
| 169 | ++ | + + | +
| 170 | +! | +
+ checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE)+ |
+
| 171 | +! | +
+ checkmate::assert_numeric(+ |
+
| 172 | +! | +
+ plot_width[1],+ |
+
| 173 | +! | +
+ lower = plot_width[2],+ |
+
| 174 | +! | +
+ upper = plot_width[3],+ |
+
| 175 | +! | +
+ null.ok = TRUE,+ |
+
| 176 | +! | +
+ .var.name = "plot_width"+ |
+
| 177 | ++ |
+ )+ |
+
| 178 | ++ | + + | +
| 179 | +! | +
+ if (length(alpha) == 1) {
+ |
+
| 180 | +! | +
+ checkmate::assert_numeric(alpha, any.missing = FALSE, finite = TRUE)+ |
+
| 181 | ++ |
+ } else {
+ |
+
| 182 | +! | +
+ checkmate::assert_numeric(alpha, len = 3, any.missing = FALSE, finite = TRUE)+ |
+
| 183 | +! | +
+ checkmate::assert_numeric(alpha[1], lower = alpha[2], upper = alpha[3], .var.name = "alpha")+ |
+
| 184 | ++ |
+ }+ |
+
| 185 | ++ | + + | +
| 186 | +! | +
+ if (length(size) == 1) {
+ |
+
| 187 | +! | +
+ checkmate::assert_numeric(size, any.missing = FALSE, finite = TRUE)+ |
+
| 188 | ++ |
+ } else {
+ |
+
| 189 | +! | +
+ checkmate::assert_numeric(size, len = 3, any.missing = FALSE, finite = TRUE)+ |
+
| 190 | +! | +
+ checkmate::assert_numeric(size[1], lower = size[2], upper = size[3], .var.name = "size")+ |
+
| 191 | ++ |
+ }+ |
+
| 192 | ++ | + + | +
| 193 | +! | +
+ ggtheme <- match.arg(ggtheme)+ |
+
| 194 | ++ | + + | +
| 195 | +! | +
+ plot_choices <- c(+ |
+
| 196 | +! | +
+ "Response vs Regressor", "Residuals vs Fitted", "Normal Q-Q", "Scale-Location",+ |
+
| 197 | +! | +
+ "Cook's distance", "Residuals vs Leverage", "Cook's dist vs Leverage"+ |
+
| 198 | ++ |
+ )+ |
+
| 199 | +! | +
+ checkmate::assert_list(ggplot2_args, types = "ggplot2_args")+ |
+
| 200 | +! | +
+ checkmate::assert_subset(names(ggplot2_args), c("default", plot_choices))
+ |
+
| 201 | ++ | + + | +
| 202 | +! | +
+ 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 | +! | +
+ checkmate::assert_choice(default_plot_type, seq.int(1L, length(plot_choices)))+ |
+
| 205 | +! | +
+ checkmate::assert_string(default_outlier_label)+ |
+
| 206 | ++ | + + | +
| 207 | +! | +
+ if (length(label_segment_threshold) == 1) {
+ |
+
| 208 | +! | +
+ checkmate::assert_numeric(label_segment_threshold, any.missing = FALSE, finite = TRUE)+ |
+
| 209 | ++ |
+ } else {
+ |
+
| 210 | +! | +
+ checkmate::assert_numeric(label_segment_threshold, len = 3, any.missing = FALSE, finite = TRUE)+ |
+
| 211 | +! | +
+ checkmate::assert_numeric(+ |
+
| 212 | +! | +
+ label_segment_threshold[1],+ |
+
| 213 | +! | +
+ lower = label_segment_threshold[2],+ |
+
| 214 | +! | +
+ upper = label_segment_threshold[3],+ |
+
| 215 | +! | +
+ .var.name = "label_segment_threshold"+ |
+
| 216 | ++ |
+ )+ |
+
| 217 | ++ |
+ }+ |
+
| 218 | ++ |
+ # End of assertions+ |
+
| 219 | ++ | + + | +
| 220 | ++ |
+ # Make UI args+ |
+
| 221 | +! | +
+ args <- as.list(environment())+ |
+
| 222 | +! | +
+ args[["plot_choices"]] <- plot_choices+ |
+
| 223 | +! | +
+ data_extract_list <- list(+ |
+
| 224 | +! | +
+ regressor = regressor,+ |
+
| 225 | +! | +
+ response = response+ |
+
| 226 | ++ |
+ )+ |
+
| 227 | ++ | + + | +
| 228 | +! | +
+ module(+ |
+
| 229 | +! | +
+ label = label,+ |
+
| 230 | +! | +
+ server = srv_a_regression,+ |
+
| 231 | +! | +
+ ui = ui_a_regression,+ |
+
| 232 | +! | +
+ ui_args = args,+ |
+
| 233 | +! | +
+ server_args = c(+ |
+
| 234 | +! | +
+ data_extract_list,+ |
+
| 235 | +! | +
+ list(+ |
+
| 236 | +! | +
+ plot_height = plot_height,+ |
+
| 237 | +! | +
+ plot_width = plot_width,+ |
+
| 238 | +! | +
+ default_outlier_label = default_outlier_label,+ |
+
| 239 | +! | +
+ ggplot2_args = ggplot2_args+ |
+
| 240 | ++ |
+ )+ |
+
| 241 | ++ |
+ ),+ |
+
| 242 | +! | +
+ datanames = teal.transform::get_extract_datanames(data_extract_list)+ |
+
| 243 | ++ |
+ )+ |
+
| 244 | ++ |
+ }+ |
+
| 245 | ++ | + + | +
| 246 | ++ |
+ # UI function for the regression module+ |
+
| 247 | ++ |
+ ui_a_regression <- function(id, ...) {
+ |
+
| 248 | +! | +
+ ns <- NS(id)+ |
+
| 249 | +! | +
+ args <- list(...)+ |
+
| 250 | +! | +
+ is_single_dataset_value <- teal.transform::is_single_dataset(args$regressor, args$response)+ |
+
| 251 | ++ | + + | +
| 252 | +! | +
+ teal.widgets::standard_layout(+ |
+
| 253 | +! | +
+ output = teal.widgets::white_small_well(tags$div(+ |
+
| 254 | +! | +
+ teal.widgets::plot_with_settings_ui(id = ns("myplot")),
+ |
+
| 255 | +! | +
+ tags$div(verbatimTextOutput(ns("text")))
+ |
+
| 256 | ++ |
+ )),+ |
+
| 257 | +! | +
+ encoding = div(+ |
+
| 258 | ++ |
+ ### Reporter+ |
+
| 259 | +! | +
+ teal.reporter::simple_reporter_ui(ns("simple_reporter")),
+ |
+
| 260 | ++ |
+ ###+ |
+
| 261 | +! | +
+ tags$label("Encodings", class = "text-primary"),
+ |
+
| 262 | +! | +
+ teal.transform::datanames_input(args[c("response", "regressor")]),
+ |
+
| 263 | +! | +
+ teal.transform::data_extract_ui(+ |
+
| 264 | +! | +
+ id = ns("response"),
+ |
+
| 265 | +! | +
+ label = "Response variable",+ |
+
| 266 | +! | +
+ data_extract_spec = args$response,+ |
+
| 267 | +! | +
+ is_single_dataset = is_single_dataset_value+ |
+
| 268 | ++ |
+ ),+ |
+
| 269 | +! | +
+ teal.transform::data_extract_ui(+ |
+
| 270 | +! | +
+ id = ns("regressor"),
+ |
+
| 271 | +! | +
+ label = "Regressor variables",+ |
+
| 272 | +! | +
+ data_extract_spec = args$regressor,+ |
+
| 273 | +! | +
+ is_single_dataset = is_single_dataset_value+ |
+
| 274 | ++ |
+ ),+ |
+
| 275 | +! | +
+ radioButtons(+ |
+
| 276 | +! | +
+ ns("plot_type"),
+ |
+
| 277 | +! | +
+ label = "Plot type:",+ |
+
| 278 | +! | +
+ choices = args$plot_choices,+ |
+
| 279 | +! | +
+ selected = args$plot_choices[args$default_plot_type]+ |
+
| 280 | ++ |
+ ),+ |
+
| 281 | +! | +
+ checkboxInput(ns("show_outlier"), label = "Display outlier labels", value = TRUE),
+ |
+
| 282 | +! | +
+ conditionalPanel(+ |
+
| 283 | +! | +
+ condition = "input['show_outlier']",+ |
+
| 284 | +! | +
+ ns = ns,+ |
+
| 285 | +! | +
+ teal.widgets::optionalSliderInput(+ |
+
| 286 | +! | +
+ ns("outlier"),
+ |
+
| 287 | +! | +
+ div(+ |
+
| 288 | +! | +
+ class = "teal-tooltip",+ |
+
| 289 | +! | +
+ tagList(+ |
+
| 290 | +! | +
+ "Outlier definition:",+ |
+
| 291 | +! | +
+ icon("circle-info"),
+ |
+
| 292 | +! | +
+ span(+ |
+
| 293 | +! | +
+ class = "tooltiptext",+ |
+
| 294 | +! | +
+ paste(+ |
+
| 295 | +! | +
+ "Use the slider to choose the cut-off value to define outliers.",+ |
+
| 296 | +! | +
+ "Points with a Cook's distance greater than",+ |
+
| 297 | +! | +
+ "the value on the slider times the mean of the Cook's distance of the dataset will have labels."+ |
+
| 298 | ++ |
+ )+ |
+
| 299 | ++ |
+ )+ |
+
| 300 | ++ |
+ )+ |
+
| 301 | ++ |
+ ),+ |
+
| 302 | +! | +
+ min = 1, max = 10, value = 9, ticks = FALSE, step = .1+ |
+
| 303 | ++ |
+ ),+ |
+
| 304 | +! | +
+ teal.widgets::optionalSelectInput(+ |
+
| 305 | +! | +
+ ns("label_var"),
+ |
+
| 306 | +! | +
+ multiple = FALSE,+ |
+
| 307 | +! | +
+ label = "Outlier label"+ |
+
| 308 | ++ |
+ )+ |
+
| 309 | ++ |
+ ),+ |
+
| 310 | +! | +
+ teal.widgets::panel_group(+ |
+
| 311 | +! | +
+ teal.widgets::panel_item(+ |
+
| 312 | +! | +
+ title = "Plot settings",+ |
+
| 313 | +! | +
+ teal.widgets::optionalSliderInputValMinMax(ns("alpha"), "Opacity:", args$alpha, ticks = FALSE),
+ |
+
| 314 | +! | +
+ teal.widgets::optionalSliderInputValMinMax(ns("size"), "Points size:", args$size, ticks = FALSE),
+ |
+
| 315 | +! | +
+ teal.widgets::optionalSliderInputValMinMax(+ |
+
| 316 | +! | +
+ inputId = ns("label_min_segment"),
+ |
+
| 317 | +! | +
+ label = div(+ |
+
| 318 | +! | +
+ class = "teal-tooltip",+ |
+
| 319 | +! | +
+ tagList(+ |
+
| 320 | +! | +
+ "Label min. segment:",+ |
+
| 321 | +! | +
+ icon("circle-info"),
+ |
+
| 322 | +! | +
+ span(+ |
+
| 323 | +! | +
+ class = "tooltiptext",+ |
+
| 324 | +! | +
+ paste(+ |
+
| 325 | +! | +
+ "Use the slider to choose the cut-off value to define minimum distance between label and point",+ |
+
| 326 | +! | +
+ "that generates a line segment.",+ |
+
| 327 | +! | +
+ "It's only valid when 'Display outlier labels' is checked."+ |
+
| 328 | ++ |
+ )+ |
+
| 329 | ++ |
+ )+ |
+
| 330 | ++ |
+ )+ |
+
| 331 | ++ |
+ ),+ |
+
| 332 | +! | +
+ value_min_max = args$label_segment_threshold,+ |
+
| 333 | ++ |
+ # Extra parameters to sliderInput+ |
+
| 334 | +! | +
+ ticks = FALSE,+ |
+
| 335 | +! | +
+ step = .1,+ |
+
| 336 | +! | +
+ round = FALSE+ |
+
| 337 | ++ |
+ ),+ |
+
| 338 | +! | +
+ selectInput(+ |
+
| 339 | +! | +
+ inputId = ns("ggtheme"),
+ |
+
| 340 | +! | +
+ label = "Theme (by ggplot):",+ |
+
| 341 | +! | +
+ choices = ggplot_themes,+ |
+
| 342 | +! | +
+ selected = args$ggtheme,+ |
+
| 343 | +! | +
+ multiple = FALSE+ |
+
| 344 | ++ |
+ )+ |
+
| 345 | ++ |
+ )+ |
+
| 346 | ++ |
+ )+ |
+
| 347 | ++ |
+ ),+ |
+
| 348 | +! | +
+ forms = tagList(+ |
+
| 349 | +! | +
+ teal.widgets::verbatim_popup_ui(ns("warning"), "Show Warnings"),
+ |
+
| 350 | +! | +
+ teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code")
+ |
+
| 351 | ++ |
+ ),+ |
+
| 352 | +! | +
+ pre_output = args$pre_output,+ |
+
| 353 | +! | +
+ post_output = args$post_output+ |
+
| 354 | ++ |
+ )+ |
+
| 355 | ++ |
+ }+ |
+
| 356 | ++ | + + | +
| 357 | ++ |
+ # Server function for the regression module+ |
+
| 358 | ++ |
+ srv_a_regression <- function(id,+ |
+
| 359 | ++ |
+ data,+ |
+
| 360 | ++ |
+ reporter,+ |
+
| 361 | ++ |
+ filter_panel_api,+ |
+
| 362 | ++ |
+ response,+ |
+
| 363 | ++ |
+ regressor,+ |
+
| 364 | ++ |
+ plot_height,+ |
+
| 365 | ++ |
+ plot_width,+ |
+
| 366 | ++ |
+ ggplot2_args,+ |
+
| 367 | ++ |
+ default_outlier_label) {
+ |
+
| 368 | +! | +
+ with_reporter <- !missing(reporter) && inherits(reporter, "Reporter")+ |
+
| 369 | +! | +
+ with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI")+ |
+
| 370 | +! | +
+ checkmate::assert_class(data, "reactive")+ |
+
| 371 | +! | +
+ checkmate::assert_class(isolate(data()), "teal_data")+ |
+
| 372 | +! | +
+ moduleServer(id, function(input, output, session) {
+ |
+
| 373 | +! | +
+ rule_rvr1 <- function(value) {
+ |
+
| 374 | +! | +
+ if (isTRUE(input$plot_type == "Response vs Regressor")) {
+ |
+
| 375 | +! | +
+ if (length(value) > 1L) {
+ |
+
| 376 | +! | +
+ "This plot can only have one regressor."+ |
+
| 377 | ++ |
+ }+ |
+
| 378 | ++ |
+ }+ |
+
| 379 | ++ |
+ }+ |
+
| 380 | +! | +
+ rule_rvr2 <- function(other) {
+ |
+
| 381 | +! | +
+ function(value) {
+ |
+
| 382 | +! | +
+ if (isTRUE(input$plot_type == "Response vs Regressor")) {
+ |
+
| 383 | +! | +
+ otherval <- selector_list()[[other]]()$select+ |
+
| 384 | +! | +
+ if (isTRUE(value == otherval)) {
+ |
+
| 385 | +! | +
+ "Response and Regressor must be different."+ |
+
| 386 | ++ |
+ }+ |
+
| 387 | ++ |
+ }+ |
+
| 388 | ++ |
+ }+ |
+
| 389 | ++ |
+ }+ |
+
| 390 | ++ | + + | +
| 391 | +! | +
+ selector_list <- teal.transform::data_extract_multiple_srv(+ |
+
| 392 | +! | +
+ data_extract = list(response = response, regressor = regressor),+ |
+
| 393 | +! | +
+ datasets = data,+ |
+
| 394 | +! | +
+ select_validation_rule = list(+ |
+
| 395 | +! | +
+ regressor = shinyvalidate::compose_rules(+ |
+
| 396 | +! | +
+ shinyvalidate::sv_required("At least one regressor should be selected."),
+ |
+
| 397 | +! | +
+ rule_rvr1,+ |
+
| 398 | +! | +
+ rule_rvr2("response")
+ |
+
| 399 | ++ |
+ ),+ |
+
| 400 | +! | +
+ response = shinyvalidate::compose_rules(+ |
+
| 401 | +! | +
+ shinyvalidate::sv_required("At least one response should be selected."),
+ |
+
| 402 | +! | +
+ rule_rvr2("regressor")
+ |
+
| 403 | ++ |
+ )+ |
+
| 404 | ++ |
+ )+ |
+
| 405 | ++ |
+ )+ |
+
| 406 | ++ | + + | +
| 407 | +! | +
+ iv_r <- reactive({
+ |
+
| 408 | +! | +
+ iv <- shinyvalidate::InputValidator$new()+ |
+
| 409 | +! | +
+ teal.transform::compose_and_enable_validators(iv, selector_list)+ |
+
| 410 | ++ |
+ })+ |
+
| 411 | ++ | + + | +
| 412 | +! | +
+ iv_out <- shinyvalidate::InputValidator$new()+ |
+
| 413 | +! | +
+ iv_out$condition(~ isTRUE(input$show_outlier))+ |
+
| 414 | +! | +
+ iv_out$add_rule("label_var", shinyvalidate::sv_required("Please provide an `Outlier label` variable"))
+ |
+
| 415 | +! | +
+ iv_out$enable()+ |
+
| 416 | ++ | + + | +
| 417 | +! | +
+ anl_merged_input <- teal.transform::merge_expression_srv(+ |
+
| 418 | +! | +
+ selector_list = selector_list,+ |
+
| 419 | +! | +
+ datasets = data+ |
+
| 420 | ++ |
+ )+ |
+
| 421 | ++ | + + | +
| 422 | +! | +
+ regression_var <- reactive({
+ |
+
| 423 | +! | +
+ teal::validate_inputs(iv_r())+ |
+
| 424 | ++ | + + | +
| 425 | +! | +
+ list(+ |
+
| 426 | +! | +
+ response = as.vector(anl_merged_input()$columns_source$response),+ |
+
| 427 | +! | +
+ regressor = as.vector(anl_merged_input()$columns_source$regressor)+ |
+
| 428 | ++ |
+ )+ |
+
| 429 | ++ |
+ })+ |
+
| 430 | ++ | + + | +
| 431 | +! | +
+ anl_merged_q <- reactive({
+ |
+
| 432 | +! | +
+ req(anl_merged_input())+ |
+
| 433 | +! | +
+ data() %>%+ |
+
| 434 | +! | +
+ teal.code::eval_code(as.expression(anl_merged_input()$expr))+ |
+
| 435 | ++ |
+ })+ |
+
| 436 | ++ | + + | +
| 437 | ++ |
+ # sets qenv object and populates it with data merge call and fit expression+ |
+
| 438 | +! | +
+ fit_r <- reactive({
+ |
+
| 439 | +! | +
+ ANL <- anl_merged_q()[["ANL"]]+ |
+
| 440 | +! | +
+ teal::validate_has_data(ANL, 10)+ |
+
| 441 | ++ | + + | +
| 442 | +! | +
+ validate(need(is.numeric(ANL[regression_var()$response][[1]]), "Response variable should be numeric."))+ |
+
| 443 | ++ | + + | +
| 444 | +! | +
+ teal::validate_has_data(+ |
+
| 445 | +! | +
+ ANL[, c(regression_var()$response, regression_var()$regressor)], 10,+ |
+
| 446 | +! | +
+ complete = TRUE, allow_inf = FALSE+ |
+
| 447 | ++ |
+ )+ |
+
| 448 | ++ | + + | +
| 449 | +! | +
+ form <- stats::as.formula(+ |
+
| 450 | +! | +
+ paste(+ |
+
| 451 | +! | +
+ regression_var()$response,+ |
+
| 452 | +! | +
+ paste(+ |
+
| 453 | +! | +
+ regression_var()$regressor,+ |
+
| 454 | +! | +
+ collapse = " + "+ |
+
| 455 | ++ |
+ ),+ |
+
| 456 | +! | +
+ sep = " ~ "+ |
+
| 457 | ++ |
+ )+ |
+
| 458 | ++ |
+ )+ |
+
| 459 | ++ | + + | +
| 460 | +! | +
+ if (input$show_outlier) {
+ |
+
| 461 | +! | +
+ opts <- teal.transform::variable_choices(ANL)+ |
+
| 462 | +! | +
+ selected <- if (!is.null(isolate(input$label_var)) && isolate(input$label_var) %in% as.character(opts)) {
+ |
+
| 463 | +! | +
+ isolate(input$label_var)+ |
+
| 464 | ++ |
+ } else {
+ |
+
| 465 | +! | +
+ if (length(opts[as.character(opts) == default_outlier_label]) == 0) {
+ |
+
| 466 | +! | +
+ opts[[1]]+ |
+
| 467 | ++ |
+ } else {
+ |
+
| 468 | +! | +
+ opts[as.character(opts) == default_outlier_label]+ |
+
| 469 | ++ |
+ }+ |
+
| 470 | ++ |
+ }+ |
+
| 471 | +! | +
+ teal.widgets::updateOptionalSelectInput(+ |
+
| 472 | +! | +
+ session = session,+ |
+
| 473 | +! | +
+ inputId = "label_var",+ |
+
| 474 | +! | +
+ choices = opts,+ |
+
| 475 | +! | +
+ selected = selected+ |
+
| 476 | ++ |
+ )+ |
+
| 477 | ++ | + + | +
| 478 | +! | +
+ data <- fortify(stats::lm(form, data = ANL))+ |
+
| 479 | +! | +
+ cooksd <- data$.cooksd[!is.nan(data$.cooksd)]+ |
+
| 480 | +! | +
+ max_outlier <- max(ceiling(max(cooksd) / mean(cooksd)), 2)+ |
+
| 481 | +! | +
+ cur_outlier <- isolate(input$outlier)+ |
+
| 482 | +! | +
+ updateSliderInput(+ |
+
| 483 | +! | +
+ session = session,+ |
+
| 484 | +! | +
+ inputId = "outlier",+ |
+
| 485 | +! | +
+ min = 1,+ |
+
| 486 | +! | +
+ max = max_outlier,+ |
+
| 487 | +! | +
+ value = if (cur_outlier < max_outlier) cur_outlier else max_outlier * .9+ |
+
| 488 | ++ |
+ )+ |
+
| 489 | ++ |
+ }+ |
+
| 490 | ++ | + + | +
| 491 | +! | +
+ anl_merged_q() %>%+ |
+
| 492 | +! | +
+ teal.code::eval_code(substitute(fit <- stats::lm(form, data = ANL), env = list(form = form))) %>%+ |
+
| 493 | +! | +
+ teal.code::eval_code(quote({
+ |
+
| 494 | +! | +
+ for (regressor in names(fit$contrasts)) {
+ |
+
| 495 | +! | +
+ alts <- paste0(levels(ANL[[regressor]]), collapse = "|")+ |
+
| 496 | +! | +
+ names(fit$coefficients) <- gsub(+ |
+
| 497 | +! | +
+ paste0("^(", regressor, ")(", alts, ")$"), paste0("\\1", ": ", "\\2"), names(fit$coefficients)
+ |
+
| 498 | ++ |
+ )+ |
+
| 499 | ++ |
+ }+ |
+
| 500 | ++ |
+ })) %>%+ |
+
| 501 | +! | +
+ teal.code::eval_code(quote(summary(fit)))+ |
+
| 502 | ++ |
+ })+ |
+
| 503 | ++ | + + | +
| 504 | +! | +
+ label_col <- reactive({
+ |
+
| 505 | +! | +
+ teal::validate_inputs(iv_out)+ |
+
| 506 | ++ | + + | +
| 507 | +! | +
+ substitute(+ |
+
| 508 | +! | +
+ expr = dplyr::if_else(+ |
+
| 509 | +! | +
+ data$.cooksd > outliers * mean(data$.cooksd, na.rm = TRUE),+ |
+
| 510 | +! | +
+ as.character(stats::na.omit(ANL)[[label_var]]),+ |
+
| 511 | ++ |
+ ""+ |
+
| 512 | ++ |
+ ) %>%+ |
+
| 513 | +! | +
+ dplyr::if_else(is.na(.), "cooksd == NaN", .),+ |
+
| 514 | +! | +
+ env = list(outliers = input$outlier, label_var = input$label_var)+ |
+
| 515 | ++ |
+ )+ |
+
| 516 | ++ |
+ })+ |
+
| 517 | ++ | + + | +
| 518 | +! | +
+ label_min_segment <- reactive({
+ |
+
| 519 | +! | +
+ input$label_min_segment+ |
+
| 520 | ++ |
+ })+ |
+
| 521 | ++ | + + | +
| 522 | +! | +
+ outlier_label <- reactive({
+ |
+
| 523 | +! | +
+ substitute(+ |
+
| 524 | +! | +
+ expr = ggrepel::geom_text_repel(+ |
+
| 525 | +! | +
+ label = label_col,+ |
+
| 526 | +! | +
+ color = "red",+ |
+
| 527 | +! | +
+ hjust = 0,+ |
+
| 528 | +! | +
+ vjust = 1,+ |
+
| 529 | +! | +
+ max.overlaps = Inf,+ |
+
| 530 | +! | +
+ min.segment.length = label_min_segment,+ |
+
| 531 | +! | +
+ segment.alpha = 0.5,+ |
+
| 532 | +! | +
+ seed = 123+ |
+
| 533 | ++ |
+ ),+ |
+
| 534 | +! | +
+ env = list(label_col = label_col(), label_min_segment = label_min_segment())+ |
+
| 535 | ++ |
+ )+ |
+
| 536 | ++ |
+ })+ |
+
| 537 | ++ | + + | +
| 538 | +! | +
+ output_q <- reactive({
+ |
+
| 539 | +! | +
+ alpha <- input$alpha+ |
+
| 540 | +! | +
+ size <- input$size+ |
+
| 541 | +! | +
+ ggtheme <- input$ggtheme+ |
+
| 542 | +! | +
+ input_type <- input$plot_type+ |
+
| 543 | +! | +
+ show_outlier <- input$show_outlier+ |
+
| 544 | ++ | + + | +
| 545 | +! | +
+ teal::validate_inputs(iv_r())+ |
+
| 546 | ++ | + + | +
| 547 | +! | +
+ plot_type_0 <- function() {
+ |
+
| 548 | +! | +
+ fit <- fit_r()[["fit"]]+ |
+
| 549 | +! | +
+ ANL <- anl_merged_q()[["ANL"]]+ |
+
| 550 | ++ | + + | +
| 551 | +! | +
+ stopifnot(ncol(fit$model) == 2)+ |
+
| 552 | ++ | + + | +
| 553 | +! | +
+ if (!is.factor(ANL[[regression_var()$regressor]])) {
+ |
+
| 554 | +! | +
+ shinyjs::show("size")
+ |
+
| 555 | +! | +
+ shinyjs::show("alpha")
+ |
+
| 556 | +! | +
+ plot <- substitute(+ |
+
| 557 | +! | +
+ env = list(+ |
+
| 558 | +! | +
+ regressor = regression_var()$regressor,+ |
+
| 559 | +! | +
+ response = regression_var()$response,+ |
+
| 560 | +! | +
+ size = size,+ |
+
| 561 | +! | +
+ alpha = alpha+ |
+
| 562 | ++ |
+ ),+ |
+
| 563 | +! | +
+ expr = ggplot(+ |
+
| 564 | +! | +
+ fit$model[, 2:1],+ |
+
| 565 | +! | +
+ aes_string(regressor, response)+ |
+
| 566 | ++ |
+ ) ++ |
+
| 567 | +! | +
+ geom_point(size = size, alpha = alpha) ++ |
+
| 568 | +! | +
+ stat_smooth(+ |
+
| 569 | +! | +
+ method = "lm",+ |
+
| 570 | +! | +
+ formula = y ~ x,+ |
+
| 571 | +! | +
+ se = FALSE+ |
+
| 572 | ++ |
+ )+ |
+
| 573 | ++ |
+ )+ |
+
| 574 | +! | +
+ if (show_outlier) {
+ |
+
| 575 | +! | +
+ plot <- substitute(+ |
+
| 576 | +! | +
+ expr = plot + outlier_label,+ |
+
| 577 | +! | +
+ env = list(plot = plot, outlier_label = outlier_label())+ |
+
| 578 | ++ |
+ )+ |
+
| 579 | ++ |
+ }+ |
+
| 580 | ++ |
+ } else {
+ |
+
| 581 | +! | +
+ shinyjs::hide("size")
+ |
+
| 582 | +! | +
+ shinyjs::hide("alpha")
+ |
+
| 583 | +! | +
+ plot <- substitute(+ |
+
| 584 | +! | +
+ expr = ggplot(fit$model[, 2:1], aes_string(regressor, response)) ++ |
+
| 585 | +! | +
+ geom_boxplot(),+ |
+
| 586 | +! | +
+ env = list(regressor = regression_var()$regressor, response = regression_var()$response)+ |
+
| 587 | ++ |
+ )+ |
+
| 588 | +! | +
+ if (show_outlier) {
+ |
+
| 589 | +! | +
+ plot <- substitute(expr = plot + outlier_label, env = list(plot = plot, outlier_label = outlier_label()))+ |
+
| 590 | ++ |
+ }+ |
+
| 591 | ++ |
+ }+ |
+
| 592 | ++ | + + | +
| 593 | +! | +
+ parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(+ |
+
| 594 | +! | +
+ teal.widgets::resolve_ggplot2_args(+ |
+
| 595 | +! | +
+ user_plot = ggplot2_args[["Response vs Regressor"]],+ |
+
| 596 | +! | +
+ user_default = ggplot2_args$default,+ |
+
| 597 | +! | +
+ module_plot = teal.widgets::ggplot2_args(+ |
+
| 598 | +! | +
+ labs = list(+ |
+
| 599 | +! | +
+ title = "Response vs Regressor",+ |
+
| 600 | +! | +
+ x = varname_w_label(regression_var()$regressor, ANL),+ |
+
| 601 | +! | +
+ y = varname_w_label(regression_var()$response, ANL)+ |
+
| 602 | ++ |
+ ),+ |
+
| 603 | +! | +
+ theme = list()+ |
+
| 604 | ++ |
+ )+ |
+
| 605 | ++ |
+ ),+ |
+
| 606 | +! | +
+ ggtheme = ggtheme+ |
+
| 607 | ++ |
+ )+ |
+
| 608 | ++ | + + | +
| 609 | +! | +
+ teal.code::eval_code(+ |
+
| 610 | +! | +
+ fit_r(),+ |
+
| 611 | +! | +
+ substitute(+ |
+
| 612 | +! | +
+ expr = {
+ |
+
| 613 | +! | +
+ class(fit$residuals) <- NULL+ |
+
| 614 | +! | +
+ data <- fortify(fit)+ |
+
| 615 | +! | +
+ g <- plot+ |
+
| 616 | +! | +
+ print(g)+ |
+
| 617 | ++ |
+ },+ |
+
| 618 | +! | +
+ env = list(+ |
+
| 619 | +! | +
+ plot = Reduce(function(x, y) call("+", x, y), c(plot, parsed_ggplot2_args))
+ |
+
| 620 | ++ |
+ )+ |
+
| 621 | ++ |
+ )+ |
+
| 622 | ++ |
+ )+ |
+
| 623 | ++ |
+ }+ |
+
| 624 | ++ | + + | +
| 625 | +! | +
+ plot_base <- function() {
+ |
+
| 626 | +! | +
+ base_fit <- fit_r()+ |
+
| 627 | +! | +
+ teal.code::eval_code(+ |
+
| 628 | +! | +
+ base_fit,+ |
+
| 629 | +! | +
+ quote({
+ |
+
| 630 | +! | +
+ class(fit$residuals) <- NULL+ |
+
| 631 | ++ | + + | +
| 632 | +! | +
+ data <- ggplot2::fortify(fit)+ |
+
| 633 | ++ | + + | +
| 634 | +! | +
+ smooth <- function(x, y) {
+ |
+
| 635 | +! | +
+ as.data.frame(stats::lowess(x, y, f = 2 / 3, iter = 3))+ |
+
| 636 | ++ |
+ }+ |
+
| 637 | ++ | + + | +
| 638 | +! | +
+ smoothy_aes <- ggplot2::aes_string(x = "x", y = "y")+ |
+
| 639 | ++ | + + | +
| 640 | +! | +
+ reg_form <- deparse(fit$call[[2]])+ |
+
| 641 | ++ |
+ })+ |
+
| 642 | ++ |
+ )+ |
+
| 643 | ++ |
+ }+ |
+
| 644 | ++ | + + | +
| 645 | +! | +
+ plot_type_1 <- function(plot_base) {
+ |
+
| 646 | +! | +
+ shinyjs::show("size")
+ |
+
| 647 | +! | +
+ shinyjs::show("alpha")
+ |
+
| 648 | +! | +
+ plot <- substitute(+ |
+
| 649 | +! | +
+ expr = ggplot(data = data, aes(.fitted, .resid)) ++ |
+
| 650 | +! | +
+ geom_point(size = size, alpha = alpha) ++ |
+
| 651 | +! | +
+ geom_hline(yintercept = 0, linetype = "dashed", size = 1) ++ |
+
| 652 | +! | +
+ geom_line(data = smoothy, mapping = smoothy_aes),+ |
+
| 653 | +! | +
+ env = list(size = size, alpha = alpha)+ |
+
| 654 | ++ |
+ )+ |
+
| 655 | +! | +
+ if (show_outlier) {
+ |
+
| 656 | +! | +
+ plot <- substitute(expr = plot + outlier_label, env = list(plot = plot, outlier_label = outlier_label()))+ |
+
| 657 | ++ |
+ }+ |
+
| 658 | ++ | + + | +
| 659 | +! | +
+ parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(+ |
+
| 660 | +! | +
+ teal.widgets::resolve_ggplot2_args(+ |
+
| 661 | +! | +
+ user_plot = ggplot2_args[["Residuals vs Fitted"]],+ |
+
| 662 | +! | +
+ user_default = ggplot2_args$default,+ |
+
| 663 | +! | +
+ module_plot = teal.widgets::ggplot2_args(+ |
+
| 664 | +! | +
+ labs = list(+ |
+
| 665 | +! | +
+ x = quote(paste0("Fitted values\nlm(", reg_form, ")")),
+ |
+
| 666 | +! | +
+ y = "Residuals",+ |
+
| 667 | +! | +
+ title = "Residuals vs Fitted"+ |
+
| 668 | ++ |
+ )+ |
+
| 669 | ++ |
+ )+ |
+
| 670 | ++ |
+ ),+ |
+
| 671 | +! | +
+ ggtheme = ggtheme+ |
+
| 672 | ++ |
+ )+ |
+
| 673 | ++ | + + | +
| 674 | +! | +
+ teal.code::eval_code(+ |
+
| 675 | +! | +
+ plot_base,+ |
+
| 676 | +! | +
+ substitute(+ |
+
| 677 | +! | +
+ expr = {
+ |
+
| 678 | +! | +
+ smoothy <- smooth(data$.fitted, data$.resid)+ |
+
| 679 | +! | +
+ g <- plot+ |
+
| 680 | +! | +
+ print(g)+ |
+
| 681 | ++ |
+ },+ |
+
| 682 | +! | +
+ env = list(+ |
+
| 683 | +! | +
+ plot = Reduce(function(x, y) call("+", x, y), c(plot, parsed_ggplot2_args))
+ |
+
| 684 | ++ |
+ )+ |
+
| 685 | ++ |
+ )+ |
+
| 686 | ++ |
+ )+ |
+
| 687 | ++ |
+ }+ |
+
| 688 | ++ | + + | +
| 689 | +! | +
+ plot_type_2 <- function(plot_base) {
+ |
+
| 690 | +! | +
+ shinyjs::show("size")
+ |
+
| 691 | +! | +
+ shinyjs::show("alpha")
+ |
+
| 692 | +! | +
+ plot <- substitute(+ |
+
| 693 | +! | +
+ expr = ggplot(data = data, aes(sample = .stdresid)) ++ |
+
| 694 | +! | +
+ stat_qq(size = size, alpha = alpha) ++ |
+
| 695 | +! | +
+ geom_abline(linetype = "dashed"),+ |
+
| 696 | +! | +
+ env = list(size = size, alpha = alpha)+ |
+
| 697 | ++ |
+ )+ |
+
| 698 | +! | +
+ if (show_outlier) {
+ |
+
| 699 | +! | +
+ plot <- substitute(+ |
+
| 700 | +! | +
+ expr = plot ++ |
+
| 701 | +! | +
+ stat_qq(+ |
+
| 702 | +! | +
+ geom = ggrepel::GeomTextRepel,+ |
+
| 703 | +! | +
+ label = label_col %>%+ |
+
| 704 | +! | +
+ data.frame(label = .) %>%+ |
+
| 705 | +! | +
+ dplyr::filter(label != "cooksd == NaN") %>%+ |
+
| 706 | +! | +
+ unlist(),+ |
+
| 707 | +! | +
+ color = "red",+ |
+
| 708 | +! | +
+ hjust = 0,+ |
+
| 709 | +! | +
+ vjust = 0,+ |
+
| 710 | +! | +
+ max.overlaps = Inf,+ |
+
| 711 | +! | +
+ min.segment.length = label_min_segment,+ |
+
| 712 | +! | +
+ segment.alpha = .5,+ |
+
| 713 | +! | +
+ seed = 123+ |
+
| 714 | ++ |
+ ),+ |
+
| 715 | +! | +
+ env = list(plot = plot, label_col = label_col(), label_min_segment = label_min_segment())+ |
+
| 716 | ++ |
+ )+ |
+
| 717 | ++ |
+ }+ |
+
| 718 | ++ | + + | +
| 719 | +! | +
+ parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(+ |
+
| 720 | +! | +
+ teal.widgets::resolve_ggplot2_args(+ |
+
| 721 | +! | +
+ user_plot = ggplot2_args[["Normal Q-Q"]],+ |
+
| 722 | +! | +
+ user_default = ggplot2_args$default,+ |
+
| 723 | +! | +
+ module_plot = teal.widgets::ggplot2_args(+ |
+
| 724 | +! | +
+ labs = list(+ |
+
| 725 | +! | +
+ x = quote(paste0("Theoretical Quantiles\nlm(", reg_form, ")")),
+ |
+
| 726 | +! | +
+ y = "Standardized residuals",+ |
+
| 727 | +! | +
+ title = "Normal Q-Q"+ |
+
| 728 | ++ |
+ )+ |
+
| 729 | ++ |
+ )+ |
+
| 730 | ++ |
+ ),+ |
+
| 731 | +! | +
+ ggtheme = ggtheme+ |
+
| 732 | ++ |
+ )+ |
+
| 733 | ++ | + + | +
| 734 | +! | +
+ teal.code::eval_code(+ |
+
| 735 | +! | +
+ plot_base,+ |
+
| 736 | +! | +
+ substitute(+ |
+
| 737 | +! | +
+ expr = {
+ |
+
| 738 | +! | +
+ g <- plot+ |
+
| 739 | +! | +
+ print(g)+ |
+
| 740 | ++ |
+ },+ |
+
| 741 | +! | +
+ env = list(+ |
+
| 742 | +! | +
+ plot = Reduce(function(x, y) call("+", x, y), c(plot, parsed_ggplot2_args))
+ |
+
| 743 | ++ |
+ )+ |
+
| 744 | ++ |
+ )+ |
+
| 745 | ++ |
+ )+ |
+
| 746 | ++ |
+ }+ |
+
| 747 | ++ | + + | +
| 748 | +! | +
+ plot_type_3 <- function(plot_base) {
+ |
+
| 749 | +! | +
+ shinyjs::show("size")
+ |
+
| 750 | +! | +
+ shinyjs::show("alpha")
+ |
+
| 751 | +! | +
+ plot <- substitute(+ |
+
| 752 | +! | +
+ expr = ggplot(data = data, aes(.fitted, sqrt(abs(.stdresid)))) ++ |
+
| 753 | +! | +
+ geom_point(size = size, alpha = alpha) ++ |
+
| 754 | +! | +
+ geom_line(data = smoothy, mapping = smoothy_aes),+ |
+
| 755 | +! | +
+ env = list(size = size, alpha = alpha)+ |
+
| 756 | ++ |
+ )+ |
+
| 757 | +! | +
+ if (show_outlier) {
+ |
+
| 758 | +! | +
+ plot <- substitute(expr = plot + outlier_label, env = list(plot = plot, outlier_label = outlier_label()))+ |
+
| 759 | ++ |
+ }+ |
+
| 760 | ++ | + + | +
| 761 | +! | +
+ parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(+ |
+
| 762 | +! | +
+ teal.widgets::resolve_ggplot2_args(+ |
+
| 763 | +! | +
+ user_plot = ggplot2_args[["Scale-Location"]],+ |
+
| 764 | +! | +
+ user_default = ggplot2_args$default,+ |
+
| 765 | +! | +
+ module_plot = teal.widgets::ggplot2_args(+ |
+
| 766 | +! | +
+ labs = list(+ |
+
| 767 | +! | +
+ x = quote(paste0("Fitted values\nlm(", reg_form, ")")),
+ |
+
| 768 | +! | +
+ y = quote(expression(sqrt(abs(`Standardized residuals`)))),+ |
+
| 769 | +! | +
+ title = "Scale-Location"+ |
+
| 770 | ++ |
+ )+ |
+
| 771 | ++ |
+ )+ |
+
| 772 | ++ |
+ ),+ |
+
| 773 | +! | +
+ ggtheme = ggtheme+ |
+
| 774 | ++ |
+ )+ |
+
| 775 | ++ | + + | +
| 776 | +! | +
+ teal.code::eval_code(+ |
+
| 777 | +! | +
+ plot_base,+ |
+
| 778 | +! | +
+ substitute(+ |
+
| 779 | +! | +
+ expr = {
+ |
+
| 780 | +! | +
+ smoothy <- smooth(data$.fitted, sqrt(abs(data$.stdresid)))+ |
+
| 781 | +! | +
+ g <- plot+ |
+
| 782 | +! | +
+ print(g)+ |
+
| 783 | ++ |
+ },+ |
+
| 784 | +! | +
+ env = list(+ |
+
| 785 | +! | +
+ plot = Reduce(function(x, y) call("+", x, y), c(plot, parsed_ggplot2_args))
+ |
+
| 786 | ++ |
+ )+ |
+
| 787 | ++ |
+ )+ |
+
| 788 | ++ |
+ )+ |
+
| 789 | ++ |
+ }+ |
+
| 790 | ++ | + + | +
| 791 | +! | +
+ plot_type_4 <- function(plot_base) {
+ |
+
| 792 | +! | +
+ shinyjs::hide("size")
+ |
+
| 793 | +! | +
+ shinyjs::show("alpha")
+ |
+
| 794 | +! | +
+ plot <- substitute(+ |
+
| 795 | +! | +
+ expr = ggplot(data = data, aes(seq_along(.cooksd), .cooksd)) ++ |
+
| 796 | +! | +
+ geom_col(alpha = alpha),+ |
+
| 797 | +! | +
+ env = list(alpha = alpha)+ |
+
| 798 | ++ |
+ )+ |
+
| 799 | +! | +
+ if (show_outlier) {
+ |
+
| 800 | +! | +
+ plot <- substitute(+ |
+
| 801 | +! | +
+ expr = plot ++ |
+
| 802 | +! | +
+ geom_hline(+ |
+
| 803 | +! | +
+ yintercept = c(+ |
+
| 804 | +! | +
+ outlier * mean(data$.cooksd, na.rm = TRUE),+ |
+
| 805 | +! | +
+ mean(data$.cooksd, na.rm = TRUE)+ |
+
| 806 | ++ |
+ ),+ |
+
| 807 | +! | +
+ color = "red",+ |
+
| 808 | +! | +
+ linetype = "dashed"+ |
+
| 809 | ++ |
+ ) ++ |
+
| 810 | +! | +
+ geom_text(+ |
+
| 811 | +! | +
+ aes(+ |
+
| 812 | +! | +
+ x = 0,+ |
+
| 813 | +! | +
+ y = mean(data$.cooksd, na.rm = TRUE),+ |
+
| 814 | +! | +
+ label = paste("mu", "=", round(mean(data$.cooksd, na.rm = TRUE), 4)),
+ |
+
| 815 | +! | +
+ vjust = -1,+ |
+
| 816 | +! | +
+ hjust = 0,+ |
+
| 817 | +! | +
+ color = "red",+ |
+
| 818 | +! | +
+ angle = 90+ |
+
| 819 | ++ |
+ ),+ |
+
| 820 | +! | +
+ parse = TRUE,+ |
+
| 821 | +! | +
+ show.legend = FALSE+ |
+
| 822 | ++ |
+ ) ++ |
+
| 823 | +! | +
+ outlier_label,+ |
+
| 824 | +! | +
+ env = list(plot = plot, outlier = input$outlier, outlier_label = outlier_label())+ |
+
| 825 | ++ |
+ )+ |
+
| 826 | ++ |
+ }+ |
+
| 827 | ++ | + + | +
| 828 | +! | +
+ parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(+ |
+
| 829 | +! | +
+ teal.widgets::resolve_ggplot2_args(+ |
+
| 830 | +! | +
+ user_plot = ggplot2_args[["Cook's distance"]],+ |
+
| 831 | +! | +
+ user_default = ggplot2_args$default,+ |
+
| 832 | +! | +
+ module_plot = teal.widgets::ggplot2_args(+ |
+
| 833 | +! | +
+ labs = list(+ |
+
| 834 | +! | +
+ x = quote(paste0("Obs. number\nlm(", reg_form, ")")),
+ |
+
| 835 | +! | +
+ y = "Cook's distance",+ |
+
| 836 | +! | +
+ title = "Cook's distance"+ |
+
| 837 | ++ |
+ )+ |
+
| 838 | ++ |
+ )+ |
+
| 839 | ++ |
+ ),+ |
+
| 840 | +! | +
+ ggtheme = ggtheme+ |
+
| 841 | ++ |
+ )+ |
+
| 842 | ++ | + + | +
| 843 | +! | +
+ teal.code::eval_code(+ |
+
| 844 | +! | +
+ plot_base,+ |
+
| 845 | +! | +
+ substitute(+ |
+
| 846 | +! | +
+ expr = {
+ |
+
| 847 | +! | +
+ g <- plot+ |
+
| 848 | +! | +
+ print(g)+ |
+
| 849 | ++ |
+ },+ |
+
| 850 | +! | +
+ env = list(+ |
+
| 851 | +! | +
+ plot = Reduce(function(x, y) call("+", x, y), c(plot, parsed_ggplot2_args))
+ |
+
| 852 | ++ |
+ )+ |
+
| 853 | ++ |
+ )+ |
+
| 854 | ++ |
+ )+ |
+
| 855 | ++ |
+ }+ |
+
| 856 | ++ | + + | +
| 857 | ++ | + + | +
| 858 | +! | +
+ plot_type_5 <- function(plot_base) {
+ |
+
| 859 | +! | +
+ shinyjs::show("size")
+ |
+
| 860 | +! | +
+ shinyjs::show("alpha")
+ |
+
| 861 | +! | +
+ plot <- substitute(+ |
+
| 862 | +! | +
+ expr = ggplot(data = data, aes(.hat, .stdresid)) ++ |
+
| 863 | +! | +
+ geom_vline(+ |
+
| 864 | +! | +
+ size = 1,+ |
+
| 865 | +! | +
+ colour = "black",+ |
+
| 866 | +! | +
+ linetype = "dashed",+ |
+
| 867 | +! | +
+ xintercept = 0+ |
+
| 868 | ++ |
+ ) ++ |
+
| 869 | +! | +
+ geom_hline(+ |
+
| 870 | +! | +
+ size = 1,+ |
+
| 871 | +! | +
+ colour = "black",+ |
+
| 872 | +! | +
+ linetype = "dashed",+ |
+
| 873 | +! | +
+ yintercept = 0+ |
+
| 874 | ++ |
+ ) ++ |
+
| 875 | +! | +
+ geom_point(size = size, alpha = alpha) ++ |
+
| 876 | +! | +
+ geom_line(data = smoothy, mapping = smoothy_aes),+ |
+
| 877 | +! | +
+ env = list(size = size, alpha = alpha)+ |
+
| 878 | ++ |
+ )+ |
+
| 879 | +! | +
+ if (show_outlier) {
+ |
+
| 880 | +! | +
+ plot <- substitute(expr = plot + outlier_label, env = list(plot = plot, outlier_label = outlier_label()))+ |
+
| 881 | ++ |
+ }+ |
+
| 882 | ++ | + + | +
| 883 | +! | +
+ parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(+ |
+
| 884 | +! | +
+ teal.widgets::resolve_ggplot2_args(+ |
+
| 885 | +! | +
+ user_plot = ggplot2_args[["Residuals vs Leverage"]],+ |
+
| 886 | +! | +
+ user_default = ggplot2_args$default,+ |
+
| 887 | +! | +
+ module_plot = teal.widgets::ggplot2_args(+ |
+
| 888 | +! | +
+ labs = list(+ |
+
| 889 | +! | +
+ x = quote(paste0("Standardized residuals\nlm(", reg_form, ")")),
+ |
+
| 890 | +! | +
+ y = "Leverage",+ |
+
| 891 | +! | +
+ title = "Residuals vs Leverage"+ |
+
| 892 | ++ |
+ )+ |
+
| 893 | ++ |
+ )+ |
+
| 894 | ++ |
+ ),+ |
+
| 895 | +! | +
+ ggtheme = ggtheme+ |
+
| 896 | ++ |
+ )+ |
+
| 897 | ++ | + + | +
| 898 | +! | +
+ teal.code::eval_code(+ |
+
| 899 | +! | +
+ plot_base,+ |
+
| 900 | +! | +
+ substitute(+ |
+
| 901 | +! | +
+ expr = {
+ |
+
| 902 | +! | +
+ smoothy <- smooth(data$.hat, data$.stdresid)+ |
+
| 903 | +! | +
+ g <- plot+ |
+
| 904 | +! | +
+ print(g)+ |
+
| 905 | ++ |
+ },+ |
+
| 906 | +! | +
+ env = list(+ |
+
| 907 | +! | +
+ plot = Reduce(function(x, y) call("+", x, y), c(plot, parsed_ggplot2_args))
+ |
+
| 908 | ++ |
+ )+ |
+
| 909 | ++ |
+ )+ |
+
| 910 | ++ |
+ )+ |
+
| 911 | ++ |
+ }+ |
+
| 912 | ++ | + + | +
| 913 | +! | +
+ plot_type_6 <- function(plot_base) {
+ |
+
| 914 | +! | +
+ shinyjs::show("size")
+ |
+
| 915 | +! | +
+ shinyjs::show("alpha")
+ |
+
| 916 | +! | +
+ plot <- substitute(+ |
+
| 917 | +! | +
+ expr = ggplot(data = data, aes(.hat, .cooksd)) ++ |
+
| 918 | +! | +
+ geom_vline(xintercept = 0, colour = NA) ++ |
+
| 919 | +! | +
+ geom_abline(+ |
+
| 920 | +! | +
+ slope = seq(0, 3, by = 0.5),+ |
+
| 921 | +! | +
+ colour = "black",+ |
+
| 922 | +! | +
+ linetype = "dashed",+ |
+
| 923 | +! | +
+ size = 1+ |
+
| 924 | ++ |
+ ) ++ |
+
| 925 | +! | +
+ geom_line(data = smoothy, mapping = smoothy_aes) ++ |
+
| 926 | +! | +
+ geom_point(size = size, alpha = alpha),+ |
+
| 927 | +! | +
+ env = list(size = size, alpha = alpha)+ |
+
| 928 | ++ |
+ )+ |
+
| 929 | +! | +
+ if (show_outlier) {
+ |
+
| 930 | +! | +
+ plot <- substitute(expr = plot + outlier_label, env = list(plot = plot, outlier_label = outlier_label()))+ |
+
| 931 | ++ |
+ }+ |
+
| 932 | ++ | + + | +
| 933 | +! | +
+ parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(+ |
+
| 934 | +! | +
+ teal.widgets::resolve_ggplot2_args(+ |
+
| 935 | +! | +
+ user_plot = ggplot2_args[["Cook's dist vs Leverage"]],+ |
+
| 936 | +! | +
+ user_default = ggplot2_args$default,+ |
+
| 937 | +! | +
+ module_plot = teal.widgets::ggplot2_args(+ |
+
| 938 | +! | +
+ labs = list(+ |
+
| 939 | +! | +
+ x = quote(paste0("Leverage\nlm(", reg_form, ")")),
+ |
+
| 940 | +! | +
+ y = "Cooks's distance",+ |
+
| 941 | +! | +
+ title = "Cook's dist vs Leverage"+ |
+
| 942 | ++ |
+ )+ |
+
| 943 | ++ |
+ )+ |
+
| 944 | ++ |
+ ),+ |
+
| 945 | +! | +
+ ggtheme = ggtheme+ |
+
| 946 | ++ |
+ )+ |
+
| 947 | ++ | + + | +
| 948 | +! | +
+ teal.code::eval_code(+ |
+
| 949 | +! | +
+ plot_base,+ |
+
| 950 | +! | +
+ substitute(+ |
+
| 951 | +! | +
+ expr = {
+ |
+
| 952 | +! | +
+ smoothy <- smooth(data$.hat, data$.cooksd)+ |
+
| 953 | +! | +
+ g <- plot+ |
+
| 954 | +! | +
+ print(g)+ |
+
| 955 | ++ |
+ },+ |
+
| 956 | +! | +
+ env = list(+ |
+
| 957 | +! | +
+ plot = Reduce(function(x, y) call("+", x, y), c(plot, parsed_ggplot2_args))
+ |
+
| 958 | ++ |
+ )+ |
+
| 959 | ++ |
+ )+ |
+
| 960 | ++ |
+ )+ |
+
| 961 | ++ |
+ }+ |
+
| 962 | ++ | + + | +
| 963 | +! | +
+ qenv <- if (input_type == "Response vs Regressor") {
+ |
+
| 964 | +! | +
+ plot_type_0()+ |
+
| 965 | ++ |
+ } else {
+ |
+
| 966 | +! | +
+ plot_base_q <- plot_base()+ |
+
| 967 | +! | +
+ switch(input_type,+ |
+
| 968 | +! | +
+ "Residuals vs Fitted" = plot_base_q %>% plot_type_1(),+ |
+
| 969 | +! | +
+ "Normal Q-Q" = plot_base_q %>% plot_type_2(),+ |
+
| 970 | +! | +
+ "Scale-Location" = plot_base_q %>% plot_type_3(),+ |
+
| 971 | +! | +
+ "Cook's distance" = plot_base_q %>% plot_type_4(),+ |
+
| 972 | +! | +
+ "Residuals vs Leverage" = plot_base_q %>% plot_type_5(),+ |
+
| 973 | +! | +
+ "Cook's dist vs Leverage" = plot_base_q %>% plot_type_6()+ |
+
| 974 | ++ |
+ )+ |
+
| 975 | ++ |
+ }+ |
+
| 976 | +! | +
+ qenv+ |
+
| 977 | ++ |
+ })+ |
+
| 978 | ++ | + + | +
| 979 | ++ | + + | +
| 980 | +! | +
+ fitted <- reactive(output_q()[["fit"]])+ |
+
| 981 | +! | +
+ plot_r <- reactive(output_q()[["g"]])+ |
+
| 982 | ++ | + + | +
| 983 | ++ |
+ # Insert the plot into a plot_with_settings module from teal.widgets+ |
+
| 984 | +! | +
+ pws <- teal.widgets::plot_with_settings_srv(+ |
+
| 985 | +! | +
+ id = "myplot",+ |
+
| 986 | +! | +
+ plot_r = plot_r,+ |
+
| 987 | +! | +
+ height = plot_height,+ |
+
| 988 | +! | +
+ width = plot_width+ |
+
| 989 | ++ |
+ )+ |
+
| 990 | ++ | + + | +
| 991 | +! | +
+ output$text <- renderText({
+ |
+
| 992 | +! | +
+ req(iv_r()$is_valid())+ |
+
| 993 | +! | +
+ req(iv_out$is_valid())+ |
+
| 994 | +! | +
+ paste(utils::capture.output(summary(teal.code::dev_suppress(fitted())))[-1],+ |
+
| 995 | +! | +
+ collapse = "\n"+ |
+
| 996 | ++ |
+ )+ |
+
| 997 | ++ |
+ })+ |
+
| 998 | ++ | + + | +
| 999 | +! | +
+ teal.widgets::verbatim_popup_srv(+ |
+
| 1000 | +! | +
+ id = "warning",+ |
+
| 1001 | +! | +
+ verbatim_content = reactive(teal.code::get_warnings(output_q())),+ |
+
| 1002 | +! | +
+ title = "Warning",+ |
+
| 1003 | +! | +
+ disabled = reactive(is.null(teal.code::get_warnings(output_q())))+ |
+
| 1004 | ++ |
+ )+ |
+
| 1005 | ++ | + + | +
| 1006 | +! | +
+ teal.widgets::verbatim_popup_srv(+ |
+
| 1007 | +! | +
+ id = "rcode",+ |
+
| 1008 | +! | +
+ verbatim_content = reactive(teal.code::get_code(output_q())),+ |
+
| 1009 | +! | +
+ title = "R code for the regression plot",+ |
+
| 1010 | ++ |
+ )+ |
+
| 1011 | ++ | + + | +
| 1012 | ++ |
+ ### REPORTER+ |
+
| 1013 | +! | +
+ if (with_reporter) {
+ |
+
| 1014 | +! | +
+ card_fun <- function(comment, label) {
+ |
+
| 1015 | +! | +
+ card <- teal::report_card_template(+ |
+
| 1016 | +! | +
+ title = "Linear Regression Plot",+ |
+
| 1017 | +! | +
+ label = label,+ |
+
| 1018 | +! | +
+ with_filter = with_filter,+ |
+
| 1019 | +! | +
+ filter_panel_api = filter_panel_api+ |
+
| 1020 | ++ |
+ )+ |
+
| 1021 | +! | +
+ card$append_text("Plot", "header3")
+ |
+
| 1022 | +! | +
+ card$append_plot(plot_r(), dim = pws$dim())+ |
+
| 1023 | +! | +
+ if (!comment == "") {
+ |
+
| 1024 | +! | +
+ card$append_text("Comment", "header3")
+ |
+
| 1025 | +! | +
+ card$append_text(comment)+ |
+
| 1026 | ++ |
+ }+ |
+
| 1027 | +! | +
+ card$append_src(teal.code::get_code(output_q()))+ |
+
| 1028 | +! | +
+ card+ |
+
| 1029 | ++ |
+ }+ |
+
| 1030 | +! | +
+ teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
+ |
+
| 1031 | ++ |
+ }+ |
+
| 1032 | ++ |
+ ###+ |
+
| 1033 | ++ |
+ })+ |
+
| 1034 | ++ |
+ }+ |
+
| 1035 | ++ | + + | +
| 1036 | ++ |
+ regression_names <- paste0(+ |
+
| 1037 | ++ |
+ '"Response vs Regressor", "Residuals vs Fitted", ',+ |
+
| 1038 | ++ |
+ '"Scale-Location", "Cook\'s distance", "Residuals vs Leverage"", "Cook\'s dist vs Leverage"'+ |
+
| 1039 | ++ |
+ )+ |
+
| 1 | ++ |
+ #' `teal` module: Stack plots of variables and show association with reference variable+ |
+
| 2 | ++ |
+ #'+ |
+
| 3 | ++ |
+ #' Module provides functionality for visualizing the distribution of variables and+ |
+
| 4 | ++ |
+ #' their association with a reference variable.+ |
+
| 5 | ++ |
+ #' It supports configuring the appearance of the plots, including themes and whether to show associations.+ |
+
| 6 | ++ |
+ #'+ |
+
| 7 | ++ |
+ #'+ |
+
| 8 | ++ |
+ #' @note For more examples, please see the vignette "Using association plot" via+ |
+
| 9 | ++ |
+ #' `vignette("using-association-plot", package = "teal.modules.general")`.
+ |
+
| 10 | ++ |
+ #'+ |
+
| 11 | ++ |
+ #' @inheritParams teal::module+ |
+
| 12 | ++ |
+ #' @inheritParams shared_params+ |
+
| 13 | ++ |
+ #' @param ref (`data_extract_spec` or `list` of multiple `data_extract_spec`)+ |
+
| 14 | ++ |
+ #' Reference variable, must accepts a `data_extract_spec` with `select_spec(multiple = FALSE)`+ |
+
| 15 | ++ |
+ #' to ensure single selection option.+ |
+
| 16 | ++ |
+ #' @param vars (`data_extract_spec` or `list` of multiple `data_extract_spec`)+ |
+
| 17 | ++ |
+ #' Variables to be associated with the reference variable.+ |
+
| 18 | ++ |
+ #' @param show_association (`logical`) optional, whether show association of `vars`+ |
+
| 19 | ++ |
+ #' with reference variable. Defaults to `TRUE`.+ |
+
| 20 | ++ |
+ #' @param distribution_theme,association_theme (`character`) optional, `ggplot2` themes to be used by default.+ |
+
| 21 | ++ |
+ #' Default to `"gray"`.+ |
+
| 22 | ++ |
+ #'+ |
+
| 23 | ++ |
+ #' @templateVar ggnames "Bivariate1", "Bivariate2"+ |
+
| 24 | ++ |
+ #' @template ggplot2_args_multi+ |
+
| 25 | ++ |
+ #'+ |
+
| 26 | ++ |
+ #' @inherit shared_params return+ |
+
| 27 | ++ |
+ #'+ |
+
| 28 | ++ |
+ #' @examples+ |
+
| 29 | ++ |
+ #' library(teal.widgets)+ |
+
| 30 | ++ |
+ #'+ |
+
| 31 | ++ |
+ #' # general data example+ |
+
| 32 | ++ |
+ #' data <- teal_data()+ |
+
| 33 | ++ |
+ #' data <- within(data, {
+ |
+
| 34 | ++ |
+ #' require(nestcolor)+ |
+
| 35 | ++ |
+ #' CO2 <- CO2+ |
+
| 36 | ++ |
+ #' factors <- names(Filter(isTRUE, vapply(CO2, is.factor, logical(1L))))+ |
+
| 37 | ++ |
+ #' CO2[factors] <- lapply(CO2[factors], as.character)+ |
+
| 38 | ++ |
+ #' })+ |
+
| 39 | ++ |
+ #' datanames(data) <- c("CO2")
+ |
+
| 40 | ++ |
+ #'+ |
+
| 41 | ++ |
+ #' app <- init(+ |
+
| 42 | ++ |
+ #' data = data,+ |
+
| 43 | ++ |
+ #' modules = modules(+ |
+
| 44 | ++ |
+ #' tm_g_association(+ |
+
| 45 | ++ |
+ #' ref = data_extract_spec(+ |
+
| 46 | ++ |
+ #' dataname = "CO2",+ |
+
| 47 | ++ |
+ #' select = select_spec(+ |
+
| 48 | ++ |
+ #' label = "Select variable:",+ |
+
| 49 | ++ |
+ #' choices = variable_choices(data[["CO2"]], c("Plant", "Type", "Treatment")),
+ |
+
| 50 | ++ |
+ #' selected = "Plant",+ |
+
| 51 | ++ |
+ #' fixed = FALSE+ |
+
| 52 | ++ |
+ #' )+ |
+
| 53 | ++ |
+ #' ),+ |
+
| 54 | ++ |
+ #' vars = data_extract_spec(+ |
+
| 55 | ++ |
+ #' dataname = "CO2",+ |
+
| 56 | ++ |
+ #' select = select_spec(+ |
+
| 57 | ++ |
+ #' label = "Select variables:",+ |
+
| 58 | ++ |
+ #' choices = variable_choices(data[["CO2"]], c("Plant", "Type", "Treatment")),
+ |
+
| 59 | ++ |
+ #' selected = "Treatment",+ |
+
| 60 | ++ |
+ #' multiple = TRUE,+ |
+
| 61 | ++ |
+ #' fixed = FALSE+ |
+
| 62 | ++ |
+ #' )+ |
+
| 63 | ++ |
+ #' ),+ |
+
| 64 | ++ |
+ #' ggplot2_args = ggplot2_args(+ |
+
| 65 | ++ |
+ #' labs = list(subtitle = "Plot generated by Association Module")+ |
+
| 66 | ++ |
+ #' )+ |
+
| 67 | ++ |
+ #' )+ |
+
| 68 | ++ |
+ #' )+ |
+
| 69 | ++ |
+ #' )+ |
+
| 70 | ++ |
+ #' if (interactive()) {
+ |
+
| 71 | ++ |
+ #' shinyApp(app$ui, app$server)+ |
+
| 72 | ++ |
+ #' }+ |
+
| 73 | ++ |
+ #'+ |
+
| 74 | ++ |
+ #' # CDISC data example+ |
+
| 75 | ++ |
+ #' data <- teal_data()+ |
+
| 76 | ++ |
+ #' data <- within(data, {
+ |
+
| 77 | ++ |
+ #' require(nestcolor)+ |
+
| 78 | ++ |
+ #' ADSL <- rADSL+ |
+
| 79 | ++ |
+ #' })+ |
+
| 80 | ++ |
+ #' datanames(data) <- "ADSL"+ |
+
| 81 | ++ |
+ #' join_keys(data) <- default_cdisc_join_keys[datanames(data)]+ |
+
| 82 | ++ |
+ #'+ |
+
| 83 | ++ |
+ #' app <- init(+ |
+
| 84 | ++ |
+ #' data = data,+ |
+
| 85 | ++ |
+ #' modules = modules(+ |
+
| 86 | ++ |
+ #' tm_g_association(+ |
+
| 87 | ++ |
+ #' ref = data_extract_spec(+ |
+
| 88 | ++ |
+ #' dataname = "ADSL",+ |
+
| 89 | ++ |
+ #' select = select_spec(+ |
+
| 90 | ++ |
+ #' label = "Select variable:",+ |
+
| 91 | ++ |
+ #' choices = variable_choices(+ |
+
| 92 | ++ |
+ #' data[["ADSL"]],+ |
+
| 93 | ++ |
+ #' c("SEX", "RACE", "COUNTRY", "ARM", "STRATA1", "STRATA2", "ITTFL", "BMRKR2")
+ |
+
| 94 | ++ |
+ #' ),+ |
+
| 95 | ++ |
+ #' selected = "RACE",+ |
+
| 96 | ++ |
+ #' fixed = FALSE+ |
+
| 97 | ++ |
+ #' )+ |
+
| 98 | ++ |
+ #' ),+ |
+
| 99 | ++ |
+ #' vars = data_extract_spec(+ |
+
| 100 | ++ |
+ #' dataname = "ADSL",+ |
+
| 101 | ++ |
+ #' select = select_spec(+ |
+
| 102 | ++ |
+ #' label = "Select variables:",+ |
+
| 103 | ++ |
+ #' choices = variable_choices(+ |
+
| 104 | ++ |
+ #' data[["ADSL"]],+ |
+
| 105 | ++ |
+ #' c("SEX", "RACE", "COUNTRY", "ARM", "STRATA1", "STRATA2", "ITTFL", "BMRKR2")
+ |
+
| 106 | ++ |
+ #' ),+ |
+
| 107 | ++ |
+ #' selected = "BMRKR2",+ |
+
| 108 | ++ |
+ #' multiple = TRUE,+ |
+
| 109 | ++ |
+ #' fixed = FALSE+ |
+
| 110 | ++ |
+ #' )+ |
+
| 111 | ++ |
+ #' ),+ |
+
| 112 | ++ |
+ #' ggplot2_args = ggplot2_args(+ |
+
| 113 | ++ |
+ #' labs = list(subtitle = "Plot generated by Association Module")+ |
+
| 114 | ++ |
+ #' )+ |
+
| 115 | ++ |
+ #' )+ |
+
| 116 | ++ |
+ #' )+ |
+
| 117 | ++ |
+ #' )+ |
+
| 118 | ++ |
+ #' if (interactive()) {
+ |
+
| 119 | ++ |
+ #' shinyApp(app$ui, app$server)+ |
+
| 120 | ++ |
+ #' }+ |
+
| 121 | ++ |
+ #'+ |
+
| 122 | ++ |
+ #' @export+ |
+
| 123 | ++ |
+ #'+ |
+
| 124 | ++ |
+ tm_g_association <- function(label = "Association",+ |
+
| 125 | ++ |
+ ref,+ |
+
| 126 | ++ |
+ vars,+ |
+
| 127 | ++ |
+ show_association = TRUE,+ |
+
| 128 | ++ |
+ plot_height = c(600, 400, 5000),+ |
+
| 129 | ++ |
+ plot_width = NULL,+ |
+
| 130 | ++ |
+ distribution_theme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void"), # nolint: line_length.
+ |
+
| 131 | ++ |
+ association_theme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void"), # nolint: line_length.
+ |
+
| 132 | ++ |
+ pre_output = NULL,+ |
+
| 133 | ++ |
+ post_output = NULL,+ |
+
| 134 | ++ |
+ ggplot2_args = teal.widgets::ggplot2_args()) {
+ |
+
| 135 | +! | +
+ logger::log_info("Initializing tm_g_association")
+ |
+
| 136 | ++ | + + | +
| 137 | ++ |
+ # Normalize the parameters+ |
+
| 138 | +! | +
+ if (inherits(ref, "data_extract_spec")) ref <- list(ref)+ |
+
| 139 | +! | +
+ if (inherits(vars, "data_extract_spec")) vars <- list(vars)+ |
+
| 140 | +! | +
+ if (inherits(ggplot2_args, "ggplot2_args")) ggplot2_args <- list(default = ggplot2_args)+ |
+
| 141 | ++ | + + | +
| 142 | ++ |
+ # Start of assertions+ |
+
| 143 | +! | +
+ checkmate::assert_string(label)+ |
+
| 144 | ++ | + + | +
| 145 | +! | +
+ checkmate::assert_list(ref, types = "data_extract_spec")+ |
+
| 146 | +! | +
+ if (!all(vapply(ref, function(x) !x$select$multiple, logical(1)))) {
+ |
+
| 147 | +! | +
+ stop("'ref' should not allow multiple selection")
+ |
+
| 148 | ++ |
+ }+ |
+
| 149 | ++ | + + | +
| 150 | +! | +
+ checkmate::assert_list(vars, types = "data_extract_spec")+ |
+
| 151 | +! | +
+ checkmate::assert_flag(show_association)+ |
+
| 152 | ++ | + + | +
| 153 | +! | +
+ checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE)+ |
+
| 154 | +! | +
+ checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height")+ |
+
| 155 | +! | +
+ checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE)+ |
+
| 156 | +! | +
+ checkmate::assert_numeric(+ |
+
| 157 | +! | +
+ plot_width[1],+ |
+
| 158 | +! | +
+ lower = plot_width[2], upper = plot_width[3], null.ok = TRUE, .var.name = "plot_width"+ |
+
| 159 | ++ |
+ )+ |
+
| 160 | ++ | + + | +
| 161 | +! | +
+ distribution_theme <- match.arg(distribution_theme)+ |
+
| 162 | +! | +
+ association_theme <- match.arg(association_theme)+ |
+
| 163 | ++ | + + | +
| 164 | +! | +
+ checkmate::assert_multi_class(pre_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
+ |
+
| 165 | +! | +
+ checkmate::assert_multi_class(post_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
+ |
+
| 166 | ++ | + + | +
| 167 | +! | +
+ plot_choices <- c("Bivariate1", "Bivariate2")
+ |
+
| 168 | +! | +
+ checkmate::assert_list(ggplot2_args, types = "ggplot2_args")+ |
+
| 169 | +! | +
+ checkmate::assert_subset(names(ggplot2_args), c("default", plot_choices))
+ |
+
| 170 | ++ |
+ # End of assertions+ |
+
| 171 | ++ | + + | +
| 172 | ++ |
+ # Make UI args+ |
+
| 173 | +! | +
+ args <- as.list(environment())+ |
+
| 174 | ++ | + + | +
| 175 | +! | +
+ data_extract_list <- list(+ |
+
| 176 | +! | +
+ ref = ref,+ |
+
| 177 | +! | +
+ vars = vars+ |
+
| 178 | ++ |
+ )+ |
+
| 179 | ++ | + + | +
| 180 | +! | +
+ module(+ |
+
| 181 | +! | +
+ label = label,+ |
+
| 182 | +! | +
+ server = srv_tm_g_association,+ |
+
| 183 | +! | +
+ ui = ui_tm_g_association,+ |
+
| 184 | +! | +
+ ui_args = args,+ |
+
| 185 | +! | +
+ server_args = c(+ |
+
| 186 | +! | +
+ data_extract_list,+ |
+
| 187 | +! | +
+ list(plot_height = plot_height, plot_width = plot_width, ggplot2_args = ggplot2_args)+ |
+
| 188 | ++ |
+ ),+ |
+
| 189 | +! | +
+ datanames = teal.transform::get_extract_datanames(data_extract_list)+ |
+
| 190 | ++ |
+ )+ |
+
| 191 | ++ |
+ }+ |
+
| 192 | ++ | + + | +
| 193 | ++ |
+ # UI function for the association module+ |
+
| 194 | ++ |
+ ui_tm_g_association <- function(id, ...) {
+ |
+
| 195 | +! | +
+ ns <- NS(id)+ |
+
| 196 | +! | +
+ args <- list(...)+ |
+
| 197 | +! | +
+ is_single_dataset_value <- teal.transform::is_single_dataset(args$ref, args$vars)+ |
+
| 198 | ++ | + + | +
| 199 | +! | +
+ teal.widgets::standard_layout(+ |
+
| 200 | +! | +
+ output = teal.widgets::white_small_well(+ |
+
| 201 | +! | +
+ textOutput(ns("title")),
+ |
+
| 202 | +! | +
+ tags$br(),+ |
+
| 203 | +! | +
+ teal.widgets::plot_with_settings_ui(id = ns("myplot"))
+ |
+
| 204 | ++ |
+ ),+ |
+
| 205 | +! | +
+ encoding = div(+ |
+
| 206 | ++ |
+ ### Reporter+ |
+
| 207 | +! | +
+ teal.reporter::simple_reporter_ui(ns("simple_reporter")),
+ |
+
| 208 | ++ |
+ ###+ |
+
| 209 | +! | +
+ tags$label("Encodings", class = "text-primary"),
+ |
+
| 210 | +! | +
+ teal.transform::datanames_input(args[c("ref", "vars")]),
+ |
+
| 211 | +! | +
+ teal.transform::data_extract_ui(+ |
+
| 212 | +! | +
+ id = ns("ref"),
+ |
+
| 213 | +! | +
+ label = "Reference variable",+ |
+
| 214 | +! | +
+ data_extract_spec = args$ref,+ |
+
| 215 | +! | +
+ is_single_dataset = is_single_dataset_value+ |
+
| 216 | ++ |
+ ),+ |
+
| 217 | +! | +
+ teal.transform::data_extract_ui(+ |
+
| 218 | +! | +
+ id = ns("vars"),
+ |
+
| 219 | +! | +
+ label = "Associated variables",+ |
+
| 220 | +! | +
+ data_extract_spec = args$vars,+ |
+
| 221 | +! | +
+ is_single_dataset = is_single_dataset_value+ |
+
| 222 | ++ |
+ ),+ |
+
| 223 | +! | +
+ checkboxInput(+ |
+
| 224 | +! | +
+ ns("association"),
+ |
+
| 225 | +! | +
+ "Association with reference variable",+ |
+
| 226 | +! | +
+ value = args$show_association+ |
+
| 227 | ++ |
+ ),+ |
+
| 228 | +! | +
+ checkboxInput(+ |
+
| 229 | +! | +
+ ns("show_dist"),
+ |
+
| 230 | +! | +
+ "Scaled frequencies",+ |
+
| 231 | +! | +
+ value = FALSE+ |
+
| 232 | ++ |
+ ),+ |
+
| 233 | +! | +
+ checkboxInput(+ |
+
| 234 | +! | +
+ ns("log_transformation"),
+ |
+
| 235 | +! | +
+ "Log transformed",+ |
+
| 236 | +! | +
+ value = FALSE+ |
+
| 237 | ++ |
+ ),+ |
+
| 238 | +! | +
+ teal.widgets::panel_group(+ |
+
| 239 | +! | +
+ teal.widgets::panel_item(+ |
+
| 240 | +! | +
+ title = "Plot settings",+ |
+
| 241 | +! | +
+ teal.widgets::optionalSliderInputValMinMax(ns("alpha"), "Scatterplot opacity:", c(0.5, 0, 1), ticks = FALSE),
+ |
+
| 242 | +! | +
+ teal.widgets::optionalSliderInputValMinMax(ns("size"), "Scatterplot points size:", c(2, 1, 8), ticks = FALSE),
+ |
+
| 243 | +! | +
+ checkboxInput(ns("swap_axes"), "Swap axes", value = FALSE),
+ |
+
| 244 | +! | +
+ checkboxInput(ns("rotate_xaxis_labels"), "Rotate X axis labels", value = FALSE),
+ |
+
| 245 | +! | +
+ selectInput(+ |
+
| 246 | +! | +
+ inputId = ns("distribution_theme"),
+ |
+
| 247 | +! | +
+ label = "Distribution theme (by ggplot):",+ |
+
| 248 | +! | +
+ choices = ggplot_themes,+ |
+
| 249 | +! | +
+ selected = args$distribution_theme,+ |
+
| 250 | +! | +
+ multiple = FALSE+ |
+
| 251 | ++ |
+ ),+ |
+
| 252 | +! | +
+ selectInput(+ |
+
| 253 | +! | +
+ inputId = ns("association_theme"),
+ |
+
| 254 | +! | +
+ label = "Association theme (by ggplot):",+ |
+
| 255 | +! | +
+ choices = ggplot_themes,+ |
+
| 256 | +! | +
+ selected = args$association_theme,+ |
+
| 257 | +! | +
+ multiple = FALSE+ |
+
| 258 | ++ |
+ )+ |
+
| 259 | ++ |
+ )+ |
+
| 260 | ++ |
+ )+ |
+
| 261 | ++ |
+ ),+ |
+
| 262 | +! | +
+ forms = tagList(+ |
+
| 263 | +! | +
+ teal.widgets::verbatim_popup_ui(ns("warning"), "Show Warnings"),
+ |
+
| 264 | +! | +
+ teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code")
+ |
+
| 265 | ++ |
+ ),+ |
+
| 266 | +! | +
+ pre_output = args$pre_output,+ |
+
| 267 | +! | +
+ post_output = args$post_output+ |
+
| 268 | ++ |
+ )+ |
+
| 269 | ++ |
+ }+ |
+
| 270 | ++ | + + | +
| 271 | ++ |
+ # Server function for the association module+ |
+
| 272 | ++ |
+ srv_tm_g_association <- function(id,+ |
+
| 273 | ++ |
+ data,+ |
+
| 274 | ++ |
+ reporter,+ |
+
| 275 | ++ |
+ filter_panel_api,+ |
+
| 276 | ++ |
+ ref,+ |
+
| 277 | ++ |
+ vars,+ |
+
| 278 | ++ |
+ plot_height,+ |
+
| 279 | ++ |
+ plot_width,+ |
+
| 280 | ++ |
+ ggplot2_args) {
+ |
+
| 281 | +! | +
+ with_reporter <- !missing(reporter) && inherits(reporter, "Reporter")+ |
+
| 282 | +! | +
+ with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI")+ |
+
| 283 | +! | +
+ checkmate::assert_class(data, "reactive")+ |
+
| 284 | +! | +
+ checkmate::assert_class(isolate(data()), "teal_data")+ |
+
| 285 | ++ | + + | +
| 286 | +! | +
+ moduleServer(id, function(input, output, session) {
+ |
+
| 287 | +! | +
+ selector_list <- teal.transform::data_extract_multiple_srv(+ |
+
| 288 | +! | +
+ data_extract = list(ref = ref, vars = vars),+ |
+
| 289 | +! | +
+ datasets = data,+ |
+
| 290 | +! | +
+ select_validation_rule = list(+ |
+
| 291 | +! | +
+ ref = shinyvalidate::compose_rules(+ |
+
| 292 | +! | +
+ shinyvalidate::sv_required("A reference variable needs to be selected."),
+ |
+
| 293 | +! | +
+ ~ if ((.) %in% selector_list()$vars()$select) {
+ |
+
| 294 | +! | +
+ "Associated variables and reference variable cannot overlap"+ |
+
| 295 | ++ |
+ }+ |
+
| 296 | ++ |
+ ),+ |
+
| 297 | +! | +
+ vars = shinyvalidate::compose_rules(+ |
+
| 298 | +! | +
+ shinyvalidate::sv_required("An associated variable needs to be selected."),
+ |
+
| 299 | +! | +
+ ~ if (length(selector_list()$ref()$select) != 0 && selector_list()$ref()$select %in% (.)) {
+ |
+
| 300 | +! | +
+ "Associated variables and reference variable cannot overlap"+ |
+
| 301 | ++ |
+ }+ |
+
| 302 | ++ |
+ )+ |
+
| 303 | ++ |
+ )+ |
+
| 304 | ++ |
+ )+ |
+
| 305 | ++ | + + | +
| 306 | +! | +
+ iv_r <- reactive({
+ |
+
| 307 | +! | +
+ iv <- shinyvalidate::InputValidator$new()+ |
+
| 308 | +! | +
+ teal.transform::compose_and_enable_validators(iv, selector_list)+ |
+
| 309 | ++ |
+ })+ |
+
| 310 | ++ | + + | +
| 311 | +! | +
+ anl_merged_input <- teal.transform::merge_expression_srv(+ |
+
| 312 | +! | +
+ datasets = data,+ |
+
| 313 | +! | +
+ selector_list = selector_list+ |
+
| 314 | ++ |
+ )+ |
+
| 315 | ++ | + + | +
| 316 | +! | +
+ anl_merged_q <- reactive({
+ |
+
| 317 | +! | +
+ req(anl_merged_input())+ |
+
| 318 | +! | +
+ data() %>% teal.code::eval_code(as.expression(anl_merged_input()$expr))+ |
+
| 319 | ++ |
+ })+ |
+
| 320 | ++ | + + | +
| 321 | +! | +
+ merged <- list(+ |
+
| 322 | +! | +
+ anl_input_r = anl_merged_input,+ |
+
| 323 | +! | +
+ anl_q_r = anl_merged_q+ |
+
| 324 | ++ |
+ )+ |
+
| 325 | ++ | + + | +
| 326 | +! | +
+ output_q <- reactive({
+ |
+
| 327 | +! | +
+ teal::validate_inputs(iv_r())+ |
+
| 328 | ++ | + + | +
| 329 | +! | +
+ ANL <- merged$anl_q_r()[["ANL"]]+ |
+
| 330 | +! | +
+ teal::validate_has_data(ANL, 3)+ |
+
| 331 | ++ | + + | +
| 332 | +! | +
+ vars_names <- merged$anl_input_r()$columns_source$vars+ |
+
| 333 | ++ | + + | +
| 334 | +! | +
+ ref_name <- as.vector(merged$anl_input_r()$columns_source$ref)+ |
+
| 335 | +! | +
+ association <- input$association+ |
+
| 336 | +! | +
+ show_dist <- input$show_dist+ |
+
| 337 | +! | +
+ log_transformation <- input$log_transformation+ |
+
| 338 | +! | +
+ rotate_xaxis_labels <- input$rotate_xaxis_labels+ |
+
| 339 | +! | +
+ swap_axes <- input$swap_axes+ |
+
| 340 | +! | +
+ distribution_theme <- input$distribution_theme+ |
+
| 341 | +! | +
+ association_theme <- input$association_theme+ |
+
| 342 | ++ | + + | +
| 343 | +! | +
+ is_scatterplot <- is.numeric(ANL[[ref_name]]) && any(vapply(ANL[vars_names], is.numeric, logical(1)))+ |
+
| 344 | +! | +
+ if (is_scatterplot) {
+ |
+
| 345 | +! | +
+ shinyjs::show("alpha")
+ |
+
| 346 | +! | +
+ shinyjs::show("size")
+ |
+
| 347 | +! | +
+ alpha <- input$alpha+ |
+
| 348 | +! | +
+ size <- input$size+ |
+
| 349 | ++ |
+ } else {
+ |
+
| 350 | +! | +
+ shinyjs::hide("alpha")
+ |
+
| 351 | +! | +
+ shinyjs::hide("size")
+ |
+
| 352 | +! | +
+ alpha <- 0.5+ |
+
| 353 | +! | +
+ size <- 2+ |
+
| 354 | ++ |
+ }+ |
+
| 355 | ++ | + + | +
| 356 | +! | +
+ teal::validate_has_data(ANL[, c(ref_name, vars_names)], 3, complete = TRUE, allow_inf = FALSE)+ |
+
| 357 | ++ | + + | +
| 358 | ++ |
+ # reference+ |
+
| 359 | +! | +
+ ref_class <- class(ANL[[ref_name]])[1]+ |
+
| 360 | +! | +
+ if (is.numeric(ANL[[ref_name]]) && log_transformation) {
+ |
+
| 361 | ++ |
+ # works for both integers and doubles+ |
+
| 362 | +! | +
+ ref_cl_name <- call("log", as.name(ref_name))
+ |
+
| 363 | +! | +
+ ref_cl_lbl <- varname_w_label(ref_name, ANL, prefix = "Log of ")+ |
+
| 364 | ++ |
+ } else {
+ |
+
| 365 | ++ |
+ # silently ignore when non-numeric even if `log` is selected because some+ |
+
| 366 | ++ |
+ # variables may be numeric and others not+ |
+
| 367 | +! | +
+ ref_cl_name <- as.name(ref_name)+ |
+
| 368 | +! | +
+ ref_cl_lbl <- varname_w_label(ref_name, ANL)+ |
+
| 369 | ++ |
+ }+ |
+
| 370 | ++ | + + | +
| 371 | +! | +
+ user_ggplot2_args <- teal.widgets::resolve_ggplot2_args(+ |
+
| 372 | +! | +
+ user_plot = ggplot2_args[["Bivariate1"]],+ |
+
| 373 | +! | +
+ user_default = ggplot2_args$default+ |
+
| 374 | ++ |
+ )+ |
+
| 375 | ++ | + + | +
| 376 | +! | +
+ ref_call <- bivariate_plot_call(+ |
+
| 377 | +! | +
+ data_name = "ANL",+ |
+
| 378 | +! | +
+ x = ref_cl_name,+ |
+
| 379 | +! | +
+ x_class = ref_class,+ |
+
| 380 | +! | +
+ x_label = ref_cl_lbl,+ |
+
| 381 | +! | +
+ freq = !show_dist,+ |
+
| 382 | +! | +
+ theme = distribution_theme,+ |
+
| 383 | +! | +
+ rotate_xaxis_labels = rotate_xaxis_labels,+ |
+
| 384 | +! | +
+ swap_axes = FALSE,+ |
+
| 385 | +! | +
+ size = size,+ |
+
| 386 | +! | +
+ alpha = alpha,+ |
+
| 387 | +! | +
+ ggplot2_args = user_ggplot2_args+ |
+
| 388 | ++ |
+ )+ |
+
| 389 | ++ | + + | +
| 390 | ++ |
+ # association+ |
+
| 391 | +! | +
+ ref_class_cov <- ifelse(association, ref_class, "NULL")+ |
+
| 392 | ++ | + + | +
| 393 | +! | +
+ print_call <- quote(print(p))+ |
+
| 394 | ++ | + + | +
| 395 | +! | +
+ var_calls <- lapply(vars_names, function(var_i) {
+ |
+
| 396 | +! | +
+ var_class <- class(ANL[[var_i]])[1]+ |
+
| 397 | +! | +
+ if (is.numeric(ANL[[var_i]]) && log_transformation) {
+ |
+
| 398 | ++ |
+ # works for both integers and doubles+ |
+
| 399 | +! | +
+ var_cl_name <- call("log", as.name(var_i))
+ |
+
| 400 | +! | +
+ var_cl_lbl <- varname_w_label(var_i, ANL, prefix = "Log of ")+ |
+
| 401 | ++ |
+ } else {
+ |
+
| 402 | ++ |
+ # silently ignore when non-numeric even if `log` is selected because some+ |
+
| 403 | ++ |
+ # variables may be numeric and others not+ |
+
| 404 | +! | +
+ var_cl_name <- as.name(var_i)+ |
+
| 405 | +! | +
+ var_cl_lbl <- varname_w_label(var_i, ANL)+ |
+
| 406 | ++ |
+ }+ |
+
| 407 | ++ | + + | +
| 408 | +! | +
+ user_ggplot2_args <- teal.widgets::resolve_ggplot2_args(+ |
+
| 409 | +! | +
+ user_plot = ggplot2_args[["Bivariate2"]],+ |
+
| 410 | +! | +
+ user_default = ggplot2_args$default+ |
+
| 411 | ++ |
+ )+ |
+
| 412 | ++ | + + | +
| 413 | +! | +
+ bivariate_plot_call(+ |
+
| 414 | +! | +
+ data_name = "ANL",+ |
+
| 415 | +! | +
+ x = ref_cl_name,+ |
+
| 416 | +! | +
+ y = var_cl_name,+ |
+
| 417 | +! | +
+ x_class = ref_class_cov,+ |
+
| 418 | +! | +
+ y_class = var_class,+ |
+
| 419 | +! | +
+ x_label = ref_cl_lbl,+ |
+
| 420 | +! | +
+ y_label = var_cl_lbl,+ |
+
| 421 | +! | +
+ theme = association_theme,+ |
+
| 422 | +! | +
+ freq = !show_dist,+ |
+
| 423 | +! | +
+ rotate_xaxis_labels = rotate_xaxis_labels,+ |
+
| 424 | +! | +
+ swap_axes = swap_axes,+ |
+
| 425 | +! | +
+ alpha = alpha,+ |
+
| 426 | +! | +
+ size = size,+ |
+
| 427 | +! | +
+ ggplot2_args = user_ggplot2_args+ |
+
| 428 | ++ |
+ )+ |
+
| 429 | ++ |
+ })+ |
+
| 430 | ++ | + + | +
| 431 | ++ |
+ # helper function to format variable name+ |
+
| 432 | +! | +
+ format_varnames <- function(x) {
+ |
+
| 433 | +! | +
+ if (is.numeric(ANL[[x]]) && log_transformation) {
+ |
+
| 434 | +! | +
+ varname_w_label(x, ANL, prefix = "Log of ")+ |
+
| 435 | ++ |
+ } else {
+ |
+
| 436 | +! | +
+ varname_w_label(x, ANL)+ |
+
| 437 | ++ |
+ }+ |
+
| 438 | ++ |
+ }+ |
+
| 439 | +! | +
+ new_title <-+ |
+
| 440 | +! | +
+ if (association) {
+ |
+
| 441 | +! | +
+ switch(as.character(length(vars_names)),+ |
+
| 442 | +! | +
+ "0" = sprintf("Value distribution for %s", ref_cl_lbl),
+ |
+
| 443 | +! | +
+ "1" = sprintf(+ |
+
| 444 | +! | +
+ "Association between %s and %s",+ |
+
| 445 | +! | +
+ ref_cl_lbl,+ |
+
| 446 | +! | +
+ format_varnames(vars_names)+ |
+
| 447 | ++ |
+ ),+ |
+
| 448 | +! | +
+ sprintf(+ |
+
| 449 | +! | +
+ "Associations between %s and: %s",+ |
+
| 450 | +! | +
+ ref_cl_lbl,+ |
+
| 451 | +! | +
+ paste(lapply(vars_names, format_varnames), collapse = ", ")+ |
+
| 452 | ++ |
+ )+ |
+
| 453 | ++ |
+ )+ |
+
| 454 | ++ |
+ } else {
+ |
+
| 455 | +! | +
+ switch(as.character(length(vars_names)),+ |
+
| 456 | +! | +
+ "0" = sprintf("Value distribution for %s", ref_cl_lbl),
+ |
+
| 457 | +! | +
+ sprintf(+ |
+
| 458 | +! | +
+ "Value distributions for %s and %s",+ |
+
| 459 | +! | +
+ ref_cl_lbl,+ |
+
| 460 | +! | +
+ paste(lapply(vars_names, format_varnames), collapse = ", ")+ |
+
| 461 | ++ |
+ )+ |
+
| 462 | ++ |
+ )+ |
+
| 463 | ++ |
+ }+ |
+
| 464 | ++ | + + | +
| 465 | +! | +
+ teal.code::eval_code(+ |
+
| 466 | +! | +
+ merged$anl_q_r(),+ |
+
| 467 | +! | +
+ substitute(+ |
+
| 468 | +! | +
+ expr = title <- new_title,+ |
+
| 469 | +! | +
+ env = list(new_title = new_title)+ |
+
| 470 | ++ |
+ )+ |
+
| 471 | ++ |
+ ) %>%+ |
+
| 472 | +! | +
+ teal.code::eval_code(+ |
+
| 473 | +! | +
+ substitute(+ |
+
| 474 | +! | +
+ expr = {
+ |
+
| 475 | +! | +
+ plots <- plot_calls+ |
+
| 476 | +! | +
+ p <- tern::stack_grobs(grobs = lapply(plots, ggplotGrob))+ |
+
| 477 | +! | +
+ grid::grid.newpage()+ |
+
| 478 | +! | +
+ grid::grid.draw(p)+ |
+
| 479 | ++ |
+ },+ |
+
| 480 | +! | +
+ env = list(+ |
+
| 481 | +! | +
+ plot_calls = do.call(+ |
+
| 482 | +! | +
+ "call",+ |
+
| 483 | +! | +
+ c(list("list", ref_call), var_calls),
+ |
+
| 484 | +! | +
+ quote = TRUE+ |
+
| 485 | ++ |
+ )+ |
+
| 486 | ++ |
+ )+ |
+
| 487 | ++ |
+ )+ |
+
| 488 | ++ |
+ )+ |
+
| 489 | ++ |
+ })+ |
+
| 490 | ++ | + + | +
| 491 | +! | +
+ plot_r <- shiny::reactive({
+ |
+
| 492 | +! | +
+ shiny::req(iv_r()$is_valid())+ |
+
| 493 | +! | +
+ output_q()[["p"]]+ |
+
| 494 | ++ |
+ })+ |
+
| 495 | ++ | + + | +
| 496 | +! | +
+ pws <- teal.widgets::plot_with_settings_srv(+ |
+
| 497 | +! | +
+ id = "myplot",+ |
+
| 498 | +! | +
+ plot_r = plot_r,+ |
+
| 499 | +! | +
+ height = plot_height,+ |
+
| 500 | +! | +
+ width = plot_width+ |
+
| 501 | ++ |
+ )+ |
+
| 502 | ++ | + + | +
| 503 | +! | +
+ output$title <- renderText({
+ |
+
| 504 | +! | +
+ teal.code::dev_suppress(output_q()[["title"]])+ |
+
| 505 | ++ |
+ })+ |
+
| 506 | ++ | + + | +
| 507 | +! | +
+ teal.widgets::verbatim_popup_srv(+ |
+
| 508 | +! | +
+ id = "warning",+ |
+
| 509 | +! | +
+ verbatim_content = reactive(teal.code::get_warnings(output_q())),+ |
+
| 510 | +! | +
+ title = "Warning",+ |
+
| 511 | +! | +
+ disabled = reactive(is.null(teal.code::get_warnings(output_q())))+ |
+
| 512 | ++ |
+ )+ |
+
| 513 | ++ | + + | +
| 514 | +! | +
+ teal.widgets::verbatim_popup_srv(+ |
+
| 515 | +! | +
+ id = "rcode",+ |
+
| 516 | +! | +
+ verbatim_content = reactive(teal.code::get_code(output_q())),+ |
+
| 517 | +! | +
+ title = "Association Plot"+ |
+
| 518 | ++ |
+ )+ |
+
| 519 | ++ | + + | +
| 520 | ++ |
+ ### REPORTER+ |
+
| 521 | +! | +
+ if (with_reporter) {
+ |
+
| 522 | +! | +
+ card_fun <- function(comment, label) {
+ |
+
| 523 | +! | +
+ card <- teal::report_card_template(+ |
+
| 524 | +! | +
+ title = "Association Plot",+ |
+
| 525 | +! | +
+ label = label,+ |
+
| 526 | +! | +
+ with_filter = with_filter,+ |
+
| 527 | +! | +
+ filter_panel_api = filter_panel_api+ |
+
| 528 | ++ |
+ )+ |
+
| 529 | +! | +
+ card$append_text("Plot", "header3")
+ |
+
| 530 | +! | +
+ card$append_plot(plot_r(), dim = pws$dim())+ |
+
| 531 | +! | +
+ if (!comment == "") {
+ |
+
| 532 | +! | +
+ card$append_text("Comment", "header3")
+ |
+
| 533 | +! | +
+ card$append_text(comment)+ |
+
| 534 | ++ |
+ }+ |
+
| 535 | +! | +
+ card$append_src(teal.code::get_code(output_q()))+ |
+
| 536 | +! | +
+ card+ |
+
| 537 | ++ |
+ }+ |
+
| 538 | +! | +
+ teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
+ |
+
| 539 | ++ |
+ }+ |
+
| 540 | ++ |
+ ###+ |
+
| 541 | ++ |
+ })+ |
+
| 542 | ++ |
+ }+ |
+
| 1 | ++ |
+ #' `teal` module: Variable browser+ |
+
| 2 | ++ |
+ #'+ |
+
| 3 | ++ |
+ #' Module provides provides a detailed summary and visualization of variable distributions+ |
+
| 4 | ++ |
+ #' for `data.frame` objects, with interactive features to customize analysis.+ |
+
| 5 | ++ |
+ #'+ |
+
| 6 | ++ |
+ #' Numeric columns with fewer than 30 distinct values can be treated as either discrete+ |
+
| 7 | ++ |
+ #' or continuous with a checkbox allowing users to switch how they are treated(if < 6 unique values+ |
+
| 8 | ++ |
+ #' then the default is discrete, otherwise it is continuous).+ |
+
| 9 | ++ |
+ #'+ |
+
| 10 | ++ |
+ #' @inheritParams teal::module+ |
+
| 11 | ++ |
+ #' @inheritParams shared_params+ |
+
| 12 | ++ |
+ #' @param parent_dataname (`character(1)`) string specifying a parent dataset.+ |
+
| 13 | ++ |
+ #' If it exists in `datasets_selected`then an extra checkbox will be shown to+ |
+
| 14 | ++ |
+ #' allow users to not show variables in other datasets which exist in this `dataname`.+ |
+
| 15 | ++ |
+ #' This is typically used to remove `ADSL` columns in `CDISC` data.+ |
+
| 16 | ++ |
+ #' In non `CDISC` data this can be ignored. Defaults to `"ADSL"`.+ |
+
| 17 | ++ |
+ #' @param datasets_selected (`character`) vector of datasets which should be+ |
+
| 18 | ++ |
+ #' shown, in order. Names must correspond with datasets names.+ |
+
| 19 | ++ |
+ #' If vector of length zero (default) then all datasets are shown.+ |
+
| 20 | ++ |
+ #' Note: Only `data.frame` objects are compatible; using other types will cause an error.+ |
+
| 21 | ++ |
+ #'+ |
+
| 22 | ++ |
+ #' @inherit shared_params return+ |
+
| 23 | ++ |
+ #'+ |
+
| 24 | ++ |
+ #' @examples+ |
+
| 25 | ++ |
+ #' library(teal.widgets)+ |
+
| 26 | ++ |
+ #'+ |
+
| 27 | ++ |
+ #' # Module specification used in apps below+ |
+
| 28 | ++ |
+ #' tm_variable_browser_module <- tm_variable_browser(+ |
+
| 29 | ++ |
+ #' label = "Variable browser",+ |
+
| 30 | ++ |
+ #' ggplot2_args = ggplot2_args(+ |
+
| 31 | ++ |
+ #' labs = list(subtitle = "Plot generated by Variable Browser Module")+ |
+
| 32 | ++ |
+ #' )+ |
+
| 33 | ++ |
+ #' )+ |
+
| 34 | ++ |
+ #'+ |
+
| 35 | ++ |
+ #' # general data example+ |
+
| 36 | ++ |
+ #' data <- teal_data()+ |
+
| 37 | ++ |
+ #' data <- within(data, {
+ |
+
| 38 | ++ |
+ #' iris <- iris+ |
+
| 39 | ++ |
+ #' mtcars <- mtcars+ |
+
| 40 | ++ |
+ #' women <- women+ |
+
| 41 | ++ |
+ #' faithful <- faithful+ |
+
| 42 | ++ |
+ #' CO2 <- CO2+ |
+
| 43 | ++ |
+ #' })+ |
+
| 44 | ++ |
+ #' datanames(data) <- c("iris", "mtcars", "women", "faithful", "CO2")
+ |
+
| 45 | ++ |
+ #'+ |
+
| 46 | ++ |
+ #' app <- init(+ |
+
| 47 | ++ |
+ #' data = data,+ |
+
| 48 | ++ |
+ #' modules = modules(tm_variable_browser_module)+ |
+
| 49 | ++ |
+ #' )+ |
+
| 50 | ++ |
+ #' if (interactive()) {
+ |
+
| 51 | ++ |
+ #' shinyApp(app$ui, app$server)+ |
+
| 52 | ++ |
+ #' }+ |
+
| 53 | ++ |
+ #'+ |
+
| 54 | ++ |
+ #' # CDISC example data+ |
+
| 55 | ++ |
+ #' data <- teal_data()+ |
+
| 56 | ++ |
+ #' data <- within(data, {
+ |
+
| 57 | ++ |
+ #' ADSL <- rADSL+ |
+
| 58 | ++ |
+ #' ADTTE <- rADTTE+ |
+
| 59 | ++ |
+ #' })+ |
+
| 60 | ++ |
+ #' datanames(data) <- c("ADSL", "ADTTE")
+ |
+
| 61 | ++ |
+ #' join_keys(data) <- default_cdisc_join_keys[datanames(data)]+ |
+
| 62 | ++ |
+ #'+ |
+
| 63 | ++ |
+ #' app <- init(+ |
+
| 64 | ++ |
+ #' data = data,+ |
+
| 65 | ++ |
+ #' modules = modules(tm_variable_browser_module)+ |
+
| 66 | ++ |
+ #' )+ |
+
| 67 | ++ |
+ #' if (interactive()) {
+ |
+
| 68 | ++ |
+ #' shinyApp(app$ui, app$server)+ |
+
| 69 | ++ |
+ #' }+ |
+
| 70 | ++ |
+ #'+ |
+
| 71 | ++ |
+ #' @export+ |
+
| 72 | ++ |
+ #'+ |
+
| 73 | ++ |
+ tm_variable_browser <- function(label = "Variable Browser",+ |
+
| 74 | ++ |
+ datasets_selected = character(0),+ |
+
| 75 | ++ |
+ parent_dataname = "ADSL",+ |
+
| 76 | ++ |
+ pre_output = NULL,+ |
+
| 77 | ++ |
+ post_output = NULL,+ |
+
| 78 | ++ |
+ ggplot2_args = teal.widgets::ggplot2_args()) {
+ |
+
| 79 | +! | +
+ logger::log_info("Initializing tm_variable_browser")
+ |
+
| 80 | ++ | + + | +
| 81 | ++ |
+ # Requires Suggested packages+ |
+
| 82 | +! | +
+ if (!requireNamespace("sparkline", quietly = TRUE)) {
+ |
+
| 83 | +! | +
+ stop("Cannot load sparkline - please install the package or restart your session.")
+ |
+
| 84 | ++ |
+ }+ |
+
| 85 | +! | +
+ if (!requireNamespace("htmlwidgets", quietly = TRUE)) {
+ |
+
| 86 | +! | +
+ stop("Cannot load htmlwidgets - please install the package or restart your session.")
+ |
+
| 87 | ++ |
+ }+ |
+
| 88 | +! | +
+ if (!requireNamespace("jsonlite", quietly = TRUE)) {
+ |
+
| 89 | +! | +
+ stop("Cannot load jsonlite - please install the package or restart your session.")
+ |
+
| 90 | ++ |
+ }+ |
+
| 91 | ++ | + + | +
| 92 | ++ |
+ # Start of assertions+ |
+
| 93 | +! | +
+ checkmate::assert_string(label)+ |
+
| 94 | +! | +
+ checkmate::assert_character(datasets_selected)+ |
+
| 95 | +! | +
+ checkmate::assert_character(parent_dataname, min.len = 0, max.len = 1)+ |
+
| 96 | +! | +
+ checkmate::assert_multi_class(pre_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
+ |
+
| 97 | +! | +
+ checkmate::assert_multi_class(post_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
+ |
+
| 98 | +! | +
+ checkmate::assert_class(ggplot2_args, "ggplot2_args")+ |
+
| 99 | ++ |
+ # End of assertions+ |
+
| 100 | ++ | + + | +
| 101 | +! | +
+ datasets_selected <- unique(datasets_selected)+ |
+
| 102 | ++ | + + | +
| 103 | +! | +
+ module(+ |
+
| 104 | +! | +
+ label,+ |
+
| 105 | +! | +
+ server = srv_variable_browser,+ |
+
| 106 | +! | +
+ ui = ui_variable_browser,+ |
+
| 107 | +! | +
+ datanames = "all",+ |
+
| 108 | +! | +
+ server_args = list(+ |
+
| 109 | +! | +
+ datasets_selected = datasets_selected,+ |
+
| 110 | +! | +
+ parent_dataname = parent_dataname,+ |
+
| 111 | +! | +
+ ggplot2_args = ggplot2_args+ |
+
| 112 | ++ |
+ ),+ |
+
| 113 | +! | +
+ ui_args = list(+ |
+
| 114 | +! | +
+ pre_output = pre_output,+ |
+
| 115 | +! | +
+ post_output = post_output+ |
+
| 116 | ++ |
+ )+ |
+
| 117 | ++ |
+ )+ |
+
| 118 | ++ |
+ }+ |
+
| 119 | ++ | + + | +
| 120 | ++ |
+ # UI function for the variable browser module+ |
+
| 121 | ++ |
+ ui_variable_browser <- function(id,+ |
+
| 122 | ++ |
+ pre_output = NULL,+ |
+
| 123 | ++ |
+ post_output = NULL) {
+ |
+
| 124 | +! | +
+ ns <- NS(id)+ |
+
| 125 | ++ | + + | +
| 126 | +! | +
+ shiny::tagList(+ |
+
| 127 | +! | +
+ include_css_files("custom"),
+ |
+
| 128 | +! | +
+ shinyjs::useShinyjs(),+ |
+
| 129 | +! | +
+ teal.widgets::standard_layout(+ |
+
| 130 | +! | +
+ output = fluidRow(+ |
+
| 131 | +! | +
+ htmlwidgets::getDependency("sparkline"), # needed for sparklines to work
+ |
+
| 132 | +! | +
+ column(+ |
+
| 133 | +! | +
+ 6,+ |
+
| 134 | ++ |
+ # variable browser+ |
+
| 135 | +! | +
+ teal.widgets::white_small_well(+ |
+
| 136 | +! | +
+ uiOutput(ns("ui_variable_browser")),
+ |
+
| 137 | +! | +
+ shinyjs::hidden({
+ |
+
| 138 | +! | +
+ checkboxInput(ns("show_parent_vars"), "Show parent dataset variables", value = FALSE)
+ |
+
| 139 | ++ |
+ })+ |
+
| 140 | ++ |
+ )+ |
+
| 141 | ++ |
+ ),+ |
+
| 142 | +! | +
+ column(+ |
+
| 143 | +! | +
+ 6,+ |
+
| 144 | +! | +
+ teal.widgets::white_small_well(+ |
+
| 145 | ++ |
+ ### Reporter+ |
+
| 146 | +! | +
+ teal.reporter::simple_reporter_ui(ns("simple_reporter")),
+ |
+
| 147 | ++ |
+ ###+ |
+
| 148 | +! | +
+ div(+ |
+
| 149 | +! | +
+ class = "block",+ |
+
| 150 | +! | +
+ uiOutput(ns("ui_histogram_display"))
+ |
+
| 151 | ++ |
+ ),+ |
+
| 152 | +! | +
+ div(+ |
+
| 153 | +! | +
+ class = "block",+ |
+
| 154 | +! | +
+ uiOutput(ns("ui_numeric_display"))
+ |
+
| 155 | ++ |
+ ),+ |
+
| 156 | +! | +
+ teal.widgets::plot_with_settings_ui(ns("variable_plot")),
+ |
+
| 157 | +! | +
+ br(),+ |
+
| 158 | ++ |
+ # input user-defined text size+ |
+
| 159 | +! | +
+ teal.widgets::panel_item(+ |
+
| 160 | +! | +
+ title = "Plot settings",+ |
+
| 161 | +! | +
+ collapsed = TRUE,+ |
+
| 162 | +! | +
+ selectInput(+ |
+
| 163 | +! | +
+ inputId = ns("ggplot_theme"), label = "ggplot2 theme",
+ |
+
| 164 | +! | +
+ choices = ggplot_themes,+ |
+
| 165 | +! | +
+ selected = "grey"+ |
+
| 166 | ++ |
+ ),+ |
+
| 167 | +! | +
+ fluidRow(+ |
+
| 168 | +! | +
+ column(6, sliderInput(+ |
+
| 169 | +! | +
+ inputId = ns("font_size"), label = "font size",
+ |
+
| 170 | +! | +
+ min = 5L, max = 30L, value = 15L, step = 1L, ticks = FALSE+ |
+
| 171 | ++ |
+ )),+ |
+
| 172 | +! | +
+ column(6, sliderInput(+ |
+
| 173 | +! | +
+ inputId = ns("label_rotation"), label = "rotate x labels",
+ |
+
| 174 | +! | +
+ min = 0L, max = 90L, value = 45L, step = 1, ticks = FALSE+ |
+
| 175 | ++ |
+ ))+ |
+
| 176 | ++ |
+ )+ |
+
| 177 | ++ |
+ ),+ |
+
| 178 | +! | +
+ br(),+ |
+
| 179 | +! | +
+ teal.widgets::get_dt_rows(ns("variable_summary_table"), ns("variable_summary_table_rows")),
+ |
+
| 180 | +! | +
+ DT::dataTableOutput(ns("variable_summary_table"))
+ |
+
| 181 | ++ |
+ )+ |
+
| 182 | ++ |
+ )+ |
+
| 183 | ++ |
+ ),+ |
+
| 184 | +! | +
+ pre_output = pre_output,+ |
+
| 185 | +! | +
+ post_output = post_output+ |
+
| 186 | ++ |
+ )+ |
+
| 187 | ++ |
+ )+ |
+
| 188 | ++ |
+ }+ |
+
| 189 | ++ | + + | +
| 190 | ++ |
+ # Server function for the variable browser module+ |
+
| 191 | ++ |
+ srv_variable_browser <- function(id,+ |
+
| 192 | ++ |
+ data,+ |
+
| 193 | ++ |
+ reporter,+ |
+
| 194 | ++ |
+ filter_panel_api,+ |
+
| 195 | ++ |
+ datasets_selected, parent_dataname, ggplot2_args) {
+ |
+
| 196 | +! | +
+ with_reporter <- !missing(reporter) && inherits(reporter, "Reporter")+ |
+
| 197 | +! | +
+ with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI")+ |
+
| 198 | +! | +
+ checkmate::assert_class(data, "reactive")+ |
+
| 199 | +! | +
+ checkmate::assert_class(isolate(data()), "teal_data")+ |
+
| 200 | +! | +
+ moduleServer(id, function(input, output, session) {
+ |
+
| 201 | ++ |
+ # if there are < this number of unique records then a numeric+ |
+
| 202 | ++ |
+ # variable can be treated as a factor and all factors with < this groups+ |
+
| 203 | ++ |
+ # have their values plotted+ |
+
| 204 | +! | +
+ .unique_records_for_factor <- 30+ |
+
| 205 | ++ |
+ # if there are < this number of unique records then a numeric+ |
+
| 206 | ++ |
+ # variable is by default treated as a factor+ |
+
| 207 | +! | +
+ .unique_records_default_as_factor <- 6 # nolint: object_length.+ |
+
| 208 | ++ | + + | +
| 209 | +! | +
+ varname_numeric_as_factor <- reactiveValues()+ |
+
| 210 | ++ | + + | +
| 211 | +! | +
+ datanames <- isolate(teal.data::datanames(data()))+ |
+
| 212 | +! | +
+ datanames <- Filter(function(name) {
+ |
+
| 213 | +! | +
+ is.data.frame(isolate(data())[[name]])+ |
+
| 214 | +! | +
+ }, datanames)+ |
+
| 215 | ++ | + + | +
| 216 | +! | +
+ checkmate::assert_character(datasets_selected)+ |
+
| 217 | +! | +
+ checkmate::assert_subset(datasets_selected, datanames)+ |
+
| 218 | +! | +
+ if (!identical(datasets_selected, character(0))) {
+ |
+
| 219 | +! | +
+ checkmate::assert_subset(datasets_selected, datanames)+ |
+
| 220 | +! | +
+ datanames <- datasets_selected+ |
+
| 221 | ++ |
+ }+ |
+
| 222 | ++ | + + | +
| 223 | +! | +
+ output$ui_variable_browser <- renderUI({
+ |
+
| 224 | +! | +
+ ns <- session$ns+ |
+
| 225 | +! | +
+ do.call(+ |
+
| 226 | +! | +
+ tabsetPanel,+ |
+
| 227 | +! | +
+ c(+ |
+
| 228 | +! | +
+ id = ns("tabset_panel"),
+ |
+
| 229 | +! | +
+ do.call(+ |
+
| 230 | +! | +
+ tagList,+ |
+
| 231 | +! | +
+ lapply(datanames, function(dataname) {
+ |
+
| 232 | +! | +
+ tabPanel(+ |
+
| 233 | +! | +
+ dataname,+ |
+
| 234 | +! | +
+ div(+ |
+
| 235 | +! | +
+ class = "mt-4",+ |
+
| 236 | +! | +
+ textOutput(ns(paste0("dataset_summary_", dataname)))
+ |
+
| 237 | ++ |
+ ),+ |
+
| 238 | +! | +
+ div(+ |
+
| 239 | +! | +
+ class = "mt-4",+ |
+
| 240 | +! | +
+ teal.widgets::get_dt_rows(+ |
+
| 241 | +! | +
+ ns(paste0("variable_browser_", dataname)),
+ |
+
| 242 | +! | +
+ ns(paste0("variable_browser_", dataname, "_rows"))
+ |
+
| 243 | ++ |
+ ),+ |
+
| 244 | +! | +
+ DT::dataTableOutput(ns(paste0("variable_browser_", dataname)), width = "100%")
+ |
+
| 245 | ++ |
+ )+ |
+
| 246 | ++ |
+ )+ |
+
| 247 | ++ |
+ })+ |
+
| 248 | ++ |
+ )+ |
+
| 249 | ++ |
+ )+ |
+
| 250 | ++ |
+ )+ |
+
| 251 | ++ |
+ })+ |
+
| 252 | ++ | + + | +
| 253 | ++ |
+ # conditionally display checkbox+ |
+
| 254 | +! | +
+ shinyjs::toggle(+ |
+
| 255 | +! | +
+ id = "show_parent_vars",+ |
+
| 256 | +! | +
+ condition = length(parent_dataname) > 0 && parent_dataname %in% datanames+ |
+
| 257 | ++ |
+ )+ |
+
| 258 | ++ | + + | +
| 259 | +! | +
+ columns_names <- new.env()+ |
+
| 260 | ++ | + + | +
| 261 | ++ |
+ # plot_var$data holds the name of the currently selected dataset+ |
+
| 262 | ++ |
+ # plot_var$variable[[<dataset_name>]] holds the name of the currently selected+ |
+
| 263 | ++ |
+ # variable for dataset <dataset_name>+ |
+
| 264 | +! | +
+ plot_var <- reactiveValues(data = NULL, variable = list())+ |
+
| 265 | ++ | + + | +
| 266 | +! | +
+ establish_updating_selection(datanames, input, plot_var, columns_names)+ |
+
| 267 | ++ | + + | +
| 268 | ++ |
+ # validations+ |
+
| 269 | +! | +
+ validation_checks <- validate_input(input, plot_var, data)+ |
+
| 270 | ++ | + + | +
| 271 | ++ |
+ # data_for_analysis is a list with two elements: a column from a dataset and the column label+ |
+
| 272 | +! | +
+ plotted_data <- reactive({
+ |
+
| 273 | +! | +
+ validation_checks()+ |
+
| 274 | ++ | + + | +
| 275 | +! | +
+ get_plotted_data(input, plot_var, data)+ |
+
| 276 | ++ |
+ })+ |
+
| 277 | ++ | + + | +
| 278 | +! | +
+ treat_numeric_as_factor <- reactive({
+ |
+
| 279 | +! | +
+ if (is_num_var_short(.unique_records_for_factor, input, plotted_data)) {
+ |
+
| 280 | +! | +
+ input$numeric_as_factor+ |
+
| 281 | ++ |
+ } else {
+ |
+
| 282 | +! | +
+ FALSE+ |
+
| 283 | ++ |
+ }+ |
+
| 284 | ++ |
+ })+ |
+
| 285 | ++ | + + | +
| 286 | +! | +
+ render_tabset_panel_content(+ |
+
| 287 | +! | +
+ input = input,+ |
+
| 288 | +! | +
+ output = output,+ |
+
| 289 | +! | +
+ data = data,+ |
+
| 290 | +! | +
+ datanames = datanames,+ |
+
| 291 | +! | +
+ parent_dataname = parent_dataname,+ |
+
| 292 | +! | +
+ columns_names = columns_names,+ |
+
| 293 | +! | +
+ plot_var = plot_var+ |
+
| 294 | ++ |
+ )+ |
+
| 295 | ++ |
+ # add used-defined text size to ggplot arguments passed from caller frame+ |
+
| 296 | +! | +
+ all_ggplot2_args <- reactive({
+ |
+
| 297 | +! | +
+ user_text <- teal.widgets::ggplot2_args(+ |
+
| 298 | +! | +
+ theme = list(+ |
+
| 299 | +! | +
+ "text" = ggplot2::element_text(size = input[["font_size"]]),+ |
+
| 300 | +! | +
+ "axis.text.x" = ggplot2::element_text(angle = input[["label_rotation"]], hjust = 1)+ |
+
| 301 | ++ |
+ )+ |
+
| 302 | ++ |
+ )+ |
+
| 303 | +! | +
+ user_theme <- utils::getFromNamespace(sprintf("theme_%s", input[["ggplot_theme"]]), ns = "ggplot2")
+ |
+
| 304 | +! | +
+ user_theme <- user_theme()+ |
+
| 305 | ++ |
+ # temporary fix to circumvent assertion issue with resolve_ggplot2_args+ |
+
| 306 | ++ |
+ # drop problematic elements+ |
+
| 307 | +! | +
+ user_theme <- user_theme[grep("strip.text.y.left", names(user_theme), fixed = TRUE, invert = TRUE)]
+ |
+
| 308 | ++ | + + | +
| 309 | +! | +
+ teal.widgets::resolve_ggplot2_args(+ |
+
| 310 | +! | +
+ user_plot = user_text,+ |
+
| 311 | +! | +
+ user_default = teal.widgets::ggplot2_args(theme = user_theme),+ |
+
| 312 | +! | +
+ module_plot = ggplot2_args+ |
+
| 313 | ++ |
+ )+ |
+
| 314 | ++ |
+ })+ |
+
| 315 | ++ | + + | +
| 316 | +! | +
+ output$ui_numeric_display <- renderUI({
+ |
+
| 317 | +! | +
+ validation_checks()+ |
+
| 318 | +! | +
+ dataname <- input$tabset_panel+ |
+
| 319 | +! | +
+ varname <- plot_var$variable[[dataname]]+ |
+
| 320 | +! | +
+ df <- data()[[dataname]]+ |
+
| 321 | ++ | + + | +
| 322 | +! | +
+ numeric_ui <- tagList(+ |
+
| 323 | +! | +
+ fluidRow(+ |
+
| 324 | +! | +
+ div(+ |
+
| 325 | +! | +
+ class = "col-md-4",+ |
+
| 326 | +! | +
+ br(),+ |
+
| 327 | +! | +
+ shinyWidgets::switchInput(+ |
+
| 328 | +! | +
+ inputId = session$ns("display_density"),
+ |
+
| 329 | +! | +
+ label = "Show density",+ |
+
| 330 | +! | +
+ value = `if`(is.null(isolate(input$display_density)), TRUE, isolate(input$display_density)),+ |
+
| 331 | +! | +
+ width = "50%",+ |
+
| 332 | +! | +
+ labelWidth = "100px",+ |
+
| 333 | +! | +
+ handleWidth = "50px"+ |
+
| 334 | ++ |
+ )+ |
+
| 335 | ++ |
+ ),+ |
+
| 336 | +! | +
+ div(+ |
+
| 337 | +! | +
+ class = "col-md-4",+ |
+
| 338 | +! | +
+ br(),+ |
+
| 339 | +! | +
+ shinyWidgets::switchInput(+ |
+
| 340 | +! | +
+ inputId = session$ns("remove_outliers"),
+ |
+
| 341 | +! | +
+ label = "Remove outliers",+ |
+
| 342 | +! | +
+ value = `if`(is.null(isolate(input$remove_outliers)), FALSE, isolate(input$remove_outliers)),+ |
+
| 343 | +! | +
+ width = "50%",+ |
+
| 344 | +! | +
+ labelWidth = "100px",+ |
+
| 345 | +! | +
+ handleWidth = "50px"+ |
+
| 346 | ++ |
+ )+ |
+
| 347 | ++ |
+ ),+ |
+
| 348 | +! | +
+ div(+ |
+
| 349 | +! | +
+ class = "col-md-4",+ |
+
| 350 | +! | +
+ uiOutput(session$ns("outlier_definition_slider_ui"))
+ |
+
| 351 | ++ |
+ )+ |
+
| 352 | ++ |
+ ),+ |
+
| 353 | +! | +
+ div(+ |
+
| 354 | +! | +
+ class = "ml-4",+ |
+
| 355 | +! | +
+ uiOutput(session$ns("ui_density_help")),
+ |
+
| 356 | +! | +
+ uiOutput(session$ns("ui_outlier_help"))
+ |
+
| 357 | ++ |
+ )+ |
+
| 358 | ++ |
+ )+ |
+
| 359 | ++ | + + | +
| 360 | +! | +
+ observeEvent(input$numeric_as_factor, ignoreInit = TRUE, {
+ |
+
| 361 | +! | +
+ varname_numeric_as_factor[[plot_var$variable[[dataname]]]] <- input$numeric_as_factor+ |
+
| 362 | ++ |
+ })+ |
+
| 363 | ++ | + + | +
| 364 | +! | +
+ if (is.numeric(df[[varname]])) {
+ |
+
| 365 | +! | +
+ unique_entries <- length(unique(df[[varname]]))+ |
+
| 366 | +! | +
+ if (unique_entries < .unique_records_for_factor && unique_entries > 0) {
+ |
+
| 367 | +! | +
+ list(+ |
+
| 368 | +! | +
+ checkboxInput(+ |
+
| 369 | +! | +
+ session$ns("numeric_as_factor"),
+ |
+
| 370 | +! | +
+ "Treat variable as factor",+ |
+
| 371 | +! | +
+ value = `if`(+ |
+
| 372 | +! | +
+ is.null(varname_numeric_as_factor[[varname]]),+ |
+
| 373 | +! | +
+ unique_entries < .unique_records_default_as_factor,+ |
+
| 374 | +! | +
+ varname_numeric_as_factor[[varname]]+ |
+
| 375 | ++ |
+ )+ |
+
| 376 | ++ |
+ ),+ |
+
| 377 | +! | +
+ conditionalPanel("!input.numeric_as_factor", ns = session$ns, numeric_ui)
+ |
+
| 378 | ++ |
+ )+ |
+
| 379 | +! | +
+ } else if (unique_entries > 0) {
+ |
+
| 380 | +! | +
+ numeric_ui+ |
+
| 381 | ++ |
+ }+ |
+
| 382 | ++ |
+ } else {
+ |
+
| 383 | +! | +
+ NULL+ |
+
| 384 | ++ |
+ }+ |
+
| 385 | ++ |
+ })+ |
+
| 386 | ++ | + + | +
| 387 | +! | +
+ output$ui_histogram_display <- renderUI({
+ |
+
| 388 | +! | +
+ validation_checks()+ |
+
| 389 | +! | +
+ dataname <- input$tabset_panel+ |
+
| 390 | +! | +
+ varname <- plot_var$variable[[dataname]]+ |
+
| 391 | +! | +
+ df <- data()[[dataname]]+ |
+
| 392 | ++ | + + | +
| 393 | +! | +
+ numeric_ui <- tagList(fluidRow(+ |
+
| 394 | +! | +
+ div(+ |
+
| 395 | +! | +
+ class = "col-md-4",+ |
+
| 396 | +! | +
+ shinyWidgets::switchInput(+ |
+
| 397 | +! | +
+ inputId = session$ns("remove_NA_hist"),
+ |
+
| 398 | +! | +
+ label = "Remove NA values",+ |
+
| 399 | +! | +
+ value = FALSE,+ |
+
| 400 | +! | +
+ width = "50%",+ |
+
| 401 | +! | +
+ labelWidth = "100px",+ |
+
| 402 | +! | +
+ handleWidth = "50px"+ |
+
| 403 | ++ |
+ )+ |
+
| 404 | ++ |
+ )+ |
+
| 405 | ++ |
+ ))+ |
+
| 406 | ++ | + + | +
| 407 | +! | +
+ var <- df[[varname]]+ |
+
| 408 | +! | +
+ if (anyNA(var) && (is.factor(var) || is.character(var) || is.logical(var))) {
+ |
+
| 409 | +! | +
+ groups <- unique(as.character(var))+ |
+
| 410 | +! | +
+ len_groups <- length(groups)+ |
+
| 411 | +! | +
+ if (len_groups >= .unique_records_for_factor) {
+ |
+
| 412 | +! | +
+ NULL+ |
+
| 413 | ++ |
+ } else {
+ |
+
| 414 | +! | +
+ numeric_ui+ |
+
| 415 | ++ |
+ }+ |
+
| 416 | ++ |
+ } else {
+ |
+
| 417 | +! | +
+ NULL+ |
+
| 418 | ++ |
+ }+ |
+
| 419 | ++ |
+ })+ |
+
| 420 | ++ | + + | +
| 421 | +! | +
+ output$outlier_definition_slider_ui <- renderUI({
+ |
+
| 422 | +! | +
+ req(input$remove_outliers)+ |
+
| 423 | +! | +
+ sliderInput(+ |
+
| 424 | +! | +
+ inputId = session$ns("outlier_definition_slider"),
+ |
+
| 425 | +! | +
+ div(+ |
+
| 426 | +! | +
+ class = "teal-tooltip",+ |
+
| 427 | +! | +
+ tagList(+ |
+
| 428 | +! | +
+ "Outlier definition:",+ |
+
| 429 | +! | +
+ icon("circle-info"),
+ |
+
| 430 | +! | +
+ span(+ |
+
| 431 | +! | +
+ class = "tooltiptext",+ |
+
| 432 | +! | +
+ paste(+ |
+
| 433 | +! | +
+ "Use the slider to choose the cut-off value to define outliers; the larger the value the",+ |
+
| 434 | +! | +
+ "further below Q1/above Q3 points have to be in order to be classed as outliers"+ |
+
| 435 | ++ |
+ )+ |
+
| 436 | ++ |
+ )+ |
+
| 437 | ++ |
+ )+ |
+
| 438 | ++ |
+ ),+ |
+
| 439 | +! | +
+ min = 1,+ |
+
| 440 | +! | +
+ max = 5,+ |
+
| 441 | +! | +
+ value = 3,+ |
+
| 442 | +! | +
+ step = 0.5+ |
+
| 443 | ++ |
+ )+ |
+
| 444 | ++ |
+ })+ |
+
| 445 | ++ | + + | +
| 446 | +! | +
+ output$ui_density_help <- renderUI({
+ |
+
| 447 | +! | +
+ req(is.logical(input$display_density))+ |
+
| 448 | +! | +
+ if (input$display_density) {
+ |
+
| 449 | +! | +
+ tags$small(helpText(paste(+ |
+
| 450 | +! | +
+ "Kernel density estimation with gaussian kernel",+ |
+
| 451 | +! | +
+ "and bandwidth function bw.nrd0 (R default)"+ |
+
| 452 | ++ |
+ )))+ |
+
| 453 | ++ |
+ } else {
+ |
+
| 454 | +! | +
+ NULL+ |
+
| 455 | ++ |
+ }+ |
+
| 456 | ++ |
+ })+ |
+
| 457 | ++ | + + | +
| 458 | +! | +
+ output$ui_outlier_help <- renderUI({
+ |
+
| 459 | +! | +
+ req(is.logical(input$remove_outliers), input$outlier_definition_slider)+ |
+
| 460 | +! | +
+ if (input$remove_outliers) {
+ |
+
| 461 | +! | +
+ tags$small(+ |
+
| 462 | +! | +
+ helpText(+ |
+
| 463 | +! | +
+ withMathJax(paste0(+ |
+
| 464 | +! | +
+ "Outlier data points (\\( X \\lt Q1 - ", input$outlier_definition_slider, "\\times IQR \\) or+ |
+
| 465 | +! | +
+ \\(Q3 + ", input$outlier_definition_slider, "\\times IQR \\lt X\\))+ |
+
| 466 | +! | +
+ have not been displayed on the graph and will not be used for any kernel density estimations, ",+ |
+
| 467 | +! | +
+ "although their values remain in the statisics table below."+ |
+
| 468 | ++ |
+ ))+ |
+
| 469 | ++ |
+ )+ |
+
| 470 | ++ |
+ )+ |
+
| 471 | ++ |
+ } else {
+ |
+
| 472 | +! | +
+ NULL+ |
+
| 473 | ++ |
+ }+ |
+
| 474 | ++ |
+ })+ |
+
| 475 | ++ | + + | +
| 476 | ++ | + + | +
| 477 | +! | +
+ variable_plot_r <- reactive({
+ |
+
| 478 | +! | +
+ display_density <- `if`(is.null(input$display_density), FALSE, input$display_density)+ |
+
| 479 | +! | +
+ remove_outliers <- `if`(is.null(input$remove_outliers), FALSE, input$remove_outliers)+ |
+
| 480 | ++ | + + | +
| 481 | +! | +
+ if (remove_outliers) {
+ |
+
| 482 | +! | +
+ req(input$outlier_definition_slider)+ |
+
| 483 | +! | +
+ outlier_definition <- as.numeric(input$outlier_definition_slider)+ |
+
| 484 | ++ |
+ } else {
+ |
+
| 485 | +! | +
+ outlier_definition <- 0+ |
+
| 486 | ++ |
+ }+ |
+
| 487 | ++ | + + | +
| 488 | +! | +
+ plot_var_summary(+ |
+
| 489 | +! | +
+ var = plotted_data()$data,+ |
+
| 490 | +! | +
+ var_lab = plotted_data()$var_description,+ |
+
| 491 | +! | +
+ wrap_character = 15,+ |
+
| 492 | +! | +
+ numeric_as_factor = treat_numeric_as_factor(),+ |
+
| 493 | +! | +
+ remove_NA_hist = input$remove_NA_hist,+ |
+
| 494 | +! | +
+ display_density = display_density,+ |
+
| 495 | +! | +
+ outlier_definition = outlier_definition,+ |
+
| 496 | +! | +
+ records_for_factor = .unique_records_for_factor,+ |
+
| 497 | +! | +
+ ggplot2_args = all_ggplot2_args()+ |
+
| 498 | ++ |
+ )+ |
+
| 499 | ++ |
+ })+ |
+
| 500 | ++ | + + | +
| 501 | +! | +
+ pws <- teal.widgets::plot_with_settings_srv(+ |
+
| 502 | +! | +
+ id = "variable_plot",+ |
+
| 503 | +! | +
+ plot_r = variable_plot_r,+ |
+
| 504 | +! | +
+ height = c(500, 200, 2000)+ |
+
| 505 | ++ |
+ )+ |
+
| 506 | ++ | + + | +
| 507 | +! | +
+ output$variable_summary_table <- DT::renderDataTable({
+ |
+
| 508 | +! | +
+ var_summary_table(+ |
+
| 509 | +! | +
+ plotted_data()$data,+ |
+
| 510 | +! | +
+ treat_numeric_as_factor(),+ |
+
| 511 | +! | +
+ input$variable_summary_table_rows,+ |
+
| 512 | +! | +
+ if (!is.null(input$remove_outliers) && input$remove_outliers) {
+ |
+
| 513 | +! | +
+ req(input$outlier_definition_slider)+ |
+
| 514 | +! | +
+ as.numeric(input$outlier_definition_slider)+ |
+
| 515 | ++ |
+ } else {
+ |
+
| 516 | +! | +
+ 0+ |
+
| 517 | ++ |
+ }+ |
+
| 518 | ++ |
+ )+ |
+
| 519 | ++ |
+ })+ |
+
| 520 | ++ | + + | +
| 521 | ++ |
+ ### REPORTER+ |
+
| 522 | +! | +
+ if (with_reporter) {
+ |
+
| 523 | +! | +
+ card_fun <- function(comment) {
+ |
+
| 524 | +! | +
+ card <- teal::TealReportCard$new()+ |
+
| 525 | +! | +
+ card$set_name("Variable Browser Plot")
+ |
+
| 526 | +! | +
+ card$append_text("Variable Browser Plot", "header2")
+ |
+
| 527 | +! | +
+ if (with_filter) card$append_fs(filter_panel_api$get_filter_state())+ |
+
| 528 | +! | +
+ card$append_text("Plot", "header3")
+ |
+
| 529 | +! | +
+ card$append_plot(variable_plot_r(), dim = pws$dim())+ |
+
| 530 | +! | +
+ if (!comment == "") {
+ |
+
| 531 | +! | +
+ card$append_text("Comment", "header3")
+ |
+
| 532 | +! | +
+ card$append_text(comment)+ |
+
| 533 | ++ |
+ }+ |
+
| 534 | +! | +
+ card+ |
+
| 535 | ++ |
+ }+ |
+
| 536 | +! | +
+ teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
+ |
+
| 537 | ++ |
+ }+ |
+
| 538 | ++ |
+ ###+ |
+
| 539 | ++ |
+ })+ |
+
| 540 | ++ |
+ }+ |
+
| 541 | ++ | + + | +
| 542 | ++ |
+ #' Summarize NAs.+ |
+
| 543 | ++ |
+ #'+ |
+
| 544 | ++ |
+ #' Summarizes occurrence of missing values in vector.+ |
+
| 545 | ++ |
+ #' @param x vector of any type and length+ |
+
| 546 | ++ |
+ #' @return Character string describing `NA` occurrence.+ |
+
| 547 | ++ |
+ #' @keywords internal+ |
+
| 548 | ++ |
+ var_missings_info <- function(x) {
+ |
+
| 549 | +! | +
+ sprintf("%s [%s%%]", sum(is.na(x)), round(mean(is.na(x) * 100), 2))
+ |
+
| 550 | ++ |
+ }+ |
+
| 551 | ++ | + + | +
| 552 | ++ |
+ #' Summarizes variable+ |
+
| 553 | ++ |
+ #'+ |
+
| 554 | ++ |
+ #' Creates html summary with statistics relevant to data type. For numeric values it returns central+ |
+
| 555 | ++ |
+ #' tendency measures, for factor returns level counts, for Date date range, for other just+ |
+
| 556 | ++ |
+ #' number of levels.+ |
+
| 557 | ++ |
+ #'+ |
+
| 558 | ++ |
+ #' @param x vector of any type+ |
+
| 559 | ++ |
+ #' @param numeric_as_factor `logical` should the numeric variable be treated as a factor+ |
+
| 560 | ++ |
+ #' @param dt_rows `numeric` current/latest `DT` page length+ |
+
| 561 | ++ |
+ #' @param outlier_definition If 0 no outliers are removed, otherwise+ |
+
| 562 | ++ |
+ #' outliers (those more than `outlier_definition*IQR below/above Q1/Q3` be removed)+ |
+
| 563 | ++ |
+ #' @return text with simple statistics.+ |
+
| 564 | ++ |
+ #' @keywords internal+ |
+
| 565 | ++ |
+ var_summary_table <- function(x, numeric_as_factor, dt_rows, outlier_definition) {
+ |
+
| 566 | +! | +
+ if (is.null(dt_rows)) {
+ |
+
| 567 | +! | +
+ dt_rows <- 10+ |
+
| 568 | ++ |
+ }+ |
+
| 569 | +! | +
+ if (is.numeric(x) && !numeric_as_factor) {
+ |
+
| 570 | +! | +
+ req(!any(is.infinite(x)))+ |
+
| 571 | ++ | + + | +
| 572 | +! | +
+ x <- remove_outliers_from(x, outlier_definition)+ |
+
| 573 | ++ | + + | +
| 574 | +! | +
+ qvals <- round(stats::quantile(x, na.rm = TRUE, probs = c(0.25, 0.5, 0.75), type = 2), 2)+ |
+
| 575 | ++ |
+ # classical central tendency measures+ |
+
| 576 | ++ | + + | +
| 577 | +! | +
+ summary <-+ |
+
| 578 | +! | +
+ data.frame(+ |
+
| 579 | +! | +
+ Statistic = c("min", "Q1", "median", "mean", "Q3", "max", "sd", "n"),
+ |
+
| 580 | +! | +
+ Value = c(+ |
+
| 581 | +! | +
+ round(min(x, na.rm = TRUE), 2),+ |
+
| 582 | +! | +
+ qvals[1],+ |
+
| 583 | +! | +
+ qvals[2],+ |
+
| 584 | +! | +
+ round(mean(x, na.rm = TRUE), 2),+ |
+
| 585 | +! | +
+ qvals[3],+ |
+
| 586 | +! | +
+ round(max(x, na.rm = TRUE), 2),+ |
+
| 587 | +! | +
+ round(stats::sd(x, na.rm = TRUE), 2),+ |
+
| 588 | +! | +
+ length(x[!is.na(x)])+ |
+
| 589 | ++ |
+ )+ |
+
| 590 | ++ |
+ )+ |
+
| 591 | ++ | + + | +
| 592 | +! | +
+ DT::datatable(summary, rownames = FALSE, options = list(dom = "<t>", pageLength = dt_rows))+ |
+
| 593 | +! | +
+ } else if (is.factor(x) || is.character(x) || (is.numeric(x) && numeric_as_factor) || is.logical(x)) {
+ |
+
| 594 | ++ |
+ # make sure factor is ordered numeric+ |
+
| 595 | +! | +
+ if (is.numeric(x)) {
+ |
+
| 596 | +! | +
+ x <- factor(x, levels = sort(unique(x)))+ |
+
| 597 | ++ |
+ }+ |
+
| 598 | ++ | + + | +
| 599 | +! | +
+ level_counts <- table(x)+ |
+
| 600 | +! | +
+ max_levels_signif <- nchar(level_counts)+ |
+
| 601 | ++ | + + | +
| 602 | +! | +
+ if (!all(is.na(x))) {
+ |
+
| 603 | +! | +
+ levels <- names(level_counts)+ |
+
| 604 | +! | +
+ counts <- sprintf(+ |
+
| 605 | +! | +
+ "%s [%.2f%%]",+ |
+
| 606 | +! | +
+ format(level_counts, width = max_levels_signif), prop.table(level_counts) * 100+ |
+
| 607 | ++ |
+ )+ |
+
| 608 | ++ |
+ } else {
+ |
+
| 609 | +! | +
+ levels <- character(0)+ |
+
| 610 | +! | +
+ counts <- numeric(0)+ |
+
| 611 | ++ |
+ }+ |
+
| 612 | ++ | + + | +
| 613 | +! | +
+ summary <- data.frame(+ |
+
| 614 | +! | +
+ Level = levels,+ |
+
| 615 | +! | +
+ Count = counts,+ |
+
| 616 | +! | +
+ stringsAsFactors = FALSE+ |
+
| 617 | ++ |
+ )+ |
+
| 618 | ++ | + + | +
| 619 | ++ |
+ # sort the dataset in decreasing order of counts (needed as character variables default to alphabetical)+ |
+
| 620 | +! | +
+ summary <- summary[order(summary$Count, decreasing = TRUE), ]+ |
+
| 621 | ++ | + + | +
| 622 | +! | +
+ dom_opts <- if (nrow(summary) <= 10) {
+ |
+
| 623 | +! | +
+ "<t>"+ |
+
| 624 | ++ |
+ } else {
+ |
+
| 625 | +! | +
+ "<lf<t>ip>"+ |
+
| 626 | ++ |
+ }+ |
+
| 627 | +! | +
+ DT::datatable(summary, rownames = FALSE, options = list(dom = dom_opts, pageLength = dt_rows))+ |
+
| 628 | +! | +
+ } else if (inherits(x, "Date") || inherits(x, "POSIXct") || inherits(x, "POSIXlt")) {
+ |
+
| 629 | +! | +
+ summary <-+ |
+
| 630 | +! | +
+ data.frame(+ |
+
| 631 | +! | +
+ Statistic = c("min", "median", "max"),
+ |
+
| 632 | +! | +
+ Value = c(+ |
+
| 633 | +! | +
+ min(x, na.rm = TRUE),+ |
+
| 634 | +! | +
+ stats::median(x, na.rm = TRUE),+ |
+
| 635 | +! | +
+ max(x, na.rm = TRUE)+ |
+
| 636 | ++ |
+ )+ |
+
| 637 | ++ |
+ )+ |
+
| 638 | +! | +
+ DT::datatable(summary, rownames = FALSE, options = list(dom = "<t>", pageLength = dt_rows))+ |
+
| 639 | ++ |
+ } else {
+ |
+
| 640 | +! | +
+ NULL+ |
+
| 641 | ++ |
+ }+ |
+
| 642 | ++ |
+ }+ |
+
| 643 | ++ | + + | +
| 644 | ++ |
+ #' Plot variable+ |
+
| 645 | ++ |
+ #'+ |
+
| 646 | ++ |
+ #' Creates summary plot with statistics relevant to data type.+ |
+
| 647 | ++ |
+ #'+ |
+
| 648 | ++ |
+ #' @inheritParams shared_params+ |
+
| 649 | ++ |
+ #' @param var vector of any type to be plotted. For numeric variables it produces histogram with+ |
+
| 650 | ++ |
+ #' density line, for factors it creates frequency plot+ |
+
| 651 | ++ |
+ #' @param var_lab text describing selected variable to be displayed on the plot+ |
+
| 652 | ++ |
+ #' @param wrap_character (`numeric`) number of characters at which to wrap text values of `var`+ |
+
| 653 | ++ |
+ #' @param numeric_as_factor (`logical`) should the numeric variable be treated as a factor+ |
+
| 654 | ++ |
+ #' @param display_density (`logical`) should density estimation be displayed for numeric values+ |
+
| 655 | ++ |
+ #' @param remove_NA_hist (`logical`) should `NA` values be removed for histogram of factor like variables+ |
+
| 656 | ++ |
+ #' @param outlier_definition if 0 no outliers are removed, otherwise+ |
+
| 657 | ++ |
+ #' outliers (those more than outlier_definition*IQR below/above Q1/Q3 be removed)+ |
+
| 658 | ++ |
+ #' @param records_for_factor (`numeric`) if the number of factor levels is >= than this value then+ |
+
| 659 | ++ |
+ #' a graph of the factors isn't shown, only a list of values+ |
+
| 660 | ++ |
+ #'+ |
+
| 661 | ++ |
+ #' @return plot+ |
+
| 662 | ++ |
+ #' @keywords internal+ |
+
| 663 | ++ |
+ plot_var_summary <- function(var,+ |
+
| 664 | ++ |
+ var_lab,+ |
+
| 665 | ++ |
+ wrap_character = NULL,+ |
+
| 666 | ++ |
+ numeric_as_factor,+ |
+
| 667 | ++ |
+ display_density = is.numeric(var),+ |
+
| 668 | ++ |
+ remove_NA_hist = FALSE, # nolint: object_name.+ |
+
| 669 | ++ |
+ outlier_definition,+ |
+
| 670 | ++ |
+ records_for_factor,+ |
+
| 671 | ++ |
+ ggplot2_args) {
+ |
+
| 672 | +! | +
+ checkmate::assert_character(var_lab)+ |
+
| 673 | +! | +
+ checkmate::assert_numeric(wrap_character, null.ok = TRUE)+ |
+
| 674 | +! | +
+ checkmate::assert_flag(numeric_as_factor)+ |
+
| 675 | +! | +
+ checkmate::assert_flag(display_density)+ |
+
| 676 | +! | +
+ checkmate::assert_logical(remove_NA_hist, null.ok = TRUE)+ |
+
| 677 | +! | +
+ checkmate::assert_number(outlier_definition, lower = 0, finite = TRUE)+ |
+
| 678 | +! | +
+ checkmate::assert_integerish(records_for_factor, lower = 0, len = 1, any.missing = FALSE)+ |
+
| 679 | +! | +
+ checkmate::assert_class(ggplot2_args, "ggplot2_args")+ |
+
| 680 | ++ | + + | +
| 681 | +! | +
+ grid::grid.newpage()+ |
+
| 682 | ++ | + + | +
| 683 | +! | +
+ plot_main <- if (is.factor(var) || is.character(var) || is.logical(var)) {
+ |
+
| 684 | +! | +
+ groups <- unique(as.character(var))+ |
+
| 685 | +! | +
+ len_groups <- length(groups)+ |
+
| 686 | +! | +
+ if (len_groups >= records_for_factor) {
+ |
+
| 687 | +! | +
+ grid::textGrob(+ |
+
| 688 | +! | +
+ sprintf(+ |
+
| 689 | +! | +
+ "%s unique values\n%s:\n %s\n ...\n %s",+ |
+
| 690 | +! | +
+ len_groups,+ |
+
| 691 | +! | +
+ var_lab,+ |
+
| 692 | +! | +
+ paste(utils::head(groups), collapse = ",\n "),+ |
+
| 693 | +! | +
+ paste(utils::tail(groups), collapse = ",\n ")+ |
+
| 694 | ++ |
+ ),+ |
+
| 695 | +! | +
+ x = grid::unit(1, "line"),+ |
+
| 696 | +! | +
+ y = grid::unit(1, "npc") - grid::unit(1, "line"),+ |
+
| 697 | +! | +
+ just = c("left", "top")
+ |
+
| 698 | ++ |
+ )+ |
+
| 699 | ++ |
+ } else {
+ |
+
| 700 | +! | +
+ if (!is.null(wrap_character)) {
+ |
+
| 701 | +! | +
+ var <- stringr::str_wrap(var, width = wrap_character)+ |
+
| 702 | ++ |
+ }+ |
+
| 703 | +! | +
+ var <- if (isTRUE(remove_NA_hist)) as.vector(stats::na.omit(var)) else var+ |
+
| 704 | +! | +
+ ggplot(data.frame(var), aes(x = forcats::fct_infreq(as.factor(var)))) ++ |
+
| 705 | +! | +
+ geom_bar(stat = "count", aes(fill = ifelse(is.na(var), "withcolor", "")), show.legend = FALSE) ++ |
+
| 706 | +! | +
+ scale_fill_manual(values = c("gray50", "tan"))
+ |
+
| 707 | ++ |
+ }+ |
+
| 708 | +! | +
+ } else if (is.numeric(var)) {
+ |
+
| 709 | +! | +
+ validate(need(any(!is.na(var)), "No data left to visualize."))+ |
+
| 710 | ++ | + + | +
| 711 | ++ |
+ # Filter out NA+ |
+
| 712 | +! | +
+ var <- var[which(!is.na(var))]+ |
+
| 713 | ++ | + + | +
| 714 | +! | +
+ validate(need(!any(is.infinite(var)), "Cannot display graph when data includes infinite values"))+ |
+
| 715 | ++ | + + | +
| 716 | +! | +
+ if (numeric_as_factor) {
+ |
+
| 717 | +! | +
+ var <- factor(var)+ |
+
| 718 | +! | +
+ ggplot(NULL, aes(x = var)) ++ |
+
| 719 | +! | +
+ geom_histogram(stat = "count")+ |
+
| 720 | ++ |
+ } else {
+ |
+
| 721 | ++ |
+ # remove outliers+ |
+
| 722 | +! | +
+ if (outlier_definition != 0) {
+ |
+
| 723 | +! | +
+ number_records <- length(var)+ |
+
| 724 | +! | +
+ var <- remove_outliers_from(var, outlier_definition)+ |
+
| 725 | +! | +
+ number_outliers <- number_records - length(var)+ |
+
| 726 | +! | +
+ outlier_text <- paste0(+ |
+
| 727 | +! | +
+ number_outliers, " outliers (",
+ |
+
| 728 | +! | +
+ round(number_outliers / number_records * 100, 2),+ |
+
| 729 | +! | +
+ "% of non-missing records) not shown"+ |
+
| 730 | ++ |
+ )+ |
+
| 731 | +! | +
+ validate(need(+ |
+
| 732 | +! | +
+ length(var) > 1,+ |
+
| 733 | +! | +
+ "At least two data points must remain after removing outliers for this graph to be displayed"+ |
+
| 734 | ++ |
+ ))+ |
+
| 735 | ++ |
+ }+ |
+
| 736 | ++ |
+ ## histogram+ |
+
| 737 | +! | +
+ binwidth <- get_bin_width(var)+ |
+
| 738 | +! | +
+ p <- ggplot(data = data.frame(var = var), aes(x = var, y = after_stat(count))) ++ |
+
| 739 | +! | +
+ geom_histogram(binwidth = binwidth) ++ |
+
| 740 | +! | +
+ scale_y_continuous(+ |
+
| 741 | +! | +
+ sec.axis = sec_axis(+ |
+
| 742 | +! | +
+ trans = ~ . / nrow(data.frame(var = var)),+ |
+
| 743 | +! | +
+ labels = scales::percent,+ |
+
| 744 | +! | +
+ name = "proportion (in %)"+ |
+
| 745 | ++ |
+ )+ |
+
| 746 | ++ |
+ )+ |
+
| 747 | ++ | + + | +
| 748 | +! | +
+ if (display_density) {
+ |
+
| 749 | +! | +
+ p <- p + geom_density(aes(y = after_stat(count * binwidth)))+ |
+
| 750 | ++ |
+ }+ |
+
| 751 | ++ | + + | +
| 752 | +! | +
+ if (outlier_definition != 0) {
+ |
+
| 753 | +! | +
+ p <- p + annotate(+ |
+
| 754 | +! | +
+ geom = "text",+ |
+
| 755 | +! | +
+ label = outlier_text,+ |
+
| 756 | +! | +
+ x = Inf, y = Inf,+ |
+
| 757 | +! | +
+ hjust = 1.02, vjust = 1.2,+ |
+
| 758 | +! | +
+ color = "black",+ |
+
| 759 | ++ |
+ # explicitly modify geom text size according+ |
+
| 760 | +! | +
+ size = ggplot2_args[["theme"]][["text"]][["size"]] / 3.5+ |
+
| 761 | ++ |
+ )+ |
+
| 762 | ++ |
+ }+ |
+
| 763 | +! | +
+ p+ |
+
| 764 | ++ |
+ }+ |
+
| 765 | +! | +
+ } else if (inherits(var, "Date") || inherits(var, "POSIXct") || inherits(var, "POSIXlt")) {
+ |
+
| 766 | +! | +
+ var_num <- as.numeric(var)+ |
+
| 767 | +! | +
+ binwidth <- get_bin_width(var_num, 1)+ |
+
| 768 | +! | +
+ p <- ggplot(data = data.frame(var = var), aes(x = var, y = after_stat(count))) ++ |
+
| 769 | +! | +
+ geom_histogram(binwidth = binwidth)+ |
+
| 770 | ++ |
+ } else {
+ |
+
| 771 | +! | +
+ grid::textGrob(+ |
+
| 772 | +! | +
+ paste(strwrap(+ |
+
| 773 | +! | +
+ utils::capture.output(utils::str(var)),+ |
+
| 774 | +! | +
+ width = .9 * grid::convertWidth(grid::unit(1, "npc"), "char", TRUE)+ |
+
| 775 | +! | +
+ ), collapse = "\n"),+ |
+
| 776 | +! | +
+ x = grid::unit(1, "line"), y = grid::unit(1, "npc") - grid::unit(1, "line"), just = c("left", "top")
+ |
+
| 777 | ++ |
+ )+ |
+
| 778 | ++ |
+ }+ |
+
| 779 | ++ | + + | +
| 780 | +! | +
+ dev_ggplot2_args <- teal.widgets::ggplot2_args(+ |
+
| 781 | +! | +
+ labs = list(x = var_lab)+ |
+
| 782 | ++ |
+ )+ |
+
| 783 | ++ |
+ ###+ |
+
| 784 | +! | +
+ all_ggplot2_args <- teal.widgets::resolve_ggplot2_args(+ |
+
| 785 | +! | +
+ ggplot2_args,+ |
+
| 786 | +! | +
+ module_plot = dev_ggplot2_args+ |
+
| 787 | ++ |
+ )+ |
+
| 788 | ++ | + + | +
| 789 | +! | +
+ if (is.ggplot(plot_main)) {
+ |
+
| 790 | +! | +
+ if (is.numeric(var) && !numeric_as_factor) {
+ |
+
| 791 | ++ |
+ # numeric not as factor+ |
+
| 792 | +! | +
+ plot_main <- plot_main ++ |
+
| 793 | +! | +
+ theme_light() ++ |
+
| 794 | +! | +
+ list(+ |
+
| 795 | +! | +
+ labs = do.call("labs", all_ggplot2_args$labs),
+ |
+
| 796 | +! | +
+ theme = do.call("theme", all_ggplot2_args$theme)
+ |
+
| 797 | ++ |
+ )+ |
+
| 798 | ++ |
+ } else {
+ |
+
| 799 | ++ |
+ # factor low number of levels OR numeric as factor OR Date+ |
+
| 800 | +! | +
+ plot_main <- plot_main ++ |
+
| 801 | +! | +
+ theme_light() ++ |
+
| 802 | +! | +
+ list(+ |
+
| 803 | +! | +
+ labs = do.call("labs", all_ggplot2_args$labs),
+ |
+
| 804 | +! | +
+ theme = do.call("theme", all_ggplot2_args$theme)
+ |
+
| 805 | ++ |
+ )+ |
+
| 806 | ++ |
+ }+ |
+
| 807 | +! | +
+ plot_main <- ggplotGrob(plot_main)+ |
+
| 808 | ++ |
+ }+ |
+
| 809 | ++ | + + | +
| 810 | +! | +
+ grid::grid.draw(plot_main)+ |
+
| 811 | +! | +
+ plot_main+ |
+
| 812 | ++ |
+ }+ |
+
| 813 | ++ | + + | +
| 814 | ++ |
+ is_num_var_short <- function(.unique_records_for_factor, input, data_for_analysis) {
+ |
+
| 815 | +! | +
+ length(unique(data_for_analysis()$data)) < .unique_records_for_factor && !is.null(input$numeric_as_factor)+ |
+
| 816 | ++ |
+ }+ |
+
| 817 | ++ | + + | +
| 818 | ++ |
+ #' Validates the variable browser inputs+ |
+
| 819 | ++ |
+ #'+ |
+
| 820 | ++ |
+ #' @param input (`session$input`) the `shiny` session input+ |
+
| 821 | ++ |
+ #' @param plot_var (`list`) list of a data frame and an array of variable names+ |
+
| 822 | ++ |
+ #' @param data (`teal_data`) the datasets passed to the module+ |
+
| 823 | ++ |
+ #'+ |
+
| 824 | ++ |
+ #' @returns `logical` TRUE if validations pass; a `shiny` validation error otherwise+ |
+
| 825 | ++ |
+ #' @keywords internal+ |
+
| 826 | ++ |
+ validate_input <- function(input, plot_var, data) {
+ |
+
| 827 | +! | +
+ reactive({
+ |
+
| 828 | +! | +
+ dataset_name <- req(input$tabset_panel)+ |
+
| 829 | +! | +
+ varname <- plot_var$variable[[dataset_name]]+ |
+
| 830 | ++ | + + | +
| 831 | +! | +
+ validate(need(dataset_name, "No data selected"))+ |
+
| 832 | +! | +
+ validate(need(varname, "No variable selected"))+ |
+
| 833 | +! | +
+ df <- data()[[dataset_name]]+ |
+
| 834 | +! | +
+ teal::validate_has_data(df, 1)+ |
+
| 835 | +! | +
+ teal::validate_has_variable(varname = varname, data = df, "Variable not available")+ |
+
| 836 | ++ | + + | +
| 837 | +! | +
+ TRUE+ |
+
| 838 | ++ |
+ })+ |
+
| 839 | ++ |
+ }+ |
+
| 840 | ++ | + + | +
| 841 | ++ |
+ get_plotted_data <- function(input, plot_var, data) {
+ |
+
| 842 | +! | +
+ dataset_name <- input$tabset_panel+ |
+
| 843 | +! | +
+ varname <- plot_var$variable[[dataset_name]]+ |
+
| 844 | +! | +
+ df <- data()[[dataset_name]]+ |
+
| 845 | ++ | + + | +
| 846 | +! | +
+ var_description <- teal.data::col_labels(df)[[varname]]+ |
+
| 847 | +! | +
+ list(data = df[[varname]], var_description = var_description)+ |
+
| 848 | ++ |
+ }+ |
+
| 849 | ++ | + + | +
| 850 | ++ |
+ #' Renders the left-hand side `tabset` panel of the module+ |
+
| 851 | ++ |
+ #'+ |
+
| 852 | ++ |
+ #' @param datanames (`character`) the name of the dataset+ |
+
| 853 | ++ |
+ #' @param parent_dataname (`character`) the name of a parent `dataname` to filter out variables from+ |
+
| 854 | ++ |
+ #' @param data (`teal_data`) the object containing all datasets+ |
+
| 855 | ++ |
+ #' @param input (`session$input`) the `shiny` session input+ |
+
| 856 | ++ |
+ #' @param output (`session$output`) the `shiny` session output+ |
+
| 857 | ++ |
+ #' @param columns_names (`environment`) the environment containing bindings for each dataset+ |
+
| 858 | ++ |
+ #' @param plot_var (`list`) the list containing the currently selected dataset (tab) and its column names+ |
+
| 859 | ++ |
+ #' @keywords internal+ |
+
| 860 | ++ |
+ render_tabset_panel_content <- function(datanames, parent_dataname, output, data, input, columns_names, plot_var) {
+ |
+
| 861 | +! | +
+ lapply(datanames, render_single_tab,+ |
+
| 862 | +! | +
+ input = input,+ |
+
| 863 | +! | +
+ output = output,+ |
+
| 864 | +! | +
+ data = data,+ |
+
| 865 | +! | +
+ parent_dataname = parent_dataname,+ |
+
| 866 | +! | +
+ columns_names = columns_names,+ |
+
| 867 | +! | +
+ plot_var = plot_var+ |
+
| 868 | ++ |
+ )+ |
+
| 869 | ++ |
+ }+ |
+
| 870 | ++ | + + | +
| 871 | ++ |
+ #' Renders a single tab in the left-hand side tabset panel+ |
+
| 872 | ++ |
+ #'+ |
+
| 873 | ++ |
+ #' Renders a single tab in the left-hand side tabset panel. The rendered tab contains+ |
+
| 874 | ++ |
+ #' information about one dataset out of many presented in the module.+ |
+
| 875 | ++ |
+ #'+ |
+
| 876 | ++ |
+ #' @param dataset_name (`character`) the name of the dataset contained in the rendered tab+ |
+
| 877 | ++ |
+ #' @param parent_dataname (`character`) the name of a parent `dataname` to filter out variables from+ |
+
| 878 | ++ |
+ #' @inheritParams render_tabset_panel_content+ |
+
| 879 | ++ |
+ #' @keywords internal+ |
+
| 880 | ++ |
+ render_single_tab <- function(dataset_name, parent_dataname, output, data, input, columns_names, plot_var) {
+ |
+
| 881 | +! | +
+ render_tab_header(dataset_name, output, data)+ |
+
| 882 | ++ | + + | +
| 883 | +! | +
+ render_tab_table(+ |
+
| 884 | +! | +
+ dataset_name = dataset_name,+ |
+
| 885 | +! | +
+ parent_dataname = parent_dataname,+ |
+
| 886 | +! | +
+ output = output,+ |
+
| 887 | +! | +
+ data = data,+ |
+
| 888 | +! | +
+ input = input,+ |
+
| 889 | +! | +
+ columns_names = columns_names,+ |
+
| 890 | +! | +
+ plot_var = plot_var+ |
+
| 891 | ++ |
+ )+ |
+
| 892 | ++ |
+ }+ |
+
| 893 | ++ | + + | +
| 894 | ++ |
+ #' Renders the text headlining a single tab in the left-hand side tabset panel+ |
+
| 895 | ++ |
+ #'+ |
+
| 896 | ++ |
+ #' @param dataset_name (`character`) the name of the dataset of the tab+ |
+
| 897 | ++ |
+ #' @inheritParams render_tabset_panel_content+ |
+
| 898 | ++ |
+ #' @keywords internal+ |
+
| 899 | ++ |
+ render_tab_header <- function(dataset_name, output, data) {
+ |
+
| 900 | +! | +
+ dataset_ui_id <- paste0("dataset_summary_", dataset_name)
+ |
+
| 901 | +! | +
+ output[[dataset_ui_id]] <- renderText({
+ |
+
| 902 | +! | +
+ df <- data()[[dataset_name]]+ |
+
| 903 | +! | +
+ join_keys <- join_keys(data())+ |
+
| 904 | +! | +
+ if (!is.null(join_keys)) {
+ |
+
| 905 | +! | +
+ key <- join_keys(data())[dataset_name, dataset_name]+ |
+
| 906 | ++ |
+ } else {
+ |
+
| 907 | +! | +
+ key <- NULL+ |
+
| 908 | ++ |
+ }+ |
+
| 909 | +! | +
+ sprintf(+ |
+
| 910 | +! | +
+ "Dataset with %s unique key rows and %s variables",+ |
+
| 911 | +! | +
+ nrow(unique(`if`(length(key) > 0, df[, key, drop = FALSE], df))),+ |
+
| 912 | +! | +
+ ncol(df)+ |
+
| 913 | ++ |
+ )+ |
+
| 914 | ++ |
+ })+ |
+
| 915 | ++ |
+ }+ |
+
| 916 | ++ | + + | +
| 917 | ++ |
+ #' Renders the table for a single dataset in the left-hand side tabset panel+ |
+
| 918 | ++ |
+ #'+ |
+
| 919 | ++ |
+ #' The table contains column names, column labels,+ |
+
| 920 | ++ |
+ #' small summary about NA values and `sparkline` (if appropriate).+ |
+
| 921 | ++ |
+ #'+ |
+
| 922 | ++ |
+ #' @param dataset_name (`character`) the name of the dataset+ |
+
| 923 | ++ |
+ #' @param parent_dataname (`character`) the name of a parent `dataname` to filter out variables from+ |
+
| 924 | ++ |
+ #' @inheritParams render_tabset_panel_content+ |
+
| 925 | ++ |
+ #' @keywords internal+ |
+
| 926 | ++ |
+ render_tab_table <- function(dataset_name, parent_dataname, output, data, input, columns_names, plot_var) {
+ |
+
| 927 | +! | +
+ table_ui_id <- paste0("variable_browser_", dataset_name)
+ |
+
| 928 | ++ | + + | +
| 929 | +! | +
+ output[[table_ui_id]] <- DT::renderDataTable({
+ |
+
| 930 | +! | +
+ df <- data()[[dataset_name]]+ |
+
| 931 | ++ | + + | +
| 932 | +! | +
+ get_vars_df <- function(input, dataset_name, parent_name, data) {
+ |
+
| 933 | +! | +
+ data_cols <- colnames(df)+ |
+
| 934 | +! | +
+ if (isTRUE(input$show_parent_vars)) {
+ |
+
| 935 | +! | +
+ data_cols+ |
+
| 936 | +! | +
+ } else if (dataset_name != parent_name && parent_name %in% names(data)) {
+ |
+
| 937 | +! | +
+ setdiff(data_cols, colnames(data()[[parent_name]]))+ |
+
| 938 | ++ |
+ } else {
+ |
+
| 939 | +! | +
+ data_cols+ |
+
| 940 | ++ |
+ }+ |
+
| 941 | ++ |
+ }+ |
+
| 942 | ++ | + + | +
| 943 | +! | +
+ if (length(parent_dataname) > 0) {
+ |
+
| 944 | +! | +
+ df_vars <- get_vars_df(input, dataset_name, parent_dataname, data)+ |
+
| 945 | +! | +
+ df <- df[df_vars]+ |
+
| 946 | ++ |
+ }+ |
+
| 947 | ++ | + + | +
| 948 | +! | +
+ if (is.null(df) || ncol(df) == 0) {
+ |
+
| 949 | +! | +
+ columns_names[[dataset_name]] <- character(0)+ |
+
| 950 | +! | +
+ df_output <- data.frame(+ |
+
| 951 | +! | +
+ Type = character(0),+ |
+
| 952 | +! | +
+ Variable = character(0),+ |
+
| 953 | +! | +
+ Label = character(0),+ |
+
| 954 | +! | +
+ Missings = character(0),+ |
+
| 955 | +! | +
+ Sparklines = character(0),+ |
+
| 956 | +! | +
+ stringsAsFactors = FALSE+ |
+
| 957 | ++ |
+ )+ |
+
| 958 | ++ |
+ } else {
+ |
+
| 959 | ++ |
+ # extract data variable labels+ |
+
| 960 | +! | +
+ labels <- teal.data::col_labels(df)+ |
+
| 961 | ++ | + + | +
| 962 | +! | +
+ columns_names[[dataset_name]] <- names(labels)+ |
+
| 963 | ++ | + + | +
| 964 | ++ |
+ # calculate number of missing values+ |
+
| 965 | +! | +
+ missings <- vapply(+ |
+
| 966 | +! | +
+ df,+ |
+
| 967 | +! | +
+ var_missings_info,+ |
+
| 968 | +! | +
+ FUN.VALUE = character(1),+ |
+
| 969 | +! | +
+ USE.NAMES = FALSE+ |
+
| 970 | ++ |
+ )+ |
+
| 971 | ++ | + + | +
| 972 | ++ |
+ # get icons proper for the data types+ |
+
| 973 | +! | +
+ icons <- vapply(df, function(x) class(x)[1L], character(1L))+ |
+
| 974 | ++ | + + | +
| 975 | +! | +
+ join_keys <- join_keys(data())+ |
+
| 976 | +! | +
+ if (!is.null(join_keys)) {
+ |
+
| 977 | +! | +
+ icons[intersect(join_keys[dataset_name, dataset_name], colnames(df))] <- "primary_key"+ |
+
| 978 | ++ |
+ }+ |
+
| 979 | +! | +
+ icons <- variable_type_icons(icons)+ |
+
| 980 | ++ | + + | +
| 981 | ++ |
+ # generate sparklines+ |
+
| 982 | +! | +
+ sparklines_html <- vapply(+ |
+
| 983 | +! | +
+ df,+ |
+
| 984 | +! | +
+ create_sparklines,+ |
+
| 985 | +! | +
+ FUN.VALUE = character(1),+ |
+
| 986 | +! | +
+ USE.NAMES = FALSE+ |
+
| 987 | ++ |
+ )+ |
+
| 988 | ++ | + + | +
| 989 | +! | +
+ df_output <- data.frame(+ |
+
| 990 | +! | +
+ Type = icons,+ |
+
| 991 | +! | +
+ Variable = names(labels),+ |
+
| 992 | +! | +
+ Label = labels,+ |
+
| 993 | +! | +
+ Missings = missings,+ |
+
| 994 | +! | +
+ Sparklines = sparklines_html,+ |
+
| 995 | +! | +
+ stringsAsFactors = FALSE+ |
+
| 996 | ++ |
+ )+ |
+
| 997 | ++ |
+ }+ |
+
| 998 | ++ | + + | +
| 999 | ++ |
+ # Select row 1 as default / fallback+ |
+
| 1000 | +! | +
+ selected_ix <- 1+ |
+
| 1001 | ++ |
+ # Define starting page index (base-0 index of the first item on page+ |
+
| 1002 | ++ |
+ # note: in many cases it's not the item itself+ |
+
| 1003 | +! | +
+ selected_page_ix <- 0+ |
+
| 1004 | ++ | + + | +
| 1005 | ++ |
+ # Retrieve current selected variable if any+ |
+
| 1006 | +! | +
+ isolated_variable <- shiny::isolate(plot_var$variable[[dataset_name]])+ |
+
| 1007 | ++ | + + | +
| 1008 | +! | +
+ if (!is.null(isolated_variable)) {
+ |
+
| 1009 | +! | +
+ index <- which(columns_names[[dataset_name]] == isolated_variable)[1]+ |
+
| 1010 | +! | +
+ if (!is.null(index) && !is.na(index) && length(index) > 0) selected_ix <- index+ |
+
| 1011 | ++ |
+ }+ |
+
| 1012 | ++ | + + | +
| 1013 | ++ |
+ # Retrieve the index of the first item of the current page+ |
+
| 1014 | ++ |
+ # it works with varying number of entries on the page (10, 25, ...)+ |
+
| 1015 | +! | +
+ table_id_sel <- paste0("variable_browser_", dataset_name, "_state")
+ |
+
| 1016 | +! | +
+ dt_state <- shiny::isolate(input[[table_id_sel]])+ |
+
| 1017 | +! | +
+ if (selected_ix != 1 && !is.null(dt_state)) {
+ |
+
| 1018 | +! | +
+ selected_page_ix <- floor(selected_ix / dt_state$length) * dt_state$length+ |
+
| 1019 | ++ |
+ }+ |
+
| 1020 | ++ | + + | +
| 1021 | +! | +
+ DT::datatable(+ |
+
| 1022 | +! | +
+ df_output,+ |
+
| 1023 | +! | +
+ escape = FALSE,+ |
+
| 1024 | +! | +
+ rownames = FALSE,+ |
+
| 1025 | +! | +
+ selection = list(mode = "single", target = "row", selected = selected_ix),+ |
+
| 1026 | +! | +
+ options = list(+ |
+
| 1027 | +! | +
+ fnDrawCallback = htmlwidgets::JS("function() { HTMLWidgets.staticRender(); }"),
+ |
+
| 1028 | +! | +
+ pageLength = input[[paste0(table_ui_id, "_rows")]],+ |
+
| 1029 | +! | +
+ displayStart = selected_page_ix+ |
+
| 1030 | ++ |
+ )+ |
+
| 1031 | ++ |
+ )+ |
+
| 1032 | ++ |
+ })+ |
+
| 1033 | ++ |
+ }+ |
+
| 1034 | ++ | + + | +
| 1035 | ++ |
+ #' Creates observers updating the currently selected column+ |
+
| 1036 | ++ |
+ #'+ |
+
| 1037 | ++ |
+ #' The created observers update the column currently selected in the left-hand side+ |
+
| 1038 | ++ |
+ #' tabset panel.+ |
+
| 1039 | ++ |
+ #'+ |
+
| 1040 | ++ |
+ #' @note+ |
+
| 1041 | ++ |
+ #' Creates an observer for each dataset (each tab in the tabset panel).+ |
+
| 1042 | ++ |
+ #'+ |
+
| 1043 | ++ |
+ #' @inheritParams render_tabset_panel_content+ |
+
| 1044 | ++ |
+ #' @keywords internal+ |
+
| 1045 | ++ |
+ establish_updating_selection <- function(datanames, input, plot_var, columns_names) {
+ |
+
| 1046 | +! | +
+ lapply(datanames, function(dataset_name) {
+ |
+
| 1047 | +! | +
+ table_ui_id <- paste0("variable_browser_", dataset_name)
+ |
+
| 1048 | +! | +
+ table_id_sel <- paste0(table_ui_id, "_rows_selected")+ |
+
| 1049 | +! | +
+ observeEvent(input[[table_id_sel]], {
+ |
+
| 1050 | +! | +
+ plot_var$data <- dataset_name+ |
+
| 1051 | +! | +
+ plot_var$variable[[dataset_name]] <- columns_names[[dataset_name]][input[[table_id_sel]]]+ |
+
| 1052 | ++ |
+ })+ |
+
| 1053 | ++ |
+ })+ |
+
| 1054 | ++ |
+ }+ |
+
| 1055 | ++ | + + | +
| 1056 | ++ |
+ get_bin_width <- function(x_vec, scaling_factor = 2) {
+ |
+
| 1057 | +! | +
+ x_vec <- x_vec[!is.na(x_vec)]+ |
+
| 1058 | +! | +
+ qntls <- stats::quantile(x_vec, probs = c(0.1, 0.25, 0.75, 0.9), type = 2)+ |
+
| 1059 | +! | +
+ iqr <- qntls[3] - qntls[2]+ |
+
| 1060 | +! | +
+ binwidth <- max(scaling_factor * iqr / length(x_vec) ^ (1 / 3), sqrt(qntls[4] - qntls[1])) # styler: off+ |
+
| 1061 | +! | +
+ binwidth <- ifelse(binwidth == 0, 1, binwidth)+ |
+
| 1062 | ++ |
+ # to ensure at least two bins when variable span is very small+ |
+
| 1063 | +! | +
+ x_span <- diff(range(x_vec))+ |
+
| 1064 | +! | +
+ if (isTRUE(x_span / binwidth >= 2)) binwidth else x_span / 2+ |
+
| 1065 | ++ |
+ }+ |
+
| 1066 | ++ | + + | +
| 1067 | ++ |
+ #' Removes the outlier observation from an array+ |
+
| 1068 | ++ |
+ #'+ |
+
| 1069 | ++ |
+ #' @param var (`numeric`) a numeric vector+ |
+
| 1070 | ++ |
+ #' @param outlier_definition (`numeric`) if `0` then no outliers are removed, otherwise+ |
+
| 1071 | ++ |
+ #' outliers (those more than `outlier_definition*IQR below/above Q1/Q3`) are removed+ |
+
| 1072 | ++ |
+ #' @returns (`numeric`) vector without the outlier values+ |
+
| 1073 | ++ |
+ #' @keywords internal+ |
+
| 1074 | ++ |
+ remove_outliers_from <- function(var, outlier_definition) {
+ |
+
| 1075 | +3x | +
+ if (outlier_definition == 0) {
+ |
+
| 1076 | +1x | +
+ return(var)+ |
+
| 1077 | ++ |
+ }+ |
+
| 1078 | +2x | +
+ q1_q3 <- stats::quantile(var, probs = c(0.25, 0.75), type = 2, na.rm = TRUE)+ |
+
| 1079 | +2x | +
+ iqr <- q1_q3[2] - q1_q3[1]+ |
+
| 1080 | +2x | +
+ var[var >= q1_q3[1] - outlier_definition * iqr & var <= q1_q3[2] + outlier_definition * iqr]+ |
+
| 1081 | ++ |
+ }+ |
+
| 1082 | ++ | + + | +
| 1083 | ++ | + + | +
| 1084 | ++ |
+ # sparklines ----+ |
+
| 1085 | ++ | + + | +
| 1086 | ++ |
+ #' S3 generic for `sparkline` widget HTML+ |
+
| 1087 | ++ |
+ #'+ |
+
| 1088 | ++ |
+ #' Generates the `sparkline` HTML code corresponding to the input array.+ |
+
| 1089 | ++ |
+ #' For numeric variables creates a box plot, for character and factors - bar plot.+ |
+
| 1090 | ++ |
+ #' Produces an empty string for variables of other types.+ |
+
| 1091 | ++ |
+ #'+ |
+
| 1092 | ++ |
+ #' @param arr vector of any type and length+ |
+
| 1093 | ++ |
+ #' @param width `numeric` the width of the `sparkline` widget (pixels)+ |
+
| 1094 | ++ |
+ #' @param bar_spacing `numeric` the spacing between the bars (in pixels)+ |
+
| 1095 | ++ |
+ #' @param bar_width `numeric` the width of the bars (in pixels)+ |
+
| 1096 | ++ |
+ #' @param ... `list` additional options passed to bar plots of `jquery.sparkline`;+ |
+
| 1097 | ++ |
+ #' see [`jquery.sparkline docs`](https://omnipotent.net/jquery.sparkline/#common)+ |
+
| 1098 | ++ |
+ #'+ |
+
| 1099 | ++ |
+ #' @return Character string containing HTML code of the `sparkline` HTML widget.+ |
+
| 1100 | ++ |
+ #' @keywords internal+ |
+
| 1101 | ++ |
+ create_sparklines <- function(arr, width = 150, ...) {
+ |
+
| 1102 | +! | +
+ if (all(is.null(arr))) {
+ |
+
| 1103 | +! | +
+ return("")
+ |
+
| 1104 | ++ |
+ }+ |
+
| 1105 | +! | +
+ UseMethod("create_sparklines")
+ |
+
| 1106 | ++ |
+ }+ |
+
| 1107 | ++ | + + | +
| 1108 | ++ |
+ #' @rdname create_sparklines+ |
+
| 1109 | ++ |
+ #' @keywords internal+ |
+
| 1110 | ++ |
+ #' @export+ |
+
| 1111 | ++ |
+ create_sparklines.logical <- function(arr, ...) {
+ |
+
| 1112 | +! | +
+ create_sparklines(as.factor(arr))+ |
+
| 1113 | ++ |
+ }+ |
+
| 1114 | ++ | + + | +
| 1115 | ++ |
+ #' @rdname create_sparklines+ |
+
| 1116 | ++ |
+ #' @keywords internal+ |
+
| 1117 | ++ |
+ #' @export+ |
+
| 1118 | ++ |
+ create_sparklines.numeric <- function(arr, width = 150, ...) {
+ |
+
| 1119 | +! | +
+ if (any(is.infinite(arr))) {
+ |
+
| 1120 | +! | +
+ return(as.character(tags$code("infinite values", class = "text-blue")))
+ |
+
| 1121 | ++ |
+ }+ |
+
| 1122 | +! | +
+ if (length(arr) > 100000) {
+ |
+
| 1123 | +! | +
+ return(as.character(tags$code("Too many rows (>100000)", class = "text-blue")))
+ |
+
| 1124 | ++ |
+ }+ |
+
| 1125 | ++ | + + | +
| 1126 | +! | +
+ arr <- arr[!is.na(arr)]+ |
+
| 1127 | +! | +
+ sparkline::spk_chr(unname(arr), type = "box", width = width, ...)+ |
+
| 1128 | ++ |
+ }+ |
+
| 1129 | ++ | + + | +
| 1130 | ++ |
+ #' @rdname create_sparklines+ |
+
| 1131 | ++ |
+ #' @keywords internal+ |
+
| 1132 | ++ |
+ #' @export+ |
+
| 1133 | ++ |
+ create_sparklines.character <- function(arr, ...) {
+ |
+
| 1134 | +! | +
+ return(create_sparklines(as.factor(arr)))+ |
+
| 1135 | ++ |
+ }+ |
+
| 1136 | ++ | + + | +
| 1137 | ++ | + + | +
| 1138 | ++ |
+ #' @rdname create_sparklines+ |
+
| 1139 | ++ |
+ #' @keywords internal+ |
+
| 1140 | ++ |
+ #' @export+ |
+
| 1141 | ++ |
+ create_sparklines.factor <- function(arr, width = 150, bar_spacing = 5, bar_width = 20, ...) {
+ |
+
| 1142 | +! | +
+ decreasing_order <- TRUE+ |
+
| 1143 | ++ | + + | +
| 1144 | +! | +
+ counts <- table(arr)+ |
+
| 1145 | +! | +
+ if (length(counts) >= 100) {
+ |
+
| 1146 | +! | +
+ return(as.character(tags$code("> 99 levels", class = "text-blue")))
+ |
+
| 1147 | +! | +
+ } else if (length(counts) == 0) {
+ |
+
| 1148 | +! | +
+ return(as.character(tags$code("no levels", class = "text-blue")))
+ |
+
| 1149 | +! | +
+ } else if (length(counts) == 1) {
+ |
+
| 1150 | +! | +
+ return(as.character(tags$code("one level", class = "text-blue")))
+ |
+
| 1151 | ++ |
+ }+ |
+
| 1152 | ++ | + + | +
| 1153 | ++ |
+ # Summarize the occurences of different levels+ |
+
| 1154 | ++ |
+ # and get the maximum and minimum number of occurences+ |
+
| 1155 | ++ |
+ # This is needed for the sparkline to correctly display the bar plots+ |
+
| 1156 | ++ |
+ # Otherwise they are cropped+ |
+
| 1157 | +! | +
+ counts <- sort(counts, decreasing = decreasing_order, method = "radix")+ |
+
| 1158 | +! | +
+ max_value <- if (decreasing_order) counts[1] else counts[length[counts]]+ |
+
| 1159 | +! | +
+ max_value <- unname(max_value)+ |
+
| 1160 | ++ | + + | +
| 1161 | +! | +
+ sparkline::spk_chr(+ |
+
| 1162 | +! | +
+ unname(counts),+ |
+
| 1163 | +! | +
+ type = "bar",+ |
+
| 1164 | +! | +
+ chartRangeMin = 0,+ |
+
| 1165 | +! | +
+ chartRangeMax = max_value,+ |
+
| 1166 | +! | +
+ width = width,+ |
+
| 1167 | +! | +
+ barWidth = bar_width,+ |
+
| 1168 | +! | +
+ barSpacing = bar_spacing,+ |
+
| 1169 | +! | +
+ tooltipFormatter = custom_sparkline_formatter(names(counts), as.vector(counts))+ |
+
| 1170 | ++ |
+ )+ |
+
| 1171 | ++ |
+ }+ |
+
| 1172 | ++ | + + | +
| 1173 | ++ |
+ #' @rdname create_sparklines+ |
+
| 1174 | ++ |
+ #' @keywords internal+ |
+
| 1175 | ++ |
+ #' @export+ |
+
| 1176 | ++ |
+ create_sparklines.Date <- function(arr, width = 150, bar_spacing = 5, bar_width = 20, ...) {
+ |
+
| 1177 | +! | +
+ arr_num <- as.numeric(arr)+ |
+
| 1178 | +! | +
+ arr_num <- sort(arr_num, decreasing = FALSE, method = "radix")+ |
+
| 1179 | +! | +
+ binwidth <- get_bin_width(arr_num, 1)+ |
+
| 1180 | +! | +
+ bins <- floor(diff(range(arr_num)) / binwidth) + 1+ |
+
| 1181 | +! | +
+ if (all(is.na(bins))) {
+ |
+
| 1182 | +! | +
+ return(as.character(tags$code("only NA", class = "text-blue")))
+ |
+
| 1183 | +! | +
+ } else if (bins == 1) {
+ |
+
| 1184 | +! | +
+ return(as.character(tags$code("one date", class = "text-blue")))
+ |
+
| 1185 | ++ |
+ }+ |
+
| 1186 | +! | +
+ counts <- as.vector(unname(base::table(cut(arr_num, breaks = bins))))+ |
+
| 1187 | +! | +
+ max_value <- max(counts)+ |
+
| 1188 | ++ | + + | +
| 1189 | +! | +
+ start_bins <- as.integer(seq(1, length(arr_num), length.out = bins))+ |
+
| 1190 | +! | +
+ labels_start <- as.character(as.Date(arr_num[start_bins], origin = as.Date("1970-01-01")))
+ |
+
| 1191 | +! | +
+ labels <- paste("Start:", labels_start)
+ |
+
| 1192 | ++ | + + | +
| 1193 | +! | +
+ sparkline::spk_chr(+ |
+
| 1194 | +! | +
+ unname(counts),+ |
+
| 1195 | +! | +
+ type = "bar",+ |
+
| 1196 | +! | +
+ chartRangeMin = 0,+ |
+
| 1197 | +! | +
+ chartRangeMax = max_value,+ |
+
| 1198 | +! | +
+ width = width,+ |
+
| 1199 | +! | +
+ barWidth = bar_width,+ |
+
| 1200 | +! | +
+ barSpacing = bar_spacing,+ |
+
| 1201 | +! | +
+ tooltipFormatter = custom_sparkline_formatter(labels, counts)+ |
+
| 1202 | ++ |
+ )+ |
+
| 1203 | ++ |
+ }+ |
+
| 1204 | ++ | + + | +
| 1205 | ++ |
+ #' @rdname create_sparklines+ |
+
| 1206 | ++ |
+ #' @keywords internal+ |
+
| 1207 | ++ |
+ #' @export+ |
+
| 1208 | ++ |
+ create_sparklines.POSIXct <- function(arr, width = 150, bar_spacing = 5, bar_width = 20, ...) {
+ |
+
| 1209 | +! | +
+ arr_num <- as.numeric(arr)+ |
+
| 1210 | +! | +
+ arr_num <- sort(arr_num, decreasing = FALSE, method = "radix")+ |
+
| 1211 | +! | +
+ binwidth <- get_bin_width(arr_num, 1)+ |
+
| 1212 | +! | +
+ bins <- floor(diff(range(arr_num)) / binwidth) + 1+ |
+
| 1213 | +! | +
+ if (all(is.na(bins))) {
+ |
+
| 1214 | +! | +
+ return(as.character(tags$code("only NA", class = "text-blue")))
+ |
+
| 1215 | +! | +
+ } else if (bins == 1) {
+ |
+
| 1216 | +! | +
+ return(as.character(tags$code("one date-time", class = "text-blue")))
+ |
+
| 1217 | ++ |
+ }+ |
+
| 1218 | +! | +
+ counts <- as.vector(unname(base::table(cut(arr_num, breaks = bins))))+ |
+
| 1219 | +! | +
+ max_value <- max(counts)+ |
+
| 1220 | ++ | + + | +
| 1221 | +! | +
+ start_bins <- as.integer(seq(1, length(arr_num), length.out = bins))+ |
+
| 1222 | +! | +
+ labels_start <- as.character(format(as.POSIXct(arr_num[start_bins], origin = as.Date("1970-01-01")), "%Y-%m-%d"))
+ |
+
| 1223 | +! | +
+ labels <- paste("Start:", labels_start)
+ |
+
| 1224 | ++ | + + | +
| 1225 | +! | +
+ sparkline::spk_chr(+ |
+
| 1226 | +! | +
+ unname(counts),+ |
+
| 1227 | +! | +
+ type = "bar",+ |
+
| 1228 | +! | +
+ chartRangeMin = 0,+ |
+
| 1229 | +! | +
+ chartRangeMax = max_value,+ |
+
| 1230 | +! | +
+ width = width,+ |
+
| 1231 | +! | +
+ barWidth = bar_width,+ |
+
| 1232 | +! | +
+ barSpacing = bar_spacing,+ |
+
| 1233 | +! | +
+ tooltipFormatter = custom_sparkline_formatter(labels, counts)+ |
+
| 1234 | ++ |
+ )+ |
+
| 1235 | ++ |
+ }+ |
+
| 1236 | ++ | + + | +
| 1237 | ++ |
+ #' @rdname create_sparklines+ |
+
| 1238 | ++ |
+ #' @keywords internal+ |
+
| 1239 | ++ |
+ #' @export+ |
+
| 1240 | ++ |
+ create_sparklines.POSIXlt <- function(arr, width = 150, bar_spacing = 5, bar_width = 20, ...) {
+ |
+
| 1241 | +! | +
+ arr_num <- as.numeric(arr)+ |
+
| 1242 | +! | +
+ arr_num <- sort(arr_num, decreasing = FALSE, method = "radix")+ |
+
| 1243 | +! | +
+ binwidth <- get_bin_width(arr_num, 1)+ |
+
| 1244 | +! | +
+ bins <- floor(diff(range(arr_num)) / binwidth) + 1+ |
+
| 1245 | +! | +
+ if (all(is.na(bins))) {
+ |
+
| 1246 | +! | +
+ return(as.character(tags$code("only NA", class = "text-blue")))
+ |
+
| 1247 | +! | +
+ } else if (bins == 1) {
+ |
+
| 1248 | +! | +
+ return(as.character(tags$code("one date-time", class = "text-blue")))
+ |
+
| 1249 | ++ |
+ }+ |
+
| 1250 | +! | +
+ counts <- as.vector(unname(base::table(cut(arr_num, breaks = bins))))+ |
+
| 1251 | +! | +
+ max_value <- max(counts)+ |
+
| 1252 | ++ | + + | +
| 1253 | +! | +
+ start_bins <- as.integer(seq(1, length(arr_num), length.out = bins))+ |
+
| 1254 | +! | +
+ labels_start <- as.character(format(as.POSIXct(arr_num[start_bins], origin = as.Date("1970-01-01")), "%Y-%m-%d"))
+ |
+
| 1255 | +! | +
+ labels <- paste("Start:", labels_start)
+ |
+
| 1256 | ++ | + + | +
| 1257 | +! | +
+ sparkline::spk_chr(+ |
+
| 1258 | +! | +
+ unname(counts),+ |
+
| 1259 | +! | +
+ type = "bar",+ |
+
| 1260 | +! | +
+ chartRangeMin = 0,+ |
+
| 1261 | +! | +
+ chartRangeMax = max_value,+ |
+
| 1262 | +! | +
+ width = width,+ |
+
| 1263 | +! | +
+ barWidth = bar_width,+ |
+
| 1264 | +! | +
+ barSpacing = bar_spacing,+ |
+
| 1265 | +! | +
+ tooltipFormatter = custom_sparkline_formatter(labels, counts)+ |
+
| 1266 | ++ |
+ )+ |
+
| 1267 | ++ |
+ }+ |
+
| 1268 | ++ | + + | +
| 1269 | ++ |
+ #' @rdname create_sparklines+ |
+
| 1270 | ++ |
+ #' @keywords internal+ |
+
| 1271 | ++ |
+ #' @export+ |
+
| 1272 | ++ |
+ create_sparklines.default <- function(arr, width = 150, ...) {
+ |
+
| 1273 | +! | +
+ as.character(tags$code("unsupported variable type", class = "text-blue"))
+ |
+
| 1274 | ++ |
+ }+ |
+
| 1275 | ++ | + + | +
| 1276 | ++ | + + | +
| 1277 | ++ |
+ custom_sparkline_formatter <- function(labels, counts) {
+ |
+
| 1278 | +! | +
+ htmlwidgets::JS(+ |
+
| 1279 | +! | +
+ sprintf(+ |
+
| 1280 | +! | +
+ "function(sparkline, options, field) {
+ |
+
| 1281 | +! | +
+ return 'ID: ' + %s[field[0].offset] + '<br>' + 'Count: ' + %s[field[0].offset];+ |
+
| 1282 | ++ |
+ }",+ |
+
| 1283 | +! | +
+ jsonlite::toJSON(labels),+ |
+
| 1284 | +! | +
+ jsonlite::toJSON(counts)+ |
+
| 1285 | ++ |
+ )+ |
+
| 1286 | ++ |
+ )+ |
+
| 1287 | ++ |
+ }+ |
+
| 1 | ++ |
+ #' `teal` module: Missing data analysis+ |
+
| 2 | ++ |
+ #'+ |
+
| 3 | ++ |
+ #' This module analyzes missing data in `data.frame`s to help users explore missing observations and+ |
+
| 4 | ++ |
+ #' gain insights into the completeness of their data.+ |
+
| 5 | ++ |
+ #' It is useful for clinical data analysis within the context of `CDISC` standards and+ |
+
| 6 | ++ |
+ #' adaptable for general data analysis purposes.+ |
+
| 7 | ++ |
+ #'+ |
+
| 8 | ++ |
+ #' @inheritParams teal::module+ |
+
| 9 | ++ |
+ #' @inheritParams shared_params+ |
+
| 10 | ++ |
+ #' @param parent_dataname (`character(1)`) Specifies the parent dataset name. Default is `ADSL` for `CDISC` data.+ |
+
| 11 | ++ |
+ #' If provided and exists, enables additional analysis "by subject". For non-`CDISC` data, this parameter can be+ |
+
| 12 | ++ |
+ #' ignored.+ |
+
| 13 | ++ |
+ #' @param ggtheme (`character`) optional, specifies the default `ggplot2` theme for plots. Defaults to `classic`.+ |
+
| 14 | ++ |
+ #'+ |
+
| 15 | ++ |
+ #' @templateVar ggnames "Summary Obs", "Summary Patients", "Combinations Main", "Combinations Hist", "By Subject"+ |
+
| 16 | ++ |
+ #' @template ggplot2_args_multi+ |
+
| 17 | ++ |
+ #'+ |
+
| 18 | ++ |
+ #' @inherit shared_params return+ |
+
| 19 | ++ |
+ #'+ |
+
| 20 | ++ |
+ #' @examples+ |
+
| 21 | ++ |
+ #' library(teal.widgets)+ |
+
| 22 | ++ |
+ #'+ |
+
| 23 | ++ |
+ #' # module specification used in apps below+ |
+
| 24 | ++ |
+ #' tm_missing_data_module <- tm_missing_data(+ |
+
| 25 | ++ |
+ #' ggplot2_args = list(+ |
+
| 26 | ++ |
+ #' "Combinations Hist" = ggplot2_args(+ |
+
| 27 | ++ |
+ #' labs = list(subtitle = "Plot produced by Missing Data Module", caption = NULL)+ |
+
| 28 | ++ |
+ #' ),+ |
+
| 29 | ++ |
+ #' "Combinations Main" = ggplot2_args(labs = list(title = NULL))+ |
+
| 30 | ++ |
+ #' )+ |
+
| 31 | ++ |
+ #' )+ |
+
| 32 | ++ |
+ #'+ |
+
| 33 | ++ |
+ #' # general example data+ |
+
| 34 | ++ |
+ #' data <- teal_data()+ |
+
| 35 | ++ |
+ #' data <- within(data, {
+ |
+
| 36 | ++ |
+ #' require(nestcolor)+ |
+
| 37 | ++ |
+ #'+ |
+
| 38 | ++ |
+ #' add_nas <- function(x) {
+ |
+
| 39 | ++ |
+ #' x[sample(seq_along(x), floor(length(x) * runif(1, .05, .17)))] <- NA+ |
+
| 40 | ++ |
+ #' x+ |
+
| 41 | ++ |
+ #' }+ |
+
| 42 | ++ |
+ #'+ |
+
| 43 | ++ |
+ #' iris <- iris+ |
+
| 44 | ++ |
+ #' mtcars <- mtcars+ |
+
| 45 | ++ |
+ #'+ |
+
| 46 | ++ |
+ #' iris[] <- lapply(iris, add_nas)+ |
+
| 47 | ++ |
+ #' mtcars[] <- lapply(mtcars, add_nas)+ |
+
| 48 | ++ |
+ #' mtcars[["cyl"]] <- as.factor(mtcars[["cyl"]])+ |
+
| 49 | ++ |
+ #' mtcars[["gear"]] <- as.factor(mtcars[["gear"]])+ |
+
| 50 | ++ |
+ #' })+ |
+
| 51 | ++ |
+ #' datanames(data) <- c("iris", "mtcars")
+ |
+
| 52 | ++ |
+ #'+ |
+
| 53 | ++ |
+ #' app <- init(+ |
+
| 54 | ++ |
+ #' data = data,+ |
+
| 55 | ++ |
+ #' modules = modules(tm_missing_data_module)+ |
+
| 56 | ++ |
+ #' )+ |
+
| 57 | ++ |
+ #' if (interactive()) {
+ |
+
| 58 | ++ |
+ #' shinyApp(app$ui, app$server)+ |
+
| 59 | ++ |
+ #' }+ |
+
| 60 | ++ |
+ #'+ |
+
| 61 | ++ |
+ #' # CDISC example data+ |
+
| 62 | ++ |
+ #' data <- teal_data()+ |
+
| 63 | ++ |
+ #' data <- within(data, {
+ |
+
| 64 | ++ |
+ #' require(nestcolor)+ |
+
| 65 | ++ |
+ #' ADSL <- rADSL+ |
+
| 66 | ++ |
+ #' ADRS <- rADRS+ |
+
| 67 | ++ |
+ #' })+ |
+
| 68 | ++ |
+ #' datanames(data) <- c("ADSL", "ADRS")
+ |
+
| 69 | ++ |
+ #' join_keys(data) <- default_cdisc_join_keys[datanames(data)]+ |
+
| 70 | ++ |
+ #'+ |
+
| 71 | ++ |
+ #' app <- init(+ |
+
| 72 | ++ |
+ #' data = data,+ |
+
| 73 | ++ |
+ #' modules = modules(tm_missing_data_module)+ |
+
| 74 | ++ |
+ #' )+ |
+
| 75 | ++ |
+ #' if (interactive()) {
+ |
+
| 76 | ++ |
+ #' shinyApp(app$ui, app$server)+ |
+
| 77 | ++ |
+ #' }+ |
+
| 78 | ++ |
+ #'+ |
+
| 79 | ++ |
+ #' @export+ |
+
| 80 | ++ |
+ #'+ |
+
| 81 | ++ |
+ tm_missing_data <- function(label = "Missing data",+ |
+
| 82 | ++ |
+ plot_height = c(600, 400, 5000),+ |
+
| 83 | ++ |
+ plot_width = NULL,+ |
+
| 84 | ++ |
+ parent_dataname = "ADSL",+ |
+
| 85 | ++ |
+ ggtheme = c("classic", "gray", "bw", "linedraw", "light", "dark", "minimal", "void"),
+ |
+
| 86 | ++ |
+ ggplot2_args = list(+ |
+
| 87 | ++ |
+ "Combinations Hist" = teal.widgets::ggplot2_args(labs = list(caption = NULL)),+ |
+
| 88 | ++ |
+ "Combinations Main" = teal.widgets::ggplot2_args(labs = list(title = NULL))+ |
+
| 89 | ++ |
+ ),+ |
+
| 90 | ++ |
+ pre_output = NULL,+ |
+
| 91 | ++ |
+ post_output = NULL) {
+ |
+
| 92 | +! | +
+ logger::log_info("Initializing tm_missing_data")
+ |
+
| 93 | ++ | + + | +
| 94 | ++ |
+ # Requires Suggested packages+ |
+
| 95 | +! | +
+ if (!requireNamespace("gridExtra", quietly = TRUE)) {
+ |
+
| 96 | +! | +
+ stop("Cannot load gridExtra - please install the package or restart your session.")
+ |
+
| 97 | ++ |
+ }+ |
+
| 98 | +! | +
+ if (!requireNamespace("rlang", quietly = TRUE)) {
+ |
+
| 99 | +! | +
+ stop("Cannot load rlang - please install the package or restart your session.")
+ |
+
| 100 | ++ |
+ }+ |
+
| 101 | ++ | + + | +
| 102 | ++ |
+ # Normalize the parameters+ |
+
| 103 | +! | +
+ if (inherits(ggplot2_args, "ggplot2_args")) ggplot2_args <- list(default = ggplot2_args)+ |
+
| 104 | ++ | + + | +
| 105 | ++ |
+ # Start of assertions+ |
+
| 106 | +! | +
+ checkmate::assert_string(label)+ |
+
| 107 | ++ | + + | +
| 108 | +! | +
+ checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE)+ |
+
| 109 | +! | +
+ checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height")+ |
+
| 110 | +! | +
+ checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE)+ |
+
| 111 | +! | +
+ checkmate::assert_numeric(+ |
+
| 112 | +! | +
+ plot_width[1],+ |
+
| 113 | +! | +
+ lower = plot_width[2], upper = plot_width[3], null.ok = TRUE, .var.name = "plot_width"+ |
+
| 114 | ++ |
+ )+ |
+
| 115 | ++ | + + | +
| 116 | +! | +
+ checkmate::assert_character(parent_dataname, min.len = 0, max.len = 1)+ |
+
| 117 | +! | +
+ ggtheme <- match.arg(ggtheme)+ |
+
| 118 | ++ | + + | +
| 119 | +! | +
+ plot_choices <- c("Summary Obs", "Summary Patients", "Combinations Main", "Combinations Hist", "By Subject")
+ |
+
| 120 | +! | +
+ checkmate::assert_list(ggplot2_args, types = "ggplot2_args")+ |
+
| 121 | +! | +
+ checkmate::assert_subset(names(ggplot2_args), c("default", plot_choices))
+ |
+
| 122 | ++ | + + | +
| 123 | +! | +
+ checkmate::assert_multi_class(pre_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
+ |
+
| 124 | +! | +
+ checkmate::assert_multi_class(post_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
+ |
+
| 125 | ++ |
+ # End of assertions+ |
+
| 126 | ++ | + + | +
| 127 | +! | +
+ module(+ |
+
| 128 | +! | +
+ label,+ |
+
| 129 | +! | +
+ server = srv_page_missing_data,+ |
+
| 130 | +! | +
+ server_args = list(+ |
+
| 131 | +! | +
+ parent_dataname = parent_dataname, plot_height = plot_height,+ |
+
| 132 | +! | +
+ plot_width = plot_width, ggplot2_args = ggplot2_args, ggtheme = ggtheme+ |
+
| 133 | ++ |
+ ),+ |
+
| 134 | +! | +
+ ui = ui_page_missing_data,+ |
+
| 135 | +! | +
+ datanames = "all",+ |
+
| 136 | +! | +
+ ui_args = list(pre_output = pre_output, post_output = post_output)+ |
+
| 137 | ++ |
+ )+ |
+
| 138 | ++ |
+ }+ |
+
| 139 | ++ | + + | +
| 140 | ++ |
+ # UI function for the missing data module (all datasets)+ |
+
| 141 | ++ |
+ ui_page_missing_data <- function(id, pre_output = NULL, post_output = NULL) {
+ |
+
| 142 | +! | +
+ ns <- NS(id)+ |
+
| 143 | +! | +
+ shiny::tagList(+ |
+
| 144 | +! | +
+ include_css_files("custom"),
+ |
+
| 145 | +! | +
+ teal.widgets::standard_layout(+ |
+
| 146 | +! | +
+ output = teal.widgets::white_small_well(+ |
+
| 147 | +! | +
+ div(+ |
+
| 148 | +! | +
+ class = "flex",+ |
+
| 149 | +! | +
+ column(+ |
+
| 150 | +! | +
+ width = 12,+ |
+
| 151 | +! | +
+ uiOutput(ns("dataset_tabs"))
+ |
+
| 152 | ++ |
+ )+ |
+
| 153 | ++ |
+ )+ |
+
| 154 | ++ |
+ ),+ |
+
| 155 | +! | +
+ encoding = div(+ |
+
| 156 | +! | +
+ uiOutput(ns("dataset_encodings"))
+ |
+
| 157 | ++ |
+ ),+ |
+
| 158 | +! | +
+ uiOutput(ns("dataset_reporter")),
+ |
+
| 159 | +! | +
+ pre_output = pre_output,+ |
+
| 160 | +! | +
+ post_output = post_output+ |
+
| 161 | ++ |
+ )+ |
+
| 162 | ++ |
+ )+ |
+
| 163 | ++ |
+ }+ |
+
| 164 | ++ | + + | +
| 165 | ++ |
+ # Server function for the missing data module (all datasets)+ |
+
| 166 | ++ |
+ srv_page_missing_data <- function(id, data, reporter, filter_panel_api, parent_dataname,+ |
+
| 167 | ++ |
+ plot_height, plot_width, ggplot2_args, ggtheme) {
+ |
+
| 168 | +! | +
+ moduleServer(id, function(input, output, session) {
+ |
+
| 169 | +! | +
+ datanames <- isolate(teal.data::datanames(data()))+ |
+
| 170 | +! | +
+ datanames <- Filter(function(name) {
+ |
+
| 171 | +! | +
+ is.data.frame(isolate(data())[[name]])+ |
+
| 172 | +! | +
+ }, datanames)+ |
+
| 173 | +! | +
+ if_subject_plot <- length(parent_dataname) > 0 && parent_dataname %in% datanames+ |
+
| 174 | +! | +
+ ns <- session$ns+ |
+
| 175 | ++ | + + | +
| 176 | +! | +
+ output$dataset_tabs <- renderUI({
+ |
+
| 177 | +! | +
+ do.call(+ |
+
| 178 | +! | +
+ tabsetPanel,+ |
+
| 179 | +! | +
+ c(+ |
+
| 180 | +! | +
+ id = ns("dataname_tab"),
+ |
+
| 181 | +! | +
+ lapply(+ |
+
| 182 | +! | +
+ datanames,+ |
+
| 183 | +! | +
+ function(x) {
+ |
+
| 184 | +! | +
+ tabPanel(+ |
+
| 185 | +! | +
+ title = x,+ |
+
| 186 | +! | +
+ column(+ |
+
| 187 | +! | +
+ width = 12,+ |
+
| 188 | +! | +
+ div(+ |
+
| 189 | +! | +
+ class = "mt-4",+ |
+
| 190 | +! | +
+ ui_missing_data(id = ns(x), by_subject_plot = if_subject_plot)+ |
+
| 191 | ++ |
+ )+ |
+
| 192 | ++ |
+ )+ |
+
| 193 | ++ |
+ )+ |
+
| 194 | ++ |
+ }+ |
+
| 195 | ++ |
+ )+ |
+
| 196 | ++ |
+ )+ |
+
| 197 | ++ |
+ )+ |
+
| 198 | ++ |
+ })+ |
+
| 199 | ++ | + + | +
| 200 | +! | +
+ output$dataset_encodings <- renderUI({
+ |
+
| 201 | +! | +
+ tagList(+ |
+
| 202 | +! | +
+ lapply(+ |
+
| 203 | +! | +
+ datanames,+ |
+
| 204 | +! | +
+ function(x) {
+ |
+
| 205 | +! | +
+ conditionalPanel(+ |
+
| 206 | +! | +
+ is_tab_active_js(ns("dataname_tab"), x),
+ |
+
| 207 | +! | +
+ encoding_missing_data(+ |
+
| 208 | +! | +
+ id = ns(x),+ |
+
| 209 | +! | +
+ summary_per_patient = if_subject_plot,+ |
+
| 210 | +! | +
+ ggtheme = ggtheme,+ |
+
| 211 | +! | +
+ datanames = datanames+ |
+
| 212 | ++ |
+ )+ |
+
| 213 | ++ |
+ )+ |
+
| 214 | ++ |
+ }+ |
+
| 215 | ++ |
+ )+ |
+
| 216 | ++ |
+ )+ |
+
| 217 | ++ |
+ })+ |
+
| 218 | ++ | + + | +
| 219 | +! | +
+ output$dataset_reporter <- renderUI({
+ |
+
| 220 | +! | +
+ lapply(datanames, function(x) {
+ |
+
| 221 | +! | +
+ dataname_ns <- NS(ns(x))+ |
+
| 222 | ++ | + + | +
| 223 | +! | +
+ conditionalPanel(+ |
+
| 224 | +! | +
+ is_tab_active_js(ns("dataname_tab"), x),
+ |
+
| 225 | +! | +
+ tagList(+ |
+
| 226 | +! | +
+ teal.widgets::verbatim_popup_ui(dataname_ns("warning"), "Show Warnings"),
+ |
+
| 227 | +! | +
+ teal.widgets::verbatim_popup_ui(dataname_ns("rcode"), "Show R code")
+ |
+
| 228 | ++ |
+ )+ |
+
| 229 | ++ |
+ )+ |
+
| 230 | ++ |
+ })+ |
+
| 231 | ++ |
+ })+ |
+
| 232 | ++ | + + | +
| 233 | +! | +
+ lapply(+ |
+
| 234 | +! | +
+ datanames,+ |
+
| 235 | +! | +
+ function(x) {
+ |
+
| 236 | +! | +
+ srv_missing_data(+ |
+
| 237 | +! | +
+ id = x,+ |
+
| 238 | +! | +
+ data = data,+ |
+
| 239 | +! | +
+ reporter = reporter,+ |
+
| 240 | +! | +
+ filter_panel_api = filter_panel_api,+ |
+
| 241 | +! | +
+ dataname = x,+ |
+
| 242 | +! | +
+ parent_dataname = parent_dataname,+ |
+
| 243 | +! | +
+ plot_height = plot_height,+ |
+
| 244 | +! | +
+ plot_width = plot_width,+ |
+
| 245 | +! | +
+ ggplot2_args = ggplot2_args+ |
+
| 246 | ++ |
+ )+ |
+
| 247 | ++ |
+ }+ |
+
| 248 | ++ |
+ )+ |
+
| 249 | ++ |
+ })+ |
+
| 250 | ++ |
+ }+ |
+
| 251 | ++ | + + | +
| 252 | ++ |
+ # UI function for the missing data module (single dataset)+ |
+
| 253 | ++ |
+ ui_missing_data <- function(id, by_subject_plot = FALSE) {
+ |
+
| 254 | +! | +
+ ns <- NS(id)+ |
+
| 255 | ++ | + + | +
| 256 | +! | +
+ tab_list <- list(+ |
+
| 257 | +! | +
+ tabPanel(+ |
+
| 258 | +! | +
+ "Summary",+ |
+
| 259 | +! | +
+ teal.widgets::plot_with_settings_ui(id = ns("summary_plot")),
+ |
+
| 260 | +! | +
+ helpText(+ |
+
| 261 | +! | +
+ p(paste(+ |
+
| 262 | +! | +
+ 'The "Summary" graph shows the number of missing values per variable (both absolute and percentage),',+ |
+
| 263 | +! | +
+ "sorted by magnitude."+ |
+
| 264 | ++ |
+ )),+ |
+
| 265 | +! | +
+ p(+ |
+
| 266 | +! | +
+ 'The "summary per patients" graph is showing how many subjects have at least one missing observation',+ |
+
| 267 | +! | +
+ "for each variable. It will be most useful for panel datasets."+ |
+
| 268 | ++ |
+ )+ |
+
| 269 | ++ |
+ )+ |
+
| 270 | ++ |
+ ),+ |
+
| 271 | +! | +
+ tabPanel(+ |
+
| 272 | +! | +
+ "Combinations",+ |
+
| 273 | +! | +
+ teal.widgets::plot_with_settings_ui(id = ns("combination_plot")),
+ |
+
| 274 | +! | +
+ helpText(+ |
+
| 275 | +! | +
+ p(paste(+ |
+
| 276 | +! | +
+ 'The "Combinations" graph is used to explore the relationship between the missing data within',+ |
+
| 277 | +! | +
+ "different columns of the dataset.",+ |
+
| 278 | +! | +
+ "It shows the different patterns of missingness in the rows of the data.",+ |
+
| 279 | +! | +
+ 'For example, suppose that 70 rows of the data have exactly columns "A" and "B" missing.',+ |
+
| 280 | +! | +
+ "In this case there would be a bar of height 70 in the top graph and",+ |
+
| 281 | +! | +
+ 'the column below this in the second graph would have rows "A" and "B" cells shaded red.'+ |
+
| 282 | ++ |
+ )),+ |
+
| 283 | +! | +
+ p(paste(+ |
+
| 284 | +! | +
+ "Due to the large number of missing data patterns possible, only those with a large set of observations",+ |
+
| 285 | +! | +
+ 'are shown in the graph and the "Combination cut-off" slider can be used to adjust the number shown.'+ |
+
| 286 | ++ |
+ ))+ |
+
| 287 | ++ |
+ )+ |
+
| 288 | ++ |
+ ),+ |
+
| 289 | +! | +
+ tabPanel(+ |
+
| 290 | +! | +
+ "By Variable Levels",+ |
+
| 291 | +! | +
+ teal.widgets::get_dt_rows(ns("levels_table"), ns("levels_table_rows")),
+ |
+
| 292 | +! | +
+ DT::dataTableOutput(ns("levels_table"))
+ |
+
| 293 | ++ |
+ )+ |
+
| 294 | ++ |
+ )+ |
+
| 295 | +! | +
+ if (isTRUE(by_subject_plot)) {
+ |
+
| 296 | +! | +
+ tab_list <- append(+ |
+
| 297 | +! | +
+ tab_list,+ |
+
| 298 | +! | +
+ list(tabPanel(+ |
+
| 299 | +! | +
+ "Grouped by Subject",+ |
+
| 300 | +! | +
+ teal.widgets::plot_with_settings_ui(id = ns("by_subject_plot")),
+ |
+
| 301 | +! | +
+ helpText(+ |
+
| 302 | +! | +
+ p(paste(+ |
+
| 303 | +! | +
+ "This graph shows the missingness with respect to subjects rather than individual rows of the",+ |
+
| 304 | +! | +
+ "dataset. Each row represents one dataset variable and each column a single subject. Only subjects",+ |
+
| 305 | +! | +
+ "with at least one record in this dataset are shown. For a given subject, if they have any missing",+ |
+
| 306 | +! | +
+ "values of a specific variable then the appropriate cell in the graph is marked as missing."+ |
+
| 307 | ++ |
+ ))+ |
+
| 308 | ++ |
+ )+ |
+
| 309 | ++ |
+ ))+ |
+
| 310 | ++ |
+ )+ |
+
| 311 | ++ |
+ }+ |
+
| 312 | ++ | + + | +
| 313 | +! | +
+ do.call(+ |
+
| 314 | +! | +
+ tabsetPanel,+ |
+
| 315 | +! | +
+ c(+ |
+
| 316 | +! | +
+ id = ns("summary_type"),
+ |
+
| 317 | +! | +
+ tab_list+ |
+
| 318 | ++ |
+ )+ |
+
| 319 | ++ |
+ )+ |
+
| 320 | ++ |
+ }+ |
+
| 321 | ++ | + + | +
| 322 | ++ |
+ # UI encoding for the missing data module (all datasets)+ |
+
| 323 | ++ |
+ encoding_missing_data <- function(id, summary_per_patient = FALSE, ggtheme, datanames) {
+ |
+
| 324 | +! | +
+ ns <- NS(id)+ |
+
| 325 | ++ | + + | +
| 326 | +! | +
+ tagList(+ |
+
| 327 | ++ |
+ ### Reporter+ |
+
| 328 | +! | +
+ teal.reporter::simple_reporter_ui(ns("simple_reporter")),
+ |
+
| 329 | ++ |
+ ###+ |
+
| 330 | +! | +
+ tags$label("Encodings", class = "text-primary"),
+ |
+
| 331 | +! | +
+ helpText(+ |
+
| 332 | +! | +
+ paste0("Dataset", `if`(length(datanames) > 1, "s", ""), ":"),
+ |
+
| 333 | +! | +
+ tags$code(paste(datanames, collapse = ", "))+ |
+
| 334 | ++ |
+ ),+ |
+
| 335 | +! | +
+ uiOutput(ns("variables")),
+ |
+
| 336 | +! | +
+ actionButton(+ |
+
| 337 | +! | +
+ ns("filter_na"),
+ |
+
| 338 | +! | +
+ span("Select only vars with missings", class = "whitespace-normal"),
+ |
+
| 339 | +! | +
+ width = "100%",+ |
+
| 340 | +! | +
+ class = "mb-4"+ |
+
| 341 | ++ |
+ ),+ |
+
| 342 | +! | +
+ conditionalPanel(+ |
+
| 343 | +! | +
+ is_tab_active_js(ns("summary_type"), "Summary"),
+ |
+
| 344 | +! | +
+ checkboxInput(+ |
+
| 345 | +! | +
+ ns("any_na"),
+ |
+
| 346 | +! | +
+ div(+ |
+
| 347 | +! | +
+ class = "teal-tooltip",+ |
+
| 348 | +! | +
+ tagList(+ |
+
| 349 | +! | +
+ "Add **anyna** variable",+ |
+
| 350 | +! | +
+ icon("circle-info"),
+ |
+
| 351 | +! | +
+ span(+ |
+
| 352 | +! | +
+ class = "tooltiptext",+ |
+
| 353 | +! | +
+ "Describes the number of observations with at least one missing value in any variable."+ |
+
| 354 | ++ |
+ )+ |
+
| 355 | ++ |
+ )+ |
+
| 356 | ++ |
+ ),+ |
+
| 357 | +! | +
+ value = FALSE+ |
+
| 358 | ++ |
+ ),+ |
+
| 359 | +! | +
+ if (summary_per_patient) {
+ |
+
| 360 | +! | +
+ checkboxInput(+ |
+
| 361 | +! | +
+ ns("if_patients_plot"),
+ |
+
| 362 | +! | +
+ div(+ |
+
| 363 | +! | +
+ class = "teal-tooltip",+ |
+
| 364 | +! | +
+ tagList(+ |
+
| 365 | +! | +
+ "Add summary per patients",+ |
+
| 366 | +! | +
+ icon("circle-info"),
+ |
+
| 367 | +! | +
+ span(+ |
+
| 368 | +! | +
+ class = "tooltiptext",+ |
+
| 369 | +! | +
+ paste(+ |
+
| 370 | +! | +
+ "Displays the number of missing values per observation,",+ |
+
| 371 | +! | +
+ "where the x-axis is sorted by observation appearance in the table."+ |
+
| 372 | ++ |
+ )+ |
+
| 373 | ++ |
+ )+ |
+
| 374 | ++ |
+ )+ |
+
| 375 | ++ |
+ ),+ |
+
| 376 | +! | +
+ value = FALSE+ |
+
| 377 | ++ |
+ )+ |
+
| 378 | ++ |
+ }+ |
+
| 379 | ++ |
+ ),+ |
+
| 380 | +! | +
+ conditionalPanel(+ |
+
| 381 | +! | +
+ is_tab_active_js(ns("summary_type"), "Combinations"),
+ |
+
| 382 | +! | +
+ uiOutput(ns("cutoff"))
+ |
+
| 383 | ++ |
+ ),+ |
+
| 384 | +! | +
+ conditionalPanel(+ |
+
| 385 | +! | +
+ is_tab_active_js(ns("summary_type"), "By Variable Levels"),
+ |
+
| 386 | +! | +
+ tagList(+ |
+
| 387 | +! | +
+ uiOutput(ns("group_by_var_ui")),
+ |
+
| 388 | +! | +
+ uiOutput(ns("group_by_vals_ui")),
+ |
+
| 389 | +! | +
+ radioButtons(+ |
+
| 390 | +! | +
+ ns("count_type"),
+ |
+
| 391 | +! | +
+ label = "Display missing as",+ |
+
| 392 | +! | +
+ choices = c("counts", "proportions"),
+ |
+
| 393 | +! | +
+ selected = "counts",+ |
+
| 394 | +! | +
+ inline = TRUE+ |
+
| 395 | ++ |
+ )+ |
+
| 396 | ++ |
+ )+ |
+
| 397 | ++ |
+ ),+ |
+
| 398 | +! | +
+ teal.widgets::panel_item(+ |
+
| 399 | +! | +
+ title = "Plot settings",+ |
+
| 400 | +! | +
+ selectInput(+ |
+
| 401 | +! | +
+ inputId = ns("ggtheme"),
+ |
+
| 402 | +! | +
+ label = "Theme (by ggplot):",+ |
+
| 403 | +! | +
+ choices = ggplot_themes,+ |
+
| 404 | +! | +
+ selected = ggtheme,+ |
+
| 405 | +! | +
+ multiple = FALSE+ |
+
| 406 | ++ |
+ )+ |
+
| 407 | ++ |
+ )+ |
+
| 408 | ++ |
+ )+ |
+
| 409 | ++ |
+ }+ |
+
| 410 | ++ | + + | +
| 411 | ++ |
+ # Server function for the missing data (single dataset)+ |
+
| 412 | ++ |
+ srv_missing_data <- function(id, data, reporter, filter_panel_api, dataname, parent_dataname,+ |
+
| 413 | ++ |
+ plot_height, plot_width, ggplot2_args) {
+ |
+
| 414 | +! | +
+ with_reporter <- !missing(reporter) && inherits(reporter, "Reporter")+ |
+
| 415 | +! | +
+ 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 | +! | +
+ moduleServer(id, function(input, output, session) {
+ |
+
| 419 | +! | +
+ prev_group_by_var <- reactiveVal("")
+ |
+
| 420 | +! | +
+ data_r <- reactive(data()[[dataname]])+ |
+
| 421 | +! | +
+ data_keys <- reactive(unlist(teal.data::join_keys(data())[[dataname]]))+ |
+
| 422 | ++ | + + | +
| 423 | +! | +
+ iv_r <- reactive({
+ |
+
| 424 | +! | +
+ iv <- shinyvalidate::InputValidator$new()+ |
+
| 425 | +! | +
+ iv$add_rule(+ |
+
| 426 | +! | +
+ "variables_select",+ |
+
| 427 | +! | +
+ shinyvalidate::sv_required("At least one reference variable needs to be selected.")
+ |
+
| 428 | ++ |
+ )+ |
+
| 429 | +! | +
+ iv$add_rule(+ |
+
| 430 | +! | +
+ "variables_select",+ |
+
| 431 | +! | +
+ ~ if (length(setdiff((.), data_keys())) < 1) "Please also select non-key columns."+ |
+
| 432 | ++ |
+ )+ |
+
| 433 | +! | +
+ iv_summary_table <- shinyvalidate::InputValidator$new()+ |
+
| 434 | +! | +
+ iv_summary_table$condition(~ isTRUE(input$summary_type == "By Variable Levels"))+ |
+
| 435 | +! | +
+ iv_summary_table$add_rule("count_type", shinyvalidate::sv_required("Please select type of counts"))
+ |
+
| 436 | +! | +
+ iv_summary_table$add_rule(+ |
+
| 437 | +! | +
+ "group_by_vals",+ |
+
| 438 | +! | +
+ shinyvalidate::sv_required("Please select both group-by variable and values")
+ |
+
| 439 | ++ |
+ )+ |
+
| 440 | +! | +
+ iv_summary_table$add_rule(+ |
+
| 441 | +! | +
+ "group_by_var",+ |
+
| 442 | +! | +
+ ~ if (length(.) > 0 && length(input$variables_select) == 1 && (.) == input$variables_select) {
+ |
+
| 443 | +! | +
+ "If only one reference variable is selected it must not be the grouping variable."+ |
+
| 444 | ++ |
+ }+ |
+
| 445 | ++ |
+ )+ |
+
| 446 | +! | +
+ iv_summary_table$add_rule(+ |
+
| 447 | +! | +
+ "variables_select",+ |
+
| 448 | +! | +
+ ~ if (length(input$group_by_var) > 0 && length(.) == 1 && (.) == input$group_by_var) {
+ |
+
| 449 | +! | +
+ "If only one reference variable is selected it must not be the grouping variable."+ |
+
| 450 | ++ |
+ }+ |
+
| 451 | ++ |
+ )+ |
+
| 452 | +! | +
+ iv$add_validator(iv_summary_table)+ |
+
| 453 | +! | +
+ iv$enable()+ |
+
| 454 | +! | +
+ iv+ |
+
| 455 | ++ |
+ })+ |
+
| 456 | ++ | + + | +
| 457 | ++ | + + | +
| 458 | +! | +
+ data_parent_keys <- reactive({
+ |
+
| 459 | +! | +
+ if (length(parent_dataname) > 0 && parent_dataname %in% names(data)) {
+ |
+
| 460 | +! | +
+ keys <- teal.data::join_keys(data)[[dataname]]+ |
+
| 461 | +! | +
+ if (parent_dataname %in% names(keys)) {
+ |
+
| 462 | +! | +
+ keys[[parent_dataname]]+ |
+
| 463 | ++ |
+ } else {
+ |
+
| 464 | +! | +
+ keys[[dataname]]+ |
+
| 465 | ++ |
+ }+ |
+
| 466 | ++ |
+ } else {
+ |
+
| 467 | +! | +
+ NULL+ |
+
| 468 | ++ |
+ }+ |
+
| 469 | ++ |
+ })+ |
+
| 470 | ++ | + + | +
| 471 | +! | +
+ common_code_q <- reactive({
+ |
+
| 472 | +! | +
+ teal::validate_inputs(iv_r())+ |
+
| 473 | ++ | + + | +
| 474 | +! | +
+ group_var <- input$group_by_var+ |
+
| 475 | +! | +
+ anl <- data_r()+ |
+
| 476 | ++ | + + | +
| 477 | +! | +
+ qenv <- if (!is.null(selected_vars()) && length(selected_vars()) != ncol(anl)) {
+ |
+
| 478 | +! | +
+ teal.code::eval_code(+ |
+
| 479 | +! | +
+ data(),+ |
+
| 480 | +! | +
+ substitute(+ |
+
| 481 | +! | +
+ expr = ANL <- anl_name[, selected_vars, drop = FALSE],+ |
+
| 482 | +! | +
+ env = list(anl_name = as.name(dataname), selected_vars = selected_vars())+ |
+
| 483 | ++ |
+ )+ |
+
| 484 | ++ |
+ )+ |
+
| 485 | ++ |
+ } else {
+ |
+
| 486 | +! | +
+ teal.code::eval_code(+ |
+
| 487 | +! | +
+ data(),+ |
+
| 488 | +! | +
+ substitute(expr = ANL <- anl_name, env = list(anl_name = as.name(dataname)))+ |
+
| 489 | ++ |
+ )+ |
+
| 490 | ++ |
+ }+ |
+
| 491 | ++ | + + | +
| 492 | +! | +
+ if (input$summary_type == "By Variable Levels" && !is.null(group_var) && !(group_var %in% selected_vars())) {
+ |
+
| 493 | +! | +
+ qenv <- teal.code::eval_code(+ |
+
| 494 | +! | +
+ qenv,+ |
+
| 495 | +! | +
+ substitute(+ |
+
| 496 | +! | +
+ expr = ANL[[group_var]] <- anl_name[[group_var]],+ |
+
| 497 | +! | +
+ env = list(group_var = group_var, anl_name = as.name(dataname))+ |
+
| 498 | ++ |
+ )+ |
+
| 499 | ++ |
+ )+ |
+
| 500 | ++ |
+ }+ |
+
| 501 | ++ | + + | +
| 502 | +! | +
+ new_col_name <- "**anyna**"+ |
+
| 503 | ++ | + + | +
| 504 | +! | +
+ qenv <- teal.code::eval_code(+ |
+
| 505 | +! | +
+ qenv,+ |
+
| 506 | +! | +
+ substitute(+ |
+
| 507 | +! | +
+ expr =+ |
+
| 508 | +! | +
+ create_cols_labels <- function(cols, just_label = FALSE) {
+ |
+
| 509 | +! | +
+ column_labels <- column_labels_value+ |
+
| 510 | +! | +
+ column_labels[is.na(column_labels) | length(column_labels) == 0] <- ""+ |
+
| 511 | +! | +
+ if (just_label) {
+ |
+
| 512 | +! | +
+ labels <- column_labels[cols]+ |
+
| 513 | ++ |
+ } else {
+ |
+
| 514 | +! | +
+ labels <- ifelse(cols == new_col_name | cols == "", cols, paste0(column_labels[cols], " [", cols, "]"))+ |
+
| 515 | ++ |
+ }+ |
+
| 516 | +! | +
+ labels+ |
+
| 517 | ++ |
+ },+ |
+
| 518 | +! | +
+ env = list(+ |
+
| 519 | +! | +
+ new_col_name = new_col_name,+ |
+
| 520 | +! | +
+ column_labels_value = c(teal.data::col_labels(data_r())[selected_vars()],+ |
+
| 521 | +! | +
+ new_col_name = new_col_name+ |
+
| 522 | ++ |
+ )+ |
+
| 523 | ++ |
+ )+ |
+
| 524 | ++ |
+ )+ |
+
| 525 | ++ |
+ )+ |
+
| 526 | +! | +
+ qenv+ |
+
| 527 | ++ |
+ })+ |
+
| 528 | ++ | + + | +
| 529 | +! | +
+ selected_vars <- reactive({
+ |
+
| 530 | +! | +
+ req(input$variables_select)+ |
+
| 531 | +! | +
+ keys <- data_keys()+ |
+
| 532 | +! | +
+ vars <- unique(c(keys, input$variables_select))+ |
+
| 533 | +! | +
+ vars+ |
+
| 534 | ++ |
+ })+ |
+
| 535 | ++ | + + | +
| 536 | +! | +
+ vars_summary <- reactive({
+ |
+
| 537 | +! | +
+ na_count <- data_r() %>%+ |
+
| 538 | +! | +
+ sapply(function(x) mean(is.na(x)), USE.NAMES = TRUE) %>%+ |
+
| 539 | +! | +
+ sort(decreasing = TRUE)+ |
+
| 540 | ++ | + + | +
| 541 | +! | +
+ tibble::tibble(+ |
+
| 542 | +! | +
+ key = names(na_count),+ |
+
| 543 | +! | +
+ value = unname(na_count),+ |
+
| 544 | +! | +
+ label = cut(na_count, breaks = seq(from = 0, to = 1, by = 0.1), include.lowest = TRUE)+ |
+
| 545 | ++ |
+ )+ |
+
| 546 | ++ |
+ })+ |
+
| 547 | ++ | + + | +
| 548 | +! | +
+ output$variables <- renderUI({
+ |
+
| 549 | +! | +
+ choices <- split(x = vars_summary()$key, f = vars_summary()$label, drop = TRUE) %>% rev()+ |
+
| 550 | +! | +
+ selected <- choices <- unname(unlist(choices))+ |
+
| 551 | ++ | + + | +
| 552 | +! | +
+ teal.widgets::optionalSelectInput(+ |
+
| 553 | +! | +
+ session$ns("variables_select"),
+ |
+
| 554 | +! | +
+ label = "Select variables",+ |
+
| 555 | +! | +
+ label_help = HTML(paste0("Dataset: ", tags$code(dataname))),
+ |
+
| 556 | +! | +
+ choices = teal.transform::variable_choices(data_r(), choices),+ |
+
| 557 | +! | +
+ selected = selected,+ |
+
| 558 | +! | +
+ multiple = TRUE+ |
+
| 559 | ++ |
+ )+ |
+
| 560 | ++ |
+ })+ |
+
| 561 | ++ | + + | +
| 562 | +! | +
+ observeEvent(input$filter_na, {
+ |
+
| 563 | +! | +
+ choices <- vars_summary() %>%+ |
+
| 564 | +! | +
+ dplyr::select(!!as.name("key")) %>%
+ |
+
| 565 | +! | +
+ getElement(name = 1)+ |
+
| 566 | ++ | + + | +
| 567 | +! | +
+ selected <- vars_summary() %>%+ |
+
| 568 | +! | +
+ dplyr::filter(!!as.name("value") > 0) %>%
+ |
+
| 569 | +! | +
+ dplyr::select(!!as.name("key")) %>%
+ |
+
| 570 | +! | +
+ getElement(name = 1)+ |
+
| 571 | ++ | + + | +
| 572 | +! | +
+ teal.widgets::updateOptionalSelectInput(+ |
+
| 573 | +! | +
+ session = session,+ |
+
| 574 | +! | +
+ inputId = "variables_select",+ |
+
| 575 | +! | +
+ choices = teal.transform::variable_choices(data_r()),+ |
+
| 576 | +! | +
+ selected = selected+ |
+
| 577 | ++ |
+ )+ |
+
| 578 | ++ |
+ })+ |
+
| 579 | ++ | + + | +
| 580 | +! | +
+ output$group_by_var_ui <- renderUI({
+ |
+
| 581 | +! | +
+ all_choices <- teal.transform::variable_choices(data_r())+ |
+
| 582 | +! | +
+ cat_choices <- all_choices[!sapply(data_r(), function(x) is.numeric(x) || inherits(x, "POSIXct"))]+ |
+
| 583 | +! | +
+ validate(+ |
+
| 584 | +! | +
+ need(cat_choices, "Dataset does not have any non-numeric or non-datetime variables to use to group data with")+ |
+
| 585 | ++ |
+ )+ |
+
| 586 | +! | +
+ teal.widgets::optionalSelectInput(+ |
+
| 587 | +! | +
+ session$ns("group_by_var"),
+ |
+
| 588 | +! | +
+ label = "Group by variable",+ |
+
| 589 | +! | +
+ choices = cat_choices,+ |
+
| 590 | +! | +
+ selected = `if`(+ |
+
| 591 | +! | +
+ is.null(isolate(input$group_by_var)),+ |
+
| 592 | +! | +
+ cat_choices[1],+ |
+
| 593 | +! | +
+ isolate(input$group_by_var)+ |
+
| 594 | ++ |
+ ),+ |
+
| 595 | +! | +
+ multiple = FALSE,+ |
+
| 596 | +! | +
+ label_help = paste0("Dataset: ", dataname)
+ |
+
| 597 | ++ |
+ )+ |
+
| 598 | ++ |
+ })+ |
+
| 599 | ++ | + + | +
| 600 | +! | +
+ output$group_by_vals_ui <- renderUI({
+ |
+
| 601 | +! | +
+ req(input$group_by_var)+ |
+
| 602 | ++ | + + | +
| 603 | +! | +
+ choices <- teal.transform::value_choices(data_r(), input$group_by_var, input$group_by_var)+ |
+
| 604 | +! | +
+ prev_choices <- isolate(input$group_by_vals)+ |
+
| 605 | ++ | + + | +
| 606 | ++ |
+ # determine selected value based on filtered data+ |
+
| 607 | ++ |
+ # display those previously selected values that are still available+ |
+
| 608 | +! | +
+ selected <- if (!is.null(prev_choices) && any(prev_choices %in% choices)) {
+ |
+
| 609 | +! | +
+ prev_choices[match(choices[choices %in% prev_choices], prev_choices)]+ |
+
| 610 | +! | +
+ } else if (+ |
+
| 611 | +! | +
+ !is.null(prev_choices) &&+ |
+
| 612 | +! | +
+ !any(prev_choices %in% choices) &&+ |
+
| 613 | +! | +
+ isolate(prev_group_by_var()) == input$group_by_var+ |
+
| 614 | ++ |
+ ) {
+ |
+
| 615 | ++ |
+ # if not any previously selected value is available and the grouping variable is the same,+ |
+
| 616 | ++ |
+ # then display NULL+ |
+
| 617 | +! | +
+ NULL+ |
+
| 618 | ++ |
+ } else {
+ |
+
| 619 | ++ |
+ # if new grouping variable (i.e. not any previously selected value is available),+ |
+
| 620 | ++ |
+ # then display all choices+ |
+
| 621 | +! | +
+ choices+ |
+
| 622 | ++ |
+ }+ |
+
| 623 | ++ | + + | +
| 624 | +! | +
+ prev_group_by_var(input$group_by_var) # set current group_by_var+ |
+
| 625 | +! | +
+ validate(need(length(choices) < 100, "Please select group-by variable with fewer than 100 unique values"))+ |
+
| 626 | ++ | + + | +
| 627 | +! | +
+ teal.widgets::optionalSelectInput(+ |
+
| 628 | +! | +
+ session$ns("group_by_vals"),
+ |
+
| 629 | +! | +
+ label = "Filter levels",+ |
+
| 630 | +! | +
+ choices = choices,+ |
+
| 631 | +! | +
+ selected = selected,+ |
+
| 632 | +! | +
+ multiple = TRUE,+ |
+
| 633 | +! | +
+ label_help = paste0("Dataset: ", dataname)
+ |
+
| 634 | ++ |
+ )+ |
+
| 635 | ++ |
+ })+ |
+
| 636 | ++ | + + | +
| 637 | +! | +
+ summary_plot_q <- reactive({
+ |
+
| 638 | +! | +
+ req(input$summary_type == "Summary") # needed to trigger show r code update on tab change+ |
+
| 639 | +! | +
+ teal::validate_has_data(data_r(), 1)+ |
+
| 640 | ++ | + + | +
| 641 | +! | +
+ qenv <- common_code_q()+ |
+
| 642 | ++ | + + | +
| 643 | +! | +
+ if (input$any_na) {
+ |
+
| 644 | +! | +
+ new_col_name <- "**anyna**"+ |
+
| 645 | +! | +
+ qenv <- teal.code::eval_code(+ |
+
| 646 | +! | +
+ qenv,+ |
+
| 647 | +! | +
+ substitute(+ |
+
| 648 | +! | +
+ expr = ANL[[new_col_name]] <- ifelse(rowSums(is.na(ANL)) > 0, NA, FALSE),+ |
+
| 649 | +! | +
+ env = list(new_col_name = new_col_name)+ |
+
| 650 | ++ |
+ )+ |
+
| 651 | ++ |
+ )+ |
+
| 652 | ++ |
+ }+ |
+
| 653 | ++ | + + | +
| 654 | +! | +
+ qenv <- teal.code::eval_code(+ |
+
| 655 | +! | +
+ qenv,+ |
+
| 656 | +! | +
+ substitute(+ |
+
| 657 | +! | +
+ expr = analysis_vars <- setdiff(colnames(ANL), data_keys),+ |
+
| 658 | +! | +
+ env = list(data_keys = data_keys())+ |
+
| 659 | ++ |
+ )+ |
+
| 660 | ++ |
+ ) %>%+ |
+
| 661 | +! | +
+ teal.code::eval_code(+ |
+
| 662 | +! | +
+ substitute(+ |
+
| 663 | +! | +
+ expr = summary_plot_obs <- data_frame_call[, analysis_vars] %>%+ |
+
| 664 | +! | +
+ dplyr::summarise_all(list(function(x) sum(is.na(x)))) %>%+ |
+
| 665 | +! | +
+ tidyr::pivot_longer(dplyr::everything(), names_to = "col", values_to = "n_na") %>%+ |
+
| 666 | +! | +
+ dplyr::mutate(n_not_na = nrow(ANL) - n_na) %>%+ |
+
| 667 | +! | +
+ tidyr::pivot_longer(-col, names_to = "isna", values_to = "n") %>%+ |
+
| 668 | +! | +
+ dplyr::mutate(isna = isna == "n_na", n_pct = n / nrow(ANL) * 100),+ |
+
| 669 | +! | +
+ env = list(data_frame_call = if (!inherits(data_r(), "tbl_df")) {
+ |
+
| 670 | +! | +
+ quote(tibble::as_tibble(ANL))+ |
+
| 671 | ++ |
+ } else {
+ |
+
| 672 | +! | +
+ quote(ANL)+ |
+
| 673 | ++ |
+ })+ |
+
| 674 | ++ |
+ )+ |
+
| 675 | ++ |
+ ) %>%+ |
+
| 676 | ++ |
+ # x axis ordering according to number of missing values and alphabet+ |
+
| 677 | +! | +
+ teal.code::eval_code(+ |
+
| 678 | +! | +
+ quote(+ |
+
| 679 | +! | +
+ expr = x_levels <- dplyr::filter(summary_plot_obs, isna) %>%+ |
+
| 680 | +! | +
+ dplyr::arrange(n_pct, dplyr::desc(col)) %>%+ |
+
| 681 | +! | +
+ dplyr::pull(col) %>%+ |
+
| 682 | +! | +
+ create_cols_labels()+ |
+
| 683 | ++ |
+ )+ |
+
| 684 | ++ |
+ )+ |
+
| 685 | ++ | + + | +
| 686 | ++ |
+ # always set "**anyna**" level as the last one+ |
+
| 687 | +! | +
+ if (isolate(input$any_na)) {
+ |
+
| 688 | +! | +
+ qenv <- teal.code::eval_code(+ |
+
| 689 | +! | +
+ qenv,+ |
+
| 690 | +! | +
+ quote(x_levels <- c(setdiff(x_levels, "**anyna**"), "**anyna**"))+ |
+
| 691 | ++ |
+ )+ |
+
| 692 | ++ |
+ }+ |
+
| 693 | ++ | + + | +
| 694 | +! | +
+ dev_ggplot2_args <- teal.widgets::ggplot2_args(+ |
+
| 695 | +! | +
+ labs = list(x = "Variable", y = "Missing observations"),+ |
+
| 696 | +! | +
+ theme = list(legend.position = "bottom", axis.text.x = quote(element_text(angle = 45, hjust = 1)))+ |
+
| 697 | ++ |
+ )+ |
+
| 698 | ++ | + + | +
| 699 | +! | +
+ all_ggplot2_args <- teal.widgets::resolve_ggplot2_args(+ |
+
| 700 | +! | +
+ user_plot = ggplot2_args[["Summary Obs"]],+ |
+
| 701 | +! | +
+ user_default = ggplot2_args$default,+ |
+
| 702 | +! | +
+ module_plot = dev_ggplot2_args+ |
+
| 703 | ++ |
+ )+ |
+
| 704 | ++ | + + | +
| 705 | +! | +
+ parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(+ |
+
| 706 | +! | +
+ all_ggplot2_args,+ |
+
| 707 | +! | +
+ ggtheme = input$ggtheme+ |
+
| 708 | ++ |
+ )+ |
+
| 709 | ++ | + + | +
| 710 | +! | +
+ qenv <- teal.code::eval_code(+ |
+
| 711 | +! | +
+ qenv,+ |
+
| 712 | +! | +
+ substitute(+ |
+
| 713 | +! | +
+ p1 <- summary_plot_obs %>%+ |
+
| 714 | +! | +
+ ggplot() ++ |
+
| 715 | +! | +
+ aes(+ |
+
| 716 | +! | +
+ x = factor(create_cols_labels(col), levels = x_levels),+ |
+
| 717 | +! | +
+ y = n_pct,+ |
+
| 718 | +! | +
+ fill = isna+ |
+
| 719 | ++ |
+ ) ++ |
+
| 720 | +! | +
+ geom_bar(position = "fill", stat = "identity") ++ |
+
| 721 | +! | +
+ scale_fill_manual(+ |
+
| 722 | +! | +
+ name = "",+ |
+
| 723 | +! | +
+ values = c("grey90", c(getOption("ggplot2.discrete.colour")[2], "#ff2951ff")[1]),
+ |
+
| 724 | +! | +
+ labels = c("Present", "Missing")
+ |
+
| 725 | ++ |
+ ) ++ |
+
| 726 | +! | +
+ scale_y_continuous(labels = scales::percent_format(), breaks = seq(0, 1, by = 0.1), expand = c(0, 0)) ++ |
+
| 727 | +! | +
+ geom_text(+ |
+
| 728 | +! | +
+ aes(label = ifelse(isna == TRUE, sprintf("%d [%.02f%%]", n, n_pct), ""), y = 1),
+ |
+
| 729 | +! | +
+ hjust = 1,+ |
+
| 730 | +! | +
+ color = "black"+ |
+
| 731 | ++ |
+ ) ++ |
+
| 732 | +! | +
+ labs ++ |
+
| 733 | +! | +
+ ggthemes ++ |
+
| 734 | +! | +
+ themes ++ |
+
| 735 | +! | +
+ coord_flip(),+ |
+
| 736 | +! | +
+ env = list(+ |
+
| 737 | +! | +
+ labs = parsed_ggplot2_args$labs,+ |
+
| 738 | +! | +
+ themes = parsed_ggplot2_args$theme,+ |
+
| 739 | +! | +
+ ggthemes = parsed_ggplot2_args$ggtheme+ |
+
| 740 | ++ |
+ )+ |
+
| 741 | ++ |
+ )+ |
+
| 742 | ++ |
+ )+ |
+
| 743 | ++ | + + | +
| 744 | +! | +
+ if (isTRUE(input$if_patients_plot)) {
+ |
+
| 745 | +! | +
+ qenv <- teal.code::eval_code(+ |
+
| 746 | +! | +
+ qenv,+ |
+
| 747 | +! | +
+ substitute(+ |
+
| 748 | +! | +
+ expr = parent_keys <- keys,+ |
+
| 749 | +! | +
+ env = list(keys = data_parent_keys())+ |
+
| 750 | ++ |
+ )+ |
+
| 751 | ++ |
+ ) %>%+ |
+
| 752 | +! | +
+ teal.code::eval_code(quote(ndistinct_subjects <- dplyr::n_distinct(ANL[, parent_keys]))) %>%+ |
+
| 753 | +! | +
+ teal.code::eval_code(+ |
+
| 754 | +! | +
+ quote(+ |
+
| 755 | +! | +
+ summary_plot_patients <- ANL[, c(parent_keys, analysis_vars)] %>%+ |
+
| 756 | +! | +
+ dplyr::group_by_at(parent_keys) %>%+ |
+
| 757 | +! | +
+ dplyr::summarise_all(anyNA) %>%+ |
+
| 758 | +! | +
+ tidyr::pivot_longer(cols = !dplyr::all_of(parent_keys), names_to = "col", values_to = "anyna") %>%+ |
+
| 759 | +! | +
+ dplyr::group_by_at(c("col")) %>%
+ |
+
| 760 | +! | +
+ dplyr::summarise(count_na = sum(anyna)) %>%+ |
+
| 761 | +! | +
+ dplyr::mutate(count_not_na = ndistinct_subjects - count_na) %>%+ |
+
| 762 | +! | +
+ tidyr::pivot_longer(-c(col), names_to = "isna", values_to = "n") %>%+ |
+
| 763 | +! | +
+ dplyr::mutate(isna = isna == "count_na", n_pct = n / ndistinct_subjects * 100) %>%+ |
+
| 764 | +! | +
+ dplyr::arrange_at(c("isna", "n"), .funs = dplyr::desc)
+ |
+
| 765 | ++ |
+ )+ |
+
| 766 | ++ |
+ )+ |
+
| 767 | ++ | + + | +
| 768 | +! | +
+ dev_ggplot2_args <- teal.widgets::ggplot2_args(+ |
+
| 769 | +! | +
+ labs = list(x = "", y = "Missing patients"),+ |
+
| 770 | +! | +
+ theme = list(+ |
+
| 771 | +! | +
+ legend.position = "bottom",+ |
+
| 772 | +! | +
+ axis.text.x = quote(element_text(angle = 45, hjust = 1)),+ |
+
| 773 | +! | +
+ axis.text.y = quote(element_blank())+ |
+
| 774 | ++ |
+ )+ |
+
| 775 | ++ |
+ )+ |
+
| 776 | ++ | + + | +
| 777 | +! | +
+ all_ggplot2_args <- teal.widgets::resolve_ggplot2_args(+ |
+
| 778 | +! | +
+ user_plot = ggplot2_args[["Summary Patients"]],+ |
+
| 779 | +! | +
+ user_default = ggplot2_args$default,+ |
+
| 780 | +! | +
+ module_plot = dev_ggplot2_args+ |
+
| 781 | ++ |
+ )+ |
+
| 782 | ++ | + + | +
| 783 | +! | +
+ parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(+ |
+
| 784 | +! | +
+ all_ggplot2_args,+ |
+
| 785 | +! | +
+ ggtheme = input$ggtheme+ |
+
| 786 | ++ |
+ )+ |
+
| 787 | ++ | + + | +
| 788 | +! | +
+ qenv <- teal.code::eval_code(+ |
+
| 789 | +! | +
+ qenv,+ |
+
| 790 | +! | +
+ substitute(+ |
+
| 791 | +! | +
+ p2 <- summary_plot_patients %>%+ |
+
| 792 | +! | +
+ ggplot() ++ |
+
| 793 | +! | +
+ aes_(+ |
+
| 794 | +! | +
+ x = ~ factor(create_cols_labels(col), levels = x_levels),+ |
+
| 795 | +! | +
+ y = ~n_pct,+ |
+
| 796 | +! | +
+ fill = ~isna+ |
+
| 797 | ++ |
+ ) ++ |
+
| 798 | +! | +
+ geom_bar(alpha = 1, stat = "identity", position = "fill") ++ |
+
| 799 | +! | +
+ scale_y_continuous(labels = scales::percent_format(), breaks = seq(0, 1, by = 0.1), expand = c(0, 0)) ++ |
+
| 800 | +! | +
+ scale_fill_manual(+ |
+
| 801 | +! | +
+ name = "",+ |
+
| 802 | +! | +
+ values = c("grey90", c(getOption("ggplot2.discrete.colour")[2], "#ff2951ff")[1]),
+ |
+
| 803 | +! | +
+ labels = c("Present", "Missing")
+ |
+
| 804 | ++ |
+ ) ++ |
+
| 805 | +! | +
+ geom_text(+ |
+
| 806 | +! | +
+ aes(label = ifelse(isna == TRUE, sprintf("%d [%.02f%%]", n, n_pct), ""), y = 1),
+ |
+
| 807 | +! | +
+ hjust = 1,+ |
+
| 808 | +! | +
+ color = "black"+ |
+
| 809 | ++ |
+ ) ++ |
+
| 810 | +! | +
+ labs ++ |
+
| 811 | +! | +
+ ggthemes ++ |
+
| 812 | +! | +
+ themes ++ |
+
| 813 | +! | +
+ coord_flip(),+ |
+
| 814 | +! | +
+ env = list(+ |
+
| 815 | +! | +
+ labs = parsed_ggplot2_args$labs,+ |
+
| 816 | +! | +
+ themes = parsed_ggplot2_args$theme,+ |
+
| 817 | +! | +
+ ggthemes = parsed_ggplot2_args$ggtheme+ |
+
| 818 | ++ |
+ )+ |
+
| 819 | ++ |
+ )+ |
+
| 820 | ++ |
+ ) %>%+ |
+
| 821 | +! | +
+ teal.code::eval_code(+ |
+
| 822 | +! | +
+ quote({
+ |
+
| 823 | +! | +
+ g1 <- ggplotGrob(p1)+ |
+
| 824 | +! | +
+ g2 <- ggplotGrob(p2)+ |
+
| 825 | +! | +
+ g <- gridExtra::gtable_cbind(g1, g2, size = "first")+ |
+
| 826 | +! | +
+ g$heights <- grid::unit.pmax(g1$heights, g2$heights)+ |
+
| 827 | +! | +
+ grid::grid.newpage()+ |
+
| 828 | ++ |
+ })+ |
+
| 829 | ++ |
+ )+ |
+
| 830 | ++ |
+ } else {
+ |
+
| 831 | +! | +
+ qenv <- teal.code::eval_code(+ |
+
| 832 | +! | +
+ qenv,+ |
+
| 833 | +! | +
+ quote({
+ |
+
| 834 | +! | +
+ g <- ggplotGrob(p1)+ |
+
| 835 | +! | +
+ grid::grid.newpage()+ |
+
| 836 | ++ |
+ })+ |
+
| 837 | ++ |
+ )+ |
+
| 838 | ++ |
+ }+ |
+
| 839 | ++ | + + | +
| 840 | +! | +
+ teal.code::eval_code(+ |
+
| 841 | +! | +
+ qenv,+ |
+
| 842 | +! | +
+ quote(grid::grid.draw(g))+ |
+
| 843 | ++ |
+ )+ |
+
| 844 | ++ |
+ })+ |
+
| 845 | ++ | + + | +
| 846 | +! | +
+ summary_plot_r <- reactive(summary_plot_q()[["g"]])+ |
+
| 847 | ++ | + + | +
| 848 | +! | +
+ combination_cutoff_q <- reactive({
+ |
+
| 849 | +! | +
+ req(common_code_q())+ |
+
| 850 | +! | +
+ teal.code::eval_code(+ |
+
| 851 | +! | +
+ common_code_q(),+ |
+
| 852 | +! | +
+ quote(+ |
+
| 853 | +! | +
+ combination_cutoff <- ANL %>%+ |
+
| 854 | +! | +
+ dplyr::mutate_all(is.na) %>%+ |
+
| 855 | +! | +
+ dplyr::group_by_all() %>%+ |
+
| 856 | +! | +
+ dplyr::tally() %>%+ |
+
| 857 | +! | +
+ dplyr::ungroup()+ |
+
| 858 | ++ |
+ )+ |
+
| 859 | ++ |
+ )+ |
+
| 860 | ++ |
+ })+ |
+
| 861 | ++ | + + | +
| 862 | +! | +
+ output$cutoff <- renderUI({
+ |
+
| 863 | +! | +
+ x <- combination_cutoff_q()[["combination_cutoff"]]$n+ |
+
| 864 | ++ | + + | +
| 865 | ++ |
+ # select 10-th from the top+ |
+
| 866 | +! | +
+ n <- length(x)+ |
+
| 867 | +! | +
+ idx <- max(1, n - 10)+ |
+
| 868 | +! | +
+ prev_value <- isolate(input$combination_cutoff)+ |
+
| 869 | +! | +
+ value <- `if`(+ |
+
| 870 | +! | +
+ is.null(prev_value) || prev_value > max(x) || prev_value < min(x),+ |
+
| 871 | +! | +
+ sort(x, partial = idx)[idx], prev_value+ |
+
| 872 | ++ |
+ )+ |
+
| 873 | ++ | + + | +
| 874 | +! | +
+ teal.widgets::optionalSliderInputValMinMax(+ |
+
| 875 | +! | +
+ session$ns("combination_cutoff"),
+ |
+
| 876 | +! | +
+ "Combination cut-off",+ |
+
| 877 | +! | +
+ c(value, range(x))+ |
+
| 878 | ++ |
+ )+ |
+
| 879 | ++ |
+ })+ |
+
| 880 | ++ | + + | +
| 881 | +! | +
+ combination_plot_q <- reactive({
+ |
+
| 882 | +! | +
+ req(input$summary_type == "Combinations", input$combination_cutoff, combination_cutoff_q())+ |
+
| 883 | +! | +
+ teal::validate_has_data(data_r(), 1)+ |
+
| 884 | ++ | + + | +
| 885 | +! | +
+ qenv <- teal.code::eval_code(+ |
+
| 886 | +! | +
+ combination_cutoff_q(),+ |
+
| 887 | +! | +
+ substitute(+ |
+
| 888 | +! | +
+ expr = data_combination_plot_cutoff <- combination_cutoff %>%+ |
+
| 889 | +! | +
+ dplyr::filter(n >= combination_cutoff_value) %>%+ |
+
| 890 | +! | +
+ dplyr::mutate(id = rank(-n, ties.method = "first")) %>%+ |
+
| 891 | +! | +
+ tidyr::pivot_longer(-c(n, id), names_to = "key", values_to = "value") %>%+ |
+
| 892 | +! | +
+ dplyr::arrange(n),+ |
+
| 893 | +! | +
+ env = list(combination_cutoff_value = input$combination_cutoff)+ |
+
| 894 | ++ |
+ )+ |
+
| 895 | ++ |
+ )+ |
+
| 896 | ++ | + + | +
| 897 | ++ |
+ # find keys in dataset not selected in the UI and remove them from dataset+ |
+
| 898 | +! | +
+ keys_not_selected <- setdiff(data_keys(), input$variables_select)+ |
+
| 899 | +! | +
+ if (length(keys_not_selected) > 0) {
+ |
+
| 900 | +! | +
+ qenv <- teal.code::eval_code(+ |
+
| 901 | +! | +
+ qenv,+ |
+
| 902 | +! | +
+ substitute(+ |
+
| 903 | +! | +
+ expr = data_combination_plot_cutoff <- data_combination_plot_cutoff %>%+ |
+
| 904 | +! | +
+ dplyr::filter(!key %in% keys_not_selected),+ |
+
| 905 | +! | +
+ env = list(keys_not_selected = keys_not_selected)+ |
+
| 906 | ++ |
+ )+ |
+
| 907 | ++ |
+ )+ |
+
| 908 | ++ |
+ }+ |
+
| 909 | ++ | + + | +
| 910 | +! | +
+ qenv <- teal.code::eval_code(+ |
+
| 911 | +! | +
+ qenv,+ |
+
| 912 | +! | +
+ quote(+ |
+
| 913 | +! | +
+ labels <- data_combination_plot_cutoff %>%+ |
+
| 914 | +! | +
+ dplyr::filter(key == key[[1]]) %>%+ |
+
| 915 | +! | +
+ getElement(name = 1)+ |
+
| 916 | ++ |
+ )+ |
+
| 917 | ++ |
+ )+ |
+
| 918 | ++ | + + | +
| 919 | +! | +
+ dev_ggplot2_args1 <- teal.widgets::ggplot2_args(+ |
+
| 920 | +! | +
+ labs = list(x = "", y = ""),+ |
+
| 921 | +! | +
+ theme = list(+ |
+
| 922 | +! | +
+ legend.position = "bottom",+ |
+
| 923 | +! | +
+ axis.text.x = quote(element_blank())+ |
+
| 924 | ++ |
+ )+ |
+
| 925 | ++ |
+ )+ |
+
| 926 | ++ | + + | +
| 927 | +! | +
+ all_ggplot2_args1 <- teal.widgets::resolve_ggplot2_args(+ |
+
| 928 | +! | +
+ user_plot = ggplot2_args[["Combinations Hist"]],+ |
+
| 929 | +! | +
+ user_default = ggplot2_args$default,+ |
+
| 930 | +! | +
+ module_plot = dev_ggplot2_args1+ |
+
| 931 | ++ |
+ )+ |
+
| 932 | ++ | + + | +
| 933 | +! | +
+ parsed_ggplot2_args1 <- teal.widgets::parse_ggplot2_args(+ |
+
| 934 | +! | +
+ all_ggplot2_args1,+ |
+
| 935 | +! | +
+ ggtheme = "void"+ |
+
| 936 | ++ |
+ )+ |
+
| 937 | ++ | + + | +
| 938 | +! | +
+ dev_ggplot2_args2 <- teal.widgets::ggplot2_args(+ |
+
| 939 | +! | +
+ labs = list(x = "", y = ""),+ |
+
| 940 | +! | +
+ theme = list(+ |
+
| 941 | +! | +
+ legend.position = "bottom",+ |
+
| 942 | +! | +
+ axis.text.x = quote(element_blank()),+ |
+
| 943 | +! | +
+ axis.ticks = quote(element_blank()),+ |
+
| 944 | +! | +
+ panel.grid.major = quote(element_blank())+ |
+
| 945 | ++ |
+ )+ |
+
| 946 | ++ |
+ )+ |
+
| 947 | ++ | + + | +
| 948 | +! | +
+ all_ggplot2_args2 <- teal.widgets::resolve_ggplot2_args(+ |
+
| 949 | +! | +
+ user_plot = ggplot2_args[["Combinations Main"]],+ |
+
| 950 | +! | +
+ user_default = ggplot2_args$default,+ |
+
| 951 | +! | +
+ module_plot = dev_ggplot2_args2+ |
+
| 952 | ++ |
+ )+ |
+
| 953 | ++ | + + | +
| 954 | +! | +
+ parsed_ggplot2_args2 <- teal.widgets::parse_ggplot2_args(+ |
+
| 955 | +! | +
+ all_ggplot2_args2,+ |
+
| 956 | +! | +
+ ggtheme = input$ggtheme+ |
+
| 957 | ++ |
+ )+ |
+
| 958 | ++ | + + | +
| 959 | +! | +
+ teal.code::eval_code(+ |
+
| 960 | +! | +
+ qenv,+ |
+
| 961 | +! | +
+ substitute(+ |
+
| 962 | +! | +
+ expr = {
+ |
+
| 963 | +! | +
+ p1 <- data_combination_plot_cutoff %>%+ |
+
| 964 | +! | +
+ dplyr::select(id, n) %>%+ |
+
| 965 | +! | +
+ dplyr::distinct() %>%+ |
+
| 966 | +! | +
+ ggplot(aes(x = id, y = n)) ++ |
+
| 967 | +! | +
+ geom_bar(stat = "identity", fill = c(getOption("ggplot2.discrete.colour")[2], "#ff2951ff")[1]) +
+ |
+
| 968 | +! | +
+ geom_text(aes(label = n), position = position_dodge(width = 0.9), vjust = -0.25) ++ |
+
| 969 | +! | +
+ ylim(c(0, max(data_combination_plot_cutoff$n) * 1.5)) ++ |
+
| 970 | +! | +
+ labs1 ++ |
+
| 971 | +! | +
+ ggthemes1 ++ |
+
| 972 | +! | +
+ themes1+ |
+
| 973 | ++ | + + | +
| 974 | +! | +
+ graph_number_rows <- length(unique(data_combination_plot_cutoff$id))+ |
+
| 975 | +! | +
+ graph_number_cols <- nrow(data_combination_plot_cutoff) / graph_number_rows+ |
+
| 976 | ++ | + + | +
| 977 | +! | +
+ p2 <- data_combination_plot_cutoff %>% ggplot() ++ |
+
| 978 | +! | +
+ aes(x = create_cols_labels(key), y = id - 0.5, fill = value) ++ |
+
| 979 | +! | +
+ geom_tile(alpha = 0.85, height = 0.95) ++ |
+
| 980 | +! | +
+ scale_fill_manual(+ |
+
| 981 | +! | +
+ name = "",+ |
+
| 982 | +! | +
+ values = c("grey90", c(getOption("ggplot2.discrete.colour")[2], "#ff2951ff")[1]),
+ |
+
| 983 | +! | +
+ labels = c("Present", "Missing")
+ |
+
| 984 | ++ |
+ ) ++ |
+
| 985 | +! | +
+ geom_hline(yintercept = seq_len(1 + graph_number_rows) - 1) ++ |
+
| 986 | +! | +
+ geom_vline(xintercept = seq_len(1 + graph_number_cols) - 0.5, linetype = "dotted") ++ |
+
| 987 | +! | +
+ coord_flip() ++ |
+
| 988 | +! | +
+ labs2 ++ |
+
| 989 | +! | +
+ ggthemes2 ++ |
+
| 990 | +! | +
+ themes2+ |
+
| 991 | ++ | + + | +
| 992 | +! | +
+ g1 <- ggplotGrob(p1)+ |
+
| 993 | +! | +
+ g2 <- ggplotGrob(p2)+ |
+
| 994 | ++ | + + | +
| 995 | +! | +
+ g <- gridExtra::gtable_rbind(g1, g2, size = "last")+ |
+
| 996 | +! | +
+ g$heights[7] <- grid::unit(0.2, "null") # rescale to get the bar chart smaller+ |
+
| 997 | +! | +
+ grid::grid.newpage()+ |
+
| 998 | +! | +
+ grid::grid.draw(g)+ |
+
| 999 | ++ |
+ },+ |
+
| 1000 | +! | +
+ env = list(+ |
+
| 1001 | +! | +
+ labs1 = parsed_ggplot2_args1$labs,+ |
+
| 1002 | +! | +
+ themes1 = parsed_ggplot2_args1$theme,+ |
+
| 1003 | +! | +
+ ggthemes1 = parsed_ggplot2_args1$ggtheme,+ |
+
| 1004 | +! | +
+ labs2 = parsed_ggplot2_args2$labs,+ |
+
| 1005 | +! | +
+ themes2 = parsed_ggplot2_args2$theme,+ |
+
| 1006 | +! | +
+ ggthemes2 = parsed_ggplot2_args2$ggtheme+ |
+
| 1007 | ++ |
+ )+ |
+
| 1008 | ++ |
+ )+ |
+
| 1009 | ++ |
+ )+ |
+
| 1010 | ++ |
+ })+ |
+
| 1011 | ++ | + + | +
| 1012 | +! | +
+ combination_plot_r <- reactive(combination_plot_q()[["g"]])+ |
+
| 1013 | ++ | + + | +
| 1014 | +! | +
+ summary_table_q <- reactive({
+ |
+
| 1015 | +! | +
+ req(+ |
+
| 1016 | +! | +
+ input$summary_type == "By Variable Levels", # needed to trigger show r code update on tab change+ |
+
| 1017 | +! | +
+ common_code_q()+ |
+
| 1018 | ++ |
+ )+ |
+
| 1019 | +! | +
+ teal::validate_has_data(data_r(), 1)+ |
+
| 1020 | ++ | + + | +
| 1021 | ++ |
+ # extract the ANL dataset for use in further validation+ |
+
| 1022 | +! | +
+ anl <- common_code_q()[["ANL"]]+ |
+
| 1023 | ++ | + + | +
| 1024 | +! | +
+ group_var <- input$group_by_var+ |
+
| 1025 | +! | +
+ validate(+ |
+
| 1026 | +! | +
+ need(+ |
+
| 1027 | +! | +
+ is.null(group_var) ||+ |
+
| 1028 | +! | +
+ length(unique(anl[[group_var]])) < 100,+ |
+
| 1029 | +! | +
+ "Please select group-by variable with fewer than 100 unique values"+ |
+
| 1030 | ++ |
+ )+ |
+
| 1031 | ++ |
+ )+ |
+
| 1032 | ++ | + + | +
| 1033 | +! | +
+ group_vals <- input$group_by_vals+ |
+
| 1034 | +! | +
+ variables_select <- input$variables_select+ |
+
| 1035 | +! | +
+ vars <- unique(variables_select, group_var)+ |
+
| 1036 | +! | +
+ count_type <- input$count_type+ |
+
| 1037 | ++ | + + | +
| 1038 | +! | +
+ if (!is.null(selected_vars()) && length(selected_vars()) != ncol(anl)) {
+ |
+
| 1039 | +! | +
+ variables <- selected_vars()+ |
+
| 1040 | ++ |
+ } else {
+ |
+
| 1041 | +! | +
+ variables <- colnames(anl)+ |
+
| 1042 | ++ |
+ }+ |
+
| 1043 | ++ | + + | +
| 1044 | +! | +
+ summ_fn <- if (input$count_type == "counts") {
+ |
+
| 1045 | +! | +
+ function(x) sum(is.na(x))+ |
+
| 1046 | ++ |
+ } else {
+ |
+
| 1047 | +! | +
+ function(x) round(sum(is.na(x)) / length(x), 4)+ |
+
| 1048 | ++ |
+ }+ |
+
| 1049 | ++ | + + | +
| 1050 | +! | +
+ qenv <- common_code_q()+ |
+
| 1051 | ++ | + + | +
| 1052 | +! | +
+ if (!is.null(group_var)) {
+ |
+
| 1053 | +! | +
+ qenv <- teal.code::eval_code(+ |
+
| 1054 | +! | +
+ qenv,+ |
+
| 1055 | +! | +
+ substitute(+ |
+
| 1056 | +! | +
+ expr = {
+ |
+
| 1057 | +! | +
+ summary_data <- ANL %>%+ |
+
| 1058 | +! | +
+ dplyr::mutate(group_var_name := forcats::fct_na_value_to_level(as.factor(group_var_name), "NA")) %>%+ |
+
| 1059 | +! | +
+ dplyr::group_by_at(group_var) %>%+ |
+
| 1060 | +! | +
+ dplyr::filter(group_var_name %in% group_vals)+ |
+
| 1061 | ++ | + + | +
| 1062 | +! | +
+ count_data <- dplyr::summarise(summary_data, n = dplyr::n())+ |
+
| 1063 | ++ | + + | +
| 1064 | +! | +
+ summary_data <- dplyr::summarise_all(summary_data, summ_fn) %>%+ |
+
| 1065 | +! | +
+ dplyr::mutate(group_var_name := paste0(group_var, ":", group_var_name, "(N=", count_data$n, ")")) %>%+ |
+
| 1066 | +! | +
+ tidyr::pivot_longer(!dplyr::all_of(group_var), names_to = "Variable", values_to = "out") %>%+ |
+
| 1067 | +! | +
+ tidyr::pivot_wider(names_from = group_var, values_from = "out") %>%+ |
+
| 1068 | +! | +
+ dplyr::mutate(`Variable label` = create_cols_labels(Variable, just_label = TRUE), .after = Variable)+ |
+
| 1069 | ++ |
+ },+ |
+
| 1070 | +! | +
+ env = list(+ |
+
| 1071 | +! | +
+ group_var = group_var, group_var_name = as.name(group_var), group_vals = group_vals, summ_fn = summ_fn+ |
+
| 1072 | ++ |
+ )+ |
+
| 1073 | ++ |
+ )+ |
+
| 1074 | ++ |
+ )+ |
+
| 1075 | ++ |
+ } else {
+ |
+
| 1076 | +! | +
+ qenv <- teal.code::eval_code(+ |
+
| 1077 | +! | +
+ qenv,+ |
+
| 1078 | +! | +
+ substitute(+ |
+
| 1079 | +! | +
+ expr = summary_data <- ANL %>%+ |
+
| 1080 | +! | +
+ dplyr::summarise_all(summ_fn) %>%+ |
+
| 1081 | +! | +
+ tidyr::pivot_longer(dplyr::everything(),+ |
+
| 1082 | +! | +
+ names_to = "Variable",+ |
+
| 1083 | +! | +
+ values_to = paste0("Missing (N=", nrow(ANL), ")")
+ |
+
| 1084 | ++ |
+ ) %>%+ |
+
| 1085 | +! | +
+ dplyr::mutate(`Variable label` = create_cols_labels(Variable), .after = Variable),+ |
+
| 1086 | +! | +
+ env = list(summ_fn = summ_fn)+ |
+
| 1087 | ++ |
+ )+ |
+
| 1088 | ++ |
+ )+ |
+
| 1089 | ++ |
+ }+ |
+
| 1090 | ++ | + + | +
| 1091 | +! | +
+ teal.code::eval_code(qenv, quote(summary_data))+ |
+
| 1092 | ++ |
+ })+ |
+
| 1093 | ++ | + + | +
| 1094 | +! | +
+ summary_table_r <- reactive(summary_table_q()[["summary_data"]])+ |
+
| 1095 | ++ | + + | +
| 1096 | +! | +
+ by_subject_plot_q <- reactive({
+ |
+
| 1097 | ++ |
+ # needed to trigger show r code update on tab change+ |
+
| 1098 | +! | +
+ req(input$summary_type == "Grouped by Subject", common_code_q())+ |
+
| 1099 | ++ | + + | +
| 1100 | +! | +
+ teal::validate_has_data(data_r(), 1)+ |
+
| 1101 | ++ | + + | +
| 1102 | +! | +
+ dev_ggplot2_args <- teal.widgets::ggplot2_args(+ |
+
| 1103 | +! | +
+ labs = list(x = "", y = ""),+ |
+
| 1104 | +! | +
+ theme = list(legend.position = "bottom", axis.text.x = quote(element_blank()))+ |
+
| 1105 | ++ |
+ )+ |
+
| 1106 | ++ | + + | +
| 1107 | +! | +
+ all_ggplot2_args <- teal.widgets::resolve_ggplot2_args(+ |
+
| 1108 | +! | +
+ user_plot = ggplot2_args[["By Subject"]],+ |
+
| 1109 | +! | +
+ user_default = ggplot2_args$default,+ |
+
| 1110 | +! | +
+ module_plot = dev_ggplot2_args+ |
+
| 1111 | ++ |
+ )+ |
+
| 1112 | ++ | + + | +
| 1113 | +! | +
+ parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(+ |
+
| 1114 | +! | +
+ all_ggplot2_args,+ |
+
| 1115 | +! | +
+ ggtheme = input$ggtheme+ |
+
| 1116 | ++ |
+ )+ |
+
| 1117 | ++ | + + | +
| 1118 | +! | +
+ teal.code::eval_code(+ |
+
| 1119 | +! | +
+ common_code_q(),+ |
+
| 1120 | +! | +
+ substitute(+ |
+
| 1121 | +! | +
+ expr = parent_keys <- keys,+ |
+
| 1122 | +! | +
+ env = list(keys = data_parent_keys())+ |
+
| 1123 | ++ |
+ )+ |
+
| 1124 | ++ |
+ ) %>%+ |
+
| 1125 | +! | +
+ teal.code::eval_code(+ |
+
| 1126 | +! | +
+ substitute(+ |
+
| 1127 | +! | +
+ expr = analysis_vars <- setdiff(colnames(ANL), data_keys),+ |
+
| 1128 | +! | +
+ env = list(data_keys = data_keys())+ |
+
| 1129 | ++ |
+ )+ |
+
| 1130 | ++ |
+ ) %>%+ |
+
| 1131 | +! | +
+ teal.code::eval_code(+ |
+
| 1132 | +! | +
+ quote({
+ |
+
| 1133 | +! | +
+ summary_plot_patients <- ANL[, c(parent_keys, analysis_vars)] %>%+ |
+
| 1134 | +! | +
+ dplyr::group_by_at(parent_keys) %>%+ |
+
| 1135 | +! | +
+ dplyr::mutate(id = dplyr::cur_group_id()) %>%+ |
+
| 1136 | +! | +
+ dplyr::ungroup() %>%+ |
+
| 1137 | +! | +
+ dplyr::group_by_at(c(parent_keys, "id")) %>%+ |
+
| 1138 | +! | +
+ dplyr::summarise_all(anyNA) %>%+ |
+
| 1139 | +! | +
+ dplyr::ungroup()+ |
+
| 1140 | ++ | + + | +
| 1141 | ++ |
+ # order subjects by decreasing number of missing and then by+ |
+
| 1142 | ++ |
+ # missingness pattern (defined using sha1)+ |
+
| 1143 | +! | +
+ order_subjects <- summary_plot_patients %>%+ |
+
| 1144 | +! | +
+ dplyr::select(-"id", -dplyr::all_of(parent_keys)) %>%+ |
+
| 1145 | +! | +
+ dplyr::transmute(+ |
+
| 1146 | +! | +
+ id = dplyr::row_number(),+ |
+
| 1147 | +! | +
+ number_NA = apply(., 1, sum),+ |
+
| 1148 | +! | +
+ sha = apply(., 1, rlang::hash)+ |
+
| 1149 | ++ |
+ ) %>%+ |
+
| 1150 | +! | +
+ dplyr::arrange(dplyr::desc(number_NA), sha) %>%+ |
+
| 1151 | +! | +
+ getElement(name = "id")+ |
+
| 1152 | ++ | + + | +
| 1153 | ++ |
+ # order columns by decreasing percent of missing values+ |
+
| 1154 | +! | +
+ ordered_columns <- summary_plot_patients %>%+ |
+
| 1155 | +! | +
+ dplyr::select(-"id", -dplyr::all_of(parent_keys)) %>%+ |
+
| 1156 | +! | +
+ dplyr::summarise(+ |
+
| 1157 | +! | +
+ column = create_cols_labels(colnames(.)),+ |
+
| 1158 | +! | +
+ na_count = apply(., MARGIN = 2, FUN = sum),+ |
+
| 1159 | +! | +
+ na_percent = na_count / nrow(.) * 100+ |
+
| 1160 | ++ |
+ ) %>%+ |
+
| 1161 | +! | +
+ dplyr::arrange(na_percent, dplyr::desc(column))+ |
+
| 1162 | ++ | + + | +
| 1163 | +! | +
+ summary_plot_patients <- summary_plot_patients %>%+ |
+
| 1164 | +! | +
+ tidyr::gather("col", "isna", -"id", -dplyr::all_of(parent_keys)) %>%
+ |
+
| 1165 | +! | +
+ dplyr::mutate(col = create_cols_labels(col))+ |
+
| 1166 | ++ |
+ })+ |
+
| 1167 | ++ |
+ ) %>%+ |
+
| 1168 | +! | +
+ teal.code::eval_code(+ |
+
| 1169 | +! | +
+ substitute(+ |
+
| 1170 | +! | +
+ expr = {
+ |
+
| 1171 | +! | +
+ g <- ggplot(summary_plot_patients, aes(+ |
+
| 1172 | +! | +
+ x = factor(id, levels = order_subjects),+ |
+
| 1173 | +! | +
+ y = factor(col, levels = ordered_columns[["column"]]),+ |
+
| 1174 | +! | +
+ fill = isna+ |
+
| 1175 | ++ |
+ )) ++ |
+
| 1176 | +! | +
+ geom_raster() ++ |
+
| 1177 | +! | +
+ annotate(+ |
+
| 1178 | +! | +
+ "text",+ |
+
| 1179 | +! | +
+ x = length(order_subjects),+ |
+
| 1180 | +! | +
+ y = seq_len(nrow(ordered_columns)),+ |
+
| 1181 | +! | +
+ hjust = 1,+ |
+
| 1182 | +! | +
+ label = sprintf("%d [%.02f%%]", ordered_columns[["na_count"]], ordered_columns[["na_percent"]])
+ |
+
| 1183 | ++ |
+ ) ++ |
+
| 1184 | +! | +
+ scale_fill_manual(+ |
+
| 1185 | +! | +
+ name = "",+ |
+
| 1186 | +! | +
+ values = c("grey90", c(getOption("ggplot2.discrete.colour")[2], "#ff2951ff")[1]),
+ |
+
| 1187 | +! | +
+ labels = c("Present", "Missing (at least one)")
+ |
+
| 1188 | ++ |
+ ) ++ |
+
| 1189 | +! | +
+ labs ++ |
+
| 1190 | +! | +
+ ggthemes ++ |
+
| 1191 | +! | +
+ themes+ |
+
| 1192 | +! | +
+ print(g)+ |
+
| 1193 | ++ |
+ },+ |
+
| 1194 | +! | +
+ env = list(+ |
+
| 1195 | +! | +
+ labs = parsed_ggplot2_args$labs,+ |
+
| 1196 | +! | +
+ themes = parsed_ggplot2_args$theme,+ |
+
| 1197 | +! | +
+ ggthemes = parsed_ggplot2_args$ggtheme+ |
+
| 1198 | ++ |
+ )+ |
+
| 1199 | ++ |
+ )+ |
+
| 1200 | ++ |
+ )+ |
+
| 1201 | ++ |
+ })+ |
+
| 1202 | ++ | + + | +
| 1203 | +! | +
+ by_subject_plot_r <- reactive(by_subject_plot_q()[["g"]])+ |
+
| 1204 | ++ | + + | +
| 1205 | +! | +
+ output$levels_table <- DT::renderDataTable(+ |
+
| 1206 | +! | +
+ expr = {
+ |
+
| 1207 | +! | +
+ if (length(input$variables_select) == 0) {
+ |
+
| 1208 | ++ |
+ # so that zeroRecords message gets printed+ |
+
| 1209 | ++ |
+ # using tibble as it supports weird column names, such as " "+ |
+
| 1210 | +! | +
+ tibble::tibble(` ` = logical(0))+ |
+
| 1211 | ++ |
+ } else {
+ |
+
| 1212 | +! | +
+ summary_table_r()+ |
+
| 1213 | ++ |
+ }+ |
+
| 1214 | ++ |
+ },+ |
+
| 1215 | +! | +
+ options = list(language = list(zeroRecords = "No variable selected"), pageLength = input$levels_table_rows)+ |
+
| 1216 | ++ |
+ )+ |
+
| 1217 | ++ | + + | +
| 1218 | +! | +
+ pws1 <- teal.widgets::plot_with_settings_srv(+ |
+
| 1219 | +! | +
+ id = "summary_plot",+ |
+
| 1220 | +! | +
+ plot_r = summary_plot_r,+ |
+
| 1221 | +! | +
+ height = plot_height,+ |
+
| 1222 | +! | +
+ width = plot_width+ |
+
| 1223 | ++ |
+ )+ |
+
| 1224 | ++ | + + | +
| 1225 | +! | +
+ pws2 <- teal.widgets::plot_with_settings_srv(+ |
+
| 1226 | +! | +
+ id = "combination_plot",+ |
+
| 1227 | +! | +
+ plot_r = combination_plot_r,+ |
+
| 1228 | +! | +
+ height = plot_height,+ |
+
| 1229 | +! | +
+ width = plot_width+ |
+
| 1230 | ++ |
+ )+ |
+
| 1231 | ++ | + + | +
| 1232 | +! | +
+ pws3 <- teal.widgets::plot_with_settings_srv(+ |
+
| 1233 | +! | +
+ id = "by_subject_plot",+ |
+
| 1234 | +! | +
+ plot_r = by_subject_plot_r,+ |
+
| 1235 | +! | +
+ height = plot_height,+ |
+
| 1236 | +! | +
+ width = plot_width+ |
+
| 1237 | ++ |
+ )+ |
+
| 1238 | ++ | + + | +
| 1239 | +! | +
+ final_q <- reactive({
+ |
+
| 1240 | +! | +
+ req(input$summary_type)+ |
+
| 1241 | +! | +
+ sum_type <- input$summary_type+ |
+
| 1242 | +! | +
+ if (sum_type == "Summary") {
+ |
+
| 1243 | +! | +
+ summary_plot_q()+ |
+
| 1244 | +! | +
+ } else if (sum_type == "Combinations") {
+ |
+
| 1245 | +! | +
+ combination_plot_q()+ |
+
| 1246 | +! | +
+ } else if (sum_type == "By Variable Levels") {
+ |
+
| 1247 | +! | +
+ summary_table_q()+ |
+
| 1248 | +! | +
+ } else if (sum_type == "Grouped by Subject") {
+ |
+
| 1249 | +! | +
+ by_subject_plot_q()+ |
+
| 1250 | ++ |
+ }+ |
+
| 1251 | ++ |
+ })+ |
+
| 1252 | ++ | + + | +
| 1253 | +! | +
+ teal.widgets::verbatim_popup_srv(+ |
+
| 1254 | +! | +
+ id = "warning",+ |
+
| 1255 | +! | +
+ verbatim_content = reactive(teal.code::get_warnings(final_q())),+ |
+
| 1256 | +! | +
+ title = "Warning",+ |
+
| 1257 | +! | +
+ disabled = reactive(is.null(teal.code::get_warnings(final_q())))+ |
+
| 1258 | ++ |
+ )+ |
+
| 1259 | ++ | + + | +
| 1260 | +! | +
+ teal.widgets::verbatim_popup_srv(+ |
+
| 1261 | +! | +
+ id = "rcode",+ |
+
| 1262 | +! | +
+ verbatim_content = reactive(teal.code::get_code(final_q())),+ |
+
| 1263 | +! | +
+ title = "Show R Code for Missing Data"+ |
+
| 1264 | ++ |
+ )+ |
+
| 1265 | ++ | + + | +
| 1266 | ++ |
+ ### REPORTER+ |
+
| 1267 | +! | +
+ if (with_reporter) {
+ |
+
| 1268 | +! | +
+ card_fun <- function(comment, label) {
+ |
+
| 1269 | +! | +
+ card <- teal::TealReportCard$new()+ |
+
| 1270 | +! | +
+ sum_type <- input$summary_type+ |
+
| 1271 | +! | +
+ title <- if (sum_type == "By Variable Levels") paste0(sum_type, " Table") else paste0(sum_type, " Plot")+ |
+
| 1272 | +! | +
+ title_dataname <- paste(title, dataname, sep = " - ")+ |
+
| 1273 | +! | +
+ label <- if (label == "") {
+ |
+
| 1274 | +! | +
+ paste("Missing Data", sum_type, dataname, sep = " - ")
+ |
+
| 1275 | ++ |
+ } else {
+ |
+
| 1276 | +! | +
+ label+ |
+
| 1277 | ++ |
+ }+ |
+
| 1278 | +! | +
+ card$set_name(label)+ |
+
| 1279 | +! | +
+ card$append_text(title_dataname, "header2")+ |
+
| 1280 | +! | +
+ if (with_filter) card$append_fs(filter_panel_api$get_filter_state())+ |
+
| 1281 | +! | +
+ if (sum_type == "Summary") {
+ |
+
| 1282 | +! | +
+ card$append_text("Plot", "header3")
+ |
+
| 1283 | +! | +
+ card$append_plot(summary_plot_r(), dim = pws1$dim())+ |
+
| 1284 | +! | +
+ } else if (sum_type == "Combinations") {
+ |
+
| 1285 | +! | +
+ card$append_text("Plot", "header3")
+ |
+
| 1286 | +! | +
+ card$append_plot(combination_plot_r(), dim = pws2$dim())+ |
+
| 1287 | +! | +
+ } else if (sum_type == "By Variable Levels") {
+ |
+
| 1288 | +! | +
+ card$append_text("Table", "header3")
+ |
+
| 1289 | +! | +
+ card$append_table(summary_table_r[["summary_data"]])+ |
+
| 1290 | +! | +
+ } else if (sum_type == "Grouped by Subject") {
+ |
+
| 1291 | +! | +
+ card$append_text("Plot", "header3")
+ |
+
| 1292 | +! | +
+ card$append_plot(by_subject_plot_r(), dim = pws3$dim())+ |
+
| 1293 | ++ |
+ }+ |
+
| 1294 | +! | +
+ if (!comment == "") {
+ |
+
| 1295 | +! | +
+ card$append_text("Comment", "header3")
+ |
+
| 1296 | +! | +
+ card$append_text(comment)+ |
+
| 1297 | ++ |
+ }+ |
+
| 1298 | +! | +
+ card$append_src(teal.code::get_code(final_q()))+ |
+
| 1299 | +! | +
+ card+ |
+
| 1300 | ++ |
+ }+ |
+
| 1301 | +! | +
+ teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
+ |
+
| 1302 | ++ |
+ }+ |
+
| 1303 | ++ |
+ ###+ |
+
| 1304 | ++ |
+ })+ |
+
| 1305 | ++ |
+ }+ |
+
| 1 | ++ |
+ #' `teal` module: Outliers analysis+ |
+
| 2 | ++ |
+ #'+ |
+
| 3 | ++ |
+ #' Module to analyze and identify outliers using different methods+ |
+
| 4 | ++ |
+ #' such as IQR, Z-score, and Percentiles, and offers visualizations including+ |
+
| 5 | ++ |
+ #' box plots, density plots, and cumulative distribution plots to help interpret the outliers.+ |
+
| 6 | ++ |
+ #'+ |
+
| 7 | ++ |
+ #' @inheritParams teal::module+ |
+
| 8 | ++ |
+ #' @inheritParams shared_params+ |
+
| 9 | ++ |
+ #'+ |
+
| 10 | ++ |
+ #' @param outlier_var (`data_extract_spec` or `list` of multiple `data_extract_spec`)+ |
+
| 11 | ++ |
+ #' Specifies variable(s) to be analyzed for outliers.+ |
+
| 12 | ++ |
+ #' @param categorical_var (`data_extract_spec` or `list` of multiple `data_extract_spec`) optional,+ |
+
| 13 | ++ |
+ #' specifies the categorical variable(s) to split the selected outlier variables on.+ |
+
| 14 | ++ |
+ #'+ |
+
| 15 | ++ |
+ #' @templateVar ggnames "Boxplot","Density Plot","Cumulative Distribution Plot"+ |
+
| 16 | ++ |
+ #' @template ggplot2_args_multi+ |
+
| 17 | ++ |
+ #'+ |
+
| 18 | ++ |
+ #' @inherit shared_params return+ |
+
| 19 | ++ |
+ #'+ |
+
| 20 | ++ |
+ #' @examples+ |
+
| 21 | ++ |
+ #' library(teal.widgets)+ |
+
| 22 | ++ |
+ #'+ |
+
| 23 | ++ |
+ #' # general data example+ |
+
| 24 | ++ |
+ #' data <- teal_data()+ |
+
| 25 | ++ |
+ #' data <- within(data, {
+ |
+
| 26 | ++ |
+ #' CO2 <- CO2+ |
+
| 27 | ++ |
+ #' CO2[["primary_key"]] <- seq_len(nrow(CO2))+ |
+
| 28 | ++ |
+ #' })+ |
+
| 29 | ++ |
+ #' datanames(data) <- "CO2"+ |
+
| 30 | ++ |
+ #' join_keys(data) <- join_keys(join_key("CO2", "CO2", "primary_key"))
+ |
+
| 31 | ++ |
+ #'+ |
+
| 32 | ++ |
+ #' vars <- choices_selected(variable_choices(data[["CO2"]], c("Plant", "Type", "Treatment")))
+ |
+
| 33 | ++ |
+ #'+ |
+
| 34 | ++ |
+ #' app <- init(+ |
+
| 35 | ++ |
+ #' data = data,+ |
+
| 36 | ++ |
+ #' modules = modules(+ |
+
| 37 | ++ |
+ #' tm_outliers(+ |
+
| 38 | ++ |
+ #' outlier_var = list(+ |
+
| 39 | ++ |
+ #' data_extract_spec(+ |
+
| 40 | ++ |
+ #' dataname = "CO2",+ |
+
| 41 | ++ |
+ #' select = select_spec(+ |
+
| 42 | ++ |
+ #' label = "Select variable:",+ |
+
| 43 | ++ |
+ #' choices = variable_choices(data[["CO2"]], c("conc", "uptake")),
+ |
+
| 44 | ++ |
+ #' selected = "uptake",+ |
+
| 45 | ++ |
+ #' multiple = FALSE,+ |
+
| 46 | ++ |
+ #' fixed = FALSE+ |
+
| 47 | ++ |
+ #' )+ |
+
| 48 | ++ |
+ #' )+ |
+
| 49 | ++ |
+ #' ),+ |
+
| 50 | ++ |
+ #' categorical_var = list(+ |
+
| 51 | ++ |
+ #' data_extract_spec(+ |
+
| 52 | ++ |
+ #' dataname = "CO2",+ |
+
| 53 | ++ |
+ #' filter = filter_spec(+ |
+
| 54 | ++ |
+ #' vars = vars,+ |
+
| 55 | ++ |
+ #' choices = value_choices(data[["CO2"]], vars$selected),+ |
+
| 56 | ++ |
+ #' selected = value_choices(data[["CO2"]], vars$selected),+ |
+
| 57 | ++ |
+ #' multiple = TRUE+ |
+
| 58 | ++ |
+ #' )+ |
+
| 59 | ++ |
+ #' )+ |
+
| 60 | ++ |
+ #' ),+ |
+
| 61 | ++ |
+ #' ggplot2_args = list(+ |
+
| 62 | ++ |
+ #' ggplot2_args(+ |
+
| 63 | ++ |
+ #' labs = list(subtitle = "Plot generated by Outliers Module")+ |
+
| 64 | ++ |
+ #' )+ |
+
| 65 | ++ |
+ #' )+ |
+
| 66 | ++ |
+ #' )+ |
+
| 67 | ++ |
+ #' )+ |
+
| 68 | ++ |
+ #' )+ |
+
| 69 | ++ |
+ #' if (interactive()) {
+ |
+
| 70 | ++ |
+ #' shinyApp(app$ui, app$server)+ |
+
| 71 | ++ |
+ #' }+ |
+
| 72 | ++ |
+ #'+ |
+
| 73 | ++ |
+ #' # CDISC data example+ |
+
| 74 | ++ |
+ #' data <- teal_data()+ |
+
| 75 | ++ |
+ #' data <- within(data, {
+ |
+
| 76 | ++ |
+ #' ADSL <- rADSL+ |
+
| 77 | ++ |
+ #' })+ |
+
| 78 | ++ |
+ #' datanames(data) <- "ADSL"+ |
+
| 79 | ++ |
+ #' join_keys(data) <- default_cdisc_join_keys[datanames(data)]+ |
+
| 80 | ++ |
+ #'+ |
+
| 81 | ++ |
+ #' fact_vars_adsl <- names(Filter(isTRUE, sapply(data[["ADSL"]], is.factor)))+ |
+
| 82 | ++ |
+ #' vars <- choices_selected(variable_choices(data[["ADSL"]], fact_vars_adsl))+ |
+
| 83 | ++ |
+ #'+ |
+
| 84 | ++ |
+ #' app <- init(+ |
+
| 85 | ++ |
+ #' data = data,+ |
+
| 86 | ++ |
+ #' modules = modules(+ |
+
| 87 | ++ |
+ #' tm_outliers(+ |
+
| 88 | ++ |
+ #' outlier_var = list(+ |
+
| 89 | ++ |
+ #' data_extract_spec(+ |
+
| 90 | ++ |
+ #' dataname = "ADSL",+ |
+
| 91 | ++ |
+ #' select = select_spec(+ |
+
| 92 | ++ |
+ #' label = "Select variable:",+ |
+
| 93 | ++ |
+ #' choices = variable_choices(data[["ADSL"]], c("AGE", "BMRKR1")),
+ |
+
| 94 | ++ |
+ #' selected = "AGE",+ |
+
| 95 | ++ |
+ #' multiple = FALSE,+ |
+
| 96 | ++ |
+ #' fixed = FALSE+ |
+
| 97 | ++ |
+ #' )+ |
+
| 98 | ++ |
+ #' )+ |
+
| 99 | ++ |
+ #' ),+ |
+
| 100 | ++ |
+ #' categorical_var = list(+ |
+
| 101 | ++ |
+ #' data_extract_spec(+ |
+
| 102 | ++ |
+ #' dataname = "ADSL",+ |
+
| 103 | ++ |
+ #' filter = filter_spec(+ |
+
| 104 | ++ |
+ #' vars = vars,+ |
+
| 105 | ++ |
+ #' choices = value_choices(data[["ADSL"]], vars$selected),+ |
+
| 106 | ++ |
+ #' selected = value_choices(data[["ADSL"]], vars$selected),+ |
+
| 107 | ++ |
+ #' multiple = TRUE+ |
+
| 108 | ++ |
+ #' )+ |
+
| 109 | ++ |
+ #' )+ |
+
| 110 | ++ |
+ #' ),+ |
+
| 111 | ++ |
+ #' ggplot2_args = list(+ |
+
| 112 | ++ |
+ #' ggplot2_args(+ |
+
| 113 | ++ |
+ #' labs = list(subtitle = "Plot generated by Outliers Module")+ |
+
| 114 | ++ |
+ #' )+ |
+
| 115 | ++ |
+ #' )+ |
+
| 116 | ++ |
+ #' )+ |
+
| 117 | ++ |
+ #' )+ |
+
| 118 | ++ |
+ #' )+ |
+
| 119 | ++ |
+ #' if (interactive()) {
+ |
+
| 120 | ++ |
+ #' shinyApp(app$ui, app$server)+ |
+
| 121 | ++ |
+ #' }+ |
+
| 122 | ++ |
+ #'+ |
+
| 123 | ++ |
+ #' @export+ |
+
| 124 | ++ |
+ #'+ |
+
| 125 | ++ |
+ tm_outliers <- function(label = "Outliers Module",+ |
+
| 126 | ++ |
+ outlier_var,+ |
+
| 127 | ++ |
+ categorical_var = NULL,+ |
+
| 128 | ++ |
+ ggtheme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void"),
+ |
+
| 129 | ++ |
+ ggplot2_args = teal.widgets::ggplot2_args(),+ |
+
| 130 | ++ |
+ plot_height = c(600, 200, 2000),+ |
+
| 131 | ++ |
+ plot_width = NULL,+ |
+
| 132 | ++ |
+ pre_output = NULL,+ |
+
| 133 | ++ |
+ post_output = NULL) {
+ |
+
| 134 | +! | +
+ logger::log_info("Initializing tm_outliers")
+ |
+
| 135 | ++ | + + | +
| 136 | ++ |
+ # Normalize the parameters+ |
+
| 137 | +! | +
+ if (inherits(outlier_var, "data_extract_spec")) outlier_var <- list(outlier_var)+ |
+
| 138 | +! | +
+ if (inherits(categorical_var, "data_extract_spec")) categorical_var <- list(categorical_var)+ |
+
| 139 | +! | +
+ if (inherits(ggplot2_args, "ggplot2_args")) ggplot2_args <- list(default = ggplot2_args)+ |
+
| 140 | ++ | + + | +
| 141 | ++ |
+ # Start of assertions+ |
+
| 142 | +! | +
+ checkmate::assert_string(label)+ |
+
| 143 | +! | +
+ checkmate::assert_list(outlier_var, types = "data_extract_spec")+ |
+
| 144 | ++ | + + | +
| 145 | +! | +
+ checkmate::assert_list(categorical_var, types = "data_extract_spec", null.ok = TRUE)+ |
+
| 146 | +! | +
+ if (is.list(categorical_var)) {
+ |
+
| 147 | +! | +
+ lapply(categorical_var, function(x) {
+ |
+
| 148 | +! | +
+ if (length(x$filter) > 1L) {
+ |
+
| 149 | +! | +
+ stop("tm_outliers: categorical_var data_extract_specs may only specify one filter_spec", call. = FALSE)
+ |
+
| 150 | ++ |
+ }+ |
+
| 151 | ++ |
+ })+ |
+
| 152 | ++ |
+ }+ |
+
| 153 | ++ | + + | +
| 154 | +! | +
+ ggtheme <- match.arg(ggtheme)+ |
+
| 155 | ++ | + + | +
| 156 | +! | +
+ plot_choices <- c("Boxplot", "Density Plot", "Cumulative Distribution Plot")
+ |
+
| 157 | +! | +
+ checkmate::assert_list(ggplot2_args, types = "ggplot2_args")+ |
+
| 158 | +! | +
+ checkmate::assert_subset(names(ggplot2_args), c("default", plot_choices))
+ |
+
| 159 | ++ | + + | +
| 160 | +! | +
+ checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE)+ |
+
| 161 | +! | +
+ checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height")+ |
+
| 162 | +! | +
+ checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE)+ |
+
| 163 | +! | +
+ checkmate::assert_numeric(+ |
+
| 164 | +! | +
+ plot_width[1],+ |
+
| 165 | +! | +
+ lower = plot_width[2], upper = plot_width[3], null.ok = TRUE, .var.name = "plot_width"+ |
+
| 166 | ++ |
+ )+ |
+
| 167 | ++ | + + | +
| 168 | +! | +
+ checkmate::assert_multi_class(pre_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
+ |
+
| 169 | +! | +
+ checkmate::assert_multi_class(post_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
+ |
+
| 170 | ++ |
+ # End of assertions+ |
+
| 171 | ++ | + + | +
| 172 | ++ |
+ # Make UI args+ |
+
| 173 | +! | +
+ args <- as.list(environment())+ |
+
| 174 | ++ | + + | +
| 175 | +! | +
+ data_extract_list <- list(+ |
+
| 176 | +! | +
+ outlier_var = outlier_var,+ |
+
| 177 | +! | +
+ categorical_var = categorical_var+ |
+
| 178 | ++ |
+ )+ |
+
| 179 | ++ | + + | +
| 180 | +! | +
+ module(+ |
+
| 181 | +! | +
+ label = label,+ |
+
| 182 | +! | +
+ server = srv_outliers,+ |
+
| 183 | +! | +
+ server_args = c(+ |
+
| 184 | +! | +
+ data_extract_list,+ |
+
| 185 | +! | +
+ list(plot_height = plot_height, plot_width = plot_width, ggplot2_args = ggplot2_args)+ |
+
| 186 | ++ |
+ ),+ |
+
| 187 | +! | +
+ ui = ui_outliers,+ |
+
| 188 | +! | +
+ ui_args = args,+ |
+
| 189 | +! | +
+ datanames = teal.transform::get_extract_datanames(data_extract_list)+ |
+
| 190 | ++ |
+ )+ |
+
| 191 | ++ |
+ }+ |
+
| 192 | ++ | + + | +
| 193 | ++ |
+ # UI function for the outliers module+ |
+
| 194 | ++ |
+ ui_outliers <- function(id, ...) {
+ |
+
| 195 | +! | +
+ args <- list(...)+ |
+
| 196 | +! | +
+ ns <- NS(id)+ |
+
| 197 | +! | +
+ is_single_dataset_value <- teal.transform::is_single_dataset(args$outlier_var, args$categorical_var)+ |
+
| 198 | ++ | + + | +
| 199 | +! | +
+ teal.widgets::standard_layout(+ |
+
| 200 | +! | +
+ output = teal.widgets::white_small_well(+ |
+
| 201 | +! | +
+ uiOutput(ns("total_outliers")),
+ |
+
| 202 | +! | +
+ DT::dataTableOutput(ns("summary_table")),
+ |
+
| 203 | +! | +
+ uiOutput(ns("total_missing")),
+ |
+
| 204 | +! | +
+ br(), hr(),+ |
+
| 205 | +! | +
+ tabsetPanel(+ |
+
| 206 | +! | +
+ id = ns("tabs"),
+ |
+
| 207 | +! | +
+ tabPanel(+ |
+
| 208 | +! | +
+ "Boxplot",+ |
+
| 209 | +! | +
+ teal.widgets::plot_with_settings_ui(id = ns("box_plot"))
+ |
+
| 210 | ++ |
+ ),+ |
+
| 211 | +! | +
+ tabPanel(+ |
+
| 212 | +! | +
+ "Density Plot",+ |
+
| 213 | +! | +
+ teal.widgets::plot_with_settings_ui(id = ns("density_plot"))
+ |
+
| 214 | ++ |
+ ),+ |
+
| 215 | +! | +
+ tabPanel(+ |
+
| 216 | +! | +
+ "Cumulative Distribution Plot",+ |
+
| 217 | +! | +
+ teal.widgets::plot_with_settings_ui(id = ns("cum_density_plot"))
+ |
+
| 218 | ++ |
+ )+ |
+
| 219 | ++ |
+ ),+ |
+
| 220 | +! | +
+ br(), hr(),+ |
+
| 221 | +! | +
+ uiOutput(ns("table_ui_wrap")),
+ |
+
| 222 | +! | +
+ DT::dataTableOutput(ns("table_ui"))
+ |
+
| 223 | ++ |
+ ),+ |
+
| 224 | +! | +
+ encoding = div(+ |
+
| 225 | ++ |
+ ### Reporter+ |
+
| 226 | +! | +
+ teal.reporter::simple_reporter_ui(ns("simple_reporter")),
+ |
+
| 227 | ++ |
+ ###+ |
+
| 228 | +! | +
+ tags$label("Encodings", class = "text-primary"),
+ |
+
| 229 | +! | +
+ teal.transform::datanames_input(args[c("outlier_var", "categorical_var")]),
+ |
+
| 230 | +! | +
+ teal.transform::data_extract_ui(+ |
+
| 231 | +! | +
+ id = ns("outlier_var"),
+ |
+
| 232 | +! | +
+ label = "Variable",+ |
+
| 233 | +! | +
+ data_extract_spec = args$outlier_var,+ |
+
| 234 | +! | +
+ is_single_dataset = is_single_dataset_value+ |
+
| 235 | ++ |
+ ),+ |
+
| 236 | +! | +
+ if (!is.null(args$categorical_var)) {
+ |
+
| 237 | +! | +
+ teal.transform::data_extract_ui(+ |
+
| 238 | +! | +
+ id = ns("categorical_var"),
+ |
+
| 239 | +! | +
+ label = "Categorical factor",+ |
+
| 240 | +! | +
+ data_extract_spec = args$categorical_var,+ |
+
| 241 | +! | +
+ is_single_dataset = is_single_dataset_value+ |
+
| 242 | ++ |
+ )+ |
+
| 243 | ++ |
+ },+ |
+
| 244 | +! | +
+ conditionalPanel(+ |
+
| 245 | +! | +
+ condition = paste0("input['", ns("tabs"), "'] == 'Boxplot'"),
+ |
+
| 246 | +! | +
+ teal.widgets::optionalSelectInput(+ |
+
| 247 | +! | +
+ inputId = ns("boxplot_alts"),
+ |
+
| 248 | +! | +
+ label = "Plot type",+ |
+
| 249 | +! | +
+ choices = c("Box plot", "Violin plot"),
+ |
+
| 250 | +! | +
+ selected = "Box plot",+ |
+
| 251 | +! | +
+ multiple = FALSE+ |
+
| 252 | ++ |
+ )+ |
+
| 253 | ++ |
+ ),+ |
+
| 254 | +! | +
+ shinyjs::hidden(checkboxInput(ns("split_outliers"), "Define outliers based on group splitting", value = FALSE)),
+ |
+
| 255 | +! | +
+ shinyjs::hidden(checkboxInput(ns("order_by_outlier"), "Re-order categories by outliers [by %]", value = FALSE)),
+ |
+
| 256 | +! | +
+ teal.widgets::panel_group(+ |
+
| 257 | +! | +
+ teal.widgets::panel_item(+ |
+
| 258 | +! | +
+ title = "Method parameters",+ |
+
| 259 | +! | +
+ collapsed = FALSE,+ |
+
| 260 | +! | +
+ teal.widgets::optionalSelectInput(+ |
+
| 261 | +! | +
+ inputId = ns("method"),
+ |
+
| 262 | +! | +
+ label = "Method",+ |
+
| 263 | +! | +
+ choices = c("IQR", "Z-score", "Percentile"),
+ |
+
| 264 | +! | +
+ selected = "IQR",+ |
+
| 265 | +! | +
+ multiple = FALSE+ |
+
| 266 | ++ |
+ ),+ |
+
| 267 | +! | +
+ conditionalPanel(+ |
+
| 268 | +! | +
+ condition =+ |
+
| 269 | +! | +
+ paste0("input['", ns("method"), "'] == 'IQR'"),
+ |
+
| 270 | +! | +
+ sliderInput(+ |
+
| 271 | +! | +
+ ns("iqr_slider"),
+ |
+
| 272 | +! | +
+ "Outlier range:",+ |
+
| 273 | +! | +
+ min = 1,+ |
+
| 274 | +! | +
+ max = 5,+ |
+
| 275 | +! | +
+ value = 3,+ |
+
| 276 | +! | +
+ step = 0.5+ |
+
| 277 | ++ |
+ )+ |
+
| 278 | ++ |
+ ),+ |
+
| 279 | +! | +
+ conditionalPanel(+ |
+
| 280 | +! | +
+ condition =+ |
+
| 281 | +! | +
+ paste0("input['", ns("method"), "'] == 'Z-score'"),
+ |
+
| 282 | +! | +
+ sliderInput(+ |
+
| 283 | +! | +
+ ns("zscore_slider"),
+ |
+
| 284 | +! | +
+ "Outlier range:",+ |
+
| 285 | +! | +
+ min = 1,+ |
+
| 286 | +! | +
+ max = 5,+ |
+
| 287 | +! | +
+ value = 3,+ |
+
| 288 | +! | +
+ step = 0.5+ |
+
| 289 | ++ |
+ )+ |
+
| 290 | ++ |
+ ),+ |
+
| 291 | +! | +
+ conditionalPanel(+ |
+
| 292 | +! | +
+ condition =+ |
+
| 293 | +! | +
+ paste0("input['", ns("method"), "'] == 'Percentile'"),
+ |
+
| 294 | +! | +
+ sliderInput(+ |
+
| 295 | +! | +
+ ns("percentile_slider"),
+ |
+
| 296 | +! | +
+ "Outlier range:",+ |
+
| 297 | +! | +
+ min = 0.001,+ |
+
| 298 | +! | +
+ max = 0.5,+ |
+
| 299 | +! | +
+ value = 0.01,+ |
+
| 300 | +! | +
+ step = 0.001+ |
+
| 301 | ++ |
+ )+ |
+
| 302 | ++ |
+ ),+ |
+
| 303 | +! | +
+ uiOutput(ns("ui_outlier_help"))
+ |
+
| 304 | ++ |
+ )+ |
+
| 305 | ++ |
+ ),+ |
+
| 306 | +! | +
+ teal.widgets::panel_item(+ |
+
| 307 | +! | +
+ title = "Plot settings",+ |
+
| 308 | +! | +
+ selectInput(+ |
+
| 309 | +! | +
+ inputId = ns("ggtheme"),
+ |
+
| 310 | +! | +
+ label = "Theme (by ggplot):",+ |
+
| 311 | +! | +
+ choices = ggplot_themes,+ |
+
| 312 | +! | +
+ selected = args$ggtheme,+ |
+
| 313 | +! | +
+ multiple = FALSE+ |
+
| 314 | ++ |
+ )+ |
+
| 315 | ++ |
+ )+ |
+
| 316 | ++ |
+ ),+ |
+
| 317 | +! | +
+ forms = tagList(+ |
+
| 318 | +! | +
+ teal.widgets::verbatim_popup_ui(ns("warning"), "Show Warnings"),
+ |
+
| 319 | +! | +
+ teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code")
+ |
+
| 320 | ++ |
+ ),+ |
+
| 321 | +! | +
+ pre_output = args$pre_output,+ |
+
| 322 | +! | +
+ post_output = args$post_output+ |
+
| 323 | ++ |
+ )+ |
+
| 324 | ++ |
+ }+ |
+
| 325 | ++ | + + | +
| 326 | ++ |
+ # Server function for the outliers module+ |
+
| 327 | ++ |
+ srv_outliers <- function(id, data, reporter, filter_panel_api, outlier_var,+ |
+
| 328 | ++ |
+ categorical_var, plot_height, plot_width, ggplot2_args) {
+ |
+
| 329 | +! | +
+ with_reporter <- !missing(reporter) && inherits(reporter, "Reporter")+ |
+
| 330 | +! | +
+ with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI")+ |
+
| 331 | +! | +
+ checkmate::assert_class(data, "reactive")+ |
+
| 332 | +! | +
+ checkmate::assert_class(isolate(data()), "teal_data")+ |
+
| 333 | +! | +
+ moduleServer(id, function(input, output, session) {
+ |
+
| 334 | +! | +
+ vars <- list(outlier_var = outlier_var, categorical_var = categorical_var)+ |
+
| 335 | ++ | + + | +
| 336 | +! | +
+ rule_diff <- function(other) {
+ |
+
| 337 | +! | +
+ function(value) {
+ |
+
| 338 | +! | +
+ othervalue <- tryCatch(selector_list()[[other]]()[["select"]], error = function(e) NULL)+ |
+
| 339 | +! | +
+ if (!is.null(othervalue) && identical(othervalue, value)) {
+ |
+
| 340 | +! | +
+ "`Variable` and `Categorical factor` cannot be the same"+ |
+
| 341 | ++ |
+ }+ |
+
| 342 | ++ |
+ }+ |
+
| 343 | ++ |
+ }+ |
+
| 344 | ++ | + + | +
| 345 | +! | +
+ selector_list <- teal.transform::data_extract_multiple_srv(+ |
+
| 346 | +! | +
+ data_extract = vars,+ |
+
| 347 | +! | +
+ datasets = data,+ |
+
| 348 | +! | +
+ select_validation_rule = list(+ |
+
| 349 | +! | +
+ outlier_var = shinyvalidate::compose_rules(+ |
+
| 350 | +! | +
+ shinyvalidate::sv_required("Please select a variable"),
+ |
+
| 351 | +! | +
+ rule_diff("categorical_var")
+ |
+
| 352 | ++ |
+ ),+ |
+
| 353 | +! | +
+ categorical_var = rule_diff("outlier_var")
+ |
+
| 354 | ++ |
+ )+ |
+
| 355 | ++ |
+ )+ |
+
| 356 | ++ | + + | +
| 357 | +! | +
+ iv_r <- reactive({
+ |
+
| 358 | +! | +
+ iv <- shinyvalidate::InputValidator$new()+ |
+
| 359 | +! | +
+ iv$add_rule("method", shinyvalidate::sv_required("Please select a method"))
+ |
+
| 360 | +! | +
+ iv$add_rule("boxplot_alts", shinyvalidate::sv_required("Please select Plot Type"))
+ |
+
| 361 | +! | +
+ teal.transform::compose_and_enable_validators(iv, selector_list)+ |
+
| 362 | ++ |
+ })+ |
+
| 363 | ++ | + + | +
| 364 | +! | +
+ reactive_select_input <- reactive({
+ |
+
| 365 | +! | +
+ if (is.null(selector_list()$categorical_var) || length(selector_list()$categorical_var()$select) == 0) {
+ |
+
| 366 | +! | +
+ selector_list()[names(selector_list()) != "categorical_var"]+ |
+
| 367 | ++ |
+ } else {
+ |
+
| 368 | +! | +
+ selector_list()+ |
+
| 369 | ++ |
+ }+ |
+
| 370 | ++ |
+ })+ |
+
| 371 | ++ | + + | +
| 372 | +! | +
+ anl_merged_input <- teal.transform::merge_expression_srv(+ |
+
| 373 | +! | +
+ selector_list = reactive_select_input,+ |
+
| 374 | +! | +
+ datasets = data,+ |
+
| 375 | +! | +
+ merge_function = "dplyr::inner_join"+ |
+
| 376 | ++ |
+ )+ |
+
| 377 | ++ | + + | +
| 378 | +! | +
+ anl_merged_q <- reactive({
+ |
+
| 379 | +! | +
+ req(anl_merged_input())+ |
+
| 380 | +! | +
+ data() %>%+ |
+
| 381 | +! | +
+ teal.code::eval_code(as.expression(anl_merged_input()$expr))+ |
+
| 382 | ++ |
+ })+ |
+
| 383 | ++ | + + | +
| 384 | +! | +
+ merged <- list(+ |
+
| 385 | +! | +
+ anl_input_r = anl_merged_input,+ |
+
| 386 | +! | +
+ anl_q_r = anl_merged_q+ |
+
| 387 | ++ |
+ )+ |
+
| 388 | ++ | + + | +
| 389 | +! | +
+ n_outlier_missing <- reactive({
+ |
+
| 390 | +! | +
+ shiny::req(iv_r()$is_valid())+ |
+
| 391 | +! | +
+ outlier_var <- as.vector(merged$anl_input_r()$columns_source$outlier_var)+ |
+
| 392 | +! | +
+ ANL <- merged$anl_q_r()[["ANL"]]+ |
+
| 393 | +! | +
+ sum(is.na(ANL[[outlier_var]]))+ |
+
| 394 | ++ |
+ })+ |
+
| 395 | ++ | + + | +
| 396 | ++ |
+ # Used to create outlier table and the dropdown with additional columns+ |
+
| 397 | +! | +
+ dataname_first <- isolate(teal.data::datanames(data())[[1]])+ |
+
| 398 | ++ | + + | +
| 399 | +! | +
+ common_code_q <- reactive({
+ |
+
| 400 | +! | +
+ shiny::req(iv_r()$is_valid())+ |
+
| 401 | ++ | + + | +
| 402 | +! | +
+ ANL <- merged$anl_q_r()[["ANL"]]+ |
+
| 403 | +! | +
+ qenv <- merged$anl_q_r()+ |
+
| 404 | ++ | + + | +
| 405 | +! | +
+ outlier_var <- as.vector(merged$anl_input_r()$columns_source$outlier_var)+ |
+
| 406 | +! | +
+ categorical_var <- as.vector(merged$anl_input_r()$columns_source$categorical_var)+ |
+
| 407 | +! | +
+ order_by_outlier <- input$order_by_outlier+ |
+
| 408 | +! | +
+ method <- input$method+ |
+
| 409 | +! | +
+ split_outliers <- input$split_outliers+ |
+
| 410 | +! | +
+ teal::validate_has_data(+ |
+
| 411 | ++ |
+ # missing values in the categorical variable may be used to form a category of its own+ |
+
| 412 | +! | +
+ `if`(+ |
+
| 413 | +! | +
+ length(categorical_var) == 0,+ |
+
| 414 | +! | +
+ ANL,+ |
+
| 415 | +! | +
+ ANL[, names(ANL) != categorical_var, drop = FALSE]+ |
+
| 416 | ++ |
+ ),+ |
+
| 417 | +! | +
+ min_nrow = 10,+ |
+
| 418 | +! | +
+ complete = TRUE,+ |
+
| 419 | +! | +
+ allow_inf = FALSE+ |
+
| 420 | ++ |
+ )+ |
+
| 421 | +! | +
+ validate(need(is.numeric(ANL[[outlier_var]]), "`Variable` is not numeric"))+ |
+
| 422 | +! | +
+ validate(need(length(unique(ANL[[outlier_var]])) > 1, "Variable has no variation, i.e. only one unique value"))+ |
+
| 423 | ++ | + + | +
| 424 | ++ |
+ # show/hide split_outliers+ |
+
| 425 | +! | +
+ if (length(categorical_var) == 0) {
+ |
+
| 426 | +! | +
+ shinyjs::hide("split_outliers")
+ |
+
| 427 | +! | +
+ if (n_outlier_missing() > 0) {
+ |
+
| 428 | +! | +
+ qenv <- teal.code::eval_code(+ |
+
| 429 | +! | +
+ qenv,+ |
+
| 430 | +! | +
+ substitute(+ |
+
| 431 | +! | +
+ expr = ANL <- ANL %>% dplyr::filter(!is.na(outlier_var_name)),+ |
+
| 432 | +! | +
+ env = list(outlier_var_name = as.name(outlier_var))+ |
+
| 433 | ++ |
+ )+ |
+
| 434 | ++ |
+ )+ |
+
| 435 | ++ |
+ }+ |
+
| 436 | ++ |
+ } else {
+ |
+
| 437 | +! | +
+ validate(need(+ |
+
| 438 | +! | +
+ is.factor(ANL[[categorical_var]]) ||+ |
+
| 439 | +! | +
+ is.character(ANL[[categorical_var]]) ||+ |
+
| 440 | +! | +
+ is.integer(ANL[[categorical_var]]),+ |
+
| 441 | +! | +
+ "`Categorical factor` must be `factor`, `character`, or `integer`"+ |
+
| 442 | ++ |
+ ))+ |
+
| 443 | ++ | + + | +
| 444 | +! | +
+ if (n_outlier_missing() > 0) {
+ |
+
| 445 | +! | +
+ qenv <- teal.code::eval_code(+ |
+
| 446 | +! | +
+ qenv,+ |
+
| 447 | +! | +
+ substitute(+ |
+
| 448 | +! | +
+ expr = ANL <- ANL %>% dplyr::filter(!is.na(outlier_var_name)),+ |
+
| 449 | +! | +
+ env = list(outlier_var_name = as.name(outlier_var))+ |
+
| 450 | ++ |
+ )+ |
+
| 451 | ++ |
+ )+ |
+
| 452 | ++ |
+ }+ |
+
| 453 | +! | +
+ shinyjs::show("split_outliers")
+ |
+
| 454 | ++ |
+ }+ |
+
| 455 | ++ | + + | +
| 456 | ++ |
+ # slider+ |
+
| 457 | +! | +
+ outlier_definition_param <- if (method == "IQR") {
+ |
+
| 458 | +! | +
+ input$iqr_slider+ |
+
| 459 | +! | +
+ } else if (method == "Z-score") {
+ |
+
| 460 | +! | +
+ input$zscore_slider+ |
+
| 461 | +! | +
+ } else if (method == "Percentile") {
+ |
+
| 462 | +! | +
+ input$percentile_slider+ |
+
| 463 | ++ |
+ }+ |
+
| 464 | ++ | + + | +
| 465 | ++ |
+ # this is utils function that converts a %>% NULL %>% b into a %>% b+ |
+
| 466 | +! | +
+ remove_pipe_null <- function(x) {
+ |
+
| 467 | +! | +
+ if (length(x) == 1) {
+ |
+
| 468 | +! | +
+ return(x)+ |
+
| 469 | ++ |
+ }+ |
+
| 470 | +! | +
+ if (identical(x[[1]], as.name("%>%")) && is.null(x[[3]])) {
+ |
+
| 471 | +! | +
+ return(remove_pipe_null(x[[2]]))+ |
+
| 472 | ++ |
+ }+ |
+
| 473 | +! | +
+ return(as.call(c(x[[1]], lapply(x[-1], remove_pipe_null))))+ |
+
| 474 | ++ |
+ }+ |
+
| 475 | ++ | + + | +
| 476 | +! | +
+ qenv <- teal.code::eval_code(+ |
+
| 477 | +! | +
+ qenv,+ |
+
| 478 | +! | +
+ substitute(+ |
+
| 479 | +! | +
+ expr = {
+ |
+
| 480 | +! | +
+ ANL_OUTLIER <- ANL %>%+ |
+
| 481 | +! | +
+ group_expr %>% # styler: off+ |
+
| 482 | +! | +
+ dplyr::mutate(is_outlier = {
+ |
+
| 483 | +! | +
+ q1_q3 <- stats::quantile(outlier_var_name, probs = c(0.25, 0.75))+ |
+
| 484 | +! | +
+ iqr <- q1_q3[2] - q1_q3[1]+ |
+
| 485 | +! | +
+ !(outlier_var_name >= q1_q3[1] - 1.5 * iqr & outlier_var_name <= q1_q3[2] + 1.5 * iqr)+ |
+
| 486 | ++ |
+ }) %>%+ |
+
| 487 | +! | +
+ calculate_outliers %>% # styler: off+ |
+
| 488 | +! | +
+ ungroup_expr %>% # styler: off+ |
+
| 489 | +! | +
+ dplyr::filter(is_outlier | is_outlier_selected) %>%+ |
+
| 490 | +! | +
+ dplyr::select(-is_outlier)+ |
+
| 491 | ++ |
+ },+ |
+
| 492 | +! | +
+ env = list(+ |
+
| 493 | +! | +
+ calculate_outliers = if (method == "IQR") {
+ |
+
| 494 | +! | +
+ substitute(+ |
+
| 495 | +! | +
+ expr = dplyr::mutate(is_outlier_selected = {
+ |
+
| 496 | +! | +
+ q1_q3 <- stats::quantile(outlier_var_name, probs = c(0.25, 0.75))+ |
+
| 497 | +! | +
+ iqr <- q1_q3[2] - q1_q3[1]+ |
+
| 498 | ++ |
+ !(+ |
+
| 499 | +! | +
+ outlier_var_name >= q1_q3[1] - outlier_definition_param * iqr &+ |
+
| 500 | +! | +
+ outlier_var_name <= q1_q3[2] + outlier_definition_param * iqr+ |
+
| 501 | ++ |
+ )+ |
+
| 502 | ++ |
+ }),+ |
+
| 503 | +! | +
+ env = list(+ |
+
| 504 | +! | +
+ outlier_var_name = as.name(outlier_var),+ |
+
| 505 | +! | +
+ outlier_definition_param = outlier_definition_param+ |
+
| 506 | ++ |
+ )+ |
+
| 507 | ++ |
+ )+ |
+
| 508 | +! | +
+ } else if (method == "Z-score") {
+ |
+
| 509 | +! | +
+ substitute(+ |
+
| 510 | +! | +
+ expr = dplyr::mutate(+ |
+
| 511 | +! | +
+ is_outlier_selected = abs(outlier_var_name - mean(outlier_var_name)) /+ |
+
| 512 | +! | +
+ stats::sd(outlier_var_name) > outlier_definition_param+ |
+
| 513 | ++ |
+ ),+ |
+
| 514 | +! | +
+ env = list(+ |
+
| 515 | +! | +
+ outlier_var_name = as.name(outlier_var),+ |
+
| 516 | +! | +
+ outlier_definition_param = outlier_definition_param+ |
+
| 517 | ++ |
+ )+ |
+
| 518 | ++ |
+ )+ |
+
| 519 | +! | +
+ } else if (method == "Percentile") {
+ |
+
| 520 | +! | +
+ substitute(+ |
+
| 521 | +! | +
+ expr = dplyr::mutate(+ |
+
| 522 | +! | +
+ is_outlier_selected = outlier_var_name < stats::quantile(outlier_var_name, outlier_definition_param) |+ |
+
| 523 | +! | +
+ outlier_var_name > stats::quantile(outlier_var_name, 1 - outlier_definition_param)+ |
+
| 524 | ++ |
+ ),+ |
+
| 525 | +! | +
+ env = list(+ |
+
| 526 | +! | +
+ outlier_var_name = as.name(outlier_var),+ |
+
| 527 | +! | +
+ outlier_definition_param = outlier_definition_param+ |
+
| 528 | ++ |
+ )+ |
+
| 529 | ++ |
+ )+ |
+
| 530 | ++ |
+ },+ |
+
| 531 | +! | +
+ outlier_var_name = as.name(outlier_var),+ |
+
| 532 | +! | +
+ group_expr = if (isTRUE(split_outliers) && length(categorical_var) != 0) {
+ |
+
| 533 | +! | +
+ substitute(dplyr::group_by(x), list(x = as.name(categorical_var)))+ |
+
| 534 | ++ |
+ },+ |
+
| 535 | +! | +
+ ungroup_expr = if (isTRUE(split_outliers) && length(categorical_var) != 0) {
+ |
+
| 536 | +! | +
+ substitute(dplyr::ungroup())+ |
+
| 537 | ++ |
+ }+ |
+
| 538 | ++ |
+ )+ |
+
| 539 | ++ |
+ ) %>%+ |
+
| 540 | +! | +
+ remove_pipe_null()+ |
+
| 541 | ++ |
+ )+ |
+
| 542 | ++ | + + | +
| 543 | ++ |
+ # ANL_OUTLIER_EXTENDED is the base table+ |
+
| 544 | +! | +
+ qenv <- teal.code::eval_code(+ |
+
| 545 | +! | +
+ qenv,+ |
+
| 546 | +! | +
+ substitute(+ |
+
| 547 | +! | +
+ expr = {
+ |
+
| 548 | +! | +
+ ANL_OUTLIER_EXTENDED <- dplyr::left_join(+ |
+
| 549 | +! | +
+ ANL_OUTLIER,+ |
+
| 550 | +! | +
+ dplyr::select(+ |
+
| 551 | +! | +
+ dataname,+ |
+
| 552 | +! | +
+ dplyr::setdiff(names(dataname), dplyr::setdiff(names(ANL_OUTLIER), join_keys))+ |
+
| 553 | ++ |
+ ),+ |
+
| 554 | +! | +
+ by = join_keys+ |
+
| 555 | ++ |
+ )+ |
+
| 556 | ++ |
+ },+ |
+
| 557 | +! | +
+ env = list(+ |
+
| 558 | +! | +
+ dataname = as.name(dataname_first),+ |
+
| 559 | +! | +
+ join_keys = as.character(teal.data::join_keys(data())[dataname_first, dataname_first])+ |
+
| 560 | ++ |
+ )+ |
+
| 561 | ++ |
+ )+ |
+
| 562 | ++ |
+ )+ |
+
| 563 | ++ | + + | +
| 564 | +! | +
+ if (length(categorical_var) > 0) {
+ |
+
| 565 | +! | +
+ qenv <- teal.code::eval_code(+ |
+
| 566 | +! | +
+ qenv,+ |
+
| 567 | +! | +
+ substitute(+ |
+
| 568 | +! | +
+ expr = summary_table_pre <- ANL_OUTLIER %>%+ |
+
| 569 | +! | +
+ dplyr::filter(is_outlier_selected) %>%+ |
+
| 570 | +! | +
+ dplyr::select(outlier_var_name, categorical_var_name) %>%+ |
+
| 571 | +! | +
+ dplyr::group_by(categorical_var_name) %>%+ |
+
| 572 | +! | +
+ dplyr::summarise(n_outliers = dplyr::n()) %>%+ |
+
| 573 | +! | +
+ dplyr::right_join(+ |
+
| 574 | +! | +
+ ANL %>%+ |
+
| 575 | +! | +
+ dplyr::select(outlier_var_name, categorical_var_name) %>%+ |
+
| 576 | +! | +
+ dplyr::group_by(categorical_var_name) %>%+ |
+
| 577 | +! | +
+ dplyr::summarise(+ |
+
| 578 | +! | +
+ total_in_cat = dplyr::n(),+ |
+
| 579 | +! | +
+ n_na = sum(is.na(outlier_var_name) | is.na(categorical_var_name))+ |
+
| 580 | ++ |
+ ),+ |
+
| 581 | +! | +
+ by = categorical_var+ |
+
| 582 | ++ |
+ ) %>%+ |
+
| 583 | ++ |
+ # This is important as there may be categorical variables with natural orderings, e.g. AGE.+ |
+
| 584 | ++ |
+ # The plots should be displayed by default in increasing order in these situations.+ |
+
| 585 | ++ |
+ # dplyr::arrange will sort integer, factor, and character data types in the expected way.+ |
+
| 586 | +! | +
+ dplyr::arrange(categorical_var_name) %>%+ |
+
| 587 | +! | +
+ dplyr::mutate(+ |
+
| 588 | +! | +
+ n_outliers = dplyr::if_else(is.na(n_outliers), 0, as.numeric(n_outliers)),+ |
+
| 589 | +! | +
+ display_str = dplyr::if_else(+ |
+
| 590 | +! | +
+ n_outliers > 0,+ |
+
| 591 | +! | +
+ sprintf("%d [%.02f%%]", n_outliers, 100 * n_outliers / total_in_cat),
+ |
+
| 592 | +! | +
+ "0"+ |
+
| 593 | ++ |
+ ),+ |
+
| 594 | +! | +
+ display_str_na = dplyr::if_else(+ |
+
| 595 | +! | +
+ n_na > 0,+ |
+
| 596 | +! | +
+ sprintf("%d [%.02f%%]", n_na, 100 * n_na / total_in_cat),
+ |
+
| 597 | +! | +
+ "0"+ |
+
| 598 | ++ |
+ ),+ |
+
| 599 | +! | +
+ order = seq_along(n_outliers)+ |
+
| 600 | ++ |
+ ),+ |
+
| 601 | +! | +
+ env = list(+ |
+
| 602 | +! | +
+ categorical_var = categorical_var,+ |
+
| 603 | +! | +
+ categorical_var_name = as.name(categorical_var),+ |
+
| 604 | +! | +
+ outlier_var_name = as.name(outlier_var)+ |
+
| 605 | ++ |
+ )+ |
+
| 606 | ++ |
+ )+ |
+
| 607 | ++ |
+ )+ |
+
| 608 | ++ |
+ # now to handle when user chooses to order based on amount of outliers+ |
+
| 609 | +! | +
+ if (order_by_outlier) {
+ |
+
| 610 | +! | +
+ qenv <- teal.code::eval_code(+ |
+
| 611 | +! | +
+ qenv,+ |
+
| 612 | +! | +
+ quote(+ |
+
| 613 | +! | +
+ summary_table_pre <- summary_table_pre %>%+ |
+
| 614 | +! | +
+ dplyr::arrange(desc(n_outliers / total_in_cat)) %>%+ |
+
| 615 | +! | +
+ dplyr::mutate(order = seq_len(nrow(summary_table_pre)))+ |
+
| 616 | ++ |
+ )+ |
+
| 617 | ++ |
+ )+ |
+
| 618 | ++ |
+ }+ |
+
| 619 | ++ | + + | +
| 620 | +! | +
+ qenv <- teal.code::eval_code(+ |
+
| 621 | +! | +
+ qenv,+ |
+
| 622 | +! | +
+ substitute(+ |
+
| 623 | +! | +
+ expr = {
+ |
+
| 624 | ++ |
+ # In order for geom_rug to work properly when reordering takes place inside facet_grid,+ |
+
| 625 | ++ |
+ # all tables must have the column used for reording.+ |
+
| 626 | ++ |
+ # In this case, the column used for reordering is `order`.+ |
+
| 627 | +! | +
+ ANL_OUTLIER <- dplyr::left_join(+ |
+
| 628 | +! | +
+ ANL_OUTLIER,+ |
+
| 629 | +! | +
+ summary_table_pre[, c("order", categorical_var)],
+ |
+
| 630 | +! | +
+ by = categorical_var+ |
+
| 631 | ++ |
+ )+ |
+
| 632 | ++ |
+ # so that x axis of plot aligns with columns of summary table, from most outliers to least by percentage+ |
+
| 633 | +! | +
+ ANL <- ANL %>%+ |
+
| 634 | +! | +
+ dplyr::left_join(+ |
+
| 635 | +! | +
+ dplyr::select(summary_table_pre, categorical_var_name, order),+ |
+
| 636 | +! | +
+ by = categorical_var+ |
+
| 637 | ++ |
+ ) %>%+ |
+
| 638 | +! | +
+ dplyr::arrange(order)+ |
+
| 639 | +! | +
+ summary_table <- summary_table_pre %>%+ |
+
| 640 | +! | +
+ dplyr::select(+ |
+
| 641 | +! | +
+ categorical_var_name,+ |
+
| 642 | +! | +
+ Outliers = display_str, Missings = display_str_na, Total = total_in_cat+ |
+
| 643 | ++ |
+ ) %>%+ |
+
| 644 | +! | +
+ dplyr::mutate_all(as.character) %>%+ |
+
| 645 | +! | +
+ tidyr::pivot_longer(-categorical_var_name) %>%+ |
+
| 646 | +! | +
+ tidyr::pivot_wider(names_from = categorical_var, values_from = value) %>%+ |
+
| 647 | +! | +
+ tibble::column_to_rownames("name")
+ |
+
| 648 | +! | +
+ summary_table+ |
+
| 649 | ++ |
+ },+ |
+
| 650 | +! | +
+ env = list(+ |
+
| 651 | +! | +
+ categorical_var = categorical_var,+ |
+
| 652 | +! | +
+ categorical_var_name = as.name(categorical_var)+ |
+
| 653 | ++ |
+ )+ |
+
| 654 | ++ |
+ )+ |
+
| 655 | ++ |
+ )+ |
+
| 656 | ++ |
+ }+ |
+
| 657 | ++ | + + | +
| 658 | +! | +
+ if (length(categorical_var) > 0 && nrow(qenv[["ANL_OUTLIER"]]) > 0) {
+ |
+
| 659 | +! | +
+ shinyjs::show("order_by_outlier")
+ |
+
| 660 | ++ |
+ } else {
+ |
+
| 661 | +! | +
+ shinyjs::hide("order_by_outlier")
+ |
+
| 662 | ++ |
+ }+ |
+
| 663 | ++ | + + | +
| 664 | +! | +
+ qenv+ |
+
| 665 | ++ |
+ })+ |
+
| 666 | ++ | + + | +
| 667 | +! | +
+ output$summary_table <- DT::renderDataTable(+ |
+
| 668 | +! | +
+ expr = {
+ |
+
| 669 | +! | +
+ if (iv_r()$is_valid()) {
+ |
+
| 670 | +! | +
+ categorical_var <- as.vector(merged$anl_input_r()$columns_source$categorical_var)+ |
+
| 671 | +! | +
+ if (!is.null(categorical_var)) {
+ |
+
| 672 | +! | +
+ DT::datatable(+ |
+
| 673 | +! | +
+ common_code_q()[["summary_table"]],+ |
+
| 674 | +! | +
+ options = list(+ |
+
| 675 | +! | +
+ dom = "t",+ |
+
| 676 | +! | +
+ autoWidth = TRUE,+ |
+
| 677 | +! | +
+ columnDefs = list(list(width = "200px", targets = "_all"))+ |
+
| 678 | ++ |
+ )+ |
+
| 679 | ++ |
+ )+ |
+
| 680 | ++ |
+ }+ |
+
| 681 | ++ |
+ }+ |
+
| 682 | ++ |
+ }+ |
+
| 683 | ++ |
+ )+ |
+
| 684 | ++ | + + | +
| 685 | ++ |
+ # boxplot/violinplot # nolint commented_code+ |
+
| 686 | +! | +
+ boxplot_q <- reactive({
+ |
+
| 687 | +! | +
+ req(common_code_q())+ |
+
| 688 | +! | +
+ ANL <- common_code_q()[["ANL"]]+ |
+
| 689 | +! | +
+ ANL_OUTLIER <- common_code_q()[["ANL_OUTLIER"]]+ |
+
| 690 | ++ | + + | +
| 691 | +! | +
+ outlier_var <- as.vector(merged$anl_input_r()$columns_source$outlier_var)+ |
+
| 692 | +! | +
+ categorical_var <- as.vector(merged$anl_input_r()$columns_source$categorical_var)+ |
+
| 693 | ++ | + + | +
| 694 | ++ |
+ # validation+ |
+
| 695 | +! | +
+ teal::validate_has_data(ANL, 1)+ |
+
| 696 | ++ | + + | +
| 697 | ++ |
+ # boxplot+ |
+
| 698 | +! | +
+ plot_call <- quote(ANL %>% ggplot())+ |
+
| 699 | ++ | + + | +
| 700 | +! | +
+ plot_call <- if (input$boxplot_alts == "Box plot") {
+ |
+
| 701 | +! | +
+ substitute(expr = plot_call + geom_boxplot(outlier.shape = NA), env = list(plot_call = plot_call))+ |
+
| 702 | +! | +
+ } else if (input$boxplot_alts == "Violin plot") {
+ |
+
| 703 | +! | +
+ substitute(expr = plot_call + geom_violin(), env = list(plot_call = plot_call))+ |
+
| 704 | ++ |
+ } else {
+ |
+
| 705 | +! | +
+ NULL+ |
+
| 706 | ++ |
+ }+ |
+
| 707 | ++ | + + | +
| 708 | +! | +
+ plot_call <- if (identical(categorical_var, character(0)) || is.null(categorical_var)) {
+ |
+
| 709 | +! | +
+ inner_call <- substitute(+ |
+
| 710 | +! | +
+ expr = plot_call ++ |
+
| 711 | +! | +
+ aes(x = "Entire dataset", y = outlier_var_name) ++ |
+
| 712 | +! | +
+ scale_x_discrete(),+ |
+
| 713 | +! | +
+ env = list(plot_call = plot_call, outlier_var_name = as.name(outlier_var))+ |
+
| 714 | ++ |
+ )+ |
+
| 715 | +! | +
+ if (nrow(ANL_OUTLIER) > 0) {
+ |
+
| 716 | +! | +
+ substitute(+ |
+
| 717 | +! | +
+ expr = inner_call + geom_point(+ |
+
| 718 | +! | +
+ data = ANL_OUTLIER,+ |
+
| 719 | +! | +
+ aes(x = "Entire dataset", y = outlier_var_name, color = is_outlier_selected)+ |
+
| 720 | ++ |
+ ),+ |
+
| 721 | +! | +
+ env = list(inner_call = inner_call, outlier_var_name = as.name(outlier_var))+ |
+
| 722 | ++ |
+ )+ |
+
| 723 | ++ |
+ } else {
+ |
+
| 724 | +! | +
+ inner_call+ |
+
| 725 | ++ |
+ }+ |
+
| 726 | ++ |
+ } else {
+ |
+
| 727 | +! | +
+ substitute(+ |
+
| 728 | +! | +
+ expr = plot_call ++ |
+
| 729 | +! | +
+ aes(y = outlier_var_name, x = reorder(categorical_var_name, order)) ++ |
+
| 730 | +! | +
+ xlab(categorical_var) ++ |
+
| 731 | +! | +
+ scale_x_discrete() ++ |
+
| 732 | +! | +
+ geom_point(+ |
+
| 733 | +! | +
+ data = ANL_OUTLIER,+ |
+
| 734 | +! | +
+ aes(x = as.factor(categorical_var_name), y = outlier_var_name, color = is_outlier_selected)+ |
+
| 735 | ++ |
+ ),+ |
+
| 736 | +! | +
+ env = list(+ |
+
| 737 | +! | +
+ plot_call = plot_call,+ |
+
| 738 | +! | +
+ outlier_var_name = as.name(outlier_var),+ |
+
| 739 | +! | +
+ categorical_var_name = as.name(categorical_var),+ |
+
| 740 | +! | +
+ categorical_var = categorical_var+ |
+
| 741 | ++ |
+ )+ |
+
| 742 | ++ |
+ )+ |
+
| 743 | ++ |
+ }+ |
+
| 744 | ++ | + + | +
| 745 | +! | +
+ dev_ggplot2_args <- teal.widgets::ggplot2_args(+ |
+
| 746 | +! | +
+ labs = list(color = "Is outlier?"),+ |
+
| 747 | +! | +
+ theme = list(legend.position = "top")+ |
+
| 748 | ++ |
+ )+ |
+
| 749 | ++ | + + | +
| 750 | +! | +
+ all_ggplot2_args <- teal.widgets::resolve_ggplot2_args(+ |
+
| 751 | +! | +
+ user_plot = ggplot2_args[["Boxplot"]],+ |
+
| 752 | +! | +
+ user_default = ggplot2_args$default,+ |
+
| 753 | +! | +
+ module_plot = dev_ggplot2_args+ |
+
| 754 | ++ |
+ )+ |
+
| 755 | ++ | + + | +
| 756 | +! | +
+ parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(+ |
+
| 757 | +! | +
+ all_ggplot2_args,+ |
+
| 758 | +! | +
+ ggtheme = input$ggtheme+ |
+
| 759 | ++ |
+ )+ |
+
| 760 | ++ | + + | +
| 761 | +! | +
+ teal.code::eval_code(+ |
+
| 762 | +! | +
+ common_code_q(),+ |
+
| 763 | +! | +
+ substitute(+ |
+
| 764 | +! | +
+ expr = g <- plot_call ++ |
+
| 765 | +! | +
+ scale_color_manual(values = c("TRUE" = "red", "FALSE" = "black")) +
+ |
+
| 766 | +! | +
+ labs + ggthemes + themes,+ |
+
| 767 | +! | +
+ env = list(+ |
+
| 768 | +! | +
+ plot_call = plot_call,+ |
+
| 769 | +! | +
+ labs = parsed_ggplot2_args$labs,+ |
+
| 770 | +! | +
+ ggthemes = parsed_ggplot2_args$ggtheme,+ |
+
| 771 | +! | +
+ themes = parsed_ggplot2_args$theme+ |
+
| 772 | ++ |
+ )+ |
+
| 773 | ++ |
+ )+ |
+
| 774 | ++ |
+ ) %>%+ |
+
| 775 | +! | +
+ teal.code::eval_code(quote(print(g)))+ |
+
| 776 | ++ |
+ })+ |
+
| 777 | ++ | + + | +
| 778 | ++ |
+ # density plot+ |
+
| 779 | +! | +
+ density_plot_q <- reactive({
+ |
+
| 780 | +! | +
+ ANL <- common_code_q()[["ANL"]]+ |
+
| 781 | +! | +
+ ANL_OUTLIER <- common_code_q()[["ANL_OUTLIER"]]+ |
+
| 782 | ++ | + + | +
| 783 | +! | +
+ outlier_var <- as.vector(merged$anl_input_r()$columns_source$outlier_var)+ |
+
| 784 | +! | +
+ categorical_var <- as.vector(merged$anl_input_r()$columns_source$categorical_var)+ |
+
| 785 | ++ | + + | +
| 786 | ++ |
+ # validation+ |
+
| 787 | +! | +
+ teal::validate_has_data(ANL, 1)+ |
+
| 788 | ++ |
+ # plot+ |
+
| 789 | +! | +
+ plot_call <- substitute(+ |
+
| 790 | +! | +
+ expr = ANL %>%+ |
+
| 791 | +! | +
+ ggplot(aes(x = outlier_var_name)) ++ |
+
| 792 | +! | +
+ geom_density() ++ |
+
| 793 | +! | +
+ geom_rug(data = ANL_OUTLIER, aes(x = outlier_var_name, color = is_outlier_selected)) ++ |
+
| 794 | +! | +
+ scale_color_manual(values = c("TRUE" = "red", "FALSE" = "black")),
+ |
+
| 795 | +! | +
+ env = list(outlier_var_name = as.name(outlier_var))+ |
+
| 796 | ++ |
+ )+ |
+
| 797 | ++ | + + | +
| 798 | +! | +
+ plot_call <- if (identical(categorical_var, character(0)) || is.null(categorical_var)) {
+ |
+
| 799 | +! | +
+ substitute(expr = plot_call, env = list(plot_call = plot_call))+ |
+
| 800 | ++ |
+ } else {
+ |
+
| 801 | +! | +
+ substitute(+ |
+
| 802 | +! | +
+ expr = plot_call + facet_grid(~ reorder(categorical_var_name, order)),+ |
+
| 803 | +! | +
+ env = list(plot_call = plot_call, categorical_var_name = as.name(categorical_var))+ |
+
| 804 | ++ |
+ )+ |
+
| 805 | ++ |
+ }+ |
+
| 806 | ++ | + + | +
| 807 | +! | +
+ dev_ggplot2_args <- teal.widgets::ggplot2_args(+ |
+
| 808 | +! | +
+ labs = list(color = "Is outlier?"),+ |
+
| 809 | +! | +
+ theme = list(legend.position = "top")+ |
+
| 810 | ++ |
+ )+ |
+
| 811 | ++ | + + | +
| 812 | +! | +
+ all_ggplot2_args <- teal.widgets::resolve_ggplot2_args(+ |
+
| 813 | +! | +
+ user_plot = ggplot2_args[["Density Plot"]],+ |
+
| 814 | +! | +
+ user_default = ggplot2_args$default,+ |
+
| 815 | +! | +
+ module_plot = dev_ggplot2_args+ |
+
| 816 | ++ |
+ )+ |
+
| 817 | ++ | + + | +
| 818 | +! | +
+ parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(+ |
+
| 819 | +! | +
+ all_ggplot2_args,+ |
+
| 820 | +! | +
+ ggtheme = input$ggtheme+ |
+
| 821 | ++ |
+ )+ |
+
| 822 | ++ | + + | +
| 823 | +! | +
+ teal.code::eval_code(+ |
+
| 824 | +! | +
+ common_code_q(),+ |
+
| 825 | +! | +
+ substitute(+ |
+
| 826 | +! | +
+ expr = g <- plot_call + labs + ggthemes + themes,+ |
+
| 827 | +! | +
+ env = list(+ |
+
| 828 | +! | +
+ plot_call = plot_call,+ |
+
| 829 | +! | +
+ labs = parsed_ggplot2_args$labs,+ |
+
| 830 | +! | +
+ themes = parsed_ggplot2_args$theme,+ |
+
| 831 | +! | +
+ ggthemes = parsed_ggplot2_args$ggtheme+ |
+
| 832 | ++ |
+ )+ |
+
| 833 | ++ |
+ )+ |
+
| 834 | ++ |
+ ) %>%+ |
+
| 835 | +! | +
+ teal.code::eval_code(quote(print(g)))+ |
+
| 836 | ++ |
+ })+ |
+
| 837 | ++ | + + | +
| 838 | ++ |
+ # Cumulative distribution plot+ |
+
| 839 | +! | +
+ cumulative_plot_q <- reactive({
+ |
+
| 840 | +! | +
+ ANL <- common_code_q()[["ANL"]]+ |
+
| 841 | +! | +
+ ANL_OUTLIER <- common_code_q()[["ANL_OUTLIER"]]+ |
+
| 842 | ++ | + + | +
| 843 | +! | +
+ qenv <- common_code_q()+ |
+
| 844 | ++ | + + | +
| 845 | +! | +
+ outlier_var <- as.vector(merged$anl_input_r()$columns_source$outlier_var)+ |
+
| 846 | +! | +
+ categorical_var <- as.vector(merged$anl_input_r()$columns_source$categorical_var)+ |
+
| 847 | ++ | + + | +
| 848 | ++ |
+ # validation+ |
+
| 849 | +! | +
+ teal::validate_has_data(ANL, 1)+ |
+
| 850 | ++ | + + | +
| 851 | ++ |
+ # plot+ |
+
| 852 | +! | +
+ plot_call <- substitute(+ |
+
| 853 | +! | +
+ expr = ANL %>% ggplot(aes(x = outlier_var_name)) ++ |
+
| 854 | +! | +
+ stat_ecdf(),+ |
+
| 855 | +! | +
+ env = list(outlier_var_name = as.name(outlier_var))+ |
+
| 856 | ++ |
+ )+ |
+
| 857 | +! | +
+ if (length(categorical_var) == 0) {
+ |
+
| 858 | +! | +
+ qenv <- teal.code::eval_code(+ |
+
| 859 | +! | +
+ qenv,+ |
+
| 860 | +! | +
+ substitute(+ |
+
| 861 | +! | +
+ expr = {
+ |
+
| 862 | +! | +
+ ecdf_df <- ANL %>%+ |
+
| 863 | +! | +
+ dplyr::mutate(+ |
+
| 864 | +! | +
+ y = stats::ecdf(ANL[[outlier_var]])(ANL[[outlier_var]])+ |
+
| 865 | ++ |
+ )+ |
+
| 866 | ++ | + + | +
| 867 | +! | +
+ outlier_points <- dplyr::left_join(+ |
+
| 868 | +! | +
+ ecdf_df,+ |
+
| 869 | +! | +
+ ANL_OUTLIER,+ |
+
| 870 | +! | +
+ by = dplyr::setdiff(names(ecdf_df), "y")+ |
+
| 871 | ++ |
+ ) %>%+ |
+
| 872 | +! | +
+ dplyr::filter(!is.na(is_outlier_selected))+ |
+
| 873 | ++ |
+ },+ |
+
| 874 | +! | +
+ env = list(outlier_var = outlier_var)+ |
+
| 875 | ++ |
+ )+ |
+
| 876 | ++ |
+ )+ |
+
| 877 | ++ |
+ } else {
+ |
+
| 878 | +! | +
+ qenv <- teal.code::eval_code(+ |
+
| 879 | +! | +
+ qenv,+ |
+
| 880 | +! | +
+ substitute(+ |
+
| 881 | +! | +
+ expr = {
+ |
+
| 882 | +! | +
+ all_categories <- lapply(+ |
+
| 883 | +! | +
+ unique(ANL[[categorical_var]]),+ |
+
| 884 | +! | +
+ function(x) {
+ |
+
| 885 | +! | +
+ ANL <- ANL %>% dplyr::filter(get(categorical_var) == x)+ |
+
| 886 | +! | +
+ anl_outlier2 <- ANL_OUTLIER %>% dplyr::filter(get(categorical_var) == x)+ |
+
| 887 | +! | +
+ ecdf_df <- ANL %>%+ |
+
| 888 | +! | +
+ dplyr::mutate(y = stats::ecdf(ANL[[outlier_var]])(ANL[[outlier_var]]))+ |
+
| 889 | ++ | + + | +
| 890 | +! | +
+ dplyr::left_join(+ |
+
| 891 | +! | +
+ ecdf_df,+ |
+
| 892 | +! | +
+ anl_outlier2,+ |
+
| 893 | +! | +
+ by = dplyr::setdiff(names(ecdf_df), "y")+ |
+
| 894 | ++ |
+ ) %>%+ |
+
| 895 | +! | +
+ dplyr::filter(!is.na(is_outlier_selected))+ |
+
| 896 | ++ |
+ }+ |
+
| 897 | ++ |
+ )+ |
+
| 898 | +! | +
+ outlier_points <- do.call(rbind, all_categories)+ |
+
| 899 | ++ |
+ },+ |
+
| 900 | +! | +
+ env = list(categorical_var = categorical_var, outlier_var = outlier_var)+ |
+
| 901 | ++ |
+ )+ |
+
| 902 | ++ |
+ )+ |
+
| 903 | +! | +
+ plot_call <- substitute(+ |
+
| 904 | +! | +
+ expr = plot_call + facet_grid(~ reorder(categorical_var_name, order)),+ |
+
| 905 | +! | +
+ env = list(plot_call = plot_call, categorical_var_name = as.name(categorical_var))+ |
+
| 906 | ++ |
+ )+ |
+
| 907 | ++ |
+ }+ |
+
| 908 | ++ | + + | +
| 909 | +! | +
+ dev_ggplot2_args <- teal.widgets::ggplot2_args(+ |
+
| 910 | +! | +
+ labs = list(color = "Is outlier?"),+ |
+
| 911 | +! | +
+ theme = list(legend.position = "top")+ |
+
| 912 | ++ |
+ )+ |
+
| 913 | ++ | + + | +
| 914 | +! | +
+ all_ggplot2_args <- teal.widgets::resolve_ggplot2_args(+ |
+
| 915 | +! | +
+ user_plot = ggplot2_args[["Cumulative Distribution Plot"]],+ |
+
| 916 | +! | +
+ user_default = ggplot2_args$default,+ |
+
| 917 | +! | +
+ module_plot = dev_ggplot2_args+ |
+
| 918 | ++ |
+ )+ |
+
| 919 | ++ | + + | +
| 920 | +! | +
+ parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(+ |
+
| 921 | +! | +
+ all_ggplot2_args,+ |
+
| 922 | +! | +
+ ggtheme = input$ggtheme+ |
+
| 923 | ++ |
+ )+ |
+
| 924 | ++ | + + | +
| 925 | +! | +
+ teal.code::eval_code(+ |
+
| 926 | +! | +
+ qenv,+ |
+
| 927 | +! | +
+ substitute(+ |
+
| 928 | +! | +
+ expr = g <- plot_call ++ |
+
| 929 | +! | +
+ geom_point(data = outlier_points, aes(x = outlier_var_name, y = y, color = is_outlier_selected)) ++ |
+
| 930 | +! | +
+ scale_color_manual(values = c("TRUE" = "red", "FALSE" = "black")) +
+ |
+
| 931 | +! | +
+ labs + ggthemes + themes,+ |
+
| 932 | +! | +
+ env = list(+ |
+
| 933 | +! | +
+ plot_call = plot_call,+ |
+
| 934 | +! | +
+ outlier_var_name = as.name(outlier_var),+ |
+
| 935 | +! | +
+ labs = parsed_ggplot2_args$labs,+ |
+
| 936 | +! | +
+ themes = parsed_ggplot2_args$theme,+ |
+
| 937 | +! | +
+ ggthemes = parsed_ggplot2_args$ggtheme+ |
+
| 938 | ++ |
+ )+ |
+
| 939 | ++ |
+ )+ |
+
| 940 | ++ |
+ ) %>%+ |
+
| 941 | +! | +
+ teal.code::eval_code(quote(print(g)))+ |
+
| 942 | ++ |
+ })+ |
+
| 943 | ++ | + + | +
| 944 | +! | +
+ final_q <- reactive({
+ |
+
| 945 | +! | +
+ req(input$tabs)+ |
+
| 946 | +! | +
+ tab_type <- input$tabs+ |
+
| 947 | +! | +
+ result_q <- if (tab_type == "Boxplot") {
+ |
+
| 948 | +! | +
+ boxplot_q()+ |
+
| 949 | +! | +
+ } else if (tab_type == "Density Plot") {
+ |
+
| 950 | +! | +
+ density_plot_q()+ |
+
| 951 | +! | +
+ } else if (tab_type == "Cumulative Distribution Plot") {
+ |
+
| 952 | +! | +
+ cumulative_plot_q()+ |
+
| 953 | ++ |
+ }+ |
+
| 954 | ++ |
+ # used to display table when running show-r-code code+ |
+
| 955 | ++ |
+ # added after the plots so that a change in selected columns doesn't affect+ |
+
| 956 | ++ |
+ # brush selection.+ |
+
| 957 | +! | +
+ teal.code::eval_code(+ |
+
| 958 | +! | +
+ result_q,+ |
+
| 959 | +! | +
+ substitute(+ |
+
| 960 | +! | +
+ expr = {
+ |
+
| 961 | +! | +
+ columns_index <- union(+ |
+
| 962 | +! | +
+ setdiff(names(ANL_OUTLIER), "is_outlier_selected"),+ |
+
| 963 | +! | +
+ table_columns+ |
+
| 964 | ++ |
+ )+ |
+
| 965 | +! | +
+ ANL_OUTLIER_EXTENDED[ANL_OUTLIER_EXTENDED$is_outlier_selected, columns_index]+ |
+
| 966 | ++ |
+ },+ |
+
| 967 | +! | +
+ env = list(+ |
+
| 968 | +! | +
+ table_columns = input$table_ui_columns+ |
+
| 969 | ++ |
+ )+ |
+
| 970 | ++ |
+ )+ |
+
| 971 | ++ |
+ )+ |
+
| 972 | ++ |
+ })+ |
+
| 973 | ++ | + + | +
| 974 | ++ |
+ # slider text+ |
+
| 975 | +! | +
+ output$ui_outlier_help <- renderUI({
+ |
+
| 976 | +! | +
+ req(input$method)+ |
+
| 977 | +! | +
+ if (input$method == "IQR") {
+ |
+
| 978 | +! | +
+ req(input$iqr_slider)+ |
+
| 979 | +! | +
+ tags$small(+ |
+
| 980 | +! | +
+ withMathJax(+ |
+
| 981 | +! | +
+ helpText(+ |
+
| 982 | +! | +
+ "Outlier data points (\\(x \\lt Q1 - ", input$iqr_slider, "\\times IQR\\) or \\(+ |
+
| 983 | +! | +
+ Q3 + ", input$iqr_slider, "\\times IQR \\lt x\\))+ |
+
| 984 | +! | +
+ are displayed in red on the plot and can be visualized in the table below."+ |
+
| 985 | ++ |
+ ),+ |
+
| 986 | +! | +
+ if (input$split_outliers) {
+ |
+
| 987 | +! | +
+ withMathJax(helpText("Note: Quantiles are calculated per group."))
+ |
+
| 988 | ++ |
+ }+ |
+
| 989 | ++ |
+ )+ |
+
| 990 | ++ |
+ )+ |
+
| 991 | +! | +
+ } else if (input$method == "Z-score") {
+ |
+
| 992 | +! | +
+ req(input$zscore_slider)+ |
+
| 993 | +! | +
+ tags$small(+ |
+
| 994 | +! | +
+ withMathJax(+ |
+
| 995 | +! | +
+ helpText(+ |
+
| 996 | +! | +
+ "Outlier data points (\\(Zscore(x) < -", input$zscore_slider,+ |
+
| 997 | +! | +
+ "\\) or \\(", input$zscore_slider, "< Zscore(x) \\))
+ |
+
| 998 | +! | +
+ are displayed in red on the plot and can be visualized in the table below."+ |
+
| 999 | ++ |
+ ),+ |
+
| 1000 | +! | +
+ if (input$split_outliers) {
+ |
+
| 1001 | +! | +
+ withMathJax(helpText(" Note: Z-scores are calculated per group."))
+ |
+
| 1002 | ++ |
+ }+ |
+
| 1003 | ++ |
+ )+ |
+
| 1004 | ++ |
+ )+ |
+
| 1005 | +! | +
+ } else if (input$method == "Percentile") {
+ |
+
| 1006 | +! | +
+ req(input$percentile_slider)+ |
+
| 1007 | +! | +
+ tags$small(+ |
+
| 1008 | +! | +
+ withMathJax(+ |
+
| 1009 | +! | +
+ helpText(+ |
+
| 1010 | +! | +
+ "Outlier/extreme data points (\\( Percentile(x) <", input$percentile_slider,+ |
+
| 1011 | +! | +
+ "\\) or \\(", 1 - input$percentile_slider, " < Percentile(x) \\))
+ |
+
| 1012 | +! | +
+ are displayed in red on the plot and can be visualized in the table below."+ |
+
| 1013 | ++ |
+ ),+ |
+
| 1014 | +! | +
+ if (input$split_outliers) {
+ |
+
| 1015 | +! | +
+ withMathJax(helpText("Note: Percentiles are calculated per group."))
+ |
+
| 1016 | ++ |
+ }+ |
+
| 1017 | ++ |
+ )+ |
+
| 1018 | ++ |
+ )+ |
+
| 1019 | ++ |
+ }+ |
+
| 1020 | ++ |
+ })+ |
+
| 1021 | ++ | + + | +
| 1022 | +! | +
+ boxplot_r <- reactive({
+ |
+
| 1023 | +! | +
+ teal::validate_inputs(iv_r())+ |
+
| 1024 | +! | +
+ boxplot_q()[["g"]]+ |
+
| 1025 | ++ |
+ })+ |
+
| 1026 | +! | +
+ density_plot_r <- reactive({
+ |
+
| 1027 | +! | +
+ teal::validate_inputs(iv_r())+ |
+
| 1028 | +! | +
+ density_plot_q()[["g"]]+ |
+
| 1029 | ++ |
+ })+ |
+
| 1030 | +! | +
+ cumulative_plot_r <- reactive({
+ |
+
| 1031 | +! | +
+ teal::validate_inputs(iv_r())+ |
+
| 1032 | +! | +
+ cumulative_plot_q()[["g"]]+ |
+
| 1033 | ++ |
+ })+ |
+
| 1034 | ++ | + + | +
| 1035 | +! | +
+ box_pws <- teal.widgets::plot_with_settings_srv(+ |
+
| 1036 | +! | +
+ id = "box_plot",+ |
+
| 1037 | +! | +
+ plot_r = boxplot_r,+ |
+
| 1038 | +! | +
+ height = plot_height,+ |
+
| 1039 | +! | +
+ width = plot_width,+ |
+
| 1040 | +! | +
+ brushing = TRUE+ |
+
| 1041 | ++ |
+ )+ |
+
| 1042 | ++ | + + | +
| 1043 | +! | +
+ density_pws <- teal.widgets::plot_with_settings_srv(+ |
+
| 1044 | +! | +
+ id = "density_plot",+ |
+
| 1045 | +! | +
+ plot_r = density_plot_r,+ |
+
| 1046 | +! | +
+ height = plot_height,+ |
+
| 1047 | +! | +
+ width = plot_width,+ |
+
| 1048 | +! | +
+ brushing = TRUE+ |
+
| 1049 | ++ |
+ )+ |
+
| 1050 | ++ | + + | +
| 1051 | +! | +
+ cum_density_pws <- teal.widgets::plot_with_settings_srv(+ |
+
| 1052 | +! | +
+ id = "cum_density_plot",+ |
+
| 1053 | +! | +
+ plot_r = cumulative_plot_r,+ |
+
| 1054 | +! | +
+ height = plot_height,+ |
+
| 1055 | +! | +
+ width = plot_width,+ |
+
| 1056 | +! | +
+ brushing = TRUE+ |
+
| 1057 | ++ |
+ )+ |
+
| 1058 | ++ | + + | +
| 1059 | +! | +
+ choices <- teal.transform::variable_choices(data()[[dataname_first]])+ |
+
| 1060 | ++ | + + | +
| 1061 | +! | +
+ observeEvent(common_code_q(), {
+ |
+
| 1062 | +! | +
+ ANL_OUTLIER <- common_code_q()[["ANL_OUTLIER"]]+ |
+
| 1063 | +! | +
+ teal.widgets::updateOptionalSelectInput(+ |
+
| 1064 | +! | +
+ session,+ |
+
| 1065 | +! | +
+ inputId = "table_ui_columns",+ |
+
| 1066 | +! | +
+ choices = dplyr::setdiff(choices, names(ANL_OUTLIER)),+ |
+
| 1067 | +! | +
+ selected = isolate(input$table_ui_columns)+ |
+
| 1068 | ++ |
+ )+ |
+
| 1069 | ++ |
+ })+ |
+
| 1070 | ++ | + + | +
| 1071 | +! | +
+ output$table_ui <- DT::renderDataTable(+ |
+
| 1072 | +! | +
+ expr = {
+ |
+
| 1073 | +! | +
+ tab <- input$tabs+ |
+
| 1074 | +! | +
+ req(tab) # tab is NULL upon app launch, hence will crash without this statement+ |
+
| 1075 | +! | +
+ shiny::req(iv_r()$is_valid()) # Same validation as output$table_ui_wrap+ |
+
| 1076 | +! | +
+ outlier_var <- as.vector(merged$anl_input_r()$columns_source$outlier_var)+ |
+
| 1077 | +! | +
+ categorical_var <- as.vector(merged$anl_input_r()$columns_source$categorical_var)+ |
+
| 1078 | ++ | + + | +
| 1079 | +! | +
+ ANL_OUTLIER <- common_code_q()[["ANL_OUTLIER"]]+ |
+
| 1080 | +! | +
+ ANL_OUTLIER_EXTENDED <- common_code_q()[["ANL_OUTLIER_EXTENDED"]]+ |
+
| 1081 | +! | +
+ ANL <- common_code_q()[["ANL"]]+ |
+
| 1082 | ++ | + + | +
| 1083 | +! | +
+ plot_brush <- if (tab == "Boxplot") {
+ |
+
| 1084 | +! | +
+ boxplot_r()+ |
+
| 1085 | +! | +
+ box_pws$brush()+ |
+
| 1086 | +! | +
+ } else if (tab == "Density Plot") {
+ |
+
| 1087 | +! | +
+ density_plot_r()+ |
+
| 1088 | +! | +
+ density_pws$brush()+ |
+
| 1089 | +! | +
+ } else if (tab == "Cumulative Distribution Plot") {
+ |
+
| 1090 | +! | +
+ cumulative_plot_r()+ |
+
| 1091 | +! | +
+ cum_density_pws$brush()+ |
+
| 1092 | ++ |
+ }+ |
+
| 1093 | ++ | + + | +
| 1094 | ++ |
+ # removing unused column ASAP+ |
+
| 1095 | +! | +
+ ANL_OUTLIER$order <- ANL$order <- NULL+ |
+
| 1096 | ++ | + + | +
| 1097 | +! | +
+ display_table <- if (!is.null(plot_brush)) {
+ |
+
| 1098 | +! | +
+ if (length(categorical_var) > 0) {
+ |
+
| 1099 | ++ |
+ # due to reordering, the x-axis label may be changed to something like "reorder(categorical_var, order)"+ |
+
| 1100 | +! | +
+ if (tab == "Boxplot") {
+ |
+
| 1101 | +! | +
+ plot_brush$mapping$x <- categorical_var+ |
+
| 1102 | ++ |
+ } else {
+ |
+
| 1103 | ++ |
+ # the other plots use facetting+ |
+
| 1104 | ++ |
+ # so it is panelvar1 that gets relabelled to "reorder(categorical_var, order)"+ |
+
| 1105 | +! | +
+ plot_brush$mapping$panelvar1 <- categorical_var+ |
+
| 1106 | ++ |
+ }+ |
+
| 1107 | ++ |
+ } else {
+ |
+
| 1108 | +! | +
+ if (tab == "Boxplot") {
+ |
+
| 1109 | ++ |
+ # in boxplot with no categorical variable, there is no column in ANL that would correspond to x-axis+ |
+
| 1110 | ++ |
+ # so a column needs to be inserted with the value "Entire dataset" because that's the label used in plot+ |
+
| 1111 | +! | +
+ ANL[[plot_brush$mapping$x]] <- "Entire dataset"+ |
+
| 1112 | ++ |
+ }+ |
+
| 1113 | ++ |
+ }+ |
+
| 1114 | ++ | + + | +
| 1115 | ++ |
+ # in density and cumulative plots, ANL does not have a column corresponding to y-axis.+ |
+
| 1116 | ++ |
+ # so they need to be computed and attached to ANL+ |
+
| 1117 | +! | +
+ if (tab == "Density Plot") {
+ |
+
| 1118 | +! | +
+ plot_brush$mapping$y <- "density"+ |
+
| 1119 | +! | +
+ ANL$density <- plot_brush$ymin+ |
+
| 1120 | ++ |
+ # either ymin or ymax will work+ |
+
| 1121 | +! | +
+ } else if (tab == "Cumulative Distribution Plot") {
+ |
+
| 1122 | +! | +
+ plot_brush$mapping$y <- "cdf"+ |
+
| 1123 | +! | +
+ if (length(categorical_var) > 0) {
+ |
+
| 1124 | +! | +
+ ANL <- ANL %>%+ |
+
| 1125 | +! | +
+ dplyr::group_by(!!as.name(plot_brush$mapping$panelvar1)) %>%+ |
+
| 1126 | +! | +
+ dplyr::mutate(cdf = stats::ecdf(!!as.name(outlier_var))(!!as.name(outlier_var)))+ |
+
| 1127 | ++ |
+ } else {
+ |
+
| 1128 | +! | +
+ ANL$cdf <- stats::ecdf(ANL[[outlier_var]])(ANL[[outlier_var]])+ |
+
| 1129 | ++ |
+ }+ |
+
| 1130 | ++ |
+ }+ |
+
| 1131 | ++ | + + | +
| 1132 | +! | +
+ brushed_rows <- brushedPoints(ANL, plot_brush)+ |
+
| 1133 | +! | +
+ if (nrow(brushed_rows) > 0) {
+ |
+
| 1134 | ++ |
+ # now we need to remove extra column from ANL so that it will have the same columns as ANL_OUTLIER+ |
+
| 1135 | ++ |
+ # so that dplyr::intersect will work+ |
+
| 1136 | +! | +
+ if (tab == "Density Plot") {
+ |
+
| 1137 | +! | +
+ brushed_rows$density <- NULL+ |
+
| 1138 | +! | +
+ } else if (tab == "Cumulative Distribution Plot") {
+ |
+
| 1139 | +! | +
+ brushed_rows$cdf <- NULL+ |
+
| 1140 | +! | +
+ } else if (tab == "Boxplot" && length(categorical_var) == 0) {
+ |
+
| 1141 | +! | +
+ brushed_rows[[plot_brush$mapping$x]] <- NULL+ |
+
| 1142 | ++ |
+ }+ |
+
| 1143 | ++ |
+ # is_outlier_selected is part of ANL_OUTLIER so needed here+ |
+
| 1144 | +! | +
+ brushed_rows$is_outlier_selected <- TRUE+ |
+
| 1145 | +! | +
+ dplyr::intersect(ANL_OUTLIER, brushed_rows)+ |
+
| 1146 | ++ |
+ } else {
+ |
+
| 1147 | +! | +
+ ANL_OUTLIER[0, ]+ |
+
| 1148 | ++ |
+ }+ |
+
| 1149 | ++ |
+ } else {
+ |
+
| 1150 | +! | +
+ ANL_OUTLIER[ANL_OUTLIER$is_outlier_selected, ]+ |
+
| 1151 | ++ |
+ }+ |
+
| 1152 | ++ | + + | +
| 1153 | +! | +
+ display_table$is_outlier_selected <- NULL+ |
+
| 1154 | ++ | + + | +
| 1155 | ++ |
+ # Extend the brushed ANL_OUTLIER with additional columns+ |
+
| 1156 | +! | +
+ dplyr::left_join(+ |
+
| 1157 | +! | +
+ display_table,+ |
+
| 1158 | +! | +
+ dplyr::select(ANL_OUTLIER_EXTENDED, -"is_outlier_selected"),+ |
+
| 1159 | +! | +
+ by = names(display_table)+ |
+
| 1160 | ++ |
+ ) %>%+ |
+
| 1161 | +! | +
+ dplyr::select(union(names(display_table), input$table_ui_columns))+ |
+
| 1162 | ++ |
+ },+ |
+
| 1163 | +! | +
+ options = list(+ |
+
| 1164 | +! | +
+ searching = FALSE, language = list(+ |
+
| 1165 | +! | +
+ zeroRecords = "The brushed area does not contain outlier observations for the currently defined threshold"+ |
+
| 1166 | ++ |
+ ),+ |
+
| 1167 | +! | +
+ pageLength = input$table_ui_rows+ |
+
| 1168 | ++ |
+ )+ |
+
| 1169 | ++ |
+ )+ |
+
| 1170 | ++ | + + | +
| 1171 | +! | +
+ output$total_outliers <- renderUI({
+ |
+
| 1172 | +! | +
+ shiny::req(iv_r()$is_valid())+ |
+
| 1173 | +! | +
+ ANL <- merged$anl_q_r()[["ANL"]]+ |
+
| 1174 | +! | +
+ ANL_OUTLIER <- common_code_q()[["ANL_OUTLIER"]]+ |
+
| 1175 | +! | +
+ teal::validate_has_data(ANL, 1)+ |
+
| 1176 | +! | +
+ ANL_OUTLIER_SELECTED <- ANL_OUTLIER[ANL_OUTLIER$is_outlier_selected, ]+ |
+
| 1177 | +! | +
+ h5(+ |
+
| 1178 | +! | +
+ sprintf(+ |
+
| 1179 | +! | +
+ "%s %d / %d [%.02f%%]",+ |
+
| 1180 | +! | +
+ "Total number of outlier(s):",+ |
+
| 1181 | +! | +
+ nrow(ANL_OUTLIER_SELECTED),+ |
+
| 1182 | +! | +
+ nrow(ANL),+ |
+
| 1183 | +! | +
+ 100 * nrow(ANL_OUTLIER_SELECTED) / nrow(ANL)+ |
+
| 1184 | ++ |
+ )+ |
+
| 1185 | ++ |
+ )+ |
+
| 1186 | ++ |
+ })+ |
+
| 1187 | ++ | + + | +
| 1188 | +! | +
+ output$total_missing <- renderUI({
+ |
+
| 1189 | +! | +
+ if (n_outlier_missing() > 0) {
+ |
+
| 1190 | +! | +
+ ANL <- merged$anl_q_r()[["ANL"]]+ |
+
| 1191 | +! | +
+ helpText(+ |
+
| 1192 | +! | +
+ sprintf(+ |
+
| 1193 | +! | +
+ "%s %d / %d [%.02f%%]",+ |
+
| 1194 | +! | +
+ "Total number of row(s) with missing values:",+ |
+
| 1195 | +! | +
+ n_outlier_missing(),+ |
+
| 1196 | +! | +
+ nrow(ANL),+ |
+
| 1197 | +! | +
+ 100 * (n_outlier_missing()) / nrow(ANL)+ |
+
| 1198 | ++ |
+ )+ |
+
| 1199 | ++ |
+ )+ |
+
| 1200 | ++ |
+ }+ |
+
| 1201 | ++ |
+ })+ |
+
| 1202 | ++ | + + | +
| 1203 | +! | +
+ output$table_ui_wrap <- renderUI({
+ |
+
| 1204 | +! | +
+ shiny::req(iv_r()$is_valid())+ |
+
| 1205 | +! | +
+ tagList(+ |
+
| 1206 | +! | +
+ teal.widgets::optionalSelectInput(+ |
+
| 1207 | +! | +
+ inputId = session$ns("table_ui_columns"),
+ |
+
| 1208 | +! | +
+ label = "Choose additional columns",+ |
+
| 1209 | +! | +
+ choices = NULL,+ |
+
| 1210 | +! | +
+ selected = NULL,+ |
+
| 1211 | +! | +
+ multiple = TRUE+ |
+
| 1212 | ++ |
+ ),+ |
+
| 1213 | +! | +
+ h4("Outlier Table"),
+ |
+
| 1214 | +! | +
+ teal.widgets::get_dt_rows(session$ns("table_ui"), session$ns("table_ui_rows"))
+ |
+
| 1215 | ++ |
+ )+ |
+
| 1216 | ++ |
+ })+ |
+
| 1217 | ++ | + + | +
| 1218 | +! | +
+ teal.widgets::verbatim_popup_srv(+ |
+
| 1219 | +! | +
+ id = "warning",+ |
+
| 1220 | +! | +
+ verbatim_content = reactive(teal.code::get_warnings(final_q())),+ |
+
| 1221 | +! | +
+ title = "Warning",+ |
+
| 1222 | +! | +
+ disabled = reactive(is.null(teal.code::get_warnings(final_q())))+ |
+
| 1223 | ++ |
+ )+ |
+
| 1224 | ++ | + + | +
| 1225 | +! | +
+ teal.widgets::verbatim_popup_srv(+ |
+
| 1226 | +! | +
+ id = "rcode",+ |
+
| 1227 | +! | +
+ verbatim_content = reactive(teal.code::get_code(final_q())),+ |
+
| 1228 | +! | +
+ title = "Show R Code for Outlier"+ |
+
| 1229 | ++ |
+ )+ |
+
| 1230 | ++ | + + | +
| 1231 | ++ |
+ ### REPORTER+ |
+
| 1232 | +! | +
+ if (with_reporter) {
+ |
+
| 1233 | +! | +
+ card_fun <- function(comment, label) {
+ |
+
| 1234 | +! | +
+ tab_type <- input$tabs+ |
+
| 1235 | +! | +
+ card <- teal::report_card_template(+ |
+
| 1236 | +! | +
+ title = paste0("Outliers - ", tab_type),
+ |
+
| 1237 | +! | +
+ label = label,+ |
+
| 1238 | +! | +
+ with_filter = with_filter,+ |
+
| 1239 | +! | +
+ filter_panel_api = filter_panel_api+ |
+
| 1240 | ++ |
+ )+ |
+
| 1241 | +! | +
+ categorical_var <- as.vector(merged$anl_input_r()$columns_source$categorical_var)+ |
+
| 1242 | +! | +
+ if (length(categorical_var) > 0) {
+ |
+
| 1243 | +! | +
+ summary_table <- common_code_q()[["summary_table"]]+ |
+
| 1244 | +! | +
+ card$append_text("Summary Table", "header3")
+ |
+
| 1245 | +! | +
+ card$append_table(summary_table)+ |
+
| 1246 | ++ |
+ }+ |
+
| 1247 | +! | +
+ card$append_text("Plot", "header3")
+ |
+
| 1248 | +! | +
+ if (tab_type == "Boxplot") {
+ |
+
| 1249 | +! | +
+ card$append_plot(boxplot_r(), dim = box_pws$dim())+ |
+
| 1250 | +! | +
+ } else if (tab_type == "Density Plot") {
+ |
+
| 1251 | +! | +
+ card$append_plot(density_plot_r(), dim = density_pws$dim())+ |
+
| 1252 | +! | +
+ } else if (tab_type == "Cumulative Distribution Plot") {
+ |
+
| 1253 | +! | +
+ card$append_plot(cumulative_plot_r(), dim = cum_density_pws$dim())+ |
+
| 1254 | ++ |
+ }+ |
+
| 1255 | +! | +
+ if (!comment == "") {
+ |
+
| 1256 | +! | +
+ card$append_text("Comment", "header3")
+ |
+
| 1257 | +! | +
+ card$append_text(comment)+ |
+
| 1258 | ++ |
+ }+ |
+
| 1259 | +! | +
+ card$append_src(teal.code::get_code(final_q()))+ |
+
| 1260 | +! | +
+ card+ |
+
| 1261 | ++ |
+ }+ |
+
| 1262 | +! | +
+ teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
+ |
+
| 1263 | ++ |
+ }+ |
+
| 1264 | ++ |
+ ###+ |
+
| 1265 | ++ |
+ })+ |
+
| 1266 | ++ |
+ }+ |
+
| 1 | ++ |
+ #' `teal` module: File viewer+ |
+
| 2 | ++ |
+ #'+ |
+
| 3 | ++ |
+ #' The file viewer module provides a tool to view static files.+ |
+
| 4 | ++ |
+ #' Supported formats include text formats, `PDF`, `PNG` `APNG`,+ |
+
| 5 | ++ |
+ #' `JPEG` `SVG`, `WEBP`, `GIF` and `BMP`.+ |
+
| 6 | ++ |
+ #'+ |
+
| 7 | ++ |
+ #' @inheritParams teal::module+ |
+
| 8 | ++ |
+ #' @inheritParams shared_params+ |
+
| 9 | ++ |
+ #' @param input_path (`list`) of the input paths, optional. Each element can be:+ |
+
| 10 | ++ |
+ #'+ |
+
| 11 | ++ |
+ #' Paths can be specified as absolute paths or relative to the running directory of the application.+ |
+
| 12 | ++ |
+ #' Default to the current working directory if not supplied.+ |
+
| 13 | ++ |
+ #'+ |
+
| 14 | ++ |
+ #' @inherit shared_params return+ |
+
| 15 | ++ |
+ #'+ |
+
| 16 | ++ |
+ #' @examples+ |
+
| 17 | ++ |
+ #' data <- teal_data()+ |
+
| 18 | ++ |
+ #' data <- within(data, {
+ |
+
| 19 | ++ |
+ #' data <- data.frame(1)+ |
+
| 20 | ++ |
+ #' })+ |
+
| 21 | ++ |
+ #' datanames(data) <- c("data")
+ |
+
| 22 | ++ |
+ #'+ |
+
| 23 | ++ |
+ #' app <- init(+ |
+
| 24 | ++ |
+ #' data = data,+ |
+
| 25 | ++ |
+ #' modules = modules(+ |
+
| 26 | ++ |
+ #' tm_file_viewer(+ |
+
| 27 | ++ |
+ #' input_path = list(+ |
+
| 28 | ++ |
+ #' folder = system.file("sample_files", package = "teal.modules.general"),
+ |
+
| 29 | ++ |
+ #' png = system.file("sample_files/sample_file.png", package = "teal.modules.general"),
+ |
+
| 30 | ++ |
+ #' txt = system.file("sample_files/sample_file.txt", package = "teal.modules.general"),
+ |
+
| 31 | ++ |
+ #' url = "https://fda.gov/files/drugs/published/Portable-Document-Format-Specifications.pdf"+ |
+
| 32 | ++ |
+ #' )+ |
+
| 33 | ++ |
+ #' )+ |
+
| 34 | ++ |
+ #' )+ |
+
| 35 | ++ |
+ #' )+ |
+
| 36 | ++ |
+ #' if (interactive()) {
+ |
+
| 37 | ++ |
+ #' shinyApp(app$ui, app$server)+ |
+
| 38 | ++ |
+ #' }+ |
+
| 39 | ++ |
+ #'+ |
+
| 40 | ++ |
+ #' @export+ |
+
| 41 | ++ |
+ #'+ |
+
| 42 | ++ |
+ tm_file_viewer <- function(label = "File Viewer Module",+ |
+
| 43 | ++ |
+ input_path = list("Current Working Directory" = ".")) {
+ |
+
| 44 | +! | +
+ logger::log_info("Initializing tm_file_viewer")
+ |
+
| 45 | ++ | + + | +
| 46 | ++ |
+ # Normalize the parameters+ |
+
| 47 | +! | +
+ if (length(label) == 0 || identical(label, "")) label <- " "+ |
+
| 48 | +! | +
+ if (length(input_path) == 0 || identical(input_path, "")) input_path <- list()+ |
+
| 49 | ++ | + + | +
| 50 | ++ |
+ # Start of assertions+ |
+
| 51 | +! | +
+ checkmate::assert_string(label)+ |
+
| 52 | ++ | + + | +
| 53 | +! | +
+ checkmate::assert(+ |
+
| 54 | +! | +
+ checkmate::check_list(input_path, types = "character", min.len = 0),+ |
+
| 55 | +! | +
+ checkmate::check_character(input_path, min.len = 1)+ |
+
| 56 | ++ |
+ )+ |
+
| 57 | +! | +
+ if (length(input_path) > 0) {
+ |
+
| 58 | +! | +
+ valid_url <- function(url_input, timeout = 2) {
+ |
+
| 59 | +! | +
+ con <- try(url(url_input), silent = TRUE)+ |
+
| 60 | +! | +
+ check <- suppressWarnings(try(open.connection(con, open = "rt", timeout = timeout), silent = TRUE)[1])+ |
+
| 61 | +! | +
+ try(close.connection(con), silent = TRUE)+ |
+
| 62 | +! | +
+ is.null(check)+ |
+
| 63 | ++ |
+ }+ |
+
| 64 | +! | +
+ idx <- vapply(input_path, function(x) file.exists(x) || valid_url(x), logical(1))+ |
+
| 65 | ++ | + + | +
| 66 | +! | +
+ if (!all(idx)) {
+ |
+
| 67 | +! | +
+ warning(+ |
+
| 68 | +! | +
+ paste0(+ |
+
| 69 | +! | +
+ "Non-existent file or url path. Please provide valid paths for:\n",+ |
+
| 70 | +! | +
+ paste0(input_path[!idx], collapse = "\n")+ |
+
| 71 | ++ |
+ )+ |
+
| 72 | ++ |
+ )+ |
+
| 73 | ++ |
+ }+ |
+
| 74 | +! | +
+ input_path <- input_path[idx]+ |
+
| 75 | ++ |
+ } else {
+ |
+
| 76 | +! | +
+ warning(+ |
+
| 77 | +! | +
+ "No file or url paths were provided."+ |
+
| 78 | ++ |
+ )+ |
+
| 79 | ++ |
+ }+ |
+
| 80 | ++ |
+ # End of assertions+ |
+
| 81 | ++ | + + | +
| 82 | ++ |
+ # Make UI args+ |
+
| 83 | +! | +
+ args <- as.list(environment())+ |
+
| 84 | ++ | + + | +
| 85 | +! | +
+ module(+ |
+
| 86 | +! | +
+ label = label,+ |
+
| 87 | +! | +
+ server = srv_viewer,+ |
+
| 88 | +! | +
+ server_args = list(input_path = input_path),+ |
+
| 89 | +! | +
+ ui = ui_viewer,+ |
+
| 90 | +! | +
+ ui_args = args,+ |
+
| 91 | +! | +
+ datanames = NULL+ |
+
| 92 | ++ |
+ )+ |
+
| 93 | ++ |
+ }+ |
+
| 94 | ++ | + + | +
| 95 | ++ |
+ # UI function for the file viewer module+ |
+
| 96 | ++ |
+ ui_viewer <- function(id, ...) {
+ |
+
| 97 | +! | +
+ args <- list(...)+ |
+
| 98 | +! | +
+ ns <- NS(id)+ |
+
| 99 | ++ | + + | +
| 100 | +! | +
+ shiny::tagList(+ |
+
| 101 | +! | +
+ include_css_files("custom"),
+ |
+
| 102 | +! | +
+ teal.widgets::standard_layout(+ |
+
| 103 | +! | +
+ output = div(+ |
+
| 104 | +! | +
+ uiOutput(ns("output"))
+ |
+
| 105 | ++ |
+ ),+ |
+
| 106 | +! | +
+ encoding = div(+ |
+
| 107 | +! | +
+ class = "file_viewer_encoding",+ |
+
| 108 | +! | +
+ tags$label("Encodings", class = "text-primary"),
+ |
+
| 109 | +! | +
+ shinyTree::shinyTree(+ |
+
| 110 | +! | +
+ ns("tree"),
+ |
+
| 111 | +! | +
+ dragAndDrop = FALSE,+ |
+
| 112 | +! | +
+ sort = FALSE,+ |
+
| 113 | +! | +
+ wholerow = TRUE,+ |
+
| 114 | +! | +
+ theme = "proton",+ |
+
| 115 | +! | +
+ multiple = FALSE+ |
+
| 116 | ++ |
+ )+ |
+
| 117 | ++ |
+ )+ |
+
| 118 | ++ |
+ )+ |
+
| 119 | ++ |
+ )+ |
+
| 120 | ++ |
+ }+ |
+
| 121 | ++ | + + | +
| 122 | ++ |
+ # Server function for the file viewer module+ |
+
| 123 | ++ |
+ srv_viewer <- function(id, input_path) {
+ |
+
| 124 | +! | +
+ moduleServer(id, function(input, output, session) {
+ |
+
| 125 | +! | +
+ temp_dir <- tempfile()+ |
+
| 126 | +! | +
+ if (!dir.exists(temp_dir)) {
+ |
+
| 127 | +! | +
+ dir.create(temp_dir, recursive = TRUE)+ |
+
| 128 | ++ |
+ }+ |
+
| 129 | +! | +
+ addResourcePath(basename(temp_dir), temp_dir)+ |
+
| 130 | ++ | + + | +
| 131 | +! | +
+ test_path_text <- function(selected_path, type) {
+ |
+
| 132 | +! | +
+ out <- tryCatch(+ |
+
| 133 | +! | +
+ expr = {
+ |
+
| 134 | +! | +
+ if (type != "url") {
+ |
+
| 135 | +! | +
+ selected_path <- normalizePath(selected_path, winslash = "/")+ |
+
| 136 | ++ |
+ }+ |
+
| 137 | +! | +
+ readLines(con = selected_path)+ |
+
| 138 | ++ |
+ },+ |
+
| 139 | +! | +
+ error = function(cond) FALSE,+ |
+
| 140 | +! | +
+ warning = function(cond) {
+ |
+
| 141 | +! | +
+ `if`(grepl("^incomplete final line found on", cond[[1]]), suppressWarnings(eval(cond[[2]])), FALSE)
+ |
+
| 142 | ++ |
+ }+ |
+
| 143 | ++ |
+ )+ |
+
| 144 | ++ |
+ }+ |
+
| 145 | ++ | + + | +
| 146 | +! | +
+ handle_connection_type <- function(selected_path) {
+ |
+
| 147 | +! | +
+ file_extension <- tools::file_ext(selected_path)+ |
+
| 148 | +! | +
+ file_class <- suppressWarnings(file(selected_path))+ |
+
| 149 | +! | +
+ close(file_class)+ |
+
| 150 | ++ | + + | +
| 151 | +! | +
+ output_text <- test_path_text(selected_path, type = class(file_class)[1])+ |
+
| 152 | ++ | + + | +
| 153 | +! | +
+ if (class(file_class)[1] == "url") {
+ |
+
| 154 | +! | +
+ list(selected_path = selected_path, output_text = output_text)+ |
+
| 155 | ++ |
+ } else {
+ |
+
| 156 | +! | +
+ file.copy(normalizePath(selected_path, winslash = "/"), temp_dir)+ |
+
| 157 | +! | +
+ selected_path <- file.path(basename(temp_dir), basename(selected_path))+ |
+
| 158 | +! | +
+ list(selected_path = selected_path, output_text = output_text)+ |
+
| 159 | ++ |
+ }+ |
+
| 160 | ++ |
+ }+ |
+
| 161 | ++ | + + | +
| 162 | +! | +
+ display_file <- function(selected_path) {
+ |
+
| 163 | +! | +
+ con_type <- handle_connection_type(selected_path)+ |
+
| 164 | +! | +
+ file_extension <- tools::file_ext(selected_path)+ |
+
| 165 | +! | +
+ if (file_extension %in% c("png", "apng", "jpg", "jpeg", "svg", "gif", "webp", "bmp")) {
+ |
+
| 166 | +! | +
+ tags$img(src = con_type$selected_path, alt = "file does not exist")+ |
+
| 167 | +! | +
+ } else if (file_extension == "pdf") {
+ |
+
| 168 | +! | +
+ tags$embed(+ |
+
| 169 | +! | +
+ class = "embed_pdf",+ |
+
| 170 | +! | +
+ src = con_type$selected_path+ |
+
| 171 | ++ |
+ )+ |
+
| 172 | +! | +
+ } else if (!isFALSE(con_type$output_text[1])) {
+ |
+
| 173 | +! | +
+ tags$pre(paste0(con_type$output_text, collapse = "\n"))+ |
+
| 174 | ++ |
+ } else {
+ |
+
| 175 | +! | +
+ tags$p("Please select a supported format.")
+ |
+
| 176 | ++ |
+ }+ |
+
| 177 | ++ |
+ }+ |
+
| 178 | ++ | + + | +
| 179 | +! | +
+ tree_list <- function(file_or_dir) {
+ |
+
| 180 | +! | +
+ nested_list <- lapply(file_or_dir, function(path) {
+ |
+
| 181 | +! | +
+ file_class <- suppressWarnings(file(path))+ |
+
| 182 | +! | +
+ close(file_class)+ |
+
| 183 | +! | +
+ if (class(file_class)[[1]] != "url") {
+ |
+
| 184 | +! | +
+ isdir <- file.info(path)$isdir+ |
+
| 185 | +! | +
+ if (!isdir) {
+ |
+
| 186 | +! | +
+ structure(path, ancestry = path, sticon = "file")+ |
+
| 187 | ++ |
+ } else {
+ |
+
| 188 | +! | +
+ files <- list.files(path, full.names = TRUE, include.dirs = TRUE)+ |
+
| 189 | +! | +
+ out <- lapply(files, function(x) tree_list(x))+ |
+
| 190 | +! | +
+ out <- unlist(out, recursive = FALSE)+ |
+
| 191 | +! | +
+ if (length(files) > 0) names(out) <- basename(files)+ |
+
| 192 | +! | +
+ out+ |
+
| 193 | ++ |
+ }+ |
+
| 194 | ++ |
+ } else {
+ |
+
| 195 | +! | +
+ structure(path, ancestry = path, sticon = "file")+ |
+
| 196 | ++ |
+ }+ |
+
| 197 | ++ |
+ })+ |
+
| 198 | ++ | + + | +
| 199 | +! | +
+ missing_labels <- if (is.null(names(nested_list))) seq_along(nested_list) else which(names(nested_list) == "")+ |
+
| 200 | +! | +
+ names(nested_list)[missing_labels] <- file_or_dir[missing_labels]+ |
+
| 201 | +! | +
+ nested_list+ |
+
| 202 | ++ |
+ }+ |
+
| 203 | ++ | + + | +
| 204 | +! | +
+ output$tree <- shinyTree::renderTree({
+ |
+
| 205 | +! | +
+ if (length(input_path) > 0) {
+ |
+
| 206 | +! | +
+ tree_list(input_path)+ |
+
| 207 | ++ |
+ } else {
+ |
+
| 208 | +! | +
+ list("Empty Path" = NULL)
+ |
+
| 209 | ++ |
+ }+ |
+
| 210 | ++ |
+ })+ |
+
| 211 | ++ | + + | +
| 212 | +! | +
+ output$output <- renderUI({
+ |
+
| 213 | +! | +
+ validate(+ |
+
| 214 | +! | +
+ need(+ |
+
| 215 | +! | +
+ length(shinyTree::get_selected(input$tree)) > 0,+ |
+
| 216 | +! | +
+ "Please select a file."+ |
+
| 217 | ++ |
+ )+ |
+
| 218 | ++ |
+ )+ |
+
| 219 | ++ | + + | +
| 220 | +! | +
+ obj <- shinyTree::get_selected(input$tree, format = "names")[[1]]+ |
+
| 221 | +! | +
+ repo <- attr(obj, "ancestry")+ |
+
| 222 | +! | +
+ repo_collapsed <- if (length(repo) > 1) paste0(repo, collapse = "/") else repo+ |
+
| 223 | +! | +
+ is_not_named <- file.exists(file.path(c(repo_collapsed, obj[1])))[1]+ |
+
| 224 | ++ | + + | +
| 225 | +! | +
+ if (is_not_named) {
+ |
+
| 226 | +! | +
+ selected_path <- do.call("file.path", as.list(c(repo, obj[1])))
+ |
+
| 227 | ++ |
+ } else {
+ |
+
| 228 | +! | +
+ if (length(repo) == 0) {
+ |
+
| 229 | +! | +
+ selected_path <- do.call("file.path", as.list(attr(input$tree[[obj[1]]], "ancestry")))
+ |
+
| 230 | ++ |
+ } else {
+ |
+
| 231 | +! | +
+ selected_path <- do.call("file.path", as.list(attr(input$tree[[repo]][[obj[1]]], "ancestry")))
+ |
+
| 232 | ++ |
+ }+ |
+
| 233 | ++ |
+ }+ |
+
| 234 | ++ | + + | +
| 235 | +! | +
+ validate(+ |
+
| 236 | +! | +
+ need(+ |
+
| 237 | +! | +
+ !isTRUE(file.info(selected_path)$isdir) && length(selected_path) > 0,+ |
+
| 238 | +! | +
+ "Please select a single file."+ |
+
| 239 | ++ |
+ )+ |
+
| 240 | ++ |
+ )+ |
+
| 241 | +! | +
+ display_file(selected_path)+ |
+
| 242 | ++ |
+ })+ |
+
| 243 | ++ | + + | +
| 244 | +! | +
+ onStop(function() {
+ |
+
| 245 | +! | +
+ removeResourcePath(basename(temp_dir))+ |
+
| 246 | +! | +
+ unlink(temp_dir)+ |
+
| 247 | ++ |
+ })+ |
+
| 248 | ++ |
+ })+ |
+
| 249 | ++ |
+ }+ |
+
| 1 | ++ |
+ #' `teal` module: Cross-table+ |
+
| 2 | ++ |
+ #'+ |
+
| 3 | ++ |
+ #' Generates a simple cross-table of two variables from a dataset with custom+ |
+
| 4 | ++ |
+ #' options for showing percentages and sub-totals.+ |
+
| 5 | ++ |
+ #'+ |
+
| 6 | ++ |
+ #' @inheritParams teal::module+ |
+
| 7 | ++ |
+ #' @inheritParams shared_params+ |
+
| 8 | ++ |
+ #' @param x (`data_extract_spec` or `list` of multiple `data_extract_spec`)+ |
+
| 9 | ++ |
+ #' Object with all available choices with pre-selected option for variable X - row values.+ |
+
| 10 | ++ |
+ #' In case of `data_extract_spec` use `select_spec(..., ordered = TRUE)` if table elements should be+ |
+
| 11 | ++ |
+ #' rendered according to selection order.+ |
+
| 12 | ++ |
+ #' @param y (`data_extract_spec` or `list` of multiple `data_extract_spec`)+ |
+
| 13 | ++ |
+ #' Object with all available choices with pre-selected option for variable Y - column values.+ |
+
| 14 | ++ |
+ #'+ |
+
| 15 | ++ |
+ #' `data_extract_spec` must not allow multiple selection in this case.+ |
+
| 16 | ++ |
+ #' @param show_percentage (`logical(1)`)+ |
+
| 17 | ++ |
+ #' Indicates whether to show percentages (relevant only when `x` is a `factor`).+ |
+
| 18 | ++ |
+ #' Defaults to `TRUE`.+ |
+
| 19 | ++ |
+ #' @param show_total (`logical(1)`)+ |
+
| 20 | ++ |
+ #' Indicates whether to show total column.+ |
+
| 21 | ++ |
+ #' Defaults to `TRUE`.+ |
+
| 22 | ++ |
+ #'+ |
+
| 23 | ++ |
+ #' @note For more examples, please see the vignette "Using cross table" via+ |
+
| 24 | ++ |
+ #' `vignette("using-cross-table", package = "teal.modules.general")`.
+ |
+
| 25 | ++ |
+ #'+ |
+
| 26 | ++ |
+ #' @inherit shared_params return+ |
+
| 27 | ++ |
+ #'+ |
+
| 28 | ++ |
+ #' @examples+ |
+
| 29 | ++ |
+ #' # general data example+ |
+
| 30 | ++ |
+ #' library(teal.widgets)+ |
+
| 31 | ++ |
+ #'+ |
+
| 32 | ++ |
+ #' data <- teal_data()+ |
+
| 33 | ++ |
+ #' data <- within(data, {
+ |
+
| 34 | ++ |
+ #' mtcars <- mtcars+ |
+
| 35 | ++ |
+ #' for (v in c("cyl", "vs", "am", "gear")) {
+ |
+
| 36 | ++ |
+ #' mtcars[[v]] <- as.factor(mtcars[[v]])+ |
+
| 37 | ++ |
+ #' }+ |
+
| 38 | ++ |
+ #' mtcars[["primary_key"]] <- seq_len(nrow(mtcars))+ |
+
| 39 | ++ |
+ #' })+ |
+
| 40 | ++ |
+ #' datanames(data) <- "mtcars"+ |
+
| 41 | ++ |
+ #' join_keys(data) <- join_keys(join_key("mtcars", "mtcars", "primary_key"))
+ |
+
| 42 | ++ |
+ #'+ |
+
| 43 | ++ |
+ #' app <- init(+ |
+
| 44 | ++ |
+ #' data = data,+ |
+
| 45 | ++ |
+ #' modules = modules(+ |
+
| 46 | ++ |
+ #' tm_t_crosstable(+ |
+
| 47 | ++ |
+ #' label = "Cross Table",+ |
+
| 48 | ++ |
+ #' x = data_extract_spec(+ |
+
| 49 | ++ |
+ #' dataname = "mtcars",+ |
+
| 50 | ++ |
+ #' select = select_spec(+ |
+
| 51 | ++ |
+ #' label = "Select variable:",+ |
+
| 52 | ++ |
+ #' choices = variable_choices(data[["mtcars"]], c("cyl", "vs", "am", "gear")),
+ |
+
| 53 | ++ |
+ #' selected = c("cyl", "gear"),
+ |
+
| 54 | ++ |
+ #' multiple = TRUE,+ |
+
| 55 | ++ |
+ #' ordered = TRUE,+ |
+
| 56 | ++ |
+ #' fixed = FALSE+ |
+
| 57 | ++ |
+ #' )+ |
+
| 58 | ++ |
+ #' ),+ |
+
| 59 | ++ |
+ #' y = data_extract_spec(+ |
+
| 60 | ++ |
+ #' dataname = "mtcars",+ |
+
| 61 | ++ |
+ #' select = select_spec(+ |
+
| 62 | ++ |
+ #' label = "Select variable:",+ |
+
| 63 | ++ |
+ #' choices = variable_choices(data[["mtcars"]], c("cyl", "vs", "am", "gear")),
+ |
+
| 64 | ++ |
+ #' selected = "vs",+ |
+
| 65 | ++ |
+ #' multiple = FALSE,+ |
+
| 66 | ++ |
+ #' fixed = FALSE+ |
+
| 67 | ++ |
+ #' )+ |
+
| 68 | ++ |
+ #' ),+ |
+
| 69 | ++ |
+ #' basic_table_args = basic_table_args(+ |
+
| 70 | ++ |
+ #' subtitles = "Table generated by Crosstable Module"+ |
+
| 71 | ++ |
+ #' )+ |
+
| 72 | ++ |
+ #' )+ |
+
| 73 | ++ |
+ #' )+ |
+
| 74 | ++ |
+ #' )+ |
+
| 75 | ++ |
+ #' if (interactive()) {
+ |
+
| 76 | ++ |
+ #' shinyApp(app$ui, app$server)+ |
+
| 77 | ++ |
+ #' }+ |
+
| 78 | ++ |
+ #'+ |
+
| 79 | ++ |
+ #' # CDISC data example+ |
+
| 80 | ++ |
+ #' library(teal.widgets)+ |
+
| 81 | ++ |
+ #'+ |
+
| 82 | ++ |
+ #' data <- teal_data()+ |
+
| 83 | ++ |
+ #' data <- within(data, {
+ |
+
| 84 | ++ |
+ #' ADSL <- rADSL+ |
+
| 85 | ++ |
+ #' })+ |
+
| 86 | ++ |
+ #' datanames(data) <- "ADSL"+ |
+
| 87 | ++ |
+ #' join_keys(data) <- default_cdisc_join_keys[datanames(data)]+ |
+
| 88 | ++ |
+ #'+ |
+
| 89 | ++ |
+ #' app <- init(+ |
+
| 90 | ++ |
+ #' data = data,+ |
+
| 91 | ++ |
+ #' modules = modules(+ |
+
| 92 | ++ |
+ #' tm_t_crosstable(+ |
+
| 93 | ++ |
+ #' label = "Cross Table",+ |
+
| 94 | ++ |
+ #' x = data_extract_spec(+ |
+
| 95 | ++ |
+ #' dataname = "ADSL",+ |
+
| 96 | ++ |
+ #' select = select_spec(+ |
+
| 97 | ++ |
+ #' label = "Select variable:",+ |
+
| 98 | ++ |
+ #' choices = variable_choices(data[["ADSL"]], subset = function(data) {
+ |
+
| 99 | ++ |
+ #' idx <- !vapply(data, inherits, logical(1), c("Date", "POSIXct", "POSIXlt"))
+ |
+
| 100 | ++ |
+ #' return(names(data)[idx])+ |
+
| 101 | ++ |
+ #' }),+ |
+
| 102 | ++ |
+ #' selected = "COUNTRY",+ |
+
| 103 | ++ |
+ #' multiple = TRUE,+ |
+
| 104 | ++ |
+ #' ordered = TRUE,+ |
+
| 105 | ++ |
+ #' fixed = FALSE+ |
+
| 106 | ++ |
+ #' )+ |
+
| 107 | ++ |
+ #' ),+ |
+
| 108 | ++ |
+ #' y = data_extract_spec(+ |
+
| 109 | ++ |
+ #' dataname = "ADSL",+ |
+
| 110 | ++ |
+ #' select = select_spec(+ |
+
| 111 | ++ |
+ #' label = "Select variable:",+ |
+
| 112 | ++ |
+ #' choices = variable_choices(data[["ADSL"]], subset = function(data) {
+ |
+
| 113 | ++ |
+ #' idx <- vapply(data, is.factor, logical(1))+ |
+
| 114 | ++ |
+ #' return(names(data)[idx])+ |
+
| 115 | ++ |
+ #' }),+ |
+
| 116 | ++ |
+ #' selected = "SEX",+ |
+
| 117 | ++ |
+ #' multiple = FALSE,+ |
+
| 118 | ++ |
+ #' fixed = FALSE+ |
+
| 119 | ++ |
+ #' )+ |
+
| 120 | ++ |
+ #' ),+ |
+
| 121 | ++ |
+ #' basic_table_args = basic_table_args(+ |
+
| 122 | ++ |
+ #' subtitles = "Table generated by Crosstable Module"+ |
+
| 123 | ++ |
+ #' )+ |
+
| 124 | ++ |
+ #' )+ |
+
| 125 | ++ |
+ #' )+ |
+
| 126 | ++ |
+ #' )+ |
+
| 127 | ++ |
+ #' if (interactive()) {
+ |
+
| 128 | ++ |
+ #' shinyApp(app$ui, app$server)+ |
+
| 129 | ++ |
+ #' }+ |
+
| 130 | ++ |
+ #'+ |
+
| 131 | ++ |
+ #' @export+ |
+
| 132 | ++ |
+ #'+ |
+
| 133 | ++ |
+ tm_t_crosstable <- function(label = "Cross Table",+ |
+
| 134 | ++ |
+ x,+ |
+
| 135 | ++ |
+ y,+ |
+
| 136 | ++ |
+ show_percentage = TRUE,+ |
+
| 137 | ++ |
+ show_total = TRUE,+ |
+
| 138 | ++ |
+ pre_output = NULL,+ |
+
| 139 | ++ |
+ post_output = NULL,+ |
+
| 140 | ++ |
+ basic_table_args = teal.widgets::basic_table_args()) {
+ |
+
| 141 | +! | +
+ logger::log_info("Initializing tm_t_crosstable")
+ |
+
| 142 | ++ | + + | +
| 143 | ++ |
+ # Requires Suggested packages+ |
+
| 144 | +! | +
+ if (!requireNamespace("rtables", quietly = TRUE)) {
+ |
+
| 145 | +! | +
+ stop("Cannot load rtables - please install the package or restart your session.")
+ |
+
| 146 | ++ |
+ }+ |
+
| 147 | ++ | + + | +
| 148 | ++ |
+ # Normalize the parameters+ |
+
| 149 | +! | +
+ if (inherits(x, "data_extract_spec")) x <- list(x)+ |
+
| 150 | +! | +
+ if (inherits(y, "data_extract_spec")) y <- list(y)+ |
+
| 151 | ++ | + + | +
| 152 | ++ |
+ # Start of assertions+ |
+
| 153 | +! | +
+ checkmate::assert_string(label)+ |
+
| 154 | +! | +
+ checkmate::assert_list(x, types = "data_extract_spec")+ |
+
| 155 | ++ | + + | +
| 156 | +! | +
+ checkmate::assert_list(y, types = "data_extract_spec")+ |
+
| 157 | +! | +
+ assert_single_selection(y)+ |
+
| 158 | ++ | + + | +
| 159 | +! | +
+ checkmate::assert_flag(show_percentage)+ |
+
| 160 | +! | +
+ checkmate::assert_flag(show_total)+ |
+
| 161 | +! | +
+ checkmate::assert_multi_class(pre_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
+ |
+
| 162 | +! | +
+ checkmate::assert_multi_class(post_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
+ |
+
| 163 | +! | +
+ checkmate::assert_class(basic_table_args, classes = "basic_table_args")+ |
+
| 164 | ++ |
+ # End of assertions+ |
+
| 165 | ++ | + + | +
| 166 | ++ |
+ # Make UI args+ |
+
| 167 | +! | +
+ ui_args <- as.list(environment())+ |
+
| 168 | ++ | + + | +
| 169 | +! | +
+ server_args <- list(+ |
+
| 170 | +! | +
+ label = label,+ |
+
| 171 | +! | +
+ x = x,+ |
+
| 172 | +! | +
+ y = y,+ |
+
| 173 | +! | +
+ basic_table_args = basic_table_args+ |
+
| 174 | ++ |
+ )+ |
+
| 175 | ++ | + + | +
| 176 | +! | +
+ module(+ |
+
| 177 | +! | +
+ label = label,+ |
+
| 178 | +! | +
+ server = srv_t_crosstable,+ |
+
| 179 | +! | +
+ ui = ui_t_crosstable,+ |
+
| 180 | +! | +
+ ui_args = ui_args,+ |
+
| 181 | +! | +
+ server_args = server_args,+ |
+
| 182 | +! | +
+ datanames = teal.transform::get_extract_datanames(list(x = x, y = y))+ |
+
| 183 | ++ |
+ )+ |
+
| 184 | ++ |
+ }+ |
+
| 185 | ++ | + + | +
| 186 | ++ |
+ # UI function for the cross-table module+ |
+
| 187 | ++ |
+ ui_t_crosstable <- function(id, x, y, show_percentage, show_total, pre_output, post_output, ...) {
+ |
+
| 188 | +! | +
+ ns <- NS(id)+ |
+
| 189 | +! | +
+ is_single_dataset <- teal.transform::is_single_dataset(x, y)+ |
+
| 190 | ++ | + + | +
| 191 | +! | +
+ join_default_options <- c(+ |
+
| 192 | +! | +
+ "Full Join" = "dplyr::full_join",+ |
+
| 193 | +! | +
+ "Inner Join" = "dplyr::inner_join",+ |
+
| 194 | +! | +
+ "Left Join" = "dplyr::left_join",+ |
+
| 195 | +! | +
+ "Right Join" = "dplyr::right_join"+ |
+
| 196 | ++ |
+ )+ |
+
| 197 | ++ | + + | +
| 198 | +! | +
+ teal.widgets::standard_layout(+ |
+
| 199 | +! | +
+ output = teal.widgets::white_small_well(+ |
+
| 200 | +! | +
+ textOutput(ns("title")),
+ |
+
| 201 | +! | +
+ teal.widgets::table_with_settings_ui(ns("table"))
+ |
+
| 202 | ++ |
+ ),+ |
+
| 203 | +! | +
+ encoding = div(+ |
+
| 204 | ++ |
+ ### Reporter+ |
+
| 205 | +! | +
+ teal.reporter::simple_reporter_ui(ns("simple_reporter")),
+ |
+
| 206 | ++ |
+ ###+ |
+
| 207 | +! | +
+ tags$label("Encodings", class = "text-primary"),
+ |
+
| 208 | +! | +
+ teal.transform::datanames_input(list(x, y)),+ |
+
| 209 | +! | +
+ teal.transform::data_extract_ui(ns("x"), label = "Row values", x, is_single_dataset = is_single_dataset),
+ |
+
| 210 | +! | +
+ teal.transform::data_extract_ui(ns("y"), label = "Column values", y, is_single_dataset = is_single_dataset),
+ |
+
| 211 | +! | +
+ teal.widgets::optionalSelectInput(+ |
+
| 212 | +! | +
+ ns("join_fun"),
+ |
+
| 213 | +! | +
+ label = "Row to Column type of join",+ |
+
| 214 | +! | +
+ choices = join_default_options,+ |
+
| 215 | +! | +
+ selected = join_default_options[1],+ |
+
| 216 | +! | +
+ multiple = FALSE+ |
+
| 217 | ++ |
+ ),+ |
+
| 218 | +! | +
+ tags$hr(),+ |
+
| 219 | +! | +
+ teal.widgets::panel_group(+ |
+
| 220 | +! | +
+ teal.widgets::panel_item(+ |
+
| 221 | +! | +
+ title = "Table settings",+ |
+
| 222 | +! | +
+ checkboxInput(ns("show_percentage"), "Show column percentage", value = show_percentage),
+ |
+
| 223 | +! | +
+ checkboxInput(ns("show_total"), "Show total column", value = show_total)
+ |
+
| 224 | ++ |
+ )+ |
+
| 225 | ++ |
+ )+ |
+
| 226 | ++ |
+ ),+ |
+
| 227 | +! | +
+ forms = tagList(+ |
+
| 228 | +! | +
+ teal.widgets::verbatim_popup_ui(ns("warning"), "Show Warnings"),
+ |
+
| 229 | +! | +
+ teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code")
+ |
+
| 230 | ++ |
+ ),+ |
+
| 231 | +! | +
+ pre_output = pre_output,+ |
+
| 232 | +! | +
+ post_output = post_output+ |
+
| 233 | ++ |
+ )+ |
+
| 234 | ++ |
+ }+ |
+
| 235 | ++ | + + | +
| 236 | ++ |
+ # Server function for the cross-table module+ |
+
| 237 | ++ |
+ srv_t_crosstable <- function(id, data, reporter, filter_panel_api, label, x, y, basic_table_args) {
+ |
+
| 238 | +! | +
+ with_reporter <- !missing(reporter) && inherits(reporter, "Reporter")+ |
+
| 239 | +! | +
+ with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI")+ |
+
| 240 | +! | +
+ checkmate::assert_class(data, "reactive")+ |
+
| 241 | +! | +
+ checkmate::assert_class(isolate(data()), "teal_data")+ |
+
| 242 | +! | +
+ moduleServer(id, function(input, output, session) {
+ |
+
| 243 | +! | +
+ selector_list <- teal.transform::data_extract_multiple_srv(+ |
+
| 244 | +! | +
+ data_extract = list(x = x, y = y),+ |
+
| 245 | +! | +
+ datasets = data,+ |
+
| 246 | +! | +
+ select_validation_rule = list(+ |
+
| 247 | +! | +
+ x = shinyvalidate::sv_required("Please define column for row variable."),
+ |
+
| 248 | +! | +
+ y = shinyvalidate::sv_required("Please define column for column variable.")
+ |
+
| 249 | ++ |
+ )+ |
+
| 250 | ++ |
+ )+ |
+
| 251 | ++ | + + | +
| 252 | +! | +
+ iv_r <- reactive({
+ |
+
| 253 | +! | +
+ iv <- shinyvalidate::InputValidator$new()+ |
+
| 254 | +! | +
+ iv$add_rule("join_fun", function(value) {
+ |
+
| 255 | +! | +
+ if (!identical(selector_list()$x()$dataname, selector_list()$y()$dataname)) {
+ |
+
| 256 | +! | +
+ if (!shinyvalidate::input_provided(value)) {
+ |
+
| 257 | +! | +
+ "Please select a joining function."+ |
+
| 258 | ++ |
+ }+ |
+
| 259 | ++ |
+ }+ |
+
| 260 | ++ |
+ })+ |
+
| 261 | +! | +
+ teal.transform::compose_and_enable_validators(iv, selector_list)+ |
+
| 262 | ++ |
+ })+ |
+
| 263 | ++ | + + | +
| 264 | +! | +
+ observeEvent(+ |
+
| 265 | +! | +
+ eventExpr = {
+ |
+
| 266 | +! | +
+ req(!is.null(selector_list()$x()) && !is.null(selector_list()$y()))+ |
+
| 267 | +! | +
+ list(selector_list()$x(), selector_list()$y())+ |
+
| 268 | ++ |
+ },+ |
+
| 269 | +! | +
+ handlerExpr = {
+ |
+
| 270 | +! | +
+ if (identical(selector_list()$x()$dataname, selector_list()$y()$dataname)) {
+ |
+
| 271 | +! | +
+ shinyjs::hide("join_fun")
+ |
+
| 272 | ++ |
+ } else {
+ |
+
| 273 | +! | +
+ shinyjs::show("join_fun")
+ |
+
| 274 | ++ |
+ }+ |
+
| 275 | ++ |
+ }+ |
+
| 276 | ++ |
+ )+ |
+
| 277 | ++ | + + | +
| 278 | +! | +
+ merge_function <- reactive({
+ |
+
| 279 | +! | +
+ if (is.null(input$join_fun)) {
+ |
+
| 280 | +! | +
+ "dplyr::full_join"+ |
+
| 281 | ++ |
+ } else {
+ |
+
| 282 | +! | +
+ input$join_fun+ |
+
| 283 | ++ |
+ }+ |
+
| 284 | ++ |
+ })+ |
+
| 285 | ++ | + + | +
| 286 | +! | +
+ anl_merged_input <- teal.transform::merge_expression_srv(+ |
+
| 287 | +! | +
+ datasets = data,+ |
+
| 288 | +! | +
+ selector_list = selector_list,+ |
+
| 289 | +! | +
+ merge_function = merge_function+ |
+
| 290 | ++ |
+ )+ |
+
| 291 | ++ | + + | +
| 292 | +! | +
+ anl_merged_q <- reactive({
+ |
+
| 293 | +! | +
+ req(anl_merged_input())+ |
+
| 294 | +! | +
+ data() %>%+ |
+
| 295 | +! | +
+ teal.code::eval_code(as.expression(anl_merged_input()$expr))+ |
+
| 296 | ++ |
+ })+ |
+
| 297 | ++ | + + | +
| 298 | +! | +
+ merged <- list(+ |
+
| 299 | +! | +
+ anl_input_r = anl_merged_input,+ |
+
| 300 | +! | +
+ anl_q_r = anl_merged_q+ |
+
| 301 | ++ |
+ )+ |
+
| 302 | ++ | + + | +
| 303 | +! | +
+ output_q <- reactive({
+ |
+
| 304 | +! | +
+ teal::validate_inputs(iv_r())+ |
+
| 305 | +! | +
+ ANL <- merged$anl_q_r()[["ANL"]]+ |
+
| 306 | ++ | + + | +
| 307 | ++ |
+ # As this is a summary+ |
+
| 308 | +! | +
+ x_name <- as.vector(merged$anl_input_r()$columns_source$x)+ |
+
| 309 | +! | +
+ y_name <- as.vector(merged$anl_input_r()$columns_source$y)+ |
+
| 310 | ++ | + + | +
| 311 | +! | +
+ teal::validate_has_data(ANL, 3)+ |
+
| 312 | +! | +
+ teal::validate_has_data(ANL[, c(x_name, y_name)], 3, complete = TRUE, allow_inf = FALSE)+ |
+
| 313 | ++ | + + | +
| 314 | +! | +
+ is_allowed_class <- function(x) is.numeric(x) || is.factor(x) || is.character(x) || is.logical(x)+ |
+
| 315 | +! | +
+ validate(need(+ |
+
| 316 | +! | +
+ all(vapply(ANL[x_name], is_allowed_class, logical(1))),+ |
+
| 317 | +! | +
+ "Selected row variable has an unsupported data type."+ |
+
| 318 | ++ |
+ ))+ |
+
| 319 | +! | +
+ validate(need(+ |
+
| 320 | +! | +
+ is_allowed_class(ANL[[y_name]]),+ |
+
| 321 | +! | +
+ "Selected column variable has an unsupported data type."+ |
+
| 322 | ++ |
+ ))+ |
+
| 323 | ++ | + + | +
| 324 | +! | +
+ show_percentage <- input$show_percentage+ |
+
| 325 | +! | +
+ show_total <- input$show_total+ |
+
| 326 | ++ | + + | +
| 327 | +! | +
+ plot_title <- paste(+ |
+
| 328 | +! | +
+ "Cross-Table of",+ |
+
| 329 | +! | +
+ paste0(varname_w_label(x_name, ANL), collapse = ", "),+ |
+
| 330 | +! | +
+ "(rows)", "vs.",+ |
+
| 331 | +! | +
+ varname_w_label(y_name, ANL),+ |
+
| 332 | +! | +
+ "(columns)"+ |
+
| 333 | ++ |
+ )+ |
+
| 334 | ++ | + + | +
| 335 | +! | +
+ labels_vec <- vapply(+ |
+
| 336 | +! | +
+ x_name,+ |
+
| 337 | +! | +
+ varname_w_label,+ |
+
| 338 | +! | +
+ character(1),+ |
+
| 339 | +! | +
+ ANL+ |
+
| 340 | ++ |
+ )+ |
+
| 341 | ++ | + + | +
| 342 | +! | +
+ teal.code::eval_code(+ |
+
| 343 | +! | +
+ merged$anl_q_r(),+ |
+
| 344 | +! | +
+ substitute(+ |
+
| 345 | +! | +
+ expr = {
+ |
+
| 346 | +! | +
+ title <- plot_title+ |
+
| 347 | ++ |
+ },+ |
+
| 348 | +! | +
+ env = list(plot_title = plot_title)+ |
+
| 349 | ++ |
+ )+ |
+
| 350 | ++ |
+ ) %>%+ |
+
| 351 | +! | +
+ teal.code::eval_code(+ |
+
| 352 | +! | +
+ substitute(+ |
+
| 353 | +! | +
+ expr = {
+ |
+
| 354 | +! | +
+ lyt <- basic_tables %>%+ |
+
| 355 | +! | +
+ split_call %>% # styler: off+ |
+
| 356 | +! | +
+ rtables::add_colcounts() %>%+ |
+
| 357 | +! | +
+ tern::analyze_vars(+ |
+
| 358 | +! | +
+ vars = x_name,+ |
+
| 359 | +! | +
+ var_labels = labels_vec,+ |
+
| 360 | +! | +
+ na.rm = FALSE,+ |
+
| 361 | +! | +
+ denom = "N_col",+ |
+
| 362 | +! | +
+ .stats = c("mean_sd", "median", "range", count_value)
+ |
+
| 363 | ++ |
+ )+ |
+
| 364 | ++ |
+ },+ |
+
| 365 | +! | +
+ env = list(+ |
+
| 366 | +! | +
+ basic_tables = teal.widgets::parse_basic_table_args(+ |
+
| 367 | +! | +
+ basic_table_args = teal.widgets::resolve_basic_table_args(basic_table_args)+ |
+
| 368 | ++ |
+ ),+ |
+
| 369 | +! | +
+ split_call = if (show_total) {
+ |
+
| 370 | +! | +
+ substitute(+ |
+
| 371 | +! | +
+ expr = rtables::split_cols_by(+ |
+
| 372 | +! | +
+ y_name,+ |
+
| 373 | +! | +
+ split_fun = rtables::add_overall_level(label = "Total", first = FALSE)+ |
+
| 374 | ++ |
+ ),+ |
+
| 375 | +! | +
+ env = list(y_name = y_name)+ |
+
| 376 | ++ |
+ )+ |
+
| 377 | ++ |
+ } else {
+ |
+
| 378 | +! | +
+ substitute(rtables::split_cols_by(y_name), env = list(y_name = y_name))+ |
+
| 379 | ++ |
+ },+ |
+
| 380 | +! | +
+ x_name = x_name,+ |
+
| 381 | +! | +
+ labels_vec = labels_vec,+ |
+
| 382 | +! | +
+ count_value = ifelse(show_percentage, "count_fraction", "count")+ |
+
| 383 | ++ |
+ )+ |
+
| 384 | ++ |
+ )+ |
+
| 385 | ++ |
+ ) %>%+ |
+
| 386 | +! | +
+ teal.code::eval_code(+ |
+
| 387 | +! | +
+ substitute(+ |
+
| 388 | +! | +
+ expr = {
+ |
+
| 389 | +! | +
+ ANL <- tern::df_explicit_na(ANL)+ |
+
| 390 | +! | +
+ tbl <- rtables::build_table(lyt = lyt, df = ANL[order(ANL[[y_name]]), ])+ |
+
| 391 | +! | +
+ tbl+ |
+
| 392 | ++ |
+ },+ |
+
| 393 | +! | +
+ env = list(y_name = y_name)+ |
+
| 394 | ++ |
+ )+ |
+
| 395 | ++ |
+ )+ |
+
| 396 | ++ |
+ })+ |
+
| 397 | ++ | + + | +
| 398 | +! | +
+ output$title <- renderText(output_q()[["title"]])+ |
+
| 399 | ++ | + + | +
| 400 | +! | +
+ table_r <- reactive({
+ |
+
| 401 | +! | +
+ shiny::req(iv_r()$is_valid())+ |
+
| 402 | +! | +
+ output_q()[["tbl"]]+ |
+
| 403 | ++ |
+ })+ |
+
| 404 | ++ | + + | +
| 405 | +! | +
+ teal.widgets::table_with_settings_srv(+ |
+
| 406 | +! | +
+ id = "table",+ |
+
| 407 | +! | +
+ table_r = table_r+ |
+
| 408 | ++ |
+ )+ |
+
| 409 | ++ | + + | +
| 410 | +! | +
+ teal.widgets::verbatim_popup_srv(+ |
+
| 411 | +! | +
+ id = "warning",+ |
+
| 412 | +! | +
+ verbatim_content = reactive(teal.code::get_warnings(output_q())),+ |
+
| 413 | +! | +
+ title = "Warning",+ |
+
| 414 | +! | +
+ disabled = reactive(is.null(teal.code::get_warnings(output_q())))+ |
+
| 415 | ++ |
+ )+ |
+
| 416 | ++ | + + | +
| 417 | +! | +
+ teal.widgets::verbatim_popup_srv(+ |
+
| 418 | +! | +
+ id = "rcode",+ |
+
| 419 | +! | +
+ verbatim_content = reactive(teal.code::get_code(output_q())),+ |
+
| 420 | +! | +
+ title = "Show R Code for Cross-Table"+ |
+
| 421 | ++ |
+ )+ |
+
| 422 | ++ | + + | +
| 423 | ++ |
+ ### REPORTER+ |
+
| 424 | +! | +
+ if (with_reporter) {
+ |
+
| 425 | +! | +
+ card_fun <- function(comment, label) {
+ |
+
| 426 | +! | +
+ card <- teal::report_card_template(+ |
+
| 427 | +! | +
+ title = "Cross Table",+ |
+
| 428 | +! | +
+ label = label,+ |
+
| 429 | +! | +
+ with_filter = with_filter,+ |
+
| 430 | +! | +
+ filter_panel_api = filter_panel_api+ |
+
| 431 | ++ |
+ )+ |
+
| 432 | +! | +
+ card$append_text("Table", "header3")
+ |
+
| 433 | +! | +
+ card$append_table(table_r())+ |
+
| 434 | +! | +
+ if (!comment == "") {
+ |
+
| 435 | +! | +
+ card$append_text("Comment", "header3")
+ |
+
| 436 | +! | +
+ card$append_text(comment)+ |
+
| 437 | ++ |
+ }+ |
+
| 438 | +! | +
+ card$append_src(teal.code::get_code(output_q()))+ |
+
| 439 | +! | +
+ card+ |
+
| 440 | ++ |
+ }+ |
+
| 441 | +! | +
+ teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
+ |
+
| 442 | ++ |
+ }+ |
+
| 443 | ++ |
+ ###+ |
+
| 444 | ++ |
+ })+ |
+
| 445 | ++ |
+ }+ |
+
| 1 | ++ |
+ #' `teal` module: Scatterplot matrix+ |
+
| 2 | ++ |
+ #'+ |
+
| 3 | ++ |
+ #' Generates a scatterplot matrix from selected `variables` from datasets.+ |
+
| 4 | ++ |
+ #' Each plot within the matrix represents the relationship between two variables,+ |
+
| 5 | ++ |
+ #' providing the overview of correlations and distributions across selected data.+ |
+
| 6 | ++ |
+ #'+ |
+
| 7 | ++ |
+ #' @note For more examples, please see the vignette "Using scatterplot matrix" via+ |
+
| 8 | ++ |
+ #' `vignette("using-scatterplot-matrix", package = "teal.modules.general")`.
+ |
+
| 9 | ++ |
+ #'+ |
+
| 10 | ++ |
+ #' @inheritParams teal::module+ |
+
| 11 | ++ |
+ #' @inheritParams tm_g_scatterplot+ |
+
| 12 | ++ |
+ #' @inheritParams shared_params+ |
+
| 13 | ++ |
+ #'+ |
+
| 14 | ++ |
+ #' @param variables (`data_extract_spec` or `list` of multiple `data_extract_spec`)+ |
+
| 15 | ++ |
+ #' Specifies plotting variables from an incoming dataset with filtering and selecting. In case of+ |
+
| 16 | ++ |
+ #' `data_extract_spec` use `select_spec(..., ordered = TRUE)` if plot elements should be+ |
+
| 17 | ++ |
+ #' rendered according to selection order.+ |
+
| 18 | ++ |
+ #'+ |
+
| 19 | ++ |
+ #' @inherit shared_params return+ |
+
| 20 | ++ |
+ #'+ |
+
| 21 | ++ |
+ #' @examples+ |
+
| 22 | ++ |
+ #' # general data example+ |
+
| 23 | ++ |
+ #' data <- teal_data()+ |
+
| 24 | ++ |
+ #' data <- within(data, {
+ |
+
| 25 | ++ |
+ #' countries <- data.frame(+ |
+
| 26 | ++ |
+ #' id = c("DE", "FR", "IT", "ES", "PT", "GR", "NL", "BE", "LU", "AT"),
+ |
+
| 27 | ++ |
+ #' government = factor(+ |
+
| 28 | ++ |
+ #' c(2, 2, 2, 1, 2, 2, 1, 1, 1, 2),+ |
+
| 29 | ++ |
+ #' labels = c("Monarchy", "Republic")
+ |
+
| 30 | ++ |
+ #' ),+ |
+
| 31 | ++ |
+ #' language_family = factor(+ |
+
| 32 | ++ |
+ #' c(1, 3, 3, 3, 3, 2, 1, 1, 3, 1),+ |
+
| 33 | ++ |
+ #' labels = c("Germanic", "Hellenic", "Romance")
+ |
+
| 34 | ++ |
+ #' ),+ |
+
| 35 | ++ |
+ #' population = c(83, 67, 60, 47, 10, 11, 17, 11, 0.6, 9),+ |
+
| 36 | ++ |
+ #' area = c(357, 551, 301, 505, 92, 132, 41, 30, 2.6, 83),+ |
+
| 37 | ++ |
+ #' gdp = c(3.4, 2.7, 2.1, 1.4, 0.3, 0.2, 0.7, 0.5, 0.1, 0.4),+ |
+
| 38 | ++ |
+ #' debt = c(2.1, 2.3, 2.4, 2.6, 2.3, 2.4, 2.3, 2.4, 2.3, 2.4)+ |
+
| 39 | ++ |
+ #' )+ |
+
| 40 | ++ |
+ #' sales <- data.frame(+ |
+
| 41 | ++ |
+ #' id = 1:50,+ |
+
| 42 | ++ |
+ #' country_id = sample(+ |
+
| 43 | ++ |
+ #' c("DE", "FR", "IT", "ES", "PT", "GR", "NL", "BE", "LU", "AT"),
+ |
+
| 44 | ++ |
+ #' size = 50,+ |
+
| 45 | ++ |
+ #' replace = TRUE+ |
+
| 46 | ++ |
+ #' ),+ |
+
| 47 | ++ |
+ #' year = sort(sample(2010:2020, 50, replace = TRUE)),+ |
+
| 48 | ++ |
+ #' venue = sample(c("small", "medium", "large", "online"), 50, replace = TRUE),
+ |
+
| 49 | ++ |
+ #' cancelled = sample(c(TRUE, FALSE), 50, replace = TRUE),+ |
+
| 50 | ++ |
+ #' quantity = rnorm(50, 100, 20),+ |
+
| 51 | ++ |
+ #' costs = rnorm(50, 80, 20),+ |
+
| 52 | ++ |
+ #' profit = rnorm(50, 20, 10)+ |
+
| 53 | ++ |
+ #' )+ |
+
| 54 | ++ |
+ #' })+ |
+
| 55 | ++ |
+ #' datanames(data) <- c("countries", "sales")
+ |
+
| 56 | ++ |
+ #' join_keys(data) <- join_keys(+ |
+
| 57 | ++ |
+ #' join_key("countries", "countries", "id"),
+ |
+
| 58 | ++ |
+ #' join_key("sales", "sales", "id"),
+ |
+
| 59 | ++ |
+ #' join_key("countries", "sales", c("id" = "country_id"))
+ |
+
| 60 | ++ |
+ #' )+ |
+
| 61 | ++ |
+ #'+ |
+
| 62 | ++ |
+ #' app <- init(+ |
+
| 63 | ++ |
+ #' data = data,+ |
+
| 64 | ++ |
+ #' modules = modules(+ |
+
| 65 | ++ |
+ #' tm_g_scatterplotmatrix(+ |
+
| 66 | ++ |
+ #' label = "Scatterplot matrix",+ |
+
| 67 | ++ |
+ #' variables = list(+ |
+
| 68 | ++ |
+ #' data_extract_spec(+ |
+
| 69 | ++ |
+ #' dataname = "countries",+ |
+
| 70 | ++ |
+ #' select = select_spec(+ |
+
| 71 | ++ |
+ #' label = "Select variables:",+ |
+
| 72 | ++ |
+ #' choices = variable_choices(data[["countries"]]),+ |
+
| 73 | ++ |
+ #' selected = c("area", "gdp", "debt"),
+ |
+
| 74 | ++ |
+ #' multiple = TRUE,+ |
+
| 75 | ++ |
+ #' ordered = TRUE,+ |
+
| 76 | ++ |
+ #' fixed = FALSE+ |
+
| 77 | ++ |
+ #' )+ |
+
| 78 | ++ |
+ #' ),+ |
+
| 79 | ++ |
+ #' data_extract_spec(+ |
+
| 80 | ++ |
+ #' dataname = "sales",+ |
+
| 81 | ++ |
+ #' filter = filter_spec(+ |
+
| 82 | ++ |
+ #' label = "Select variable:",+ |
+
| 83 | ++ |
+ #' vars = "country_id",+ |
+
| 84 | ++ |
+ #' choices = value_choices(data[["sales"]], "country_id"),+ |
+
| 85 | ++ |
+ #' selected = c("DE", "FR", "IT", "ES", "PT", "GR", "NL", "BE", "LU", "AT"),
+ |
+
| 86 | ++ |
+ #' multiple = TRUE+ |
+
| 87 | ++ |
+ #' ),+ |
+
| 88 | ++ |
+ #' select = select_spec(+ |
+
| 89 | ++ |
+ #' label = "Select variables:",+ |
+
| 90 | ++ |
+ #' choices = variable_choices(data[["sales"]], c("quantity", "costs", "profit")),
+ |
+
| 91 | ++ |
+ #' selected = c("quantity", "costs", "profit"),
+ |
+
| 92 | ++ |
+ #' multiple = TRUE,+ |
+
| 93 | ++ |
+ #' ordered = TRUE,+ |
+
| 94 | ++ |
+ #' fixed = FALSE+ |
+
| 95 | ++ |
+ #' )+ |
+
| 96 | ++ |
+ #' )+ |
+
| 97 | ++ |
+ #' )+ |
+
| 98 | ++ |
+ #' )+ |
+
| 99 | ++ |
+ #' )+ |
+
| 100 | ++ |
+ #' )+ |
+
| 101 | ++ |
+ #' if (interactive()) {
+ |
+
| 102 | ++ |
+ #' shinyApp(app$ui, app$server)+ |
+
| 103 | ++ |
+ #' }+ |
+
| 104 | ++ |
+ #'+ |
+
| 105 | ++ |
+ #' # CDISC data example+ |
+
| 106 | ++ |
+ #' data <- teal_data()+ |
+
| 107 | ++ |
+ #' data <- within(data, {
+ |
+
| 108 | ++ |
+ #' ADSL <- rADSL+ |
+
| 109 | ++ |
+ #' ADRS <- rADRS+ |
+
| 110 | ++ |
+ #' })+ |
+
| 111 | ++ |
+ #' datanames(data) <- c("ADSL", "ADRS")
+ |
+
| 112 | ++ |
+ #' join_keys(data) <- default_cdisc_join_keys[datanames(data)]+ |
+
| 113 | ++ |
+ #'+ |
+
| 114 | ++ |
+ #' app <- init(+ |
+
| 115 | ++ |
+ #' data = data,+ |
+
| 116 | ++ |
+ #' modules = modules(+ |
+
| 117 | ++ |
+ #' tm_g_scatterplotmatrix(+ |
+
| 118 | ++ |
+ #' label = "Scatterplot matrix",+ |
+
| 119 | ++ |
+ #' variables = list(+ |
+
| 120 | ++ |
+ #' data_extract_spec(+ |
+
| 121 | ++ |
+ #' dataname = "ADSL",+ |
+
| 122 | ++ |
+ #' select = select_spec(+ |
+
| 123 | ++ |
+ #' label = "Select variables:",+ |
+
| 124 | ++ |
+ #' choices = variable_choices(data[["ADSL"]]),+ |
+
| 125 | ++ |
+ #' selected = c("AGE", "RACE", "SEX"),
+ |
+
| 126 | ++ |
+ #' multiple = TRUE,+ |
+
| 127 | ++ |
+ #' ordered = TRUE,+ |
+
| 128 | ++ |
+ #' fixed = FALSE+ |
+
| 129 | ++ |
+ #' )+ |
+
| 130 | ++ |
+ #' ),+ |
+
| 131 | ++ |
+ #' data_extract_spec(+ |
+
| 132 | ++ |
+ #' dataname = "ADRS",+ |
+
| 133 | ++ |
+ #' filter = filter_spec(+ |
+
| 134 | ++ |
+ #' label = "Select endpoints:",+ |
+
| 135 | ++ |
+ #' vars = c("PARAMCD", "AVISIT"),
+ |
+
| 136 | ++ |
+ #' choices = value_choices(data[["ADRS"]], c("PARAMCD", "AVISIT"), c("PARAM", "AVISIT")),
+ |
+
| 137 | ++ |
+ #' selected = "INVET - END OF INDUCTION",+ |
+
| 138 | ++ |
+ #' multiple = TRUE+ |
+
| 139 | ++ |
+ #' ),+ |
+
| 140 | ++ |
+ #' select = select_spec(+ |
+
| 141 | ++ |
+ #' label = "Select variables:",+ |
+
| 142 | ++ |
+ #' choices = variable_choices(data[["ADRS"]]),+ |
+
| 143 | ++ |
+ #' selected = c("AGE", "AVAL", "ADY"),
+ |
+
| 144 | ++ |
+ #' multiple = TRUE,+ |
+
| 145 | ++ |
+ #' ordered = TRUE,+ |
+
| 146 | ++ |
+ #' fixed = FALSE+ |
+
| 147 | ++ |
+ #' )+ |
+
| 148 | ++ |
+ #' )+ |
+
| 149 | ++ |
+ #' )+ |
+
| 150 | ++ |
+ #' )+ |
+
| 151 | ++ |
+ #' )+ |
+
| 152 | ++ |
+ #' )+ |
+
| 153 | ++ |
+ #' if (interactive()) {
+ |
+
| 154 | ++ |
+ #' shinyApp(app$ui, app$server)+ |
+
| 155 | ++ |
+ #' }+ |
+
| 156 | ++ |
+ #'+ |
+
| 157 | ++ |
+ #' @export+ |
+
| 158 | ++ |
+ #'+ |
+
| 159 | ++ |
+ tm_g_scatterplotmatrix <- function(label = "Scatterplot Matrix",+ |
+
| 160 | ++ |
+ variables,+ |
+
| 161 | ++ |
+ plot_height = c(600, 200, 2000),+ |
+
| 162 | ++ |
+ plot_width = NULL,+ |
+
| 163 | ++ |
+ pre_output = NULL,+ |
+
| 164 | ++ |
+ post_output = NULL) {
+ |
+
| 165 | +! | +
+ logger::log_info("Initializing tm_g_scatterplotmatrix")
+ |
+
| 166 | ++ | + + | +
| 167 | ++ |
+ # Requires Suggested packages+ |
+
| 168 | +! | +
+ if (!requireNamespace("lattice", quietly = TRUE)) {
+ |
+
| 169 | +! | +
+ stop("Cannot load lattice - please install the package or restart your session.")
+ |
+
| 170 | ++ |
+ }+ |
+
| 171 | ++ | + + | +
| 172 | ++ |
+ # Normalize the parameters+ |
+
| 173 | +! | +
+ if (inherits(variables, "data_extract_spec")) variables <- list(variables)+ |
+
| 174 | ++ | + + | +
| 175 | ++ |
+ # Start of assertions+ |
+
| 176 | +! | +
+ checkmate::assert_string(label)+ |
+
| 177 | +! | +
+ checkmate::assert_list(variables, types = "data_extract_spec")+ |
+
| 178 | ++ | + + | +
| 179 | +! | +
+ checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE)+ |
+
| 180 | +! | +
+ checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height")+ |
+
| 181 | +! | +
+ checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE)+ |
+
| 182 | +! | +
+ checkmate::assert_numeric(+ |
+
| 183 | +! | +
+ plot_width[1],+ |
+
| 184 | +! | +
+ lower = plot_width[2], upper = plot_width[3], null.ok = TRUE, .var.name = "plot_width"+ |
+
| 185 | ++ |
+ )+ |
+
| 186 | ++ | + + | +
| 187 | +! | +
+ checkmate::assert_multi_class(pre_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
+ |
+
| 188 | +! | +
+ checkmate::assert_multi_class(post_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
+ |
+
| 189 | ++ |
+ # End of assertions+ |
+
| 190 | ++ | + + | +
| 191 | ++ |
+ # Make UI args+ |
+
| 192 | +! | +
+ args <- as.list(environment())+ |
+
| 193 | ++ | + + | +
| 194 | +! | +
+ module(+ |
+
| 195 | +! | +
+ label = label,+ |
+
| 196 | +! | +
+ server = srv_g_scatterplotmatrix,+ |
+
| 197 | +! | +
+ ui = ui_g_scatterplotmatrix,+ |
+
| 198 | +! | +
+ ui_args = args,+ |
+
| 199 | +! | +
+ server_args = list(variables = variables, plot_height = plot_height, plot_width = plot_width),+ |
+
| 200 | +! | +
+ datanames = teal.transform::get_extract_datanames(variables)+ |
+
| 201 | ++ |
+ )+ |
+
| 202 | ++ |
+ }+ |
+
| 203 | ++ | + + | +
| 204 | ++ |
+ # UI function for the scatterplot matrix module+ |
+
| 205 | ++ |
+ ui_g_scatterplotmatrix <- function(id, ...) {
+ |
+
| 206 | +! | +
+ args <- list(...)+ |
+
| 207 | +! | +
+ is_single_dataset_value <- teal.transform::is_single_dataset(args$variables)+ |
+
| 208 | +! | +
+ ns <- NS(id)+ |
+
| 209 | +! | +
+ teal.widgets::standard_layout(+ |
+
| 210 | +! | +
+ output = teal.widgets::white_small_well(+ |
+
| 211 | +! | +
+ textOutput(ns("message")),
+ |
+
| 212 | +! | +
+ br(),+ |
+
| 213 | +! | +
+ teal.widgets::plot_with_settings_ui(id = ns("myplot"))
+ |
+
| 214 | ++ |
+ ),+ |
+
| 215 | +! | +
+ encoding = div(+ |
+
| 216 | ++ |
+ ### Reporter+ |
+
| 217 | +! | +
+ teal.reporter::simple_reporter_ui(ns("simple_reporter")),
+ |
+
| 218 | ++ |
+ ###+ |
+
| 219 | +! | +
+ tags$label("Encodings", class = "text-primary"),
+ |
+
| 220 | +! | +
+ teal.transform::datanames_input(args$variables),+ |
+
| 221 | +! | +
+ teal.transform::data_extract_ui(+ |
+
| 222 | +! | +
+ id = ns("variables"),
+ |
+
| 223 | +! | +
+ label = "Variables",+ |
+
| 224 | +! | +
+ data_extract_spec = args$variables,+ |
+
| 225 | +! | +
+ is_single_dataset = is_single_dataset_value+ |
+
| 226 | ++ |
+ ),+ |
+
| 227 | +! | +
+ hr(),+ |
+
| 228 | +! | +
+ teal.widgets::panel_group(+ |
+
| 229 | +! | +
+ teal.widgets::panel_item(+ |
+
| 230 | +! | +
+ title = "Plot settings",+ |
+
| 231 | +! | +
+ sliderInput(+ |
+
| 232 | +! | +
+ ns("alpha"), "Opacity:",
+ |
+
| 233 | +! | +
+ min = 0, max = 1,+ |
+
| 234 | +! | +
+ step = .05, value = .5, ticks = FALSE+ |
+
| 235 | ++ |
+ ),+ |
+
| 236 | +! | +
+ sliderInput(+ |
+
| 237 | +! | +
+ ns("cex"), "Points size:",
+ |
+
| 238 | +! | +
+ min = 0.2, max = 3,+ |
+
| 239 | +! | +
+ step = .05, value = .65, ticks = FALSE+ |
+
| 240 | ++ |
+ ),+ |
+
| 241 | +! | +
+ checkboxInput(ns("cor"), "Add Correlation", value = FALSE),
+ |
+
| 242 | +! | +
+ radioButtons(+ |
+
| 243 | +! | +
+ ns("cor_method"), "Select Correlation Method",
+ |
+
| 244 | +! | +
+ choiceNames = c("Pearson", "Kendall", "Spearman"),
+ |
+
| 245 | +! | +
+ choiceValues = c("pearson", "kendall", "spearman"),
+ |
+
| 246 | +! | +
+ inline = TRUE+ |
+
| 247 | ++ |
+ ),+ |
+
| 248 | +! | +
+ checkboxInput(ns("cor_na_omit"), "Omit Missing Values", value = TRUE)
+ |
+
| 249 | ++ |
+ )+ |
+
| 250 | ++ |
+ )+ |
+
| 251 | ++ |
+ ),+ |
+
| 252 | +! | +
+ forms = tagList(+ |
+
| 253 | +! | +
+ teal.widgets::verbatim_popup_ui(ns("warning"), "Show Warnings"),
+ |
+
| 254 | +! | +
+ teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code")
+ |
+
| 255 | ++ |
+ ),+ |
+
| 256 | +! | +
+ pre_output = args$pre_output,+ |
+
| 257 | +! | +
+ post_output = args$post_output+ |
+
| 258 | ++ |
+ )+ |
+
| 259 | ++ |
+ }+ |
+
| 260 | ++ | + + | +
| 261 | ++ |
+ # Server function for the scatterplot matrix module+ |
+
| 262 | ++ |
+ srv_g_scatterplotmatrix <- function(id, data, reporter, filter_panel_api, variables, plot_height, plot_width) {
+ |
+
| 263 | +! | +
+ with_reporter <- !missing(reporter) && inherits(reporter, "Reporter")+ |
+
| 264 | +! | +
+ with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI")+ |
+
| 265 | +! | +
+ checkmate::assert_class(data, "reactive")+ |
+
| 266 | +! | +
+ checkmate::assert_class(isolate(data()), "teal_data")+ |
+
| 267 | +! | +
+ moduleServer(id, function(input, output, session) {
+ |
+
| 268 | +! | +
+ selector_list <- teal.transform::data_extract_multiple_srv(+ |
+
| 269 | +! | +
+ data_extract = list(variables = variables),+ |
+
| 270 | +! | +
+ datasets = data,+ |
+
| 271 | +! | +
+ select_validation_rule = list(+ |
+
| 272 | +! | +
+ variables = ~ if (length(.) <= 1) "Please select at least 2 columns."+ |
+
| 273 | ++ |
+ )+ |
+
| 274 | ++ |
+ )+ |
+
| 275 | ++ | + + | +
| 276 | +! | +
+ iv_r <- reactive({
+ |
+
| 277 | +! | +
+ iv <- shinyvalidate::InputValidator$new()+ |
+
| 278 | +! | +
+ teal.transform::compose_and_enable_validators(iv, selector_list)+ |
+
| 279 | ++ |
+ })+ |
+
| 280 | ++ | + + | +
| 281 | +! | +
+ anl_merged_input <- teal.transform::merge_expression_srv(+ |
+
| 282 | +! | +
+ datasets = data,+ |
+
| 283 | +! | +
+ selector_list = selector_list+ |
+
| 284 | ++ |
+ )+ |
+
| 285 | ++ | + + | +
| 286 | +! | +
+ anl_merged_q <- reactive({
+ |
+
| 287 | +! | +
+ req(anl_merged_input())+ |
+
| 288 | +! | +
+ data() %>%+ |
+
| 289 | +! | +
+ teal.code::eval_code(as.expression(anl_merged_input()$expr))+ |
+
| 290 | ++ |
+ })+ |
+
| 291 | ++ | + + | +
| 292 | +! | +
+ merged <- list(+ |
+
| 293 | +! | +
+ anl_input_r = anl_merged_input,+ |
+
| 294 | +! | +
+ anl_q_r = anl_merged_q+ |
+
| 295 | ++ |
+ )+ |
+
| 296 | ++ | + + | +
| 297 | ++ |
+ # plot+ |
+
| 298 | +! | +
+ output_q <- reactive({
+ |
+
| 299 | +! | +
+ teal::validate_inputs(iv_r())+ |
+
| 300 | ++ | + + | +
| 301 | +! | +
+ qenv <- merged$anl_q_r()+ |
+
| 302 | +! | +
+ ANL <- qenv[["ANL"]]+ |
+
| 303 | ++ | + + | +
| 304 | +! | +
+ cols_names <- merged$anl_input_r()$columns_source$variables+ |
+
| 305 | +! | +
+ alpha <- input$alpha+ |
+
| 306 | +! | +
+ cex <- input$cex+ |
+
| 307 | +! | +
+ add_cor <- input$cor+ |
+
| 308 | +! | +
+ cor_method <- input$cor_method+ |
+
| 309 | +! | +
+ cor_na_omit <- input$cor_na_omit+ |
+
| 310 | ++ | + + | +
| 311 | +! | +
+ cor_na_action <- if (isTruthy(cor_na_omit)) {
+ |
+
| 312 | +! | +
+ "na.omit"+ |
+
| 313 | ++ |
+ } else {
+ |
+
| 314 | +! | +
+ "na.fail"+ |
+
| 315 | ++ |
+ }+ |
+
| 316 | ++ | + + | +
| 317 | +! | +
+ teal::validate_has_data(ANL, 10)+ |
+
| 318 | +! | +
+ teal::validate_has_data(ANL[, cols_names, drop = FALSE], 10, complete = TRUE, allow_inf = FALSE)+ |
+
| 319 | ++ | + + | +
| 320 | ++ |
+ # get labels and proper variable names+ |
+
| 321 | +! | +
+ varnames <- varname_w_label(cols_names, ANL, wrap_width = 20)+ |
+
| 322 | ++ | + + | +
| 323 | ++ |
+ # check character columns. If any, then those are converted to factors+ |
+
| 324 | +! | +
+ check_char <- vapply(ANL[, cols_names], is.character, logical(1))+ |
+
| 325 | +! | +
+ if (any(check_char)) {
+ |
+
| 326 | +! | +
+ qenv <- teal.code::eval_code(+ |
+
| 327 | +! | +
+ qenv,+ |
+
| 328 | +! | +
+ substitute(+ |
+
| 329 | +! | +
+ expr = ANL <- ANL[, cols_names] %>%+ |
+
| 330 | +! | +
+ dplyr::mutate_if(is.character, as.factor) %>%+ |
+
| 331 | +! | +
+ droplevels(),+ |
+
| 332 | +! | +
+ env = list(cols_names = cols_names)+ |
+
| 333 | ++ |
+ )+ |
+
| 334 | ++ |
+ )+ |
+
| 335 | ++ |
+ } else {
+ |
+
| 336 | +! | +
+ qenv <- teal.code::eval_code(+ |
+
| 337 | +! | +
+ qenv,+ |
+
| 338 | +! | +
+ substitute(+ |
+
| 339 | +! | +
+ expr = ANL <- ANL[, cols_names] %>%+ |
+
| 340 | +! | +
+ droplevels(),+ |
+
| 341 | +! | +
+ env = list(cols_names = cols_names)+ |
+
| 342 | ++ |
+ )+ |
+
| 343 | ++ |
+ )+ |
+
| 344 | ++ |
+ }+ |
+
| 345 | ++ | + + | +
| 346 | ++ | + + | +
| 347 | ++ |
+ # create plot+ |
+
| 348 | +! | +
+ if (add_cor) {
+ |
+
| 349 | +! | +
+ shinyjs::show("cor_method")
+ |
+
| 350 | +! | +
+ shinyjs::show("cor_use")
+ |
+
| 351 | +! | +
+ shinyjs::show("cor_na_omit")
+ |
+
| 352 | ++ | + + | +
| 353 | +! | +
+ qenv <- teal.code::eval_code(+ |
+
| 354 | +! | +
+ qenv,+ |
+
| 355 | +! | +
+ substitute(+ |
+
| 356 | +! | +
+ expr = {
+ |
+
| 357 | +! | +
+ g <- lattice::splom(+ |
+
| 358 | +! | +
+ ANL,+ |
+
| 359 | +! | +
+ varnames = varnames_value,+ |
+
| 360 | +! | +
+ panel = function(x, y, ...) {
+ |
+
| 361 | +! | +
+ lattice::panel.splom(x = x, y = y, ...)+ |
+
| 362 | +! | +
+ cpl <- lattice::current.panel.limits()+ |
+
| 363 | +! | +
+ lattice::panel.text(+ |
+
| 364 | +! | +
+ mean(cpl$xlim),+ |
+
| 365 | +! | +
+ mean(cpl$ylim),+ |
+
| 366 | +! | +
+ get_scatterplotmatrix_stats(+ |
+
| 367 | +! | +
+ x,+ |
+
| 368 | +! | +
+ y,+ |
+
| 369 | +! | +
+ .f = stats::cor.test,+ |
+
| 370 | +! | +
+ .f_args = list(method = cor_method, na.action = cor_na_action)+ |
+
| 371 | ++ |
+ ),+ |
+
| 372 | +! | +
+ alpha = 0.6,+ |
+
| 373 | +! | +
+ fontsize = 18,+ |
+
| 374 | +! | +
+ fontface = "bold"+ |
+
| 375 | ++ |
+ )+ |
+
| 376 | ++ |
+ },+ |
+
| 377 | +! | +
+ pch = 16,+ |
+
| 378 | +! | +
+ alpha = alpha_value,+ |
+
| 379 | +! | +
+ cex = cex_value+ |
+
| 380 | ++ |
+ )+ |
+
| 381 | +! | +
+ print(g)+ |
+
| 382 | ++ |
+ },+ |
+
| 383 | +! | +
+ env = list(+ |
+
| 384 | +! | +
+ varnames_value = varnames,+ |
+
| 385 | +! | +
+ cor_method = cor_method,+ |
+
| 386 | +! | +
+ cor_na_action = cor_na_action,+ |
+
| 387 | +! | +
+ alpha_value = alpha,+ |
+
| 388 | +! | +
+ cex_value = cex+ |
+
| 389 | ++ |
+ )+ |
+
| 390 | ++ |
+ )+ |
+
| 391 | ++ |
+ )+ |
+
| 392 | ++ |
+ } else {
+ |
+
| 393 | +! | +
+ shinyjs::hide("cor_method")
+ |
+
| 394 | +! | +
+ shinyjs::hide("cor_use")
+ |
+
| 395 | +! | +
+ shinyjs::hide("cor_na_omit")
+ |
+
| 396 | +! | +
+ qenv <- teal.code::eval_code(+ |
+
| 397 | +! | +
+ qenv,+ |
+
| 398 | +! | +
+ substitute(+ |
+
| 399 | +! | +
+ expr = {
+ |
+
| 400 | +! | +
+ g <- lattice::splom(ANL, varnames = varnames_value, pch = 16, alpha = alpha_value, cex = cex_value)+ |
+
| 401 | +! | +
+ g+ |
+
| 402 | ++ |
+ },+ |
+
| 403 | +! | +
+ env = list(varnames_value = varnames, alpha_value = alpha, cex_value = cex)+ |
+
| 404 | ++ |
+ )+ |
+
| 405 | ++ |
+ )+ |
+
| 406 | ++ |
+ }+ |
+
| 407 | +! | +
+ qenv+ |
+
| 408 | ++ |
+ })+ |
+
| 409 | ++ | + + | +
| 410 | +! | +
+ plot_r <- reactive(output_q()[["g"]])+ |
+
| 411 | ++ | + + | +
| 412 | ++ |
+ # Insert the plot into a plot_with_settings module+ |
+
| 413 | +! | +
+ pws <- teal.widgets::plot_with_settings_srv(+ |
+
| 414 | +! | +
+ id = "myplot",+ |
+
| 415 | +! | +
+ plot_r = plot_r,+ |
+
| 416 | +! | +
+ height = plot_height,+ |
+
| 417 | +! | +
+ width = plot_width+ |
+
| 418 | ++ |
+ )+ |
+
| 419 | ++ | + + | +
| 420 | ++ |
+ # show a message if conversion to factors took place+ |
+
| 421 | +! | +
+ output$message <- renderText({
+ |
+
| 422 | +! | +
+ shiny::req(iv_r()$is_valid())+ |
+
| 423 | +! | +
+ req(selector_list()$variables())+ |
+
| 424 | +! | +
+ ANL <- merged$anl_q_r()[["ANL"]]+ |
+
| 425 | +! | +
+ cols_names <- unique(unname(do.call(c, merged$anl_input_r()$columns_source)))+ |
+
| 426 | +! | +
+ check_char <- vapply(ANL[, cols_names], is.character, logical(1))+ |
+
| 427 | +! | +
+ if (any(check_char)) {
+ |
+
| 428 | +! | +
+ is_single <- sum(check_char) == 1+ |
+
| 429 | +! | +
+ paste(+ |
+
| 430 | +! | +
+ "Character",+ |
+
| 431 | +! | +
+ ifelse(is_single, "variable", "variables"),+ |
+
| 432 | +! | +
+ paste0("(", paste(cols_names[check_char], collapse = ", "), ")"),
+ |
+
| 433 | +! | +
+ ifelse(is_single, "was", "were"),+ |
+
| 434 | +! | +
+ "converted to",+ |
+
| 435 | +! | +
+ ifelse(is_single, "factor.", "factors.")+ |
+
| 436 | ++ |
+ )+ |
+
| 437 | ++ |
+ } else {
+ |
+
| 438 | ++ |
+ ""+ |
+
| 439 | ++ |
+ }+ |
+
| 440 | ++ |
+ })+ |
+
| 441 | ++ | + + | +
| 442 | +! | +
+ teal.widgets::verbatim_popup_srv(+ |
+
| 443 | +! | +
+ id = "warning",+ |
+
| 444 | +! | +
+ verbatim_content = reactive(teal.code::get_warnings(output_q())),+ |
+
| 445 | +! | +
+ title = "Warning",+ |
+
| 446 | +! | +
+ disabled = reactive(is.null(teal.code::get_warnings(output_q())))+ |
+
| 447 | ++ |
+ )+ |
+
| 448 | ++ | + + | +
| 449 | +! | +
+ teal.widgets::verbatim_popup_srv(+ |
+
| 450 | +! | +
+ id = "rcode",+ |
+
| 451 | +! | +
+ verbatim_content = reactive(teal.code::get_code(output_q())),+ |
+
| 452 | +! | +
+ title = "Show R Code for Scatterplotmatrix"+ |
+
| 453 | ++ |
+ )+ |
+
| 454 | ++ | + + | +
| 455 | ++ |
+ ### REPORTER+ |
+
| 456 | +! | +
+ if (with_reporter) {
+ |
+
| 457 | +! | +
+ card_fun <- function(comment, label) {
+ |
+
| 458 | +! | +
+ card <- teal::report_card_template(+ |
+
| 459 | +! | +
+ title = "Scatter Plot Matrix",+ |
+
| 460 | +! | +
+ label = label,+ |
+
| 461 | +! | +
+ with_filter = with_filter,+ |
+
| 462 | +! | +
+ filter_panel_api = filter_panel_api+ |
+
| 463 | ++ |
+ )+ |
+
| 464 | +! | +
+ card$append_text("Plot", "header3")
+ |
+
| 465 | +! | +
+ card$append_plot(plot_r(), dim = pws$dim())+ |
+
| 466 | +! | +
+ if (!comment == "") {
+ |
+
| 467 | +! | +
+ card$append_text("Comment", "header3")
+ |
+
| 468 | +! | +
+ card$append_text(comment)+ |
+
| 469 | ++ |
+ }+ |
+
| 470 | +! | +
+ card$append_src(teal.code::get_code(output_q()))+ |
+
| 471 | +! | +
+ card+ |
+
| 472 | ++ |
+ }+ |
+
| 473 | +! | +
+ teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
+ |
+
| 474 | ++ |
+ }+ |
+
| 475 | ++ |
+ ###+ |
+
| 476 | ++ |
+ })+ |
+
| 477 | ++ |
+ }+ |
+
| 478 | ++ | + + | +
| 479 | ++ |
+ #' Get stats for x-y pairs in scatterplot matrix+ |
+
| 480 | ++ |
+ #'+ |
+
| 481 | ++ |
+ #' Uses [stats::cor.test()] per default for all numerical input variables and converts results+ |
+
| 482 | ++ |
+ #' to character vector.+ |
+
| 483 | ++ |
+ #' Could be extended if different stats for different variable types are needed.+ |
+
| 484 | ++ |
+ #' Meant to be called from [lattice::panel.text()].+ |
+
| 485 | ++ |
+ #'+ |
+
| 486 | ++ |
+ #' Presently we need to use a formula input for `stats::cor.test` because+ |
+
| 487 | ++ |
+ #' `na.fail` only gets evaluated when a formula is passed (see below).+ |
+
| 488 | ++ |
+ #' ```+ |
+
| 489 | ++ |
+ #' x = c(1,3,5,7,NA)+ |
+
| 490 | ++ |
+ #' y = c(3,6,7,8,1)+ |
+
| 491 | ++ |
+ #' stats::cor.test(x, y, na.action = "na.fail")+ |
+
| 492 | ++ |
+ #' stats::cor.test(~ x + y, na.action = "na.fail")+ |
+
| 493 | ++ |
+ #' ```+ |
+
| 494 | ++ |
+ #'+ |
+
| 495 | ++ |
+ #' @param x,y (`numeric`) vectors of data values. `x` and `y` must have the same length.+ |
+
| 496 | ++ |
+ #' @param .f (`function`) function that accepts x and y as formula input `~ x + y`.+ |
+
| 497 | ++ |
+ #' Default `stats::cor.test`.+ |
+
| 498 | ++ |
+ #' @param .f_args (`list`) of arguments to be passed to `.f`.+ |
+
| 499 | ++ |
+ #' @param round_stat (`integer(1)`) optional, number of decimal places to use when rounding the estimate.+ |
+
| 500 | ++ |
+ #' @param round_pval (`integer(1)`) optional, number of decimal places to use when rounding the p-value.+ |
+
| 501 | ++ |
+ #'+ |
+
| 502 | ++ |
+ #' @return Character with stats. For [stats::cor.test()] correlation coefficient and p-value.+ |
+
| 503 | ++ |
+ #'+ |
+
| 504 | ++ |
+ #' @examples+ |
+
| 505 | ++ |
+ #' set.seed(1)+ |
+
| 506 | ++ |
+ #' x <- runif(25, 0, 1)+ |
+
| 507 | ++ |
+ #' y <- runif(25, 0, 1)+ |
+
| 508 | ++ |
+ #' x[c(3, 10, 18)] <- NA+ |
+
| 509 | ++ |
+ #'+ |
+
| 510 | ++ |
+ #' get_scatterplotmatrix_stats(x, y, .f = stats::cor.test, .f_args = list(method = "pearson"))+ |
+
| 511 | ++ |
+ #' get_scatterplotmatrix_stats(x, y, .f = stats::cor.test, .f_args = list(+ |
+
| 512 | ++ |
+ #' method = "pearson",+ |
+
| 513 | ++ |
+ #' na.action = na.fail+ |
+
| 514 | ++ |
+ #' ))+ |
+
| 515 | ++ |
+ #'+ |
+
| 516 | ++ |
+ #' @export+ |
+
| 517 | ++ |
+ #'+ |
+
| 518 | ++ |
+ get_scatterplotmatrix_stats <- function(x, y,+ |
+
| 519 | ++ |
+ .f = stats::cor.test,+ |
+
| 520 | ++ |
+ .f_args = list(),+ |
+
| 521 | ++ |
+ round_stat = 2,+ |
+
| 522 | ++ |
+ round_pval = 4) {
+ |
+
| 523 | +6x | +
+ if (is.numeric(x) && is.numeric(y)) {
+ |
+
| 524 | +3x | +
+ stat <- tryCatch(do.call(.f, c(list(~ x + y), .f_args)), error = function(e) NA)+ |
+
| 525 | ++ | + + | +
| 526 | +3x | +
+ if (anyNA(stat)) {
+ |
+
| 527 | +1x | +
+ return("NA")
+ |
+
| 528 | +2x | +
+ } else if (all(c("estimate", "p.value") %in% names(stat))) {
+ |
+
| 529 | +2x | +
+ return(paste(+ |
+
| 530 | +2x | +
+ c(+ |
+
| 531 | +2x | +
+ paste0(names(stat$estimate), ":", round(stat$estimate, round_stat)),+ |
+
| 532 | +2x | +
+ paste0("P:", round(stat$p.value, round_pval))
+ |
+
| 533 | ++ |
+ ),+ |
+
| 534 | +2x | +
+ collapse = "\n"+ |
+
| 535 | ++ |
+ ))+ |
+
| 536 | ++ |
+ } else {
+ |
+
| 537 | +! | +
+ stop("function not supported")
+ |
+
| 538 | ++ |
+ }+ |
+
| 539 | ++ |
+ } else {
+ |
+
| 540 | +3x | +
+ if ("method" %in% names(.f_args)) {
+ |
+
| 541 | +3x | +
+ if (.f_args$method == "pearson") {
+ |
+
| 542 | +1x | +
+ return("cor:-")
+ |
+
| 543 | ++ |
+ }+ |
+
| 544 | +2x | +
+ if (.f_args$method == "kendall") {
+ |
+
| 545 | +1x | +
+ return("tau:-")
+ |
+
| 546 | ++ |
+ }+ |
+
| 547 | +1x | +
+ if (.f_args$method == "spearman") {
+ |
+
| 548 | +1x | +
+ return("rho:-")
+ |
+
| 549 | ++ |
+ }+ |
+
| 550 | ++ |
+ }+ |
+
| 551 | +! | +
+ return("-")
+ |
+
| 552 | ++ |
+ }+ |
+
| 553 | ++ |
+ }+ |
+
| 1 | ++ |
+ #' 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.+ |
+
| 28 | ++ |
+ #'+ |
+
| 29 | ++ |
+ #' @param alpha (`integer(1)` or `integer(3)`) optional, specifies point opacity.+ |
+
| 30 | ++ |
+ #' - When the length of `alpha` is one: the plot points will have a fixed opacity.+ |
+
| 31 | ++ |
+ #' - When the length of `alpha` is three: the plot points opacity are dynamically adjusted based on+ |
+
| 32 | ++ |
+ #' vector of `value`, `min`, and `max`.+ |
+
| 33 | ++ |
+ #' @param size (`integer(1)` or `integer(3)`) optional, specifies point size.+ |
+
| 34 | ++ |
+ #' - When the length of `size` is one: the plot point sizes will have a fixed size.+ |
+
| 35 | ++ |
+ #' - When the length of `size` is three: the plot points size are dynamically adjusted based on+ |
+
| 36 | ++ |
+ #' vector of `value`, `min`, and `max`.+ |
+
| 37 | ++ |
+ #'+ |
+
| 38 | ++ |
+ #' @return Object of class `teal_module` to be used in `teal` applications.+ |
+
| 39 | ++ |
+ #'+ |
+
| 40 | ++ |
+ #' @name shared_params+ |
+
| 41 | ++ |
+ #' @keywords internal+ |
+
| 42 | ++ |
+ NULL+ |
+
| 43 | ++ | + + | +
| 44 | ++ |
+ #' Add labels for facets to a `ggplot2` object+ |
+
| 45 | ++ |
+ #'+ |
+
| 46 | ++ |
+ #' Enhances a `ggplot2` plot by adding labels that describe+ |
+
| 47 | ++ |
+ #' the faceting variables along the x and y axes.+ |
+
| 48 | ++ |
+ #'+ |
+
| 49 | ++ |
+ #' @param p (`ggplot2`) object to which facet labels will be added.+ |
+
| 50 | ++ |
+ #' @param xfacet_label (`character`) Label for the facet along the x-axis.+ |
+
| 51 | ++ |
+ #' If `NULL`, no label is added. If a vector, labels are joined with " & ".+ |
+
| 52 | ++ |
+ #' @param yfacet_label (`character`) Label for the facet along the y-axis.+ |
+
| 53 | ++ |
+ #' Similar behavior to `xfacet_label`.+ |
+
| 54 | ++ |
+ #'+ |
+
| 55 | ++ |
+ #' @return Returns `grid` or `grob` object (to be drawn with `grid.draw`)+ |
+
| 56 | ++ |
+ #'+ |
+
| 57 | ++ |
+ #' @examples+ |
+
| 58 | ++ |
+ #' library(ggplot2)+ |
+
| 59 | ++ |
+ #' library(grid)+ |
+
| 60 | ++ |
+ #'+ |
+
| 61 | ++ |
+ #' p <- ggplot(mtcars) ++ |
+
| 62 | ++ |
+ #' aes(x = mpg, y = disp) ++ |
+
| 63 | ++ |
+ #' geom_point() ++ |
+
| 64 | ++ |
+ #' facet_grid(gear ~ cyl)+ |
+
| 65 | ++ |
+ #'+ |
+
| 66 | ++ |
+ #' xfacet_label <- "cylinders"+ |
+
| 67 | ++ |
+ #' yfacet_label <- "gear"+ |
+
| 68 | ++ |
+ #' res <- add_facet_labels(p, xfacet_label, yfacet_label)+ |
+
| 69 | ++ |
+ #' grid.newpage()+ |
+
| 70 | ++ |
+ #' grid.draw(res)+ |
+
| 71 | ++ |
+ #'+ |
+
| 72 | ++ |
+ #' grid.newpage()+ |
+
| 73 | ++ |
+ #' grid.draw(add_facet_labels(p, xfacet_label = NULL, yfacet_label))+ |
+
| 74 | ++ |
+ #' grid.newpage()+ |
+
| 75 | ++ |
+ #' grid.draw(add_facet_labels(p, xfacet_label, yfacet_label = NULL))+ |
+
| 76 | ++ |
+ #' grid.newpage()+ |
+
| 77 | ++ |
+ #' grid.draw(add_facet_labels(p, xfacet_label = NULL, yfacet_label = NULL))+ |
+
| 78 | ++ |
+ #'+ |
+
| 79 | ++ |
+ #' @export+ |
+
| 80 | ++ |
+ #'+ |
+
| 81 | ++ |
+ add_facet_labels <- function(p, xfacet_label = NULL, yfacet_label = NULL) {
+ |
+
| 82 | +! | +
+ checkmate::assert_class(p, classes = "ggplot")+ |
+
| 83 | +! | +
+ checkmate::assert_character(xfacet_label, null.ok = TRUE, min.len = 1)+ |
+
| 84 | +! | +
+ checkmate::assert_character(yfacet_label, null.ok = TRUE, min.len = 1)+ |
+
| 85 | +! | +
+ if (is.null(xfacet_label) && is.null(yfacet_label)) {
+ |
+
| 86 | +! | +
+ return(ggplotGrob(p))+ |
+
| 87 | ++ |
+ }+ |
+
| 88 | +! | +
+ grid::grid.grabExpr({
+ |
+
| 89 | +! | +
+ g <- ggplotGrob(p)+ |
+
| 90 | ++ | + + | +
| 91 | ++ |
+ # we are going to replace these, so we make sure they have nothing in them+ |
+
| 92 | +! | +
+ checkmate::assert_class(g$grobs[[grep("xlab-t", g$layout$name, fixed = TRUE)]], "zeroGrob")
+ |
+
| 93 | +! | +
+ checkmate::assert_class(g$grobs[[grep("ylab-r", g$layout$name, fixed = TRUE)]], "zeroGrob")
+ |
+
| 94 | ++ | + + | +
| 95 | +! | +
+ xaxis_label_grob <- g$grobs[[grep("xlab-b", g$layout$name, fixed = TRUE)]]
+ |
+
| 96 | +! | +
+ xaxis_label_grob$children[[1]]$label <- paste(xfacet_label, collapse = " & ")+ |
+
| 97 | +! | +
+ yaxis_label_grob <- g$grobs[[grep("ylab-l", g$layout$name, fixed = TRUE)]]
+ |
+
| 98 | +! | +
+ yaxis_label_grob$children[[1]]$label <- paste(yfacet_label, collapse = " & ")+ |
+
| 99 | +! | +
+ yaxis_label_grob$children[[1]]$rot <- 270+ |
+
| 100 | ++ | + + | +
| 101 | +! | +
+ top_height <- if (is.null(xfacet_label)) 0 else grid::unit(2, "line")+ |
+
| 102 | +! | +
+ right_width <- if (is.null(yfacet_label)) 0 else grid::unit(2, "line")+ |
+
| 103 | ++ | + + | +
| 104 | +! | +
+ grid::grid.newpage()+ |
+
| 105 | +! | +
+ grid::pushViewport(grid::plotViewport(margins = c(0, 0, top_height, right_width), name = "ggplot"))+ |
+
| 106 | +! | +
+ grid::grid.draw(g)+ |
+
| 107 | +! | +
+ grid::upViewport(1)+ |
+
| 108 | ++ | + + | +
| 109 | ++ |
+ # draw x facet+ |
+
| 110 | +! | +
+ if (!is.null(xfacet_label)) {
+ |
+
| 111 | +! | +
+ grid::pushViewport(grid::viewport(+ |
+
| 112 | +! | +
+ x = 0, y = grid::unit(1, "npc") - top_height, width = grid::unit(1, "npc"),+ |
+
| 113 | +! | +
+ height = top_height, just = c("left", "bottom"), name = "topxaxis"
+ |
+
| 114 | ++ |
+ ))+ |
+
| 115 | +! | +
+ grid::grid.draw(xaxis_label_grob)+ |
+
| 116 | +! | +
+ grid::upViewport(1)+ |
+
| 117 | ++ |
+ }+ |
+
| 118 | ++ | + + | +
| 119 | ++ |
+ # draw y facet+ |
+
| 120 | +! | +
+ if (!is.null(yfacet_label)) {
+ |
+
| 121 | +! | +
+ grid::pushViewport(grid::viewport(+ |
+
| 122 | +! | +
+ x = grid::unit(1, "npc") - grid::unit(as.numeric(right_width) / 2, "line"), y = 0, width = right_width,+ |
+
| 123 | +! | +
+ height = grid::unit(1, "npc"), just = c("left", "bottom"), name = "rightyaxis"
+ |
+
| 124 | ++ |
+ ))+ |
+
| 125 | +! | +
+ grid::grid.draw(yaxis_label_grob)+ |
+
| 126 | +! | +
+ grid::upViewport(1)+ |
+
| 127 | ++ |
+ }+ |
+
| 128 | ++ |
+ })+ |
+
| 129 | ++ |
+ }+ |
+
| 130 | ++ | + + | +
| 131 | ++ |
+ #' Call a function with a character vector for the `...` argument+ |
+
| 132 | ++ |
+ #'+ |
+
| 133 | ++ |
+ #' @param fun (`character`) Name of a function where the `...` argument shall be replaced by values from `str_args`.+ |
+
| 134 | ++ |
+ #' @param str_args (`character`) A character vector that the function shall be executed with+ |
+
| 135 | ++ |
+ #'+ |
+
| 136 | ++ |
+ #' @return+ |
+
| 137 | ++ |
+ #' Value of call to `fun` with arguments specified in `str_args`.+ |
+
| 138 | ++ |
+ #'+ |
+
| 139 | ++ |
+ #' @keywords internal+ |
+
| 140 | ++ |
+ call_fun_dots <- function(fun, str_args) {
+ |
+
| 141 | +! | +
+ do.call("call", c(list(fun), lapply(str_args, as.name)), quote = TRUE)
+ |
+
| 142 | ++ |
+ }+ |
+
| 143 | ++ | + + | +
| 144 | ++ |
+ #' Generate a string for a variable including its label+ |
+
| 145 | ++ |
+ #'+ |
+
| 146 | ++ |
+ #' @param var_names (`character`) Name of variable to extract labels from.+ |
+
| 147 | ++ |
+ #' @param dataset (`dataset`) Name of analysis dataset.+ |
+
| 148 | ++ |
+ #' @param prefix,suffix (`character`) String to paste to the beginning/end of the variable name with label.+ |
+
| 149 | ++ |
+ #' @param wrap_width (`numeric`) Number of characters to wrap original label to. Defaults to 80.+ |
+
| 150 | ++ |
+ #'+ |
+
| 151 | ++ |
+ #' @return (`character`) String with variable name and label.+ |
+
| 152 | ++ |
+ #'+ |
+
| 153 | ++ |
+ #' @keywords internal+ |
+
| 154 | ++ |
+ #'+ |
+
| 155 | ++ |
+ varname_w_label <- function(var_names,+ |
+
| 156 | ++ |
+ dataset,+ |
+
| 157 | ++ |
+ wrap_width = 80,+ |
+
| 158 | ++ |
+ prefix = NULL,+ |
+
| 159 | ++ |
+ suffix = NULL) {
+ |
+
| 160 | +! | +
+ add_label <- function(var_names) {
+ |
+
| 161 | +! | +
+ label <- vapply(+ |
+
| 162 | +! | +
+ dataset[var_names], function(x) {
+ |
+
| 163 | +! | +
+ attr_label <- attr(x, "label")+ |
+
| 164 | +! | +
+ `if`(is.null(attr_label), "", attr_label)+ |
+
| 165 | ++ |
+ },+ |
+
| 166 | +! | +
+ character(1)+ |
+
| 167 | ++ |
+ )+ |
+
| 168 | ++ | + + | +
| 169 | +! | +
+ if (length(label) == 1 && !is.na(label) && !identical(label, "")) {
+ |
+
| 170 | +! | +
+ paste0(prefix, label, " [", var_names, "]", suffix)+ |
+
| 171 | ++ |
+ } else {
+ |
+
| 172 | +! | +
+ var_names+ |
+
| 173 | ++ |
+ }+ |
+
| 174 | ++ |
+ }+ |
+
| 175 | ++ | + + | +
| 176 | +! | +
+ if (length(var_names) < 1) {
+ |
+
| 177 | +! | +
+ NULL+ |
+
| 178 | +! | +
+ } else if (length(var_names) == 1) {
+ |
+
| 179 | +! | +
+ stringr::str_wrap(add_label(var_names), width = wrap_width)+ |
+
| 180 | +! | +
+ } else if (length(var_names) > 1) {
+ |
+
| 181 | +! | +
+ stringr::str_wrap(vapply(var_names, add_label, character(1)), width = wrap_width)+ |
+
| 182 | ++ |
+ }+ |
+
| 183 | ++ |
+ }+ |
+
| 184 | ++ | + + | +
| 185 | ++ |
+ # see vignette("ggplot2-specs", package="ggplot2")
+ |
+
| 186 | ++ |
+ shape_names <- c(+ |
+
| 187 | ++ |
+ "circle", paste("circle", c("open", "filled", "cross", "plus", "small")), "bullet",
+ |
+
| 188 | ++ |
+ "square", paste("square", c("open", "filled", "cross", "plus", "triangle")),
+ |
+
| 189 | ++ |
+ "diamond", paste("diamond", c("open", "filled", "plus")),
+ |
+
| 190 | ++ |
+ "triangle", paste("triangle", c("open", "filled", "square")),
+ |
+
| 191 | ++ |
+ paste("triangle down", c("open", "filled")),
+ |
+
| 192 | ++ |
+ "plus", "cross", "asterisk"+ |
+
| 193 | ++ |
+ )+ |
+
| 194 | ++ | + + | +
| 195 | ++ |
+ #' Get icons to represent variable types in dataset+ |
+
| 196 | ++ |
+ #'+ |
+
| 197 | ++ |
+ #' @param var_type (`character`) of R internal types (classes).+ |
+
| 198 | ++ |
+ #' @return (`character`) vector of HTML icons corresponding to data type in each column.+ |
+
| 199 | ++ |
+ #' @keywords internal+ |
+
| 200 | ++ |
+ variable_type_icons <- function(var_type) {
+ |
+
| 201 | +! | +
+ checkmate::assert_character(var_type, any.missing = FALSE)+ |
+
| 202 | ++ | + + | +
| 203 | +! | +
+ class_to_icon <- list(+ |
+
| 204 | +! | +
+ numeric = "arrow-up-1-9",+ |
+
| 205 | +! | +
+ integer = "arrow-up-1-9",+ |
+
| 206 | +! | +
+ logical = "pause",+ |
+
| 207 | +! | +
+ Date = "calendar",+ |
+
| 208 | +! | +
+ POSIXct = "calendar",+ |
+
| 209 | +! | +
+ POSIXlt = "calendar",+ |
+
| 210 | +! | +
+ factor = "chart-bar",+ |
+
| 211 | +! | +
+ character = "keyboard",+ |
+
| 212 | +! | +
+ primary_key = "key",+ |
+
| 213 | +! | +
+ unknown = "circle-question"+ |
+
| 214 | ++ |
+ )+ |
+
| 215 | +! | +
+ class_to_icon <- lapply(class_to_icon, function(icon_name) toString(icon(icon_name, lib = "font-awesome")))+ |
+
| 216 | ++ | + + | +
| 217 | +! | +
+ unname(vapply(+ |
+
| 218 | +! | +
+ var_type,+ |
+
| 219 | +! | +
+ FUN.VALUE = character(1),+ |
+
| 220 | +! | +
+ FUN = function(class) {
+ |
+
| 221 | +! | +
+ if (class == "") {
+ |
+
| 222 | +! | +
+ class+ |
+
| 223 | +! | +
+ } else if (is.null(class_to_icon[[class]])) {
+ |
+
| 224 | +! | +
+ class_to_icon[["unknown"]]+ |
+
| 225 | ++ |
+ } else {
+ |
+
| 226 | +! | +
+ class_to_icon[[class]]+ |
+
| 227 | ++ |
+ }+ |
+
| 228 | ++ |
+ }+ |
+
| 229 | ++ |
+ ))+ |
+
| 230 | ++ |
+ }+ |
+
| 231 | ++ | + + | +
| 232 | ++ |
+ #' Include `CSS` files from `/inst/css/` package directory to application header+ |
+
| 233 | ++ |
+ #'+ |
+
| 234 | ++ |
+ #' `system.file` should not be used to access files in other packages, it does+ |
+
| 235 | ++ |
+ #' not work with `devtools`. Therefore, we redefine this method in each package+ |
+
| 236 | ++ |
+ #' as needed. Thus, we do not export this method+ |
+
| 237 | ++ |
+ #'+ |
+
| 238 | ++ |
+ #' @param pattern (`character`) optional, regular expression to match the file names to be included.+ |
+
| 239 | ++ |
+ #'+ |
+
| 240 | ++ |
+ #' @return HTML code that includes `CSS` files.+ |
+
| 241 | ++ |
+ #' @keywords internal+ |
+
| 242 | ++ |
+ #'+ |
+
| 243 | ++ |
+ include_css_files <- function(pattern = "*") {
+ |
+
| 244 | +! | +
+ css_files <- list.files(+ |
+
| 245 | +! | +
+ system.file("css", package = "teal.modules.general", mustWork = TRUE),
+ |
+
| 246 | +! | +
+ pattern = pattern, full.names = TRUE+ |
+
| 247 | ++ |
+ )+ |
+
| 248 | +! | +
+ if (length(css_files) == 0) {
+ |
+
| 249 | +! | +
+ return(NULL)+ |
+
| 250 | ++ |
+ }+ |
+
| 251 | +! | +
+ shiny::singleton(shiny::tags$head(lapply(css_files, shiny::includeCSS)))+ |
+
| 252 | ++ |
+ }+ |
+
| 253 | ++ | + + | +
| 254 | ++ |
+ #' JavaScript condition to check if a specific tab is active+ |
+
| 255 | ++ |
+ #'+ |
+
| 256 | ++ |
+ #' @param id (`character(1)`) the id of the tab panel with tabs.+ |
+
| 257 | ++ |
+ #' @param name (`character(1)`) the name of the tab.+ |
+
| 258 | ++ |
+ #' @return JavaScript expression to be used in `shiny::conditionalPanel()` to determine+ |
+
| 259 | ++ |
+ #' if the specified tab is active.+ |
+
| 260 | ++ |
+ #' @keywords internal+ |
+
| 261 | ++ |
+ #'+ |
+
| 262 | ++ |
+ is_tab_active_js <- function(id, name) {
+ |
+
| 263 | ++ |
+ # supporting the bs3 and higher version at the same time+ |
+
| 264 | +! | +
+ sprintf(+ |
+
| 265 | +! | +
+ "$(\"#%1$s > li.active\").text().trim() == '%2$s' || $(\"#%1$s > li a.active\").text().trim() == '%2$s'",+ |
+
| 266 | +! | +
+ id, name+ |
+
| 267 | ++ |
+ )+ |
+
| 268 | ++ |
+ }+ |
+
| 269 | ++ | + + | +
| 270 | ++ |
+ #' Assert single selection on `data_extract_spec` object+ |
+
| 271 | ++ |
+ #' Helper to reduce code in assertions+ |
+
| 272 | ++ |
+ #' @noRd+ |
+
| 273 | ++ |
+ #'+ |
+
| 274 | ++ |
+ assert_single_selection <- function(x,+ |
+
| 275 | ++ |
+ .var.name = checkmate::vname(x)) { # nolint: object_name.
+ |
+
| 276 | +104x | +
+ if (any(vapply(x, function(.x) .x$select$multiple, logical(1)))) {
+ |
+
| 277 | +4x | +
+ stop("'", .var.name, "' should not allow multiple selection")
+ |
+
| 278 | ++ |
+ }+ |
+
| 279 | +100x | +
+ invisible(TRUE)+ |
+
| 280 | ++ |
+ }+ |
+
| 1 | ++ |
+ #' `teal` module: Data table viewer+ |
+
| 2 | ++ |
+ #'+ |
+
| 3 | ++ |
+ #' Module provides a dynamic and interactive way to view `data.frame`s in a `teal` application.+ |
+
| 4 | ++ |
+ #' It uses the `DT` package to display data tables in a paginated, searchable, and sortable format,+ |
+
| 5 | ++ |
+ #' which helps to enhance data exploration and analysis.+ |
+
| 6 | ++ |
+ #'+ |
+
| 7 | ++ |
+ #' The `DT` package has an option `DT.TOJSON_ARGS` to show `Inf` and `NA` in data tables.+ |
+
| 8 | ++ |
+ #' Configure the `DT.TOJSON_ARGS` option via+ |
+
| 9 | ++ |
+ #' `options(DT.TOJSON_ARGS = list(na = "string"))` before running the module.+ |
+
| 10 | ++ |
+ #' Note though that sorting of numeric columns with `NA`/`Inf` will be lexicographic not numerical.+ |
+
| 11 | ++ |
+ #'+ |
+
| 12 | ++ |
+ #' @inheritParams teal::module+ |
+
| 13 | ++ |
+ #' @inheritParams shared_params+ |
+
| 14 | ++ |
+ #' @param variables_selected (`named list`) Character vectors of the variables (i.e. columns)+ |
+
| 15 | ++ |
+ #' which should be initially shown for each dataset.+ |
+
| 16 | ++ |
+ #' Names of list elements should correspond to the names of the datasets available in the app.+ |
+
| 17 | ++ |
+ #' If no entry is specified for a dataset, the first six variables from that+ |
+
| 18 | ++ |
+ #' dataset will initially be shown.+ |
+
| 19 | ++ |
+ #' @param datasets_selected (`character`) A vector of datasets which should be+ |
+
| 20 | ++ |
+ #' shown and in what order. Names in the vector have to correspond with datasets names.+ |
+
| 21 | ++ |
+ #' If vector of `length == 0` (default) then all datasets are shown.+ |
+
| 22 | ++ |
+ #' Note: Only datasets of the `data.frame` class are compatible.+ |
+
| 23 | ++ |
+ #' @param dt_args (`named list`) Additional arguments to be passed to [DT::datatable()]+ |
+
| 24 | ++ |
+ #' (must not include `data` or `options`).+ |
+
| 25 | ++ |
+ #' @param dt_options (`named list`) The `options` argument to `DT::datatable`. By default+ |
+
| 26 | ++ |
+ #' `list(searching = FALSE, pageLength = 30, lengthMenu = c(5, 15, 30, 100), scrollX = TRUE)`+ |
+
| 27 | ++ |
+ #' @param server_rendering (`logical`) should the data table be rendered server side+ |
+
| 28 | ++ |
+ #' (see `server` argument of [DT::renderDataTable()])+ |
+
| 29 | ++ |
+ #'+ |
+
| 30 | ++ |
+ #' @inherit shared_params return+ |
+
| 31 | ++ |
+ #'+ |
+
| 32 | ++ |
+ #' @examples+ |
+
| 33 | ++ |
+ #' # general data example+ |
+
| 34 | ++ |
+ #' data <- teal_data()+ |
+
| 35 | ++ |
+ #' data <- within(data, {
+ |
+
| 36 | ++ |
+ #' require(nestcolor)+ |
+
| 37 | ++ |
+ #' iris <- iris+ |
+
| 38 | ++ |
+ #' })+ |
+
| 39 | ++ |
+ #' datanames(data) <- c("iris")
+ |
+
| 40 | ++ |
+ #'+ |
+
| 41 | ++ |
+ #' app <- init(+ |
+
| 42 | ++ |
+ #' data = data,+ |
+
| 43 | ++ |
+ #' modules = modules(+ |
+
| 44 | ++ |
+ #' tm_data_table(+ |
+
| 45 | ++ |
+ #' variables_selected = list(+ |
+
| 46 | ++ |
+ #' iris = c("Sepal.Length", "Sepal.Width", "Petal.Length", "Petal.Width", "Species")
+ |
+
| 47 | ++ |
+ #' ),+ |
+
| 48 | ++ |
+ #' dt_args = list(caption = "ADSL Table Caption")+ |
+
| 49 | ++ |
+ #' )+ |
+
| 50 | ++ |
+ #' )+ |
+
| 51 | ++ |
+ #' )+ |
+
| 52 | ++ |
+ #' if (interactive()) {
+ |
+
| 53 | ++ |
+ #' shinyApp(app$ui, app$server)+ |
+
| 54 | ++ |
+ #' }+ |
+
| 55 | ++ |
+ #'+ |
+
| 56 | ++ |
+ #' # CDISC data example+ |
+
| 57 | ++ |
+ #' data <- teal_data()+ |
+
| 58 | ++ |
+ #' data <- within(data, {
+ |
+
| 59 | ++ |
+ #' require(nestcolor)+ |
+
| 60 | ++ |
+ #' ADSL <- rADSL+ |
+
| 61 | ++ |
+ #' })+ |
+
| 62 | ++ |
+ #' datanames(data) <- "ADSL"+ |
+
| 63 | ++ |
+ #' join_keys(data) <- default_cdisc_join_keys[datanames(data)]+ |
+
| 64 | ++ |
+ #'+ |
+
| 65 | ++ |
+ #' app <- init(+ |
+
| 66 | ++ |
+ #' data = data,+ |
+
| 67 | ++ |
+ #' modules = modules(+ |
+
| 68 | ++ |
+ #' tm_data_table(+ |
+
| 69 | ++ |
+ #' variables_selected = list(ADSL = c("STUDYID", "USUBJID", "SUBJID", "SITEID", "AGE", "SEX")),
+ |
+
| 70 | ++ |
+ #' dt_args = list(caption = "ADSL Table Caption")+ |
+
| 71 | ++ |
+ #' )+ |
+
| 72 | ++ |
+ #' )+ |
+
| 73 | ++ |
+ #' )+ |
+
| 74 | ++ |
+ #' if (interactive()) {
+ |
+
| 75 | ++ |
+ #' shinyApp(app$ui, app$server)+ |
+
| 76 | ++ |
+ #' }+ |
+
| 77 | ++ |
+ #'+ |
+
| 78 | ++ |
+ #' @export+ |
+
| 79 | ++ |
+ #'+ |
+
| 80 | ++ |
+ tm_data_table <- function(label = "Data Table",+ |
+
| 81 | ++ |
+ variables_selected = list(),+ |
+
| 82 | ++ |
+ datasets_selected = character(0),+ |
+
| 83 | ++ |
+ dt_args = list(),+ |
+
| 84 | ++ |
+ dt_options = list(+ |
+
| 85 | ++ |
+ searching = FALSE,+ |
+
| 86 | ++ |
+ pageLength = 30,+ |
+
| 87 | ++ |
+ lengthMenu = c(5, 15, 30, 100),+ |
+
| 88 | ++ |
+ scrollX = TRUE+ |
+
| 89 | ++ |
+ ),+ |
+
| 90 | ++ |
+ server_rendering = FALSE,+ |
+
| 91 | ++ |
+ pre_output = NULL,+ |
+
| 92 | ++ |
+ post_output = NULL) {
+ |
+
| 93 | +! | +
+ logger::log_info("Initializing tm_data_table")
+ |
+
| 94 | ++ | + + | +
| 95 | ++ |
+ # Start of assertions+ |
+
| 96 | +! | +
+ checkmate::assert_string(label)+ |
+
| 97 | ++ | + + | +
| 98 | +! | +
+ checkmate::assert_list(variables_selected, min.len = 0, types = "character", names = "named")+ |
+
| 99 | +! | +
+ if (length(variables_selected) > 0) {
+ |
+
| 100 | +! | +
+ lapply(seq_along(variables_selected), function(i) {
+ |
+
| 101 | +! | +
+ checkmate::assert_character(variables_selected[[i]], min.chars = 1, min.len = 1)+ |
+
| 102 | +! | +
+ if (!is.null(names(variables_selected[[i]]))) {
+ |
+
| 103 | +! | +
+ checkmate::assert_names(names(variables_selected[[i]]))+ |
+
| 104 | ++ |
+ }+ |
+
| 105 | ++ |
+ })+ |
+
| 106 | ++ |
+ }+ |
+
| 107 | ++ | + + | +
| 108 | +! | +
+ checkmate::assert_character(datasets_selected, min.len = 0, min.chars = 1)+ |
+
| 109 | +! | +
+ checkmate::assert(+ |
+
| 110 | +! | +
+ checkmate::check_list(dt_args, len = 0),+ |
+
| 111 | +! | +
+ checkmate::check_subset(names(dt_args), choices = names(formals(DT::datatable)))+ |
+
| 112 | ++ |
+ )+ |
+
| 113 | +! | +
+ checkmate::assert_list(dt_options, names = "named")+ |
+
| 114 | +! | +
+ checkmate::assert_flag(server_rendering)+ |
+
| 115 | +! | +
+ checkmate::assert_multi_class(pre_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
+ |
+
| 116 | +! | +
+ checkmate::assert_multi_class(post_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
+ |
+
| 117 | ++ |
+ # End of assertions+ |
+
| 118 | ++ | + + | +
| 119 | +! | +
+ module(+ |
+
| 120 | +! | +
+ label,+ |
+
| 121 | +! | +
+ server = srv_page_data_table,+ |
+
| 122 | +! | +
+ ui = ui_page_data_table,+ |
+
| 123 | +! | +
+ datanames = if (length(datasets_selected) == 0) "all" else datasets_selected,+ |
+
| 124 | +! | +
+ server_args = list(+ |
+
| 125 | +! | +
+ variables_selected = variables_selected,+ |
+
| 126 | +! | +
+ datasets_selected = datasets_selected,+ |
+
| 127 | +! | +
+ dt_args = dt_args,+ |
+
| 128 | +! | +
+ dt_options = dt_options,+ |
+
| 129 | +! | +
+ server_rendering = server_rendering+ |
+
| 130 | ++ |
+ ),+ |
+
| 131 | +! | +
+ ui_args = list(+ |
+
| 132 | +! | +
+ pre_output = pre_output,+ |
+
| 133 | +! | +
+ post_output = post_output+ |
+
| 134 | ++ |
+ )+ |
+
| 135 | ++ |
+ )+ |
+
| 136 | ++ |
+ }+ |
+
| 137 | ++ | + + | +
| 138 | ++ |
+ # UI page module+ |
+
| 139 | ++ |
+ ui_page_data_table <- function(id,+ |
+
| 140 | ++ |
+ pre_output = NULL,+ |
+
| 141 | ++ |
+ post_output = NULL) {
+ |
+
| 142 | +! | +
+ ns <- NS(id)+ |
+
| 143 | ++ | + + | +
| 144 | +! | +
+ shiny::tagList(+ |
+
| 145 | +! | +
+ include_css_files("custom"),
+ |
+
| 146 | +! | +
+ teal.widgets::standard_layout(+ |
+
| 147 | +! | +
+ output = teal.widgets::white_small_well(+ |
+
| 148 | +! | +
+ fluidRow(+ |
+
| 149 | +! | +
+ column(+ |
+
| 150 | +! | +
+ width = 12,+ |
+
| 151 | +! | +
+ checkboxInput(+ |
+
| 152 | +! | +
+ ns("if_distinct"),
+ |
+
| 153 | +! | +
+ "Show only distinct rows:",+ |
+
| 154 | +! | +
+ value = FALSE+ |
+
| 155 | ++ |
+ )+ |
+
| 156 | ++ |
+ )+ |
+
| 157 | ++ |
+ ),+ |
+
| 158 | +! | +
+ fluidRow(+ |
+
| 159 | +! | +
+ class = "mb-8",+ |
+
| 160 | +! | +
+ column(+ |
+
| 161 | +! | +
+ width = 12,+ |
+
| 162 | +! | +
+ uiOutput(ns("dataset_table"))
+ |
+
| 163 | ++ |
+ )+ |
+
| 164 | ++ |
+ )+ |
+
| 165 | ++ |
+ ),+ |
+
| 166 | +! | +
+ pre_output = pre_output,+ |
+
| 167 | +! | +
+ post_output = post_output+ |
+
| 168 | ++ |
+ )+ |
+
| 169 | ++ |
+ )+ |
+
| 170 | ++ |
+ }+ |
+
| 171 | ++ | + + | +
| 172 | ++ |
+ # Server page module+ |
+
| 173 | ++ |
+ srv_page_data_table <- function(id,+ |
+
| 174 | ++ |
+ data,+ |
+
| 175 | ++ |
+ datasets_selected,+ |
+
| 176 | ++ |
+ variables_selected,+ |
+
| 177 | ++ |
+ dt_args,+ |
+
| 178 | ++ |
+ dt_options,+ |
+
| 179 | ++ |
+ server_rendering) {
+ |
+
| 180 | +! | +
+ checkmate::assert_class(data, "reactive")+ |
+
| 181 | +! | +
+ checkmate::assert_class(isolate(data()), "teal_data")+ |
+
| 182 | +! | +
+ moduleServer(id, function(input, output, session) {
+ |
+
| 183 | +! | +
+ if_filtered <- reactive(as.logical(input$if_filtered))+ |
+
| 184 | +! | +
+ if_distinct <- reactive(as.logical(input$if_distinct))+ |
+
| 185 | ++ | + + | +
| 186 | +! | +
+ datanames <- isolate(teal.data::datanames(data()))+ |
+
| 187 | +! | +
+ datanames <- Filter(function(name) {
+ |
+
| 188 | +! | +
+ is.data.frame(isolate(data())[[name]])+ |
+
| 189 | +! | +
+ }, datanames)+ |
+
| 190 | ++ | + + | +
| 191 | +! | +
+ if (!identical(datasets_selected, character(0))) {
+ |
+
| 192 | +! | +
+ checkmate::assert_subset(datasets_selected, datanames)+ |
+
| 193 | +! | +
+ datanames <- datasets_selected+ |
+
| 194 | ++ |
+ }+ |
+
| 195 | ++ | + + | +
| 196 | +! | +
+ output$dataset_table <- renderUI({
+ |
+
| 197 | +! | +
+ do.call(+ |
+
| 198 | +! | +
+ tabsetPanel,+ |
+
| 199 | +! | +
+ lapply(+ |
+
| 200 | +! | +
+ datanames,+ |
+
| 201 | +! | +
+ function(x) {
+ |
+
| 202 | +! | +
+ dataset <- isolate(data()[[x]])+ |
+
| 203 | +! | +
+ choices <- names(dataset)+ |
+
| 204 | +! | +
+ labels <- vapply(+ |
+
| 205 | +! | +
+ dataset,+ |
+
| 206 | +! | +
+ function(x) ifelse(is.null(attr(x, "label")), "", attr(x, "label")),+ |
+
| 207 | +! | +
+ character(1)+ |
+
| 208 | ++ |
+ )+ |
+
| 209 | +! | +
+ names(choices) <- ifelse(+ |
+
| 210 | +! | +
+ is.na(labels) | labels == "",+ |
+
| 211 | +! | +
+ choices,+ |
+
| 212 | +! | +
+ paste(choices, labels, sep = ": ")+ |
+
| 213 | ++ |
+ )+ |
+
| 214 | +! | +
+ variables_selected <- if (!is.null(variables_selected[[x]])) {
+ |
+
| 215 | +! | +
+ variables_selected[[x]]+ |
+
| 216 | ++ |
+ } else {
+ |
+
| 217 | +! | +
+ utils::head(choices)+ |
+
| 218 | ++ |
+ }+ |
+
| 219 | +! | +
+ tabPanel(+ |
+
| 220 | +! | +
+ title = x,+ |
+
| 221 | +! | +
+ column(+ |
+
| 222 | +! | +
+ width = 12,+ |
+
| 223 | +! | +
+ div(+ |
+
| 224 | +! | +
+ class = "mt-4",+ |
+
| 225 | +! | +
+ ui_data_table(+ |
+
| 226 | +! | +
+ id = session$ns(x),+ |
+
| 227 | +! | +
+ choices = choices,+ |
+
| 228 | +! | +
+ selected = variables_selected+ |
+
| 229 | ++ |
+ )+ |
+
| 230 | ++ |
+ )+ |
+
| 231 | ++ |
+ )+ |
+
| 232 | ++ |
+ )+ |
+
| 233 | ++ |
+ }+ |
+
| 234 | ++ |
+ )+ |
+
| 235 | ++ |
+ )+ |
+
| 236 | ++ |
+ })+ |
+
| 237 | ++ | + + | +
| 238 | +! | +
+ lapply(+ |
+
| 239 | +! | +
+ datanames,+ |
+
| 240 | +! | +
+ function(x) {
+ |
+
| 241 | +! | +
+ srv_data_table(+ |
+
| 242 | +! | +
+ id = x,+ |
+
| 243 | +! | +
+ data = data,+ |
+
| 244 | +! | +
+ dataname = x,+ |
+
| 245 | +! | +
+ if_filtered = if_filtered,+ |
+
| 246 | +! | +
+ if_distinct = if_distinct,+ |
+
| 247 | +! | +
+ dt_args = dt_args,+ |
+
| 248 | +! | +
+ dt_options = dt_options,+ |
+
| 249 | +! | +
+ server_rendering = server_rendering+ |
+
| 250 | ++ |
+ )+ |
+
| 251 | ++ |
+ }+ |
+
| 252 | ++ |
+ )+ |
+
| 253 | ++ |
+ })+ |
+
| 254 | ++ |
+ }+ |
+
| 255 | ++ | + + | +
| 256 | ++ |
+ # UI function for the data_table module+ |
+
| 257 | ++ |
+ ui_data_table <- function(id,+ |
+
| 258 | ++ |
+ choices,+ |
+
| 259 | ++ |
+ selected) {
+ |
+
| 260 | +! | +
+ ns <- NS(id)+ |
+
| 261 | ++ | + + | +
| 262 | +! | +
+ if (!is.null(selected)) {
+ |
+
| 263 | +! | +
+ all_choices <- choices+ |
+
| 264 | +! | +
+ choices <- c(selected, setdiff(choices, selected))+ |
+
| 265 | +! | +
+ names(choices) <- names(all_choices)[match(choices, all_choices)]+ |
+
| 266 | ++ |
+ }+ |
+
| 267 | ++ | + + | +
| 268 | +! | +
+ tagList(+ |
+
| 269 | +! | +
+ teal.widgets::get_dt_rows(ns("data_table"), ns("dt_rows")),
+ |
+
| 270 | +! | +
+ fluidRow(+ |
+
| 271 | +! | +
+ teal.widgets::optionalSelectInput(+ |
+
| 272 | +! | +
+ ns("variables"),
+ |
+
| 273 | +! | +
+ "Select variables:",+ |
+
| 274 | +! | +
+ choices = choices,+ |
+
| 275 | +! | +
+ selected = selected,+ |
+
| 276 | +! | +
+ multiple = TRUE,+ |
+
| 277 | +! | +
+ width = "100%"+ |
+
| 278 | ++ |
+ )+ |
+
| 279 | ++ |
+ ),+ |
+
| 280 | +! | +
+ fluidRow(+ |
+
| 281 | +! | +
+ DT::dataTableOutput(ns("data_table"), width = "100%")
+ |
+
| 282 | ++ |
+ )+ |
+
| 283 | ++ |
+ )+ |
+
| 284 | ++ |
+ }+ |
+
| 285 | ++ | + + | +
| 286 | ++ |
+ # Server function for the data_table module+ |
+
| 287 | ++ |
+ srv_data_table <- function(id,+ |
+
| 288 | ++ |
+ data,+ |
+
| 289 | ++ |
+ dataname,+ |
+
| 290 | ++ |
+ if_filtered,+ |
+
| 291 | ++ |
+ if_distinct,+ |
+
| 292 | ++ |
+ dt_args,+ |
+
| 293 | ++ |
+ dt_options,+ |
+
| 294 | ++ |
+ server_rendering) {
+ |
+
| 295 | +! | +
+ moduleServer(id, function(input, output, session) {
+ |
+
| 296 | +! | +
+ iv <- shinyvalidate::InputValidator$new()+ |
+
| 297 | +! | +
+ iv$add_rule("variables", shinyvalidate::sv_required("Please select valid variable names"))
+ |
+
| 298 | +! | +
+ iv$add_rule("variables", shinyvalidate::sv_in_set(
+ |
+
| 299 | +! | +
+ set = names(data()[[dataname]]), message_fmt = "Not all selected variables exist in the data"+ |
+
| 300 | ++ |
+ ))+ |
+
| 301 | +! | +
+ iv$enable()+ |
+
| 302 | ++ | + + | +
| 303 | +! | +
+ output$data_table <- DT::renderDataTable(server = server_rendering, {
+ |
+
| 304 | +! | +
+ teal::validate_inputs(iv)+ |
+
| 305 | ++ | + + | +
| 306 | +! | +
+ df <- data()[[dataname]]+ |
+
| 307 | +! | +
+ variables <- input$variables+ |
+
| 308 | ++ | + + | +
| 309 | +! | +
+ teal::validate_has_data(df, min_nrow = 1L, msg = paste("data", dataname, "is empty"))
+ |
+
| 310 | ++ | + + | +
| 311 | +! | +
+ dataframe_selected <- if (if_distinct()) {
+ |
+
| 312 | +! | +
+ dplyr::count(df, dplyr::across(dplyr::all_of(variables)))+ |
+
| 313 | ++ |
+ } else {
+ |
+
| 314 | +! | +
+ df[variables]+ |
+
| 315 | ++ |
+ }+ |
+
| 316 | ++ | + + | +
| 317 | +! | +
+ dt_args$options <- dt_options+ |
+
| 318 | +! | +
+ if (!is.null(input$dt_rows)) {
+ |
+
| 319 | +! | +
+ dt_args$options$pageLength <- input$dt_rows+ |
+
| 320 | ++ |
+ }+ |
+
| 321 | +! | +
+ dt_args$data <- dataframe_selected+ |
+
| 322 | ++ | + + | +
| 323 | +! | +
+ do.call(DT::datatable, dt_args)+ |
+
| 324 | ++ |
+ })+ |
+
| 325 | ++ |
+ })+ |
+
| 326 | ++ |
+ }+ |
+
| 1 | ++ |
+ .onLoad <- function(libname, pkgname) {
+ |
+
| 2 | +! | +
+ teal.logger::register_logger(namespace = "teal.modules.general")+ |
+
| 3 | ++ |
+ }+ |
+
| 4 | ++ | + + | +
| 5 | ++ |
+ ### global variables+ |
+
| 6 | ++ |
+ ggplot_themes <- c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void")
+ |
+