| 1 |
- #' Missing data module+ #' File Viewer Teal Module |
||
| 3 |
- #' Present analysis of missing observations and patients.+ #' The file viewer module provides a tool to view static files. |
||
| 4 |
- #' specifically designed for use with `data.frames`.+ #' Supported formats include text formats, \code{PDF}, \code{PNG}, \code{APNG},
|
||
| 5 |
- #'+ #' \code{JPEG}, \code{SVG}, \code{WEBP}, \code{GIF} and \code{BMP}.
|
||
| 6 |
- #' @inheritParams teal::module+ #' |
||
| 7 |
- #' @inheritParams shared_params+ #' @inheritParams teal::module |
||
| 8 |
- #' @param parent_dataname (`character(1)`) If this `dataname` exists in then "the by subject"graph is displayed.+ #' @inheritParams shared_params |
||
| 9 |
- #' For `CDISC` data. In non `CDISC` data this can be ignored. Defaults to `"ADSL"`.+ #' @param input_path optional, (`list`) of the input paths to either: specific files of accepted formats, |
||
| 10 |
- #' @param ggtheme optional, (`character`) `ggplot2` theme to be used by default. Defaults to `"classic"`.+ #' a directory or a URL. The paths can be specified as absolute paths or relative to the running |
||
| 11 |
- #'+ #' directory of the application. Will default to current working directory if not supplied. |
||
| 12 |
- #' @templateVar ggnames "Summary Obs", "Summary Patients", "Combinations Main", "Combinations Hist", "By Subject"+ #' |
||
| 13 |
- #' @template ggplot2_args_multi+ #' @export |
||
| 16 |
- #' library(teal.widgets)+ #' data <- teal_data() |
||
| 17 |
- #'+ #' data <- within(data, {
|
||
| 18 |
- #' # module specification used in apps below+ #' data <- data.frame(1) |
||
| 19 |
- #' tm_missing_data_module <- tm_missing_data(+ #' }) |
||
| 20 |
- #' ggplot2_args = list(+ #' datanames(data) <- c("data")
|
||
| 21 |
- #' "Combinations Hist" = ggplot2_args(+ #' |
||
| 22 |
- #' labs = list(subtitle = "Plot produced by Missing Data Module", caption = NULL)+ #' app <- teal::init( |
||
| 23 |
- #' ),+ #' data = data, |
||
| 24 |
- #' "Combinations Main" = ggplot2_args(labs = list(title = NULL))+ #' modules = teal::modules( |
||
| 25 |
- #' )+ #' teal.modules.general::tm_file_viewer( |
||
| 26 |
- #' )+ #' input_path = list( |
||
| 27 |
- #'+ #' folder = system.file("sample_files", package = "teal.modules.general"),
|
||
| 28 |
- #' # general example data+ #' png = system.file("sample_files/sample_file.png", package = "teal.modules.general"),
|
||
| 29 |
- #' data <- teal_data()+ #' txt = system.file("sample_files/sample_file.txt", package = "teal.modules.general"),
|
||
| 30 |
- #' data <- within(data, {
+ #' url = |
||
| 31 |
- #' library(nestcolor)+ #' "https://www.fda.gov/files/drugs/published/Portable-Document-Format-Specifications.pdf" |
||
| 32 |
- #'+ #' ) |
||
| 33 |
- #' add_nas <- function(x) {
+ #' ) |
||
| 34 |
- #' x[sample(seq_along(x), floor(length(x) * runif(1, .05, .17)))] <- NA+ #' ) |
||
| 35 |
- #' x+ #' ) |
||
| 36 |
- #' }+ #' if (interactive()) {
|
||
| 37 |
- #'+ #' shinyApp(app$ui, app$server) |
||
| 38 |
- #' iris <- iris+ #' } |
||
| 39 |
- #' mtcars <- mtcars+ #' |
||
| 40 |
- #'+ tm_file_viewer <- function(label = "File Viewer Module", |
||
| 41 |
- #' iris[] <- lapply(iris, add_nas)+ input_path = list("Current Working Directory" = ".")) {
|
||
| 42 | -+ | ! |
- #' mtcars[] <- lapply(mtcars, add_nas)+ logger::log_info("Initializing tm_file_viewer")
|
| 43 | -+ | ! |
- #' mtcars[["cyl"]] <- as.factor(mtcars[["cyl"]])+ if (length(label) == 0 || identical(label, "")) {
|
| 44 | -+ | ! |
- #' mtcars[["gear"]] <- as.factor(mtcars[["gear"]])+ label <- " " |
| 45 |
- #' })+ } |
||
| 46 | -+ | ! |
- #' datanames(data) <- c("iris", "mtcars")
+ if (length(input_path) == 0 || identical(input_path, "")) {
|
| 47 | -+ | ! |
- #'+ input_path <- list() |
| 48 |
- #' app <- init(+ } |
||
| 49 |
- #' data = data,+ |
||
| 50 | -+ | ! |
- #' modules = modules(tm_missing_data_module)+ checkmate::assert_string(label) |
| 51 | -+ | ! |
- #' )+ checkmate::assert( |
| 52 | -+ | ! |
- #' if (interactive()) {
+ checkmate::check_list(input_path, types = "character", min.len = 0), |
| 53 | -+ | ! |
- #' shinyApp(app$ui, app$server)+ checkmate::check_character(input_path, min.len = 1) |
| 54 |
- #' }+ ) |
||
| 55 |
- #'+ |
||
| 56 | -+ | ! |
- #' # CDISC example data+ if (length(input_path) > 0) {
|
| 57 | -+ | ! |
- #' data <- teal_data()+ valid_url <- function(url_input, timeout = 2) {
|
| 58 | -+ | ! |
- #' data <- within(data, {
+ con <- try(url(url_input), silent = TRUE) |
| 59 | -+ | ! |
- #' library(nestcolor)+ check <- suppressWarnings(try(open.connection(con, open = "rt", timeout = timeout), silent = TRUE)[1]) |
| 60 | -+ | ! |
- #' ADSL <- rADSL+ try(close.connection(con), silent = TRUE) |
| 61 | -+ | ! |
- #' ADRS <- rADRS+ ifelse(is.null(check), TRUE, FALSE) |
| 62 |
- #' })+ } |
||
| 63 | -+ | ! |
- #' datanames(data) <- c("ADSL", "ADRS")
+ idx <- vapply(input_path, function(x) file.exists(x) || valid_url(x), logical(1)) |
| 64 |
- #' join_keys(data) <- default_cdisc_join_keys[datanames(data)]+ |
||
| 65 | -+ | ! |
- #'+ if (!all(idx)) {
|
| 66 | -+ | ! |
- #' app <- init(+ warning( |
| 67 | -+ | ! |
- #' data = data,+ paste0( |
| 68 | -+ | ! |
- #' modules = modules(tm_missing_data_module)+ "Non-existent file or url path. Please provide valid paths for:\n", |
| 69 | -+ | ! |
- #' )+ paste0(input_path[!idx], collapse = "\n") |
| 70 |
- #' if (interactive()) {
+ ) |
||
| 71 |
- #' shinyApp(app$ui, app$server)+ ) |
||
| 72 |
- #' }+ } |
||
| 73 | -+ | ! |
- #'+ input_path <- input_path[idx] |
| 74 |
- #' @export+ } else {
|
||
| 75 | -+ | ! |
- #'+ warning( |
| 76 | -+ | ! |
- tm_missing_data <- function(label = "Missing data",+ "No file or url paths were provided." |
| 77 |
- plot_height = c(600, 400, 5000),+ ) |
||
| 78 |
- plot_width = NULL,+ } |
||
| 79 |
- parent_dataname = "ADSL",+ |
||
| 80 |
- ggtheme = c("classic", "gray", "bw", "linedraw", "light", "dark", "minimal", "void"),
+
|
||
| 81 | -+ | ! |
- ggplot2_args = list(+ args <- as.list(environment()) |
| 82 |
- "Combinations Hist" = teal.widgets::ggplot2_args(labs = list(caption = NULL)),+ |
||
| 83 | -+ | ! |
- "Combinations Main" = teal.widgets::ggplot2_args(labs = list(title = NULL))+ module( |
| 84 | -+ | ! |
- ),+ label = label, |
| 85 | -+ | ! |
- pre_output = NULL,+ server = srv_viewer, |
| 86 | -+ | ! |
- post_output = NULL) {
+ server_args = list(input_path = input_path), |
| 87 | ! |
- if (!requireNamespace("gridExtra", quietly = TRUE)) {
+ ui = ui_viewer, |
|
| 88 | ! |
- stop("Cannot load gridExtra - please install the package or restart your session.")
+ ui_args = args, |
|
| 89 | -+ | ! |
- }+ datanames = NULL |
| 90 | -! | +
- if (!requireNamespace("rlang", quietly = TRUE)) {
+ ) |
|
| 91 | -! | +
- stop("Cannot load rlang - please install the package or restart your session.")
+ } |
|
| 92 |
- }+ |
||
| 93 | -! | +
- logger::log_info("Initializing tm_missing_data")
+ ui_viewer <- function(id, ...) {
|
|
| 94 | ! |
- if (inherits(ggplot2_args, "ggplot2_args")) ggplot2_args <- list(default = ggplot2_args)+ args <- list(...) |
|
| 95 | -+ | ! |
-
+ ns <- NS(id) |
| 96 | -! | +
- checkmate::assert_string(label)+ |
|
| 97 | ! |
- checkmate::assert_character(parent_dataname, min.len = 0, max.len = 1)+ shiny::tagList( |
|
| 98 | ! |
- checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE)+ include_css_files("custom"),
|
|
| 99 | ! |
- checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height")+ teal.widgets::standard_layout( |
|
| 100 | ! |
- checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE)+ output = div( |
|
| 101 | ! |
- checkmate::assert_numeric(+ uiOutput(ns("output"))
|
|
| 102 | -! | +
- plot_width[1],+ ), |
|
| 103 | ! |
- lower = plot_width[2], upper = plot_width[3], null.ok = TRUE, .var.name = "plot_width"+ encoding = div( |
|
| 104 | -+ | ! |
- )+ class = "file_viewer_encoding", |
| 105 | ! |
- ggtheme <- match.arg(ggtheme)+ tags$label("Encodings", class = "text-primary"),
|
|
| 106 | ! |
- plot_choices <- c("Summary Obs", "Summary Patients", "Combinations Main", "Combinations Hist", "By Subject")
+ shinyTree::shinyTree( |
|
| 107 | ! |
- checkmate::assert_list(ggplot2_args, types = "ggplot2_args")+ ns("tree"),
|
|
| 108 | ! |
- checkmate::assert_subset(names(ggplot2_args), c("default", plot_choices))
+ dragAndDrop = FALSE, |
|
| 109 | -+ | ! |
-
+ sort = FALSE, |
| 110 | ! |
- module(+ wholerow = TRUE, |
|
| 111 | ! |
- label,+ theme = "proton", |
|
| 112 | ! |
- server = srv_page_missing_data,+ multiple = FALSE |
|
| 113 | -! | +
- server_args = list(+ ) |
|
| 114 | -! | +
- parent_dataname = parent_dataname, plot_height = plot_height,+ ) |
|
| 115 | -! | +
- plot_width = plot_width, ggplot2_args = ggplot2_args, ggtheme = ggtheme+ ) |
|
| 116 |
- ),+ ) |
||
| 117 | -! | +
- ui = ui_page_missing_data,+ } |
|
| 118 | -! | +
- datanames = "all",+ |
|
| 119 | -! | +
- ui_args = list(pre_output = pre_output, post_output = post_output)+ srv_viewer <- function(id, input_path) {
|
|
| 120 | -+ | ! |
- )+ moduleServer(id, function(input, output, session) {
|
| 121 | -+ | ! |
- }+ temp_dir <- tempfile() |
| 122 | -+ | ! |
-
+ if (!dir.exists(temp_dir)) {
|
| 123 | -+ | ! |
- ui_page_missing_data <- function(id, pre_output = NULL, post_output = NULL) {
+ dir.create(temp_dir, recursive = TRUE) |
| 124 | -! | +
- ns <- NS(id)+ } |
|
| 125 | ! |
- shiny::tagList(+ addResourcePath(basename(temp_dir), temp_dir) |
|
| 126 | -! | +
- include_css_files("custom"),
+
|
|
| 127 | ! |
- teal.widgets::standard_layout(+ test_path_text <- function(selected_path, type) {
|
|
| 128 | ! |
- output = teal.widgets::white_small_well(+ out <- tryCatch( |
|
| 129 | ! |
- div(+ expr = {
|
|
| 130 | ! |
- class = "flex",+ if (type != "url") {
|
|
| 131 | ! |
- column(+ selected_path <- normalizePath(selected_path, winslash = "/") |
|
| 132 | -! | +
- width = 12,+ } |
|
| 133 | ! |
- uiOutput(ns("dataset_tabs"))
+ readLines(con = selected_path) |
|
| 134 |
- )+ }, |
||
| 135 | -+ | ! |
- )+ error = function(cond) FALSE, |
| 136 | -+ | ! |
- ),+ warning = function(cond) {
|
| 137 | ! |
- encoding = div(+ `if`(grepl("^incomplete final line found on", cond[[1]]), suppressWarnings(eval(cond[[2]])), FALSE)
|
|
| 138 | -! | +
- uiOutput(ns("dataset_encodings"))
+ } |
|
| 139 |
- ),+ ) |
||
| 140 | -! | +
- uiOutput(ns("dataset_reporter")),
+ } |
|
| 141 | -! | +
- pre_output = pre_output,+ |
|
| 142 | ! |
- post_output = post_output+ handle_connection_type <- function(selected_path) {
|
|
| 143 | -+ | ! |
- )+ file_extension <- tools::file_ext(selected_path) |
| 144 | -+ | ! |
- )+ file_class <- suppressWarnings(file(selected_path)) |
| 145 | -+ | ! |
- }+ close(file_class) |
| 147 | -+ | ! |
- srv_page_missing_data <- function(id, data, reporter, filter_panel_api, parent_dataname,+ output_text <- test_path_text(selected_path, type = class(file_class)[1]) |
| 148 |
- plot_height, plot_width, ggplot2_args, ggtheme) {
+
|
||
| 149 | ! |
- moduleServer(id, function(input, output, session) {
+ if (class(file_class)[1] == "url") {
|
|
| 150 | ! |
- datanames <- isolate(teal.data::datanames(data()))+ list(selected_path = selected_path, output_text = output_text) |
|
| 151 | -! | +
- datanames <- Filter(function(name) {
+ } else {
|
|
| 152 | ! |
- is.data.frame(isolate(data())[[name]])+ file.copy(normalizePath(selected_path, winslash = "/"), temp_dir) |
|
| 153 | ! |
- }, datanames)+ selected_path <- file.path(basename(temp_dir), basename(selected_path)) |
|
| 154 | ! |
- if_subject_plot <- length(parent_dataname) > 0 && parent_dataname %in% datanames+ list(selected_path = selected_path, output_text = output_text) |
|
| 155 | -! | +
- ns <- session$ns+ } |
|
| 156 |
-
+ } |
||
| 157 | -! | +
- output$dataset_tabs <- renderUI({
+
|
|
| 158 | ! |
- do.call(+ display_file <- function(selected_path) {
|
|
| 159 | ! |
- tabsetPanel,+ con_type <- handle_connection_type(selected_path) |
|
| 160 | ! |
- c(+ file_extension <- tools::file_ext(selected_path) |
|
| 161 | ! |
- id = ns("dataname_tab"),
+ if (file_extension %in% c("png", "apng", "jpg", "jpeg", "svg", "gif", "webp", "bmp")) {
|
|
| 162 | ! |
- lapply(+ tags$img(src = con_type$selected_path, alt = "file does not exist") |
|
| 163 | ! |
- datanames,+ } else if (file_extension == "pdf") {
|
|
| 164 | ! |
- function(x) {
+ tags$embed( |
|
| 165 | ! |
- tabPanel(+ class = "embed_pdf", |
|
| 166 | ! |
- title = x,+ src = con_type$selected_path |
|
| 167 | -! | +
- column(+ ) |
|
| 168 | ! |
- width = 12,+ } else if (!isFALSE(con_type$output_text[1])) {
|
|
| 169 | ! |
- div(+ tags$pre(paste0(con_type$output_text, collapse = "\n")) |
|
| 170 | -! | +
- class = "mt-4",+ } else {
|
|
| 171 | ! |
- ui_missing_data(id = ns(x), by_subject_plot = if_subject_plot)+ tags$p("Please select a supported format.")
|
|
| 172 |
- )+ } |
||
| 173 |
- )+ } |
||
| 174 |
- )+ |
||
| 175 | -+ | ! |
- }+ tree_list <- function(file_or_dir) {
|
| 176 | -+ | ! |
- )+ nested_list <- lapply(file_or_dir, function(path) {
|
| 177 | -+ | ! |
- )+ file_class <- suppressWarnings(file(path)) |
| 178 | -+ | ! |
- )+ close(file_class) |
| 179 | -+ | ! |
- })+ if (class(file_class)[[1]] != "url") {
|
| 180 | -+ | ! |
-
+ isdir <- file.info(path)$isdir |
| 181 | ! |
- output$dataset_encodings <- renderUI({
+ if (!isdir) {
|
|
| 182 | ! |
- tagList(+ structure(path, ancestry = path, sticon = "file") |
|
| 183 | -! | +
- lapply(+ } else {
|
|
| 184 | ! |
- datanames,+ files <- list.files(path, full.names = TRUE, include.dirs = TRUE) |
|
| 185 | ! |
- function(x) {
+ out <- lapply(files, function(x) tree_list(x)) |
|
| 186 | ! |
- conditionalPanel(+ out <- unlist(out, recursive = FALSE) |
|
| 187 | ! |
- is_tab_active_js(ns("dataname_tab"), x),
+ if (length(files) > 0) names(out) <- basename(files) |
|
| 188 | ! |
- encoding_missing_data(+ out |
|
| 189 | -! | +
- id = ns(x),+ } |
|
| 190 | -! | +
- summary_per_patient = if_subject_plot,+ } else {
|
|
| 191 | ! |
- ggtheme = ggtheme,+ structure(path, ancestry = path, sticon = "file") |
|
| 192 | -! | +
- datanames = datanames+ } |
|
| 193 |
- )+ }) |
||
| 194 |
- )+ |
||
| 195 | -+ | ! |
- }+ missing_labels <- if (is.null(names(nested_list))) seq_along(nested_list) else which(names(nested_list) == "") |
| 196 | -+ | ! |
- )+ names(nested_list)[missing_labels] <- file_or_dir[missing_labels] |
| 197 | -+ | ! |
- )+ nested_list |
| 198 |
- })+ } |
||
| 200 | ! |
- output$dataset_reporter <- renderUI({
+ output$tree <- shinyTree::renderTree({
|
|
| 201 | ! |
- lapply(datanames, function(x) {
+ if (length(input_path) > 0) {
|
|
| 202 | ! |
- dataname_ns <- NS(ns(x))+ tree_list(input_path) |
|
| 203 |
-
+ } else {
|
||
| 204 | ! |
- conditionalPanel(+ list("Empty Path" = NULL)
|
|
| 205 | -! | +
- is_tab_active_js(ns("dataname_tab"), x),
+ } |
|
| 206 | -! | +
- tagList(+ }) |
|
| 207 | -! | +
- teal.widgets::verbatim_popup_ui(dataname_ns("warning"), "Show Warnings"),
+
|
|
| 208 | ! |
- teal.widgets::verbatim_popup_ui(dataname_ns("rcode"), "Show R code")
+ output$output <- renderUI({
|
|
| 209 | -+ | ! |
- )+ validate( |
| 210 | -+ | ! |
- )+ need( |
| 211 | -+ | ! |
- })+ length(shinyTree::get_selected(input$tree)) > 0, |
| 212 | -+ | ! |
- })+ "Please select a file." |
| 213 |
-
+ ) |
||
| 214 | -! | +
- lapply(+ ) |
|
| 215 | -! | +
- datanames,+ |
|
| 216 | ! |
- function(x) {
+ obj <- shinyTree::get_selected(input$tree, format = "names")[[1]] |
|
| 217 | ! |
- srv_missing_data(+ repo <- attr(obj, "ancestry") |
|
| 218 | ! |
- id = x,+ repo_collapsed <- if (length(repo) > 1) paste0(repo, collapse = "/") else repo |
|
| 219 | ! |
- data = data,+ is_not_named <- file.exists(file.path(c(repo_collapsed, obj[1])))[1] |
|
| 220 | -! | +
- reporter = reporter,+ |
|
| 221 | ! |
- filter_panel_api = filter_panel_api,+ if (is_not_named) {
|
|
| 222 | ! |
- dataname = x,+ selected_path <- do.call("file.path", as.list(c(repo, obj[1])))
|
|
| 223 | -! | +
- parent_dataname = parent_dataname,+ } else {
|
|
| 224 | ! |
- plot_height = plot_height,+ if (length(repo) == 0) {
|
|
| 225 | ! |
- plot_width = plot_width,+ selected_path <- do.call("file.path", as.list(attr(input$tree[[obj[1]]], "ancestry")))
|
|
| 226 | -! | +
- ggplot2_args = ggplot2_args+ } else {
|
|
| 227 | -+ | ! |
- )+ selected_path <- do.call("file.path", as.list(attr(input$tree[[repo]][[obj[1]]], "ancestry")))
|
| 228 |
- }+ } |
||
| 229 |
- )+ } |
||
| 230 |
- })+ |
||
| 231 | -+ | ! |
- }+ validate( |
| 232 | -+ | ! |
-
+ need( |
| 233 | -+ | ! |
- ui_missing_data <- function(id, by_subject_plot = FALSE) {
+ !isTRUE(file.info(selected_path)$isdir) && length(selected_path) > 0, |
| 234 | ! |
- ns <- NS(id)+ "Please select a single file." |
|
| 235 |
-
+ ) |
||
| 236 | -! | +
- tab_list <- list(+ ) |
|
| 237 | ! |
- tabPanel(+ display_file(selected_path) |
|
| 238 | -! | +
- "Summary",+ }) |
|
| 239 | -! | +
- teal.widgets::plot_with_settings_ui(id = ns("summary_plot")),
+
|
|
| 240 | ! |
- helpText(+ onStop(function() {
|
|
| 241 | ! |
- p(paste(+ removeResourcePath(basename(temp_dir)) |
|
| 242 | ! |
- 'The "Summary" graph shows the number of missing values per variable (both absolute and percentage),',+ unlink(temp_dir) |
|
| 243 | -! | +
- "sorted by magnitude."+ }) |
|
| 244 |
- )),+ }) |
||
| 245 | -! | +
- p(+ } |
|
| 246 | -! | +
| 1 | +
- 'The "summary per patients" graph is showing how many subjects have at least one missing observation',+ #' Response Plots |
||
| 247 | -! | +||
| 2 | +
- "for each variable. It will be most useful for panel datasets."+ #' @md |
||
| 248 | +3 |
- )+ #' |
|
| 249 | +4 |
- )+ #' @inheritParams teal::module |
|
| 250 | +5 |
- ),+ #' @inheritParams shared_params |
|
| 251 | -! | +||
| 6 | +
- tabPanel(+ #' @param response (`data_extract_spec` or `list` of multiple `data_extract_spec`) |
||
| 252 | -! | +||
| 7 | +
- "Combinations",+ #' Which variable to use as the response. You can define one fixed column by using the |
||
| 253 | -! | +||
| 8 | +
- teal.widgets::plot_with_settings_ui(id = ns("combination_plot")),
+ #' setting `fixed = TRUE` inside the `select_spec`. |
||
| 254 | -! | +||
| 9 | +
- helpText(+ #' `data_extract_spec` must not allow multiple selection in this case. |
||
| 255 | -! | +||
| 10 | +
- p(paste(+ #' @param x (`data_extract_spec` or `list` of multiple `data_extract_spec`) |
||
| 256 | -! | +||
| 11 | +
- 'The "Combinations" graph is used to explore the relationship between the missing data within',+ #' Which variable to use on the X-axis of the response plot. Allow the user to select multiple |
||
| 257 | -! | +||
| 12 | +
- "different columns of the dataset.",+ #' columns from the `data` allowed in teal. |
||
| 258 | -! | +||
| 13 | +
- "It shows the different patterns of missingness in the rows of the data.",+ #' `data_extract_spec` must not allow multiple selection in this case. |
||
| 259 | -! | +||
| 14 | +
- 'For example, suppose that 70 rows of the data have exactly columns "A" and "B" missing.',+ #' @param row_facet optional, (`data_extract_spec` or `list` of multiple `data_extract_spec`) |
||
| 260 | -! | +||
| 15 | +
- "In this case there would be a bar of height 70 in the top graph and",+ #' Which data columns to use for faceting rows. |
||
| 261 | -! | +||
| 16 | +
- 'the column below this in the second graph would have rows "A" and "B" cells shaded red.'+ #' @param col_facet optional, (`data_extract_spec` or `list` of multiple `data_extract_spec`) |
||
| 262 | +17 |
- )),+ #' Which data to use for faceting columns. |
|
| 263 | -! | +||
| 18 | +
- p(paste(+ #' @param coord_flip optional, (`logical`) Whether to flip coordinates between `x` and `response`. |
||
| 264 | -! | +||
| 19 | +
- "Due to the large number of missing data patterns possible, only those with a large set of observations",- |
- ||
| 265 | -! | -
- 'are shown in the graph and the "Combination cut-off" slider can be used to adjust the number shown.'+ #' @param count_labels optional, (`logical`) Whether to show count labels. |
|
| 266 | +20 |
- ))+ #' Defaults to `TRUE`. |
|
| 267 | +21 |
- )+ #' @param freq optional, (`logical`) Whether to display frequency (`TRUE`) or density (`FALSE`). |
|
| 268 | +22 |
- ),+ #' Defaults to density (`FALSE`). |
|
| 269 | -! | +||
| 23 | +
- tabPanel(+ #' |
||
| 270 | -! | +||
| 24 | +
- "By Variable Levels",+ #' @note For more examples, please see the vignette "Using response plot" via |
||
| 271 | -! | +||
| 25 | +
- teal.widgets::get_dt_rows(ns("levels_table"), ns("levels_table_rows")),
+ #' \code{vignette("using-response-plot", package = "teal.modules.general")}.
|
||
| 272 | -! | +||
| 26 | +
- DT::dataTableOutput(ns("levels_table"))
+ #' |
||
| 273 | +27 |
- )+ #' @examples |
|
| 274 | +28 |
- )+ #' # general data example |
|
| 275 | -! | +||
| 29 | +
- if (isTRUE(by_subject_plot)) {
+ #' library(teal.widgets) |
||
| 276 | -! | +||
| 30 | +
- tab_list <- append(+ #' |
||
| 277 | -! | +||
| 31 | +
- tab_list,+ #' data <- teal_data() |
||
| 278 | -! | +||
| 32 | +
- list(tabPanel(+ #' data <- within(data, {
|
||
| 279 | -! | +||
| 33 | +
- "Grouped by Subject",+ #' library(nestcolor) |
||
| 280 | -! | +||
| 34 | +
- teal.widgets::plot_with_settings_ui(id = ns("by_subject_plot")),
+ #' mtcars <- mtcars |
||
| 281 | -! | +||
| 35 | +
- helpText(+ #' for (v in c("cyl", "vs", "am", "gear")) {
|
||
| 282 | -! | +||
| 36 | +
- p(paste(+ #' mtcars[[v]] <- as.factor(mtcars[[v]]) |
||
| 283 | -! | +||
| 37 | +
- "This graph shows the missingness with respect to subjects rather than individual rows of the",+ #' } |
||
| 284 | -! | +||
| 38 | +
- "dataset. Each row represents one dataset variable and each column a single subject. Only subjects",+ #' }) |
||
| 285 | -! | +||
| 39 | +
- "with at least one record in this dataset are shown. For a given subject, if they have any missing",+ #' datanames(data) <- "mtcars" |
||
| 286 | -! | +||
| 40 | +
- "values of a specific variable then the appropriate cell in the graph is marked as missing."+ #' |
||
| 287 | +41 |
- ))+ #' app <- init( |
|
| 288 | +42 |
- )+ #' data = data, |
|
| 289 | +43 |
- ))+ #' modules = modules( |
|
| 290 | +44 |
- )+ #' tm_g_response( |
|
| 291 | +45 |
- }+ #' label = "Response Plots", |
|
| 292 | +46 |
-
+ #' response = data_extract_spec( |
|
| 293 | -! | +||
| 47 | +
- do.call(+ #' dataname = "mtcars", |
||
| 294 | -! | +||
| 48 | +
- tabsetPanel,+ #' select = select_spec( |
||
| 295 | -! | +||
| 49 | +
- c(+ #' label = "Select variable:", |
||
| 296 | -! | +||
| 50 | +
- id = ns("summary_type"),
+ #' choices = variable_choices(data[["mtcars"]], c("cyl", "gear")),
|
||
| 297 | -! | +||
| 51 | +
- tab_list+ #' selected = "cyl", |
||
| 298 | +52 |
- )+ #' multiple = FALSE, |
|
| 299 | +53 |
- )+ #' fixed = FALSE |
|
| 300 | +54 |
- }+ #' ) |
|
| 301 | +55 |
-
+ #' ), |
|
| 302 | +56 |
- encoding_missing_data <- function(id, summary_per_patient = FALSE, ggtheme, datanames) {
+ #' x = data_extract_spec( |
|
| 303 | -! | +||
| 57 | +
- ns <- NS(id)+ #' dataname = "mtcars", |
||
| 304 | +58 |
-
+ #' select = select_spec( |
|
| 305 | -! | +||
| 59 | +
- tagList(+ #' label = "Select variable:", |
||
| 306 | +60 |
- ### Reporter+ #' choices = variable_choices(data[["mtcars"]], c("vs", "am")),
|
|
| 307 | -! | +||
| 61 | +
- teal.reporter::simple_reporter_ui(ns("simple_reporter")),
+ #' selected = "vs", |
||
| 308 | +62 |
- ###+ #' multiple = FALSE, |
|
| 309 | -! | +||
| 63 | +
- tags$label("Encodings", class = "text-primary"),
+ #' fixed = FALSE |
||
| 310 | -! | +||
| 64 | +
- helpText(+ #' ) |
||
| 311 | -! | +||
| 65 | +
- paste0("Dataset", `if`(length(datanames) > 1, "s", ""), ":"),
+ #' ), |
||
| 312 | -! | +||
| 66 | +
- tags$code(paste(datanames, collapse = ", "))+ #' ggplot2_args = ggplot2_args( |
||
| 313 | +67 |
- ),+ #' labs = list(subtitle = "Plot generated by Response Module") |
|
| 314 | -! | +||
| 68 | +
- uiOutput(ns("variables")),
+ #' ) |
||
| 315 | -! | +||
| 69 | +
- actionButton(+ #' ) |
||
| 316 | -! | +||
| 70 | +
- ns("filter_na"),
+ #' ) |
||
| 317 | -! | +||
| 71 | +
- span("Select only vars with missings", class = "whitespace-normal"),
+ #' ) |
||
| 318 | -! | +||
| 72 | +
- width = "100%",+ #' if (interactive()) {
|
||
| 319 | -! | +||
| 73 | +
- class = "mb-4"+ #' shinyApp(app$ui, app$server) |
||
| 320 | +74 |
- ),+ #' } |
|
| 321 | -! | +||
| 75 | +
- conditionalPanel(+ #' |
||
| 322 | -! | +||
| 76 | +
- is_tab_active_js(ns("summary_type"), "Summary"),
+ #' # CDISC data example |
||
| 323 | -! | +||
| 77 | +
- checkboxInput(+ #' library(teal.widgets) |
||
| 324 | -! | +||
| 78 | +
- ns("any_na"),
+ #' |
||
| 325 | -! | +||
| 79 | +
- div(+ #' data <- teal_data() |
||
| 326 | -! | +||
| 80 | +
- class = "teal-tooltip",+ #' data <- within(data, {
|
||
| 327 | -! | +||
| 81 | +
- tagList(+ #' library(nestcolor) |
||
| 328 | -! | +||
| 82 | +
- "Add **anyna** variable",+ #' ADSL <- rADSL |
||
| 329 | -! | +||
| 83 | +
- icon("circle-info"),
+ #' }) |
||
| 330 | -! | +||
| 84 | +
- span(+ #' datanames(data) <- c("ADSL")
|
||
| 331 | -! | +||
| 85 | +
- class = "tooltiptext",+ #' join_keys(data) <- default_cdisc_join_keys[datanames(data)] |
||
| 332 | -! | +||
| 86 | +
- "Describes the number of observations with at least one missing value in any variable."+ #' |
||
| 333 | +87 |
- )+ #' app <- init( |
|
| 334 | +88 |
- )+ #' data = data, |
|
| 335 | +89 |
- ),+ #' modules = modules( |
|
| 336 | -! | +||
| 90 | +
- value = FALSE+ #' tm_g_response( |
||
| 337 | +91 |
- ),+ #' label = "Response Plots", |
|
| 338 | -! | +||
| 92 | +
- if (summary_per_patient) {
+ #' response = data_extract_spec( |
||
| 339 | -! | +||
| 93 | +
- checkboxInput(+ #' dataname = "ADSL", |
||
| 340 | -! | +||
| 94 | +
- ns("if_patients_plot"),
+ #' select = select_spec( |
||
| 341 | -! | +||
| 95 | +
- div(+ #' label = "Select variable:", |
||
| 342 | -! | -
- class = "teal-tooltip",- |
- |
| 343 | -! | -
- tagList(- |
- |
| 344 | -! | -
- "Add summary per patients",- |
- |
| 345 | -! | -
- icon("circle-info"),
- |
- |
| 346 | -! | -
- span(- |
- |
| 347 | -! | -
- class = "tooltiptext",- |
- |
| 348 | -! | -
- paste(- |
- |
| 349 | -! | +||
| 96 | +
- "Displays the number of missing values per observation,",+ #' choices = variable_choices(data[["ADSL"]], c("BMRKR2", "COUNTRY")),
|
||
| 350 | -! | +||
| 97 | +
- "where the x-axis is sorted by observation appearance in the table."+ #' selected = "BMRKR2", |
||
| 351 | +98 |
- )+ #' multiple = FALSE, |
|
| 352 | +99 |
- )+ #' fixed = FALSE |
|
| 353 | +100 |
- )+ #' ) |
|
| 354 | +101 |
- ),+ #' ), |
|
| 355 | -! | +||
| 102 | +
- value = FALSE+ #' x = data_extract_spec( |
||
| 356 | +103 |
- )+ #' dataname = "ADSL", |
|
| 357 | +104 |
- }+ #' select = select_spec( |
|
| 358 | +105 |
- ),+ #' label = "Select variable:", |
|
| 359 | -! | +||
| 106 | +
- conditionalPanel(+ #' choices = variable_choices(data[["ADSL"]], c("SEX", "RACE")),
|
||
| 360 | -! | +||
| 107 | +
- is_tab_active_js(ns("summary_type"), "Combinations"),
+ #' selected = "RACE", |
||
| 361 | -! | +||
| 108 | +
- uiOutput(ns("cutoff"))
+ #' multiple = FALSE, |
||
| 362 | +109 |
- ),+ #' fixed = FALSE |
|
| 363 | -! | +||
| 110 | +
- conditionalPanel(+ #' ) |
||
| 364 | -! | +||
| 111 | +
- is_tab_active_js(ns("summary_type"), "By Variable Levels"),
+ #' ), |
||
| 365 | -! | +||
| 112 | +
- tagList(+ #' ggplot2_args = ggplot2_args( |
||
| 366 | -! | +||
| 113 | +
- uiOutput(ns("group_by_var_ui")),
+ #' labs = list(subtitle = "Plot generated by Response Module") |
||
| 367 | -! | +||
| 114 | +
- uiOutput(ns("group_by_vals_ui")),
+ #' ) |
||
| 368 | -! | +||
| 115 | +
- radioButtons(+ #' ) |
||
| 369 | -! | +||
| 116 | +
- ns("count_type"),
+ #' ) |
||
| 370 | -! | +||
| 117 | +
- label = "Display missing as",+ #' ) |
||
| 371 | -! | +||
| 118 | +
- choices = c("counts", "proportions"),
+ #' if (interactive()) {
|
||
| 372 | -! | +||
| 119 | +
- selected = "counts",+ #' shinyApp(app$ui, app$server) |
||
| 373 | -! | +||
| 120 | +
- inline = TRUE+ #' } |
||
| 374 | +121 |
- )+ #' |
|
| 375 | +122 |
- )+ #' @export |
|
| 376 | +123 |
- ),+ #' |
|
| 377 | -! | +||
| 124 | +
- teal.widgets::panel_item(+ tm_g_response <- function(label = "Response Plot", |
||
| 378 | -! | +||
| 125 | +
- title = "Plot settings",+ response, |
||
| 379 | -! | +||
| 126 | +
- selectInput(+ x, |
||
| 380 | -! | +||
| 127 | +
- inputId = ns("ggtheme"),
+ row_facet = NULL, |
||
| 381 | -! | +||
| 128 | +
- label = "Theme (by ggplot):",+ col_facet = NULL, |
||
| 382 | -! | +||
| 129 | +
- choices = ggplot_themes,+ coord_flip = FALSE, |
||
| 383 | -! | +||
| 130 | +
- selected = ggtheme,+ count_labels = TRUE, |
||
| 384 | -! | +||
| 131 | +
- multiple = FALSE+ rotate_xaxis_labels = FALSE, |
||
| 385 | +132 |
- )+ freq = FALSE, |
|
| 386 | +133 |
- )+ plot_height = c(600, 400, 5000), |
|
| 387 | +134 |
- )+ plot_width = NULL, |
|
| 388 | +135 |
- }+ ggtheme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void"),
|
|
| 389 | +136 |
-
+ ggplot2_args = teal.widgets::ggplot2_args(), |
|
| 390 | +137 |
- srv_missing_data <- function(id, data, reporter, filter_panel_api, dataname, parent_dataname,+ pre_output = NULL, |
|
| 391 | +138 |
- plot_height, plot_width, ggplot2_args) {
+ post_output = NULL) {
|
|
| 392 | +139 | ! |
- with_reporter <- !missing(reporter) && inherits(reporter, "Reporter")+ logger::log_info("Initializing tm_g_response")
|
| 393 | +140 | ! |
- with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI")+ if (inherits(response, "data_extract_spec")) response <- list(response) |
| 394 | +141 | ! |
- checkmate::assert_class(data, "reactive")+ if (inherits(x, "data_extract_spec")) x <- list(x) |
| 395 | +142 | ! |
- checkmate::assert_class(isolate(data()), "teal_data")+ if (inherits(row_facet, "data_extract_spec")) row_facet <- list(row_facet) |
| 396 | +143 | ! |
- moduleServer(id, function(input, output, session) {
+ if (inherits(col_facet, "data_extract_spec")) col_facet <- list(col_facet) |
| 397 | +144 | ! |
- prev_group_by_var <- reactiveVal("")
+ checkmate::assert_string(label) |
| 398 | +145 | ! |
- data_r <- reactive(data()[[dataname]])+ ggtheme <- match.arg(ggtheme) |
| 399 | +146 | ! |
- data_keys <- reactive(unlist(teal.data::join_keys(data())[[dataname]]))- |
-
| 400 | -- |
-
+ checkmate::assert_list(response, types = "data_extract_spec") |
|
| 401 | +147 | ! |
- iv_r <- reactive({
+ if (!all(vapply(response, function(x) !("" %in% x$select$choices), logical(1)))) {
|
| 402 | +148 | ! |
- iv <- shinyvalidate::InputValidator$new()+ stop("'response' should not allow empty values")
|
| 403 | -! | +||
| 149 | +
- iv$add_rule(+ } |
||
| 404 | +150 | ! |
- "variables_select",+ if (!all(vapply(response, function(x) !x$select$multiple, logical(1)))) {
|
| 405 | +151 | ! |
- shinyvalidate::sv_required("At least one reference variable needs to be selected.")
+ stop("'response' should not allow multiple selection")
|
| 406 | +152 |
- )+ } |
|
| 407 | +153 | ! |
- iv$add_rule(+ checkmate::assert_list(x, types = "data_extract_spec") |
| 408 | +154 | ! |
- "variables_select",+ if (!all(vapply(x, function(x) !("" %in% x$select$choices), logical(1)))) {
|
| 409 | +155 | ! |
- ~ if (length(setdiff((.), data_keys())) < 1) "Please also select non-key columns."+ stop("'x' should not allow empty values")
|
| 410 | +156 |
- )+ } |
|
| 411 | +157 | ! |
- iv_summary_table <- shinyvalidate::InputValidator$new()+ if (!all(vapply(x, function(x) !x$select$multiple, logical(1)))) {
|
| 412 | +158 | ! |
- iv_summary_table$condition(~ isTRUE(input$summary_type == "By Variable Levels"))+ stop("'x' should not allow multiple selection")
|
| 413 | -! | +||
| 159 | +
- iv_summary_table$add_rule("count_type", shinyvalidate::sv_required("Please select type of counts"))
+ } |
||
| 414 | +160 | ! |
- iv_summary_table$add_rule(+ checkmate::assert_list(row_facet, types = "data_extract_spec", null.ok = TRUE) |
| 415 | +161 | ! |
- "group_by_vals",+ checkmate::assert_list(col_facet, types = "data_extract_spec", null.ok = TRUE) |
| 416 | +162 | ! |
- shinyvalidate::sv_required("Please select both group-by variable and values")
- |
-
| 417 | -- |
- )+ checkmate::assert_flag(coord_flip) |
|
| 418 | +163 | ! |
- iv_summary_table$add_rule(+ checkmate::assert_flag(count_labels) |
| 419 | +164 | ! |
- "group_by_var",+ checkmate::assert_flag(rotate_xaxis_labels) |
| 420 | +165 | ! |
- ~ if (length(.) > 0 && length(input$variables_select) == 1 && (.) == input$variables_select) {
+ checkmate::assert_flag(freq) |
| 421 | +166 | ! |
- "If only one reference variable is selected it must not be the grouping variable."- |
-
| 422 | -- |
- }+ checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE) |
|
| 423 | -+ | ||
| 167 | +! |
- )+ checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height") |
|
| 424 | +168 | ! |
- iv_summary_table$add_rule(+ checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE) |
| 425 | +169 | ! |
- "variables_select",+ checkmate::assert_numeric( |
| 426 | +170 | ! |
- ~ if (length(input$group_by_var) > 0 && length(.) == 1 && (.) == input$group_by_var) {
+ plot_width[1], |
| 427 | +171 | ! |
- "If only one reference variable is selected it must not be the grouping variable."+ lower = plot_width[2], upper = plot_width[3], null.ok = TRUE, .var.name = "plot_width" |
| 428 | +172 |
- }+ ) |
|
| 429 | +173 |
- )+ |
|
| 430 | +174 | ! |
- iv$add_validator(iv_summary_table)+ checkmate::assert_class(ggplot2_args, "ggplot2_args") |
| 431 | -! | +||
| 175 | +
- iv$enable()+ |
||
| 432 | +176 | ! |
- iv+ args <- as.list(environment()) |
| 433 | -- |
- })- |
- |
| 434 | -- | - - | -|
| 435 | +177 | ||
| 436 | -! | -
- data_parent_keys <- reactive({
- |
- |
| 437 | +178 | ! |
- if (length(parent_dataname) > 0 && parent_dataname %in% names(data)) {
+ data_extract_list <- list( |
| 438 | +179 | ! |
- keys <- teal.data::join_keys(data)[[dataname]]+ response = response, |
| 439 | +180 | ! |
- if (parent_dataname %in% names(keys)) {
+ x = x, |
| 440 | +181 | ! |
- keys[[parent_dataname]]- |
-
| 441 | -- |
- } else {
+ row_facet = row_facet, |
|
| 442 | +182 | ! |
- keys[[dataname]]+ col_facet = col_facet |
| 443 | +183 |
- }+ ) |
|
| 444 | +184 |
- } else {
+
|
|
| 445 | +185 | ! |
- NULL- |
-
| 446 | -- |
- }+ module( |
|
| 447 | -+ | ||
| 186 | +! |
- })+ label = label, |
|
| 448 | -+ | ||
| 187 | +! |
-
+ server = srv_g_response, |
|
| 449 | +188 | ! |
- common_code_q <- reactive({
+ ui = ui_g_response, |
| 450 | +189 | ! |
- teal::validate_inputs(iv_r())+ ui_args = args, |
| 451 | -+ | ||
| 190 | +! |
-
+ server_args = c( |
|
| 452 | +191 | ! |
- group_var <- input$group_by_var+ data_extract_list, |
| 453 | +192 | ! |
- anl <- data_r()+ list(plot_height = plot_height, plot_width = plot_width, ggplot2_args = ggplot2_args) |
| 454 | +193 |
-
+ ), |
|
| 455 | +194 | ! |
- qenv <- if (!is.null(selected_vars()) && length(selected_vars()) != ncol(anl)) {
+ datanames = teal.transform::get_extract_datanames(data_extract_list) |
| 456 | -! | +||
| 195 | +
- teal.code::eval_code(+ ) |
||
| 457 | -! | +||
| 196 | +
- data(),+ } |
||
| 458 | -! | +||
| 197 | +
- substitute(+ |
||
| 459 | -! | +||
| 198 | +
- expr = ANL <- anl_name[, selected_vars, drop = FALSE], # nolint: object_name.+ ui_g_response <- function(id, ...) {
|
||
| 460 | +199 | ! |
- env = list(anl_name = as.name(dataname), selected_vars = selected_vars())+ ns <- NS(id) |
| 461 | -+ | ||
| 200 | +! |
- )+ args <- list(...) |
|
| 462 | -+ | ||
| 201 | +! |
- )+ is_single_dataset_value <- teal.transform::is_single_dataset(args$response, args$x, args$row_facet, args$col_facet) |
|
| 463 | +202 |
- } else {
+
|
|
| 464 | +203 | ! |
- teal.code::eval_code(+ teal.widgets::standard_layout( |
| 465 | +204 | ! |
- data(),+ output = teal.widgets::white_small_well( |
| 466 | +205 | ! |
- substitute(expr = ANL <- anl_name, env = list(anl_name = as.name(dataname))) # nolint: object_name.+ teal.widgets::plot_with_settings_ui(id = ns("myplot"))
|
| 467 | +206 |
- )+ ), |
|
| 468 | -+ | ||
| 207 | +! |
- }+ encoding = div( |
|
| 469 | +208 |
-
+ ### Reporter |
|
| 470 | +209 | ! |
- if (input$summary_type == "By Variable Levels" && !is.null(group_var) && !(group_var %in% selected_vars())) {
+ teal.reporter::simple_reporter_ui(ns("simple_reporter")),
|
| 471 | -! | +||
| 210 | +
- qenv <- teal.code::eval_code(+ ### |
||
| 472 | +211 | ! |
- qenv,+ tags$label("Encodings", class = "text-primary"),
|
| 473 | +212 | ! |
- substitute(+ teal.transform::datanames_input(args[c("response", "x", "row_facet", "col_facet")]),
|
| 474 | +213 | ! |
- expr = ANL[[group_var]] <- anl_name[[group_var]], # nolint: object_name.+ teal.transform::data_extract_ui( |
| 475 | +214 | ! |
- env = list(group_var = group_var, anl_name = as.name(dataname))+ id = ns("response"),
|
| 476 | -+ | ||
| 215 | +! |
- )+ label = "Response variable", |
|
| 477 | -+ | ||
| 216 | +! |
- )+ data_extract_spec = args$response, |
|
| 478 | -+ | ||
| 217 | +! |
- }+ is_single_dataset = is_single_dataset_value |
|
| 479 | +218 |
-
+ ), |
|
| 480 | +219 | ! |
- new_col_name <- "**anyna**"- |
-
| 481 | -- |
-
+ teal.transform::data_extract_ui( |
|
| 482 | +220 | ! |
- qenv <- teal.code::eval_code(+ id = ns("x"),
|
| 483 | +221 | ! |
- qenv,+ label = "X variable", |
| 484 | +222 | ! |
- substitute(+ data_extract_spec = args$x, |
| 485 | +223 | ! |
- expr =+ is_single_dataset = is_single_dataset_value |
| 486 | -! | +||
| 224 | +
- create_cols_labels <- function(cols, just_label = FALSE) {
+ ), |
||
| 487 | +225 | ! |
- column_labels <- column_labels_value+ if (!is.null(args$row_facet)) {
|
| 488 | +226 | ! |
- column_labels[is.na(column_labels) | length(column_labels) == 0] <- ""+ teal.transform::data_extract_ui( |
| 489 | +227 | ! |
- if (just_label) {
+ id = ns("row_facet"),
|
| 490 | +228 | ! |
- labels <- column_labels[cols]+ label = "Row facetting", |
| 491 | -+ | ||
| 229 | +! |
- } else {
+ data_extract_spec = args$row_facet, |
|
| 492 | +230 | ! |
- labels <- ifelse(cols == new_col_name | cols == "", cols, paste0(column_labels[cols], " [", cols, "]"))+ is_single_dataset = is_single_dataset_value |
| 493 | +231 |
- }- |
- |
| 494 | -! | -
- return(labels)+ ) |
|
| 495 | +232 |
- },+ }, |
|
| 496 | +233 | ! |
- env = list(+ if (!is.null(args$col_facet)) {
|
| 497 | +234 | ! |
- new_col_name = new_col_name,+ teal.transform::data_extract_ui( |
| 498 | +235 | ! |
- column_labels_value = c(var_labels(data_r())[selected_vars()],+ id = ns("col_facet"),
|
| 499 | +236 | ! |
- new_col_name = new_col_name+ label = "Column facetting", |
| 500 | -+ | ||
| 237 | +! |
- )+ data_extract_spec = args$col_facet, |
|
| 501 | -+ | ||
| 238 | +! |
- )+ is_single_dataset = is_single_dataset_value |
|
| 502 | +239 |
) |
|
| 503 | +240 |
- )+ }, |
|
| 504 | +241 | ! |
- qenv+ shinyWidgets::radioGroupButtons( |
| 505 | -+ | ||
| 242 | +! |
- })+ inputId = ns("freq"),
|
|
| 506 | -+ | ||
| 243 | +! |
-
+ label = NULL, |
|
| 507 | +244 | ! |
- selected_vars <- reactive({
+ choices = c("frequency", "density"),
|
| 508 | +245 | ! |
- req(input$variables_select)+ selected = ifelse(args$freq, "frequency", "density"), |
| 509 | +246 | ! |
- keys <- data_keys()+ justified = TRUE |
| 510 | -! | +||
| 247 | +
- vars <- unique(c(keys, input$variables_select))+ ), |
||
| 511 | +248 | ! |
- vars+ teal.widgets::panel_group( |
| 512 | -+ | ||
| 249 | +! |
- })+ teal.widgets::panel_item( |
|
| 513 | -+ | ||
| 250 | +! |
-
+ title = "Plot settings", |
|
| 514 | +251 | ! |
- vars_summary <- reactive({
+ checkboxInput(ns("count_labels"), "Add count labels", value = args$count_labels),
|
| 515 | +252 | ! |
- na_count <- data_r() %>%+ checkboxInput(ns("coord_flip"), "Swap axes", value = args$coord_flip),
|
| 516 | +253 | ! |
- sapply(function(x) mean(is.na(x)), USE.NAMES = TRUE) %>%+ checkboxInput(ns("rotate_xaxis_labels"), "Rotate X axis labels", value = args$rotate_xaxis_labels),
|
| 517 | +254 | ! |
- sort(decreasing = TRUE)+ selectInput( |
| 518 | -+ | ||
| 255 | +! |
-
+ inputId = ns("ggtheme"),
|
|
| 519 | +256 | ! |
- tibble::tibble(+ label = "Theme (by ggplot):", |
| 520 | +257 | ! |
- key = names(na_count),+ choices = ggplot_themes, |
| 521 | +258 | ! |
- value = unname(na_count),+ selected = args$ggtheme, |
| 522 | +259 | ! |
- label = cut(na_count, breaks = seq(from = 0, to = 1, by = 0.1), include.lowest = TRUE)+ multiple = FALSE |
| 523 | +260 |
- )+ ) |
|
| 524 | +261 |
- })+ ) |
|
| 525 | +262 |
-
+ )+ |
+ |
| 263 | ++ |
+ ), |
|
| 526 | +264 | ! |
- output$variables <- renderUI({
+ forms = tagList( |
| 527 | +265 | ! |
- choices <- split(x = vars_summary()$key, f = vars_summary()$label, drop = TRUE) %>% rev()+ teal.widgets::verbatim_popup_ui(ns("warning"), button_label = "Show Warnings"),
|
| 528 | +266 | ! |
- selected <- choices <- unname(unlist(choices))+ teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code")
|
| 529 | +267 |
-
+ ), |
|
| 530 | +268 | ! |
- teal.widgets::optionalSelectInput(+ pre_output = args$pre_output, |
| 531 | +269 | ! |
- session$ns("variables_select"),
+ post_output = args$post_output |
| 532 | -! | +||
| 270 | +
- label = "Select variables",+ ) |
||
| 533 | -! | +||
| 271 | +
- label_help = HTML(paste0("Dataset: ", tags$code(dataname))),
+ } |
||
| 534 | -! | +||
| 272 | +
- choices = teal.transform::variable_choices(data_r(), choices),+ |
||
| 535 | -! | +||
| 273 | +
- selected = selected,+ srv_g_response <- function(id, |
||
| 536 | -! | +||
| 274 | +
- multiple = TRUE+ data, |
||
| 537 | +275 |
- )+ reporter, |
|
| 538 | +276 |
- })+ filter_panel_api, |
|
| 539 | +277 |
-
+ response, |
|
| 540 | -! | +||
| 278 | +
- observeEvent(input$filter_na, {
+ x, |
||
| 541 | -! | +||
| 279 | +
- choices <- vars_summary() %>%+ row_facet, |
||
| 542 | -! | +||
| 280 | +
- dplyr::select(!!as.name("key")) %>%
+ col_facet, |
||
| 543 | -! | +||
| 281 | +
- getElement(name = 1)+ plot_height, |
||
| 544 | +282 |
-
+ plot_width,+ |
+ |
| 283 | ++ |
+ ggplot2_args) {
|
|
| 545 | +284 | ! |
- selected <- vars_summary() %>%+ with_reporter <- !missing(reporter) && inherits(reporter, "Reporter") |
| 546 | +285 | ! |
- dplyr::filter(!!as.name("value") > 0) %>%
+ with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI") |
| 547 | +286 | ! |
- dplyr::select(!!as.name("key")) %>%
+ checkmate::assert_class(data, "reactive") |
| 548 | +287 | ! |
- getElement(name = 1)+ checkmate::assert_class(isolate(data()), "teal_data")+ |
+
| 288 | +! | +
+ moduleServer(id, function(input, output, session) {
+ |
+ |
| 289 | +! | +
+ data_extract <- list(response = response, x = x, row_facet = row_facet, col_facet = col_facet) |
|
| 549 | +290 | ||
| 550 | +291 | ! |
- teal.widgets::updateOptionalSelectInput(+ rule_diff <- function(other) {
|
| 551 | +292 | ! |
- session = session,+ function(value) {
|
| 552 | +293 | ! |
- inputId = "variables_select",+ if (other %in% names(selector_list())) {
|
| 553 | +294 | ! |
- choices = teal.transform::variable_choices(data_r()),+ othervalue <- selector_list()[[other]]()[["select"]] |
| 554 | +295 | ! |
- selected = selected+ if (!is.null(othervalue)) {
+ |
+
| 296 | +! | +
+ if (identical(value, othervalue)) {
+ |
+ |
| 297 | +! | +
+ "Row and column facetting variables must be different." |
|
| 555 | +298 |
- )+ } |
|
| 556 | +299 |
- })+ } |
|
| 557 | +300 |
-
+ } |
|
| 558 | -! | +||
| 301 | +
- output$group_by_var_ui <- renderUI({
+ } |
||
| 559 | -! | +||
| 302 | +
- all_choices <- teal.transform::variable_choices(data_r())+ } |
||
| 560 | -! | +||
| 303 | +
- cat_choices <- all_choices[!sapply(data_r(), function(x) is.numeric(x) || inherits(x, "POSIXct"))]+ |
||
| 561 | +304 | ! |
- validate(+ selector_list <- teal.transform::data_extract_multiple_srv( |
| 562 | +305 | ! |
- need(cat_choices, "Dataset does not have any non-numeric or non-datetime variables to use to group data with")- |
-
| 563 | -- |
- )+ data_extract = data_extract, |
|
| 564 | +306 | ! |
- teal.widgets::optionalSelectInput(+ datasets = data, |
| 565 | +307 | ! |
- session$ns("group_by_var"),
+ select_validation_rule = list( |
| 566 | +308 | ! |
- label = "Group by variable",+ response = shinyvalidate::sv_required("Please define a column for the response variable"),
|
| 567 | +309 | ! |
- choices = cat_choices,+ x = shinyvalidate::sv_required("Please define a column for X variable"),
|
| 568 | +310 | ! |
- selected = `if`(+ row_facet = shinyvalidate::compose_rules( |
| 569 | +311 | ! |
- is.null(isolate(input$group_by_var)),+ shinyvalidate::sv_optional(), |
| 570 | +312 | ! |
- cat_choices[1],+ ~ if (length(.) > 1) "There must be 1 or no row facetting variable.", |
| 571 | +313 | ! |
- isolate(input$group_by_var)+ rule_diff("col_facet")
|
| 572 | +314 |
), |
|
| 573 | +315 | ! |
- multiple = FALSE,+ col_facet = shinyvalidate::compose_rules( |
| 574 | +316 | ! |
- label_help = paste0("Dataset: ", dataname)
+ shinyvalidate::sv_optional(),+ |
+
| 317 | +! | +
+ ~ if (length(.) > 1) "There must be 1 or no column facetting variable.",+ |
+ |
| 318 | +! | +
+ rule_diff("row_facet")
|
|
| 575 | +319 | ++ |
+ )+ |
+
| 320 |
) |
||
| 576 | +321 |
- })+ ) |
|
| 577 | +322 | ||
| 578 | +323 | ! |
- output$group_by_vals_ui <- renderUI({
+ iv_r <- reactive({
|
| 579 | +324 | ! |
- req(input$group_by_var)- |
-
| 580 | -- |
-
+ iv <- shinyvalidate::InputValidator$new() |
|
| 581 | +325 | ! |
- choices <- teal.transform::value_choices(data_r(), input$group_by_var, input$group_by_var)+ iv$add_rule("ggtheme", shinyvalidate::sv_required("Please select a theme"))
|
| 582 | +326 | ! |
- prev_choices <- isolate(input$group_by_vals)+ teal.transform::compose_and_enable_validators(iv, selector_list) |
| 583 | +327 |
-
+ }) |
|
| 584 | +328 |
- # determine selected value based on filtered data+ |
|
| 585 | -+ | ||
| 329 | +! |
- # display those previously selected values that are still available+ anl_merged_input <- teal.transform::merge_expression_srv( |
|
| 586 | +330 | ! |
- selected <- if (!is.null(prev_choices) && any(prev_choices %in% choices)) {
+ selector_list = selector_list, |
| 587 | +331 | ! |
- prev_choices[match(choices[choices %in% prev_choices], prev_choices)]+ datasets = data |
| 588 | -! | +||
| 332 | +
- } else if (!is.null(prev_choices) &&+ ) |
||
| 589 | -! | +||
| 333 | +
- !any(prev_choices %in% choices) &&+ |
||
| 590 | +334 | ! |
- isolate(prev_group_by_var()) == input$group_by_var) {
+ anl_merged_q <- reactive({
|
| 591 | -+ | ||
| 335 | +! |
- # if not any previously selected value is available and the grouping variable is the same,+ req(anl_merged_input()) |
|
| 592 | -+ | ||
| 336 | +! |
- # then display NULL+ data() %>% |
|
| 593 | +337 | ! |
- NULL+ teal.code::eval_code(as.expression(anl_merged_input()$expr)) |
| 594 | +338 |
- } else {
+ }) |
|
| 595 | +339 |
- # if new grouping variable (i.e. not any previously selected value is available),+ |
|
| 596 | -+ | ||
| 340 | +! |
- # then display all choices+ merged <- list( |
|
| 597 | +341 | ! |
- choices+ anl_input_r = anl_merged_input,+ |
+
| 342 | +! | +
+ anl_q_r = anl_merged_q |
|
| 598 | +343 |
- }+ ) |
|
| 599 | +344 | ||
| 600 | +345 | ! |
- prev_group_by_var(input$group_by_var) # set current group_by_var+ output_q <- reactive({
|
| 601 | +346 | ! |
- validate(need(length(choices) < 100, "Please select group-by variable with fewer than 100 unique values"))+ teal::validate_inputs(iv_r()) |
| 602 | +347 | ||
| 603 | +348 | ! |
- teal.widgets::optionalSelectInput(+ qenv <- merged$anl_q_r() |
| 604 | +349 | ! |
- session$ns("group_by_vals"),
+ ANL <- qenv[["ANL"]] # nolint: object_name. |
| 605 | +350 | ! |
- label = "Filter levels",+ resp_var <- as.vector(merged$anl_input_r()$columns_source$response) |
| 606 | +351 | ! |
- choices = choices,+ x <- as.vector(merged$anl_input_r()$columns_source$x) |
| 607 | -! | +||
| 352 | +
- selected = selected,+ |
||
| 608 | +353 | ! |
- multiple = TRUE,+ validate(need(is.factor(ANL[[resp_var]]), "Please select a factor variable as the response.")) |
| 609 | +354 | ! |
- label_help = paste0("Dataset: ", dataname)
+ validate(need(is.factor(ANL[[x]]), "Please select a factor variable as the X-Variable.")) |
| 610 | -+ | ||
| 355 | +! |
- )+ teal::validate_has_data(ANL, 10) |
|
| 611 | -+ | ||
| 356 | +! |
- })+ teal::validate_has_data(ANL[, c(resp_var, x)], 10, complete = TRUE, allow_inf = FALSE) |
|
| 612 | +357 | ||
| 613 | -! | -
- summary_plot_q <- reactive({
- |
- |
| 614 | +358 | ! |
- req(input$summary_type == "Summary") # needed to trigger show r code update on tab change+ row_facet_name <- if (length(merged$anl_input_r()$columns_source$row_facet) == 0) {
|
| 615 | +359 | ! |
- teal::validate_has_data(data_r(), 1)+ character(0) |
| 616 | +360 |
-
+ } else {
|
|
| 617 | +361 | ! |
- qenv <- common_code_q()+ as.vector(merged$anl_input_r()$columns_source$row_facet) |
| 618 | +362 |
-
+ } |
|
| 619 | +363 | ! |
- if (input$any_na) {
+ col_facet_name <- if (length(merged$anl_input_r()$columns_source$col_facet) == 0) {
|
| 620 | +364 | ! |
- new_col_name <- "**anyna**"+ character(0) |
| 621 | -! | +||
| 365 | +
- qenv <- teal.code::eval_code(+ } else {
|
||
| 622 | +366 | ! |
- qenv,- |
-
| 623 | -! | -
- substitute(- |
- |
| 624 | -! | -
- expr = ANL[[new_col_name]] <- ifelse(rowSums(is.na(ANL)) > 0, NA, FALSE), # nolint: object_name.- |
- |
| 625 | -! | -
- env = list(new_col_name = new_col_name)- |
- |
| 626 | -- |
- )- |
- |
| 627 | -- |
- )+ as.vector(merged$anl_input_r()$columns_source$col_facet) |
|
| 628 | +367 |
} |
|
| 629 | +368 | ||
| 630 | +369 | ! |
- qenv <- teal.code::eval_code(+ freq <- input$freq == "frequency" |
| 631 | +370 | ! |
- qenv,+ swap_axes <- input$coord_flip |
| 632 | +371 | ! |
- substitute(+ counts <- input$count_labels |
| 633 | +372 | ! |
- expr = analysis_vars <- setdiff(colnames(ANL), data_keys),+ rotate_xaxis_labels <- input$rotate_xaxis_labels |
| 634 | +373 | ! |
- env = list(data_keys = data_keys())+ ggtheme <- input$ggtheme |
| 635 | +374 |
- )+ + |
+ |
| 375 | +! | +
+ arg_position <- if (freq) "stack" else "fill" |
|
| 636 | +376 |
- ) %>%+ |
|
| 637 | +377 | ! |
- teal.code::eval_code(+ rowf <- if (length(row_facet_name) != 0) as.name(row_facet_name) |
| 638 | +378 | ! |
- substitute(+ colf <- if (length(col_facet_name) != 0) as.name(col_facet_name) |
| 639 | +379 | ! |
- expr = summary_plot_obs <- data_frame_call[, analysis_vars] %>%+ resp_cl <- as.name(resp_var) |
| 640 | +380 | ! |
- dplyr::summarise_all(list(function(x) sum(is.na(x)))) %>%+ x_cl <- as.name(x) |
| 641 | -! | +||
| 381 | +
- tidyr::pivot_longer(tidyselect::everything(), names_to = "col", values_to = "n_na") %>%+ |
||
| 642 | +382 | ! |
- dplyr::mutate(n_not_na = nrow(ANL) - n_na) %>%+ if (swap_axes) {
|
| 643 | +383 | ! |
- tidyr::pivot_longer(-col, names_to = "isna", values_to = "n") %>%+ qenv <- teal.code::eval_code( |
| 644 | +384 | ! |
- dplyr::mutate(isna = isna == "n_na", n_pct = n / nrow(ANL) * 100),+ qenv, |
| 645 | +385 | ! |
- env = list(data_frame_call = if (!inherits(data_r(), "tbl_df")) {
+ substitute( |
| 646 | +386 | ! |
- quote(tibble::as_tibble(ANL))- |
-
| 647 | -- |
- } else {
+ expr = ANL[[x]] <- with(ANL, forcats::fct_rev(x_cl)), # nolint: object_name. |
|
| 648 | +387 | ! |
- quote(ANL)+ env = list(x = x, x_cl = x_cl) |
| 649 | +388 |
- })+ ) |
|
| 650 | +389 |
- )+ ) |
|
| 651 | +390 |
- ) %>%+ } |
|
| 652 | +391 |
- # x axis ordering according to number of missing values and alphabet- |
- |
| 653 | -! | -
- teal.code::eval_code(+ |
|
| 654 | +392 | ! |
- quote(+ qenv <- teal.code::eval_code( |
| 655 | +393 | ! |
- expr = x_levels <- dplyr::filter(summary_plot_obs, isna) %>%+ qenv, |
| 656 | +394 | ! |
- dplyr::arrange(n_pct, dplyr::desc(col)) %>%+ substitute( |
| 657 | +395 | ! |
- dplyr::pull(col) %>%+ expr = ANL[[resp_var]] <- factor(ANL[[resp_var]]), # nolint: object_name. |
| 658 | +396 | ! |
- create_cols_labels()+ env = list(resp_var = resp_var) |
| 659 | +397 |
- )+ ) |
|
| 660 | +398 |
- )+ ) %>% |
|
| 661 | +399 |
-
+ # nolint start |
|
| 662 | +400 |
- # always set "**anyna**" level as the last one+ # rowf and colf will be a NULL if not set by a user |
|
| 663 | +401 | ! |
- if (isolate(input$any_na)) {
+ teal.code::eval_code( |
| 664 | +402 | ! |
- qenv <- teal.code::eval_code(+ substitute( |
| 665 | +403 | ! |
- qenv,+ expr = ANL2 <- ANL %>% |
| 666 | +404 | ! |
- quote(x_levels <- c(setdiff(x_levels, "**anyna**"), "**anyna**"))- |
-
| 667 | -- |
- )- |
- |
| 668 | -- |
- }+ dplyr::group_by_at(dplyr::vars(x_cl, resp_cl, rowf, colf)) %>% |
|
| 669 | -+ | ||
| 405 | +! |
-
+ dplyr::summarise(ns = dplyr::n()) %>% |
|
| 670 | +406 | ! |
- dev_ggplot2_args <- teal.widgets::ggplot2_args(+ dplyr::group_by_at(dplyr::vars(x_cl, rowf, colf)) %>% |
| 671 | +407 | ! |
- labs = list(x = "Variable", y = "Missing observations"),+ dplyr::mutate(sums = sum(ns), percent = round(ns / sums * 100, 1)), |
| 672 | +408 | ! |
- theme = list(legend.position = "bottom", axis.text.x = quote(element_text(angle = 45, hjust = 1)))+ env = list(x_cl = x_cl, resp_cl = resp_cl, rowf = rowf, colf = colf) |
| 673 | +409 |
- )+ ) |
|
| 674 | +410 |
-
+ ) %>% |
|
| 675 | +411 | ! |
- all_ggplot2_args <- teal.widgets::resolve_ggplot2_args(+ teal.code::eval_code( |
| 676 | +412 | ! |
- user_plot = ggplot2_args[["Summary Obs"]],+ substitute( |
| 677 | +413 | ! |
- user_default = ggplot2_args$default,+ expr = ANL3 <- ANL %>% |
| 678 | +414 | ! |
- module_plot = dev_ggplot2_args- |
-
| 679 | -- |
- )+ dplyr::group_by_at(dplyr::vars(x_cl, rowf, colf)) %>% |
|
| 680 | -+ | ||
| 415 | +! |
-
+ dplyr::summarise(ns = dplyr::n()), |
|
| 681 | +416 | ! |
- parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(+ env = list(x_cl = x_cl, rowf = rowf, colf = colf) |
| 682 | -! | +||
| 417 | +
- all_ggplot2_args,+ ) |
||
| 683 | -! | +||
| 418 | +
- ggtheme = input$ggtheme+ ) |
||
| 684 | +419 |
- )+ # nolint end |
|
| 685 | +420 | ||
| 686 | +421 | ! |
- qenv <- teal.code::eval_code(+ plot_call <- substitute( |
| 687 | +422 | ! |
- qenv,+ expr = |
| 688 | +423 | ! |
- substitute(+ ggplot(ANL2, aes(x = x_cl, y = ns)) + |
| 689 | +424 | ! |
- p1 <- summary_plot_obs %>%+ geom_bar(aes(fill = resp_cl), stat = "identity", position = arg_position), |
| 690 | +425 | ! |
- ggplot() ++ env = list( |
| 691 | +426 | ! |
- aes(+ x_cl = x_cl, |
| 692 | +427 | ! |
- x = factor(create_cols_labels(col), levels = x_levels),+ resp_cl = resp_cl, |
| 693 | +428 | ! |
- y = n_pct,+ arg_position = arg_position |
| 694 | -! | +||
| 429 | +
- fill = isna+ ) |
||
| 695 | +430 |
- ) ++ ) |
|
| 696 | -! | +||
| 431 | +
- geom_bar(position = "fill", stat = "identity") ++ |
||
| 697 | +432 | ! |
- scale_fill_manual(+ if (!freq) plot_call <- substitute(plot_call + expand_limits(y = c(0, 1.1)), env = list(plot_call = plot_call)) |
| 698 | -! | +||
| 433 | +
- name = "",+ |
||
| 699 | +434 | ! |
- values = c("grey90", c(getOption("ggplot2.discrete.colour")[2], "#ff2951ff")[1]),
+ if (counts) {
|
| 700 | +435 | ! |
- labels = c("Present", "Missing")
- |
-
| 701 | -- |
- ) ++ plot_call <- substitute( |
|
| 702 | +436 | ! |
- scale_y_continuous(labels = scales::percent_format(), breaks = seq(0, 1, by = 0.1), expand = c(0, 0)) ++ expr = plot_call + |
| 703 | +437 | ! |
geom_text( |
| 704 | +438 | ! |
- aes(label = ifelse(isna == TRUE, sprintf("%d [%.02f%%]", n, n_pct), ""), y = 1),
+ data = ANL2, |
| 705 | +439 | ! |
- hjust = 1,+ aes(label = ns, x = x_cl, y = ns, group = resp_cl), |
| 706 | +440 | ! |
- color = "black"+ col = "white", |
| 707 | -+ | ||
| 441 | +! |
- ) ++ vjust = "middle", |
|
| 708 | +442 | ! |
- labs ++ hjust = "middle", |
| 709 | +443 | ! |
- ggthemes ++ position = position_anl2_value |
| 710 | -! | +||
| 444 | +
- themes ++ ) + |
||
| 711 | +445 | ! |
- coord_flip(),+ geom_text( |
| 712 | +446 | ! |
- env = list(+ data = ANL3, aes(label = ns, x = x_cl, y = anl3_y), |
| 713 | +447 | ! |
- labs = parsed_ggplot2_args$labs,+ hjust = hjust_value, |
| 714 | +448 | ! |
- themes = parsed_ggplot2_args$theme,+ vjust = vjust_value, |
| 715 | +449 | ! |
- ggthemes = parsed_ggplot2_args$ggtheme+ position = position_anl3_value |
| 716 | +450 |
- )+ ), |
|
| 717 | -+ | ||
| 451 | +! |
- )+ env = list( |
|
| 718 | -+ | ||
| 452 | +! |
- )+ plot_call = plot_call, |
|
| 719 | -+ | ||
| 453 | +! |
-
+ x_cl = x_cl, |
|
| 720 | +454 | ! |
- if (isTRUE(input$if_patients_plot)) {
+ resp_cl = resp_cl, |
| 721 | +455 | ! |
- qenv <- teal.code::eval_code(+ hjust_value = if (swap_axes) "left" else "middle", |
| 722 | +456 | ! |
- qenv,+ vjust_value = if (swap_axes) "middle" else -1, |
| 723 | +457 | ! |
- substitute(+ position_anl2_value = if (!freq) quote(position_fill(0.5)) else quote(position_stack(0.5)), |
| 724 | +458 | ! |
- expr = parent_keys <- keys,+ anl3_y = if (!freq) 1.1 else as.name("ns"),
|
| 725 | +459 | ! |
- env = list(keys = data_parent_keys())+ position_anl3_value = if (!freq) "fill" else "stack" |
| 726 | +460 |
) |
|
| 727 | +461 |
- ) %>%+ ) |
|
| 728 | -! | +||
| 462 | +
- teal.code::eval_code(quote(ndistinct_subjects <- dplyr::n_distinct(ANL[, parent_keys]))) %>%+ } |
||
| 729 | -! | +||
| 463 | +
- teal.code::eval_code(+ |
||
| 730 | +464 | ! |
- quote(+ if (swap_axes) {
|
| 731 | +465 | ! |
- summary_plot_patients <- ANL[, c(parent_keys, analysis_vars)] %>%+ plot_call <- substitute(plot_call + coord_flip(), env = list(plot_call = plot_call)) |
| 732 | -! | +||
| 466 | +
- dplyr::group_by_at(parent_keys) %>%+ }+ |
+ ||
| 467 | ++ | + | |
| 733 | +468 | ! |
- dplyr::summarise_all(anyNA) %>%+ facet_cl <- facet_ggplot_call(row_facet_name, col_facet_name)+ |
+
| 469 | ++ | + | |
| 734 | +470 | ! |
- tidyr::pivot_longer(cols = !tidyselect::all_of(parent_keys), names_to = "col", values_to = "anyna") %>%+ if (!is.null(facet_cl)) {
|
| 735 | +471 | ! |
- dplyr::group_by_at(c("col")) %>%
+ plot_call <- substitute(expr = plot_call + facet_cl, env = list(plot_call = plot_call, facet_cl = facet_cl))+ |
+
| 472 | ++ |
+ }+ |
+ |
| 473 | ++ | + | |
| 736 | +474 | ! |
- dplyr::summarise(count_na = sum(anyna)) %>%+ dev_ggplot2_args <- teal.widgets::ggplot2_args( |
| 737 | +475 | ! |
- dplyr::mutate(count_not_na = ndistinct_subjects - count_na) %>%+ labs = list( |
| 738 | +476 | ! |
- tidyr::pivot_longer(-c(col), names_to = "isna", values_to = "n") %>%+ x = varname_w_label(x, ANL), |
| 739 | +477 | ! |
- dplyr::mutate(isna = isna == "count_na", n_pct = n / ndistinct_subjects * 100) %>%+ y = varname_w_label(resp_var, ANL, prefix = "Proportion of "), |
| 740 | +478 | ! |
- dplyr::arrange_at(c("isna", "n"), .funs = dplyr::desc)
+ fill = varname_w_label(resp_var, ANL) |
| 741 | +479 |
- )+ ),+ |
+ |
| 480 | +! | +
+ theme = list(legend.position = "bottom") |
|
| 742 | +481 |
- )+ ) |
|
| 743 | +482 | ||
| 744 | +483 | ! |
- dev_ggplot2_args <- teal.widgets::ggplot2_args(+ if (rotate_xaxis_labels) {
|
| 745 | +484 | ! |
- labs = list(x = "", y = "Missing patients"),+ dev_ggplot2_args$theme[["axis.text.x"]] <- quote(element_text(angle = 45, hjust = 1)) |
| 746 | -! | +||
| 485 | +
- theme = list(+ } |
||
| 747 | -! | +||
| 486 | +
- legend.position = "bottom",+ |
||
| 748 | +487 | ! |
- axis.text.x = quote(element_text(angle = 45, hjust = 1)),+ all_ggplot2_args <- teal.widgets::resolve_ggplot2_args( |
| 749 | +488 | ! |
- axis.text.y = quote(element_blank())+ user_plot = ggplot2_args, |
| 750 | -+ | ||
| 489 | +! |
- )+ module_plot = dev_ggplot2_args |
|
| 751 | +490 |
- )+ ) |
|
| 752 | +491 | ||
| 753 | -! | -
- all_ggplot2_args <- teal.widgets::resolve_ggplot2_args(- |
- |
| 754 | +492 | ! |
- user_plot = ggplot2_args[["Summary Patients"]],+ parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args( |
| 755 | +493 | ! |
- user_default = ggplot2_args$default,+ all_ggplot2_args, |
| 756 | +494 | ! |
- module_plot = dev_ggplot2_args+ ggtheme = ggtheme |
| 757 | +495 |
- )+ ) |
|
| 758 | +496 | ||
| 759 | +497 | ! |
- parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(+ plot_call <- substitute(expr = {
|
| 760 | +498 | ! |
- all_ggplot2_args,+ p <- plot_call + labs + ggthemes + themes |
| 761 | +499 | ! |
- ggtheme = input$ggtheme+ print(p) |
| 762 | -+ | ||
| 500 | +! |
- )+ }, env = list( |
|
| 763 | -+ | ||
| 501 | +! |
-
+ plot_call = plot_call, |
|
| 764 | +502 | ! |
- qenv <- teal.code::eval_code(+ labs = parsed_ggplot2_args$labs, |
| 765 | +503 | ! |
- qenv,+ themes = parsed_ggplot2_args$theme, |
| 766 | +504 | ! |
- substitute(+ ggthemes = parsed_ggplot2_args$ggtheme |
| 767 | -! | +||
| 505 | +
- p2 <- summary_plot_patients %>%+ )) |
||
| 768 | -! | +||
| 506 | +
- ggplot() ++ |
||
| 769 | +507 | ! |
- aes_(+ teal.code::eval_code(qenv, plot_call) |
| 770 | -! | +||
| 508 | +
- x = ~ factor(create_cols_labels(col), levels = x_levels),+ }) |
||
| 771 | -! | +||
| 509 | +
- y = ~n_pct,+ |
||
| 772 | +510 | ! |
- fill = ~isna+ plot_r <- reactive(output_q()[["p"]]) |
| 773 | +511 |
- ) ++ |
|
| 774 | -! | +||
| 512 | +
- geom_bar(alpha = 1, stat = "identity", position = "fill") ++ # Insert the plot into a plot_with_settings module from teal.widgets |
||
| 775 | +513 | ! |
- scale_y_continuous(labels = scales::percent_format(), breaks = seq(0, 1, by = 0.1), expand = c(0, 0)) ++ pws <- teal.widgets::plot_with_settings_srv( |
| 776 | +514 | ! |
- scale_fill_manual(+ id = "myplot", |
| 777 | +515 | ! |
- name = "",+ plot_r = plot_r, |
| 778 | +516 | ! |
- values = c("grey90", c(getOption("ggplot2.discrete.colour")[2], "#ff2951ff")[1]),
+ height = plot_height, |
| 779 | +517 | ! |
- labels = c("Present", "Missing")
+ width = plot_width |
| 780 | +518 |
- ) ++ ) |
|
| 781 | -! | +||
| 519 | +
- geom_text(+ |
||
| 782 | +520 | ! |
- aes(label = ifelse(isna == TRUE, sprintf("%d [%.02f%%]", n, n_pct), ""), y = 1),
+ teal.widgets::verbatim_popup_srv( |
| 783 | +521 | ! |
- hjust = 1,+ id = "warning", |
| 784 | +522 | ! |
- color = "black"- |
-
| 785 | -- |
- ) ++ verbatim_content = reactive(teal.code::get_warnings(output_q())), |
|
| 786 | +523 | ! |
- labs ++ title = "Warning", |
| 787 | +524 | ! |
- ggthemes ++ disabled = reactive(is.null(teal.code::get_warnings(output_q()))) |
| 788 | -! | +||
| 525 | +
- themes ++ ) |
||
| 789 | -! | +||
| 526 | +
- coord_flip(),+ |
||
| 790 | +527 | ! |
- env = list(+ teal.widgets::verbatim_popup_srv( |
| 791 | +528 | ! |
- labs = parsed_ggplot2_args$labs,+ id = "rcode", |
| 792 | +529 | ! |
- themes = parsed_ggplot2_args$theme,+ verbatim_content = reactive(teal.code::get_code(output_q())), |
| 793 | +530 | ! |
- ggthemes = parsed_ggplot2_args$ggtheme+ title = "Show R Code for Response" |
| 794 | +531 |
- )+ ) |
|
| 795 | +532 |
- )+ |
|
| 796 | +533 |
- ) %>%+ ### REPORTER |
|
| 797 | +534 | ! |
- teal.code::eval_code(+ if (with_reporter) {
|
| 798 | +535 | ! |
- quote({
+ card_fun <- function(comment, label) {
|
| 799 | +536 | ! |
- g1 <- ggplotGrob(p1)+ card <- teal::report_card_template( |
| 800 | +537 | ! |
- g2 <- ggplotGrob(p2)+ title = "Response Plot", |
| 801 | +538 | ! |
- g <- gridExtra::gtable_cbind(g1, g2, size = "first")+ label = label, |
| 802 | +539 | ! |
- g$heights <- grid::unit.pmax(g1$heights, g2$heights)+ with_filter = with_filter, |
| 803 | +540 | ! |
- grid::grid.newpage()+ filter_panel_api = filter_panel_api |
| 804 | +541 |
- })+ ) |
|
| 805 | -+ | ||
| 542 | +! |
- )+ card$append_text("Plot", "header3")
|
|
| 806 | -+ | ||
| 543 | +! |
- } else {
+ card$append_plot(plot_r(), dim = pws$dim()) |
|
| 807 | +544 | ! |
- qenv <- teal.code::eval_code(+ if (!comment == "") {
|
| 808 | +545 | ! |
- qenv,+ card$append_text("Comment", "header3")
|
| 809 | +546 | ! |
- quote({
+ card$append_text(comment)+ |
+
| 547 | ++ |
+ } |
|
| 810 | +548 | ! |
- g <- ggplotGrob(p1)+ card$append_src(teal.code::get_code(output_q())) |
| 811 | +549 | ! |
- grid::grid.newpage()+ card |
| 812 | +550 |
- })+ } |
|
| 813 | -+ | ||
| 551 | +! |
- )+ teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
|
|
| 814 | +552 |
- }+ } |
|
| 815 | +553 |
-
+ ### |
|
| 816 | -! | +||
| 554 | +
- teal.code::eval_code(+ }) |
||
| 817 | -! | +||
| 555 | +
- qenv,+ } |
||
| 818 | -! | +
| 1 | +
- quote(grid::grid.draw(g))+ #' Outliers Module |
||
| 819 | +2 |
- )+ #' |
|
| 820 | +3 |
- })+ #' Module to analyze and identify outliers using different methods |
|
| 821 | +4 |
-
+ #' |
|
| 822 | -! | +||
| 5 | +
- summary_plot_r <- reactive(summary_plot_q()[["g"]])+ #' @inheritParams teal::module |
||
| 823 | +6 |
-
+ #' @inheritParams shared_params |
|
| 824 | -! | +||
| 7 | +
- combination_cutoff_q <- reactive({
+ #' |
||
| 825 | -! | +||
| 8 | +
- req(common_code_q())+ #' @param outlier_var (`data_extract_spec` or `list` of multiple `data_extract_spec`) |
||
| 826 | -! | +||
| 9 | +
- teal.code::eval_code(+ #' variable to consider for the outliers analysis. |
||
| 827 | -! | +||
| 10 | +
- common_code_q(),+ #' @param categorical_var (`data_extract_spec` or `list` of multiple `data_extract_spec`) |
||
| 828 | -! | +||
| 11 | +
- quote(+ #' categorical factor to split the selected outlier variables on. |
||
| 829 | -! | +||
| 12 | +
- combination_cutoff <- ANL %>%+ #' |
||
| 830 | -! | +||
| 13 | +
- dplyr::mutate_all(is.na) %>%+ #' @templateVar ggnames "Boxplot","Density Plot","Cumulative Distribution Plot" |
||
| 831 | -! | +||
| 14 | +
- dplyr::group_by_all() %>%+ #' @template ggplot2_args_multi |
||
| 832 | -! | +||
| 15 | +
- dplyr::tally() %>%+ #' |
||
| 833 | -! | +||
| 16 | +
- dplyr::ungroup()+ #' @examples |
||
| 834 | +17 |
- )+ #' # general data example |
|
| 835 | +18 |
- )+ #' library(teal.widgets) |
|
| 836 | +19 |
- })+ #' |
|
| 837 | +20 |
-
+ #' data <- teal_data() |
|
| 838 | -! | +||
| 21 | +
- output$cutoff <- renderUI({
+ #' data <- within(data, {
|
||
| 839 | -! | +||
| 22 | +
- x <- combination_cutoff_q()[["combination_cutoff"]]$n+ #' CO2 <- CO2 |
||
| 840 | +23 |
-
+ #' CO2[["primary_key"]] <- seq_len(nrow(CO2)) |
|
| 841 | +24 |
- # select 10-th from the top+ #' }) |
|
| 842 | -! | +||
| 25 | +
- n <- length(x)+ #' datanames(data) <- "CO2" |
||
| 843 | -! | +||
| 26 | +
- idx <- max(1, n - 10)+ #' join_keys(data) <- join_keys(join_key("CO2", "CO2", "primary_key"))
|
||
| 844 | -! | +||
| 27 | +
- prev_value <- isolate(input$combination_cutoff)+ #' |
||
| 845 | -! | +||
| 28 | +
- value <- `if`(+ #' vars <- choices_selected(variable_choices(data[["CO2"]], c("Plant", "Type", "Treatment")))
|
||
| 846 | -! | +||
| 29 | +
- is.null(prev_value) || prev_value > max(x) || prev_value < min(x),+ #' |
||
| 847 | -! | +||
| 30 | +
- sort(x, partial = idx)[idx], prev_value+ #' app <- init( |
||
| 848 | +31 |
- )+ #' data = data, |
|
| 849 | +32 |
-
+ #' modules = modules( |
|
| 850 | -! | +||
| 33 | +
- teal.widgets::optionalSliderInputValMinMax(+ #' tm_outliers( |
||
| 851 | -! | +||
| 34 | +
- session$ns("combination_cutoff"),
+ #' outlier_var = list( |
||
| 852 | -! | +||
| 35 | +
- "Combination cut-off",+ #' data_extract_spec( |
||
| 853 | -! | +||
| 36 | +
- c(value, range(x))+ #' dataname = "CO2", |
||
| 854 | +37 |
- )+ #' select = select_spec( |
|
| 855 | +38 |
- })+ #' label = "Select variable:", |
|
| 856 | +39 |
-
+ #' choices = variable_choices(data[["CO2"]], c("conc", "uptake")),
|
|
| 857 | -! | +||
| 40 | +
- combination_plot_q <- reactive({
+ #' selected = "uptake", |
||
| 858 | -! | +||
| 41 | +
- req(input$summary_type == "Combinations", input$combination_cutoff, combination_cutoff_q())+ #' multiple = FALSE, |
||
| 859 | -! | +||
| 42 | +
- teal::validate_has_data(data_r(), 1)+ #' fixed = FALSE |
||
| 860 | +43 |
-
+ #' ) |
|
| 861 | -! | +||
| 44 | +
- qenv <- teal.code::eval_code(+ #' ) |
||
| 862 | -! | +||
| 45 | +
- combination_cutoff_q(),+ #' ), |
||
| 863 | -! | +||
| 46 | +
- substitute(+ #' categorical_var = list( |
||
| 864 | -! | +||
| 47 | +
- expr = data_combination_plot_cutoff <- combination_cutoff %>%+ #' data_extract_spec( |
||
| 865 | -! | +||
| 48 | +
- dplyr::filter(n >= combination_cutoff_value) %>%+ #' dataname = "CO2", |
||
| 866 | -! | +||
| 49 | +
- dplyr::mutate(id = rank(-n, ties.method = "first")) %>%+ #' filter = filter_spec( |
||
| 867 | -! | +||
| 50 | +
- tidyr::pivot_longer(-c(n, id), names_to = "key", values_to = "value") %>%+ #' vars = vars, |
||
| 868 | -! | +||
| 51 | +
- dplyr::arrange(n),+ #' choices = value_choices(data[["CO2"]], vars$selected), |
||
| 869 | -! | +||
| 52 | +
- env = list(combination_cutoff_value = input$combination_cutoff)+ #' selected = value_choices(data[["CO2"]], vars$selected), |
||
| 870 | +53 |
- )+ #' multiple = TRUE |
|
| 871 | +54 |
- )+ #' ) |
|
| 872 | +55 |
-
+ #' ) |
|
| 873 | +56 |
- # find keys in dataset not selected in the UI and remove them from dataset+ #' ), |
|
| 874 | -! | +||
| 57 | +
- keys_not_selected <- setdiff(data_keys(), input$variables_select)+ #' ggplot2_args = list( |
||
| 875 | -! | +||
| 58 | +
- if (length(keys_not_selected) > 0) {
+ #' ggplot2_args( |
||
| 876 | -! | +||
| 59 | +
- qenv <- teal.code::eval_code(+ #' labs = list(subtitle = "Plot generated by Outliers Module") |
||
| 877 | -! | +||
| 60 | +
- qenv,+ #' ) |
||
| 878 | -! | +||
| 61 | +
- substitute(+ #' ) |
||
| 879 | -! | +||
| 62 | +
- expr = data_combination_plot_cutoff <- data_combination_plot_cutoff %>%+ #' ) |
||
| 880 | -! | +||
| 63 | +
- dplyr::filter(!key %in% keys_not_selected),+ #' ) |
||
| 881 | -! | +||
| 64 | +
- env = list(keys_not_selected = keys_not_selected)+ #' ) |
||
| 882 | +65 |
- )+ #' if (interactive()) {
|
|
| 883 | +66 |
- )+ #' shinyApp(app$ui, app$server) |
|
| 884 | +67 |
- }+ #' } |
|
| 885 | +68 |
-
+ #' |
|
| 886 | -! | +||
| 69 | +
- qenv <- teal.code::eval_code(+ #' # CDISC data example |
||
| 887 | -! | +||
| 70 | +
- qenv,+ #' library(teal.widgets) |
||
| 888 | -! | +||
| 71 | +
- quote(+ #' |
||
| 889 | -! | +||
| 72 | +
- labels <- data_combination_plot_cutoff %>%+ #' data <- teal_data() |
||
| 890 | -! | +||
| 73 | +
- dplyr::filter(key == key[[1]]) %>%+ #' data <- within(data, {
|
||
| 891 | -! | +||
| 74 | +
- getElement(name = 1)+ #' ADSL <- rADSL |
||
| 892 | +75 |
- )+ #' }) |
|
| 893 | +76 |
- )+ #' datanames(data) <- "ADSL" |
|
| 894 | +77 |
-
+ #' join_keys(data) <- default_cdisc_join_keys[datanames(data)] |
|
| 895 | -! | +||
| 78 | +
- dev_ggplot2_args1 <- teal.widgets::ggplot2_args(+ #' |
||
| 896 | -! | +||
| 79 | +
- labs = list(x = "", y = ""),+ #' fact_vars_adsl <- names(Filter(isTRUE, sapply(data[["ADSL"]], is.factor))) |
||
| 897 | -! | +||
| 80 | +
- theme = list(+ #' vars <- choices_selected(variable_choices(data[["ADSL"]], fact_vars_adsl)) |
||
| 898 | -! | +||
| 81 | +
- legend.position = "bottom",+ #' |
||
| 899 | -! | +||
| 82 | +
- axis.text.x = quote(element_blank())+ #' app <- init( |
||
| 900 | +83 |
- )+ #' data = data, |
|
| 901 | +84 |
- )+ #' modules = modules( |
|
| 902 | +85 |
-
+ #' tm_outliers( |
|
| 903 | -! | +||
| 86 | +
- all_ggplot2_args1 <- teal.widgets::resolve_ggplot2_args(+ #' outlier_var = list( |
||
| 904 | -! | +||
| 87 | +
- user_plot = ggplot2_args[["Combinations Hist"]],+ #' data_extract_spec( |
||
| 905 | -! | +||
| 88 | +
- user_default = ggplot2_args$default,+ #' dataname = "ADSL", |
||
| 906 | -! | +||
| 89 | +
- module_plot = dev_ggplot2_args1+ #' select = select_spec( |
||
| 907 | +90 |
- )+ #' label = "Select variable:", |
|
| 908 | +91 |
-
+ #' choices = variable_choices(data[["ADSL"]], c("AGE", "BMRKR1")),
|
|
| 909 | -! | +||
| 92 | +
- parsed_ggplot2_args1 <- teal.widgets::parse_ggplot2_args(+ #' selected = "AGE", |
||
| 910 | -! | +||
| 93 | +
- all_ggplot2_args1,+ #' multiple = FALSE, |
||
| 911 | -! | +||
| 94 | +
- ggtheme = "void"+ #' fixed = FALSE |
||
| 912 | +95 |
- )+ #' ) |
|
| 913 | +96 |
-
+ #' ) |
|
| 914 | -! | +||
| 97 | +
- dev_ggplot2_args2 <- teal.widgets::ggplot2_args(+ #' ), |
||
| 915 | -! | +||
| 98 | +
- labs = list(x = "", y = ""),+ #' categorical_var = list( |
||
| 916 | -! | +||
| 99 | +
- theme = list(+ #' data_extract_spec( |
||
| 917 | -! | +||
| 100 | +
- legend.position = "bottom",+ #' dataname = "ADSL", |
||
| 918 | -! | +||
| 101 | +
- axis.text.x = quote(element_blank()),+ #' filter = filter_spec( |
||
| 919 | -! | +||
| 102 | +
- axis.ticks = quote(element_blank()),+ #' vars = vars, |
||
| 920 | -! | +||
| 103 | +
- panel.grid.major = quote(element_blank())+ #' choices = value_choices(data[["ADSL"]], vars$selected), |
||
| 921 | +104 |
- )+ #' selected = value_choices(data[["ADSL"]], vars$selected), |
|
| 922 | +105 |
- )+ #' multiple = TRUE |
|
| 923 | +106 |
-
+ #' ) |
|
| 924 | -! | +||
| 107 | +
- all_ggplot2_args2 <- teal.widgets::resolve_ggplot2_args(+ #' ) |
||
| 925 | -! | +||
| 108 | +
- user_plot = ggplot2_args[["Combinations Main"]],+ #' ), |
||
| 926 | -! | +||
| 109 | +
- user_default = ggplot2_args$default,+ #' ggplot2_args = list( |
||
| 927 | -! | +||
| 110 | +
- module_plot = dev_ggplot2_args2+ #' ggplot2_args( |
||
| 928 | +111 |
- )+ #' labs = list(subtitle = "Plot generated by Outliers Module") |
|
| 929 | +112 |
-
+ #' ) |
|
| 930 | -! | +||
| 113 | +
- parsed_ggplot2_args2 <- teal.widgets::parse_ggplot2_args(+ #' ) |
||
| 931 | -! | +||
| 114 | +
- all_ggplot2_args2,+ #' ) |
||
| 932 | -! | +||
| 115 | +
- ggtheme = input$ggtheme+ #' ) |
||
| 933 | +116 |
- )+ #' ) |
|
| 934 | +117 |
-
+ #' if (interactive()) {
|
|
| 935 | -! | +||
| 118 | +
- teal.code::eval_code(+ #' shinyApp(app$ui, app$server) |
||
| 936 | -! | +||
| 119 | +
- qenv,+ #' } |
||
| 937 | -! | +||
| 120 | +
- substitute(+ #' |
||
| 938 | -! | +||
| 121 | +
- expr = {
+ #' @export |
||
| 939 | -! | +||
| 122 | +
- p1 <- data_combination_plot_cutoff %>%+ #' |
||
| 940 | -! | +||
| 123 | +
- dplyr::select(id, n) %>%+ tm_outliers <- function(label = "Outliers Module", |
||
| 941 | -! | +||
| 124 | +
- dplyr::distinct() %>%+ outlier_var, |
||
| 942 | -! | +||
| 125 | +
- ggplot(aes(x = id, y = n)) ++ categorical_var = NULL, |
||
| 943 | -! | +||
| 126 | +
- geom_bar(stat = "identity", fill = c(getOption("ggplot2.discrete.colour")[2], "#ff2951ff")[1]) +
+ ggtheme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void"),
|
||
| 944 | -! | +||
| 127 | +
- geom_text(aes(label = n), position = position_dodge(width = 0.9), vjust = -0.25) ++ ggplot2_args = teal.widgets::ggplot2_args(), |
||
| 945 | -! | +||
| 128 | +
- ylim(c(0, max(data_combination_plot_cutoff$n) * 1.5)) ++ plot_height = c(600, 200, 2000), |
||
| 946 | -! | +||
| 129 | +
- labs1 ++ plot_width = NULL, |
||
| 947 | -! | +||
| 130 | +
- ggthemes1 ++ pre_output = NULL,+ |
+ ||
| 131 | ++ |
+ post_output = NULL) {
|
|
| 948 | +132 | ! |
- themes1+ logger::log_info("Initializing tm_outliers")
|
| 949 | -+ | ||
| 133 | +! |
-
+ if (inherits(outlier_var, "data_extract_spec")) outlier_var <- list(outlier_var) |
|
| 950 | +134 | ! |
- graph_number_rows <- length(unique(data_combination_plot_cutoff$id))+ if (inherits(categorical_var, "data_extract_spec")) categorical_var <- list(categorical_var) |
| 951 | +135 | ! |
- graph_number_cols <- nrow(data_combination_plot_cutoff) / graph_number_rows+ if (inherits(ggplot2_args, "ggplot2_args")) ggplot2_args <- list(default = ggplot2_args) |
| 952 | +136 | ||
| 953 | +137 | ! |
- p2 <- data_combination_plot_cutoff %>% ggplot() ++ ggtheme <- match.arg(ggtheme) |
| 954 | +138 | ! |
- aes(x = create_cols_labels(key), y = id - 0.5, fill = value) ++ checkmate::assert_string(label) |
| 955 | +139 | ! |
- geom_tile(alpha = 0.85, height = 0.95) ++ checkmate::assert_list(outlier_var, types = "data_extract_spec") |
| 956 | +140 | ! |
- scale_fill_manual(+ checkmate::assert_list(categorical_var, types = "data_extract_spec", null.ok = TRUE) |
| 957 | +141 | ! |
- name = "",+ if (is.list(categorical_var)) {
|
| 958 | +142 | ! |
- values = c("grey90", c(getOption("ggplot2.discrete.colour")[2], "#ff2951ff")[1]),
+ lapply(categorical_var, function(x) {
|
| 959 | +143 | ! |
- labels = c("Present", "Missing")
+ if (length(x$filter) > 1L) {
|
| 960 | -+ | ||
| 144 | +! |
- ) ++ stop("tm_outliers: categorical_var data_extract_specs may only specify one filter_spec", call. = FALSE)
|
|
| 961 | -! | +||
| 145 | +
- geom_hline(yintercept = seq_len(1 + graph_number_rows) - 1) ++ } |
||
| 962 | -! | +||
| 146 | +
- geom_vline(xintercept = seq_len(1 + graph_number_cols) - 0.5, linetype = "dotted") ++ }) |
||
| 963 | -! | +||
| 147 | +
- coord_flip() ++ } |
||
| 964 | +148 | ! |
- labs2 ++ plot_choices <- c("Boxplot", "Density Plot", "Cumulative Distribution Plot")
|
| 965 | +149 | ! |
- ggthemes2 ++ checkmate::assert_list(ggplot2_args, types = "ggplot2_args") |
| 966 | +150 | ! |
- themes2+ checkmate::assert_subset(names(ggplot2_args), c("default", plot_choices))
|
| 967 | +151 | ||
| 968 | -! | -
- g1 <- ggplotGrob(p1)- |
- |
| 969 | +152 | ! |
- g2 <- ggplotGrob(p2)+ args <- as.list(environment()) |
| 970 | +153 | ||
| 971 | -! | -
- g <- gridExtra::gtable_rbind(g1, g2, size = "last")- |
- |
| 972 | +154 | ! |
- g$heights[7] <- grid::unit(0.2, "null") # rescale to get the bar chart smaller+ data_extract_list <- list( |
| 973 | +155 | ! |
- grid::grid.newpage()+ outlier_var = outlier_var, |
| 974 | +156 | ! |
- grid::grid.draw(g)+ categorical_var = categorical_var |
| 975 | +157 |
- },+ ) |
|
| 976 | -! | +||
| 158 | +
- env = list(+ |
||
| 977 | +159 | ! |
- labs1 = parsed_ggplot2_args1$labs,+ module( |
| 978 | +160 | ! |
- themes1 = parsed_ggplot2_args1$theme,+ label = label, |
| 979 | +161 | ! |
- ggthemes1 = parsed_ggplot2_args1$ggtheme,+ server = srv_outliers, |
| 980 | +162 | ! |
- labs2 = parsed_ggplot2_args2$labs,+ server_args = c( |
| 981 | +163 | ! |
- themes2 = parsed_ggplot2_args2$theme,+ data_extract_list, |
| 982 | +164 | ! |
- ggthemes2 = parsed_ggplot2_args2$ggtheme+ list(plot_height = plot_height, plot_width = plot_width, ggplot2_args = ggplot2_args) |
| 983 | +165 |
- )+ ), |
|
| 984 | -- |
- )+ | |
| 166 | +! | +
+ ui = ui_outliers, |
|
| 985 | -+ | ||
| 167 | +! |
- )+ ui_args = args, |
|
| 986 | -+ | ||
| 168 | +! |
- })+ datanames = teal.transform::get_extract_datanames(data_extract_list) |
|
| 987 | +169 |
-
+ ) |
|
| 988 | -! | +||
| 170 | +
- combination_plot_r <- reactive(combination_plot_q()[["g"]])+ } |
||
| 989 | +171 | ||
| 990 | -! | +||
| 172 | +
- summary_table_q <- reactive({
+ ui_outliers <- function(id, ...) {
|
||
| 991 | +173 | ! |
- req(+ args <- list(...) |
| 992 | +174 | ! |
- input$summary_type == "By Variable Levels", # needed to trigger show r code update on tab change+ ns <- NS(id) |
| 993 | +175 | ! |
- common_code_q()+ is_single_dataset_value <- teal.transform::is_single_dataset(args$outlier_var, args$categorical_var) |
| 994 | +176 |
- )+ |
|
| 995 | +177 | ! |
- teal::validate_has_data(data_r(), 1)- |
-
| 996 | -- | - - | -|
| 997 | -- |
- # extract the ANL dataset for use in further validation+ teal.widgets::standard_layout( |
|
| 998 | +178 | ! |
- anl <- common_code_q()[["ANL"]]+ output = teal.widgets::white_small_well( |
| 999 | -+ | ||
| 179 | +! |
-
+ uiOutput(ns("total_outliers")),
|
|
| 1000 | +180 | ! |
- group_var <- input$group_by_var+ DT::dataTableOutput(ns("summary_table")),
|
| 1001 | +181 | ! |
- validate(+ uiOutput(ns("total_missing")),
|
| 1002 | +182 | ! |
- need(+ br(), hr(), |
| 1003 | +183 | ! |
- is.null(group_var) ||+ tabsetPanel( |
| 1004 | +184 | ! |
- length(unique(anl[[group_var]])) < 100,+ id = ns("tabs"),
|
| 1005 | +185 | ! |
- "Please select group-by variable with fewer than 100 unique values"+ tabPanel( |
| 1006 | -+ | ||
| 186 | +! |
- )+ "Boxplot", |
|
| 1007 | -+ | ||
| 187 | +! |
- )+ teal.widgets::plot_with_settings_ui(id = ns("box_plot"))
|
|
| 1008 | +188 | - - | -|
| 1009 | -! | -
- group_vals <- input$group_by_vals+ ), |
|
| 1010 | +189 | ! |
- variables_select <- input$variables_select+ tabPanel( |
| 1011 | +190 | ! |
- vars <- unique(variables_select, group_var)+ "Density Plot", |
| 1012 | +191 | ! |
- count_type <- input$count_type+ teal.widgets::plot_with_settings_ui(id = ns("density_plot"))
|
| 1013 | +192 |
-
+ ), |
|
| 1014 | +193 | ! |
- if (!is.null(selected_vars()) && length(selected_vars()) != ncol(anl)) {
+ tabPanel( |
| 1015 | +194 | ! |
- variables <- selected_vars()- |
-
| 1016 | -- |
- } else {
+ "Cumulative Distribution Plot", |
|
| 1017 | +195 | ! |
- variables <- colnames(anl)+ teal.widgets::plot_with_settings_ui(id = ns("cum_density_plot"))
|
| 1018 | +196 |
- }+ ) |
|
| 1019 | +197 |
-
+ ), |
|
| 1020 | +198 | ! |
- summ_fn <- if (input$count_type == "counts") {
+ br(), hr(), |
| 1021 | +199 | ! |
- function(x) sum(is.na(x))+ uiOutput(ns("table_ui_wrap"))
|
| 1022 | +200 |
- } else {
+ ), |
|
| 1023 | +201 | ! |
- function(x) round(sum(is.na(x)) / length(x), 4)+ encoding = div( |
| 1024 | +202 |
- }+ ### Reporter+ |
+ |
| 203 | +! | +
+ teal.reporter::simple_reporter_ui(ns("simple_reporter")),
|
|
| 1025 | +204 |
-
+ ### |
|
| 1026 | +205 | ! |
- qenv <- common_code_q()+ tags$label("Encodings", class = "text-primary"),
|
| 1027 | -+ | ||
| 206 | +! |
-
+ teal.transform::datanames_input(args[c("outlier_var", "categorical_var")]),
|
|
| 1028 | +207 | ! |
- if (!is.null(group_var)) {
+ teal.transform::data_extract_ui( |
| 1029 | +208 | ! |
- qenv <- teal.code::eval_code(+ id = ns("outlier_var"),
|
| 1030 | +209 | ! |
- qenv,+ label = "Variable", |
| 1031 | +210 | ! |
- substitute(+ data_extract_spec = args$outlier_var, |
| 1032 | +211 | ! |
- expr = {
+ is_single_dataset = is_single_dataset_value+ |
+
| 212 | ++ |
+ ), |
|
| 1033 | +213 | ! |
- summary_data <- ANL %>%+ if (!is.null(args$categorical_var)) {
|
| 1034 | +214 | ! |
- dplyr::mutate(group_var_name := forcats::fct_na_value_to_level(as.factor(group_var_name), "NA")) %>%+ teal.transform::data_extract_ui( |
| 1035 | +215 | ! |
- dplyr::group_by_at(group_var) %>%+ id = ns("categorical_var"),
|
| 1036 | +216 | ! |
- dplyr::filter(group_var_name %in% group_vals)+ label = "Categorical factor", |
| 1037 | -+ | ||
| 217 | +! |
-
+ data_extract_spec = args$categorical_var, |
|
| 1038 | +218 | ! |
- count_data <- dplyr::summarise(summary_data, n = dplyr::n())+ is_single_dataset = is_single_dataset_value |
| 1039 | +219 |
-
+ ) |
|
| 1040 | -! | +||
| 220 | +
- summary_data <- dplyr::summarise_all(summary_data, summ_fn) %>%+ }, |
||
| 1041 | +221 | ! |
- dplyr::mutate(group_var_name := paste0(group_var, ":", group_var_name, "(N=", count_data$n, ")")) %>%+ conditionalPanel( |
| 1042 | +222 | ! |
- tidyr::pivot_longer(!tidyselect::all_of(group_var), names_to = "Variable", values_to = "out") %>%+ condition = paste0("input['", ns("tabs"), "'] == 'Boxplot'"),
|
| 1043 | +223 | ! |
- tidyr::pivot_wider(names_from = group_var, values_from = "out") %>%+ teal.widgets::optionalSelectInput( |
| 1044 | +224 | ! |
- dplyr::mutate(`Variable label` = create_cols_labels(Variable, just_label = TRUE), .after = Variable)- |
-
| 1045 | -- |
- },+ inputId = ns("boxplot_alts"),
|
|
| 1046 | +225 | ! |
- env = list(+ label = "Plot type", |
| 1047 | +226 | ! |
- group_var = group_var, group_var_name = as.name(group_var), group_vals = group_vals, summ_fn = summ_fn+ choices = c("Box plot", "Violin plot"),
|
| 1048 | -+ | ||
| 227 | +! |
- )+ selected = "Box plot", |
|
| 1049 | -+ | ||
| 228 | +! |
- )+ multiple = FALSE |
|
| 1050 | +229 |
) |
|
| 1051 | +230 |
- } else {
+ ), |
|
| 1052 | +231 | ! |
- qenv <- teal.code::eval_code(+ shinyjs::hidden(checkboxInput(ns("split_outliers"), "Define outliers based on group splitting", value = FALSE)),
|
| 1053 | +232 | ! |
- qenv,+ shinyjs::hidden(checkboxInput(ns("order_by_outlier"), "Re-order categories by outliers [by %]", value = FALSE)),
|
| 1054 | +233 | ! |
- substitute(+ teal.widgets::panel_group( |
| 1055 | +234 | ! |
- expr = summary_data <- ANL %>%+ teal.widgets::panel_item( |
| 1056 | +235 | ! |
- dplyr::summarise_all(summ_fn) %>%+ title = "Method parameters", |
| 1057 | +236 | ! |
- tidyr::pivot_longer(tidyselect::everything(),+ collapsed = FALSE, |
| 1058 | +237 | ! |
- names_to = "Variable",+ teal.widgets::optionalSelectInput( |
| 1059 | +238 | ! |
- values_to = paste0("Missing (N=", nrow(ANL), ")")
+ inputId = ns("method"),
|
| 1060 | -+ | ||
| 239 | +! |
- ) %>%+ label = "Method", |
|
| 1061 | +240 | ! |
- dplyr::mutate(`Variable label` = create_cols_labels(Variable), .after = Variable),+ choices = c("IQR", "Z-score", "Percentile"),
|
| 1062 | +241 | ! |
- env = list(summ_fn = summ_fn)+ selected = "IQR", |
| 1063 | -+ | ||
| 242 | +! |
- )+ multiple = FALSE |
|
| 1064 | +243 |
- )+ ), |
|
| 1065 | -+ | ||
| 244 | +! |
- }+ conditionalPanel( |
|
| 1066 | -+ | ||
| 245 | +! |
-
+ condition = |
|
| 1067 | +246 | ! |
- teal.code::eval_code(qenv, quote(summary_data))+ paste0("input['", ns("method"), "'] == 'IQR'"),
|
| 1068 | -+ | ||
| 247 | +! |
- })+ sliderInput( |
|
| 1069 | -+ | ||
| 248 | +! |
-
+ ns("iqr_slider"),
|
|
| 1070 | +249 | ! |
- summary_table_r <- reactive(summary_table_q()[["summary_data"]])+ "Outlier range:", |
| 1071 | -+ | ||
| 250 | +! |
-
+ min = 1, |
|
| 1072 | +251 | ! |
- by_subject_plot_q <- reactive({
+ max = 5, |
| 1073 | -+ | ||
| 252 | +! |
- # needed to trigger show r code update on tab change+ value = 3, |
|
| 1074 | +253 | ! |
- req(input$summary_type == "Grouped by Subject", common_code_q())+ step = 0.5 |
| 1075 | +254 | - - | -|
| 1076 | -! | -
- teal::validate_has_data(data_r(), 1)+ ) |
|
| 1077 | +255 |
-
+ ), |
|
| 1078 | +256 | ! |
- dev_ggplot2_args <- teal.widgets::ggplot2_args(+ conditionalPanel( |
| 1079 | +257 | ! |
- labs = list(x = "", y = ""),+ condition = |
| 1080 | +258 | ! |
- theme = list(legend.position = "bottom", axis.text.x = quote(element_blank()))+ paste0("input['", ns("method"), "'] == 'Z-score'"),
|
| 1081 | -+ | ||
| 259 | +! |
- )+ sliderInput( |
|
| 1082 | -+ | ||
| 260 | +! |
-
+ ns("zscore_slider"),
|
|
| 1083 | +261 | ! |
- all_ggplot2_args <- teal.widgets::resolve_ggplot2_args(+ "Outlier range:", |
| 1084 | +262 | ! |
- user_plot = ggplot2_args[["By Subject"]],+ min = 1, |
| 1085 | +263 | ! |
- user_default = ggplot2_args$default,+ max = 5, |
| 1086 | +264 | ! |
- module_plot = dev_ggplot2_args+ value = 3,+ |
+
| 265 | +! | +
+ step = 0.5 |
|
| 1087 | +266 |
- )+ ) |
|
| 1088 | +267 |
-
+ ), |
|
| 1089 | +268 | ! |
- parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(+ conditionalPanel( |
| 1090 | +269 | ! |
- all_ggplot2_args,+ condition = |
| 1091 | +270 | ! |
- ggtheme = input$ggtheme+ paste0("input['", ns("method"), "'] == 'Percentile'"),
|
| 1092 | -+ | ||
| 271 | +! |
- )+ sliderInput( |
|
| 1093 | -+ | ||
| 272 | +! |
-
+ ns("percentile_slider"),
|
|
| 1094 | +273 | ! |
- teal.code::eval_code(+ "Outlier range:", |
| 1095 | +274 | ! |
- common_code_q(),+ min = 0.001, |
| 1096 | +275 | ! |
- substitute(+ max = 0.5, |
| 1097 | +276 | ! |
- expr = parent_keys <- keys,+ value = 0.01, |
| 1098 | +277 | ! |
- env = list(keys = data_parent_keys())+ step = 0.001 |
| 1099 | +278 |
- )+ ) |
|
| 1100 | +279 |
- ) %>%- |
- |
| 1101 | -! | -
- teal.code::eval_code(- |
- |
| 1102 | -! | -
- substitute(- |
- |
| 1103 | -! | -
- expr = analysis_vars <- setdiff(colnames(ANL), data_keys),+ ), |
|
| 1104 | +280 | ! |
- env = list(data_keys = data_keys())+ uiOutput(ns("ui_outlier_help"))
|
| 1105 | +281 |
- )+ ) |
|
| 1106 | +282 |
- ) %>%- |
- |
| 1107 | -! | -
- teal.code::eval_code(+ ), |
|
| 1108 | +283 | ! |
- quote({
+ teal.widgets::panel_item( |
| 1109 | +284 | ! |
- summary_plot_patients <- ANL[, c(parent_keys, analysis_vars)] %>%+ title = "Plot settings", |
| 1110 | +285 | ! |
- dplyr::group_by_at(parent_keys) %>%+ selectInput( |
| 1111 | +286 | ! |
- dplyr::mutate(id = dplyr::cur_group_id()) %>%+ inputId = ns("ggtheme"),
|
| 1112 | +287 | ! |
- dplyr::ungroup() %>%+ label = "Theme (by ggplot):", |
| 1113 | +288 | ! |
- dplyr::group_by_at(c(parent_keys, "id")) %>%+ choices = ggplot_themes, |
| 1114 | +289 | ! |
- dplyr::summarise_all(anyNA) %>%+ selected = args$ggtheme, |
| 1115 | +290 | ! |
- dplyr::ungroup()+ multiple = FALSE |
| 1116 | +291 |
-
+ ) |
|
| 1117 | +292 |
- # order subjects by decreasing number of missing and then by+ ) |
|
| 1118 | +293 |
- # missingness pattern (defined using sha1)+ ), |
|
| 1119 | +294 | ! |
- order_subjects <- summary_plot_patients %>%+ forms = tagList( |
| 1120 | +295 | ! |
- dplyr::select(-"id", -tidyselect::all_of(parent_keys)) %>%+ teal.widgets::verbatim_popup_ui(ns("warning"), "Show Warnings"),
|
| 1121 | +296 | ! |
- dplyr::transmute(+ teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code")
|
| 1122 | -! | +||
| 297 | +
- id = dplyr::row_number(),+ ), |
||
| 1123 | +298 | ! |
- number_NA = apply(., 1, sum),+ pre_output = args$pre_output, |
| 1124 | +299 | ! |
- sha = apply(., 1, rlang::hash)+ post_output = args$post_output |
| 1125 | +300 |
- ) %>%+ ) |
|
| 1126 | -! | +||
| 301 | +
- dplyr::arrange(dplyr::desc(number_NA), sha) %>%+ } |
||
| 1127 | -! | +||
| 302 | +
- getElement(name = "id")+ |
||
| 1128 | +303 |
-
+ srv_outliers <- function(id, data, reporter, filter_panel_api, outlier_var, |
|
| 1129 | +304 |
- # order columns by decreasing percent of missing values+ categorical_var, plot_height, plot_width, ggplot2_args) {
|
|
| 1130 | +305 | ! |
- ordered_columns <- summary_plot_patients %>%+ with_reporter <- !missing(reporter) && inherits(reporter, "Reporter") |
| 1131 | +306 | ! |
- dplyr::select(-"id", -tidyselect::all_of(parent_keys)) %>%+ with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI") |
| 1132 | +307 | ! |
- dplyr::summarise(+ checkmate::assert_class(data, "reactive") |
| 1133 | +308 | ! |
- column = create_cols_labels(colnames(.)),+ checkmate::assert_class(isolate(data()), "teal_data") |
| 1134 | +309 | ! |
- na_count = apply(., MARGIN = 2, FUN = sum),+ moduleServer(id, function(input, output, session) {
|
| 1135 | +310 | ! |
- na_percent = na_count / nrow(.) * 100+ vars <- list(outlier_var = outlier_var, categorical_var = categorical_var) |
| 1136 | +311 |
- ) %>%+ |
|
| 1137 | +312 | ! |
- dplyr::arrange(na_percent, dplyr::desc(column))+ rule_diff <- function(other) {
|
| 1138 | -+ | ||
| 313 | +! |
-
+ function(value) {
|
|
| 1139 | +314 | ! |
- summary_plot_patients <- summary_plot_patients %>%+ othervalue <- tryCatch(selector_list()[[other]]()[["select"]], error = function(e) NULL) |
| 1140 | +315 | ! |
- tidyr::gather("col", "isna", -"id", -tidyselect::all_of(parent_keys)) %>%
+ if (!is.null(othervalue) && identical(othervalue, value)) {
|
| 1141 | +316 | ! |
- dplyr::mutate(col = create_cols_labels(col))+ "`Variable` and `Categorical factor` cannot be the same" |
| 1142 | +317 |
- })+ } |
|
| 1143 | +318 |
- ) %>%+ }+ |
+ |
| 319 | ++ |
+ }+ |
+ |
| 320 | ++ | + | |
| 1144 | +321 | ! |
- teal.code::eval_code(+ selector_list <- teal.transform::data_extract_multiple_srv( |
| 1145 | +322 | ! |
- substitute(+ data_extract = vars, |
| 1146 | +323 | ! |
- expr = {
+ datasets = data, |
| 1147 | +324 | ! |
- g <- ggplot(summary_plot_patients, aes(+ select_validation_rule = list( |
| 1148 | +325 | ! |
- x = factor(id, levels = order_subjects),+ outlier_var = shinyvalidate::compose_rules( |
| 1149 | +326 | ! |
- y = factor(col, levels = ordered_columns[["column"]]),+ shinyvalidate::sv_required("Please select a variable"),
|
| 1150 | +327 | ! |
- fill = isna+ rule_diff("categorical_var")
|
| 1151 | +328 |
- )) ++ ), |
|
| 1152 | +329 | ! |
- geom_raster() ++ categorical_var = rule_diff("outlier_var")
|
| 1153 | -! | +||
| 330 | +
- annotate(+ )+ |
+ ||
| 331 | ++ |
+ )+ |
+ |
| 332 | ++ | + | |
| 1154 | +333 | ! |
- "text",+ iv_r <- reactive({
|
| 1155 | +334 | ! |
- x = length(order_subjects),+ iv <- shinyvalidate::InputValidator$new() |
| 1156 | +335 | ! |
- y = seq_len(nrow(ordered_columns)),+ iv$add_rule("method", shinyvalidate::sv_required("Please select a method"))
|
| 1157 | +336 | ! |
- hjust = 1,+ iv$add_rule("boxplot_alts", shinyvalidate::sv_required("Please select Plot Type"))
|
| 1158 | +337 | ! |
- label = sprintf("%d [%.02f%%]", ordered_columns[["na_count"]], ordered_columns[["na_percent"]])
+ teal.transform::compose_and_enable_validators(iv, selector_list) |
| 1159 | +338 |
- ) ++ }) |
|
| 1160 | -! | +||
| 339 | +
- scale_fill_manual(+ |
||
| 1161 | +340 | ! |
- name = "",+ reactive_select_input <- reactive({
|
| 1162 | +341 | ! |
- values = c("grey90", c(getOption("ggplot2.discrete.colour")[2], "#ff2951ff")[1]),
+ if (is.null(selector_list()$categorical_var) || length(selector_list()$categorical_var()$select) == 0) {
|
| 1163 | +342 | ! |
- labels = c("Present", "Missing (at least one)")
+ selector_list()[names(selector_list()) != "categorical_var"] |
| 1164 | +343 |
- ) +- |
- |
| 1165 | -! | -
- labs ++ } else {
|
|
| 1166 | +344 | ! |
- ggthemes ++ selector_list() |
| 1167 | -! | +||
| 345 | +
- themes+ } |
||
| 1168 | -! | +||
| 346 | +
- print(g)+ }) |
||
| 1169 | +347 |
- },+ |
|
| 1170 | +348 | ! |
- env = list(+ anl_merged_input <- teal.transform::merge_expression_srv( |
| 1171 | +349 | ! |
- labs = parsed_ggplot2_args$labs,+ selector_list = reactive_select_input, |
| 1172 | +350 | ! |
- themes = parsed_ggplot2_args$theme,+ datasets = data, |
| 1173 | +351 | ! |
- ggthemes = parsed_ggplot2_args$ggtheme+ merge_function = "dplyr::inner_join" |
| 1174 | +352 |
- )+ ) |
|
| 1175 | +353 |
- )+ |
|
| 1176 | -+ | ||
| 354 | +! |
- )+ anl_merged_q <- reactive({
|
|
| 1177 | -+ | ||
| 355 | +! |
- })+ req(anl_merged_input()) |
|
| 1178 | -+ | ||
| 356 | +! |
-
+ data() %>% |
|
| 1179 | +357 | ! |
- by_subject_plot_r <- reactive(by_subject_plot_q()[["g"]])+ teal.code::eval_code(as.expression(anl_merged_input()$expr)) |
| 1180 | +358 | ++ |
+ })+ |
+
| 359 | |||
| 1181 | +360 | ! |
- output$levels_table <- DT::renderDataTable(+ merged <- list( |
| 1182 | +361 | ! |
- expr = {
+ anl_input_r = anl_merged_input, |
| 1183 | +362 | ! |
- if (length(input$variables_select) == 0) {
+ anl_q_r = anl_merged_q |
| 1184 | +363 |
- # so that zeroRecords message gets printed+ ) |
|
| 1185 | +364 |
- # using tibble as it supports weird column names, such as " "+ |
|
| 1186 | +365 | ! |
- tibble::tibble(` ` = logical(0))+ n_outlier_missing <- reactive({
|
| 1187 | -+ | ||
| 366 | +! |
- } else {
+ shiny::req(iv_r()$is_valid()) |
|
| 1188 | +367 | ! |
- summary_table_r()+ outlier_var <- as.vector(merged$anl_input_r()$columns_source$outlier_var) |
| 1189 | -+ | ||
| 368 | +! |
- }+ ANL <- merged$anl_q_r()[["ANL"]] # nolint: object_name.+ |
+ |
| 369 | +! | +
+ sum(is.na(ANL[[outlier_var]])) |
|
| 1190 | +370 |
- },+ }) |
|
| 1191 | -! | +||
| 371 | +
- options = list(language = list(zeroRecords = "No variable selected"), pageLength = input$levels_table_rows)+ |
||
| 1192 | +372 |
- )+ # Used to create outlier table and the dropdown with additional columns+ |
+ |
| 373 | +! | +
+ dataname_first <- isolate(teal.data::datanames(data())[[1]]) |
|
| 1193 | +374 | ||
| 1194 | +375 | ! |
- pws1 <- teal.widgets::plot_with_settings_srv(+ common_code_q <- reactive({
|
| 1195 | +376 | ! |
- id = "summary_plot",+ shiny::req(iv_r()$is_valid()) |
| 1196 | -! | +||
| 377 | +
- plot_r = summary_plot_r,+ |
||
| 1197 | +378 | ! |
- height = plot_height,+ ANL <- merged$anl_q_r()[["ANL"]] # nolint: object_name. |
| 1198 | +379 | ! |
- width = plot_width+ qenv <- merged$anl_q_r() |
| 1199 | +380 |
- )+ |
|
| 1200 | -+ | ||
| 381 | +! |
-
+ outlier_var <- as.vector(merged$anl_input_r()$columns_source$outlier_var) |
|
| 1201 | +382 | ! |
- pws2 <- teal.widgets::plot_with_settings_srv(+ categorical_var <- as.vector(merged$anl_input_r()$columns_source$categorical_var) |
| 1202 | +383 | ! |
- id = "combination_plot",+ order_by_outlier <- input$order_by_outlier |
| 1203 | +384 | ! |
- plot_r = combination_plot_r,+ method <- input$method |
| 1204 | +385 | ! |
- height = plot_height,+ split_outliers <- input$split_outliers |
| 1205 | +386 | ! |
- width = plot_width+ teal::validate_has_data( |
| 1206 | +387 |
- )+ # missing values in the categorical variable may be used to form a category of its own |
|
| 1207 | -+ | ||
| 388 | +! |
-
+ `if`( |
|
| 1208 | +389 | ! |
- pws3 <- teal.widgets::plot_with_settings_srv(+ length(categorical_var) == 0, |
| 1209 | +390 | ! |
- id = "by_subject_plot",+ ANL, |
| 1210 | +391 | ! |
- plot_r = by_subject_plot_r,+ ANL[, names(ANL) != categorical_var, drop = FALSE]+ |
+
| 392 | ++ |
+ ), |
|
| 1211 | +393 | ! |
- height = plot_height,+ min_nrow = 10, |
| 1212 | +394 | ! |
- width = plot_width+ complete = TRUE, |
| 1213 | -+ | ||
| 395 | +! |
- )+ allow_inf = FALSE |
|
| 1214 | +396 |
-
+ ) |
|
| 1215 | +397 | ! |
- final_q <- reactive({
+ validate(need(is.numeric(ANL[[outlier_var]]), "`Variable` is not numeric")) |
| 1216 | +398 | ! |
- req(input$summary_type)+ validate(need(length(unique(ANL[[outlier_var]])) > 1, "Variable has no variation, i.e. only one unique value")) |
| 1217 | -! | +||
| 399 | +
- sum_type <- input$summary_type+ + |
+ ||
| 400 | ++ |
+ # show/hide split_outliers |
|
| 1218 | +401 | ! |
- if (sum_type == "Summary") {
+ if (length(categorical_var) == 0) {
|
| 1219 | +402 | ! |
- summary_plot_q()+ shinyjs::hide("split_outliers")
|
| 1220 | +403 | ! |
- } else if (sum_type == "Combinations") {
+ if (n_outlier_missing() > 0) {
|
| 1221 | +404 | ! |
- combination_plot_q()+ qenv <- teal.code::eval_code( |
| 1222 | +405 | ! |
- } else if (sum_type == "By Variable Levels") {
+ qenv, |
| 1223 | +406 | ! |
- summary_table_q()+ substitute( |
| 1224 | +407 | ! |
- } else if (sum_type == "Grouped by Subject") {
+ expr = ANL <- ANL %>% dplyr::filter(!is.na(outlier_var_name)), # nolint: object_name. |
| 1225 | +408 | ! |
- by_subject_plot_q()+ env = list(outlier_var_name = as.name(outlier_var)) |
| 1226 | +409 |
- }+ ) |
|
| 1227 | +410 |
- })+ ) |
|
| 1228 | +411 |
-
+ }+ |
+ |
| 412 | ++ |
+ } else {
|
|
| 1229 | +413 | ! |
- teal.widgets::verbatim_popup_srv(+ validate(need( |
| 1230 | +414 | ! |
- id = "warning",+ is.factor(ANL[[categorical_var]]) || |
| 1231 | +415 | ! |
- verbatim_content = reactive(teal.code::get_warnings(final_q())),+ is.character(ANL[[categorical_var]]) || |
| 1232 | +416 | ! |
- title = "Warning",+ is.integer(ANL[[categorical_var]]), |
| 1233 | +417 | ! |
- disabled = reactive(is.null(teal.code::get_warnings(final_q())))+ "`Categorical factor` must be `factor`, `character`, or `integer`" |
| 1234 | +418 |
- )+ )) |
|
| 1235 | +419 | ||
| 1236 | +420 | ! |
- teal.widgets::verbatim_popup_srv(+ if (n_outlier_missing() > 0) {
|
| 1237 | +421 | ! |
- id = "rcode",+ qenv <- teal.code::eval_code( |
| 1238 | +422 | ! |
- verbatim_content = reactive(teal.code::get_code(final_q())),+ qenv, |
| 1239 | +423 | ! |
- title = "Show R Code for Missing Data"+ substitute(+ |
+
| 424 | +! | +
+ expr = ANL <- ANL %>% dplyr::filter(!is.na(outlier_var_name)), # nolint: object_name.+ |
+ |
| 425 | +! | +
+ env = list(outlier_var_name = as.name(outlier_var)) |
|
| 1240 | +426 |
- )+ ) |
|
| 1241 | +427 |
-
+ ) |
|
| 1242 | +428 |
- ### REPORTER+ } |
|
| 1243 | +429 | ! |
- if (with_reporter) {
+ shinyjs::show("split_outliers")
|
| 1244 | -! | +||
| 430 | +
- card_fun <- function(comment, label) {
+ }+ |
+ ||
| 431 | ++ | + + | +|
| 432 | ++ |
+ # slider |
|
| 1245 | +433 | ! |
- card <- teal::TealReportCard$new()+ outlier_definition_param <- if (method == "IQR") {
|
| 1246 | +434 | ! |
- sum_type <- input$summary_type+ input$iqr_slider |
| 1247 | +435 | ! |
- title <- if (sum_type == "By Variable Levels") paste0(sum_type, " Table") else paste0(sum_type, " Plot")+ } else if (method == "Z-score") {
|
| 1248 | +436 | ! |
- title_dataname <- paste(title, dataname, sep = " - ")+ input$zscore_slider |
| 1249 | +437 | ! |
- label <- if (label == "") {
+ } else if (method == "Percentile") {
|
| 1250 | +438 | ! |
- paste("Missing Data", sum_type, dataname, sep = " - ")
+ input$percentile_slider |
| 1251 | +439 |
- } else {
+ } |
|
| 1252 | -! | +||
| 440 | +
- label+ |
||
| 1253 | +441 |
- }+ # this is utils function that converts a %>% NULL %>% b into a %>% b |
|
| 1254 | +442 | ! |
- card$set_name(label)+ remove_pipe_null <- function(x) {
|
| 1255 | +443 | ! |
- card$append_text(title_dataname, "header2")+ if (length(x) == 1) {
|
| 1256 | +444 | ! |
- if (with_filter) card$append_fs(filter_panel_api$get_filter_state())+ return(x) |
| 1257 | -! | +||
| 445 | +
- if (sum_type == "Summary") {
+ } |
||
| 1258 | +446 | ! |
- card$append_text("Plot", "header3")
+ if (identical(x[[1]], as.name("%>%")) && is.null(x[[3]])) {
|
| 1259 | +447 | ! |
- card$append_plot(summary_plot_r(), dim = pws1$dim())+ return(remove_pipe_null(x[[2]])) |
| 1260 | -! | +||
| 448 | +
- } else if (sum_type == "Combinations") {
+ } |
||
| 1261 | +449 | ! |
- card$append_text("Plot", "header3")
+ return(as.call(c(x[[1]], lapply(x[-1], remove_pipe_null)))) |
| 1262 | -! | +||
| 450 | +
- card$append_plot(combination_plot_r(), dim = pws2$dim())+ }+ |
+ ||
| 451 | ++ | + | |
| 1263 | +452 | ! |
- } else if (sum_type == "By Variable Levels") {
+ qenv <- teal.code::eval_code( |
| 1264 | +453 | ! |
- card$append_text("Table", "header3")
+ qenv, |
| 1265 | +454 | ! |
- card$append_table(summary_table_r[["summary_data"]])+ substitute( |
| 1266 | +455 | ! |
- } else if (sum_type == "Grouped by Subject") {
+ expr = {
|
| 1267 | +456 | ! |
- card$append_text("Plot", "header3")
+ ANL_OUTLIER <- ANL %>% # nolint: object_name. |
| 1268 | +457 | ! |
- card$append_plot(by_subject_plot_r(), dim = pws3$dim())+ group_expr %>% # styler: off |
| 1269 | -+ | ||
| 458 | +! |
- }+ dplyr::mutate(is_outlier = {
|
|
| 1270 | +459 | ! |
- if (!comment == "") {
+ q1_q3 <- stats::quantile(outlier_var_name, probs = c(0.25, 0.75)) |
| 1271 | +460 | ! |
- card$append_text("Comment", "header3")
+ iqr <- q1_q3[2] - q1_q3[1] |
| 1272 | +461 | ! |
- card$append_text(comment)+ !(outlier_var_name >= q1_q3[1] - 1.5 * iqr & outlier_var_name <= q1_q3[2] + 1.5 * iqr) |
| 1273 | +462 |
- }+ }) %>% |
|
| 1274 | +463 | ! |
- card$append_src(teal.code::get_code(final_q()))+ calculate_outliers %>% # styler: off |
| 1275 | +464 | ! |
- card+ ungroup_expr %>% # styler: off |
| 1276 | -+ | ||
| 465 | +! |
- }+ dplyr::filter(is_outlier | is_outlier_selected) %>% |
|
| 1277 | +466 | ! |
- teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
+ dplyr::select(-is_outlier) |
| 1278 | +467 |
- }+ }, |
|
| 1279 | -- |
- ###- |
- |
| 1280 | -- |
- })- |
- |
| 1281 | -- |
- }- |
-
| 1 | -+ | ||
| 468 | +! |
- #' File Viewer Teal Module+ env = list( |
|
| 2 | -+ | ||
| 469 | +! |
- #'+ calculate_outliers = if (method == "IQR") {
|
|
| 3 | -+ | ||
| 470 | +! |
- #' The file viewer module provides a tool to view static files.+ substitute( |
|
| 4 | -+ | ||
| 471 | +! |
- #' Supported formats include text formats, \code{PDF}, \code{PNG}, \code{APNG},
+ expr = dplyr::mutate(is_outlier_selected = {
|
|
| 5 | -+ | ||
| 472 | +! |
- #' \code{JPEG}, \code{SVG}, \code{WEBP}, \code{GIF} and \code{BMP}.
+ q1_q3 <- stats::quantile(outlier_var_name, probs = c(0.25, 0.75)) |
|
| 6 | -+ | ||
| 473 | +! |
- #'+ iqr <- q1_q3[2] - q1_q3[1] |
|
| 7 | -+ | ||
| 474 | +! |
- #' @inheritParams teal::module+ !(outlier_var_name >= q1_q3[1] - outlier_definition_param * iqr & |
|
| 8 | -+ | ||
| 475 | +! |
- #' @inheritParams shared_params+ outlier_var_name <= q1_q3[2] + outlier_definition_param * iqr) |
|
| 9 | +476 |
- #' @param input_path optional, (`list`) of the input paths to either: specific files of accepted formats,+ }), |
|
| 10 | -+ | ||
| 477 | +! |
- #' a directory or a URL. The paths can be specified as absolute paths or relative to the running+ env = list( |
|
| 11 | -+ | ||
| 478 | +! |
- #' directory of the application. Will default to current working directory if not supplied.+ outlier_var_name = as.name(outlier_var), |
|
| 12 | -+ | ||
| 479 | +! |
- #'+ outlier_definition_param = outlier_definition_param |
|
| 13 | +480 |
- #' @export+ ) |
|
| 14 | +481 |
- #'+ ) |
|
| 15 | -+ | ||
| 482 | +! |
- #' @examples+ } else if (method == "Z-score") {
|
|
| 16 | -+ | ||
| 483 | +! |
- #' data <- teal_data()+ substitute( |
|
| 17 | -+ | ||
| 484 | +! |
- #' data <- within(data, {
+ expr = dplyr::mutate( |
|
| 18 | -+ | ||
| 485 | +! |
- #' data <- data.frame(1)+ is_outlier_selected = abs(outlier_var_name - mean(outlier_var_name)) / |
|
| 19 | -+ | ||
| 486 | +! |
- #' })+ stats::sd(outlier_var_name) > outlier_definition_param |
|
| 20 | +487 |
- #' datanames(data) <- c("data")
+ ), |
|
| 21 | -+ | ||
| 488 | +! |
- #'+ env = list( |
|
| 22 | -+ | ||
| 489 | +! |
- #' app <- teal::init(+ outlier_var_name = as.name(outlier_var), |
|
| 23 | -+ | ||
| 490 | +! |
- #' data = data,+ outlier_definition_param = outlier_definition_param |
|
| 24 | +491 |
- #' modules = teal::modules(+ ) |
|
| 25 | +492 |
- #' teal.modules.general::tm_file_viewer(+ ) |
|
| 26 | -+ | ||
| 493 | +! |
- #' input_path = list(+ } else if (method == "Percentile") {
|
|
| 27 | -+ | ||
| 494 | +! |
- #' folder = system.file("sample_files", package = "teal.modules.general"),
+ substitute( |
|
| 28 | -+ | ||
| 495 | +! |
- #' png = system.file("sample_files/sample_file.png", package = "teal.modules.general"),
+ expr = dplyr::mutate( |
|
| 29 | -+ | ||
| 496 | +! |
- #' txt = system.file("sample_files/sample_file.txt", package = "teal.modules.general"),
+ is_outlier_selected = outlier_var_name < stats::quantile(outlier_var_name, outlier_definition_param) | |
|
| 30 | -+ | ||
| 497 | +! |
- #' url =+ outlier_var_name > stats::quantile(outlier_var_name, 1 - outlier_definition_param) |
|
| 31 | +498 |
- #' "https://www.fda.gov/files/drugs/published/Portable-Document-Format-Specifications.pdf"+ ), |
|
| 32 | -+ | ||
| 499 | +! |
- #' )+ env = list( |
|
| 33 | -+ | ||
| 500 | +! |
- #' )+ outlier_var_name = as.name(outlier_var), |
|
| 34 | -+ | ||
| 501 | +! |
- #' )+ outlier_definition_param = outlier_definition_param |
|
| 35 | +502 |
- #' )+ ) |
|
| 36 | +503 |
- #' if (interactive()) {
+ ) |
|
| 37 | +504 |
- #' shinyApp(app$ui, app$server)+ }, |
|
| 38 | -+ | ||
| 505 | +! |
- #' }+ outlier_var_name = as.name(outlier_var), |
|
| 39 | -+ | ||
| 506 | +! |
- #'+ group_expr = if (isTRUE(split_outliers) && length(categorical_var) != 0) {
|
|
| 40 | -+ | ||
| 507 | +! |
- tm_file_viewer <- function(label = "File Viewer Module",+ substitute(dplyr::group_by(x), list(x = as.name(categorical_var))) |
|
| 41 | +508 |
- input_path = list("Current Working Directory" = ".")) {
+ }, |
|
| 42 | +509 | ! |
- logger::log_info("Initializing tm_file_viewer")
+ ungroup_expr = if (isTRUE(split_outliers) && length(categorical_var) != 0) {
|
| 43 | +510 | ! |
- if (length(label) == 0 || identical(label, "")) {
+ substitute(dplyr::ungroup()) |
| 44 | -! | +||
| 511 | +
- label <- " "+ } |
||
| 45 | +512 |
- }+ ) |
|
| 46 | -! | +||
| 513 | +
- if (length(input_path) == 0 || identical(input_path, "")) {
+ ) %>% |
||
| 47 | +514 | ! |
- input_path <- list()+ remove_pipe_null() |
| 48 | +515 |
- }+ ) |
|
| 49 | +516 | ||
| 50 | -! | +||
| 517 | +
- checkmate::assert_string(label)+ # ANL_OUTLIER_EXTENDED is the base table |
||
| 51 | +518 | ! |
- checkmate::assert(+ qenv <- teal.code::eval_code( |
| 52 | +519 | ! |
- checkmate::check_list(input_path, types = "character", min.len = 0),+ qenv, |
| 53 | +520 | ! |
- checkmate::check_character(input_path, min.len = 1)- |
-
| 54 | -- |
- )- |
- |
| 55 | -- |
-
+ substitute( |
|
| 56 | +521 | ! |
- if (length(input_path) > 0) {
+ expr = {
|
| 57 | +522 | ! |
- valid_url <- function(url_input, timeout = 2) {
+ ANL_OUTLIER_EXTENDED <- dplyr::left_join( # nolint: object_name. |
| 58 | +523 | ! |
- con <- try(url(url_input), silent = TRUE)+ ANL_OUTLIER, |
| 59 | +524 | ! |
- check <- suppressWarnings(try(open.connection(con, open = "rt", timeout = timeout), silent = TRUE)[1])+ dplyr::select( |
| 60 | +525 | ! |
- try(close.connection(con), silent = TRUE)+ dataname, |
| 61 | +526 | ! |
- ifelse(is.null(check), TRUE, FALSE)+ dplyr::setdiff(names(dataname), dplyr::setdiff(names(ANL_OUTLIER), join_keys)) |
| 62 | +527 |
- }+ ), |
|
| 63 | +528 | ! |
- idx <- vapply(input_path, function(x) file.exists(x) || valid_url(x), logical(1))+ by = join_keys |
| 64 | +529 |
-
+ ) |
|
| 65 | -! | +||
| 530 | +
- if (!all(idx)) {
+ }, |
||
| 66 | +531 | ! |
- warning(+ env = list( |
| 67 | +532 | ! |
- paste0(+ dataname = as.name(dataname_first), |
| 68 | +533 | ! |
- "Non-existent file or url path. Please provide valid paths for:\n",+ join_keys = as.character(teal.data::join_keys(data())[dataname_first, dataname_first]) |
| 69 | -! | +||
| 534 | +
- paste0(input_path[!idx], collapse = "\n")+ ) |
||
| 70 | +535 |
) |
|
| 71 | +536 |
) |
|
| 72 | +537 |
- }+ |
|
| 73 | +538 | ! |
- input_path <- input_path[idx]+ if (length(categorical_var) > 0) {
|
| 74 | -+ | ||
| 539 | +! |
- } else {
+ qenv <- teal.code::eval_code( |
|
| 75 | +540 | ! |
- warning(+ qenv, |
| 76 | +541 | ! |
- "No file or url paths were provided."+ substitute( |
| 77 | -+ | ||
| 542 | +! |
- )+ expr = summary_table_pre <- ANL_OUTLIER %>% |
|
| 78 | -+ | ||
| 543 | +! |
- }+ dplyr::filter(is_outlier_selected) %>% |
|
| 79 | -+ | ||
| 544 | +! |
-
+ dplyr::select(outlier_var_name, categorical_var_name) %>% |
|
| 80 | -+ | ||
| 545 | +! |
-
+ dplyr::group_by(categorical_var_name) %>% |
|
| 81 | +546 | ! |
- args <- as.list(environment())+ dplyr::summarise(n_outliers = dplyr::n()) %>% |
| 82 | -+ | ||
| 547 | +! |
-
+ dplyr::right_join( |
|
| 83 | +548 | ! |
- module(+ ANL %>% |
| 84 | +549 | ! |
- label = label,+ dplyr::select(outlier_var_name, categorical_var_name) %>% |
| 85 | +550 | ! |
- server = srv_viewer,+ dplyr::group_by(categorical_var_name) %>% |
| 86 | +551 | ! |
- server_args = list(input_path = input_path),+ dplyr::summarise( |
| 87 | +552 | ! |
- ui = ui_viewer,+ total_in_cat = dplyr::n(), |
| 88 | +553 | ! |
- ui_args = args,+ n_na = sum(is.na(outlier_var_name) | is.na(categorical_var_name))+ |
+
| 554 | ++ |
+ ), |
|
| 89 | +555 | ! |
- datanames = NULL+ by = categorical_var |
| 90 | +556 |
- )+ ) %>% |
|
| 91 | +557 |
- }+ # This is important as there may be categorical variables with natural orderings, e.g. AGE. |
|
| 92 | +558 |
-
+ # The plots should be displayed by default in increasing order in these situations. |
|
| 93 | +559 |
- ui_viewer <- function(id, ...) {
+ # dplyr::arrange will sort integer, factor, and character data types in the expected way. |
|
| 94 | +560 | ! |
- args <- list(...)+ dplyr::arrange(categorical_var_name) %>% |
| 95 | +561 | ! |
- ns <- NS(id)- |
-
| 96 | -- |
-
+ dplyr::mutate( |
|
| 97 | +562 | ! |
- shiny::tagList(+ n_outliers = dplyr::if_else(is.na(n_outliers), 0, as.numeric(n_outliers)), |
| 98 | +563 | ! |
- include_css_files("custom"),
+ display_str = dplyr::if_else( |
| 99 | +564 | ! |
- teal.widgets::standard_layout(+ n_outliers > 0, |
| 100 | +565 | ! |
- output = div(+ sprintf("%d [%.02f%%]", n_outliers, 100 * n_outliers / total_in_cat),
|
| 101 | +566 | ! |
- uiOutput(ns("output"))
+ "0" |
| 102 | +567 |
- ),+ ), |
|
| 103 | +568 | ! |
- encoding = div(+ display_str_na = dplyr::if_else( |
| 104 | +569 | ! |
- class = "file_viewer_encoding",+ n_na > 0, |
| 105 | +570 | ! |
- tags$label("Encodings", class = "text-primary"),
+ sprintf("%d [%.02f%%]", n_na, 100 * n_na / total_in_cat),
|
| 106 | +571 | ! |
- shinyTree::shinyTree(+ "0" |
| 107 | -! | +||
| 572 | +
- ns("tree"),
+ ), |
||
| 108 | +573 | ! |
- dragAndDrop = FALSE,+ order = seq_along(n_outliers)+ |
+
| 574 | ++ |
+ ), |
|
| 109 | +575 | ! |
- sort = FALSE,+ env = list( |
| 110 | +576 | ! |
- wholerow = TRUE,+ categorical_var = categorical_var, |
| 111 | +577 | ! |
- theme = "proton",+ categorical_var_name = as.name(categorical_var), |
| 112 | +578 | ! |
- multiple = FALSE+ outlier_var_name = as.name(outlier_var) |
| 113 | +579 |
- )+ ) |
|
| 114 | +580 |
- )+ ) |
|
| 115 | +581 |
- )+ ) |
|
| 116 | +582 |
- )+ # now to handle when user chooses to order based on amount of outliers |
|
| 117 | -+ | ||
| 583 | +! |
- }+ if (order_by_outlier) {
|
|
| 118 | -+ | ||
| 584 | +! |
-
+ qenv <- teal.code::eval_code( |
|
| 119 | -+ | ||
| 585 | +! |
- srv_viewer <- function(id, input_path) {
+ qenv, |
|
| 120 | +586 | ! |
- moduleServer(id, function(input, output, session) {
+ quote( |
| 121 | +587 | ! |
- temp_dir <- tempfile()+ summary_table_pre <- summary_table_pre %>% |
| 122 | +588 | ! |
- if (!dir.exists(temp_dir)) {
+ dplyr::arrange(desc(n_outliers / total_in_cat)) %>% |
| 123 | +589 | ! |
- dir.create(temp_dir, recursive = TRUE)+ dplyr::mutate(order = seq_len(nrow(summary_table_pre))) |
| 124 | +590 |
- }+ ) |
|
| 125 | -! | +||
| 591 | +
- addResourcePath(basename(temp_dir), temp_dir)+ ) |
||
| 126 | +592 |
-
+ } |
|
| 127 | -! | +||
| 593 | +
- test_path_text <- function(selected_path, type) {
+
|
||
| 128 | +594 | ! |
- out <- tryCatch(+ qenv <- teal.code::eval_code( |
| 129 | +595 | ! |
- expr = {
+ qenv, |
| 130 | +596 | ! |
- if (type != "url") {
+ substitute( |
| 131 | +597 | ! |
- selected_path <- normalizePath(selected_path, winslash = "/")+ expr = {
|
| 132 | +598 |
- }+ # In order for geom_rug to work properly when reordering takes place inside facet_grid, |
|
| 133 | -! | +||
| 599 | +
- readLines(con = selected_path)+ # all tables must have the column used for reording. |
||
| 134 | +600 |
- },+ # In this case, the column used for reordering is `order`. |
|
| 135 | +601 | ! |
- error = function(cond) FALSE,+ ANL_OUTLIER <- dplyr::left_join( # nolint: object_name. |
| 136 | +602 | ! |
- warning = function(cond) {
+ ANL_OUTLIER, |
| 137 | +603 | ! |
- `if`(grepl("^incomplete final line found on", cond[[1]]), suppressWarnings(eval(cond[[2]])), FALSE)
- |
-
| 138 | -- |
- }+ summary_table_pre[, c("order", categorical_var)],
|
|
| 139 | -+ | ||
| 604 | +! |
- )+ by = categorical_var |
|
| 140 | +605 |
- }+ ) |
|
| 141 | +606 |
-
+ # so that x axis of plot aligns with columns of summary table, from most outliers to least by percentage |
|
| 142 | +607 | ! |
- handle_connection_type <- function(selected_path) {
+ ANL <- ANL %>% # nolint: object_name. |
| 143 | +608 | ! |
- file_extension <- tools::file_ext(selected_path)+ dplyr::left_join( |
| 144 | +609 | ! |
- file_class <- suppressWarnings(file(selected_path))+ dplyr::select(summary_table_pre, categorical_var_name, order), |
| 145 | +610 | ! |
- close(file_class)+ by = categorical_var |
| 146 | +611 |
-
+ ) %>% |
|
| 147 | +612 | ! |
- output_text <- test_path_text(selected_path, type = class(file_class)[1])+ dplyr::arrange(order) |
| 148 | -+ | ||
| 613 | +! |
-
+ summary_table <- summary_table_pre %>% |
|
| 149 | +614 | ! |
- if (class(file_class)[1] == "url") {
+ dplyr::select( |
| 150 | +615 | ! |
- list(selected_path = selected_path, output_text = output_text)+ categorical_var_name,+ |
+
| 616 | +! | +
+ Outliers = display_str, Missings = display_str_na, Total = total_in_cat |
|
| 151 | +617 |
- } else {
+ ) %>% |
|
| 152 | +618 | ! |
- file.copy(normalizePath(selected_path, winslash = "/"), temp_dir)+ dplyr::mutate_all(as.character) %>% |
| 153 | +619 | ! |
- selected_path <- file.path(basename(temp_dir), basename(selected_path))+ tidyr::pivot_longer(-categorical_var_name) %>% |
| 154 | +620 | ! |
- list(selected_path = selected_path, output_text = output_text)+ tidyr::pivot_wider(names_from = categorical_var, values_from = value) %>% |
| 155 | -+ | ||
| 621 | +! |
- }+ tibble::column_to_rownames("name")
|
|
| 156 | -+ | ||
| 622 | +! |
- }+ summary_table |
|
| 157 | +623 |
-
+ }, |
|
| 158 | +624 | ! |
- display_file <- function(selected_path) {
+ env = list( |
| 159 | +625 | ! |
- con_type <- handle_connection_type(selected_path)+ categorical_var = categorical_var, |
| 160 | +626 | ! |
- file_extension <- tools::file_ext(selected_path)+ categorical_var_name = as.name(categorical_var) |
| 161 | -! | +||
| 627 | +
- if (file_extension %in% c("png", "apng", "jpg", "jpeg", "svg", "gif", "webp", "bmp")) {
+ ) |
||
| 162 | -! | +||
| 628 | +
- tags$img(src = con_type$selected_path, alt = "file does not exist")+ ) |
||
| 163 | -! | +||
| 629 | +
- } else if (file_extension == "pdf") {
+ ) |
||
| 164 | -! | +||
| 630 | +
- tags$embed(+ }+ |
+ ||
| 631 | ++ | + | |
| 165 | +632 | ! |
- class = "embed_pdf",+ if (length(categorical_var) > 0 && nrow(qenv[["ANL_OUTLIER"]]) > 0) {
|
| 166 | +633 | ! |
- src = con_type$selected_path+ shinyjs::show("order_by_outlier")
|
| 167 | +634 |
- )+ } else {
|
|
| 168 | +635 | ! |
- } else if (!isFALSE(con_type$output_text[1])) {
+ shinyjs::hide("order_by_outlier")
|
| 169 | -! | +||
| 636 | +
- tags$pre(paste0(con_type$output_text, collapse = "\n"))+ } |
||
| 170 | +637 |
- } else {
+
|
|
| 171 | +638 | ! |
- tags$p("Please select a supported format.")
- |
-
| 172 | -- |
- }+ qenv |
|
| 173 | +639 |
- }+ }) |
|
| 174 | +640 | ||
| 175 | +641 | ! |
- tree_list <- function(file_or_dir) {
+ output$summary_table <- DT::renderDataTable( |
| 176 | +642 | ! |
- nested_list <- lapply(file_or_dir, function(path) {
+ expr = {
|
| 177 | +643 | ! |
- file_class <- suppressWarnings(file(path))+ if (iv_r()$is_valid()) {
|
| 178 | +644 | ! |
- close(file_class)+ categorical_var <- as.vector(merged$anl_input_r()$columns_source$categorical_var) |
| 179 | +645 | ! |
- if (class(file_class)[[1]] != "url") {
+ if (!is.null(categorical_var)) {
|
| 180 | +646 | ! |
- isdir <- file.info(path)$isdir+ DT::datatable( |
| 181 | +647 | ! |
- if (!isdir) {
+ common_code_q()[["summary_table"]], |
| 182 | +648 | ! |
- structure(path, ancestry = path, sticon = "file")- |
-
| 183 | -- |
- } else {
+ options = list( |
|
| 184 | +649 | ! |
- files <- list.files(path, full.names = TRUE, include.dirs = TRUE)+ dom = "t", |
| 185 | +650 | ! |
- out <- lapply(files, function(x) tree_list(x))+ autoWidth = TRUE, |
| 186 | +651 | ! |
- out <- unlist(out, recursive = FALSE)+ columnDefs = list(list(width = "200px", targets = "_all")) |
| 187 | -! | +||
| 652 | +
- if (length(files) > 0) names(out) <- basename(files)+ ) |
||
| 188 | -! | +||
| 653 | +
- out+ ) |
||
| 189 | +654 |
} |
|
| 190 | +655 |
- } else {
+ } |
|
| 191 | -! | +||
| 656 | +
- structure(path, ancestry = path, sticon = "file")+ } |
||
| 192 | +657 |
- }+ ) |
|
| 193 | +658 |
- })+ |
|
| 194 | +659 |
-
+ # boxplot/violinplot # nolint commented_code |
|
| 195 | +660 | ! |
- missing_labels <- if (is.null(names(nested_list))) seq_along(nested_list) else which(names(nested_list) == "")+ boxplot_q <- reactive({
|
| 196 | +661 | ! |
- names(nested_list)[missing_labels] <- file_or_dir[missing_labels]+ req(common_code_q()) |
| 197 | +662 | ! |
- nested_list+ ANL <- common_code_q()[["ANL"]] # nolint: object_name. |
| 198 | -+ | ||
| 663 | +! |
- }+ ANL_OUTLIER <- common_code_q()[["ANL_OUTLIER"]] # nolint: object_name. |
|
| 199 | +664 | ||
| 200 | +665 | ! |
- output$tree <- shinyTree::renderTree({
+ outlier_var <- as.vector(merged$anl_input_r()$columns_source$outlier_var) |
| 201 | +666 | ! |
- if (length(input_path) > 0) {
+ categorical_var <- as.vector(merged$anl_input_r()$columns_source$categorical_var) |
| 202 | -! | +||
| 667 | +
- tree_list(input_path)+ |
||
| 203 | +668 |
- } else {
+ # validation |
|
| 204 | +669 | ! |
- list("Empty Path" = NULL)
+ teal::validate_has_data(ANL, 1) |
| 205 | +670 |
- }+ |
|
| 206 | +671 |
- })+ # boxplot+ |
+ |
| 672 | +! | +
+ plot_call <- quote(ANL %>% ggplot()) |
|
| 207 | +673 | ||
| 208 | +674 | ! |
- output$output <- renderUI({
+ plot_call <- if (input$boxplot_alts == "Box plot") {
|
| 209 | +675 | ! |
- validate(+ substitute(expr = plot_call + geom_boxplot(outlier.shape = NA), env = list(plot_call = plot_call)) |
| 210 | +676 | ! |
- need(+ } else if (input$boxplot_alts == "Violin plot") {
|
| 211 | +677 | ! |
- length(shinyTree::get_selected(input$tree)) > 0,+ substitute(expr = plot_call + geom_violin(), env = list(plot_call = plot_call))+ |
+
| 678 | ++ |
+ } else {
|
|
| 212 | +679 | ! |
- "Please select a file."+ NULL |
| 213 | +680 |
- )+ } |
|
| 214 | +681 |
- )+ |
|
| 215 | -+ | ||
| 682 | +! |
-
+ plot_call <- if (identical(categorical_var, character(0)) || is.null(categorical_var)) {
|
|
| 216 | +683 | ! |
- obj <- shinyTree::get_selected(input$tree, format = "names")[[1]]+ inner_call <- substitute( |
| 217 | +684 | ! |
- repo <- attr(obj, "ancestry")+ expr = plot_call + |
| 218 | +685 | ! |
- repo_collapsed <- if (length(repo) > 1) paste0(repo, collapse = "/") else repo+ aes(x = "Entire dataset", y = outlier_var_name) + |
| 219 | +686 | ! |
- is_not_named <- file.exists(file.path(c(repo_collapsed, obj[1])))[1]+ scale_x_discrete(),+ |
+
| 687 | +! | +
+ env = list(plot_call = plot_call, outlier_var_name = as.name(outlier_var)) |
|
| 220 | +688 |
-
+ ) |
|
| 221 | +689 | ! |
- if (is_not_named) {
+ if (nrow(ANL_OUTLIER) > 0) {
|
| 222 | +690 | ! |
- selected_path <- do.call("file.path", as.list(c(repo, obj[1])))
+ substitute( |
| 223 | -+ | ||
| 691 | +! |
- } else {
+ expr = inner_call + geom_point( |
|
| 224 | +692 | ! |
- if (length(repo) == 0) {
+ data = ANL_OUTLIER, |
| 225 | +693 | ! |
- selected_path <- do.call("file.path", as.list(attr(input$tree[[obj[1]]], "ancestry")))
+ aes(x = "Entire dataset", y = outlier_var_name, color = is_outlier_selected) |
| 226 | +694 |
- } else {
+ ), |
|
| 227 | +695 | ! |
- selected_path <- do.call("file.path", as.list(attr(input$tree[[repo]][[obj[1]]], "ancestry")))
+ env = list(inner_call = inner_call, outlier_var_name = as.name(outlier_var)) |
| 228 | +696 |
- }+ ) |
|
| 229 | +697 |
- }+ } else {
+ |
+ |
| 698 | +! | +
+ inner_call |
|
| 230 | +699 |
-
+ }+ |
+ |
| 700 | ++ |
+ } else {
|
|
| 231 | +701 | ! |
- validate(+ substitute( |
| 232 | +702 | ! |
- need(+ expr = plot_call + |
| 233 | +703 | ! |
- !isTRUE(file.info(selected_path)$isdir) && length(selected_path) > 0,+ aes(y = outlier_var_name, x = reorder(categorical_var_name, order)) + |
| 234 | +704 | ! |
- "Please select a single file."+ xlab(categorical_var) + |
| 235 | -+ | ||
| 705 | +! |
- )+ scale_x_discrete() + |
|
| 236 | -+ | ||
| 706 | +! |
- )+ geom_point( |
|
| 237 | +707 | ! |
- display_file(selected_path)+ data = ANL_OUTLIER, |
| 238 | -+ | ||
| 708 | +! |
- })+ aes(x = as.factor(categorical_var_name), y = outlier_var_name, color = is_outlier_selected) |
|
| 239 | +709 |
-
+ ), |
|
| 240 | +710 | ! |
- onStop(function() {
+ env = list( |
| 241 | +711 | ! |
- removeResourcePath(basename(temp_dir))+ plot_call = plot_call, |
| 242 | +712 | ! |
- unlink(temp_dir)+ outlier_var_name = as.name(outlier_var), |
| 243 | -+ | ||
| 713 | +! |
- })+ categorical_var_name = as.name(categorical_var), |
|
| 244 | -+ | ||
| 714 | +! |
- })+ categorical_var = categorical_var |
|
| 245 | +715 |
- }+ ) |
| 1 | +716 |
- #' Outliers Module+ ) |
|
| 2 | +717 |
- #'+ } |
|
| 3 | +718 |
- #' Module to analyze and identify outliers using different methods+ |
|
| 4 | -+ | ||
| 719 | +! |
- #'+ dev_ggplot2_args <- teal.widgets::ggplot2_args( |
|
| 5 | -+ | ||
| 720 | +! |
- #' @inheritParams teal::module+ labs = list(color = "Is outlier?"), |
|
| 6 | -+ | ||
| 721 | +! |
- #' @inheritParams shared_params+ theme = list(legend.position = "top") |
|
| 7 | +722 |
- #'+ ) |
|
| 8 | +723 |
- #' @param outlier_var (`data_extract_spec` or `list` of multiple `data_extract_spec`)+ |
|
| 9 | -+ | ||
| 724 | +! |
- #' variable to consider for the outliers analysis.+ all_ggplot2_args <- teal.widgets::resolve_ggplot2_args( |
|
| 10 | -+ | ||
| 725 | +! |
- #' @param categorical_var (`data_extract_spec` or `list` of multiple `data_extract_spec`)+ user_plot = ggplot2_args[["Boxplot"]], |
|
| 11 | -+ | ||
| 726 | +! |
- #' categorical factor to split the selected outlier variables on.+ user_default = ggplot2_args$default, |
|
| 12 | -+ | ||
| 727 | +! |
- #'+ module_plot = dev_ggplot2_args |
|
| 13 | +728 |
- #' @templateVar ggnames "Boxplot","Density Plot","Cumulative Distribution Plot"+ ) |
|
| 14 | +729 |
- #' @template ggplot2_args_multi+ |
|
| 15 | -+ | ||
| 730 | +! |
- #'+ parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args( |
|
| 16 | -+ | ||
| 731 | +! |
- #' @examples+ all_ggplot2_args, |
|
| 17 | -+ | ||
| 732 | +! |
- #' # general data example+ ggtheme = input$ggtheme |
|
| 18 | +733 |
- #' library(teal.widgets)+ ) |
|
| 19 | +734 |
- #'+ |
|
| 20 | -+ | ||
| 735 | +! |
- #' data <- teal_data()+ teal.code::eval_code( |
|
| 21 | -+ | ||
| 736 | +! |
- #' data <- within(data, {
+ common_code_q(), |
|
| 22 | -+ | ||
| 737 | +! |
- #' CO2 <- CO2+ substitute( |
|
| 23 | -+ | ||
| 738 | +! |
- #' CO2[["primary_key"]] <- seq_len(nrow(CO2))+ expr = g <- plot_call + |
|
| 24 | -+ | ||
| 739 | +! |
- #' })+ scale_color_manual(values = c("TRUE" = "red", "FALSE" = "black")) +
|
|
| 25 | -+ | ||
| 740 | +! |
- #' datanames(data) <- "CO2"+ labs + ggthemes + themes, |
|
| 26 | -+ | ||
| 741 | +! |
- #' join_keys(data) <- join_keys(join_key("CO2", "CO2", "primary_key"))
+ env = list( |
|
| 27 | -+ | ||
| 742 | +! |
- #'+ plot_call = plot_call, |
|
| 28 | -- |
- #' vars <- choices_selected(variable_choices(data[["CO2"]], c("Plant", "Type", "Treatment")))
+ | |
| 743 | +! | +
+ labs = parsed_ggplot2_args$labs, |
|
| 29 | -+ | ||
| 744 | +! |
- #'+ ggthemes = parsed_ggplot2_args$ggtheme, |
|
| 30 | -+ | ||
| 745 | +! |
- #' app <- init(+ themes = parsed_ggplot2_args$theme |
|
| 31 | +746 |
- #' data = data,+ ) |
|
| 32 | +747 |
- #' modules = modules(+ ) |
|
| 33 | +748 |
- #' tm_outliers(+ ) %>% |
|
| 34 | -+ | ||
| 749 | +! |
- #' outlier_var = list(+ teal.code::eval_code(quote(print(g))) |
|
| 35 | +750 |
- #' data_extract_spec(+ }) |
|
| 36 | +751 |
- #' dataname = "CO2",+ |
|
| 37 | +752 |
- #' select = select_spec(+ # density plot |
|
| 38 | -+ | ||
| 753 | +! |
- #' label = "Select variable:",+ density_plot_q <- reactive({
|
|
| 39 | -+ | ||
| 754 | +! |
- #' choices = variable_choices(data[["CO2"]], c("conc", "uptake")),
+ ANL <- common_code_q()[["ANL"]] # nolint: object_name. |
|
| 40 | -+ | ||
| 755 | +! |
- #' selected = "uptake",+ ANL_OUTLIER <- common_code_q()[["ANL_OUTLIER"]] # nolint: object_name. |
|
| 41 | +756 |
- #' multiple = FALSE,+ |
|
| 42 | -+ | ||
| 757 | +! |
- #' fixed = FALSE+ outlier_var <- as.vector(merged$anl_input_r()$columns_source$outlier_var) |
|
| 43 | -+ | ||
| 758 | +! |
- #' )+ categorical_var <- as.vector(merged$anl_input_r()$columns_source$categorical_var) |
|
| 44 | +759 |
- #' )+ |
|
| 45 | +760 |
- #' ),+ # validation |
|
| 46 | -+ | ||
| 761 | +! |
- #' categorical_var = list(+ teal::validate_has_data(ANL, 1) |
|
| 47 | +762 |
- #' data_extract_spec(+ # plot |
|
| 48 | -+ | ||
| 763 | +! |
- #' dataname = "CO2",+ plot_call <- substitute( |
|
| 49 | -+ | ||
| 764 | +! |
- #' filter = filter_spec(+ expr = ANL %>% |
|
| 50 | -+ | ||
| 765 | +! |
- #' vars = vars,+ ggplot(aes(x = outlier_var_name)) + |
|
| 51 | -+ | ||
| 766 | +! |
- #' choices = value_choices(data[["CO2"]], vars$selected),+ geom_density() + |
|
| 52 | -+ | ||
| 767 | +! |
- #' selected = value_choices(data[["CO2"]], vars$selected),+ geom_rug(data = ANL_OUTLIER, aes(x = outlier_var_name, color = is_outlier_selected)) + |
|
| 53 | -+ | ||
| 768 | +! |
- #' multiple = TRUE+ scale_color_manual(values = c("TRUE" = "red", "FALSE" = "black")),
|
|
| 54 | -+ | ||
| 769 | +! |
- #' )+ env = list(outlier_var_name = as.name(outlier_var)) |
|
| 55 | +770 |
- #' )+ ) |
|
| 56 | +771 |
- #' ),+ |
|
| 57 | -+ | ||
| 772 | +! |
- #' ggplot2_args = list(+ plot_call <- if (identical(categorical_var, character(0)) || is.null(categorical_var)) {
|
|
| 58 | -+ | ||
| 773 | +! |
- #' ggplot2_args(+ substitute(expr = plot_call, env = list(plot_call = plot_call)) |
|
| 59 | +774 |
- #' labs = list(subtitle = "Plot generated by Outliers Module")+ } else {
|
|
| 60 | -+ | ||
| 775 | +! |
- #' )+ substitute( |
|
| 61 | -+ | ||
| 776 | +! |
- #' )+ expr = plot_call + facet_grid(~ reorder(categorical_var_name, order)), |
|
| 62 | -+ | ||
| 777 | +! |
- #' )+ env = list(plot_call = plot_call, categorical_var_name = as.name(categorical_var)) |
|
| 63 | +778 |
- #' )+ ) |
|
| 64 | +779 |
- #' )+ } |
|
| 65 | +780 |
- #' if (interactive()) {
+
|
|
| 66 | -+ | ||
| 781 | +! |
- #' shinyApp(app$ui, app$server)+ dev_ggplot2_args <- teal.widgets::ggplot2_args( |
|
| 67 | -+ | ||
| 782 | +! |
- #' }+ labs = list(color = "Is outlier?"), |
|
| 68 | -+ | ||
| 783 | +! |
- #'+ theme = list(legend.position = "top") |
|
| 69 | +784 |
- #' # CDISC data example+ ) |
|
| 70 | +785 |
- #' library(teal.widgets)+ |
|
| 71 | -+ | ||
| 786 | +! |
- #'+ all_ggplot2_args <- teal.widgets::resolve_ggplot2_args( |
|
| 72 | -+ | ||
| 787 | +! |
- #' data <- teal_data()+ user_plot = ggplot2_args[["Density Plot"]], |
|
| 73 | -+ | ||
| 788 | +! |
- #' data <- within(data, {
+ user_default = ggplot2_args$default, |
|
| 74 | -+ | ||
| 789 | +! |
- #' ADSL <- rADSL+ module_plot = dev_ggplot2_args |
|
| 75 | +790 |
- #' })+ ) |
|
| 76 | +791 |
- #' datanames(data) <- "ADSL"+ |
|
| 77 | -+ | ||
| 792 | +! |
- #' join_keys(data) <- default_cdisc_join_keys[datanames(data)]+ parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args( |
|
| 78 | -+ | ||
| 793 | +! |
- #'+ all_ggplot2_args, |
|
| 79 | -+ | ||
| 794 | +! |
- #' fact_vars_adsl <- names(Filter(isTRUE, sapply(data[["ADSL"]], is.factor)))+ ggtheme = input$ggtheme |
|
| 80 | +795 |
- #' vars <- choices_selected(variable_choices(data[["ADSL"]], fact_vars_adsl))+ ) |
|
| 81 | +796 |
- #'+ |
|
| 82 | -+ | ||
| 797 | +! |
- #' app <- init(+ teal.code::eval_code( |
|
| 83 | -+ | ||
| 798 | +! |
- #' data = data,+ common_code_q(), |
|
| 84 | -+ | ||
| 799 | +! |
- #' modules = modules(+ substitute( |
|
| 85 | -+ | ||
| 800 | +! |
- #' tm_outliers(+ expr = g <- plot_call + labs + ggthemes + themes, |
|
| 86 | -+ | ||
| 801 | +! |
- #' outlier_var = list(+ env = list( |
|
| 87 | -+ | ||
| 802 | +! |
- #' data_extract_spec(+ plot_call = plot_call, |
|
| 88 | -+ | ||
| 803 | +! |
- #' dataname = "ADSL",+ labs = parsed_ggplot2_args$labs, |
|
| 89 | -+ | ||
| 804 | +! |
- #' select = select_spec(+ themes = parsed_ggplot2_args$theme, |
|
| 90 | -+ | ||
| 805 | +! |
- #' label = "Select variable:",+ ggthemes = parsed_ggplot2_args$ggtheme |
|
| 91 | +806 |
- #' choices = variable_choices(data[["ADSL"]], c("AGE", "BMRKR1")),
+ ) |
|
| 92 | +807 |
- #' selected = "AGE",+ ) |
|
| 93 | +808 |
- #' multiple = FALSE,+ ) %>% |
|
| 94 | -+ | ||
| 809 | +! |
- #' fixed = FALSE+ teal.code::eval_code(quote(print(g))) |
|
| 95 | +810 |
- #' )+ }) |
|
| 96 | +811 |
- #' )+ |
|
| 97 | +812 |
- #' ),+ # Cumulative distribution plot |
|
| 98 | -+ | ||
| 813 | +! |
- #' categorical_var = list(+ cumulative_plot_q <- reactive({
|
|
| 99 | -+ | ||
| 814 | +! |
- #' data_extract_spec(+ ANL <- common_code_q()[["ANL"]] # nolint: object_name. |
|
| 100 | -+ | ||
| 815 | +! |
- #' dataname = "ADSL",+ ANL_OUTLIER <- common_code_q()[["ANL_OUTLIER"]] # nolint: object_name. |
|
| 101 | +816 |
- #' filter = filter_spec(+ |
|
| 102 | -+ | ||
| 817 | +! |
- #' vars = vars,+ qenv <- common_code_q() |
|
| 103 | +818 |
- #' choices = value_choices(data[["ADSL"]], vars$selected),+ |
|
| 104 | -+ | ||
| 819 | +! |
- #' selected = value_choices(data[["ADSL"]], vars$selected),+ outlier_var <- as.vector(merged$anl_input_r()$columns_source$outlier_var) |
|
| 105 | -+ | ||
| 820 | +! |
- #' multiple = TRUE+ categorical_var <- as.vector(merged$anl_input_r()$columns_source$categorical_var) |
|
| 106 | +821 |
- #' )+ |
|
| 107 | +822 |
- #' )+ # validation |
|
| 108 | -+ | ||
| 823 | +! |
- #' ),+ teal::validate_has_data(ANL, 1) |
|
| 109 | +824 |
- #' ggplot2_args = list(+ |
|
| 110 | +825 |
- #' ggplot2_args(+ # plot |
|
| 111 | -+ | ||
| 826 | +! |
- #' labs = list(subtitle = "Plot generated by Outliers Module")+ plot_call <- substitute( |
|
| 112 | -+ | ||
| 827 | +! |
- #' )+ expr = ANL %>% ggplot(aes(x = outlier_var_name)) + |
|
| 113 | -+ | ||
| 828 | +! |
- #' )+ stat_ecdf(), |
|
| 114 | -+ | ||
| 829 | +! |
- #' )+ env = list(outlier_var_name = as.name(outlier_var)) |
|
| 115 | +830 |
- #' )+ ) |
|
| 116 | -+ | ||
| 831 | +! |
- #' )+ if (length(categorical_var) == 0) {
|
|
| 117 | -+ | ||
| 832 | +! |
- #' if (interactive()) {
+ qenv <- teal.code::eval_code( |
|
| 118 | -+ | ||
| 833 | +! |
- #' shinyApp(app$ui, app$server)+ qenv, |
|
| 119 | -+ | ||
| 834 | +! |
- #' }+ substitute( |
|
| 120 | -+ | ||
| 835 | +! |
- #'+ expr = {
|
|
| 121 | -+ | ||
| 836 | +! |
- #' @export+ ecdf_df <- ANL %>% |
|
| 122 | -+ | ||
| 837 | +! |
- #'+ dplyr::mutate( |
|
| 123 | -+ | ||
| 838 | +! |
- tm_outliers <- function(label = "Outliers Module",+ y = stats::ecdf(ANL[[outlier_var]])(ANL[[outlier_var]]) |
|
| 124 | +839 |
- outlier_var,+ ) |
|
| 125 | +840 |
- categorical_var = NULL,+ |
|
| 126 | -+ | ||
| 841 | +! |
- ggtheme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void"),
+ outlier_points <- dplyr::left_join( |
|
| 127 | -+ | ||
| 842 | +! |
- ggplot2_args = teal.widgets::ggplot2_args(),+ ecdf_df, |
|
| 128 | -+ | ||
| 843 | +! |
- plot_height = c(600, 200, 2000),+ ANL_OUTLIER, |
|
| 129 | -+ | ||
| 844 | +! |
- plot_width = NULL,+ by = dplyr::setdiff(names(ecdf_df), "y") |
|
| 130 | +845 |
- pre_output = NULL,+ ) %>%+ |
+ |
| 846 | +! | +
+ dplyr::filter(!is.na(is_outlier_selected)) |
|
| 131 | +847 |
- post_output = NULL) {
+ }, |
|
| 132 | +848 | ! |
- logger::log_info("Initializing tm_outliers")
+ env = list(outlier_var = outlier_var) |
| 133 | -! | +||
| 849 | +
- if (inherits(outlier_var, "data_extract_spec")) outlier_var <- list(outlier_var)+ ) |
||
| 134 | -! | +||
| 850 | +
- if (inherits(categorical_var, "data_extract_spec")) categorical_var <- list(categorical_var)+ )+ |
+ ||
| 851 | ++ |
+ } else {
|
|
| 135 | +852 | ! |
- if (inherits(ggplot2_args, "ggplot2_args")) ggplot2_args <- list(default = ggplot2_args)+ qenv <- teal.code::eval_code( |
| 136 | -+ | ||
| 853 | +! |
-
+ qenv, |
|
| 137 | +854 | ! |
- ggtheme <- match.arg(ggtheme)+ substitute( |
| 138 | +855 | ! |
- checkmate::assert_string(label)+ expr = {
|
| 139 | +856 | ! |
- checkmate::assert_list(outlier_var, types = "data_extract_spec")+ all_categories <- lapply( |
| 140 | +857 | ! |
- checkmate::assert_list(categorical_var, types = "data_extract_spec", null.ok = TRUE)+ unique(ANL[[categorical_var]]), |
| 141 | +858 | ! |
- if (is.list(categorical_var)) {
+ function(x) {
|
| 142 | +859 | ! |
- lapply(categorical_var, function(x) {
+ ANL <- ANL %>% dplyr::filter(get(categorical_var) == x) # nolint: object_name. |
| 143 | +860 | ! |
- if (length(x$filter) > 1L) {
+ anl_outlier2 <- ANL_OUTLIER %>% dplyr::filter(get(categorical_var) == x) |
| 144 | +861 | ! |
- stop("tm_outliers: categorical_var data_extract_specs may only specify one filter_spec", call. = FALSE)
+ ecdf_df <- ANL %>% |
| 145 | -+ | ||
| 862 | +! |
- }+ dplyr::mutate(y = stats::ecdf(ANL[[outlier_var]])(ANL[[outlier_var]])) |
|
| 146 | +863 |
- })+ |
|
| 147 | -+ | ||
| 864 | +! |
- }+ dplyr::left_join( |
|
| 148 | +865 | ! |
- plot_choices <- c("Boxplot", "Density Plot", "Cumulative Distribution Plot")
+ ecdf_df, |
| 149 | +866 | ! |
- checkmate::assert_list(ggplot2_args, types = "ggplot2_args")+ anl_outlier2, |
| 150 | +867 | ! |
- checkmate::assert_subset(names(ggplot2_args), c("default", plot_choices))
+ by = dplyr::setdiff(names(ecdf_df), "y") |
| 151 | +868 |
-
+ ) %>% |
|
| 152 | +869 | ! |
- args <- as.list(environment())+ dplyr::filter(!is.na(is_outlier_selected)) |
| 153 | +870 |
-
+ } |
|
| 154 | -! | +||
| 871 | +
- data_extract_list <- list(+ ) |
||
| 155 | +872 | ! |
- outlier_var = outlier_var,+ outlier_points <- do.call(rbind, all_categories)+ |
+
| 873 | ++ |
+ }, |
|
| 156 | +874 | ! |
- categorical_var = categorical_var+ env = list(categorical_var = categorical_var, outlier_var = outlier_var) |
| 157 | +875 |
- )+ ) |
|
| 158 | +876 | - - | -|
| 159 | -! | -
- module(+ ) |
|
| 160 | +877 | ! |
- label = label,+ plot_call <- substitute( |
| 161 | +878 | ! |
- server = srv_outliers,+ expr = plot_call + facet_grid(~ reorder(categorical_var_name, order)), |
| 162 | +879 | ! |
- server_args = c(+ env = list(plot_call = plot_call, categorical_var_name = as.name(categorical_var)) |
| 163 | -! | +||
| 880 | +
- data_extract_list,+ ) |
||
| 164 | -! | +||
| 881 | +
- list(plot_height = plot_height, plot_width = plot_width, ggplot2_args = ggplot2_args)+ } |
||
| 165 | +882 |
- ),+ |
|
| 166 | +883 | ! |
- ui = ui_outliers,+ dev_ggplot2_args <- teal.widgets::ggplot2_args( |
| 167 | +884 | ! |
- ui_args = args,+ labs = list(color = "Is outlier?"), |
| 168 | +885 | ! |
- datanames = teal.transform::get_extract_datanames(data_extract_list)- |
-
| 169 | -- |
- )+ theme = list(legend.position = "top") |
|
| 170 | +886 |
- }+ ) |
|
| 171 | +887 | ||
| 172 | -+ | ||
| 888 | +! |
- ui_outliers <- function(id, ...) {
+ all_ggplot2_args <- teal.widgets::resolve_ggplot2_args( |
|
| 173 | +889 | ! |
- args <- list(...)+ user_plot = ggplot2_args[["Cumulative Distribution Plot"]], |
| 174 | +890 | ! |
- ns <- NS(id)+ user_default = ggplot2_args$default, |
| 175 | +891 | ! |
- is_single_dataset_value <- teal.transform::is_single_dataset(args$outlier_var, args$categorical_var)+ module_plot = dev_ggplot2_args |
| 176 | +892 | ++ |
+ )+ |
+
| 893 | |||
| 177 | +894 | ! |
- teal.widgets::standard_layout(+ parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args( |
| 178 | +895 | ! |
- output = teal.widgets::white_small_well(+ all_ggplot2_args, |
| 179 | +896 | ! |
- uiOutput(ns("total_outliers")),
+ ggtheme = input$ggtheme |
| 180 | -! | +||
| 897 | +
- DT::dataTableOutput(ns("summary_table")),
+ ) |
||
| 181 | -! | +||
| 898 | +
- uiOutput(ns("total_missing")),
+
|
||
| 182 | +899 | ! |
- br(), hr(),+ teal.code::eval_code( |
| 183 | +900 | ! |
- tabsetPanel(+ qenv, |
| 184 | +901 | ! |
- id = ns("tabs"),
+ substitute( |
| 185 | +902 | ! |
- tabPanel(+ expr = g <- plot_call + |
| 186 | +903 | ! |
- "Boxplot",+ geom_point(data = outlier_points, aes(x = outlier_var_name, y = y, color = is_outlier_selected)) + |
| 187 | +904 | ! |
- teal.widgets::plot_with_settings_ui(id = ns("box_plot"))
+ scale_color_manual(values = c("TRUE" = "red", "FALSE" = "black")) +
|
| 188 | -+ | ||
| 905 | +! |
- ),+ labs + ggthemes + themes, |
|
| 189 | +906 | ! |
- tabPanel(+ env = list( |
| 190 | +907 | ! |
- "Density Plot",+ plot_call = plot_call, |
| 191 | +908 | ! |
- teal.widgets::plot_with_settings_ui(id = ns("density_plot"))
+ outlier_var_name = as.name(outlier_var), |
| 192 | -+ | ||
| 909 | +! |
- ),+ labs = parsed_ggplot2_args$labs, |
|
| 193 | +910 | ! |
- tabPanel(+ themes = parsed_ggplot2_args$theme, |
| 194 | +911 | ! |
- "Cumulative Distribution Plot",+ ggthemes = parsed_ggplot2_args$ggtheme |
| 195 | -! | +||
| 912 | +
- teal.widgets::plot_with_settings_ui(id = ns("cum_density_plot"))
+ ) |
||
| 196 | +913 |
) |
|
| 197 | +914 |
- ),+ ) %>% |
|
| 198 | +915 | ! |
- br(), hr(),+ teal.code::eval_code(quote(print(g))) |
| 199 | -! | +||
| 916 | +
- uiOutput(ns("table_ui_wrap"))
+ }) |
||
| 200 | +917 |
- ),+ |
|
| 201 | +918 | ! |
- encoding = div(+ final_q <- reactive({
|
| 202 | -+ | ||
| 919 | +! |
- ### Reporter+ req(input$tabs) |
|
| 203 | +920 | ! |
- teal.reporter::simple_reporter_ui(ns("simple_reporter")),
+ tab_type <- input$tabs |
| 204 | -+ | ||
| 921 | +! |
- ###+ result_q <- if (tab_type == "Boxplot") {
|
|
| 205 | +922 | ! |
- tags$label("Encodings", class = "text-primary"),
+ boxplot_q() |
| 206 | +923 | ! |
- teal.transform::datanames_input(args[c("outlier_var", "categorical_var")]),
+ } else if (tab_type == "Density Plot") {
|
| 207 | +924 | ! |
- teal.transform::data_extract_ui(+ density_plot_q() |
| 208 | +925 | ! |
- id = ns("outlier_var"),
+ } else if (tab_type == "Cumulative Distribution Plot") {
|
| 209 | +926 | ! |
- label = "Variable",+ cumulative_plot_q() |
| 210 | -! | +||
| 927 | +
- data_extract_spec = args$outlier_var,+ } |
||
| 211 | -! | +||
| 928 | +
- is_single_dataset = is_single_dataset_value+ # used to display table when running show-r-code code |
||
| 212 | +929 |
- ),+ # added after the plots so that a change in selected columns doesn't affect+ |
+ |
| 930 | ++ |
+ # brush selection. |
|
| 213 | +931 | ! |
- if (!is.null(args$categorical_var)) {
+ teal.code::eval_code( |
| 214 | +932 | ! |
- teal.transform::data_extract_ui(+ result_q, |
| 215 | +933 | ! |
- id = ns("categorical_var"),
+ substitute( |
| 216 | +934 | ! |
- label = "Categorical factor",+ expr = {
|
| 217 | +935 | ! |
- data_extract_spec = args$categorical_var,+ columns_index <- union( |
| 218 | +936 | ! |
- is_single_dataset = is_single_dataset_value+ setdiff(names(ANL_OUTLIER), "is_outlier_selected"), |
| 219 | -+ | ||
| 937 | +! |
- )+ table_columns |
|
| 220 | +938 |
- },+ ) |
|
| 221 | +939 | ! |
- conditionalPanel(+ ANL_OUTLIER_EXTENDED[ANL_OUTLIER_EXTENDED$is_outlier_selected, columns_index] |
| 222 | -! | +||
| 940 | +
- condition = paste0("input['", ns("tabs"), "'] == 'Boxplot'"),
+ }, |
||
| 223 | +941 | ! |
- teal.widgets::optionalSelectInput(+ env = list( |
| 224 | +942 | ! |
- inputId = ns("boxplot_alts"),
+ table_columns = input$table_ui_columns |
| 225 | -! | +||
| 943 | +
- label = "Plot type",+ ) |
||
| 226 | -! | +||
| 944 | +
- choices = c("Box plot", "Violin plot"),
+ ) |
||
| 227 | -! | +||
| 945 | +
- selected = "Box plot",+ ) |
||
| 228 | -! | +||
| 946 | +
- multiple = FALSE+ }) |
||
| 229 | +947 |
- )+ |
|
| 230 | +948 |
- ),+ # slider text |
|
| 231 | +949 | ! |
- shinyjs::hidden(checkboxInput(ns("split_outliers"), "Define outliers based on group splitting", value = FALSE)),
+ output$ui_outlier_help <- renderUI({
|
| 232 | +950 | ! |
- shinyjs::hidden(checkboxInput(ns("order_by_outlier"), "Re-order categories by outliers [by %]", value = FALSE)),
+ req(input$method) |
| 233 | +951 | ! |
- teal.widgets::panel_group(+ if (input$method == "IQR") {
|
| 234 | +952 | ! |
- teal.widgets::panel_item(+ req(input$iqr_slider) |
| 235 | +953 | ! |
- title = "Method parameters",+ tags$small( |
| 236 | +954 | ! |
- collapsed = FALSE,+ withMathJax( |
| 237 | +955 | ! |
- teal.widgets::optionalSelectInput(+ helpText( |
| 238 | +956 | ! |
- inputId = ns("method"),
+ "Outlier data points (\\(x \\lt Q1 - ", input$iqr_slider, "\\times IQR\\) or \\( |
| 239 | +957 | ! |
- label = "Method",+ Q3 + ", input$iqr_slider, "\\times IQR \\lt x\\)) |
| 240 | +958 | ! |
- choices = c("IQR", "Z-score", "Percentile"),
+ are displayed in red on the plot and can be visualized in the table below."+ |
+
| 959 | ++ |
+ ), |
|
| 241 | +960 | ! |
- selected = "IQR",+ if (input$split_outliers) {
|
| 242 | +961 | ! |
- multiple = FALSE+ withMathJax(helpText("Note: Quantiles are calculated per group."))
|
| 243 | +962 |
- ),+ }+ |
+ |
| 963 | ++ |
+ )+ |
+ |
| 964 | ++ |
+ ) |
|
| 244 | +965 | ! |
- conditionalPanel(+ } else if (input$method == "Z-score") {
|
| 245 | +966 | ! |
- condition =+ req(input$zscore_slider) |
| 246 | +967 | ! |
- paste0("input['", ns("method"), "'] == 'IQR'"),
+ tags$small( |
| 247 | +968 | ! |
- sliderInput(+ withMathJax( |
| 248 | +969 | ! |
- ns("iqr_slider"),
+ helpText( |
| 249 | +970 | ! |
- "Outlier range:",+ "Outlier data points (\\(Zscore(x) < -", input$zscore_slider, |
| 250 | +971 | ! |
- min = 1,+ "\\) or \\(", input$zscore_slider, "< Zscore(x) \\))
|
| 251 | +972 | ! |
- max = 5,+ are displayed in red on the plot and can be visualized in the table below."+ |
+
| 973 | ++ |
+ ), |
|
| 252 | +974 | ! |
- value = 3,+ if (input$split_outliers) {
|
| 253 | +975 | ! |
- step = 0.5+ withMathJax(helpText(" Note: Z-scores are calculated per group."))
|
| 254 | +976 |
- )+ } |
|
| 255 | +977 |
- ),+ )+ |
+ |
| 978 | ++ |
+ ) |
|
| 256 | +979 | ! |
- conditionalPanel(+ } else if (input$method == "Percentile") {
|
| 257 | +980 | ! |
- condition =+ req(input$percentile_slider) |
| 258 | +981 | ! |
- paste0("input['", ns("method"), "'] == 'Z-score'"),
+ tags$small( |
| 259 | +982 | ! |
- sliderInput(+ withMathJax( |
| 260 | +983 | ! |
- ns("zscore_slider"),
+ helpText( |
| 261 | +984 | ! |
- "Outlier range:",+ "Outlier/extreme data points (\\( Percentile(x) <", input$percentile_slider, |
| 262 | +985 | ! |
- min = 1,+ "\\) or \\(", 1 - input$percentile_slider, " < Percentile(x) \\))
|
| 263 | +986 | ! |
- max = 5,+ are displayed in red on the plot and can be visualized in the table below."+ |
+
| 987 | ++ |
+ ), |
|
| 264 | +988 | ! |
- value = 3,+ if (input$split_outliers) {
|
| 265 | +989 | ! |
- step = 0.5+ withMathJax(helpText("Note: Percentiles are calculated per group."))
|
| 266 | +990 |
- )+ } |
|
| 267 | +991 |
- ),+ ) |
|
| 268 | -! | +||
| 992 | +
- conditionalPanel(+ ) |
||
| 269 | -! | +||
| 993 | +
- condition =+ } |
||
| 270 | -! | +||
| 994 | +
- paste0("input['", ns("method"), "'] == 'Percentile'"),
+ }) |
||
| 271 | -! | +||
| 995 | +
- sliderInput(+ |
||
| 272 | +996 | ! |
- ns("percentile_slider"),
+ boxplot_r <- reactive({
|
| 273 | +997 | ! |
- "Outlier range:",+ teal::validate_inputs(iv_r()) |
| 274 | +998 | ! |
- min = 0.001,+ boxplot_q()[["g"]]+ |
+
| 999 | ++ |
+ }) |
|
| 275 | +1000 | ! |
- max = 0.5,+ density_plot_r <- reactive({
|
| 276 | +1001 | ! |
- value = 0.01,+ teal::validate_inputs(iv_r()) |
| 277 | +1002 | ! |
- step = 0.001+ density_plot_q()[["g"]] |
| 278 | +1003 |
- )+ }) |
|
| 279 | -+ | ||
| 1004 | +! |
- ),+ cumulative_plot_r <- reactive({
|
|
| 280 | +1005 | ! |
- uiOutput(ns("ui_outlier_help"))
+ teal::validate_inputs(iv_r()) |
| 281 | -+ | ||
| 1006 | +! |
- )+ cumulative_plot_q()[["g"]] |
|
| 282 | +1007 |
- ),- |
- |
| 283 | -! | -
- teal.widgets::panel_item(+ }) |
|
| 284 | -! | +||
| 1008 | +
- title = "Plot settings",+ |
||
| 285 | +1009 | ! |
- selectInput(+ box_pws <- teal.widgets::plot_with_settings_srv( |
| 286 | +1010 | ! |
- inputId = ns("ggtheme"),
+ id = "box_plot", |
| 287 | +1011 | ! |
- label = "Theme (by ggplot):",+ plot_r = boxplot_r, |
| 288 | +1012 | ! |
- choices = ggplot_themes,+ height = plot_height, |
| 289 | +1013 | ! |
- selected = args$ggtheme,+ width = plot_width, |
| 290 | +1014 | ! |
- multiple = FALSE+ brushing = TRUE |
| 291 | +1015 |
- )+ ) |
|
| 292 | +1016 |
- )- |
- |
| 293 | -- |
- ),+ |
|
| 294 | +1017 | ! |
- forms = tagList(+ density_pws <- teal.widgets::plot_with_settings_srv( |
| 295 | +1018 | ! |
- teal.widgets::verbatim_popup_ui(ns("warning"), "Show Warnings"),
+ id = "density_plot", |
| 296 | +1019 | ! |
- teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code")
- |
-
| 297 | -- |
- ),+ plot_r = density_plot_r, |
|
| 298 | +1020 | ! |
- pre_output = args$pre_output,+ height = plot_height, |
| 299 | +1021 | ! |
- post_output = args$post_output+ width = plot_width, |
| 300 | -+ | ||
| 1022 | +! |
- )+ brushing = TRUE |
|
| 301 | +1023 |
- }+ ) |
|
| 302 | +1024 | ||
| 303 | -+ | ||
| 1025 | +! |
- srv_outliers <- function(id, data, reporter, filter_panel_api, outlier_var,+ cum_density_pws <- teal.widgets::plot_with_settings_srv( |
|
| 304 | -+ | ||
| 1026 | +! |
- categorical_var, plot_height, plot_width, ggplot2_args) {
+ id = "cum_density_plot", |
|
| 305 | +1027 | ! |
- with_reporter <- !missing(reporter) && inherits(reporter, "Reporter")+ plot_r = cumulative_plot_r, |
| 306 | +1028 | ! |
- with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI")+ height = plot_height, |
| 307 | +1029 | ! |
- checkmate::assert_class(data, "reactive")+ width = plot_width, |
| 308 | +1030 | ! |
- checkmate::assert_class(isolate(data()), "teal_data")+ brushing = TRUE |
| 309 | -! | +||
| 1031 | +
- moduleServer(id, function(input, output, session) {
+ )+ |
+ ||
| 1032 | ++ | + | |
| 310 | +1033 | ! |
- vars <- list(outlier_var = outlier_var, categorical_var = categorical_var)+ choices <- teal.transform::variable_choices(data()[[dataname_first]]) |
| 311 | +1034 | ||
| 312 | +1035 | ! |
- rule_diff <- function(other) {
+ observeEvent(common_code_q(), {
|
| 313 | +1036 | ! |
- function(value) {
+ ANL_OUTLIER <- common_code_q()[["ANL_OUTLIER"]] # nolint: object_name. |
| 314 | +1037 | ! |
- othervalue <- tryCatch(selector_list()[[other]]()[["select"]], error = function(e) NULL)+ teal.widgets::updateOptionalSelectInput( |
| 315 | +1038 | ! |
- if (!is.null(othervalue) && identical(othervalue, value)) {
+ session, |
| 316 | +1039 | ! |
- "`Variable` and `Categorical factor` cannot be the same"+ inputId = "table_ui_columns", |
| 317 | -+ | ||
| 1040 | +! |
- }+ choices = dplyr::setdiff(choices, names(ANL_OUTLIER)),+ |
+ |
| 1041 | +! | +
+ selected = isolate(input$table_ui_columns) |
|
| 318 | +1042 |
- }+ ) |
|
| 319 | +1043 |
- }+ }) |
|
| 320 | +1044 | ||
| 321 | +1045 | ! |
- selector_list <- teal.transform::data_extract_multiple_srv(+ output$table_ui <- DT::renderDataTable( |
| 322 | +1046 | ! |
- data_extract = vars,+ expr = {
|
| 323 | +1047 | ! |
- datasets = data,+ tab <- input$tabs |
| 324 | +1048 | ! |
- select_validation_rule = list(+ req(tab) # tab is NULL upon app launch, hence will crash without this statement |
| 325 | +1049 | ! |
- outlier_var = shinyvalidate::compose_rules(+ outlier_var <- as.vector(merged$anl_input_r()$columns_source$outlier_var) |
| 326 | +1050 | ! |
- shinyvalidate::sv_required("Please select a variable"),
+ categorical_var <- as.vector(merged$anl_input_r()$columns_source$categorical_var)+ |
+
| 1051 | ++ | + | |
| 327 | +1052 | ! |
- rule_diff("categorical_var")
+ ANL_OUTLIER <- common_code_q()[["ANL_OUTLIER"]] # nolint: object_name. |
| 328 | -+ | ||
| 1053 | +! |
- ),+ ANL_OUTLIER_EXTENDED <- common_code_q()[["ANL_OUTLIER_EXTENDED"]] # nolint: object_name. |
|
| 329 | +1054 | ! |
- categorical_var = rule_diff("outlier_var")
+ ANL <- common_code_q()[["ANL"]] # nolint: object_name. |
| 330 | -+ | ||
| 1055 | +! |
- )+ plot_brush <- if (tab == "Boxplot") {
|
|
| 331 | -+ | ||
| 1056 | +! |
- )+ boxplot_r() |
|
| 332 | -+ | ||
| 1057 | +! |
-
+ box_pws$brush() |
|
| 333 | +1058 | ! |
- iv_r <- reactive({
+ } else if (tab == "Density Plot") {
|
| 334 | +1059 | ! |
- iv <- shinyvalidate::InputValidator$new()+ density_plot_r() |
| 335 | +1060 | ! |
- iv$add_rule("method", shinyvalidate::sv_required("Please select a method"))
+ density_pws$brush() |
| 336 | +1061 | ! |
- iv$add_rule("boxplot_alts", shinyvalidate::sv_required("Please select Plot Type"))
+ } else if (tab == "Cumulative Distribution Plot") {
|
| 337 | +1062 | ! |
- teal.transform::compose_and_enable_validators(iv, selector_list)+ cumulative_plot_r()+ |
+
| 1063 | +! | +
+ cum_density_pws$brush() |
|
| 338 | +1064 |
- })+ } |
|
| 339 | +1065 | ||
| 1066 | ++ |
+ # removing unused column ASAP+ |
+ |
| 340 | +1067 | ! |
- reactive_select_input <- reactive({
+ ANL_OUTLIER$order <- ANL$order <- NULL # nolint: object_name.+ |
+
| 1068 | ++ | + | |
| 341 | +1069 | ! |
- if (is.null(selector_list()$categorical_var) || length(selector_list()$categorical_var()$select) == 0) {
+ display_table <- if (!is.null(plot_brush)) {
|
| 342 | +1070 | ! |
- selector_list()[names(selector_list()) != "categorical_var"]+ if (length(categorical_var) > 0) {
|
| 343 | +1071 |
- } else {
+ # due to reordering, the x-axis label may be changed to something like "reorder(categorical_var, order)" |
|
| 344 | +1072 | ! |
- selector_list()+ if (tab == "Boxplot") {
+ |
+
| 1073 | +! | +
+ plot_brush$mapping$x <- categorical_var |
|
| 345 | +1074 |
- }+ } else {
|
|
| 346 | +1075 |
- })+ # the other plots use facetting |
|
| 347 | +1076 |
-
+ # so it is panelvar1 that gets relabelled to "reorder(categorical_var, order)" |
|
| 348 | +1077 | ! |
- anl_merged_input <- teal.transform::merge_expression_srv(+ plot_brush$mapping$panelvar1 <- categorical_var |
| 349 | -! | +||
| 1078 | +
- selector_list = reactive_select_input,+ } |
||
| 350 | -! | +||
| 1079 | +
- datasets = data,+ } else {
|
||
| 351 | +1080 | ! |
- merge_function = "dplyr::inner_join"+ if (tab == "Boxplot") {
|
| 352 | +1081 |
- )+ # in boxplot with no categorical variable, there is no column in ANL that would correspond to x-axis |
|
| 353 | +1082 |
-
+ # so a column needs to be inserted with the value "Entire dataset" because that's the label used in plot |
|
| 354 | +1083 | ! |
- anl_merged_q <- reactive({
+ ANL[[plot_brush$mapping$x]] <- "Entire dataset" # nolint: object_name. |
| 355 | -! | +||
| 1084 | +
- req(anl_merged_input())+ } |
||
| 356 | -! | +||
| 1085 | +
- data() %>%+ } |
||
| 357 | -! | +||
| 1086 | +
- teal.code::eval_code(as.expression(anl_merged_input()$expr))+ |
||
| 358 | +1087 |
- })+ # in density and cumulative plots, ANL does not have a column corresponding to y-axis. |
|
| 359 | +1088 |
-
+ # so they need to be computed and attached to ANL |
|
| 360 | +1089 | ! |
- merged <- list(+ if (tab == "Density Plot") {
|
| 361 | +1090 | ! |
- anl_input_r = anl_merged_input,+ plot_brush$mapping$y <- "density" |
| 362 | +1091 | ! |
- anl_q_r = anl_merged_q+ ANL$density <- plot_brush$ymin # nolint: object_name. |
| 363 | +1092 |
- )+ # either ymin or ymax will work |
|
| 364 | -+ | ||
| 1093 | +! |
-
+ } else if (tab == "Cumulative Distribution Plot") {
|
|
| 365 | +1094 | ! |
- n_outlier_missing <- reactive({
+ plot_brush$mapping$y <- "cdf" |
| 366 | +1095 | ! |
- shiny::req(iv_r()$is_valid())+ if (length(categorical_var) > 0) {
|
| 367 | +1096 | ! |
- outlier_var <- as.vector(merged$anl_input_r()$columns_source$outlier_var)+ ANL <- ANL %>% # nolint: object_name. |
| 368 | +1097 | ! |
- ANL <- merged$anl_q_r()[["ANL"]] # nolint: object_name.+ dplyr::group_by(!!as.name(plot_brush$mapping$panelvar1)) %>% |
| 369 | +1098 | ! |
- sum(is.na(ANL[[outlier_var]]))+ dplyr::mutate(cdf = stats::ecdf(!!as.name(outlier_var))(!!as.name(outlier_var))) |
| 370 | +1099 |
- })+ } else {
|
|
| 371 | -+ | ||
| 1100 | +! |
-
+ ANL$cdf <- stats::ecdf(ANL[[outlier_var]])(ANL[[outlier_var]]) # nolint: object_name. |
|
| 372 | +1101 |
- # Used to create outlier table and the dropdown with additional columns+ } |
|
| 373 | -! | +||
| 1102 | +
- dataname_first <- isolate(teal.data::datanames(data())[[1]])+ } |
||
| 374 | +1103 | ||
| 375 | +1104 | ! |
- common_code_q <- reactive({
+ brushed_rows <- brushedPoints(ANL, plot_brush) |
| 376 | +1105 | ! |
- shiny::req(iv_r()$is_valid())+ if (nrow(brushed_rows) > 0) {
|
| 377 | +1106 | - - | -|
| 378 | -! | -
- ANL <- merged$anl_q_r()[["ANL"]] # nolint: object_name.- |
- |
| 379 | -! | -
- qenv <- merged$anl_q_r()+ # now we need to remove extra column from ANL so that it will have the same columns as ANL_OUTLIER |
|
| 380 | +1107 |
-
+ # so that dplyr::intersect will work |
|
| 381 | +1108 | ! |
- outlier_var <- as.vector(merged$anl_input_r()$columns_source$outlier_var)+ if (tab == "Density Plot") {
|
| 382 | +1109 | ! |
- categorical_var <- as.vector(merged$anl_input_r()$columns_source$categorical_var)+ brushed_rows$density <- NULL |
| 383 | +1110 | ! |
- order_by_outlier <- input$order_by_outlier+ } else if (tab == "Cumulative Distribution Plot") {
|
| 384 | +1111 | ! |
- method <- input$method+ brushed_rows$cdf <- NULL |
| 385 | +1112 | ! |
- split_outliers <- input$split_outliers+ } else if (tab == "Boxplot" && length(categorical_var) == 0) {
|
| 386 | +1113 | ! |
- teal::validate_has_data(+ brushed_rows[[plot_brush$mapping$x]] <- NULL |
| 387 | +1114 |
- # missing values in the categorical variable may be used to form a category of its own+ } |
|
| 388 | -! | +||
| 1115 | +
- `if`(+ # is_outlier_selected is part of ANL_OUTLIER so needed here |
||
| 389 | +1116 | ! |
- length(categorical_var) == 0,+ brushed_rows$is_outlier_selected <- TRUE |
| 390 | +1117 | ! |
- ANL,- |
-
| 391 | -! | -
- ANL[, names(ANL) != categorical_var, drop = FALSE]+ dplyr::intersect(ANL_OUTLIER, brushed_rows) |
|
| 392 | +1118 |
- ),+ } else {
|
|
| 393 | +1119 | ! |
- min_nrow = 10,+ ANL_OUTLIER[0, ] |
| 394 | -! | +||
| 1120 | +
- complete = TRUE,+ }+ |
+ ||
| 1121 | ++ |
+ } else {
|
|
| 395 | +1122 | ! |
- allow_inf = FALSE+ ANL_OUTLIER[ANL_OUTLIER$is_outlier_selected, ] |
| 396 | +1123 |
- )+ } |
|
| 397 | -! | +||
| 1124 | +
- validate(need(is.numeric(ANL[[outlier_var]]), "`Variable` is not numeric"))+ |
||
| 398 | +1125 | ! |
- validate(need(length(unique(ANL[[outlier_var]])) > 1, "Variable has no variation, i.e. only one unique value"))+ display_table$is_outlier_selected <- NULL |
| 399 | +1126 | ||
| 400 | +1127 |
- # show/hide split_outliers+ # Extend the brushed ANL_OUTLIER with additional columns |
|
| 401 | +1128 | ! |
- if (length(categorical_var) == 0) {
+ dplyr::left_join( |
| 402 | +1129 | ! |
- shinyjs::hide("split_outliers")
+ display_table, |
| 403 | +1130 | ! |
- if (n_outlier_missing() > 0) {
+ dplyr::select(ANL_OUTLIER_EXTENDED, -"is_outlier_selected"), |
| 404 | +1131 | ! |
- qenv <- teal.code::eval_code(+ by = names(display_table)+ |
+
| 1132 | ++ |
+ ) %>% |
|
| 405 | +1133 | ! |
- qenv,+ dplyr::select(union(names(display_table), input$table_ui_columns))+ |
+
| 1134 | ++ |
+ }, |
|
| 406 | +1135 | ! |
- substitute(+ options = list( |
| 407 | +1136 | ! |
- expr = ANL <- ANL %>% dplyr::filter(!is.na(outlier_var_name)), # nolint: object_name.+ searching = FALSE, language = list( |
| 408 | +1137 | ! |
- env = list(outlier_var_name = as.name(outlier_var))+ zeroRecords = "The brushed area does not contain outlier observations for the currently defined threshold" |
| 409 | +1138 |
- )+ ),+ |
+ |
| 1139 | +! | +
+ pageLength = input$table_ui_rows |
|
| 410 | +1140 |
- )+ ) |
|
| 411 | +1141 |
- }+ ) |
|
| 412 | +1142 |
- } else {
+
|
|
| 413 | +1143 | ! |
- validate(need(+ output$total_outliers <- renderUI({
|
| 414 | +1144 | ! |
- is.factor(ANL[[categorical_var]]) ||+ shiny::req(iv_r()$is_valid()) |
| 415 | +1145 | ! |
- is.character(ANL[[categorical_var]]) ||+ ANL <- merged$anl_q_r()[["ANL"]] # nolint: object_name. |
| 416 | +1146 | ! |
- is.integer(ANL[[categorical_var]]),+ ANL_OUTLIER <- common_code_q()[["ANL_OUTLIER"]] # nolint: object_name. |
| 417 | +1147 | ! |
- "`Categorical factor` must be `factor`, `character`, or `integer`"+ teal::validate_has_data(ANL, 1) |
| 418 | -+ | ||
| 1148 | +! |
- ))+ ANL_OUTLIER_SELECTED <- ANL_OUTLIER[ANL_OUTLIER$is_outlier_selected, ] # nolint: object_name. |
|
| 419 | -+ | ||
| 1149 | +! |
-
+ h5( |
|
| 420 | +1150 | ! |
- if (n_outlier_missing() > 0) {
+ sprintf( |
| 421 | +1151 | ! |
- qenv <- teal.code::eval_code(+ "%s %d / %d [%.02f%%]", |
| 422 | +1152 | ! |
- qenv,+ "Total number of outlier(s):", |
| 423 | +1153 | ! |
- substitute(+ nrow(ANL_OUTLIER_SELECTED), |
| 424 | +1154 | ! |
- expr = ANL <- ANL %>% dplyr::filter(!is.na(outlier_var_name)), # nolint: object_name.+ nrow(ANL), |
| 425 | +1155 | ! |
- env = list(outlier_var_name = as.name(outlier_var))+ 100 * nrow(ANL_OUTLIER_SELECTED) / nrow(ANL) |
| 426 | +1156 |
- )+ ) |
|
| 427 | +1157 |
- )+ ) |
|
| 428 | +1158 |
- }+ })+ |
+ |
| 1159 | ++ | + | |
| 429 | +1160 | ! |
- shinyjs::show("split_outliers")
+ output$total_missing <- renderUI({
|
| 430 | -+ | ||
| 1161 | +! |
- }+ if (n_outlier_missing() > 0) {
|
|
| 431 | -+ | ||
| 1162 | +! |
-
+ ANL <- merged$anl_q_r()[["ANL"]] # nolint: object_name. |
|
| 432 | -+ | ||
| 1163 | +! |
- # slider+ helpText( |
|
| 433 | +1164 | ! |
- outlier_definition_param <- if (method == "IQR") {
+ sprintf( |
| 434 | +1165 | ! |
- input$iqr_slider+ "%s %d / %d [%.02f%%]", |
| 435 | +1166 | ! |
- } else if (method == "Z-score") {
+ "Total number of row(s) with missing values:", |
| 436 | +1167 | ! |
- input$zscore_slider+ n_outlier_missing(), |
| 437 | +1168 | ! |
- } else if (method == "Percentile") {
+ nrow(ANL), |
| 438 | +1169 | ! |
- input$percentile_slider+ 100 * (n_outlier_missing()) / nrow(ANL) |
| 439 | +1170 | ++ |
+ )+ |
+
| 1171 | ++ |
+ )+ |
+ |
| 1172 |
} |
||
| 440 | +1173 |
-
+ }) |
|
| 441 | +1174 |
- # this is utils function that converts a %>% NULL %>% b into a %>% b+ |
|
| 442 | +1175 | ! |
- remove_pipe_null <- function(x) {
+ output$table_ui_wrap <- renderUI({
|
| 443 | +1176 | ! |
- if (length(x) == 1) {
+ shiny::req(iv_r()$is_valid()) |
| 444 | +1177 | ! |
- return(x)+ tagList( |
| 445 | -+ | ||
| 1178 | +! |
- }+ teal.widgets::optionalSelectInput( |
|
| 446 | +1179 | ! |
- if (identical(x[[1]], as.name("%>%")) && is.null(x[[3]])) {
+ inputId = session$ns("table_ui_columns"),
|
| 447 | +1180 | ! |
- return(remove_pipe_null(x[[2]]))+ label = "Choose additional columns", |
| 448 | -+ | ||
| 1181 | +! |
- }+ choices = NULL, |
|
| 449 | +1182 | ! |
- return(as.call(c(x[[1]], lapply(x[-1], remove_pipe_null))))+ selected = NULL, |
| 450 | -+ | ||
| 1183 | +! |
- }+ multiple = TRUE |
|
| 451 | +1184 |
-
+ ), |
|
| 452 | +1185 | ! |
- qenv <- teal.code::eval_code(+ h4("Outlier Table"),
|
| 453 | +1186 | ! |
- qenv,+ teal.widgets::get_dt_rows(session$ns("table_ui"), session$ns("table_ui_rows")),
|
| 454 | +1187 | ! |
- substitute(+ DT::dataTableOutput(session$ns("table_ui"))
|
| 455 | -! | +||
| 1188 | +
- expr = {
+ ) |
||
| 456 | -! | +||
| 1189 | +
- ANL_OUTLIER <- ANL %>% # nolint: object_name.+ })+ |
+ ||
| 1190 | ++ | + | |
| 457 | +1191 | ! |
- group_expr %>% # styler: off+ teal.widgets::verbatim_popup_srv( |
| 458 | +1192 | ! |
- dplyr::mutate(is_outlier = {
+ id = "warning", |
| 459 | +1193 | ! |
- q1_q3 <- stats::quantile(outlier_var_name, probs = c(0.25, 0.75))+ verbatim_content = reactive(teal.code::get_warnings(final_q())), |
| 460 | +1194 | ! |
- iqr <- q1_q3[2] - q1_q3[1]+ title = "Warning", |
| 461 | +1195 | ! |
- !(outlier_var_name >= q1_q3[1] - 1.5 * iqr & outlier_var_name <= q1_q3[2] + 1.5 * iqr)+ disabled = reactive(is.null(teal.code::get_warnings(final_q()))) |
| 462 | +1196 |
- }) %>%+ )+ |
+ |
| 1197 | ++ | + | |
| 463 | +1198 | ! |
- calculate_outliers %>% # styler: off+ teal.widgets::verbatim_popup_srv( |
| 464 | +1199 | ! |
- ungroup_expr %>% # styler: off+ id = "rcode", |
| 465 | +1200 | ! |
- dplyr::filter(is_outlier | is_outlier_selected) %>%+ verbatim_content = reactive(teal.code::get_code(final_q())), |
| 466 | +1201 | ! |
- dplyr::select(-is_outlier)+ title = "Show R Code for Outlier" |
| 467 | +1202 |
- },+ )+ |
+ |
| 1203 | ++ | + + | +|
| 1204 | ++ |
+ ### REPORTER |
|
| 468 | +1205 | ! |
- env = list(+ if (with_reporter) {
|
| 469 | +1206 | ! |
- calculate_outliers = if (method == "IQR") {
+ card_fun <- function(comment, label) {
|
| 470 | +1207 | ! |
- substitute(+ tab_type <- input$tabs |
| 471 | +1208 | ! |
- expr = dplyr::mutate(is_outlier_selected = {
+ card <- teal::report_card_template( |
| 472 | +1209 | ! |
- q1_q3 <- stats::quantile(outlier_var_name, probs = c(0.25, 0.75))+ title = paste0("Outliers - ", tab_type),
|
| 473 | +1210 | ! |
- iqr <- q1_q3[2] - q1_q3[1]+ label = label, |
| 474 | +1211 | ! |
- !(outlier_var_name >= q1_q3[1] - outlier_definition_param * iqr &+ with_filter = with_filter, |
| 475 | +1212 | ! |
- outlier_var_name <= q1_q3[2] + outlier_definition_param * iqr)+ filter_panel_api = filter_panel_api |
| 476 | +1213 |
- }),+ ) |
|
| 477 | +1214 | ! |
- env = list(+ categorical_var <- as.vector(merged$anl_input_r()$columns_source$categorical_var) |
| 478 | +1215 | ! |
- outlier_var_name = as.name(outlier_var),+ if (length(categorical_var) > 0) {
|
| 479 | +1216 | ! |
- outlier_definition_param = outlier_definition_param+ summary_table <- common_code_q()[["summary_table"]] |
| 480 | -+ | ||
| 1217 | +! |
- )+ card$append_text("Summary Table", "header3")
+ |
+ |
| 1218 | +! | +
+ card$append_table(summary_table) |
|
| 481 | +1219 |
- )+ } |
|
| 482 | +1220 | ! |
- } else if (method == "Z-score") {
+ card$append_text("Plot", "header3")
|
| 483 | +1221 | ! |
- substitute(+ if (tab_type == "Boxplot") {
|
| 484 | +1222 | ! |
- expr = dplyr::mutate(+ card$append_plot(boxplot_r(), dim = box_pws$dim()) |
| 485 | +1223 | ! |
- is_outlier_selected = abs(outlier_var_name - mean(outlier_var_name)) /- |
-
| 486 | -! | -
- stats::sd(outlier_var_name) > outlier_definition_param- |
- |
| 487 | -- |
- ),+ } else if (tab_type == "Density Plot") {
|
|
| 488 | +1224 | ! |
- env = list(+ card$append_plot(density_plot_r(), dim = density_pws$dim()) |
| 489 | +1225 | ! |
- outlier_var_name = as.name(outlier_var),+ } else if (tab_type == "Cumulative Distribution Plot") {
|
| 490 | +1226 | ! |
- outlier_definition_param = outlier_definition_param+ card$append_plot(cumulative_plot_r(), dim = cum_density_pws$dim()) |
| 491 | +1227 |
- )+ } |
|
| 492 | -+ | ||
| 1228 | +! |
- )+ if (!comment == "") {
|
|
| 493 | +1229 | ! |
- } else if (method == "Percentile") {
+ card$append_text("Comment", "header3")
|
| 494 | +1230 | ! |
- substitute(+ card$append_text(comment) |
| 495 | -! | +||
| 1231 | +
- expr = dplyr::mutate(+ } |
||
| 496 | +1232 | ! |
- is_outlier_selected = outlier_var_name < stats::quantile(outlier_var_name, outlier_definition_param) |+ card$append_src(teal.code::get_code(final_q())) |
| 497 | +1233 | ! |
- outlier_var_name > stats::quantile(outlier_var_name, 1 - outlier_definition_param)+ card |
| 498 | +1234 |
- ),+ } |
|
| 499 | +1235 | ! |
- env = list(+ teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
|
| 500 | -! | +||
| 1236 | +
- outlier_var_name = as.name(outlier_var),+ } |
||
| 501 | -! | +||
| 1237 | +
- outlier_definition_param = outlier_definition_param+ ### |
||
| 502 | +1238 |
- )+ }) |
|
| 503 | +1239 |
- )+ } |
| 504 | +1 |
- },+ #' Stack Plots of variables and show association with reference variable |
|
| 505 | -! | +||
| 2 | +
- outlier_var_name = as.name(outlier_var),+ #' @md |
||
| 506 | -! | +||
| 3 | +
- group_expr = if (isTRUE(split_outliers) && length(categorical_var) != 0) {
+ #' |
||
| 507 | -! | +||
| 4 | +
- substitute(dplyr::group_by(x), list(x = as.name(categorical_var)))+ #' @inheritParams teal::module |
||
| 508 | +5 |
- },+ #' @inheritParams shared_params |
|
| 509 | -! | +||
| 6 | +
- ungroup_expr = if (isTRUE(split_outliers) && length(categorical_var) != 0) {
+ #' @param ref (`data_extract_spec` or `list` of multiple `data_extract_spec`) |
||
| 510 | -! | +||
| 7 | +
- substitute(dplyr::ungroup())+ #' reference variable, must set `multiple = FALSE`. |
||
| 511 | +8 |
- }+ #' @param vars (`data_extract_spec` or `list` of multiple `data_extract_spec`) |
|
| 512 | +9 |
- )+ #' associated variables. |
|
| 513 | +10 |
- ) %>%+ #' @param show_association optional, (`logical`) Whether show association of `vars` |
|
| 514 | -! | +||
| 11 | +
- remove_pipe_null()+ #' with reference variable. Defaults to `TRUE`. |
||
| 515 | +12 |
- )+ #' @param distribution_theme,association_theme optional, (`character`) `ggplot2` themes to be used by default. |
|
| 516 | +13 |
-
+ #' Default to `"gray"`. |
|
| 517 | +14 |
- # ANL_OUTLIER_EXTENDED is the base table+ #' |
|
| 518 | -! | +||
| 15 | +
- qenv <- teal.code::eval_code(+ #' @templateVar ggnames "Bivariate1", "Bivariate2" |
||
| 519 | -! | +||
| 16 | +
- qenv,+ #' @template ggplot2_args_multi |
||
| 520 | -! | +||
| 17 | +
- substitute(+ #' |
||
| 521 | -! | +||
| 18 | +
- expr = {
+ #' @note For more examples, please see the vignette "Using association plot" via |
||
| 522 | -! | +||
| 19 | +
- ANL_OUTLIER_EXTENDED <- dplyr::left_join( # nolint: object_name.+ #' \code{vignette("using-association-plot", package = "teal.modules.general")}.
|
||
| 523 | -! | +||
| 20 | +
- ANL_OUTLIER,+ #' |
||
| 524 | -! | +||
| 21 | +
- dplyr::select(+ #' @examples |
||
| 525 | -! | +||
| 22 | +
- dataname,+ #' # general data exapmle |
||
| 526 | -! | +||
| 23 | +
- dplyr::setdiff(names(dataname), dplyr::setdiff(names(ANL_OUTLIER), join_keys))+ #' library(teal.widgets) |
||
| 527 | +24 |
- ),+ #' |
|
| 528 | -! | +||
| 25 | +
- by = join_keys+ #' data <- teal_data() |
||
| 529 | +26 |
- )+ #' data <- within(data, {
|
|
| 530 | +27 |
- },+ #' library(nestcolor) |
|
| 531 | -! | +||
| 28 | +
- env = list(+ #' CO2 <- CO2 |
||
| 532 | -! | +||
| 29 | +
- dataname = as.name(dataname_first),+ #' factors <- names(Filter(isTRUE, vapply(CO2, is.factor, logical(1L)))) |
||
| 533 | -! | +||
| 30 | +
- join_keys = as.character(teal.data::join_keys(data())[dataname_first, dataname_first])+ #' CO2[factors] <- lapply(CO2[factors], as.character) |
||
| 534 | +31 |
- )+ #' }) |
|
| 535 | +32 |
- )+ #' datanames(data) <- c("CO2")
|
|
| 536 | +33 |
- )+ #' |
|
| 537 | +34 |
-
+ #' app <- init( |
|
| 538 | -! | +||
| 35 | +
- if (length(categorical_var) > 0) {
+ #' data = data, |
||
| 539 | -! | +||
| 36 | +
- qenv <- teal.code::eval_code(+ #' modules = modules( |
||
| 540 | -! | +||
| 37 | +
- qenv,+ #' tm_g_association( |
||
| 541 | -! | +||
| 38 | +
- substitute(+ #' ref = data_extract_spec( |
||
| 542 | -! | +||
| 39 | +
- expr = summary_table_pre <- ANL_OUTLIER %>%+ #' dataname = "CO2", |
||
| 543 | -! | +||
| 40 | +
- dplyr::filter(is_outlier_selected) %>%+ #' select = select_spec( |
||
| 544 | -! | +||
| 41 | +
- dplyr::select(outlier_var_name, categorical_var_name) %>%+ #' label = "Select variable:", |
||
| 545 | -! | +||
| 42 | +
- dplyr::group_by(categorical_var_name) %>%+ #' choices = variable_choices(data[["CO2"]], c("Plant", "Type", "Treatment")),
|
||
| 546 | -! | +||
| 43 | +
- dplyr::summarise(n_outliers = dplyr::n()) %>%+ #' selected = "Plant", |
||
| 547 | -! | +||
| 44 | +
- dplyr::right_join(+ #' fixed = FALSE |
||
| 548 | -! | +||
| 45 | +
- ANL %>%+ #' ) |
||
| 549 | -! | +||
| 46 | +
- dplyr::select(outlier_var_name, categorical_var_name) %>%+ #' ), |
||
| 550 | -! | +||
| 47 | +
- dplyr::group_by(categorical_var_name) %>%+ #' vars = data_extract_spec( |
||
| 551 | -! | +||
| 48 | +
- dplyr::summarise(+ #' dataname = "CO2", |
||
| 552 | -! | +||
| 49 | +
- total_in_cat = dplyr::n(),+ #' select = select_spec( |
||
| 553 | -! | +||
| 50 | +
- n_na = sum(is.na(outlier_var_name) | is.na(categorical_var_name))+ #' label = "Select variables:", |
||
| 554 | +51 |
- ),+ #' choices = variable_choices(data[["CO2"]], c("Plant", "Type", "Treatment")),
|
|
| 555 | -! | +||
| 52 | +
- by = categorical_var+ #' selected = "Treatment", |
||
| 556 | +53 |
- ) %>%+ #' multiple = TRUE, |
|
| 557 | +54 |
- # This is important as there may be categorical variables with natural orderings, e.g. AGE.+ #' fixed = FALSE |
|
| 558 | +55 |
- # The plots should be displayed by default in increasing order in these situations.+ #' ) |
|
| 559 | +56 |
- # dplyr::arrange will sort integer, factor, and character data types in the expected way.+ #' ), |
|
| 560 | -! | +||
| 57 | +
- dplyr::arrange(categorical_var_name) %>%+ #' ggplot2_args = ggplot2_args( |
||
| 561 | -! | +||
| 58 | +
- dplyr::mutate(+ #' labs = list(subtitle = "Plot generated by Association Module") |
||
| 562 | -! | +||
| 59 | +
- n_outliers = dplyr::if_else(is.na(n_outliers), 0, as.numeric(n_outliers)),+ #' ) |
||
| 563 | -! | +||
| 60 | +
- display_str = dplyr::if_else(+ #' ) |
||
| 564 | -! | +||
| 61 | +
- n_outliers > 0,+ #' ) |
||
| 565 | -! | +||
| 62 | +
- sprintf("%d [%.02f%%]", n_outliers, 100 * n_outliers / total_in_cat),
+ #' ) |
||
| 566 | -! | +||
| 63 | +
- "0"+ #' if (interactive()) {
|
||
| 567 | +64 |
- ),+ #' shinyApp(app$ui, app$server) |
|
| 568 | -! | +||
| 65 | +
- display_str_na = dplyr::if_else(+ #' } |
||
| 569 | -! | +||
| 66 | +
- n_na > 0,+ #' |
||
| 570 | -! | +||
| 67 | +
- sprintf("%d [%.02f%%]", n_na, 100 * n_na / total_in_cat),
+ #' # CDISC data example |
||
| 571 | -! | +||
| 68 | +
- "0"+ #' library(teal.widgets) |
||
| 572 | +69 |
- ),+ #' |
|
| 573 | -! | +||
| 70 | +
- order = seq_along(n_outliers)+ #' data <- teal_data() |
||
| 574 | +71 |
- ),+ #' data <- within(data, {
|
|
| 575 | -! | +||
| 72 | +
- env = list(+ #' library(nestcolor) |
||
| 576 | -! | +||
| 73 | +
- categorical_var = categorical_var,+ #' ADSL <- rADSL |
||
| 577 | -! | +||
| 74 | +
- categorical_var_name = as.name(categorical_var),+ #' }) |
||
| 578 | -! | +||
| 75 | +
- outlier_var_name = as.name(outlier_var)+ #' datanames(data) <- "ADSL" |
||
| 579 | +76 |
- )+ #' join_keys(data) <- default_cdisc_join_keys[datanames(data)] |
|
| 580 | +77 |
- )+ #' |
|
| 581 | +78 |
- )+ #' app <- init( |
|
| 582 | +79 |
- # now to handle when user chooses to order based on amount of outliers+ #' data = data, |
|
| 583 | -! | +||
| 80 | +
- if (order_by_outlier) {
+ #' modules = modules( |
||
| 584 | -! | +||
| 81 | +
- qenv <- teal.code::eval_code(+ #' tm_g_association( |
||
| 585 | -! | +||
| 82 | +
- qenv,+ #' ref = data_extract_spec( |
||
| 586 | -! | +||
| 83 | +
- quote(+ #' dataname = "ADSL", |
||
| 587 | -! | +||
| 84 | +
- summary_table_pre <- summary_table_pre %>%+ #' select = select_spec( |
||
| 588 | -! | +||
| 85 | +
- dplyr::arrange(desc(n_outliers / total_in_cat)) %>%+ #' label = "Select variable:", |
||
| 589 | -! | +||
| 86 | +
- dplyr::mutate(order = seq_len(nrow(summary_table_pre)))+ #' choices = variable_choices( |
||
| 590 | +87 |
- )+ #' data[["ADSL"]], |
|
| 591 | +88 |
- )+ #' c("SEX", "RACE", "COUNTRY", "ARM", "STRATA1", "STRATA2", "ITTFL", "BMRKR2")
|
|
| 592 | +89 |
- }+ #' ), |
|
| 593 | +90 |
-
+ #' selected = "RACE", |
|
| 594 | -! | +||
| 91 | +
- qenv <- teal.code::eval_code(+ #' fixed = FALSE |
||
| 595 | -! | +||
| 92 | +
- qenv,+ #' ) |
||
| 596 | -! | +||
| 93 | +
- substitute(+ #' ), |
||
| 597 | -! | +||
| 94 | +
- expr = {
+ #' vars = data_extract_spec( |
||
| 598 | +95 |
- # In order for geom_rug to work properly when reordering takes place inside facet_grid,+ #' dataname = "ADSL", |
|
| 599 | +96 |
- # all tables must have the column used for reording.+ #' select = select_spec( |
|
| 600 | +97 |
- # In this case, the column used for reordering is `order`.+ #' label = "Select variables:", |
|
| 601 | -! | +||
| 98 | +
- ANL_OUTLIER <- dplyr::left_join( # nolint: object_name.+ #' choices = variable_choices( |
||
| 602 | -! | +||
| 99 | +
- ANL_OUTLIER,+ #' data[["ADSL"]], |
||
| 603 | -! | +||
| 100 | +
- summary_table_pre[, c("order", categorical_var)],
+ #' c("SEX", "RACE", "COUNTRY", "ARM", "STRATA1", "STRATA2", "ITTFL", "BMRKR2")
|
||
| 604 | -! | +||
| 101 | +
- by = categorical_var+ #' ), |
||
| 605 | +102 |
- )+ #' selected = "BMRKR2", |
|
| 606 | +103 |
- # so that x axis of plot aligns with columns of summary table, from most outliers to least by percentage+ #' multiple = TRUE, |
|
| 607 | -! | +||
| 104 | +
- ANL <- ANL %>% # nolint: object_name.+ #' fixed = FALSE |
||
| 608 | -! | +||
| 105 | +
- dplyr::left_join(+ #' ) |
||
| 609 | -! | +||
| 106 | +
- dplyr::select(summary_table_pre, categorical_var_name, order),+ #' ), |
||
| 610 | -! | +||
| 107 | +
- by = categorical_var+ #' ggplot2_args = ggplot2_args( |
||
| 611 | +108 |
- ) %>%+ #' labs = list(subtitle = "Plot generated by Association Module") |
|
| 612 | -! | +||
| 109 | +
- dplyr::arrange(order)+ #' ) |
||
| 613 | -! | +||
| 110 | +
- summary_table <- summary_table_pre %>%+ #' ) |
||
| 614 | -! | +||
| 111 | +
- dplyr::select(+ #' ) |
||
| 615 | -! | +||
| 112 | +
- categorical_var_name,+ #' ) |
||
| 616 | -! | +||
| 113 | +
- Outliers = display_str, Missings = display_str_na, Total = total_in_cat+ #' if (interactive()) {
|
||
| 617 | +114 |
- ) %>%+ #' shinyApp(app$ui, app$server) |
|
| 618 | -! | +||
| 115 | +
- dplyr::mutate_all(as.character) %>%+ #' } |
||
| 619 | -! | +||
| 116 | +
- tidyr::pivot_longer(-categorical_var_name) %>%+ #' |
||
| 620 | -! | +||
| 117 | +
- tidyr::pivot_wider(names_from = categorical_var, values_from = value) %>%+ #' @export |
||
| 621 | -! | +||
| 118 | +
- tibble::column_to_rownames("name")
+ #' |
||
| 622 | -! | +||
| 119 | +
- summary_table+ tm_g_association <- function(label = "Association", |
||
| 623 | +120 |
- },+ ref, |
|
| 624 | -! | +||
| 121 | +
- env = list(+ vars, |
||
| 625 | -! | +||
| 122 | +
- categorical_var = categorical_var,+ show_association = TRUE, |
||
| 626 | -! | +||
| 123 | +
- categorical_var_name = as.name(categorical_var)+ plot_height = c(600, 400, 5000), |
||
| 627 | +124 |
- )+ plot_width = NULL, |
|
| 628 | +125 |
- )+ distribution_theme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void"), # nolint: line_length.
|
|
| 629 | +126 |
- )+ association_theme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void"), # nolint: line_length.
|
|
| 630 | +127 |
- }+ pre_output = NULL, |
|
| 631 | +128 |
-
+ post_output = NULL, |
|
| 632 | -! | +||
| 129 | +
- if (length(categorical_var) > 0 && nrow(qenv[["ANL_OUTLIER"]]) > 0) {
+ ggplot2_args = teal.widgets::ggplot2_args()) {
|
||
| 633 | +130 | ! |
- shinyjs::show("order_by_outlier")
+ logger::log_info("Initializing tm_g_association")
|
| 634 | -+ | ||
| 131 | +! |
- } else {
+ if (inherits(ref, "data_extract_spec")) ref <- list(ref) |
|
| 635 | +132 | ! |
- shinyjs::hide("order_by_outlier")
+ if (inherits(vars, "data_extract_spec")) vars <- list(vars) |
| 636 | -+ | ||
| 133 | +! |
- }+ if (inherits(ggplot2_args, "ggplot2_args")) ggplot2_args <- list(default = ggplot2_args) |
|
| 637 | +134 | ||
| 638 | +135 | ! |
- qenv+ checkmate::assert_string(label) |
| 639 | -+ | ||
| 136 | +! |
- })+ checkmate::assert_list(ref, types = "data_extract_spec") |
|
| 640 | -+ | ||
| 137 | +! |
-
+ if (!all(vapply(ref, function(x) !x$select$multiple, logical(1)))) {
|
|
| 641 | +138 | ! |
- output$summary_table <- DT::renderDataTable(+ stop("'ref' should not allow multiple selection")
|
| 642 | -! | +||
| 139 | +
- expr = {
+ } |
||
| 643 | +140 | ! |
- if (iv_r()$is_valid()) {
+ checkmate::assert_list(vars, types = "data_extract_spec") |
| 644 | +141 | ! |
- categorical_var <- as.vector(merged$anl_input_r()$columns_source$categorical_var)+ checkmate::assert_flag(show_association) |
| 645 | -! | -
- if (!is.null(categorical_var)) {
- |
- |
| 646 | +142 | ! |
- DT::datatable(+ checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE) |
| 647 | +143 | ! |
- common_code_q()[["summary_table"]],+ checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height") |
| 648 | +144 | ! |
- options = list(+ checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE) |
| 649 | +145 | ! |
- dom = "t",+ checkmate::assert_numeric( |
| 650 | +146 | ! |
- autoWidth = TRUE,+ plot_width[1], |
| 651 | +147 | ! |
- columnDefs = list(list(width = "200px", targets = "_all"))+ lower = plot_width[2], upper = plot_width[3], null.ok = TRUE, .var.name = "plot_width" |
| 652 | +148 |
- )+ ) |
|
| 653 | -+ | ||
| 149 | +! |
- )+ distribution_theme <- match.arg(distribution_theme) |
|
| 654 | -+ | ||
| 150 | +! |
- }+ association_theme <- match.arg(association_theme) |
|
| 655 | -+ | ||
| 151 | +! |
- }+ plot_choices <- c("Bivariate1", "Bivariate2")
|
|
| 656 | -+ | ||
| 152 | +! |
- }+ checkmate::assert_list(ggplot2_args, types = "ggplot2_args") |
|
| 657 | -+ | ||
| 153 | +! |
- )+ checkmate::assert_subset(names(ggplot2_args), c("default", plot_choices))
|
|
| 658 | +154 | ||
| 659 | -- |
- # boxplot/violinplot # nolint commented_code- |
- |
| 660 | -! | -
- boxplot_q <- reactive({
- |
- |
| 661 | +155 | ! |
- req(common_code_q())+ args <- as.list(environment()) |
| 662 | -! | +||
| 156 | +
- ANL <- common_code_q()[["ANL"]] # nolint: object_name.+ |
||
| 663 | +157 | ! |
- ANL_OUTLIER <- common_code_q()[["ANL_OUTLIER"]] # nolint: object_name.- |
-
| 664 | -- |
-
+ data_extract_list <- list( |
|
| 665 | +158 | ! |
- outlier_var <- as.vector(merged$anl_input_r()$columns_source$outlier_var)+ ref = ref, |
| 666 | +159 | ! |
- categorical_var <- as.vector(merged$anl_input_r()$columns_source$categorical_var)+ vars = vars |
| 667 | +160 |
-
+ ) |
|
| 668 | +161 |
- # validation+ |
|
| 669 | +162 | ! |
- teal::validate_has_data(ANL, 1)- |
-
| 670 | -- |
-
+ module( |
|
| 671 | -+ | ||
| 163 | +! |
- # boxplot+ label = label, |
|
| 672 | +164 | ! |
- plot_call <- quote(ANL %>% ggplot())+ server = srv_tm_g_association, |
| 673 | -+ | ||
| 165 | +! |
-
+ ui = ui_tm_g_association, |
|
| 674 | +166 | ! |
- plot_call <- if (input$boxplot_alts == "Box plot") {
+ ui_args = args, |
| 675 | +167 | ! |
- substitute(expr = plot_call + geom_boxplot(outlier.shape = NA), env = list(plot_call = plot_call))+ server_args = c( |
| 676 | +168 | ! |
- } else if (input$boxplot_alts == "Violin plot") {
+ data_extract_list, |
| 677 | +169 | ! |
- substitute(expr = plot_call + geom_violin(), env = list(plot_call = plot_call))+ list(plot_height = plot_height, plot_width = plot_width, ggplot2_args = ggplot2_args) |
| 678 | +170 |
- } else {
+ ), |
|
| 679 | +171 | ! |
- NULL+ datanames = teal.transform::get_extract_datanames(data_extract_list) |
| 680 | +172 |
- }+ ) |
|
| 681 | +173 | - - | -|
| 682 | -! | -
- plot_call <- if (identical(categorical_var, character(0)) || is.null(categorical_var)) {
+ } |
|
| 683 | -! | +||
| 174 | +
- inner_call <- substitute(+ |
||
| 684 | -! | +||
| 175 | +
- expr = plot_call ++ ui_tm_g_association <- function(id, ...) {
|
||
| 685 | +176 | ! |
- aes(x = "Entire dataset", y = outlier_var_name) ++ ns <- NS(id) |
| 686 | +177 | ! |
- scale_x_discrete(),+ args <- list(...) |
| 687 | +178 | ! |
- env = list(plot_call = plot_call, outlier_var_name = as.name(outlier_var))+ is_single_dataset_value <- teal.transform::is_single_dataset(args$ref, args$vars) |
| 688 | +179 |
- )+ |
|
| 689 | +180 | ! |
- if (nrow(ANL_OUTLIER) > 0) {
+ teal.widgets::standard_layout( |
| 690 | +181 | ! |
- substitute(+ output = teal.widgets::white_small_well( |
| 691 | +182 | ! |
- expr = inner_call + geom_point(+ textOutput(ns("title")),
|
| 692 | +183 | ! |
- data = ANL_OUTLIER,+ tags$br(), |
| 693 | +184 | ! |
- aes(x = "Entire dataset", y = outlier_var_name, color = is_outlier_selected)+ teal.widgets::plot_with_settings_ui(id = ns("myplot"))
|
| 694 | +185 |
- ),+ ), |
|
| 695 | +186 | ! |
- env = list(inner_call = inner_call, outlier_var_name = as.name(outlier_var))- |
-
| 696 | -- |
- )+ encoding = div( |
|
| 697 | +187 |
- } else {
+ ### Reporter |
|
| 698 | +188 | ! |
- inner_call- |
-
| 699 | -- |
- }+ teal.reporter::simple_reporter_ui(ns("simple_reporter")),
|
|
| 700 | +189 |
- } else {
- |
- |
| 701 | -! | -
- substitute(+ ### |
|
| 702 | +190 | ! |
- expr = plot_call ++ tags$label("Encodings", class = "text-primary"),
|
| 703 | +191 | ! |
- aes(y = outlier_var_name, x = reorder(categorical_var_name, order)) ++ teal.transform::datanames_input(args[c("ref", "vars")]),
|
| 704 | +192 | ! |
- xlab(categorical_var) ++ teal.transform::data_extract_ui( |
| 705 | +193 | ! |
- scale_x_discrete() ++ id = ns("ref"),
|
| 706 | +194 | ! |
- geom_point(+ label = "Reference variable", |
| 707 | +195 | ! |
- data = ANL_OUTLIER,+ data_extract_spec = args$ref, |
| 708 | +196 | ! |
- aes(x = as.factor(categorical_var_name), y = outlier_var_name, color = is_outlier_selected)+ is_single_dataset = is_single_dataset_value |
| 709 | +197 |
- ),+ ), |
|
| 710 | +198 | ! |
- env = list(+ teal.transform::data_extract_ui( |
| 711 | +199 | ! |
- plot_call = plot_call,+ id = ns("vars"),
|
| 712 | +200 | ! |
- outlier_var_name = as.name(outlier_var),+ label = "Associated variables", |
| 713 | +201 | ! |
- categorical_var_name = as.name(categorical_var),+ data_extract_spec = args$vars, |
| 714 | +202 | ! |
- categorical_var = categorical_var- |
-
| 715 | -- |
- )- |
- |
| 716 | -- |
- )- |
- |
| 717 | -- |
- }+ is_single_dataset = is_single_dataset_value |
|
| 718 | +203 |
-
+ ), |
|
| 719 | +204 | ! |
- dev_ggplot2_args <- teal.widgets::ggplot2_args(+ checkboxInput( |
| 720 | +205 | ! |
- labs = list(color = "Is outlier?"),+ ns("association"),
|
| 721 | +206 | ! |
- theme = list(legend.position = "top")+ "Association with reference variable", |
| 722 | -+ | ||
| 207 | +! |
- )+ value = args$show_association |
|
| 723 | +208 |
-
+ ), |
|
| 724 | +209 | ! |
- all_ggplot2_args <- teal.widgets::resolve_ggplot2_args(+ checkboxInput( |
| 725 | +210 | ! |
- user_plot = ggplot2_args[["Boxplot"]],+ ns("show_dist"),
|
| 726 | +211 | ! |
- user_default = ggplot2_args$default,+ "Scaled frequencies", |
| 727 | +212 | ! |
- module_plot = dev_ggplot2_args+ value = FALSE |
| 728 | +213 |
- )+ ), |
|
| 729 | -+ | ||
| 214 | +! |
-
+ checkboxInput( |
|
| 730 | +215 | ! |
- parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(+ ns("log_transformation"),
|
| 731 | +216 | ! |
- all_ggplot2_args,+ "Log transformed", |
| 732 | +217 | ! |
- ggtheme = input$ggtheme+ value = FALSE |
| 733 | +218 |
- )+ ), |
|
| 734 | -+ | ||
| 219 | +! |
-
+ teal.widgets::panel_group( |
|
| 735 | +220 | ! |
- teal.code::eval_code(+ teal.widgets::panel_item( |
| 736 | +221 | ! |
- common_code_q(),+ title = "Plot settings", |
| 737 | +222 | ! |
- substitute(+ teal.widgets::optionalSliderInputValMinMax(ns("alpha"), "Scatterplot opacity:", c(0.5, 0, 1), ticks = FALSE),
|
| 738 | +223 | ! |
- expr = g <- plot_call ++ teal.widgets::optionalSliderInputValMinMax(ns("size"), "Scatterplot points size:", c(2, 1, 8), ticks = FALSE),
|
| 739 | +224 | ! |
- scale_color_manual(values = c("TRUE" = "red", "FALSE" = "black")) +
+ checkboxInput(ns("swap_axes"), "Swap axes", value = FALSE),
|
| 740 | +225 | ! |
- labs + ggthemes + themes,+ checkboxInput(ns("rotate_xaxis_labels"), "Rotate X axis labels", value = FALSE),
|
| 741 | +226 | ! |
- env = list(+ selectInput( |
| 742 | +227 | ! |
- plot_call = plot_call,+ inputId = ns("distribution_theme"),
|
| 743 | +228 | ! |
- labs = parsed_ggplot2_args$labs,+ label = "Distribution theme (by ggplot):", |
| 744 | +229 | ! |
- ggthemes = parsed_ggplot2_args$ggtheme,+ choices = ggplot_themes, |
| 745 | +230 | ! |
- themes = parsed_ggplot2_args$theme+ selected = args$distribution_theme, |
| 746 | -+ | ||
| 231 | +! |
- )+ multiple = FALSE |
|
| 747 | +232 |
- )+ ), |
|
| 748 | -+ | ||
| 233 | +! |
- ) %>%+ selectInput( |
|
| 749 | +234 | ! |
- teal.code::eval_code(quote(print(g)))- |
-
| 750 | -- |
- })- |
- |
| 751 | -- | - - | -|
| 752 | -- |
- # density plot- |
- |
| 753 | -! | -
- density_plot_q <- reactive({
+ inputId = ns("association_theme"),
|
|
| 754 | +235 | ! |
- ANL <- common_code_q()[["ANL"]] # nolint: object_name.+ label = "Association theme (by ggplot):", |
| 755 | +236 | ! |
- ANL_OUTLIER <- common_code_q()[["ANL_OUTLIER"]] # nolint: object_name.- |
-
| 756 | -- |
-
+ choices = ggplot_themes, |
|
| 757 | +237 | ! |
- outlier_var <- as.vector(merged$anl_input_r()$columns_source$outlier_var)+ selected = args$association_theme, |
| 758 | +238 | ! |
- categorical_var <- as.vector(merged$anl_input_r()$columns_source$categorical_var)+ multiple = FALSE |
| 759 | +239 |
-
+ ) |
|
| 760 | +240 |
- # validation+ ) |
|
| 761 | -! | +||
| 241 | +
- teal::validate_has_data(ANL, 1)+ ) |
||
| 762 | +242 |
- # plot+ ), |
|
| 763 | +243 | ! |
- plot_call <- substitute(+ forms = tagList( |
| 764 | +244 | ! |
- expr = ANL %>%+ teal.widgets::verbatim_popup_ui(ns("warning"), "Show Warnings"),
|
| 765 | +245 | ! |
- ggplot(aes(x = outlier_var_name)) ++ teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code")
|
| 766 | -! | +||
| 246 | +
- geom_density() ++ ), |
||
| 767 | +247 | ! |
- geom_rug(data = ANL_OUTLIER, aes(x = outlier_var_name, color = is_outlier_selected)) ++ pre_output = args$pre_output, |
| 768 | +248 | ! |
- scale_color_manual(values = c("TRUE" = "red", "FALSE" = "black")),
+ post_output = args$post_output |
| 769 | -! | +||
| 249 | +
- env = list(outlier_var_name = as.name(outlier_var))+ ) |
||
| 770 | +250 |
- )+ } |
|
| 771 | +251 | ||
| 772 | -! | +||
| 252 | +
- plot_call <- if (identical(categorical_var, character(0)) || is.null(categorical_var)) {
+ srv_tm_g_association <- function(id, |
||
| 773 | -! | +||
| 253 | +
- substitute(expr = plot_call, env = list(plot_call = plot_call))+ data, |
||
| 774 | +254 |
- } else {
+ reporter, |
|
| 775 | -! | +||
| 255 | +
- substitute(+ filter_panel_api, |
||
| 776 | -! | +||
| 256 | +
- expr = plot_call + facet_grid(~ reorder(categorical_var_name, order)),+ ref, |
||
| 777 | -! | +||
| 257 | +
- env = list(plot_call = plot_call, categorical_var_name = as.name(categorical_var))+ vars, |
||
| 778 | +258 |
- )+ plot_height, |
|
| 779 | +259 |
- }+ plot_width, |
|
| 780 | +260 |
-
+ ggplot2_args) {
|
|
| 781 | +261 | ! |
- dev_ggplot2_args <- teal.widgets::ggplot2_args(+ with_reporter <- !missing(reporter) && inherits(reporter, "Reporter") |
| 782 | +262 | ! |
- labs = list(color = "Is outlier?"),+ with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI") |
| 783 | +263 | ! |
- theme = list(legend.position = "top")+ checkmate::assert_class(data, "reactive") |
| 784 | -+ | ||
| 264 | +! |
- )+ checkmate::assert_class(isolate(data()), "teal_data") |
|
| 785 | +265 | ||
| 786 | +266 | ! |
- all_ggplot2_args <- teal.widgets::resolve_ggplot2_args(+ moduleServer(id, function(input, output, session) {
|
| 787 | +267 | ! |
- user_plot = ggplot2_args[["Density Plot"]],+ selector_list <- teal.transform::data_extract_multiple_srv( |
| 788 | +268 | ! |
- user_default = ggplot2_args$default,+ data_extract = list(ref = ref, vars = vars), |
| 789 | +269 | ! |
- module_plot = dev_ggplot2_args+ datasets = data, |
| 790 | -+ | ||
| 270 | +! |
- )+ select_validation_rule = list( |
|
| 791 | -+ | ||
| 271 | +! |
-
+ ref = shinyvalidate::compose_rules( |
|
| 792 | +272 | ! |
- parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(+ shinyvalidate::sv_required("A reference variable needs to be selected."),
|
| 793 | +273 | ! |
- all_ggplot2_args,+ ~ if ((.) %in% selector_list()$vars()$select) {
|
| 794 | +274 | ! |
- ggtheme = input$ggtheme+ "Associated variables and reference variable cannot overlap" |
| 795 | +275 |
- )+ } |
|
| 796 | +276 |
-
+ ), |
|
| 797 | +277 | ! |
- teal.code::eval_code(+ vars = shinyvalidate::compose_rules( |
| 798 | +278 | ! |
- common_code_q(),+ shinyvalidate::sv_required("An associated variable needs to be selected."),
|
| 799 | +279 | ! |
- substitute(+ ~ if (length(selector_list()$ref()$select) != 0 && selector_list()$ref()$select %in% (.)) {
|
| 800 | +280 | ! |
- expr = g <- plot_call + labs + ggthemes + themes,+ "Associated variables and reference variable cannot overlap" |
| 801 | -! | +||
| 281 | +
- env = list(+ } |
||
| 802 | -! | +||
| 282 | +
- plot_call = plot_call,+ )+ |
+ ||
| 283 | ++ |
+ )+ |
+ |
| 284 | ++ |
+ )+ |
+ |
| 285 | ++ | + | |
| 803 | +286 | ! |
- labs = parsed_ggplot2_args$labs,+ iv_r <- reactive({
|
| 804 | +287 | ! |
- themes = parsed_ggplot2_args$theme,+ iv <- shinyvalidate::InputValidator$new() |
| 805 | +288 | ! |
- ggthemes = parsed_ggplot2_args$ggtheme+ teal.transform::compose_and_enable_validators(iv, selector_list) |
| 806 | +289 |
- )+ }) |
|
| 807 | +290 |
- )+ |
|
| 808 | -+ | ||
| 291 | +! |
- ) %>%+ anl_merged_input <- teal.transform::merge_expression_srv( |
|
| 809 | +292 | ! |
- teal.code::eval_code(quote(print(g)))+ datasets = data, |
| 810 | -+ | ||
| 293 | +! |
- })+ selector_list = selector_list |
|
| 811 | +294 |
-
+ ) |
|
| 812 | +295 |
- # Cumulative distribution plot+ |
|
| 813 | +296 | ! |
- cumulative_plot_q <- reactive({
+ anl_merged_q <- reactive({
|
| 814 | +297 | ! |
- ANL <- common_code_q()[["ANL"]] # nolint: object_name.+ req(anl_merged_input()) |
| 815 | +298 | ! |
- ANL_OUTLIER <- common_code_q()[["ANL_OUTLIER"]] # nolint: object_name.+ data() %>% teal.code::eval_code(as.expression(anl_merged_input()$expr)) |
| 816 | +299 | - - | -|
| 817 | -! | -
- qenv <- common_code_q()+ }) |
|
| 818 | +300 | ||
| 819 | +301 | ! |
- outlier_var <- as.vector(merged$anl_input_r()$columns_source$outlier_var)+ merged <- list( |
| 820 | +302 | ! |
- categorical_var <- as.vector(merged$anl_input_r()$columns_source$categorical_var)+ anl_input_r = anl_merged_input,+ |
+
| 303 | +! | +
+ anl_q_r = anl_merged_q |
|
| 821 | +304 |
-
+ ) |
|
| 822 | +305 |
- # validation+ |
|
| 823 | +306 | ! |
- teal::validate_has_data(ANL, 1)+ output_q <- reactive({
|
| 824 | -+ | ||
| 307 | +! |
-
+ teal::validate_inputs(iv_r()) |
|
| 825 | +308 |
- # plot+ |
|
| 826 | +309 | ! |
- plot_call <- substitute(+ ANL <- merged$anl_q_r()[["ANL"]] # nolint: object_name. |
| 827 | +310 | ! |
- expr = ANL %>% ggplot(aes(x = outlier_var_name)) ++ teal::validate_has_data(ANL, 3) |
| 828 | -! | +||
| 311 | +
- stat_ecdf(),+ |
||
| 829 | +312 | ! |
- env = list(outlier_var_name = as.name(outlier_var))+ vars_names <- merged$anl_input_r()$columns_source$vars |
| 830 | +313 |
- )+ |
|
| 831 | +314 | ! |
- if (length(categorical_var) == 0) {
+ ref_name <- as.vector(merged$anl_input_r()$columns_source$ref) |
| 832 | +315 | ! |
- qenv <- teal.code::eval_code(+ association <- input$association |
| 833 | +316 | ! |
- qenv,+ show_dist <- input$show_dist |
| 834 | +317 | ! |
- substitute(+ log_transformation <- input$log_transformation |
| 835 | +318 | ! |
- expr = {
+ rotate_xaxis_labels <- input$rotate_xaxis_labels |
| 836 | +319 | ! |
- ecdf_df <- ANL %>%+ swap_axes <- input$swap_axes |
| 837 | +320 | ! |
- dplyr::mutate(+ distribution_theme <- input$distribution_theme |
| 838 | +321 | ! |
- y = stats::ecdf(ANL[[outlier_var]])(ANL[[outlier_var]])- |
-
| 839 | -- |
- )+ association_theme <- input$association_theme |
|
| 840 | +322 | ||
| 841 | +323 | ! |
- outlier_points <- dplyr::left_join(+ is_scatterplot <- is.numeric(ANL[[ref_name]]) && any(vapply(ANL[vars_names], is.numeric, logical(1))) |
| 842 | +324 | ! |
- ecdf_df,+ if (is_scatterplot) {
|
| 843 | +325 | ! |
- ANL_OUTLIER,+ shinyjs::show("alpha")
|
| 844 | +326 | ! |
- by = dplyr::setdiff(names(ecdf_df), "y")+ shinyjs::show("size")
|
| 845 | -+ | ||
| 327 | +! |
- ) %>%+ alpha <- input$alpha |
|
| 846 | +328 | ! |
- dplyr::filter(!is.na(is_outlier_selected))+ size <- input$size |
| 847 | +329 |
- },+ } else {
|
|
| 848 | +330 | ! |
- env = list(outlier_var = outlier_var)+ shinyjs::hide("alpha")
|
| 849 | -+ | ||
| 331 | +! |
- )+ shinyjs::hide("size")
+ |
+ |
| 332 | +! | +
+ alpha <- 0.5+ |
+ |
| 333 | +! | +
+ size <- 2 |
|
| 850 | +334 |
- )+ } |
|
| 851 | +335 |
- } else {
+
|
|
| 852 | +336 | ! |
- qenv <- teal.code::eval_code(+ teal::validate_has_data(ANL[, c(ref_name, vars_names)], 3, complete = TRUE, allow_inf = FALSE) |
| 853 | -! | +||
| 337 | +
- qenv,+ |
||
| 854 | -! | +||
| 338 | +
- substitute(+ # reference |
||
| 855 | +339 | ! |
- expr = {
+ ref_class <- class(ANL[[ref_name]]) |
| 856 | +340 | ! |
- all_categories <- lapply(+ if (is.numeric(ANL[[ref_name]]) && log_transformation) {
|
| 857 | -! | +||
| 341 | +
- unique(ANL[[categorical_var]]),+ # works for both integers and doubles |
||
| 858 | +342 | ! |
- function(x) {
+ ref_cl_name <- call("log", as.name(ref_name))
|
| 859 | +343 | ! |
- ANL <- ANL %>% dplyr::filter(get(categorical_var) == x) # nolint: object_name.+ ref_cl_lbl <- varname_w_label(ref_name, ANL, prefix = "Log of ") |
| 860 | -! | +||
| 344 | +
- anl_outlier2 <- ANL_OUTLIER %>% dplyr::filter(get(categorical_var) == x)+ } else {
+ |
+ ||
| 345 | ++ |
+ # silently ignore when non-numeric even if `log` is selected because some+ |
+ |
| 346 | ++ |
+ # variables may be numeric and others not |
|
| 861 | +347 | ! |
- ecdf_df <- ANL %>%+ ref_cl_name <- as.name(ref_name) |
| 862 | +348 | ! |
- dplyr::mutate(y = stats::ecdf(ANL[[outlier_var]])(ANL[[outlier_var]]))+ ref_cl_lbl <- varname_w_label(ref_name, ANL) |
| 863 | +349 | ++ |
+ }+ |
+
| 350 | |||
| 864 | +351 | ! |
- dplyr::left_join(+ user_ggplot2_args <- teal.widgets::resolve_ggplot2_args( |
| 865 | +352 | ! |
- ecdf_df,+ user_plot = ggplot2_args[["Bivariate1"]], |
| 866 | +353 | ! |
- anl_outlier2,+ user_default = ggplot2_args$default |
| 867 | -! | +||
| 354 | +
- by = dplyr::setdiff(names(ecdf_df), "y")+ ) |
||
| 868 | +355 |
- ) %>%+ |
|
| 869 | +356 | ! |
- dplyr::filter(!is.na(is_outlier_selected))+ ref_call <- bivariate_plot_call( |
| 870 | -+ | ||
| 357 | +! |
- }+ data_name = "ANL", |
|
| 871 | -+ | ||
| 358 | +! |
- )+ x = ref_cl_name, |
|
| 872 | +359 | ! |
- outlier_points <- do.call(rbind, all_categories)+ x_class = ref_class, |
| 873 | -+ | ||
| 360 | +! |
- },+ x_label = ref_cl_lbl, |
|
| 874 | +361 | ! |
- env = list(categorical_var = categorical_var, outlier_var = outlier_var)+ freq = !show_dist, |
| 875 | -+ | ||
| 362 | +! |
- )+ theme = distribution_theme, |
|
| 876 | -+ | ||
| 363 | +! |
- )+ rotate_xaxis_labels = rotate_xaxis_labels, |
|
| 877 | +364 | ! |
- plot_call <- substitute(+ swap_axes = FALSE, |
| 878 | +365 | ! |
- expr = plot_call + facet_grid(~ reorder(categorical_var_name, order)),+ size = size, |
| 879 | +366 | ! |
- env = list(plot_call = plot_call, categorical_var_name = as.name(categorical_var))+ alpha = alpha,+ |
+
| 367 | +! | +
+ ggplot2_args = user_ggplot2_args |
|
| 880 | +368 |
- )+ ) |
|
| 881 | +369 |
- }+ |
|
| 882 | +370 | ++ |
+ # association+ |
+
| 371 | +! | +
+ ref_class_cov <- ifelse(association, ref_class, "NULL")+ |
+ |
| 372 | |||
| 883 | +373 | ! |
- dev_ggplot2_args <- teal.widgets::ggplot2_args(+ print_call <- quote(print(p))+ |
+
| 374 | ++ | + | |
| 884 | +375 | ! |
- labs = list(color = "Is outlier?"),+ var_calls <- lapply(vars_names, function(var_i) {
|
| 885 | +376 | ! |
- theme = list(legend.position = "top")+ var_class <- class(ANL[[var_i]]) |
| 886 | -+ | ||
| 377 | +! |
- )+ if (is.numeric(ANL[[var_i]]) && log_transformation) {
|
|
| 887 | +378 |
-
+ # works for both integers and doubles |
|
| 888 | +379 | ! |
- all_ggplot2_args <- teal.widgets::resolve_ggplot2_args(+ var_cl_name <- call("log", as.name(var_i))
|
| 889 | +380 | ! |
- user_plot = ggplot2_args[["Cumulative Distribution Plot"]],+ var_cl_lbl <- varname_w_label(var_i, ANL, prefix = "Log of ")+ |
+
| 381 | ++ |
+ } else {
+ |
+ |
| 382 | ++ |
+ # silently ignore when non-numeric even if `log` is selected because some+ |
+ |
| 383 | ++ |
+ # variables may be numeric and others not |
|
| 890 | +384 | ! |
- user_default = ggplot2_args$default,+ var_cl_name <- as.name(var_i) |
| 891 | +385 | ! |
- module_plot = dev_ggplot2_args+ var_cl_lbl <- varname_w_label(var_i, ANL) |
| 892 | +386 |
- )+ } |
|
| 893 | +387 | ||
| 894 | +388 | ! |
- parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(+ user_ggplot2_args <- teal.widgets::resolve_ggplot2_args( |
| 895 | +389 | ! |
- all_ggplot2_args,+ user_plot = ggplot2_args[["Bivariate2"]], |
| 896 | +390 | ! |
- ggtheme = input$ggtheme+ user_default = ggplot2_args$default |
| 897 | +391 |
- )+ ) |
|
| 898 | +392 | ||
| 899 | +393 | ! |
- teal.code::eval_code(+ bivariate_plot_call( |
| 900 | +394 | ! |
- qenv,+ data_name = "ANL", |
| 901 | +395 | ! |
- substitute(+ x = ref_cl_name, |
| 902 | +396 | ! |
- expr = g <- plot_call ++ y = var_cl_name, |
| 903 | +397 | ! |
- geom_point(data = outlier_points, aes(x = outlier_var_name, y = y, color = is_outlier_selected)) ++ x_class = ref_class_cov, |
| 904 | +398 | ! |
- scale_color_manual(values = c("TRUE" = "red", "FALSE" = "black")) +
+ y_class = var_class, |
| 905 | +399 | ! |
- labs + ggthemes + themes,+ x_label = ref_cl_lbl, |
| 906 | +400 | ! |
- env = list(+ y_label = var_cl_lbl, |
| 907 | +401 | ! |
- plot_call = plot_call,+ theme = association_theme, |
| 908 | +402 | ! |
- outlier_var_name = as.name(outlier_var),+ freq = !show_dist, |
| 909 | +403 | ! |
- labs = parsed_ggplot2_args$labs,+ rotate_xaxis_labels = rotate_xaxis_labels, |
| 910 | +404 | ! |
- themes = parsed_ggplot2_args$theme,+ swap_axes = swap_axes, |
| 911 | +405 | ! |
- ggthemes = parsed_ggplot2_args$ggtheme+ alpha = alpha, |
| 912 | -+ | ||
| 406 | +! |
- )+ size = size, |
|
| 913 | -+ | ||
| 407 | +! |
- )+ ggplot2_args = user_ggplot2_args |
|
| 914 | +408 |
- ) %>%+ ) |
|
| 915 | -! | +||
| 409 | +
- teal.code::eval_code(quote(print(g)))+ }) |
||
| 916 | +410 |
- })+ |
|
| 917 | +411 |
-
+ # helper function to format variable name |
|
| 918 | +412 | ! |
- final_q <- reactive({
+ format_varnames <- function(x) {
|
| 919 | +413 | ! |
- req(input$tabs)+ if (is.numeric(ANL[[x]]) && log_transformation) {
|
| 920 | +414 | ! |
- tab_type <- input$tabs+ varname_w_label(x, ANL, prefix = "Log of ")+ |
+
| 415 | ++ |
+ } else {
|
|
| 921 | +416 | ! |
- result_q <- if (tab_type == "Boxplot") {
+ varname_w_label(x, ANL)+ |
+
| 417 | ++ |
+ }+ |
+ |
| 418 | ++ |
+ } |
|
| 922 | +419 | ! |
- boxplot_q()+ new_title <- |
| 923 | +420 | ! |
- } else if (tab_type == "Density Plot") {
+ if (association) {
|
| 924 | +421 | ! |
- density_plot_q()+ switch(as.character(length(vars_names)), |
| 925 | +422 | ! |
- } else if (tab_type == "Cumulative Distribution Plot") {
+ "0" = sprintf("Value distribution for %s", ref_cl_lbl),
|
| 926 | +423 | ! |
- cumulative_plot_q()+ "1" = sprintf( |
| 927 | -+ | ||
| 424 | +! |
- }+ "Association between %s and %s", |
|
| 928 | -+ | ||
| 425 | +! |
- # used to display table when running show-r-code code+ ref_cl_lbl, |
|
| 929 | -+ | ||
| 426 | +! |
- # added after the plots so that a change in selected columns doesn't affect+ format_varnames(vars_names) |
|
| 930 | +427 |
- # brush selection.+ ), |
|
| 931 | +428 | ! |
- teal.code::eval_code(+ sprintf( |
| 932 | +429 | ! |
- result_q,+ "Associations between %s and: %s", |
| 933 | +430 | ! |
- substitute(+ ref_cl_lbl, |
| 934 | +431 | ! |
- expr = {
+ paste(lapply(vars_names, format_varnames), collapse = ", ") |
| 935 | -! | -
- columns_index <- union(- |
- |
| 936 | -! | +||
| 432 | +
- setdiff(names(ANL_OUTLIER), "is_outlier_selected"),+ ) |
||
| 937 | -! | +||
| 433 | +
- table_columns+ ) |
||
| 938 | +434 |
- )+ } else {
|
|
| 939 | +435 | ! |
- ANL_OUTLIER_EXTENDED[ANL_OUTLIER_EXTENDED$is_outlier_selected, columns_index]+ switch(as.character(length(vars_names)), |
| 940 | -+ | ||
| 436 | +! |
- },+ "0" = sprintf("Value distribution for %s", ref_cl_lbl),
|
|
| 941 | +437 | ! |
- env = list(+ sprintf( |
| 942 | +438 | ! |
- table_columns = input$table_ui_columns+ "Value distributions for %s and %s", |
| 943 | -+ | ||
| 439 | +! |
- )+ ref_cl_lbl, |
|
| 944 | -+ | ||
| 440 | +! |
- )+ paste(lapply(vars_names, format_varnames), collapse = ", ") |
|
| 945 | +441 |
- )+ ) |
|
| 946 | +442 |
- })+ ) |
|
| 947 | +443 |
-
+ } |
|
| 948 | +444 |
- # slider text+ |
|
| 949 | +445 | ! |
- output$ui_outlier_help <- renderUI({
+ teal.code::eval_code( |
| 950 | +446 | ! |
- req(input$method)+ merged$anl_q_r(), |
| 951 | +447 | ! |
- if (input$method == "IQR") {
+ substitute( |
| 952 | +448 | ! |
- req(input$iqr_slider)+ expr = title <- new_title, |
| 953 | +449 | ! |
- tags$small(+ env = list(new_title = new_title) |
| 954 | -! | +||
| 450 | +
- withMathJax(+ ) |
||
| 955 | -! | +||
| 451 | +
- helpText(+ ) %>% |
||
| 956 | +452 | ! |
- "Outlier data points (\\(x \\lt Q1 - ", input$iqr_slider, "\\times IQR\\) or \\(+ teal.code::eval_code( |
| 957 | +453 | ! |
- Q3 + ", input$iqr_slider, "\\times IQR \\lt x\\))+ substitute( |
| 958 | +454 | ! |
- are displayed in red on the plot and can be visualized in the table below."- |
-
| 959 | -- |
- ),+ expr = {
|
|
| 960 | +455 | ! |
- if (input$split_outliers) {
+ plots <- plot_calls |
| 961 | +456 | ! |
- withMathJax(helpText("Note: Quantiles are calculated per group."))
- |
-
| 962 | -- |
- }- |
- |
| 963 | -- |
- )- |
- |
| 964 | -- |
- )+ p <- tern::stack_grobs(grobs = lapply(plots, ggplotGrob)) |
|
| 965 | +457 | ! |
- } else if (input$method == "Z-score") {
+ grid::grid.newpage() |
| 966 | +458 | ! |
- req(input$zscore_slider)+ grid::grid.draw(p) |
| 967 | -! | +||
| 459 | +
- tags$small(+ }, |
||
| 968 | +460 | ! |
- withMathJax(+ env = list( |
| 969 | +461 | ! |
- helpText(+ plot_calls = do.call( |
| 970 | +462 | ! |
- "Outlier data points (\\(Zscore(x) < -", input$zscore_slider,+ "call", |
| 971 | +463 | ! |
- "\\) or \\(", input$zscore_slider, "< Zscore(x) \\))
+ c(list("list", ref_call), var_calls),
|
| 972 | +464 | ! |
- are displayed in red on the plot and can be visualized in the table below."+ quote = TRUE |
| 973 | +465 |
- ),+ ) |
|
| 974 | -! | +||
| 466 | +
- if (input$split_outliers) {
+ ) |
||
| 975 | -! | +||
| 467 | +
- withMathJax(helpText(" Note: Z-scores are calculated per group."))
+ ) |
||
| 976 | +468 |
- }+ ) |
|
| 977 | +469 |
- )+ }) |
|
| 978 | +470 |
- )+ |
|
| 979 | +471 | ! |
- } else if (input$method == "Percentile") {
+ plot_r <- shiny::reactive({
|
| 980 | +472 | ! |
- req(input$percentile_slider)+ shiny::req(iv_r()$is_valid()) |
| 981 | +473 | ! |
- tags$small(+ output_q()[["p"]] |
| 982 | -! | +||
| 474 | +
- withMathJax(+ }) |
||
| 983 | -! | +||
| 475 | +
- helpText(+ |
||
| 984 | +476 | ! |
- "Outlier/extreme data points (\\( Percentile(x) <", input$percentile_slider,+ pws <- teal.widgets::plot_with_settings_srv( |
| 985 | +477 | ! |
- "\\) or \\(", 1 - input$percentile_slider, " < Percentile(x) \\))
+ id = "myplot", |
| 986 | +478 | ! |
- are displayed in red on the plot and can be visualized in the table below."- |
-
| 987 | -- |
- ),+ plot_r = plot_r, |
|
| 988 | +479 | ! |
- if (input$split_outliers) {
+ height = plot_height, |
| 989 | +480 | ! |
- withMathJax(helpText("Note: Percentiles are calculated per group."))
+ width = plot_width |
| 990 | +481 |
- }+ ) |
|
| 991 | +482 |
- )+ |
|
| 992 | -+ | ||
| 483 | +! |
- )+ output$title <- renderText({
|
|
| 993 | -+ | ||
| 484 | +! |
- }+ teal.code::dev_suppress(output_q()[["title"]]) |
|
| 994 | +485 |
}) |
|
| 995 | +486 | ||
| 996 | +487 | ! |
- boxplot_r <- reactive({
+ teal.widgets::verbatim_popup_srv( |
| 997 | +488 | ! |
- teal::validate_inputs(iv_r())+ id = "warning", |
| 998 | +489 | ! |
- boxplot_q()[["g"]]- |
-
| 999 | -- |
- })+ verbatim_content = reactive(teal.code::get_warnings(output_q())), |
|
| 1000 | +490 | ! |
- density_plot_r <- reactive({
+ title = "Warning", |
| 1001 | +491 | ! |
- teal::validate_inputs(iv_r())+ disabled = reactive(is.null(teal.code::get_warnings(output_q()))) |
| 1002 | -! | +||
| 492 | +
- density_plot_q()[["g"]]+ ) |
||
| 1003 | +493 |
- })+ |
|
| 1004 | +494 | ! |
- cumulative_plot_r <- reactive({
+ teal.widgets::verbatim_popup_srv( |
| 1005 | +495 | ! |
- teal::validate_inputs(iv_r())+ id = "rcode", |
| 1006 | +496 | ! |
- cumulative_plot_q()[["g"]]+ verbatim_content = reactive(teal.code::get_code(output_q())),+ |
+
| 497 | +! | +
+ title = "Association Plot" |
|
| 1007 | +498 |
- })+ ) |
|
| 1008 | +499 | ||
| 500 | ++ |
+ ### REPORTER+ |
+ |
| 1009 | +501 | ! |
- box_pws <- teal.widgets::plot_with_settings_srv(+ if (with_reporter) {
|
| 1010 | +502 | ! |
- id = "box_plot",+ card_fun <- function(comment, label) {
|
| 1011 | +503 | ! |
- plot_r = boxplot_r,+ card <- teal::report_card_template( |
| 1012 | +504 | ! |
- height = plot_height,+ title = "Association Plot", |
| 1013 | +505 | ! |
- width = plot_width,+ label = label, |
| 1014 | +506 | ! |
- brushing = TRUE+ with_filter = with_filter, |
| 1015 | -+ | ||
| 507 | +! |
- )+ filter_panel_api = filter_panel_api |
|
| 1016 | +508 | - - | -|
| 1017 | -! | -
- density_pws <- teal.widgets::plot_with_settings_srv(+ ) |
|
| 1018 | +509 | ! |
- id = "density_plot",+ card$append_text("Plot", "header3")
|
| 1019 | +510 | ! |
- plot_r = density_plot_r,+ card$append_plot(plot_r(), dim = pws$dim()) |
| 1020 | +511 | ! |
- height = plot_height,+ if (!comment == "") {
|
| 1021 | +512 | ! |
- width = plot_width,+ card$append_text("Comment", "header3")
|
| 1022 | +513 | ! |
- brushing = TRUE- |
-
| 1023 | -- |
- )+ card$append_text(comment) |
|
| 1024 | +514 | - - | -|
| 1025 | -! | -
- cum_density_pws <- teal.widgets::plot_with_settings_srv(- |
- |
| 1026 | -! | -
- id = "cum_density_plot",+ } |
|
| 1027 | +515 | ! |
- plot_r = cumulative_plot_r,+ card$append_src(teal.code::get_code(output_q())) |
| 1028 | +516 | ! |
- height = plot_height,+ card |
| 1029 | -! | +||
| 517 | +
- width = plot_width,+ } |
||
| 1030 | +518 | ! |
- brushing = TRUE+ teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
|
| 1031 | +519 |
- )+ } |
|
| 1032 | +520 |
-
+ ### |
|
| 1033 | -! | +||
| 521 | +
- choices <- teal.transform::variable_choices(data()[[dataname_first]])+ }) |
||
| 1034 | +522 |
-
+ } |
|
| 1035 | -! | +
| 1 | +
- observeEvent(common_code_q(), {
+ #' Create a simple scatterplot |
||
| 1036 | -! | +||
| 2 | +
- ANL_OUTLIER <- common_code_q()[["ANL_OUTLIER"]] # nolint: object_name.+ #' |
||
| 1037 | -! | +||
| 3 | +
- teal.widgets::updateOptionalSelectInput(+ #' Create a plot with the \code{\link{ggplot2}[geom_point]} function
|
||
| 1038 | -! | +||
| 4 | +
- session,+ #' @md |
||
| 1039 | -! | +||
| 5 | +
- inputId = "table_ui_columns",+ #' |
||
| 1040 | -! | +||
| 6 | +
- choices = dplyr::setdiff(choices, names(ANL_OUTLIER)),+ #' @inheritParams teal::module |
||
| 1041 | -! | +||
| 7 | +
- selected = isolate(input$table_ui_columns)+ #' @inheritParams shared_params |
||
| 1042 | +8 |
- )+ #' @param x (`data_extract_spec` or `list` of multiple `data_extract_spec`) Variable |
|
| 1043 | +9 |
- })+ #' names selected to plot along the x-axis by default. |
|
| 1044 | +10 |
-
+ #' @param y (`data_extract_spec` or `list` of multiple `data_extract_spec`) Variable |
|
| 1045 | -! | +||
| 11 | +
- output$table_ui <- DT::renderDataTable(+ #' names selected to plot along the y-axis by default. |
||
| 1046 | -! | +||
| 12 | +
- expr = {
+ #' @param color_by optional (`data_extract_spec` or `list` of multiple `data_extract_spec`) |
||
| 1047 | -! | +||
| 13 | +
- tab <- input$tabs+ #' Defines the color encoding. If `NULL` then no color encoding option will be displayed. |
||
| 1048 | -! | +||
| 14 | +
- req(tab) # tab is NULL upon app launch, hence will crash without this statement+ #' @param size_by optional (`data_extract_spec` or `list` of multiple `data_extract_spec`) |
||
| 1049 | -! | +||
| 15 | +
- outlier_var <- as.vector(merged$anl_input_r()$columns_source$outlier_var)+ #' Defines the point size encoding. If `NULL` then no size encoding option will be displayed. |
||
| 1050 | -! | +||
| 16 | +
- categorical_var <- as.vector(merged$anl_input_r()$columns_source$categorical_var)+ #' @param row_facet optional, (`data_extract_spec` or `list` of multiple `data_extract_spec`) |
||
| 1051 | +17 |
-
+ #' Which data columns to use for faceting rows. |
|
| 1052 | -! | +||
| 18 | +
- ANL_OUTLIER <- common_code_q()[["ANL_OUTLIER"]] # nolint: object_name.+ #' @param col_facet optional, (`data_extract_spec` or `list` of multiple `data_extract_spec`) |
||
| 1053 | -! | +||
| 19 | +
- ANL_OUTLIER_EXTENDED <- common_code_q()[["ANL_OUTLIER_EXTENDED"]] # nolint: object_name.+ #' Which data to use for faceting columns. |
||
| 1054 | -! | +||
| 20 | +
- ANL <- common_code_q()[["ANL"]] # nolint: object_name.+ #' @param alpha optional, (`numeric`) If scalar then the plot points will have a fixed opacity. If a |
||
| 1055 | -! | +||
| 21 | +
- plot_brush <- if (tab == "Boxplot") {
+ #' slider should be presented to adjust the plot point opacity dynamically then it can be a vector of |
||
| 1056 | -! | +||
| 22 | +
- boxplot_r()+ #' length three with `c(value, min, max)`. |
||
| 1057 | -! | +||
| 23 | +
- box_pws$brush()+ #' @param size optional, (`numeric`) If scalar then the plot point sizes will have a fixed size |
||
| 1058 | -! | +||
| 24 | +
- } else if (tab == "Density Plot") {
+ #' If a slider should be presented to adjust the plot point sizes dynamically then it can be a |
||
| 1059 | -! | +||
| 25 | +
- density_plot_r()+ #' vector of length three with `c(value, min, max)`. |
||
| 1060 | -! | +||
| 26 | +
- density_pws$brush()+ #' @param shape optional, (`character`) A character vector with the English names of the |
||
| 1061 | -! | +||
| 27 | +
- } else if (tab == "Cumulative Distribution Plot") {
+ #' shape, e.g. `c("triangle", "square", "circle")`. It defaults to `shape_names`. This is a complete list from
|
||
| 1062 | -! | +||
| 28 | +
- cumulative_plot_r()+ #' `vignette("ggplot2-specs", package="ggplot2")`.
|
||
| 1063 | -! | +||
| 29 | +
- cum_density_pws$brush()+ #' @param max_deg optional, (`integer`) The maximum degree for the polynomial trend line. Must not be less than 1. |
||
| 1064 | +30 |
- }+ #' @param table_dec optional, (`integer`) Number of decimal places used to round numeric values in the table. |
|
| 1065 | +31 |
-
+ #' |
|
| 1066 | +32 |
- # removing unused column ASAP+ #' |
|
| 1067 | -! | +||
| 33 | +
- ANL_OUTLIER$order <- ANL$order <- NULL # nolint: object_name.+ #' @note For more examples, please see the vignette "Using scatterplot" via |
||
| 1068 | +34 |
-
+ #' `vignette("using-scatterplot", package = "teal.modules.general")`.
|
|
| 1069 | -! | +||
| 35 | +
- display_table <- if (!is.null(plot_brush)) {
+ #' |
||
| 1070 | -! | +||
| 36 | +
- if (length(categorical_var) > 0) {
+ #' @examples |
||
| 1071 | +37 |
- # due to reordering, the x-axis label may be changed to something like "reorder(categorical_var, order)"+ #' # general data example |
|
| 1072 | -! | +||
| 38 | +
- if (tab == "Boxplot") {
+ #' library(teal.widgets) |
||
| 1073 | -! | +||
| 39 | +
- plot_brush$mapping$x <- categorical_var+ #' |
||
| 1074 | +40 |
- } else {
+ #' data <- teal_data() |
|
| 1075 | +41 |
- # the other plots use facetting+ #' data <- within(data, {
|
|
| 1076 | +42 |
- # so it is panelvar1 that gets relabelled to "reorder(categorical_var, order)"+ #' library(nestcolor) |
|
| 1077 | -! | +||
| 43 | +
- plot_brush$mapping$panelvar1 <- categorical_var+ #' CO2 <- CO2 |
||
| 1078 | +44 |
- }+ #' }) |
|
| 1079 | +45 |
- } else {
+ #' datanames(data) <- "CO2" |
|
| 1080 | -! | +||
| 46 | +
- if (tab == "Boxplot") {
+ #' |
||
| 1081 | +47 |
- # in boxplot with no categorical variable, there is no column in ANL that would correspond to x-axis+ #' app <- init( |
|
| 1082 | +48 |
- # so a column needs to be inserted with the value "Entire dataset" because that's the label used in plot+ #' data = data, |
|
| 1083 | -! | +||
| 49 | +
- ANL[[plot_brush$mapping$x]] <- "Entire dataset" # nolint: object_name.+ #' modules = modules( |
||
| 1084 | +50 |
- }+ #' tm_g_scatterplot( |
|
| 1085 | +51 |
- }+ #' label = "Scatterplot Choices", |
|
| 1086 | +52 |
-
+ #' x = data_extract_spec( |
|
| 1087 | +53 |
- # in density and cumulative plots, ANL does not have a column corresponding to y-axis.+ #' dataname = "CO2", |
|
| 1088 | +54 |
- # so they need to be computed and attached to ANL+ #' select = select_spec( |
|
| 1089 | -! | +||
| 55 | +
- if (tab == "Density Plot") {
+ #' label = "Select variable:", |
||
| 1090 | -! | +||
| 56 | +
- plot_brush$mapping$y <- "density"+ #' choices = variable_choices(data[["CO2"]], c("conc", "uptake")),
|
||
| 1091 | -! | +||
| 57 | +
- ANL$density <- plot_brush$ymin # nolint: object_name.+ #' selected = "conc", |
||
| 1092 | +58 |
- # either ymin or ymax will work+ #' multiple = FALSE, |
|
| 1093 | -! | +||
| 59 | +
- } else if (tab == "Cumulative Distribution Plot") {
+ #' fixed = FALSE |
||
| 1094 | -! | +||
| 60 | +
- plot_brush$mapping$y <- "cdf"+ #' ) |
||
| 1095 | -! | +||
| 61 | +
- if (length(categorical_var) > 0) {
+ #' ), |
||
| 1096 | -! | +||
| 62 | +
- ANL <- ANL %>% # nolint: object_name.+ #' y = data_extract_spec( |
||
| 1097 | -! | +||
| 63 | +
- dplyr::group_by(!!as.name(plot_brush$mapping$panelvar1)) %>%+ #' dataname = "CO2", |
||
| 1098 | -! | +||
| 64 | +
- dplyr::mutate(cdf = stats::ecdf(!!as.name(outlier_var))(!!as.name(outlier_var)))+ #' select = select_spec( |
||
| 1099 | +65 |
- } else {
+ #' label = "Select variable:", |
|
| 1100 | -! | +||
| 66 | +
- ANL$cdf <- stats::ecdf(ANL[[outlier_var]])(ANL[[outlier_var]]) # nolint: object_name.+ #' choices = variable_choices(data[["CO2"]], c("conc", "uptake")),
|
||
| 1101 | +67 |
- }+ #' selected = "uptake", |
|
| 1102 | +68 |
- }+ #' multiple = FALSE, |
|
| 1103 | +69 |
-
+ #' fixed = FALSE |
|
| 1104 | -! | +||
| 70 | +
- brushed_rows <- brushedPoints(ANL, plot_brush)+ #' ) |
||
| 1105 | -! | +||
| 71 | +
- if (nrow(brushed_rows) > 0) {
+ #' ), |
||
| 1106 | +72 |
- # now we need to remove extra column from ANL so that it will have the same columns as ANL_OUTLIER+ #' color_by = data_extract_spec( |
|
| 1107 | +73 |
- # so that dplyr::intersect will work+ #' dataname = "CO2", |
|
| 1108 | -! | +||
| 74 | +
- if (tab == "Density Plot") {
+ #' select = select_spec( |
||
| 1109 | -! | +||
| 75 | +
- brushed_rows$density <- NULL+ #' label = "Select variable:", |
||
| 1110 | -! | +||
| 76 | +
- } else if (tab == "Cumulative Distribution Plot") {
+ #' choices = variable_choices( |
||
| 1111 | -! | +||
| 77 | +
- brushed_rows$cdf <- NULL+ #' data[["CO2"]], |
||
| 1112 | -! | +||
| 78 | +
- } else if (tab == "Boxplot" && length(categorical_var) == 0) {
+ #' c("Plant", "Type", "Treatment", "conc", "uptake")
|
||
| 1113 | -! | +||
| 79 | +
- brushed_rows[[plot_brush$mapping$x]] <- NULL+ #' ), |
||
| 1114 | +80 |
- }+ #' selected = NULL, |
|
| 1115 | +81 |
- # is_outlier_selected is part of ANL_OUTLIER so needed here+ #' multiple = FALSE, |
|
| 1116 | -! | +||
| 82 | +
- brushed_rows$is_outlier_selected <- TRUE+ #' fixed = FALSE |
||
| 1117 | -! | +||
| 83 | +
- dplyr::intersect(ANL_OUTLIER, brushed_rows)+ #' ) |
||
| 1118 | +84 |
- } else {
+ #' ), |
|
| 1119 | -! | +||
| 85 | +
- ANL_OUTLIER[0, ]+ #' size_by = data_extract_spec( |
||
| 1120 | +86 |
- }+ #' dataname = "CO2", |
|
| 1121 | +87 |
- } else {
+ #' select = select_spec( |
|
| 1122 | -! | +||
| 88 | +
- ANL_OUTLIER[ANL_OUTLIER$is_outlier_selected, ]+ #' label = "Select variable:", |
||
| 1123 | +89 |
- }+ #' choices = variable_choices(data[["CO2"]], c("conc", "uptake")),
|
|
| 1124 | +90 |
-
+ #' selected = "uptake", |
|
| 1125 | -! | +||
| 91 | +
- display_table$is_outlier_selected <- NULL+ #' multiple = FALSE, |
||
| 1126 | +92 |
-
+ #' fixed = FALSE |
|
| 1127 | +93 |
- # Extend the brushed ANL_OUTLIER with additional columns+ #' ) |
|
| 1128 | -! | +||
| 94 | +
- dplyr::left_join(+ #' ), |
||
| 1129 | -! | +||
| 95 | +
- display_table,+ #' row_facet = data_extract_spec( |
||
| 1130 | -! | +||
| 96 | +
- dplyr::select(ANL_OUTLIER_EXTENDED, -"is_outlier_selected"),+ #' dataname = "CO2", |
||
| 1131 | -! | +||
| 97 | +
- by = names(display_table)+ #' select = select_spec( |
||
| 1132 | +98 |
- ) %>%+ #' label = "Select variable:", |
|
| 1133 | -! | +||
| 99 | +
- dplyr::select(union(names(display_table), input$table_ui_columns))+ #' choices = variable_choices(data[["CO2"]], c("Plant", "Type", "Treatment")),
|
||
| 1134 | +100 |
- },+ #' selected = NULL, |
|
| 1135 | -! | +||
| 101 | +
- options = list(+ #' multiple = FALSE, |
||
| 1136 | -! | +||
| 102 | +
- searching = FALSE, language = list(+ #' fixed = FALSE |
||
| 1137 | -! | +||
| 103 | +
- zeroRecords = "The brushed area does not contain outlier observations for the currently defined threshold"+ #' ) |
||
| 1138 | +104 |
- ),+ #' ), |
|
| 1139 | -! | +||
| 105 | +
- pageLength = input$table_ui_rows+ #' col_facet = data_extract_spec( |
||
| 1140 | +106 |
- )+ #' dataname = "CO2", |
|
| 1141 | +107 |
- )+ #' select = select_spec( |
|
| 1142 | +108 |
-
+ #' label = "Select variable:", |
|
| 1143 | -! | +||
| 109 | +
- output$total_outliers <- renderUI({
+ #' choices = variable_choices(data[["CO2"]], c("Plant", "Type", "Treatment")),
|
||
| 1144 | -! | +||
| 110 | +
- shiny::req(iv_r()$is_valid())+ #' selected = NULL, |
||
| 1145 | -! | +||
| 111 | +
- ANL <- merged$anl_q_r()[["ANL"]] # nolint: object_name.+ #' multiple = FALSE, |
||
| 1146 | -! | +||
| 112 | +
- ANL_OUTLIER <- common_code_q()[["ANL_OUTLIER"]] # nolint: object_name.+ #' fixed = FALSE |
||
| 1147 | -! | +||
| 113 | +
- teal::validate_has_data(ANL, 1)+ #' ) |
||
| 1148 | -! | +||
| 114 | +
- ANL_OUTLIER_SELECTED <- ANL_OUTLIER[ANL_OUTLIER$is_outlier_selected, ] # nolint: object_name.+ #' ), |
||
| 1149 | -! | +||
| 115 | +
- h5(+ #' ggplot2_args = ggplot2_args( |
||
| 1150 | -! | +||
| 116 | +
- sprintf(+ #' labs = list(subtitle = "Plot generated by Scatterplot Module") |
||
| 1151 | -! | +||
| 117 | +
- "%s %d / %d [%.02f%%]",+ #' ) |
||
| 1152 | -! | +||
| 118 | +
- "Total number of outlier(s):",+ #' ) |
||
| 1153 | -! | +||
| 119 | +
- nrow(ANL_OUTLIER_SELECTED),+ #' ) |
||
| 1154 | -! | +||
| 120 | +
- nrow(ANL),+ #' ) |
||
| 1155 | -! | +||
| 121 | +
- 100 * nrow(ANL_OUTLIER_SELECTED) / nrow(ANL)+ #' if (interactive()) {
|
||
| 1156 | +122 |
- )+ #' shinyApp(app$ui, app$server) |
|
| 1157 | +123 |
- )+ #' } |
|
| 1158 | +124 |
- })+ #' |
|
| 1159 | +125 |
-
+ #' |
|
| 1160 | -! | +||
| 126 | +
- output$total_missing <- renderUI({
+ #' # CDISC data example |
||
| 1161 | -! | +||
| 127 | +
- if (n_outlier_missing() > 0) {
+ #' library(teal.widgets) |
||
| 1162 | -! | +||
| 128 | +
- ANL <- merged$anl_q_r()[["ANL"]] # nolint: object_name.+ #' |
||
| 1163 | -! | +||
| 129 | +
- helpText(+ #' data <- teal_data() |
||
| 1164 | -! | +||
| 130 | +
- sprintf(+ #' data <- within(data, {
|
||
| 1165 | -! | +||
| 131 | +
- "%s %d / %d [%.02f%%]",+ #' library(nestcolor) |
||
| 1166 | -! | +||
| 132 | +
- "Total number of row(s) with missing values:",+ #' ADSL <- rADSL |
||
| 1167 | -! | +||
| 133 | +
- n_outlier_missing(),+ #' }) |
||
| 1168 | -! | +||
| 134 | +
- nrow(ANL),+ #' datanames(data) <- c("ADSL")
|
||
| 1169 | -! | +||
| 135 | +
- 100 * (n_outlier_missing()) / nrow(ANL)+ #' join_keys(data) <- default_cdisc_join_keys[datanames(data)] |
||
| 1170 | +136 |
- )+ #' |
|
| 1171 | +137 |
- )+ #' app <- init( |
|
| 1172 | +138 |
- }+ #' data = data, |
|
| 1173 | +139 |
- })+ #' modules = modules( |
|
| 1174 | +140 |
-
+ #' tm_g_scatterplot( |
|
| 1175 | -! | +||
| 141 | +
- output$table_ui_wrap <- renderUI({
+ #' label = "Scatterplot Choices", |
||
| 1176 | -! | +||
| 142 | +
- shiny::req(iv_r()$is_valid())+ #' x = data_extract_spec( |
||
| 1177 | -! | +||
| 143 | +
- tagList(+ #' dataname = "ADSL", |
||
| 1178 | -! | +||
| 144 | +
- teal.widgets::optionalSelectInput(+ #' select = select_spec( |
||
| 1179 | -! | +||
| 145 | +
- inputId = session$ns("table_ui_columns"),
+ #' label = "Select variable:", |
||
| 1180 | -! | +||
| 146 | +
- label = "Choose additional columns",+ #' choices = variable_choices(data[["ADSL"]], c("AGE", "BMRKR1", "BMRKR2")),
|
||
| 1181 | -! | +||
| 147 | +
- choices = NULL,+ #' selected = "AGE", |
||
| 1182 | -! | +||
| 148 | +
- selected = NULL,+ #' multiple = FALSE, |
||
| 1183 | -! | +||
| 149 | +
- multiple = TRUE+ #' fixed = FALSE |
||
| 1184 | +150 |
- ),+ #' ) |
|
| 1185 | -! | +||
| 151 | +
- h4("Outlier Table"),
+ #' ), |
||
| 1186 | -! | +||
| 152 | +
- teal.widgets::get_dt_rows(session$ns("table_ui"), session$ns("table_ui_rows")),
+ #' y = data_extract_spec( |
||
| 1187 | -! | +||
| 153 | +
- DT::dataTableOutput(session$ns("table_ui"))
+ #' dataname = "ADSL", |
||
| 1188 | +154 |
- )+ #' select = select_spec( |
|
| 1189 | +155 |
- })+ #' label = "Select variable:", |
|
| 1190 | +156 | - - | -|
| 1191 | -! | -
- teal.widgets::verbatim_popup_srv(- |
- |
| 1192 | -! | -
- id = "warning",- |
- |
| 1193 | -! | -
- verbatim_content = reactive(teal.code::get_warnings(final_q())),- |
- |
| 1194 | -! | -
- title = "Warning",- |
- |
| 1195 | -! | -
- disabled = reactive(is.null(teal.code::get_warnings(final_q())))+ #' choices = variable_choices(data[["ADSL"]], c("AGE", "BMRKR1", "BMRKR2")),
|
|
| 1196 | +157 |
- )+ #' selected = "BMRKR1", |
|
| 1197 | +158 | - - | -|
| 1198 | -! | -
- teal.widgets::verbatim_popup_srv(- |
- |
| 1199 | -! | -
- id = "rcode",- |
- |
| 1200 | -! | -
- verbatim_content = reactive(teal.code::get_code(final_q())),- |
- |
| 1201 | -! | -
- title = "Show R Code for Outlier"+ #' multiple = FALSE, |
|
| 1202 | +159 |
- )+ #' fixed = FALSE |
|
| 1203 | +160 |
-
+ #' ) |
|
| 1204 | +161 |
- ### REPORTER- |
- |
| 1205 | -! | -
- if (with_reporter) {
- |
- |
| 1206 | -! | -
- card_fun <- function(comment, label) {
- |
- |
| 1207 | -! | -
- tab_type <- input$tabs- |
- |
| 1208 | -! | -
- card <- teal::report_card_template(- |
- |
| 1209 | -! | -
- title = paste0("Outliers - ", tab_type),
- |
- |
| 1210 | -! | -
- label = label,+ #' ), |
|
| 1211 | -! | +||
| 162 | +
- with_filter = with_filter,+ #' color_by = data_extract_spec( |
||
| 1212 | -! | +||
| 163 | +
- filter_panel_api = filter_panel_api+ #' dataname = "ADSL", |
||
| 1213 | +164 |
- )+ #' select = select_spec( |
|
| 1214 | -! | +||
| 165 | +
- categorical_var <- as.vector(merged$anl_input_r()$columns_source$categorical_var)+ #' label = "Select variable:", |
||
| 1215 | -! | +||
| 166 | +
- if (length(categorical_var) > 0) {
+ #' choices = variable_choices( |
||
| 1216 | -! | +||
| 167 | +
- summary_table <- common_code_q()[["summary_table"]]+ #' data[["ADSL"]], |
||
| 1217 | -! | +||
| 168 | +
- card$append_text("Summary Table", "header3")
+ #' c("AGE", "BMRKR1", "BMRKR2", "RACE", "REGION1")
|
||
| 1218 | -! | +||
| 169 | +
- card$append_table(summary_table)+ #' ), |
||
| 1219 | +170 |
- }+ #' selected = NULL, |
|
| 1220 | -! | +||
| 171 | +
- card$append_text("Plot", "header3")
+ #' multiple = FALSE, |
||
| 1221 | -! | +||
| 172 | +
- if (tab_type == "Boxplot") {
+ #' fixed = FALSE |
||
| 1222 | -! | +||
| 173 | +
- card$append_plot(boxplot_r(), dim = box_pws$dim())+ #' ) |
||
| 1223 | -! | +||
| 174 | +
- } else if (tab_type == "Density Plot") {
+ #' ), |
||
| 1224 | -! | +||
| 175 | +
- card$append_plot(density_plot_r(), dim = density_pws$dim())+ #' size_by = data_extract_spec( |
||
| 1225 | -! | +||
| 176 | +
- } else if (tab_type == "Cumulative Distribution Plot") {
+ #' dataname = "ADSL", |
||
| 1226 | -! | +||
| 177 | +
- card$append_plot(cumulative_plot_r(), dim = cum_density_pws$dim())+ #' select = select_spec( |
||
| 1227 | +178 |
- }+ #' label = "Select variable:", |
|
| 1228 | -! | +||
| 179 | +
- if (!comment == "") {
+ #' choices = variable_choices(data[["ADSL"]], c("AGE", "BMRKR1")),
|
||
| 1229 | -! | +||
| 180 | +
- card$append_text("Comment", "header3")
+ #' selected = "AGE", |
||
| 1230 | -! | +||
| 181 | +
- card$append_text(comment)+ #' multiple = FALSE, |
||
| 1231 | +182 |
- }+ #' fixed = FALSE |
|
| 1232 | -! | +||
| 183 | +
- card$append_src(teal.code::get_code(final_q()))+ #' ) |
||
| 1233 | -! | +||
| 184 | +
- card+ #' ), |
||
| 1234 | +185 |
- }+ #' row_facet = data_extract_spec( |
|
| 1235 | -! | +||
| 186 | +
- teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
+ #' dataname = "ADSL", |
||
| 1236 | +187 |
- }+ #' select = select_spec( |
|
| 1237 | +188 |
- ###+ #' label = "Select variable:", |
|
| 1238 | +189 |
- })+ #' choices = variable_choices(data[["ADSL"]], c("BMRKR2", "RACE", "REGION1")),
|
|
| 1239 | +190 |
- }+ #' selected = NULL, |
| 1 | +191 |
- #' Response Plots+ #' multiple = FALSE, |
|
| 2 | +192 |
- #' @md+ #' fixed = FALSE |
|
| 3 | +193 |
- #'+ #' ) |
|
| 4 | +194 |
- #' @inheritParams teal::module+ #' ), |
|
| 5 | +195 |
- #' @inheritParams shared_params+ #' col_facet = data_extract_spec( |
|
| 6 | +196 |
- #' @param response (`data_extract_spec` or `list` of multiple `data_extract_spec`)+ #' dataname = "ADSL", |
|
| 7 | +197 |
- #' Which variable to use as the response. You can define one fixed column by using the+ #' select = select_spec( |
|
| 8 | +198 |
- #' setting `fixed = TRUE` inside the `select_spec`.+ #' label = "Select variable:", |
|
| 9 | +199 |
- #' `data_extract_spec` must not allow multiple selection in this case.+ #' choices = variable_choices(data[["ADSL"]], c("BMRKR2", "RACE", "REGION1")),
|
|
| 10 | +200 |
- #' @param x (`data_extract_spec` or `list` of multiple `data_extract_spec`)+ #' selected = NULL, |
|
| 11 | +201 |
- #' Which variable to use on the X-axis of the response plot. Allow the user to select multiple+ #' multiple = FALSE, |
|
| 12 | +202 |
- #' columns from the `data` allowed in teal.+ #' fixed = FALSE |
|
| 13 | +203 |
- #' `data_extract_spec` must not allow multiple selection in this case.+ #' ) |
|
| 14 | +204 |
- #' @param row_facet optional, (`data_extract_spec` or `list` of multiple `data_extract_spec`)+ #' ), |
|
| 15 | +205 |
- #' Which data columns to use for faceting rows.+ #' ggplot2_args = ggplot2_args( |
|
| 16 | +206 |
- #' @param col_facet optional, (`data_extract_spec` or `list` of multiple `data_extract_spec`)+ #' labs = list(subtitle = "Plot generated by Scatterplot Module") |
|
| 17 | +207 |
- #' Which data to use for faceting columns.+ #' ) |
|
| 18 | +208 |
- #' @param coord_flip optional, (`logical`) Whether to flip coordinates between `x` and `response`.+ #' ) |
|
| 19 | +209 |
- #' @param count_labels optional, (`logical`) Whether to show count labels.+ #' ) |
|
| 20 | +210 |
- #' Defaults to `TRUE`.+ #' ) |
|
| 21 | +211 |
- #' @param freq optional, (`logical`) Whether to display frequency (`TRUE`) or density (`FALSE`).+ #' if (interactive()) {
|
|
| 22 | +212 |
- #' Defaults to density (`FALSE`).+ #' shinyApp(app$ui, app$server) |
|
| 23 | +213 |
- #'+ #' } |
|
| 24 | +214 |
- #' @note For more examples, please see the vignette "Using response plot" via+ #' |
|
| 25 | +215 |
- #' \code{vignette("using-response-plot", package = "teal.modules.general")}.
+ #' @export |
|
| 26 | +216 |
#' |
|
| 27 | +217 |
- #' @examples+ tm_g_scatterplot <- function(label = "Scatterplot", |
|
| 28 | +218 |
- #' # general data example+ x, |
|
| 29 | +219 |
- #' library(teal.widgets)+ y, |
|
| 30 | +220 |
- #'+ color_by = NULL, |
|
| 31 | +221 |
- #' data <- teal_data()+ size_by = NULL, |
|
| 32 | +222 |
- #' data <- within(data, {
+ row_facet = NULL, |
|
| 33 | +223 |
- #' library(nestcolor)+ col_facet = NULL, |
|
| 34 | +224 |
- #' mtcars <- mtcars+ plot_height = c(600, 200, 2000), |
|
| 35 | +225 |
- #' for (v in c("cyl", "vs", "am", "gear")) {
+ plot_width = NULL, |
|
| 36 | +226 |
- #' mtcars[[v]] <- as.factor(mtcars[[v]])+ alpha = c(1, 0, 1), |
|
| 37 | +227 |
- #' }+ shape = shape_names, |
|
| 38 | +228 |
- #' })+ size = c(5, 1, 15), |
|
| 39 | +229 |
- #' datanames(data) <- "mtcars"+ max_deg = 5L, |
|
| 40 | +230 |
- #'+ rotate_xaxis_labels = FALSE, |
|
| 41 | +231 |
- #' app <- init(+ ggtheme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void"),
|
|
| 42 | +232 |
- #' data = data,+ pre_output = NULL, |
|
| 43 | +233 |
- #' modules = modules(+ post_output = NULL, |
|
| 44 | +234 |
- #' tm_g_response(+ table_dec = 4, |
|
| 45 | +235 |
- #' label = "Response Plots",+ ggplot2_args = teal.widgets::ggplot2_args()) {
|
|
| 46 | -+ | ||
| 236 | +! |
- #' response = data_extract_spec(+ logger::log_info("Initializing tm_g_scatterplot")
|
|
| 47 | +237 |
- #' dataname = "mtcars",+ |
|
| 48 | -+ | ||
| 238 | +! |
- #' select = select_spec(+ extra_packages <- c("ggpmisc", "ggExtra", "colourpicker")
|
|
| 49 | -+ | ||
| 239 | +! |
- #' label = "Select variable:",+ missing_packages <- Filter(function(x) !requireNamespace(x, quietly = TRUE), extra_packages) |
|
| 50 | -+ | ||
| 240 | +! |
- #' choices = variable_choices(data[["mtcars"]], c("cyl", "gear")),
+ if (length(missing_packages) > 0L) {
|
|
| 51 | -+ | ||
| 241 | +! |
- #' selected = "cyl",+ stop(sprintf( |
|
| 52 | -+ | ||
| 242 | +! |
- #' multiple = FALSE,+ "Cannot load package(s): %s.\nInstall or restart your session.", |
|
| 53 | -+ | ||
| 243 | +! |
- #' fixed = FALSE+ toString(missing_packages) |
|
| 54 | +244 |
- #' )+ )) |
|
| 55 | +245 |
- #' ),+ } |
|
| 56 | +246 |
- #' x = data_extract_spec(+ |
|
| 57 | -+ | ||
| 247 | +! |
- #' dataname = "mtcars",+ if (inherits(x, "data_extract_spec")) x <- list(x) |
|
| 58 | -+ | ||
| 248 | +! |
- #' select = select_spec(+ if (inherits(y, "data_extract_spec")) y <- list(y) |
|
| 59 | -+ | ||
| 249 | +! |
- #' label = "Select variable:",+ if (inherits(color_by, "data_extract_spec")) color_by <- list(color_by) |
|
| 60 | -+ | ||
| 250 | +! |
- #' choices = variable_choices(data[["mtcars"]], c("vs", "am")),
+ if (inherits(size_by, "data_extract_spec")) size_by <- list(size_by) |
|
| 61 | -+ | ||
| 251 | +! |
- #' selected = "vs",+ if (inherits(row_facet, "data_extract_spec")) row_facet <- list(row_facet) |
|
| 62 | -+ | ||
| 252 | +! |
- #' multiple = FALSE,+ if (inherits(col_facet, "data_extract_spec")) col_facet <- list(col_facet) |
|
| 63 | -+ | ||
| 253 | +! |
- #' fixed = FALSE+ if (is.double(max_deg)) max_deg <- as.integer(max_deg) |
|
| 64 | +254 |
- #' )+ |
|
| 65 | -+ | ||
| 255 | +! |
- #' ),+ ggtheme <- match.arg(ggtheme) |
|
| 66 | -+ | ||
| 256 | +! |
- #' ggplot2_args = ggplot2_args(+ checkmate::assert_string(label) |
|
| 67 | -+ | ||
| 257 | +! |
- #' labs = list(subtitle = "Plot generated by Response Module")+ checkmate::assert_list(x, types = "data_extract_spec") |
|
| 68 | -+ | ||
| 258 | +! |
- #' )+ checkmate::assert_list(y, types = "data_extract_spec") |
|
| 69 | -+ | ||
| 259 | +! |
- #' )+ checkmate::assert_list(color_by, types = "data_extract_spec", null.ok = TRUE) |
|
| 70 | -+ | ||
| 260 | +! |
- #' )+ checkmate::assert_list(size_by, types = "data_extract_spec", null.ok = TRUE) |
|
| 71 | -+ | ||
| 261 | +! |
- #' )+ checkmate::assert_list(row_facet, types = "data_extract_spec", null.ok = TRUE) |
|
| 72 | -+ | ||
| 262 | +! |
- #' if (interactive()) {
+ checkmate::assert_list(col_facet, types = "data_extract_spec", null.ok = TRUE) |
|
| 73 | -+ | ||
| 263 | +! |
- #' shinyApp(app$ui, app$server)+ checkmate::assert_list(row_facet, types = "data_extract_spec", null.ok = TRUE) |
|
| 74 | -+ | ||
| 264 | +! |
- #' }+ if (!all(vapply(row_facet, function(x) !x$select$multiple, logical(1)))) {
|
|
| 75 | -+ | ||
| 265 | +! |
- #'+ stop("'row_facet' should not allow multiple selection")
|
|
| 76 | +266 |
- #' # CDISC data example+ } |
|
| 77 | -+ | ||
| 267 | +! |
- #' library(teal.widgets)+ if (!all(vapply(col_facet, function(x) !x$select$multiple, logical(1)))) {
|
|
| 78 | -+ | ||
| 268 | +! |
- #'+ stop("'col_facet' should not allow multiple selection")
|
|
| 79 | +269 |
- #' data <- teal_data()+ } |
|
| 80 | -+ | ||
| 270 | +! |
- #' data <- within(data, {
+ checkmate::assert_character(shape) |
|
| 81 | +271 |
- #' library(nestcolor)+ |
|
| 82 | -+ | ||
| 272 | +! |
- #' ADSL <- rADSL+ checkmate::assert_int(max_deg, lower = 1L) |
|
| 83 | -+ | ||
| 273 | +! |
- #' })+ checkmate::assert_scalar(table_dec) |
|
| 84 | -+ | ||
| 274 | +! |
- #' datanames(data) <- c("ADSL")
+ checkmate::assert_flag(rotate_xaxis_labels) |
|
| 85 | -+ | ||
| 275 | +! |
- #' join_keys(data) <- default_cdisc_join_keys[datanames(data)]+ if (length(alpha) == 1) {
|
|
| 86 | -+ | ||
| 276 | +! |
- #'+ checkmate::assert_numeric(alpha, any.missing = FALSE, finite = TRUE) |
|
| 87 | +277 |
- #' app <- init(+ } else {
|
|
| 88 | -+ | ||
| 278 | +! |
- #' data = data,+ checkmate::assert_numeric(alpha, len = 3, any.missing = FALSE, finite = TRUE) |
|
| 89 | -+ | ||
| 279 | +! |
- #' modules = modules(+ checkmate::assert_numeric(alpha[1], lower = alpha[2], upper = alpha[3], .var.name = "alpha") |
|
| 90 | +280 |
- #' tm_g_response(+ } |
|
| 91 | +281 |
- #' label = "Response Plots",+ |
|
| 92 | -+ | ||
| 282 | +! |
- #' response = data_extract_spec(+ if (length(size) == 1) {
|
|
| 93 | -+ | ||
| 283 | +! |
- #' dataname = "ADSL",+ checkmate::assert_numeric(size, any.missing = FALSE, finite = TRUE) |
|
| 94 | +284 |
- #' select = select_spec(+ } else {
|
|
| 95 | -+ | ||
| 285 | +! |
- #' label = "Select variable:",+ checkmate::assert_numeric(size, len = 3, any.missing = FALSE, finite = TRUE) |
|
| 96 | -+ | ||
| 286 | +! |
- #' choices = variable_choices(data[["ADSL"]], c("BMRKR2", "COUNTRY")),
+ checkmate::assert_numeric(size[1], lower = size[2], upper = size[3], .var.name = "size") |
|
| 97 | +287 |
- #' selected = "BMRKR2",+ } |
|
| 98 | +288 |
- #' multiple = FALSE,+ |
|
| 99 | -+ | ||
| 289 | +! |
- #' fixed = FALSE+ checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE) |
|
| 100 | -+ | ||
| 290 | +! |
- #' )+ checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height") |
|
| 101 | -+ | ||
| 291 | +! |
- #' ),+ checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE) |
|
| 102 | -+ | ||
| 292 | +! |
- #' x = data_extract_spec(+ checkmate::assert_numeric( |
|
| 103 | -+ | ||
| 293 | +! |
- #' dataname = "ADSL",+ plot_width[1], |
|
| 104 | -+ | ||
| 294 | +! |
- #' select = select_spec(+ lower = plot_width[2], upper = plot_width[3], null.ok = TRUE, .var.name = "plot_width" |
|
| 105 | +295 |
- #' label = "Select variable:",+ ) |
|
| 106 | +296 |
- #' choices = variable_choices(data[["ADSL"]], c("SEX", "RACE")),
+
|
|
| 107 | -+ | ||
| 297 | +! |
- #' selected = "RACE",+ checkmate::assert_class(ggplot2_args, "ggplot2_args") |
|
| 108 | +298 |
- #' multiple = FALSE,+ |
|
| 109 | -+ | ||
| 299 | +! |
- #' fixed = FALSE+ args <- as.list(environment()) |
|
| 110 | +300 |
- #' )+ |
|
| 111 | -+ | ||
| 301 | +! |
- #' ),+ data_extract_list <- list( |
|
| 112 | -+ | ||
| 302 | +! |
- #' ggplot2_args = ggplot2_args(+ x = x, |
|
| 113 | -+ | ||
| 303 | +! |
- #' labs = list(subtitle = "Plot generated by Response Module")+ y = y, |
|
| 114 | -+ | ||
| 304 | +! |
- #' )+ color_by = color_by, |
|
| 115 | -+ | ||
| 305 | +! |
- #' )+ size_by = size_by, |
|
| 116 | -+ | ||
| 306 | +! |
- #' )+ row_facet = row_facet, |
|
| 117 | -+ | ||
| 307 | +! |
- #' )+ col_facet = col_facet |
|
| 118 | +308 |
- #' if (interactive()) {
+ ) |
|
| 119 | +309 |
- #' shinyApp(app$ui, app$server)+ |
|
| 120 | -+ | ||
| 310 | +! |
- #' }+ module( |
|
| 121 | -+ | ||
| 311 | +! |
- #'+ label = label, |
|
| 122 | -+ | ||
| 312 | +! |
- #' @export+ server = srv_g_scatterplot, |
|
| 123 | -+ | ||
| 313 | +! |
- #'+ ui = ui_g_scatterplot, |
|
| 124 | -+ | ||
| 314 | +! |
- tm_g_response <- function(label = "Response Plot",+ ui_args = args, |
|
| 125 | -+ | ||
| 315 | +! |
- response,+ server_args = c( |
|
| 126 | -+ | ||
| 316 | +! |
- x,+ data_extract_list, |
|
| 127 | -+ | ||
| 317 | +! |
- row_facet = NULL,+ list(plot_height = plot_height, plot_width = plot_width, table_dec = table_dec, ggplot2_args = ggplot2_args) |
|
| 128 | +318 |
- col_facet = NULL,+ ), |
|
| 129 | -+ | ||
| 319 | +! |
- coord_flip = FALSE,+ datanames = teal.transform::get_extract_datanames(data_extract_list) |
|
| 130 | +320 |
- count_labels = TRUE,+ ) |
|
| 131 | +321 |
- rotate_xaxis_labels = FALSE,+ } |
|
| 132 | +322 |
- freq = FALSE,+ |
|
| 133 | +323 |
- plot_height = c(600, 400, 5000),+ ui_g_scatterplot <- function(id, ...) {
|
|
| 134 | -+ | ||
| 324 | +! |
- plot_width = NULL,+ args <- list(...) |
|
| 135 | -+ | ||
| 325 | +! |
- ggtheme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void"),
+ ns <- NS(id) |
|
| 136 | -+ | ||
| 326 | +! |
- ggplot2_args = teal.widgets::ggplot2_args(),+ is_single_dataset_value <- teal.transform::is_single_dataset(+ |
+ |
| 327 | +! | +
+ args$x, args$y, args$color_by, args$size_by, args$row_facet, args$col_facet |
|
| 137 | +328 |
- pre_output = NULL,+ ) |
|
| 138 | +329 |
- post_output = NULL) {
+
|
|
| 139 | +330 | ! |
- logger::log_info("Initializing tm_g_response")
+ shiny::tagList( |
| 140 | +331 | ! |
- if (inherits(response, "data_extract_spec")) response <- list(response)+ include_css_files("custom"),
|
| 141 | +332 | ! |
- if (inherits(x, "data_extract_spec")) x <- list(x)+ teal.widgets::standard_layout( |
| 142 | +333 | ! |
- if (inherits(row_facet, "data_extract_spec")) row_facet <- list(row_facet)+ output = teal.widgets::white_small_well( |
| 143 | +334 | ! |
- if (inherits(col_facet, "data_extract_spec")) col_facet <- list(col_facet)+ teal.widgets::plot_with_settings_ui(id = ns("scatter_plot")),
|
| 144 | +335 | ! |
- checkmate::assert_string(label)+ tags$h1(tags$strong("Selected points:"), class = "text-center font-150p"),
|
| 145 | +336 | ! |
- ggtheme <- match.arg(ggtheme)+ teal.widgets::get_dt_rows(ns("data_table"), ns("data_table_rows")),
|
| 146 | +337 | ! |
- checkmate::assert_list(response, types = "data_extract_spec")+ DT::dataTableOutput(ns("data_table"), width = "100%")
|
| 147 | -! | +||
| 338 | +
- if (!all(vapply(response, function(x) !("" %in% x$select$choices), logical(1)))) {
+ ), |
||
| 148 | +339 | ! |
- stop("'response' should not allow empty values")
+ encoding = div( |
| 149 | +340 |
- }+ ### Reporter |
|
| 150 | +341 | ! |
- if (!all(vapply(response, function(x) !x$select$multiple, logical(1)))) {
+ teal.reporter::simple_reporter_ui(ns("simple_reporter")),
|
| 151 | -! | +||
| 342 | +
- stop("'response' should not allow multiple selection")
+ ### |
||
| 152 | -+ | ||
| 343 | +! |
- }+ tags$label("Encodings", class = "text-primary"),
|
|
| 153 | +344 | ! |
- checkmate::assert_list(x, types = "data_extract_spec")+ teal.transform::datanames_input(args[c("x", "y", "color_by", "size_by", "row_facet", "col_facet")]),
|
| 154 | +345 | ! |
- if (!all(vapply(x, function(x) !("" %in% x$select$choices), logical(1)))) {
+ teal.transform::data_extract_ui( |
| 155 | +346 | ! |
- stop("'x' should not allow empty values")
+ id = ns("x"),
|
| 156 | -+ | ||
| 347 | +! |
- }+ label = "X variable", |
|
| 157 | +348 | ! |
- if (!all(vapply(x, function(x) !x$select$multiple, logical(1)))) {
+ data_extract_spec = args$x, |
| 158 | +349 | ! |
- stop("'x' should not allow multiple selection")
+ is_single_dataset = is_single_dataset_value |
| 159 | +350 |
- }+ ), |
|
| 160 | +351 | ! |
- checkmate::assert_list(row_facet, types = "data_extract_spec", null.ok = TRUE)+ checkboxInput(ns("log_x"), "Use log transformation", value = FALSE),
|
| 161 | +352 | ! |
- checkmate::assert_list(col_facet, types = "data_extract_spec", null.ok = TRUE)+ conditionalPanel( |
| 162 | +353 | ! |
- checkmate::assert_flag(coord_flip)+ condition = paste0("input['", ns("log_x"), "'] == true"),
|
| 163 | +354 | ! |
- checkmate::assert_flag(count_labels)+ radioButtons( |
| 164 | +355 | ! |
- checkmate::assert_flag(rotate_xaxis_labels)+ ns("log_x_base"),
|
| 165 | +356 | ! |
- checkmate::assert_flag(freq)+ label = NULL, |
| 166 | +357 | ! |
- checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE)+ inline = TRUE, |
| 167 | +358 | ! |
- checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height")+ choices = c("Natural" = "log", "Base 10" = "log10", "Base 2" = "log2")
+ |
+
| 359 | ++ |
+ )+ |
+ |
| 360 | ++ |
+ ), |
|
| 168 | +361 | ! |
- checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE)+ teal.transform::data_extract_ui( |
| 169 | +362 | ! |
- checkmate::assert_numeric(+ id = ns("y"),
|
| 170 | +363 | ! |
- plot_width[1],+ label = "Y variable", |
| 171 | +364 | ! |
- lower = plot_width[2], upper = plot_width[3], null.ok = TRUE, .var.name = "plot_width"+ data_extract_spec = args$y, |
| 172 | -+ | ||
| 365 | +! |
- )+ is_single_dataset = is_single_dataset_value |
|
| 173 | +366 |
-
+ ), |
|
| 174 | +367 | ! |
- checkmate::assert_class(ggplot2_args, "ggplot2_args")- |
-
| 175 | -- |
-
+ checkboxInput(ns("log_y"), "Use log transformation", value = FALSE),
|
|
| 176 | +368 | ! |
- args <- as.list(environment())+ conditionalPanel( |
| 177 | -+ | ||
| 369 | +! |
-
+ condition = paste0("input['", ns("log_y"), "'] == true"),
|
|
| 178 | +370 | ! |
- data_extract_list <- list(+ radioButtons( |
| 179 | +371 | ! |
- response = response,+ ns("log_y_base"),
|
| 180 | +372 | ! |
- x = x,+ label = NULL, |
| 181 | +373 | ! |
- row_facet = row_facet,+ inline = TRUE, |
| 182 | +374 | ! |
- col_facet = col_facet+ choices = c("Natural" = "log", "Base 10" = "log10", "Base 2" = "log2")
|
| 183 | +375 |
- )+ ) |
|
| 184 | +376 |
-
+ ), |
|
| 185 | +377 | ! |
- module(+ if (!is.null(args$color_by)) {
|
| 186 | +378 | ! |
- label = label,+ teal.transform::data_extract_ui( |
| 187 | +379 | ! |
- server = srv_g_response,+ id = ns("color_by"),
|
| 188 | +380 | ! |
- ui = ui_g_response,+ label = "Color by variable", |
| 189 | +381 | ! |
- ui_args = args,+ data_extract_spec = args$color_by, |
| 190 | +382 | ! |
- server_args = c(+ is_single_dataset = is_single_dataset_value+ |
+
| 383 | ++ |
+ )+ |
+ |
| 384 | ++ |
+ }, |
|
| 191 | +385 | ! |
- data_extract_list,+ if (!is.null(args$size_by)) {
|
| 192 | +386 | ! |
- list(plot_height = plot_height, plot_width = plot_width, ggplot2_args = ggplot2_args)+ teal.transform::data_extract_ui( |
| 193 | -+ | ||
| 387 | +! |
- ),+ id = ns("size_by"),
|
|
| 194 | +388 | ! |
- datanames = teal.transform::get_extract_datanames(data_extract_list)+ label = "Size by variable", |
| 195 | -+ | ||
| 389 | +! |
- )+ data_extract_spec = args$size_by, |
|
| 196 | -+ | ||
| 390 | +! |
- }+ is_single_dataset = is_single_dataset_value |
|
| 197 | +391 |
-
+ ) |
|
| 198 | +392 |
- ui_g_response <- function(id, ...) {
+ }, |
|
| 199 | +393 | ! |
- ns <- NS(id)+ if (!is.null(args$row_facet)) {
|
| 200 | +394 | ! |
- args <- list(...)+ teal.transform::data_extract_ui( |
| 201 | +395 | ! |
- is_single_dataset_value <- teal.transform::is_single_dataset(args$response, args$x, args$row_facet, args$col_facet)- |
-
| 202 | -- |
-
+ id = ns("row_facet"),
|
|
| 203 | +396 | ! |
- teal.widgets::standard_layout(+ label = "Row facetting", |
| 204 | +397 | ! |
- output = teal.widgets::white_small_well(+ data_extract_spec = args$row_facet, |
| 205 | +398 | ! |
- teal.widgets::plot_with_settings_ui(id = ns("myplot"))
+ is_single_dataset = is_single_dataset_value |
| 206 | +399 |
- ),- |
- |
| 207 | -! | -
- encoding = div(+ ) |
|
| 208 | +400 |
- ### Reporter+ }, |
|
| 209 | +401 | ! |
- teal.reporter::simple_reporter_ui(ns("simple_reporter")),
+ if (!is.null(args$col_facet)) {
|
| 210 | -+ | ||
| 402 | +! |
- ###+ teal.transform::data_extract_ui( |
|
| 211 | +403 | ! |
- tags$label("Encodings", class = "text-primary"),
+ id = ns("col_facet"),
|
| 212 | +404 | ! |
- teal.transform::datanames_input(args[c("response", "x", "row_facet", "col_facet")]),
+ label = "Column facetting", |
| 213 | +405 | ! |
- teal.transform::data_extract_ui(+ data_extract_spec = args$col_facet, |
| 214 | +406 | ! |
- id = ns("response"),
+ is_single_dataset = is_single_dataset_value+ |
+
| 407 | ++ |
+ )+ |
+ |
| 408 | ++ |
+ }, |
|
| 215 | +409 | ! |
- label = "Response variable",+ teal.widgets::panel_group( |
| 216 | +410 | ! |
- data_extract_spec = args$response,+ teal.widgets::panel_item( |
| 217 | +411 | ! |
- is_single_dataset = is_single_dataset_value+ title = "Plot settings", |
| 218 | -+ | ||
| 412 | +! |
- ),+ teal.widgets::optionalSliderInputValMinMax(ns("alpha"), "Opacity:", args$alpha, ticks = FALSE),
|
|
| 219 | +413 | ! |
- teal.transform::data_extract_ui(+ teal.widgets::optionalSelectInput( |
| 220 | +414 | ! |
- id = ns("x"),
+ inputId = ns("shape"),
|
| 221 | +415 | ! |
- label = "X variable",+ label = "Points shape:", |
| 222 | +416 | ! |
- data_extract_spec = args$x,+ choices = args$shape, |
| 223 | +417 | ! |
- is_single_dataset = is_single_dataset_value+ selected = args$shape[1],+ |
+
| 418 | +! | +
+ multiple = FALSE |
|
| 224 | +419 |
- ),+ ), |
|
| 225 | +420 | ! |
- if (!is.null(args$row_facet)) {
+ colourpicker::colourInput(ns("color"), "Points color:", "black"),
|
| 226 | +421 | ! |
- teal.transform::data_extract_ui(+ teal.widgets::optionalSliderInputValMinMax(ns("size"), "Points size:", args$size, ticks = FALSE, step = .1),
|
| 227 | +422 | ! |
- id = ns("row_facet"),
+ checkboxInput(ns("rotate_xaxis_labels"), "Rotate X axis labels", value = args$rotate_xaxis_labels),
|
| 228 | +423 | ! |
- label = "Row facetting",+ checkboxInput(ns("add_density"), "Add marginal density", value = FALSE),
|
| 229 | +424 | ! |
- data_extract_spec = args$row_facet,+ checkboxInput(ns("rug_plot"), "Include rug plot", value = FALSE),
|
| 230 | +425 | ! |
- is_single_dataset = is_single_dataset_value+ checkboxInput(ns("show_count"), "Show N (number of observations)", value = FALSE),
|
| 231 | -+ | ||
| 426 | +! |
- )+ shinyjs::hidden(helpText(id = ns("line_msg"), "Trendline needs numeric X and Y variables")),
|
|
| 232 | -+ | ||
| 427 | +! |
- },+ teal.widgets::optionalSelectInput(ns("smoothing_degree"), "Smoothing degree", seq_len(args$max_deg)),
|
|
| 233 | +428 | ! |
- if (!is.null(args$col_facet)) {
+ shinyjs::hidden(teal.widgets::optionalSelectInput(ns("color_sub"), label = "", multiple = TRUE)),
|
| 234 | +429 | ! |
- teal.transform::data_extract_ui(+ teal.widgets::optionalSliderInputValMinMax(ns("ci"), "Confidence", c(.95, .8, .99), ticks = FALSE),
|
| 235 | +430 | ! |
- id = ns("col_facet"),
+ shinyjs::hidden(checkboxInput(ns("show_form"), "Show formula", value = TRUE)),
|
| 236 | +431 | ! |
- label = "Column facetting",+ shinyjs::hidden(checkboxInput(ns("show_r2"), "Show adj-R Squared", value = TRUE)),
|
| 237 | +432 | ! |
- data_extract_spec = args$col_facet,+ uiOutput(ns("num_na_removed")),
|
| 238 | +433 | ! |
- is_single_dataset = is_single_dataset_value+ div( |
| 239 | -+ | ||
| 434 | +! |
- )+ id = ns("label_pos"),
|
|
| 240 | -+ | ||
| 435 | +! |
- },+ div(strong("Stats position")),
|
|
| 241 | +436 | ! |
- shinyWidgets::radioGroupButtons(+ div(class = "inline-block w-10", helpText("Left")),
|
| 242 | +437 | ! |
- inputId = ns("freq"),
+ div( |
| 243 | +438 | ! |
- label = NULL,+ class = "inline-block w-70", |
| 244 | +439 | ! |
- choices = c("frequency", "density"),
+ teal.widgets::optionalSliderInput( |
| 245 | +440 | ! |
- selected = ifelse(args$freq, "frequency", "density"),+ ns("pos"),
|
| 246 | +441 | ! |
- justified = TRUE+ label = NULL,+ |
+
| 442 | +! | +
+ min = 0, max = 1, value = .99, ticks = FALSE, step = .01 |
|
| 247 | +443 |
- ),+ )+ |
+ |
| 444 | ++ |
+ ), |
|
| 248 | +445 | ! |
- teal.widgets::panel_group(+ div(class = "inline-block w-10", helpText("Right"))
+ |
+
| 446 | ++ |
+ ), |
|
| 249 | +447 | ! |
- teal.widgets::panel_item(+ teal.widgets::optionalSliderInput( |
| 250 | +448 | ! |
- title = "Plot settings",+ ns("label_size"), "Stats font size",
|
| 251 | +449 | ! |
- checkboxInput(ns("count_labels"), "Add count labels", value = args$count_labels),
+ min = 3, max = 10, value = 5, ticks = FALSE, step = .1+ |
+
| 450 | ++ |
+ ), |
|
| 252 | +451 | ! |
- checkboxInput(ns("coord_flip"), "Swap axes", value = args$coord_flip),
+ if (!is.null(args$row_facet) || !is.null(args$col_facet)) {
|
| 253 | +452 | ! |
- checkboxInput(ns("rotate_xaxis_labels"), "Rotate X axis labels", value = args$rotate_xaxis_labels),
+ checkboxInput(ns("free_scales"), "Free scales", value = FALSE)
+ |
+
| 453 | ++ |
+ }, |
|
| 254 | +454 | ! |
- selectInput(+ selectInput( |
| 255 | +455 | ! |
- inputId = ns("ggtheme"),
+ inputId = ns("ggtheme"),
|
| 256 | +456 | ! |
- label = "Theme (by ggplot):",+ label = "Theme (by ggplot):", |
| 257 | +457 | ! |
- choices = ggplot_themes,+ choices = ggplot_themes, |
| 258 | +458 | ! |
- selected = args$ggtheme,+ selected = args$ggtheme, |
| 259 | +459 | ! |
- multiple = FALSE+ multiple = FALSE |
| 260 | +460 |
- )+ ) |
|
| 261 | +461 |
- )+ ) |
|
| 262 | +462 |
- )+ ) |
|
| 263 | +463 |
- ),+ ), |
|
| 264 | +464 | ! |
- forms = tagList(+ forms = tagList( |
| 265 | +465 | ! |
- teal.widgets::verbatim_popup_ui(ns("warning"), button_label = "Show Warnings"),
+ teal.widgets::verbatim_popup_ui(ns("warning"), button_label = "Show Warnings"),
|
| 266 | +466 | ! |
- teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code")
+ teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code")
|
| 267 | +467 |
- ),+ ), |
|
| 268 | +468 | ! |
- pre_output = args$pre_output,+ pre_output = args$pre_output, |
| 269 | +469 | ! |
- post_output = args$post_output+ post_output = args$post_output |
| 270 | +470 | ++ |
+ )+ |
+
| 471 |
) |
||
| 271 | +472 |
} |
|
| 272 | +473 | ||
| 273 | +474 |
- srv_g_response <- function(id,+ srv_g_scatterplot <- function(id, |
|
| 274 | +475 |
- data,+ data, |
|
| 275 | +476 |
- reporter,+ reporter, |
|
| 276 | +477 |
- filter_panel_api,+ filter_panel_api, |
|
| 277 | +478 |
- response,+ x, |
|
| 278 | +479 |
- x,+ y, |
|
| 279 | +480 |
- row_facet,+ color_by, |
|
| 280 | +481 |
- col_facet,+ size_by, |
|
| 281 | +482 |
- plot_height,+ row_facet, |
|
| 282 | +483 |
- plot_width,+ col_facet, |
|
| 283 | +484 |
- ggplot2_args) {
+ plot_height,+ |
+ |
| 485 | ++ |
+ plot_width,+ |
+ |
| 486 | ++ |
+ table_dec,+ |
+ |
| 487 | ++ |
+ ggplot2_args) {
|
|
| 284 | +488 | ! |
with_reporter <- !missing(reporter) && inherits(reporter, "Reporter") |
| 285 | +489 | ! |
with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI") |
| 286 | +490 | ! |
checkmate::assert_class(data, "reactive") |
| 287 | +491 | ! |
checkmate::assert_class(isolate(data()), "teal_data") |
| 288 | +492 | ! |
moduleServer(id, function(input, output, session) {
|
| 289 | +493 | ! |
- data_extract <- list(response = response, x = x, row_facet = row_facet, col_facet = col_facet)+ data_extract <- list( |
| 290 | -+ | ||
| 494 | +! |
-
+ x = x, |
|
| 291 | +495 | ! |
- rule_diff <- function(other) {
+ y = y, |
| 292 | +496 | ! |
- function(value) {
+ color_by = color_by, |
| 293 | +497 | ! |
- if (other %in% names(selector_list())) {
+ size_by = size_by, |
| 294 | +498 | ! |
- othervalue <- selector_list()[[other]]()[["select"]]+ row_facet = row_facet, |
| 295 | +499 | ! |
- if (!is.null(othervalue)) {
+ col_facet = col_facet+ |
+
| 500 | ++ |
+ )+ |
+ |
| 501 | ++ | + | |
| 296 | +502 | ! |
- if (identical(value, othervalue)) {
+ rule_diff <- function(other) {
|
| 297 | +503 | ! |
- "Row and column facetting variables must be different."+ function(value) {
|
| 298 | -+ | ||
| 504 | +! |
- }+ othervalue <- selector_list()[[other]]()[["select"]]+ |
+ |
| 505 | +! | +
+ if (!is.null(othervalue)) {
+ |
+ |
| 506 | +! | +
+ if (identical(value, othervalue)) {
+ |
+ |
| 507 | +! | +
+ "Row and column facetting variables must be different." |
|
| 299 | +508 |
} |
|
| 300 | +509 |
} |
|
| 301 | +510 |
} |
|
| 302 | +511 |
} |
|
| 303 | +512 | ||
| 304 | +513 | ! |
selector_list <- teal.transform::data_extract_multiple_srv( |
| 305 | +514 | ! |
data_extract = data_extract, |
| 306 | +515 | ! |
datasets = data, |
| 307 | +516 | ! |
select_validation_rule = list( |
| 308 | +517 | ! |
- response = shinyvalidate::sv_required("Please define a column for the response variable"),
+ x = ~ if (length(.) != 1) "Please select exactly one x var.", |
| 309 | +518 | ! |
- x = shinyvalidate::sv_required("Please define a column for X variable"),
+ y = ~ if (length(.) != 1) "Please select exactly one y var.", |
| 310 | +519 | ! |
- row_facet = shinyvalidate::compose_rules(+ color_by = ~ if (length(.) > 1) "There cannot be more than 1 color variable.", |
| 311 | +520 | ! |
- shinyvalidate::sv_optional(),+ size_by = ~ if (length(.) > 1) "There cannot be more than 1 size variable.", |
| 312 | +521 | ! |
- ~ if (length(.) > 1) "There must be 1 or no row facetting variable.",+ row_facet = shinyvalidate::compose_rules( |
| 313 | +522 | ! |
- rule_diff("col_facet")
+ shinyvalidate::sv_optional(), |
| 314 | -+ | ||
| 523 | +! |
- ),+ rule_diff("col_facet")
|
|
| 315 | -! | +||
| 524 | +
- col_facet = shinyvalidate::compose_rules(+ ), |
||
| 316 | +525 | ! |
- shinyvalidate::sv_optional(),+ col_facet = shinyvalidate::compose_rules( |
| 317 | +526 | ! |
- ~ if (length(.) > 1) "There must be 1 or no column facetting variable.",+ shinyvalidate::sv_optional(), |
| 318 | +527 | ! |
rule_diff("row_facet")
|
| 319 | +528 |
) |
|
| 320 | +529 |
) |
|
| 321 | +530 |
) |
|
| 322 | +531 | ||
| 323 | +532 | ! |
iv_r <- reactive({
|
| 324 | +533 | ! |
- iv <- shinyvalidate::InputValidator$new()+ iv_facet <- shinyvalidate::InputValidator$new() |
| 325 | +534 | ! |
- iv$add_rule("ggtheme", shinyvalidate::sv_required("Please select a theme"))
+ iv <- shinyvalidate::InputValidator$new() |
| 326 | +535 | ! |
teal.transform::compose_and_enable_validators(iv, selector_list) |
| 327 | +536 | ++ |
+ })+ |
+
| 537 | +! | +
+ iv_facet <- shinyvalidate::InputValidator$new()+ |
+ |
| 538 | +! | +
+ iv_facet$add_rule("add_density", ~ if (isTRUE(.) &&
+ |
+ |
| 539 | +! | +
+ (length(selector_list()$row_facet()$select) > 0L ||+ |
+ |
| 540 | +! | +
+ length(selector_list()$col_facet()$select) > 0L)) {
+ |
+ |
| 541 | +! | +
+ "Cannot add marginal density when Row or Column facetting has been selected"+ |
+ |
| 542 |
}) |
||
| 543 | +! | +
+ iv_facet$enable()+ |
+ |
| 328 | +544 | ||
| 329 | +545 | ! |
anl_merged_input <- teal.transform::merge_expression_srv( |
| 330 | +546 | ! |
selector_list = selector_list, |
| 331 | +547 | ! |
- datasets = data+ datasets = data,+ |
+
| 548 | +! | +
+ merge_function = "dplyr::inner_join" |
|
| 332 | +549 |
) |
|
| 333 | +550 | ||
| 334 | +551 | ! |
anl_merged_q <- reactive({
|
| 335 | +552 | ! |
req(anl_merged_input()) |
| 336 | +553 | ! |
data() %>% |
| 337 | +554 | ! |
- teal.code::eval_code(as.expression(anl_merged_input()$expr))+ teal.code::eval_code(as.expression(anl_merged_input()$expr)) %>%+ |
+
| 555 | +! | +
+ teal.code::eval_code(quote(ANL)) # used to display table when running show-r-code code |
|
| 338 | +556 |
}) |
|
| 339 | +557 | ||
| 340 | +558 | ! |
merged <- list( |
| 341 | +559 | ! |
anl_input_r = anl_merged_input, |
| 342 | +560 | ! |
anl_q_r = anl_merged_q |
| 343 | +561 |
) |
|
| 344 | +562 | ||
| 345 | +563 | ! |
- output_q <- reactive({
+ trend_line_is_applicable <- reactive({
|
| 346 | +564 | ! |
- teal::validate_inputs(iv_r())- |
-
| 347 | -- |
-
+ ANL <- merged$anl_q_r()[["ANL"]] # nolint: object_name. |
|
| 348 | +565 | ! |
- qenv <- merged$anl_q_r()+ x_var <- as.vector(merged$anl_input_r()$columns_source$x) |
| 349 | +566 | ! |
- ANL <- qenv[["ANL"]] # nolint: object_name.+ y_var <- as.vector(merged$anl_input_r()$columns_source$y) |
| 350 | +567 | ! |
- resp_var <- as.vector(merged$anl_input_r()$columns_source$response)+ length(x_var) > 0 && length(y_var) > 0 && is.numeric(ANL[[x_var]]) && is.numeric(ANL[[y_var]]) |
| 351 | -! | +||
| 568 | +
- x <- as.vector(merged$anl_input_r()$columns_source$x)+ }) |
||
| 352 | +569 | ||
| 353 | +570 | ! |
- validate(need(is.factor(ANL[[resp_var]]), "Please select a factor variable as the response."))+ add_trend_line <- reactive({
|
| 354 | +571 | ! |
- validate(need(is.factor(ANL[[x]]), "Please select a factor variable as the X-Variable."))+ smoothing_degree <- as.integer(input$smoothing_degree) |
| 355 | +572 | ! |
- teal::validate_has_data(ANL, 10)+ trend_line_is_applicable() && length(smoothing_degree) > 0 |
| 356 | -! | +||
| 573 | +
- teal::validate_has_data(ANL[, c(resp_var, x)], 10, complete = TRUE, allow_inf = FALSE)+ }) |
||
| 357 | +574 | ||
| 358 | +575 | ! |
- row_facet_name <- if (length(merged$anl_input_r()$columns_source$row_facet) == 0) {
+ if (!is.null(color_by)) {
|
| 359 | +576 | ! |
- character(0)+ observeEvent( |
| 360 | -+ | ||
| 577 | +! |
- } else {
+ eventExpr = merged$anl_input_r()$columns_source$color_by, |
|
| 361 | +578 | ! |
- as.vector(merged$anl_input_r()$columns_source$row_facet)+ handlerExpr = {
|
| 362 | -+ | ||
| 579 | +! |
- }+ color_by_var <- as.vector(merged$anl_input_r()$columns_source$color_by) |
|
| 363 | +580 | ! |
- col_facet_name <- if (length(merged$anl_input_r()$columns_source$col_facet) == 0) {
+ if (length(color_by_var) > 0) {
|
| 364 | +581 | ! |
- character(0)+ shinyjs::hide("color")
|
| 365 | +582 |
- } else {
+ } else {
|
|
| 366 | +583 | ! |
- as.vector(merged$anl_input_r()$columns_source$col_facet)+ shinyjs::show("color")
|
| 367 | +584 |
- }+ } |
|
| 368 | +585 |
-
+ } |
|
| 369 | -! | +||
| 586 | +
- freq <- input$freq == "frequency"+ ) |
||
| 370 | -! | +||
| 587 | +
- swap_axes <- input$coord_flip+ } |
||
| 371 | -! | +||
| 588 | +
- counts <- input$count_labels+ |
||
| 372 | +589 | ! |
- rotate_xaxis_labels <- input$rotate_xaxis_labels+ output$num_na_removed <- renderUI({
|
| 373 | +590 | ! |
- ggtheme <- input$ggtheme+ if (add_trend_line()) {
|
| 374 | -+ | ||
| 591 | +! |
-
+ ANL <- merged$anl_q_r()[["ANL"]] # nolint: object_name. |
|
| 375 | +592 | ! |
- arg_position <- if (freq) "stack" else "fill"+ x_var <- as.vector(merged$anl_input_r()$columns_source$x) |
| 376 | -+ | ||
| 593 | +! |
-
+ y_var <- as.vector(merged$anl_input_r()$columns_source$y) |
|
| 377 | +594 | ! |
- rowf <- if (length(row_facet_name) != 0) as.name(row_facet_name)+ if ((num_total_na <- nrow(ANL) - nrow(stats::na.omit(ANL[, c(x_var, y_var)]))) > 0) {
|
| 378 | +595 | ! |
- colf <- if (length(col_facet_name) != 0) as.name(col_facet_name)+ shiny::tags$div(paste(num_total_na, "row(s) with missing values were removed"), shiny::tags$hr()) |
| 379 | -! | +||
| 596 | +
- resp_cl <- as.name(resp_var)+ } |
||
| 380 | -! | +||
| 597 | +
- x_cl <- as.name(x)+ } |
||
| 381 | +598 | ++ |
+ })+ |
+
| 599 | |||
| 382 | +600 | ! |
- if (swap_axes) {
+ observeEvent( |
| 383 | +601 | ! |
- qenv <- teal.code::eval_code(+ eventExpr = merged$anl_input_r()$columns_source[c("col_facet", "row_facet")],
|
| 384 | +602 | ! |
- qenv,+ handlerExpr = {
|
| 385 | +603 | ! |
- substitute(+ if (length(merged$anl_input_r()$columns_source$col_facet) == 0 && |
| 386 | +604 | ! |
- expr = ANL[[x]] <- with(ANL, forcats::fct_rev(x_cl)), # nolint: object_name.+ length(merged$anl_input_r()$columns_source$row_facet) == 0) {
|
| 387 | +605 | ! |
- env = list(x = x, x_cl = x_cl)+ shinyjs::hide("free_scales")
|
| 388 | +606 |
- )+ } else {
+ |
+ |
| 607 | +! | +
+ shinyjs::show("free_scales")
|
|
| 389 | +608 |
- )+ } |
|
| 390 | +609 |
} |
|
| 391 | +610 |
-
+ ) |
|
| 392 | -! | +||
| 611 | +
- qenv <- teal.code::eval_code(+ |
||
| 393 | +612 | ! |
- qenv,+ output_q <- reactive({
|
| 394 | +613 | ! |
- substitute(+ teal::validate_inputs(iv_r(), iv_facet) |
| 395 | -! | +||
| 614 | +
- expr = ANL[[resp_var]] <- factor(ANL[[resp_var]]), # nolint: object_name.+ |
||
| 396 | +615 | ! |
- env = list(resp_var = resp_var)+ ANL <- merged$anl_q_r()[["ANL"]] # nolint: object_name. |
| 397 | +616 |
- )+ |
|
| 398 | -+ | ||
| 617 | +! |
- ) %>%+ x_var <- as.vector(merged$anl_input_r()$columns_source$x) |
|
| 399 | -+ | ||
| 618 | +! |
- # nolint start+ y_var <- as.vector(merged$anl_input_r()$columns_source$y) |
|
| 400 | -+ | ||
| 619 | +! |
- # rowf and colf will be a NULL if not set by a user+ color_by_var <- as.vector(merged$anl_input_r()$columns_source$color_by) |
|
| 401 | +620 | ! |
- teal.code::eval_code(+ size_by_var <- as.vector(merged$anl_input_r()$columns_source$size_by) |
| 402 | +621 | ! |
- substitute(+ row_facet_name <- if (length(merged$anl_input_r()$columns_source$row_facet) == 0) {
|
| 403 | +622 | ! |
- expr = ANL2 <- ANL %>%+ character(0) |
| 404 | -! | +||
| 623 | +
- dplyr::group_by_at(dplyr::vars(x_cl, resp_cl, rowf, colf)) %>%+ } else {
|
||
| 405 | +624 | ! |
- dplyr::summarise(ns = dplyr::n()) %>%+ as.vector(merged$anl_input_r()$columns_source$row_facet) |
| 406 | -! | +||
| 625 | +
- dplyr::group_by_at(dplyr::vars(x_cl, rowf, colf)) %>%+ } |
||
| 407 | +626 | ! |
- dplyr::mutate(sums = sum(ns), percent = round(ns / sums * 100, 1)),+ col_facet_name <- if (length(merged$anl_input_r()$columns_source$col_facet) == 0) {
|
| 408 | +627 | ! |
- env = list(x_cl = x_cl, resp_cl = resp_cl, rowf = rowf, colf = colf)+ character(0) |
| 409 | +628 |
- )+ } else {
+ |
+ |
| 629 | +! | +
+ as.vector(merged$anl_input_r()$columns_source$col_facet) |
|
| 410 | +630 |
- ) %>%+ } |
|
| 411 | +631 | ! |
- teal.code::eval_code(+ alpha <- input$alpha |
| 412 | +632 | ! |
- substitute(+ size <- input$size |
| 413 | +633 | ! |
- expr = ANL3 <- ANL %>%+ rotate_xaxis_labels <- input$rotate_xaxis_labels |
| 414 | +634 | ! |
- dplyr::group_by_at(dplyr::vars(x_cl, rowf, colf)) %>%+ add_density <- input$add_density |
| 415 | +635 | ! |
- dplyr::summarise(ns = dplyr::n()),+ ggtheme <- input$ggtheme |
| 416 | +636 | ! |
- env = list(x_cl = x_cl, rowf = rowf, colf = colf)- |
-
| 417 | -- |
- )+ rug_plot <- input$rug_plot |
|
| 418 | -+ | ||
| 637 | +! |
- )+ color <- input$color |
|
| 419 | -+ | ||
| 638 | +! |
- # nolint end+ shape <- `if`(is.null(input$shape) || identical(input$shape, ""), "circle", input$shape) |
|
| 420 | -+ | ||
| 639 | +! |
-
+ smoothing_degree <- as.integer(input$smoothing_degree) |
|
| 421 | +640 | ! |
- plot_call <- substitute(+ ci <- input$ci |
| 422 | -! | +||
| 641 | +
- expr =+ |
||
| 423 | +642 | ! |
- ggplot(ANL2, aes(x = x_cl, y = ns)) ++ log_x <- input$log_x |
| 424 | +643 | ! |
- geom_bar(aes(fill = resp_cl), stat = "identity", position = arg_position),+ log_y <- input$log_y |
| 425 | -! | +||
| 644 | +
- env = list(+ |
||
| 426 | +645 | ! |
- x_cl = x_cl,+ validate(need( |
| 427 | +646 | ! |
- resp_cl = resp_cl,+ length(row_facet_name) == 0 || inherits(ANL[[row_facet_name]], c("character", "factor", "Date", "integer")),
|
| 428 | +647 | ! |
- arg_position = arg_position+ "`Row facetting` variable must be of class `character`, `factor`, `Date`, or `integer`" |
| 429 | +648 |
- )+ )) |
|
| 430 | -+ | ||
| 649 | +! |
- )+ validate(need( |
|
| 431 | -+ | ||
| 650 | +! |
-
+ length(col_facet_name) == 0 || inherits(ANL[[col_facet_name]], c("character", "factor", "Date", "integer")),
|
|
| 432 | +651 | ! |
- if (!freq) plot_call <- substitute(plot_call + expand_limits(y = c(0, 1.1)), env = list(plot_call = plot_call))+ "`Column facetting` variable must be of class `character`, `factor`, `Date`, or `integer`" |
| 433 | +652 |
-
+ )) |
|
| 434 | -! | +||
| 653 | +
- if (counts) {
+
|
||
| 435 | +654 | ! |
- plot_call <- substitute(+ if (add_density && length(color_by_var) > 0) {
|
| 436 | +655 | ! |
- expr = plot_call ++ validate(need( |
| 437 | +656 | ! |
- geom_text(+ !is.numeric(ANL[[color_by_var]]), |
| 438 | +657 | ! |
- data = ANL2,+ "Marginal plots cannot be produced when the points are colored by numeric variables. |
| 439 | +658 | ! |
- aes(label = ns, x = x_cl, y = ns, group = resp_cl),+ \n Uncheck the 'Add marginal density' checkbox to display the plot." |
| 440 | -! | +||
| 659 | +
- col = "white",+ )) |
||
| 441 | +660 | ! |
- vjust = "middle",+ validate(need( |
| 442 | +661 | ! |
- hjust = "middle",+ !(inherits(ANL[[color_by_var]], "Date") || |
| 443 | +662 | ! |
- position = position_anl2_value- |
-
| 444 | -- |
- ) ++ inherits(ANL[[color_by_var]], "POSIXct") || |
|
| 445 | +663 | ! |
- geom_text(+ inherits(ANL[[color_by_var]], "POSIXlt")), |
| 446 | +664 | ! |
- data = ANL3, aes(label = ns, x = x_cl, y = anl3_y),+ "Marginal plots cannot be produced when the points are colored by Date or POSIX variables. |
| 447 | +665 | ! |
- hjust = hjust_value,+ \n Uncheck the 'Add marginal density' checkbox to display the plot." |
| 448 | -! | +||
| 666 | +
- vjust = vjust_value,+ )) |
||
| 449 | -! | +||
| 667 | +
- position = position_anl3_value+ } |
||
| 450 | +668 |
- ),+ |
|
| 451 | +669 | ! |
- env = list(+ teal::validate_has_data(ANL[, c(x_var, y_var)], 10, complete = TRUE, allow_inf = FALSE) |
| 452 | -! | +||
| 670 | +
- plot_call = plot_call,+ |
||
| 453 | +671 | ! |
- x_cl = x_cl,+ if (log_x) {
|
| 454 | +672 | ! |
- resp_cl = resp_cl,+ validate( |
| 455 | +673 | ! |
- hjust_value = if (swap_axes) "left" else "middle",+ need( |
| 456 | +674 | ! |
- vjust_value = if (swap_axes) "middle" else -1,+ is.numeric(ANL[[x_var]]) && all( |
| 457 | +675 | ! |
- position_anl2_value = if (!freq) quote(position_fill(0.5)) else quote(position_stack(0.5)),+ ANL[[x_var]] > 0 | is.na(ANL[[x_var]]) |
| 458 | -! | +||
| 676 | +
- anl3_y = if (!freq) 1.1 else as.name("ns"),
+ ), |
||
| 459 | +677 | ! |
- position_anl3_value = if (!freq) "fill" else "stack"+ "X variable can only be log transformed if variable is numeric and all values are positive." |
| 460 | +678 |
) |
|
| 461 | +679 |
) |
|
| 462 | +680 |
} |
|
| 463 | -- | - - | -|
| 464 | +681 | ! |
- if (swap_axes) {
+ if (log_y) {
|
| 465 | +682 | ! |
- plot_call <- substitute(plot_call + coord_flip(), env = list(plot_call = plot_call))+ validate( |
| 466 | -+ | ||
| 683 | +! |
- }+ need( |
|
| 467 | -+ | ||
| 684 | +! |
-
+ is.numeric(ANL[[y_var]]) && all( |
|
| 468 | +685 | ! |
- facet_cl <- facet_ggplot_call(row_facet_name, col_facet_name)+ ANL[[y_var]] > 0 | is.na(ANL[[y_var]]) |
| 469 | +686 |
-
+ ), |
|
| 470 | +687 | ! |
- if (!is.null(facet_cl)) {
+ "Y variable can only be log transformed if variable is numeric and all values are positive." |
| 471 | -! | +||
| 688 | +
- plot_call <- substitute(expr = plot_call + facet_cl, env = list(plot_call = plot_call, facet_cl = facet_cl))+ ) |
||
| 472 | +689 |
- }+ ) |
|
| 473 | +690 |
-
+ } |
|
| 474 | -! | +||
| 691 | +
- dev_ggplot2_args <- teal.widgets::ggplot2_args(+ |
||
| 475 | +692 | ! |
- labs = list(+ facet_cl <- facet_ggplot_call( |
| 476 | +693 | ! |
- x = varname_w_label(x, ANL),+ row_facet_name, |
| 477 | +694 | ! |
- y = varname_w_label(resp_var, ANL, prefix = "Proportion of "),+ col_facet_name, |
| 478 | +695 | ! |
- fill = varname_w_label(resp_var, ANL)- |
-
| 479 | -- |
- ),+ free_x_scales = isTRUE(input$free_scales), |
|
| 480 | +696 | ! |
- theme = list(legend.position = "bottom")+ free_y_scales = isTRUE(input$free_scales) |
| 481 | +697 |
) |
|
| 482 | +698 | ||
| 483 | +699 | ! |
- if (rotate_xaxis_labels) {
+ point_sizes <- if (length(size_by_var) > 0) {
|
| 484 | +700 | ! |
- dev_ggplot2_args$theme[["axis.text.x"]] <- quote(element_text(angle = 45, hjust = 1))- |
-
| 485 | -- |
- }- |
- |
| 486 | -- |
-
+ validate(need(is.numeric(ANL[[size_by_var]]), "Variable to size by must be numeric")) |
|
| 487 | +701 | ! |
- all_ggplot2_args <- teal.widgets::resolve_ggplot2_args(+ substitute( |
| 488 | +702 | ! |
- user_plot = ggplot2_args,+ expr = size * ANL[[size_by_var]] / max(ANL[[size_by_var]], na.rm = TRUE), |
| 489 | +703 | ! |
- module_plot = dev_ggplot2_args+ env = list(size = size, size_by_var = size_by_var) |
| 490 | +704 |
- )+ ) |
|
| 491 | +705 |
-
+ } else {
|
|
| 492 | +706 | ! |
- parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(+ size |
| 493 | -! | +||
| 707 | +
- all_ggplot2_args,+ } |
||
| 494 | -! | +||
| 708 | +
- ggtheme = ggtheme+ |
||
| 495 | -+ | ||
| 709 | +! |
- )+ plot_q <- merged$anl_q_r() |
|
| 496 | +710 | ||
| 497 | +711 | ! |
- plot_call <- substitute(expr = {
+ if (log_x) {
|
| 498 | +712 | ! |
- p <- plot_call + labs + ggthemes + themes+ log_x_fn <- input$log_x_base |
| 499 | +713 | ! |
- print(p)+ plot_q <- teal.code::eval_code( |
| 500 | +714 | ! |
- }, env = list(+ object = plot_q, |
| 501 | +715 | ! |
- plot_call = plot_call,+ code = substitute( |
| 502 | +716 | ! |
- labs = parsed_ggplot2_args$labs,+ expr = ANL[, log_x_var] <- log_x_fn(ANL[, x_var]), # nolint: object_name. |
| 503 | +717 | ! |
- themes = parsed_ggplot2_args$theme,+ env = list( |
| 504 | +718 | ! |
- ggthemes = parsed_ggplot2_args$ggtheme- |
-
| 505 | -- |
- ))+ x_var = x_var, |
|
| 506 | -+ | ||
| 719 | +! |
-
+ log_x_fn = as.name(log_x_fn), |
|
| 507 | +720 | ! |
- teal.code::eval_code(qenv, plot_call)+ log_x_var = paste0(log_x_fn, "_", x_var) |
| 508 | +721 |
- })+ ) |
|
| 509 | +722 |
-
+ ) |
|
| 510 | -! | +||
| 723 | +
- plot_r <- reactive(output_q()[["p"]])+ ) |
||
| 511 | +724 |
-
+ } |
|
| 512 | +725 |
- # Insert the plot into a plot_with_settings module from teal.widgets+ |
|
| 513 | +726 | ! |
- pws <- teal.widgets::plot_with_settings_srv(+ if (log_y) {
|
| 514 | +727 | ! |
- id = "myplot",+ log_y_fn <- input$log_y_base |
| 515 | +728 | ! |
- plot_r = plot_r,+ plot_q <- teal.code::eval_code( |
| 516 | +729 | ! |
- height = plot_height,+ object = plot_q, |
| 517 | +730 | ! |
- width = plot_width- |
-
| 518 | -- |
- )- |
- |
| 519 | -- |
-
+ code = substitute( |
|
| 520 | +731 | ! |
- teal.widgets::verbatim_popup_srv(+ expr = ANL[, log_y_var] <- log_y_fn(ANL[, y_var]), # nolint: object_name. |
| 521 | +732 | ! |
- id = "warning",+ env = list( |
| 522 | +733 | ! |
- verbatim_content = reactive(teal.code::get_warnings(output_q())),+ y_var = y_var, |
| 523 | +734 | ! |
- title = "Warning",+ log_y_fn = as.name(log_y_fn), |
| 524 | +735 | ! |
- disabled = reactive(is.null(teal.code::get_warnings(output_q())))+ log_y_var = paste0(log_y_fn, "_", y_var) |
| 525 | +736 |
- )+ ) |
|
| 526 | +737 | - - | -|
| 527 | -! | -
- teal.widgets::verbatim_popup_srv(- |
- |
| 528 | -! | -
- id = "rcode",- |
- |
| 529 | -! | -
- verbatim_content = reactive(teal.code::get_code(output_q())),+ ) |
|
| 530 | -! | +||
| 738 | +
- title = "Show R Code for Response"+ ) |
||
| 531 | +739 |
- )+ } |
|
| 532 | +740 | ||
| 533 | -+ | ||
| 741 | +! |
- ### REPORTER+ pre_pro_anl <- if (input$show_count) {
|
|
| 534 | +742 | ! |
- if (with_reporter) {
+ paste0( |
| 535 | +743 | ! |
- card_fun <- function(comment, label) {
+ "ANL %>% dplyr::group_by(",
|
| 536 | +744 | ! |
- card <- teal::report_card_template(+ paste( |
| 537 | +745 | ! |
- title = "Response Plot",+ c( |
| 538 | +746 | ! |
- label = label,+ if (length(color_by_var) > 0 && inherits(ANL[[color_by_var]], c("factor", "character"))) color_by_var,
|
| 539 | +747 | ! |
- with_filter = with_filter,+ row_facet_name, |
| 540 | +748 | ! |
- filter_panel_api = filter_panel_api+ col_facet_name |
| 541 | +749 |
- )- |
- |
| 542 | -! | -
- card$append_text("Plot", "header3")
+ ), |
|
| 543 | +750 | ! |
- card$append_plot(plot_r(), dim = pws$dim())+ collapse = ", " |
| 544 | -! | +||
| 751 | +
- if (!comment == "") {
+ ), |
||
| 545 | +752 | ! |
- card$append_text("Comment", "header3")
+ ") %>% dplyr::mutate(n = dplyr::n()) %>% dplyr::ungroup()" |
| 546 | -! | +||
| 753 | +
- card$append_text(comment)+ ) |
||
| 547 | +754 |
- }+ } else {
|
|
| 548 | +755 | ! |
- card$append_src(teal.code::get_code(output_q()))+ "ANL" |
| 549 | -! | +||
| 756 | +
- card+ } |
||
| 550 | +757 |
- }+ |
|
| 551 | +758 | ! |
- teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
+ plot_call <- substitute(expr = pre_pro_anl %>% ggplot(), env = list(pre_pro_anl = str2lang(pre_pro_anl))) |
| 552 | +759 |
- }+ |
|
| 553 | -+ | ||
| 760 | +! |
- ###+ plot_call <- if (length(color_by_var) == 0) {
|
|
| 554 | -+ | ||
| 761 | +! |
- })+ substitute( |
|
| 555 | -+ | ||
| 762 | +! |
- }+ expr = plot_call + |
| 1 | -+ | ||
| 763 | +! |
- #' Stack Plots of variables and show association with reference variable+ ggplot2::aes(x = x_name, y = y_name) + |
|
| 2 | -+ | ||
| 764 | +! |
- #' @md+ ggplot2::geom_point(alpha = alpha_value, size = point_sizes, shape = shape_value, color = color_value), |
|
| 3 | -+ | ||
| 765 | +! |
- #'+ env = list( |
|
| 4 | -+ | ||
| 766 | +! |
- #' @inheritParams teal::module+ plot_call = plot_call, |
|
| 5 | -+ | ||
| 767 | +! |
- #' @inheritParams shared_params+ x_name = if (log_x) as.name(paste0(log_x_fn, "_", x_var)) else as.name(x_var), |
|
| 6 | -+ | ||
| 768 | +! |
- #' @param ref (`data_extract_spec` or `list` of multiple `data_extract_spec`)+ y_name = if (log_y) as.name(paste0(log_y_fn, "_", y_var)) else as.name(y_var), |
|
| 7 | -+ | ||
| 769 | +! |
- #' reference variable, must set `multiple = FALSE`.+ alpha_value = alpha, |
|
| 8 | -+ | ||
| 770 | +! |
- #' @param vars (`data_extract_spec` or `list` of multiple `data_extract_spec`)+ point_sizes = point_sizes, |
|
| 9 | -+ | ||
| 771 | +! |
- #' associated variables.+ shape_value = shape, |
|
| 10 | -+ | ||
| 772 | +! |
- #' @param show_association optional, (`logical`) Whether show association of `vars`+ color_value = color |
|
| 11 | +773 |
- #' with reference variable. Defaults to `TRUE`.+ ) |
|
| 12 | +774 |
- #' @param distribution_theme,association_theme optional, (`character`) `ggplot2` themes to be used by default.+ ) |
|
| 13 | +775 |
- #' Default to `"gray"`.+ } else {
|
|
| 14 | -+ | ||
| 776 | +! |
- #'+ substitute( |
|
| 15 | -+ | ||
| 777 | +! |
- #' @templateVar ggnames "Bivariate1", "Bivariate2"+ expr = plot_call + |
|
| 16 | -+ | ||
| 778 | +! |
- #' @template ggplot2_args_multi+ ggplot2::aes(x = x_name, y = y_name, color = color_by_var_name) + |
|
| 17 | -+ | ||
| 779 | +! |
- #'+ ggplot2::geom_point(alpha = alpha_value, size = point_sizes, shape = shape_value), |
|
| 18 | -+ | ||
| 780 | +! |
- #' @note For more examples, please see the vignette "Using association plot" via+ env = list( |
|
| 19 | -+ | ||
| 781 | +! |
- #' \code{vignette("using-association-plot", package = "teal.modules.general")}.
+ plot_call = plot_call, |
|
| 20 | -+ | ||
| 782 | +! |
- #'+ x_name = if (log_x) as.name(paste0(log_x_fn, "_", x_var)) else as.name(x_var), |
|
| 21 | -+ | ||
| 783 | +! |
- #' @examples+ y_name = if (log_y) as.name(paste0(log_y_fn, "_", y_var)) else as.name(y_var), |
|
| 22 | -+ | ||
| 784 | +! |
- #' # general data exapmle+ color_by_var_name = as.name(color_by_var), |
|
| 23 | -+ | ||
| 785 | +! |
- #' library(teal.widgets)+ alpha_value = alpha, |
|
| 24 | -+ | ||
| 786 | +! |
- #'+ point_sizes = point_sizes, |
|
| 25 | -+ | ||
| 787 | +! |
- #' data <- teal_data()+ shape_value = shape |
|
| 26 | +788 |
- #' data <- within(data, {
+ ) |
|
| 27 | +789 |
- #' library(nestcolor)+ ) |
|
| 28 | +790 |
- #' CO2 <- CO2+ } |
|
| 29 | +791 |
- #' factors <- names(Filter(isTRUE, vapply(CO2, is.factor, logical(1L))))+ |
|
| 30 | -+ | ||
| 792 | +! |
- #' CO2[factors] <- lapply(CO2[factors], as.character)+ if (rug_plot) plot_call <- substitute(expr = plot_call + geom_rug(), env = list(plot_call = plot_call)) |
|
| 31 | +793 |
- #' })+ |
|
| 32 | -+ | ||
| 794 | +! |
- #' datanames(data) <- c("CO2")
+ plot_label_generator <- function(rhs_formula = quote(y ~ 1), |
|
| 33 | -+ | ||
| 795 | +! |
- #'+ show_form = input$show_form, |
|
| 34 | -+ | ||
| 796 | +! |
- #' app <- init(+ show_r2 = input$show_r2, |
|
| 35 | -+ | ||
| 797 | +! |
- #' data = data,+ show_count = input$show_count, |
|
| 36 | -+ | ||
| 798 | +! |
- #' modules = modules(+ pos = input$pos, |
|
| 37 | -+ | ||
| 799 | +! |
- #' tm_g_association(+ label_size = input$label_size) {
|
|
| 38 | -+ | ||
| 800 | +! |
- #' ref = data_extract_spec(+ stopifnot(sum(show_form, show_r2, show_count) >= 1) |
|
| 39 | -+ | ||
| 801 | +! |
- #' dataname = "CO2",+ aes_label <- paste0( |
|
| 40 | -+ | ||
| 802 | +! |
- #' select = select_spec(+ "aes(",
|
|
| 41 | -+ | ||
| 803 | +! |
- #' label = "Select variable:",+ if (show_count) "n = n, ", |
|
| 42 | -+ | ||
| 804 | +! |
- #' choices = variable_choices(data[["CO2"]], c("Plant", "Type", "Treatment")),
+ "label = ", |
|
| 43 | -+ | ||
| 805 | +! |
- #' selected = "Plant",+ if (sum(show_form, show_r2, show_count) > 1) "paste(",
|
|
| 44 | -+ | ||
| 806 | +! |
- #' fixed = FALSE+ paste( |
|
| 45 | -+ | ||
| 807 | +! |
- #' )+ c( |
|
| 46 | -+ | ||
| 808 | +! |
- #' ),+ if (show_form) "stat(eq.label)", |
|
| 47 | -+ | ||
| 809 | +! |
- #' vars = data_extract_spec(+ if (show_r2) "stat(adj.rr.label)", |
|
| 48 | -+ | ||
| 810 | +! |
- #' dataname = "CO2",+ if (show_count) "paste('N ~`=`~', n)"
|
|
| 49 | +811 |
- #' select = select_spec(+ ), |
|
| 50 | -+ | ||
| 812 | +! |
- #' label = "Select variables:",+ collapse = ", " |
|
| 51 | +813 |
- #' choices = variable_choices(data[["CO2"]], c("Plant", "Type", "Treatment")),
+ ), |
|
| 52 | -+ | ||
| 814 | +! |
- #' selected = "Treatment",+ if (sum(show_form, show_r2, show_count) > 1) ", sep = '*\", \"*'))" else ")" |
|
| 53 | +815 |
- #' multiple = TRUE,+ ) |
|
| 54 | -+ | ||
| 816 | +! |
- #' fixed = FALSE+ label_geom <- substitute( |
|
| 55 | -+ | ||
| 817 | +! |
- #' )+ expr = ggpmisc::stat_poly_eq( |
|
| 56 | -+ | ||
| 818 | +! |
- #' ),+ mapping = aes_label, |
|
| 57 | -+ | ||
| 819 | +! |
- #' ggplot2_args = ggplot2_args(+ formula = rhs_formula, |
|
| 58 | -+ | ||
| 820 | +! |
- #' labs = list(subtitle = "Plot generated by Association Module")+ parse = TRUE, |
|
| 59 | -+ | ||
| 821 | +! |
- #' )+ label.x = pos, |
|
| 60 | -+ | ||
| 822 | +! |
- #' )+ size = label_size |
|
| 61 | +823 |
- #' )+ ), |
|
| 62 | -+ | ||
| 824 | +! |
- #' )+ env = list( |
|
| 63 | -+ | ||
| 825 | +! |
- #' if (interactive()) {
+ rhs_formula = rhs_formula, |
|
| 64 | -+ | ||
| 826 | +! |
- #' shinyApp(app$ui, app$server)+ pos = pos, |
|
| 65 | -+ | ||
| 827 | +! |
- #' }+ aes_label = str2lang(aes_label), |
|
| 66 | -+ | ||
| 828 | +! |
- #'+ label_size = label_size |
|
| 67 | +829 |
- #' # CDISC data example+ ) |
|
| 68 | +830 |
- #' library(teal.widgets)+ ) |
|
| 69 | -+ | ||
| 831 | +! |
- #'+ substitute( |
|
| 70 | -+ | ||
| 832 | +! |
- #' data <- teal_data()+ expr = plot_call + label_geom, |
|
| 71 | -+ | ||
| 833 | +! |
- #' data <- within(data, {
+ env = list( |
|
| 72 | -+ | ||
| 834 | +! |
- #' library(nestcolor)+ plot_call = plot_call, |
|
| 73 | -+ | ||
| 835 | +! |
- #' ADSL <- rADSL+ label_geom = label_geom |
|
| 74 | +836 |
- #' })+ ) |
|
| 75 | +837 |
- #' datanames(data) <- "ADSL"+ ) |
|
| 76 | +838 |
- #' join_keys(data) <- default_cdisc_join_keys[datanames(data)]+ } |
|
| 77 | +839 |
- #'+ |
|
| 78 | -+ | ||
| 840 | +! |
- #' app <- init(+ if (trend_line_is_applicable()) {
|
|
| 79 | -+ | ||
| 841 | +! |
- #' data = data,+ shinyjs::hide("line_msg")
|
|
| 80 | -+ | ||
| 842 | +! |
- #' modules = modules(+ shinyjs::show("smoothing_degree")
|
|
| 81 | -+ | ||
| 843 | +! |
- #' tm_g_association(+ if (!add_trend_line()) {
|
|
| 82 | -+ | ||
| 844 | +! |
- #' ref = data_extract_spec(+ shinyjs::hide("ci")
|
|
| 83 | -+ | ||
| 845 | +! |
- #' dataname = "ADSL",+ shinyjs::hide("color_sub")
|
|
| 84 | -+ | ||
| 846 | +! |
- #' select = select_spec(+ shinyjs::hide("show_form")
|
|
| 85 | -+ | ||
| 847 | +! |
- #' label = "Select variable:",+ shinyjs::hide("show_r2")
|
|
| 86 | -+ | ||
| 848 | +! |
- #' choices = variable_choices(+ if (input$show_count) {
|
|
| 87 | -+ | ||
| 849 | +! |
- #' data[["ADSL"]],+ plot_call <- plot_label_generator(show_form = FALSE, show_r2 = FALSE) |
|
| 88 | -+ | ||
| 850 | +! |
- #' c("SEX", "RACE", "COUNTRY", "ARM", "STRATA1", "STRATA2", "ITTFL", "BMRKR2")
+ shinyjs::show("label_pos")
|
|
| 89 | -+ | ||
| 851 | +! |
- #' ),+ shinyjs::show("label_size")
|
|
| 90 | +852 |
- #' selected = "RACE",+ } else {
|
|
| 91 | -+ | ||
| 853 | +! |
- #' fixed = FALSE+ shinyjs::hide("label_pos")
|
|
| 92 | -+ | ||
| 854 | +! |
- #' )+ shinyjs::hide("label_size")
|
|
| 93 | +855 |
- #' ),+ } |
|
| 94 | +856 |
- #' vars = data_extract_spec(+ } else {
|
|
| 95 | -+ | ||
| 857 | +! |
- #' dataname = "ADSL",+ shinyjs::show("ci")
|
|
| 96 | -+ | ||
| 858 | +! |
- #' select = select_spec(+ shinyjs::show("show_form")
|
|
| 97 | -+ | ||
| 859 | +! |
- #' label = "Select variables:",+ shinyjs::show("show_r2")
|
|
| 98 | -+ | ||
| 860 | +! |
- #' choices = variable_choices(+ if (nrow(ANL) - nrow(stats::na.omit(ANL[, c(x_var, y_var)])) > 0) {
|
|
| 99 | -+ | ||
| 861 | +! |
- #' data[["ADSL"]],+ plot_q <- teal.code::eval_code( |
|
| 100 | -+ | ||
| 862 | +! |
- #' c("SEX", "RACE", "COUNTRY", "ARM", "STRATA1", "STRATA2", "ITTFL", "BMRKR2")
+ plot_q, |
|
| 101 | -+ | ||
| 863 | +! |
- #' ),+ substitute( |
|
| 102 | -+ | ||
| 864 | +! |
- #' selected = "BMRKR2",+ expr = ANL <- dplyr::filter(ANL, !is.na(x_var) & !is.na(y_var)), # nolint: object_name. |
|
| 103 | -+ | ||
| 865 | +! |
- #' multiple = TRUE,+ env = list(x_var = as.name(x_var), y_var = as.name(y_var)) |
|
| 104 | +866 |
- #' fixed = FALSE+ ) |
|
| 105 | +867 |
- #' )+ ) |
|
| 106 | +868 |
- #' ),+ } |
|
| 107 | -+ | ||
| 869 | +! |
- #' ggplot2_args = ggplot2_args(+ rhs_formula <- substitute( |
|
| 108 | -+ | ||
| 870 | +! |
- #' labs = list(subtitle = "Plot generated by Association Module")+ expr = y ~ poly(x, smoothing_degree, raw = TRUE), |
|
| 109 | -+ | ||
| 871 | +! |
- #' )+ env = list(smoothing_degree = smoothing_degree) |
|
| 110 | +872 |
- #' )+ ) |
|
| 111 | -+ | ||
| 873 | +! |
- #' )+ if (input$show_form || input$show_r2 || input$show_count) {
|
|
| 112 | -+ | ||
| 874 | +! |
- #' )+ plot_call <- plot_label_generator(rhs_formula = rhs_formula) |
|
| 113 | -+ | ||
| 875 | +! |
- #' if (interactive()) {
+ shinyjs::show("label_pos")
|
|
| 114 | -+ | ||
| 876 | +! |
- #' shinyApp(app$ui, app$server)+ shinyjs::show("label_size")
|
|
| 115 | +877 |
- #' }+ } else {
|
|
| 116 | -+ | ||
| 878 | +! |
- #'+ shinyjs::hide("label_pos")
|
|
| 117 | -+ | ||
| 879 | +! |
- #' @export+ shinyjs::hide("label_size")
|
|
| 118 | +880 |
- #'+ } |
|
| 119 | -+ | ||
| 881 | +! |
- tm_g_association <- function(label = "Association",+ plot_call <- substitute( |
|
| 120 | -+ | ||
| 882 | +! |
- ref,+ expr = plot_call + ggplot2::geom_smooth(formula = rhs_formula, se = TRUE, level = ci, method = "lm"), |
|
| 121 | -+ | ||
| 883 | +! |
- vars,+ env = list(plot_call = plot_call, rhs_formula = rhs_formula, ci = ci) |
|
| 122 | +884 |
- show_association = TRUE,+ ) |
|
| 123 | +885 |
- plot_height = c(600, 400, 5000),+ } |
|
| 124 | +886 |
- plot_width = NULL,+ } else {
|
|
| 125 | -+ | ||
| 887 | +! |
- distribution_theme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void"), # nolint: line_length.
+ shinyjs::hide("smoothing_degree")
|
|
| 126 | -+ | ||
| 888 | +! |
- association_theme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void"), # nolint: line_length.
+ shinyjs::hide("ci")
|
|
| 127 | -+ | ||
| 889 | +! |
- pre_output = NULL,+ shinyjs::hide("color_sub")
|
|
| 128 | -+ | ||
| 890 | +! |
- post_output = NULL,+ shinyjs::hide("show_form")
|
|
| 129 | -+ | ||
| 891 | +! |
- ggplot2_args = teal.widgets::ggplot2_args()) {
+ shinyjs::hide("show_r2")
|
|
| 130 | +892 | ! |
- logger::log_info("Initializing tm_g_association")
+ if (input$show_count) {
|
| 131 | +893 | ! |
- if (inherits(ref, "data_extract_spec")) ref <- list(ref)+ plot_call <- plot_label_generator(show_form = FALSE, show_r2 = FALSE) |
| 132 | +894 | ! |
- if (inherits(vars, "data_extract_spec")) vars <- list(vars)+ shinyjs::show("label_pos")
|
| 133 | +895 | ! |
- if (inherits(ggplot2_args, "ggplot2_args")) ggplot2_args <- list(default = ggplot2_args)+ shinyjs::show("label_size")
|
| 134 | +896 |
-
+ } else {
|
|
| 135 | +897 | ! |
- checkmate::assert_string(label)+ shinyjs::hide("label_pos")
|
| 136 | +898 | ! |
- checkmate::assert_list(ref, types = "data_extract_spec")+ shinyjs::hide("label_size")
|
| 137 | -! | +||
| 899 | +
- if (!all(vapply(ref, function(x) !x$select$multiple, logical(1)))) {
+ } |
||
| 138 | +900 | ! |
- stop("'ref' should not allow multiple selection")
+ shinyjs::show("line_msg")
|
| 139 | +901 |
- }+ } |
|
| 140 | -! | +||
| 902 | +
- checkmate::assert_list(vars, types = "data_extract_spec")+ |
||
| 141 | +903 | ! |
- checkmate::assert_flag(show_association)+ if (!is.null(facet_cl)) {
|
| 142 | +904 | ! |
- checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE)+ plot_call <- substitute(expr = plot_call + facet_cl, env = list(plot_call = plot_call, facet_cl = facet_cl))+ |
+
| 905 | ++ |
+ }+ |
+ |
| 906 | ++ | + | |
| 143 | +907 | ! |
- checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height")+ y_label <- varname_w_label( |
| 144 | +908 | ! |
- checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE)+ y_var, |
| 145 | +909 | ! |
- checkmate::assert_numeric(+ ANL, |
| 146 | +910 | ! |
- plot_width[1],+ prefix = if (log_y) paste(log_y_fn, "(") else NULL,
|
| 147 | +911 | ! |
- lower = plot_width[2], upper = plot_width[3], null.ok = TRUE, .var.name = "plot_width"+ suffix = if (log_y) ")" else NULL |
| 148 | +912 |
- )+ ) |
|
| 149 | +913 | ! |
- distribution_theme <- match.arg(distribution_theme)+ x_label <- varname_w_label( |
| 150 | +914 | ! |
- association_theme <- match.arg(association_theme)+ x_var, |
| 151 | +915 | ! |
- plot_choices <- c("Bivariate1", "Bivariate2")
+ ANL, |
| 152 | +916 | ! |
- checkmate::assert_list(ggplot2_args, types = "ggplot2_args")+ prefix = if (log_x) paste(log_x_fn, "(") else NULL,
|
| 153 | +917 | ! |
- checkmate::assert_subset(names(ggplot2_args), c("default", plot_choices))
+ suffix = if (log_x) ")" else NULL |
| 154 | +918 | - - | -|
| 155 | -! | -
- args <- as.list(environment())+ ) |
|
| 156 | +919 | ||
| 157 | +920 | ! |
- data_extract_list <- list(+ dev_ggplot2_args <- teal.widgets::ggplot2_args( |
| 158 | +921 | ! |
- ref = ref,+ labs = list(y = y_label, x = x_label), |
| 159 | +922 | ! |
- vars = vars+ theme = list(legend.position = "bottom") |
| 160 | +923 |
- )+ ) |
|
| 161 | +924 | ||
| 162 | +925 | ! |
- module(+ if (rotate_xaxis_labels) {
|
| 163 | +926 | ! |
- label = label,+ dev_ggplot2_args$theme[["axis.text.x"]] <- quote(element_text(angle = 45, hjust = 1)) |
| 164 | -! | +||
| 927 | +
- server = srv_tm_g_association,+ } |
||
| 165 | -! | +||
| 928 | +
- ui = ui_tm_g_association,+ |
||
| 166 | +929 | ! |
- ui_args = args,+ all_ggplot2_args <- teal.widgets::resolve_ggplot2_args( |
| 167 | +930 | ! |
- server_args = c(+ user_plot = ggplot2_args, |
| 168 | +931 | ! |
- data_extract_list,+ module_plot = dev_ggplot2_args |
| 169 | -! | +||
| 932 | +
- list(plot_height = plot_height, plot_width = plot_width, ggplot2_args = ggplot2_args)+ ) |
||
| 170 | +933 |
- ),+ |
|
| 171 | +934 | ! |
- datanames = teal.transform::get_extract_datanames(data_extract_list)+ parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(all_ggplot2_args, ggtheme = ggtheme) |
| 172 | +935 |
- )+ |
|
| 173 | +936 |
- }+ |
|
| 174 | -+ | ||
| 937 | +! |
-
+ if (add_density) {
|
|
| 175 | -+ | ||
| 938 | +! |
- ui_tm_g_association <- function(id, ...) {
+ plot_call <- substitute( |
|
| 176 | +939 | ! |
- ns <- NS(id)+ expr = ggExtra::ggMarginal( |
| 177 | +940 | ! |
- args <- list(...)+ plot_call + labs + ggthemes + themes, |
| 178 | +941 | ! |
- is_single_dataset_value <- teal.transform::is_single_dataset(args$ref, args$vars)+ type = "density",+ |
+
| 942 | +! | +
+ groupColour = group_colour |
|
| 179 | +943 |
-
+ ), |
|
| 180 | +944 | ! |
- teal.widgets::standard_layout(+ env = list( |
| 181 | +945 | ! |
- output = teal.widgets::white_small_well(+ plot_call = plot_call, |
| 182 | +946 | ! |
- textOutput(ns("title")),
+ group_colour = if (length(color_by_var) > 0) TRUE else FALSE, |
| 183 | +947 | ! |
- tags$br(),+ labs = parsed_ggplot2_args$labs, |
| 184 | +948 | ! |
- teal.widgets::plot_with_settings_ui(id = ns("myplot"))
- |
-
| 185 | -- |
- ),+ ggthemes = parsed_ggplot2_args$ggtheme, |
|
| 186 | +949 | ! |
- encoding = div(+ themes = parsed_ggplot2_args$theme |
| 187 | +950 |
- ### Reporter+ ) |
|
| 188 | -! | +||
| 951 | +
- teal.reporter::simple_reporter_ui(ns("simple_reporter")),
+ ) |
||
| 189 | +952 |
- ###+ } else {
|
|
| 190 | +953 | ! |
- tags$label("Encodings", class = "text-primary"),
+ plot_call <- substitute( |
| 191 | +954 | ! |
- teal.transform::datanames_input(args[c("ref", "vars")]),
+ expr = plot_call + |
| 192 | +955 | ! |
- teal.transform::data_extract_ui(+ labs + |
| 193 | +956 | ! |
- id = ns("ref"),
+ ggthemes + |
| 194 | +957 | ! |
- label = "Reference variable",+ themes, |
| 195 | +958 | ! |
- data_extract_spec = args$ref,+ env = list( |
| 196 | +959 | ! |
- is_single_dataset = is_single_dataset_value+ plot_call = plot_call, |
| 197 | -+ | ||
| 960 | +! |
- ),+ labs = parsed_ggplot2_args$labs, |
|
| 198 | +961 | ! |
- teal.transform::data_extract_ui(+ ggthemes = parsed_ggplot2_args$ggtheme, |
| 199 | +962 | ! |
- id = ns("vars"),
+ themes = parsed_ggplot2_args$theme |
| 200 | -! | +||
| 963 | +
- label = "Associated variables",+ ) |
||
| 201 | -! | +||
| 964 | +
- data_extract_spec = args$vars,+ ) |
||
| 202 | -! | +||
| 965 | +
- is_single_dataset = is_single_dataset_value+ } |
||
| 203 | +966 |
- ),+ |
|
| 204 | +967 | ! |
- checkboxInput(+ plot_call <- substitute(expr = p <- plot_call, env = list(plot_call = plot_call)) |
| 205 | -! | +||
| 968 | +
- ns("association"),
+
|
||
| 206 | +969 | ! |
- "Association with reference variable",+ teal.code::eval_code(plot_q, plot_call) %>% |
| 207 | +970 | ! |
- value = args$show_association+ teal.code::eval_code(quote(print(p))) |
| 208 | +971 |
- ),+ }) |
|
| 209 | -! | +||
| 972 | +
- checkboxInput(+ |
||
| 210 | +973 | ! |
- ns("show_dist"),
+ plot_r <- reactive(output_q()[["p"]]) |
| 211 | -! | +||
| 974 | +
- "Scaled frequencies",+ |
||
| 212 | -! | +||
| 975 | +
- value = FALSE+ # Insert the plot into a plot_with_settings module from teal.widgets |
||
| 213 | -+ | ||
| 976 | +! |
- ),+ pws <- teal.widgets::plot_with_settings_srv( |
|
| 214 | +977 | ! |
- checkboxInput(+ id = "scatter_plot", |
| 215 | +978 | ! |
- ns("log_transformation"),
+ plot_r = plot_r, |
| 216 | +979 | ! |
- "Log transformed",+ height = plot_height, |
| 217 | +980 | ! |
- value = FALSE+ width = plot_width,+ |
+
| 981 | +! | +
+ brushing = TRUE |
|
| 218 | +982 |
- ),+ ) |
|
| 219 | -! | +||
| 983 | +
- teal.widgets::panel_group(+ |
||
| 220 | +984 | ! |
- teal.widgets::panel_item(+ output$data_table <- DT::renderDataTable({
|
| 221 | +985 | ! |
- title = "Plot settings",+ plot_brush <- pws$brush() |
| 222 | -! | +||
| 986 | +
- teal.widgets::optionalSliderInputValMinMax(ns("alpha"), "Scatterplot opacity:", c(0.5, 0, 1), ticks = FALSE),
+
|
||
| 223 | +987 | ! |
- teal.widgets::optionalSliderInputValMinMax(ns("size"), "Scatterplot points size:", c(2, 1, 8), ticks = FALSE),
+ if (!is.null(plot_brush)) {
|
| 224 | +988 | ! |
- checkboxInput(ns("swap_axes"), "Swap axes", value = FALSE),
+ validate(need(!input$add_density, "Brushing feature is currently not supported when plot has marginal density")) |
| 225 | -! | +||
| 989 | +
- checkboxInput(ns("rotate_xaxis_labels"), "Rotate X axis labels", value = FALSE),
+ } |
||
| 226 | -! | +||
| 990 | +
- selectInput(+ |
||
| 227 | +991 | ! |
- inputId = ns("distribution_theme"),
+ merged_data <- isolate(teal.code::dev_suppress(output_q()[["ANL"]])) |
| 228 | -! | +||
| 992 | +
- label = "Distribution theme (by ggplot):",+ |
||
| 229 | +993 | ! |
- choices = ggplot_themes,+ brushed_df <- teal.widgets::clean_brushedPoints(merged_data, plot_brush) |
| 230 | +994 | ! |
- selected = args$distribution_theme,+ numeric_cols <- names(brushed_df)[ |
| 231 | +995 | ! |
- multiple = FALSE+ vapply(brushed_df, function(x) is.numeric(x) && !is.integer(x), FUN.VALUE = logical(1)) |
| 232 | +996 |
- ),+ ] |
|
| 233 | -! | +||
| 997 | +
- selectInput(+ |
||
| 234 | +998 | ! |
- inputId = ns("association_theme"),
+ if (length(numeric_cols) > 0) {
|
| 235 | +999 | ! |
- label = "Association theme (by ggplot):",+ DT::formatRound( |
| 236 | +1000 | ! |
- choices = ggplot_themes,+ DT::datatable(brushed_df, |
| 237 | +1001 | ! |
- selected = args$association_theme,+ rownames = FALSE, |
| 238 | +1002 | ! |
- multiple = FALSE+ options = list(scrollX = TRUE, pageLength = input$data_table_rows) |
| 239 | +1003 |
- )+ ), |
|
| 240 | -+ | ||
| 1004 | +! |
- )+ numeric_cols,+ |
+ |
| 1005 | +! | +
+ table_dec |
|
| 241 | +1006 |
- )+ ) |
|
| 242 | +1007 |
- ),+ } else {
|
|
| 243 | +1008 | ! |
- forms = tagList(+ DT::datatable(brushed_df, rownames = FALSE, options = list(scrollX = TRUE, pageLength = input$data_table_rows)) |
| 244 | -! | +||
| 1009 | +
- teal.widgets::verbatim_popup_ui(ns("warning"), "Show Warnings"),
+ } |
||
| 245 | -! | +||
| 1010 | +
- teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code")
+ }) |
||
| 246 | +1011 |
- ),+ |
|
| 247 | +1012 | ! |
- pre_output = args$pre_output,+ teal.widgets::verbatim_popup_srv( |
| 248 | +1013 | ! |
- post_output = args$post_output+ id = "warning", |
| 249 | -+ | ||
| 1014 | +! |
- )+ verbatim_content = reactive(teal.code::get_warnings(output_q())), |
|
| 250 | -+ | ||
| 1015 | +! |
- }+ title = "Warning", |
|
| 251 | -+ | ||
| 1016 | +! |
-
+ disabled = reactive(is.null(teal.code::get_warnings(output_q()))) |
|
| 252 | +1017 |
- srv_tm_g_association <- function(id,+ ) |
|
| 253 | +1018 |
- data,+ |
|
| 254 | -+ | ||
| 1019 | +! |
- reporter,+ teal.widgets::verbatim_popup_srv( |
|
| 255 | -+ | ||
| 1020 | +! |
- filter_panel_api,+ id = "rcode", |
|
| 256 | -+ | ||
| 1021 | +! |
- ref,+ verbatim_content = reactive(teal.code::get_code(output_q())), |
|
| 257 | -+ | ||
| 1022 | +! |
- vars,+ title = "R Code for scatterplot" |
|
| 258 | +1023 |
- plot_height,+ ) |
|
| 259 | +1024 |
- plot_width,+ |
|
| 260 | +1025 |
- ggplot2_args) {
+ ### REPORTER |
|
| 261 | +1026 | ! |
- with_reporter <- !missing(reporter) && inherits(reporter, "Reporter")+ if (with_reporter) {
|
| 262 | +1027 | ! |
- with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI")+ card_fun <- function(comment, label) {
|
| 263 | +1028 | ! |
- checkmate::assert_class(data, "reactive")+ card <- teal::report_card_template( |
| 264 | +1029 | ! |
- checkmate::assert_class(isolate(data()), "teal_data")- |
-
| 265 | -- |
-
+ title = "Scatter Plot", |
|
| 266 | +1030 | ! |
- moduleServer(id, function(input, output, session) {
+ label = label, |
| 267 | +1031 | ! |
- selector_list <- teal.transform::data_extract_multiple_srv(+ with_filter = with_filter, |
| 268 | +1032 | ! |
- data_extract = list(ref = ref, vars = vars),+ filter_panel_api = filter_panel_api |
| 269 | -! | +||
| 1033 | +
- datasets = data,+ ) |
||
| 270 | +1034 | ! |
- select_validation_rule = list(+ card$append_text("Plot", "header3")
|
| 271 | +1035 | ! |
- ref = shinyvalidate::compose_rules(+ card$append_plot(plot_r(), dim = pws$dim()) |
| 272 | +1036 | ! |
- shinyvalidate::sv_required("A reference variable needs to be selected."),
+ if (!comment == "") {
|
| 273 | +1037 | ! |
- ~ if ((.) %in% selector_list()$vars()$select) {
+ card$append_text("Comment", "header3")
|
| 274 | +1038 | ! |
- "Associated variables and reference variable cannot overlap"- |
-
| 275 | -- |
- }+ card$append_text(comment) |
|
| 276 | +1039 |
- ),+ } |
|
| 277 | +1040 | ! |
- vars = shinyvalidate::compose_rules(+ card$append_src(teal.code::get_code(output_q())) |
| 278 | +1041 | ! |
- shinyvalidate::sv_required("An associated variable needs to be selected."),
+ card |
| 279 | -! | +||
| 1042 | +
- ~ if (length(selector_list()$ref()$select) != 0 && selector_list()$ref()$select %in% (.)) {
+ } |
||
| 280 | +1043 | ! |
- "Associated variables and reference variable cannot overlap"+ teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
|
| 281 | +1044 |
- }+ } |
|
| 282 | +1045 |
- )+ ### |
|
| 283 | +1046 |
- )+ }) |
|
| 284 | +1047 |
- )+ } |
| 285 | +1 |
-
+ #' Distribution Module |
|
| 286 | -! | +||
| 2 | +
- iv_r <- reactive({
+ #' @md |
||
| 287 | -! | +||
| 3 | +
- iv <- shinyvalidate::InputValidator$new()+ #' |
||
| 288 | -! | +||
| 4 | +
- teal.transform::compose_and_enable_validators(iv, selector_list)+ #' @details |
||
| 289 | +5 |
- })+ #' Module to analyze and explore univariate variable distribution |
|
| 290 | +6 |
-
+ #' |
|
| 291 | -! | +||
| 7 | +
- anl_merged_input <- teal.transform::merge_expression_srv(+ #' @inheritParams teal::module |
||
| 292 | -! | +||
| 8 | +
- datasets = data,+ #' @inheritParams teal.widgets::standard_layout |
||
| 293 | -! | +||
| 9 | +
- selector_list = selector_list+ #' @inheritParams shared_params |
||
| 294 | +10 |
- )+ #' |
|
| 295 | +11 |
-
+ #' @param dist_var (`data_extract_spec` or `list` of multiple `data_extract_spec`) |
|
| 296 | -! | +||
| 12 | +
- anl_merged_q <- reactive({
+ #' Variable to consider for the distribution analysis. |
||
| 297 | -! | +||
| 13 | +
- req(anl_merged_input())+ #' @param strata_var (`data_extract_spec` or `list` of multiple `data_extract_spec`) |
||
| 298 | -! | +||
| 14 | +
- data() %>% teal.code::eval_code(as.expression(anl_merged_input()$expr))+ #' Categorical variable to split the selected distribution variable on. |
||
| 299 | +15 |
- })+ #' @param group_var optional, (`data_extract_spec` or `list` of multiple `data_extract_spec`) |
|
| 300 | +16 |
-
+ #' Which data columns to use for faceting rows. |
|
| 301 | -! | +||
| 17 | +
- merged <- list(+ #' @param freq optional, (`logical`) Whether to display frequency (`TRUE`) or density (`FALSE`). |
||
| 302 | -! | +||
| 18 | +
- anl_input_r = anl_merged_input,+ #' Defaults to density (`FALSE`). |
||
| 303 | -! | +||
| 19 | +
- anl_q_r = anl_merged_q+ #' @param bins optional, (`integer(1)` or `integer(3)`) If scalar then the histogram bins will have a fixed size. |
||
| 304 | +20 |
- )+ #' If a slider should be presented to adjust the number of histogram bins dynamically then it can be a |
|
| 305 | +21 |
-
+ #' vector of length three with `c(value, min, max)`. |
|
| 306 | -! | +||
| 22 | +
- output_q <- reactive({
+ #' Defaults to `c(30L, 1L, 100L)`. |
||
| 307 | -! | +||
| 23 | +
- teal::validate_inputs(iv_r())+ #' |
||
| 308 | +24 |
-
+ #' @templateVar ggnames "Histogram", "QQplot" |
|
| 309 | -! | +||
| 25 | +
- ANL <- merged$anl_q_r()[["ANL"]] # nolint: object_name.+ #' @template ggplot2_args_multi |
||
| 310 | -! | +||
| 26 | +
- teal::validate_has_data(ANL, 3)+ #' |
||
| 311 | +27 |
-
+ #' @examples |
|
| 312 | -! | +||
| 28 | +
- vars_names <- merged$anl_input_r()$columns_source$vars+ #' # general data example |
||
| 313 | +29 |
-
+ #' library(teal.widgets) |
|
| 314 | -! | +||
| 30 | +
- ref_name <- as.vector(merged$anl_input_r()$columns_source$ref)+ #' |
||
| 315 | -! | +||
| 31 | +
- association <- input$association+ #' data <- teal_data() |
||
| 316 | -! | +||
| 32 | +
- show_dist <- input$show_dist+ #' data <- within(data, {
|
||
| 317 | -! | +||
| 33 | +
- log_transformation <- input$log_transformation+ #' iris <- iris |
||
| 318 | -! | +||
| 34 | +
- rotate_xaxis_labels <- input$rotate_xaxis_labels+ #' }) |
||
| 319 | -! | +||
| 35 | +
- swap_axes <- input$swap_axes+ #' datanames(data) <- "iris" |
||
| 320 | -! | +||
| 36 | +
- distribution_theme <- input$distribution_theme+ #' |
||
| 321 | -! | +||
| 37 | +
- association_theme <- input$association_theme+ #' app <- init( |
||
| 322 | +38 |
-
+ #' data = data, |
|
| 323 | -! | +||
| 39 | +
- is_scatterplot <- is.numeric(ANL[[ref_name]]) && any(vapply(ANL[vars_names], is.numeric, logical(1)))+ #' modules = list( |
||
| 324 | -! | +||
| 40 | +
- if (is_scatterplot) {
+ #' tm_g_distribution( |
||
| 325 | -! | +||
| 41 | +
- shinyjs::show("alpha")
+ #' dist_var = data_extract_spec( |
||
| 326 | -! | +||
| 42 | +
- shinyjs::show("size")
+ #' dataname = "iris", |
||
| 327 | -! | +||
| 43 | +
- alpha <- input$alpha+ #' select = select_spec(variable_choices("iris"), "Petal.Length")
|
||
| 328 | -! | +||
| 44 | +
- size <- input$size+ #' ), |
||
| 329 | +45 |
- } else {
+ #' ggplot2_args = ggplot2_args( |
|
| 330 | -! | +||
| 46 | +
- shinyjs::hide("alpha")
+ #' labs = list(subtitle = "Plot generated by Distribution Module") |
||
| 331 | -! | +||
| 47 | +
- shinyjs::hide("size")
+ #' ) |
||
| 332 | -! | +||
| 48 | +
- alpha <- 0.5+ #' ) |
||
| 333 | -! | +||
| 49 | +
- size <- 2+ #' ) |
||
| 334 | +50 |
- }+ #' ) |
|
| 335 | +51 |
-
+ #' if (interactive()) {
|
|
| 336 | -! | +||
| 52 | +
- teal::validate_has_data(ANL[, c(ref_name, vars_names)], 3, complete = TRUE, allow_inf = FALSE)+ #' shinyApp(app$ui, app$server) |
||
| 337 | +53 |
-
+ #' } |
|
| 338 | +54 |
- # reference+ #' |
|
| 339 | -! | +||
| 55 | +
- ref_class <- class(ANL[[ref_name]])+ #' # CDISC data example |
||
| 340 | -! | +||
| 56 | +
- if (is.numeric(ANL[[ref_name]]) && log_transformation) {
+ #' library(teal.widgets) |
||
| 341 | +57 |
- # works for both integers and doubles+ #' |
|
| 342 | -! | +||
| 58 | +
- ref_cl_name <- call("log", as.name(ref_name))
+ #' data <- teal_data() |
||
| 343 | -! | +||
| 59 | +
- ref_cl_lbl <- varname_w_label(ref_name, ANL, prefix = "Log of ")+ #' data <- within(data, {
|
||
| 344 | +60 |
- } else {
+ #' ADSL <- rADSL |
|
| 345 | +61 |
- # silently ignore when non-numeric even if `log` is selected because some+ #' }) |
|
| 346 | +62 |
- # variables may be numeric and others not+ #' datanames(data) <- c("ADSL")
|
|
| 347 | -! | +||
| 63 | +
- ref_cl_name <- as.name(ref_name)+ #' join_keys(data) <- default_cdisc_join_keys[datanames(data)] |
||
| 348 | -! | +||
| 64 | +
- ref_cl_lbl <- varname_w_label(ref_name, ANL)+ #' |
||
| 349 | +65 |
- }+ #' vars1 <- choices_selected( |
|
| 350 | +66 |
-
+ #' variable_choices(data[["ADSL"]], c("ARM", "COUNTRY", "SEX")),
|
|
| 351 | -! | +||
| 67 | +
- user_ggplot2_args <- teal.widgets::resolve_ggplot2_args(+ #' selected = NULL |
||
| 352 | -! | +||
| 68 | +
- user_plot = ggplot2_args[["Bivariate1"]],+ #' ) |
||
| 353 | -! | +||
| 69 | +
- user_default = ggplot2_args$default+ #' |
||
| 354 | +70 |
- )+ #' app <- init( |
|
| 355 | +71 |
-
+ #' data = data, |
|
| 356 | -! | +||
| 72 | +
- ref_call <- bivariate_plot_call(+ #' modules = modules( |
||
| 357 | -! | +||
| 73 | +
- data_name = "ANL",+ #' tm_g_distribution( |
||
| 358 | -! | +||
| 74 | +
- x = ref_cl_name,+ #' dist_var = data_extract_spec( |
||
| 359 | -! | +||
| 75 | +
- x_class = ref_class,+ #' dataname = "ADSL", |
||
| 360 | -! | +||
| 76 | +
- x_label = ref_cl_lbl,+ #' select = select_spec( |
||
| 361 | -! | +||
| 77 | +
- freq = !show_dist,+ #' choices = variable_choices(data[["ADSL"]], c("AGE", "BMRKR1")),
|
||
| 362 | -! | +||
| 78 | +
- theme = distribution_theme,+ #' selected = "BMRKR1", |
||
| 363 | -! | +||
| 79 | +
- rotate_xaxis_labels = rotate_xaxis_labels,+ #' multiple = FALSE, |
||
| 364 | -! | +||
| 80 | +
- swap_axes = FALSE,+ #' fixed = FALSE |
||
| 365 | -! | +||
| 81 | +
- size = size,+ #' ) |
||
| 366 | -! | +||
| 82 | +
- alpha = alpha,+ #' ), |
||
| 367 | -! | +||
| 83 | +
- ggplot2_args = user_ggplot2_args+ #' strata_var = data_extract_spec( |
||
| 368 | +84 |
- )+ #' dataname = "ADSL", |
|
| 369 | +85 |
-
+ #' filter = filter_spec( |
|
| 370 | +86 |
- # association+ #' vars = vars1, |
|
| 371 | -! | +||
| 87 | +
- ref_class_cov <- ifelse(association, ref_class, "NULL")+ #' multiple = TRUE |
||
| 372 | +88 |
-
+ #' ) |
|
| 373 | -! | +||
| 89 | +
- print_call <- quote(print(p))+ #' ), |
||
| 374 | +90 |
-
+ #' group_var = data_extract_spec( |
|
| 375 | -! | +||
| 91 | +
- var_calls <- lapply(vars_names, function(var_i) {
+ #' dataname = "ADSL", |
||
| 376 | -! | +||
| 92 | +
- var_class <- class(ANL[[var_i]])+ #' filter = filter_spec( |
||
| 377 | -! | +||
| 93 | +
- if (is.numeric(ANL[[var_i]]) && log_transformation) {
+ #' vars = vars1, |
||
| 378 | +94 |
- # works for both integers and doubles+ #' multiple = TRUE |
|
| 379 | -! | +||
| 95 | +
- var_cl_name <- call("log", as.name(var_i))
+ #' ) |
||
| 380 | -! | +||
| 96 | +
- var_cl_lbl <- varname_w_label(var_i, ANL, prefix = "Log of ")+ #' ), |
||
| 381 | +97 |
- } else {
+ #' ggplot2_args = ggplot2_args( |
|
| 382 | +98 |
- # silently ignore when non-numeric even if `log` is selected because some+ #' labs = list(subtitle = "Plot generated by Distribution Module") |
|
| 383 | +99 |
- # variables may be numeric and others not+ #' ) |
|
| 384 | -! | +||
| 100 | +
- var_cl_name <- as.name(var_i)+ #' ) |
||
| 385 | -! | +||
| 101 | +
- var_cl_lbl <- varname_w_label(var_i, ANL)+ #' ) |
||
| 386 | +102 |
- }+ #' ) |
|
| 387 | +103 |
-
+ #' if (interactive()) {
|
|
| 388 | -! | +||
| 104 | +
- user_ggplot2_args <- teal.widgets::resolve_ggplot2_args(+ #' shinyApp(app$ui, app$server) |
||
| 389 | -! | +||
| 105 | +
- user_plot = ggplot2_args[["Bivariate2"]],+ #' } |
||
| 390 | -! | +||
| 106 | +
- user_default = ggplot2_args$default+ #' |
||
| 391 | +107 |
- )+ #' @export |
|
| 392 | +108 |
-
+ #' |
|
| 393 | -! | +||
| 109 | +
- bivariate_plot_call(+ tm_g_distribution <- function(label = "Distribution Module", |
||
| 394 | -! | +||
| 110 | +
- data_name = "ANL",+ dist_var, |
||
| 395 | -! | +||
| 111 | +
- x = ref_cl_name,+ strata_var = NULL, |
||
| 396 | -! | +||
| 112 | +
- y = var_cl_name,+ group_var = NULL, |
||
| 397 | -! | +||
| 113 | +
- x_class = ref_class_cov,+ freq = FALSE, |
||
| 398 | -! | +||
| 114 | +
- y_class = var_class,+ ggtheme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void"),
|
||
| 399 | -! | +||
| 115 | +
- x_label = ref_cl_lbl,+ ggplot2_args = teal.widgets::ggplot2_args(), |
||
| 400 | -! | +||
| 116 | +
- y_label = var_cl_lbl,+ bins = c(30L, 1L, 100L),+ |
+ ||
| 117 | ++ |
+ plot_height = c(600, 200, 2000),+ |
+ |
| 118 | ++ |
+ plot_width = NULL,+ |
+ |
| 119 | ++ |
+ pre_output = NULL,+ |
+ |
| 120 | ++ |
+ post_output = NULL) {
|
|
| 401 | +121 | ! |
- theme = association_theme,+ logger::log_info("Initializing tm_g_distribution")
+ |
+
| 122 | ++ | + | |
| 402 | +123 | ! |
- freq = !show_dist,+ extra_packages <- c("ggpmisc", "ggpp", "goftest", "MASS", "broom")
|
| 403 | +124 | ! |
- rotate_xaxis_labels = rotate_xaxis_labels,+ missing_packages <- Filter(function(x) !requireNamespace(x, quietly = TRUE), extra_packages) |
| 404 | +125 | ! |
- swap_axes = swap_axes,+ if (length(missing_packages) > 0L) {
|
| 405 | +126 | ! |
- alpha = alpha,+ stop(sprintf( |
| 406 | +127 | ! |
- size = size,+ "Cannot load package(s): %s.\nInstall or restart your session.", |
| 407 | +128 | ! |
- ggplot2_args = user_ggplot2_args+ toString(missing_packages) |
| 408 | +129 |
- )+ )) |
|
| 409 | +130 |
- })+ } |
|
| 410 | +131 | ||
| 411 | -+ | ||
| 132 | +! |
- # helper function to format variable name+ if (inherits(dist_var, "data_extract_spec")) dist_var <- list(dist_var) |
|
| 412 | +133 | ! |
- format_varnames <- function(x) {
+ if (inherits(strata_var, "data_extract_spec")) strata_var <- list(strata_var) |
| 413 | +134 | ! |
- if (is.numeric(ANL[[x]]) && log_transformation) {
+ if (inherits(group_var, "data_extract_spec")) group_var <- list(group_var) |
| 414 | +135 | ! |
- varname_w_label(x, ANL, prefix = "Log of ")+ if (inherits(ggplot2_args, "ggplot2_args")) ggplot2_args <- list(default = ggplot2_args) |
| 415 | +136 |
- } else {
+
|
|
| 416 | +137 | ! |
- varname_w_label(x, ANL)+ ggtheme <- match.arg(ggtheme) |
| 417 | -+ | ||
| 138 | +! |
- }+ if (length(bins) == 1) {
+ |
+ |
| 139 | +! | +
+ checkmate::assert_numeric(bins, any.missing = FALSE, lower = 1) |
|
| 418 | +140 |
- }+ } else {
|
|
| 419 | +141 | ! |
- new_title <-+ checkmate::assert_numeric(bins, len = 3, any.missing = FALSE, lower = 1) |
| 420 | +142 | ! |
- if (association) {
+ checkmate::assert_numeric(bins[1], lower = bins[2], upper = bins[3], .var.name = "bins") |
| 421 | -! | +||
| 143 | +
- switch(as.character(length(vars_names)),+ } |
||
| 422 | +144 | ! |
- "0" = sprintf("Value distribution for %s", ref_cl_lbl),
+ checkmate::assert_string(label) |
| 423 | +145 | ! |
- "1" = sprintf(+ checkmate::assert_list(dist_var, "data_extract_spec") |
| 424 | +146 | ! |
- "Association between %s and %s",+ checkmate::assert_false(dist_var[[1]]$select$multiple) |
| 425 | +147 | ! |
- ref_cl_lbl,+ checkmate::assert_list(strata_var, types = "data_extract_spec", null.ok = TRUE) |
| 426 | +148 | ! |
- format_varnames(vars_names)- |
-
| 427 | -- |
- ),+ checkmate::assert_list(group_var, types = "data_extract_spec", null.ok = TRUE) |
|
| 428 | +149 | ! |
- sprintf(+ checkmate::assert_flag(freq) |
| 429 | +150 | ! |
- "Associations between %s and: %s",+ plot_choices <- c("Histogram", "QQplot")
|
| 430 | +151 | ! |
- ref_cl_lbl,+ checkmate::assert_list(ggplot2_args, types = "ggplot2_args") |
| 431 | +152 | ! |
- paste(lapply(vars_names, format_varnames), collapse = ", ")+ checkmate::assert_subset(names(ggplot2_args), c("default", plot_choices))
|
| 432 | +153 |
- )+ |
|
| 433 | -+ | ||
| 154 | +! |
- )+ args <- as.list(environment()) |
|
| 434 | +155 |
- } else {
+
|
|
| 435 | +156 | ! |
- switch(as.character(length(vars_names)),+ data_extract_list <- list( |
| 436 | +157 | ! |
- "0" = sprintf("Value distribution for %s", ref_cl_lbl),
+ dist_var = dist_var, |
| 437 | +158 | ! |
- sprintf(+ strata_var = strata_var, |
| 438 | +159 | ! |
- "Value distributions for %s and %s",+ group_var = group_var+ |
+
| 160 | ++ |
+ )+ |
+ |
| 161 | ++ | + | |
| 439 | +162 | ! |
- ref_cl_lbl,+ module( |
| 440 | +163 | ! |
- paste(lapply(vars_names, format_varnames), collapse = ", ")+ label = label, |
| 441 | -+ | ||
| 164 | +! |
- )+ server = srv_distribution, |
|
| 442 | -+ | ||
| 165 | +! |
- )+ server_args = c( |
|
| 443 | -+ | ||
| 166 | +! |
- }+ data_extract_list,+ |
+ |
| 167 | +! | +
+ list(plot_height = plot_height, plot_width = plot_width, ggplot2_args = ggplot2_args) |
|
| 444 | +168 |
-
+ ), |
|
| 445 | +169 | ! |
- teal.code::eval_code(+ ui = ui_distribution, |
| 446 | +170 | ! |
- merged$anl_q_r(),+ ui_args = args, |
| 447 | +171 | ! |
- substitute(+ datanames = teal.transform::get_extract_datanames(data_extract_list) |
| 448 | -! | +||
| 172 | +
- expr = title <- new_title,+ ) |
||
| 449 | -! | +||
| 173 | +
- env = list(new_title = new_title)+ } |
||
| 450 | +174 |
- )+ |
|
| 451 | +175 |
- ) %>%+ ui_distribution <- function(id, ...) {
|
|
| 452 | +176 | ! |
- teal.code::eval_code(+ args <- list(...) |
| 453 | +177 | ! |
- substitute(+ ns <- NS(id) |
| 454 | +178 | ! |
- expr = {
+ is_single_dataset_value <- teal.transform::is_single_dataset(args$dist_var, args$strata_var, args$group_var)+ |
+
| 179 | ++ | + | |
| 455 | +180 | ! |
- plots <- plot_calls+ teal.widgets::standard_layout( |
| 456 | +181 | ! |
- p <- tern::stack_grobs(grobs = lapply(plots, ggplotGrob))+ output = teal.widgets::white_small_well( |
| 457 | +182 | ! |
- grid::grid.newpage()+ tabsetPanel( |
| 458 | +183 | ! |
- grid::grid.draw(p)+ id = ns("tabs"),
|
| 459 | -+ | ||
| 184 | +! |
- },+ tabPanel("Histogram", teal.widgets::plot_with_settings_ui(id = ns("hist_plot"))),
|
|
| 460 | +185 | ! |
- env = list(+ tabPanel("QQplot", teal.widgets::plot_with_settings_ui(id = ns("qq_plot")))
+ |
+
| 186 | ++ |
+ ), |
|
| 461 | +187 | ! |
- plot_calls = do.call(+ h3("Statistics Table"),
|
| 462 | +188 | ! |
- "call",+ DT::dataTableOutput(ns("summary_table")),
|
| 463 | +189 | ! |
- c(list("list", ref_call), var_calls),
+ h3("Tests"),
|
| 464 | +190 | ! |
- quote = TRUE+ DT::dataTableOutput(ns("t_stats"))
|
| 465 | +191 |
- )+ ), |
|
| 466 | -+ | ||
| 192 | +! |
- )+ encoding = div( |
|
| 467 | +193 |
- )+ ### Reporter |
|
| 468 | -+ | ||
| 194 | +! |
- )+ teal.reporter::simple_reporter_ui(ns("simple_reporter")),
|
|
| 469 | +195 |
- })+ ### |
|
| 470 | -+ | ||
| 196 | +! |
-
+ tags$label("Encodings", class = "text-primary"),
|
|
| 471 | +197 | ! |
- plot_r <- shiny::reactive({
+ teal.transform::datanames_input(args[c("dist_var", "strata_var")]),
|
| 472 | +198 | ! |
- shiny::req(iv_r()$is_valid())+ teal.transform::data_extract_ui( |
| 473 | +199 | ! |
- output_q()[["p"]]+ id = ns("dist_i"),
|
| 474 | -+ | ||
| 200 | +! |
- })+ label = "Variable", |
|
| 475 | -+ | ||
| 201 | +! |
-
+ data_extract_spec = args$dist_var, |
|
| 476 | +202 | ! |
- pws <- teal.widgets::plot_with_settings_srv(+ is_single_dataset = is_single_dataset_value+ |
+
| 203 | ++ |
+ ), |
|
| 477 | +204 | ! |
- id = "myplot",+ if (!is.null(args$group_var)) {
|
| 478 | +205 | ! |
- plot_r = plot_r,+ tagList( |
| 479 | +206 | ! |
- height = plot_height,+ teal.transform::data_extract_ui( |
| 480 | +207 | ! |
- width = plot_width+ id = ns("group_i"),
|
| 481 | -+ | ||
| 208 | +! |
- )+ label = "Group by", |
|
| 482 | -+ | ||
| 209 | +! |
-
+ data_extract_spec = args$group_var, |
|
| 483 | +210 | ! |
- output$title <- renderText({
+ is_single_dataset = is_single_dataset_value+ |
+
| 211 | ++ |
+ ), |
|
| 484 | +212 | ! |
- teal.code::dev_suppress(output_q()[["title"]])+ uiOutput(ns("scales_types_ui"))
|
| 485 | +213 |
- })+ ) |
|
| 486 | +214 |
-
+ }, |
|
| 487 | +215 | ! |
- teal.widgets::verbatim_popup_srv(+ if (!is.null(args$strata_var)) {
|
| 488 | +216 | ! |
- id = "warning",+ teal.transform::data_extract_ui( |
| 489 | +217 | ! |
- verbatim_content = reactive(teal.code::get_warnings(output_q())),+ id = ns("strata_i"),
|
| 490 | +218 | ! |
- title = "Warning",+ label = "Stratify by", |
| 491 | +219 | ! |
- disabled = reactive(is.null(teal.code::get_warnings(output_q())))+ data_extract_spec = args$strata_var,+ |
+
| 220 | +! | +
+ is_single_dataset = is_single_dataset_value |
|
| 492 | +221 |
- )+ ) |
|
| 493 | +222 |
-
+ }, |
|
| 494 | +223 | ! |
- teal.widgets::verbatim_popup_srv(+ teal.widgets::panel_group( |
| 495 | +224 | ! |
- id = "rcode",+ conditionalPanel( |
| 496 | +225 | ! |
- verbatim_content = reactive(teal.code::get_code(output_q())),+ condition = paste0("input['", ns("tabs"), "'] == 'Histogram'"),
|
| 497 | +226 | ! |
- title = "Association Plot"- |
-
| 498 | -- |
- )+ teal.widgets::panel_item( |
|
| 499 | -+ | ||
| 227 | +! |
-
+ "Histogram", |
|
| 500 | -+ | ||
| 228 | +! |
- ### REPORTER+ teal.widgets::optionalSliderInputValMinMax(ns("bins"), "Bins", args$bins, ticks = FALSE, step = 1),
|
|
| 501 | +229 | ! |
- if (with_reporter) {
+ shinyWidgets::prettyRadioButtons( |
| 502 | +230 | ! |
- card_fun <- function(comment, label) {
+ ns("main_type"),
|
| 503 | +231 | ! |
- card <- teal::report_card_template(+ label = "Plot Type:", |
| 504 | +232 | ! |
- title = "Association Plot",+ choices = c("Density", "Frequency"),
|
| 505 | +233 | ! |
- label = label,+ selected = if (!args$freq) "Density" else "Frequency", |
| 506 | +234 | ! |
- with_filter = with_filter,+ bigger = FALSE, |
| 507 | +235 | ! |
- filter_panel_api = filter_panel_api+ inline = TRUE |
| 508 | +236 |
- )+ ), |
|
| 509 | +237 | ! |
- card$append_text("Plot", "header3")
+ checkboxInput(ns("add_dens"), label = "Overlay Density", value = TRUE),
|
| 510 | +238 | ! |
- card$append_plot(plot_r(), dim = pws$dim())+ collapsed = FALSE |
| 511 | -! | +||
| 239 | +
- if (!comment == "") {
+ ) |
||
| 512 | -! | +||
| 240 | +
- card$append_text("Comment", "header3")
+ ), |
||
| 513 | +241 | ! |
- card$append_text(comment)+ conditionalPanel( |
| 514 | -+ | ||
| 242 | +! |
- }+ condition = paste0("input['", ns("tabs"), "'] == 'QQplot'"),
|
|
| 515 | +243 | ! |
- card$append_src(teal.code::get_code(output_q()))+ teal.widgets::panel_item( |
| 516 | +244 | ! |
- card+ "QQ Plot", |
| 517 | -+ | ||
| 245 | +! |
- }+ checkboxInput(ns("qq_line"), label = "Add diagonal line(s)", TRUE),
|
|
| 518 | +246 | ! |
- teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
+ collapsed = FALSE |
| 519 | +247 |
- }+ ) |
|
| 520 | +248 |
- ###+ ), |
|
| 521 | -+ | ||
| 249 | +! |
- })+ conditionalPanel( |
|
| 522 | -+ | ||
| 250 | +! |
- }+ condition = paste0("input['", ns("main_type"), "'] == 'Density'"),
|
| 1 | -+ | ||
| 251 | +! |
- #' Create a simple scatterplot+ teal.widgets::panel_item( |
|
| 2 | -+ | ||
| 252 | +! |
- #'+ "Theoretical Distribution", |
|
| 3 | -+ | ||
| 253 | +! |
- #' Create a plot with the \code{\link{ggplot2}[geom_point]} function
+ teal.widgets::optionalSelectInput( |
|
| 4 | -+ | ||
| 254 | +! |
- #' @md+ ns("t_dist"),
|
|
| 5 | -+ | ||
| 255 | +! |
- #'+ div( |
|
| 6 | -+ | ||
| 256 | +! |
- #' @inheritParams teal::module+ class = "teal-tooltip", |
|
| 7 | -+ | ||
| 257 | +! |
- #' @inheritParams shared_params+ tagList( |
|
| 8 | -+ | ||
| 258 | +! |
- #' @param x (`data_extract_spec` or `list` of multiple `data_extract_spec`) Variable+ "Distribution:", |
|
| 9 | -+ | ||
| 259 | +! |
- #' names selected to plot along the x-axis by default.+ icon("circle-info"),
|
|
| 10 | -+ | ||
| 260 | +! |
- #' @param y (`data_extract_spec` or `list` of multiple `data_extract_spec`) Variable+ span( |
|
| 11 | -+ | ||
| 261 | +! |
- #' names selected to plot along the y-axis by default.+ class = "tooltiptext", |
|
| 12 | -+ | ||
| 262 | +! |
- #' @param color_by optional (`data_extract_spec` or `list` of multiple `data_extract_spec`)+ "Default parameters are optimized with MASS::fitdistr function." |
|
| 13 | +263 |
- #' Defines the color encoding. If `NULL` then no color encoding option will be displayed.+ ) |
|
| 14 | +264 |
- #' @param size_by optional (`data_extract_spec` or `list` of multiple `data_extract_spec`)+ ) |
|
| 15 | +265 |
- #' Defines the point size encoding. If `NULL` then no size encoding option will be displayed.+ ), |
|
| 16 | -+ | ||
| 266 | +! |
- #' @param row_facet optional, (`data_extract_spec` or `list` of multiple `data_extract_spec`)+ choices = c("normal", "lognormal", "gamma", "unif"),
|
|
| 17 | -+ | ||
| 267 | +! |
- #' Which data columns to use for faceting rows.+ selected = NULL, |
|
| 18 | -+ | ||
| 268 | +! |
- #' @param col_facet optional, (`data_extract_spec` or `list` of multiple `data_extract_spec`)+ multiple = FALSE |
|
| 19 | +269 |
- #' Which data to use for faceting columns.+ ), |
|
| 20 | -+ | ||
| 270 | +! |
- #' @param alpha optional, (`numeric`) If scalar then the plot points will have a fixed opacity. If a+ numericInput(ns("dist_param1"), label = "param1", value = NULL),
|
|
| 21 | -+ | ||
| 271 | +! |
- #' slider should be presented to adjust the plot point opacity dynamically then it can be a vector of+ numericInput(ns("dist_param2"), label = "param2", value = NULL),
|
|
| 22 | -+ | ||
| 272 | +! |
- #' length three with `c(value, min, max)`.+ span(actionButton(ns("params_reset"), "Reset params")),
|
|
| 23 | -+ | ||
| 273 | +! |
- #' @param size optional, (`numeric`) If scalar then the plot point sizes will have a fixed size+ collapsed = FALSE |
|
| 24 | +274 |
- #' If a slider should be presented to adjust the plot point sizes dynamically then it can be a+ ) |
|
| 25 | +275 |
- #' vector of length three with `c(value, min, max)`.+ ) |
|
| 26 | +276 |
- #' @param shape optional, (`character`) A character vector with the English names of the+ ), |
|
| 27 | -+ | ||
| 277 | +! |
- #' shape, e.g. `c("triangle", "square", "circle")`. It defaults to `shape_names`. This is a complete list from
+ teal.widgets::panel_item( |
|
| 28 | -+ | ||
| 278 | +! |
- #' `vignette("ggplot2-specs", package="ggplot2")`.
+ "Tests", |
|
| 29 | -+ | ||
| 279 | +! |
- #' @param max_deg optional, (`integer`) The maximum degree for the polynomial trend line. Must not be less than 1.+ teal.widgets::optionalSelectInput( |
|
| 30 | -+ | ||
| 280 | +! |
- #' @param table_dec optional, (`integer`) Number of decimal places used to round numeric values in the table.+ ns("dist_tests"),
|
|
| 31 | -+ | ||
| 281 | +! |
- #'+ "Tests:", |
|
| 32 | -+ | ||
| 282 | +! |
- #'+ choices = c( |
|
| 33 | -+ | ||
| 283 | +! |
- #' @note For more examples, please see the vignette "Using scatterplot" via+ "Shapiro-Wilk", |
|
| 34 | -+ | ||
| 284 | +! |
- #' `vignette("using-scatterplot", package = "teal.modules.general")`.
+ if (!is.null(args$strata_var)) "t-test (two-samples, not paired)", |
|
| 35 | -+ | ||
| 285 | +! |
- #'+ if (!is.null(args$strata_var)) "one-way ANOVA", |
|
| 36 | -+ | ||
| 286 | +! |
- #' @examples+ if (!is.null(args$strata_var)) "Fligner-Killeen", |
|
| 37 | -+ | ||
| 287 | +! |
- #' # general data example+ if (!is.null(args$strata_var)) "F-test", |
|
| 38 | -+ | ||
| 288 | +! |
- #' library(teal.widgets)+ "Kolmogorov-Smirnov (one-sample)", |
|
| 39 | -+ | ||
| 289 | +! |
- #'+ "Anderson-Darling (one-sample)", |
|
| 40 | -+ | ||
| 290 | +! |
- #' data <- teal_data()+ "Cramer-von Mises (one-sample)", |
|
| 41 | -+ | ||
| 291 | +! |
- #' data <- within(data, {
+ if (!is.null(args$strata_var)) "Kolmogorov-Smirnov (two-samples)" |
|
| 42 | +292 |
- #' library(nestcolor)+ ), |
|
| 43 | -+ | ||
| 293 | +! |
- #' CO2 <- CO2+ selected = NULL |
|
| 44 | +294 |
- #' })+ ) |
|
| 45 | +295 |
- #' datanames(data) <- "CO2"+ ), |
|
| 46 | -+ | ||
| 296 | +! |
- #'+ teal.widgets::panel_item( |
|
| 47 | -+ | ||
| 297 | +! |
- #' app <- init(+ "Statistics Table", |
|
| 48 | -+ | ||
| 298 | +! |
- #' data = data,+ sliderInput(ns("roundn"), "Round to n digits", min = 0, max = 10, value = 2)
|
|
| 49 | +299 |
- #' modules = modules(+ ), |
|
| 50 | -+ | ||
| 300 | +! |
- #' tm_g_scatterplot(+ teal.widgets::panel_item( |
|
| 51 | -+ | ||
| 301 | +! |
- #' label = "Scatterplot Choices",+ title = "Plot settings", |
|
| 52 | -+ | ||
| 302 | +! |
- #' x = data_extract_spec(+ selectInput( |
|
| 53 | -+ | ||
| 303 | +! |
- #' dataname = "CO2",+ inputId = ns("ggtheme"),
|
|
| 54 | -+ | ||
| 304 | +! |
- #' select = select_spec(+ label = "Theme (by ggplot):", |
|
| 55 | -+ | ||
| 305 | +! |
- #' label = "Select variable:",+ choices = ggplot_themes, |
|
| 56 | -+ | ||
| 306 | +! |
- #' choices = variable_choices(data[["CO2"]], c("conc", "uptake")),
+ selected = args$ggtheme, |
|
| 57 | -+ | ||
| 307 | +! |
- #' selected = "conc",+ multiple = FALSE |
|
| 58 | +308 |
- #' multiple = FALSE,+ ) |
|
| 59 | +309 |
- #' fixed = FALSE+ ) |
|
| 60 | +310 |
- #' )+ ), |
|
| 61 | -+ | ||
| 311 | +! |
- #' ),+ forms = tagList( |
|
| 62 | -+ | ||
| 312 | +! |
- #' y = data_extract_spec(+ teal.widgets::verbatim_popup_ui(ns("warning"), "Show Warnings"),
|
|
| 63 | -+ | ||
| 313 | +! |
- #' dataname = "CO2",+ teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code")
|
|
| 64 | +314 |
- #' select = select_spec(+ ), |
|
| 65 | -+ | ||
| 315 | +! |
- #' label = "Select variable:",+ pre_output = args$pre_output, |
|
| 66 | -+ | ||
| 316 | +! |
- #' choices = variable_choices(data[["CO2"]], c("conc", "uptake")),
+ post_output = args$post_output |
|
| 67 | +317 |
- #' selected = "uptake",+ ) |
|
| 68 | +318 |
- #' multiple = FALSE,+ } |
|
| 69 | +319 |
- #' fixed = FALSE+ |
|
| 70 | +320 |
- #' )+ srv_distribution <- function(id, |
|
| 71 | +321 |
- #' ),+ data, |
|
| 72 | +322 |
- #' color_by = data_extract_spec(+ reporter, |
|
| 73 | +323 |
- #' dataname = "CO2",+ filter_panel_api, |
|
| 74 | +324 |
- #' select = select_spec(+ dist_var, |
|
| 75 | +325 |
- #' label = "Select variable:",+ strata_var, |
|
| 76 | +326 |
- #' choices = variable_choices(+ group_var, |
|
| 77 | +327 |
- #' data[["CO2"]],+ plot_height, |
|
| 78 | +328 |
- #' c("Plant", "Type", "Treatment", "conc", "uptake")
+ plot_width, |
|
| 79 | +329 |
- #' ),+ ggplot2_args) {
|
|
| 80 | -+ | ||
| 330 | +! |
- #' selected = NULL,+ with_reporter <- !missing(reporter) && inherits(reporter, "Reporter") |
|
| 81 | -+ | ||
| 331 | +! |
- #' multiple = FALSE,+ with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI") |
|
| 82 | -+ | ||
| 332 | +! |
- #' fixed = FALSE+ checkmate::assert_class(data, "reactive") |
|
| 83 | -+ | ||
| 333 | +! |
- #' )+ checkmate::assert_class(isolate(data()), "teal_data") |
|
| 84 | -+ | ||
| 334 | +! |
- #' ),+ moduleServer(id, function(input, output, session) {
|
|
| 85 | -+ | ||
| 335 | +! |
- #' size_by = data_extract_spec(+ rule_req <- function(value) {
|
|
| 86 | -+ | ||
| 336 | +! |
- #' dataname = "CO2",+ if (isTRUE(input$dist_tests %in% c( |
|
| 87 | -+ | ||
| 337 | +! |
- #' select = select_spec(+ "Fligner-Killeen", |
|
| 88 | -+ | ||
| 338 | +! |
- #' label = "Select variable:",+ "t-test (two-samples, not paired)", |
|
| 89 | -+ | ||
| 339 | +! |
- #' choices = variable_choices(data[["CO2"]], c("conc", "uptake")),
+ "F-test", |
|
| 90 | -+ | ||
| 340 | +! |
- #' selected = "uptake",+ "Kolmogorov-Smirnov (two-samples)", |
|
| 91 | -+ | ||
| 341 | +! |
- #' multiple = FALSE,+ "one-way ANOVA" |
|
| 92 | +342 |
- #' fixed = FALSE+ ))) {
|
|
| 93 | -+ | ||
| 343 | +! |
- #' )+ if (!shinyvalidate::input_provided(value)) {
|
|
| 94 | -+ | ||
| 344 | +! |
- #' ),+ "Please select stratify variable." |
|
| 95 | +345 |
- #' row_facet = data_extract_spec(+ } |
|
| 96 | +346 |
- #' dataname = "CO2",+ } |
|
| 97 | +347 |
- #' select = select_spec(+ } |
|
| 98 | -+ | ||
| 348 | +! |
- #' label = "Select variable:",+ rule_dupl <- function(...) {
|
|
| 99 | -+ | ||
| 349 | +! |
- #' choices = variable_choices(data[["CO2"]], c("Plant", "Type", "Treatment")),
+ if (identical(input$dist_tests, "Fligner-Killeen")) {
|
|
| 100 | -+ | ||
| 350 | +! |
- #' selected = NULL,+ strata <- selector_list()$strata_i()$select |
|
| 101 | -+ | ||
| 351 | +! |
- #' multiple = FALSE,+ group <- selector_list()$group_i()$select |
|
| 102 | -+ | ||
| 352 | +! |
- #' fixed = FALSE+ if (isTRUE(strata == group)) {
|
|
| 103 | -+ | ||
| 353 | +! |
- #' )+ "Please select different variables for strata and group." |
|
| 104 | +354 |
- #' ),+ } |
|
| 105 | +355 |
- #' col_facet = data_extract_spec(+ } |
|
| 106 | +356 |
- #' dataname = "CO2",+ } |
|
| 107 | +357 |
- #' select = select_spec(+ |
|
| 108 | -+ | ||
| 358 | +! |
- #' label = "Select variable:",+ selector_list <- teal.transform::data_extract_multiple_srv( |
|
| 109 | -+ | ||
| 359 | +! |
- #' choices = variable_choices(data[["CO2"]], c("Plant", "Type", "Treatment")),
+ data_extract = list( |
|
| 110 | -+ | ||
| 360 | +! |
- #' selected = NULL,+ dist_i = dist_var, |
|
| 111 | -+ | ||
| 361 | +! |
- #' multiple = FALSE,+ strata_i = strata_var, |
|
| 112 | -+ | ||
| 362 | +! |
- #' fixed = FALSE+ group_i = group_var |
|
| 113 | +363 |
- #' )+ ), |
|
| 114 | -+ | ||
| 364 | +! |
- #' ),+ data, |
|
| 115 | -+ | ||
| 365 | +! |
- #' ggplot2_args = ggplot2_args(+ select_validation_rule = list( |
|
| 116 | -+ | ||
| 366 | +! |
- #' labs = list(subtitle = "Plot generated by Scatterplot Module")+ dist_i = shinyvalidate::sv_required("Please select a variable")
|
|
| 117 | +367 |
- #' )+ ), |
|
| 118 | -+ | ||
| 368 | +! |
- #' )+ filter_validation_rule = list( |
|
| 119 | -+ | ||
| 369 | +! |
- #' )+ strata_i = shinyvalidate::compose_rules( |
|
| 120 | -+ | ||
| 370 | +! |
- #' )+ rule_req, |
|
| 121 | -+ | ||
| 371 | +! |
- #' if (interactive()) {
+ rule_dupl |
|
| 122 | +372 |
- #' shinyApp(app$ui, app$server)+ ), |
|
| 123 | -+ | ||
| 373 | +! |
- #' }+ group_i = rule_dupl |
|
| 124 | +374 |
- #'+ ) |
|
| 125 | +375 |
- #'+ ) |
|
| 126 | +376 |
- #' # CDISC data example+ |
|
| 127 | -+ | ||
| 377 | +! |
- #' library(teal.widgets)+ iv_r <- reactive({
|
|
| 128 | -+ | ||
| 378 | +! |
- #'+ iv <- shinyvalidate::InputValidator$new() |
|
| 129 | -+ | ||
| 379 | +! |
- #' data <- teal_data()+ teal.transform::compose_and_enable_validators(iv, selector_list, validator_names = "dist_i") |
|
| 130 | +380 |
- #' data <- within(data, {
+ }) |
|
| 131 | +381 |
- #' library(nestcolor)+ |
|
| 132 | -+ | ||
| 382 | +! |
- #' ADSL <- rADSL+ iv_r_dist <- reactive({
|
|
| 133 | -+ | ||
| 383 | +! |
- #' })+ iv <- shinyvalidate::InputValidator$new() |
|
| 134 | -+ | ||
| 384 | +! |
- #' datanames(data) <- c("ADSL")
+ teal.transform::compose_and_enable_validators( |
|
| 135 | -+ | ||
| 385 | +! |
- #' join_keys(data) <- default_cdisc_join_keys[datanames(data)]+ iv, selector_list, |
|
| 136 | -+ | ||
| 386 | +! |
- #'+ validator_names = c("strata_i", "group_i")
|
|
| 137 | +387 |
- #' app <- init(+ ) |
|
| 138 | +388 |
- #' data = data,+ }) |
|
| 139 | -+ | ||
| 389 | +! |
- #' modules = modules(+ rule_dist_1 <- function(value) {
|
|
| 140 | -+ | ||
| 390 | +! |
- #' tm_g_scatterplot(+ if (!is.null(input$t_dist)) {
|
|
| 141 | -+ | ||
| 391 | +! |
- #' label = "Scatterplot Choices",+ switch(input$t_dist, |
|
| 142 | -+ | ||
| 392 | +! |
- #' x = data_extract_spec(+ "normal" = if (!shinyvalidate::input_provided(value)) "mean is required", |
|
| 143 | -+ | ||
| 393 | +! |
- #' dataname = "ADSL",+ "lognormal" = if (!shinyvalidate::input_provided(value)) "meanlog is required", |
|
| 144 | -+ | ||
| 394 | +! |
- #' select = select_spec(+ "gamma" = {
|
|
| 145 | -+ | ||
| 395 | +! |
- #' label = "Select variable:",+ if (!shinyvalidate::input_provided(value)) "shape is required" else if (value <= 0) "shape must be positive" |
|
| 146 | +396 |
- #' choices = variable_choices(data[["ADSL"]], c("AGE", "BMRKR1", "BMRKR2")),
+ }, |
|
| 147 | -+ | ||
| 397 | +! |
- #' selected = "AGE",+ "unif" = NULL |
|
| 148 | +398 |
- #' multiple = FALSE,+ ) |
|
| 149 | +399 |
- #' fixed = FALSE+ } |
|
| 150 | +400 |
- #' )+ } |
|
| 151 | -+ | ||
| 401 | +! |
- #' ),+ rule_dist_2 <- function(value) {
|
|
| 152 | -+ | ||
| 402 | +! |
- #' y = data_extract_spec(+ if (!is.null(input$t_dist)) {
|
|
| 153 | -+ | ||
| 403 | +! |
- #' dataname = "ADSL",+ switch(input$t_dist, |
|
| 154 | -+ | ||
| 404 | +! |
- #' select = select_spec(+ "normal" = {
|
|
| 155 | -+ | ||
| 405 | +! |
- #' label = "Select variable:",+ if (!shinyvalidate::input_provided(value)) {
|
|
| 156 | -+ | ||
| 406 | +! |
- #' choices = variable_choices(data[["ADSL"]], c("AGE", "BMRKR1", "BMRKR2")),
+ "sd is required" |
|
| 157 | -+ | ||
| 407 | +! |
- #' selected = "BMRKR1",+ } else if (value < 0) {
|
|
| 158 | -+ | ||
| 408 | +! |
- #' multiple = FALSE,+ "sd must be non-negative" |
|
| 159 | +409 |
- #' fixed = FALSE+ } |
|
| 160 | +410 |
- #' )+ }, |
|
| 161 | -+ | ||
| 411 | +! |
- #' ),+ "lognormal" = {
|
|
| 162 | -+ | ||
| 412 | +! |
- #' color_by = data_extract_spec(+ if (!shinyvalidate::input_provided(value)) {
|
|
| 163 | -+ | ||
| 413 | +! |
- #' dataname = "ADSL",+ "sdlog is required" |
|
| 164 | -+ | ||
| 414 | +! |
- #' select = select_spec(+ } else if (value < 0) {
|
|
| 165 | -+ | ||
| 415 | +! |
- #' label = "Select variable:",+ "sdlog must be non-negative" |
|
| 166 | +416 |
- #' choices = variable_choices(+ } |
|
| 167 | +417 |
- #' data[["ADSL"]],+ }, |
|
| 168 | -+ | ||
| 418 | +! |
- #' c("AGE", "BMRKR1", "BMRKR2", "RACE", "REGION1")
+ "gamma" = {
|
|
| 169 | -+ | ||
| 419 | +! |
- #' ),+ if (!shinyvalidate::input_provided(value)) {
|
|
| 170 | -+ | ||
| 420 | +! |
- #' selected = NULL,+ "rate is required" |
|
| 171 | -+ | ||
| 421 | +! |
- #' multiple = FALSE,+ } else if (value <= 0) {
|
|
| 172 | -+ | ||
| 422 | +! |
- #' fixed = FALSE+ "rate must be positive" |
|
| 173 | +423 |
- #' )+ } |
|
| 174 | +424 |
- #' ),+ }, |
|
| 175 | -+ | ||
| 425 | +! |
- #' size_by = data_extract_spec(+ "unif" = NULL |
|
| 176 | +426 |
- #' dataname = "ADSL",+ ) |
|
| 177 | +427 |
- #' select = select_spec(+ } |
|
| 178 | +428 |
- #' label = "Select variable:",+ } |
|
| 179 | -+ | ||
| 429 | +! |
- #' choices = variable_choices(data[["ADSL"]], c("AGE", "BMRKR1")),
+ rule_dist <- function(value) {
|
|
| 180 | -+ | ||
| 430 | +! |
- #' selected = "AGE",+ if (isTRUE(input$tabs == "QQplot" || |
|
| 181 | -+ | ||
| 431 | +! |
- #' multiple = FALSE,+ input$dist_tests %in% c( |
|
| 182 | -+ | ||
| 432 | +! |
- #' fixed = FALSE+ "Kolmogorov-Smirnov (one-sample)", |
|
| 183 | -+ | ||
| 433 | +! |
- #' )+ "Anderson-Darling (one-sample)", |
|
| 184 | -+ | ||
| 434 | +! |
- #' ),+ "Cramer-von Mises (one-sample)" |
|
| 185 | +435 |
- #' row_facet = data_extract_spec(+ ))) {
|
|
| 186 | -+ | ||
| 436 | +! |
- #' dataname = "ADSL",+ if (!shinyvalidate::input_provided(value)) {
|
|
| 187 | -+ | ||
| 437 | +! |
- #' select = select_spec(+ "Please select the theoretical distribution." |
|
| 188 | +438 |
- #' label = "Select variable:",+ } |
|
| 189 | +439 |
- #' choices = variable_choices(data[["ADSL"]], c("BMRKR2", "RACE", "REGION1")),
+ } |
|
| 190 | +440 |
- #' selected = NULL,+ } |
|
| 191 | -+ | ||
| 441 | +! |
- #' multiple = FALSE,+ iv_dist <- shinyvalidate::InputValidator$new() |
|
| 192 | -+ | ||
| 442 | +! |
- #' fixed = FALSE+ iv_dist$add_rule("t_dist", rule_dist)
|
|
| 193 | -+ | ||
| 443 | +! |
- #' )+ iv_dist$add_rule("dist_param1", rule_dist_1)
|
|
| 194 | -+ | ||
| 444 | +! |
- #' ),+ iv_dist$add_rule("dist_param2", rule_dist_2)
|
|
| 195 | -+ | ||
| 445 | +! |
- #' col_facet = data_extract_spec(+ iv_dist$enable() |
|
| 196 | +446 |
- #' dataname = "ADSL",+ |
|
| 197 | -+ | ||
| 447 | +! |
- #' select = select_spec(+ anl_merged_input <- teal.transform::merge_expression_srv( |
|
| 198 | -+ | ||
| 448 | +! |
- #' label = "Select variable:",+ selector_list = selector_list, |
|
| 199 | -+ | ||
| 449 | +! |
- #' choices = variable_choices(data[["ADSL"]], c("BMRKR2", "RACE", "REGION1")),
+ datasets = data |
|
| 200 | +450 |
- #' selected = NULL,+ ) |
|
| 201 | +451 |
- #' multiple = FALSE,+ |
|
| 202 | -+ | ||
| 452 | +! |
- #' fixed = FALSE+ anl_merged_q <- reactive({
|
|
| 203 | -+ | ||
| 453 | +! |
- #' )+ req(anl_merged_input()) |
|
| 204 | -+ | ||
| 454 | +! |
- #' ),+ data() %>% |
|
| 205 | -+ | ||
| 455 | +! |
- #' ggplot2_args = ggplot2_args(+ teal.code::eval_code(as.expression(anl_merged_input()$expr)) |
|
| 206 | +456 |
- #' labs = list(subtitle = "Plot generated by Scatterplot Module")+ }) |
|
| 207 | +457 |
- #' )+ |
|
| 208 | -+ | ||
| 458 | +! |
- #' )+ merged <- list( |
|
| 209 | -+ | ||
| 459 | +! |
- #' )+ anl_input_r = anl_merged_input, |
|
| 210 | -+ | ||
| 460 | +! |
- #' )+ anl_q_r = anl_merged_q |
|
| 211 | +461 |
- #' if (interactive()) {
+ ) |
|
| 212 | +462 |
- #' shinyApp(app$ui, app$server)+ |
|
| 213 | -+ | ||
| 463 | +! |
- #' }+ output$scales_types_ui <- renderUI({
|
|
| 214 | -+ | ||
| 464 | +! |
- #'+ if ("group_i" %in% names(selector_list()) && length(selector_list()$group_i()$filters[[1]]$selected) > 0) {
|
|
| 215 | -+ | ||
| 465 | +! |
- #' @export+ shinyWidgets::prettyRadioButtons( |
|
| 216 | -+ | ||
| 466 | +! |
- #'+ session$ns("scales_type"),
|
|
| 217 | -+ | ||
| 467 | +! |
- tm_g_scatterplot <- function(label = "Scatterplot",+ label = "Scales:", |
|
| 218 | -+ | ||
| 468 | +! |
- x,+ choices = c("Fixed", "Free"),
|
|
| 219 | -+ | ||
| 469 | +! |
- y,+ selected = "Fixed", |
|
| 220 | -+ | ||
| 470 | +! |
- color_by = NULL,+ bigger = FALSE, |
|
| 221 | -+ | ||
| 471 | +! |
- size_by = NULL,+ inline = TRUE |
|
| 222 | +472 |
- row_facet = NULL,+ ) |
|
| 223 | +473 |
- col_facet = NULL,+ } |
|
| 224 | +474 |
- plot_height = c(600, 200, 2000),+ }) |
|
| 225 | +475 |
- plot_width = NULL,+ |
|
| 226 | -+ | ||
| 476 | +! |
- alpha = c(1, 0, 1),+ observeEvent( |
|
| 227 | -+ | ||
| 477 | +! |
- shape = shape_names,+ eventExpr = list( |
|
| 228 | -+ | ||
| 478 | +! |
- size = c(5, 1, 15),+ input$t_dist, |
|
| 229 | -+ | ||
| 479 | +! |
- max_deg = 5L,+ input$params_reset, |
|
| 230 | -+ | ||
| 480 | +! |
- rotate_xaxis_labels = FALSE,+ selector_list()$dist_i()$select |
|
| 231 | +481 |
- ggtheme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void"),
+ ), |
|
| 232 | -+ | ||
| 482 | +! |
- pre_output = NULL,+ handlerExpr = {
|
|
| 233 | -+ | ||
| 483 | +! |
- post_output = NULL,+ if (length(input$t_dist) != 0) {
|
|
| 234 | -+ | ||
| 484 | +! |
- table_dec = 4,+ dist_var2 <- as.vector(merged$anl_input_r()$columns_source$dist_i) |
|
| 235 | +485 |
- ggplot2_args = teal.widgets::ggplot2_args()) {
+
|
|
| 236 | +486 | ! |
- logger::log_info("Initializing tm_g_scatterplot")
+ get_dist_params <- function(x, dist) {
|
| 237 | -+ | ||
| 487 | +! |
-
+ if (dist == "unif") {
|
|
| 238 | +488 | ! |
- extra_packages <- c("ggpmisc", "ggExtra", "colourpicker")
+ res <- as.list(range(x)) |
| 239 | +489 | ! |
- missing_packages <- Filter(function(x) !requireNamespace(x, quietly = TRUE), extra_packages)+ names(res) <- c("min", "max")
|
| 240 | +490 | ! |
- if (length(missing_packages) > 0L) {
+ return(res)+ |
+
| 491 | ++ |
+ } |
|
| 241 | +492 | ! |
- stop(sprintf(+ tryCatch( |
| 242 | +493 | ! |
- "Cannot load package(s): %s.\nInstall or restart your session.",+ as.list(MASS::fitdistr(x, densfun = dist)$estimate), |
| 243 | +494 | ! |
- toString(missing_packages)+ error = function(e) list(param1 = NA, param2 = NA) |
| 244 | +495 |
- ))+ ) |
|
| 245 | +496 |
- }+ } |
|
| 246 | +497 | ||
| 247 | +498 | ! |
- if (inherits(x, "data_extract_spec")) x <- list(x)+ ANL <- merged$anl_q_r()[[as.character(dist_var[[1]]$dataname)]] # nolint: object_name. |
| 248 | +499 | ! |
- if (inherits(y, "data_extract_spec")) y <- list(y)+ params <- get_dist_params(as.numeric(stats::na.omit(ANL[[dist_var2]])), input$t_dist) |
| 249 | +500 | ! |
- if (inherits(color_by, "data_extract_spec")) color_by <- list(color_by)+ params_vec <- round(unname(unlist(params)), 2) |
| 250 | +501 | ! |
- if (inherits(size_by, "data_extract_spec")) size_by <- list(size_by)+ params_names <- names(params) |
| 251 | -! | +||
| 502 | +
- if (inherits(row_facet, "data_extract_spec")) row_facet <- list(row_facet)+ |
||
| 252 | +503 | ! |
- if (inherits(col_facet, "data_extract_spec")) col_facet <- list(col_facet)+ updateNumericInput(session, "dist_param1", label = params_names[1], value = params_vec[1]) |
| 253 | +504 | ! |
- if (is.double(max_deg)) max_deg <- as.integer(max_deg)+ updateNumericInput(session, "dist_param2", label = params_names[2], value = params_vec[2]) |
| 254 | +505 |
-
+ } else {
|
|
| 255 | +506 | ! |
- ggtheme <- match.arg(ggtheme)+ updateNumericInput(session, "dist_param1", label = "param1", value = NA) |
| 256 | +507 | ! |
- checkmate::assert_string(label)+ updateNumericInput(session, "dist_param2", label = "param2", value = NA) |
| 257 | -! | +||
| 508 | +
- checkmate::assert_list(x, types = "data_extract_spec")+ } |
||
| 258 | -! | +||
| 509 | +
- checkmate::assert_list(y, types = "data_extract_spec")+ }, |
||
| 259 | +510 | ! |
- checkmate::assert_list(color_by, types = "data_extract_spec", null.ok = TRUE)+ ignoreInit = TRUE |
| 260 | -! | +||
| 511 | +
- checkmate::assert_list(size_by, types = "data_extract_spec", null.ok = TRUE)+ ) |
||
| 261 | -! | +||
| 512 | +
- checkmate::assert_list(row_facet, types = "data_extract_spec", null.ok = TRUE)+ |
||
| 262 | +513 | ! |
- checkmate::assert_list(col_facet, types = "data_extract_spec", null.ok = TRUE)+ merge_vars <- reactive({
|
| 263 | +514 | ! |
- checkmate::assert_list(row_facet, types = "data_extract_spec", null.ok = TRUE)+ teal::validate_inputs(iv_r()) |
| 264 | -! | +||
| 515 | +
- if (!all(vapply(row_facet, function(x) !x$select$multiple, logical(1)))) {
+
|
||
| 265 | +516 | ! |
- stop("'row_facet' should not allow multiple selection")
+ dist_var <- as.vector(merged$anl_input_r()$columns_source$dist_i) |
| 266 | -+ | ||
| 517 | +! |
- }+ s_var <- as.vector(merged$anl_input_r()$columns_source$strata_i) |
|
| 267 | +518 | ! |
- if (!all(vapply(col_facet, function(x) !x$select$multiple, logical(1)))) {
+ g_var <- as.vector(merged$anl_input_r()$columns_source$group_i)+ |
+
| 519 | ++ | + | |
| 268 | +520 | ! |
- stop("'col_facet' should not allow multiple selection")
+ dist_var_name <- if (length(dist_var)) as.name(dist_var) else NULL |
| 269 | -+ | ||
| 521 | +! |
- }+ s_var_name <- if (length(s_var)) as.name(s_var) else NULL |
|
| 270 | +522 | ! |
- checkmate::assert_character(shape)+ g_var_name <- if (length(g_var)) as.name(g_var) else NULL |
| 271 | +523 | ||
| 272 | +524 | ! |
- checkmate::assert_int(max_deg, lower = 1L)+ list( |
| 273 | +525 | ! |
- checkmate::assert_scalar(table_dec)+ dist_var = dist_var, |
| 274 | +526 | ! |
- checkmate::assert_flag(rotate_xaxis_labels)+ s_var = s_var, |
| 275 | +527 | ! |
- if (length(alpha) == 1) {
+ g_var = g_var, |
| 276 | +528 | ! |
- checkmate::assert_numeric(alpha, any.missing = FALSE, finite = TRUE)- |
-
| 277 | -- |
- } else {
+ dist_var_name = dist_var_name, |
|
| 278 | +529 | ! |
- checkmate::assert_numeric(alpha, len = 3, any.missing = FALSE, finite = TRUE)+ s_var_name = s_var_name, |
| 279 | +530 | ! |
- checkmate::assert_numeric(alpha[1], lower = alpha[2], upper = alpha[3], .var.name = "alpha")+ g_var_name = g_var_name |
| 280 | +531 |
- }+ ) |
|
| 281 | +532 | - - | -|
| 282 | -! | -
- if (length(size) == 1) {
- |
- |
| 283 | -! | -
- checkmate::assert_numeric(size, any.missing = FALSE, finite = TRUE)+ }) |
|
| 284 | +533 |
- } else {
+
|
|
| 285 | -! | +||
| 534 | +
- checkmate::assert_numeric(size, len = 3, any.missing = FALSE, finite = TRUE)+ # common qenv |
||
| 286 | +535 | ! |
- checkmate::assert_numeric(size[1], lower = size[2], upper = size[3], .var.name = "size")+ common_q <- reactive({
|
| 287 | +536 |
- }+ # Create a private stack for this function only. |
|
| 288 | +537 | ||
| 289 | +538 | ! |
- checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE)+ ANL <- merged$anl_q_r()[["ANL"]] # nolint: object_name. |
| 290 | +539 | ! |
- checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height")+ dist_var <- merge_vars()$dist_var |
| 291 | +540 | ! |
- checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE)+ s_var <- merge_vars()$s_var |
| 292 | +541 | ! |
- checkmate::assert_numeric(+ g_var <- merge_vars()$g_var+ |
+
| 542 | ++ | + | |
| 293 | +543 | ! |
- plot_width[1],+ dist_var_name <- merge_vars()$dist_var_name |
| 294 | +544 | ! |
- lower = plot_width[2], upper = plot_width[3], null.ok = TRUE, .var.name = "plot_width"+ s_var_name <- merge_vars()$s_var_name |
| 295 | -+ | ||
| 545 | +! |
- )+ g_var_name <- merge_vars()$g_var_name |
|
| 296 | +546 | ||
| 297 | +547 | ! |
- checkmate::assert_class(ggplot2_args, "ggplot2_args")+ roundn <- input$roundn+ |
+
| 548 | +! | +
+ dist_param1 <- input$dist_param1+ |
+ |
| 549 | +! | +
+ dist_param2 <- input$dist_param2 |
|
| 298 | +550 |
-
+ # isolated as dist_param1/dist_param2 already triggered the reactivity |
|
| 299 | +551 | ! |
- args <- as.list(environment())+ t_dist <- isolate(input$t_dist) |
| 300 | +552 | ||
| 301 | +553 | ! |
- data_extract_list <- list(+ qenv <- merged$anl_q_r() |
| 302 | -! | +||
| 554 | +
- x = x,+ |
||
| 303 | +555 | ! |
- y = y,+ if (length(g_var) > 0) {
|
| 304 | +556 | ! |
- color_by = color_by,+ validate( |
| 305 | +557 | ! |
- size_by = size_by,+ need( |
| 306 | +558 | ! |
- row_facet = row_facet,+ inherits(ANL[[g_var]], c("integer", "factor", "character")),
|
| 307 | +559 | ! |
- col_facet = col_facet+ "Group by variable must be `factor`, `character`, or `integer`" |
| 308 | +560 |
- )+ ) |
|
| 309 | +561 | - - | -|
| 310 | -! | -
- module(- |
- |
| 311 | -! | -
- label = label,- |
- |
| 312 | -! | -
- server = srv_g_scatterplot,+ ) |
|
| 313 | +562 | ! |
- ui = ui_g_scatterplot,+ qenv <- teal.code::eval_code( |
| 314 | +563 | ! |
- ui_args = args,+ qenv, |
| 315 | +564 | ! |
- server_args = c(+ substitute( |
| 316 | +565 | ! |
- data_extract_list,+ expr = ANL[[g_var]] <- forcats::fct_na_value_to_level(as.factor(ANL[[g_var]]), "NA"), # nolint: object_name. |
| 317 | +566 | ! |
- list(plot_height = plot_height, plot_width = plot_width, table_dec = table_dec, ggplot2_args = ggplot2_args)+ env = list(g_var = g_var) |
| 318 | +567 |
- ),- |
- |
| 319 | -! | -
- datanames = teal.transform::get_extract_datanames(data_extract_list)+ ) |
|
| 320 | +568 |
- )+ ) |
|
| 321 | +569 |
- }+ } |
|
| 322 | +570 | ||
| 323 | -+ | ||
| 571 | +! |
- ui_g_scatterplot <- function(id, ...) {
+ if (length(s_var) > 0) {
|
|
| 324 | +572 | ! |
- args <- list(...)+ validate( |
| 325 | +573 | ! |
- ns <- NS(id)+ need( |
| 326 | +574 | ! |
- is_single_dataset_value <- teal.transform::is_single_dataset(+ inherits(ANL[[s_var]], c("integer", "factor", "character")),
|
| 327 | +575 | ! |
- args$x, args$y, args$color_by, args$size_by, args$row_facet, args$col_facet+ "Stratify by variable must be `factor`, `character`, or `integer`" |
| 328 | +576 |
- )+ ) |
|
| 329 | +577 |
-
+ ) |
|
| 330 | +578 | ! |
- shiny::tagList(+ qenv <- teal.code::eval_code( |
| 331 | +579 | ! |
- include_css_files("custom"),
+ qenv, |
| 332 | +580 | ! |
- teal.widgets::standard_layout(+ substitute( |
| 333 | +581 | ! |
- output = teal.widgets::white_small_well(+ expr = ANL[[s_var]] <- forcats::fct_na_value_to_level(as.factor(ANL[[s_var]]), "NA"), # nolint: object_name. |
| 334 | +582 | ! |
- teal.widgets::plot_with_settings_ui(id = ns("scatter_plot")),
+ env = list(s_var = s_var) |
| 335 | -! | +||
| 583 | +
- tags$h1(tags$strong("Selected points:"), class = "text-center font-150p"),
+ ) |
||
| 336 | -! | +||
| 584 | +
- teal.widgets::get_dt_rows(ns("data_table"), ns("data_table_rows")),
+ ) |
||
| 337 | -! | +||
| 585 | +
- DT::dataTableOutput(ns("data_table"), width = "100%")
+ } |
||
| 338 | +586 |
- ),+ |
|
| 339 | +587 | ! |
- encoding = div(- |
-
| 340 | -- |
- ### Reporter+ validate(need(is.numeric(ANL[[dist_var]]), "Please select a numeric variable.")) |
|
| 341 | +588 | ! |
- teal.reporter::simple_reporter_ui(ns("simple_reporter")),
+ teal::validate_has_data(ANL, 1, complete = TRUE) |
| 342 | +589 |
- ###- |
- |
| 343 | -! | -
- tags$label("Encodings", class = "text-primary"),
+
|
|
| 344 | +590 | ! |
- teal.transform::datanames_input(args[c("x", "y", "color_by", "size_by", "row_facet", "col_facet")]),
+ if (length(t_dist) != 0) {
|
| 345 | +591 | ! |
- teal.transform::data_extract_ui(+ map_distr_nams <- list( |
| 346 | +592 | ! |
- id = ns("x"),
+ normal = c("mean", "sd"),
|
| 347 | +593 | ! |
- label = "X variable",+ lognormal = c("meanlog", "sdlog"),
|
| 348 | +594 | ! |
- data_extract_spec = args$x,+ gamma = c("shape", "rate"),
|
| 349 | +595 | ! |
- is_single_dataset = is_single_dataset_value+ unif = c("min", "max")
|
| 350 | +596 |
- ),+ ) |
|
| 351 | +597 | ! |
- checkboxInput(ns("log_x"), "Use log transformation", value = FALSE),
+ params_names_raw <- map_distr_nams[[t_dist]] |
| 352 | -! | +||
| 598 | +
- conditionalPanel(+ |
||
| 353 | +599 | ! |
- condition = paste0("input['", ns("log_x"), "'] == true"),
+ qenv <- teal.code::eval_code( |
| 354 | +600 | ! |
- radioButtons(+ qenv, |
| 355 | +601 | ! |
- ns("log_x_base"),
+ substitute( |
| 356 | +602 | ! |
- label = NULL,+ expr = {
|
| 357 | +603 | ! |
- inline = TRUE,+ params <- as.list(c(dist_param1, dist_param2)) |
| 358 | +604 | ! |
- choices = c("Natural" = "log", "Base 10" = "log10", "Base 2" = "log2")
+ names(params) <- params_names_raw |
| 359 | +605 |
- )+ }, |
|
| 360 | -+ | ||
| 606 | +! |
- ),+ env = list( |
|
| 361 | +607 | ! |
- teal.transform::data_extract_ui(+ dist_param1 = dist_param1, |
| 362 | +608 | ! |
- id = ns("y"),
+ dist_param2 = dist_param2, |
| 363 | +609 | ! |
- label = "Y variable",+ params_names_raw = params_names_raw |
| 364 | -! | +||
| 610 | +
- data_extract_spec = args$y,+ ) |
||
| 365 | -! | +||
| 611 | +
- is_single_dataset = is_single_dataset_value+ ) |
||
| 366 | +612 |
- ),+ ) |
|
| 367 | -! | +||
| 613 | +
- checkboxInput(ns("log_y"), "Use log transformation", value = FALSE),
+ } |
||
| 368 | -! | +||
| 614 | +
- conditionalPanel(+ |
||
| 369 | +615 | ! |
- condition = paste0("input['", ns("log_y"), "'] == true"),
+ if (length(s_var) == 0 && length(g_var) == 0) {
|
| 370 | +616 | ! |
- radioButtons(+ qenv <- teal.code::eval_code( |
| 371 | +617 | ! |
- ns("log_y_base"),
+ qenv, |
| 372 | +618 | ! |
- label = NULL,+ substitute( |
| 373 | +619 | ! |
- inline = TRUE,+ expr = {
|
| 374 | +620 | ! |
- choices = c("Natural" = "log", "Base 10" = "log10", "Base 2" = "log2")
- |
-
| 375 | -- |
- )+ summary_table <- ANL %>% |
|
| 376 | -+ | ||
| 621 | +! |
- ),+ dplyr::summarise( |
|
| 377 | +622 | ! |
- if (!is.null(args$color_by)) {
+ min = round(min(dist_var_name, na.rm = TRUE), roundn), |
| 378 | +623 | ! |
- teal.transform::data_extract_ui(+ median = round(stats::median(dist_var_name, na.rm = TRUE), roundn), |
| 379 | +624 | ! |
- id = ns("color_by"),
+ mean = round(mean(dist_var_name, na.rm = TRUE), roundn), |
| 380 | +625 | ! |
- label = "Color by variable",+ max = round(max(dist_var_name, na.rm = TRUE), roundn), |
| 381 | +626 | ! |
- data_extract_spec = args$color_by,+ sd = round(stats::sd(dist_var_name, na.rm = TRUE), roundn), |
| 382 | +627 | ! |
- is_single_dataset = is_single_dataset_value+ count = dplyr::n() |
| 383 | +628 |
- )+ ) |
|
| 384 | +629 |
- },- |
- |
| 385 | -! | -
- if (!is.null(args$size_by)) {
+ }, |
|
| 386 | +630 | ! |
- teal.transform::data_extract_ui(+ env = list( |
| 387 | +631 | ! |
- id = ns("size_by"),
+ dist_var_name = as.name(dist_var), |
| 388 | +632 | ! |
- label = "Size by variable",+ roundn = roundn |
| 389 | -! | +||
| 633 | +
- data_extract_spec = args$size_by,+ ) |
||
| 390 | -! | +||
| 634 | +
- is_single_dataset = is_single_dataset_value+ ) |
||
| 391 | +635 |
- )+ ) |
|
| 392 | +636 |
- },+ } else {
|
|
| 393 | +637 | ! |
- if (!is.null(args$row_facet)) {
+ qenv <- teal.code::eval_code( |
| 394 | +638 | ! |
- teal.transform::data_extract_ui(+ qenv, |
| 395 | +639 | ! |
- id = ns("row_facet"),
+ substitute( |
| 396 | +640 | ! |
- label = "Row facetting",+ expr = {
|
| 397 | +641 | ! |
- data_extract_spec = args$row_facet,+ strata_vars <- strata_vars_raw |
| 398 | +642 | ! |
- is_single_dataset = is_single_dataset_value+ summary_table <- ANL %>% |
| 399 | -+ | ||
| 643 | +! |
- )+ dplyr::group_by_at(dplyr::vars(dplyr::any_of(strata_vars))) %>% |
|
| 400 | -+ | ||
| 644 | +! |
- },+ dplyr::summarise( |
|
| 401 | +645 | ! |
- if (!is.null(args$col_facet)) {
+ min = round(min(dist_var_name, na.rm = TRUE), roundn), |
| 402 | +646 | ! |
- teal.transform::data_extract_ui(+ median = round(stats::median(dist_var_name, na.rm = TRUE), roundn), |
| 403 | +647 | ! |
- id = ns("col_facet"),
+ mean = round(mean(dist_var_name, na.rm = TRUE), roundn), |
| 404 | +648 | ! |
- label = "Column facetting",+ max = round(max(dist_var_name, na.rm = TRUE), roundn), |
| 405 | +649 | ! |
- data_extract_spec = args$col_facet,+ sd = round(stats::sd(dist_var_name, na.rm = TRUE), roundn), |
| 406 | +650 | ! |
- is_single_dataset = is_single_dataset_value+ count = dplyr::n() |
| 407 | +651 |
- )+ )+ |
+ |
| 652 | +! | +
+ summary_table # used to display table when running show-r-code code |
|
| 408 | +653 |
- },+ }, |
|
| 409 | +654 | ! |
- teal.widgets::panel_group(+ env = list( |
| 410 | +655 | ! |
- teal.widgets::panel_item(+ dist_var_name = dist_var_name, |
| 411 | +656 | ! |
- title = "Plot settings",+ strata_vars_raw = c(g_var, s_var), |
| 412 | +657 | ! |
- teal.widgets::optionalSliderInputValMinMax(ns("alpha"), "Opacity:", args$alpha, ticks = FALSE),
+ roundn = roundn |
| 413 | -! | +||
| 658 | +
- teal.widgets::optionalSelectInput(+ ) |
||
| 414 | -! | +||
| 659 | +
- inputId = ns("shape"),
+ ) |
||
| 415 | -! | +||
| 660 | +
- label = "Points shape:",+ ) |
||
| 416 | -! | +||
| 661 | +
- choices = args$shape,+ } |
||
| 417 | -! | +||
| 662 | +
- selected = args$shape[1],+ }) |
||
| 418 | -! | +||
| 663 | +
- multiple = FALSE+ |
||
| 419 | +664 |
- ),+ # distplot qenv ---- |
|
| 420 | +665 | ! |
- colourpicker::colourInput(ns("color"), "Points color:", "black"),
+ dist_q <- eventReactive( |
| 421 | +666 | ! |
- teal.widgets::optionalSliderInputValMinMax(ns("size"), "Points size:", args$size, ticks = FALSE, step = .1),
+ eventExpr = {
|
| 422 | +667 | ! |
- checkboxInput(ns("rotate_xaxis_labels"), "Rotate X axis labels", value = args$rotate_xaxis_labels),
+ common_q() |
| 423 | +668 | ! |
- checkboxInput(ns("add_density"), "Add marginal density", value = FALSE),
+ input$scales_type |
| 424 | +669 | ! |
- checkboxInput(ns("rug_plot"), "Include rug plot", value = FALSE),
+ input$main_type |
| 425 | +670 | ! |
- checkboxInput(ns("show_count"), "Show N (number of observations)", value = FALSE),
+ input$bins |
| 426 | +671 | ! |
- shinyjs::hidden(helpText(id = ns("line_msg"), "Trendline needs numeric X and Y variables")),
+ input$add_dens |
| 427 | +672 | ! |
- teal.widgets::optionalSelectInput(ns("smoothing_degree"), "Smoothing degree", seq_len(args$max_deg)),
+ is.null(input$ggtheme)+ |
+
| 673 | ++ |
+ }, |
|
| 428 | +674 | ! |
- shinyjs::hidden(teal.widgets::optionalSelectInput(ns("color_sub"), label = "", multiple = TRUE)),
+ valueExpr = {
|
| 429 | +675 | ! |
- teal.widgets::optionalSliderInputValMinMax(ns("ci"), "Confidence", c(.95, .8, .99), ticks = FALSE),
+ dist_var <- merge_vars()$dist_var |
| 430 | +676 | ! |
- shinyjs::hidden(checkboxInput(ns("show_form"), "Show formula", value = TRUE)),
+ s_var <- merge_vars()$s_var |
| 431 | +677 | ! |
- shinyjs::hidden(checkboxInput(ns("show_r2"), "Show adj-R Squared", value = TRUE)),
+ g_var <- merge_vars()$g_var |
| 432 | +678 | ! |
- uiOutput(ns("num_na_removed")),
+ dist_var_name <- merge_vars()$dist_var_name |
| 433 | +679 | ! |
- div(+ s_var_name <- merge_vars()$s_var_name |
| 434 | +680 | ! |
- id = ns("label_pos"),
+ g_var_name <- merge_vars()$g_var_name |
| 435 | +681 | ! |
- div(strong("Stats position")),
+ t_dist <- input$t_dist |
| 436 | +682 | ! |
- div(class = "inline-block w-10", helpText("Left")),
+ dist_param1 <- input$dist_param1 |
| 437 | +683 | ! |
- div(+ dist_param2 <- input$dist_param2+ |
+
| 684 | ++ | + | |
| 438 | +685 | ! |
- class = "inline-block w-70",+ scales_type <- input$scales_type+ |
+
| 686 | ++ | + | |
| 439 | +687 | ! |
- teal.widgets::optionalSliderInput(+ ndensity <- 512 |
| 440 | +688 | ! |
- ns("pos"),
+ main_type_var <- input$main_type |
| 441 | +689 | ! |
- label = NULL,+ bins_var <- input$bins |
| 442 | +690 | ! |
- min = 0, max = 1, value = .99, ticks = FALSE, step = .01+ add_dens_var <- input$add_dens |
| 443 | -+ | ||
| 691 | +! |
- )+ ggtheme <- input$ggtheme |
|
| 444 | +692 |
- ),+ |
|
| 445 | +693 | ! |
- div(class = "inline-block w-10", helpText("Right"))
+ teal::validate_inputs(iv_dist) |
| 446 | +694 |
- ),+ |
|
| 447 | +695 | ! |
- teal.widgets::optionalSliderInput(+ qenv <- common_q() |
| 448 | -! | +||
| 696 | +
- ns("label_size"), "Stats font size",
+
|
||
| 449 | +697 | ! |
- min = 3, max = 10, value = 5, ticks = FALSE, step = .1+ m_type <- if (main_type_var == "Density") "density" else "count" |
| 450 | +698 |
- ),+ |
|
| 451 | +699 | ! |
- if (!is.null(args$row_facet) || !is.null(args$col_facet)) {
+ plot_call <- if (length(s_var) == 0 && length(g_var) == 0) {
|
| 452 | +700 | ! |
- checkboxInput(ns("free_scales"), "Free scales", value = FALSE)
- |
-
| 453 | -- |
- },+ substitute( |
|
| 454 | +701 | ! |
- selectInput(+ expr = ggplot(ANL, aes(dist_var_name)) + |
| 455 | +702 | ! |
- inputId = ns("ggtheme"),
+ geom_histogram( |
| 456 | +703 | ! |
- label = "Theme (by ggplot):",+ position = "identity", aes(y = after_stat(m_type)), bins = bins_var, alpha = 0.3 |
| 457 | -! | +||
| 704 | +
- choices = ggplot_themes,+ ), |
||
| 458 | +705 | ! |
- selected = args$ggtheme,+ env = list( |
| 459 | +706 | ! |
- multiple = FALSE+ m_type = as.name(m_type), bins_var = bins_var, dist_var_name = as.name(dist_var) |
| 460 | +707 |
) |
|
| 461 | +708 |
) |
|
| 462 | -+ | ||
| 709 | +! |
- )+ } else if (length(s_var) != 0 && length(g_var) == 0) {
|
|
| 463 | -+ | ||
| 710 | +! |
- ),+ substitute( |
|
| 464 | +711 | ! |
- forms = tagList(+ expr = ggplot(ANL, aes(dist_var_name, col = s_var_name)) + |
| 465 | +712 | ! |
- teal.widgets::verbatim_popup_ui(ns("warning"), button_label = "Show Warnings"),
+ geom_histogram( |
| 466 | +713 | ! |
- teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code")
+ position = "identity", aes(y = after_stat(m_type), fill = s_var), bins = bins_var, alpha = 0.3 |
| 467 | +714 |
- ),+ ), |
|
| 468 | +715 | ! |
- pre_output = args$pre_output,+ env = list( |
| 469 | +716 | ! |
- post_output = args$post_output+ m_type = as.name(m_type), |
| 470 | -+ | ||
| 717 | +! |
- )+ bins_var = bins_var, |
|
| 471 | -+ | ||
| 718 | +! |
- )+ dist_var_name = dist_var_name, |
|
| 472 | -+ | ||
| 719 | +! |
- }+ s_var = as.name(s_var), |
|
| 473 | -+ | ||
| 720 | +! |
-
+ s_var_name = s_var_name |
|
| 474 | +721 |
- srv_g_scatterplot <- function(id,+ ) |
|
| 475 | +722 |
- data,+ ) |
|
| 476 | -+ | ||
| 723 | +! |
- reporter,+ } else if (length(s_var) == 0 && length(g_var) != 0) {
|
|
| 477 | -+ | ||
| 724 | +! |
- filter_panel_api,+ req(scales_type) |
|
| 478 | -+ | ||
| 725 | +! |
- x,+ substitute( |
|
| 479 | -+ | ||
| 726 | +! |
- y,+ expr = ggplot(ANL[ANL[[g_var]] != "NA", ], aes(dist_var_name)) + |
|
| 480 | -+ | ||
| 727 | +! |
- color_by,+ geom_histogram( |
|
| 481 | -+ | ||
| 728 | +! |
- size_by,+ position = "identity", aes(y = after_stat(m_type)), bins = bins_var, alpha = 0.3 |
|
| 482 | +729 |
- row_facet,+ ) + |
|
| 483 | -+ | ||
| 730 | +! |
- col_facet,+ facet_wrap(~g_var_name, ncol = 1, scales = scales_raw), |
|
| 484 | -+ | ||
| 731 | +! |
- plot_height,+ env = list( |
|
| 485 | -+ | ||
| 732 | +! |
- plot_width,+ m_type = as.name(m_type), |
|
| 486 | -+ | ||
| 733 | +! |
- table_dec,+ bins_var = bins_var, |
|
| 487 | -+ | ||
| 734 | +! |
- ggplot2_args) {
+ dist_var_name = dist_var_name, |
|
| 488 | +735 | ! |
- with_reporter <- !missing(reporter) && inherits(reporter, "Reporter")+ g_var = g_var, |
| 489 | +736 | ! |
- with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI")+ g_var_name = g_var_name, |
| 490 | +737 | ! |
- checkmate::assert_class(data, "reactive")+ scales_raw = tolower(scales_type) |
| 491 | -! | +||
| 738 | +
- checkmate::assert_class(isolate(data()), "teal_data")+ )+ |
+ ||
| 739 | ++ |
+ )+ |
+ |
| 740 | ++ |
+ } else {
|
|
| 492 | +741 | ! |
- moduleServer(id, function(input, output, session) {
+ req(scales_type) |
| 493 | +742 | ! |
- data_extract <- list(+ substitute( |
| 494 | +743 | ! |
- x = x,+ expr = ggplot(ANL[ANL[[g_var]] != "NA", ], aes(dist_var_name, col = s_var_name)) + |
| 495 | +744 | ! |
- y = y,+ geom_histogram( |
| 496 | +745 | ! |
- color_by = color_by,+ position = "identity", |
| 497 | +746 | ! |
- size_by = size_by,+ aes(y = after_stat(m_type), fill = s_var), bins = bins_var, alpha = 0.3+ |
+
| 747 | ++ |
+ ) + |
|
| 498 | +748 | ! |
- row_facet = row_facet,+ facet_wrap(~g_var_name, ncol = 1, scales = scales_raw), |
| 499 | +749 | ! |
- col_facet = col_facet+ env = list( |
| 500 | -+ | ||
| 750 | +! |
- )+ m_type = as.name(m_type), |
|
| 501 | -+ | ||
| 751 | +! |
-
+ bins_var = bins_var, |
|
| 502 | +752 | ! |
- rule_diff <- function(other) {
+ dist_var_name = dist_var_name, |
| 503 | +753 | ! |
- function(value) {
+ g_var = g_var, |
| 504 | +754 | ! |
- othervalue <- selector_list()[[other]]()[["select"]]+ s_var = as.name(s_var), |
| 505 | +755 | ! |
- if (!is.null(othervalue)) {
+ g_var_name = g_var_name, |
| 506 | +756 | ! |
- if (identical(value, othervalue)) {
+ s_var_name = s_var_name, |
| 507 | +757 | ! |
- "Row and column facetting variables must be different."+ scales_raw = tolower(scales_type) |
| 508 | +758 |
- }+ ) |
|
| 509 | +759 |
- }+ ) |
|
| 510 | +760 |
- }+ } |
|
| 511 | +761 |
- }+ |
|
| 512 | -+ | ||
| 762 | +! |
-
+ if (add_dens_var) {
|
|
| 513 | +763 | ! |
- selector_list <- teal.transform::data_extract_multiple_srv(+ plot_call <- substitute( |
| 514 | +764 | ! |
- data_extract = data_extract,+ expr = plot_call + |
| 515 | +765 | ! |
- datasets = data,+ stat_density( |
| 516 | +766 | ! |
- select_validation_rule = list(+ aes(y = after_stat(const * m_type2)), |
| 517 | +767 | ! |
- x = ~ if (length(.) != 1) "Please select exactly one x var.",+ geom = "line", |
| 518 | +768 | ! |
- y = ~ if (length(.) != 1) "Please select exactly one y var.",+ position = "identity", |
| 519 | +769 | ! |
- color_by = ~ if (length(.) > 1) "There cannot be more than 1 color variable.",+ alpha = 0.5, |
| 520 | +770 | ! |
- size_by = ~ if (length(.) > 1) "There cannot be more than 1 size variable.",+ size = 2, |
| 521 | +771 | ! |
- row_facet = shinyvalidate::compose_rules(+ n = ndensity+ |
+
| 772 | ++ |
+ ), |
|
| 522 | +773 | ! |
- shinyvalidate::sv_optional(),+ env = list( |
| 523 | +774 | ! |
- rule_diff("col_facet")
+ plot_call = plot_call,+ |
+
| 775 | +! | +
+ const = if (main_type_var == "Density") {
+ |
+ |
| 776 | +! | +
+ 1 |
|
| 524 | +777 |
- ),+ } else {
|
|
| 525 | +778 | ! |
- col_facet = shinyvalidate::compose_rules(+ diff(range(qenv[["ANL"]][[dist_var]], na.rm = TRUE)) / bins_var+ |
+
| 779 | ++ |
+ }, |
|
| 526 | +780 | ! |
- shinyvalidate::sv_optional(),+ m_type2 = if (main_type_var == "Density") as.name("density") else as.name("count"),
|
| 527 | +781 | ! |
- rule_diff("row_facet")
+ ndensity = ndensity |
| 528 | +782 |
- )+ ) |
|
| 529 | +783 |
- )+ ) |
|
| 530 | +784 |
- )+ } |
|
| 531 | +785 | ||
| 532 | +786 | ! |
- iv_r <- reactive({
+ if (length(t_dist) != 0 && main_type_var == "Density" && length(g_var) == 0 && length(s_var) == 0) {
|
| 533 | +787 | ! |
- iv_facet <- shinyvalidate::InputValidator$new()+ qenv <- teal.code::eval_code( |
| 534 | +788 | ! |
- iv <- shinyvalidate::InputValidator$new()+ qenv, |
| 535 | +789 | ! |
- teal.transform::compose_and_enable_validators(iv, selector_list)+ substitute( |
| 536 | -+ | ||
| 790 | +! |
- })+ df_params <- as.data.frame(append(params, list(name = t_dist))), |
|
| 537 | +791 | ! |
- iv_facet <- shinyvalidate::InputValidator$new()+ env = list(t_dist = t_dist) |
| 538 | -! | +||
| 792 | +
- iv_facet$add_rule("add_density", ~ if (isTRUE(.) &&
+ ) |
||
| 539 | -! | +||
| 793 | +
- (length(selector_list()$row_facet()$select) > 0L ||+ ) |
||
| 540 | +794 | ! |
- length(selector_list()$col_facet()$select) > 0L)) {
+ datas <- quote(data.frame(x = 0.7, y = 1, tb = I(list(df_params = df_params)))) |
| 541 | +795 | ! |
- "Cannot add marginal density when Row or Column facetting has been selected"+ label <- quote(tb) |
| 542 | +796 |
- })+ |
|
| 543 | +797 | ! |
- iv_facet$enable()+ plot_call <- substitute( |
| 544 | -+ | ||
| 798 | +! |
-
+ expr = plot_call + ggpp::geom_table_npc( |
|
| 545 | +799 | ! |
- anl_merged_input <- teal.transform::merge_expression_srv(+ data = data, |
| 546 | +800 | ! |
- selector_list = selector_list,+ aes(npcx = x, npcy = y, label = label), |
| 547 | +801 | ! |
- datasets = data,+ hjust = 0, vjust = 1, size = 4+ |
+
| 802 | ++ |
+ ), |
|
| 548 | +803 | ! |
- merge_function = "dplyr::inner_join"+ env = list(plot_call = plot_call, data = datas, label = label) |
| 549 | +804 |
- )+ ) |
|
| 550 | +805 | ++ |
+ }+ |
+
| 806 | |||
| 551 | +807 | ! |
- anl_merged_q <- reactive({
+ if (length(s_var) == 0 && length(g_var) == 0 && main_type_var == "Density" && |
| 552 | +808 | ! |
- req(anl_merged_input())+ length(t_dist) != 0 && main_type_var == "Density") {
|
| 553 | +809 | ! |
- data() %>%+ map_dist <- stats::setNames( |
| 554 | +810 | ! |
- teal.code::eval_code(as.expression(anl_merged_input()$expr)) %>%+ c("dnorm", "dlnorm", "dgamma", "dunif"),
|
| 555 | +811 | ! |
- teal.code::eval_code(quote(ANL)) # used to display table when running show-r-code code+ c("normal", "lognormal", "gamma", "unif")
|
| 556 | +812 |
- })+ ) |
|
| 557 | -+ | ||
| 813 | +! |
-
+ plot_call <- substitute( |
|
| 558 | +814 | ! |
- merged <- list(+ expr = plot_call + stat_function( |
| 559 | +815 | ! |
- anl_input_r = anl_merged_input,+ data = data.frame(x = range(ANL[[dist_var]]), color = mapped_dist), |
| 560 | +816 | ! |
- anl_q_r = anl_merged_q+ aes(x, color = color), |
| 561 | -+ | ||
| 817 | +! |
- )+ fun = mapped_dist_name, |
|
| 562 | -+ | ||
| 818 | +! |
-
+ n = ndensity, |
|
| 563 | +819 | ! |
- trend_line_is_applicable <- reactive({
+ size = 2, |
| 564 | +820 | ! |
- ANL <- merged$anl_q_r()[["ANL"]] # nolint: object_name.+ args = params |
| 565 | -! | +||
| 821 | +
- x_var <- as.vector(merged$anl_input_r()$columns_source$x)+ ) + |
||
| 566 | +822 | ! |
- y_var <- as.vector(merged$anl_input_r()$columns_source$y)+ scale_color_manual(values = stats::setNames("blue", mapped_dist), aesthetics = "color"),
|
| 567 | +823 | ! |
- length(x_var) > 0 && length(y_var) > 0 && is.numeric(ANL[[x_var]]) && is.numeric(ANL[[y_var]])+ env = list( |
| 568 | -+ | ||
| 824 | +! |
- })+ plot_call = plot_call, |
|
| 569 | -+ | ||
| 825 | +! |
-
+ dist_var = dist_var, |
|
| 570 | +826 | ! |
- add_trend_line <- reactive({
+ ndensity = ndensity, |
| 571 | +827 | ! |
- smoothing_degree <- as.integer(input$smoothing_degree)+ mapped_dist = unname(map_dist[t_dist]), |
| 572 | +828 | ! |
- trend_line_is_applicable() && length(smoothing_degree) > 0+ mapped_dist_name = as.name(unname(map_dist[t_dist])) |
| 573 | +829 |
- })+ ) |
|
| 574 | +830 | - - | -|
| 575 | -! | -
- if (!is.null(color_by)) {
+ ) |
|
| 576 | -! | +||
| 831 | +
- observeEvent(+ } |
||
| 577 | -! | +||
| 832 | +
- eventExpr = merged$anl_input_r()$columns_source$color_by,+ |
||
| 578 | +833 | ! |
- handlerExpr = {
+ all_ggplot2_args <- teal.widgets::resolve_ggplot2_args( |
| 579 | +834 | ! |
- color_by_var <- as.vector(merged$anl_input_r()$columns_source$color_by)+ user_plot = ggplot2_args[["Histogram"]], |
| 580 | +835 | ! |
- if (length(color_by_var) > 0) {
+ user_default = ggplot2_args$default |
| 581 | -! | +||
| 836 | +
- shinyjs::hide("color")
+ ) |
||
| 582 | +837 |
- } else {
+
|
|
| 583 | +838 | ! |
- shinyjs::show("color")
- |
-
| 584 | -- |
- }+ parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args( |
|
| 585 | -+ | ||
| 839 | +! |
- }+ all_ggplot2_args, |
|
| 586 | -+ | ||
| 840 | +! |
- )+ ggtheme = ggtheme |
|
| 587 | +841 |
- }+ ) |
|
| 588 | +842 | ||
| 589 | +843 | ! |
- output$num_na_removed <- renderUI({
+ teal.code::eval_code( |
| 590 | +844 | ! |
- if (add_trend_line()) {
+ qenv, |
| 591 | +845 | ! |
- ANL <- merged$anl_q_r()[["ANL"]] # nolint: object_name.+ substitute( |
| 592 | +846 | ! |
- x_var <- as.vector(merged$anl_input_r()$columns_source$x)+ expr = {
|
| 593 | +847 | ! |
- y_var <- as.vector(merged$anl_input_r()$columns_source$y)+ g <- plot_call |
| 594 | +848 | ! |
- if ((num_total_na <- nrow(ANL) - nrow(stats::na.omit(ANL[, c(x_var, y_var)]))) > 0) {
+ print(g)+ |
+
| 849 | ++ |
+ }, |
|
| 595 | +850 | ! |
- shiny::tags$div(paste(num_total_na, "row(s) with missing values were removed"), shiny::tags$hr())+ env = list(plot_call = Reduce(function(x, y) call("+", x, y), c(plot_call, parsed_ggplot2_args)))
|
| 596 | +851 |
- }+ ) |
|
| 597 | +852 | ++ |
+ )+ |
+
| 853 |
} |
||
| 598 | +854 |
- })+ ) |
|
| 599 | +855 | ||
| 600 | -! | +||
| 856 | +
- observeEvent(+ # qqplot qenv ---- |
||
| 601 | +857 | ! |
- eventExpr = merged$anl_input_r()$columns_source[c("col_facet", "row_facet")],
+ qq_q <- eventReactive( |
| 602 | +858 | ! |
- handlerExpr = {
+ eventExpr = {
|
| 603 | +859 | ! |
- if (length(merged$anl_input_r()$columns_source$col_facet) == 0 &&+ common_q() |
| 604 | +860 | ! |
- length(merged$anl_input_r()$columns_source$row_facet) == 0) {
+ input$scales_type |
| 605 | +861 | ! |
- shinyjs::hide("free_scales")
- |
-
| 606 | -- |
- } else {
+ input$qq_line |
|
| 607 | +862 | ! |
- shinyjs::show("free_scales")
- |
-
| 608 | -- |
- }- |
- |
| 609 | -- |
- }- |
- |
| 610 | -- |
- )+ is.null(input$ggtheme) |
|
| 611 | +863 |
-
+ }, |
|
| 612 | +864 | ! |
- output_q <- reactive({
+ valueExpr = {
|
| 613 | +865 | ! |
- teal::validate_inputs(iv_r(), iv_facet)- |
-
| 614 | -- |
-
+ dist_var <- merge_vars()$dist_var |
|
| 615 | +866 | ! |
- ANL <- merged$anl_q_r()[["ANL"]] # nolint: object_name.- |
-
| 616 | -- |
-
+ s_var <- merge_vars()$s_var |
|
| 617 | +867 | ! |
- x_var <- as.vector(merged$anl_input_r()$columns_source$x)+ g_var <- merge_vars()$g_var |
| 618 | +868 | ! |
- y_var <- as.vector(merged$anl_input_r()$columns_source$y)+ dist_var_name <- merge_vars()$dist_var_name |
| 619 | +869 | ! |
- color_by_var <- as.vector(merged$anl_input_r()$columns_source$color_by)+ s_var_name <- merge_vars()$s_var_name |
| 620 | +870 | ! |
- size_by_var <- as.vector(merged$anl_input_r()$columns_source$size_by)+ g_var_name <- merge_vars()$g_var_name |
| 621 | +871 | ! |
- row_facet_name <- if (length(merged$anl_input_r()$columns_source$row_facet) == 0) {
+ t_dist <- input$t_dist |
| 622 | +872 | ! |
- character(0)- |
-
| 623 | -- |
- } else {
+ dist_param1 <- input$dist_param1 |
|
| 624 | +873 | ! |
- as.vector(merged$anl_input_r()$columns_source$row_facet)+ dist_param2 <- input$dist_param2 |
| 625 | +874 |
- }+ |
|
| 626 | +875 | ! |
- col_facet_name <- if (length(merged$anl_input_r()$columns_source$col_facet) == 0) {
+ scales_type <- input$scales_type |
| 627 | +876 | ! |
- character(0)+ ggtheme <- input$ggtheme |
| 628 | +877 |
- } else {
+
|
|
| 629 | +878 | ! |
- as.vector(merged$anl_input_r()$columns_source$col_facet)+ teal::validate_inputs(iv_r_dist(), iv_dist) |
| 630 | +879 |
- }+ |
|
| 631 | +880 | ! |
- alpha <- input$alpha+ qenv <- common_q() |
| 632 | -! | +||
| 881 | +
- size <- input$size+ |
||
| 633 | +882 | ! |
- rotate_xaxis_labels <- input$rotate_xaxis_labels+ plot_call <- if (length(s_var) == 0 && length(g_var) == 0) {
|
| 634 | +883 | ! |
- add_density <- input$add_density+ substitute( |
| 635 | +884 | ! |
- ggtheme <- input$ggtheme+ expr = ggplot(ANL, aes_string(sample = dist_var)), |
| 636 | +885 | ! |
- rug_plot <- input$rug_plot+ env = list(dist_var = dist_var)+ |
+
| 886 | ++ |
+ ) |
|
| 637 | +887 | ! |
- color <- input$color+ } else if (length(s_var) != 0 && length(g_var) == 0) {
|
| 638 | +888 | ! |
- shape <- `if`(is.null(input$shape) || identical(input$shape, ""), "circle", input$shape)+ substitute( |
| 639 | +889 | ! |
- smoothing_degree <- as.integer(input$smoothing_degree)+ expr = ggplot(ANL, aes_string(sample = dist_var, color = s_var)), |
| 640 | +890 | ! |
- ci <- input$ci+ env = list(dist_var = dist_var, s_var = s_var) |
| 641 | +891 |
-
+ ) |
|
| 642 | +892 | ! |
- log_x <- input$log_x+ } else if (length(s_var) == 0 && length(g_var) != 0) {
|
| 643 | +893 | ! |
- log_y <- input$log_y+ substitute( |
| 644 | -+ | ||
| 894 | +! |
-
+ expr = ggplot(ANL[ANL[[g_var]] != "NA", ], aes_string(sample = dist_var)) + |
|
| 645 | +895 | ! |
- validate(need(+ facet_wrap(~g_var_name, ncol = 1, scales = scales_raw), |
| 646 | +896 | ! |
- length(row_facet_name) == 0 || inherits(ANL[[row_facet_name]], c("character", "factor", "Date", "integer")),
+ env = list( |
| 647 | +897 | ! |
- "`Row facetting` variable must be of class `character`, `factor`, `Date`, or `integer`"+ dist_var = dist_var, |
| 648 | -+ | ||
| 898 | +! |
- ))+ g_var = g_var, |
|
| 649 | +899 | ! |
- validate(need(+ g_var_name = g_var_name, |
| 650 | +900 | ! |
- length(col_facet_name) == 0 || inherits(ANL[[col_facet_name]], c("character", "factor", "Date", "integer")),
+ scales_raw = tolower(scales_type) |
| 651 | -! | +||
| 901 | +
- "`Column facetting` variable must be of class `character`, `factor`, `Date`, or `integer`"+ ) |
||
| 652 | +902 |
- ))+ ) |
|
| 653 | +903 |
-
+ } else {
|
|
| 654 | +904 | ! |
- if (add_density && length(color_by_var) > 0) {
+ substitute( |
| 655 | +905 | ! |
- validate(need(+ expr = ggplot(ANL[ANL[[g_var]] != "NA", ], aes_string(sample = dist_var, color = s_var)) + |
| 656 | +906 | ! |
- !is.numeric(ANL[[color_by_var]]),+ facet_wrap(~g_var_name, ncol = 1, scales = scales_raw), |
| 657 | +907 | ! |
- "Marginal plots cannot be produced when the points are colored by numeric variables.+ env = list( |
| 658 | +908 | ! |
- \n Uncheck the 'Add marginal density' checkbox to display the plot."+ dist_var = dist_var, |
| 659 | -+ | ||
| 909 | +! |
- ))+ g_var = g_var, |
|
| 660 | +910 | ! |
- validate(need(+ s_var = s_var, |
| 661 | +911 | ! |
- !(inherits(ANL[[color_by_var]], "Date") ||- |
-
| 662 | -! | -
- inherits(ANL[[color_by_var]], "POSIXct") ||- |
- |
| 663 | -! | -
- inherits(ANL[[color_by_var]], "POSIXlt")),+ g_var_name = g_var_name, |
|
| 664 | +912 | ! |
- "Marginal plots cannot be produced when the points are colored by Date or POSIX variables.+ scales_raw = tolower(scales_type) |
| 665 | -! | +||
| 913 | +
- \n Uncheck the 'Add marginal density' checkbox to display the plot."+ ) |
||
| 666 | +914 |
- ))+ ) |
|
| 667 | +915 |
- }+ } |
|
| 668 | +916 | ||
| 669 | +917 | ! |
- teal::validate_has_data(ANL[, c(x_var, y_var)], 10, complete = TRUE, allow_inf = FALSE)+ map_dist <- stats::setNames( |
| 670 | -+ | ||
| 918 | +! |
-
+ c("qnorm", "qlnorm", "qgamma", "qunif"),
|
|
| 671 | +919 | ! |
- if (log_x) {
+ c("normal", "lognormal", "gamma", "unif")
|
| 672 | -! | +||
| 920 | +
- validate(+ ) |
||
| 673 | -! | +||
| 921 | +
- need(+ |
||
| 674 | +922 | ! |
- is.numeric(ANL[[x_var]]) && all(+ plot_call <- substitute( |
| 675 | +923 | ! |
- ANL[[x_var]] > 0 | is.na(ANL[[x_var]])+ expr = plot_call + |
| 676 | -+ | ||
| 924 | +! |
- ),+ stat_qq(distribution = mapped_dist, dparams = params), |
|
| 677 | +925 | ! |
- "X variable can only be log transformed if variable is numeric and all values are positive."+ env = list(plot_call = plot_call, mapped_dist = as.name(unname(map_dist[t_dist]))) |
| 678 | +926 |
- )+ ) |
|
| 679 | +927 |
- )+ |
|
| 680 | -+ | ||
| 928 | +! |
- }+ if (length(t_dist) != 0 && length(g_var) == 0 && length(s_var) == 0) {
|
|
| 681 | +929 | ! |
- if (log_y) {
+ qenv <- teal.code::eval_code( |
| 682 | +930 | ! |
- validate(+ qenv, |
| 683 | +931 | ! |
- need(+ substitute( |
| 684 | +932 | ! |
- is.numeric(ANL[[y_var]]) && all(+ df_params <- as.data.frame(append(params, list(name = t_dist))), |
| 685 | +933 | ! |
- ANL[[y_var]] > 0 | is.na(ANL[[y_var]])+ env = list(t_dist = t_dist) |
| 686 | +934 |
- ),- |
- |
| 687 | -! | -
- "Y variable can only be log transformed if variable is numeric and all values are positive."+ ) |
|
| 688 | +935 |
) |
|
| 689 | -+ | ||
| 936 | +! |
- )+ datas <- quote(data.frame(x = 0.7, y = 1, tb = I(list(df_params = df_params)))) |
|
| 690 | -+ | ||
| 937 | +! |
- }+ label <- quote(tb) |
|
| 691 | +938 | ||
| 692 | +939 | ! |
- facet_cl <- facet_ggplot_call(+ plot_call <- substitute( |
| 693 | +940 | ! |
- row_facet_name,+ expr = plot_call + |
| 694 | +941 | ! |
- col_facet_name,+ ggpp::geom_table_npc( |
| 695 | +942 | ! |
- free_x_scales = isTRUE(input$free_scales),+ data = data, |
| 696 | +943 | ! |
- free_y_scales = isTRUE(input$free_scales)+ aes(npcx = x, npcy = y, label = label), |
| 697 | -+ | ||
| 944 | +! |
- )+ hjust = 0, |
|
| 698 | -+ | ||
| 945 | +! |
-
+ vjust = 1, |
|
| 699 | +946 | ! |
- point_sizes <- if (length(size_by_var) > 0) {
+ size = 4+ |
+
| 947 | ++ |
+ ), |
|
| 700 | +948 | ! |
- validate(need(is.numeric(ANL[[size_by_var]]), "Variable to size by must be numeric"))+ env = list( |
| 701 | +949 | ! |
- substitute(+ plot_call = plot_call, |
| 702 | +950 | ! |
- expr = size * ANL[[size_by_var]] / max(ANL[[size_by_var]], na.rm = TRUE),+ data = datas, |
| 703 | +951 | ! |
- env = list(size = size, size_by_var = size_by_var)+ label = label |
| 704 | +952 |
- )+ ) |
|
| 705 | +953 |
- } else {
- |
- |
| 706 | -! | -
- size+ ) |
|
| 707 | +954 |
- }+ } |
|
| 708 | +955 | ||
| 709 | +956 | ! |
- plot_q <- merged$anl_q_r()- |
-
| 710 | -- |
-
+ if (isTRUE(input$qq_line)) {
|
|
| 711 | +957 | ! |
- if (log_x) {
+ plot_call <- substitute( |
| 712 | +958 | ! |
- log_x_fn <- input$log_x_base+ expr = plot_call + |
| 713 | +959 | ! |
- plot_q <- teal.code::eval_code(+ stat_qq_line(distribution = mapped_dist, dparams = params), |
| 714 | +960 | ! |
- object = plot_q,+ env = list(plot_call = plot_call, mapped_dist = as.name(unname(map_dist[t_dist]))) |
| 715 | -! | +||
| 961 | +
- code = substitute(+ ) |
||
| 716 | -! | +||
| 962 | +
- expr = ANL[, log_x_var] <- log_x_fn(ANL[, x_var]), # nolint: object_name.+ } |
||
| 717 | -! | +||
| 963 | +
- env = list(+ |
||
| 718 | +964 | ! |
- x_var = x_var,+ all_ggplot2_args <- teal.widgets::resolve_ggplot2_args( |
| 719 | +965 | ! |
- log_x_fn = as.name(log_x_fn),+ user_plot = ggplot2_args[["QQplot"]], |
| 720 | +966 | ! |
- log_x_var = paste0(log_x_fn, "_", x_var)- |
-
| 721 | -- |
- )+ user_default = ggplot2_args$default, |
|
| 722 | -+ | ||
| 967 | +! |
- )+ module_plot = teal.widgets::ggplot2_args(labs = list(x = "theoretical", y = "sample")) |
|
| 723 | +968 |
) |
|
| 724 | -- |
- }- |
- |
| 725 | +969 | ||
| 726 | +970 | ! |
- if (log_y) {
+ parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args( |
| 727 | +971 | ! |
- log_y_fn <- input$log_y_base+ all_ggplot2_args, |
| 728 | +972 | ! |
- plot_q <- teal.code::eval_code(+ ggtheme = ggtheme |
| 729 | -! | +||
| 973 | +
- object = plot_q,+ )+ |
+ ||
| 974 | ++ | + | |
| 730 | +975 | ! |
- code = substitute(+ teal.code::eval_code( |
| 731 | +976 | ! |
- expr = ANL[, log_y_var] <- log_y_fn(ANL[, y_var]), # nolint: object_name.+ qenv, |
| 732 | +977 | ! |
- env = list(+ substitute( |
| 733 | +978 | ! |
- y_var = y_var,+ expr = {
|
| 734 | +979 | ! |
- log_y_fn = as.name(log_y_fn),+ g <- plot_call |
| 735 | +980 | ! |
- log_y_var = paste0(log_y_fn, "_", y_var)+ print(g) |
| 736 | +981 |
- )+ },+ |
+ |
| 982 | +! | +
+ env = list(plot_call = Reduce(function(x, y) call("+", x, y), c(plot_call, parsed_ggplot2_args)))
|
|
| 737 | +983 |
) |
|
| 738 | +984 |
) |
|
| 739 | +985 |
} |
|
| 740 | +986 | ++ |
+ )+ |
+
| 987 | |||
| 741 | -! | +||
| 988 | +
- pre_pro_anl <- if (input$show_count) {
+ # test qenv ---- |
||
| 742 | +989 | ! |
- paste0(+ test_q <- eventReactive( |
| 743 | +990 | ! |
- "ANL %>% dplyr::group_by(",
+ ignoreNULL = FALSE, |
| 744 | +991 | ! |
- paste(+ eventExpr = {
|
| 745 | +992 | ! |
- c(+ common_q() |
| 746 | +993 | ! |
- if (length(color_by_var) > 0 && inherits(ANL[[color_by_var]], c("factor", "character"))) color_by_var,
+ input$dist_param1 |
| 747 | +994 | ! |
- row_facet_name,+ input$dist_param2 |
| 748 | +995 | ! |
- col_facet_name+ input$dist_tests |
| 749 | +996 |
- ),+ }, |
|
| 750 | +997 | ! |
- collapse = ", "+ valueExpr = {
|
| 751 | +998 |
- ),+ # Create a private stack for this function only. |
|
| 752 | +999 | ! |
- ") %>% dplyr::mutate(n = dplyr::n()) %>% dplyr::ungroup()"+ ANL <- common_q()[["ANL"]] # nolint: object_name. |
| 753 | +1000 |
- )+ |
|
| 754 | -+ | ||
| 1001 | +! |
- } else {
+ dist_var <- merge_vars()$dist_var |
|
| 755 | +1002 | ! |
- "ANL"+ s_var <- merge_vars()$s_var |
| 756 | -+ | ||
| 1003 | +! |
- }+ g_var <- merge_vars()$g_var |
|
| 757 | +1004 | ||
| 758 | +1005 | ! |
- plot_call <- substitute(expr = pre_pro_anl %>% ggplot(), env = list(pre_pro_anl = str2lang(pre_pro_anl)))- |
-
| 759 | -- |
-
+ dist_var_name <- merge_vars()$dist_var_name |
|
| 760 | +1006 | ! |
- plot_call <- if (length(color_by_var) == 0) {
+ s_var_name <- merge_vars()$s_var_name |
| 761 | +1007 | ! |
- substitute(+ g_var_name <- merge_vars()$g_var_name |
| 762 | -! | +||
| 1008 | +
- expr = plot_call ++ |
||
| 763 | +1009 | ! |
- ggplot2::aes(x = x_name, y = y_name) ++ dist_param1 <- input$dist_param1 |
| 764 | +1010 | ! |
- ggplot2::geom_point(alpha = alpha_value, size = point_sizes, shape = shape_value, color = color_value),+ dist_param2 <- input$dist_param2 |
| 765 | +1011 | ! |
- env = list(+ dist_tests <- input$dist_tests |
| 766 | +1012 | ! |
- plot_call = plot_call,+ t_dist <- input$t_dist+ |
+
| 1013 | ++ | + | |
| 767 | +1014 | ! |
- x_name = if (log_x) as.name(paste0(log_x_fn, "_", x_var)) else as.name(x_var),+ validate(need(dist_tests, "Please select a test"))+ |
+
| 1015 | ++ | + | |
| 768 | +1016 | ! |
- y_name = if (log_y) as.name(paste0(log_y_fn, "_", y_var)) else as.name(y_var),+ teal::validate_inputs(iv_dist)+ |
+
| 1017 | ++ | + | |
| 769 | +1018 | ! |
- alpha_value = alpha,+ if (length(s_var) > 0 || length(g_var) > 0) {
|
| 770 | +1019 | ! |
- point_sizes = point_sizes,+ counts <- ANL %>% |
| 771 | +1020 | ! |
- shape_value = shape,+ dplyr::group_by_at(dplyr::vars(dplyr::any_of(c(s_var, g_var)))) %>% |
| 772 | +1021 | ! |
- color_value = color+ dplyr::summarise(n = dplyr::n()) |
| 773 | +1022 |
- )+ + |
+ |
| 1023 | +! | +
+ validate(need(all(counts$n > 5), "Please select strata*group with at least 5 observation each.")) |
|
| 774 | +1024 |
- )+ } |
|
| 775 | +1025 |
- } else {
+
+ |
+ |
| 1026 | ++ | + | |
| 776 | +1027 | ! |
- substitute(+ if (dist_tests %in% c( |
| 777 | +1028 | ! |
- expr = plot_call ++ "t-test (two-samples, not paired)", |
| 778 | +1029 | ! |
- ggplot2::aes(x = x_name, y = y_name, color = color_by_var_name) ++ "F-test", |
| 779 | +1030 | ! |
- ggplot2::geom_point(alpha = alpha_value, size = point_sizes, shape = shape_value),+ "Kolmogorov-Smirnov (two-samples)"+ |
+
| 1031 | ++ |
+ )) {
|
|
| 780 | +1032 | ! |
- env = list(+ if (length(g_var) == 0 && length(s_var) > 0) {
|
| 781 | +1033 | ! |
- plot_call = plot_call,+ validate(need( |
| 782 | +1034 | ! |
- x_name = if (log_x) as.name(paste0(log_x_fn, "_", x_var)) else as.name(x_var),+ length(unique(ANL[[s_var]])) == 2, |
| 783 | +1035 | ! |
- y_name = if (log_y) as.name(paste0(log_y_fn, "_", y_var)) else as.name(y_var),+ "Please select stratify variable with 2 levels."+ |
+
| 1036 | ++ |
+ ))+ |
+ |
| 1037 | ++ |
+ } |
|
| 784 | +1038 | ! |
- color_by_var_name = as.name(color_by_var),+ if (length(g_var) > 0 && length(s_var) > 0) {
|
| 785 | +1039 | ! |
- alpha_value = alpha,+ validate(need( |
| 786 | +1040 | ! |
- point_sizes = point_sizes,+ all(stats::na.omit(as.vector( |
| 787 | +1041 | ! |
- shape_value = shape+ tapply(ANL[[s_var]], list(ANL[[g_var]]), function(x) length(unique(x))) == 2 |
| 788 | +1042 |
- )+ ))), |
|
| 789 | -+ | ||
| 1043 | +! |
- )+ "Please select stratify variable with 2 levels, per each group." |
|
| 790 | +1044 |
- }+ )) |
|
| 791 | +1045 |
-
+ } |
|
| 792 | -! | +||
| 1046 | +
- if (rug_plot) plot_call <- substitute(expr = plot_call + geom_rug(), env = list(plot_call = plot_call))+ } |
||
| 793 | +1047 | ||
| 794 | +1048 | ! |
- plot_label_generator <- function(rhs_formula = quote(y ~ 1),+ map_dist <- stats::setNames( |
| 795 | +1049 | ! |
- show_form = input$show_form,+ c("pnorm", "plnorm", "pgamma", "punif"),
|
| 796 | +1050 | ! |
- show_r2 = input$show_r2,+ c("normal", "lognormal", "gamma", "unif")
|
| 797 | -! | +||
| 1051 | +
- show_count = input$show_count,+ ) |
||
| 798 | +1052 | ! |
- pos = input$pos,+ sks_args <- list( |
| 799 | +1053 | ! |
- label_size = input$label_size) {
+ test = quote(stats::ks.test), |
| 800 | +1054 | ! |
- stopifnot(sum(show_form, show_r2, show_count) >= 1)+ args = bquote(append(list(.[[.(dist_var)]], .(map_dist[t_dist])), params)), |
| 801 | +1055 | ! |
- aes_label <- paste0(+ groups = c(g_var, s_var) |
| 802 | -! | +||
| 1056 | +
- "aes(",
+ ) |
||
| 803 | +1057 | ! |
- if (show_count) "n = n, ",+ ssw_args <- list( |
| 804 | +1058 | ! |
- "label = ",+ test = quote(stats::shapiro.test), |
| 805 | +1059 | ! |
- if (sum(show_form, show_r2, show_count) > 1) "paste(",
+ args = bquote(list(.[[.(dist_var)]])), |
| 806 | +1060 | ! |
- paste(+ groups = c(g_var, s_var) |
| 807 | -! | +||
| 1061 | +
- c(+ ) |
||
| 808 | +1062 | ! |
- if (show_form) "stat(eq.label)",+ mfil_args <- list( |
| 809 | +1063 | ! |
- if (show_r2) "stat(adj.rr.label)",+ test = quote(stats::fligner.test), |
| 810 | +1064 | ! |
- if (show_count) "paste('N ~`=`~', n)"
- |
-
| 811 | -- |
- ),+ args = bquote(list(.[[.(dist_var)]], .[[.(s_var)]])), |
|
| 812 | +1065 | ! |
- collapse = ", "+ groups = c(g_var) |
| 813 | +1066 |
- ),+ ) |
|
| 814 | +1067 | ! |
- if (sum(show_form, show_r2, show_count) > 1) ", sep = '*\", \"*'))" else ")"+ sad_args <- list( |
| 815 | -+ | ||
| 1068 | +! |
- )+ test = quote(goftest::ad.test), |
|
| 816 | +1069 | ! |
- label_geom <- substitute(+ args = bquote(append(list(.[[.(dist_var)]], .(map_dist[t_dist])), params)), |
| 817 | +1070 | ! |
- expr = ggpmisc::stat_poly_eq(+ groups = c(g_var, s_var) |
| 818 | -! | +||
| 1071 | +
- mapping = aes_label,+ ) |
||
| 819 | +1072 | ! |
- formula = rhs_formula,+ scvm_args <- list( |
| 820 | +1073 | ! |
- parse = TRUE,+ test = quote(goftest::cvm.test), |
| 821 | +1074 | ! |
- label.x = pos,+ args = bquote(append(list(.[[.(dist_var)]], .(map_dist[t_dist])), params)), |
| 822 | +1075 | ! |
- size = label_size+ groups = c(g_var, s_var) |
| 823 | +1076 |
- ),- |
- |
| 824 | -! | -
- env = list(+ ) |
|
| 825 | +1077 | ! |
- rhs_formula = rhs_formula,+ manov_args <- list( |
| 826 | +1078 | ! |
- pos = pos,+ test = quote(stats::aov), |
| 827 | +1079 | ! |
- aes_label = str2lang(aes_label),+ args = bquote(list(stats::formula(.(dist_var_name) ~ .(s_var_name)), .)), |
| 828 | +1080 | ! |
- label_size = label_size- |
-
| 829 | -- |
- )+ groups = c(g_var) |
|
| 830 | +1081 |
) |
|
| 831 | +1082 | ! |
- substitute(+ mt_args <- list( |
| 832 | +1083 | ! |
- expr = plot_call + label_geom,+ test = quote(stats::t.test), |
| 833 | +1084 | ! |
- env = list(+ args = bquote(unname(split(.[[.(dist_var)]], .[[.(s_var)]], drop = TRUE))), |
| 834 | +1085 | ! |
- plot_call = plot_call,+ groups = c(g_var)+ |
+
| 1086 | ++ |
+ ) |
|
| 835 | +1087 | ! |
- label_geom = label_geom+ mv_args <- list( |
| 836 | -+ | ||
| 1088 | +! |
- )+ test = quote(stats::var.test), |
|
| 837 | -+ | ||
| 1089 | +! |
- )+ args = bquote(unname(split(.[[.(dist_var)]], .[[.(s_var)]], drop = TRUE))), |
|
| 838 | -+ | ||
| 1090 | +! |
- }+ groups = c(g_var) |
|
| 839 | +1091 |
-
+ ) |
|
| 840 | +1092 | ! |
- if (trend_line_is_applicable()) {
+ mks_args <- list( |
| 841 | +1093 | ! |
- shinyjs::hide("line_msg")
+ test = quote(stats::ks.test), |
| 842 | +1094 | ! |
- shinyjs::show("smoothing_degree")
+ args = bquote(unname(split(.[[.(dist_var)]], .[[.(s_var)]], drop = TRUE))), |
| 843 | +1095 | ! |
- if (!add_trend_line()) {
+ groups = c(g_var) |
| 844 | -! | +||
| 1096 | +
- shinyjs::hide("ci")
+ )+ |
+ ||
| 1097 | ++ | + | |
| 845 | +1098 | ! |
- shinyjs::hide("color_sub")
+ tests_base <- switch(dist_tests, |
| 846 | +1099 | ! |
- shinyjs::hide("show_form")
+ "Kolmogorov-Smirnov (one-sample)" = sks_args, |
| 847 | +1100 | ! |
- shinyjs::hide("show_r2")
+ "Shapiro-Wilk" = ssw_args, |
| 848 | +1101 | ! |
- if (input$show_count) {
+ "Fligner-Killeen" = mfil_args, |
| 849 | +1102 | ! |
- plot_call <- plot_label_generator(show_form = FALSE, show_r2 = FALSE)+ "one-way ANOVA" = manov_args, |
| 850 | +1103 | ! |
- shinyjs::show("label_pos")
+ "t-test (two-samples, not paired)" = mt_args, |
| 851 | +1104 | ! |
- shinyjs::show("label_size")
+ "F-test" = mv_args, |
| 852 | -+ | ||
| 1105 | +! |
- } else {
+ "Kolmogorov-Smirnov (two-samples)" = mks_args, |
|
| 853 | +1106 | ! |
- shinyjs::hide("label_pos")
+ "Anderson-Darling (one-sample)" = sad_args, |
| 854 | +1107 | ! |
- shinyjs::hide("label_size")
+ "Cramer-von Mises (one-sample)" = scvm_args |
| 855 | +1108 |
- }+ ) |
|
| 856 | +1109 |
- } else {
+
|
|
| 857 | +1110 | ! |
- shinyjs::show("ci")
+ env <- list( |
| 858 | +1111 | ! |
- shinyjs::show("show_form")
+ t_test = t_dist, |
| 859 | +1112 | ! |
- shinyjs::show("show_r2")
+ dist_var = dist_var, |
| 860 | +1113 | ! |
- if (nrow(ANL) - nrow(stats::na.omit(ANL[, c(x_var, y_var)])) > 0) {
+ g_var = g_var, |
| 861 | +1114 | ! |
- plot_q <- teal.code::eval_code(+ s_var = s_var, |
| 862 | +1115 | ! |
- plot_q,+ args = tests_base$args, |
| 863 | +1116 | ! |
- substitute(+ groups = tests_base$groups, |
| 864 | +1117 | ! |
- expr = ANL <- dplyr::filter(ANL, !is.na(x_var) & !is.na(y_var)), # nolint: object_name.+ test = tests_base$test, |
| 865 | +1118 | ! |
- env = list(x_var = as.name(x_var), y_var = as.name(y_var))+ dist_var_name = dist_var_name, |
| 866 | -+ | ||
| 1119 | +! |
- )+ g_var_name = g_var_name,+ |
+ |
| 1120 | +! | +
+ s_var_name = s_var_name |
|
| 867 | +1121 |
- )+ ) |
|
| 868 | +1122 |
- }+ |
|
| 869 | +1123 | ! |
- rhs_formula <- substitute(+ qenv <- common_q() |
| 870 | -! | +||
| 1124 | +
- expr = y ~ poly(x, smoothing_degree, raw = TRUE),+ |
||
| 871 | +1125 | ! |
- env = list(smoothing_degree = smoothing_degree)+ if (length(s_var) == 0 && length(g_var) == 0) {
|
| 872 | -+ | ||
| 1126 | +! |
- )+ qenv <- teal.code::eval_code( |
|
| 873 | +1127 | ! |
- if (input$show_form || input$show_r2 || input$show_count) {
+ qenv, |
| 874 | +1128 | ! |
- plot_call <- plot_label_generator(rhs_formula = rhs_formula)+ substitute( |
| 875 | +1129 | ! |
- shinyjs::show("label_pos")
+ expr = {
|
| 876 | +1130 | ! |
- shinyjs::show("label_size")
+ test_stats <- ANL %>% |
| 877 | -+ | ||
| 1131 | +! |
- } else {
+ dplyr::select(dist_var) %>% |
|
| 878 | +1132 | ! |
- shinyjs::hide("label_pos")
+ with(., broom::glance(do.call(test, args))) %>% |
| 879 | +1133 | ! |
- shinyjs::hide("label_size")
+ dplyr::mutate_if(is.numeric, round, 3) |
| 880 | +1134 |
- }- |
- |
| 881 | -! | -
- plot_call <- substitute(+ }, |
|
| 882 | +1135 | ! |
- expr = plot_call + ggplot2::geom_smooth(formula = rhs_formula, se = TRUE, level = ci, method = "lm"),+ env = env |
| 883 | -! | +||
| 1136 | +
- env = list(plot_call = plot_call, rhs_formula = rhs_formula, ci = ci)+ ) |
||
| 884 | +1137 |
) |
|
| 885 | +1138 |
- }+ } else {
|
|
| 886 | -+ | ||
| 1139 | +! |
- } else {
+ qenv <- teal.code::eval_code( |
|
| 887 | +1140 | ! |
- shinyjs::hide("smoothing_degree")
+ qenv, |
| 888 | +1141 | ! |
- shinyjs::hide("ci")
+ substitute( |
| 889 | +1142 | ! |
- shinyjs::hide("color_sub")
+ expr = {
|
| 890 | +1143 | ! |
- shinyjs::hide("show_form")
+ test_stats <- ANL %>% |
| 891 | +1144 | ! |
- shinyjs::hide("show_r2")
+ dplyr::select(dist_var, s_var, g_var) %>% |
| 892 | +1145 | ! |
- if (input$show_count) {
+ dplyr::group_by_at(dplyr::vars(dplyr::any_of(groups))) %>% |
| 893 | +1146 | ! |
- plot_call <- plot_label_generator(show_form = FALSE, show_r2 = FALSE)+ dplyr::do(tests = broom::glance(do.call(test, args))) %>% |
| 894 | +1147 | ! |
- shinyjs::show("label_pos")
+ tidyr::unnest(tests) %>% |
| 895 | +1148 | ! |
- shinyjs::show("label_size")
+ dplyr::mutate_if(is.numeric, round, 3) |
| 896 | +1149 |
- } else {
+ }, |
|
| 897 | +1150 | ! |
- shinyjs::hide("label_pos")
+ env = env |
| 898 | -! | +||
| 1151 | +
- shinyjs::hide("label_size")
+ ) |
||
| 899 | +1152 |
- }+ ) |
|
| 900 | -! | +||
| 1153 | +
- shinyjs::show("line_msg")
+ } |
||
| 901 | -+ | ||
| 1154 | +! |
- }+ qenv %>% |
|
| 902 | +1155 |
-
+ # used to display table when running show-r-code code |
|
| 903 | +1156 | ! |
- if (!is.null(facet_cl)) {
+ teal.code::eval_code(quote(test_stats)) |
| 904 | -! | +||
| 1157 | +
- plot_call <- substitute(expr = plot_call + facet_cl, env = list(plot_call = plot_call, facet_cl = facet_cl))+ } |
||
| 905 | +1158 |
- }+ ) |
|
| 906 | +1159 | ||
| 907 | -! | +||
| 1160 | +
- y_label <- varname_w_label(+ # outputs ---- |
||
| 908 | -! | +||
| 1161 | +
- y_var,+ ## building main qenv |
||
| 909 | +1162 | ! |
- ANL,+ output_q <- reactive({
|
| 910 | +1163 | ! |
- prefix = if (log_y) paste(log_y_fn, "(") else NULL,
+ tab <- input$tabs |
| 911 | +1164 | ! |
- suffix = if (log_y) ")" else NULL+ req(tab) # tab is NULL upon app launch, hence will crash without this statement |
| 912 | +1165 |
- )+ |
|
| 913 | +1166 | ! |
- x_label <- varname_w_label(+ qenv_final <- common_q() |
| 914 | -! | +||
| 1167 | +
- x_var,+ # wrapped in if since could lead into validate error - we do want to continue |
||
| 915 | +1168 | ! |
- ANL,+ test_r_qenv_out <- try(test_q(), silent = TRUE) |
| 916 | +1169 | ! |
- prefix = if (log_x) paste(log_x_fn, "(") else NULL,
+ if (!inherits(test_r_qenv_out, c("try-error", "error"))) {
|
| 917 | +1170 | ! |
- suffix = if (log_x) ")" else NULL+ qenv_final <- teal.code::join(qenv_final, test_q()) |
| 918 | +1171 |
- )+ } |
|
| 919 | +1172 | ||
| 920 | +1173 | ! |
- dev_ggplot2_args <- teal.widgets::ggplot2_args(+ qenv_final <- if (tab == "Histogram") {
|
| 921 | +1174 | ! |
- labs = list(y = y_label, x = x_label),+ req(dist_q()) |
| 922 | +1175 | ! |
- theme = list(legend.position = "bottom")- |
-
| 923 | -- |
- )+ teal.code::join(qenv_final, dist_q()) |
|
| 924 | -+ | ||
| 1176 | +! |
-
+ } else if (tab == "QQplot") {
|
|
| 925 | +1177 | ! |
- if (rotate_xaxis_labels) {
+ req(qq_q()) |
| 926 | +1178 | ! |
- dev_ggplot2_args$theme[["axis.text.x"]] <- quote(element_text(angle = 45, hjust = 1))+ teal.code::join(qenv_final, qq_q()) |
| 927 | +1179 |
} |
|
| 928 | -- | - - | -|
| 929 | -! | -
- all_ggplot2_args <- teal.widgets::resolve_ggplot2_args(- |
- |
| 930 | -! | -
- user_plot = ggplot2_args,- |
- |
| 931 | +1180 | ! |
- module_plot = dev_ggplot2_args+ qenv_final |
| 932 | +1181 |
- )+ }) |
|
| 933 | +1182 | ||
| 934 | +1183 | ! |
- parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(all_ggplot2_args, ggtheme = ggtheme)+ dist_r <- reactive(dist_q()[["g"]]) |
| 935 | +1184 | ||
| 936 | -+ | ||
| 1185 | +! |
-
+ qq_r <- reactive(qq_q()[["g"]]) |
|
| 937 | -! | +||
| 1186 | +
- if (add_density) {
+
|
||
| 938 | +1187 | ! |
- plot_call <- substitute(+ output$summary_table <- DT::renderDataTable( |
| 939 | +1188 | ! |
- expr = ggExtra::ggMarginal(+ expr = if (iv_r()$is_valid()) common_q()[["summary_table"]] else NULL, |
| 940 | +1189 | ! |
- plot_call + labs + ggthemes + themes,+ options = list( |
| 941 | +1190 | ! |
- type = "density",+ autoWidth = TRUE, |
| 942 | +1191 | ! |
- groupColour = group_colour+ columnDefs = list(list(width = "200px", targets = "_all")) |
| 943 | +1192 |
- ),+ ), |
|
| 944 | +1193 | ! |
- env = list(+ rownames = FALSE |
| 945 | -! | +||
| 1194 | +
- plot_call = plot_call,+ ) |
||
| 946 | -! | +||
| 1195 | +
- group_colour = if (length(color_by_var) > 0) TRUE else FALSE,+ |
||
| 947 | +1196 | ! |
- labs = parsed_ggplot2_args$labs,+ tests_r <- reactive({
|
| 948 | +1197 | ! |
- ggthemes = parsed_ggplot2_args$ggtheme,+ req(iv_r()$is_valid()) |
| 949 | +1198 | ! |
- themes = parsed_ggplot2_args$theme+ teal::validate_inputs(iv_r_dist()) |
| 950 | -+ | ||
| 1199 | +! |
- )+ test_q()[["test_stats"]] |
|
| 951 | +1200 |
- )+ }) |
|
| 952 | +1201 |
- } else {
+
|
|
| 953 | +1202 | ! |
- plot_call <- substitute(+ pws1 <- teal.widgets::plot_with_settings_srv( |
| 954 | +1203 | ! |
- expr = plot_call ++ id = "hist_plot", |
| 955 | +1204 | ! |
- labs ++ plot_r = dist_r, |
| 956 | +1205 | ! |
- ggthemes ++ height = plot_height, |
| 957 | +1206 | ! |
- themes,+ width = plot_width, |
| 958 | +1207 | ! |
- env = list(+ brushing = FALSE+ |
+
| 1208 | ++ |
+ )+ |
+ |
| 1209 | ++ | + | |
| 959 | +1210 | ! |
- plot_call = plot_call,+ pws2 <- teal.widgets::plot_with_settings_srv( |
| 960 | +1211 | ! |
- labs = parsed_ggplot2_args$labs,+ id = "qq_plot", |
| 961 | +1212 | ! |
- ggthemes = parsed_ggplot2_args$ggtheme,+ plot_r = qq_r, |
| 962 | +1213 | ! |
- themes = parsed_ggplot2_args$theme- |
-
| 963 | -- |
- )- |
- |
| 964 | -- |
- )- |
- |
| 965 | -- |
- }- |
- |
| 966 | -- | - - | -|
| 967 | -! | -
- plot_call <- substitute(expr = p <- plot_call, env = list(plot_call = plot_call))- |
- |
| 968 | -- |
-
+ height = plot_height, |
|
| 969 | +1214 | ! |
- teal.code::eval_code(plot_q, plot_call) %>%+ width = plot_width, |
| 970 | +1215 | ! |
- teal.code::eval_code(quote(print(p)))- |
-
| 971 | -- |
- })+ brushing = FALSE |
|
| 972 | +1216 | - - | -|
| 973 | -! | -
- plot_r <- reactive(output_q()[["p"]])+ ) |
|
| 974 | +1217 | ||
| 975 | -- |
- # Insert the plot into a plot_with_settings module from teal.widgets- |
- |
| 976 | -! | -
- pws <- teal.widgets::plot_with_settings_srv(- |
- |
| 977 | -! | -
- id = "scatter_plot",- |
- |
| 978 | +1218 | ! |
- plot_r = plot_r,+ output$t_stats <- DT::renderDataTable( |
| 979 | +1219 | ! |
- height = plot_height,+ expr = tests_r(), |
| 980 | +1220 | ! |
- width = plot_width,+ options = list(scrollX = TRUE), |
| 981 | +1221 | ! |
- brushing = TRUE+ rownames = FALSE |
| 982 | +1222 |
) |
|
| 983 | +1223 | ||
| 984 | +1224 | ! |
- output$data_table <- DT::renderDataTable({
+ teal.widgets::verbatim_popup_srv( |
| 985 | +1225 | ! |
- plot_brush <- pws$brush()+ id = "warning", |
| 986 | -+ | ||
| 1226 | +! |
-
+ verbatim_content = reactive(teal.code::get_warnings(output_q())), |
|
| 987 | +1227 | ! |
- if (!is.null(plot_brush)) {
+ title = "Warning", |
| 988 | +1228 | ! |
- validate(need(!input$add_density, "Brushing feature is currently not supported when plot has marginal density"))+ disabled = reactive(is.null(teal.code::get_warnings(output_q()))) |
| 989 | +1229 |
- }+ ) |
|
| 990 | +1230 | ||
| 991 | +1231 | ! |
- merged_data <- isolate(teal.code::dev_suppress(output_q()[["ANL"]]))- |
-
| 992 | -- |
-
+ teal.widgets::verbatim_popup_srv( |
|
| 993 | +1232 | ! |
- brushed_df <- teal.widgets::clean_brushedPoints(merged_data, plot_brush)+ id = "rcode", |
| 994 | +1233 | ! |
- numeric_cols <- names(brushed_df)[+ verbatim_content = reactive(teal.code::get_code(output_q())), |
| 995 | +1234 | ! |
- vapply(brushed_df, function(x) is.numeric(x) && !is.integer(x), FUN.VALUE = logical(1))+ title = "R Code for distribution" |
| 996 | +1235 |
- ]+ ) |
|
| 997 | +1236 | ||
| 998 | -! | +||
| 1237 | +
- if (length(numeric_cols) > 0) {
+ ### REPORTER |
||
| 999 | +1238 | ! |
- DT::formatRound(+ if (with_reporter) {
|
| 1000 | +1239 | ! |
- DT::datatable(brushed_df,+ card_fun <- function(comment, label) {
|
| 1001 | +1240 | ! |
- rownames = FALSE,+ card <- teal::report_card_template( |
| 1002 | +1241 | ! |
- options = list(scrollX = TRUE, pageLength = input$data_table_rows)- |
-
| 1003 | -- |
- ),+ title = "Distribution Plot", |
|
| 1004 | +1242 | ! |
- numeric_cols,+ label = label, |
| 1005 | +1243 | ! |
- table_dec- |
-
| 1006 | -- |
- )- |
- |
| 1007 | -- |
- } else {
+ with_filter = with_filter, |
|
| 1008 | +1244 | ! |
- DT::datatable(brushed_df, rownames = FALSE, options = list(scrollX = TRUE, pageLength = input$data_table_rows))- |
-
| 1009 | -- |
- }- |
- |
| 1010 | -- |
- })+ filter_panel_api = filter_panel_api |
|
| 1011 | +1245 |
-
+ ) |
|
| 1012 | +1246 | ! |
- teal.widgets::verbatim_popup_srv(+ card$append_text("Plot", "header3")
|
| 1013 | +1247 | ! |
- id = "warning",+ if (input$tabs == "Histogram") {
|
| 1014 | +1248 | ! |
- verbatim_content = reactive(teal.code::get_warnings(output_q())),+ card$append_plot(dist_r(), dim = pws1$dim()) |
| 1015 | +1249 | ! |
- title = "Warning",+ } else if (input$tabs == "QQplot") {
|
| 1016 | +1250 | ! |
- disabled = reactive(is.null(teal.code::get_warnings(output_q())))- |
-
| 1017 | -- |
- )+ card$append_plot(qq_r(), dim = pws2$dim()) |
|
| 1018 | +1251 | - - | -|
| 1019 | -! | -
- teal.widgets::verbatim_popup_srv(- |
- |
| 1020 | -! | -
- id = "rcode",- |
- |
| 1021 | -! | -
- verbatim_content = reactive(teal.code::get_code(output_q())),+ } |
|
| 1022 | +1252 | ! |
- title = "R Code for scatterplot"- |
-
| 1023 | -- |
- )+ card$append_text("Statistics table", "header3")
|
|
| 1024 | +1253 | ||
| 1025 | -- |
- ### REPORTER- |
- |
| 1026 | -! | -
- if (with_reporter) {
- |
- |
| 1027 | -! | -
- card_fun <- function(comment, label) {
- |
- |
| 1028 | +1254 | ! |
- card <- teal::report_card_template(+ card$append_table(common_q()[["summary_table"]]) |
| 1029 | +1255 | ! |
- title = "Scatter Plot",+ tests_error <- tryCatch(expr = tests_r(), error = function(e) "error") |
| 1030 | +1256 | ! |
- label = label,+ if (inherits(tests_error, "data.frame")) {
|
| 1031 | +1257 | ! |
- with_filter = with_filter,+ card$append_text("Tests table", "header3")
|
| 1032 | +1258 | ! |
- filter_panel_api = filter_panel_api+ card$append_table(tests_r()) |
| 1033 | +1259 |
- )- |
- |
| 1034 | -! | -
- card$append_text("Plot", "header3")
+ } |
|
| 1035 | -! | +||
| 1260 | +
- card$append_plot(plot_r(), dim = pws$dim())+ |
||
| 1036 | +1261 | ! |
if (!comment == "") {
|
| 1037 | +1262 | ! |
card$append_text("Comment", "header3")
|
| 1038 | +1263 | ! |
card$append_text(comment) |
| 1039 | +1264 |
} |
|
| 1040 | +1265 | ! |
card$append_src(teal.code::get_code(output_q())) |
| 1041 | +1266 | ! |
card |
| 1042 | +1267 |
} |
|
| 1043 | +1268 | ! |
teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
|
| 1044 | +1269 |
} |
|
| 1045 | +1270 |
### |
|
| 1046 | +1271 |
}) |
|
| 1047 | +1272 |
}@@ -34370,42 +34307,42 @@ teal.modules.general coverage - 2.26% |
| 1 |
- #' Distribution Module+ #' Create a scatterplot matrix |
||
| 2 |
- #' @md+ #' |
||
| 3 |
- #'+ #' The available datasets to choose from for each dataset selector is the same and |
||
| 4 |
- #' @details+ #' determined by the argument `variables`. |
||
| 5 |
- #' Module to analyze and explore univariate variable distribution+ #' @md |
||
| 8 |
- #' @inheritParams teal.widgets::standard_layout+ #' @inheritParams tm_g_scatterplot |
||
| 11 |
- #' @param dist_var (`data_extract_spec` or `list` of multiple `data_extract_spec`)+ #' @param variables (`data_extract_spec` or `list` of multiple `data_extract_spec`) |
||
| 12 |
- #' Variable to consider for the distribution analysis.+ #' Plotting variables from an incoming dataset with filtering and selecting. In case of |
||
| 13 |
- #' @param strata_var (`data_extract_spec` or `list` of multiple `data_extract_spec`)+ #' `data_extract_spec` use `select_spec(..., ordered = TRUE)` if plot elements should be |
||
| 14 |
- #' Categorical variable to split the selected distribution variable on.+ #' rendered according to selection order. |
||
| 15 |
- #' @param group_var optional, (`data_extract_spec` or `list` of multiple `data_extract_spec`)+ #' |
||
| 16 |
- #' Which data columns to use for faceting rows.+ #' @note For more examples, please see the vignette "Using scatterplot matrix" via |
||
| 17 |
- #' @param freq optional, (`logical`) Whether to display frequency (`TRUE`) or density (`FALSE`).+ #' \code{vignette("using-scatterplot-matrix", package = "teal.modules.general")}.
|
||
| 18 |
- #' Defaults to density (`FALSE`).+ #' |
||
| 19 |
- #' @param bins optional, (`integer(1)` or `integer(3)`) If scalar then the histogram bins will have a fixed size.+ #' @examples |
||
| 20 |
- #' If a slider should be presented to adjust the number of histogram bins dynamically then it can be a+ #' # general data example |
||
| 21 |
- #' vector of length three with `c(value, min, max)`.+ #' data <- teal_data() |
||
| 22 |
- #' Defaults to `c(30L, 1L, 100L)`.+ #' data <- within(data, {
|
||
| 23 |
- #'+ #' countries <- data.frame( |
||
| 24 |
- #' @templateVar ggnames "Histogram", "QQplot"+ #' id = c("DE", "FR", "IT", "ES", "PT", "GR", "NL", "BE", "LU", "AT"),
|
||
| 25 |
- #' @template ggplot2_args_multi+ #' government = factor( |
||
| 26 |
- #'+ #' c(2, 2, 2, 1, 2, 2, 1, 1, 1, 2), |
||
| 27 |
- #' @examples+ #' labels = c("Monarchy", "Republic")
|
||
| 28 |
- #' # general data example+ #' ), |
||
| 29 |
- #' library(teal.widgets)+ #' language_family = factor( |
||
| 30 |
- #'+ #' c(1, 3, 3, 3, 3, 2, 1, 1, 3, 1), |
||
| 31 |
- #' data <- teal_data()+ #' labels = c("Germanic", "Hellenic", "Romance")
|
||
| 32 |
- #' data <- within(data, {
+ #' ), |
||
| 33 |
- #' iris <- iris+ #' population = c(83, 67, 60, 47, 10, 11, 17, 11, 0.6, 9), |
||
| 34 |
- #' })+ #' area = c(357, 551, 301, 505, 92, 132, 41, 30, 2.6, 83), |
||
| 35 |
- #' datanames(data) <- "iris"+ #' gdp = c(3.4, 2.7, 2.1, 1.4, 0.3, 0.2, 0.7, 0.5, 0.1, 0.4), |
||
| 36 |
- #'+ #' debt = c(2.1, 2.3, 2.4, 2.6, 2.3, 2.4, 2.3, 2.4, 2.3, 2.4) |
||
| 37 |
- #' app <- init(+ #' ) |
||
| 38 |
- #' data = data,+ #' sales <- data.frame( |
||
| 39 |
- #' modules = list(+ #' id = 1:50, |
||
| 40 |
- #' tm_g_distribution(+ #' country_id = sample( |
||
| 41 |
- #' dist_var = data_extract_spec(+ #' c("DE", "FR", "IT", "ES", "PT", "GR", "NL", "BE", "LU", "AT"),
|
||
| 42 |
- #' dataname = "iris",+ #' size = 50, |
||
| 43 |
- #' select = select_spec(variable_choices("iris"), "Petal.Length")
+ #' replace = TRUE |
||
| 44 |
- #' ),+ #' ), |
||
| 45 |
- #' ggplot2_args = ggplot2_args(+ #' year = sort(sample(2010:2020, 50, replace = TRUE)), |
||
| 46 |
- #' labs = list(subtitle = "Plot generated by Distribution Module")+ #' venue = sample(c("small", "medium", "large", "online"), 50, replace = TRUE),
|
||
| 47 |
- #' )+ #' cancelled = sample(c(TRUE, FALSE), 50, replace = TRUE), |
||
| 48 |
- #' )+ #' quantity = rnorm(50, 100, 20), |
||
| 49 |
- #' )+ #' costs = rnorm(50, 80, 20), |
||
| 50 |
- #' )+ #' profit = rnorm(50, 20, 10) |
||
| 51 |
- #' if (interactive()) {
+ #' ) |
||
| 52 |
- #' shinyApp(app$ui, app$server)+ #' }) |
||
| 53 |
- #' }+ #' datanames(data) <- c("countries", "sales")
|
||
| 54 |
- #'+ #' join_keys(data) <- join_keys( |
||
| 55 |
- #' # CDISC data example+ #' join_key("countries", "countries", "id"),
|
||
| 56 |
- #' library(teal.widgets)+ #' join_key("sales", "sales", "id"),
|
||
| 57 |
- #'+ #' join_key("countries", "sales", c("id" = "country_id"))
|
||
| 58 |
- #' data <- teal_data()+ #' ) |
||
| 59 |
- #' data <- within(data, {
+ #' |
||
| 60 |
- #' ADSL <- rADSL+ #' app <- init( |
||
| 61 |
- #' })+ #' data = data, |
||
| 62 |
- #' datanames(data) <- c("ADSL")
+ #' modules = modules( |
||
| 63 |
- #' join_keys(data) <- default_cdisc_join_keys[datanames(data)]+ #' tm_g_scatterplotmatrix( |
||
| 64 |
- #'+ #' label = "Scatterplot matrix", |
||
| 65 |
- #' vars1 <- choices_selected(+ #' variables = list( |
||
| 66 |
- #' variable_choices(data[["ADSL"]], c("ARM", "COUNTRY", "SEX")),
+ #' data_extract_spec( |
||
| 67 |
- #' selected = NULL+ #' dataname = "countries", |
||
| 68 |
- #' )+ #' select = select_spec( |
||
| 69 |
- #'+ #' label = "Select variables:", |
||
| 70 |
- #' app <- init(+ #' choices = variable_choices(data[["countries"]]), |
||
| 71 |
- #' data = data,+ #' selected = c("area", "gdp", "debt"),
|
||
| 72 |
- #' modules = modules(+ #' multiple = TRUE, |
||
| 73 |
- #' tm_g_distribution(+ #' ordered = TRUE, |
||
| 74 |
- #' dist_var = data_extract_spec(+ #' fixed = FALSE |
||
| 75 |
- #' dataname = "ADSL",+ #' ) |
||
| 76 |
- #' select = select_spec(+ #' ), |
||
| 77 |
- #' choices = variable_choices(data[["ADSL"]], c("AGE", "BMRKR1")),
+ #' data_extract_spec( |
||
| 78 |
- #' selected = "BMRKR1",+ #' dataname = "sales", |
||
| 79 |
- #' multiple = FALSE,+ #' filter = filter_spec( |
||
| 80 |
- #' fixed = FALSE+ #' label = "Select variable:", |
||
| 81 |
- #' )+ #' vars = "country_id", |
||
| 82 |
- #' ),+ #' choices = value_choices(data[["sales"]], "country_id"), |
||
| 83 |
- #' strata_var = data_extract_spec(+ #' selected = c("DE", "FR", "IT", "ES", "PT", "GR", "NL", "BE", "LU", "AT"),
|
||
| 84 |
- #' dataname = "ADSL",+ #' multiple = TRUE |
||
| 85 |
- #' filter = filter_spec(+ #' ), |
||
| 86 |
- #' vars = vars1,+ #' select = select_spec( |
||
| 87 |
- #' multiple = TRUE+ #' label = "Select variables:", |
||
| 88 |
- #' )+ #' choices = variable_choices(data[["sales"]], c("quantity", "costs", "profit")),
|
||
| 89 |
- #' ),+ #' selected = c("quantity", "costs", "profit"),
|
||
| 90 |
- #' group_var = data_extract_spec(+ #' multiple = TRUE, |
||
| 91 |
- #' dataname = "ADSL",+ #' ordered = TRUE, |
||
| 92 |
- #' filter = filter_spec(+ #' fixed = FALSE |
||
| 93 |
- #' vars = vars1,+ #' ) |
||
| 94 |
- #' multiple = TRUE+ #' ) |
||
| 95 |
- #' )+ #' ) |
||
| 96 |
- #' ),+ #' ) |
||
| 97 |
- #' ggplot2_args = ggplot2_args(+ #' ) |
||
| 98 |
- #' labs = list(subtitle = "Plot generated by Distribution Module")+ #' ) |
||
| 99 |
- #' )+ #' if (interactive()) {
|
||
| 100 |
- #' )+ #' shinyApp(app$ui, app$server) |
||
| 101 |
- #' )+ #' } |
||
| 102 |
- #' )+ #' |
||
| 103 |
- #' if (interactive()) {
+ #' # CDISC data example |
||
| 104 |
- #' shinyApp(app$ui, app$server)+ #' data <- teal_data() |
||
| 105 |
- #' }+ #' data <- within(data, {
|
||
| 106 |
- #'+ #' ADSL <- rADSL |
||
| 107 |
- #' @export+ #' ADRS <- rADRS |
||
| 108 |
- #'+ #' }) |
||
| 109 |
- tm_g_distribution <- function(label = "Distribution Module",+ #' datanames(data) <- c("ADSL", "ADRS")
|
||
| 110 |
- dist_var,+ #' join_keys(data) <- default_cdisc_join_keys[datanames(data)] |
||
| 111 |
- strata_var = NULL,+ #' |
||
| 112 |
- group_var = NULL,+ #' app <- init( |
||
| 113 |
- freq = FALSE,+ #' data = data, |
||
| 114 |
- ggtheme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void"),
+ #' modules = modules( |
||
| 115 |
- ggplot2_args = teal.widgets::ggplot2_args(),+ #' tm_g_scatterplotmatrix( |
||
| 116 |
- bins = c(30L, 1L, 100L),+ #' label = "Scatterplot matrix", |
||
| 117 |
- plot_height = c(600, 200, 2000),+ #' variables = list( |
||
| 118 |
- plot_width = NULL,+ #' data_extract_spec( |
||
| 119 |
- pre_output = NULL,+ #' dataname = "ADSL", |
||
| 120 |
- post_output = NULL) {
+ #' select = select_spec( |
||
| 121 | -! | +
- logger::log_info("Initializing tm_g_distribution")
+ #' label = "Select variables:", |
|
| 122 |
-
+ #' choices = variable_choices(data[["ADSL"]]), |
||
| 123 | -! | +
- extra_packages <- c("ggpmisc", "ggpp", "goftest", "MASS", "broom")
+ #' selected = c("AGE", "RACE", "SEX"),
|
|
| 124 | -! | +
- missing_packages <- Filter(function(x) !requireNamespace(x, quietly = TRUE), extra_packages)+ #' multiple = TRUE, |
|
| 125 | -! | +
- if (length(missing_packages) > 0L) {
+ #' ordered = TRUE, |
|
| 126 | -! | +
- stop(sprintf(+ #' fixed = FALSE |
|
| 127 | -! | +
- "Cannot load package(s): %s.\nInstall or restart your session.",+ #' ) |
|
| 128 | -! | +
- toString(missing_packages)+ #' ), |
|
| 129 |
- ))+ #' data_extract_spec( |
||
| 130 |
- }+ #' dataname = "ADRS", |
||
| 131 |
-
+ #' filter = filter_spec( |
||
| 132 | -! | +
- if (inherits(dist_var, "data_extract_spec")) dist_var <- list(dist_var)+ #' label = "Select endpoints:", |
|
| 133 | -! | +
- if (inherits(strata_var, "data_extract_spec")) strata_var <- list(strata_var)+ #' vars = c("PARAMCD", "AVISIT"),
|
|
| 134 | -! | +
- if (inherits(group_var, "data_extract_spec")) group_var <- list(group_var)+ #' choices = value_choices(data[["ADRS"]], c("PARAMCD", "AVISIT"), c("PARAM", "AVISIT")),
|
|
| 135 | -! | +
- if (inherits(ggplot2_args, "ggplot2_args")) ggplot2_args <- list(default = ggplot2_args)+ #' selected = "INVET - END OF INDUCTION", |
|
| 136 |
-
+ #' multiple = TRUE |
||
| 137 | -! | +
- ggtheme <- match.arg(ggtheme)+ #' ), |
|
| 138 | -! | +
- if (length(bins) == 1) {
+ #' select = select_spec( |
|
| 139 | -! | +
- checkmate::assert_numeric(bins, any.missing = FALSE, lower = 1)+ #' label = "Select variables:", |
|
| 140 |
- } else {
+ #' choices = variable_choices(data[["ADRS"]]), |
||
| 141 | -! | +
- checkmate::assert_numeric(bins, len = 3, any.missing = FALSE, lower = 1)+ #' selected = c("AGE", "AVAL", "ADY"),
|
|
| 142 | -! | +
- checkmate::assert_numeric(bins[1], lower = bins[2], upper = bins[3], .var.name = "bins")+ #' multiple = TRUE, |
|
| 143 |
- }+ #' ordered = TRUE, |
||
| 144 | -! | +
- checkmate::assert_string(label)+ #' fixed = FALSE |
|
| 145 | -! | +
- checkmate::assert_list(dist_var, "data_extract_spec")+ #' ) |
|
| 146 | -! | +
- checkmate::assert_false(dist_var[[1]]$select$multiple)+ #' ) |
|
| 147 | -! | +
- checkmate::assert_list(strata_var, types = "data_extract_spec", null.ok = TRUE)+ #' ) |
|
| 148 | -! | +
- checkmate::assert_list(group_var, types = "data_extract_spec", null.ok = TRUE)+ #' ) |
|
| 149 | -! | +
- checkmate::assert_flag(freq)+ #' ) |
|
| 150 | -! | +
- plot_choices <- c("Histogram", "QQplot")
+ #' ) |
|
| 151 | -! | +
- checkmate::assert_list(ggplot2_args, types = "ggplot2_args")+ #' if (interactive()) {
|
|
| 152 | -! | +
- checkmate::assert_subset(names(ggplot2_args), c("default", plot_choices))
+ #' shinyApp(app$ui, app$server) |
|
| 153 |
-
+ #' } |
||
| 154 | -! | +
- args <- as.list(environment())+ #' |
|
| 155 |
-
+ #' @export |
||
| 156 | -! | +
- data_extract_list <- list(+ #' |
|
| 157 | -! | +
- dist_var = dist_var,+ tm_g_scatterplotmatrix <- function(label = "Scatterplot Matrix", |
|
| 158 | -! | +
- strata_var = strata_var,+ variables, |
|
| 159 | -! | +
- group_var = group_var+ plot_height = c(600, 200, 2000), |
|
| 160 |
- )+ plot_width = NULL, |
||
| 161 |
-
+ pre_output = NULL, |
||
| 162 | -! | +
- module(+ post_output = NULL) {
|
|
| 163 | ! |
- label = label,+ logger::log_info("Initializing tm_g_scatterplotmatrix")
|
|
| 164 | ! |
- server = srv_distribution,+ if (!requireNamespace("lattice", quietly = TRUE)) {
|
|
| 165 | ! |
- server_args = c(+ stop("Cannot load lattice - please install the package or restart your session.")
|
|
| 166 | -! | +
- data_extract_list,+ } |
|
| 167 | ! |
- list(plot_height = plot_height, plot_width = plot_width, ggplot2_args = ggplot2_args)+ if (inherits(variables, "data_extract_spec")) variables <- list(variables) |
|
| 168 |
- ),+ |
||
| 169 | ! |
- ui = ui_distribution,+ checkmate::assert_string(label) |
|
| 170 | ! |
- ui_args = args,+ checkmate::assert_list(variables, types = "data_extract_spec") |
|
| 171 | ! |
- datanames = teal.transform::get_extract_datanames(data_extract_list)+ checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE) |
|
| 172 | -+ | ! |
- )+ checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height") |
| 173 | -+ | ! |
- }+ checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE) |
| 174 | -+ | ! |
-
+ checkmate::assert_numeric( |
| 175 | -+ | ! |
- ui_distribution <- function(id, ...) {
+ plot_width[1], |
| 176 | ! |
- args <- list(...)+ lower = plot_width[2], upper = plot_width[3], null.ok = TRUE, .var.name = "plot_width" |
|
| 177 | -! | +
- ns <- NS(id)+ ) |
|
| 178 | -! | +
- is_single_dataset_value <- teal.transform::is_single_dataset(args$dist_var, args$strata_var, args$group_var)+ |
|
| 179 | -+ | ! |
-
+ args <- as.list(environment()) |
| 180 | ! |
- teal.widgets::standard_layout(+ module( |
|
| 181 | ! |
- output = teal.widgets::white_small_well(+ label = label, |
|
| 182 | ! |
- tabsetPanel(+ server = srv_g_scatterplotmatrix, |
|
| 183 | ! |
- id = ns("tabs"),
+ ui = ui_g_scatterplotmatrix, |
|
| 184 | ! |
- tabPanel("Histogram", teal.widgets::plot_with_settings_ui(id = ns("hist_plot"))),
+ ui_args = args, |
|
| 185 | ! |
- tabPanel("QQplot", teal.widgets::plot_with_settings_ui(id = ns("qq_plot")))
+ server_args = list(variables = variables, plot_height = plot_height, plot_width = plot_width), |
|
| 186 | -+ | ! |
- ),+ datanames = teal.transform::get_extract_datanames(variables) |
| 187 | -! | +
- h3("Statistics Table"),
+ ) |
|
| 188 | -! | +
- DT::dataTableOutput(ns("summary_table")),
+ } |
|
| 189 | -! | +
- h3("Tests"),
+
|
|
| 190 | -! | +
- DT::dataTableOutput(ns("t_stats"))
+ ui_g_scatterplotmatrix <- function(id, ...) {
|
|
| 191 | -+ | ! |
- ),+ args <- list(...) |
| 192 | ! |
- encoding = div(+ is_single_dataset_value <- teal.transform::is_single_dataset(args$variables) |
|
| 193 | -+ | ! |
- ### Reporter+ ns <- NS(id) |
| 194 | ! |
- teal.reporter::simple_reporter_ui(ns("simple_reporter")),
+ teal.widgets::standard_layout( |
|
| 195 | -+ | ! |
- ###+ output = teal.widgets::white_small_well( |
| 196 | ! |
- tags$label("Encodings", class = "text-primary"),
+ textOutput(ns("message")),
|
|
| 197 | ! |
- teal.transform::datanames_input(args[c("dist_var", "strata_var")]),
+ br(), |
|
| 198 | ! |
- teal.transform::data_extract_ui(+ teal.widgets::plot_with_settings_ui(id = ns("myplot"))
|
|
| 199 | -! | +
- id = ns("dist_i"),
+ ), |
|
| 200 | ! |
- label = "Variable",+ encoding = div( |
|
| 201 | -! | +
- data_extract_spec = args$dist_var,+ ### Reporter |
|
| 202 | ! |
- is_single_dataset = is_single_dataset_value+ teal.reporter::simple_reporter_ui(ns("simple_reporter")),
|
|
| 203 |
- ),+ ### |
||
| 204 | ! |
- if (!is.null(args$group_var)) {
+ tags$label("Encodings", class = "text-primary"),
|
|
| 205 | ! |
- tagList(+ teal.transform::datanames_input(args$variables), |
|
| 206 | ! |
- teal.transform::data_extract_ui(+ teal.transform::data_extract_ui( |
|
| 207 | ! |
- id = ns("group_i"),
+ id = ns("variables"),
|
|
| 208 | ! |
- label = "Group by",+ label = "Variables", |
|
| 209 | ! |
- data_extract_spec = args$group_var,+ data_extract_spec = args$variables, |
|
| 210 | ! |
- is_single_dataset = is_single_dataset_value+ is_single_dataset = is_single_dataset_value |
|
| 211 |
- ),+ ), |
||
| 212 | ! |
- uiOutput(ns("scales_types_ui"))
+ hr(), |
|
| 213 | -+ | ! |
- )+ teal.widgets::panel_group( |
| 214 | -+ | ! |
- },+ teal.widgets::panel_item( |
| 215 | ! |
- if (!is.null(args$strata_var)) {
+ title = "Plot settings", |
|
| 216 | ! |
- teal.transform::data_extract_ui(+ sliderInput( |
|
| 217 | ! |
- id = ns("strata_i"),
+ ns("alpha"), "Opacity:",
|
|
| 218 | ! |
- label = "Stratify by",+ min = 0, max = 1, |
|
| 219 | ! |
- data_extract_spec = args$strata_var,+ step = .05, value = .5, ticks = FALSE |
|
| 220 | -! | +
- is_single_dataset = is_single_dataset_value+ ), |
|
| 221 | -+ | ! |
- )+ sliderInput( |
| 222 | -+ | ! |
- },+ ns("cex"), "Points size:",
|
| 223 | ! |
- teal.widgets::panel_group(+ min = 0.2, max = 3, |
|
| 224 | ! |
- conditionalPanel(+ step = .05, value = .65, ticks = FALSE |
|
| 225 | -! | +
- condition = paste0("input['", ns("tabs"), "'] == 'Histogram'"),
+ ), |
|
| 226 | ! |
- teal.widgets::panel_item(+ checkboxInput(ns("cor"), "Add Correlation", value = FALSE),
|
|
| 227 | ! |
- "Histogram",+ radioButtons( |
|
| 228 | ! |
- teal.widgets::optionalSliderInputValMinMax(ns("bins"), "Bins", args$bins, ticks = FALSE, step = 1),
+ ns("cor_method"), "Select Correlation Method",
|
|
| 229 | ! |
- shinyWidgets::prettyRadioButtons(+ choiceNames = c("Pearson", "Kendall", "Spearman"),
|
|
| 230 | ! |
- ns("main_type"),
+ choiceValues = c("pearson", "kendall", "spearman"),
|
|
| 231 | ! |
- label = "Plot Type:",+ inline = TRUE |
|
| 232 | -! | +
- choices = c("Density", "Frequency"),
+ ), |
|
| 233 | ! |
- selected = if (!args$freq) "Density" else "Frequency",+ checkboxInput(ns("cor_na_omit"), "Omit Missing Values", value = TRUE)
|
|
| 234 | -! | +
- bigger = FALSE,+ ) |
|
| 235 | -! | +
- inline = TRUE+ ) |
|
| 236 |
- ),+ ), |
||
| 237 | ! |
- checkboxInput(ns("add_dens"), label = "Overlay Density", value = TRUE),
+ forms = tagList( |
|
| 238 | ! |
- collapsed = FALSE+ teal.widgets::verbatim_popup_ui(ns("warning"), "Show Warnings"),
|
|
| 239 | -+ | ! |
- )+ teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code")
|
| 240 |
- ),+ ), |
||
| 241 | ! |
- conditionalPanel(+ pre_output = args$pre_output, |
|
| 242 | ! |
- condition = paste0("input['", ns("tabs"), "'] == 'QQplot'"),
+ post_output = args$post_output |
|
| 243 | -! | +
- teal.widgets::panel_item(+ ) |
|
| 244 | -! | +
- "QQ Plot",+ } |
|
| 245 | -! | +
- checkboxInput(ns("qq_line"), label = "Add diagonal line(s)", TRUE),
+
|
|
| 246 | -! | +
- collapsed = FALSE+ srv_g_scatterplotmatrix <- function(id, data, reporter, filter_panel_api, variables, plot_height, plot_width) {
|
|
| 247 | -+ | ! |
- )+ with_reporter <- !missing(reporter) && inherits(reporter, "Reporter") |
| 248 | -+ | ! |
- ),+ with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI") |
| 249 | ! |
- conditionalPanel(+ checkmate::assert_class(data, "reactive") |
|
| 250 | ! |
- condition = paste0("input['", ns("main_type"), "'] == 'Density'"),
+ checkmate::assert_class(isolate(data()), "teal_data") |
|
| 251 | ! |
- teal.widgets::panel_item(+ moduleServer(id, function(input, output, session) {
|
|
| 252 | ! |
- "Theoretical Distribution",+ selector_list <- teal.transform::data_extract_multiple_srv( |
|
| 253 | ! |
- teal.widgets::optionalSelectInput(+ data_extract = list(variables = variables), |
|
| 254 | ! |
- ns("t_dist"),
+ datasets = data, |
|
| 255 | ! |
- div(+ select_validation_rule = list( |
|
| 256 | ! |
- class = "teal-tooltip",+ variables = ~ if (length(.) <= 1) "Please select at least 2 columns." |
|
| 257 | -! | +
- tagList(+ ) |
|
| 258 | -! | +
- "Distribution:",+ ) |
|
| 259 | -! | +
- icon("circle-info"),
+
|
|
| 260 | ! |
- span(+ iv_r <- reactive({
|
|
| 261 | ! |
- class = "tooltiptext",+ iv <- shinyvalidate::InputValidator$new() |
|
| 262 | ! |
- "Default parameters are optimized with MASS::fitdistr function."+ teal.transform::compose_and_enable_validators(iv, selector_list) |
|
| 263 |
- )+ }) |
||
| 264 |
- )+ |
||
| 265 | -+ | ! |
- ),+ anl_merged_input <- teal.transform::merge_expression_srv( |
| 266 | ! |
- choices = c("normal", "lognormal", "gamma", "unif"),
+ datasets = data, |
|
| 267 | ! |
- selected = NULL,+ selector_list = selector_list |
|
| 268 | -! | +
- multiple = FALSE+ ) |
|
| 269 |
- ),+ |
||
| 270 | ! |
- numericInput(ns("dist_param1"), label = "param1", value = NULL),
+ anl_merged_q <- reactive({
|
|
| 271 | ! |
- numericInput(ns("dist_param2"), label = "param2", value = NULL),
+ req(anl_merged_input()) |
|
| 272 | ! |
- span(actionButton(ns("params_reset"), "Reset params")),
+ data() %>% |
|
| 273 | ! |
- collapsed = FALSE+ teal.code::eval_code(as.expression(anl_merged_input()$expr)) |
|
| 274 |
- )+ }) |
||
| 275 |
- )+ |
||
| 276 | -+ | ! |
- ),+ merged <- list( |
| 277 | ! |
- teal.widgets::panel_item(+ anl_input_r = anl_merged_input, |
|
| 278 | ! |
- "Tests",+ anl_q_r = anl_merged_q |
|
| 279 | -! | +
- teal.widgets::optionalSelectInput(+ ) |
|
| 280 | -! | +
- ns("dist_tests"),
+
|
|
| 281 | -! | +
- "Tests:",+ # plot |
|
| 282 | ! |
- choices = c(+ output_q <- reactive({
|
|
| 283 | ! |
- "Shapiro-Wilk",+ teal::validate_inputs(iv_r()) |
|
| 284 | -! | +
- if (!is.null(args$strata_var)) "t-test (two-samples, not paired)",+ |
|
| 285 | ! |
- if (!is.null(args$strata_var)) "one-way ANOVA",+ qenv <- merged$anl_q_r() |
|
| 286 | ! |
- if (!is.null(args$strata_var)) "Fligner-Killeen",+ ANL <- qenv[["ANL"]] # nolint: object_name. |
|
| 287 | -! | +
- if (!is.null(args$strata_var)) "F-test",+ |
|
| 288 | ! |
- "Kolmogorov-Smirnov (one-sample)",+ cols_names <- merged$anl_input_r()$columns_source$variables |
|
| 289 | ! |
- "Anderson-Darling (one-sample)",+ alpha <- input$alpha |
|
| 290 | ! |
- "Cramer-von Mises (one-sample)",+ cex <- input$cex |
|
| 291 | ! |
- if (!is.null(args$strata_var)) "Kolmogorov-Smirnov (two-samples)"+ add_cor <- input$cor |
|
| 292 | -+ | ! |
- ),+ cor_method <- input$cor_method |
| 293 | ! |
- selected = NULL+ cor_na_omit <- input$cor_na_omit |
|
| 294 |
- )+ |
||
| 295 | -+ | ! |
- ),+ cor_na_action <- if (isTruthy(cor_na_omit)) {
|
| 296 | ! |
- teal.widgets::panel_item(+ "na.omit" |
|
| 297 | -! | +
- "Statistics Table",+ } else {
|
|
| 298 | ! |
- sliderInput(ns("roundn"), "Round to n digits", min = 0, max = 10, value = 2)
+ "na.fail" |
|
| 299 |
- ),+ } |
||
| 300 | -! | +
- teal.widgets::panel_item(+ |
|
| 301 | ! |
- title = "Plot settings",+ teal::validate_has_data(ANL, 10) |
|
| 302 | ! |
- selectInput(+ teal::validate_has_data(ANL[, cols_names, drop = FALSE], 10, complete = TRUE, allow_inf = FALSE) |
|
| 303 | -! | +
- inputId = ns("ggtheme"),
+
|
|
| 304 | -! | +
- label = "Theme (by ggplot):",+ # get labels and proper variable names |
|
| 305 | ! |
- choices = ggplot_themes,+ varnames <- varname_w_label(cols_names, ANL, wrap_width = 20) |
|
| 306 | -! | +
- selected = args$ggtheme,+ |
|
| 307 | -! | +
- multiple = FALSE+ # check character columns. If any, then those are converted to factors |
|
| 308 | -+ | ! |
- )+ check_char <- vapply(ANL[, cols_names], is.character, logical(1)) |
| 309 | -+ | ! |
- )+ if (any(check_char)) {
|
| 310 | -+ | ! |
- ),+ qenv <- teal.code::eval_code( |
| 311 | ! |
- forms = tagList(+ qenv, |
|
| 312 | ! |
- teal.widgets::verbatim_popup_ui(ns("warning"), "Show Warnings"),
+ substitute( |
|
| 313 | ! |
- teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code")
+ expr = ANL <- ANL[, cols_names] %>% # nolint: object_name. |
|
| 314 | -+ | ! |
- ),+ dplyr::mutate_if(is.character, as.factor) %>% |
| 315 | ! |
- pre_output = args$pre_output,+ droplevels(), |
|
| 316 | ! |
- post_output = args$post_output+ env = list(cols_names = cols_names) |
|
| 317 |
- )+ ) |
||
| 318 |
- }+ ) |
||
| 319 |
-
+ } else {
|
||
| 320 | -+ | ! |
- srv_distribution <- function(id,+ qenv <- teal.code::eval_code( |
| 321 | -+ | ! |
- data,+ qenv, |
| 322 | -+ | ! |
- reporter,+ substitute( |
| 323 | -+ | ! |
- filter_panel_api,+ expr = ANL <- ANL[, cols_names] %>% # nolint: object_name. |
| 324 | -+ | ! |
- dist_var,+ droplevels(), |
| 325 | -+ | ! |
- strata_var,+ env = list(cols_names = cols_names) |
| 326 |
- group_var,+ ) |
||
| 327 |
- plot_height,+ ) |
||
| 328 |
- plot_width,+ } |
||
| 329 |
- ggplot2_args) {
+
|
||
| 330 | -! | +
- with_reporter <- !missing(reporter) && inherits(reporter, "Reporter")+ |
|
| 331 | -! | +
- with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI")+ # create plot |
|
| 332 | ! |
- checkmate::assert_class(data, "reactive")+ if (add_cor) {
|
|
| 333 | ! |
- checkmate::assert_class(isolate(data()), "teal_data")+ shinyjs::show("cor_method")
|
|
| 334 | ! |
- moduleServer(id, function(input, output, session) {
+ shinyjs::show("cor_use")
|
|
| 335 | ! |
- rule_req <- function(value) {
+ shinyjs::show("cor_na_omit")
|
|
| 336 | -! | +
- if (isTRUE(input$dist_tests %in% c(+ |
|
| 337 | ! |
- "Fligner-Killeen",+ qenv <- teal.code::eval_code( |
|
| 338 | ! |
- "t-test (two-samples, not paired)",+ qenv, |
|
| 339 | ! |
- "F-test",+ substitute( |
|
| 340 | ! |
- "Kolmogorov-Smirnov (two-samples)",+ expr = {
|
|
| 341 | ! |
- "one-way ANOVA"+ g <- lattice::splom( |
|
| 342 | -+ | ! |
- ))) {
+ ANL, |
| 343 | ! |
- if (!shinyvalidate::input_provided(value)) {
+ varnames = varnames_value, |
|
| 344 | ! |
- "Please select stratify variable."+ panel = function(x, y, ...) {
|
|
| 345 | -+ | ! |
- }+ lattice::panel.splom(x = x, y = y, ...) |
| 346 | -+ | ! |
- }+ cpl <- lattice::current.panel.limits() |
| 347 | -+ | ! |
- }+ lattice::panel.text( |
| 348 | ! |
- rule_dupl <- function(...) {
+ mean(cpl$xlim), |
|
| 349 | ! |
- if (identical(input$dist_tests, "Fligner-Killeen")) {
+ mean(cpl$ylim), |
|
| 350 | ! |
- strata <- selector_list()$strata_i()$select+ get_scatterplotmatrix_stats( |
|
| 351 | ! |
- group <- selector_list()$group_i()$select+ x, |
|
| 352 | ! |
- if (isTRUE(strata == group)) {
+ y, |
|
| 353 | ! |
- "Please select different variables for strata and group."+ .f = stats::cor.test, |
|
| 354 | -+ | ! |
- }+ .f_args = list(method = cor_method, na.action = cor_na_action) |
| 355 |
- }+ ), |
||
| 356 | -+ | ! |
- }+ alpha = 0.6, |
| 357 | -+ | ! |
-
+ fontsize = 18, |
| 358 | ! |
- selector_list <- teal.transform::data_extract_multiple_srv(+ fontface = "bold" |
|
| 359 | -! | +
- data_extract = list(+ ) |
|
| 360 | -! | +
- dist_i = dist_var,+ }, |
|
| 361 | ! |
- strata_i = strata_var,+ pch = 16, |
|
| 362 | ! |
- group_i = group_var+ alpha = alpha_value, |
|
| 363 | -+ | ! |
- ),+ cex = cex_value |
| 364 | -! | +
- data,+ ) |
|
| 365 | ! |
- select_validation_rule = list(+ print(g) |
|
| 366 | -! | +
- dist_i = shinyvalidate::sv_required("Please select a variable")
+ }, |
|
| 367 | -+ | ! |
- ),+ env = list( |
| 368 | ! |
- filter_validation_rule = list(+ varnames_value = varnames, |
|
| 369 | ! |
- strata_i = shinyvalidate::compose_rules(+ cor_method = cor_method, |
|
| 370 | ! |
- rule_req,+ cor_na_action = cor_na_action, |
|
| 371 | ! |
- rule_dupl+ alpha_value = alpha, |
|
| 372 | -+ | ! |
- ),+ cex_value = cex |
| 373 | -! | +
- group_i = rule_dupl+ ) |
|
| 374 |
- )+ ) |
||
| 375 |
- )+ ) |
||
| 376 |
-
+ } else {
|
||
| 377 | ! |
- iv_r <- reactive({
+ shinyjs::hide("cor_method")
|
|
| 378 | ! |
- iv <- shinyvalidate::InputValidator$new()+ shinyjs::hide("cor_use")
|
|
| 379 | ! |
- teal.transform::compose_and_enable_validators(iv, selector_list, validator_names = "dist_i")+ shinyjs::hide("cor_na_omit")
|
|
| 380 | -+ | ! |
- })+ qenv <- teal.code::eval_code( |
| 381 | -+ | ! |
-
+ qenv, |
| 382 | ! |
- iv_r_dist <- reactive({
+ substitute( |
|
| 383 | ! |
- iv <- shinyvalidate::InputValidator$new()+ expr = {
|
|
| 384 | ! |
- teal.transform::compose_and_enable_validators(+ g <- lattice::splom(ANL, varnames = varnames_value, pch = 16, alpha = alpha_value, cex = cex_value) |
|
| 385 | ! |
- iv, selector_list,+ g |
|
| 386 | -! | +
- validator_names = c("strata_i", "group_i")
+ }, |
|
| 387 | -+ | ! |
- )+ env = list(varnames_value = varnames, alpha_value = alpha, cex_value = cex) |
| 388 |
- })+ ) |
||
| 389 | -! | +
- rule_dist_1 <- function(value) {
+ ) |
|
| 390 | -! | +
- if (!is.null(input$t_dist)) {
+ } |
|
| 391 | ! |
- switch(input$t_dist,+ qenv |
|
| 392 | -! | +
- "normal" = if (!shinyvalidate::input_provided(value)) "mean is required",+ }) |
|
| 393 | -! | +
- "lognormal" = if (!shinyvalidate::input_provided(value)) "meanlog is required",+ |
|
| 394 | ! |
- "gamma" = {
+ plot_r <- reactive(output_q()[["g"]]) |
|
| 395 | -! | +
- if (!shinyvalidate::input_provided(value)) "shape is required" else if (value <= 0) "shape must be positive"+ |
|
| 396 |
- },+ # Insert the plot into a plot_with_settings module |
||
| 397 | ! |
- "unif" = NULL+ pws <- teal.widgets::plot_with_settings_srv( |
|
| 398 | -+ | ! |
- )+ id = "myplot", |
| 399 | -+ | ! |
- }+ plot_r = plot_r, |
| 400 | -+ | ! |
- }+ height = plot_height, |
| 401 | ! |
- rule_dist_2 <- function(value) {
+ width = plot_width |
|
| 402 | -! | +
- if (!is.null(input$t_dist)) {
+ ) |
|
| 403 | -! | +
- switch(input$t_dist,+ |
|
| 404 | -! | +
- "normal" = {
+ # show a message if conversion to factors took place |
|
| 405 | ! |
- if (!shinyvalidate::input_provided(value)) {
+ output$message <- renderText({
|
|
| 406 | ! |
- "sd is required"+ shiny::req(iv_r()$is_valid()) |
|
| 407 | ! |
- } else if (value < 0) {
+ req(selector_list()$variables()) |
|
| 408 | ! |
- "sd must be non-negative"+ ANL <- merged$anl_q_r()[["ANL"]] # nolint: object_name. |
|
| 409 | -+ | ! |
- }+ cols_names <- unique(unname(do.call(c, merged$anl_input_r()$columns_source))) |
| 410 | -+ | ! |
- },+ check_char <- vapply(ANL[, cols_names], is.character, logical(1)) |
| 411 | ! |
- "lognormal" = {
+ if (any(check_char)) {
|
|
| 412 | ! |
- if (!shinyvalidate::input_provided(value)) {
+ is_single <- sum(check_char) == 1 |
|
| 413 | ! |
- "sdlog is required"+ paste( |
|
| 414 | ! |
- } else if (value < 0) {
+ "Character", |
|
| 415 | ! |
- "sdlog must be non-negative"+ ifelse(is_single, "variable", "variables"), |
|
| 416 | -+ | ! |
- }+ paste0("(", paste(cols_names[check_char], collapse = ", "), ")"),
|
| 417 | -+ | ! |
- },+ ifelse(is_single, "was", "were"), |
| 418 | ! |
- "gamma" = {
+ "converted to", |
|
| 419 | ! |
- if (!shinyvalidate::input_provided(value)) {
+ ifelse(is_single, "factor.", "factors.") |
|
| 420 | -! | +
- "rate is required"+ ) |
|
| 421 | -! | +
- } else if (value <= 0) {
+ } else {
|
|
| 422 | -! | +
- "rate must be positive"+ "" |
|
| 423 |
- }+ } |
||
| 424 |
- },+ }) |
||
| 425 | -! | +
- "unif" = NULL+ |
|
| 426 | -+ | ! |
- )+ teal.widgets::verbatim_popup_srv( |
| 427 | -+ | ! |
- }+ id = "warning", |
| 428 | -+ | ! |
- }+ verbatim_content = reactive(teal.code::get_warnings(output_q())), |
| 429 | ! |
- rule_dist <- function(value) {
+ title = "Warning", |
|
| 430 | ! |
- if (isTRUE(input$tabs == "QQplot" ||+ disabled = reactive(is.null(teal.code::get_warnings(output_q()))) |
|
| 431 | -! | +
- input$dist_tests %in% c(+ ) |
|
| 432 | -! | +
- "Kolmogorov-Smirnov (one-sample)",+ |
|
| 433 | ! |
- "Anderson-Darling (one-sample)",+ teal.widgets::verbatim_popup_srv( |
|
| 434 | ! |
- "Cramer-von Mises (one-sample)"+ id = "rcode", |
|
| 435 | -+ | ! |
- ))) {
+ verbatim_content = reactive(teal.code::get_code(output_q())), |
| 436 | ! |
- if (!shinyvalidate::input_provided(value)) {
+ title = "Show R Code for Scatterplotmatrix" |
|
| 437 | -! | +
- "Please select the theoretical distribution."+ ) |
|
| 438 |
- }+ |
||
| 439 |
- }+ ### REPORTER |
||
| 440 | -+ | ! |
- }+ if (with_reporter) {
|
| 441 | ! |
- iv_dist <- shinyvalidate::InputValidator$new()+ card_fun <- function(comment, label) {
|
|
| 442 | ! |
- iv_dist$add_rule("t_dist", rule_dist)
+ card <- teal::report_card_template( |
|
| 443 | ! |
- iv_dist$add_rule("dist_param1", rule_dist_1)
+ title = "Scatter Plot Matrix", |
|
| 444 | ! |
- iv_dist$add_rule("dist_param2", rule_dist_2)
+ label = label, |
|
| 445 | ! |
- iv_dist$enable()+ with_filter = with_filter, |
|
| 446 | -+ | ! |
-
+ filter_panel_api = filter_panel_api |
| 447 | -! | +
- anl_merged_input <- teal.transform::merge_expression_srv(+ ) |
|
| 448 | ! |
- selector_list = selector_list,+ card$append_text("Plot", "header3")
|
|
| 449 | ! |
- datasets = data+ card$append_plot(plot_r(), dim = pws$dim()) |
|
| 450 | -+ | ! |
- )+ if (!comment == "") {
|
| 451 | -+ | ! |
-
+ card$append_text("Comment", "header3")
|
| 452 | ! |
- anl_merged_q <- reactive({
+ card$append_text(comment) |
|
| 453 | -! | +
- req(anl_merged_input())+ } |
|
| 454 | ! |
- data() %>%+ card$append_src(teal.code::get_code(output_q())) |
|
| 455 | ! |
- teal.code::eval_code(as.expression(anl_merged_input()$expr))+ card |
|
| 456 |
- })+ } |
||
| 457 | -+ | ! |
-
+ teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
|
| 458 | -! | +
- merged <- list(+ } |
|
| 459 | -! | +
- anl_input_r = anl_merged_input,+ ### |
|
| 460 | -! | +
- anl_q_r = anl_merged_q+ }) |
|
| 461 |
- )+ } |
||
| 463 | -! | +
- output$scales_types_ui <- renderUI({
+ #' Get stats for x-y pairs in scatterplot matrix |
|
| 464 | -! | +
- if ("group_i" %in% names(selector_list()) && length(selector_list()$group_i()$filters[[1]]$selected) > 0) {
+ #' @description uses stats::cor.test per default for all numerical input variables and converts results |
|
| 465 | -! | +
- shinyWidgets::prettyRadioButtons(+ #' to character vector. Could be extended if different stats for different variable |
|
| 466 | -! | +
- session$ns("scales_type"),
+ #' types are needed. Meant to be called from \code{lattice::panel.text}.
|
|
| 467 | -! | +
- label = "Scales:",+ #' @param x \code{numeric}
|
|
| 468 | -! | +
- choices = c("Fixed", "Free"),
+ #' @param y \code{numeric}
|
|
| 469 | -! | +
- selected = "Fixed",+ #' @param .f \code{function}, function that accepts x and y as formula input \code{~ x + y}.
|
|
| 470 | -! | +
- bigger = FALSE,+ #' Default \code{stats::cor.test}
|
|
| 471 | -! | +
- inline = TRUE+ #' @param .f_args \code{list} of arguments to be passed to \code{.f}
|
|
| 472 |
- )+ #' @param round_stat \code{integer}
|
||
| 473 |
- }+ #' @param round_pval \code{integer}
|
||
| 474 |
- })+ #' @details presently we need to use a formula input for \code{stats::cor.test} because
|
||
| 475 |
-
+ #' \code{na.fail} only gets evaluated when a formula is passed (see below).
|
||
| 476 | -! | +
- observeEvent(+ #' \preformatted{
|
|
| 477 | -! | +
- eventExpr = list(+ #' x = c(1,3,5,7,NA) |
|
| 478 | -! | +
- input$t_dist,+ #' y = c(3,6,7,8,1) |
|
| 479 | -! | +
- input$params_reset,+ #' stats::cor.test(x, y, na.action = "na.fail") |
|
| 480 | -! | +
- selector_list()$dist_i()$select+ #' stats::cor.test(~ x + y, na.action = "na.fail") |
|
| 481 |
- ),+ #' } |
||
| 482 | -! | +
- handlerExpr = {
+ #' @return \code{character} with stats. For \code{stats::cor.test} correlation coefficient and p-value.
|
|
| 483 | -! | +
- if (length(input$t_dist) != 0) {
+ #' @export |
|
| 484 | -! | +
- dist_var2 <- as.vector(merged$anl_input_r()$columns_source$dist_i)+ #' @examples |
|
| 485 |
-
+ #' set.seed(1) |
||
| 486 | -! | +
- get_dist_params <- function(x, dist) {
+ #' x <- runif(25, 0, 1) |
|
| 487 | -! | +
- if (dist == "unif") {
+ #' y <- runif(25, 0, 1) |
|
| 488 | -! | +
- res <- as.list(range(x))+ #' x[c(3, 10, 18)] <- NA |
|
| 489 | -! | +
- names(res) <- c("min", "max")
+ #' |
|
| 490 | -! | +
- return(res)+ #' get_scatterplotmatrix_stats(x, y, .f = stats::cor.test, .f_args = list(method = "pearson")) |
|
| 491 |
- }+ #' get_scatterplotmatrix_stats(x, y, .f = stats::cor.test, .f_args = list( |
||
| 492 | -! | +
- tryCatch(+ #' method = "pearson", |
|
| 493 | -! | +
- as.list(MASS::fitdistr(x, densfun = dist)$estimate),+ #' na.action = na.fail |
|
| 494 | -! | +
- error = function(e) list(param1 = NA, param2 = NA)+ #' )) |
|
| 495 |
- )+ get_scatterplotmatrix_stats <- function(x, y, |
||
| 496 |
- }+ .f = stats::cor.test, |
||
| 497 |
-
+ .f_args = list(), |
||
| 498 | -! | +
- ANL <- merged$anl_q_r()[[as.character(dist_var[[1]]$dataname)]] # nolint: object_name.+ round_stat = 2, |
|
| 499 | -! | +
- params <- get_dist_params(as.numeric(stats::na.omit(ANL[[dist_var2]])), input$t_dist)+ round_pval = 4) {
|
|
| 500 | -! | +6x |
- params_vec <- round(unname(unlist(params)), 2)+ if (is.numeric(x) && is.numeric(y)) {
|
| 501 | -! | +3x |
- params_names <- names(params)+ stat <- tryCatch(do.call(.f, c(list(~ x + y), .f_args)), error = function(e) NA) |
| 503 | -! | +3x |
- updateNumericInput(session, "dist_param1", label = params_names[1], value = params_vec[1])+ if (anyNA(stat)) {
|
| 504 | -! | +1x |
- updateNumericInput(session, "dist_param2", label = params_names[2], value = params_vec[2])+ return("NA")
|
| 505 | -+ | 2x |
- } else {
+ } else if (all(c("estimate", "p.value") %in% names(stat))) {
|
| 506 | -! | +2x |
- updateNumericInput(session, "dist_param1", label = "param1", value = NA)+ return(paste( |
| 507 | -! | +2x |
- updateNumericInput(session, "dist_param2", label = "param2", value = NA)+ c( |
| 508 | -+ | 2x |
- }+ paste0(names(stat$estimate), ":", round(stat$estimate, round_stat)), |
| 509 | -+ | 2x |
- },+ paste0("P:", round(stat$p.value, round_pval))
|
| 510 | -! | +
- ignoreInit = TRUE+ ), |
|
| 511 | -+ | 2x |
- )+ collapse = "\n" |
| 512 |
-
+ )) |
||
| 513 | -! | +
- merge_vars <- reactive({
+ } else {
|
|
| 514 | ! |
- teal::validate_inputs(iv_r())+ stop("function not supported")
|
|
| 515 |
-
+ } |
||
| 516 | -! | +
- dist_var <- as.vector(merged$anl_input_r()$columns_source$dist_i)+ } else {
|
|
| 517 | -! | +3x |
- s_var <- as.vector(merged$anl_input_r()$columns_source$strata_i)+ if ("method" %in% names(.f_args)) {
|
| 518 | -! | +3x |
- g_var <- as.vector(merged$anl_input_r()$columns_source$group_i)+ if (.f_args$method == "pearson") {
|
| 519 | -+ | 1x |
-
+ return("cor:-")
|
| 520 | -! | +
- dist_var_name <- if (length(dist_var)) as.name(dist_var) else NULL+ } |
|
| 521 | -! | +2x |
- s_var_name <- if (length(s_var)) as.name(s_var) else NULL+ if (.f_args$method == "kendall") {
|
| 522 | -! | +1x |
- g_var_name <- if (length(g_var)) as.name(g_var) else NULL+ return("tau:-")
|
| 523 |
-
+ } |
||
| 524 | -! | +1x |
- list(+ if (.f_args$method == "spearman") {
|
| 525 | -! | +1x |
- dist_var = dist_var,+ return("rho:-")
|
| 526 | -! | +
- s_var = s_var,+ } |
|
| 527 | -! | +
- g_var = g_var,+ } |
|
| 528 | ! |
- dist_var_name = dist_var_name,+ return("-")
|
|
| 529 | -! | +
- s_var_name = s_var_name,+ } |
|
| 530 | -! | +
- g_var_name = g_var_name+ } |
| 531 | +1 |
- )+ #' Univariate and bivariate visualizations |
|
| 532 | +2 |
- })+ #' @md |
|
| 533 | +3 |
-
+ #' |
|
| 534 | +4 |
- # common qenv- |
- |
| 535 | -! | -
- common_q <- reactive({
+ #' @inheritParams teal::module |
|
| 536 | +5 |
- # Create a private stack for this function only.+ #' @inheritParams shared_params |
|
| 537 | +6 |
-
+ #' @param x (`data_extract_spec` or `list` of multiple `data_extract_spec`) |
|
| 538 | -! | +||
| 7 | +
- ANL <- merged$anl_q_r()[["ANL"]] # nolint: object_name.+ #' Variable names selected to plot along the x-axis by default. Variable can be numeric, factor or character. |
||
| 539 | -! | +||
| 8 | +
- dist_var <- merge_vars()$dist_var+ #' No empty selections are allowed! |
||
| 540 | -! | +||
| 9 | +
- s_var <- merge_vars()$s_var+ #' @param y (`data_extract_spec` or `list` of multiple `data_extract_spec`) |
||
| 541 | -! | +||
| 10 | +
- g_var <- merge_vars()$g_var+ #' Variable names selected to plot along the y-axis by default. Variable can be numeric, factor or character. |
||
| 542 | +11 |
-
+ #' @param use_density optional, (`logical`) value for whether density (`TRUE`) is plotted or |
|
| 543 | -! | +||
| 12 | +
- dist_var_name <- merge_vars()$dist_var_name+ #' frequency (`FALSE`). Defaults to frequency (`FALSE`). |
||
| 544 | -! | +||
| 13 | +
- s_var_name <- merge_vars()$s_var_name+ #' @param row_facet optional, (`data_extract_spec` or `list` of multiple `data_extract_spec`) |
||
| 545 | -! | +||
| 14 | +
- g_var_name <- merge_vars()$g_var_name+ #' Variables for row facetting. |
||
| 546 | +15 |
-
+ #' @param col_facet optional, (`data_extract_spec` or `list` of multiple `data_extract_spec`) |
|
| 547 | -! | +||
| 16 | +
- roundn <- input$roundn+ #' Variables for col facetting. |
||
| 548 | -! | +||
| 17 | +
- dist_param1 <- input$dist_param1+ #' @param facet optional, (`logical`) to specify whether the facet encodings `ui` elements are toggled |
||
| 549 | -! | +||
| 18 | +
- dist_param2 <- input$dist_param2+ #' on and shown to the user by default. Defaults to `TRUE` if either `row_facet` or `column_facet` |
||
| 550 | +19 |
- # isolated as dist_param1/dist_param2 already triggered the reactivity+ #' are supplied. |
|
| 551 | -! | +||
| 20 | +
- t_dist <- isolate(input$t_dist)+ #' @param color_settings (`logical`) Whether coloring, filling and size should be applied |
||
| 552 | +21 |
-
+ #' and `UI` tool offered to the user. |
|
| 553 | -! | +||
| 22 | +
- qenv <- merged$anl_q_r()+ #' @param color optional, (`data_extract_spec` or `list` of multiple `data_extract_spec`) |
||
| 554 | +23 |
-
+ #' Variables selected for the outline color inside the coloring settings. |
|
| 555 | -! | +||
| 24 | +
- if (length(g_var) > 0) {
+ #' It will be applied when `color_settings` is set to `TRUE`. |
||
| 556 | -! | +||
| 25 | +
- validate(+ #' @param fill optional, (`data_extract_spec` or `list` of multiple `data_extract_spec`) |
||
| 557 | -! | +||
| 26 | +
- need(+ #' Variables selected for the fill color inside the coloring settings. |
||
| 558 | -! | +||
| 27 | +
- inherits(ANL[[g_var]], c("integer", "factor", "character")),
+ #' It will be applied when `color_settings` is set to `TRUE`. |
||
| 559 | -! | +||
| 28 | +
- "Group by variable must be `factor`, `character`, or `integer`"+ #' @param size optional, (`data_extract_spec` or `list` of multiple `data_extract_spec`) |
||
| 560 | +29 |
- )+ #' Variables selected for the size of `geom_point` plots inside the coloring settings. |
|
| 561 | +30 |
- )+ #' It will be applied when `color_settings` is set to `TRUE`. |
|
| 562 | -! | +||
| 31 | +
- qenv <- teal.code::eval_code(+ #' @param free_x_scales optional, (`logical`) Whether X scaling shall be changeable. |
||
| 563 | -! | +||
| 32 | +
- qenv,+ #' Does not allow scaling to be changed by default (`FALSE`). |
||
| 564 | -! | +||
| 33 | +
- substitute(+ #' @param free_y_scales optional, (`logical`) Whether Y scaling shall be changeable. |
||
| 565 | -! | +||
| 34 | +
- expr = ANL[[g_var]] <- forcats::fct_na_value_to_level(as.factor(ANL[[g_var]]), "NA"), # nolint: object_name.+ #' Does not allow scaling to be changed by default (`FALSE`). |
||
| 566 | -! | +||
| 35 | +
- env = list(g_var = g_var)+ #' @param swap_axes optional, (`logical`) Whether to swap X and Y axes. Defaults to `FALSE`. |
||
| 567 | +36 |
- )+ #' |
|
| 568 | +37 |
- )+ #' @details |
|
| 569 | +38 |
- }+ #' This is a general module to visualize 1 & 2 dimensional data. |
|
| 570 | +39 |
-
+ #' |
|
| 571 | -! | +||
| 40 | +
- if (length(s_var) > 0) {
+ #' @note |
||
| 572 | -! | +||
| 41 | +
- validate(+ #' For more examples, please see the vignette "Using bivariate plot" via |
||
| 573 | -! | +||
| 42 | +
- need(+ #' `vignette("using-bivariate-plot", package = "teal.modules.general")`.
|
||
| 574 | -! | +||
| 43 | +
- inherits(ANL[[s_var]], c("integer", "factor", "character")),
+ #' |
||
| 575 | -! | +||
| 44 | +
- "Stratify by variable must be `factor`, `character`, or `integer`"+ #' @export |
||
| 576 | +45 |
- )+ #' |
|
| 577 | +46 |
- )+ #' @examples |
|
| 578 | -! | +||
| 47 | +
- qenv <- teal.code::eval_code(+ #' # general data exapmle |
||
| 579 | -! | +||
| 48 | +
- qenv,+ #' library(teal.widgets) |
||
| 580 | -! | +||
| 49 | +
- substitute(+ #' |
||
| 581 | -! | +||
| 50 | +
- expr = ANL[[s_var]] <- forcats::fct_na_value_to_level(as.factor(ANL[[s_var]]), "NA"), # nolint: object_name.+ #' data <- teal_data() |
||
| 582 | -! | +||
| 51 | +
- env = list(s_var = s_var)+ #' data <- within(data, {
|
||
| 583 | +52 |
- )+ #' library(nestcolor) |
|
| 584 | +53 |
- )+ #' CO2 <- data.frame(CO2) |
|
| 585 | +54 |
- }+ #' }) |
|
| 586 | +55 |
-
+ #' datanames(data) <- c("CO2")
|
|
| 587 | -! | +||
| 56 | +
- validate(need(is.numeric(ANL[[dist_var]]), "Please select a numeric variable."))+ #' join_keys(data) <- default_cdisc_join_keys[datanames(data)] |
||
| 588 | -! | +||
| 57 | +
- teal::validate_has_data(ANL, 1, complete = TRUE)+ #' |
||
| 589 | +58 |
-
+ #' app <- init( |
|
| 590 | -! | +||
| 59 | +
- if (length(t_dist) != 0) {
+ #' data = data, |
||
| 591 | -! | +||
| 60 | +
- map_distr_nams <- list(+ #' modules = modules( |
||
| 592 | -! | +||
| 61 | +
- normal = c("mean", "sd"),
+ #' tm_g_bivariate( |
||
| 593 | -! | +||
| 62 | +
- lognormal = c("meanlog", "sdlog"),
+ #' x = data_extract_spec( |
||
| 594 | -! | +||
| 63 | +
- gamma = c("shape", "rate"),
+ #' dataname = "CO2", |
||
| 595 | -! | +||
| 64 | +
- unif = c("min", "max")
+ #' select = select_spec( |
||
| 596 | +65 |
- )+ #' label = "Select variable:", |
|
| 597 | -! | +||
| 66 | +
- params_names_raw <- map_distr_nams[[t_dist]]+ #' choices = variable_choices(data[["CO2"]]), |
||
| 598 | +67 |
-
+ #' selected = "conc", |
|
| 599 | -! | +||
| 68 | +
- qenv <- teal.code::eval_code(+ #' fixed = FALSE |
||
| 600 | -! | +||
| 69 | +
- qenv,+ #' ) |
||
| 601 | -! | +||
| 70 | +
- substitute(+ #' ), |
||
| 602 | -! | +||
| 71 | +
- expr = {
+ #' y = data_extract_spec( |
||
| 603 | -! | +||
| 72 | +
- params <- as.list(c(dist_param1, dist_param2))+ #' dataname = "CO2", |
||
| 604 | -! | +||
| 73 | +
- names(params) <- params_names_raw+ #' select = select_spec( |
||
| 605 | +74 |
- },+ #' label = "Select variable:", |
|
| 606 | -! | +||
| 75 | +
- env = list(+ #' choices = variable_choices(data[["CO2"]]), |
||
| 607 | -! | +||
| 76 | +
- dist_param1 = dist_param1,+ #' selected = "uptake", |
||
| 608 | -! | +||
| 77 | +
- dist_param2 = dist_param2,+ #' multiple = FALSE, |
||
| 609 | -! | +||
| 78 | +
- params_names_raw = params_names_raw+ #' fixed = FALSE |
||
| 610 | +79 |
- )+ #' ) |
|
| 611 | +80 |
- )+ #' ), |
|
| 612 | +81 |
- )+ #' row_facet = data_extract_spec( |
|
| 613 | +82 |
- }+ #' dataname = "CO2", |
|
| 614 | +83 |
-
+ #' select = select_spec( |
|
| 615 | -! | +||
| 84 | +
- if (length(s_var) == 0 && length(g_var) == 0) {
+ #' label = "Select variable:", |
||
| 616 | -! | +||
| 85 | +
- qenv <- teal.code::eval_code(+ #' choices = variable_choices(data[["CO2"]]), |
||
| 617 | -! | +||
| 86 | +
- qenv,+ #' selected = "Type", |
||
| 618 | -! | +||
| 87 | +
- substitute(+ #' fixed = FALSE |
||
| 619 | -! | +||
| 88 | +
- expr = {
+ #' ) |
||
| 620 | -! | +||
| 89 | +
- summary_table <- ANL %>%+ #' ), |
||
| 621 | -! | +||
| 90 | +
- dplyr::summarise(+ #' col_facet = data_extract_spec( |
||
| 622 | -! | +||
| 91 | +
- min = round(min(dist_var_name, na.rm = TRUE), roundn),+ #' dataname = "CO2", |
||
| 623 | -! | +||
| 92 | +
- median = round(stats::median(dist_var_name, na.rm = TRUE), roundn),+ #' select = select_spec( |
||
| 624 | -! | +||
| 93 | +
- mean = round(mean(dist_var_name, na.rm = TRUE), roundn),+ #' label = "Select variable:", |
||
| 625 | -! | +||
| 94 | +
- max = round(max(dist_var_name, na.rm = TRUE), roundn),+ #' choices = variable_choices(data[["CO2"]]), |
||
| 626 | -! | +||
| 95 | +
- sd = round(stats::sd(dist_var_name, na.rm = TRUE), roundn),+ #' selected = "Treatment", |
||
| 627 | -! | +||
| 96 | +
- count = dplyr::n()+ #' fixed = FALSE |
||
| 628 | +97 |
- )+ #' ) |
|
| 629 | +98 |
- },+ #' ), |
|
| 630 | -! | +||
| 99 | +
- env = list(+ #' ggplot2_args = ggplot2_args( |
||
| 631 | -! | +||
| 100 | +
- dist_var_name = as.name(dist_var),+ #' labs = list(subtitle = "Plot generated by Bivariate Module") |
||
| 632 | -! | +||
| 101 | +
- roundn = roundn+ #' ) |
||
| 633 | +102 |
- )+ #' ) |
|
| 634 | +103 |
- )+ #' ) |
|
| 635 | +104 |
- )+ #' ) |
|
| 636 | +105 |
- } else {
+ #' if (interactive()) {
|
|
| 637 | -! | +||
| 106 | +
- qenv <- teal.code::eval_code(+ #' shinyApp(app$ui, app$server) |
||
| 638 | -! | +||
| 107 | +
- qenv,+ #' } |
||
| 639 | -! | +||
| 108 | +
- substitute(+ #' |
||
| 640 | -! | +||
| 109 | +
- expr = {
+ #' |
||
| 641 | -! | +||
| 110 | +
- strata_vars <- strata_vars_raw+ #' # CDISC data example |
||
| 642 | -! | +||
| 111 | +
- summary_table <- ANL %>%+ #' library(teal.widgets) |
||
| 643 | -! | +||
| 112 | +
- dplyr::group_by_at(dplyr::vars(dplyr::any_of(strata_vars))) %>%+ #' |
||
| 644 | -! | +||
| 113 | +
- dplyr::summarise(+ #' data <- teal_data() |
||
| 645 | -! | +||
| 114 | +
- min = round(min(dist_var_name, na.rm = TRUE), roundn),+ #' data <- within(data, {
|
||
| 646 | -! | +||
| 115 | +
- median = round(stats::median(dist_var_name, na.rm = TRUE), roundn),+ #' library(nestcolor) |
||
| 647 | -! | +||
| 116 | +
- mean = round(mean(dist_var_name, na.rm = TRUE), roundn),+ #' ADSL <- rADSL |
||
| 648 | -! | +||
| 117 | +
- max = round(max(dist_var_name, na.rm = TRUE), roundn),+ #' }) |
||
| 649 | -! | +||
| 118 | +
- sd = round(stats::sd(dist_var_name, na.rm = TRUE), roundn),+ #' datanames(data) <- c("ADSL")
|
||
| 650 | -! | +||
| 119 | +
- count = dplyr::n()+ #' join_keys(data) <- default_cdisc_join_keys[datanames(data)] |
||
| 651 | +120 |
- )+ #' |
|
| 652 | -! | +||
| 121 | +
- summary_table # used to display table when running show-r-code code+ #' app <- init( |
||
| 653 | +122 |
- },+ #' data = data, |
|
| 654 | -! | +||
| 123 | +
- env = list(+ #' modules = modules( |
||
| 655 | -! | +||
| 124 | +
- dist_var_name = dist_var_name,+ #' tm_g_bivariate( |
||
| 656 | -! | +||
| 125 | +
- strata_vars_raw = c(g_var, s_var),+ #' x = data_extract_spec( |
||
| 657 | -! | +||
| 126 | +
- roundn = roundn+ #' dataname = "ADSL", |
||
| 658 | +127 |
- )+ #' select = select_spec( |
|
| 659 | +128 |
- )+ #' label = "Select variable:", |
|
| 660 | +129 |
- )+ #' choices = variable_choices(data[["ADSL"]]), |
|
| 661 | +130 |
- }+ #' selected = "AGE", |
|
| 662 | +131 |
- })+ #' fixed = FALSE |
|
| 663 | +132 |
-
+ #' ) |
|
| 664 | +133 |
- # distplot qenv ----+ #' ), |
|
| 665 | -! | +||
| 134 | +
- dist_q <- eventReactive(+ #' y = data_extract_spec( |
||
| 666 | -! | +||
| 135 | +
- eventExpr = {
+ #' dataname = "ADSL", |
||
| 667 | -! | +||
| 136 | +
- common_q()+ #' select = select_spec( |
||
| 668 | -! | +||
| 137 | +
- input$scales_type+ #' label = "Select variable:", |
||
| 669 | -! | +||
| 138 | +
- input$main_type+ #' choices = variable_choices(data[["ADSL"]]), |
||
| 670 | -! | +||
| 139 | +
- input$bins+ #' selected = "SEX", |
||
| 671 | -! | +||
| 140 | +
- input$add_dens+ #' multiple = FALSE, |
||
| 672 | -! | +||
| 141 | +
- is.null(input$ggtheme)+ #' fixed = FALSE |
||
| 673 | +142 |
- },+ #' ) |
|
| 674 | -! | +||
| 143 | +
- valueExpr = {
+ #' ), |
||
| 675 | -! | +||
| 144 | +
- dist_var <- merge_vars()$dist_var+ #' row_facet = data_extract_spec( |
||
| 676 | -! | +||
| 145 | +
- s_var <- merge_vars()$s_var+ #' dataname = "ADSL", |
||
| 677 | -! | +||
| 146 | +
- g_var <- merge_vars()$g_var+ #' select = select_spec( |
||
| 678 | -! | +||
| 147 | +
- dist_var_name <- merge_vars()$dist_var_name+ #' label = "Select variable:", |
||
| 679 | -! | +||
| 148 | +
- s_var_name <- merge_vars()$s_var_name+ #' choices = variable_choices(data[["ADSL"]]), |
||
| 680 | -! | +||
| 149 | +
- g_var_name <- merge_vars()$g_var_name+ #' selected = "ARM", |
||
| 681 | -! | +||
| 150 | +
- t_dist <- input$t_dist+ #' fixed = FALSE |
||
| 682 | -! | +||
| 151 | +
- dist_param1 <- input$dist_param1+ #' ) |
||
| 683 | -! | +||
| 152 | +
- dist_param2 <- input$dist_param2+ #' ), |
||
| 684 | +153 |
-
+ #' col_facet = data_extract_spec( |
|
| 685 | -! | +||
| 154 | +
- scales_type <- input$scales_type+ #' dataname = "ADSL", |
||
| 686 | +155 |
-
+ #' select = select_spec( |
|
| 687 | -! | +||
| 156 | +
- ndensity <- 512+ #' label = "Select variable:", |
||
| 688 | -! | +||
| 157 | +
- main_type_var <- input$main_type+ #' choices = variable_choices(data[["ADSL"]]), |
||
| 689 | -! | +||
| 158 | +
- bins_var <- input$bins+ #' selected = "COUNTRY", |
||
| 690 | -! | +||
| 159 | +
- add_dens_var <- input$add_dens+ #' fixed = FALSE |
||
| 691 | -! | +||
| 160 | +
- ggtheme <- input$ggtheme+ #' ) |
||
| 692 | +161 |
-
+ #' ), |
|
| 693 | -! | +||
| 162 | +
- teal::validate_inputs(iv_dist)+ #' ggplot2_args = ggplot2_args( |
||
| 694 | +163 |
-
+ #' labs = list(subtitle = "Plot generated by Bivariate Module") |
|
| 695 | -! | +||
| 164 | +
- qenv <- common_q()+ #' ) |
||
| 696 | +165 |
-
+ #' ) |
|
| 697 | -! | +||
| 166 | +
- m_type <- if (main_type_var == "Density") "density" else "count"+ #' ) |
||
| 698 | +167 |
-
+ #' ) |
|
| 699 | -! | +||
| 168 | +
- plot_call <- if (length(s_var) == 0 && length(g_var) == 0) {
+ #' if (interactive()) {
|
||
| 700 | -! | +||
| 169 | +
- substitute(+ #' shinyApp(app$ui, app$server) |
||
| 701 | -! | +||
| 170 | +
- expr = ggplot(ANL, aes(dist_var_name)) ++ #' } |
||
| 702 | -! | +||
| 171 | +
- geom_histogram(+ tm_g_bivariate <- function(label = "Bivariate Plots", |
||
| 703 | -! | +||
| 172 | +
- position = "identity", aes(y = after_stat(m_type)), bins = bins_var, alpha = 0.3+ x, |
||
| 704 | +173 |
- ),+ y, |
|
| 705 | -! | +||
| 174 | +
- env = list(+ row_facet = NULL, |
||
| 706 | -! | +||
| 175 | +
- m_type = as.name(m_type), bins_var = bins_var, dist_var_name = as.name(dist_var)+ col_facet = NULL, |
||
| 707 | +176 |
- )+ facet = !is.null(row_facet) || !is.null(col_facet), |
|
| 708 | +177 |
- )+ color = NULL, |
|
| 709 | -! | +||
| 178 | +
- } else if (length(s_var) != 0 && length(g_var) == 0) {
+ fill = NULL, |
||
| 710 | -! | +||
| 179 | +
- substitute(+ size = NULL, |
||
| 711 | -! | +||
| 180 | +
- expr = ggplot(ANL, aes(dist_var_name, col = s_var_name)) ++ use_density = FALSE, |
||
| 712 | -! | +||
| 181 | +
- geom_histogram(+ color_settings = FALSE, |
||
| 713 | -! | +||
| 182 | +
- position = "identity", aes(y = after_stat(m_type), fill = s_var), bins = bins_var, alpha = 0.3+ free_x_scales = FALSE, |
||
| 714 | +183 |
- ),+ free_y_scales = FALSE, |
|
| 715 | -! | +||
| 184 | +
- env = list(+ plot_height = c(600, 200, 2000), |
||
| 716 | -! | +||
| 185 | +
- m_type = as.name(m_type),+ plot_width = NULL, |
||
| 717 | -! | +||
| 186 | +
- bins_var = bins_var,+ rotate_xaxis_labels = FALSE, |
||
| 718 | -! | +||
| 187 | +
- dist_var_name = dist_var_name,+ swap_axes = FALSE, |
||
| 719 | -! | +||
| 188 | +
- s_var = as.name(s_var),+ ggtheme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void"),
|
||
| 720 | -! | +||
| 189 | +
- s_var_name = s_var_name+ ggplot2_args = teal.widgets::ggplot2_args(), |
||
| 721 | +190 |
- )+ pre_output = NULL, |
|
| 722 | +191 |
- )+ post_output = NULL) {
|
|
| 723 | +192 | ! |
- } else if (length(s_var) == 0 && length(g_var) != 0) {
+ logger::log_info("Initializing tm_g_bivariate")
|
| 724 | +193 | ! |
- req(scales_type)+ if (inherits(x, "data_extract_spec")) x <- list(x) |
| 725 | +194 | ! |
- substitute(+ if (inherits(y, "data_extract_spec")) y <- list(y) |
| 726 | +195 | ! |
- expr = ggplot(ANL[ANL[[g_var]] != "NA", ], aes(dist_var_name)) ++ if (inherits(row_facet, "data_extract_spec")) row_facet <- list(row_facet) |
| 727 | +196 | ! |
- geom_histogram(+ if (inherits(col_facet, "data_extract_spec")) col_facet <- list(col_facet) |
| 728 | +197 | ! |
- position = "identity", aes(y = after_stat(m_type)), bins = bins_var, alpha = 0.3+ if (inherits(color, "data_extract_spec")) color <- list(color) |
| 729 | -+ | ||
| 198 | +! |
- ) ++ if (inherits(fill, "data_extract_spec")) fill <- list(fill) |
|
| 730 | +199 | ! |
- facet_wrap(~g_var_name, ncol = 1, scales = scales_raw),+ if (inherits(size, "data_extract_spec")) size <- list(size) |
| 731 | -! | +||
| 200 | +
- env = list(+ |
||
| 732 | +201 | ! |
- m_type = as.name(m_type),+ checkmate::assert_list(x, types = "data_extract_spec") |
| 733 | +202 | ! |
- bins_var = bins_var,+ if (!all(vapply(x, function(x) !x$select$multiple, logical(1)))) {
|
| 734 | +203 | ! |
- dist_var_name = dist_var_name,+ stop("'x' should not allow multiple selection")
|
| 735 | -! | +||
| 204 | +
- g_var = g_var,+ } |
||
| 736 | +205 | ! |
- g_var_name = g_var_name,+ checkmate::assert_list(y, types = "data_extract_spec") |
| 737 | +206 | ! |
- scales_raw = tolower(scales_type)+ if (!all(vapply(y, function(x) !x$select$multiple, logical(1)))) {
|
| 738 | -+ | ||
| 207 | +! |
- )+ stop("'y' should not allow multiple selection")
|
|
| 739 | +208 |
- )+ } |
|
| 740 | -+ | ||
| 209 | +! |
- } else {
+ checkmate::assert_list(row_facet, types = "data_extract_spec", null.ok = TRUE) |
|
| 741 | +210 | ! |
- req(scales_type)+ if (!all(vapply(row_facet, function(x) !x$select$multiple, logical(1)))) {
|
| 742 | +211 | ! |
- substitute(+ stop("'row_facet' should not allow multiple selection")
|
| 743 | -! | +||
| 212 | +
- expr = ggplot(ANL[ANL[[g_var]] != "NA", ], aes(dist_var_name, col = s_var_name)) ++ } |
||
| 744 | +213 | ! |
- geom_histogram(+ checkmate::assert_list(col_facet, types = "data_extract_spec", null.ok = TRUE) |
| 745 | +214 | ! |
- position = "identity",+ if (!all(vapply(col_facet, function(x) !x$select$multiple, logical(1)))) {
|
| 746 | +215 | ! |
- aes(y = after_stat(m_type), fill = s_var), bins = bins_var, alpha = 0.3+ stop("'col_facet' should not allow multiple selection")
|
| 747 | +216 |
- ) ++ } |
|
| 748 | +217 | ! |
- facet_wrap(~g_var_name, ncol = 1, scales = scales_raw),+ checkmate::assert_list(color, types = "data_extract_spec", null.ok = TRUE) |
| 749 | +218 | ! |
- env = list(+ if (!all(vapply(color, function(x) !x$select$multiple, logical(1)))) {
|
| 750 | +219 | ! |
- m_type = as.name(m_type),+ stop("'color' should not allow multiple selection")
|
| 751 | -! | +||
| 220 | +
- bins_var = bins_var,+ } |
||
| 752 | +221 | ! |
- dist_var_name = dist_var_name,+ checkmate::assert_list(fill, types = "data_extract_spec", null.ok = TRUE) |
| 753 | +222 | ! |
- g_var = g_var,+ if (!all(vapply(fill, function(x) !x$select$multiple, logical(1)))) {
|
| 754 | +223 | ! |
- s_var = as.name(s_var),+ stop("'fill' should not allow multiple selection")
|
| 755 | -! | +||
| 224 | +
- g_var_name = g_var_name,+ } |
||
| 756 | +225 | ! |
- s_var_name = s_var_name,+ checkmate::assert_list(size, types = "data_extract_spec", null.ok = TRUE) |
| 757 | +226 | ! |
- scales_raw = tolower(scales_type)- |
-
| 758 | -- |
- )+ if (!all(vapply(size, function(x) !x$select$multiple, logical(1)))) {
|
|
| 759 | -+ | ||
| 227 | +! |
- )+ stop("'size' should not allow multiple selection")
|
|
| 760 | +228 |
- }+ } |
|
| 761 | +229 | ||
| 762 | +230 | ! |
- if (add_dens_var) {
+ ggtheme <- match.arg(ggtheme) |
| 763 | +231 | ! |
- plot_call <- substitute(+ checkmate::assert_string(label) |
| 764 | +232 | ! |
- expr = plot_call ++ checkmate::assert_flag(use_density) |
| 765 | +233 | ! |
- stat_density(+ checkmate::assert_flag(color_settings) |
| 766 | +234 | ! |
- aes(y = after_stat(const * m_type2)),+ checkmate::assert_flag(free_x_scales) |
| 767 | +235 | ! |
- geom = "line",+ checkmate::assert_flag(free_y_scales) |
| 768 | +236 | ! |
- position = "identity",+ checkmate::assert_flag(rotate_xaxis_labels) |
| 769 | +237 | ! |
- alpha = 0.5,+ checkmate::assert_flag(swap_axes) |
| 770 | +238 | ! |
- size = 2,+ checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE) |
| 771 | +239 | ! |
- n = ndensity- |
-
| 772 | -- |
- ),+ checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height") |
|
| 773 | +240 | ! |
- env = list(+ checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE) |
| 774 | +241 | ! |
- plot_call = plot_call,+ checkmate::assert_numeric( |
| 775 | +242 | ! |
- const = if (main_type_var == "Density") {
+ plot_width[1], |
| 776 | +243 | ! |
- 1+ lower = plot_width[2], upper = plot_width[3], null.ok = TRUE, .var.name = "plot_width" |
| 777 | +244 |
- } else {
+ ) |
|
| 778 | +245 | ! |
- diff(range(qenv[["ANL"]][[dist_var]], na.rm = TRUE)) / bins_var+ checkmate::assert_class(ggplot2_args, "ggplot2_args") |
| 779 | +246 |
- },+ |
|
| 780 | +247 | ! |
- m_type2 = if (main_type_var == "Density") as.name("density") else as.name("count"),
+ if (color_settings) {
|
| 781 | +248 | ! |
- ndensity = ndensity+ if (is.null(color)) {
|
| 782 | -+ | ||
| 249 | +! |
- )+ color <- x |
|
| 783 | -+ | ||
| 250 | +! |
- )+ color[[1]]$select <- teal.transform::select_spec(choices = color[[1]]$select$choices, selected = NULL) |
|
| 784 | +251 |
- }+ } |
|
| 785 | -+ | ||
| 252 | +! |
-
+ if (is.null(fill)) {
|
|
| 786 | +253 | ! |
- if (length(t_dist) != 0 && main_type_var == "Density" && length(g_var) == 0 && length(s_var) == 0) {
+ fill <- x |
| 787 | +254 | ! |
- qenv <- teal.code::eval_code(+ fill[[1]]$select <- teal.transform::select_spec(choices = fill[[1]]$select$choices, selected = NULL) |
| 788 | -! | +||
| 255 | +
- qenv,+ } |
||
| 789 | +256 | ! |
- substitute(+ if (is.null(size)) {
|
| 790 | +257 | ! |
- df_params <- as.data.frame(append(params, list(name = t_dist))),+ size <- x |
| 791 | +258 | ! |
- env = list(t_dist = t_dist)+ size[[1]]$select <- teal.transform::select_spec(choices = size[[1]]$select$choices, selected = NULL) |
| 792 | +259 |
- )+ } |
|
| 793 | +260 |
- )+ } else {
|
|
| 794 | +261 | ! |
- datas <- quote(data.frame(x = 0.7, y = 1, tb = I(list(df_params = df_params))))+ if (!is.null(c(color, fill, size))) {
|
| 795 | +262 | ! |
- label <- quote(tb)+ stop("'color_settings' argument needs to be set to TRUE if 'color', 'fill', and/or 'size' is/are supplied.")
|
| 796 | +263 |
-
+ } |
|
| 797 | -! | +||
| 264 | +
- plot_call <- substitute(+ } |
||
| 798 | -! | +||
| 265 | +
- expr = plot_call + ggpp::geom_table_npc(+ |
||
| 799 | +266 | ! |
- data = data,+ args <- as.list(environment()) |
| 800 | -! | +||
| 267 | +
- aes(npcx = x, npcy = y, label = label),+ |
||
| 801 | +268 | ! |
- hjust = 0, vjust = 1, size = 4- |
-
| 802 | -- |
- ),+ data_extract_list <- list( |
|
| 803 | +269 | ! |
- env = list(plot_call = plot_call, data = datas, label = label)+ x = x, |
| 804 | -+ | ||
| 270 | +! |
- )+ y = y, |
|
| 805 | -+ | ||
| 271 | +! |
- }+ row_facet = row_facet, |
|
| 806 | -+ | ||
| 272 | +! |
-
+ col_facet = col_facet, |
|
| 807 | +273 | ! |
- if (length(s_var) == 0 && length(g_var) == 0 && main_type_var == "Density" &&+ color_settings = color_settings, |
| 808 | +274 | ! |
- length(t_dist) != 0 && main_type_var == "Density") {
+ color = color, |
| 809 | +275 | ! |
- map_dist <- stats::setNames(+ fill = fill, |
| 810 | +276 | ! |
- c("dnorm", "dlnorm", "dgamma", "dunif"),
+ size = size |
| 811 | -! | +||
| 277 | +
- c("normal", "lognormal", "gamma", "unif")
+ ) |
||
| 812 | +278 |
- )+ |
|
| 813 | +279 | ! |
- plot_call <- substitute(+ module( |
| 814 | +280 | ! |
- expr = plot_call + stat_function(+ label = label, |
| 815 | +281 | ! |
- data = data.frame(x = range(ANL[[dist_var]]), color = mapped_dist),+ server = srv_g_bivariate, |
| 816 | +282 | ! |
- aes(x, color = color),+ ui = ui_g_bivariate, |
| 817 | +283 | ! |
- fun = mapped_dist_name,+ ui_args = args, |
| 818 | +284 | ! |
- n = ndensity,+ server_args = c( |
| 819 | +285 | ! |
- size = 2,+ data_extract_list, |
| 820 | +286 | ! |
- args = params+ list(plot_height = plot_height, plot_width = plot_width, ggplot2_args = ggplot2_args) |
| 821 | +287 |
- ) ++ ), |
|
| 822 | +288 | ! |
- scale_color_manual(values = stats::setNames("blue", mapped_dist), aesthetics = "color"),
+ datanames = teal.transform::get_extract_datanames(data_extract_list) |
| 823 | -! | +||
| 289 | +
- env = list(+ ) |
||
| 824 | -! | +||
| 290 | +
- plot_call = plot_call,+ } |
||
| 825 | -! | +||
| 291 | +
- dist_var = dist_var,+ + |
+ ||
| 292 | ++ |
+ ui_g_bivariate <- function(id, ...) {
|
|
| 826 | +293 | ! |
- ndensity = ndensity,+ args <- list(...) |
| 827 | +294 | ! |
- mapped_dist = unname(map_dist[t_dist]),+ is_single_dataset_value <- teal.transform::is_single_dataset( |
| 828 | +295 | ! |
- mapped_dist_name = as.name(unname(map_dist[t_dist]))+ args$x, args$y, args$row_facet, args$col_facet, args$color, args$fill, args$size |
| 829 | +296 |
- )+ ) |
|
| 830 | -- |
- )- |
- |
| 831 | -- |
- }- |
- |
| 832 | +297 | ||
| 833 | +298 | ! |
- all_ggplot2_args <- teal.widgets::resolve_ggplot2_args(+ ns <- NS(id) |
| 834 | +299 | ! |
- user_plot = ggplot2_args[["Histogram"]],+ teal.widgets::standard_layout( |
| 835 | +300 | ! |
- user_default = ggplot2_args$default+ output = teal.widgets::white_small_well( |
| 836 | -+ | ||
| 301 | +! |
- )+ tags$div(teal.widgets::plot_with_settings_ui(id = ns("myplot")))
|
|
| 837 | +302 |
-
+ ), |
|
| 838 | +303 | ! |
- parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(+ encoding = div( |
| 839 | -! | +||
| 304 | +
- all_ggplot2_args,+ ### Reporter |
||
| 840 | +305 | ! |
- ggtheme = ggtheme- |
-
| 841 | -- |
- )+ teal.reporter::simple_reporter_ui(ns("simple_reporter")),
|
|
| 842 | +306 |
-
+ ### |
|
| 843 | +307 | ! |
- teal.code::eval_code(+ tags$label("Encodings", class = "text-primary"),
|
| 844 | +308 | ! |
- qenv,+ teal.transform::datanames_input(args[c("x", "y", "row_facet", "col_facet", "color", "fill", "size")]),
|
| 845 | +309 | ! |
- substitute(+ teal.transform::data_extract_ui( |
| 846 | +310 | ! |
- expr = {
+ id = ns("x"),
|
| 847 | +311 | ! |
- g <- plot_call+ label = "X variable", |
| 848 | +312 | ! |
- print(g)- |
-
| 849 | -- |
- },+ data_extract_spec = args$x, |
|
| 850 | +313 | ! |
- env = list(plot_call = Reduce(function(x, y) call("+", x, y), c(plot_call, parsed_ggplot2_args)))
- |
-
| 851 | -- |
- )- |
- |
| 852 | -- |
- )- |
- |
| 853 | -- |
- }- |
- |
| 854 | -- |
- )- |
- |
| 855 | -- |
-
+ is_single_dataset = is_single_dataset_value |
|
| 856 | +314 |
- # qqplot qenv ----- |
- |
| 857 | -! | -
- qq_q <- eventReactive(+ ), |
|
| 858 | +315 | ! |
- eventExpr = {
+ teal.transform::data_extract_ui( |
| 859 | +316 | ! |
- common_q()+ id = ns("y"),
|
| 860 | +317 | ! |
- input$scales_type+ label = "Y variable", |
| 861 | +318 | ! |
- input$qq_line+ data_extract_spec = args$y, |
| 862 | +319 | ! |
- is.null(input$ggtheme)+ is_single_dataset = is_single_dataset_value |
| 863 | +320 |
- },+ ), |
|
| 864 | +321 | ! |
- valueExpr = {
+ conditionalPanel( |
| 865 | +322 | ! |
- dist_var <- merge_vars()$dist_var+ condition = |
| 866 | +323 | ! |
- s_var <- merge_vars()$s_var+ "$(\"button[data-id*='-x-dataset'][data-id$='-select']\").text() == '- Nothing selected - ' || |
| 867 | +324 | ! |
- g_var <- merge_vars()$g_var+ $(\"button[data-id*='-y-dataset'][data-id$='-select']\").text() == '- Nothing selected - ' ", |
| 868 | +325 | ! |
- dist_var_name <- merge_vars()$dist_var_name+ shinyWidgets::radioGroupButtons( |
| 869 | +326 | ! |
- s_var_name <- merge_vars()$s_var_name+ inputId = ns("use_density"),
|
| 870 | +327 | ! |
- g_var_name <- merge_vars()$g_var_name+ label = NULL, |
| 871 | +328 | ! |
- t_dist <- input$t_dist+ choices = c("frequency", "density"),
|
| 872 | +329 | ! |
- dist_param1 <- input$dist_param1+ selected = ifelse(args$use_density, "density", "frequency"), |
| 873 | +330 | ! |
- dist_param2 <- input$dist_param2+ justified = TRUE |
| 874 | +331 |
-
+ ) |
|
| 875 | -! | +||
| 332 | +
- scales_type <- input$scales_type+ ), |
||
| 876 | +333 | ! |
- ggtheme <- input$ggtheme+ if (!is.null(args$row_facet) || !is.null(args$col_facet)) {
|
| 877 | -+ | ||
| 334 | +! |
-
+ div( |
|
| 878 | +335 | ! |
- teal::validate_inputs(iv_r_dist(), iv_dist)+ class = "data-extract-box", |
| 879 | -+ | ||
| 336 | +! |
-
+ tags$label("Facetting"),
|
|
| 880 | +337 | ! |
- qenv <- common_q()+ shinyWidgets::switchInput(inputId = ns("facetting"), value = args$facet, size = "mini"),
|
| 881 | -+ | ||
| 338 | +! |
-
+ conditionalPanel( |
|
| 882 | +339 | ! |
- plot_call <- if (length(s_var) == 0 && length(g_var) == 0) {
+ condition = paste0("input['", ns("facetting"), "']"),
|
| 883 | +340 | ! |
- substitute(+ div( |
| 884 | +341 | ! |
- expr = ggplot(ANL, aes_string(sample = dist_var)),+ if (!is.null(args$row_facet)) {
|
| 885 | +342 | ! |
- env = list(dist_var = dist_var)+ teal.transform::data_extract_ui( |
| 886 | -+ | ||
| 343 | +! |
- )+ id = ns("row_facet"),
|
|
| 887 | +344 | ! |
- } else if (length(s_var) != 0 && length(g_var) == 0) {
+ label = "Row facetting variable", |
| 888 | +345 | ! |
- substitute(+ data_extract_spec = args$row_facet, |
| 889 | +346 | ! |
- expr = ggplot(ANL, aes_string(sample = dist_var, color = s_var)),+ is_single_dataset = is_single_dataset_value |
| 890 | -! | +||
| 347 | +
- env = list(dist_var = dist_var, s_var = s_var)+ ) |
||
| 891 | +348 |
- )+ }, |
|
| 892 | +349 | ! |
- } else if (length(s_var) == 0 && length(g_var) != 0) {
+ if (!is.null(args$col_facet)) {
|
| 893 | +350 | ! |
- substitute(+ teal.transform::data_extract_ui( |
| 894 | +351 | ! |
- expr = ggplot(ANL[ANL[[g_var]] != "NA", ], aes_string(sample = dist_var)) ++ id = ns("col_facet"),
|
| 895 | +352 | ! |
- facet_wrap(~g_var_name, ncol = 1, scales = scales_raw),+ label = "Column facetting variable", |
| 896 | +353 | ! |
- env = list(+ data_extract_spec = args$col_facet, |
| 897 | +354 | ! |
- dist_var = dist_var,+ is_single_dataset = is_single_dataset_value |
| 898 | -! | +||
| 355 | +
- g_var = g_var,+ )+ |
+ ||
| 356 | ++ |
+ }, |
|
| 899 | +357 | ! |
- g_var_name = g_var_name,+ checkboxInput(ns("free_x_scales"), "free x scales", value = args$free_x_scales),
|
| 900 | +358 | ! |
- scales_raw = tolower(scales_type)+ checkboxInput(ns("free_y_scales"), "free y scales", value = args$free_y_scales)
|
| 901 | +359 |
) |
|
| 902 | +360 |
) |
|
| 903 | +361 |
- } else {
+ ) |
|
| 904 | -! | +||
| 362 | +
- substitute(+ }, |
||
| 905 | +363 | ! |
- expr = ggplot(ANL[ANL[[g_var]] != "NA", ], aes_string(sample = dist_var, color = s_var)) ++ if (args$color_settings) {
|
| 906 | -! | +||
| 364 | +
- facet_wrap(~g_var_name, ncol = 1, scales = scales_raw),+ # Put a grey border around the coloring settings |
||
| 907 | +365 | ! |
- env = list(+ div( |
| 908 | +366 | ! |
- dist_var = dist_var,+ class = "data-extract-box", |
| 909 | +367 | ! |
- g_var = g_var,+ tags$label("Color settings"),
|
| 910 | +368 | ! |
- s_var = s_var,+ shinyWidgets::switchInput(inputId = ns("coloring"), value = TRUE, size = "mini"),
|
| 911 | +369 | ! |
- g_var_name = g_var_name,+ conditionalPanel( |
| 912 | +370 | ! |
- scales_raw = tolower(scales_type)- |
-
| 913 | -- |
- )+ condition = paste0("input['", ns("coloring"), "']"),
|
|
| 914 | -+ | ||
| 371 | +! |
- )+ div( |
|
| 915 | -+ | ||
| 372 | +! |
- }+ teal.transform::data_extract_ui( |
|
| 916 | -+ | ||
| 373 | +! |
-
+ id = ns("color"),
|
|
| 917 | +374 | ! |
- map_dist <- stats::setNames(+ label = "Outline color by variable", |
| 918 | +375 | ! |
- c("qnorm", "qlnorm", "qgamma", "qunif"),
+ data_extract_spec = args$color, |
| 919 | +376 | ! |
- c("normal", "lognormal", "gamma", "unif")
+ is_single_dataset = is_single_dataset_value |
| 920 | +377 |
- )+ ), |
|
| 921 | -+ | ||
| 378 | +! |
-
+ teal.transform::data_extract_ui( |
|
| 922 | +379 | ! |
- plot_call <- substitute(+ id = ns("fill"),
|
| 923 | +380 | ! |
- expr = plot_call ++ label = "Fill color by variable", |
| 924 | +381 | ! |
- stat_qq(distribution = mapped_dist, dparams = params),+ data_extract_spec = args$fill, |
| 925 | +382 | ! |
- env = list(plot_call = plot_call, mapped_dist = as.name(unname(map_dist[t_dist])))+ is_single_dataset = is_single_dataset_value |
| 926 | +383 |
- )+ ), |
|
| 927 | -+ | ||
| 384 | +! |
-
+ div( |
|
| 928 | +385 | ! |
- if (length(t_dist) != 0 && length(g_var) == 0 && length(s_var) == 0) {
+ id = ns("size_settings"),
|
| 929 | +386 | ! |
- qenv <- teal.code::eval_code(+ teal.transform::data_extract_ui( |
| 930 | +387 | ! |
- qenv,+ id = ns("size"),
|
| 931 | +388 | ! |
- substitute(+ label = "Size of points by variable (only if x and y are numeric)", |
| 932 | +389 | ! |
- df_params <- as.data.frame(append(params, list(name = t_dist))),+ data_extract_spec = args$size, |
| 933 | +390 | ! |
- env = list(t_dist = t_dist)+ is_single_dataset = is_single_dataset_value |
| 934 | +391 |
- )+ ) |
|
| 935 | +392 |
- )+ ) |
|
| 936 | -! | +||
| 393 | +
- datas <- quote(data.frame(x = 0.7, y = 1, tb = I(list(df_params = df_params))))+ ) |
||
| 937 | -! | +||
| 394 | +
- label <- quote(tb)+ ) |
||
| 938 | +395 |
-
+ ) |
|
| 939 | -! | +||
| 396 | +
- plot_call <- substitute(+ }, |
||
| 940 | +397 | ! |
- expr = plot_call ++ teal.widgets::panel_group( |
| 941 | +398 | ! |
- ggpp::geom_table_npc(+ teal.widgets::panel_item( |
| 942 | +399 | ! |
- data = data,+ title = "Plot settings", |
| 943 | +400 | ! |
- aes(npcx = x, npcy = y, label = label),+ checkboxInput(ns("rotate_xaxis_labels"), "Rotate X axis labels", value = args$rotate_xaxis_labels),
|
| 944 | +401 | ! |
- hjust = 0,+ checkboxInput(ns("swap_axes"), "Swap axes", value = args$swap_axes),
|
| 945 | +402 | ! |
- vjust = 1,+ selectInput( |
| 946 | +403 | ! |
- size = 4- |
-
| 947 | -- |
- ),+ inputId = ns("ggtheme"),
|
|
| 948 | +404 | ! |
- env = list(+ label = "Theme (by ggplot):", |
| 949 | +405 | ! |
- plot_call = plot_call,+ choices = ggplot_themes, |
| 950 | +406 | ! |
- data = datas,+ selected = args$ggtheme, |
| 951 | +407 | ! |
- label = label+ multiple = FALSE |
| 952 | +408 |
- )+ ), |
|
| 953 | -+ | ||
| 409 | +! |
- )+ sliderInput( |
|
| 954 | -+ | ||
| 410 | +! |
- }+ ns("alpha"), "Opacity Scatterplot:",
|
|
| 955 | -+ | ||
| 411 | +! |
-
+ min = 0, max = 1, |
|
| 956 | +412 | ! |
- if (isTRUE(input$qq_line)) {
+ step = .05, value = .5, ticks = FALSE+ |
+
| 413 | ++ |
+ ), |
|
| 957 | +414 | ! |
- plot_call <- substitute(+ sliderInput( |
| 958 | +415 | ! |
- expr = plot_call ++ ns("fixed_size"), "Scatterplot point size:",
|
| 959 | +416 | ! |
- stat_qq_line(distribution = mapped_dist, dparams = params),+ min = 1, max = 8, |
| 960 | +417 | ! |
- env = list(plot_call = plot_call, mapped_dist = as.name(unname(map_dist[t_dist])))+ step = 1, value = 2, ticks = FALSE |
| 961 | +418 |
- )+ ),+ |
+ |
| 419 | +! | +
+ checkboxInput(ns("add_lines"), "Add lines"),
|
|
| 962 | +420 |
- }+ ) |
|
| 963 | +421 |
-
+ ) |
|
| 964 | -! | +||
| 422 | +
- all_ggplot2_args <- teal.widgets::resolve_ggplot2_args(+ ), |
||
| 965 | +423 | ! |
- user_plot = ggplot2_args[["QQplot"]],+ forms = tagList( |
| 966 | +424 | ! |
- user_default = ggplot2_args$default,+ teal.widgets::verbatim_popup_ui(ns("warning"), button_label = "Show Warnings"),
|
| 967 | +425 | ! |
- module_plot = teal.widgets::ggplot2_args(labs = list(x = "theoretical", y = "sample"))+ teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code")
|
| 968 | +426 |
- )+ ), |
|
| 969 | -+ | ||
| 427 | +! |
-
+ pre_output = args$pre_output, |
|
| 970 | +428 | ! |
- parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(+ post_output = args$post_output |
| 971 | -! | +||
| 429 | +
- all_ggplot2_args,+ ) |
||
| 972 | -! | +||
| 430 | +
- ggtheme = ggtheme+ } |
||
| 973 | +431 |
- )+ |
|
| 974 | +432 | ||
| 975 | -! | +||
| 433 | +
- teal.code::eval_code(+ srv_g_bivariate <- function(id, |
||
| 976 | -! | +||
| 434 | +
- qenv,+ data, |
||
| 977 | -! | +||
| 435 | +
- substitute(+ reporter, |
||
| 978 | -! | +||
| 436 | +
- expr = {
+ filter_panel_api, |
||
| 979 | -! | +||
| 437 | +
- g <- plot_call+ x, |
||
| 980 | -! | +||
| 438 | +
- print(g)+ y, |
||
| 981 | +439 |
- },+ row_facet, |
|
| 982 | -! | +||
| 440 | +
- env = list(plot_call = Reduce(function(x, y) call("+", x, y), c(plot_call, parsed_ggplot2_args)))
+ col_facet, |
||
| 983 | +441 |
- )+ color_settings = FALSE, |
|
| 984 | +442 |
- )+ color, |
|
| 985 | +443 |
- }+ fill, |
|
| 986 | +444 |
- )+ size, |
|
| 987 | +445 |
-
+ plot_height, |
|
| 988 | +446 |
- # test qenv ----+ plot_width, |
|
| 989 | -! | +||
| 447 | +
- test_q <- eventReactive(+ ggplot2_args) {
|
||
| 990 | +448 | ! |
- ignoreNULL = FALSE,+ with_reporter <- !missing(reporter) && inherits(reporter, "Reporter") |
| 991 | +449 | ! |
- eventExpr = {
+ with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI") |
| 992 | +450 | ! |
- common_q()+ checkmate::assert_class(data, "reactive") |
| 993 | +451 | ! |
- input$dist_param1+ checkmate::assert_class(isolate(data()), "teal_data") |
| 994 | +452 | ! |
- input$dist_param2+ moduleServer(id, function(input, output, session) {
|
| 995 | +453 | ! |
- input$dist_tests+ data_extract <- list( |
| 996 | -+ | ||
| 454 | +! |
- },+ x = x, y = y, row_facet = row_facet, col_facet = col_facet, |
|
| 997 | +455 | ! |
- valueExpr = {
+ color = color, fill = fill, size = size |
| 998 | +456 |
- # Create a private stack for this function only.+ )+ |
+ |
| 457 | ++ | + | |
| 999 | +458 | ! |
- ANL <- common_q()[["ANL"]] # nolint: object_name.+ rule_var <- function(other) {
|
| 1000 | -+ | ||
| 459 | +! |
-
+ function(value) {
|
|
| 1001 | +460 | ! |
- dist_var <- merge_vars()$dist_var+ othervalue <- selector_list()[[other]]()$select |
| 1002 | +461 | ! |
- s_var <- merge_vars()$s_var+ if (length(value) == 0L && length(othervalue) == 0L) {
|
| 1003 | +462 | ! |
- g_var <- merge_vars()$g_var+ "Please select at least one of x-variable or y-variable" |
| 1004 | +463 |
-
+ } |
|
| 1005 | -! | +||
| 464 | +
- dist_var_name <- merge_vars()$dist_var_name+ } |
||
| 1006 | -! | +||
| 465 | +
- s_var_name <- merge_vars()$s_var_name+ } |
||
| 1007 | +466 | ! |
- g_var_name <- merge_vars()$g_var_name+ rule_diff <- function(other) {
|
| 1008 | -+ | ||
| 467 | +! |
-
+ function(value) {
|
|
| 1009 | +468 | ! |
- dist_param1 <- input$dist_param1+ othervalue <- selector_list()[[other]]()[["select"]] |
| 1010 | +469 | ! |
- dist_param2 <- input$dist_param2+ if (!is.null(othervalue)) {
|
| 1011 | +470 | ! |
- dist_tests <- input$dist_tests+ if (identical(value, othervalue)) {
|
| 1012 | +471 | ! |
- t_dist <- input$t_dist+ "Row and column facetting variables must be different." |
| 1013 | +472 |
-
+ } |
|
| 1014 | -! | +||
| 473 | +
- validate(need(dist_tests, "Please select a test"))+ } |
||
| 1015 | +474 |
-
+ } |
|
| 1016 | -! | +||
| 475 | +
- teal::validate_inputs(iv_dist)+ } |
||
| 1017 | +476 | ||
| 1018 | +477 | ! |
- if (length(s_var) > 0 || length(g_var) > 0) {
+ selector_list <- teal.transform::data_extract_multiple_srv( |
| 1019 | +478 | ! |
- counts <- ANL %>%+ data_extract = data_extract, |
| 1020 | +479 | ! |
- dplyr::group_by_at(dplyr::vars(dplyr::any_of(c(s_var, g_var)))) %>%+ datasets = data, |
| 1021 | +480 | ! |
- dplyr::summarise(n = dplyr::n())+ select_validation_rule = list( |
| 1022 | -+ | ||
| 481 | +! |
-
+ x = rule_var("y"),
|
|
| 1023 | +482 | ! |
- validate(need(all(counts$n > 5), "Please select strata*group with at least 5 observation each."))+ y = rule_var("x"),
|
| 1024 | -+ | ||
| 483 | +! |
- }+ row_facet = shinyvalidate::compose_rules( |
|
| 1025 | -+ | ||
| 484 | +! |
-
+ shinyvalidate::sv_optional(),+ |
+ |
| 485 | +! | +
+ rule_diff("col_facet")
|
|
| 1026 | +486 |
-
+ ), |
|
| 1027 | +487 | ! |
- if (dist_tests %in% c(+ col_facet = shinyvalidate::compose_rules( |
| 1028 | +488 | ! |
- "t-test (two-samples, not paired)",+ shinyvalidate::sv_optional(), |
| 1029 | +489 | ! |
- "F-test",+ rule_diff("row_facet")
|
| 1030 | -! | +||
| 490 | +
- "Kolmogorov-Smirnov (two-samples)"+ ) |
||
| 1031 | +491 |
- )) {
+ ) |
|
| 1032 | -! | +||
| 492 | +
- if (length(g_var) == 0 && length(s_var) > 0) {
+ ) |
||
| 1033 | -! | +||
| 493 | +
- validate(need(+ |
||
| 1034 | +494 | ! |
- length(unique(ANL[[s_var]])) == 2,+ iv_r <- reactive({
|
| 1035 | +495 | ! |
- "Please select stratify variable with 2 levels."- |
-
| 1036 | -- |
- ))- |
- |
| 1037 | -- |
- }+ iv_facet <- shinyvalidate::InputValidator$new() |
|
| 1038 | +496 | ! |
- if (length(g_var) > 0 && length(s_var) > 0) {
+ iv_child <- teal.transform::compose_and_enable_validators(iv_facet, selector_list, |
| 1039 | +497 | ! |
- validate(need(+ validator_names = c("row_facet", "col_facet")
|
| 1040 | -! | +||
| 498 | +
- all(stats::na.omit(as.vector(+ ) |
||
| 1041 | +499 | ! |
- tapply(ANL[[s_var]], list(ANL[[g_var]]), function(x) length(unique(x))) == 2+ iv_child$condition(~ isTRUE(input$facetting)) |
| 1042 | +500 |
- ))),+ |
|
| 1043 | +501 | ! |
- "Please select stratify variable with 2 levels, per each group."+ iv <- shinyvalidate::InputValidator$new() |
| 1044 | -+ | ||
| 502 | +! |
- ))+ iv$add_validator(iv_child) |
|
| 1045 | -+ | ||
| 503 | +! |
- }+ teal.transform::compose_and_enable_validators(iv, selector_list, validator_names = c("x", "y"))
|
|
| 1046 | +504 |
- }+ }) |
|
| 1047 | +505 | ||
| 1048 | +506 | ! |
- map_dist <- stats::setNames(+ anl_merged_input <- teal.transform::merge_expression_srv( |
| 1049 | +507 | ! |
- c("pnorm", "plnorm", "pgamma", "punif"),
+ selector_list = selector_list, |
| 1050 | +508 | ! |
- c("normal", "lognormal", "gamma", "unif")
+ datasets = data |
| 1051 | +509 |
- )+ )+ |
+ |
| 510 | ++ | + | |
| 1052 | +511 | ! |
- sks_args <- list(+ anl_merged_q <- reactive({
|
| 1053 | +512 | ! |
- test = quote(stats::ks.test),+ req(anl_merged_input()) |
| 1054 | +513 | ! |
- args = bquote(append(list(.[[.(dist_var)]], .(map_dist[t_dist])), params)),+ data() %>% |
| 1055 | +514 | ! |
- groups = c(g_var, s_var)+ teal.code::eval_code(as.expression(anl_merged_input()$expr)) |
| 1056 | +515 |
- )+ }) |
|
| 1057 | -! | +||
| 516 | +
- ssw_args <- list(+ |
||
| 1058 | +517 | ! |
- test = quote(stats::shapiro.test),+ merged <- list( |
| 1059 | +518 | ! |
- args = bquote(list(.[[.(dist_var)]])),+ anl_input_r = anl_merged_input, |
| 1060 | +519 | ! |
- groups = c(g_var, s_var)+ anl_q_r = anl_merged_q |
| 1061 | +520 |
- )+ )+ |
+ |
| 521 | ++ | + | |
| 1062 | +522 | ! |
- mfil_args <- list(+ output_q <- reactive({
|
| 1063 | +523 | ! |
- test = quote(stats::fligner.test),+ teal::validate_inputs(iv_r())+ |
+
| 524 | ++ | + | |
| 1064 | +525 | ! |
- args = bquote(list(.[[.(dist_var)]], .[[.(s_var)]])),+ ANL <- merged$anl_q_r()[["ANL"]] # nolint: object_name. |
| 1065 | +526 | ! |
- groups = c(g_var)+ teal::validate_has_data(ANL, 3) |
| 1066 | +527 |
- )+ |
|
| 1067 | +528 | ! |
- sad_args <- list(+ x_col_vec <- as.vector(merged$anl_input_r()$columns_source$x) |
| 1068 | +529 | ! |
- test = quote(goftest::ad.test),+ x_name <- `if`(is.null(x_col_vec), character(0), x_col_vec) |
| 1069 | +530 | ! |
- args = bquote(append(list(.[[.(dist_var)]], .(map_dist[t_dist])), params)),+ y_col_vec <- as.vector(merged$anl_input_r()$columns_source$y) |
| 1070 | +531 | ! |
- groups = c(g_var, s_var)+ y_name <- `if`(is.null(y_col_vec), character(0), y_col_vec) |
| 1071 | +532 |
- )+ |
|
| 1072 | +533 | ! |
- scvm_args <- list(+ row_facet_name <- as.vector(merged$anl_input_r()$columns_source$row_facet) |
| 1073 | +534 | ! |
- test = quote(goftest::cvm.test),+ col_facet_name <- as.vector(merged$anl_input_r()$columns_source$col_facet) |
| 1074 | +535 | ! |
- args = bquote(append(list(.[[.(dist_var)]], .(map_dist[t_dist])), params)),+ color_name <- if ("color" %in% names(merged$anl_input_r()$columns_source)) {
|
| 1075 | +536 | ! |
- groups = c(g_var, s_var)+ as.vector(merged$anl_input_r()$columns_source$color) |
| 1076 | +537 |
- )+ } else {
|
|
| 1077 | +538 | ! |
- manov_args <- list(+ character(0) |
| 1078 | -! | +||
| 539 | +
- test = quote(stats::aov),+ } |
||
| 1079 | +540 | ! |
- args = bquote(list(stats::formula(.(dist_var_name) ~ .(s_var_name)), .)),+ fill_name <- if ("fill" %in% names(merged$anl_input_r()$columns_source)) {
|
| 1080 | +541 | ! |
- groups = c(g_var)+ as.vector(merged$anl_input_r()$columns_source$fill) |
| 1081 | +542 |
- )+ } else {
|
|
| 1082 | +543 | ! |
- mt_args <- list(+ character(0) |
| 1083 | -! | +||
| 544 | +
- test = quote(stats::t.test),+ } |
||
| 1084 | +545 | ! |
- args = bquote(unname(split(.[[.(dist_var)]], .[[.(s_var)]], drop = TRUE))),+ size_name <- if ("size" %in% names(merged$anl_input_r()$columns_source)) {
|
| 1085 | +546 | ! |
- groups = c(g_var)+ as.vector(merged$anl_input_r()$columns_source$size) |
| 1086 | +547 |
- )+ } else {
|
|
| 1087 | +548 | ! |
- mv_args <- list(+ character(0) |
| 1088 | -! | +||
| 549 | +
- test = quote(stats::var.test),+ } |
||
| 1089 | -! | +||
| 550 | +
- args = bquote(unname(split(.[[.(dist_var)]], .[[.(s_var)]], drop = TRUE))),+ |
||
| 1090 | +551 | ! |
- groups = c(g_var)- |
-
| 1091 | -- |
- )+ use_density <- input$use_density == "density" |
|
| 1092 | +552 | ! |
- mks_args <- list(+ free_x_scales <- input$free_x_scales |
| 1093 | +553 | ! |
- test = quote(stats::ks.test),+ free_y_scales <- input$free_y_scales |
| 1094 | +554 | ! |
- args = bquote(unname(split(.[[.(dist_var)]], .[[.(s_var)]], drop = TRUE))),+ ggtheme <- input$ggtheme |
| 1095 | +555 | ! |
- groups = c(g_var)+ rotate_xaxis_labels <- input$rotate_xaxis_labels |
| 1096 | -+ | ||
| 556 | +! |
- )+ swap_axes <- input$swap_axes |
|
| 1097 | +557 | ||
| 1098 | +558 | ! |
- tests_base <- switch(dist_tests,+ is_scatterplot <- all(vapply(ANL[c(x_name, y_name)], is.numeric, logical(1))) && |
| 1099 | +559 | ! |
- "Kolmogorov-Smirnov (one-sample)" = sks_args,+ length(x_name) > 0 && length(y_name) > 0 |
| 1100 | -! | +||
| 560 | +
- "Shapiro-Wilk" = ssw_args,+ |
||
| 1101 | +561 | ! |
- "Fligner-Killeen" = mfil_args,+ if (is_scatterplot) {
|
| 1102 | +562 | ! |
- "one-way ANOVA" = manov_args,+ shinyjs::show("alpha")
|
| 1103 | +563 | ! |
- "t-test (two-samples, not paired)" = mt_args,+ alpha <- input$alpha |
| 1104 | +564 | ! |
- "F-test" = mv_args,+ shinyjs::show("add_lines")
+ |
+
| 565 | ++ | + | |
| 1105 | +566 | ! |
- "Kolmogorov-Smirnov (two-samples)" = mks_args,+ if (color_settings && input$coloring) {
|
| 1106 | +567 | ! |
- "Anderson-Darling (one-sample)" = sad_args,+ shinyjs::hide("fixed_size")
|
| 1107 | +568 | ! |
- "Cramer-von Mises (one-sample)" = scvm_args+ shinyjs::show("size_settings")
|
| 1108 | -+ | ||
| 569 | +! |
- )+ size <- NULL |
|
| 1109 | +570 |
-
+ } else {
|
|
| 1110 | +571 | ! |
- env <- list(+ shinyjs::show("fixed_size")
|
| 1111 | +572 | ! |
- t_test = t_dist,+ size <- input$fixed_size |
| 1112 | -! | +||
| 573 | +
- dist_var = dist_var,+ } |
||
| 1113 | -! | +||
| 574 | +
- g_var = g_var,+ } else {
|
||
| 1114 | +575 | ! |
- s_var = s_var,+ shinyjs::hide("add_lines")
|
| 1115 | +576 | ! |
- args = tests_base$args,+ updateCheckboxInput(session, "add_lines", value = FALSE) |
| 1116 | +577 | ! |
- groups = tests_base$groups,+ shinyjs::hide("alpha")
|
| 1117 | +578 | ! |
- test = tests_base$test,+ shinyjs::hide("fixed_size")
|
| 1118 | +579 | ! |
- dist_var_name = dist_var_name,+ shinyjs::hide("size_settings")
|
| 1119 | +580 | ! |
- g_var_name = g_var_name,+ alpha <- 1 |
| 1120 | +581 | ! |
- s_var_name = s_var_name+ size <- NULL |
| 1121 | +582 |
- )+ } |
|
| 1122 | +583 | ++ | + + | +
| 584 | |||
| 1123 | +585 | ! |
- qenv <- common_q()+ teal::validate_has_data(ANL[, c(x_name, y_name)], 3, complete = TRUE, allow_inf = FALSE) |
| 1124 | +586 | ||
| 1125 | +587 | ! |
- if (length(s_var) == 0 && length(g_var) == 0) {
+ cl <- bivariate_plot_call( |
| 1126 | +588 | ! |
- qenv <- teal.code::eval_code(+ data_name = "ANL", |
| 1127 | +589 | ! |
- qenv,+ x = x_name, |
| 1128 | +590 | ! |
- substitute(+ y = y_name, |
| 1129 | +591 | ! |
- expr = {
+ x_class = ifelse(!identical(x_name, character(0)), class(ANL[[x_name]]), "NULL"), |
| 1130 | +592 | ! |
- test_stats <- ANL %>%+ y_class = ifelse(!identical(y_name, character(0)), class(ANL[[y_name]]), "NULL"), |
| 1131 | +593 | ! |
- dplyr::select(dist_var) %>%+ x_label = varname_w_label(x_name, ANL), |
| 1132 | +594 | ! |
- with(., broom::glance(do.call(test, args))) %>%+ y_label = varname_w_label(y_name, ANL), |
| 1133 | +595 | ! |
- dplyr::mutate_if(is.numeric, round, 3)- |
-
| 1134 | -- |
- },+ freq = !use_density, |
|
| 1135 | +596 | ! |
- env = env- |
-
| 1136 | -- |
- )- |
- |
| 1137 | -- |
- )+ theme = ggtheme, |
|
| 1138 | -+ | ||
| 597 | +! |
- } else {
+ rotate_xaxis_labels = rotate_xaxis_labels, |
|
| 1139 | +598 | ! |
- qenv <- teal.code::eval_code(+ swap_axes = swap_axes, |
| 1140 | +599 | ! |
- qenv,+ alpha = alpha, |
| 1141 | +600 | ! |
- substitute(+ size = size, |
| 1142 | +601 | ! |
- expr = {
+ ggplot2_args = ggplot2_args |
| 1143 | -! | +||
| 602 | +
- test_stats <- ANL %>%+ ) |
||
| 1144 | -! | +||
| 603 | +
- dplyr::select(dist_var, s_var, g_var) %>%+ |
||
| 1145 | +604 | ! |
- dplyr::group_by_at(dplyr::vars(dplyr::any_of(groups))) %>%+ facetting <- (isTRUE(input$facetting) && (!is.null(row_facet_name) || !is.null(col_facet_name))) |
| 1146 | -! | +||
| 605 | +
- dplyr::do(tests = broom::glance(do.call(test, args))) %>%+ |
||
| 1147 | +606 | ! |
- tidyr::unnest(tests) %>%+ if (facetting) {
|
| 1148 | +607 | ! |
- dplyr::mutate_if(is.numeric, round, 3)+ facet_cl <- facet_ggplot_call(row_facet_name, col_facet_name, free_x_scales, free_y_scales) |
| 1149 | +608 |
- },+ |
|
| 1150 | +609 | ! |
- env = env+ if (!is.null(facet_cl)) {
|
| 1151 | -+ | ||
| 610 | +! |
- )+ cl <- call("+", cl, facet_cl)
|
|
| 1152 | +611 |
- )+ } |
|
| 1153 | +612 |
- }- |
- |
| 1154 | -! | -
- qenv %>%+ } |
|
| 1155 | +613 |
- # used to display table when running show-r-code code+ |
|
| 1156 | +614 | ! |
- teal.code::eval_code(quote(test_stats))+ if (input$add_lines) {
|
| 1157 | -+ | ||
| 615 | +! |
- }+ cl <- call("+", cl, quote(geom_line(size = 1)))
|
|
| 1158 | +616 |
- )+ } |
|
| 1159 | +617 | ||
| 1160 | -- |
- # outputs ----- |
- |
| 1161 | -- |
- ## building main qenv- |
- |
| 1162 | +618 | ! |
- output_q <- reactive({
+ coloring_cl <- NULL |
| 1163 | +619 | ! |
- tab <- input$tabs+ if (color_settings) {
|
| 1164 | +620 | ! |
- req(tab) # tab is NULL upon app launch, hence will crash without this statement- |
-
| 1165 | -- |
-
+ if (input$coloring) {
|
|
| 1166 | +621 | ! |
- qenv_final <- common_q()- |
-
| 1167 | -- |
- # wrapped in if since could lead into validate error - we do want to continue+ coloring_cl <- coloring_ggplot_call( |
|
| 1168 | +622 | ! |
- test_r_qenv_out <- try(test_q(), silent = TRUE)+ colour = color_name, |
| 1169 | +623 | ! |
- if (!inherits(test_r_qenv_out, c("try-error", "error"))) {
+ fill = fill_name, |
| 1170 | +624 | ! |
- qenv_final <- teal.code::join(qenv_final, test_q())+ size = size_name, |
| 1171 | -+ | ||
| 625 | +! |
- }+ is_point = any(grepl("geom_point", cl %>% deparse()))
|
|
| 1172 | +626 |
-
+ ) |
|
| 1173 | +627 | ! |
- qenv_final <- if (tab == "Histogram") {
+ legend_lbls <- substitute( |
| 1174 | +628 | ! |
- req(dist_q())+ expr = labs(color = color_name, fill = fill_name, size = size_name), |
| 1175 | +629 | ! |
- teal.code::join(qenv_final, dist_q())+ env = list( |
| 1176 | +630 | ! |
- } else if (tab == "QQplot") {
+ color_name = varname_w_label(color_name, ANL), |
| 1177 | +631 | ! |
- req(qq_q())+ fill_name = varname_w_label(fill_name, ANL), |
| 1178 | +632 | ! |
- teal.code::join(qenv_final, qq_q())+ size_name = varname_w_label(size_name, ANL) |
| 1179 | +633 |
- }+ ) |
|
| 1180 | -! | +||
| 634 | +
- qenv_final+ ) |
||
| 1181 | +635 |
- })+ } |
|
| 1182 | -+ | ||
| 636 | +! |
-
+ if (!is.null(coloring_cl)) {
|
|
| 1183 | +637 | ! |
- dist_r <- reactive(dist_q()[["g"]])+ cl <- call("+", call("+", cl, coloring_cl), legend_lbls)
|
| 1184 | +638 |
-
+ } |
|
| 1185 | -! | +||
| 639 | +
- qq_r <- reactive(qq_q()[["g"]])+ } |
||
| 1186 | +640 | ||
| 1187 | -! | -
- output$summary_table <- DT::renderDataTable(- |
- |
| 1188 | -! | +||
| 641 | +
- expr = if (iv_r()$is_valid()) common_q()[["summary_table"]] else NULL,+ # Add labels to facets |
||
| 1189 | +642 | ! |
- options = list(+ nulled_row_facet_name <- varname_w_label(row_facet_name, ANL) |
| 1190 | +643 | ! |
- autoWidth = TRUE,+ nulled_col_facet_name <- varname_w_label(col_facet_name, ANL) |
| 1191 | +644 | ! |
- columnDefs = list(list(width = "200px", targets = "_all"))+ without_facet <- (is.null(nulled_row_facet_name) && is.null(nulled_col_facet_name)) || !facetting |
| 1192 | +645 |
- ),+ |
|
| 1193 | +646 | ! |
- rownames = FALSE- |
-
| 1194 | -- |
- )- |
- |
| 1195 | -- |
-
+ print_call <- if (without_facet) {
|
|
| 1196 | +647 | ! |
- tests_r <- reactive({
+ quote(print(p)) |
| 1197 | -! | +||
| 648 | +
- req(iv_r()$is_valid())+ } else {
|
||
| 1198 | +649 | ! |
- teal::validate_inputs(iv_r_dist())+ substitute( |
| 1199 | +650 | ! |
- test_q()[["test_stats"]]+ expr = {
|
| 1200 | +651 |
- })+ # Add facetting labels |
|
| 1201 | +652 |
-
+ # optional: grid.newpage() # nolint: commented_code. |
|
| 1202 | +653 | ! |
- pws1 <- teal.widgets::plot_with_settings_srv(+ p <- add_facet_labels(p, xfacet_label = nulled_col_facet_name, yfacet_label = nulled_row_facet_name) |
| 1203 | +654 | ! |
- id = "hist_plot",+ grid::grid.newpage() |
| 1204 | +655 | ! |
- plot_r = dist_r,+ grid::grid.draw(p) |
| 1205 | -! | +||
| 656 | +
- height = plot_height,+ }, |
||
| 1206 | +657 | ! |
- width = plot_width,+ env = list(nulled_col_facet_name = nulled_col_facet_name, nulled_row_facet_name = nulled_row_facet_name) |
| 1207 | -! | +||
| 658 | +
- brushing = FALSE+ ) |
||
| 1208 | +659 |
- )+ } |
|
| 1209 | +660 | ||
| 1210 | +661 | ! |
- pws2 <- teal.widgets::plot_with_settings_srv(+ teal.code::eval_code(merged$anl_q_r(), substitute(expr = p <- cl, env = list(cl = cl))) %>% |
| 1211 | +662 | ! |
- id = "qq_plot",+ teal.code::eval_code(print_call) |
| 1212 | -! | +||
| 663 | +
- plot_r = qq_r,+ }) |
||
| 1213 | -! | +||
| 664 | +
- height = plot_height,+ |
||
| 1214 | +665 | ! |
- width = plot_width,+ plot_r <- shiny::reactive({
|
| 1215 | +666 | ! |
- brushing = FALSE+ output_q()[["p"]] |
| 1216 | +667 |
- )+ }) |
|
| 1217 | +668 | ||
| 1218 | +669 | ! |
- output$t_stats <- DT::renderDataTable(+ pws <- teal.widgets::plot_with_settings_srv( |
| 1219 | +670 | ! |
- expr = tests_r(),+ id = "myplot", |
| 1220 | +671 | ! |
- options = list(scrollX = TRUE),+ plot_r = plot_r, |
| 1221 | +672 | ! |
- rownames = FALSE+ height = plot_height,+ |
+
| 673 | +! | +
+ width = plot_width |
|
| 1222 | +674 |
) |
|
| 1223 | +675 | ||
| 1224 | +676 | ! |
teal.widgets::verbatim_popup_srv( |
| 1225 | +677 | ! |
id = "warning", |
| 1226 | +678 | ! |
verbatim_content = reactive(teal.code::get_warnings(output_q())), |
| 1227 | +679 | ! |
title = "Warning", |
| 1228 | +680 | ! |
disabled = reactive(is.null(teal.code::get_warnings(output_q()))) |
| 1229 | +681 |
) |
|
| 1230 | +682 | ||
| 1231 | +683 | ! |
teal.widgets::verbatim_popup_srv( |
| 1232 | +684 | ! |
id = "rcode", |
| 1233 | +685 | ! |
verbatim_content = reactive(teal.code::get_code(output_q())), |
| 1234 | +686 | ! |
- title = "R Code for distribution"+ title = "Bivariate Plot" |
| 1235 | +687 |
) |
|
| 1236 | +688 | ||
| 1237 | +689 |
### REPORTER |
|
| 1238 | +690 | ! |
if (with_reporter) {
|
| 1239 | +691 | ! |
card_fun <- function(comment, label) {
|
| 1240 | +692 | ! |
card <- teal::report_card_template( |
| 1241 | +693 | ! |
- title = "Distribution Plot",+ title = "Bivariate Plot", |
| 1242 | +694 | ! |
label = label, |
| 1243 | +695 | ! |
with_filter = with_filter, |
| 1244 | +696 | ! |
filter_panel_api = filter_panel_api |
| 1245 | +697 |
) |
|
| 1246 | +698 | ! |
card$append_text("Plot", "header3")
|
| 1247 | +699 | ! |
- if (input$tabs == "Histogram") {
+ card$append_plot(plot_r(), dim = pws$dim()) |
| 1248 | +700 | ! |
- card$append_plot(dist_r(), dim = pws1$dim())+ if (!comment == "") {
|
| 1249 | +701 | ! |
- } else if (input$tabs == "QQplot") {
+ card$append_text("Comment", "header3")
|
| 1250 | +702 | ! |
- card$append_plot(qq_r(), dim = pws2$dim())+ card$append_text(comment) |
| 1251 | +703 |
} |
|
| 1252 | +704 | ! |
- card$append_text("Statistics table", "header3")
- |
-
| 1253 | -- |
-
+ card$append_src(teal.code::get_code(output_q())) |
|
| 1254 | +705 | ! |
- card$append_table(common_q()[["summary_table"]])+ card |
| 1255 | -! | +||
| 706 | +
- tests_error <- tryCatch(expr = tests_r(), error = function(e) "error")+ } |
||
| 1256 | +707 | ! |
- if (inherits(tests_error, "data.frame")) {
+ teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
|
| 1257 | -! | +||
| 708 | +
- card$append_text("Tests table", "header3")
+ } |
||
| 1258 | -! | +||
| 709 | +
- card$append_table(tests_r())+ ### |
||
| 1259 | +710 |
- }+ }) |
|
| 1260 | +711 |
-
+ } |
|
| 1261 | -! | +||
| 712 | +
- if (!comment == "") {
+
|
||
| 1262 | -! | +||
| 713 | +
- card$append_text("Comment", "header3")
+
|
||
| 1263 | -! | +||
| 714 | +
- card$append_text(comment)+ #' Get Substituted ggplot call |
||
| 1264 | +715 |
- }+ #' |
|
| 1265 | -! | +||
| 716 | +
- card$append_src(teal.code::get_code(output_q()))+ #' @noRd |
||
| 1266 | -! | +||
| 717 | +
- card+ #' |
||
| 1267 | +718 |
- }+ #' @examples |
|
| 1268 | -! | +||
| 719 | +
- teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
+ #' |
||
| 1269 | +720 |
- }+ #' bivariate_plot_call("ANL", "BAGE", "RACE", "numeric", "factor")
|
|
| 1270 | +721 |
- ###+ #' bivariate_plot_call("ANL", "BAGE", character(0), "numeric", "NULL")
|
|
| 1271 | +722 |
- })+ bivariate_plot_call <- function(data_name, |
|
| 1272 | +723 |
- }+ x = character(0), |
| 1 | +724 |
- #' Create a scatterplot matrix+ y = character(0), |
|
| 2 | +725 |
- #'+ x_class = "NULL", |
|
| 3 | +726 |
- #' The available datasets to choose from for each dataset selector is the same and+ y_class = "NULL", |
|
| 4 | +727 |
- #' determined by the argument `variables`.+ x_label = NULL, |
|
| 5 | +728 |
- #' @md+ y_label = NULL, |
|
| 6 | +729 |
- #'+ freq = TRUE, |
|
| 7 | +730 |
- #' @inheritParams teal::module+ theme = "gray", |
|
| 8 | +731 |
- #' @inheritParams tm_g_scatterplot+ rotate_xaxis_labels = FALSE, |
|
| 9 | +732 |
- #' @inheritParams shared_params+ swap_axes = FALSE, |
|
| 10 | +733 |
- #'+ alpha = double(0), |
|
| 11 | +734 |
- #' @param variables (`data_extract_spec` or `list` of multiple `data_extract_spec`)+ size = 2, |
|
| 12 | +735 |
- #' Plotting variables from an incoming dataset with filtering and selecting. In case of+ ggplot2_args = teal.widgets::ggplot2_args()) {
|
|
| 13 | -+ | ||
| 736 | +! |
- #' `data_extract_spec` use `select_spec(..., ordered = TRUE)` if plot elements should be+ supported_types <- c("NULL", "numeric", "integer", "factor", "character", "logical")
|
|
| 14 | -+ | ||
| 737 | +! |
- #' rendered according to selection order.+ validate(need(x_class %in% supported_types, paste0("Data type '", x_class, "' is not supported.")))
|
|
| 15 | -+ | ||
| 738 | +! |
- #'+ validate(need(y_class %in% supported_types, paste0("Data type '", y_class, "' is not supported.")))
|
|
| 16 | +739 |
- #' @note For more examples, please see the vignette "Using scatterplot matrix" via+ |
|
| 17 | +740 |
- #' \code{vignette("using-scatterplot-matrix", package = "teal.modules.general")}.
+
|
|
| 18 | -+ | ||
| 741 | +! |
- #'+ if (identical(x, character(0))) {
|
|
| 19 | -+ | ||
| 742 | +! |
- #' @examples+ x <- x_label <- "-" |
|
| 20 | +743 |
- #' # general data example+ } else {
|
|
| 21 | -+ | ||
| 744 | +! |
- #' data <- teal_data()+ x <- if (is.call(x)) x else as.name(x) |
|
| 22 | +745 |
- #' data <- within(data, {
+ } |
|
| 23 | -+ | ||
| 746 | +! |
- #' countries <- data.frame(+ if (identical(y, character(0))) {
|
|
| 24 | -+ | ||
| 747 | +! |
- #' id = c("DE", "FR", "IT", "ES", "PT", "GR", "NL", "BE", "LU", "AT"),
+ y <- y_label <- "-" |
|
| 25 | +748 |
- #' government = factor(+ } else {
|
|
| 26 | -+ | ||
| 749 | +! |
- #' c(2, 2, 2, 1, 2, 2, 1, 1, 1, 2),+ y <- if (is.call(y)) y else as.name(y) |
|
| 27 | +750 |
- #' labels = c("Monarchy", "Republic")
+ } |
|
| 28 | +751 |
- #' ),+ |
|
| 29 | -+ | ||
| 752 | +! |
- #' language_family = factor(+ cl <- bivariate_ggplot_call( |
|
| 30 | -+ | ||
| 753 | +! |
- #' c(1, 3, 3, 3, 3, 2, 1, 1, 3, 1),+ x_class = x_class, |
|
| 31 | -+ | ||
| 754 | +! |
- #' labels = c("Germanic", "Hellenic", "Romance")
+ y_class = y_class, |
|
| 32 | -+ | ||
| 755 | +! |
- #' ),+ freq = freq, |
|
| 33 | -+ | ||
| 756 | +! |
- #' population = c(83, 67, 60, 47, 10, 11, 17, 11, 0.6, 9),+ theme = theme, |
|
| 34 | -+ | ||
| 757 | +! |
- #' area = c(357, 551, 301, 505, 92, 132, 41, 30, 2.6, 83),+ rotate_xaxis_labels = rotate_xaxis_labels, |
|
| 35 | -+ | ||
| 758 | +! |
- #' gdp = c(3.4, 2.7, 2.1, 1.4, 0.3, 0.2, 0.7, 0.5, 0.1, 0.4),+ swap_axes = swap_axes, |
|
| 36 | -+ | ||
| 759 | +! |
- #' debt = c(2.1, 2.3, 2.4, 2.6, 2.3, 2.4, 2.3, 2.4, 2.3, 2.4)+ alpha = alpha, |
|
| 37 | -+ | ||
| 760 | +! |
- #' )+ size = size, |
|
| 38 | -+ | ||
| 761 | +! |
- #' sales <- data.frame(+ ggplot2_args = ggplot2_args, |
|
| 39 | -+ | ||
| 762 | +! |
- #' id = 1:50,+ x = x, |
|
| 40 | -+ | ||
| 763 | +! |
- #' country_id = sample(+ y = y, |
|
| 41 | -+ | ||
| 764 | +! |
- #' c("DE", "FR", "IT", "ES", "PT", "GR", "NL", "BE", "LU", "AT"),
+ xlab = x_label, |
|
| 42 | -+ | ||
| 765 | +! |
- #' size = 50,+ ylab = y_label, |
|
| 43 | -+ | ||
| 766 | +! |
- #' replace = TRUE+ data_name = data_name |
|
| 44 | +767 |
- #' ),+ ) |
|
| 45 | +768 |
- #' year = sort(sample(2010:2020, 50, replace = TRUE)),+ } |
|
| 46 | +769 |
- #' venue = sample(c("small", "medium", "large", "online"), 50, replace = TRUE),
+
|
|
| 47 | +770 |
- #' cancelled = sample(c(TRUE, FALSE), 50, replace = TRUE),+ substitute_q <- function(x, env) {
|
|
| 48 | -+ | ||
| 771 | +! |
- #' quantity = rnorm(50, 100, 20),+ stopifnot(is.language(x)) |
|
| 49 | -+ | ||
| 772 | +! |
- #' costs = rnorm(50, 80, 20),+ call <- substitute(substitute(x, env), list(x = x)) |
|
| 50 | -+ | ||
| 773 | +! |
- #' profit = rnorm(50, 20, 10)+ eval(call) |
|
| 51 | +774 |
- #' )+ } |
|
| 52 | +775 |
- #' })+ |
|
| 53 | +776 |
- #' datanames(data) <- c("countries", "sales")
+
|
|
| 54 | +777 |
- #' join_keys(data) <- join_keys(+ #' Create ggplot part of plot call |
|
| 55 | +778 |
- #' join_key("countries", "countries", "id"),
+ #' |
|
| 56 | +779 |
- #' join_key("sales", "sales", "id"),
+ #' Due to the type of the x and y variable the plot type is chosen |
|
| 57 | +780 |
- #' join_key("countries", "sales", c("id" = "country_id"))
+ #' |
|
| 58 | +781 |
- #' )+ #' @noRd |
|
| 59 | +782 |
#' |
|
| 60 | +783 |
- #' app <- init(+ #' @examples |
|
| 61 | +784 |
- #' data = data,+ #' bivariate_ggplot_call("numeric", "NULL")
|
|
| 62 | +785 |
- #' modules = modules(+ #' bivariate_ggplot_call("numeric", "NULL", freq = FALSE)
|
|
| 63 | +786 |
- #' tm_g_scatterplotmatrix(+ #' |
|
| 64 | +787 |
- #' label = "Scatterplot matrix",+ #' bivariate_ggplot_call("NULL", "numeric")
|
|
| 65 | +788 |
- #' variables = list(+ #' bivariate_ggplot_call("NULL", "numeric", freq = FALSE)
|
|
| 66 | +789 |
- #' data_extract_spec(+ #' |
|
| 67 | +790 |
- #' dataname = "countries",+ #' bivariate_ggplot_call("NULL", "factor")
|
|
| 68 | +791 |
- #' select = select_spec(+ #' bivariate_ggplot_call("NULL", "factor", freq = FALSE)
|
|
| 69 | +792 |
- #' label = "Select variables:",+ #' |
|
| 70 | +793 |
- #' choices = variable_choices(data[["countries"]]),+ #' bivariate_ggplot_call("factor", "NULL")
|
|
| 71 | +794 |
- #' selected = c("area", "gdp", "debt"),
+ #' bivariate_ggplot_call("factor", "NULL", freq = FALSE)
|
|
| 72 | +795 |
- #' multiple = TRUE,+ #' |
|
| 73 | +796 |
- #' ordered = TRUE,+ #' bivariate_ggplot_call("numeric", "numeric")
|
|
| 74 | +797 |
- #' fixed = FALSE+ #' bivariate_ggplot_call("numeric", "factor")
|
|
| 75 | +798 |
- #' )+ #' bivariate_ggplot_call("factor", "numeric")
|
|
| 76 | +799 |
- #' ),+ #' bivariate_ggplot_call("factor", "factor")
|
|
| 77 | +800 |
- #' data_extract_spec(+ bivariate_ggplot_call <- function(x_class = c("NULL", "numeric", "integer", "factor", "character", "logical"),
|
|
| 78 | +801 |
- #' dataname = "sales",+ y_class = c("NULL", "numeric", "integer", "factor", "character", "logical"),
|
|
| 79 | +802 |
- #' filter = filter_spec(+ freq = TRUE, |
|
| 80 | +803 |
- #' label = "Select variable:",+ theme = "gray", |
|
| 81 | +804 |
- #' vars = "country_id",+ rotate_xaxis_labels = FALSE, |
|
| 82 | +805 |
- #' choices = value_choices(data[["sales"]], "country_id"),+ swap_axes = FALSE, |
|
| 83 | +806 |
- #' selected = c("DE", "FR", "IT", "ES", "PT", "GR", "NL", "BE", "LU", "AT"),
+ size = double(0), |
|
| 84 | +807 |
- #' multiple = TRUE+ alpha = double(0), |
|
| 85 | +808 |
- #' ),+ x = NULL, |
|
| 86 | +809 |
- #' select = select_spec(+ y = NULL, |
|
| 87 | +810 |
- #' label = "Select variables:",+ xlab = "-", |
|
| 88 | +811 |
- #' choices = variable_choices(data[["sales"]], c("quantity", "costs", "profit")),
+ ylab = "-", |
|
| 89 | +812 |
- #' selected = c("quantity", "costs", "profit"),
+ data_name = "ANL", |
|
| 90 | +813 |
- #' multiple = TRUE,+ ggplot2_args = teal.widgets::ggplot2_args()) {
|
|
| 91 | -+ | ||
| 814 | +42x |
- #' ordered = TRUE,+ x_class <- match.arg(x_class) |
|
| 92 | -+ | ||
| 815 | +42x |
- #' fixed = FALSE+ y_class <- match.arg(y_class) |
|
| 93 | +816 |
- #' )+ |
|
| 94 | -+ | ||
| 817 | +42x |
- #' )+ if (x_class %in% c("character", "logical")) {
|
|
| 95 | -+ | ||
| 818 | +12x |
- #' )+ x_class <- "factor" |
|
| 96 | +819 |
- #' )+ } |
|
| 97 | -+ | ||
| 820 | +42x |
- #' )+ if (x_class %in% c("integer")) {
|
|
| 98 | -+ | ||
| 821 | +! |
- #' )+ x_class <- "numeric" |
|
| 99 | +822 |
- #' if (interactive()) {
+ } |
|
| 100 | -+ | ||
| 823 | +42x |
- #' shinyApp(app$ui, app$server)+ if (y_class %in% c("character", "logical")) {
|
|
| 101 | -+ | ||
| 824 | +8x |
- #' }+ y_class <- "factor" |
|
| 102 | +825 |
- #'+ } |
|
| 103 | -+ | ||
| 826 | +42x |
- #' # CDISC data example+ if (y_class %in% c("integer")) {
|
|
| 104 | -+ | ||
| 827 | +! |
- #' data <- teal_data()+ y_class <- "numeric" |
|
| 105 | +828 |
- #' data <- within(data, {
+ } |
|
| 106 | +829 |
- #' ADSL <- rADSL+ |
|
| 107 | -+ | ||
| 830 | +42x |
- #' ADRS <- rADRS+ if (all(c(x_class, y_class) == "NULL")) {
|
|
| 108 | -+ | ||
| 831 | +! |
- #' })+ stop("either x or y is required")
|
|
| 109 | +832 |
- #' datanames(data) <- c("ADSL", "ADRS")
+ } |
|
| 110 | +833 |
- #' join_keys(data) <- default_cdisc_join_keys[datanames(data)]+ |
|
| 111 | -+ | ||
| 834 | +42x |
- #'+ reduce_plot_call <- function(...) {
|
|
| 112 | -+ | ||
| 835 | +104x |
- #' app <- init(+ args <- Filter(Negate(is.null), list(...)) |
|
| 113 | -+ | ||
| 836 | +104x |
- #' data = data,+ Reduce(function(x, y) call("+", x, y), args)
|
|
| 114 | +837 |
- #' modules = modules(+ } |
|
| 115 | +838 |
- #' tm_g_scatterplotmatrix(+ |
|
| 116 | -+ | ||
| 839 | +42x |
- #' label = "Scatterplot matrix",+ plot_call <- substitute(ggplot(data_name), env = list(data_name = as.name(data_name))) |
|
| 117 | +840 |
- #' variables = list(+ |
|
| 118 | +841 |
- #' data_extract_spec(+ # Single data plots |
|
| 119 | -+ | ||
| 842 | +42x |
- #' dataname = "ADSL",+ if (x_class == "numeric" && y_class == "NULL") {
|
|
| 120 | -+ | ||
| 843 | +6x |
- #' select = select_spec(+ plot_call <- reduce_plot_call(plot_call, substitute(aes(x = xval), env = list(xval = x))) |
|
| 121 | +844 |
- #' label = "Select variables:",+ |
|
| 122 | -+ | ||
| 845 | +6x |
- #' choices = variable_choices(data[["ADSL"]]),+ if (freq) {
|
|
| 123 | -+ | ||
| 846 | +4x |
- #' selected = c("AGE", "RACE", "SEX"),
+ plot_call <- reduce_plot_call( |
|
| 124 | -+ | ||
| 847 | +4x |
- #' multiple = TRUE,+ plot_call, |
|
| 125 | -+ | ||
| 848 | +4x |
- #' ordered = TRUE,+ quote(geom_histogram(bins = 30)), |
|
| 126 | -+ | ||
| 849 | +4x |
- #' fixed = FALSE+ quote(ylab("Frequency"))
|
|
| 127 | +850 |
- #' )+ ) |
|
| 128 | +851 |
- #' ),+ } else {
|
|
| 129 | -+ | ||
| 852 | +2x |
- #' data_extract_spec(+ plot_call <- reduce_plot_call( |
|
| 130 | -+ | ||
| 853 | +2x |
- #' dataname = "ADRS",+ plot_call, |
|
| 131 | -+ | ||
| 854 | +2x |
- #' filter = filter_spec(+ quote(geom_histogram(bins = 30, aes(y = after_stat(density)))), |
|
| 132 | -+ | ||
| 855 | +2x |
- #' label = "Select endpoints:",+ quote(geom_density(aes(y = after_stat(density)))), |
|
| 133 | -+ | ||
| 856 | +2x |
- #' vars = c("PARAMCD", "AVISIT"),
+ quote(ylab("Density"))
|
|
| 134 | +857 |
- #' choices = value_choices(data[["ADRS"]], c("PARAMCD", "AVISIT"), c("PARAM", "AVISIT")),
+ ) |
|
| 135 | +858 |
- #' selected = "INVET - END OF INDUCTION",+ } |
|
| 136 | -+ | ||
| 859 | +36x |
- #' multiple = TRUE+ } else if (x_class == "NULL" && y_class == "numeric") {
|
|
| 137 | -+ | ||
| 860 | +6x |
- #' ),+ plot_call <- reduce_plot_call(plot_call, substitute(aes(x = yval), env = list(yval = y))) |
|
| 138 | +861 |
- #' select = select_spec(+ |
|
| 139 | -+ | ||
| 862 | +6x |
- #' label = "Select variables:",+ if (freq) {
|
|
| 140 | -+ | ||
| 863 | +4x |
- #' choices = variable_choices(data[["ADRS"]]),+ plot_call <- reduce_plot_call( |
|
| 141 | -+ | ||
| 864 | +4x |
- #' selected = c("AGE", "AVAL", "ADY"),
+ plot_call, |
|
| 142 | -+ | ||
| 865 | +4x |
- #' multiple = TRUE,+ quote(geom_histogram(bins = 30)), |
|
| 143 | -+ | ||
| 866 | +4x |
- #' ordered = TRUE,+ quote(ylab("Frequency"))
|
|
| 144 | +867 |
- #' fixed = FALSE+ ) |
|
| 145 | +868 |
- #' )+ } else {
|
|
| 146 | -+ | ||
| 869 | +2x |
- #' )+ plot_call <- reduce_plot_call( |
|
| 147 | -+ | ||
| 870 | +2x |
- #' )+ plot_call, |
|
| 148 | -+ | ||
| 871 | +2x |
- #' )+ quote(geom_histogram(bins = 30, aes(y = after_stat(density)))), |
|
| 149 | -+ | ||
| 872 | +2x |
- #' )+ quote(geom_density(aes(y = after_stat(density)))), |
|
| 150 | -+ | ||
| 873 | +2x |
- #' )+ quote(ylab("Density"))
|
|
| 151 | +874 |
- #' if (interactive()) {
+ ) |
|
| 152 | +875 |
- #' shinyApp(app$ui, app$server)+ } |
|
| 153 | -+ | ||
| 876 | +30x |
- #' }+ } else if (x_class == "factor" && y_class == "NULL") {
|
|
| 154 | -+ | ||
| 877 | +4x |
- #'+ plot_call <- reduce_plot_call(plot_call, substitute(aes(x = xval), env = list(xval = x))) |
|
| 155 | +878 |
- #' @export+ |
|
| 156 | -+ | ||
| 879 | +4x |
- #'+ if (freq) {
|
|
| 157 | -+ | ||
| 880 | +2x |
- tm_g_scatterplotmatrix <- function(label = "Scatterplot Matrix",+ plot_call <- reduce_plot_call( |
|
| 158 | -+ | ||
| 881 | +2x |
- variables,+ plot_call, |
|
| 159 | -+ | ||
| 882 | +2x |
- plot_height = c(600, 200, 2000),+ quote(geom_bar()), |
|
| 160 | -+ | ||
| 883 | +2x |
- plot_width = NULL,+ quote(ylab("Frequency"))
|
|
| 161 | +884 |
- pre_output = NULL,+ ) |
|
| 162 | +885 |
- post_output = NULL) {
+ } else {
|
|
| 163 | -! | +||
| 886 | +2x |
- logger::log_info("Initializing tm_g_scatterplotmatrix")
+ plot_call <- reduce_plot_call( |
|
| 164 | -! | +||
| 887 | +2x |
- if (!requireNamespace("lattice", quietly = TRUE)) {
+ plot_call, |
|
| 165 | -! | +||
| 888 | +2x |
- stop("Cannot load lattice - please install the package or restart your session.")
+ quote(geom_bar(aes(y = after_stat(prop), group = 1))), |
|
| 166 | -+ | ||
| 889 | +2x |
- }+ quote(ylab("Fraction"))
|
|
| 167 | -! | +||
| 890 | +
- if (inherits(variables, "data_extract_spec")) variables <- list(variables)+ ) |
||
| 168 | +891 |
-
+ } |
|
| 169 | -! | +||
| 892 | +26x |
- checkmate::assert_string(label)+ } else if (x_class == "NULL" && y_class == "factor") {
|
|
| 170 | -! | +||
| 893 | +4x |
- checkmate::assert_list(variables, types = "data_extract_spec")+ plot_call <- reduce_plot_call(plot_call, substitute(aes(x = yval), env = list(yval = y))) |
|
| 171 | -! | +||
| 894 | +
- checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE)+ |
||
| 172 | -! | +||
| 895 | +4x |
- checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height")+ if (freq) {
|
|
| 173 | -! | +||
| 896 | +2x |
- checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE)+ plot_call <- reduce_plot_call( |
|
| 174 | -! | +||
| 897 | +2x |
- checkmate::assert_numeric(+ plot_call, |
|
| 175 | -! | +||
| 898 | +2x |
- plot_width[1],+ quote(geom_bar()), |
|
| 176 | -! | +||
| 899 | +2x |
- lower = plot_width[2], upper = plot_width[3], null.ok = TRUE, .var.name = "plot_width"+ quote(ylab("Frequency"))
|
|
| 177 | +900 |
- )+ ) |
|
| 178 | +901 |
-
+ } else {
|
|
| 179 | -! | +||
| 902 | +2x |
- args <- as.list(environment())+ plot_call <- reduce_plot_call( |
|
| 180 | -! | +||
| 903 | +2x |
- module(+ plot_call, |
|
| 181 | -! | +||
| 904 | +2x |
- label = label,+ quote(geom_bar(aes(y = after_stat(prop), group = 1))), |
|
| 182 | -! | +||
| 905 | +2x |
- server = srv_g_scatterplotmatrix,+ quote(ylab("Fraction"))
|
|
| 183 | -! | +||
| 906 | +
- ui = ui_g_scatterplotmatrix,+ ) |
||
| 184 | -! | +||
| 907 | +
- ui_args = args,+ } |
||
| 185 | -! | +||
| 908 | +
- server_args = list(variables = variables, plot_height = plot_height, plot_width = plot_width),+ # Numeric Plots |
||
| 186 | -! | +||
| 909 | +22x |
- datanames = teal.transform::get_extract_datanames(variables)+ } else if (x_class == "numeric" && y_class == "numeric") {
|
|
| 187 | -+ | ||
| 910 | +2x |
- )+ plot_call <- reduce_plot_call( |
|
| 188 | -+ | ||
| 911 | +2x |
- }+ plot_call, |
|
| 189 | -+ | ||
| 912 | +2x |
-
+ substitute(aes(x = xval, y = yval), env = list(xval = x, yval = y)), |
|
| 190 | +913 |
- ui_g_scatterplotmatrix <- function(id, ...) {
- |
- |
| 191 | -! | -
- args <- list(...)+ # pch = 21 for consistent coloring behaviour b/w all geoms (outline and fill properties) |
|
| 192 | -! | +||
| 914 | +2x |
- is_single_dataset_value <- teal.transform::is_single_dataset(args$variables)+ `if`( |
|
| 193 | -! | +||
| 915 | +2x |
- ns <- NS(id)+ !is.null(size), |
|
| 194 | -! | +||
| 916 | +2x |
- teal.widgets::standard_layout(+ substitute( |
|
| 195 | -! | +||
| 917 | +2x |
- output = teal.widgets::white_small_well(+ geom_point(alpha = alphaval, size = sizeval, pch = 21), |
|
| 196 | -! | +||
| 918 | +2x |
- textOutput(ns("message")),
+ env = list(alphaval = alpha, sizeval = size) |
|
| 197 | -! | +||
| 919 | +
- br(),+ ), |
||
| 198 | -! | +||
| 920 | +2x |
- teal.widgets::plot_with_settings_ui(id = ns("myplot"))
+ substitute( |
|
| 199 | -+ | ||
| 921 | +2x |
- ),+ geom_point(alpha = alphaval, pch = 21), |
|
| 200 | -! | +||
| 922 | +2x |
- encoding = div(+ env = list(alphaval = alpha) |
|
| 201 | +923 |
- ### Reporter- |
- |
| 202 | -! | -
- teal.reporter::simple_reporter_ui(ns("simple_reporter")),
+ ) |
|
| 203 | +924 |
- ###+ ) |
|
| 204 | -! | +||
| 925 | +
- tags$label("Encodings", class = "text-primary"),
+ ) |
||
| 205 | -! | +||
| 926 | +20x |
- teal.transform::datanames_input(args$variables),+ } else if ((x_class == "numeric" && y_class == "factor") || (x_class == "factor" && y_class == "numeric")) {
|
|
| 206 | -! | +||
| 927 | +6x |
- teal.transform::data_extract_ui(+ plot_call <- reduce_plot_call( |
|
| 207 | -! | +||
| 928 | +6x |
- id = ns("variables"),
+ plot_call, |
|
| 208 | -! | +||
| 929 | +6x |
- label = "Variables",+ substitute(aes(x = xval, y = yval), env = list(xval = x, yval = y)), |
|
| 209 | -! | +||
| 930 | +6x |
- data_extract_spec = args$variables,+ quote(geom_boxplot()) |
|
| 210 | -! | +||
| 931 | +
- is_single_dataset = is_single_dataset_value+ ) |
||
| 211 | +932 |
- ),+ # Factor and character plots |
|
| 212 | -! | +||
| 933 | +14x |
- hr(),+ } else if (x_class == "factor" && y_class == "factor") {
|
|
| 213 | -! | +||
| 934 | +14x |
- teal.widgets::panel_group(+ plot_call <- reduce_plot_call( |
|
| 214 | -! | +||
| 935 | +14x |
- teal.widgets::panel_item(+ plot_call, |
|
| 215 | -! | +||
| 936 | +14x |
- title = "Plot settings",+ substitute( |
|
| 216 | -! | +||
| 937 | +14x |
- sliderInput(+ ggmosaic::geom_mosaic(aes(x = ggmosaic::product(xval), fill = yval), na.rm = TRUE), |
|
| 217 | -! | +||
| 938 | +14x |
- ns("alpha"), "Opacity:",
+ env = list(xval = x, yval = y) |
|
| 218 | -! | +||
| 939 | +
- min = 0, max = 1,+ ) |
||
| 219 | -! | +||
| 940 | +
- step = .05, value = .5, ticks = FALSE+ ) |
||
| 220 | +941 |
- ),+ } else {
|
|
| 221 | +942 | ! |
- sliderInput(+ stop("x y type combination not allowed")
|
| 222 | -! | +||
| 943 | +
- ns("cex"), "Points size:",
+ } |
||
| 223 | -! | +||
| 944 | +
- min = 0.2, max = 3,+ |
||
| 224 | -! | +||
| 945 | +42x |
- step = .05, value = .65, ticks = FALSE+ labs_base <- if (x_class == "NULL") {
|
|
| 225 | -+ | ||
| 946 | +10x |
- ),+ list(x = substitute(ylab, list(ylab = ylab))) |
|
| 226 | -! | +||
| 947 | +42x |
- checkboxInput(ns("cor"), "Add Correlation", value = FALSE),
+ } else if (y_class == "NULL") {
|
|
| 227 | -! | +||
| 948 | +10x |
- radioButtons(+ list(x = substitute(xlab, list(xlab = xlab))) |
|
| 228 | -! | +||
| 949 | +
- ns("cor_method"), "Select Correlation Method",
+ } else {
|
||
| 229 | -! | +||
| 950 | +22x |
- choiceNames = c("Pearson", "Kendall", "Spearman"),
+ list( |
|
| 230 | -! | +||
| 951 | +22x |
- choiceValues = c("pearson", "kendall", "spearman"),
+ x = substitute(xlab, list(xlab = xlab)), |
|
| 231 | -! | +||
| 952 | +22x |
- inline = TRUE+ y = substitute(ylab, list(ylab = ylab)) |
|
| 232 | +953 |
- ),+ ) |
|
| 233 | -! | +||
| 954 | +
- checkboxInput(ns("cor_na_omit"), "Omit Missing Values", value = TRUE)
+ } |
||
| 234 | +955 |
- )+ |
|
| 235 | -+ | ||
| 956 | +42x |
- )+ dev_ggplot2_args <- teal.widgets::ggplot2_args(labs = labs_base) |
|
| 236 | +957 |
- ),+ |
|
| 237 | -! | +||
| 958 | +42x |
- forms = tagList(+ if (rotate_xaxis_labels) {
|
|
| 238 | +959 | ! |
- teal.widgets::verbatim_popup_ui(ns("warning"), "Show Warnings"),
+ dev_ggplot2_args$theme <- list(axis.text.x = quote(element_text(angle = 45, hjust = 1))) |
| 239 | -! | +||
| 960 | +
- teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code")
+ } |
||
| 240 | +961 |
- ),+ |
|
| 241 | -! | +||
| 962 | +42x |
- pre_output = args$pre_output,+ all_ggplot2_args <- teal.widgets::resolve_ggplot2_args( |
|
| 242 | -! | +||
| 963 | +42x |
- post_output = args$post_output+ user_plot = ggplot2_args, |
|
| 243 | -+ | ||
| 964 | +42x |
- )+ module_plot = dev_ggplot2_args |
|
| 244 | +965 |
- }+ ) |
|
| 245 | +966 | ||
| 246 | -+ | ||
| 967 | +42x |
- srv_g_scatterplotmatrix <- function(id, data, reporter, filter_panel_api, variables, plot_height, plot_width) {
+ parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(all_ggplot2_args, ggtheme = theme) |
|
| 247 | -! | +||
| 968 | +
- with_reporter <- !missing(reporter) && inherits(reporter, "Reporter")+ |
||
| 248 | -! | +||
| 969 | +42x |
- with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI")+ plot_call <- reduce_plot_call( |
|
| 249 | -! | +||
| 970 | +42x |
- checkmate::assert_class(data, "reactive")+ plot_call, |
|
| 250 | -! | +||
| 971 | +42x |
- checkmate::assert_class(isolate(data()), "teal_data")+ parsed_ggplot2_args$labs, |
|
| 251 | -! | +||
| 972 | +42x |
- moduleServer(id, function(input, output, session) {
+ parsed_ggplot2_args$ggtheme, |
|
| 252 | -! | +||
| 973 | +42x |
- selector_list <- teal.transform::data_extract_multiple_srv(+ parsed_ggplot2_args$theme |
|
| 253 | -! | +||
| 974 | +
- data_extract = list(variables = variables),+ ) |
||
| 254 | -! | +||
| 975 | +
- datasets = data,+ |
||
| 255 | -! | +||
| 976 | +42x |
- select_validation_rule = list(+ if (swap_axes) {
|
|
| 256 | +977 | ! |
- variables = ~ if (length(.) <= 1) "Please select at least 2 columns."+ plot_call <- reduce_plot_call(plot_call, quote(coord_flip())) |
| 257 | +978 |
- )+ } |
|
| 258 | +979 |
- )+ |
|
| 259 | -+ | ||
| 980 | +42x |
-
+ return(plot_call) |
|
| 260 | -! | +||
| 981 | +
- iv_r <- reactive({
+ } |
||
| 261 | -! | +||
| 982 | +
- iv <- shinyvalidate::InputValidator$new()+ |
||
| 262 | -! | +||
| 983 | +
- teal.transform::compose_and_enable_validators(iv, selector_list)+ |
||
| 263 | +984 |
- })+ #' Create facet call |
|
| 264 | +985 |
-
+ #' |
|
| 265 | -! | +||
| 986 | +
- anl_merged_input <- teal.transform::merge_expression_srv(+ #' @noRd |
||
| 266 | -! | +||
| 987 | +
- datasets = data,+ #' |
||
| 267 | -! | +||
| 988 | +
- selector_list = selector_list+ #' @examples |
||
| 268 | +989 |
- )+ #' |
|
| 269 | +990 |
-
+ #' facet_ggplot_call(LETTERS[1:3]) |
|
| 270 | -! | +||
| 991 | +
- anl_merged_q <- reactive({
+ #' facet_ggplot_call(NULL, LETTERS[23:26]) |
||
| 271 | -! | +||
| 992 | +
- req(anl_merged_input())+ #' facet_ggplot_call(LETTERS[1:3], LETTERS[23:26]) |
||
| 272 | -! | +||
| 993 | +
- data() %>%+ facet_ggplot_call <- function(row_facet = character(0), |
||
| 273 | -! | +||
| 994 | +
- teal.code::eval_code(as.expression(anl_merged_input()$expr))+ col_facet = character(0), |
||
| 274 | +995 |
- })+ free_x_scales = FALSE, |
|
| 275 | +996 |
-
+ free_y_scales = FALSE) {
|
|
| 276 | +997 | ! |
- merged <- list(+ scales <- if (free_x_scales && free_y_scales) {
|
| 277 | +998 | ! |
- anl_input_r = anl_merged_input,+ "free" |
| 278 | +999 | ! |
- anl_q_r = anl_merged_q- |
-
| 279 | -- |
- )- |
- |
| 280 | -- |
-
+ } else if (free_x_scales) {
|
|
| 281 | -+ | ||
| 1000 | +! |
- # plot+ "free_x" |
|
| 282 | +1001 | ! |
- output_q <- reactive({
+ } else if (free_y_scales) {
|
| 283 | +1002 | ! |
- teal::validate_inputs(iv_r())+ "free_y" |
| 284 | +1003 |
-
+ } else {
|
|
| 285 | +1004 | ! |
- qenv <- merged$anl_q_r()+ "fixed" |
| 286 | -! | +||
| 1005 | +
- ANL <- qenv[["ANL"]] # nolint: object_name.+ } |
||
| 287 | +1006 | ||
| 288 | +1007 | ! |
- cols_names <- merged$anl_input_r()$columns_source$variables+ if (identical(row_facet, character(0)) && identical(col_facet, character(0))) {
|
| 289 | +1008 | ! |
- alpha <- input$alpha+ NULL |
| 290 | +1009 | ! |
- cex <- input$cex+ } else if (!identical(row_facet, character(0)) && !identical(col_facet, character(0))) {
|
| 291 | +1010 | ! |
- add_cor <- input$cor+ call( |
| 292 | +1011 | ! |
- cor_method <- input$cor_method+ "facet_grid", |
| 293 | +1012 | ! |
- cor_na_omit <- input$cor_na_omit- |
-
| 294 | -- |
-
+ rows = call_fun_dots("vars", row_facet),
|
|
| 295 | +1013 | ! |
- cor_na_action <- if (isTruthy(cor_na_omit)) {
+ cols = call_fun_dots("vars", col_facet),
|
| 296 | +1014 | ! |
- "na.omit"+ scales = scales |
| 297 | +1015 |
- } else {
+ ) |
|
| 298 | +1016 | ! |
- "na.fail"- |
-
| 299 | -- |
- }+ } else if (identical(row_facet, character(0)) && !identical(col_facet, character(0))) {
|
|
| 300 | -+ | ||
| 1017 | +! |
-
+ call("facet_grid", cols = call_fun_dots("vars", col_facet), scales = scales)
|
|
| 301 | +1018 | ! |
- teal::validate_has_data(ANL, 10)+ } else if (!identical(row_facet, character(0)) && identical(col_facet, character(0))) {
|
| 302 | +1019 | ! |
- teal::validate_has_data(ANL[, cols_names, drop = FALSE], 10, complete = TRUE, allow_inf = FALSE)+ call("facet_grid", rows = call_fun_dots("vars", row_facet), scales = scales)
|
| 303 | +1020 |
-
+ } |
|
| 304 | +1021 |
- # get labels and proper variable names+ } |
|
| 305 | -! | +||
| 1022 | +
- varnames <- varname_w_label(cols_names, ANL, wrap_width = 20)+ |
||
| 306 | +1023 |
-
+ coloring_ggplot_call <- function(colour, |
|
| 307 | +1024 |
- # check character columns. If any, then those are converted to factors+ fill, |
|
| 308 | -! | -
- check_char <- vapply(ANL[, cols_names], is.character, logical(1))- |
- |
| 309 | -! | -
- if (any(check_char)) {
- |
- |
| 310 | -! | +||
| 1025 | +
- qenv <- teal.code::eval_code(+ size, |
||
| 311 | -! | +||
| 1026 | +
- qenv,+ is_point = FALSE) {
|
||
| 312 | -! | +||
| 1027 | +15x |
- substitute(+ if (!identical(colour, character(0)) && !identical(fill, character(0)) && |
|
| 313 | -! | +||
| 1028 | +15x |
- expr = ANL <- ANL[, cols_names] %>% # nolint: object_name.+ is_point && !identical(size, character(0))) {
|
|
| 314 | -! | +||
| 1029 | +1x |
- dplyr::mutate_if(is.character, as.factor) %>%+ substitute( |
|
| 315 | -! | +||
| 1030 | +1x |
- droplevels(),+ expr = aes(colour = colour_name, fill = fill_name, size = size_name), |
|
| 316 | -! | +||
| 1031 | +1x |
- env = list(cols_names = cols_names)+ env = list(colour_name = as.name(colour), fill_name = as.name(fill), size_name = as.name(size)) |
|
| 317 | +1032 |
- )+ ) |
|
| 318 | -+ | ||
| 1033 | +14x |
- )+ } else if (identical(colour, character(0)) && !identical(fill, character(0)) && |
|
| 319 | -+ | ||
| 1034 | +14x |
- } else {
+ is_point && identical(size, character(0))) {
|
|
| 320 | -! | +||
| 1035 | +1x |
- qenv <- teal.code::eval_code(+ substitute(expr = aes(fill = fill_name), env = list(fill_name = as.name(fill))) |
|
| 321 | -! | +||
| 1036 | +13x |
- qenv,+ } else if (!identical(colour, character(0)) && !identical(fill, character(0)) && |
|
| 322 | -! | +||
| 1037 | +13x |
- substitute(+ (!is_point || identical(size, character(0)))) {
|
|
| 323 | -! | +||
| 1038 | +3x |
- expr = ANL <- ANL[, cols_names] %>% # nolint: object_name.+ substitute( |
|
| 324 | -! | +||
| 1039 | +3x |
- droplevels(),+ expr = aes(colour = colour_name, fill = fill_name), |
|
| 325 | -! | +||
| 1040 | +3x |
- env = list(cols_names = cols_names)+ env = list(colour_name = as.name(colour), fill_name = as.name(fill)) |
|
| 326 | +1041 |
- )+ ) |
|
| 327 | -+ | ||
| 1042 | +10x |
- )+ } else if (!identical(colour, character(0)) && identical(fill, character(0)) && |
|
| 328 | -+ | ||
| 1043 | +10x |
- }+ (!is_point || identical(size, character(0)))) {
|
|
| 329 | -+ | ||
| 1044 | +1x |
-
+ substitute(expr = aes(colour = colour_name), env = list(colour_name = as.name(colour))) |
|
| 330 | -+ | ||
| 1045 | +9x |
-
+ } else if (identical(colour, character(0)) && !identical(fill, character(0)) && |
|
| 331 | -+ | ||
| 1046 | +9x |
- # create plot+ (!is_point || identical(size, character(0)))) {
|
|
| 332 | -! | +||
| 1047 | +2x |
- if (add_cor) {
+ substitute(expr = aes(fill = fill_name), env = list(fill_name = as.name(fill))) |
|
| 333 | -! | +||
| 1048 | +7x |
- shinyjs::show("cor_method")
+ } else if (identical(colour, character(0)) && identical(fill, character(0)) && |
|
| 334 | -! | +||
| 1049 | +7x |
- shinyjs::show("cor_use")
+ is_point && !identical(size, character(0))) {
|
|
| 335 | -! | +||
| 1050 | +1x |
- shinyjs::show("cor_na_omit")
+ substitute(expr = aes(size = size_name), env = list(size_name = as.name(size))) |
|
| 336 | -+ | ||
| 1051 | +6x |
-
+ } else if (!identical(colour, character(0)) && identical(fill, character(0)) && |
|
| 337 | -! | +||
| 1052 | +6x |
- qenv <- teal.code::eval_code(+ is_point && !identical(size, character(0))) {
|
|
| 338 | -! | +||
| 1053 | +1x |
- qenv,+ substitute( |
|
| 339 | -! | +||
| 1054 | +1x |
- substitute(+ expr = aes(colour = colour_name, size = size_name), |
|
| 340 | -! | +||
| 1055 | +1x |
- expr = {
+ env = list(colour_name = as.name(colour), size_name = as.name(size)) |
|
| 341 | -! | +||
| 1056 | +
- g <- lattice::splom(+ ) |
||
| 342 | -! | +||
| 1057 | +5x |
- ANL,+ } else if (identical(colour, character(0)) && !identical(fill, character(0)) && |
|
| 343 | -! | +||
| 1058 | +5x |
- varnames = varnames_value,+ is_point && !identical(size, character(0))) {
|
|
| 344 | -! | +||
| 1059 | +1x |
- panel = function(x, y, ...) {
+ substitute( |
|
| 345 | -! | +||
| 1060 | +1x |
- lattice::panel.splom(x = x, y = y, ...)+ expr = aes(colour = colour_name, fill = fill_name, size = size_name), |
|
| 346 | -! | +||
| 1061 | +1x |
- cpl <- lattice::current.panel.limits()+ env = list(colour_name = as.name(fill), fill_name = as.name(fill), size_name = as.name(size)) |
|
| 347 | -! | +||
| 1062 | +
- lattice::panel.text(+ ) |
||
| 348 | -! | +||
| 1063 | +
- mean(cpl$xlim),+ } else {
|
||
| 349 | -! | +||
| 1064 | +4x |
- mean(cpl$ylim),+ NULL |
|
| 350 | -! | +||
| 1065 | +
- get_scatterplotmatrix_stats(+ } |
||
| 351 | -! | +||
| 1066 | +
- x,+ } |
||
| 352 | -! | +
| 1 | +
- y,+ #' Principal component analysis module |
||
| 353 | -! | +||
| 2 | +
- .f = stats::cor.test,+ #' @md |
||
| 354 | -! | +||
| 3 | +
- .f_args = list(method = cor_method, na.action = cor_na_action)+ #' |
||
| 355 | +4 |
- ),+ #' @inheritParams teal::module |
|
| 356 | -! | +||
| 5 | +
- alpha = 0.6,+ #' @inheritParams shared_params |
||
| 357 | -! | +||
| 6 | +
- fontsize = 18,+ #' @param dat (`data_extract_spec` or `list` of multiple `data_extract_spec`) |
||
| 358 | -! | +||
| 7 | +
- fontface = "bold"+ #' Columns used to compute PCA. |
||
| 359 | +8 |
- )+ #' @param alpha optional, (`numeric`) If scalar then the plot points will have a fixed opacity. If a |
|
| 360 | +9 |
- },+ #' slider should be presented to adjust the plot point opacity dynamically then it can be a vector of |
|
| 361 | -! | +||
| 10 | +
- pch = 16,+ #' length three with `c(value, min, max)`. |
||
| 362 | -! | +||
| 11 | +
- alpha = alpha_value,+ #' @param size optional, (`numeric`) If scalar then the plot point sizes will have a fixed size. |
||
| 363 | -! | +||
| 12 | +
- cex = cex_value+ #' If a slider should be presented to adjust the plot point sizes dynamically then it can be a |
||
| 364 | +13 |
- )+ #' vector of length three with `c(value, min, max)`. |
|
| 365 | -! | +||
| 14 | +
- print(g)+ #' @param font_size optional, (`numeric`) font size control for title, x-axis label, y-axis label and legend. |
||
| 366 | +15 |
- },+ #' If scalar then the font size will have a fixed size. If a slider should be presented to adjust the plot |
|
| 367 | -! | +||
| 16 | +
- env = list(+ #' point sizes dynamically then it can be a vector of length three with `c(value, min, max)`. |
||
| 368 | -! | +||
| 17 | +
- varnames_value = varnames,+ #' |
||
| 369 | -! | +||
| 18 | +
- cor_method = cor_method,+ #' @templateVar ggnames "Elbow plot", "Circle plot", "Biplot", "Eigenvector plot" |
||
| 370 | -! | +||
| 19 | +
- cor_na_action = cor_na_action,+ #' @template ggplot2_args_multi |
||
| 371 | -! | +||
| 20 | +
- alpha_value = alpha,+ #' |
||
| 372 | -! | +||
| 21 | +
- cex_value = cex+ #' @examples |
||
| 373 | +22 |
- )+ #' # general data example |
|
| 374 | +23 |
- )+ #' library(teal.widgets) |
|
| 375 | +24 |
- )+ #' |
|
| 376 | +25 |
- } else {
+ #' data <- teal_data() |
|
| 377 | -! | +||
| 26 | +
- shinyjs::hide("cor_method")
+ #' data <- within(data, {
|
||
| 378 | -! | +||
| 27 | +
- shinyjs::hide("cor_use")
+ #' library(nestcolor) |
||
| 379 | -! | +||
| 28 | +
- shinyjs::hide("cor_na_omit")
+ #' USArrests <- USArrests |
||
| 380 | -! | +||
| 29 | +
- qenv <- teal.code::eval_code(+ #' }) |
||
| 381 | -! | +||
| 30 | +
- qenv,+ #' datanames(data) <- "USArrests" |
||
| 382 | -! | +||
| 31 | +
- substitute(+ #' |
||
| 383 | -! | +||
| 32 | +
- expr = {
+ #' app <- init( |
||
| 384 | -! | +||
| 33 | +
- g <- lattice::splom(ANL, varnames = varnames_value, pch = 16, alpha = alpha_value, cex = cex_value)+ #' data = data, |
||
| 385 | -! | +||
| 34 | +
- g+ #' modules = modules( |
||
| 386 | +35 |
- },+ #' tm_a_pca( |
|
| 387 | -! | +||
| 36 | +
- env = list(varnames_value = varnames, alpha_value = alpha, cex_value = cex)+ #' "PCA", |
||
| 388 | +37 |
- )+ #' dat = data_extract_spec( |
|
| 389 | +38 |
- )+ #' dataname = "USArrests", |
|
| 390 | +39 |
- }+ #' select = select_spec( |
|
| 391 | -! | +||
| 40 | +
- qenv+ #' choices = variable_choices( |
||
| 392 | +41 |
- })+ #' data = data[["USArrests"]], c("Murder", "Assault", "UrbanPop", "Rape")
|
|
| 393 | +42 |
-
+ #' ), |
|
| 394 | -! | +||
| 43 | +
- plot_r <- reactive(output_q()[["g"]])+ #' selected = c("Murder", "Assault"),
|
||
| 395 | +44 |
-
+ #' multiple = TRUE |
|
| 396 | +45 |
- # Insert the plot into a plot_with_settings module+ #' ), |
|
| 397 | -! | +||
| 46 | +
- pws <- teal.widgets::plot_with_settings_srv(+ #' filter = NULL |
||
| 398 | -! | +||
| 47 | +
- id = "myplot",+ #' ), |
||
| 399 | -! | +||
| 48 | +
- plot_r = plot_r,+ #' ggplot2_args = ggplot2_args( |
||
| 400 | -! | +||
| 49 | +
- height = plot_height,+ #' labs = list(subtitle = "Plot generated by PCA Module") |
||
| 401 | -! | +||
| 50 | +
- width = plot_width+ #' ) |
||
| 402 | +51 |
- )+ #' ) |
|
| 403 | +52 |
-
+ #' ) |
|
| 404 | +53 |
- # show a message if conversion to factors took place+ #' ) |
|
| 405 | -! | +||
| 54 | +
- output$message <- renderText({
+ #' |
||
| 406 | -! | +||
| 55 | +
- shiny::req(iv_r()$is_valid())+ #' if (interactive()) {
|
||
| 407 | -! | +||
| 56 | +
- req(selector_list()$variables())+ #' shinyApp(app$ui, app$server) |
||
| 408 | -! | +||
| 57 | +
- ANL <- merged$anl_q_r()[["ANL"]] # nolint: object_name.+ #' } |
||
| 409 | -! | +||
| 58 | +
- cols_names <- unique(unname(do.call(c, merged$anl_input_r()$columns_source)))+ #' |
||
| 410 | -! | +||
| 59 | +
- check_char <- vapply(ANL[, cols_names], is.character, logical(1))+ #' # CDISC data example |
||
| 411 | -! | +||
| 60 | +
- if (any(check_char)) {
+ #' library(teal.widgets) |
||
| 412 | -! | +||
| 61 | +
- is_single <- sum(check_char) == 1+ #' |
||
| 413 | -! | +||
| 62 | +
- paste(+ #' data <- teal_data() |
||
| 414 | -! | +||
| 63 | +
- "Character",+ #' data <- within(data, {
|
||
| 415 | -! | +||
| 64 | +
- ifelse(is_single, "variable", "variables"),+ #' library(nestcolor) |
||
| 416 | -! | +||
| 65 | +
- paste0("(", paste(cols_names[check_char], collapse = ", "), ")"),
+ #' ADSL <- rADSL |
||
| 417 | -! | +||
| 66 | +
- ifelse(is_single, "was", "were"),+ #' }) |
||
| 418 | -! | +||
| 67 | +
- "converted to",+ #' datanames(data) <- "ADSL" |
||
| 419 | -! | +||
| 68 | +
- ifelse(is_single, "factor.", "factors.")+ #' join_keys(data) <- default_cdisc_join_keys[datanames(data)] |
||
| 420 | +69 |
- )+ #' |
|
| 421 | +70 |
- } else {
+ #' app <- init( |
|
| 422 | +71 |
- ""+ #' data = data, |
|
| 423 | +72 |
- }+ #' modules = modules( |
|
| 424 | +73 |
- })+ #' teal.modules.general::tm_a_pca( |
|
| 425 | +74 |
-
+ #' "PCA", |
|
| 426 | -! | +||
| 75 | +
- teal.widgets::verbatim_popup_srv(+ #' dat = data_extract_spec( |
||
| 427 | -! | +||
| 76 | +
- id = "warning",+ #' dataname = "ADSL", |
||
| 428 | -! | +||
| 77 | +
- verbatim_content = reactive(teal.code::get_warnings(output_q())),+ #' select = select_spec( |
||
| 429 | -! | +||
| 78 | +
- title = "Warning",+ #' choices = variable_choices( |
||
| 430 | -! | +||
| 79 | +
- disabled = reactive(is.null(teal.code::get_warnings(output_q())))+ #' data = data[["ADSL"]], c("BMRKR1", "AGE", "EOSDY")
|
||
| 431 | +80 |
- )+ #' ), |
|
| 432 | +81 |
-
+ #' selected = c("BMRKR1", "AGE"),
|
|
| 433 | -! | +||
| 82 | +
- teal.widgets::verbatim_popup_srv(+ #' multiple = TRUE |
||
| 434 | -! | +||
| 83 | +
- id = "rcode",+ #' ), |
||
| 435 | -! | +||
| 84 | +
- verbatim_content = reactive(teal.code::get_code(output_q())),+ #' filter = NULL |
||
| 436 | -! | +||
| 85 | +
- title = "Show R Code for Scatterplotmatrix"+ #' ), |
||
| 437 | +86 |
- )+ #' ggplot2_args = ggplot2_args( |
|
| 438 | +87 |
-
+ #' labs = list(subtitle = "Plot generated by PCA Module") |
|
| 439 | +88 |
- ### REPORTER+ #' ) |
|
| 440 | -! | +||
| 89 | +
- if (with_reporter) {
+ #' ) |
||
| 441 | -! | +||
| 90 | +
- card_fun <- function(comment, label) {
+ #' ) |
||
| 442 | -! | +||
| 91 | +
- card <- teal::report_card_template(+ #' ) |
||
| 443 | -! | +||
| 92 | +
- title = "Scatter Plot Matrix",+ #' |
||
| 444 | -! | +||
| 93 | +
- label = label,+ #' if (interactive()) {
|
||
| 445 | -! | +||
| 94 | +
- with_filter = with_filter,+ #' shinyApp(app$ui, app$server) |
||
| 446 | -! | +||
| 95 | +
- filter_panel_api = filter_panel_api+ #' } |
||
| 447 | +96 |
- )+ #' |
|
| 448 | -! | +||
| 97 | +
- card$append_text("Plot", "header3")
+ #' @export |
||
| 449 | -! | +||
| 98 | +
- card$append_plot(plot_r(), dim = pws$dim())+ #' |
||
| 450 | -! | +||
| 99 | +
- if (!comment == "") {
+ tm_a_pca <- function(label = "Principal Component Analysis", |
||
| 451 | -! | +||
| 100 | +
- card$append_text("Comment", "header3")
- |
- ||
| 452 | -! | -
- card$append_text(comment)+ dat, |
|
| 453 | +101 |
- }- |
- |
| 454 | -! | -
- card$append_src(teal.code::get_code(output_q()))- |
- |
| 455 | -! | -
- card+ plot_height = c(600, 200, 2000), |
|
| 456 | +102 |
- }- |
- |
| 457 | -! | -
- teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
+ plot_width = NULL, |
|
| 458 | +103 |
- }+ ggtheme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void"),
|
|
| 459 | +104 |
- ###+ ggplot2_args = teal.widgets::ggplot2_args(), |
|
| 460 | +105 |
- })+ rotate_xaxis_labels = FALSE, |
|
| 461 | +106 |
- }+ font_size = c(12, 8, 20), |
|
| 462 | +107 |
-
+ alpha = c(1, 0, 1), |
|
| 463 | +108 |
- #' Get stats for x-y pairs in scatterplot matrix+ size = c(2, 1, 8), |
|
| 464 | +109 |
- #' @description uses stats::cor.test per default for all numerical input variables and converts results+ pre_output = NULL, |
|
| 465 | +110 |
- #' to character vector. Could be extended if different stats for different variable+ post_output = NULL) {
|
|
| 466 | -+ | ||
| 111 | +! |
- #' types are needed. Meant to be called from \code{lattice::panel.text}.
+ logger::log_info("Initializing tm_a_pca")
|
|
| 467 | -+ | ||
| 112 | +! |
- #' @param x \code{numeric}
+ if (inherits(dat, "data_extract_spec")) dat <- list(dat) |
|
| 468 | -+ | ||
| 113 | +! |
- #' @param y \code{numeric}
+ if (inherits(ggplot2_args, "ggplot2_args")) ggplot2_args <- list(default = ggplot2_args) |
|
| 469 | +114 |
- #' @param .f \code{function}, function that accepts x and y as formula input \code{~ x + y}.
+
|
|
| 470 | -+ | ||
| 115 | +! |
- #' Default \code{stats::cor.test}
+ checkmate::assert_string(label) |
|
| 471 | -+ | ||
| 116 | +! |
- #' @param .f_args \code{list} of arguments to be passed to \code{.f}
+ checkmate::assert_list(dat, types = "data_extract_spec") |
|
| 472 | -+ | ||
| 117 | +! |
- #' @param round_stat \code{integer}
+ ggtheme <- match.arg(ggtheme) |
|
| 473 | -+ | ||
| 118 | +! |
- #' @param round_pval \code{integer}
+ checkmate::assert_flag(rotate_xaxis_labels) |
|
| 474 | +119 |
- #' @details presently we need to use a formula input for \code{stats::cor.test} because
+
|
|
| 475 | -+ | ||
| 120 | +! |
- #' \code{na.fail} only gets evaluated when a formula is passed (see below).
+ if (length(alpha) == 1) {
|
|
| 476 | -+ | ||
| 121 | +! |
- #' \preformatted{
+ checkmate::assert_numeric(alpha, any.missing = FALSE, finite = TRUE, lower = 0, upper = 1) |
|
| 477 | +122 |
- #' x = c(1,3,5,7,NA)+ } else {
|
|
| 478 | -+ | ||
| 123 | +! |
- #' y = c(3,6,7,8,1)+ checkmate::assert_numeric(alpha, len = 3, any.missing = FALSE, finite = TRUE, lower = 0, upper = 1) |
|
| 479 | -+ | ||
| 124 | +! |
- #' stats::cor.test(x, y, na.action = "na.fail")+ checkmate::assert_numeric(alpha[1], lower = alpha[2], upper = alpha[3], .var.name = "alpha") |
|
| 480 | +125 |
- #' stats::cor.test(~ x + y, na.action = "na.fail")+ } |
|
| 481 | +126 |
- #' }+ |
|
| 482 | -+ | ||
| 127 | +! |
- #' @return \code{character} with stats. For \code{stats::cor.test} correlation coefficient and p-value.
+ if (length(size) == 1) {
|
|
| 483 | -+ | ||
| 128 | +! |
- #' @export+ checkmate::assert_numeric(size, any.missing = FALSE, finite = TRUE, lower = 1, upper = 8) |
|
| 484 | +129 |
- #' @examples+ } else {
|
|
| 485 | -+ | ||
| 130 | +! |
- #' set.seed(1)+ checkmate::assert_numeric(size, len = 3, any.missing = FALSE, finite = TRUE, lower = 1, upper = 8) |
|
| 486 | -+ | ||
| 131 | +! |
- #' x <- runif(25, 0, 1)+ checkmate::assert_numeric(size[1], lower = size[2], upper = size[3], .var.name = "size") |
|
| 487 | +132 |
- #' y <- runif(25, 0, 1)+ } |
|
| 488 | +133 |
- #' x[c(3, 10, 18)] <- NA+ |
|
| 489 | -+ | ||
| 134 | +! |
- #'+ if (length(font_size) == 1) {
|
|
| 490 | -+ | ||
| 135 | +! |
- #' get_scatterplotmatrix_stats(x, y, .f = stats::cor.test, .f_args = list(method = "pearson"))+ checkmate::assert_numeric(font_size, any.missing = FALSE, finite = TRUE, lower = 8, upper = 20) |
|
| 491 | +136 |
- #' get_scatterplotmatrix_stats(x, y, .f = stats::cor.test, .f_args = list(+ } else {
|
|
| 492 | -+ | ||
| 137 | +! |
- #' method = "pearson",+ checkmate::assert_numeric(font_size, len = 3, any.missing = FALSE, finite = TRUE, lower = 8, upper = 20) |
|
| 493 | -+ | ||
| 138 | +! |
- #' na.action = na.fail+ checkmate::assert_numeric(font_size[1], lower = font_size[2], upper = font_size[3], .var.name = "font_size") |
|
| 494 | +139 |
- #' ))+ } |
|
| 495 | +140 |
- get_scatterplotmatrix_stats <- function(x, y,+ |
|
| 496 | -+ | ||
| 141 | +! |
- .f = stats::cor.test,+ checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE) |
|
| 497 | -+ | ||
| 142 | +! |
- .f_args = list(),+ checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height") |
|
| 498 | -+ | ||
| 143 | +! |
- round_stat = 2,+ checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE) |
|
| 499 | -+ | ||
| 144 | +! |
- round_pval = 4) {
+ checkmate::assert_numeric( |
|
| 500 | -6x | +||
| 145 | +! |
- if (is.numeric(x) && is.numeric(y)) {
+ plot_width[1], |
|
| 501 | -3x | +||
| 146 | +! |
- stat <- tryCatch(do.call(.f, c(list(~ x + y), .f_args)), error = function(e) NA)+ lower = plot_width[2], upper = plot_width[3], null.ok = TRUE, .var.name = "plot_width" |
|
| 502 | +147 | - - | -|
| 503 | -3x | -
- if (anyNA(stat)) {
+ ) |
|
| 504 | -1x | +||
| 148 | +
- return("NA")
+
|
||
| 505 | -2x | +||
| 149 | +! |
- } else if (all(c("estimate", "p.value") %in% names(stat))) {
+ plot_choices <- c("Elbow plot", "Circle plot", "Biplot", "Eigenvector plot")
|
|
| 506 | -2x | +||
| 150 | +! |
- return(paste(+ checkmate::assert_list(ggplot2_args, types = "ggplot2_args") |
|
| 507 | -2x | +||
| 151 | +! |
- c(+ checkmate::assert_subset(names(ggplot2_args), c("default", plot_choices))
|
|
| 508 | -2x | +||
| 152 | +
- paste0(names(stat$estimate), ":", round(stat$estimate, round_stat)),+ |
||
| 509 | -2x | +||
| 153 | +! |
- paste0("P:", round(stat$p.value, round_pval))
+ args <- as.list(environment()) |
|
| 510 | +154 |
- ),- |
- |
| 511 | -2x | -
- collapse = "\n"+ |
|
| 512 | -+ | ||
| 155 | +! |
- ))+ data_extract_list <- list(dat = dat) |
|
| 513 | +156 |
- } else {
+
|
|
| 514 | +157 | ! |
- stop("function not supported")
- |
-
| 515 | -- |
- }+ module( |
|
| 516 | -+ | ||
| 158 | +! |
- } else {
+ label = label, |
|
| 517 | -3x | +||
| 159 | +! |
- if ("method" %in% names(.f_args)) {
+ server = srv_a_pca, |
|
| 518 | -3x | +||
| 160 | +! |
- if (.f_args$method == "pearson") {
+ ui = ui_a_pca, |
|
| 519 | -1x | +||
| 161 | +! |
- return("cor:-")
+ ui_args = args, |
|
| 520 | -+ | ||
| 162 | +! |
- }+ server_args = c( |
|
| 521 | -2x | +||
| 163 | +! |
- if (.f_args$method == "kendall") {
+ data_extract_list, |
|
| 522 | -1x | +||
| 164 | +! |
- return("tau:-")
+ list( |
|
| 523 | -+ | ||
| 165 | +! |
- }+ plot_height = plot_height, |
|
| 524 | -1x | +||
| 166 | +! |
- if (.f_args$method == "spearman") {
+ plot_width = plot_width, |
|
| 525 | -1x | +||
| 167 | +! |
- return("rho:-")
+ ggplot2_args = ggplot2_args |
|
| 526 | +168 |
- }+ ) |
|
| 527 | +169 |
- }+ ), |
|
| 528 | +170 | ! |
- return("-")
+ datanames = teal.transform::get_extract_datanames(data_extract_list) |
| 529 | +171 |
- }+ ) |
|
| 530 | +172 |
} |
| 1 | +173 |
- #' Principal component analysis module+ |
|
| 2 | +174 |
- #' @md+ |
|
| 3 | +175 |
- #'+ ui_a_pca <- function(id, ...) {
|
|
| 4 | -+ | ||
| 176 | +! |
- #' @inheritParams teal::module+ ns <- NS(id) |
|
| 5 | -+ | ||
| 177 | +! |
- #' @inheritParams shared_params+ args <- list(...) |
|
| 6 | -+ | ||
| 178 | +! |
- #' @param dat (`data_extract_spec` or `list` of multiple `data_extract_spec`)+ is_single_dataset_value <- teal.transform::is_single_dataset(args$dat) |
|
| 7 | +179 |
- #' Columns used to compute PCA.+ |
|
| 8 | -+ | ||
| 180 | +! |
- #' @param alpha optional, (`numeric`) If scalar then the plot points will have a fixed opacity. If a+ color_selector <- args$dat |
|
| 9 | -+ | ||
| 181 | +! |
- #' slider should be presented to adjust the plot point opacity dynamically then it can be a vector of+ for (i in seq_along(color_selector)) {
|
|
| 10 | -+ | ||
| 182 | +! |
- #' length three with `c(value, min, max)`.+ color_selector[[i]]$select$multiple <- FALSE |
|
| 11 | -+ | ||
| 183 | +! |
- #' @param size optional, (`numeric`) If scalar then the plot point sizes will have a fixed size.+ color_selector[[i]]$select$always_selected <- NULL |
|
| 12 | -+ | ||
| 184 | +! |
- #' If a slider should be presented to adjust the plot point sizes dynamically then it can be a+ color_selector[[i]]$select$selected <- NULL |
|
| 13 | +185 |
- #' vector of length three with `c(value, min, max)`.+ } |
|
| 14 | +186 |
- #' @param font_size optional, (`numeric`) font size control for title, x-axis label, y-axis label and legend.+ |
|
| 15 | -+ | ||
| 187 | +! |
- #' If scalar then the font size will have a fixed size. If a slider should be presented to adjust the plot+ shiny::tagList( |
|
| 16 | -+ | ||
| 188 | +! |
- #' point sizes dynamically then it can be a vector of length three with `c(value, min, max)`.+ include_css_files("custom"),
|
|
| 17 | -+ | ||
| 189 | +! |
- #'+ teal.widgets::standard_layout( |
|
| 18 | -+ | ||
| 190 | +! |
- #' @templateVar ggnames "Elbow plot", "Circle plot", "Biplot", "Eigenvector plot"+ output = teal.widgets::white_small_well( |
|
| 19 | -+ | ||
| 191 | +! |
- #' @template ggplot2_args_multi+ uiOutput(ns("all_plots"))
|
|
| 20 | +192 |
- #'+ ), |
|
| 21 | -+ | ||
| 193 | +! |
- #' @examples+ encoding = div( |
|
| 22 | +194 |
- #' # general data example+ ### Reporter |
|
| 23 | -+ | ||
| 195 | +! |
- #' library(teal.widgets)+ teal.reporter::simple_reporter_ui(ns("simple_reporter")),
|
|
| 24 | +196 |
- #'+ ### |
|
| 25 | -+ | ||
| 197 | +! |
- #' data <- teal_data()+ tags$label("Encodings", class = "text-primary"),
|
|
| 26 | -+ | ||
| 198 | +! |
- #' data <- within(data, {
+ teal.transform::datanames_input(args["dat"]), |
|
| 27 | -+ | ||
| 199 | +! |
- #' library(nestcolor)+ teal.transform::data_extract_ui( |
|
| 28 | -+ | ||
| 200 | +! |
- #' USArrests <- USArrests+ id = ns("dat"),
|
|
| 29 | -+ | ||
| 201 | +! |
- #' })+ label = "Data selection", |
|
| 30 | -+ | ||
| 202 | +! |
- #' datanames(data) <- "USArrests"+ data_extract_spec = args$dat, |
|
| 31 | -+ | ||
| 203 | +! |
- #'+ is_single_dataset = is_single_dataset_value |
|
| 32 | +204 |
- #' app <- init(+ ), |
|
| 33 | -+ | ||
| 205 | +! |
- #' data = data,+ teal.widgets::panel_group( |
|
| 34 | -+ | ||
| 206 | +! |
- #' modules = modules(+ teal.widgets::panel_item( |
|
| 35 | -+ | ||
| 207 | +! |
- #' tm_a_pca(+ title = "Display", |
|
| 36 | -+ | ||
| 208 | +! |
- #' "PCA",+ collapsed = FALSE, |
|
| 37 | -+ | ||
| 209 | +! |
- #' dat = data_extract_spec(+ checkboxGroupInput( |
|
| 38 | -+ | ||
| 210 | +! |
- #' dataname = "USArrests",+ ns("tables_display"),
|
|
| 39 | -+ | ||
| 211 | +! |
- #' select = select_spec(+ "Tables display", |
|
| 40 | -+ | ||
| 212 | +! |
- #' choices = variable_choices(+ choices = c("PC importance" = "importance", "Eigenvectors" = "eigenvector"),
|
|
| 41 | -+ | ||
| 213 | +! |
- #' data = data[["USArrests"]], c("Murder", "Assault", "UrbanPop", "Rape")
+ selected = c("importance", "eigenvector")
|
|
| 42 | +214 |
- #' ),+ ), |
|
| 43 | -+ | ||
| 215 | +! |
- #' selected = c("Murder", "Assault"),
+ radioButtons( |
|
| 44 | -+ | ||
| 216 | +! |
- #' multiple = TRUE+ ns("plot_type"),
|
|
| 45 | -+ | ||
| 217 | +! |
- #' ),+ label = "Plot type", |
|
| 46 | -+ | ||
| 218 | +! |
- #' filter = NULL+ choices = args$plot_choices, |
|
| 47 | -+ | ||
| 219 | +! |
- #' ),+ selected = args$plot_choices[1] |
|
| 48 | +220 |
- #' ggplot2_args = ggplot2_args(+ ) |
|
| 49 | +221 |
- #' labs = list(subtitle = "Plot generated by PCA Module")+ ), |
|
| 50 | -+ | ||
| 222 | +! |
- #' )+ teal.widgets::panel_item( |
|
| 51 | -+ | ||
| 223 | +! |
- #' )+ title = "Pre-processing", |
|
| 52 | -+ | ||
| 224 | +! |
- #' )+ radioButtons( |
|
| 53 | -+ | ||
| 225 | +! |
- #' )+ ns("standardization"), "Standardization",
|
|
| 54 | -+ | ||
| 226 | +! |
- #'+ choices = c("None" = "none", "Center" = "center", "Center & Scale" = "center_scale"),
|
|
| 55 | -+ | ||
| 227 | +! |
- #' if (interactive()) {
+ selected = "center_scale" |
|
| 56 | +228 |
- #' shinyApp(app$ui, app$server)+ ), |
|
| 57 | -+ | ||
| 229 | +! |
- #' }+ radioButtons( |
|
| 58 | -+ | ||
| 230 | +! |
- #'+ ns("na_action"), "NA action",
|
|
| 59 | -+ | ||
| 231 | +! |
- #' # CDISC data example+ choices = c("None" = "none", "Drop" = "drop"),
|
|
| 60 | -+ | ||
| 232 | +! |
- #' library(teal.widgets)+ selected = "none" |
|
| 61 | +233 |
- #'+ ) |
|
| 62 | +234 |
- #' data <- teal_data()+ ), |
|
| 63 | -+ | ||
| 235 | +! |
- #' data <- within(data, {
+ teal.widgets::panel_item( |
|
| 64 | -+ | ||
| 236 | +! |
- #' library(nestcolor)+ title = "Selected plot specific settings", |
|
| 65 | -+ | ||
| 237 | +! |
- #' ADSL <- rADSL+ collapsed = FALSE, |
|
| 66 | -+ | ||
| 238 | +! |
- #' })+ uiOutput(ns("plot_settings")),
|
|
| 67 | -+ | ||
| 239 | +! |
- #' datanames(data) <- "ADSL"+ conditionalPanel( |
|
| 68 | -+ | ||
| 240 | +! |
- #' join_keys(data) <- default_cdisc_join_keys[datanames(data)]+ condition = sprintf("input['%s'] == 'Biplot'", ns("plot_type")),
|
|
| 69 | -+ | ||
| 241 | +! |
- #'+ list( |
|
| 70 | -+ | ||
| 242 | +! |
- #' app <- init(+ teal.transform::data_extract_ui( |
|
| 71 | -+ | ||
| 243 | +! |
- #' data = data,+ id = ns("response"),
|
|
| 72 | -+ | ||
| 244 | +! |
- #' modules = modules(+ label = "Color by", |
|
| 73 | -+ | ||
| 245 | +! |
- #' teal.modules.general::tm_a_pca(+ data_extract_spec = color_selector, |
|
| 74 | -+ | ||
| 246 | +! |
- #' "PCA",+ is_single_dataset = is_single_dataset_value |
|
| 75 | +247 |
- #' dat = data_extract_spec(+ ), |
|
| 76 | -+ | ||
| 248 | +! |
- #' dataname = "ADSL",+ teal.widgets::optionalSliderInputValMinMax(ns("alpha"), "Opacity:", args$alpha, ticks = FALSE),
|
|
| 77 | -+ | ||
| 249 | +! |
- #' select = select_spec(+ teal.widgets::optionalSliderInputValMinMax(ns("size"), "Points size:", args$size, ticks = FALSE)
|
|
| 78 | +250 |
- #' choices = variable_choices(+ ) |
|
| 79 | +251 |
- #' data = data[["ADSL"]], c("BMRKR1", "AGE", "EOSDY")
+ ) |
|
| 80 | +252 |
- #' ),+ ), |
|
| 81 | -+ | ||
| 253 | +! |
- #' selected = c("BMRKR1", "AGE"),
+ teal.widgets::panel_item( |
|
| 82 | -+ | ||
| 254 | +! |
- #' multiple = TRUE+ title = "Plot settings", |
|
| 83 | -+ | ||
| 255 | +! |
- #' ),+ collapsed = TRUE, |
|
| 84 | -+ | ||
| 256 | +! |
- #' filter = NULL+ conditionalPanel( |
|
| 85 | -+ | ||
| 257 | +! |
- #' ),+ condition = sprintf( |
|
| 86 | -+ | ||
| 258 | +! |
- #' ggplot2_args = ggplot2_args(+ "input['%s'] == 'Elbow Plot' || input['%s'] == 'Eigenvector plot'", |
|
| 87 | -+ | ||
| 259 | +! |
- #' labs = list(subtitle = "Plot generated by PCA Module")+ ns("plot_type"),
|
|
| 88 | -+ | ||
| 260 | +! |
- #' )+ ns("plot_type")
|
|
| 89 | +261 |
- #' )+ ), |
|
| 90 | -+ | ||
| 262 | +! |
- #' )+ list(checkboxInput(ns("rotate_xaxis_labels"), "Rotate X axis labels", value = args$rotate_xaxis_labels))
|
|
| 91 | +263 |
- #' )+ ), |
|
| 92 | -+ | ||
| 264 | +! |
- #'+ selectInput( |
|
| 93 | -+ | ||
| 265 | +! |
- #' if (interactive()) {
+ inputId = ns("ggtheme"),
|
|
| 94 | -+ | ||
| 266 | +! |
- #' shinyApp(app$ui, app$server)+ label = "Theme (by ggplot):", |
|
| 95 | -+ | ||
| 267 | +! |
- #' }+ choices = ggplot_themes, |
|
| 96 | -+ | ||
| 268 | +! |
- #'+ selected = args$ggtheme, |
|
| 97 | -+ | ||
| 269 | +! |
- #' @export+ multiple = FALSE |
|
| 98 | +270 |
- #'+ ), |
|
| 99 | -+ | ||
| 271 | +! |
- tm_a_pca <- function(label = "Principal Component Analysis",+ teal.widgets::optionalSliderInputValMinMax(ns("font_size"), "Font Size", args$font_size, ticks = FALSE)
|
|
| 100 | +272 |
- dat,+ ) |
|
| 101 | +273 |
- plot_height = c(600, 200, 2000),+ ) |
|
| 102 | +274 |
- plot_width = NULL,+ ), |
|
| 103 | -+ | ||
| 275 | +! |
- ggtheme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void"),
+ forms = tagList( |
|
| 104 | -+ | ||
| 276 | +! |
- ggplot2_args = teal.widgets::ggplot2_args(),+ teal.widgets::verbatim_popup_ui(ns("warning"), "Show Warnings"),
|
|
| 105 | -+ | ||
| 277 | +! |
- rotate_xaxis_labels = FALSE,+ teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code")
|
|
| 106 | +278 |
- font_size = c(12, 8, 20),+ ),+ |
+ |
| 279 | +! | +
+ pre_output = args$pre_output,+ |
+ |
| 280 | +! | +
+ post_output = args$post_output |
|
| 107 | +281 |
- alpha = c(1, 0, 1),+ ) |
|
| 108 | +282 |
- size = c(2, 1, 8),+ ) |
|
| 109 | +283 |
- pre_output = NULL,+ } |
|
| 110 | +284 |
- post_output = NULL) {
+
|
|
| 111 | -! | +||
| 285 | +
- logger::log_info("Initializing tm_a_pca")
+ srv_a_pca <- function(id, data, reporter, filter_panel_api, dat, plot_height, plot_width, ggplot2_args) {
|
||
| 112 | +286 | ! |
- if (inherits(dat, "data_extract_spec")) dat <- list(dat)+ with_reporter <- !missing(reporter) && inherits(reporter, "Reporter") |
| 113 | +287 | ! |
- if (inherits(ggplot2_args, "ggplot2_args")) ggplot2_args <- list(default = ggplot2_args)- |
-
| 114 | -- |
-
+ with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI") |
|
| 115 | +288 | ! |
- checkmate::assert_string(label)+ checkmate::assert_class(data, "reactive") |
| 116 | +289 | ! |
- checkmate::assert_list(dat, types = "data_extract_spec")+ checkmate::assert_class(isolate(data()), "teal_data") |
| 117 | +290 | ! |
- ggtheme <- match.arg(ggtheme)+ moduleServer(id, function(input, output, session) {
|
| 118 | +291 | ! |
- checkmate::assert_flag(rotate_xaxis_labels)+ response <- dat |
| 119 | +292 | ||
| 120 | +293 | ! |
- if (length(alpha) == 1) {
+ for (i in seq_along(response)) {
|
| 121 | +294 | ! |
- checkmate::assert_numeric(alpha, any.missing = FALSE, finite = TRUE, lower = 0, upper = 1)+ response[[i]]$select$multiple <- FALSE |
| 122 | -+ | ||
| 295 | +! |
- } else {
+ response[[i]]$select$always_selected <- NULL |
|
| 123 | +296 | ! |
- checkmate::assert_numeric(alpha, len = 3, any.missing = FALSE, finite = TRUE, lower = 0, upper = 1)+ response[[i]]$select$selected <- NULL |
| 124 | +297 | ! |
- checkmate::assert_numeric(alpha[1], lower = alpha[2], upper = alpha[3], .var.name = "alpha")+ all_cols <- teal.data::col_labels(isolate(data())[[response[[i]]$dataname]]) |
| 125 | -+ | ||
| 298 | +! |
- }+ ignore_cols <- unlist(teal.data::join_keys(isolate(data()))[[response[[i]]$dataname]]) |
|
| 126 | -+ | ||
| 299 | +! |
-
+ color_cols <- all_cols[!names(all_cols) %in% ignore_cols] |
|
| 127 | +300 | ! |
- if (length(size) == 1) {
+ response[[i]]$select$choices <- choices_labeled(names(color_cols), color_cols) |
| 128 | -! | +||
| 301 | +
- checkmate::assert_numeric(size, any.missing = FALSE, finite = TRUE, lower = 1, upper = 8)+ } |
||
| 129 | +302 |
- } else {
+
|
|
| 130 | +303 | ! |
- checkmate::assert_numeric(size, len = 3, any.missing = FALSE, finite = TRUE, lower = 1, upper = 8)+ selector_list <- teal.transform::data_extract_multiple_srv( |
| 131 | +304 | ! |
- checkmate::assert_numeric(size[1], lower = size[2], upper = size[3], .var.name = "size")+ data_extract = list(dat = dat, response = response), |
| 132 | -+ | ||
| 305 | +! |
- }+ datasets = data, |
|
| 133 | -+ | ||
| 306 | +! |
-
+ select_validation_rule = list( |
|
| 134 | +307 | ! |
- if (length(font_size) == 1) {
+ dat = ~ if (length(.) < 2L) "Please select more than 1 variable to perform PCA.", |
| 135 | +308 | ! |
- checkmate::assert_numeric(font_size, any.missing = FALSE, finite = TRUE, lower = 8, upper = 20)+ response = shinyvalidate::compose_rules( |
| 136 | -+ | ||
| 309 | +! |
- } else {
+ shinyvalidate::sv_optional(), |
|
| 137 | +310 | ! |
- checkmate::assert_numeric(font_size, len = 3, any.missing = FALSE, finite = TRUE, lower = 8, upper = 20)+ ~ if (isTRUE(is.element(., selector_list()$dat()$select))) {
|
| 138 | +311 | ! |
- checkmate::assert_numeric(font_size[1], lower = font_size[2], upper = font_size[3], .var.name = "font_size")+ "Response must not have been used for PCA." |
| 139 | +312 |
- }+ } |
|
| 140 | +313 |
-
+ ) |
|
| 141 | -! | +||
| 314 | +
- checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE)+ ) |
||
| 142 | -! | +||
| 315 | +
- checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height")+ ) |
||
| 143 | -! | +||
| 316 | +
- checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE)+ |
||
| 144 | +317 | ! |
- checkmate::assert_numeric(+ iv_r <- reactive({
|
| 145 | +318 | ! |
- plot_width[1],+ iv <- shinyvalidate::InputValidator$new() |
| 146 | +319 | ! |
- lower = plot_width[2], upper = plot_width[3], null.ok = TRUE, .var.name = "plot_width"+ teal.transform::compose_and_enable_validators(iv, selector_list) |
| 147 | +320 |
- )+ }) |
|
| 148 | +321 | ||
| 149 | +322 | ! |
- plot_choices <- c("Elbow plot", "Circle plot", "Biplot", "Eigenvector plot")
+ iv_extra <- shinyvalidate::InputValidator$new() |
| 150 | +323 | ! |
- checkmate::assert_list(ggplot2_args, types = "ggplot2_args")+ iv_extra$add_rule("x_axis", function(value) {
|
| 151 | +324 | ! |
- checkmate::assert_subset(names(ggplot2_args), c("default", plot_choices))
+ if (isTRUE(input$plot_type %in% c("Circle plot", "Biplot"))) {
|
| 152 | -+ | ||
| 325 | +! |
-
+ if (!shinyvalidate::input_provided(value)) {
|
|
| 153 | +326 | ! |
- args <- as.list(environment())+ "Need X axis" |
| 154 | +327 |
-
+ } |
|
| 155 | -! | +||
| 328 | +
- data_extract_list <- list(dat = dat)+ } |
||
| 156 | +329 |
-
+ }) |
|
| 157 | +330 | ! |
- module(+ iv_extra$add_rule("y_axis", function(value) {
|
| 158 | +331 | ! |
- label = label,+ if (isTRUE(input$plot_type %in% c("Circle plot", "Biplot"))) {
|
| 159 | +332 | ! |
- server = srv_a_pca,+ if (!shinyvalidate::input_provided(value)) {
|
| 160 | +333 | ! |
- ui = ui_a_pca,+ "Need Y axis" |
| 161 | -! | +||
| 334 | +
- ui_args = args,+ } |
||
| 162 | -! | +||
| 335 | +
- server_args = c(+ } |
||
| 163 | -! | +||
| 336 | +
- data_extract_list,+ }) |
||
| 164 | +337 | ! |
- list(+ rule_dupl <- function(...) {
|
| 165 | +338 | ! |
- plot_height = plot_height,+ if (isTRUE(input$plot_type %in% c("Circle plot", "Biplot"))) {
|
| 166 | +339 | ! |
- plot_width = plot_width,+ if (isTRUE(input$x_axis == input$y_axis)) {
|
| 167 | +340 | ! |
- ggplot2_args = ggplot2_args+ "Please choose different X and Y axes." |
| 168 | +341 |
- )+ } |
|
| 169 | +342 |
- ),- |
- |
| 170 | -! | -
- datanames = teal.transform::get_extract_datanames(data_extract_list)+ } |
|
| 171 | +343 |
- )+ } |
|
| 172 | -+ | ||
| 344 | +! |
- }+ iv_extra$add_rule("x_axis", rule_dupl)
|
|
| 173 | -+ | ||
| 345 | +! |
-
+ iv_extra$add_rule("y_axis", rule_dupl)
|
|
| 174 | -+ | ||
| 346 | +! |
-
+ iv_extra$add_rule("variables", function(value) {
|
|
| 175 | -+ | ||
| 347 | +! |
- ui_a_pca <- function(id, ...) {
+ if (identical(input$plot_type, "Circle plot")) {
|
|
| 176 | +348 | ! |
- ns <- NS(id)+ if (!shinyvalidate::input_provided(value)) {
|
| 177 | +349 | ! |
- args <- list(...)+ "Need Original Coordinates" |
| 178 | -! | +||
| 350 | +
- is_single_dataset_value <- teal.transform::is_single_dataset(args$dat)+ } |
||
| 179 | +351 |
-
+ } |
|
| 180 | -! | +||
| 352 | +
- color_selector <- args$dat+ }) |
||
| 181 | +353 | ! |
- for (i in seq_along(color_selector)) {
+ iv_extra$add_rule("pc", function(value) {
|
| 182 | +354 | ! |
- color_selector[[i]]$select$multiple <- FALSE+ if (identical(input$plot_type, "Eigenvector plot")) {
|
| 183 | +355 | ! |
- color_selector[[i]]$select$always_selected <- NULL+ if (!shinyvalidate::input_provided(value)) {
|
| 184 | +356 | ! |
- color_selector[[i]]$select$selected <- NULL+ "Need PC" |
| 185 | +357 |
- }+ } |
|
| 186 | +358 |
-
+ } |
|
| 187 | -! | +||
| 359 | +
- shiny::tagList(+ }) |
||
| 188 | +360 | ! |
- include_css_files("custom"),
+ iv_extra$enable()+ |
+
| 361 | ++ | + | |
| 189 | +362 | ! |
- teal.widgets::standard_layout(+ anl_merged_input <- teal.transform::merge_expression_srv( |
| 190 | +363 | ! |
- output = teal.widgets::white_small_well(+ selector_list = selector_list, |
| 191 | +364 | ! |
- uiOutput(ns("all_plots"))
+ datasets = data |
| 192 | +365 |
- ),- |
- |
| 193 | -! | -
- encoding = div(+ ) |
|
| 194 | +366 |
- ### Reporter+ |
|
| 195 | +367 | ! |
- teal.reporter::simple_reporter_ui(ns("simple_reporter")),
+ anl_merged_q <- reactive({
|
| 196 | -+ | ||
| 368 | +! |
- ###+ req(anl_merged_input()) |
|
| 197 | +369 | ! |
- tags$label("Encodings", class = "text-primary"),
+ data() %>% |
| 198 | +370 | ! |
- teal.transform::datanames_input(args["dat"]),+ teal.code::eval_code(as.expression(anl_merged_input()$expr)) |
| 199 | -! | +||
| 371 | +
- teal.transform::data_extract_ui(+ }) |
||
| 200 | -! | +||
| 372 | +
- id = ns("dat"),
+
|
||
| 201 | +373 | ! |
- label = "Data selection",+ merged <- list( |
| 202 | +374 | ! |
- data_extract_spec = args$dat,+ anl_input_r = anl_merged_input, |
| 203 | +375 | ! |
- is_single_dataset = is_single_dataset_value+ anl_q_r = anl_merged_q |
| 204 | +376 |
- ),+ ) |
|
| 205 | -! | +||
| 377 | +
- teal.widgets::panel_group(+ |
||
| 206 | +378 | ! |
- teal.widgets::panel_item(+ validation <- reactive({
|
| 207 | +379 | ! |
- title = "Display",+ req(merged$anl_q_r())+ |
+
| 380 | ++ |
+ # inputs |
|
| 208 | +381 | ! |
- collapsed = FALSE,+ keep_cols <- as.character(merged$anl_input_r()$columns_source$dat) |
| 209 | +382 | ! |
- checkboxGroupInput(+ na_action <- input$na_action |
| 210 | +383 | ! |
- ns("tables_display"),
+ standardization <- input$standardization |
| 211 | +384 | ! |
- "Tables display",+ center <- standardization %in% c("center", "center_scale")
|
| 212 | +385 | ! |
- choices = c("PC importance" = "importance", "Eigenvectors" = "eigenvector"),
+ scale <- standardization == "center_scale" |
| 213 | +386 | ! |
- selected = c("importance", "eigenvector")
+ ANL <- merged$anl_q_r()[["ANL"]] # nolint: object_name. |
| 214 | +387 |
- ),+ |
|
| 215 | +388 | ! |
- radioButtons(+ teal::validate_has_data(ANL, 10) |
| 216 | +389 | ! |
- ns("plot_type"),
+ validate(need( |
| 217 | +390 | ! |
- label = "Plot type",+ na_action != "none" | !anyNA(ANL[keep_cols]), |
| 218 | +391 | ! |
- choices = args$plot_choices,+ paste( |
| 219 | +392 | ! |
- selected = args$plot_choices[1]+ "There are NAs in the dataset. Please deal with them in preprocessing",+ |
+
| 393 | +! | +
+ "or select \"Drop\" in the NA actions inside the encodings panel (left)." |
|
| 220 | +394 |
- )+ ) |
|
| 221 | +395 |
- ),+ )) |
|
| 222 | +396 | ! |
- teal.widgets::panel_item(+ if (scale) {
|
| 223 | +397 | ! |
- title = "Pre-processing",+ not_single <- vapply(ANL[keep_cols], function(column) length(unique(column)) != 1, FUN.VALUE = logical(1)) |
| 224 | -! | +||
| 398 | +
- radioButtons(+ |
||
| 225 | +399 | ! |
- ns("standardization"), "Standardization",
+ msg <- paste0( |
| 226 | +400 | ! |
- choices = c("None" = "none", "Center" = "center", "Center & Scale" = "center_scale"),
+ "You have selected `Center & Scale` under `Standardization` in the `Pre-processing` panel, ", |
| 227 | +401 | ! |
- selected = "center_scale"+ "but one or more of your columns has/have a variance value of zero, indicating all values are identical" |
| 228 | +402 |
- ),- |
- |
| 229 | -! | -
- radioButtons(+ ) |
|
| 230 | +403 | ! |
- ns("na_action"), "NA action",
+ validate(need(all(not_single), msg)) |
| 231 | -! | +||
| 404 | +
- choices = c("None" = "none", "Drop" = "drop"),
+ } |
||
| 232 | -! | +||
| 405 | +
- selected = "none"+ }) |
||
| 233 | +406 |
- )+ |
|
| 234 | +407 |
- ),+ # computation ---- |
|
| 235 | +408 | ! |
- teal.widgets::panel_item(+ computation <- reactive({
|
| 236 | +409 | ! |
- title = "Selected plot specific settings",+ validation() |
| 237 | -! | +||
| 410 | +
- collapsed = FALSE,+ |
||
| 238 | -! | +||
| 411 | +
- uiOutput(ns("plot_settings")),
+ # inputs |
||
| 239 | +412 | ! |
- conditionalPanel(+ keep_cols <- as.character(merged$anl_input_r()$columns_source$dat) |
| 240 | +413 | ! |
- condition = sprintf("input['%s'] == 'Biplot'", ns("plot_type")),
+ na_action <- input$na_action |
| 241 | +414 | ! |
- list(+ standardization <- input$standardization |
| 242 | +415 | ! |
- teal.transform::data_extract_ui(+ center <- standardization %in% c("center", "center_scale")
|
| 243 | +416 | ! |
- id = ns("response"),
+ scale <- standardization == "center_scale" |
| 244 | +417 | ! |
- label = "Color by",+ ANL <- merged$anl_q_r()[["ANL"]] # nolint: object_name.+ |
+
| 418 | ++ | + | |
| 245 | +419 | ! |
- data_extract_spec = color_selector,+ qenv <- teal.code::eval_code( |
| 246 | +420 | ! |
- is_single_dataset = is_single_dataset_value+ merged$anl_q_r(), |
| 247 | -+ | ||
| 421 | +! |
- ),+ substitute( |
|
| 248 | +422 | ! |
- teal.widgets::optionalSliderInputValMinMax(ns("alpha"), "Opacity:", args$alpha, ticks = FALSE),
+ expr = keep_columns <- keep_cols, |
| 249 | +423 | ! |
- teal.widgets::optionalSliderInputValMinMax(ns("size"), "Points size:", args$size, ticks = FALSE)
+ env = list(keep_cols = keep_cols) |
| 250 | +424 |
- )+ ) |
|
| 251 | +425 |
- )+ ) |
|
| 252 | +426 |
- ),+ |
|
| 253 | +427 | ! |
- teal.widgets::panel_item(+ if (na_action == "drop") {
|
| 254 | +428 | ! |
- title = "Plot settings",+ qenv <- teal.code::eval_code( |
| 255 | +429 | ! |
- collapsed = TRUE,+ qenv, |
| 256 | +430 | ! |
- conditionalPanel(+ quote(ANL <- tidyr::drop_na(ANL, keep_columns)) # nolint: object_name. |
| 257 | -! | +||
| 431 | +
- condition = sprintf(+ ) |
||
| 258 | -! | +||
| 432 | +
- "input['%s'] == 'Elbow Plot' || input['%s'] == 'Eigenvector plot'",+ } |
||
| 259 | -! | +||
| 433 | +
- ns("plot_type"),
+
|
||
| 260 | +434 | ! |
- ns("plot_type")
+ qenv <- teal.code::eval_code( |
| 261 | -+ | ||
| 435 | +! |
- ),+ qenv, |
|
| 262 | +436 | ! |
- list(checkboxInput(ns("rotate_xaxis_labels"), "Rotate X axis labels", value = args$rotate_xaxis_labels))
+ substitute( |
| 263 | -+ | ||
| 437 | +! |
- ),+ expr = pca <- summary(stats::prcomp(ANL[keep_columns], center = center, scale. = scale, retx = TRUE)), |
|
| 264 | +438 | ! |
- selectInput(+ env = list(center = center, scale = scale) |
| 265 | -! | +||
| 439 | +
- inputId = ns("ggtheme"),
+ ) |
||
| 266 | -! | +||
| 440 | +
- label = "Theme (by ggplot):",+ )+ |
+ ||
| 441 | ++ | + | |
| 267 | +442 | ! |
- choices = ggplot_themes,+ qenv <- teal.code::eval_code( |
| 268 | +443 | ! |
- selected = args$ggtheme,+ qenv, |
| 269 | +444 | ! |
- multiple = FALSE+ quote({
|
| 270 | -+ | ||
| 445 | +! |
- ),+ tbl_importance <- dplyr::as_tibble(pca$importance, rownames = "Metric") |
|
| 271 | +446 | ! |
- teal.widgets::optionalSliderInputValMinMax(ns("font_size"), "Font Size", args$font_size, ticks = FALSE)
+ tbl_importance |
| 272 | +447 |
- )+ }) |
|
| 273 | +448 |
- )+ ) |
|
| 274 | +449 |
- ),+ |
|
| 275 | +450 | ! |
- forms = tagList(+ teal.code::eval_code( |
| 276 | +451 | ! |
- teal.widgets::verbatim_popup_ui(ns("warning"), "Show Warnings"),
+ qenv, |
| 277 | +452 | ! |
- teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code")
- |
-
| 278 | -- |
- ),+ quote({
|
|
| 279 | +453 | ! |
- pre_output = args$pre_output,+ tbl_eigenvector <- dplyr::as_tibble(pca$rotation, rownames = "Variable") |
| 280 | +454 | ! |
- post_output = args$post_output+ tbl_eigenvector |
| 281 | +455 |
- )+ }) |
|
| 282 | +456 |
- )+ ) |
|
| 283 | +457 |
- }+ }) |
|
| 284 | +458 | ||
| 285 | +459 |
- srv_a_pca <- function(id, data, reporter, filter_panel_api, dat, plot_height, plot_width, ggplot2_args) {
+ # plot args ---- |
|
| 286 | +460 | ! |
- with_reporter <- !missing(reporter) && inherits(reporter, "Reporter")+ output$plot_settings <- renderUI({
|
| 287 | -! | +||
| 461 | +
- with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI")+ # reactivity triggers |
||
| 288 | +462 | ! |
- checkmate::assert_class(data, "reactive")+ req(iv_r()$is_valid()) |
| 289 | +463 | ! |
- checkmate::assert_class(isolate(data()), "teal_data")+ req(computation()) |
| 290 | +464 | ! |
- moduleServer(id, function(input, output, session) {
+ qenv <- computation()+ |
+
| 465 | ++ | + | |
| 291 | +466 | ! |
- response <- dat+ ns <- session$ns |
| 292 | +467 | ||
| 293 | +468 | ! |
- for (i in seq_along(response)) {
+ pca <- qenv[["pca"]] |
| 294 | +469 | ! |
- response[[i]]$select$multiple <- FALSE+ chcs_pcs <- colnames(pca$rotation) |
| 295 | +470 | ! |
- response[[i]]$select$always_selected <- NULL+ chcs_vars <- qenv[["keep_columns"]] |
| 296 | -! | +||
| 471 | +
- response[[i]]$select$selected <- NULL+ |
||
| 297 | +472 | ! |
- response[[i]]$select$choices <- var_labels(isolate(data())[[response[[i]]$dataname]])+ tagList( |
| 298 | +473 | ! |
- response[[i]]$select$choices <- setdiff(+ conditionalPanel( |
| 299 | +474 | ! |
- response[[i]]$select$choices,+ condition = sprintf( |
| 300 | +475 | ! |
- unlist(teal.data::join_keys(isolate(data()))[[response[[i]]$dataname]])- |
-
| 301 | -- |
- )+ "input['%s'] == 'Biplot' || input['%s'] == 'Circle plot'", |
|
| 302 | -+ | ||
| 476 | +! |
- }+ ns("plot_type"), ns("plot_type")
|
|
| 303 | +477 |
-
+ ), |
|
| 304 | +478 | ! |
- selector_list <- teal.transform::data_extract_multiple_srv(+ list( |
| 305 | +479 | ! |
- data_extract = list(dat = dat, response = response),+ teal.widgets::optionalSelectInput(ns("x_axis"), "X axis", choices = chcs_pcs, selected = chcs_pcs[1]),
|
| 306 | +480 | ! |
- datasets = data,+ teal.widgets::optionalSelectInput(ns("y_axis"), "Y axis", choices = chcs_pcs, selected = chcs_pcs[2]),
|
| 307 | +481 | ! |
- select_validation_rule = list(+ teal.widgets::optionalSelectInput( |
| 308 | +482 | ! |
- dat = ~ if (length(.) < 2L) "Please select more than 1 variable to perform PCA.",+ ns("variables"), "Original coordinates",
|
| 309 | +483 | ! |
- response = shinyvalidate::compose_rules(+ choices = chcs_vars, selected = chcs_vars, |
| 310 | +484 | ! |
- shinyvalidate::sv_optional(),+ multiple = TRUE |
| 311 | -! | +||
| 485 | +
- ~ if (isTRUE(is.element(., selector_list()$dat()$select))) {
+ ) |
||
| 312 | -! | +||
| 486 | +
- "Response must not have been used for PCA."+ ) |
||
| 313 | +487 |
- }+ ), |
|
| 314 | -+ | ||
| 488 | +! |
- )+ conditionalPanel( |
|
| 315 | -+ | ||
| 489 | +! |
- )+ condition = sprintf("input['%s'] == 'Elbow plot'", ns("plot_type")),
|
|
| 316 | -+ | ||
| 490 | +! |
- )+ helpText("No plot specific settings available.")
|
|
| 317 | +491 |
-
+ ), |
|
| 318 | +492 | ! |
- iv_r <- reactive({
+ conditionalPanel( |
| 319 | +493 | ! |
- iv <- shinyvalidate::InputValidator$new()+ condition = paste0("input['", ns("plot_type"), "'] == 'Eigenvector plot'"),
|
| 320 | +494 | ! |
- teal.transform::compose_and_enable_validators(iv, selector_list)+ teal.widgets::optionalSelectInput(ns("pc"), "PC", choices = chcs_pcs, selected = chcs_pcs[1])
|
| 321 | +495 | ++ |
+ )+ |
+
| 496 | ++ |
+ )+ |
+ |
| 497 |
}) |
||
| 322 | +498 | ||
| 323 | -! | +||
| 499 | +
- iv_extra <- shinyvalidate::InputValidator$new()+ # plot elbow ---- |
||
| 324 | +500 | ! |
- iv_extra$add_rule("x_axis", function(value) {
+ plot_elbow <- function(base_q) {
|
| 325 | +501 | ! |
- if (isTRUE(input$plot_type %in% c("Circle plot", "Biplot"))) {
+ ggtheme <- input$ggtheme |
| 326 | +502 | ! |
- if (!shinyvalidate::input_provided(value)) {
+ rotate_xaxis_labels <- input$rotate_xaxis_labels |
| 327 | +503 | ! |
- "Need X axis"+ font_size <- input$font_size |
| 328 | +504 |
- }+ |
|
| 329 | -+ | ||
| 505 | +! |
- }+ angle_value <- ifelse(isTRUE(rotate_xaxis_labels), 45, 0)+ |
+ |
| 506 | +! | +
+ hjust_value <- ifelse(isTRUE(rotate_xaxis_labels), 1, 0.5) |
|
| 330 | +507 |
- })+ |
|
| 331 | +508 | ! |
- iv_extra$add_rule("y_axis", function(value) {
+ dev_ggplot2_args <- teal.widgets::ggplot2_args( |
| 332 | +509 | ! |
- if (isTRUE(input$plot_type %in% c("Circle plot", "Biplot"))) {
+ labs = list(x = "Principal component", y = "Proportion of variance explained", color = "", fill = "Legend"), |
| 333 | +510 | ! |
- if (!shinyvalidate::input_provided(value)) {
+ theme = list( |
| 334 | +511 | ! |
- "Need Y axis"+ legend.position = "right", |
| 335 | -+ | ||
| 512 | +! |
- }+ legend.spacing.y = quote(grid::unit(-5, "pt")), |
|
| 336 | -+ | ||
| 513 | +! |
- }+ legend.title = quote(element_text(vjust = 25)), |
|
| 337 | -+ | ||
| 514 | +! |
- })+ axis.text.x = substitute( |
|
| 338 | +515 | ! |
- rule_dupl <- function(...) {
+ element_text(angle = angle_value, hjust = hjust_value), |
| 339 | +516 | ! |
- if (isTRUE(input$plot_type %in% c("Circle plot", "Biplot"))) {
+ list(angle_value = angle_value, hjust_value = hjust_value) |
| 340 | -! | +||
| 517 | +
- if (isTRUE(input$x_axis == input$y_axis)) {
+ ), |
||
| 341 | +518 | ! |
- "Please choose different X and Y axes."+ text = substitute(element_text(size = font_size), list(font_size = font_size)) |
| 342 | +519 |
- }+ ) |
|
| 343 | +520 |
- }+ ) |
|
| 344 | +521 |
- }+ |
|
| 345 | +522 | ! |
- iv_extra$add_rule("x_axis", rule_dupl)
+ parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args( |
| 346 | +523 | ! |
- iv_extra$add_rule("y_axis", rule_dupl)
+ teal.widgets::resolve_ggplot2_args( |
| 347 | +524 | ! |
- iv_extra$add_rule("variables", function(value) {
+ user_plot = ggplot2_args[["Elbow plot"]], |
| 348 | +525 | ! |
- if (identical(input$plot_type, "Circle plot")) {
+ user_default = ggplot2_args$default, |
| 349 | +526 | ! |
- if (!shinyvalidate::input_provided(value)) {
+ module_plot = dev_ggplot2_args |
| 350 | -! | +||
| 527 | +
- "Need Original Coordinates"+ ), |
||
| 351 | -+ | ||
| 528 | +! |
- }+ ggtheme = ggtheme |
|
| 352 | +529 |
- }+ ) |
|
| 353 | +530 |
- })+ |
|
| 354 | +531 | ! |
- iv_extra$add_rule("pc", function(value) {
+ teal.code::eval_code( |
| 355 | +532 | ! |
- if (identical(input$plot_type, "Eigenvector plot")) {
+ base_q, |
| 356 | +533 | ! |
- if (!shinyvalidate::input_provided(value)) {
+ substitute( |
| 357 | +534 | ! |
- "Need PC"+ expr = {
|
| 358 | -+ | ||
| 535 | +! |
- }- |
- |
| 359 | -- |
- }- |
- |
| 360 | -- |
- })+ elb_dat <- pca$importance[c("Proportion of Variance", "Cumulative Proportion"), ] %>%
|
|
| 361 | +536 | ! |
- iv_extra$enable()- |
-
| 362 | -- |
-
+ dplyr::as_tibble(rownames = "metric") %>% |
|
| 363 | +537 | ! |
- anl_merged_input <- teal.transform::merge_expression_srv(+ tidyr::gather("component", "value", -metric) %>%
|
| 364 | +538 | ! |
- selector_list = selector_list,+ dplyr::mutate( |
| 365 | +539 | ! |
- datasets = data+ component = factor(component, levels = unique(stringr::str_sort(component, numeric = TRUE))) |
| 366 | +540 |
- )+ ) |
|
| 367 | +541 | ||
| 368 | +542 | ! |
- anl_merged_q <- reactive({
+ cols <- c(getOption("ggplot2.discrete.colour"), c("lightblue", "darkred", "black"))[1:3]
|
| 369 | +543 | ! |
- req(anl_merged_input())+ g <- ggplot(mapping = aes_string(x = "component", y = "value")) + |
| 370 | +544 | ! |
- data() %>%+ geom_bar( |
| 371 | +545 | ! |
- teal.code::eval_code(as.expression(anl_merged_input()$expr))+ aes(fill = "Single variance"), |
| 372 | -+ | ||
| 546 | +! |
- })+ data = dplyr::filter(elb_dat, metric == "Proportion of Variance"),+ |
+ |
| 547 | +! | +
+ color = "black",+ |
+ |
| 548 | +! | +
+ stat = "identity" |
|
| 373 | +549 |
-
+ ) + |
|
| 374 | +550 | ! |
- merged <- list(+ geom_point( |
| 375 | +551 | ! |
- anl_input_r = anl_merged_input,+ aes(color = "Cumulative variance"), |
| 376 | +552 | ! |
- anl_q_r = anl_merged_q+ data = dplyr::filter(elb_dat, metric == "Cumulative Proportion") |
| 377 | +553 |
- )+ ) + |
|
| 378 | -+ | ||
| 554 | +! |
-
+ geom_line( |
|
| 379 | +555 | ! |
- validation <- reactive({
+ aes(group = 1, color = "Cumulative variance"), |
| 380 | +556 | ! |
- req(merged$anl_q_r())+ data = dplyr::filter(elb_dat, metric == "Cumulative Proportion") |
| 381 | +557 |
- # inputs- |
- |
| 382 | -! | -
- keep_cols <- as.character(merged$anl_input_r()$columns_source$dat)+ ) + |
|
| 383 | +558 | ! |
- na_action <- input$na_action+ labs + |
| 384 | +559 | ! |
- standardization <- input$standardization+ scale_color_manual(values = c("Cumulative variance" = cols[2], "Single variance" = cols[3])) +
|
| 385 | +560 | ! |
- center <- standardization %in% c("center", "center_scale")
+ scale_fill_manual(values = c("Cumulative variance" = cols[2], "Single variance" = cols[1])) +
|
| 386 | +561 | ! |
- scale <- standardization == "center_scale"+ ggthemes + |
| 387 | +562 | ! |
- ANL <- merged$anl_q_r()[["ANL"]] # nolint: object_name.+ themes |
| 388 | +563 | ||
| 389 | +564 | ! |
- teal::validate_has_data(ANL, 10)+ print(g) |
| 390 | -! | +||
| 565 | +
- validate(need(+ }, |
||
| 391 | +566 | ! |
- na_action != "none" | !anyNA(ANL[keep_cols]),+ env = list( |
| 392 | +567 | ! |
- paste(+ ggthemes = parsed_ggplot2_args$ggtheme, |
| 393 | +568 | ! |
- "There are NAs in the dataset. Please deal with them in preprocessing",+ labs = parsed_ggplot2_args$labs, |
| 394 | +569 | ! |
- "or select \"Drop\" in the NA actions inside the encodings panel (left)."+ themes = parsed_ggplot2_args$theme |
| 395 | +570 |
- )+ ) |
|
| 396 | +571 |
- ))+ ) |
|
| 397 | -! | +||
| 572 | +
- if (scale) {
+ ) |
||
| 398 | -! | +||
| 573 | +
- not_single <- vapply(ANL[keep_cols], function(column) length(unique(column)) != 1, FUN.VALUE = logical(1))+ } |
||
| 399 | +574 | ||
| 575 | ++ |
+ # plot circle ----+ |
+ |
| 400 | +576 | ! |
- msg <- paste0(+ plot_circle <- function(base_q) {
|
| 401 | +577 | ! |
- "You have selected `Center & Scale` under `Standardization` in the `Pre-processing` panel, ",+ x_axis <- input$x_axis |
| 402 | +578 | ! |
- "but one or more of your columns has/have a variance value of zero, indicating all values are identical"+ y_axis <- input$y_axis |
| 403 | -+ | ||
| 579 | +! |
- )+ variables <- input$variables |
|
| 404 | +580 | ! |
- validate(need(all(not_single), msg))+ ggtheme <- input$ggtheme |
| 405 | +581 |
- }+ |
|
| 406 | -+ | ||
| 582 | +! |
- })+ rotate_xaxis_labels <- input$rotate_xaxis_labels |
|
| 407 | -+ | ||
| 583 | +! |
-
+ font_size <- input$font_size |
|
| 408 | +584 |
- # computation ----+ |
|
| 409 | +585 | ! |
- computation <- reactive({
+ angle <- ifelse(isTRUE(rotate_xaxis_labels), 45, 0) |
| 410 | +586 | ! |
- validation()+ hjust <- ifelse(isTRUE(rotate_xaxis_labels), 1, 0.5) |
| 411 | +587 | ||
| 412 | -+ | ||
| 588 | +! |
- # inputs+ dev_ggplot2_args <- teal.widgets::ggplot2_args( |
|
| 413 | +589 | ! |
- keep_cols <- as.character(merged$anl_input_r()$columns_source$dat)+ theme = list( |
| 414 | +590 | ! |
- na_action <- input$na_action+ text = substitute(element_text(size = font_size), list(font_size = font_size)), |
| 415 | +591 | ! |
- standardization <- input$standardization+ axis.text.x = substitute( |
| 416 | +592 | ! |
- center <- standardization %in% c("center", "center_scale")
+ element_text(angle = angle_val, hjust = hjust_val), |
| 417 | +593 | ! |
- scale <- standardization == "center_scale"+ list(angle_val = angle, hjust_val = hjust) |
| 418 | -! | +||
| 594 | +
- ANL <- merged$anl_q_r()[["ANL"]] # nolint: object_name.+ ) |
||
| 419 | +595 |
-
+ ) |
|
| 420 | -! | +||
| 596 | +
- qenv <- teal.code::eval_code(+ ) |
||
| 421 | -! | +||
| 597 | +
- merged$anl_q_r(),+ |
||
| 422 | +598 | ! |
- substitute(+ all_ggplot2_args <- teal.widgets::resolve_ggplot2_args( |
| 423 | +599 | ! |
- expr = keep_columns <- keep_cols,+ user_plot = ggplot2_args[["Circle plot"]], |
| 424 | +600 | ! |
- env = list(keep_cols = keep_cols)+ user_default = ggplot2_args$default, |
| 425 | -+ | ||
| 601 | +! |
- )+ module_plot = dev_ggplot2_args |
|
| 426 | +602 |
) |
|
| 427 | +603 | ||
| 428 | +604 | ! |
- if (na_action == "drop") {
+ parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args( |
| 429 | +605 | ! |
- qenv <- teal.code::eval_code(+ all_ggplot2_args, |
| 430 | +606 | ! |
- qenv,+ ggtheme = ggtheme |
| 431 | -! | +||
| 607 | +
- quote(ANL <- tidyr::drop_na(ANL, keep_columns)) # nolint: object_name.+ ) |
||
| 432 | +608 |
- )+ |
|
| 433 | -+ | ||
| 609 | +! |
- }+ teal.code::eval_code( |
|
| 434 | -+ | ||
| 610 | +! |
-
+ base_q, |
|
| 435 | +611 | ! |
- qenv <- teal.code::eval_code(+ substitute( |
| 436 | +612 | ! |
- qenv,+ expr = {
|
| 437 | +613 | ! |
- substitute(+ pca_rot <- pca$rotation[, c(x_axis, y_axis)] %>% |
| 438 | +614 | ! |
- expr = pca <- summary(stats::prcomp(ANL[keep_columns], center = center, scale. = scale, retx = TRUE)),+ dplyr::as_tibble(rownames = "label") %>% |
| 439 | +615 | ! |
- env = list(center = center, scale = scale)+ dplyr::filter(label %in% variables) |
| 440 | +616 |
- )+ + |
+ |
| 617 | +! | +
+ circle_data <- data.frame(+ |
+ |
| 618 | +! | +
+ x = cos(seq(0, 2 * pi, length.out = 100)),+ |
+ |
| 619 | +! | +
+ y = sin(seq(0, 2 * pi, length.out = 100)) |
|
| 441 | +620 |
- )+ ) |
|
| 442 | +621 | ||
| 443 | +622 | ! |
- qenv <- teal.code::eval_code(+ g <- ggplot(pca_rot) + |
| 444 | +623 | ! |
- qenv,+ geom_point(aes_string(x = x_axis, y = y_axis)) + |
| 445 | +624 | ! |
- quote({
+ geom_label( |
| 446 | +625 | ! |
- tbl_importance <- dplyr::as_tibble(pca$importance, rownames = "Metric")+ aes_string(x = x_axis, y = y_axis, label = "label"), |
| 447 | +626 | ! |
- tbl_importance+ nudge_x = 0.1, nudge_y = 0.05, |
| 448 | -+ | ||
| 627 | +! |
- })+ fontface = "bold" |
|
| 449 | +628 |
- )+ ) + |
|
| 450 | -+ | ||
| 629 | +! |
-
+ geom_path(aes(x, y, group = 1), data = circle_data) + |
|
| 451 | +630 | ! |
- teal.code::eval_code(+ geom_point(aes(x = x, y = y), data = data.frame(x = 0, y = 0), shape = "x", size = 5) + |
| 452 | +631 | ! |
- qenv,+ labs + |
| 453 | +632 | ! |
- quote({
+ ggthemes + |
| 454 | +633 | ! |
- tbl_eigenvector <- dplyr::as_tibble(pca$rotation, rownames = "Variable")+ themes |
| 455 | +634 | ! |
- tbl_eigenvector+ print(g) |
| 456 | +635 |
- })+ }, |
|
| 457 | -+ | ||
| 636 | +! |
- )- |
- |
| 458 | -- |
- })- |
- |
| 459 | -- | - - | -|
| 460 | -- |
- # plot args ----+ env = list( |
|
| 461 | +637 | ! |
- output$plot_settings <- renderUI({
- |
-
| 462 | -- |
- # reactivity triggers+ x_axis = x_axis, |
|
| 463 | +638 | ! |
- req(iv_r()$is_valid())+ y_axis = y_axis, |
| 464 | +639 | ! |
- req(computation())+ variables = variables, |
| 465 | +640 | ! |
- qenv <- computation()+ ggthemes = parsed_ggplot2_args$ggtheme, |
| 466 | -+ | ||
| 641 | +! |
-
+ labs = `if`(is.null(parsed_ggplot2_args$labs), quote(labs()), parsed_ggplot2_args$labs), |
|
| 467 | +642 | ! |
- ns <- session$ns+ themes = parsed_ggplot2_args$theme |
| 468 | +643 |
-
+ ) |
|
| 469 | -! | +||
| 644 | +
- pca <- qenv[["pca"]]+ ) |
||
| 470 | -! | +||
| 645 | +
- chcs_pcs <- colnames(pca$rotation)+ ) |
||
| 471 | -! | +||
| 646 | +
- chcs_vars <- qenv[["keep_columns"]]+ } |
||
| 472 | +647 | ||
| 473 | -! | +||
| 648 | +
- tagList(+ # plot biplot ---- |
||
| 474 | +649 | ! |
- conditionalPanel(+ plot_biplot <- function(base_q) {
|
| 475 | +650 | ! |
- condition = sprintf(+ qenv <- base_q |
| 476 | -! | +||
| 651 | +
- "input['%s'] == 'Biplot' || input['%s'] == 'Circle plot'",+ |
||
| 477 | +652 | ! |
- ns("plot_type"), ns("plot_type")
+ ANL <- qenv[["ANL"]] # nolint: object_name. |
| 478 | +653 |
- ),+ |
|
| 479 | +654 | ! |
- list(+ resp_col <- as.character(merged$anl_input_r()$columns_source$response) |
| 480 | +655 | ! |
- teal.widgets::optionalSelectInput(ns("x_axis"), "X axis", choices = chcs_pcs, selected = chcs_pcs[1]),
+ dat_cols <- as.character(merged$anl_input_r()$columns_source$dat) |
| 481 | +656 | ! |
- teal.widgets::optionalSelectInput(ns("y_axis"), "Y axis", choices = chcs_pcs, selected = chcs_pcs[2]),
+ x_axis <- input$x_axis |
| 482 | +657 | ! |
- teal.widgets::optionalSelectInput(+ y_axis <- input$y_axis |
| 483 | +658 | ! |
- ns("variables"), "Original coordinates",
+ variables <- input$variables |
| 484 | +659 | ! |
- choices = chcs_vars, selected = chcs_vars,+ pca <- qenv[["pca"]] |
| 485 | -! | +||
| 660 | +
- multiple = TRUE+ |
||
| 486 | -+ | ||
| 661 | +! |
- )+ ggtheme <- input$ggtheme |
|
| 487 | +662 |
- )+ |
|
| 488 | -+ | ||
| 663 | +! |
- ),+ rotate_xaxis_labels <- input$rotate_xaxis_labels |
|
| 489 | +664 | ! |
- conditionalPanel(+ alpha <- input$alpha |
| 490 | +665 | ! |
- condition = sprintf("input['%s'] == 'Elbow plot'", ns("plot_type")),
+ size <- input$size |
| 491 | +666 | ! |
- helpText("No plot specific settings available.")
+ font_size <- input$font_size |
| 492 | +667 |
- ),+ |
|
| 493 | +668 | ! |
- conditionalPanel(+ qenv <- teal.code::eval_code( |
| 494 | +669 | ! |
- condition = paste0("input['", ns("plot_type"), "'] == 'Eigenvector plot'"),
+ qenv, |
| 495 | +670 | ! |
- teal.widgets::optionalSelectInput(ns("pc"), "PC", choices = chcs_pcs, selected = chcs_pcs[1])
+ substitute( |
| 496 | -+ | ||
| 671 | +! |
- )+ expr = pca_rot <- dplyr::as_tibble(pca$x[, c(x_axis, y_axis)]),+ |
+ |
| 672 | +! | +
+ env = list(x_axis = x_axis, y_axis = y_axis) |
|
| 497 | +673 |
- )+ ) |
|
| 498 | +674 |
- })+ ) |
|
| 499 | +675 | ||
| 500 | +676 |
- # plot elbow ----+ # rot_vars = data frame that displays arrows in the plot, need to be scaled to data |
|
| 501 | +677 | ! |
- plot_elbow <- function(base_q) {
+ if (!is.null(input$variables)) {
|
| 502 | +678 | ! |
- ggtheme <- input$ggtheme+ qenv <- teal.code::eval_code( |
| 503 | +679 | ! |
- rotate_xaxis_labels <- input$rotate_xaxis_labels+ qenv, |
| 504 | +680 | ! |
- font_size <- input$font_size+ substitute( |
| 505 | -+ | ||
| 681 | +! |
-
+ expr = {
|
|
| 506 | +682 | ! |
- angle_value <- ifelse(isTRUE(rotate_xaxis_labels), 45, 0)+ r <- sqrt(qchisq(0.69, df = 2)) * prod(colMeans(pca_rot ^ 2)) ^ (1 / 4) # styler: off |
| 507 | +683 | ! |
- hjust_value <- ifelse(isTRUE(rotate_xaxis_labels), 1, 0.5)+ v_scale <- rowSums(pca$rotation ^ 2) # styler: off |
| 508 | +684 | ||
| 509 | +685 | ! |
- dev_ggplot2_args <- teal.widgets::ggplot2_args(+ rot_vars <- pca$rotation[, c(x_axis, y_axis)] %>% |
| 510 | +686 | ! |
- labs = list(x = "Principal component", y = "Proportion of variance explained", color = "", fill = "Legend"),+ dplyr::as_tibble(rownames = "label") %>% |
| 511 | +687 | ! |
- theme = list(+ dplyr::mutate_at(vars(c(x_axis, y_axis)), function(x) r * x / sqrt(max(v_scale))) |
| 512 | -! | +||
| 688 | +
- legend.position = "right",+ }, |
||
| 513 | +689 | ! |
- legend.spacing.y = quote(grid::unit(-5, "pt")),+ env = list(x_axis = x_axis, y_axis = y_axis) |
| 514 | -! | +||
| 690 | +
- legend.title = quote(element_text(vjust = 25)),+ ) |
||
| 515 | -! | +||
| 691 | +
- axis.text.x = substitute(+ ) %>% |
||
| 516 | +692 | ! |
- element_text(angle = angle_value, hjust = hjust_value),+ teal.code::eval_code( |
| 517 | +693 | ! |
- list(angle_value = angle_value, hjust_value = hjust_value)+ if (is.logical(pca$center) && !pca$center) {
|
| 518 | -+ | ||
| 694 | +! |
- ),+ substitute( |
|
| 519 | +695 | ! |
- text = substitute(element_text(size = font_size), list(font_size = font_size))+ expr = {
|
| 520 | -+ | ||
| 696 | +! |
- )+ rot_vars <- rot_vars %>% |
|
| 521 | -+ | ||
| 697 | +! |
- )+ tibble::column_to_rownames("label") %>%
|
|
| 522 | -+ | ||
| 698 | +! |
-
+ sweep(1, apply(ANL[keep_columns], 2, mean, na.rm = TRUE)) %>% |
|
| 523 | +699 | ! |
- parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(+ tibble::rownames_to_column("label") %>%
|
| 524 | +700 | ! |
- teal.widgets::resolve_ggplot2_args(+ dplyr::mutate( |
| 525 | +701 | ! |
- user_plot = ggplot2_args[["Elbow plot"]],+ xstart = mean(pca$x[, x_axis], na.rm = TRUE), |
| 526 | +702 | ! |
- user_default = ggplot2_args$default,+ ystart = mean(pca$x[, y_axis], na.rm = TRUE) |
| 527 | -! | +||
| 703 | +
- module_plot = dev_ggplot2_args+ ) |
||
| 528 | +704 |
- ),+ }, |
|
| 529 | +705 | ! |
- ggtheme = ggtheme+ env = list(x_axis = x_axis, y_axis = y_axis) |
| 530 | +706 |
- )+ ) |
|
| 531 | +707 |
-
+ } else {
|
|
| 532 | +708 | ! |
- teal.code::eval_code(+ quote(rot_vars <- rot_vars %>% dplyr::mutate(xstart = 0, ystart = 0)) |
| 533 | -! | +||
| 709 | +
- base_q,+ } |
||
| 534 | -! | +||
| 710 | +
- substitute(+ ) %>% |
||
| 535 | +711 | ! |
- expr = {
+ teal.code::eval_code( |
| 536 | +712 | ! |
- elb_dat <- pca$importance[c("Proportion of Variance", "Cumulative Proportion"), ] %>%
+ substitute( |
| 537 | +713 | ! |
- dplyr::as_tibble(rownames = "metric") %>%+ expr = rot_vars <- rot_vars %>% dplyr::filter(label %in% variables), |
| 538 | +714 | ! |
- tidyr::gather("component", "value", -metric) %>%
+ env = list(variables = variables) |
| 539 | -! | +||
| 715 | +
- dplyr::mutate(+ ) |
||
| 540 | -! | +||
| 716 | +
- component = factor(component, levels = unique(stringr::str_sort(component, numeric = TRUE)))+ ) |
||
| 541 | +717 |
- )+ } |
|
| 542 | +718 | ||
| 543 | +719 | ! |
- cols <- c(getOption("ggplot2.discrete.colour"), c("lightblue", "darkred", "black"))[1:3]
+ pca_plot_biplot_expr <- list(quote(ggplot()))+ |
+
| 720 | ++ | + | |
| 544 | +721 | ! |
- g <- ggplot(mapping = aes_string(x = "component", y = "value")) ++ if (length(resp_col) == 0) {
|
| 545 | +722 | ! |
- geom_bar(+ pca_plot_biplot_expr <- c( |
| 546 | +723 | ! |
- aes(fill = "Single variance"),+ pca_plot_biplot_expr, |
| 547 | +724 | ! |
- data = dplyr::filter(elb_dat, metric == "Proportion of Variance"),+ substitute( |
| 548 | +725 | ! |
- color = "black",+ geom_point(aes_string(x = x_axis, y = y_axis), data = pca_rot, alpha = alpha, size = size), |
| 549 | +726 | ! |
- stat = "identity"+ list(x_axis = input$x_axis, y_axis = input$y_axis, alpha = input$alpha, size = input$size) |
| 550 | +727 |
- ) ++ ) |
|
| 551 | -! | +||
| 728 | +
- geom_point(+ ) |
||
| 552 | +729 | ! |
- aes(color = "Cumulative variance"),+ dev_labs <- list()+ |
+
| 730 | ++ |
+ } else {
|
|
| 553 | +731 | ! |
- data = dplyr::filter(elb_dat, metric == "Cumulative Proportion")+ rp_keys <- setdiff(colnames(ANL), as.character(unlist(merged$anl_input_r()$columns_source))) |
| 554 | +732 |
- ) ++ |
|
| 555 | +733 | ! |
- geom_line(- |
-
| 556 | -! | -
- aes(group = 1, color = "Cumulative variance"),- |
- |
| 557 | -! | -
- data = dplyr::filter(elb_dat, metric == "Cumulative Proportion")+ response <- ANL[[resp_col]] |
|
| 558 | +734 |
- ) +- |
- |
| 559 | -! | -
- labs +- |
- |
| 560 | -! | -
- scale_color_manual(values = c("Cumulative variance" = cols[2], "Single variance" = cols[3])) +
+
|
|
| 561 | +735 | ! |
- scale_fill_manual(values = c("Cumulative variance" = cols[2], "Single variance" = cols[1])) +
+ aes_biplot <- substitute( |
| 562 | +736 | ! |
- ggthemes ++ aes_string(x = x_axis, y = y_axis, color = "response"), |
| 563 | +737 | ! |
- themes+ env = list(x_axis = x_axis, y_axis = y_axis) |
| 564 | +738 | - - | -|
| 565 | -! | -
- print(g)+ ) |
|
| 566 | +739 |
- },- |
- |
| 567 | -! | -
- env = list(+ |
|
| 568 | +740 | ! |
- ggthemes = parsed_ggplot2_args$ggtheme,+ qenv <- teal.code::eval_code( |
| 569 | +741 | ! |
- labs = parsed_ggplot2_args$labs,+ qenv, |
| 570 | +742 | ! |
- themes = parsed_ggplot2_args$theme- |
-
| 571 | -- |
- )+ substitute(response <- ANL[[resp_col]], env = list(resp_col = resp_col)) |
|
| 572 | +743 |
) |
|
| 573 | +744 |
- )+ |
|
| 574 | -+ | ||
| 745 | +! |
- }+ dev_labs <- list(color = varname_w_label(resp_col, ANL)) |
|
| 575 | +746 | ||
| 576 | -- |
- # plot circle ----- |
- |
| 577 | +747 | ! |
- plot_circle <- function(base_q) {
+ scales_biplot <- |
| 578 | +748 | ! |
- x_axis <- input$x_axis+ if (is.character(response) || is.factor(response) || (is.numeric(response) && length(unique(response)) <= 6)) { # nolint: line_length.
|
| 579 | +749 | ! |
- y_axis <- input$y_axis+ qenv <- teal.code::eval_code( |
| 580 | +750 | ! |
- variables <- input$variables+ qenv, |
| 581 | +751 | ! |
- ggtheme <- input$ggtheme+ quote(pca_rot$response <- as.factor(response)) |
| 582 | +752 |
-
+ ) |
|
| 583 | +753 | ! |
- rotate_xaxis_labels <- input$rotate_xaxis_labels+ quote(scale_color_brewer(palette = "Dark2")) |
| 584 | +754 | ! |
- font_size <- input$font_size+ } else if (inherits(response, "Date")) {
|
| 585 | -+ | ||
| 755 | +! |
-
+ qenv <- teal.code::eval_code( |
|
| 586 | +756 | ! |
- angle <- ifelse(isTRUE(rotate_xaxis_labels), 45, 0)+ qenv, |
| 587 | +757 | ! |
- hjust <- ifelse(isTRUE(rotate_xaxis_labels), 1, 0.5)+ quote(pca_rot$response <- numeric(response)) |
| 588 | +758 |
-
+ ) |
|
| 589 | -! | +||
| 759 | +
- dev_ggplot2_args <- teal.widgets::ggplot2_args(+ |
||
| 590 | +760 | ! |
- theme = list(+ quote( |
| 591 | +761 | ! |
- text = substitute(element_text(size = font_size), list(font_size = font_size)),+ scale_color_gradient( |
| 592 | +762 | ! |
- axis.text.x = substitute(+ low = c(getOption("ggplot2.discrete.colour")[2], "darkred")[1],
|
| 593 | +763 | ! |
- element_text(angle = angle_val, hjust = hjust_val),+ high = c(getOption("ggplot2.discrete.colour"), "lightblue")[1],
|
| 594 | +764 | ! |
- list(angle_val = angle, hjust_val = hjust)- |
-
| 595 | -- |
- )+ labels = function(x) as.Date(x, origin = "1970-01-01") |
|
| 596 | +765 |
- )+ ) |
|
| 597 | +766 |
- )+ ) |
|
| 598 | +767 | - - | -|
| 599 | -! | -
- all_ggplot2_args <- teal.widgets::resolve_ggplot2_args(+ } else {
|
|
| 600 | +768 | ! |
- user_plot = ggplot2_args[["Circle plot"]],+ qenv <- teal.code::eval_code( |
| 601 | +769 | ! |
- user_default = ggplot2_args$default,+ qenv, |
| 602 | +770 | ! |
- module_plot = dev_ggplot2_args+ quote(pca_rot$response <- response) |
| 603 | +771 |
- )+ ) |
|
| 604 | -+ | ||
| 772 | +! |
-
+ quote(scale_color_gradient( |
|
| 605 | +773 | ! |
- parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(+ low = c(getOption("ggplot2.discrete.colour")[2], "darkred")[1],
|
| 606 | +774 | ! |
- all_ggplot2_args,+ high = c(getOption("ggplot2.discrete.colour"), "lightblue")[1]
|
| 607 | -! | +||
| 775 | +
- ggtheme = ggtheme+ )) |
||
| 608 | +776 |
- )+ } |
|
| 609 | +777 | ||
| 610 | +778 | ! |
- teal.code::eval_code(+ pca_plot_biplot_expr <- c( |
| 611 | +779 | ! |
- base_q,+ pca_plot_biplot_expr, |
| 612 | +780 | ! |
- substitute(+ substitute( |
| 613 | +781 | ! |
- expr = {
+ geom_point(aes_biplot, data = pca_rot, alpha = alpha, size = size), |
| 614 | +782 | ! |
- pca_rot <- pca$rotation[, c(x_axis, y_axis)] %>%+ env = list(aes_biplot = aes_biplot, alpha = alpha, size = size) |
| 615 | -! | +||
| 783 | +
- dplyr::as_tibble(rownames = "label") %>%+ ), |
||
| 616 | +784 | ! |
- dplyr::filter(label %in% variables)+ scales_biplot |
| 617 | +785 |
-
+ ) |
|
| 618 | -! | +||
| 786 | +
- circle_data <- data.frame(+ } |
||
| 619 | -! | +||
| 787 | +
- x = cos(seq(0, 2 * pi, length.out = 100)),+ |
||
| 620 | +788 | ! |
- y = sin(seq(0, 2 * pi, length.out = 100))+ if (!is.null(input$variables)) {
|
| 621 | -+ | ||
| 789 | +! |
- )+ pca_plot_biplot_expr <- c( |
|
| 622 | -+ | ||
| 790 | +! |
-
+ pca_plot_biplot_expr, |
|
| 623 | +791 | ! |
- g <- ggplot(pca_rot) ++ substitute( |
| 624 | +792 | ! |
- geom_point(aes_string(x = x_axis, y = y_axis)) ++ geom_segment( |
| 625 | +793 | ! |
- geom_label(+ aes_string(x = "xstart", y = "ystart", xend = x_axis, yend = y_axis), |
| 626 | +794 | ! |
- aes_string(x = x_axis, y = y_axis, label = "label"),+ data = rot_vars, |
| 627 | +795 | ! |
- nudge_x = 0.1, nudge_y = 0.05,+ lineend = "round", linejoin = "round", |
| 628 | +796 | ! |
- fontface = "bold"+ arrow = grid::arrow(length = grid::unit(0.5, "cm")) |
| 629 | +797 |
- ) ++ ), |
|
| 630 | +798 | ! |
- geom_path(aes(x, y, group = 1), data = circle_data) ++ env = list(x_axis = x_axis, y_axis = y_axis) |
| 631 | -! | +||
| 799 | +
- geom_point(aes(x = x, y = y), data = data.frame(x = 0, y = 0), shape = "x", size = 5) ++ ), |
||
| 632 | +800 | ! |
- labs ++ substitute( |
| 633 | +801 | ! |
- ggthemes ++ geom_label( |
| 634 | +802 | ! |
- themes+ aes_string( |
| 635 | +803 | ! |
- print(g)+ x = x_axis, |
| 636 | -+ | ||
| 804 | +! |
- },+ y = y_axis, |
|
| 637 | +805 | ! |
- env = list(+ label = "label" |
| 638 | -! | +||
| 806 | +
- x_axis = x_axis,+ ), |
||
| 639 | +807 | ! |
- y_axis = y_axis,+ data = rot_vars, |
| 640 | +808 | ! |
- variables = variables,+ nudge_y = 0.1, |
| 641 | +809 | ! |
- ggthemes = parsed_ggplot2_args$ggtheme,+ fontface = "bold" |
| 642 | -! | +||
| 810 | +
- labs = `if`(is.null(parsed_ggplot2_args$labs), quote(labs()), parsed_ggplot2_args$labs),+ ), |
||
| 643 | +811 | ! |
- themes = parsed_ggplot2_args$theme+ env = list(x_axis = x_axis, y_axis = y_axis) |
| 644 | +812 |
- )+ ), |
|
| 645 | -+ | ||
| 813 | +! |
- )+ quote(geom_point(aes(x = xstart, y = ystart), data = rot_vars, shape = "x", size = 5)) |
|
| 646 | +814 |
- )+ ) |
|
| 647 | +815 |
- }+ } |
|
| 648 | +816 | ||
| 649 | -- |
- # plot biplot ----- |
- |
| 650 | +817 | ! |
- plot_biplot <- function(base_q) {
+ angle <- ifelse(isTRUE(rotate_xaxis_labels), 45, 0) |
| 651 | +818 | ! |
- qenv <- base_q+ hjust <- ifelse(isTRUE(rotate_xaxis_labels), 1, 0.5) |
| 652 | +819 | ||
| 653 | +820 | ! |
- ANL <- qenv[["ANL"]] # nolint: object_name.- |
-
| 654 | -- |
-
+ dev_ggplot2_args <- teal.widgets::ggplot2_args( |
|
| 655 | +821 | ! |
- resp_col <- as.character(merged$anl_input_r()$columns_source$response)+ labs = dev_labs, |
| 656 | +822 | ! |
- dat_cols <- as.character(merged$anl_input_r()$columns_source$dat)+ theme = list( |
| 657 | +823 | ! |
- x_axis <- input$x_axis+ text = substitute(element_text(size = font_size), list(font_size = font_size)), |
| 658 | +824 | ! |
- y_axis <- input$y_axis+ axis.text.x = substitute( |
| 659 | +825 | ! |
- variables <- input$variables+ element_text(angle = angle_val, hjust = hjust_val), |
| 660 | +826 | ! |
- pca <- qenv[["pca"]]+ list(angle_val = angle, hjust_val = hjust) |
| 661 | +827 |
-
+ ) |
|
| 662 | -! | +||
| 828 | +
- ggtheme <- input$ggtheme+ ) |
||
| 663 | +829 | ++ |
+ )+ |
+
| 830 | |||
| 664 | +831 | ! |
- rotate_xaxis_labels <- input$rotate_xaxis_labels+ all_ggplot2_args <- teal.widgets::resolve_ggplot2_args( |
| 665 | +832 | ! |
- alpha <- input$alpha+ user_plot = ggplot2_args[["Biplot"]], |
| 666 | +833 | ! |
- size <- input$size+ user_default = ggplot2_args$default, |
| 667 | +834 | ! |
- font_size <- input$font_size+ module_plot = dev_ggplot2_args |
| 668 | +835 | ++ |
+ )+ |
+
| 836 | |||
| 669 | +837 | ! |
- qenv <- teal.code::eval_code(+ parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args( |
| 670 | +838 | ! |
- qenv,+ all_ggplot2_args, |
| 671 | +839 | ! |
- substitute(+ ggtheme = ggtheme+ |
+
| 840 | ++ |
+ )+ |
+ |
| 841 | ++ | + | |
| 672 | +842 | ! |
- expr = pca_rot <- dplyr::as_tibble(pca$x[, c(x_axis, y_axis)]),+ pca_plot_biplot_expr <- c( |
| 673 | +843 | ! |
- env = list(x_axis = x_axis, y_axis = y_axis)+ pca_plot_biplot_expr, |
| 674 | -+ | ||
| 844 | +! |
- )+ parsed_ggplot2_args |
|
| 675 | +845 |
) |
|
| 676 | +846 | ||
| 677 | -- |
- # rot_vars = data frame that displays arrows in the plot, need to be scaled to data- |
- |
| 678 | -! | -
- if (!is.null(input$variables)) {
- |
- |
| 679 | +847 | ! |
- qenv <- teal.code::eval_code(+ teal.code::eval_code( |
| 680 | +848 | ! |
- qenv,+ qenv, |
| 681 | +849 | ! |
- substitute(+ substitute( |
| 682 | +850 | ! |
- expr = {
+ expr = {
|
| 683 | +851 | ! |
- r <- sqrt(qchisq(0.69, df = 2)) * prod(colMeans(pca_rot ^ 2)) ^ (1 / 4) # styler: off+ g <- plot_call |
| 684 | +852 | ! |
- v_scale <- rowSums(pca$rotation ^ 2) # styler: off+ print(g) |
| 685 | +853 |
-
+ }, |
|
| 686 | +854 | ! |
- rot_vars <- pca$rotation[, c(x_axis, y_axis)] %>%+ env = list( |
| 687 | +855 | ! |
- dplyr::as_tibble(rownames = "label") %>%+ plot_call = Reduce(function(x, y) call("+", x, y), pca_plot_biplot_expr)
|
| 688 | -! | +||
| 856 | +
- dplyr::mutate_at(vars(c(x_axis, y_axis)), function(x) r * x / sqrt(max(v_scale)))+ ) |
||
| 689 | +857 |
- },+ ) |
|
| 690 | -! | +||
| 858 | +
- env = list(x_axis = x_axis, y_axis = y_axis)+ ) |
||
| 691 | +859 |
- )+ } |
|
| 692 | +860 |
- ) %>%+ |
|
| 693 | -! | +||
| 861 | +
- teal.code::eval_code(+ # plot pc_var ---- |
||
| 694 | +862 | ! |
- if (is.logical(pca$center) && !pca$center) {
+ plot_pc_var <- function(base_q) {
|
| 695 | +863 | ! |
- substitute(+ pc <- input$pc |
| 696 | +864 | ! |
- expr = {
+ ggtheme <- input$ggtheme+ |
+
| 865 | ++ | + | |
| 697 | +866 | ! |
- rot_vars <- rot_vars %>%+ rotate_xaxis_labels <- input$rotate_xaxis_labels |
| 698 | +867 | ! |
- tibble::column_to_rownames("label") %>%
+ font_size <- input$font_size+ |
+
| 868 | ++ | + | |
| 699 | +869 | ! |
- sweep(1, apply(ANL[keep_columns], 2, mean, na.rm = TRUE)) %>%+ angle <- ifelse(rotate_xaxis_labels, 45, 0) |
| 700 | +870 | ! |
- tibble::rownames_to_column("label") %>%
+ hjust <- ifelse(rotate_xaxis_labels, 1, 0.5)+ |
+
| 871 | ++ | + | |
| 701 | +872 | ! |
- dplyr::mutate(+ dev_ggplot2_args <- teal.widgets::ggplot2_args( |
| 702 | +873 | ! |
- xstart = mean(pca$x[, x_axis], na.rm = TRUE),+ theme = list( |
| 703 | +874 | ! |
- ystart = mean(pca$x[, y_axis], na.rm = TRUE)+ text = substitute(element_text(size = font_size), list(font_size = font_size)), |
| 704 | -+ | ||
| 875 | +! |
- )+ axis.text.x = substitute( |
|
| 705 | -+ | ||
| 876 | +! |
- },+ element_text(angle = angle_val, hjust = hjust_val), |
|
| 706 | +877 | ! |
- env = list(x_axis = x_axis, y_axis = y_axis)+ list(angle_val = angle, hjust_val = hjust) |
| 707 | +878 |
- )+ ) |
|
| 708 | +879 |
- } else {
- |
- |
| 709 | -! | -
- quote(rot_vars <- rot_vars %>% dplyr::mutate(xstart = 0, ystart = 0))+ ) |
|
| 710 | +880 |
- }+ ) |
|
| 711 | +881 |
- ) %>%+ |
|
| 712 | +882 | ! |
- teal.code::eval_code(+ all_ggplot2_args <- teal.widgets::resolve_ggplot2_args( |
| 713 | +883 | ! |
- substitute(+ user_plot = ggplot2_args[["Eigenvector plot"]], |
| 714 | +884 | ! |
- expr = rot_vars <- rot_vars %>% dplyr::filter(label %in% variables),+ user_default = ggplot2_args$default, |
| 715 | +885 | ! |
- env = list(variables = variables)+ module_plot = dev_ggplot2_args |
| 716 | +886 |
- )+ ) |
|
| 717 | +887 |
- )+ |
|
| 718 | -+ | ||
| 888 | +! |
- }+ parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args( |
|
| 719 | -+ | ||
| 889 | +! |
-
+ all_ggplot2_args, |
|
| 720 | +890 | ! |
- pca_plot_biplot_expr <- list(quote(ggplot()))+ ggtheme = ggtheme |
| 721 | +891 | ++ |
+ )+ |
+
| 892 | |||
| 722 | +893 | ! |
- if (length(resp_col) == 0) {
+ ggplot_exprs <- c( |
| 723 | +894 | ! |
- pca_plot_biplot_expr <- c(+ list( |
| 724 | +895 | ! |
- pca_plot_biplot_expr,+ quote(ggplot(pca_rot)), |
| 725 | +896 | ! |
substitute( |
| 726 | +897 | ! |
- geom_point(aes_string(x = x_axis, y = y_axis), data = pca_rot, alpha = alpha, size = size),+ geom_bar( |
| 727 | +898 | ! |
- list(x_axis = input$x_axis, y_axis = input$y_axis, alpha = input$alpha, size = input$size)- |
-
| 728 | -- |
- )- |
- |
| 729 | -- |
- )+ aes_string(x = "Variable", y = pc), |
|
| 730 | +899 | ! |
- dev_labs <- list()+ stat = "identity", |
| 731 | -+ | ||
| 900 | +! |
- } else {
+ color = "black", |
|
| 732 | +901 | ! |
- rp_keys <- setdiff(colnames(ANL), as.character(unlist(merged$anl_input_r()$columns_source)))+ fill = c(getOption("ggplot2.discrete.colour"), "lightblue")[1]
|
| 733 | +902 |
-
+ ), |
|
| 734 | +903 | ! |
- response <- ANL[[resp_col]]+ env = list(pc = pc) |
| 735 | +904 |
-
+ ), |
|
| 736 | +905 | ! |
- aes_biplot <- substitute(+ substitute( |
| 737 | +906 | ! |
- aes_string(x = x_axis, y = y_axis, color = "response"),+ geom_text( |
| 738 | +907 | ! |
- env = list(x_axis = x_axis, y_axis = y_axis)- |
-
| 739 | -- |
- )+ aes( |
|
| 740 | -+ | ||
| 908 | +! |
-
+ x = Variable, |
|
| 741 | +909 | ! |
- qenv <- teal.code::eval_code(+ y = pc_name, |
| 742 | +910 | ! |
- qenv,+ label = round(pc_name, 3), |
| 743 | +911 | ! |
- substitute(response <- ANL[[resp_col]], env = list(resp_col = resp_col))+ vjust = ifelse(pc_name > 0, -0.5, 1.3) |
| 744 | +912 |
- )+ ) |
|
| 745 | +913 |
-
+ ), |
|
| 746 | +914 | ! |
- dev_labs <- list(color = varname_w_label(resp_col, ANL))+ env = list(pc_name = as.name(pc)) |
| 747 | +915 |
-
+ ) |
|
| 748 | -! | +||
| 916 | +
- scales_biplot <-+ ), |
||
| 749 | +917 | ! |
- if (is.character(response) || is.factor(response) || (is.numeric(response) && length(unique(response)) <= 6)) { # nolint: line_length.
+ parsed_ggplot2_args$labs, |
| 750 | +918 | ! |
- qenv <- teal.code::eval_code(+ parsed_ggplot2_args$ggtheme, |
| 751 | +919 | ! |
- qenv,+ parsed_ggplot2_args$theme |
| 752 | -! | +||
| 920 | +
- quote(pca_rot$response <- as.factor(response))+ ) |
||
| 753 | +921 |
- )+ |
|
| 754 | +922 | ! |
- quote(scale_color_brewer(palette = "Dark2"))+ teal.code::eval_code( |
| 755 | +923 | ! |
- } else if (inherits(response, "Date")) {
+ base_q, |
| 756 | +924 | ! |
- qenv <- teal.code::eval_code(+ substitute( |
| 757 | +925 | ! |
- qenv,+ expr = {
|
| 758 | +926 | ! |
- quote(pca_rot$response <- numeric(response))+ pca_rot <- pca$rotation[, pc, drop = FALSE] %>% |
| 759 | -+ | ||
| 927 | +! |
- )+ dplyr::as_tibble(rownames = "Variable") |
|
| 760 | +928 | ||
| 761 | +929 | ! |
- quote(+ g <- plot_call+ |
+
| 930 | ++ | + | |
| 762 | +931 | ! |
- scale_color_gradient(+ print(g)+ |
+
| 932 | ++ |
+ }, |
|
| 763 | +933 | ! |
- low = c(getOption("ggplot2.discrete.colour")[2], "darkred")[1],
+ env = list( |
| 764 | +934 | ! |
- high = c(getOption("ggplot2.discrete.colour"), "lightblue")[1],
+ pc = pc, |
| 765 | +935 | ! |
- labels = function(x) as.Date(x, origin = "1970-01-01")+ plot_call = Reduce(function(x, y) call("+", x, y), ggplot_exprs)
|
| 766 | +936 |
- )+ ) |
|
| 767 | +937 |
- )+ ) |
|
| 768 | +938 |
- } else {
- |
- |
| 769 | -! | -
- qenv <- teal.code::eval_code(+ ) |
|
| 770 | -! | +||
| 939 | +
- qenv,+ } |
||
| 771 | -! | +||
| 940 | +
- quote(pca_rot$response <- response)+ |
||
| 772 | +941 |
- )+ # plot final ---- |
|
| 773 | +942 | ! |
- quote(scale_color_gradient(+ output_q <- reactive({
|
| 774 | +943 | ! |
- low = c(getOption("ggplot2.discrete.colour")[2], "darkred")[1],
+ req(computation()) |
| 775 | +944 | ! |
- high = c(getOption("ggplot2.discrete.colour"), "lightblue")[1]
- |
-
| 776 | -- |
- ))+ teal::validate_inputs(iv_r()) |
|
| 777 | -+ | ||
| 945 | +! |
- }+ teal::validate_inputs(iv_extra, header = "Plot settings are required") |
|
| 778 | +946 | ||
| 779 | +947 | ! |
- pca_plot_biplot_expr <- c(+ switch(input$plot_type, |
| 780 | +948 | ! |
- pca_plot_biplot_expr,+ "Elbow plot" = plot_elbow(computation()), |
| 781 | +949 | ! |
- substitute(+ "Circle plot" = plot_circle(computation()), |
| 782 | +950 | ! |
- geom_point(aes_biplot, data = pca_rot, alpha = alpha, size = size),+ "Biplot" = plot_biplot(computation()), |
| 783 | +951 | ! |
- env = list(aes_biplot = aes_biplot, alpha = alpha, size = size)- |
-
| 784 | -- |
- ),+ "Eigenvector plot" = plot_pc_var(computation()), |
|
| 785 | +952 | ! |
- scales_biplot+ stop("Unknown plot")
|
| 786 | +953 |
- )+ ) |
|
| 787 | +954 |
- }+ }) |
|
| 788 | +955 | ||
| 789 | +956 | ! |
- if (!is.null(input$variables)) {
+ plot_r <- reactive({
|
| 790 | +957 | ! |
- pca_plot_biplot_expr <- c(+ output_q()[["g"]] |
| 791 | -! | +||
| 958 | +
- pca_plot_biplot_expr,+ })+ |
+ ||
| 959 | ++ | + | |
| 792 | +960 | ! |
- substitute(+ pws <- teal.widgets::plot_with_settings_srv( |
| 793 | +961 | ! |
- geom_segment(+ id = "pca_plot", |
| 794 | +962 | ! |
- aes_string(x = "xstart", y = "ystart", xend = x_axis, yend = y_axis),+ plot_r = plot_r, |
| 795 | +963 | ! |
- data = rot_vars,+ height = plot_height, |
| 796 | +964 | ! |
- lineend = "round", linejoin = "round",+ width = plot_width, |
| 797 | +965 | ! |
- arrow = grid::arrow(length = grid::unit(0.5, "cm"))+ graph_align = "center" |
| 798 | +966 |
- ),+ ) |
|
| 799 | -! | +||
| 967 | +
- env = list(x_axis = x_axis, y_axis = y_axis)+ |
||
| 800 | +968 |
- ),+ # tables ---- |
|
| 801 | +969 | ! |
- substitute(+ output$tbl_importance <- renderTable( |
| 802 | +970 | ! |
- geom_label(+ expr = {
|
| 803 | +971 | ! |
- aes_string(+ req("importance" %in% input$tables_display, computation())
|
| 804 | +972 | ! |
- x = x_axis,+ computation()[["tbl_importance"]]+ |
+
| 973 | ++ |
+ }, |
|
| 805 | +974 | ! |
- y = y_axis,+ bordered = TRUE, |
| 806 | +975 | ! |
- label = "label"+ align = "c",+ |
+
| 976 | +! | +
+ digits = 3 |
|
| 807 | +977 |
- ),+ )+ |
+ |
| 978 | ++ | + | |
| 808 | +979 | ! |
- data = rot_vars,+ output$tbl_importance_ui <- renderUI({
|
| 809 | +980 | ! |
- nudge_y = 0.1,+ req("importance" %in% input$tables_display)
|
| 810 | +981 | ! |
- fontface = "bold"+ div( |
| 811 | -+ | ||
| 982 | +! |
- ),+ align = "center", |
|
| 812 | +983 | ! |
- env = list(x_axis = x_axis, y_axis = y_axis)+ tags$h4("Principal components importance"),
|
| 813 | -+ | ||
| 984 | +! |
- ),+ tableOutput(session$ns("tbl_importance")),
|
|
| 814 | +985 | ! |
- quote(geom_point(aes(x = xstart, y = ystart), data = rot_vars, shape = "x", size = 5))+ hr() |
| 815 | +986 |
- )+ ) |
|
| 816 | +987 |
- }+ }) |
|
| 817 | +988 | ||
| 818 | +989 | ! |
- angle <- ifelse(isTRUE(rotate_xaxis_labels), 45, 0)+ output$tbl_eigenvector <- renderTable( |
| 819 | +990 | ! |
- hjust <- ifelse(isTRUE(rotate_xaxis_labels), 1, 0.5)- |
-
| 820 | -- |
-
+ expr = {
|
|
| 821 | +991 | ! |
- dev_ggplot2_args <- teal.widgets::ggplot2_args(+ req("eigenvector" %in% input$tables_display, req(computation()))
|
| 822 | +992 | ! |
- labs = dev_labs,+ computation()[["tbl_eigenvector"]] |
| 823 | -! | +||
| 993 | +
- theme = list(+ }, |
||
| 824 | +994 | ! |
- text = substitute(element_text(size = font_size), list(font_size = font_size)),+ bordered = TRUE, |
| 825 | +995 | ! |
- axis.text.x = substitute(+ align = "c", |
| 826 | +996 | ! |
- element_text(angle = angle_val, hjust = hjust_val),+ digits = 3 |
| 827 | -! | +||
| 997 | +
- list(angle_val = angle, hjust_val = hjust)+ ) |
||
| 828 | +998 |
- )+ |
|
| 829 | -+ | ||
| 999 | +! |
- )+ output$tbl_eigenvector_ui <- renderUI({
|
|
| 830 | -+ | ||
| 1000 | +! |
- )+ req("eigenvector" %in% input$tables_display)
|
|
| 831 | -+ | ||
| 1001 | +! |
-
+ div( |
|
| 832 | +1002 | ! |
- all_ggplot2_args <- teal.widgets::resolve_ggplot2_args(+ align = "center", |
| 833 | +1003 | ! |
- user_plot = ggplot2_args[["Biplot"]],+ tags$h4("Eigenvectors"),
|
| 834 | +1004 | ! |
- user_default = ggplot2_args$default,+ tableOutput(session$ns("tbl_eigenvector")),
|
| 835 | +1005 | ! |
- module_plot = dev_ggplot2_args+ hr() |
| 836 | +1006 |
) |
|
| 837 | +1007 | ++ |
+ })+ |
+
| 1008 | |||
| 838 | +1009 | ! |
- parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(+ output$all_plots <- renderUI({
|
| 839 | +1010 | ! |
- all_ggplot2_args,+ teal::validate_inputs(iv_r()) |
| 840 | +1011 | ! |
- ggtheme = ggtheme+ teal::validate_inputs(iv_extra, header = "Plot settings are required") |
| 841 | +1012 |
- )+ |
|
| 842 | -+ | ||
| 1013 | +! |
-
+ validation() |
|
| 843 | +1014 | ! |
- pca_plot_biplot_expr <- c(+ tags$div( |
| 844 | +1015 | ! |
- pca_plot_biplot_expr,+ class = "overflow-scroll", |
| 845 | +1016 | ! |
- parsed_ggplot2_args+ uiOutput(session$ns("tbl_importance_ui")),
+ |
+
| 1017 | +! | +
+ uiOutput(session$ns("tbl_eigenvector_ui")),
+ |
+ |
| 1018 | +! | +
+ teal.widgets::plot_with_settings_ui(id = session$ns("pca_plot"))
|
|
| 846 | +1019 |
) |
|
| 847 | +1020 | ++ |
+ })+ |
+
| 1021 | |||
| 848 | +1022 | ! |
- teal.code::eval_code(+ teal.widgets::verbatim_popup_srv( |
| 849 | +1023 | ! |
- qenv,+ id = "warning", |
| 850 | +1024 | ! |
- substitute(+ verbatim_content = reactive(teal.code::get_warnings(output_q())), |
| 851 | +1025 | ! |
- expr = {
+ title = "Warning", |
| 852 | +1026 | ! |
- g <- plot_call+ disabled = reactive(is.null(teal.code::get_warnings(output_q()))) |
| 853 | -! | +||
| 1027 | +
- print(g)+ ) |
||
| 854 | +1028 |
- },+ |
|
| 855 | +1029 | ! |
- env = list(+ teal.widgets::verbatim_popup_srv( |
| 856 | +1030 | ! |
- plot_call = Reduce(function(x, y) call("+", x, y), pca_plot_biplot_expr)
+ id = "rcode", |
| 857 | -- |
- )- |
- |
| 858 | -+ | ||
| 1031 | +! |
- )+ verbatim_content = reactive(teal.code::get_code(output_q())), |
|
| 859 | -+ | ||
| 1032 | +! |
- )+ title = "R Code for PCA" |
|
| 860 | +1033 |
- }+ ) |
|
| 861 | +1034 | ||
| 862 | +1035 |
- # plot pc_var ----+ ### REPORTER |
|
| 863 | +1036 | ! |
- plot_pc_var <- function(base_q) {
+ if (with_reporter) {
|
| 864 | +1037 | ! |
- pc <- input$pc+ card_fun <- function(comment, label) {
|
| 865 | +1038 | ! |
- ggtheme <- input$ggtheme- |
-
| 866 | -- |
-
+ card <- teal::report_card_template( |
|
| 867 | +1039 | ! |
- rotate_xaxis_labels <- input$rotate_xaxis_labels+ title = "Principal Component Analysis Plot", |
| 868 | +1040 | ! |
- font_size <- input$font_size- |
-
| 869 | -- |
-
+ label = label, |
|
| 870 | +1041 | ! |
- angle <- ifelse(rotate_xaxis_labels, 45, 0)+ with_filter = with_filter, |
| 871 | +1042 | ! |
- hjust <- ifelse(rotate_xaxis_labels, 1, 0.5)+ filter_panel_api = filter_panel_api |
| 872 | +1043 |
-
+ ) |
|
| 873 | +1044 | ! |
- dev_ggplot2_args <- teal.widgets::ggplot2_args(+ card$append_text("Principal Components Table", "header3")
|
| 874 | +1045 | ! |
- theme = list(+ card$append_table(computation()[["tbl_importance"]]) |
| 875 | +1046 | ! |
- text = substitute(element_text(size = font_size), list(font_size = font_size)),+ card$append_text("Eigenvectors Table", "header3")
|
| 876 | +1047 | ! |
- axis.text.x = substitute(+ card$append_table(computation()[["tbl_eigenvector"]]) |
| 877 | +1048 | ! |
- element_text(angle = angle_val, hjust = hjust_val),+ card$append_text("Plot", "header3")
|
| 878 | +1049 | ! |
- list(angle_val = angle, hjust_val = hjust)+ card$append_plot(plot_r(), dim = pws$dim()) |
| 879 | -+ | ||
| 1050 | +! |
- )+ if (!comment == "") {
|
|
| 880 | -+ | ||
| 1051 | +! |
- )+ card$append_text("Comment", "header3")
|
|
| 881 | -+ | ||
| 1052 | +! |
- )+ card$append_text(comment) |
|
| 882 | +1053 |
-
+ } |
|
| 883 | +1054 | ! |
- all_ggplot2_args <- teal.widgets::resolve_ggplot2_args(+ card$append_src(teal.code::get_code(output_q())) |
| 884 | +1055 | ! |
- user_plot = ggplot2_args[["Eigenvector plot"]],+ card |
| 885 | -! | +||
| 1056 | +
- user_default = ggplot2_args$default,+ } |
||
| 886 | +1057 | ! |
- module_plot = dev_ggplot2_args+ teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
|
| 887 | +1058 |
- )+ } |
|
| 888 | +1059 |
-
+ ### |
|
| 889 | -! | +||
| 1060 | +
- parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(+ }) |
||
| 890 | -! | +||
| 1061 | +
- all_ggplot2_args,+ } |
||
| 891 | -! | +
| 1 | +
- ggtheme = ggtheme+ #' Create a simple cross-table |
||
| 892 | +2 |
- )+ #' @md |
|
| 893 | +3 |
-
+ #' |
|
| 894 | -! | +||
| 4 | +
- ggplot_exprs <- c(+ #' @inheritParams teal::module |
||
| 895 | -! | +||
| 5 | +
- list(+ #' @inheritParams shared_params |
||
| 896 | -! | +||
| 6 | +
- quote(ggplot(pca_rot)),+ #' @param x (`data_extract_spec` or `list` of multiple `data_extract_spec`) |
||
| 897 | -! | +||
| 7 | +
- substitute(+ #' Object with all available choices with pre-selected option for variable X - row values. In case |
||
| 898 | -! | +||
| 8 | +
- geom_bar(+ #' of `data_extract_spec` use `select_spec(..., ordered = TRUE)` if table elements should be |
||
| 899 | -! | +||
| 9 | +
- aes_string(x = "Variable", y = pc),+ #' rendered according to selection order. |
||
| 900 | -! | +||
| 10 | +
- stat = "identity",+ #' @param y (`data_extract_spec` or `list` of multiple `data_extract_spec`) |
||
| 901 | -! | +||
| 11 | +
- color = "black",+ #' Object with all available choices with pre-selected option for variable Y - column values |
||
| 902 | -! | +||
| 12 | +
- fill = c(getOption("ggplot2.discrete.colour"), "lightblue")[1]
+ #' \code{data_extract_spec} must not allow multiple selection in this case.
|
||
| 903 | +13 |
- ),+ #' |
|
| 904 | -! | +||
| 14 | +
- env = list(pc = pc)+ #' @param show_percentage optional, (`logical`) Whether to show percentages |
||
| 905 | +15 |
- ),+ #' (relevant only when `x` is a `factor`). Defaults to `TRUE`. |
|
| 906 | -! | +||
| 16 | +
- substitute(+ #' @param show_total optional, (`logical`) Whether to show total column. Defaults to `TRUE`. |
||
| 907 | -! | +||
| 17 | +
- geom_text(+ #' |
||
| 908 | -! | +||
| 18 | +
- aes(+ #' @note For more examples, please see the vignette "Using cross table" via |
||
| 909 | -! | +||
| 19 | +
- x = Variable,+ #' `vignette("using-cross-table", package = "teal.modules.general")`.
|
||
| 910 | -! | +||
| 20 | +
- y = pc_name,+ #' |
||
| 911 | -! | +||
| 21 | +
- label = round(pc_name, 3),+ #' @examples |
||
| 912 | -! | +||
| 22 | +
- vjust = ifelse(pc_name > 0, -0.5, 1.3)+ #' # general data example |
||
| 913 | +23 |
- )+ #' library(teal.widgets) |
|
| 914 | +24 |
- ),+ #' |
|
| 915 | -! | +||
| 25 | +
- env = list(pc_name = as.name(pc))+ #' data <- teal_data() |
||
| 916 | +26 |
- )+ #' data <- within(data, {
|
|
| 917 | +27 |
- ),+ #' mtcars <- mtcars |
|
| 918 | -! | +||
| 28 | +
- parsed_ggplot2_args$labs,+ #' for (v in c("cyl", "vs", "am", "gear")) {
|
||
| 919 | -! | +||
| 29 | +
- parsed_ggplot2_args$ggtheme,+ #' mtcars[[v]] <- as.factor(mtcars[[v]]) |
||
| 920 | -! | +||
| 30 | +
- parsed_ggplot2_args$theme+ #' } |
||
| 921 | +31 |
- )+ #' mtcars[["primary_key"]] <- seq_len(nrow(mtcars)) |
|
| 922 | +32 |
-
+ #' }) |
|
| 923 | -! | +||
| 33 | +
- teal.code::eval_code(+ #' datanames(data) <- "mtcars" |
||
| 924 | -! | +||
| 34 | +
- base_q,+ #' join_keys(data) <- join_keys(join_key("mtcars", "mtcars", "primary_key"))
|
||
| 925 | -! | +||
| 35 | +
- substitute(+ #' |
||
| 926 | -! | +||
| 36 | +
- expr = {
+ #' app <- init( |
||
| 927 | -! | +||
| 37 | +
- pca_rot <- pca$rotation[, pc, drop = FALSE] %>%+ #' data = data, |
||
| 928 | -! | +||
| 38 | +
- dplyr::as_tibble(rownames = "Variable")+ #' modules = modules( |
||
| 929 | +39 |
-
+ #' tm_t_crosstable( |
|
| 930 | -! | +||
| 40 | +
- g <- plot_call+ #' label = "Cross Table", |
||
| 931 | +41 |
-
+ #' x = data_extract_spec( |
|
| 932 | -! | +||
| 42 | +
- print(g)+ #' dataname = "mtcars", |
||
| 933 | +43 |
- },+ #' select = select_spec( |
|
| 934 | -! | +||
| 44 | +
- env = list(+ #' label = "Select variable:", |
||
| 935 | -! | +||
| 45 | +
- pc = pc,+ #' choices = variable_choices(data[["mtcars"]], c("cyl", "vs", "am", "gear")),
|
||
| 936 | -! | +||
| 46 | +
- plot_call = Reduce(function(x, y) call("+", x, y), ggplot_exprs)
+ #' selected = c("cyl", "gear"),
|
||
| 937 | +47 |
- )+ #' multiple = TRUE, |
|
| 938 | +48 |
- )+ #' ordered = TRUE, |
|
| 939 | +49 |
- )+ #' fixed = FALSE |
|
| 940 | +50 |
- }+ #' ) |
|
| 941 | +51 |
-
+ #' ), |
|
| 942 | +52 |
- # plot final ----+ #' y = data_extract_spec( |
|
| 943 | -! | +||
| 53 | +
- output_q <- reactive({
+ #' dataname = "mtcars", |
||
| 944 | -! | +||
| 54 | +
- req(computation())+ #' select = select_spec( |
||
| 945 | -! | +||
| 55 | +
- teal::validate_inputs(iv_r())+ #' label = "Select variable:", |
||
| 946 | -! | +||
| 56 | +
- teal::validate_inputs(iv_extra, header = "Plot settings are required")+ #' choices = variable_choices(data[["mtcars"]], c("cyl", "vs", "am", "gear")),
|
||
| 947 | +57 |
-
+ #' selected = "vs", |
|
| 948 | -! | +||
| 58 | +
- switch(input$plot_type,+ #' multiple = FALSE, |
||
| 949 | -! | +||
| 59 | +
- "Elbow plot" = plot_elbow(computation()),+ #' fixed = FALSE |
||
| 950 | -! | +||
| 60 | +
- "Circle plot" = plot_circle(computation()),+ #' ) |
||
| 951 | -! | +||
| 61 | +
- "Biplot" = plot_biplot(computation()),+ #' ), |
||
| 952 | -! | +||
| 62 | +
- "Eigenvector plot" = plot_pc_var(computation()),+ #' basic_table_args = basic_table_args( |
||
| 953 | -! | +||
| 63 | +
- stop("Unknown plot")
+ #' subtitles = "Table generated by Crosstable Module" |
||
| 954 | +64 |
- )+ #' ) |
|
| 955 | +65 |
- })+ #' ) |
|
| 956 | +66 |
-
+ #' ) |
|
| 957 | -! | +||
| 67 | +
- plot_r <- reactive({
+ #' ) |
||
| 958 | -! | +||
| 68 | +
- output_q()[["g"]]+ #' if (interactive()) {
|
||
| 959 | +69 |
- })+ #' shinyApp(app$ui, app$server) |
|
| 960 | +70 |
-
+ #' } |
|
| 961 | -! | +||
| 71 | +
- pws <- teal.widgets::plot_with_settings_srv(+ #' |
||
| 962 | -! | +||
| 72 | +
- id = "pca_plot",+ #' # CDISC data example |
||
| 963 | -! | +||
| 73 | +
- plot_r = plot_r,+ #' library(teal.widgets) |
||
| 964 | -! | +||
| 74 | +
- height = plot_height,+ #' |
||
| 965 | -! | +||
| 75 | +
- width = plot_width,+ #' data <- teal_data() |
||
| 966 | -! | +||
| 76 | +
- graph_align = "center"+ #' data <- within(data, {
|
||
| 967 | +77 |
- )+ #' ADSL <- rADSL |
|
| 968 | +78 |
-
+ #' }) |
|
| 969 | +79 |
- # tables ----+ #' datanames(data) <- "ADSL" |
|
| 970 | -! | +||
| 80 | +
- output$tbl_importance <- renderTable(+ #' join_keys(data) <- default_cdisc_join_keys[datanames(data)] |
||
| 971 | -! | +||
| 81 | +
- expr = {
+ #' |
||
| 972 | -! | +||
| 82 | +
- req("importance" %in% input$tables_display, computation())
+ #' app <- init( |
||
| 973 | -! | +||
| 83 | +
- computation()[["tbl_importance"]]+ #' data = data, |
||
| 974 | +84 |
- },+ #' modules = modules( |
|
| 975 | -! | +||
| 85 | +
- bordered = TRUE,+ #' tm_t_crosstable( |
||
| 976 | -! | +||
| 86 | +
- align = "c",+ #' label = "Cross Table", |
||
| 977 | -! | +||
| 87 | +
- digits = 3+ #' x = data_extract_spec( |
||
| 978 | +88 |
- )+ #' dataname = "ADSL", |
|
| 979 | +89 |
-
+ #' select = select_spec( |
|
| 980 | -! | +||
| 90 | +
- output$tbl_importance_ui <- renderUI({
+ #' label = "Select variable:", |
||
| 981 | -! | +||
| 91 | +
- req("importance" %in% input$tables_display)
+ #' choices = variable_choices(data[["ADSL"]], subset = function(data) {
|
||
| 982 | -! | +||
| 92 | +
- div(+ #' idx <- !vapply(data, inherits, logical(1), c("Date", "POSIXct", "POSIXlt"))
|
||
| 983 | -! | +||
| 93 | +
- align = "center",+ #' return(names(data)[idx]) |
||
| 984 | -! | +||
| 94 | +
- tags$h4("Principal components importance"),
+ #' }), |
||
| 985 | -! | +||
| 95 | +
- tableOutput(session$ns("tbl_importance")),
+ #' selected = "COUNTRY", |
||
| 986 | -! | +||
| 96 | +
- hr()+ #' multiple = TRUE, |
||
| 987 | +97 |
- )+ #' ordered = TRUE, |
|
| 988 | +98 |
- })+ #' fixed = FALSE |
|
| 989 | +99 |
-
+ #' ) |
|
| 990 | -! | +||
| 100 | +
- output$tbl_eigenvector <- renderTable(+ #' ), |
||
| 991 | -! | +||
| 101 | +
- expr = {
+ #' y = data_extract_spec( |
||
| 992 | -! | +||
| 102 | +
- req("eigenvector" %in% input$tables_display, req(computation()))
+ #' dataname = "ADSL", |
||
| 993 | -! | +||
| 103 | +
- computation()[["tbl_eigenvector"]]+ #' select = select_spec( |
||
| 994 | +104 |
- },+ #' label = "Select variable:", |
|
| 995 | -! | +||
| 105 | +
- bordered = TRUE,+ #' choices = variable_choices(data[["ADSL"]], subset = function(data) {
|
||
| 996 | -! | +||
| 106 | +
- align = "c",+ #' idx <- vapply(data, is.factor, logical(1)) |
||
| 997 | -! | +||
| 107 | +
- digits = 3+ #' return(names(data)[idx]) |
||
| 998 | +108 |
- )+ #' }), |
|
| 999 | +109 |
-
+ #' selected = "SEX", |
|
| 1000 | -! | +||
| 110 | +
- output$tbl_eigenvector_ui <- renderUI({
+ #' multiple = FALSE, |
||
| 1001 | -! | +||
| 111 | +
- req("eigenvector" %in% input$tables_display)
+ #' fixed = FALSE |
||
| 1002 | -! | +||
| 112 | +
- div(+ #' ) |
||
| 1003 | -! | +||
| 113 | +
- align = "center",+ #' ), |
||
| 1004 | -! | +||
| 114 | +
- tags$h4("Eigenvectors"),
+ #' basic_table_args = basic_table_args( |
||
| 1005 | -! | +||
| 115 | +
- tableOutput(session$ns("tbl_eigenvector")),
+ #' subtitles = "Table generated by Crosstable Module" |
||
| 1006 | -! | +||
| 116 | +
- hr()+ #' ) |
||
| 1007 | +117 |
- )+ #' ) |
|
| 1008 | +118 |
- })+ #' ) |
|
| 1009 | +119 |
-
+ #' ) |
|
| 1010 | -! | +||
| 120 | +
- output$all_plots <- renderUI({
+ #' if (interactive()) {
|
||
| 1011 | -! | +||
| 121 | +
- teal::validate_inputs(iv_r())+ #' shinyApp(app$ui, app$server) |
||
| 1012 | -! | +||
| 122 | +
- teal::validate_inputs(iv_extra, header = "Plot settings are required")+ #' } |
||
| 1013 | +123 |
-
+ #' |
|
| 1014 | -! | +||
| 124 | +
- validation()+ #' @export |
||
| 1015 | -! | +||
| 125 | +
- tags$div(+ #' |
||
| 1016 | -! | +||
| 126 | +
- class = "overflow-scroll",+ tm_t_crosstable <- function(label = "Cross Table", |
||
| 1017 | -! | -
- uiOutput(session$ns("tbl_importance_ui")),
+ | |
| 127 | ++ |
+ x, |
|
| 1018 | -! | +||
| 128 | +
- uiOutput(session$ns("tbl_eigenvector_ui")),
+ y, |
||
| 1019 | -! | +||
| 129 | +
- teal.widgets::plot_with_settings_ui(id = session$ns("pca_plot"))
+ show_percentage = TRUE, |
||
| 1020 | +130 |
- )+ show_total = TRUE, |
|
| 1021 | +131 |
- })+ pre_output = NULL, |
|
| 1022 | +132 |
-
+ post_output = NULL, |
|
| 1023 | -! | +||
| 133 | +
- teal.widgets::verbatim_popup_srv(+ basic_table_args = teal.widgets::basic_table_args()) {
|
||
| 1024 | +134 | ! |
- id = "warning",+ logger::log_info("Initializing tm_t_crosstable")
|
| 1025 | +135 | ! |
- verbatim_content = reactive(teal.code::get_warnings(output_q())),+ if (!requireNamespace("rtables", quietly = TRUE)) {
|
| 1026 | +136 | ! |
- title = "Warning",+ stop("Cannot load rtables - please install the package or restart your session.")
+ |
+
| 137 | ++ |
+ } |
|
| 1027 | +138 | ! |
- disabled = reactive(is.null(teal.code::get_warnings(output_q())))+ if (inherits(x, "data_extract_spec")) x <- list(x) |
| 1028 | -+ | ||
| 139 | +! |
- )+ if (inherits(y, "data_extract_spec")) y <- list(y) |
|
| 1029 | +140 | ||
| 1030 | +141 | ! |
- teal.widgets::verbatim_popup_srv(+ checkmate::assert_string(label) |
| 1031 | +142 | ! |
- id = "rcode",+ checkmate::assert_list(x, types = "data_extract_spec") |
| 1032 | +143 | ! |
- verbatim_content = reactive(teal.code::get_code(output_q())),+ checkmate::assert_list(y, types = "data_extract_spec") |
| 1033 | +144 | ! |
- title = "R Code for PCA"- |
-
| 1034 | -- |
- )+ if (any(vapply(y, function(x) x$select$multiple, logical(1)))) {
|
|
| 1035 | -+ | ||
| 145 | +! |
-
+ stop("'y' should not allow multiple selection")
|
|
| 1036 | +146 |
- ### REPORTER+ } |
|
| 1037 | +147 | ! |
- if (with_reporter) {
+ checkmate::assert_flag(show_percentage) |
| 1038 | +148 | ! |
- card_fun <- function(comment, label) {
+ checkmate::assert_flag(show_total) |
| 1039 | +149 | ! |
- card <- teal::report_card_template(+ checkmate::assert_class(basic_table_args, classes = "basic_table_args") |
| 1040 | -! | +||
| 150 | +
- title = "Principal Component Analysis Plot",+ |
||
| 1041 | +151 | ! |
- label = label,+ ui_args <- as.list(environment()) |
| 1042 | -! | +||
| 152 | +
- with_filter = with_filter,+ |
||
| 1043 | +153 | ! |
- filter_panel_api = filter_panel_api+ server_args <- list( |
| 1044 | -+ | ||
| 154 | +! |
- )+ label = label, |
|
| 1045 | +155 | ! |
- card$append_text("Principal Components Table", "header3")
+ x = x, |
| 1046 | +156 | ! |
- card$append_table(computation()[["tbl_importance"]])+ y = y, |
| 1047 | +157 | ! |
- card$append_text("Eigenvectors Table", "header3")
+ basic_table_args = basic_table_args |
| 1048 | -! | +||
| 158 | +
- card$append_table(computation()[["tbl_eigenvector"]])+ ) |
||
| 1049 | -! | +||
| 159 | +
- card$append_text("Plot", "header3")
+
|
||
| 1050 | +160 | ! |
- card$append_plot(plot_r(), dim = pws$dim())+ module( |
| 1051 | +161 | ! |
- if (!comment == "") {
+ label = label, |
| 1052 | +162 | ! |
- card$append_text("Comment", "header3")
+ server = srv_t_crosstable, |
| 1053 | +163 | ! |
- card$append_text(comment)+ ui = ui_t_crosstable, |
| 1054 | -+ | ||
| 164 | +! |
- }+ ui_args = ui_args, |
|
| 1055 | +165 | ! |
- card$append_src(teal.code::get_code(output_q()))+ server_args = server_args, |
| 1056 | +166 | ! |
- card+ datanames = teal.transform::get_extract_datanames(list(x = x, y = y)) |
| 1057 | +167 |
- }+ ) |
|
| 1058 | -! | +||
| 168 | +
- teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
+ } |
||
| 1059 | +169 |
- }+ |
|
| 1060 | +170 |
- ###+ ui_t_crosstable <- function(id, x, y, show_percentage, show_total, pre_output, post_output, ...) {
|
|
| 1061 | -+ | ||
| 171 | +! |
- })+ ns <- NS(id) |
|
| 1062 | -+ | ||
| 172 | +! |
- }+ is_single_dataset <- teal.transform::is_single_dataset(x, y) |
| 1 | +173 |
- #' Univariate and bivariate visualizations+ |
|
| 2 | -+ | ||
| 174 | +! |
- #' @md+ join_default_options <- c( |
|
| 3 | -+ | ||
| 175 | +! |
- #'+ "Full Join" = "dplyr::full_join", |
|
| 4 | -+ | ||
| 176 | +! |
- #' @inheritParams teal::module+ "Inner Join" = "dplyr::inner_join", |
|
| 5 | -+ | ||
| 177 | +! |
- #' @inheritParams shared_params+ "Left Join" = "dplyr::left_join", |
|
| 6 | -+ | ||
| 178 | +! |
- #' @param x (`data_extract_spec` or `list` of multiple `data_extract_spec`)+ "Right Join" = "dplyr::right_join" |
|
| 7 | +179 |
- #' Variable names selected to plot along the x-axis by default. Variable can be numeric, factor or character.+ ) |
|
| 8 | +180 |
- #' No empty selections are allowed!+ |
|
| 9 | -+ | ||
| 181 | +! |
- #' @param y (`data_extract_spec` or `list` of multiple `data_extract_spec`)+ teal.widgets::standard_layout( |
|
| 10 | -+ | ||
| 182 | +! |
- #' Variable names selected to plot along the y-axis by default. Variable can be numeric, factor or character.+ output = teal.widgets::white_small_well( |
|
| 11 | -+ | ||
| 183 | +! |
- #' @param use_density optional, (`logical`) value for whether density (`TRUE`) is plotted or+ textOutput(ns("title")),
|
|
| 12 | -+ | ||
| 184 | +! |
- #' frequency (`FALSE`). Defaults to frequency (`FALSE`).+ teal.widgets::table_with_settings_ui(ns("table"))
|
|
| 13 | +185 |
- #' @param row_facet optional, (`data_extract_spec` or `list` of multiple `data_extract_spec`)+ ), |
|
| 14 | -+ | ||
| 186 | +! |
- #' Variables for row facetting.+ encoding = div( |
|
| 15 | +187 |
- #' @param col_facet optional, (`data_extract_spec` or `list` of multiple `data_extract_spec`)+ ### Reporter |
|
| 16 | -+ | ||
| 188 | +! |
- #' Variables for col facetting.+ teal.reporter::simple_reporter_ui(ns("simple_reporter")),
|
|
| 17 | +189 |
- #' @param facet optional, (`logical`) to specify whether the facet encodings `ui` elements are toggled+ ### |
|
| 18 | -+ | ||
| 190 | +! |
- #' on and shown to the user by default. Defaults to `TRUE` if either `row_facet` or `column_facet`+ tags$label("Encodings", class = "text-primary"),
|
|
| 19 | -+ | ||
| 191 | +! |
- #' are supplied.+ teal.transform::datanames_input(list(x, y)), |
|
| 20 | -+ | ||
| 192 | +! |
- #' @param color_settings (`logical`) Whether coloring, filling and size should be applied+ teal.transform::data_extract_ui(ns("x"), label = "Row values", x, is_single_dataset = is_single_dataset),
|
|
| 21 | -+ | ||
| 193 | +! |
- #' and `UI` tool offered to the user.+ teal.transform::data_extract_ui(ns("y"), label = "Column values", y, is_single_dataset = is_single_dataset),
|
|
| 22 | -+ | ||
| 194 | +! |
- #' @param color optional, (`data_extract_spec` or `list` of multiple `data_extract_spec`)+ teal.widgets::optionalSelectInput( |
|
| 23 | -+ | ||
| 195 | +! |
- #' Variables selected for the outline color inside the coloring settings.+ ns("join_fun"),
|
|
| 24 | -+ | ||
| 196 | +! |
- #' It will be applied when `color_settings` is set to `TRUE`.+ label = "Row to Column type of join", |
|
| 25 | -+ | ||
| 197 | +! |
- #' @param fill optional, (`data_extract_spec` or `list` of multiple `data_extract_spec`)+ choices = join_default_options, |
|
| 26 | -+ | ||
| 198 | +! |
- #' Variables selected for the fill color inside the coloring settings.+ selected = join_default_options[1], |
|
| 27 | -+ | ||
| 199 | +! |
- #' It will be applied when `color_settings` is set to `TRUE`.+ multiple = FALSE |
|
| 28 | +200 |
- #' @param size optional, (`data_extract_spec` or `list` of multiple `data_extract_spec`)+ ), |
|
| 29 | -+ | ||
| 201 | +! |
- #' Variables selected for the size of `geom_point` plots inside the coloring settings.+ tags$hr(), |
|
| 30 | -+ | ||
| 202 | +! |
- #' It will be applied when `color_settings` is set to `TRUE`.+ teal.widgets::panel_group( |
|
| 31 | -+ | ||
| 203 | +! |
- #' @param free_x_scales optional, (`logical`) Whether X scaling shall be changeable.+ teal.widgets::panel_item( |
|
| 32 | -+ | ||
| 204 | +! |
- #' Does not allow scaling to be changed by default (`FALSE`).+ title = "Table settings", |
|
| 33 | -+ | ||
| 205 | +! |
- #' @param free_y_scales optional, (`logical`) Whether Y scaling shall be changeable.+ checkboxInput(ns("show_percentage"), "Show column percentage", value = show_percentage),
|
|
| 34 | -+ | ||
| 206 | +! |
- #' Does not allow scaling to be changed by default (`FALSE`).+ checkboxInput(ns("show_total"), "Show total column", value = show_total)
|
|
| 35 | +207 |
- #' @param swap_axes optional, (`logical`) Whether to swap X and Y axes. Defaults to `FALSE`.+ ) |
|
| 36 | +208 |
- #'+ ) |
|
| 37 | +209 |
- #' @details+ ), |
|
| 38 | -+ | ||
| 210 | +! |
- #' This is a general module to visualize 1 & 2 dimensional data.+ forms = tagList( |
|
| 39 | -+ | ||
| 211 | +! |
- #'+ teal.widgets::verbatim_popup_ui(ns("warning"), "Show Warnings"),
|
|
| 40 | -+ | ||
| 212 | +! |
- #' @note+ teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code")
|
|
| 41 | +213 |
- #' For more examples, please see the vignette "Using bivariate plot" via+ ), |
|
| 42 | -+ | ||
| 214 | +! |
- #' `vignette("using-bivariate-plot", package = "teal.modules.general")`.
+ pre_output = pre_output, |
|
| 43 | -+ | ||
| 215 | +! |
- #'+ post_output = post_output |
|
| 44 | +216 |
- #' @export+ ) |
|
| 45 | +217 |
- #'+ } |
|
| 46 | +218 |
- #' @examples+ |
|
| 47 | +219 |
- #' # general data exapmle+ srv_t_crosstable <- function(id, data, reporter, filter_panel_api, label, x, y, basic_table_args) {
|
|
| 48 | -+ | ||
| 220 | +! |
- #' library(teal.widgets)+ with_reporter <- !missing(reporter) && inherits(reporter, "Reporter") |
|
| 49 | -+ | ||
| 221 | +! |
- #'+ with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI") |
|
| 50 | -+ | ||
| 222 | +! |
- #' data <- teal_data()+ checkmate::assert_class(data, "reactive") |
|
| 51 | -+ | ||
| 223 | +! |
- #' data <- within(data, {
+ checkmate::assert_class(isolate(data()), "teal_data") |
|
| 52 | -+ | ||
| 224 | +! |
- #' library(nestcolor)+ moduleServer(id, function(input, output, session) {
|
|
| 53 | -+ | ||
| 225 | +! |
- #' CO2 <- data.frame(CO2)+ selector_list <- teal.transform::data_extract_multiple_srv( |
|
| 54 | -+ | ||
| 226 | +! |
- #' })+ data_extract = list(x = x, y = y), |
|
| 55 | -+ | ||
| 227 | +! |
- #' datanames(data) <- c("CO2")
+ datasets = data, |
|
| 56 | -+ | ||
| 228 | +! |
- #' join_keys(data) <- default_cdisc_join_keys[datanames(data)]+ select_validation_rule = list( |
|
| 57 | -+ | ||
| 229 | +! |
- #'+ x = shinyvalidate::sv_required("Please define column for row variable."),
|
|
| 58 | -+ | ||
| 230 | +! |
- #' app <- init(+ y = shinyvalidate::sv_required("Please define column for column variable.")
|
|
| 59 | +231 |
- #' data = data,+ ) |
|
| 60 | +232 |
- #' modules = modules(+ ) |
|
| 61 | +233 |
- #' tm_g_bivariate(+ |
|
| 62 | -+ | ||
| 234 | +! |
- #' x = data_extract_spec(+ iv_r <- reactive({
|
|
| 63 | -+ | ||
| 235 | +! |
- #' dataname = "CO2",+ iv <- shinyvalidate::InputValidator$new() |
|
| 64 | -+ | ||
| 236 | +! |
- #' select = select_spec(+ iv$add_rule("join_fun", function(value) {
|
|
| 65 | -+ | ||
| 237 | +! |
- #' label = "Select variable:",+ if (!identical(selector_list()$x()$dataname, selector_list()$y()$dataname)) {
|
|
| 66 | -+ | ||
| 238 | +! |
- #' choices = variable_choices(data[["CO2"]]),+ if (!shinyvalidate::input_provided(value)) {
|
|
| 67 | -+ | ||
| 239 | +! |
- #' selected = "conc",+ "Please select a joining function." |
|
| 68 | +240 |
- #' fixed = FALSE+ } |
|
| 69 | +241 |
- #' )+ } |
|
| 70 | +242 |
- #' ),+ }) |
|
| 71 | -+ | ||
| 243 | +! |
- #' y = data_extract_spec(+ teal.transform::compose_and_enable_validators(iv, selector_list) |
|
| 72 | +244 |
- #' dataname = "CO2",+ }) |
|
| 73 | +245 |
- #' select = select_spec(+ |
|
| 74 | -+ | ||
| 246 | +! |
- #' label = "Select variable:",+ observeEvent( |
|
| 75 | -+ | ||
| 247 | +! |
- #' choices = variable_choices(data[["CO2"]]),+ eventExpr = {
|
|
| 76 | -+ | ||
| 248 | +! |
- #' selected = "uptake",+ req(!is.null(selector_list()$x()) && !is.null(selector_list()$y())) |
|
| 77 | -+ | ||
| 249 | +! |
- #' multiple = FALSE,+ list(selector_list()$x(), selector_list()$y()) |
|
| 78 | +250 |
- #' fixed = FALSE+ }, |
|
| 79 | -+ | ||
| 251 | +! |
- #' )+ handlerExpr = {
|
|
| 80 | -+ | ||
| 252 | +! |
- #' ),+ if (identical(selector_list()$x()$dataname, selector_list()$y()$dataname)) {
|
|
| 81 | -+ | ||
| 253 | +! |
- #' row_facet = data_extract_spec(+ shinyjs::hide("join_fun")
|
|
| 82 | +254 |
- #' dataname = "CO2",+ } else {
|
|
| 83 | -+ | ||
| 255 | +! |
- #' select = select_spec(+ shinyjs::show("join_fun")
|
|
| 84 | +256 |
- #' label = "Select variable:",+ } |
|
| 85 | +257 |
- #' choices = variable_choices(data[["CO2"]]),+ } |
|
| 86 | +258 |
- #' selected = "Type",+ ) |
|
| 87 | +259 |
- #' fixed = FALSE+ |
|
| 88 | -+ | ||
| 260 | +! |
- #' )+ merge_function <- reactive({
|
|
| 89 | -+ | ||
| 261 | +! |
- #' ),+ if (is.null(input$join_fun)) {
|
|
| 90 | -+ | ||
| 262 | +! |
- #' col_facet = data_extract_spec(+ "dplyr::full_join" |
|
| 91 | +263 |
- #' dataname = "CO2",+ } else {
|
|
| 92 | -+ | ||
| 264 | +! |
- #' select = select_spec(+ input$join_fun |
|
| 93 | +265 |
- #' label = "Select variable:",+ } |
|
| 94 | +266 |
- #' choices = variable_choices(data[["CO2"]]),+ }) |
|
| 95 | +267 |
- #' selected = "Treatment",+ |
|
| 96 | -+ | ||
| 268 | +! |
- #' fixed = FALSE+ anl_merged_input <- teal.transform::merge_expression_srv( |
|
| 97 | -+ | ||
| 269 | +! |
- #' )+ datasets = data, |
|
| 98 | -+ | ||
| 270 | +! |
- #' ),+ selector_list = selector_list, |
|
| 99 | -+ | ||
| 271 | +! |
- #' ggplot2_args = ggplot2_args(+ merge_function = merge_function |
|
| 100 | +272 |
- #' labs = list(subtitle = "Plot generated by Bivariate Module")+ ) |
|
| 101 | +273 |
- #' )+ |
|
| 102 | -+ | ||
| 274 | +! |
- #' )+ anl_merged_q <- reactive({
|
|
| 103 | -+ | ||
| 275 | +! |
- #' )+ req(anl_merged_input()) |
|
| 104 | -+ | ||
| 276 | +! |
- #' )+ data() %>% |
|
| 105 | -+ | ||
| 277 | +! |
- #' if (interactive()) {
+ teal.code::eval_code(as.expression(anl_merged_input()$expr)) |
|
| 106 | +278 |
- #' shinyApp(app$ui, app$server)+ }) |
|
| 107 | +279 |
- #' }+ |
|
| 108 | -+ | ||
| 280 | +! |
- #'+ merged <- list( |
|
| 109 | -+ | ||
| 281 | +! |
- #'+ anl_input_r = anl_merged_input, |
|
| 110 | -+ | ||
| 282 | +! |
- #' # CDISC data example+ anl_q_r = anl_merged_q |
|
| 111 | +283 |
- #' library(teal.widgets)+ ) |
|
| 112 | +284 |
- #'+ |
|
| 113 | -+ | ||
| 285 | +! |
- #' data <- teal_data()+ output_q <- reactive({
|
|
| 114 | -+ | ||
| 286 | +! |
- #' data <- within(data, {
+ teal::validate_inputs(iv_r()) |
|
| 115 | -+ | ||
| 287 | +! |
- #' library(nestcolor)+ ANL <- merged$anl_q_r()[["ANL"]] # nolint: object_name. |
|
| 116 | +288 |
- #' ADSL <- rADSL+ |
|
| 117 | +289 |
- #' })+ # As this is a summary |
|
| 118 | -+ | ||
| 290 | +! |
- #' datanames(data) <- c("ADSL")
+ x_name <- as.vector(merged$anl_input_r()$columns_source$x) |
|
| 119 | -+ | ||
| 291 | +! |
- #' join_keys(data) <- default_cdisc_join_keys[datanames(data)]+ y_name <- as.vector(merged$anl_input_r()$columns_source$y) |
|
| 120 | +292 |
- #'+ |
|
| 121 | -+ | ||
| 293 | +! |
- #' app <- init(+ teal::validate_has_data(ANL, 3) |
|
| 122 | -+ | ||
| 294 | +! |
- #' data = data,+ teal::validate_has_data(ANL[, c(x_name, y_name)], 3, complete = TRUE, allow_inf = FALSE) |
|
| 123 | +295 |
- #' modules = modules(+ |
|
| 124 | -+ | ||
| 296 | +! |
- #' tm_g_bivariate(+ is_allowed_class <- function(x) is.numeric(x) || is.factor(x) || is.character(x) || is.logical(x) |
|
| 125 | -+ | ||
| 297 | +! |
- #' x = data_extract_spec(+ validate(need( |
|
| 126 | -+ | ||
| 298 | +! |
- #' dataname = "ADSL",+ all(vapply(ANL[x_name], is_allowed_class, logical(1))), |
|
| 127 | -+ | ||
| 299 | +! |
- #' select = select_spec(+ "Selected row variable has an unsupported data type." |
|
| 128 | +300 |
- #' label = "Select variable:",+ )) |
|
| 129 | -+ | ||
| 301 | +! |
- #' choices = variable_choices(data[["ADSL"]]),+ validate(need( |
|
| 130 | -+ | ||
| 302 | +! |
- #' selected = "AGE",+ is_allowed_class(ANL[[y_name]]), |
|
| 131 | -+ | ||
| 303 | +! |
- #' fixed = FALSE+ "Selected column variable has an unsupported data type." |
|
| 132 | +304 |
- #' )+ )) |
|
| 133 | +305 |
- #' ),+ |
|
| 134 | -+ | ||
| 306 | +! |
- #' y = data_extract_spec(+ show_percentage <- input$show_percentage |
|
| 135 | -+ | ||
| 307 | +! |
- #' dataname = "ADSL",+ show_total <- input$show_total |
|
| 136 | +308 |
- #' select = select_spec(+ |
|
| 137 | -+ | ||
| 309 | +! |
- #' label = "Select variable:",+ plot_title <- paste( |
|
| 138 | -+ | ||
| 310 | +! |
- #' choices = variable_choices(data[["ADSL"]]),+ "Cross-Table of", |
|
| 139 | -+ | ||
| 311 | +! |
- #' selected = "SEX",+ paste0(varname_w_label(x_name, ANL), collapse = ", "), |
|
| 140 | -+ | ||
| 312 | +! |
- #' multiple = FALSE,+ "(rows)", "vs.", |
|
| 141 | -+ | ||
| 313 | +! |
- #' fixed = FALSE+ varname_w_label(y_name, ANL), |
|
| 142 | -+ | ||
| 314 | +! |
- #' )+ "(columns)" |
|
| 143 | +315 |
- #' ),+ ) |
|
| 144 | +316 |
- #' row_facet = data_extract_spec(+ |
|
| 145 | -+ | ||
| 317 | +! |
- #' dataname = "ADSL",+ labels_vec <- vapply( |
|
| 146 | -+ | ||
| 318 | +! |
- #' select = select_spec(+ x_name, |
|
| 147 | -+ | ||
| 319 | +! |
- #' label = "Select variable:",+ varname_w_label, |
|
| 148 | -+ | ||
| 320 | +! |
- #' choices = variable_choices(data[["ADSL"]]),+ character(1), |
|
| 149 | -+ | ||
| 321 | +! |
- #' selected = "ARM",+ ANL |
|
| 150 | +322 |
- #' fixed = FALSE+ ) |
|
| 151 | +323 |
- #' )+ |
|
| 152 | -+ | ||
| 324 | +! |
- #' ),+ teal.code::eval_code( |
|
| 153 | -+ | ||
| 325 | +! |
- #' col_facet = data_extract_spec(+ merged$anl_q_r(), |
|
| 154 | -+ | ||
| 326 | +! |
- #' dataname = "ADSL",+ substitute( |
|
| 155 | -+ | ||
| 327 | +! |
- #' select = select_spec(+ expr = {
|
|
| 156 | -+ | ||
| 328 | +! |
- #' label = "Select variable:",+ title <- plot_title |
|
| 157 | +329 |
- #' choices = variable_choices(data[["ADSL"]]),+ }, |
|
| 158 | -+ | ||
| 330 | +! |
- #' selected = "COUNTRY",+ env = list(plot_title = plot_title) |
|
| 159 | +331 |
- #' fixed = FALSE+ ) |
|
| 160 | +332 |
- #' )+ ) %>% |
|
| 161 | -+ | ||
| 333 | +! |
- #' ),+ teal.code::eval_code( |
|
| 162 | -+ | ||
| 334 | +! |
- #' ggplot2_args = ggplot2_args(+ substitute( |
|
| 163 | -+ | ||
| 335 | +! |
- #' labs = list(subtitle = "Plot generated by Bivariate Module")+ expr = {
|
|
| 164 | -+ | ||
| 336 | +! |
- #' )+ lyt <- basic_tables %>% |
|
| 165 | -+ | ||
| 337 | +! |
- #' )+ split_call %>% # styler: off |
|
| 166 | -+ | ||
| 338 | +! |
- #' )+ rtables::add_colcounts() %>% |
|
| 167 | -+ | ||
| 339 | +! |
- #' )+ tern::analyze_vars( |
|
| 168 | -+ | ||
| 340 | +! |
- #' if (interactive()) {
+ vars = x_name, |
|
| 169 | -+ | ||
| 341 | +! |
- #' shinyApp(app$ui, app$server)+ var_labels = labels_vec, |
|
| 170 | -+ | ||
| 342 | +! |
- #' }+ na.rm = FALSE, |
|
| 171 | -+ | ||
| 343 | +! |
- tm_g_bivariate <- function(label = "Bivariate Plots",+ denom = "N_col", |
|
| 172 | -+ | ||
| 344 | +! |
- x,+ .stats = c("mean_sd", "median", "range", count_value)
|
|
| 173 | +345 |
- y,+ ) |
|
| 174 | +346 |
- row_facet = NULL,+ }, |
|
| 175 | -+ | ||
| 347 | +! |
- col_facet = NULL,+ env = list( |
|
| 176 | -+ | ||
| 348 | +! |
- facet = !is.null(row_facet) || !is.null(col_facet),+ basic_tables = teal.widgets::parse_basic_table_args( |
|
| 177 | -+ | ||
| 349 | +! |
- color = NULL,+ basic_table_args = teal.widgets::resolve_basic_table_args(basic_table_args) |
|
| 178 | +350 |
- fill = NULL,+ ), |
|
| 179 | -+ | ||
| 351 | +! |
- size = NULL,+ split_call = if (show_total) {
|
|
| 180 | -+ | ||
| 352 | +! |
- use_density = FALSE,+ substitute( |
|
| 181 | -+ | ||
| 353 | +! |
- color_settings = FALSE,+ expr = rtables::split_cols_by( |
|
| 182 | -+ | ||
| 354 | +! |
- free_x_scales = FALSE,+ y_name, |
|
| 183 | -+ | ||
| 355 | +! |
- free_y_scales = FALSE,+ split_fun = rtables::add_overall_level(label = "Total", first = FALSE) |
|
| 184 | +356 |
- plot_height = c(600, 200, 2000),+ ), |
|
| 185 | -+ | ||
| 357 | +! |
- plot_width = NULL,+ env = list(y_name = y_name) |
|
| 186 | +358 |
- rotate_xaxis_labels = FALSE,+ ) |
|
| 187 | +359 |
- swap_axes = FALSE,+ } else {
|
|
| 188 | -+ | ||
| 360 | +! |
- ggtheme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void"),
+ substitute(rtables::split_cols_by(y_name), env = list(y_name = y_name)) |
|
| 189 | +361 |
- ggplot2_args = teal.widgets::ggplot2_args(),+ }, |
|
| 190 | -+ | ||
| 362 | +! |
- pre_output = NULL,- |
- |
| 191 | -- |
- post_output = NULL) {
+ x_name = x_name, |
|
| 192 | +363 | ! |
- logger::log_info("Initializing tm_g_bivariate")
+ labels_vec = labels_vec, |
| 193 | +364 | ! |
- if (inherits(x, "data_extract_spec")) x <- list(x)+ count_value = ifelse(show_percentage, "count_fraction", "count") |
| 194 | -! | +||
| 365 | +
- if (inherits(y, "data_extract_spec")) y <- list(y)+ ) |
||
| 195 | -! | +||
| 366 | +
- if (inherits(row_facet, "data_extract_spec")) row_facet <- list(row_facet)+ ) |
||
| 196 | -! | +||
| 367 | +
- if (inherits(col_facet, "data_extract_spec")) col_facet <- list(col_facet)+ ) %>% |
||
| 197 | +368 | ! |
- if (inherits(color, "data_extract_spec")) color <- list(color)+ teal.code::eval_code( |
| 198 | +369 | ! |
- if (inherits(fill, "data_extract_spec")) fill <- list(fill)+ substitute( |
| 199 | +370 | ! |
- if (inherits(size, "data_extract_spec")) size <- list(size)- |
-
| 200 | -- |
-
+ expr = {
|
|
| 201 | +371 | ! |
- checkmate::assert_list(x, types = "data_extract_spec")+ ANL <- tern::df_explicit_na(ANL) # nolint: object_name. |
| 202 | +372 | ! |
- if (!all(vapply(x, function(x) !x$select$multiple, logical(1)))) {
+ tbl <- rtables::build_table(lyt = lyt, df = ANL[order(ANL[[y_name]]), ]) |
| 203 | +373 | ! |
- stop("'x' should not allow multiple selection")
+ tbl |
| 204 | +374 |
- }- |
- |
| 205 | -! | -
- checkmate::assert_list(y, types = "data_extract_spec")+ }, |
|
| 206 | +375 | ! |
- if (!all(vapply(y, function(x) !x$select$multiple, logical(1)))) {
+ env = list(y_name = y_name) |
| 207 | -! | +||
| 376 | +
- stop("'y' should not allow multiple selection")
+ ) |
||
| 208 | +377 |
- }+ ) |
|
| 209 | -! | +||
| 378 | +
- checkmate::assert_list(row_facet, types = "data_extract_spec", null.ok = TRUE)+ }) |
||
| 210 | -! | +||
| 379 | +
- if (!all(vapply(row_facet, function(x) !x$select$multiple, logical(1)))) {
+
|
||
| 211 | +380 | ! |
- stop("'row_facet' should not allow multiple selection")
+ output$title <- renderText(output_q()[["title"]]) |
| 212 | +381 |
- }+ |
|
| 213 | +382 | ! |
- checkmate::assert_list(col_facet, types = "data_extract_spec", null.ok = TRUE)+ table_r <- reactive({
|
| 214 | +383 | ! |
- if (!all(vapply(col_facet, function(x) !x$select$multiple, logical(1)))) {
+ shiny::req(iv_r()$is_valid()) |
| 215 | +384 | ! |
- stop("'col_facet' should not allow multiple selection")
+ output_q()[["tbl"]] |
| 216 | +385 |
- }+ })+ |
+ |
| 386 | ++ | + | |
| 217 | +387 | ! |
- checkmate::assert_list(color, types = "data_extract_spec", null.ok = TRUE)+ teal.widgets::table_with_settings_srv( |
| 218 | +388 | ! |
- if (!all(vapply(color, function(x) !x$select$multiple, logical(1)))) {
+ id = "table", |
| 219 | +389 | ! |
- stop("'color' should not allow multiple selection")
+ table_r = table_r |
| 220 | +390 |
- }+ ) |
|
| 221 | -! | +||
| 391 | +
- checkmate::assert_list(fill, types = "data_extract_spec", null.ok = TRUE)+ |
||
| 222 | +392 | ! |
- if (!all(vapply(fill, function(x) !x$select$multiple, logical(1)))) {
+ teal.widgets::verbatim_popup_srv( |
| 223 | +393 | ! |
- stop("'fill' should not allow multiple selection")
- |
-
| 224 | -- |
- }+ id = "warning", |
|
| 225 | +394 | ! |
- checkmate::assert_list(size, types = "data_extract_spec", null.ok = TRUE)+ verbatim_content = reactive(teal.code::get_warnings(output_q())), |
| 226 | +395 | ! |
- if (!all(vapply(size, function(x) !x$select$multiple, logical(1)))) {
+ title = "Warning", |
| 227 | +396 | ! |
- stop("'size' should not allow multiple selection")
+ disabled = reactive(is.null(teal.code::get_warnings(output_q()))) |
| 228 | +397 |
- }+ ) |
|
| 229 | +398 | ||
| 230 | +399 | ! |
- ggtheme <- match.arg(ggtheme)+ teal.widgets::verbatim_popup_srv( |
| 231 | +400 | ! |
- checkmate::assert_string(label)+ id = "rcode", |
| 232 | +401 | ! |
- checkmate::assert_flag(use_density)+ verbatim_content = reactive(teal.code::get_code(output_q())), |
| 233 | +402 | ! |
- checkmate::assert_flag(color_settings)+ title = "Show R Code for Cross-Table" |
| 234 | -! | +||
| 403 | +
- checkmate::assert_flag(free_x_scales)+ ) |
||
| 235 | -! | +||
| 404 | +
- checkmate::assert_flag(free_y_scales)+ |
||
| 236 | -! | +||
| 405 | +
- checkmate::assert_flag(rotate_xaxis_labels)+ ### REPORTER |
||
| 237 | +406 | ! |
- checkmate::assert_flag(swap_axes)+ if (with_reporter) {
|
| 238 | +407 | ! |
- checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE)+ card_fun <- function(comment, label) {
|
| 239 | +408 | ! |
- checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height")+ card <- teal::report_card_template( |
| 240 | +409 | ! |
- checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE)+ title = "Cross Table", |
| 241 | +410 | ! |
- checkmate::assert_numeric(+ label = label, |
| 242 | +411 | ! |
- plot_width[1],+ with_filter = with_filter, |
| 243 | +412 | ! |
- lower = plot_width[2], upper = plot_width[3], null.ok = TRUE, .var.name = "plot_width"+ filter_panel_api = filter_panel_api |
| 244 | +413 |
- )+ ) |
|
| 245 | +414 | ! |
- checkmate::assert_class(ggplot2_args, "ggplot2_args")- |
-
| 246 | -- |
-
+ card$append_text("Table", "header3")
|
|
| 247 | +415 | ! |
- if (color_settings) {
+ card$append_table(table_r()) |
| 248 | +416 | ! |
- if (is.null(color)) {
+ if (!comment == "") {
|
| 249 | +417 | ! |
- color <- x+ card$append_text("Comment", "header3")
|
| 250 | +418 | ! |
- color[[1]]$select <- teal.transform::select_spec(choices = color[[1]]$select$choices, selected = NULL)+ card$append_text(comment) |
| 251 | +419 |
- }+ } |
|
| 252 | +420 | ! |
- if (is.null(fill)) {
+ card$append_src(teal.code::get_code(output_q())) |
| 253 | +421 | ! |
- fill <- x+ card+ |
+
| 422 | ++ |
+ } |
|
| 254 | +423 | ! |
- fill[[1]]$select <- teal.transform::select_spec(choices = fill[[1]]$select$choices, selected = NULL)+ teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
|
| 255 | +424 |
} |
|
| 256 | -! | +||
| 425 | +
- if (is.null(size)) {
+ ### |
||
| 257 | -! | +||
| 426 | +
- size <- x+ }) |
||
| 258 | -! | +||
| 427 | +
- size[[1]]$select <- teal.transform::select_spec(choices = size[[1]]$select$choices, selected = NULL)+ } |
| 259 | +1 |
- }+ #' Missing data module |
|
| 260 | +2 |
- } else {
+ #' |
|
| 261 | -! | +||
| 3 | +
- if (!is.null(c(color, fill, size))) {
+ #' Present analysis of missing observations and patients. |
||
| 262 | -! | +||
| 4 | +
- stop("'color_settings' argument needs to be set to TRUE if 'color', 'fill', and/or 'size' is/are supplied.")
+ #' specifically designed for use with `data.frames`. |
||
| 263 | +5 |
- }+ #' |
|
| 264 | +6 |
- }+ #' @inheritParams teal::module |
|
| 265 | +7 |
-
+ #' @inheritParams shared_params |
|
| 266 | -! | +||
| 8 | +
- args <- as.list(environment())+ #' @param parent_dataname (`character(1)`) If this `dataname` exists in then "the by subject"graph is displayed. |
||
| 267 | +9 |
-
+ #' For `CDISC` data. In non `CDISC` data this can be ignored. Defaults to `"ADSL"`. |
|
| 268 | -! | +||
| 10 | +
- data_extract_list <- list(+ #' @param ggtheme optional, (`character`) `ggplot2` theme to be used by default. Defaults to `"classic"`. |
||
| 269 | -! | +||
| 11 | +
- x = x,+ #' |
||
| 270 | -! | +||
| 12 | +
- y = y,+ #' @templateVar ggnames "Summary Obs", "Summary Patients", "Combinations Main", "Combinations Hist", "By Subject" |
||
| 271 | -! | +||
| 13 | +
- row_facet = row_facet,+ #' @template ggplot2_args_multi |
||
| 272 | -! | +||
| 14 | +
- col_facet = col_facet,+ #' |
||
| 273 | -! | +||
| 15 | +
- color_settings = color_settings,+ #' @examples |
||
| 274 | -! | +||
| 16 | +
- color = color,+ #' library(teal.widgets) |
||
| 275 | -! | +||
| 17 | +
- fill = fill,+ #' |
||
| 276 | -! | +||
| 18 | +
- size = size+ #' # module specification used in apps below |
||
| 277 | +19 |
- )+ #' tm_missing_data_module <- tm_missing_data( |
|
| 278 | +20 |
-
+ #' ggplot2_args = list( |
|
| 279 | -! | +||
| 21 | +
- module(+ #' "Combinations Hist" = ggplot2_args( |
||
| 280 | -! | +||
| 22 | +
- label = label,+ #' labs = list(subtitle = "Plot produced by Missing Data Module", caption = NULL) |
||
| 281 | -! | +||
| 23 | +
- server = srv_g_bivariate,+ #' ), |
||
| 282 | -! | +||
| 24 | +
- ui = ui_g_bivariate,+ #' "Combinations Main" = ggplot2_args(labs = list(title = NULL)) |
||
| 283 | -! | +||
| 25 | +
- ui_args = args,+ #' ) |
||
| 284 | -! | +||
| 26 | +
- server_args = c(+ #' ) |
||
| 285 | -! | +||
| 27 | +
- data_extract_list,+ #' |
||
| 286 | -! | +||
| 28 | +
- list(plot_height = plot_height, plot_width = plot_width, ggplot2_args = ggplot2_args)+ #' # general example data |
||
| 287 | +29 |
- ),+ #' data <- teal_data() |
|
| 288 | -! | +||
| 30 | +
- datanames = teal.transform::get_extract_datanames(data_extract_list)+ #' data <- within(data, {
|
||
| 289 | +31 |
- )+ #' library(nestcolor) |
|
| 290 | +32 |
- }+ #' |
|
| 291 | +33 |
-
+ #' add_nas <- function(x) {
|
|
| 292 | +34 |
- ui_g_bivariate <- function(id, ...) {
+ #' x[sample(seq_along(x), floor(length(x) * runif(1, .05, .17)))] <- NA |
|
| 293 | -! | +||
| 35 | +
- args <- list(...)+ #' x |
||
| 294 | -! | +||
| 36 | +
- is_single_dataset_value <- teal.transform::is_single_dataset(+ #' } |
||
| 295 | -! | +||
| 37 | +
- args$x, args$y, args$row_facet, args$col_facet, args$color, args$fill, args$size+ #' |
||
| 296 | +38 |
- )+ #' iris <- iris |
|
| 297 | +39 |
-
+ #' mtcars <- mtcars |
|
| 298 | -! | +||
| 40 | +
- ns <- NS(id)+ #' |
||
| 299 | -! | +||
| 41 | +
- teal.widgets::standard_layout(+ #' iris[] <- lapply(iris, add_nas) |
||
| 300 | -! | +||
| 42 | +
- output = teal.widgets::white_small_well(+ #' mtcars[] <- lapply(mtcars, add_nas) |
||
| 301 | -! | +||
| 43 | +
- tags$div(teal.widgets::plot_with_settings_ui(id = ns("myplot")))
+ #' mtcars[["cyl"]] <- as.factor(mtcars[["cyl"]]) |
||
| 302 | +44 |
- ),+ #' mtcars[["gear"]] <- as.factor(mtcars[["gear"]]) |
|
| 303 | -! | +||
| 45 | +
- encoding = div(+ #' }) |
||
| 304 | +46 |
- ### Reporter+ #' datanames(data) <- c("iris", "mtcars")
|
|
| 305 | -! | +||
| 47 | +
- teal.reporter::simple_reporter_ui(ns("simple_reporter")),
+ #' |
||
| 306 | +48 |
- ###+ #' app <- init( |
|
| 307 | -! | +||
| 49 | +
- tags$label("Encodings", class = "text-primary"),
+ #' data = data, |
||
| 308 | -! | +||
| 50 | +
- teal.transform::datanames_input(args[c("x", "y", "row_facet", "col_facet", "color", "fill", "size")]),
+ #' modules = modules(tm_missing_data_module) |
||
| 309 | -! | +||
| 51 | +
- teal.transform::data_extract_ui(+ #' ) |
||
| 310 | -! | +||
| 52 | +
- id = ns("x"),
+ #' if (interactive()) {
|
||
| 311 | -! | +||
| 53 | +
- label = "X variable",+ #' shinyApp(app$ui, app$server) |
||
| 312 | -! | +||
| 54 | +
- data_extract_spec = args$x,+ #' } |
||
| 313 | -! | +||
| 55 | +
- is_single_dataset = is_single_dataset_value+ #' |
||
| 314 | +56 |
- ),+ #' # CDISC example data |
|
| 315 | -! | +||
| 57 | +
- teal.transform::data_extract_ui(+ #' data <- teal_data() |
||
| 316 | -! | +||
| 58 | +
- id = ns("y"),
+ #' data <- within(data, {
|
||
| 317 | -! | +||
| 59 | +
- label = "Y variable",+ #' library(nestcolor) |
||
| 318 | -! | +||
| 60 | +
- data_extract_spec = args$y,+ #' ADSL <- rADSL |
||
| 319 | -! | +||
| 61 | +
- is_single_dataset = is_single_dataset_value+ #' ADRS <- rADRS |
||
| 320 | +62 |
- ),+ #' }) |
|
| 321 | -! | +||
| 63 | +
- conditionalPanel(+ #' datanames(data) <- c("ADSL", "ADRS")
|
||
| 322 | -! | +||
| 64 | +
- condition =+ #' join_keys(data) <- default_cdisc_join_keys[datanames(data)] |
||
| 323 | -! | +||
| 65 | +
- "$(\"button[data-id*='-x-dataset'][data-id$='-select']\").text() == '- Nothing selected - ' ||+ #' |
||
| 324 | -! | +||
| 66 | +
- $(\"button[data-id*='-y-dataset'][data-id$='-select']\").text() == '- Nothing selected - ' ",+ #' app <- init( |
||
| 325 | -! | +||
| 67 | +
- shinyWidgets::radioGroupButtons(+ #' data = data, |
||
| 326 | -! | +||
| 68 | +
- inputId = ns("use_density"),
+ #' modules = modules(tm_missing_data_module) |
||
| 327 | -! | +||
| 69 | +
- label = NULL,+ #' ) |
||
| 328 | -! | +||
| 70 | +
- choices = c("frequency", "density"),
+ #' if (interactive()) {
|
||
| 329 | -! | +||
| 71 | +
- selected = ifelse(args$use_density, "density", "frequency"),+ #' shinyApp(app$ui, app$server) |
||
| 330 | -! | +||
| 72 | +
- justified = TRUE+ #' } |
||
| 331 | +73 |
- )+ #' |
|
| 332 | +74 |
- ),+ #' @export |
|
| 333 | -! | +||
| 75 | +
- if (!is.null(args$row_facet) || !is.null(args$col_facet)) {
+ #' |
||
| 334 | -! | +||
| 76 | +
- div(+ tm_missing_data <- function(label = "Missing data", |
||
| 335 | -! | +||
| 77 | +
- class = "data-extract-box",+ plot_height = c(600, 400, 5000), |
||
| 336 | -! | +||
| 78 | +
- tags$label("Facetting"),
+ plot_width = NULL, |
||
| 337 | -! | +||
| 79 | +
- shinyWidgets::switchInput(inputId = ns("facetting"), value = args$facet, size = "mini"),
+ parent_dataname = "ADSL", |
||
| 338 | -! | +||
| 80 | +
- conditionalPanel(+ ggtheme = c("classic", "gray", "bw", "linedraw", "light", "dark", "minimal", "void"),
|
||
| 339 | -! | +||
| 81 | +
- condition = paste0("input['", ns("facetting"), "']"),
+ ggplot2_args = list( |
||
| 340 | -! | +||
| 82 | +
- div(+ "Combinations Hist" = teal.widgets::ggplot2_args(labs = list(caption = NULL)), |
||
| 341 | -! | +||
| 83 | +
- if (!is.null(args$row_facet)) {
+ "Combinations Main" = teal.widgets::ggplot2_args(labs = list(title = NULL)) |
||
| 342 | -! | +||
| 84 | +
- teal.transform::data_extract_ui(+ ), |
||
| 343 | -! | +||
| 85 | +
- id = ns("row_facet"),
+ pre_output = NULL, |
||
| 344 | -! | +||
| 86 | +
- label = "Row facetting variable",+ post_output = NULL) {
|
||
| 345 | +87 | ! |
- data_extract_spec = args$row_facet,+ if (!requireNamespace("gridExtra", quietly = TRUE)) {
|
| 346 | +88 | ! |
- is_single_dataset = is_single_dataset_value- |
-
| 347 | -- |
- )+ stop("Cannot load gridExtra - please install the package or restart your session.")
|
|
| 348 | +89 |
- },- |
- |
| 349 | -! | -
- if (!is.null(args$col_facet)) {
+ } |
|
| 350 | +90 | ! |
- teal.transform::data_extract_ui(+ if (!requireNamespace("rlang", quietly = TRUE)) {
|
| 351 | +91 | ! |
- id = ns("col_facet"),
+ stop("Cannot load rlang - please install the package or restart your session.")
|
| 352 | -! | +||
| 92 | +
- label = "Column facetting variable",+ } |
||
| 353 | +93 | ! |
- data_extract_spec = args$col_facet,+ logger::log_info("Initializing tm_missing_data")
|
| 354 | +94 | ! |
- is_single_dataset = is_single_dataset_value+ if (inherits(ggplot2_args, "ggplot2_args")) ggplot2_args <- list(default = ggplot2_args) |
| 355 | +95 |
- )+ |
|
| 356 | -+ | ||
| 96 | +! |
- },+ checkmate::assert_string(label) |
|
| 357 | +97 | ! |
- checkboxInput(ns("free_x_scales"), "free x scales", value = args$free_x_scales),
+ checkmate::assert_character(parent_dataname, min.len = 0, max.len = 1) |
| 358 | +98 | ! |
- checkboxInput(ns("free_y_scales"), "free y scales", value = args$free_y_scales)
+ checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE) |
| 359 | -+ | ||
| 99 | +! |
- )+ checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height") |
|
| 360 | -+ | ||
| 100 | +! |
- )+ checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE) |
|
| 361 | -+ | ||
| 101 | +! |
- )+ checkmate::assert_numeric( |
|
| 362 | -+ | ||
| 102 | +! |
- },+ plot_width[1], |
|
| 363 | +103 | ! |
- if (args$color_settings) {
+ lower = plot_width[2], upper = plot_width[3], null.ok = TRUE, .var.name = "plot_width" |
| 364 | +104 |
- # Put a grey border around the coloring settings- |
- |
| 365 | -! | -
- div(+ ) |
|
| 366 | +105 | ! |
- class = "data-extract-box",+ ggtheme <- match.arg(ggtheme) |
| 367 | +106 | ! |
- tags$label("Color settings"),
+ plot_choices <- c("Summary Obs", "Summary Patients", "Combinations Main", "Combinations Hist", "By Subject")
|
| 368 | +107 | ! |
- shinyWidgets::switchInput(inputId = ns("coloring"), value = TRUE, size = "mini"),
+ checkmate::assert_list(ggplot2_args, types = "ggplot2_args") |
| 369 | +108 | ! |
- conditionalPanel(+ checkmate::assert_subset(names(ggplot2_args), c("default", plot_choices))
|
| 370 | -! | +||
| 109 | +
- condition = paste0("input['", ns("coloring"), "']"),
+
|
||
| 371 | +110 | ! |
- div(+ module( |
| 372 | +111 | ! |
- teal.transform::data_extract_ui(+ label, |
| 373 | +112 | ! |
- id = ns("color"),
+ server = srv_page_missing_data, |
| 374 | +113 | ! |
- label = "Outline color by variable",+ server_args = list( |
| 375 | +114 | ! |
- data_extract_spec = args$color,+ parent_dataname = parent_dataname, plot_height = plot_height, |
| 376 | +115 | ! |
- is_single_dataset = is_single_dataset_value+ plot_width = plot_width, ggplot2_args = ggplot2_args, ggtheme = ggtheme |
| 377 | +116 |
- ),+ ), |
|
| 378 | +117 | ! |
- teal.transform::data_extract_ui(+ ui = ui_page_missing_data, |
| 379 | +118 | ! |
- id = ns("fill"),
+ datanames = "all", |
| 380 | +119 | ! |
- label = "Fill color by variable",+ ui_args = list(pre_output = pre_output, post_output = post_output) |
| 381 | -! | +||
| 120 | +
- data_extract_spec = args$fill,+ ) |
||
| 382 | -! | +||
| 121 | +
- is_single_dataset = is_single_dataset_value+ } |
||
| 383 | +122 |
- ),+ + |
+ |
| 123 | ++ |
+ ui_page_missing_data <- function(id, pre_output = NULL, post_output = NULL) {
|
|
| 384 | +124 | ! |
- div(+ ns <- NS(id) |
| 385 | +125 | ! |
- id = ns("size_settings"),
+ shiny::tagList( |
| 386 | +126 | ! |
- teal.transform::data_extract_ui(+ include_css_files("custom"),
|
| 387 | +127 | ! |
- id = ns("size"),
+ teal.widgets::standard_layout( |
| 388 | +128 | ! |
- label = "Size of points by variable (only if x and y are numeric)",+ output = teal.widgets::white_small_well( |
| 389 | +129 | ! |
- data_extract_spec = args$size,+ div( |
| 390 | +130 | ! |
- is_single_dataset = is_single_dataset_value+ class = "flex", |
| 391 | -+ | ||
| 131 | +! |
- )+ column( |
|
| 392 | -+ | ||
| 132 | +! |
- )+ width = 12, |
|
| 393 | -+ | ||
| 133 | +! |
- )+ uiOutput(ns("dataset_tabs"))
|
|
| 394 | +134 |
) |
|
| 395 | +135 |
) |
|
| 396 | +136 |
- },- |
- |
| 397 | -! | -
- teal.widgets::panel_group(+ ), |
|
| 398 | +137 | ! |
- teal.widgets::panel_item(+ encoding = div( |
| 399 | +138 | ! |
- title = "Plot settings",+ uiOutput(ns("dataset_encodings"))
|
| 400 | -! | +||
| 139 | +
- checkboxInput(ns("rotate_xaxis_labels"), "Rotate X axis labels", value = args$rotate_xaxis_labels),
+ ), |
||
| 401 | +140 | ! |
- checkboxInput(ns("swap_axes"), "Swap axes", value = args$swap_axes),
+ uiOutput(ns("dataset_reporter")),
|
| 402 | +141 | ! |
- selectInput(+ pre_output = pre_output, |
| 403 | +142 | ! |
- inputId = ns("ggtheme"),
+ post_output = post_output |
| 404 | -! | +||
| 143 | +
- label = "Theme (by ggplot):",+ ) |
||
| 405 | -! | +||
| 144 | +
- choices = ggplot_themes,+ ) |
||
| 406 | -! | +||
| 145 | +
- selected = args$ggtheme,+ } |
||
| 407 | -! | +||
| 146 | +
- multiple = FALSE+ |
||
| 408 | +147 |
- ),+ srv_page_missing_data <- function(id, data, reporter, filter_panel_api, parent_dataname, |
|
| 409 | -! | +||
| 148 | +
- sliderInput(+ plot_height, plot_width, ggplot2_args, ggtheme) {
|
||
| 410 | +149 | ! |
- ns("alpha"), "Opacity Scatterplot:",
+ moduleServer(id, function(input, output, session) {
|
| 411 | +150 | ! |
- min = 0, max = 1,+ datanames <- isolate(teal.data::datanames(data())) |
| 412 | +151 | ! |
- step = .05, value = .5, ticks = FALSE- |
-
| 413 | -- |
- ),+ datanames <- Filter(function(name) {
|
|
| 414 | +152 | ! |
- sliderInput(+ is.data.frame(isolate(data())[[name]]) |
| 415 | +153 | ! |
- ns("fixed_size"), "Scatterplot point size:",
+ }, datanames) |
| 416 | +154 | ! |
- min = 1, max = 8,+ if_subject_plot <- length(parent_dataname) > 0 && parent_dataname %in% datanames |
| 417 | +155 | ! |
- step = 1, value = 2, ticks = FALSE+ ns <- session$ns |
| 418 | +156 |
- ),+ |
|
| 419 | +157 | ! |
- checkboxInput(ns("add_lines"), "Add lines"),
- |
-
| 420 | -- |
- )+ output$dataset_tabs <- renderUI({
|
|
| 421 | -+ | ||
| 158 | +! |
- )+ do.call( |
|
| 422 | -+ | ||
| 159 | +! |
- ),+ tabsetPanel, |
|
| 423 | +160 | ! |
- forms = tagList(+ c( |
| 424 | +161 | ! |
- teal.widgets::verbatim_popup_ui(ns("warning"), button_label = "Show Warnings"),
+ id = ns("dataname_tab"),
|
| 425 | +162 | ! |
- teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code")
+ lapply( |
| 426 | -+ | ||
| 163 | +! |
- ),+ datanames, |
|
| 427 | +164 | ! |
- pre_output = args$pre_output,+ function(x) {
|
| 428 | +165 | ! |
- post_output = args$post_output+ tabPanel( |
| 429 | -+ | ||
| 166 | +! |
- )+ title = x, |
|
| 430 | -+ | ||
| 167 | +! |
- }+ column( |
|
| 431 | -+ | ||
| 168 | +! |
-
+ width = 12, |
|
| 432 | -+ | ||
| 169 | +! |
-
+ div( |
|
| 433 | -+ | ||
| 170 | +! |
- srv_g_bivariate <- function(id,+ class = "mt-4", |
|
| 434 | -+ | ||
| 171 | +! |
- data,+ ui_missing_data(id = ns(x), by_subject_plot = if_subject_plot) |
|
| 435 | +172 |
- reporter,+ ) |
|
| 436 | +173 |
- filter_panel_api,+ ) |
|
| 437 | +174 |
- x,+ ) |
|
| 438 | +175 |
- y,+ } |
|
| 439 | +176 |
- row_facet,+ ) |
|
| 440 | +177 |
- col_facet,+ ) |
|
| 441 | +178 |
- color_settings = FALSE,+ ) |
|
| 442 | +179 |
- color,+ }) |
|
| 443 | +180 |
- fill,+ |
|
| 444 | -+ | ||
| 181 | +! |
- size,+ output$dataset_encodings <- renderUI({
|
|
| 445 | -+ | ||
| 182 | +! |
- plot_height,+ tagList( |
|
| 446 | -+ | ||
| 183 | +! |
- plot_width,+ lapply( |
|
| 447 | -+ | ||
| 184 | +! |
- ggplot2_args) {
+ datanames, |
|
| 448 | +185 | ! |
- with_reporter <- !missing(reporter) && inherits(reporter, "Reporter")+ function(x) {
|
| 449 | +186 | ! |
- with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI")+ conditionalPanel( |
| 450 | +187 | ! |
- checkmate::assert_class(data, "reactive")+ is_tab_active_js(ns("dataname_tab"), x),
|
| 451 | +188 | ! |
- checkmate::assert_class(isolate(data()), "teal_data")+ encoding_missing_data( |
| 452 | +189 | ! |
- moduleServer(id, function(input, output, session) {
+ id = ns(x), |
| 453 | +190 | ! |
- data_extract <- list(+ summary_per_patient = if_subject_plot, |
| 454 | +191 | ! |
- x = x, y = y, row_facet = row_facet, col_facet = col_facet,+ ggtheme = ggtheme, |
| 455 | +192 | ! |
- color = color, fill = fill, size = size+ datanames = datanames |
| 456 | +193 |
- )+ ) |
|
| 457 | +194 | - - | -|
| 458 | -! | -
- rule_var <- function(other) {
+ ) |
|
| 459 | -! | +||
| 195 | +
- function(value) {
+ } |
||
| 460 | -! | +||
| 196 | +
- othervalue <- selector_list()[[other]]()$select+ ) |
||
| 461 | -! | +||
| 197 | +
- if (length(value) == 0L && length(othervalue) == 0L) {
+ ) |
||
| 462 | -! | +||
| 198 | +
- "Please select at least one of x-variable or y-variable"+ }) |
||
| 463 | +199 |
- }+ |
|
| 464 | -+ | ||
| 200 | +! |
- }+ output$dataset_reporter <- renderUI({
|
|
| 465 | -+ | ||
| 201 | +! |
- }+ lapply(datanames, function(x) {
|
|
| 466 | +202 | ! |
- rule_diff <- function(other) {
+ dataname_ns <- NS(ns(x))+ |
+
| 203 | ++ | + | |
| 467 | +204 | ! |
- function(value) {
+ conditionalPanel( |
| 468 | +205 | ! |
- othervalue <- selector_list()[[other]]()[["select"]]+ is_tab_active_js(ns("dataname_tab"), x),
|
| 469 | +206 | ! |
- if (!is.null(othervalue)) {
+ tagList( |
| 470 | +207 | ! |
- if (identical(value, othervalue)) {
+ teal.widgets::verbatim_popup_ui(dataname_ns("warning"), "Show Warnings"),
|
| 471 | +208 | ! |
- "Row and column facetting variables must be different."+ teal.widgets::verbatim_popup_ui(dataname_ns("rcode"), "Show R code")
|
| 472 | +209 |
- }+ ) |
|
| 473 | +210 |
- }+ ) |
|
| 474 | +211 |
- }+ }) |
|
| 475 | +212 |
- }+ }) |
|
| 476 | +213 | ||
| 477 | +214 | ! |
- selector_list <- teal.transform::data_extract_multiple_srv(+ lapply( |
| 478 | +215 | ! |
- data_extract = data_extract,+ datanames, |
| 479 | +216 | ! |
- datasets = data,+ function(x) {
|
| 480 | +217 | ! |
- select_validation_rule = list(+ srv_missing_data( |
| 481 | +218 | ! |
- x = rule_var("y"),
+ id = x, |
| 482 | +219 | ! |
- y = rule_var("x"),
+ data = data, |
| 483 | +220 | ! |
- row_facet = shinyvalidate::compose_rules(+ reporter = reporter, |
| 484 | +221 | ! |
- shinyvalidate::sv_optional(),+ filter_panel_api = filter_panel_api, |
| 485 | +222 | ! |
- rule_diff("col_facet")
+ dataname = x, |
| 486 | -+ | ||
| 223 | +! |
- ),+ parent_dataname = parent_dataname, |
|
| 487 | +224 | ! |
- col_facet = shinyvalidate::compose_rules(+ plot_height = plot_height, |
| 488 | +225 | ! |
- shinyvalidate::sv_optional(),+ plot_width = plot_width, |
| 489 | +226 | ! |
- rule_diff("row_facet")
+ ggplot2_args = ggplot2_args |
| 490 | +227 |
) |
|
| 491 | +228 |
- )+ } |
|
| 492 | +229 |
) |
|
| 493 | +230 | - - | -|
| 494 | -! | -
- iv_r <- reactive({
- |
- |
| 495 | -! | -
- iv_facet <- shinyvalidate::InputValidator$new()+ }) |
|
| 496 | -! | +||
| 231 | +
- iv_child <- teal.transform::compose_and_enable_validators(iv_facet, selector_list,+ } |
||
| 497 | -! | +||
| 232 | +
- validator_names = c("row_facet", "col_facet")
+
|
||
| 498 | +233 |
- )+ ui_missing_data <- function(id, by_subject_plot = FALSE) {
|
|
| 499 | +234 | ! |
- iv_child$condition(~ isTRUE(input$facetting))+ ns <- NS(id) |
| 500 | +235 | ||
| 501 | +236 | ! |
- iv <- shinyvalidate::InputValidator$new()+ tab_list <- list( |
| 502 | +237 | ! |
- iv$add_validator(iv_child)+ tabPanel( |
| 503 | +238 | ! |
- teal.transform::compose_and_enable_validators(iv, selector_list, validator_names = c("x", "y"))
- |
-
| 504 | -- |
- })+ "Summary", |
|
| 505 | -+ | ||
| 239 | +! |
-
+ teal.widgets::plot_with_settings_ui(id = ns("summary_plot")),
|
|
| 506 | +240 | ! |
- anl_merged_input <- teal.transform::merge_expression_srv(+ helpText( |
| 507 | +241 | ! |
- selector_list = selector_list,+ p(paste( |
| 508 | +242 | ! |
- datasets = data+ 'The "Summary" graph shows the number of missing values per variable (both absolute and percentage),', |
| 509 | -+ | ||
| 243 | +! |
- )+ "sorted by magnitude." |
|
| 510 | +244 |
-
+ )), |
|
| 511 | +245 | ! |
- anl_merged_q <- reactive({
+ p( |
| 512 | +246 | ! |
- req(anl_merged_input())+ 'The "summary per patients" graph is showing how many subjects have at least one missing observation', |
| 513 | +247 | ! |
- data() %>%+ "for each variable. It will be most useful for panel datasets." |
| 514 | -! | +||
| 248 | +
- teal.code::eval_code(as.expression(anl_merged_input()$expr))+ ) |
||
| 515 | +249 |
- })+ ) |
|
| 516 | +250 |
-
+ ), |
|
| 517 | +251 | ! |
- merged <- list(+ tabPanel( |
| 518 | +252 | ! |
- anl_input_r = anl_merged_input,+ "Combinations", |
| 519 | +253 | ! |
- anl_q_r = anl_merged_q- |
-
| 520 | -- |
- )- |
- |
| 521 | -- |
-
+ teal.widgets::plot_with_settings_ui(id = ns("combination_plot")),
|
|
| 522 | +254 | ! |
- output_q <- reactive({
+ helpText( |
| 523 | +255 | ! |
- teal::validate_inputs(iv_r())- |
-
| 524 | -- |
-
+ p(paste( |
|
| 525 | +256 | ! |
- ANL <- merged$anl_q_r()[["ANL"]] # nolint: object_name.+ 'The "Combinations" graph is used to explore the relationship between the missing data within', |
| 526 | +257 | ! |
- teal::validate_has_data(ANL, 3)- |
-
| 527 | -- |
-
+ "different columns of the dataset.", |
|
| 528 | +258 | ! |
- x_col_vec <- as.vector(merged$anl_input_r()$columns_source$x)+ "It shows the different patterns of missingness in the rows of the data.", |
| 529 | +259 | ! |
- x_name <- `if`(is.null(x_col_vec), character(0), x_col_vec)+ 'For example, suppose that 70 rows of the data have exactly columns "A" and "B" missing.', |
| 530 | +260 | ! |
- y_col_vec <- as.vector(merged$anl_input_r()$columns_source$y)+ "In this case there would be a bar of height 70 in the top graph and", |
| 531 | +261 | ! |
- y_name <- `if`(is.null(y_col_vec), character(0), y_col_vec)+ 'the column below this in the second graph would have rows "A" and "B" cells shaded red.' |
| 532 | +262 | - - | -|
| 533 | -! | -
- row_facet_name <- as.vector(merged$anl_input_r()$columns_source$row_facet)+ )), |
|
| 534 | +263 | ! |
- col_facet_name <- as.vector(merged$anl_input_r()$columns_source$col_facet)+ p(paste( |
| 535 | +264 | ! |
- color_name <- if ("color" %in% names(merged$anl_input_r()$columns_source)) {
+ "Due to the large number of missing data patterns possible, only those with a large set of observations", |
| 536 | +265 | ! |
- as.vector(merged$anl_input_r()$columns_source$color)+ 'are shown in the graph and the "Combination cut-off" slider can be used to adjust the number shown.' |
| 537 | +266 |
- } else {
+ )) |
|
| 538 | -! | +||
| 267 | +
- character(0)+ ) |
||
| 539 | +268 |
- }+ ), |
|
| 540 | +269 | ! |
- fill_name <- if ("fill" %in% names(merged$anl_input_r()$columns_source)) {
+ tabPanel( |
| 541 | +270 | ! |
- as.vector(merged$anl_input_r()$columns_source$fill)+ "By Variable Levels", |
| 542 | -+ | ||
| 271 | +! |
- } else {
+ teal.widgets::get_dt_rows(ns("levels_table"), ns("levels_table_rows")),
|
|
| 543 | +272 | ! |
- character(0)+ DT::dataTableOutput(ns("levels_table"))
|
| 544 | +273 |
- }+ )+ |
+ |
| 274 | ++ |
+ ) |
|
| 545 | +275 | ! |
- size_name <- if ("size" %in% names(merged$anl_input_r()$columns_source)) {
+ if (isTRUE(by_subject_plot)) {
|
| 546 | +276 | ! |
- as.vector(merged$anl_input_r()$columns_source$size)+ tab_list <- append( |
| 547 | -+ | ||
| 277 | +! |
- } else {
+ tab_list, |
|
| 548 | +278 | ! |
- character(0)+ list(tabPanel( |
| 549 | -+ | ||
| 279 | +! |
- }+ "Grouped by Subject", |
|
| 550 | -+ | ||
| 280 | +! |
-
+ teal.widgets::plot_with_settings_ui(id = ns("by_subject_plot")),
|
|
| 551 | +281 | ! |
- use_density <- input$use_density == "density"+ helpText( |
| 552 | +282 | ! |
- free_x_scales <- input$free_x_scales+ p(paste( |
| 553 | +283 | ! |
- free_y_scales <- input$free_y_scales+ "This graph shows the missingness with respect to subjects rather than individual rows of the", |
| 554 | +284 | ! |
- ggtheme <- input$ggtheme+ "dataset. Each row represents one dataset variable and each column a single subject. Only subjects", |
| 555 | +285 | ! |
- rotate_xaxis_labels <- input$rotate_xaxis_labels+ "with at least one record in this dataset are shown. For a given subject, if they have any missing", |
| 556 | +286 | ! |
- swap_axes <- input$swap_axes+ "values of a specific variable then the appropriate cell in the graph is marked as missing." |
| 557 | +287 | - - | -|
| 558 | -! | -
- is_scatterplot <- all(vapply(ANL[c(x_name, y_name)], is.numeric, logical(1))) &&+ )) |
|
| 559 | -! | +||
| 288 | +
- length(x_name) > 0 && length(y_name) > 0+ ) |
||
| 560 | +289 |
-
+ )) |
|
| 561 | -! | +||
| 290 | +
- if (is_scatterplot) {
+ ) |
||
| 562 | -! | +||
| 291 | +
- shinyjs::show("alpha")
+ } |
||
| 563 | -! | +||
| 292 | +
- alpha <- input$alpha+ |
||
| 564 | +293 | ! |
- shinyjs::show("add_lines")
- |
-
| 565 | -- |
-
+ do.call( |
|
| 566 | +294 | ! |
- if (color_settings && input$coloring) {
+ tabsetPanel, |
| 567 | +295 | ! |
- shinyjs::hide("fixed_size")
+ c( |
| 568 | +296 | ! |
- shinyjs::show("size_settings")
+ id = ns("summary_type"),
|
| 569 | +297 | ! |
- size <- NULL+ tab_list |
| 570 | +298 |
- } else {
+ ) |
|
| 571 | -! | +||
| 299 | +
- shinyjs::show("fixed_size")
+ ) |
||
| 572 | -! | +||
| 300 | +
- size <- input$fixed_size+ } |
||
| 573 | +301 |
- }+ |
|
| 574 | +302 |
- } else {
+ encoding_missing_data <- function(id, summary_per_patient = FALSE, ggtheme, datanames) {
|
|
| 575 | +303 | ! |
- shinyjs::hide("add_lines")
+ ns <- NS(id) |
| 576 | -! | +||
| 304 | +
- updateCheckboxInput(session, "add_lines", value = FALSE)+ |
||
| 577 | +305 | ! |
- shinyjs::hide("alpha")
+ tagList( |
| 578 | -! | +||
| 306 | +
- shinyjs::hide("fixed_size")
+ ### Reporter |
||
| 579 | +307 | ! |
- shinyjs::hide("size_settings")
+ teal.reporter::simple_reporter_ui(ns("simple_reporter")),
|
| 580 | -! | +||
| 308 | +
- alpha <- 1+ ### |
||
| 581 | +309 | ! |
- size <- NULL- |
-
| 582 | -- |
- }+ tags$label("Encodings", class = "text-primary"),
|
|
| 583 | -+ | ||
| 310 | +! |
-
+ helpText( |
|
| 584 | -+ | ||
| 311 | +! |
-
+ paste0("Dataset", `if`(length(datanames) > 1, "s", ""), ":"),
|
|
| 585 | +312 | ! |
- teal::validate_has_data(ANL[, c(x_name, y_name)], 3, complete = TRUE, allow_inf = FALSE)+ tags$code(paste(datanames, collapse = ", ")) |
| 586 | +313 | - - | -|
| 587 | -! | -
- cl <- bivariate_plot_call(+ ), |
|
| 588 | +314 | ! |
- data_name = "ANL",+ uiOutput(ns("variables")),
|
| 589 | +315 | ! |
- x = x_name,+ actionButton( |
| 590 | +316 | ! |
- y = y_name,+ ns("filter_na"),
|
| 591 | +317 | ! |
- x_class = ifelse(!identical(x_name, character(0)), class(ANL[[x_name]]), "NULL"),+ span("Select only vars with missings", class = "whitespace-normal"),
|
| 592 | +318 | ! |
- y_class = ifelse(!identical(y_name, character(0)), class(ANL[[y_name]]), "NULL"),+ width = "100%", |
| 593 | +319 | ! |
- x_label = varname_w_label(x_name, ANL),+ class = "mb-4" |
| 594 | -! | +||
| 320 | +
- y_label = varname_w_label(y_name, ANL),+ ), |
||
| 595 | +321 | ! |
- freq = !use_density,+ conditionalPanel( |
| 596 | +322 | ! |
- theme = ggtheme,+ is_tab_active_js(ns("summary_type"), "Summary"),
|
| 597 | +323 | ! |
- rotate_xaxis_labels = rotate_xaxis_labels,+ checkboxInput( |
| 598 | +324 | ! |
- swap_axes = swap_axes,+ ns("any_na"),
|
| 599 | +325 | ! |
- alpha = alpha,+ div( |
| 600 | +326 | ! |
- size = size,+ class = "teal-tooltip", |
| 601 | +327 | ! |
- ggplot2_args = ggplot2_args- |
-
| 602 | -- |
- )- |
- |
| 603 | -- |
-
+ tagList( |
|
| 604 | +328 | ! |
- facetting <- (isTRUE(input$facetting) && (!is.null(row_facet_name) || !is.null(col_facet_name)))- |
-
| 605 | -- |
-
+ "Add **anyna** variable", |
|
| 606 | +329 | ! |
- if (facetting) {
+ icon("circle-info"),
|
| 607 | +330 | ! |
- facet_cl <- facet_ggplot_call(row_facet_name, col_facet_name, free_x_scales, free_y_scales)- |
-
| 608 | -- |
-
+ span( |
|
| 609 | +331 | ! |
- if (!is.null(facet_cl)) {
+ class = "tooltiptext", |
| 610 | +332 | ! |
- cl <- call("+", cl, facet_cl)
+ "Describes the number of observations with at least one missing value in any variable." |
| 611 | +333 |
- }+ ) |
|
| 612 | +334 |
- }+ ) |
|
| 613 | +335 | - - | -|
| 614 | -! | -
- if (input$add_lines) {
+ ), |
|
| 615 | +336 | ! |
- cl <- call("+", cl, quote(geom_line(size = 1)))
- |
-
| 616 | -- |
- }+ value = FALSE |
|
| 617 | +337 | - - | -|
| 618 | -! | -
- coloring_cl <- NULL+ ), |
|
| 619 | +338 | ! |
- if (color_settings) {
+ if (summary_per_patient) {
|
| 620 | +339 | ! |
- if (input$coloring) {
+ checkboxInput( |
| 621 | +340 | ! |
- coloring_cl <- coloring_ggplot_call(+ ns("if_patients_plot"),
|
| 622 | +341 | ! |
- colour = color_name,+ div( |
| 623 | +342 | ! |
- fill = fill_name,+ class = "teal-tooltip", |
| 624 | +343 | ! |
- size = size_name,+ tagList( |
| 625 | +344 | ! |
- is_point = any(grepl("geom_point", cl %>% deparse()))
- |
-
| 626 | -- |
- )+ "Add summary per patients", |
|
| 627 | +345 | ! |
- legend_lbls <- substitute(+ icon("circle-info"),
|
| 628 | +346 | ! |
- expr = labs(color = color_name, fill = fill_name, size = size_name),+ span( |
| 629 | +347 | ! |
- env = list(+ class = "tooltiptext", |
| 630 | +348 | ! |
- color_name = varname_w_label(color_name, ANL),+ paste( |
| 631 | +349 | ! |
- fill_name = varname_w_label(fill_name, ANL),+ "Displays the number of missing values per observation,", |
| 632 | +350 | ! |
- size_name = varname_w_label(size_name, ANL)+ "where the x-axis is sorted by observation appearance in the table." |
| 633 | +351 |
- )+ ) |
|
| 634 | +352 |
- )+ ) |
|
| 635 | +353 |
- }+ ) |
|
| 636 | -! | +||
| 354 | +
- if (!is.null(coloring_cl)) {
+ ), |
||
| 637 | +355 | ! |
- cl <- call("+", call("+", cl, coloring_cl), legend_lbls)
+ value = FALSE |
| 638 | +356 |
- }+ ) |
|
| 639 | +357 |
} |
|
| 640 | -- | - - | -|
| 641 | +358 |
- # Add labels to facets+ ), |
|
| 642 | +359 | ! |
- nulled_row_facet_name <- varname_w_label(row_facet_name, ANL)+ conditionalPanel( |
| 643 | +360 | ! |
- nulled_col_facet_name <- varname_w_label(col_facet_name, ANL)+ is_tab_active_js(ns("summary_type"), "Combinations"),
|
| 644 | +361 | ! |
- without_facet <- (is.null(nulled_row_facet_name) && is.null(nulled_col_facet_name)) || !facetting+ uiOutput(ns("cutoff"))
|
| 645 | +362 |
-
+ ), |
|
| 646 | +363 | ! |
- print_call <- if (without_facet) {
+ conditionalPanel( |
| 647 | +364 | ! |
- quote(print(p))- |
-
| 648 | -- |
- } else {
+ is_tab_active_js(ns("summary_type"), "By Variable Levels"),
|
|
| 649 | +365 | ! |
- substitute(+ tagList( |
| 650 | +366 | ! |
- expr = {
+ uiOutput(ns("group_by_var_ui")),
|
| 651 | -+ | ||
| 367 | +! |
- # Add facetting labels+ uiOutput(ns("group_by_vals_ui")),
|
|
| 652 | -+ | ||
| 368 | +! |
- # optional: grid.newpage() # nolint: commented_code.+ radioButtons( |
|
| 653 | +369 | ! |
- p <- add_facet_labels(p, xfacet_label = nulled_col_facet_name, yfacet_label = nulled_row_facet_name)+ ns("count_type"),
|
| 654 | +370 | ! |
- grid::grid.newpage()+ label = "Display missing as", |
| 655 | +371 | ! |
- grid::grid.draw(p)+ choices = c("counts", "proportions"),
|
| 656 | -+ | ||
| 372 | +! |
- },+ selected = "counts", |
|
| 657 | +373 | ! |
- env = list(nulled_col_facet_name = nulled_col_facet_name, nulled_row_facet_name = nulled_row_facet_name)+ inline = TRUE |
| 658 | +374 |
) |
|
| 659 | +375 |
- }+ ) |
|
| 660 | +376 |
-
+ ), |
|
| 661 | +377 | ! |
- teal.code::eval_code(merged$anl_q_r(), substitute(expr = p <- cl, env = list(cl = cl))) %>%+ teal.widgets::panel_item( |
| 662 | +378 | ! |
- teal.code::eval_code(print_call)- |
-
| 663 | -- |
- })- |
- |
| 664 | -- |
-
+ title = "Plot settings", |
|
| 665 | +379 | ! |
- plot_r <- shiny::reactive({
+ selectInput( |
| 666 | +380 | ! |
- output_q()[["p"]]- |
-
| 667 | -- |
- })- |
- |
| 668 | -- |
-
+ inputId = ns("ggtheme"),
|
|
| 669 | +381 | ! |
- pws <- teal.widgets::plot_with_settings_srv(+ label = "Theme (by ggplot):", |
| 670 | +382 | ! |
- id = "myplot",+ choices = ggplot_themes, |
| 671 | +383 | ! |
- plot_r = plot_r,+ selected = ggtheme, |
| 672 | +384 | ! |
- height = plot_height,+ multiple = FALSE |
| 673 | -! | +||
| 385 | +
- width = plot_width+ ) |
||
| 674 | +386 |
) |
|
| 675 | +387 |
-
+ ) |
|
| 676 | -! | +||
| 388 | +
- teal.widgets::verbatim_popup_srv(+ } |
||
| 677 | -! | +||
| 389 | +
- id = "warning",+ |
||
| 678 | -! | +||
| 390 | +
- verbatim_content = reactive(teal.code::get_warnings(output_q())),+ srv_missing_data <- function(id, data, reporter, filter_panel_api, dataname, parent_dataname, |
||
| 679 | -! | +||
| 391 | +
- title = "Warning",+ plot_height, plot_width, ggplot2_args) {
|
||
| 680 | +392 | ! |
- disabled = reactive(is.null(teal.code::get_warnings(output_q())))+ with_reporter <- !missing(reporter) && inherits(reporter, "Reporter") |
| 681 | -+ | ||
| 393 | +! |
- )+ with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI") |
|
| 682 | -+ | ||
| 394 | +! |
-
+ checkmate::assert_class(data, "reactive") |
|
| 683 | +395 | ! |
- teal.widgets::verbatim_popup_srv(+ checkmate::assert_class(isolate(data()), "teal_data") |
| 684 | +396 | ! |
- id = "rcode",+ moduleServer(id, function(input, output, session) {
|
| 685 | +397 | ! |
- verbatim_content = reactive(teal.code::get_code(output_q())),+ prev_group_by_var <- reactiveVal("")
|
| 686 | +398 | ! |
- title = "Bivariate Plot"+ data_r <- reactive(data()[[dataname]]) |
| 687 | -+ | ||
| 399 | +! |
- )+ data_keys <- reactive(unlist(teal.data::join_keys(data())[[dataname]])) |
|
| 688 | +400 | ||
| 689 | -+ | ||
| 401 | +! |
- ### REPORTER+ iv_r <- reactive({
|
|
| 690 | +402 | ! |
- if (with_reporter) {
+ iv <- shinyvalidate::InputValidator$new() |
| 691 | +403 | ! |
- card_fun <- function(comment, label) {
+ iv$add_rule( |
| 692 | +404 | ! |
- card <- teal::report_card_template(+ "variables_select", |
| 693 | +405 | ! |
- title = "Bivariate Plot",+ shinyvalidate::sv_required("At least one reference variable needs to be selected.")
+ |
+
| 406 | ++ |
+ ) |
|
| 694 | +407 | ! |
- label = label,+ iv$add_rule( |
| 695 | +408 | ! |
- with_filter = with_filter,+ "variables_select", |
| 696 | +409 | ! |
- filter_panel_api = filter_panel_api+ ~ if (length(setdiff((.), data_keys())) < 1) "Please also select non-key columns." |
| 697 | +410 |
- )+ ) |
|
| 698 | +411 | ! |
- card$append_text("Plot", "header3")
+ iv_summary_table <- shinyvalidate::InputValidator$new() |
| 699 | +412 | ! |
- card$append_plot(plot_r(), dim = pws$dim())+ iv_summary_table$condition(~ isTRUE(input$summary_type == "By Variable Levels")) |
| 700 | +413 | ! |
- if (!comment == "") {
+ iv_summary_table$add_rule("count_type", shinyvalidate::sv_required("Please select type of counts"))
|
| 701 | +414 | ! |
- card$append_text("Comment", "header3")
+ iv_summary_table$add_rule( |
| 702 | +415 | ! |
- card$append_text(comment)+ "group_by_vals",+ |
+
| 416 | +! | +
+ shinyvalidate::sv_required("Please select both group-by variable and values")
|
|
| 703 | +417 |
- }+ ) |
|
| 704 | +418 | ! |
- card$append_src(teal.code::get_code(output_q()))+ iv_summary_table$add_rule( |
| 705 | +419 | ! |
- card- |
-
| 706 | -- |
- }+ "group_by_var", |
|
| 707 | +420 | ! |
- teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
+ ~ if (length(.) > 0 && length(input$variables_select) == 1 && (.) == input$variables_select) {
|
| 708 | -+ | ||
| 421 | +! |
- }+ "If only one reference variable is selected it must not be the grouping variable." |
|
| 709 | +422 |
- ###+ } |
|
| 710 | +423 |
- })+ ) |
|
| 711 | -+ | ||
| 424 | +! |
- }+ iv_summary_table$add_rule( |
|
| 712 | -+ | ||
| 425 | +! |
-
+ "variables_select", |
|
| 713 | -+ | ||
| 426 | +! |
-
+ ~ if (length(input$group_by_var) > 0 && length(.) == 1 && (.) == input$group_by_var) {
|
|
| 714 | -+ | ||
| 427 | +! |
- #' Get Substituted ggplot call+ "If only one reference variable is selected it must not be the grouping variable." |
|
| 715 | +428 |
- #'+ } |
|
| 716 | +429 |
- #' @noRd+ ) |
|
| 717 | -+ | ||
| 430 | +! |
- #'+ iv$add_validator(iv_summary_table) |
|
| 718 | -+ | ||
| 431 | +! |
- #' @examples+ iv$enable() |
|
| 719 | -+ | ||
| 432 | +! |
- #'+ iv |
|
| 720 | +433 |
- #' bivariate_plot_call("ANL", "BAGE", "RACE", "numeric", "factor")
+ }) |
|
| 721 | +434 |
- #' bivariate_plot_call("ANL", "BAGE", character(0), "numeric", "NULL")
+
|
|
| 722 | +435 |
- bivariate_plot_call <- function(data_name,+ |
|
| 723 | -+ | ||
| 436 | +! |
- x = character(0),+ data_parent_keys <- reactive({
|
|
| 724 | -+ | ||
| 437 | +! |
- y = character(0),+ if (length(parent_dataname) > 0 && parent_dataname %in% names(data)) {
|
|
| 725 | -+ | ||
| 438 | +! |
- x_class = "NULL",+ keys <- teal.data::join_keys(data)[[dataname]] |
|
| 726 | -+ | ||
| 439 | +! |
- y_class = "NULL",+ if (parent_dataname %in% names(keys)) {
|
|
| 727 | -+ | ||
| 440 | +! |
- x_label = NULL,+ keys[[parent_dataname]] |
|
| 728 | +441 |
- y_label = NULL,+ } else {
|
|
| 729 | -+ | ||
| 442 | +! |
- freq = TRUE,+ keys[[dataname]] |
|
| 730 | +443 |
- theme = "gray",+ } |
|
| 731 | +444 |
- rotate_xaxis_labels = FALSE,+ } else {
|
|
| 732 | -+ | ||
| 445 | +! |
- swap_axes = FALSE,+ NULL |
|
| 733 | +446 |
- alpha = double(0),+ } |
|
| 734 | +447 |
- size = 2,+ }) |
|
| 735 | +448 |
- ggplot2_args = teal.widgets::ggplot2_args()) {
- |
- |
| 736 | -! | -
- supported_types <- c("NULL", "numeric", "integer", "factor", "character", "logical")
+
|
|
| 737 | +449 | ! |
- validate(need(x_class %in% supported_types, paste0("Data type '", x_class, "' is not supported.")))
+ common_code_q <- reactive({
|
| 738 | +450 | ! |
- validate(need(y_class %in% supported_types, paste0("Data type '", y_class, "' is not supported.")))
- |
-
| 739 | -- |
-
+ teal::validate_inputs(iv_r()) |
|
| 740 | +451 | ||
| 741 | +452 | ! |
- if (identical(x, character(0))) {
+ group_var <- input$group_by_var |
| 742 | +453 | ! |
- x <- x_label <- "-"+ anl <- data_r() |
| 743 | +454 |
- } else {
+
|
|
| 744 | +455 | ! |
- x <- if (is.call(x)) x else as.name(x)+ qenv <- if (!is.null(selected_vars()) && length(selected_vars()) != ncol(anl)) {
|
| 745 | -+ | ||
| 456 | +! |
- }+ teal.code::eval_code( |
|
| 746 | +457 | ! |
- if (identical(y, character(0))) {
+ data(), |
| 747 | +458 | ! |
- y <- y_label <- "-"+ substitute( |
| 748 | -+ | ||
| 459 | +! |
- } else {
+ expr = ANL <- anl_name[, selected_vars, drop = FALSE], # nolint: object_name. |
|
| 749 | +460 | ! |
- y <- if (is.call(y)) y else as.name(y)+ env = list(anl_name = as.name(dataname), selected_vars = selected_vars()) |
| 750 | +461 |
- }+ ) |
|
| 751 | +462 |
-
+ ) |
|
| 752 | -! | +||
| 463 | +
- cl <- bivariate_ggplot_call(+ } else {
|
||
| 753 | +464 | ! |
- x_class = x_class,+ teal.code::eval_code( |
| 754 | +465 | ! |
- y_class = y_class,+ data(), |
| 755 | +466 | ! |
- freq = freq,+ substitute(expr = ANL <- anl_name, env = list(anl_name = as.name(dataname))) # nolint: object_name. |
| 756 | -! | +||
| 467 | +
- theme = theme,+ ) |
||
| 757 | -! | +||
| 468 | +
- rotate_xaxis_labels = rotate_xaxis_labels,+ } |
||
| 758 | -! | +||
| 469 | +
- swap_axes = swap_axes,+ |
||
| 759 | +470 | ! |
- alpha = alpha,+ if (input$summary_type == "By Variable Levels" && !is.null(group_var) && !(group_var %in% selected_vars())) {
|
| 760 | +471 | ! |
- size = size,+ qenv <- teal.code::eval_code( |
| 761 | +472 | ! |
- ggplot2_args = ggplot2_args,+ qenv, |
| 762 | +473 | ! |
- x = x,+ substitute( |
| 763 | +474 | ! |
- y = y,+ expr = ANL[[group_var]] <- anl_name[[group_var]], # nolint: object_name. |
| 764 | +475 | ! |
- xlab = x_label,+ env = list(group_var = group_var, anl_name = as.name(dataname)) |
| 765 | -! | +||
| 476 | +
- ylab = y_label,+ ) |
||
| 766 | -! | +||
| 477 | +
- data_name = data_name+ ) |
||
| 767 | +478 |
- )+ } |
|
| 768 | +479 |
- }+ + |
+ |
| 480 | +! | +
+ new_col_name <- "**anyna**" |
|
| 769 | +481 | ||
| 770 | -+ | ||
| 482 | +! |
- substitute_q <- function(x, env) {
+ qenv <- teal.code::eval_code( |
|
| 771 | +483 | ! |
- stopifnot(is.language(x))+ qenv, |
| 772 | +484 | ! |
- call <- substitute(substitute(x, env), list(x = x))+ substitute( |
| 773 | +485 | ! |
- eval(call)+ expr = |
| 774 | -+ | ||
| 486 | +! |
- }+ create_cols_labels <- function(cols, just_label = FALSE) {
|
|
| 775 | -+ | ||
| 487 | +! |
-
+ column_labels <- column_labels_value |
|
| 776 | -+ | ||
| 488 | +! |
-
+ column_labels[is.na(column_labels) | length(column_labels) == 0] <- "" |
|
| 777 | -+ | ||
| 489 | +! |
- #' Create ggplot part of plot call+ if (just_label) {
|
|
| 778 | -+ | ||
| 490 | +! |
- #'+ labels <- column_labels[cols] |
|
| 779 | +491 |
- #' Due to the type of the x and y variable the plot type is chosen+ } else {
|
|
| 780 | -+ | ||
| 492 | +! |
- #'+ labels <- ifelse(cols == new_col_name | cols == "", cols, paste0(column_labels[cols], " [", cols, "]")) |
|
| 781 | +493 |
- #' @noRd+ } |
|
| 782 | -+ | ||
| 494 | +! |
- #'+ return(labels) |
|
| 783 | +495 |
- #' @examples+ }, |
|
| 784 | -+ | ||
| 496 | +! |
- #' bivariate_ggplot_call("numeric", "NULL")
+ env = list( |
|
| 785 | -+ | ||
| 497 | +! |
- #' bivariate_ggplot_call("numeric", "NULL", freq = FALSE)
+ new_col_name = new_col_name, |
|
| 786 | -+ | ||
| 498 | +! |
- #'+ column_labels_value = c(var_labels(data_r())[selected_vars()], |
|
| 787 | -+ | ||
| 499 | +! |
- #' bivariate_ggplot_call("NULL", "numeric")
+ new_col_name = new_col_name |
|
| 788 | +500 |
- #' bivariate_ggplot_call("NULL", "numeric", freq = FALSE)
+ ) |
|
| 789 | +501 |
- #'+ ) |
|
| 790 | +502 |
- #' bivariate_ggplot_call("NULL", "factor")
+ ) |
|
| 791 | +503 |
- #' bivariate_ggplot_call("NULL", "factor", freq = FALSE)
+ ) |
|
| 792 | -+ | ||
| 504 | +! |
- #'+ qenv |
|
| 793 | +505 |
- #' bivariate_ggplot_call("factor", "NULL")
+ }) |
|
| 794 | +506 |
- #' bivariate_ggplot_call("factor", "NULL", freq = FALSE)
+
|
|
| 795 | -+ | ||
| 507 | +! |
- #'+ selected_vars <- reactive({
|
|
| 796 | -+ | ||
| 508 | +! |
- #' bivariate_ggplot_call("numeric", "numeric")
+ req(input$variables_select) |
|
| 797 | -+ | ||
| 509 | +! |
- #' bivariate_ggplot_call("numeric", "factor")
+ keys <- data_keys() |
|
| 798 | -+ | ||
| 510 | +! |
- #' bivariate_ggplot_call("factor", "numeric")
+ vars <- unique(c(keys, input$variables_select)) |
|
| 799 | -+ | ||
| 511 | +! |
- #' bivariate_ggplot_call("factor", "factor")
+ vars |
|
| 800 | +512 |
- bivariate_ggplot_call <- function(x_class = c("NULL", "numeric", "integer", "factor", "character", "logical"),
+ }) |
|
| 801 | +513 |
- y_class = c("NULL", "numeric", "integer", "factor", "character", "logical"),
+
|
|
| 802 | -+ | ||
| 514 | +! |
- freq = TRUE,+ vars_summary <- reactive({
|
|
| 803 | -+ | ||
| 515 | +! |
- theme = "gray",+ na_count <- data_r() %>% |
|
| 804 | -+ | ||
| 516 | +! |
- rotate_xaxis_labels = FALSE,+ sapply(function(x) mean(is.na(x)), USE.NAMES = TRUE) %>% |
|
| 805 | -+ | ||
| 517 | +! |
- swap_axes = FALSE,+ sort(decreasing = TRUE) |
|
| 806 | +518 |
- size = double(0),+ |
|
| 807 | -+ | ||
| 519 | +! |
- alpha = double(0),+ tibble::tibble( |
|
| 808 | -+ | ||
| 520 | +! |
- x = NULL,+ key = names(na_count), |
|
| 809 | -+ | ||
| 521 | +! |
- y = NULL,+ value = unname(na_count), |
|
| 810 | -+ | ||
| 522 | +! |
- xlab = "-",+ label = cut(na_count, breaks = seq(from = 0, to = 1, by = 0.1), include.lowest = TRUE) |
|
| 811 | +523 |
- ylab = "-",+ ) |
|
| 812 | +524 |
- data_name = "ANL",+ }) |
|
| 813 | +525 |
- ggplot2_args = teal.widgets::ggplot2_args()) {
+
|
|
| 814 | -42x | +||
| 526 | +! |
- x_class <- match.arg(x_class)+ output$variables <- renderUI({
|
|
| 815 | -42x | +||
| 527 | +! |
- y_class <- match.arg(y_class)+ choices <- split(x = vars_summary()$key, f = vars_summary()$label, drop = TRUE) %>% rev()+ |
+ |
| 528 | +! | +
+ selected <- choices <- unname(unlist(choices)) |
|
| 816 | +529 | ||
| 817 | -42x | +||
| 530 | +! |
- if (x_class %in% c("character", "logical")) {
+ teal.widgets::optionalSelectInput( |
|
| 818 | -12x | +||
| 531 | +! |
- x_class <- "factor"+ session$ns("variables_select"),
|
|
| 819 | -+ | ||
| 532 | +! |
- }+ label = "Select variables", |
|
| 820 | -42x | +||
| 533 | +! |
- if (x_class %in% c("integer")) {
+ label_help = HTML(paste0("Dataset: ", tags$code(dataname))),
|
|
| 821 | +534 | ! |
- x_class <- "numeric"+ choices = teal.transform::variable_choices(data_r(), choices), |
| 822 | -+ | ||
| 535 | +! |
- }+ selected = selected, |
|
| 823 | -42x | +||
| 536 | +! |
- if (y_class %in% c("character", "logical")) {
+ multiple = TRUE |
|
| 824 | -8x | +||
| 537 | +
- y_class <- "factor"+ ) |
||
| 825 | +538 |
- }+ }) |
|
| 826 | -42x | +||
| 539 | +
- if (y_class %in% c("integer")) {
+
|
||
| 827 | +540 | ! |
- y_class <- "numeric"- |
-
| 828 | -- |
- }+ observeEvent(input$filter_na, {
|
|
| 829 | -+ | ||
| 541 | +! |
-
+ choices <- vars_summary() %>% |
|
| 830 | -42x | +||
| 542 | +! |
- if (all(c(x_class, y_class) == "NULL")) {
+ dplyr::select(!!as.name("key")) %>%
|
|
| 831 | +543 | ! |
- stop("either x or y is required")
+ getElement(name = 1) |
| 832 | +544 |
- }+ |
|
| 833 | -+ | ||
| 545 | +! |
-
+ selected <- vars_summary() %>% |
|
| 834 | -42x | +||
| 546 | +! |
- reduce_plot_call <- function(...) {
+ dplyr::filter(!!as.name("value") > 0) %>%
|
|
| 835 | -104x | +||
| 547 | +! |
- args <- Filter(Negate(is.null), list(...))+ dplyr::select(!!as.name("key")) %>%
|
|
| 836 | -104x | +||
| 548 | +! |
- Reduce(function(x, y) call("+", x, y), args)
+ getElement(name = 1) |
|
| 837 | +549 |
- }+ |
|
| 838 | -+ | ||
| 550 | +! |
-
+ teal.widgets::updateOptionalSelectInput( |
|
| 839 | -42x | +||
| 551 | +! |
- plot_call <- substitute(ggplot(data_name), env = list(data_name = as.name(data_name)))+ session = session, |
|
| 840 | -+ | ||
| 552 | +! |
-
+ inputId = "variables_select", |
|
| 841 | -+ | ||
| 553 | +! |
- # Single data plots+ choices = teal.transform::variable_choices(data_r()), |
|
| 842 | -42x | +||
| 554 | +! |
- if (x_class == "numeric" && y_class == "NULL") {
+ selected = selected |
|
| 843 | -6x | +||
| 555 | +
- plot_call <- reduce_plot_call(plot_call, substitute(aes(x = xval), env = list(xval = x)))+ ) |
||
| 844 | +556 |
-
+ }) |
|
| 845 | -6x | +||
| 557 | +
- if (freq) {
+
|
||
| 846 | -4x | +||
| 558 | +! |
- plot_call <- reduce_plot_call(+ output$group_by_var_ui <- renderUI({
|
|
| 847 | -4x | +||
| 559 | +! |
- plot_call,+ all_choices <- teal.transform::variable_choices(data_r()) |
|
| 848 | -4x | +||
| 560 | +! |
- quote(geom_histogram(bins = 30)),+ cat_choices <- all_choices[!sapply(data_r(), function(x) is.numeric(x) || inherits(x, "POSIXct"))] |
|
| 849 | -4x | +||
| 561 | +! |
- quote(ylab("Frequency"))
+ validate( |
|
| 850 | -+ | ||
| 562 | +! |
- )+ need(cat_choices, "Dataset does not have any non-numeric or non-datetime variables to use to group data with") |
|
| 851 | +563 |
- } else {
- |
- |
| 852 | -2x | -
- plot_call <- reduce_plot_call(+ ) |
|
| 853 | -2x | +||
| 564 | +! |
- plot_call,+ teal.widgets::optionalSelectInput( |
|
| 854 | -2x | +||
| 565 | +! |
- quote(geom_histogram(bins = 30, aes(y = after_stat(density)))),+ session$ns("group_by_var"),
|
|
| 855 | -2x | +||
| 566 | +! |
- quote(geom_density(aes(y = after_stat(density)))),+ label = "Group by variable", |
|
| 856 | -2x | +||
| 567 | +! |
- quote(ylab("Density"))
+ choices = cat_choices, |
|
| 857 | -+ | ||
| 568 | +! |
- )+ selected = `if`( |
|
| 858 | -+ | ||
| 569 | +! |
- }+ is.null(isolate(input$group_by_var)), |
|
| 859 | -36x | +||
| 570 | +! |
- } else if (x_class == "NULL" && y_class == "numeric") {
+ cat_choices[1], |
|
| 860 | -6x | +||
| 571 | +! |
- plot_call <- reduce_plot_call(plot_call, substitute(aes(x = yval), env = list(yval = y)))+ isolate(input$group_by_var) |
|
| 861 | +572 | - - | -|
| 862 | -6x | -
- if (freq) {
- |
- |
| 863 | -4x | -
- plot_call <- reduce_plot_call(+ ), |
|
| 864 | -4x | +||
| 573 | +! |
- plot_call,+ multiple = FALSE, |
|
| 865 | -4x | +||
| 574 | +! |
- quote(geom_histogram(bins = 30)),+ label_help = paste0("Dataset: ", dataname)
|
|
| 866 | -4x | +||
| 575 | +
- quote(ylab("Frequency"))
+ ) |
||
| 867 | +576 |
- )+ }) |
|
| 868 | +577 |
- } else {
+
|
|
| 869 | -2x | +||
| 578 | +! |
- plot_call <- reduce_plot_call(+ output$group_by_vals_ui <- renderUI({
|
|
| 870 | -2x | +||
| 579 | +! |
- plot_call,+ req(input$group_by_var) |
|
| 871 | -2x | +||
| 580 | +
- quote(geom_histogram(bins = 30, aes(y = after_stat(density)))),+ |
||
| 872 | -2x | +||
| 581 | +! |
- quote(geom_density(aes(y = after_stat(density)))),+ choices <- teal.transform::value_choices(data_r(), input$group_by_var, input$group_by_var) |
|
| 873 | -2x | +||
| 582 | +! |
- quote(ylab("Density"))
+ prev_choices <- isolate(input$group_by_vals) |
|
| 874 | +583 |
- )+ |
|
| 875 | +584 |
- }- |
- |
| 876 | -30x | -
- } else if (x_class == "factor" && y_class == "NULL") {
- |
- |
| 877 | -4x | -
- plot_call <- reduce_plot_call(plot_call, substitute(aes(x = xval), env = list(xval = x)))+ # determine selected value based on filtered data |
|
| 878 | +585 |
-
+ # display those previously selected values that are still available |
|
| 879 | -4x | +||
| 586 | +! |
- if (freq) {
+ selected <- if (!is.null(prev_choices) && any(prev_choices %in% choices)) {
|
|
| 880 | -2x | +||
| 587 | +! |
- plot_call <- reduce_plot_call(+ prev_choices[match(choices[choices %in% prev_choices], prev_choices)] |
|
| 881 | -2x | +||
| 588 | +! |
- plot_call,+ } else if (!is.null(prev_choices) && |
|
| 882 | -2x | +||
| 589 | +! |
- quote(geom_bar()),+ !any(prev_choices %in% choices) && |
|
| 883 | -2x | +||
| 590 | +! |
- quote(ylab("Frequency"))
+ isolate(prev_group_by_var()) == input$group_by_var) {
|
|
| 884 | +591 |
- )+ # if not any previously selected value is available and the grouping variable is the same, |
|
| 885 | +592 |
- } else {
- |
- |
| 886 | -2x | -
- plot_call <- reduce_plot_call(- |
- |
| 887 | -2x | -
- plot_call,+ # then display NULL |
|
| 888 | -2x | +||
| 593 | +! |
- quote(geom_bar(aes(y = after_stat(prop), group = 1))),+ NULL |
|
| 889 | -2x | +||
| 594 | +
- quote(ylab("Fraction"))
+ } else {
|
||
| 890 | +595 |
- )+ # if new grouping variable (i.e. not any previously selected value is available), |
|
| 891 | +596 |
- }+ # then display all choices |
|
| 892 | -26x | +||
| 597 | +! |
- } else if (x_class == "NULL" && y_class == "factor") {
+ choices |
|
| 893 | -4x | +||
| 598 | +
- plot_call <- reduce_plot_call(plot_call, substitute(aes(x = yval), env = list(yval = y)))+ } |
||
| 894 | +599 | ||
| 895 | -4x | -
- if (freq) {
- |
- |
| 896 | -2x | +||
| 600 | +! |
- plot_call <- reduce_plot_call(+ prev_group_by_var(input$group_by_var) # set current group_by_var |
|
| 897 | -2x | +||
| 601 | +! |
- plot_call,+ validate(need(length(choices) < 100, "Please select group-by variable with fewer than 100 unique values")) |
|
| 898 | -2x | +||
| 602 | +
- quote(geom_bar()),+ |
||
| 899 | -2x | +||
| 603 | +! |
- quote(ylab("Frequency"))
+ teal.widgets::optionalSelectInput( |
|
| 900 | -+ | ||
| 604 | +! |
- )+ session$ns("group_by_vals"),
|
|
| 901 | -+ | ||
| 605 | +! |
- } else {
+ label = "Filter levels", |
|
| 902 | -2x | +||
| 606 | +! |
- plot_call <- reduce_plot_call(+ choices = choices, |
|
| 903 | -2x | +||
| 607 | +! |
- plot_call,+ selected = selected, |
|
| 904 | -2x | +||
| 608 | +! |
- quote(geom_bar(aes(y = after_stat(prop), group = 1))),+ multiple = TRUE, |
|
| 905 | -2x | +||
| 609 | +! |
- quote(ylab("Fraction"))
+ label_help = paste0("Dataset: ", dataname)
|
|
| 906 | +610 |
) |
|
| 907 | +611 |
- }+ }) |
|
| 908 | +612 |
- # Numeric Plots+ |
|
| 909 | -22x | +||
| 613 | +! |
- } else if (x_class == "numeric" && y_class == "numeric") {
+ summary_plot_q <- reactive({
|
|
| 910 | -2x | +||
| 614 | +! |
- plot_call <- reduce_plot_call(+ req(input$summary_type == "Summary") # needed to trigger show r code update on tab change |
|
| 911 | -2x | +||
| 615 | +! |
- plot_call,+ teal::validate_has_data(data_r(), 1) |
|
| 912 | -2x | +||
| 616 | +
- substitute(aes(x = xval, y = yval), env = list(xval = x, yval = y)),+ + |
+ ||
| 617 | +! | +
+ qenv <- common_code_q() |
|
| 913 | +618 |
- # pch = 21 for consistent coloring behaviour b/w all geoms (outline and fill properties)+ |
|
| 914 | -2x | +||
| 619 | +! |
- `if`(+ if (input$any_na) {
|
|
| 915 | -2x | +||
| 620 | +! |
- !is.null(size),+ new_col_name <- "**anyna**" |
|
| 916 | -2x | +||
| 621 | +! |
- substitute(+ qenv <- teal.code::eval_code( |
|
| 917 | -2x | +||
| 622 | +! |
- geom_point(alpha = alphaval, size = sizeval, pch = 21),+ qenv, |
|
| 918 | -2x | +||
| 623 | +! |
- env = list(alphaval = alpha, sizeval = size)+ substitute(+ |
+ |
| 624 | +! | +
+ expr = ANL[[new_col_name]] <- ifelse(rowSums(is.na(ANL)) > 0, NA, FALSE), # nolint: object_name.+ |
+ |
| 625 | +! | +
+ env = list(new_col_name = new_col_name) |
|
| 919 | +626 |
- ),+ ) |
|
| 920 | -2x | +||
| 627 | ++ |
+ )+ |
+ |
| 628 | ++ |
+ }+ |
+ |
| 629 | ++ | + + | +|
| 630 | +! | +
+ qenv <- teal.code::eval_code(+ |
+ |
| 631 | +! | +
+ qenv,+ |
+ |
| 632 | +! |
substitute( |
|
| 921 | -2x | +||
| 633 | +! |
- geom_point(alpha = alphaval, pch = 21),+ expr = analysis_vars <- setdiff(colnames(ANL), data_keys), |
|
| 922 | -2x | +||
| 634 | +! |
- env = list(alphaval = alpha)+ env = list(data_keys = data_keys()) |
|
| 923 | +635 |
) |
|
| 924 | +636 |
- )+ ) %>%+ |
+ |
| 637 | +! | +
+ teal.code::eval_code(+ |
+ |
| 638 | +! | +
+ substitute(+ |
+ |
| 639 | +! | +
+ expr = summary_plot_obs <- data_frame_call[, analysis_vars] %>%+ |
+ |
| 640 | +! | +
+ dplyr::summarise_all(list(function(x) sum(is.na(x)))) %>%+ |
+ |
| 641 | +! | +
+ tidyr::pivot_longer(tidyselect::everything(), names_to = "col", values_to = "n_na") %>%+ |
+ |
| 642 | +! | +
+ dplyr::mutate(n_not_na = nrow(ANL) - n_na) %>%+ |
+ |
| 643 | +! | +
+ tidyr::pivot_longer(-col, names_to = "isna", values_to = "n") %>%+ |
+ |
| 644 | +! | +
+ dplyr::mutate(isna = isna == "n_na", n_pct = n / nrow(ANL) * 100),+ |
+ |
| 645 | +! | +
+ env = list(data_frame_call = if (!inherits(data_r(), "tbl_df")) {
+ |
+ |
| 646 | +! | +
+ quote(tibble::as_tibble(ANL)) |
|
| 925 | +647 |
- )+ } else {
|
|
| 926 | -20x | +||
| 648 | +! |
- } else if ((x_class == "numeric" && y_class == "factor") || (x_class == "factor" && y_class == "numeric")) {
+ quote(ANL) |
|
| 927 | -6x | +||
| 649 | +
- plot_call <- reduce_plot_call(+ }) |
||
| 928 | -6x | +||
| 650 | +
- plot_call,+ ) |
||
| 929 | -6x | +||
| 651 | +
- substitute(aes(x = xval, y = yval), env = list(xval = x, yval = y)),+ ) %>% |
||
| 930 | -6x | +||
| 652 | +
- quote(geom_boxplot())+ # x axis ordering according to number of missing values and alphabet+ |
+ ||
| 653 | +! | +
+ teal.code::eval_code(+ |
+ |
| 654 | +! | +
+ quote(+ |
+ |
| 655 | +! | +
+ expr = x_levels <- dplyr::filter(summary_plot_obs, isna) %>%+ |
+ |
| 656 | +! | +
+ dplyr::arrange(n_pct, dplyr::desc(col)) %>%+ |
+ |
| 657 | +! | +
+ dplyr::pull(col) %>%+ |
+ |
| 658 | +! | +
+ create_cols_labels() |
|
| 931 | +659 |
- )+ ) |
|
| 932 | +660 |
- # Factor and character plots+ ) |
|
| 933 | -14x | +||
| 661 | +
- } else if (x_class == "factor" && y_class == "factor") {
+
|
||
| 934 | -14x | +||
| 662 | +
- plot_call <- reduce_plot_call(+ # always set "**anyna**" level as the last one |
||
| 935 | -14x | +||
| 663 | +! |
- plot_call,+ if (isolate(input$any_na)) {
|
|
| 936 | -14x | +||
| 664 | +! |
- substitute(+ qenv <- teal.code::eval_code( |
|
| 937 | -14x | +||
| 665 | +! |
- ggmosaic::geom_mosaic(aes(x = ggmosaic::product(xval), fill = yval), na.rm = TRUE),+ qenv, |
|
| 938 | -14x | +||
| 666 | +! |
- env = list(xval = x, yval = y)+ quote(x_levels <- c(setdiff(x_levels, "**anyna**"), "**anyna**")) |
|
| 939 | +667 | ++ |
+ )+ |
+
| 668 | ++ |
+ }+ |
+ |
| 669 | ++ | + + | +|
| 670 | +! | +
+ dev_ggplot2_args <- teal.widgets::ggplot2_args(+ |
+ |
| 671 | +! | +
+ labs = list(x = "Variable", y = "Missing observations"),+ |
+ |
| 672 | +! | +
+ theme = list(legend.position = "bottom", axis.text.x = quote(element_text(angle = 45, hjust = 1)))+ |
+ |
| 673 |
) |
||
| 940 | +674 | ++ | + + | +
| 675 | +! | +
+ all_ggplot2_args <- teal.widgets::resolve_ggplot2_args(+ |
+ |
| 676 | +! | +
+ user_plot = ggplot2_args[["Summary Obs"]],+ |
+ |
| 677 | +! | +
+ user_default = ggplot2_args$default,+ |
+ |
| 678 | +! | +
+ module_plot = dev_ggplot2_args+ |
+ |
| 679 | ++ |
+ )+ |
+ |
| 680 | ++ | + + | +|
| 681 | +! | +
+ parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(+ |
+ |
| 682 | +! | +
+ all_ggplot2_args,+ |
+ |
| 683 | +! | +
+ ggtheme = input$ggtheme+ |
+ |
| 684 | ++ |
+ )+ |
+ |
| 685 |
- )+ + |
+ ||
| 686 | +! | +
+ qenv <- teal.code::eval_code(+ |
+ |
| 687 | +! | +
+ qenv,+ |
+ |
| 688 | +! | +
+ substitute(+ |
+ |
| 689 | +! | +
+ p1 <- summary_plot_obs %>%+ |
+ |
| 690 | +! | +
+ ggplot() ++ |
+ |
| 691 | +! | +
+ aes(+ |
+ |
| 692 | +! | +
+ x = factor(create_cols_labels(col), levels = x_levels),+ |
+ |
| 693 | +! | +
+ y = n_pct,+ |
+ |
| 694 | +! | +
+ fill = isna+ |
+ |
| 695 | ++ |
+ ) ++ |
+ |
| 696 | +! | +
+ geom_bar(position = "fill", stat = "identity") ++ |
+ |
| 697 | +! | +
+ scale_fill_manual(+ |
+ |
| 698 | +! | +
+ name = "",+ |
+ |
| 699 | +! | +
+ values = c("grey90", c(getOption("ggplot2.discrete.colour")[2], "#ff2951ff")[1]),
+ |
+ |
| 700 | +! | +
+ labels = c("Present", "Missing")
+ |
+ |
| 701 | ++ |
+ ) ++ |
+ |
| 702 | +! | +
+ scale_y_continuous(labels = scales::percent_format(), breaks = seq(0, 1, by = 0.1), expand = c(0, 0)) ++ |
+ |
| 703 | +! | +
+ geom_text(+ |
+ |
| 704 | +! | +
+ aes(label = ifelse(isna == TRUE, sprintf("%d [%.02f%%]", n, n_pct), ""), y = 1),
+ |
+ |
| 705 | +! | +
+ hjust = 1,+ |
+ |
| 706 | +! | +
+ color = "black"+ |
+ |
| 707 | ++ |
+ ) ++ |
+ |
| 708 | +! | +
+ labs ++ |
+ |
| 709 | +! | +
+ ggthemes ++ |
+ |
| 710 | +! | +
+ themes ++ |
+ |
| 711 | +! | +
+ coord_flip(),+ |
+ |
| 712 | +! | +
+ env = list(+ |
+ |
| 713 | +! | +
+ labs = parsed_ggplot2_args$labs,+ |
+ |
| 714 | +! | +
+ themes = parsed_ggplot2_args$theme,+ |
+ |
| 715 | +! | +
+ ggthemes = parsed_ggplot2_args$ggtheme+ |
+ |
| 716 | ++ |
+ )+ |
+ |
| 717 | ++ |
+ )+ |
+ |
| 718 | ++ |
+ )+ |
+ |
| 719 | ++ | + + | +|
| 720 | +! | +
+ if (isTRUE(input$if_patients_plot)) {
+ |
+ |
| 721 | +! | +
+ qenv <- teal.code::eval_code(+ |
+ |
| 722 | +! | +
+ qenv,+ |
+ |
| 723 | +! | +
+ substitute(+ |
+ |
| 724 | +! | +
+ expr = parent_keys <- keys,+ |
+ |
| 725 | +! | +
+ env = list(keys = data_parent_keys())+ |
+ |
| 726 | ++ |
+ )+ |
+ |
| 727 | ++ |
+ ) %>%+ |
+ |
| 728 | +! | +
+ teal.code::eval_code(quote(ndistinct_subjects <- dplyr::n_distinct(ANL[, parent_keys]))) %>%+ |
+ |
| 729 | +! | +
+ teal.code::eval_code(+ |
+ |
| 730 | +! | +
+ quote(+ |
+ |
| 731 | +! | +
+ summary_plot_patients <- ANL[, c(parent_keys, analysis_vars)] %>%+ |
+ |
| 732 | +! | +
+ dplyr::group_by_at(parent_keys) %>%+ |
+ |
| 733 | +! | +
+ dplyr::summarise_all(anyNA) %>%+ |
+ |
| 734 | +! | +
+ tidyr::pivot_longer(cols = !tidyselect::all_of(parent_keys), names_to = "col", values_to = "anyna") %>%+ |
+ |
| 735 | +! | +
+ dplyr::group_by_at(c("col")) %>%
+ |
+ |
| 736 | +! | +
+ dplyr::summarise(count_na = sum(anyna)) %>%+ |
+ |
| 737 | +! | +
+ dplyr::mutate(count_not_na = ndistinct_subjects - count_na) %>%+ |
+ |
| 738 | +! | +
+ tidyr::pivot_longer(-c(col), names_to = "isna", values_to = "n") %>%+ |
+ |
| 739 | +! | +
+ dplyr::mutate(isna = isna == "count_na", n_pct = n / ndistinct_subjects * 100) %>%+ |
+ |
| 740 | +! | +
+ dplyr::arrange_at(c("isna", "n"), .funs = dplyr::desc)
+ |
+ |
| 741 | ++ |
+ )+ |
+ |
| 742 | ++ |
+ )+ |
+ |
| 743 | ++ | + + | +|
| 744 | +! | +
+ dev_ggplot2_args <- teal.widgets::ggplot2_args(+ |
+ |
| 745 | +! | +
+ labs = list(x = "", y = "Missing patients"),+ |
+ |
| 746 | +! | +
+ theme = list(+ |
+ |
| 747 | +! | +
+ legend.position = "bottom",+ |
+ |
| 748 | +! | +
+ axis.text.x = quote(element_text(angle = 45, hjust = 1)),+ |
+ |
| 749 | +! | +
+ axis.text.y = quote(element_blank())+ |
+ |
| 750 | ++ |
+ )+ |
+ |
| 751 | ++ |
+ )+ |
+ |
| 752 | ++ | + + | +|
| 753 | +! | +
+ all_ggplot2_args <- teal.widgets::resolve_ggplot2_args(+ |
+ |
| 754 | +! | +
+ user_plot = ggplot2_args[["Summary Patients"]],+ |
+ |
| 755 | +! | +
+ user_default = ggplot2_args$default,+ |
+ |
| 756 | +! | +
+ module_plot = dev_ggplot2_args+ |
+ |
| 757 | ++ |
+ )+ |
+ |
| 758 | ++ | + + | +|
| 759 | +! | +
+ parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(+ |
+ |
| 760 | +! | +
+ all_ggplot2_args,+ |
+ |
| 761 | +! | +
+ ggtheme = input$ggtheme+ |
+ |
| 762 | ++ |
+ )+ |
+ |
| 763 | ++ | + + | +|
| 764 | +! | +
+ qenv <- teal.code::eval_code(+ |
+ |
| 765 | +! | +
+ qenv,+ |
+ |
| 766 | +! | +
+ substitute(+ |
+ |
| 767 | +! | +
+ p2 <- summary_plot_patients %>%+ |
+ |
| 768 | +! | +
+ ggplot() ++ |
+ |
| 769 | +! | +
+ aes_(+ |
+ |
| 770 | +! | +
+ x = ~ factor(create_cols_labels(col), levels = x_levels),+ |
+ |
| 771 | +! | +
+ y = ~n_pct,+ |
+ |
| 772 | +! | +
+ fill = ~isna+ |
+ |
| 773 | ++ |
+ ) ++ |
+ |
| 774 | +! | +
+ geom_bar(alpha = 1, stat = "identity", position = "fill") ++ |
+ |
| 775 | +! | +
+ scale_y_continuous(labels = scales::percent_format(), breaks = seq(0, 1, by = 0.1), expand = c(0, 0)) ++ |
+ |
| 776 | +! | +
+ scale_fill_manual(+ |
+ |
| 777 | +! | +
+ name = "",+ |
+ |
| 778 | +! | +
+ values = c("grey90", c(getOption("ggplot2.discrete.colour")[2], "#ff2951ff")[1]),
+ |
+ |
| 779 | +! | +
+ labels = c("Present", "Missing")
+ |
+ |
| 780 | ++ |
+ ) ++ |
+ |
| 781 | +! | +
+ geom_text(+ |
+ |
| 782 | +! | +
+ aes(label = ifelse(isna == TRUE, sprintf("%d [%.02f%%]", n, n_pct), ""), y = 1),
+ |
+ |
| 783 | +! | +
+ hjust = 1,+ |
+ |
| 784 | +! | +
+ color = "black"+ |
+ |
| 785 | ++ |
+ ) ++ |
+ |
| 786 | +! | +
+ labs ++ |
+ |
| 787 | +! | +
+ ggthemes ++ |
+ |
| 788 | +! | +
+ themes ++ |
+ |
| 789 | +! | +
+ coord_flip(),+ |
+ |
| 790 | +! | +
+ env = list(+ |
+ |
| 791 | +! | +
+ labs = parsed_ggplot2_args$labs,+ |
+ |
| 792 | +! | +
+ themes = parsed_ggplot2_args$theme,+ |
+ |
| 793 | +! | +
+ ggthemes = parsed_ggplot2_args$ggtheme+ |
+ |
| 794 | ++ |
+ )+ |
+ |
| 795 | ++ |
+ )+ |
+ |
| 796 | ++ |
+ ) %>%+ |
+ |
| 797 | +! | +
+ teal.code::eval_code(+ |
+ |
| 798 | +! | +
+ quote({
+ |
+ |
| 799 | +! | +
+ g1 <- ggplotGrob(p1)+ |
+ |
| 800 | +! | +
+ g2 <- ggplotGrob(p2)+ |
+ |
| 801 | +! | +
+ g <- gridExtra::gtable_cbind(g1, g2, size = "first")+ |
+ |
| 802 | +! | +
+ g$heights <- grid::unit.pmax(g1$heights, g2$heights)+ |
+ |
| 803 | +! | +
+ grid::grid.newpage()+ |
+ |
| 804 | ++ |
+ })+ |
+ |
| 805 | ++ |
+ )+ |
+ |
| 806 | ++ |
+ } else {
+ |
+ |
| 807 | +! | +
+ qenv <- teal.code::eval_code(+ |
+ |
| 808 | +! | +
+ qenv,+ |
+ |
| 809 | +! | +
+ quote({
|
|
| 941 | -+ | ||
| 810 | +! |
- } else {
+ g <- ggplotGrob(p1) |
|
| 942 | +811 | ! |
- stop("x y type combination not allowed")
+ grid::grid.newpage() |
| 943 | +812 |
- }+ }) |
|
| 944 | +813 | - - | -|
| 945 | -42x | -
- labs_base <- if (x_class == "NULL") {
- |
- |
| 946 | -10x | -
- list(x = substitute(ylab, list(ylab = ylab)))- |
- |
| 947 | -42x | -
- } else if (y_class == "NULL") {
+ ) |
|
| 948 | -10x | +||
| 814 | +
- list(x = substitute(xlab, list(xlab = xlab)))+ } |
||
| 949 | +815 |
- } else {
+
|
|
| 950 | -22x | +||
| 816 | +! |
- list(+ teal.code::eval_code( |
|
| 951 | -22x | +||
| 817 | +! |
- x = substitute(xlab, list(xlab = xlab)),+ qenv, |
|
| 952 | -22x | +||
| 818 | +! |
- y = substitute(ylab, list(ylab = ylab))+ quote(grid::grid.draw(g)) |
|
| 953 | +819 |
- )+ ) |
|
| 954 | +820 |
- }+ }) |
|
| 955 | +821 | ||
| 956 | -42x | +||
| 822 | +! |
- dev_ggplot2_args <- teal.widgets::ggplot2_args(labs = labs_base)+ summary_plot_r <- reactive(summary_plot_q()[["g"]]) |
|
| 957 | +823 | ||
| 958 | -42x | +||
| 824 | +! |
- if (rotate_xaxis_labels) {
+ combination_cutoff_q <- reactive({
|
|
| 959 | +825 | ! |
- dev_ggplot2_args$theme <- list(axis.text.x = quote(element_text(angle = 45, hjust = 1)))+ req(common_code_q()) |
| 960 | -+ | ||
| 826 | +! |
- }+ teal.code::eval_code( |
|
| 961 | -+ | ||
| 827 | +! |
-
+ common_code_q(), |
|
| 962 | -42x | +||
| 828 | +! |
- all_ggplot2_args <- teal.widgets::resolve_ggplot2_args(+ quote( |
|
| 963 | -42x | +||
| 829 | +! |
- user_plot = ggplot2_args,+ combination_cutoff <- ANL %>% |
|
| 964 | -42x | +||
| 830 | +! |
- module_plot = dev_ggplot2_args+ dplyr::mutate_all(is.na) %>% |
|
| 965 | -+ | ||
| 831 | +! |
- )+ dplyr::group_by_all() %>% |
|
| 966 | -+ | ||
| 832 | +! |
-
+ dplyr::tally() %>% |
|
| 967 | -42x | +||
| 833 | +! |
- parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(all_ggplot2_args, ggtheme = theme)+ dplyr::ungroup() |
|
| 968 | +834 |
-
+ ) |
|
| 969 | -42x | +||
| 835 | +
- plot_call <- reduce_plot_call(+ ) |
||
| 970 | -42x | +||
| 836 | +
- plot_call,+ }) |
||
| 971 | -42x | +||
| 837 | +
- parsed_ggplot2_args$labs,+ |
||
| 972 | -42x | +||
| 838 | +! |
- parsed_ggplot2_args$ggtheme,+ output$cutoff <- renderUI({
|
|
| 973 | -42x | +||
| 839 | +! |
- parsed_ggplot2_args$theme+ x <- combination_cutoff_q()[["combination_cutoff"]]$n |
|
| 974 | +840 |
- )+ |
|
| 975 | +841 |
-
+ # select 10-th from the top |
|
| 976 | -42x | +||
| 842 | +! |
- if (swap_axes) {
+ n <- length(x) |
|
| 977 | +843 | ! |
- plot_call <- reduce_plot_call(plot_call, quote(coord_flip()))+ idx <- max(1, n - 10) |
| 978 | -+ | ||
| 844 | +! |
- }+ prev_value <- isolate(input$combination_cutoff) |
|
| 979 | -+ | ||
| 845 | +! |
-
+ value <- `if`( |
|
| 980 | -42x | +||
| 846 | +! |
- return(plot_call)+ is.null(prev_value) || prev_value > max(x) || prev_value < min(x), |
|
| 981 | -+ | ||
| 847 | +! |
- }+ sort(x, partial = idx)[idx], prev_value |
|
| 982 | +848 |
-
+ ) |
|
| 983 | +849 | ||
| 984 | -+ | ||
| 850 | +! |
- #' Create facet call+ teal.widgets::optionalSliderInputValMinMax( |
|
| 985 | -+ | ||
| 851 | +! |
- #'+ session$ns("combination_cutoff"),
|
|
| 986 | -+ | ||
| 852 | +! |
- #' @noRd+ "Combination cut-off", |
|
| 987 | -+ | ||
| 853 | +! |
- #'+ c(value, range(x)) |
|
| 988 | +854 |
- #' @examples+ ) |
|
| 989 | +855 |
- #'+ }) |
|
| 990 | +856 |
- #' facet_ggplot_call(LETTERS[1:3])+ |
|
| 991 | -+ | ||
| 857 | +! |
- #' facet_ggplot_call(NULL, LETTERS[23:26])+ combination_plot_q <- reactive({
|
|
| 992 | -+ | ||
| 858 | +! |
- #' facet_ggplot_call(LETTERS[1:3], LETTERS[23:26])+ req(input$summary_type == "Combinations", input$combination_cutoff, combination_cutoff_q()) |
|
| 993 | -+ | ||
| 859 | +! |
- facet_ggplot_call <- function(row_facet = character(0),+ teal::validate_has_data(data_r(), 1) |
|
| 994 | +860 |
- col_facet = character(0),+ |
|
| 995 | -+ | ||
| 861 | +! |
- free_x_scales = FALSE,+ qenv <- teal.code::eval_code( |
|
| 996 | -+ | ||
| 862 | +! |
- free_y_scales = FALSE) {
+ combination_cutoff_q(), |
|
| 997 | +863 | ! |
- scales <- if (free_x_scales && free_y_scales) {
+ substitute( |
| 998 | +864 | ! |
- "free"+ expr = data_combination_plot_cutoff <- combination_cutoff %>% |
| 999 | +865 | ! |
- } else if (free_x_scales) {
+ dplyr::filter(n >= combination_cutoff_value) %>% |
| 1000 | +866 | ! |
- "free_x"+ dplyr::mutate(id = rank(-n, ties.method = "first")) %>% |
| 1001 | +867 | ! |
- } else if (free_y_scales) {
+ tidyr::pivot_longer(-c(n, id), names_to = "key", values_to = "value") %>% |
| 1002 | +868 | ! |
- "free_y"+ dplyr::arrange(n),+ |
+
| 869 | +! | +
+ env = list(combination_cutoff_value = input$combination_cutoff) |
|
| 1003 | +870 |
- } else {
+ ) |
|
| 1004 | -! | +||
| 871 | +
- "fixed"+ ) |
||
| 1005 | +872 |
- }+ |
|
| 1006 | +873 |
-
+ # find keys in dataset not selected in the UI and remove them from dataset |
|
| 1007 | +874 | ! |
- if (identical(row_facet, character(0)) && identical(col_facet, character(0))) {
+ keys_not_selected <- setdiff(data_keys(), input$variables_select) |
| 1008 | +875 | ! |
- NULL+ if (length(keys_not_selected) > 0) {
|
| 1009 | +876 | ! |
- } else if (!identical(row_facet, character(0)) && !identical(col_facet, character(0))) {
+ qenv <- teal.code::eval_code( |
| 1010 | +877 | ! |
- call(+ qenv, |
| 1011 | +878 | ! |
- "facet_grid",+ substitute( |
| 1012 | +879 | ! |
- rows = call_fun_dots("vars", row_facet),
+ expr = data_combination_plot_cutoff <- data_combination_plot_cutoff %>% |
| 1013 | +880 | ! |
- cols = call_fun_dots("vars", col_facet),
+ dplyr::filter(!key %in% keys_not_selected), |
| 1014 | +881 | ! |
- scales = scales+ env = list(keys_not_selected = keys_not_selected) |
| 1015 | +882 |
- )+ ) |
|
| 1016 | -! | +||
| 883 | +
- } else if (identical(row_facet, character(0)) && !identical(col_facet, character(0))) {
+ ) |
||
| 1017 | -! | +||
| 884 | +
- call("facet_grid", cols = call_fun_dots("vars", col_facet), scales = scales)
+ } |
||
| 1018 | -! | +||
| 885 | +
- } else if (!identical(row_facet, character(0)) && identical(col_facet, character(0))) {
+
|
||
| 1019 | +886 | ! |
- call("facet_grid", rows = call_fun_dots("vars", row_facet), scales = scales)
+ qenv <- teal.code::eval_code( |
| 1020 | -+ | ||
| 887 | +! |
- }+ qenv, |
|
| 1021 | -+ | ||
| 888 | +! |
- }+ quote( |
|
| 1022 | -+ | ||
| 889 | +! |
-
+ labels <- data_combination_plot_cutoff %>% |
|
| 1023 | -+ | ||
| 890 | +! | +
+ dplyr::filter(key == key[[1]]) %>%+ |
+ |
| 891 | +! |
- coloring_ggplot_call <- function(colour,+ getElement(name = 1) |
|
| 1024 | +892 |
- fill,+ ) |
|
| 1025 | +893 |
- size,+ ) |
|
| 1026 | +894 |
- is_point = FALSE) {
+
|
|
| 1027 | -15x | +||
| 895 | +! |
- if (!identical(colour, character(0)) && !identical(fill, character(0)) &&+ dev_ggplot2_args1 <- teal.widgets::ggplot2_args( |
|
| 1028 | -15x | +||
| 896 | +! |
- is_point && !identical(size, character(0))) {
+ labs = list(x = "", y = ""), |
|
| 1029 | -1x | +||
| 897 | +! |
- substitute(+ theme = list( |
|
| 1030 | -1x | +||
| 898 | +! |
- expr = aes(colour = colour_name, fill = fill_name, size = size_name),+ legend.position = "bottom", |
|
| 1031 | -1x | +||
| 899 | +! |
- env = list(colour_name = as.name(colour), fill_name = as.name(fill), size_name = as.name(size))+ axis.text.x = quote(element_blank()) |
|
| 1032 | +900 |
- )- |
- |
| 1033 | -14x | -
- } else if (identical(colour, character(0)) && !identical(fill, character(0)) &&+ ) |
|
| 1034 | -14x | +||
| 901 | +
- is_point && identical(size, character(0))) {
+ ) |
||
| 1035 | -1x | +||
| 902 | +
- substitute(expr = aes(fill = fill_name), env = list(fill_name = as.name(fill)))+ |
||
| 1036 | -13x | +||
| 903 | +! |
- } else if (!identical(colour, character(0)) && !identical(fill, character(0)) &&+ all_ggplot2_args1 <- teal.widgets::resolve_ggplot2_args( |
|
| 1037 | -13x | +||
| 904 | +! |
- (!is_point || identical(size, character(0)))) {
+ user_plot = ggplot2_args[["Combinations Hist"]], |
|
| 1038 | -3x | +||
| 905 | +! |
- substitute(+ user_default = ggplot2_args$default, |
|
| 1039 | -3x | +||
| 906 | +! |
- expr = aes(colour = colour_name, fill = fill_name),+ module_plot = dev_ggplot2_args1 |
|
| 1040 | -3x | +||
| 907 | +
- env = list(colour_name = as.name(colour), fill_name = as.name(fill))+ ) |
||
| 1041 | +908 |
- )+ |
|
| 1042 | -10x | +||
| 909 | +! |
- } else if (!identical(colour, character(0)) && identical(fill, character(0)) &&+ parsed_ggplot2_args1 <- teal.widgets::parse_ggplot2_args( |
|
| 1043 | -10x | +||
| 910 | +! |
- (!is_point || identical(size, character(0)))) {
+ all_ggplot2_args1, |
|
| 1044 | -1x | +||
| 911 | +! |
- substitute(expr = aes(colour = colour_name), env = list(colour_name = as.name(colour)))+ ggtheme = "void" |
|
| 1045 | -9x | +||
| 912 | +
- } else if (identical(colour, character(0)) && !identical(fill, character(0)) &&+ ) |
||
| 1046 | -9x | +||
| 913 | +
- (!is_point || identical(size, character(0)))) {
+
|
||
| 1047 | -2x | +||
| 914 | +! |
- substitute(expr = aes(fill = fill_name), env = list(fill_name = as.name(fill)))+ dev_ggplot2_args2 <- teal.widgets::ggplot2_args( |
|
| 1048 | -7x | +||
| 915 | +! |
- } else if (identical(colour, character(0)) && identical(fill, character(0)) &&+ labs = list(x = "", y = ""), |
|
| 1049 | -7x | +||
| 916 | +! |
- is_point && !identical(size, character(0))) {
+ theme = list( |
|
| 1050 | -1x | +||
| 917 | +! |
- substitute(expr = aes(size = size_name), env = list(size_name = as.name(size)))+ legend.position = "bottom", |
|
| 1051 | -6x | +||
| 918 | +! |
- } else if (!identical(colour, character(0)) && identical(fill, character(0)) &&+ axis.text.x = quote(element_blank()), |
|
| 1052 | -6x | +||
| 919 | +! |
- is_point && !identical(size, character(0))) {
+ axis.ticks = quote(element_blank()), |
|
| 1053 | -1x | +||
| 920 | +! |
- substitute(+ panel.grid.major = quote(element_blank()) |
|
| 1054 | -1x | +||
| 921 | +
- expr = aes(colour = colour_name, size = size_name),+ ) |
||
| 1055 | -1x | +||
| 922 | +
- env = list(colour_name = as.name(colour), size_name = as.name(size))+ ) |
||
| 1056 | +923 |
- )+ |
|
| 1057 | -5x | +||
| 924 | +! |
- } else if (identical(colour, character(0)) && !identical(fill, character(0)) &&+ all_ggplot2_args2 <- teal.widgets::resolve_ggplot2_args( |
|
| 1058 | -5x | +||
| 925 | +! |
- is_point && !identical(size, character(0))) {
+ user_plot = ggplot2_args[["Combinations Main"]], |
|
| 1059 | -1x | +||
| 926 | +! |
- substitute(+ user_default = ggplot2_args$default, |
|
| 1060 | -1x | +||
| 927 | +! |
- expr = aes(colour = colour_name, fill = fill_name, size = size_name),+ module_plot = dev_ggplot2_args2 |
|
| 1061 | -1x | +||
| 928 | +
- env = list(colour_name = as.name(fill), fill_name = as.name(fill), size_name = as.name(size))+ ) |
||
| 1062 | +929 |
- )+ |
|
| 1063 | -+ | ||
| 930 | +! |
- } else {
+ parsed_ggplot2_args2 <- teal.widgets::parse_ggplot2_args( |
|
| 1064 | -4x | +||
| 931 | +! |
- NULL+ all_ggplot2_args2, |
|
| 1065 | -+ | ||
| 932 | +! |
- }+ ggtheme = input$ggtheme |
|
| 1066 | +933 |
- }+ ) |
| 1 | +934 |
- #' Variable Browser Teal Module+ |
|
| 2 | -+ | ||
| 935 | +! |
- #'+ teal.code::eval_code( |
|
| 3 | -+ | ||
| 936 | +! |
- #' The variable browser provides a table with variable names and labels and a+ qenv, |
|
| 4 | -+ | ||
| 937 | +! |
- #' plot that visualizes the content of a particular variable.+ substitute( |
|
| 5 | -+ | ||
| 938 | +! |
- #' specifically designed for use with `data.frames`.+ expr = {
|
|
| 6 | -+ | ||
| 939 | +! |
- #'+ p1 <- data_combination_plot_cutoff %>% |
|
| 7 | -+ | ||
| 940 | +! |
- #' @details Numeric columns with fewer than 30 distinct values can be treated as either factors+ dplyr::select(id, n) %>% |
|
| 8 | -+ | ||
| 941 | +! |
- #' or numbers with a checkbox allowing users to switch how they are treated (if < 6 unique values+ dplyr::distinct() %>% |
|
| 9 | -+ | ||
| 942 | +! |
- #' then the default is categorical, otherwise it is numeric).+ ggplot(aes(x = id, y = n)) + |
|
| 10 | -+ | ||
| 943 | +! |
- #'+ geom_bar(stat = "identity", fill = c(getOption("ggplot2.discrete.colour")[2], "#ff2951ff")[1]) +
|
|
| 11 | -+ | ||
| 944 | +! |
- #' @inheritParams teal::module+ geom_text(aes(label = n), position = position_dodge(width = 0.9), vjust = -0.25) + |
|
| 12 | -+ | ||
| 945 | +! |
- #' @inheritParams shared_params+ ylim(c(0, max(data_combination_plot_cutoff$n) * 1.5)) + |
|
| 13 | -+ | ||
| 946 | +! |
- #' @param parent_dataname (`character(1)`) If this `dataname` exists in `datasets_selected`+ labs1 + |
|
| 14 | -+ | ||
| 947 | +! |
- #' then an extra checkbox will be shown to allow users to not show variables in other datasets+ ggthemes1 + |
|
| 15 | -+ | ||
| 948 | +! |
- #' which exist in this `dataname`.+ themes1 |
|
| 16 | +949 |
- #' This is typically used to remove `ADSL` columns in `CDISC` data. In non `CDISC` data this+ |
|
| 17 | -+ | ||
| 950 | +! |
- #' can be ignored. Defaults to `"ADSL"`.+ graph_number_rows <- length(unique(data_combination_plot_cutoff$id)) |
|
| 18 | -+ | ||
| 951 | +! |
- #' @param datasets_selected (`character`) A vector of datasets which should be+ graph_number_cols <- nrow(data_combination_plot_cutoff) / graph_number_rows |
|
| 19 | +952 |
- #' shown and in what order. Names in the vector have to correspond with datasets names.+ |
|
| 20 | -+ | ||
| 953 | +! |
- #' If vector of length zero (default) then all datasets are shown.+ p2 <- data_combination_plot_cutoff %>% ggplot() + |
|
| 21 | -+ | ||
| 954 | +! |
- #' Note: Only datasets of the `data.frame` class are compatible; using other types will cause an error.+ aes(x = create_cols_labels(key), y = id - 0.5, fill = value) + |
|
| 22 | -+ | ||
| 955 | +! |
- #'+ geom_tile(alpha = 0.85, height = 0.95) + |
|
| 23 | -+ | ||
| 956 | +! |
- #' @aliases+ scale_fill_manual( |
|
| 24 | -+ | ||
| 957 | +! |
- #' tm_variable_browser_ui,+ name = "", |
|
| 25 | -+ | ||
| 958 | +! |
- #' tm_variable_browser_srv,+ values = c("grey90", c(getOption("ggplot2.discrete.colour")[2], "#ff2951ff")[1]),
|
|
| 26 | -+ | ||
| 959 | +! |
- #' tm_variable_browser,+ labels = c("Present", "Missing")
|
|
| 27 | +960 |
- #' variable_browser_ui,+ ) + |
|
| 28 | -+ | ||
| 961 | +! |
- #' variable_browser_srv,+ geom_hline(yintercept = seq_len(1 + graph_number_rows) - 1) + |
|
| 29 | -+ | ||
| 962 | +! |
- #' variable_browser+ geom_vline(xintercept = seq_len(1 + graph_number_cols) - 0.5, linetype = "dotted") + |
|
| 30 | -+ | ||
| 963 | +! |
- #'+ coord_flip() + |
|
| 31 | -+ | ||
| 964 | +! |
- #' @examples+ labs2 + |
|
| 32 | -+ | ||
| 965 | +! |
- #' library(teal.widgets)+ ggthemes2 + |
|
| 33 | -+ | ||
| 966 | +! |
- #'+ themes2 |
|
| 34 | +967 |
- #' # module specification used in apps below+ |
|
| 35 | -+ | ||
| 968 | +! |
- #' tm_variable_browser_module <- tm_variable_browser(+ g1 <- ggplotGrob(p1) |
|
| 36 | -+ | ||
| 969 | +! |
- #' label = "Variable browser",+ g2 <- ggplotGrob(p2) |
|
| 37 | +970 |
- #' ggplot2_args = ggplot2_args(+ |
|
| 38 | -+ | ||
| 971 | +! |
- #' labs = list(subtitle = "Plot generated by Variable Browser Module")+ g <- gridExtra::gtable_rbind(g1, g2, size = "last") |
|
| 39 | -+ | ||
| 972 | +! |
- #' )+ g$heights[7] <- grid::unit(0.2, "null") # rescale to get the bar chart smaller |
|
| 40 | -+ | ||
| 973 | +! |
- #' )+ grid::grid.newpage() |
|
| 41 | -+ | ||
| 974 | +! |
- #'+ grid::grid.draw(g) |
|
| 42 | +975 |
- #' # general data example+ }, |
|
| 43 | -+ | ||
| 976 | +! |
- #' data <- teal_data()+ env = list( |
|
| 44 | -+ | ||
| 977 | +! |
- #' data <- within(data, {
+ labs1 = parsed_ggplot2_args1$labs, |
|
| 45 | -+ | ||
| 978 | +! |
- #' iris <- iris+ themes1 = parsed_ggplot2_args1$theme, |
|
| 46 | -+ | ||
| 979 | +! |
- #' mtcars <- mtcars+ ggthemes1 = parsed_ggplot2_args1$ggtheme, |
|
| 47 | -+ | ||
| 980 | +! |
- #' women <- women+ labs2 = parsed_ggplot2_args2$labs, |
|
| 48 | -+ | ||
| 981 | +! |
- #' faithful <- faithful+ themes2 = parsed_ggplot2_args2$theme, |
|
| 49 | -+ | ||
| 982 | +! |
- #' CO2 <- CO2+ ggthemes2 = parsed_ggplot2_args2$ggtheme |
|
| 50 | +983 |
- #' })+ ) |
|
| 51 | +984 |
- #' datanames(data) <- c("iris", "mtcars", "women", "faithful", "CO2")
+ ) |
|
| 52 | +985 |
- #'+ ) |
|
| 53 | +986 |
- #' app <- init(+ }) |
|
| 54 | +987 |
- #' data = data,+ |
|
| 55 | -+ | ||
| 988 | +! |
- #' modules = modules(tm_variable_browser_module)+ combination_plot_r <- reactive(combination_plot_q()[["g"]]) |
|
| 56 | +989 |
- #' )+ |
|
| 57 | -+ | ||
| 990 | +! |
- #' if (interactive()) {
+ summary_table_q <- reactive({
|
|
| 58 | -+ | ||
| 991 | +! |
- #' shinyApp(app$ui, app$server)+ req( |
|
| 59 | -+ | ||
| 992 | +! |
- #' }+ input$summary_type == "By Variable Levels", # needed to trigger show r code update on tab change |
|
| 60 | -+ | ||
| 993 | +! |
- #'+ common_code_q() |
|
| 61 | +994 |
- #' # CDISC example data+ ) |
|
| 62 | -+ | ||
| 995 | +! |
- #' data <- teal_data()+ teal::validate_has_data(data_r(), 1) |
|
| 63 | +996 |
- #' data <- within(data, {
+
|
|
| 64 | +997 |
- #' ADSL <- rADSL+ # extract the ANL dataset for use in further validation |
|
| 65 | -+ | ||
| 998 | +! |
- #' ADTTE <- rADTTE+ anl <- common_code_q()[["ANL"]] |
|
| 66 | +999 |
- #' })+ |
|
| 67 | -+ | ||
| 1000 | +! |
- #' datanames(data) <- c("ADSL", "ADTTE")
+ group_var <- input$group_by_var |
|
| 68 | -+ | ||
| 1001 | +! |
- #' join_keys(data) <- default_cdisc_join_keys[datanames(data)]+ validate( |
|
| 69 | -+ | ||
| 1002 | +! |
- #'+ need( |
|
| 70 | -+ | ||
| 1003 | +! |
- #' app <- init(+ is.null(group_var) || |
|
| 71 | -+ | ||
| 1004 | +! |
- #' data = data,+ length(unique(anl[[group_var]])) < 100, |
|
| 72 | -+ | ||
| 1005 | +! |
- #' modules = modules(tm_variable_browser_module)+ "Please select group-by variable with fewer than 100 unique values" |
|
| 73 | +1006 |
- #' )+ ) |
|
| 74 | +1007 |
- #' if (interactive()) {
+ ) |
|
| 75 | +1008 |
- #' shinyApp(app$ui, app$server)+ |
|
| 76 | -+ | ||
| 1009 | +! |
- #' }+ group_vals <- input$group_by_vals |
|
| 77 | -+ | ||
| 1010 | +! |
- #'+ variables_select <- input$variables_select |
|
| 78 | -+ | ||
| 1011 | +! |
- #' @export+ vars <- unique(variables_select, group_var) |
|
| 79 | -+ | ||
| 1012 | +! |
- #'+ count_type <- input$count_type |
|
| 80 | +1013 |
- tm_variable_browser <- function(label = "Variable Browser",+ |
|
| 81 | -+ | ||
| 1014 | +! |
- datasets_selected = character(0),+ if (!is.null(selected_vars()) && length(selected_vars()) != ncol(anl)) {
|
|
| 82 | -+ | ||
| 1015 | +! |
- parent_dataname = "ADSL",+ variables <- selected_vars() |
|
| 83 | +1016 |
- pre_output = NULL,+ } else {
|
|
| 84 | -+ | ||
| 1017 | +! |
- post_output = NULL,+ variables <- colnames(anl) |
|
| 85 | +1018 |
- ggplot2_args = teal.widgets::ggplot2_args()) {
+ } |
|
| 86 | -! | +||
| 1019 | +
- logger::log_info("Initializing tm_variable_browser")
+
|
||
| 87 | +1020 | ! |
- if (!requireNamespace("sparkline", quietly = TRUE)) {
+ summ_fn <- if (input$count_type == "counts") {
|
| 88 | +1021 | ! |
- stop("Cannot load sparkline - please install the package or restart your session.")
+ function(x) sum(is.na(x)) |
| 89 | +1022 |
- }- |
- |
| 90 | -! | -
- if (!requireNamespace("htmlwidgets", quietly = TRUE)) {
+ } else {
|
|
| 91 | +1023 | ! |
- stop("Cannot load htmlwidgets - please install the package or restart your session.")
+ function(x) round(sum(is.na(x)) / length(x), 4) |
| 92 | +1024 |
- }+ } |
|
| 93 | -! | +||
| 1025 | +
- if (!requireNamespace("jsonlite", quietly = TRUE)) {
+
|
||
| 94 | +1026 | ! |
- stop("Cannot load jsonlite - please install the package or restart your session.")
+ qenv <- common_code_q() |
| 95 | +1027 |
- }+ |
|
| 96 | +1028 | ! |
- checkmate::assert_string(label)+ if (!is.null(group_var)) {
|
| 97 | +1029 | ! |
- checkmate::assert_character(datasets_selected)+ qenv <- teal.code::eval_code( |
| 98 | +1030 | ! |
- checkmate::assert_character(parent_dataname, min.len = 0, max.len = 1)+ qenv, |
| 99 | +1031 | ! |
- checkmate::assert_class(ggplot2_args, "ggplot2_args")+ substitute( |
| 100 | +1032 | ! |
- datasets_selected <- unique(datasets_selected)- |
-
| 101 | -- |
-
+ expr = {
|
|
| 102 | +1033 | ! |
- module(+ summary_data <- ANL %>% |
| 103 | +1034 | ! |
- label,+ dplyr::mutate(group_var_name := forcats::fct_na_value_to_level(as.factor(group_var_name), "NA")) %>% |
| 104 | +1035 | ! |
- server = srv_variable_browser,+ dplyr::group_by_at(group_var) %>% |
| 105 | +1036 | ! |
- ui = ui_variable_browser,+ dplyr::filter(group_var_name %in% group_vals) |
| 106 | -! | +||
| 1037 | +
- datanames = "all",+ |
||
| 107 | +1038 | ! |
- server_args = list(+ count_data <- dplyr::summarise(summary_data, n = dplyr::n()) |
| 108 | -! | +||
| 1039 | +
- datasets_selected = datasets_selected,+ |
||
| 109 | +1040 | ! |
- parent_dataname = parent_dataname,+ summary_data <- dplyr::summarise_all(summary_data, summ_fn) %>% |
| 110 | +1041 | ! |
- ggplot2_args = ggplot2_args- |
-
| 111 | -- |
- ),+ dplyr::mutate(group_var_name := paste0(group_var, ":", group_var_name, "(N=", count_data$n, ")")) %>% |
|
| 112 | +1042 | ! |
- ui_args = list(+ tidyr::pivot_longer(!tidyselect::all_of(group_var), names_to = "Variable", values_to = "out") %>% |
| 113 | +1043 | ! |
- pre_output = pre_output,+ tidyr::pivot_wider(names_from = group_var, values_from = "out") %>% |
| 114 | +1044 | ! |
- post_output = post_output+ dplyr::mutate(`Variable label` = create_cols_labels(Variable, just_label = TRUE), .after = Variable) |
| 115 | +1045 |
- )+ }, |
|
| 116 | -+ | ||
| 1046 | +! |
- )+ env = list( |
|
| 117 | -+ | ||
| 1047 | +! |
- }+ group_var = group_var, group_var_name = as.name(group_var), group_vals = group_vals, summ_fn = summ_fn |
|
| 118 | +1048 |
-
+ ) |
|
| 119 | +1049 |
- # ui function+ ) |
|
| 120 | +1050 |
- ui_variable_browser <- function(id,+ ) |
|
| 121 | +1051 |
- pre_output = NULL,+ } else {
|
|
| 122 | -+ | ||
| 1052 | +! |
- post_output = NULL) {
+ qenv <- teal.code::eval_code( |
|
| 123 | +1053 | ! |
- ns <- NS(id)+ qenv, |
| 124 | -+ | ||
| 1054 | +! |
-
+ substitute( |
|
| 125 | +1055 | ! |
- shiny::tagList(+ expr = summary_data <- ANL %>% |
| 126 | +1056 | ! |
- include_css_files("custom"),
+ dplyr::summarise_all(summ_fn) %>% |
| 127 | +1057 | ! |
- shinyjs::useShinyjs(),+ tidyr::pivot_longer(tidyselect::everything(), |
| 128 | +1058 | ! |
- teal.widgets::standard_layout(+ names_to = "Variable", |
| 129 | +1059 | ! |
- output = fluidRow(+ values_to = paste0("Missing (N=", nrow(ANL), ")")
|
| 130 | -! | +||
| 1060 | +
- htmlwidgets::getDependency("sparkline"), # needed for sparklines to work
+ ) %>% |
||
| 131 | +1061 | ! |
- column(+ dplyr::mutate(`Variable label` = create_cols_labels(Variable), .after = Variable), |
| 132 | +1062 | ! |
- 6,+ env = list(summ_fn = summ_fn) |
| 133 | +1063 |
- # variable browser+ ) |
|
| 134 | -! | +||
| 1064 | +
- teal.widgets::white_small_well(+ ) |
||
| 135 | -! | +||
| 1065 | +
- uiOutput(ns("ui_variable_browser")),
+ } |
||
| 136 | -! | +||
| 1066 | +
- shinyjs::hidden({
+
|
||
| 137 | +1067 | ! |
- checkboxInput(ns("show_parent_vars"), "Show parent dataset variables", value = FALSE)
+ teal.code::eval_code(qenv, quote(summary_data)) |
| 138 | +1068 |
- })+ }) |
|
| 139 | +1069 |
- )+ + |
+ |
| 1070 | +! | +
+ summary_table_r <- reactive(summary_table_q()[["summary_data"]]) |
|
| 140 | +1071 |
- ),+ |
|
| 141 | +1072 | ! |
- column(+ by_subject_plot_q <- reactive({
|
| 142 | -! | +||
| 1073 | +
- 6,+ # needed to trigger show r code update on tab change |
||
| 143 | +1074 | ! |
- teal.widgets::white_small_well(+ req(input$summary_type == "Grouped by Subject", common_code_q()) |
| 144 | +1075 |
- ### Reporter+ |
|
| 145 | +1076 | ! |
- teal.reporter::simple_reporter_ui(ns("simple_reporter")),
+ teal::validate_has_data(data_r(), 1) |
| 146 | +1077 |
- ###+ |
|
| 147 | +1078 | ! |
- div(+ dev_ggplot2_args <- teal.widgets::ggplot2_args( |
| 148 | +1079 | ! |
- class = "block",+ labs = list(x = "", y = ""), |
| 149 | +1080 | ! |
- uiOutput(ns("ui_histogram_display"))
+ theme = list(legend.position = "bottom", axis.text.x = quote(element_blank())) |
| 150 | +1081 |
- ),+ )+ |
+ |
| 1082 | ++ | + | |
| 151 | +1083 | ! |
- div(+ all_ggplot2_args <- teal.widgets::resolve_ggplot2_args( |
| 152 | +1084 | ! |
- class = "block",+ user_plot = ggplot2_args[["By Subject"]], |
| 153 | +1085 | ! |
- uiOutput(ns("ui_numeric_display"))
+ user_default = ggplot2_args$default,+ |
+
| 1086 | +! | +
+ module_plot = dev_ggplot2_args |
|
| 154 | +1087 |
- ),+ )+ |
+ |
| 1088 | ++ | + | |
| 155 | +1089 | ! |
- teal.widgets::plot_with_settings_ui(ns("variable_plot")),
+ parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args( |
| 156 | +1090 | ! |
- br(),+ all_ggplot2_args,+ |
+
| 1091 | +! | +
+ ggtheme = input$ggtheme |
|
| 157 | +1092 |
- # input user-defined text size+ ) |
|
| 158 | -! | +||
| 1093 | +
- teal.widgets::panel_item(+ |
||
| 159 | +1094 | ! |
- title = "Plot settings",+ teal.code::eval_code( |
| 160 | +1095 | ! |
- collapsed = TRUE,+ common_code_q(), |
| 161 | +1096 | ! |
- selectInput(+ substitute( |
| 162 | +1097 | ! |
- inputId = ns("ggplot_theme"), label = "ggplot2 theme",
+ expr = parent_keys <- keys, |
| 163 | +1098 | ! |
- choices = ggplot_themes,+ env = list(keys = data_parent_keys()) |
| 164 | -! | +||
| 1099 | +
- selected = "grey"+ ) |
||
| 165 | +1100 |
- ),+ ) %>% |
|
| 166 | +1101 | ! |
- fluidRow(+ teal.code::eval_code( |
| 167 | +1102 | ! |
- column(6, sliderInput(+ substitute( |
| 168 | +1103 | ! |
- inputId = ns("font_size"), label = "font size",
+ expr = analysis_vars <- setdiff(colnames(ANL), data_keys), |
| 169 | +1104 | ! |
- min = 5L, max = 30L, value = 15L, step = 1L, ticks = FALSE+ env = list(data_keys = data_keys()) |
| 170 | +1105 |
- )),+ )+ |
+ |
| 1106 | ++ |
+ ) %>% |
|
| 171 | +1107 | ! |
- column(6, sliderInput(+ teal.code::eval_code( |
| 172 | +1108 | ! |
- inputId = ns("label_rotation"), label = "rotate x labels",
+ quote({
|
| 173 | +1109 | ! |
- min = 0L, max = 90L, value = 45L, step = 1, ticks = FALSE+ summary_plot_patients <- ANL[, c(parent_keys, analysis_vars)] %>% |
| 174 | -+ | ||
| 1110 | +! |
- ))+ dplyr::group_by_at(parent_keys) %>% |
|
| 175 | -+ | ||
| 1111 | +! |
- )+ dplyr::mutate(id = dplyr::cur_group_id()) %>% |
|
| 176 | -+ | ||
| 1112 | +! |
- ),+ dplyr::ungroup() %>% |
|
| 177 | +1113 | ! |
- br(),+ dplyr::group_by_at(c(parent_keys, "id")) %>% |
| 178 | +1114 | ! |
- teal.widgets::get_dt_rows(ns("variable_summary_table"), ns("variable_summary_table_rows")),
+ dplyr::summarise_all(anyNA) %>% |
| 179 | +1115 | ! |
- DT::dataTableOutput(ns("variable_summary_table"))
+ dplyr::ungroup() |
| 180 | +1116 |
- )+ |
|
| 181 | +1117 |
- )+ # order subjects by decreasing number of missing and then by |
|
| 182 | +1118 |
- ),+ # missingness pattern (defined using sha1) |
|
| 183 | +1119 | ! |
- pre_output = pre_output,+ order_subjects <- summary_plot_patients %>% |
| 184 | +1120 | ! |
- post_output = post_output+ dplyr::select(-"id", -tidyselect::all_of(parent_keys)) %>% |
| 185 | -+ | ||
| 1121 | +! |
- )+ dplyr::transmute( |
|
| 186 | -+ | ||
| 1122 | +! |
- )+ id = dplyr::row_number(), |
|
| 187 | -+ | ||
| 1123 | +! |
- }+ number_NA = apply(., 1, sum), |
|
| 188 | -+ | ||
| 1124 | +! |
-
+ sha = apply(., 1, rlang::hash) |
|
| 189 | +1125 |
- srv_variable_browser <- function(id,+ ) %>% |
|
| 190 | -+ | ||
| 1126 | +! |
- data,+ dplyr::arrange(dplyr::desc(number_NA), sha) %>% |
|
| 191 | -+ | ||
| 1127 | +! |
- reporter,+ getElement(name = "id") |
|
| 192 | +1128 |
- filter_panel_api,+ |
|
| 193 | +1129 |
- datasets_selected, parent_dataname, ggplot2_args) {
- |
- |
| 194 | -! | -
- with_reporter <- !missing(reporter) && inherits(reporter, "Reporter")+ # order columns by decreasing percent of missing values |
|
| 195 | +1130 | ! |
- with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI")+ ordered_columns <- summary_plot_patients %>% |
| 196 | +1131 | ! |
- checkmate::assert_class(data, "reactive")+ dplyr::select(-"id", -tidyselect::all_of(parent_keys)) %>% |
| 197 | +1132 | ! |
- checkmate::assert_class(isolate(data()), "teal_data")+ dplyr::summarise( |
| 198 | +1133 | ! |
- moduleServer(id, function(input, output, session) {
- |
-
| 199 | -- |
- # if there are < this number of unique records then a numeric- |
- |
| 200 | -- |
- # variable can be treated as a factor and all factors with < this groups- |
- |
| 201 | -- |
- # have their values plotted+ column = create_cols_labels(colnames(.)), |
|
| 202 | +1134 | ! |
- .unique_records_for_factor <- 30+ na_count = apply(., MARGIN = 2, FUN = sum), |
| 203 | -+ | ||
| 1135 | +! |
- # if there are < this number of unique records then a numeric+ na_percent = na_count / nrow(.) * 100 |
|
| 204 | +1136 |
- # variable is by default treated as a factor+ ) %>% |
|
| 205 | +1137 | ! |
- .unique_records_default_as_factor <- 6 # nolint: object_length.+ dplyr::arrange(na_percent, dplyr::desc(column)) |
| 206 | +1138 | ||
| 207 | +1139 | ! |
- datanames <- isolate(teal.data::datanames(data()))+ summary_plot_patients <- summary_plot_patients %>% |
| 208 | +1140 | ! |
- datanames <- Filter(function(name) {
+ tidyr::gather("col", "isna", -"id", -tidyselect::all_of(parent_keys)) %>%
|
| 209 | +1141 | ! |
- is.data.frame(isolate(data())[[name]])+ dplyr::mutate(col = create_cols_labels(col)) |
| 210 | -! | +||
| 1142 | +
- }, datanames)+ }) |
||
| 211 | +1143 |
-
+ ) %>% |
|
| 212 | +1144 | ! |
- checkmate::assert_character(datasets_selected)+ teal.code::eval_code( |
| 213 | +1145 | ! |
- checkmate::assert_subset(datasets_selected, datanames)+ substitute( |
| 214 | +1146 | ! |
- if (!identical(datasets_selected, character(0))) {
+ expr = {
|
| 215 | +1147 | ! |
- checkmate::assert_subset(datasets_selected, datanames)+ g <- ggplot(summary_plot_patients, aes( |
| 216 | +1148 | ! |
- datanames <- datasets_selected- |
-
| 217 | -- |
- }+ x = factor(id, levels = order_subjects), |
|
| 218 | -+ | ||
| 1149 | +! |
-
+ y = factor(col, levels = ordered_columns[["column"]]), |
|
| 219 | +1150 | ! |
- output$ui_variable_browser <- renderUI({
+ fill = isna |
| 220 | -! | +||
| 1151 | +
- ns <- session$ns+ )) + |
||
| 221 | +1152 | ! |
- do.call(+ geom_raster() + |
| 222 | +1153 | ! |
- tabsetPanel,+ annotate( |
| 223 | +1154 | ! |
- c(+ "text", |
| 224 | +1155 | ! |
- id = ns("tabset_panel"),
+ x = length(order_subjects), |
| 225 | +1156 | ! |
- do.call(+ y = seq_len(nrow(ordered_columns)), |
| 226 | +1157 | ! |
- tagList,+ hjust = 1, |
| 227 | +1158 | ! |
- lapply(datanames, function(dataname) {
+ label = sprintf("%d [%.02f%%]", ordered_columns[["na_count"]], ordered_columns[["na_percent"]])
|
| 228 | -! | +||
| 1159 | +
- tabPanel(+ ) + |
||
| 229 | +1160 | ! |
- dataname,+ scale_fill_manual( |
| 230 | +1161 | ! |
- div(+ name = "", |
| 231 | +1162 | ! |
- class = "mt-4",+ values = c("grey90", c(getOption("ggplot2.discrete.colour")[2], "#ff2951ff")[1]),
|
| 232 | +1163 | ! |
- textOutput(ns(paste0("dataset_summary_", dataname)))
+ labels = c("Present", "Missing (at least one)")
|
| 233 | +1164 |
- ),+ ) + |
|
| 234 | +1165 | ! |
- div(+ labs + |
| 235 | +1166 | ! |
- class = "mt-4",+ ggthemes + |
| 236 | +1167 | ! |
- teal.widgets::get_dt_rows(+ themes |
| 237 | +1168 | ! |
- ns(paste0("variable_browser_", dataname)),
+ print(g) |
| 238 | -! | +||
| 1169 | +
- ns(paste0("variable_browser_", dataname, "_rows"))
+ }, |
||
| 239 | -+ | ||
| 1170 | +! |
- ),+ env = list( |
|
| 240 | +1171 | ! |
- DT::dataTableOutput(ns(paste0("variable_browser_", dataname)), width = "100%")
+ labs = parsed_ggplot2_args$labs, |
| 241 | -+ | ||
| 1172 | +! |
- )+ themes = parsed_ggplot2_args$theme, |
|
| 242 | -+ | ||
| 1173 | +! |
- )+ ggthemes = parsed_ggplot2_args$ggtheme |
|
| 243 | +1174 |
- })+ ) |
|
| 244 | +1175 |
) |
|
| 245 | +1176 |
) |
|
| 246 | +1177 |
- )+ }) |
|
| 247 | +1178 |
- })+ |
|
| 248 | -+ | ||
| 1179 | +! |
-
+ by_subject_plot_r <- reactive(by_subject_plot_q()[["g"]]) |
|
| 249 | +1180 |
- # conditionally display checkbox+ |
|
| 250 | +1181 | ! |
- shinyjs::toggle(+ output$levels_table <- DT::renderDataTable( |
| 251 | +1182 | ! |
- id = "show_parent_vars",+ expr = {
|
| 252 | +1183 | ! |
- condition = length(parent_dataname) > 0 && parent_dataname %in% datanames+ if (length(input$variables_select) == 0) {
|
| 253 | +1184 |
- )+ # so that zeroRecords message gets printed |
|
| 254 | +1185 |
-
+ # using tibble as it supports weird column names, such as " " |
|
| 255 | +1186 | ! |
- columns_names <- new.env()+ tibble::tibble(` ` = logical(0)) |
| 256 | +1187 |
-
+ } else {
|
|
| 257 | -+ | ||
| 1188 | +! |
- # plot_var$data holds the name of the currently selected dataset+ summary_table_r() |
|
| 258 | +1189 |
- # plot_var$variable[[<dataset_name>]] holds the name of the currently selected+ } |
|
| 259 | +1190 |
- # variable for dataset <dataset_name>+ }, |
|
| 260 | +1191 | ! |
- plot_var <- reactiveValues(data = NULL, variable = list())+ options = list(language = list(zeroRecords = "No variable selected"), pageLength = input$levels_table_rows) |
| 261 | +1192 | ++ |
+ )+ |
+
| 1193 | |||
| 262 | +1194 | ! |
- establish_updating_selection(datanames, input, plot_var, columns_names)+ pws1 <- teal.widgets::plot_with_settings_srv( |
| 263 | -+ | ||
| 1195 | +! |
-
+ id = "summary_plot", |
|
| 264 | -+ | ||
| 1196 | +! |
- # validations+ plot_r = summary_plot_r, |
|
| 265 | +1197 | ! |
- validation_checks <- validate_input(input, plot_var, data)+ height = plot_height,+ |
+
| 1198 | +! | +
+ width = plot_width |
|
| 266 | +1199 |
-
+ ) |
|
| 267 | +1200 |
- # data_for_analysis is a list with two elements: a column from a dataset and the column label+ |
|
| 268 | +1201 | ! |
- plotted_data <- reactive({
+ pws2 <- teal.widgets::plot_with_settings_srv( |
| 269 | +1202 | ! |
- validation_checks()+ id = "combination_plot", |
| 270 | -+ | ||
| 1203 | +! |
-
+ plot_r = combination_plot_r, |
|
| 271 | +1204 | ! |
- get_plotted_data(input, plot_var, data)+ height = plot_height,+ |
+
| 1205 | +! | +
+ width = plot_width |
|
| 272 | +1206 |
- })+ ) |
|
| 273 | +1207 | ||
| 274 | +1208 | ! |
- treat_numeric_as_factor <- reactive({
+ pws3 <- teal.widgets::plot_with_settings_srv( |
| 275 | +1209 | ! |
- if (is_num_var_short(.unique_records_for_factor, input, plotted_data)) {
+ id = "by_subject_plot", |
| 276 | +1210 | ! |
- input$numeric_as_factor- |
-
| 277 | -- |
- } else {
+ plot_r = by_subject_plot_r, |
|
| 278 | +1211 | ! |
- FALSE+ height = plot_height, |
| 279 | -+ | ||
| 1212 | +! |
- }+ width = plot_width |
|
| 280 | +1213 |
- })+ ) |
|
| 281 | +1214 | ||
| 282 | -! | -
- render_tabset_panel_content(- |
- |
| 283 | +1215 | ! |
- input = input,+ final_q <- reactive({
|
| 284 | +1216 | ! |
- output = output,+ req(input$summary_type) |
| 285 | +1217 | ! |
- data = data,+ sum_type <- input$summary_type |
| 286 | +1218 | ! |
- datanames = datanames,+ if (sum_type == "Summary") {
|
| 287 | +1219 | ! |
- parent_dataname = parent_dataname,+ summary_plot_q() |
| 288 | +1220 | ! |
- columns_names = columns_names,+ } else if (sum_type == "Combinations") {
|
| 289 | +1221 | ! |
- plot_var = plot_var- |
-
| 290 | -- |
- )- |
- |
| 291 | -- |
- # add used-defined text size to ggplot arguments passed from caller frame+ combination_plot_q() |
|
| 292 | +1222 | ! |
- all_ggplot2_args <- reactive({
+ } else if (sum_type == "By Variable Levels") {
|
| 293 | +1223 | ! |
- user_text <- teal.widgets::ggplot2_args(+ summary_table_q() |
| 294 | +1224 | ! |
- theme = list(+ } else if (sum_type == "Grouped by Subject") {
|
| 295 | +1225 | ! |
- "text" = ggplot2::element_text(size = input[["font_size"]]),+ by_subject_plot_q() |
| 296 | -! | +||
| 1226 | +
- "axis.text.x" = ggplot2::element_text(angle = input[["label_rotation"]], hjust = 1)+ } |
||
| 297 | +1227 |
- )+ }) |
|
| 298 | +1228 |
- )+ |
|
| 299 | +1229 | ! |
- user_theme <- utils::getFromNamespace(sprintf("theme_%s", input[["ggplot_theme"]]), ns = "ggplot2")
+ teal.widgets::verbatim_popup_srv( |
| 300 | +1230 | ! |
- user_theme <- user_theme()+ id = "warning", |
| 301 | -+ | ||
| 1231 | +! |
- # temporary fix to circumvent assertion issue with resolve_ggplot2_args+ verbatim_content = reactive(teal.code::get_warnings(final_q())), |
|
| 302 | -+ | ||
| 1232 | +! |
- # drop problematic elements+ title = "Warning", |
|
| 303 | +1233 | ! |
- user_theme <- user_theme[grep("strip.text.y.left", names(user_theme), fixed = TRUE, invert = TRUE)]
+ disabled = reactive(is.null(teal.code::get_warnings(final_q()))) |
| 304 | +1234 | ++ |
+ )+ |
+
| 1235 | |||
| 305 | +1236 | ! |
- teal.widgets::resolve_ggplot2_args(+ teal.widgets::verbatim_popup_srv( |
| 306 | +1237 | ! |
- user_plot = user_text,+ id = "rcode", |
| 307 | +1238 | ! |
- user_default = teal.widgets::ggplot2_args(theme = user_theme),+ verbatim_content = reactive(teal.code::get_code(final_q())), |
| 308 | +1239 | ! |
- module_plot = ggplot2_args+ title = "Show R Code for Missing Data" |
| 309 | +1240 |
- )+ ) |
|
| 310 | +1241 |
- })+ |
|
| 311 | +1242 |
-
+ ### REPORTER |
|
| 312 | +1243 | ! |
- output$ui_numeric_display <- renderUI({
+ if (with_reporter) {
|
| 313 | +1244 | ! |
- validation_checks()+ card_fun <- function(comment, label) {
|
| 314 | +1245 | ! |
- dataname <- input$tabset_panel+ card <- teal::TealReportCard$new() |
| 315 | +1246 | ! |
- varname <- plot_var$variable[[dataname]]+ sum_type <- input$summary_type |
| 316 | +1247 | ! |
- df <- data()[[dataname]]+ title <- if (sum_type == "By Variable Levels") paste0(sum_type, " Table") else paste0(sum_type, " Plot") |
| 317 | -+ | ||
| 1248 | +! |
-
+ title_dataname <- paste(title, dataname, sep = " - ") |
|
| 318 | +1249 | ! |
- numeric_ui <- tagList(+ label <- if (label == "") {
|
| 319 | +1250 | ! |
- fluidRow(+ paste("Missing Data", sum_type, dataname, sep = " - ")
|
| 320 | -! | +||
| 1251 | +
- div(+ } else {
|
||
| 321 | +1252 | ! |
- class = "col-md-4",+ label |
| 322 | -! | +||
| 1253 | +
- br(),+ } |
||
| 323 | +1254 | ! |
- shinyWidgets::switchInput(+ card$set_name(label) |
| 324 | +1255 | ! |
- inputId = session$ns("display_density"),
+ card$append_text(title_dataname, "header2") |
| 325 | +1256 | ! |
- label = "Show density",+ if (with_filter) card$append_fs(filter_panel_api$get_filter_state()) |
| 326 | +1257 | ! |
- value = `if`(is.null(isolate(input$display_density)), TRUE, isolate(input$display_density)),+ if (sum_type == "Summary") {
|
| 327 | +1258 | ! |
- width = "50%",+ card$append_text("Plot", "header3")
|
| 328 | +1259 | ! |
- labelWidth = "100px",+ card$append_plot(summary_plot_r(), dim = pws1$dim()) |
| 329 | +1260 | ! |
- handleWidth = "50px"+ } else if (sum_type == "Combinations") {
|
| 330 | -+ | ||
| 1261 | +! |
- )+ card$append_text("Plot", "header3")
|
|
| 331 | -+ | ||
| 1262 | +! |
- ),+ card$append_plot(combination_plot_r(), dim = pws2$dim()) |
|
| 332 | +1263 | ! |
- div(+ } else if (sum_type == "By Variable Levels") {
|
| 333 | +1264 | ! |
- class = "col-md-4",+ card$append_text("Table", "header3")
|
| 334 | +1265 | ! |
- br(),+ card$append_table(summary_table_r[["summary_data"]]) |
| 335 | +1266 | ! |
- shinyWidgets::switchInput(+ } else if (sum_type == "Grouped by Subject") {
|
| 336 | +1267 | ! |
- inputId = session$ns("remove_outliers"),
+ card$append_text("Plot", "header3")
|
| 337 | +1268 | ! |
- label = "Remove outliers",+ card$append_plot(by_subject_plot_r(), dim = pws3$dim()) |
| 338 | -! | +||
| 1269 | +
- value = `if`(is.null(isolate(input$remove_outliers)), FALSE, isolate(input$remove_outliers)),+ } |
||
| 339 | +1270 | ! |
- width = "50%",+ if (!comment == "") {
|
| 340 | +1271 | ! |
- labelWidth = "100px",+ card$append_text("Comment", "header3")
|
| 341 | +1272 | ! |
- handleWidth = "50px"+ card$append_text(comment) |
| 342 | +1273 |
- )+ } |
|
| 343 | -+ | ||
| 1274 | +! |
- ),+ card$append_src(teal.code::get_code(final_q())) |
|
| 344 | +1275 | ! |
- div(+ card |
| 345 | -! | +||
| 1276 | +
- class = "col-md-4",+ } |
||
| 346 | +1277 | ! |
- uiOutput(session$ns("outlier_definition_slider_ui"))
+ teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
|
| 347 | +1278 |
- )+ } |
|
| 348 | +1279 |
- ),- |
- |
| 349 | -! | -
- div(- |
- |
| 350 | -! | -
- class = "ml-4",+ ### |
|
| 351 | -! | +||
| 1280 | +
- uiOutput(session$ns("ui_density_help")),
+ }) |
||
| 352 | -! | +||
| 1281 | +
- uiOutput(session$ns("ui_outlier_help"))
+ } |
| 353 | +1 |
- )+ #' Variable Browser Teal Module |
|
| 354 | +2 |
- )+ #' |
|
| 355 | +3 |
-
+ #' The variable browser provides a table with variable names and labels and a |
|
| 356 | -! | +||
| 4 | +
- if (is.numeric(df[[varname]])) {
+ #' plot that visualizes the content of a particular variable. |
||
| 357 | -! | +||
| 5 | +
- unique_entries <- length(unique(df[[varname]]))+ #' specifically designed for use with `data.frames`. |
||
| 358 | -! | +||
| 6 | +
- if (unique_entries < .unique_records_for_factor && unique_entries > 0) {
+ #' |
||
| 359 | -! | +||
| 7 | +
- list(+ #' @details Numeric columns with fewer than 30 distinct values can be treated as either factors |
||
| 360 | -! | +||
| 8 | +
- checkboxInput(+ #' or numbers with a checkbox allowing users to switch how they are treated (if < 6 unique values |
||
| 361 | -! | +||
| 9 | +
- session$ns("numeric_as_factor"),
+ #' then the default is categorical, otherwise it is numeric). |
||
| 362 | -! | +||
| 10 | +
- "Treat variable as factor",+ #' |
||
| 363 | -! | +||
| 11 | +
- value = `if`(+ #' @inheritParams teal::module |
||
| 364 | -! | +||
| 12 | +
- is.null(isolate(input$numeric_as_factor)),+ #' @inheritParams shared_params |
||
| 365 | -! | +||
| 13 | +
- unique_entries < .unique_records_default_as_factor,+ #' @param parent_dataname (`character(1)`) If this `dataname` exists in `datasets_selected` |
||
| 366 | -! | +||
| 14 | +
- isolate(input$numeric_as_factor)+ #' then an extra checkbox will be shown to allow users to not show variables in other datasets |
||
| 367 | +15 |
- )+ #' which exist in this `dataname`. |
|
| 368 | +16 |
- ),+ #' This is typically used to remove `ADSL` columns in `CDISC` data. In non `CDISC` data this |
|
| 369 | -! | +||
| 17 | +
- conditionalPanel("!input.numeric_as_factor", ns = session$ns, numeric_ui)
+ #' can be ignored. Defaults to `"ADSL"`. |
||
| 370 | +18 |
- )+ #' @param datasets_selected (`character`) A vector of datasets which should be |
|
| 371 | -! | +||
| 19 | +
- } else if (unique_entries > 0) {
+ #' shown and in what order. Names in the vector have to correspond with datasets names. |
||
| 372 | -! | +||
| 20 | +
- numeric_ui+ #' If vector of length zero (default) then all datasets are shown. |
||
| 373 | +21 |
- }+ #' Note: Only datasets of the `data.frame` class are compatible; using other types will cause an error. |
|
| 374 | +22 |
- } else {
+ #' |
|
| 375 | -! | +||
| 23 | +
- NULL+ #' @aliases |
||
| 376 | +24 |
- }+ #' tm_variable_browser_ui, |
|
| 377 | +25 |
- })+ #' tm_variable_browser_srv, |
|
| 378 | +26 |
-
+ #' tm_variable_browser, |
|
| 379 | -! | +||
| 27 | +
- output$ui_histogram_display <- renderUI({
+ #' variable_browser_ui, |
||
| 380 | -! | +||
| 28 | +
- validation_checks()+ #' variable_browser_srv, |
||
| 381 | -! | +||
| 29 | +
- dataname <- input$tabset_panel+ #' variable_browser |
||
| 382 | -! | +||
| 30 | +
- varname <- plot_var$variable[[dataname]]+ #' |
||
| 383 | -! | +||
| 31 | +
- df <- data()[[dataname]]+ #' @examples |
||
| 384 | +32 |
-
+ #' library(teal.widgets) |
|
| 385 | -! | +||
| 33 | +
- numeric_ui <- tagList(fluidRow(+ #' |
||
| 386 | -! | +||
| 34 | +
- div(+ #' # module specification used in apps below |
||
| 387 | -! | +||
| 35 | +
- class = "col-md-4",+ #' tm_variable_browser_module <- tm_variable_browser( |
||
| 388 | -! | +||
| 36 | +
- shinyWidgets::switchInput(+ #' label = "Variable browser", |
||
| 389 | -! | +||
| 37 | +
- inputId = session$ns("remove_NA_hist"),
+ #' ggplot2_args = ggplot2_args( |
||
| 390 | -! | +||
| 38 | +
- label = "Remove NA values",+ #' labs = list(subtitle = "Plot generated by Variable Browser Module") |
||
| 391 | -! | +||
| 39 | +
- value = FALSE,+ #' ) |
||
| 392 | -! | +||
| 40 | +
- width = "50%",+ #' ) |
||
| 393 | -! | +||
| 41 | +
- labelWidth = "100px",+ #' |
||
| 394 | -! | +||
| 42 | +
- handleWidth = "50px"+ #' # general data example |
||
| 395 | +43 |
- )+ #' data <- teal_data() |
|
| 396 | +44 |
- )+ #' data <- within(data, {
|
|
| 397 | +45 |
- ))+ #' iris <- iris |
|
| 398 | +46 |
-
+ #' mtcars <- mtcars |
|
| 399 | -! | +||
| 47 | +
- var <- df[[varname]]+ #' women <- women |
||
| 400 | -! | +||
| 48 | +
- if (anyNA(var) && (is.factor(var) || is.character(var) || is.logical(var))) {
+ #' faithful <- faithful |
||
| 401 | -! | +||
| 49 | +
- groups <- unique(as.character(var))+ #' CO2 <- CO2 |
||
| 402 | -! | +||
| 50 | +
- len_groups <- length(groups)+ #' }) |
||
| 403 | -! | +||
| 51 | +
- if (len_groups >= .unique_records_for_factor) {
+ #' datanames(data) <- c("iris", "mtcars", "women", "faithful", "CO2")
|
||
| 404 | -! | +||
| 52 | +
- NULL+ #' |
||
| 405 | +53 |
- } else {
+ #' app <- init( |
|
| 406 | -! | +||
| 54 | +
- numeric_ui+ #' data = data, |
||
| 407 | +55 |
- }+ #' modules = modules(tm_variable_browser_module) |
|
| 408 | +56 |
- } else {
+ #' ) |
|
| 409 | -! | +||
| 57 | +
- NULL+ #' if (interactive()) {
|
||
| 410 | +58 |
- }+ #' shinyApp(app$ui, app$server) |
|
| 411 | +59 |
- })+ #' } |
|
| 412 | +60 |
-
+ #' |
|
| 413 | -! | +||
| 61 | +
- output$outlier_definition_slider_ui <- renderUI({
+ #' # CDISC example data |
||
| 414 | -! | +||
| 62 | +
- req(input$remove_outliers)+ #' data <- teal_data() |
||
| 415 | -! | +||
| 63 | +
- sliderInput(+ #' data <- within(data, {
|
||
| 416 | -! | +||
| 64 | +
- inputId = session$ns("outlier_definition_slider"),
+ #' ADSL <- rADSL |
||
| 417 | -! | +||
| 65 | +
- div(+ #' ADTTE <- rADTTE |
||
| 418 | -! | +||
| 66 | +
- class = "teal-tooltip",+ #' }) |
||
| 419 | -! | +||
| 67 | +
- tagList(+ #' datanames(data) <- c("ADSL", "ADTTE")
|
||
| 420 | -! | +||
| 68 | +
- "Outlier definition:",+ #' join_keys(data) <- default_cdisc_join_keys[datanames(data)] |
||
| 421 | -! | +||
| 69 | +
- icon("circle-info"),
+ #' |
||
| 422 | -! | +||
| 70 | +
- span(+ #' app <- init( |
||
| 423 | -! | +||
| 71 | +
- class = "tooltiptext",+ #' data = data, |
||
| 424 | -! | +||
| 72 | +
- paste(+ #' modules = modules(tm_variable_browser_module) |
||
| 425 | -! | +||
| 73 | +
- "Use the slider to choose the cut-off value to define outliers; the larger the value the",+ #' ) |
||
| 426 | -! | +||
| 74 | +
- "further below Q1/above Q3 points have to be in order to be classed as outliers"+ #' if (interactive()) {
|
||
| 427 | +75 |
- )+ #' shinyApp(app$ui, app$server) |
|
| 428 | +76 |
- )+ #' } |
|
| 429 | +77 |
- )+ #' |
|
| 430 | +78 |
- ),+ #' @export |
|
| 431 | -! | +||
| 79 | +
- min = 1,+ #' |
||
| 432 | -! | +||
| 80 | +
- max = 5,+ tm_variable_browser <- function(label = "Variable Browser", |
||
| 433 | -! | +||
| 81 | +
- value = 3,+ datasets_selected = character(0), |
||
| 434 | -! | +||
| 82 | +
- step = 0.5+ parent_dataname = "ADSL", |
||
| 435 | +83 |
- )+ pre_output = NULL, |
|
| 436 | +84 |
- })+ post_output = NULL, |
|
| 437 | +85 |
-
+ ggplot2_args = teal.widgets::ggplot2_args()) {
|
|
| 438 | +86 | ! |
- output$ui_density_help <- renderUI({
+ logger::log_info("Initializing tm_variable_browser")
|
| 439 | +87 | ! |
- req(is.logical(input$display_density))+ if (!requireNamespace("sparkline", quietly = TRUE)) {
|
| 440 | +88 | ! |
- if (input$display_density) {
+ stop("Cannot load sparkline - please install the package or restart your session.")
|
| 441 | -! | +||
| 89 | +
- tags$small(helpText(paste(+ } |
||
| 442 | +90 | ! |
- "Kernel density estimation with gaussian kernel",+ if (!requireNamespace("htmlwidgets", quietly = TRUE)) {
|
| 443 | +91 | ! |
- "and bandwidth function bw.nrd0 (R default)"- |
-
| 444 | -- |
- )))+ stop("Cannot load htmlwidgets - please install the package or restart your session.")
|
|
| 445 | +92 |
- } else {
+ } |
|
| 446 | +93 | ! |
- NULL- |
-
| 447 | -- |
- }+ if (!requireNamespace("jsonlite", quietly = TRUE)) {
|
|
| 448 | -+ | ||
| 94 | +! |
- })+ stop("Cannot load jsonlite - please install the package or restart your session.")
|
|
| 449 | +95 |
-
+ } |
|
| 450 | +96 | ! |
- output$ui_outlier_help <- renderUI({
+ checkmate::assert_string(label) |
| 451 | +97 | ! |
- req(is.logical(input$remove_outliers), input$outlier_definition_slider)+ checkmate::assert_character(datasets_selected) |
| 452 | +98 | ! |
- if (input$remove_outliers) {
+ checkmate::assert_character(parent_dataname, min.len = 0, max.len = 1) |
| 453 | +99 | ! |
- tags$small(+ checkmate::assert_class(ggplot2_args, "ggplot2_args") |
| 454 | +100 | ! |
- helpText(+ datasets_selected <- unique(datasets_selected) |
| 455 | -! | +||
| 101 | +
- withMathJax(paste0(+ |
||
| 456 | +102 | ! |
- "Outlier data points (\\( X \\lt Q1 - ", input$outlier_definition_slider, "\\times IQR \\) or+ module( |
| 457 | +103 | ! |
- \\(Q3 + ", input$outlier_definition_slider, "\\times IQR \\lt X\\))+ label, |
| 458 | +104 | ! |
- have not been displayed on the graph and will not be used for any kernel density estimations, ",+ server = srv_variable_browser, |
| 459 | +105 | ! |
- "although their values remain in the statisics table below."- |
-
| 460 | -- |
- ))- |
- |
| 461 | -- |
- )- |
- |
| 462 | -- |
- )+ ui = ui_variable_browser, |
|
| 463 | -+ | ||
| 106 | +! |
- } else {
+ datanames = "all", |
|
| 464 | +107 | ! |
- NULL+ server_args = list( |
| 465 | -+ | ||
| 108 | +! |
- }+ datasets_selected = datasets_selected, |
|
| 466 | -+ | ||
| 109 | +! |
- })+ parent_dataname = parent_dataname, |
|
| 467 | -+ | ||
| 110 | +! |
-
+ ggplot2_args = ggplot2_args |
|
| 468 | +111 |
-
+ ), |
|
| 469 | +112 | ! |
- variable_plot_r <- reactive({
+ ui_args = list( |
| 470 | +113 | ! |
- display_density <- `if`(is.null(input$display_density), FALSE, input$display_density)+ pre_output = pre_output, |
| 471 | +114 | ! |
- remove_outliers <- `if`(is.null(input$remove_outliers), FALSE, input$remove_outliers)+ post_output = post_output |
| 472 | +115 | - - | -|
| 473 | -! | -
- if (remove_outliers) {
+ ) |
|
| 474 | -! | +||
| 116 | +
- req(input$outlier_definition_slider)+ ) |
||
| 475 | -! | +||
| 117 | +
- outlier_definition <- as.numeric(input$outlier_definition_slider)+ } |
||
| 476 | +118 |
- } else {
+
|
|
| 477 | -! | +||
| 119 | +
- outlier_definition <- 0+ # ui function |
||
| 478 | +120 |
- }+ ui_variable_browser <- function(id, |
|
| 479 | +121 |
-
+ pre_output = NULL, |
|
| 480 | -! | +||
| 122 | +
- plot_var_summary(+ post_output = NULL) {
|
||
| 481 | +123 | ! |
- var = plotted_data()$data,+ ns <- NS(id) |
| 482 | -! | +||
| 124 | +
- var_lab = plotted_data()$var_description,+ |
||
| 483 | +125 | ! |
- wrap_character = 15,+ shiny::tagList( |
| 484 | +126 | ! |
- numeric_as_factor = treat_numeric_as_factor(),+ include_css_files("custom"),
|
| 485 | +127 | ! |
- remove_NA_hist = input$remove_NA_hist,+ shinyjs::useShinyjs(), |
| 486 | +128 | ! |
- display_density = display_density,+ teal.widgets::standard_layout( |
| 487 | +129 | ! |
- outlier_definition = outlier_definition,+ output = fluidRow( |
| 488 | +130 | ! |
- records_for_factor = .unique_records_for_factor,+ htmlwidgets::getDependency("sparkline"), # needed for sparklines to work
|
| 489 | +131 | ! |
- ggplot2_args = all_ggplot2_args()- |
-
| 490 | -- |
- )+ column( |
|
| 491 | -+ | ||
| 132 | +! |
- })+ 6, |
|
| 492 | +133 |
-
+ # variable browser |
|
| 493 | +134 | ! |
- pws <- teal.widgets::plot_with_settings_srv(+ teal.widgets::white_small_well( |
| 494 | +135 | ! |
- id = "variable_plot",+ uiOutput(ns("ui_variable_browser")),
|
| 495 | +136 | ! |
- plot_r = variable_plot_r,+ shinyjs::hidden({
|
| 496 | +137 | ! |
- height = c(500, 200, 2000)+ checkboxInput(ns("show_parent_vars"), "Show parent dataset variables", value = FALSE)
|
| 497 | +138 |
- )+ }) |
|
| 498 | +139 |
-
+ ) |
|
| 499 | -! | +||
| 140 | +
- output$variable_summary_table <- DT::renderDataTable({
+ ), |
||
| 500 | +141 | ! |
- var_summary_table(+ column( |
| 501 | +142 | ! |
- plotted_data()$data,+ 6, |
| 502 | +143 | ! |
- treat_numeric_as_factor(),+ teal.widgets::white_small_well( |
| 503 | -! | +||
| 144 | +
- input$variable_summary_table_rows,+ ### Reporter |
||
| 504 | +145 | ! |
- if (!is.null(input$remove_outliers) && input$remove_outliers) {
+ teal.reporter::simple_reporter_ui(ns("simple_reporter")),
|
| 505 | -! | +||
| 146 | +
- req(input$outlier_definition_slider)+ ### |
||
| 506 | +147 | ! |
- as.numeric(input$outlier_definition_slider)+ div( |
| 507 | -+ | ||
| 148 | +! |
- } else {
+ class = "block", |
|
| 508 | +149 | ! |
- 0+ uiOutput(ns("ui_histogram_display"))
|
| 509 | +150 |
- }+ ), |
|
| 510 | -+ | ||
| 151 | +! |
- )+ div( |
|
| 511 | -+ | ||
| 152 | +! |
- })+ class = "block", |
|
| 512 | -+ | ||
| 153 | +! |
-
+ uiOutput(ns("ui_numeric_display"))
|
|
| 513 | +154 |
- ### REPORTER- |
- |
| 514 | -! | -
- if (with_reporter) {
+ ), |
|
| 515 | +155 | ! |
- card_fun <- function(comment) {
+ teal.widgets::plot_with_settings_ui(ns("variable_plot")),
|
| 516 | +156 | ! |
- card <- teal::TealReportCard$new()+ br(), |
| 517 | -! | +||
| 157 | +
- card$set_name("Variable Browser Plot")
+ # input user-defined text size |
||
| 518 | +158 | ! |
- card$append_text("Variable Browser Plot", "header2")
+ teal.widgets::panel_item( |
| 519 | +159 | ! |
- if (with_filter) card$append_fs(filter_panel_api$get_filter_state())+ title = "Plot settings", |
| 520 | +160 | ! |
- card$append_text("Plot", "header3")
+ collapsed = TRUE, |
| 521 | +161 | ! |
- card$append_plot(variable_plot_r(), dim = pws$dim())+ selectInput( |
| 522 | +162 | ! |
- if (!comment == "") {
+ inputId = ns("ggplot_theme"), label = "ggplot2 theme",
|
| 523 | +163 | ! |
- card$append_text("Comment", "header3")
+ choices = ggplot_themes, |
| 524 | +164 | ! |
- card$append_text(comment)+ selected = "grey" |
| 525 | +165 |
- }+ ), |
|
| 526 | +166 | ! |
- card- |
-
| 527 | -- |
- }+ fluidRow( |
|
| 528 | +167 | ! |
- teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
- |
-
| 529 | -- |
- }- |
- |
| 530 | -- |
- ###- |
- |
| 531 | -- |
- })+ column(6, sliderInput( |
|
| 532 | -+ | ||
| 168 | +! |
- }+ inputId = ns("font_size"), label = "font size",
|
|
| 533 | -+ | ||
| 169 | +! |
-
+ min = 5L, max = 30L, value = 15L, step = 1L, ticks = FALSE |
|
| 534 | +170 |
- #' Summarizes missings occurrence+ )), |
|
| 535 | -+ | ||
| 171 | +! |
- #'+ column(6, sliderInput( |
|
| 536 | -+ | ||
| 172 | +! |
- #' Summarizes missings occurrence in vector+ inputId = ns("label_rotation"), label = "rotate x labels",
|
|
| 537 | -+ | ||
| 173 | +! |
- #' @param x vector of any type and length+ min = 0L, max = 90L, value = 45L, step = 1, ticks = FALSE |
|
| 538 | +174 |
- #' @return text describing \code{NA} occurrence.
+ )) |
|
| 539 | +175 |
- #' @keywords internal+ ) |
|
| 540 | +176 |
- var_missings_info <- function(x) {
+ ), |
|
| 541 | +177 | ! |
- return(sprintf("%s [%s%%]", sum(is.na(x)), round(mean(is.na(x) * 100), 2)))
- |
-
| 542 | -- |
- }+ br(), |
|
| 543 | -+ | ||
| 178 | +! |
-
+ teal.widgets::get_dt_rows(ns("variable_summary_table"), ns("variable_summary_table_rows")),
|
|
| 544 | -+ | ||
| 179 | +! |
- #' S3 generic for \code{sparkline} widget HTML
+ DT::dataTableOutput(ns("variable_summary_table"))
|
|
| 545 | +180 |
- #'+ ) |
|
| 546 | +181 |
- #' Generates the \code{sparkline} HTML code corresponding to the input array.
+ ) |
|
| 547 | +182 |
- #' For numeric variables creates a box plot, for character and factors - bar plot.+ ), |
|
| 548 | -+ | ||
| 183 | +! |
- #' Produces an empty string for variables of other types.+ pre_output = pre_output, |
|
| 549 | -+ | ||
| 184 | +! |
- #'+ post_output = post_output |
|
| 550 | +185 |
- #' @param arr vector of any type and length+ ) |
|
| 551 | +186 |
- #' @param width \code{numeric} the width of the \code{sparkline} widget (pixels)
+ ) |
|
| 552 | +187 |
- #' @param ... \code{list} additional options passed to bar plots of \code{jquery.sparkline}; see
+ } |
|
| 553 | +188 |
- #' \href{https://omnipotent.net/jquery.sparkline/#common}{\code{jquery.sparkline docs}}
+
|
|
| 554 | +189 |
- #'+ srv_variable_browser <- function(id, |
|
| 555 | +190 |
- #' @return character variable containing the HTML code of the \code{sparkline} HTML widget
+ data, |
|
| 556 | +191 |
- #' @keywords internal+ reporter, |
|
| 557 | +192 |
- #'+ filter_panel_api, |
|
| 558 | +193 |
- create_sparklines <- function(arr, width = 150, ...) {
+ datasets_selected, parent_dataname, ggplot2_args) {
|
|
| 559 | +194 | ! |
- if (all(is.null(arr))) {
+ with_reporter <- !missing(reporter) && inherits(reporter, "Reporter") |
| 560 | +195 | ! |
- return("")
- |
-
| 561 | -- |
- }+ with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI") |
|
| 562 | +196 | ! |
- UseMethod("create_sparklines")
- |
-
| 563 | -- |
- }+ checkmate::assert_class(data, "reactive") |
|
| 564 | -+ | ||
| 197 | +! |
-
+ checkmate::assert_class(isolate(data()), "teal_data") |
|
| 565 | -+ | ||
| 198 | +! |
- #' Default method for \code{\link{create_sparklines}}
+ moduleServer(id, function(input, output, session) {
|
|
| 566 | +199 |
- #'+ # if there are < this number of unique records then a numeric |
|
| 567 | +200 |
- #'+ # variable can be treated as a factor and all factors with < this groups |
|
| 568 | +201 |
- #' @export+ # have their values plotted |
|
| 569 | -+ | ||
| 202 | +! |
- #' @keywords internal+ .unique_records_for_factor <- 30 |
|
| 570 | +203 |
- #' @rdname create_sparklines+ # if there are < this number of unique records then a numeric |
|
| 571 | +204 |
- create_sparklines.default <- function(arr, width = 150, ...) {
+ # variable is by default treated as a factor |
|
| 572 | +205 | ! |
- return(as.character(tags$code("unsupported variable type", class = "text-blue")))
+ .unique_records_default_as_factor <- 6 # nolint: object_length. |
| 573 | +206 |
- }+ |
|
| 574 | -+ | ||
| 207 | +! |
-
+ datanames <- isolate(teal.data::datanames(data())) |
|
| 575 | -+ | ||
| 208 | +! |
- #' Generates the HTML code for the \code{sparkline} widget
+ datanames <- Filter(function(name) {
|
|
| 576 | -+ | ||
| 209 | +! |
- #'+ is.data.frame(isolate(data())[[name]]) |
|
| 577 | -+ | ||
| 210 | +! |
- #' @param bar_spacing \code{numeric} the spacing between the bars (in pixels)
+ }, datanames) |
|
| 578 | +211 |
- #' @param bar_width \code{numeric} the width of the bars (in pixels)
+
|
|
| 579 | -+ | ||
| 212 | +! |
- #'+ checkmate::assert_character(datasets_selected) |
|
| 580 | -+ | ||
| 213 | +! |
- #' @return \code{character} with HTML code for the \code{sparkline} widget
+ checkmate::assert_subset(datasets_selected, datanames) |
|
| 581 | -+ | ||
| 214 | +! |
- #'+ if (!identical(datasets_selected, character(0))) {
|
|
| 582 | -+ | ||
| 215 | +! |
- #' @export+ checkmate::assert_subset(datasets_selected, datanames) |
|
| 583 | -+ | ||
| 216 | +! |
- #' @keywords internal+ datanames <- datasets_selected |
|
| 584 | +217 |
- #' @rdname create_sparklines+ } |
|
| 585 | +218 |
- create_sparklines.Date <- function(arr, width = 150, bar_spacing = 5, bar_width = 20, ...) {
+
|
|
| 586 | +219 | ! |
- arr_num <- as.numeric(arr)+ output$ui_variable_browser <- renderUI({
|
| 587 | +220 | ! |
- arr_num <- sort(arr_num, decreasing = FALSE, method = "radix")+ ns <- session$ns |
| 588 | +221 | ! |
- binwidth <- get_bin_width(arr_num, 1)+ do.call( |
| 589 | +222 | ! |
- bins <- floor(diff(range(arr_num)) / binwidth) + 1+ tabsetPanel, |
| 590 | +223 | ! |
- if (all(is.na(bins))) {
+ c( |
| 591 | +224 | ! |
- return(as.character(tags$code("only NA", class = "text-blue")))
+ id = ns("tabset_panel"),
|
| 592 | +225 | ! |
- } else if (bins == 1) {
+ do.call( |
| 593 | +226 | ! |
- return(as.character(tags$code("one date", class = "text-blue")))
- |
-
| 594 | -- |
- }+ tagList, |
|
| 595 | +227 | ! |
- counts <- as.vector(unname(base::table(cut(arr_num, breaks = bins))))+ lapply(datanames, function(dataname) {
|
| 596 | +228 | ! |
- max_value <- max(counts)+ tabPanel( |
| 597 | -+ | ||
| 229 | +! |
-
+ dataname, |
|
| 598 | +230 | ! |
- start_bins <- as.integer(seq(1, length(arr_num), length.out = bins))+ div( |
| 599 | +231 | ! |
- labels_start <- as.character(as.Date(arr_num[start_bins], origin = as.Date("1970-01-01")))
+ class = "mt-4", |
| 600 | +232 | ! |
- labels <- paste("Start:", labels_start)
+ textOutput(ns(paste0("dataset_summary_", dataname)))
|
| 601 | +233 |
-
+ ), |
|
| 602 | +234 | ! |
- sparkline::spk_chr(+ div( |
| 603 | +235 | ! |
- unname(counts),+ class = "mt-4", |
| 604 | +236 | ! |
- type = "bar",+ teal.widgets::get_dt_rows( |
| 605 | +237 | ! |
- chartRangeMin = 0,+ ns(paste0("variable_browser_", dataname)),
|
| 606 | +238 | ! |
- chartRangeMax = max_value,+ ns(paste0("variable_browser_", dataname, "_rows"))
|
| 607 | -! | +||
| 239 | +
- width = width,+ ), |
||
| 608 | +240 | ! |
- barWidth = bar_width,+ DT::dataTableOutput(ns(paste0("variable_browser_", dataname)), width = "100%")
|
| 609 | -! | +||
| 241 | +
- barSpacing = bar_spacing,+ ) |
||
| 610 | -! | +||
| 242 | +
- tooltipFormatter = custom_sparkline_formatter(labels, counts)+ ) |
||
| 611 | +243 |
- )+ }) |
|
| 612 | +244 |
- }+ ) |
|
| 613 | +245 |
-
+ ) |
|
| 614 | +246 |
- #' Generates the HTML code for the \code{sparkline} widget
+ ) |
|
| 615 | +247 |
- #'+ }) |
|
| 616 | +248 |
- #'+ |
|
| 617 | +249 |
- #' @param bar_spacing \code{numeric} the spacing between the bars (in pixels)
+ # conditionally display checkbox |
|
| 618 | -+ | ||
| 250 | +! |
- #' @param bar_width \code{numeric} the width of the bars (in pixels)
+ shinyjs::toggle( |
|
| 619 | -+ | ||
| 251 | +! |
- #'+ id = "show_parent_vars",+ |
+ |
| 252 | +! | +
+ condition = length(parent_dataname) > 0 && parent_dataname %in% datanames |
|
| 620 | +253 |
- #' @return \code{character} with HTML code for the \code{sparkline} widget
+ ) |
|
| 621 | +254 |
- #'+ + |
+ |
| 255 | +! | +
+ columns_names <- new.env() |
|
| 622 | +256 |
- #' @export+ |
|
| 623 | +257 |
- #' @keywords internal+ # plot_var$data holds the name of the currently selected dataset |
|
| 624 | +258 |
- #' @rdname create_sparklines+ # plot_var$variable[[<dataset_name>]] holds the name of the currently selected |
|
| 625 | +259 |
- create_sparklines.POSIXct <- function(arr, width = 150, bar_spacing = 5, bar_width = 20, ...) {
+ # variable for dataset <dataset_name> |
|
| 626 | +260 | ! |
- arr_num <- as.numeric(arr)+ plot_var <- reactiveValues(data = NULL, variable = list()) |
| 627 | -! | +||
| 261 | +
- arr_num <- sort(arr_num, decreasing = FALSE, method = "radix")+ |
||
| 628 | +262 | ! |
- binwidth <- get_bin_width(arr_num, 1)+ establish_updating_selection(datanames, input, plot_var, columns_names) |
| 629 | -! | +||
| 263 | +
- bins <- floor(diff(range(arr_num)) / binwidth) + 1+ |
||
| 630 | -! | +||
| 264 | +
- if (all(is.na(bins))) {
+ # validations |
||
| 631 | +265 | ! |
- return(as.character(tags$code("only NA", class = "text-blue")))
+ validation_checks <- validate_input(input, plot_var, data)+ |
+
| 266 | ++ | + + | +|
| 267 | ++ |
+ # data_for_analysis is a list with two elements: a column from a dataset and the column label |
|
| 632 | +268 | ! |
- } else if (bins == 1) {
+ plotted_data <- reactive({
|
| 633 | +269 | ! |
- return(as.character(tags$code("one date-time", class = "text-blue")))
+ validation_checks() |
| 634 | +270 |
- }+ |
|
| 635 | +271 | ! |
- counts <- as.vector(unname(base::table(cut(arr_num, breaks = bins))))+ get_plotted_data(input, plot_var, data) |
| 636 | -! | +||
| 272 | +
- max_value <- max(counts)+ }) |
||
| 637 | +273 | ||
| 638 | +274 | ! |
- start_bins <- as.integer(seq(1, length(arr_num), length.out = bins))+ treat_numeric_as_factor <- reactive({
|
| 639 | +275 | ! |
- labels_start <- as.character(format(as.POSIXct(arr_num[start_bins], origin = as.Date("1970-01-01")), "%Y-%m-%d"))
+ if (is_num_var_short(.unique_records_for_factor, input, plotted_data)) {
|
| 640 | +276 | ! |
- labels <- paste("Start:", labels_start)
+ input$numeric_as_factor |
| 641 | +277 |
-
+ } else {
|
|
| 642 | +278 | ! |
- sparkline::spk_chr(+ FALSE |
| 643 | -! | +||
| 279 | +
- unname(counts),+ } |
||
| 644 | -! | +||
| 280 | +
- type = "bar",+ })+ |
+ ||
| 281 | ++ | + | |
| 645 | +282 | ! |
- chartRangeMin = 0,+ render_tabset_panel_content( |
| 646 | +283 | ! |
- chartRangeMax = max_value,+ input = input, |
| 647 | +284 | ! |
- width = width,+ output = output, |
| 648 | +285 | ! |
- barWidth = bar_width,+ data = data, |
| 649 | +286 | ! |
- barSpacing = bar_spacing,+ datanames = datanames, |
| 650 | +287 | ! |
- tooltipFormatter = custom_sparkline_formatter(labels, counts)+ parent_dataname = parent_dataname, |
| 651 | -+ | ||
| 288 | +! |
- )+ columns_names = columns_names, |
|
| 652 | -+ | ||
| 289 | +! |
- }+ plot_var = plot_var |
|
| 653 | +290 |
-
+ ) |
|
| 654 | +291 |
- #' Generates the HTML code for the \code{sparkline} widget
+ # add used-defined text size to ggplot arguments passed from caller frame |
|
| 655 | -+ | ||
| 292 | +! |
- #'+ all_ggplot2_args <- reactive({
|
|
| 656 | -+ | ||
| 293 | +! |
- #'+ user_text <- teal.widgets::ggplot2_args( |
|
| 657 | -+ | ||
| 294 | +! |
- #' @param bar_spacing \code{numeric} the spacing between the bars (in pixels)
+ theme = list( |
|
| 658 | -+ | ||
| 295 | +! |
- #' @param bar_width \code{numeric} the width of the bars (in pixels)
+ "text" = ggplot2::element_text(size = input[["font_size"]]), |
|
| 659 | -+ | ||
| 296 | +! |
- #'+ "axis.text.x" = ggplot2::element_text(angle = input[["label_rotation"]], hjust = 1) |
|
| 660 | +297 |
- #' @return \code{character} with HTML code for the \code{sparkline} widget
+ ) |
|
| 661 | +298 |
- #'+ ) |
|
| 662 | -+ | ||
| 299 | +! |
- #' @export+ user_theme <- utils::getFromNamespace(sprintf("theme_%s", input[["ggplot_theme"]]), ns = "ggplot2")
|
|
| 663 | -+ | ||
| 300 | +! |
- #' @keywords internal+ user_theme <- user_theme() |
|
| 664 | +301 |
- #' @rdname create_sparklines+ # temporary fix to circumvent assertion issue with resolve_ggplot2_args |
|
| 665 | +302 |
- create_sparklines.POSIXlt <- function(arr, width = 150, bar_spacing = 5, bar_width = 20, ...) {
+ # drop problematic elements |
|
| 666 | +303 | ! |
- arr_num <- as.numeric(arr)+ user_theme <- user_theme[grep("strip.text.y.left", names(user_theme), fixed = TRUE, invert = TRUE)]
|
| 667 | -! | +||
| 304 | +
- arr_num <- sort(arr_num, decreasing = FALSE, method = "radix")+ |
||
| 668 | +305 | ! |
- binwidth <- get_bin_width(arr_num, 1)+ teal.widgets::resolve_ggplot2_args( |
| 669 | +306 | ! |
- bins <- floor(diff(range(arr_num)) / binwidth) + 1+ user_plot = user_text, |
| 670 | +307 | ! |
- if (all(is.na(bins))) {
+ user_default = teal.widgets::ggplot2_args(theme = user_theme), |
| 671 | +308 | ! |
- return(as.character(tags$code("only NA", class = "text-blue")))
+ module_plot = ggplot2_args |
| 672 | -! | +||
| 309 | +
- } else if (bins == 1) {
+ ) |
||
| 673 | -! | +||
| 310 | +
- return(as.character(tags$code("one date-time", class = "text-blue")))
+ }) |
||
| 674 | +311 |
- }+ |
|
| 675 | +312 | ! |
- counts <- as.vector(unname(base::table(cut(arr_num, breaks = bins))))+ output$ui_numeric_display <- renderUI({
|
| 676 | +313 | ! |
- max_value <- max(counts)- |
-
| 677 | -- |
-
+ validation_checks() |
|
| 678 | +314 | ! |
- start_bins <- as.integer(seq(1, length(arr_num), length.out = bins))+ dataname <- input$tabset_panel |
| 679 | +315 | ! |
- labels_start <- as.character(format(as.POSIXct(arr_num[start_bins], origin = as.Date("1970-01-01")), "%Y-%m-%d"))
+ varname <- plot_var$variable[[dataname]] |
| 680 | +316 | ! |
- labels <- paste("Start:", labels_start)
+ df <- data()[[dataname]] |
| 681 | +317 | ||
| 682 | +318 | ! |
- sparkline::spk_chr(+ numeric_ui <- tagList( |
| 683 | +319 | ! |
- unname(counts),+ fluidRow( |
| 684 | +320 | ! |
- type = "bar",+ div( |
| 685 | +321 | ! |
- chartRangeMin = 0,+ class = "col-md-4", |
| 686 | +322 | ! |
- chartRangeMax = max_value,+ br(), |
| 687 | +323 | ! |
- width = width,+ shinyWidgets::switchInput( |
| 688 | +324 | ! |
- barWidth = bar_width,+ inputId = session$ns("display_density"),
|
| 689 | +325 | ! |
- barSpacing = bar_spacing,+ label = "Show density", |
| 690 | +326 | ! |
- tooltipFormatter = custom_sparkline_formatter(labels, counts)- |
-
| 691 | -- |
- )+ value = `if`(is.null(isolate(input$display_density)), TRUE, isolate(input$display_density)), |
|
| 692 | -+ | ||
| 327 | +! |
- }+ width = "50%", |
|
| 693 | -+ | ||
| 328 | +! |
-
+ labelWidth = "100px", |
|
| 694 | -+ | ||
| 329 | +! |
-
+ handleWidth = "50px" |
|
| 695 | +330 |
- #' Generates the HTML code for the \code{sparkline} widget
+ ) |
|
| 696 | +331 |
- #'+ ), |
|
| 697 | -+ | ||
| 332 | +! |
- #' Coerces a character vector to factor and delegates to the \code{create_sparklines.factor}
+ div( |
|
| 698 | -+ | ||
| 333 | +! |
- #'+ class = "col-md-4", |
|
| 699 | -+ | ||
| 334 | +! |
- #'+ br(), |
|
| 700 | -+ | ||
| 335 | +! |
- #' @return \code{character} with HTML code for the \code{sparkline} widget
+ shinyWidgets::switchInput( |
|
| 701 | -+ | ||
| 336 | +! |
- #'+ inputId = session$ns("remove_outliers"),
|
|
| 702 | -+ | ||
| 337 | +! |
- #' @export+ label = "Remove outliers", |
|
| 703 | -+ | ||
| 338 | +! |
- #' @keywords internal+ value = `if`(is.null(isolate(input$remove_outliers)), FALSE, isolate(input$remove_outliers)), |
|
| 704 | -+ | ||
| 339 | +! |
- #' @rdname create_sparklines+ width = "50%", |
|
| 705 | -+ | ||
| 340 | +! |
- create_sparklines.character <- function(arr, ...) {
+ labelWidth = "100px", |
|
| 706 | +341 | ! |
- return(create_sparklines(as.factor(arr)))+ handleWidth = "50px" |
| 707 | +342 |
- }+ ) |
|
| 708 | +343 |
-
+ ), |
|
| 709 | -+ | ||
| 344 | +! |
-
+ div( |
|
| 710 | -+ | ||
| 345 | +! |
- #' Generates the HTML code for the \code{sparkline} widget
+ class = "col-md-4", |
|
| 711 | -+ | ||
| 346 | +! |
- #'+ uiOutput(session$ns("outlier_definition_slider_ui"))
|
|
| 712 | +347 |
- #' Coerces logical vector to factor and delegates to the \code{create_sparklines.factor}
+ ) |
|
| 713 | +348 |
- #'+ ), |
|
| 714 | -+ | ||
| 349 | +! |
- #'+ div( |
|
| 715 | -+ | ||
| 350 | +! |
- #' @return \code{character} with HTML code for the \code{sparkline} widget
+ class = "ml-4", |
|
| 716 | -+ | ||
| 351 | +! |
- #'+ uiOutput(session$ns("ui_density_help")),
|
|
| 717 | -+ | ||
| 352 | +! |
- #' @export+ uiOutput(session$ns("ui_outlier_help"))
|
|
| 718 | +353 |
- #' @keywords internal+ ) |
|
| 719 | +354 |
- #' @rdname create_sparklines+ ) |
|
| 720 | +355 |
- create_sparklines.logical <- function(arr, ...) {
+
|
|
| 721 | +356 | ! |
- return(create_sparklines(as.factor(arr)))- |
-
| 722 | -- |
- }- |
- |
| 723 | -- |
-
+ if (is.numeric(df[[varname]])) {
|
|
| 724 | -+ | ||
| 357 | +! |
-
+ unique_entries <- length(unique(df[[varname]])) |
|
| 725 | -+ | ||
| 358 | +! |
- #' Generates the \code{sparkline} HTML code
+ if (unique_entries < .unique_records_for_factor && unique_entries > 0) {
|
|
| 726 | -+ | ||
| 359 | +! |
- #'+ list( |
|
| 727 | -+ | ||
| 360 | +! |
- #' @param bar_spacing \code{numeric} spacing between the bars (in pixels)
+ checkboxInput( |
|
| 728 | -+ | ||
| 361 | +! |
- #' @param bar_width \code{numeric} width of the bars (in pixels)
+ session$ns("numeric_as_factor"),
|
|
| 729 | -+ | ||
| 362 | +! |
- #'+ "Treat variable as factor", |
|
| 730 | -+ | ||
| 363 | +! |
- #' @return \code{character} with HTML code for the \code{sparkline} widget
+ value = `if`( |
|
| 731 | -+ | ||
| 364 | +! |
- #'+ is.null(isolate(input$numeric_as_factor)), |
|
| 732 | -+ | ||
| 365 | +! |
- #' @export+ unique_entries < .unique_records_default_as_factor, |
|
| 733 | -+ | ||
| 366 | +! |
- #' @keywords internal+ isolate(input$numeric_as_factor) |
|
| 734 | +367 |
- #' @rdname create_sparklines+ ) |
|
| 735 | +368 |
- create_sparklines.factor <- function(arr, width = 150, bar_spacing = 5, bar_width = 20, ...) {
+ ), |
|
| 736 | +369 | ! |
- decreasing_order <- TRUE+ conditionalPanel("!input.numeric_as_factor", ns = session$ns, numeric_ui)
|
| 737 | +370 | - - | -|
| 738 | -! | -
- counts <- table(arr)- |
- |
| 739 | -! | -
- if (length(counts) >= 100) {
+ ) |
|
| 740 | +371 | ! |
- return(as.character(tags$code("> 99 levels", class = "text-blue")))
+ } else if (unique_entries > 0) {
|
| 741 | +372 | ! |
- } else if (length(counts) == 0) {
+ numeric_ui |
| 742 | -! | +||
| 373 | +
- return(as.character(tags$code("no levels", class = "text-blue")))
+ } |
||
| 743 | -! | +||
| 374 | +
- } else if (length(counts) == 1) {
+ } else {
|
||
| 744 | +375 | ! |
- return(as.character(tags$code("one level", class = "text-blue")))
- |
-
| 745 | -- |
- }+ NULL |
|
| 746 | +376 |
-
+ } |
|
| 747 | +377 |
- # Summarize the occurences of different levels+ }) |
|
| 748 | +378 |
- # and get the maximum and minimum number of occurences+ |
|
| 749 | -+ | ||
| 379 | +! |
- # This is needed for the sparkline to correctly display the bar plots+ output$ui_histogram_display <- renderUI({
|
|
| 750 | -+ | ||
| 380 | +! |
- # Otherwise they are cropped+ validation_checks() |
|
| 751 | +381 | ! |
- counts <- sort(counts, decreasing = decreasing_order, method = "radix")+ dataname <- input$tabset_panel |
| 752 | +382 | ! |
- max_value <- if (decreasing_order) counts[1] else counts[length[counts]]+ varname <- plot_var$variable[[dataname]] |
| 753 | +383 | ! |
- max_value <- unname(max_value)+ df <- data()[[dataname]] |
| 754 | +384 | ||
| 755 | +385 | ! |
- sparkline::spk_chr(+ numeric_ui <- tagList(fluidRow( |
| 756 | +386 | ! |
- unname(counts),+ div( |
| 757 | +387 | ! |
- type = "bar",+ class = "col-md-4", |
| 758 | +388 | ! |
- chartRangeMin = 0,+ shinyWidgets::switchInput( |
| 759 | +389 | ! |
- chartRangeMax = max_value,+ inputId = session$ns("remove_NA_hist"),
|
| 760 | +390 | ! |
- width = width,+ label = "Remove NA values", |
| 761 | +391 | ! |
- barWidth = bar_width,+ value = FALSE, |
| 762 | +392 | ! |
- barSpacing = bar_spacing,+ width = "50%", |
| 763 | +393 | ! |
- tooltipFormatter = custom_sparkline_formatter(names(counts), as.vector(counts))+ labelWidth = "100px", |
| 764 | -+ | ||
| 394 | +! |
- )+ handleWidth = "50px" |
|
| 765 | +395 |
- }+ ) |
|
| 766 | +396 |
-
+ ) |
|
| 767 | +397 |
- #' Generates the \code{sparkline} HTML code
+ )) |
|
| 768 | +398 |
- #'+ |
|
| 769 | -+ | ||
| 399 | +! |
- #'+ var <- df[[varname]]+ |
+ |
| 400 | +! | +
+ if (anyNA(var) && (is.factor(var) || is.character(var) || is.logical(var))) {
+ |
+ |
| 401 | +! | +
+ groups <- unique(as.character(var))+ |
+ |
| 402 | +! | +
+ len_groups <- length(groups)+ |
+ |
| 403 | +! | +
+ if (len_groups >= .unique_records_for_factor) {
+ |
+ |
| 404 | +! | +
+ NULL |
|
| 770 | +405 |
- #' @return \code{character} with HTML code for the \code{sparkline} widget
+ } else {
+ |
+ |
| 406 | +! | +
+ numeric_ui |
|
| 771 | +407 |
- #'+ } |
|
| 772 | +408 |
- #' @export+ } else {
+ |
+ |
| 409 | +! | +
+ NULL |
|
| 773 | +410 |
- #' @keywords internal+ } |
|
| 774 | +411 |
- #' @rdname create_sparklines+ }) |
|
| 775 | +412 |
- create_sparklines.numeric <- function(arr, width = 150, ...) {
+
|
|
| 776 | +413 | ! |
- if (any(is.infinite(arr))) {
+ output$outlier_definition_slider_ui <- renderUI({
|
| 777 | +414 | ! |
- return(as.character(tags$code("infinite values", class = "text-blue")))
+ req(input$remove_outliers) |
| 778 | -+ | ||
| 415 | +! |
- }+ sliderInput( |
|
| 779 | +416 | ! |
- if (length(arr) > 100000) {
+ inputId = session$ns("outlier_definition_slider"),
|
| 780 | +417 | ! |
- return(as.character(tags$code("Too many rows (>100000)", class = "text-blue")))
+ div( |
| 781 | -+ | ||
| 418 | +! |
- }+ class = "teal-tooltip", |
|
| 782 | -+ | ||
| 419 | +! |
-
+ tagList( |
|
| 783 | +420 | ! |
- arr <- arr[!is.na(arr)]+ "Outlier definition:", |
| 784 | +421 | ! |
- res <- sparkline::spk_chr(unname(arr), type = "box", width = width, ...)+ icon("circle-info"),
|
| 785 | +422 | ! |
- return(res)+ span( |
| 786 | -+ | ||
| 423 | +! |
- }+ class = "tooltiptext", |
|
| 787 | -+ | ||
| 424 | +! |
-
+ paste( |
|
| 788 | -+ | ||
| 425 | +! |
- #' Summarizes variable+ "Use the slider to choose the cut-off value to define outliers; the larger the value the", |
|
| 789 | -+ | ||
| 426 | +! |
- #'+ "further below Q1/above Q3 points have to be in order to be classed as outliers" |
|
| 790 | +427 |
- #' Creates html summary with statistics relevant to data type. For numeric values it returns central+ ) |
|
| 791 | +428 |
- #' tendency measures, for factor returns level counts, for Date date range, for other just+ ) |
|
| 792 | +429 |
- #' number of levels.+ ) |
|
| 793 | +430 |
- #' @param x vector of any type+ ), |
|
| 794 | -+ | ||
| 431 | +! |
- #' @param numeric_as_factor \code{logical} should the numeric variable be treated as a factor
+ min = 1, |
|
| 795 | -+ | ||
| 432 | +! |
- #' @param dt_rows \code{numeric} current/latest `DT` page length
+ max = 5, |
|
| 796 | -+ | ||
| 433 | +! |
- #' @param outlier_definition If 0 no outliers are removed, otherwise+ value = 3, |
|
| 797 | -+ | ||
| 434 | +! |
- #' outliers (those more than outlier_definition*IQR below/above Q1/Q3 be removed)+ step = 0.5 |
|
| 798 | +435 |
- #' @return text with simple statistics.+ ) |
|
| 799 | +436 |
- #' @keywords internal+ }) |
|
| 800 | +437 |
- var_summary_table <- function(x, numeric_as_factor, dt_rows, outlier_definition) {
+
|
|
| 801 | +438 | ! |
- if (is.null(dt_rows)) {
+ output$ui_density_help <- renderUI({
|
| 802 | +439 | ! |
- dt_rows <- 10+ req(is.logical(input$display_density)) |
| 803 | -+ | ||
| 440 | +! |
- }+ if (input$display_density) {
|
|
| 804 | +441 | ! |
- if (is.numeric(x) && !numeric_as_factor) {
+ tags$small(helpText(paste( |
| 805 | +442 | ! |
- req(!any(is.infinite(x)))+ "Kernel density estimation with gaussian kernel", |
| 806 | -+ | ||
| 443 | +! |
-
+ "and bandwidth function bw.nrd0 (R default)" |
|
| 807 | -! | +||
| 444 | +
- x <- remove_outliers_from(x, outlier_definition)+ ))) |
||
| 808 | +445 |
-
+ } else {
|
|
| 809 | +446 | ! |
- qvals <- round(stats::quantile(x, na.rm = TRUE, probs = c(0.25, 0.5, 0.75), type = 2), 2)+ NULL |
| 810 | +447 |
- # classical central tendency measures+ } |
|
| 811 | +448 | ++ |
+ })+ |
+
| 449 | |||
| 812 | +450 | ! |
- summary <-+ output$ui_outlier_help <- renderUI({
|
| 813 | +451 | ! |
- data.frame(+ req(is.logical(input$remove_outliers), input$outlier_definition_slider) |
| 814 | +452 | ! |
- Statistic = c("min", "Q1", "median", "mean", "Q3", "max", "sd", "n"),
+ if (input$remove_outliers) {
|
| 815 | +453 | ! |
- Value = c(+ tags$small( |
| 816 | +454 | ! |
- round(min(x, na.rm = TRUE), 2),+ helpText( |
| 817 | +455 | ! |
- qvals[1],+ withMathJax(paste0( |
| 818 | +456 | ! |
- qvals[2],+ "Outlier data points (\\( X \\lt Q1 - ", input$outlier_definition_slider, "\\times IQR \\) or |
| 819 | +457 | ! |
- round(mean(x, na.rm = TRUE), 2),+ \\(Q3 + ", input$outlier_definition_slider, "\\times IQR \\lt X\\)) |
| 820 | +458 | ! |
- qvals[3],+ have not been displayed on the graph and will not be used for any kernel density estimations, ", |
| 821 | +459 | ! |
- round(max(x, na.rm = TRUE), 2),+ "although their values remain in the statisics table below." |
| 822 | -! | +||
| 460 | +
- round(stats::sd(x, na.rm = TRUE), 2),+ ))+ |
+ ||
| 461 | ++ |
+ )+ |
+ |
| 462 | ++ |
+ )+ |
+ |
| 463 | ++ |
+ } else {
|
|
| 823 | +464 | ! |
- length(x[!is.na(x)])+ NULL |
| 824 | +465 |
- )+ } |
|
| 825 | +466 |
- )+ }) |
|
| 826 | +467 | ++ | + + | +
| 468 | |||
| 827 | +469 | ! |
- DT::datatable(summary, rownames = FALSE, options = list(dom = "<t>", pageLength = dt_rows))+ variable_plot_r <- reactive({
|
| 828 | +470 | ! |
- } else if (is.factor(x) || is.character(x) || (is.numeric(x) && numeric_as_factor) || is.logical(x)) {
+ display_density <- `if`(is.null(input$display_density), FALSE, input$display_density)+ |
+
| 471 | +! | +
+ remove_outliers <- `if`(is.null(input$remove_outliers), FALSE, input$remove_outliers) |
|
| 829 | +472 |
- # make sure factor is ordered numeric+ |
|
| 830 | +473 | ! |
- if (is.numeric(x)) {
+ if (remove_outliers) {
|
| 831 | +474 | ! |
- x <- factor(x, levels = sort(unique(x)))+ req(input$outlier_definition_slider)+ |
+
| 475 | +! | +
+ outlier_definition <- as.numeric(input$outlier_definition_slider) |
|
| 832 | +476 |
- }+ } else {
+ |
+ |
| 477 | +! | +
+ outlier_definition <- 0+ |
+ |
| 478 | ++ |
+ }+ |
+ |
| 479 | ++ | + + | +|
| 480 | +! | +
+ plot_var_summary( |
|
| 833 | -+ | ||
| 481 | +! |
-
+ var = plotted_data()$data, |
|
| 834 | +482 | ! |
- level_counts <- table(x)+ var_lab = plotted_data()$var_description, |
| 835 | +483 | ! |
- max_levels_signif <- nchar(level_counts)+ wrap_character = 15, |
| 836 | -+ | ||
| 484 | +! |
-
+ numeric_as_factor = treat_numeric_as_factor(), |
|
| 837 | +485 | ! |
- if (!all(is.na(x))) {
+ remove_NA_hist = input$remove_NA_hist, |
| 838 | +486 | ! |
- levels <- names(level_counts)+ display_density = display_density, |
| 839 | +487 | ! |
- counts <- sprintf(+ outlier_definition = outlier_definition, |
| 840 | +488 | ! |
- "%s [%.2f%%]",+ records_for_factor = .unique_records_for_factor, |
| 841 | +489 | ! |
- format(level_counts, width = max_levels_signif), prop.table(level_counts) * 100+ ggplot2_args = all_ggplot2_args() |
| 842 | +490 |
) |
|
| 843 | +491 |
- } else {
+ })+ |
+ |
| 492 | ++ | + | |
| 844 | +493 | ! |
- levels <- character(0)+ pws <- teal.widgets::plot_with_settings_srv( |
| 845 | +494 | ! |
- counts <- numeric(0)+ id = "variable_plot",+ |
+
| 495 | +! | +
+ plot_r = variable_plot_r,+ |
+ |
| 496 | +! | +
+ height = c(500, 200, 2000) |
|
| 846 | +497 |
- }+ ) |
|
| 847 | +498 | ||
| 848 | +499 | ! |
- summary <- data.frame(+ output$variable_summary_table <- DT::renderDataTable({
|
| 849 | +500 | ! |
- Level = levels,+ var_summary_table( |
| 850 | +501 | ! |
- Count = counts,+ plotted_data()$data, |
| 851 | +502 | ! |
- stringsAsFactors = FALSE+ treat_numeric_as_factor(), |
| 852 | -+ | ||
| 503 | +! |
- )+ input$variable_summary_table_rows, |
|
| 853 | -+ | ||
| 504 | +! |
-
+ if (!is.null(input$remove_outliers) && input$remove_outliers) {
|
|
| 854 | -+ | ||
| 505 | +! |
- # sort the dataset in decreasing order of counts (needed as character variables default to alphabetical)+ req(input$outlier_definition_slider) |
|
| 855 | +506 | ! |
- summary <- summary[order(summary$Count, decreasing = TRUE), ]+ as.numeric(input$outlier_definition_slider) |
| 856 | +507 |
-
+ } else {
|
|
| 857 | +508 | ! |
- dom_opts <- if (nrow(summary) <= 10) {
+ 0 |
| 858 | -! | +||
| 509 | +
- "<t>"+ } |
||
| 859 | +510 |
- } else {
+ ) |
|
| 860 | -! | +||
| 511 | +
- "<lf<t>ip>"+ }) |
||
| 861 | +512 |
- }+ |
|
| 862 | -! | +||
| 513 | +
- DT::datatable(summary, rownames = FALSE, options = list(dom = dom_opts, pageLength = dt_rows))+ ### REPORTER |
||
| 863 | +514 | ! |
- } else if (inherits(x, "Date") || inherits(x, "POSIXct") || inherits(x, "POSIXlt")) {
+ if (with_reporter) {
|
| 864 | +515 | ! |
- summary <-+ card_fun <- function(comment) {
|
| 865 | +516 | ! |
- data.frame(+ card <- teal::TealReportCard$new() |
| 866 | +517 | ! |
- Statistic = c("min", "median", "max"),
+ card$set_name("Variable Browser Plot")
|
| 867 | +518 | ! |
- Value = c(+ card$append_text("Variable Browser Plot", "header2")
|
| 868 | +519 | ! |
- min(x, na.rm = TRUE),+ if (with_filter) card$append_fs(filter_panel_api$get_filter_state()) |
| 869 | +520 | ! |
- stats::median(x, na.rm = TRUE),+ card$append_text("Plot", "header3")
|
| 870 | +521 | ! |
- max(x, na.rm = TRUE)+ card$append_plot(variable_plot_r(), dim = pws$dim()) |
| 871 | -+ | ||
| 522 | +! |
- )+ if (!comment == "") {
|
|
| 872 | -+ | ||
| 523 | +! |
- )+ card$append_text("Comment", "header3")
|
|
| 873 | +524 | ! |
- DT::datatable(summary, rownames = FALSE, options = list(dom = "<t>", pageLength = dt_rows))+ card$append_text(comment) |
| 874 | +525 |
- } else {
+ } |
|
| 875 | +526 | ! |
- NULL+ card |
| 876 | +527 |
- }+ } |
|
| 877 | -+ | ||
| 528 | +! |
- }+ teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
|
|
| 878 | +529 |
-
+ } |
|
| 879 | +530 |
-
+ ### |
|
| 880 | +531 |
- #' Plot variable+ }) |
|
| 881 | +532 |
- #'+ } |
|
| 882 | +533 |
- #' Creates summary plot with statistics relevant to data type.+ |
|
| 883 | +534 |
- #' @inheritParams shared_params+ #' Summarizes missings occurrence |
|
| 884 | +535 |
- #' @param var vector of any type to be plotted. For numeric variables it produces histogram with+ #' |
|
| 885 | +536 |
- #' density line, for factors it creates frequency plot+ #' Summarizes missings occurrence in vector |
|
| 886 | +537 |
- #' @param var_lab text describing selected variable to be displayed on the plot+ #' @param x vector of any type and length |
|
| 887 | +538 |
- #' @param wrap_character (`numeric`) number of characters at which to wrap text values of `var`+ #' @return text describing \code{NA} occurrence.
|
|
| 888 | +539 |
- #' @param numeric_as_factor (`logical`) should the numeric variable be treated as a factor+ #' @keywords internal |
|
| 889 | +540 |
- #' @param display_density (`logical`) should density estimation be displayed for numeric values+ var_missings_info <- function(x) {
|
|
| 890 | -+ | ||
| 541 | +! |
- #' @param remove_NA_hist (`logical`) should (`NA`) values be removed for histogram of factor like variables+ return(sprintf("%s [%s%%]", sum(is.na(x)), round(mean(is.na(x) * 100), 2)))
|
|
| 891 | +542 |
- #' @param outlier_definition if 0 no outliers are removed, otherwise+ } |
|
| 892 | +543 |
- #' outliers (those more than outlier_definition*IQR below/above Q1/Q3 be removed)+ |
|
| 893 | +544 |
- #' @param records_for_factor (`numeric`) if the number of factor levels is >= than this value then+ #' S3 generic for \code{sparkline} widget HTML
|
|
| 894 | +545 |
- #' a graph of the factors isn't shown, only a list of values+ #' |
|
| 895 | +546 |
- #'+ #' Generates the \code{sparkline} HTML code corresponding to the input array.
|
|
| 896 | +547 |
- #' @return plot+ #' For numeric variables creates a box plot, for character and factors - bar plot. |
|
| 897 | +548 |
- #' @keywords internal+ #' Produces an empty string for variables of other types. |
|
| 898 | +549 |
- plot_var_summary <- function(var,+ #' |
|
| 899 | +550 |
- var_lab,+ #' @param arr vector of any type and length |
|
| 900 | +551 |
- wrap_character = NULL,+ #' @param width \code{numeric} the width of the \code{sparkline} widget (pixels)
|
|
| 901 | +552 |
- numeric_as_factor,+ #' @param ... \code{list} additional options passed to bar plots of \code{jquery.sparkline}; see
|
|
| 902 | +553 |
- display_density = is.numeric(var),+ #' \href{https://omnipotent.net/jquery.sparkline/#common}{\code{jquery.sparkline docs}}
|
|
| 903 | +554 |
- remove_NA_hist = FALSE, # nolint: object_name.+ #' |
|
| 904 | +555 |
- outlier_definition,+ #' @return character variable containing the HTML code of the \code{sparkline} HTML widget
|
|
| 905 | +556 |
- records_for_factor,+ #' @keywords internal |
|
| 906 | +557 |
- ggplot2_args) {
- |
- |
| 907 | -! | -
- checkmate::assert_character(var_lab)- |
- |
| 908 | -! | -
- checkmate::assert_numeric(wrap_character, null.ok = TRUE)+ #' |
|
| 909 | -! | +||
| 558 | +
- checkmate::assert_flag(numeric_as_factor)+ create_sparklines <- function(arr, width = 150, ...) {
|
||
| 910 | +559 | ! |
- checkmate::assert_flag(display_density)+ if (all(is.null(arr))) {
|
| 911 | +560 | ! |
- checkmate::assert_logical(remove_NA_hist, null.ok = TRUE)+ return("")
|
| 912 | -! | +||
| 561 | +
- checkmate::assert_number(outlier_definition, lower = 0, finite = TRUE)+ } |
||
| 913 | +562 | ! |
- checkmate::assert_integerish(records_for_factor, lower = 0, len = 1, any.missing = FALSE)+ UseMethod("create_sparklines")
|
| 914 | -! | +||
| 563 | +
- checkmate::assert_class(ggplot2_args, "ggplot2_args")+ } |
||
| 915 | +564 | ||
| 916 | -! | -
- grid::grid.newpage()- |
- |
| 917 | +565 |
-
+ #' Default method for \code{\link{create_sparklines}}
|
|
| 918 | -! | +||
| 566 | +
- plot_main <- if (is.factor(var) || is.character(var) || is.logical(var)) {
+ #' |
||
| 919 | -! | +||
| 567 | +
- groups <- unique(as.character(var))+ #' |
||
| 920 | -! | +||
| 568 | +
- len_groups <- length(groups)+ #' @export |
||
| 921 | -! | +||
| 569 | +
- if (len_groups >= records_for_factor) {
+ #' @keywords internal |
||
| 922 | -! | +||
| 570 | +
- grid::textGrob(+ #' @rdname create_sparklines |
||
| 923 | -! | +||
| 571 | +
- sprintf(+ create_sparklines.default <- function(arr, width = 150, ...) {
|
||
| 924 | +572 | ! |
- "%s unique values\n%s:\n %s\n ...\n %s",+ return(as.character(tags$code("unsupported variable type", class = "text-blue")))
|
| 925 | -! | +||
| 573 | +
- len_groups,+ } |
||
| 926 | -! | +||
| 574 | +
- var_lab,+ |
||
| 927 | -! | +||
| 575 | +
- paste(utils::head(groups), collapse = ",\n "),+ #' Generates the HTML code for the \code{sparkline} widget
|
||
| 928 | -! | +||
| 576 | +
- paste(utils::tail(groups), collapse = ",\n ")+ #' |
||
| 929 | +577 |
- ),+ #' @param bar_spacing \code{numeric} the spacing between the bars (in pixels)
|
|
| 930 | -! | +||
| 578 | +
- x = grid::unit(1, "line"),+ #' @param bar_width \code{numeric} the width of the bars (in pixels)
|
||
| 931 | -! | +||
| 579 | +
- y = grid::unit(1, "npc") - grid::unit(1, "line"),+ #' |
||
| 932 | -! | +||
| 580 | +
- just = c("left", "top")
+ #' @return \code{character} with HTML code for the \code{sparkline} widget
|
||
| 933 | +581 |
- )+ #' |
|
| 934 | +582 |
- } else {
+ #' @export |
|
| 935 | -! | +||
| 583 | +
- if (!is.null(wrap_character)) {
+ #' @keywords internal |
||
| 936 | -! | +||
| 584 | +
- var <- stringr::str_wrap(var, width = wrap_character)+ #' @rdname create_sparklines |
||
| 937 | +585 |
- }+ create_sparklines.Date <- function(arr, width = 150, bar_spacing = 5, bar_width = 20, ...) {
|
|
| 938 | +586 | ! |
- var <- if (isTRUE(remove_NA_hist)) as.vector(stats::na.omit(var)) else var+ arr_num <- as.numeric(arr) |
| 939 | +587 | ! |
- ggplot(data.frame(var), aes(x = forcats::fct_infreq(as.factor(var)))) ++ arr_num <- sort(arr_num, decreasing = FALSE, method = "radix") |
| 940 | +588 | ! |
- geom_bar(stat = "count", aes(fill = ifelse(is.na(var), "withcolor", "")), show.legend = FALSE) ++ binwidth <- get_bin_width(arr_num, 1) |
| 941 | +589 | ! |
- scale_fill_manual(values = c("gray50", "tan"))
+ bins <- floor(diff(range(arr_num)) / binwidth) + 1 |
| 942 | -+ | ||
| 590 | +! |
- }+ if (all(is.na(bins))) {
|
|
| 943 | +591 | ! |
- } else if (is.numeric(var)) {
+ return(as.character(tags$code("only NA", class = "text-blue")))
|
| 944 | +592 | ! |
- validate(need(any(!is.na(var)), "No data left to visualize."))+ } else if (bins == 1) {
|
| 945 | -+ | ||
| 593 | +! |
-
+ return(as.character(tags$code("one date", class = "text-blue")))
|
|
| 946 | +594 |
- # Filter out NA+ } |
|
| 947 | +595 | ! |
- var <- var[which(!is.na(var))]- |
-
| 948 | -- |
-
+ counts <- as.vector(unname(base::table(cut(arr_num, breaks = bins)))) |
|
| 949 | +596 | ! |
- validate(need(!any(is.infinite(var)), "Cannot display graph when data includes infinite values"))+ max_value <- max(counts) |
| 950 | +597 | ||
| 951 | -! | -
- if (numeric_as_factor) {
- |
- |
| 952 | +598 | ! |
- var <- factor(var)+ start_bins <- as.integer(seq(1, length(arr_num), length.out = bins)) |
| 953 | +599 | ! |
- ggplot(NULL, aes(x = var)) ++ labels_start <- as.character(as.Date(arr_num[start_bins], origin = as.Date("1970-01-01")))
|
| 954 | +600 | ! |
- geom_histogram(stat = "count")- |
-
| 955 | -- |
- } else {
+ labels <- paste("Start:", labels_start)
|
|
| 956 | +601 |
- # remove outliers- |
- |
| 957 | -! | -
- if (outlier_definition != 0) {
+
|
|
| 958 | +602 | ! |
- number_records <- length(var)+ sparkline::spk_chr( |
| 959 | +603 | ! |
- var <- remove_outliers_from(var, outlier_definition)+ unname(counts), |
| 960 | +604 | ! |
- number_outliers <- number_records - length(var)+ type = "bar", |
| 961 | +605 | ! |
- outlier_text <- paste0(+ chartRangeMin = 0, |
| 962 | +606 | ! |
- number_outliers, " outliers (",
+ chartRangeMax = max_value, |
| 963 | +607 | ! |
- round(number_outliers / number_records * 100, 2),+ width = width, |
| 964 | +608 | ! |
- "% of non-missing records) not shown"- |
-
| 965 | -- |
- )+ barWidth = bar_width, |
|
| 966 | +609 | ! |
- validate(need(+ barSpacing = bar_spacing, |
| 967 | +610 | ! |
- length(var) > 1,+ tooltipFormatter = custom_sparkline_formatter(labels, counts) |
| 968 | -! | +||
| 611 | +
- "At least two data points must remain after removing outliers for this graph to be displayed"+ ) |
||
| 969 | +612 |
- ))+ } |
|
| 970 | +613 |
- }+ |
|
| 971 | +614 |
- ## histogram+ #' Generates the HTML code for the \code{sparkline} widget
|
|
| 972 | -! | +||
| 615 | +
- binwidth <- get_bin_width(var)+ #' |
||
| 973 | -! | +||
| 616 | +
- p <- ggplot(data = data.frame(var = var), aes(x = var, y = after_stat(count))) ++ #' |
||
| 974 | -! | +||
| 617 | +
- geom_histogram(binwidth = binwidth) ++ #' @param bar_spacing \code{numeric} the spacing between the bars (in pixels)
|
||
| 975 | -! | +||
| 618 | +
- scale_y_continuous(+ #' @param bar_width \code{numeric} the width of the bars (in pixels)
|
||
| 976 | -! | +||
| 619 | +
- sec.axis = sec_axis(+ #' |
||
| 977 | -! | +||
| 620 | +
- trans = ~ . / nrow(data.frame(var = var)),+ #' @return \code{character} with HTML code for the \code{sparkline} widget
|
||
| 978 | -! | +||
| 621 | +
- labels = scales::percent,+ #' |
||
| 979 | -! | +||
| 622 | +
- name = "proportion (in %)"+ #' @export |
||
| 980 | +623 |
- )+ #' @keywords internal |
|
| 981 | +624 |
- )+ #' @rdname create_sparklines |
|
| 982 | +625 |
-
+ create_sparklines.POSIXct <- function(arr, width = 150, bar_spacing = 5, bar_width = 20, ...) {
|
|
| 983 | +626 | ! |
- if (display_density) {
+ arr_num <- as.numeric(arr) |
| 984 | +627 | ! |
- p <- p + geom_density(aes(y = after_stat(count * binwidth)))+ arr_num <- sort(arr_num, decreasing = FALSE, method = "radix") |
| 985 | -+ | ||
| 628 | +! |
- }+ binwidth <- get_bin_width(arr_num, 1) |
|
| 986 | -+ | ||
| 629 | +! |
-
+ bins <- floor(diff(range(arr_num)) / binwidth) + 1 |
|
| 987 | +630 | ! |
- if (outlier_definition != 0) {
+ if (all(is.na(bins))) {
|
| 988 | +631 | ! |
- p <- p + annotate(+ return(as.character(tags$code("only NA", class = "text-blue")))
|
| 989 | +632 | ! |
- geom = "text",+ } else if (bins == 1) {
|
| 990 | +633 | ! |
- label = outlier_text,+ return(as.character(tags$code("one date-time", class = "text-blue")))
|
| 991 | -! | +||
| 634 | +
- x = Inf, y = Inf,+ } |
||
| 992 | +635 | ! |
- hjust = 1.02, vjust = 1.2,+ counts <- as.vector(unname(base::table(cut(arr_num, breaks = bins)))) |
| 993 | +636 | ! |
- color = "black",+ max_value <- max(counts) |
| 994 | +637 |
- # explicitly modify geom text size according+ |
|
| 995 | +638 | ! |
- size = ggplot2_args[["theme"]][["text"]][["size"]] / 3.5- |
-
| 996 | -- |
- )+ start_bins <- as.integer(seq(1, length(arr_num), length.out = bins)) |
|
| 997 | -+ | ||
| 639 | +! |
- }+ labels_start <- as.character(format(as.POSIXct(arr_num[start_bins], origin = as.Date("1970-01-01")), "%Y-%m-%d"))
|
|
| 998 | +640 | ! |
- p+ labels <- paste("Start:", labels_start)
|
| 999 | +641 |
- }+ |
|
| 1000 | +642 | ! |
- } else if (inherits(var, "Date") || inherits(var, "POSIXct") || inherits(var, "POSIXlt")) {
+ sparkline::spk_chr( |
| 1001 | +643 | ! |
- var_num <- as.numeric(var)+ unname(counts), |
| 1002 | +644 | ! |
- binwidth <- get_bin_width(var_num, 1)+ type = "bar", |
| 1003 | +645 | ! |
- p <- ggplot(data = data.frame(var = var), aes(x = var, y = after_stat(count))) ++ chartRangeMin = 0, |
| 1004 | +646 | ! |
- geom_histogram(binwidth = binwidth)+ chartRangeMax = max_value, |
| 1005 | -+ | ||
| 647 | +! |
- } else {
+ width = width, |
|
| 1006 | +648 | ! |
- grid::textGrob(+ barWidth = bar_width, |
| 1007 | +649 | ! |
- paste(strwrap(+ barSpacing = bar_spacing, |
| 1008 | +650 | ! |
- utils::capture.output(utils::str(var)),+ tooltipFormatter = custom_sparkline_formatter(labels, counts) |
| 1009 | -! | +||
| 651 | +
- width = .9 * grid::convertWidth(grid::unit(1, "npc"), "char", TRUE)+ ) |
||
| 1010 | -! | +||
| 652 | +
- ), collapse = "\n"),+ } |
||
| 1011 | -! | +||
| 653 | +
- x = grid::unit(1, "line"), y = grid::unit(1, "npc") - grid::unit(1, "line"), just = c("left", "top")
+
|
||
| 1012 | +654 |
- )+ #' Generates the HTML code for the \code{sparkline} widget
|
|
| 1013 | +655 |
- }+ #' |
|
| 1014 | +656 |
-
+ #' |
|
| 1015 | -! | +||
| 657 | +
- dev_ggplot2_args <- teal.widgets::ggplot2_args(+ #' @param bar_spacing \code{numeric} the spacing between the bars (in pixels)
|
||
| 1016 | -! | +||
| 658 | +
- labs = list(x = var_lab)+ #' @param bar_width \code{numeric} the width of the bars (in pixels)
|
||
| 1017 | +659 |
- )+ #' |
|
| 1018 | +660 |
- ###+ #' @return \code{character} with HTML code for the \code{sparkline} widget
|
|
| 1019 | -! | +||
| 661 | +
- all_ggplot2_args <- teal.widgets::resolve_ggplot2_args(+ #' |
||
| 1020 | -! | +||
| 662 | +
- ggplot2_args,+ #' @export |
||
| 1021 | -! | +||
| 663 | +
- module_plot = dev_ggplot2_args+ #' @keywords internal |
||
| 1022 | +664 |
- )+ #' @rdname create_sparklines |
|
| 1023 | +665 |
-
+ create_sparklines.POSIXlt <- function(arr, width = 150, bar_spacing = 5, bar_width = 20, ...) {
|
|
| 1024 | +666 | ! |
- if (is.ggplot(plot_main)) {
+ arr_num <- as.numeric(arr) |
| 1025 | +667 | ! |
- if (is.numeric(var) && !numeric_as_factor) {
+ arr_num <- sort(arr_num, decreasing = FALSE, method = "radix") |
| 1026 | -+ | ||
| 668 | +! |
- # numeric not as factor+ binwidth <- get_bin_width(arr_num, 1) |
|
| 1027 | +669 | ! |
- plot_main <- plot_main ++ bins <- floor(diff(range(arr_num)) / binwidth) + 1 |
| 1028 | +670 | ! |
- theme_light() ++ if (all(is.na(bins))) {
|
| 1029 | +671 | ! |
- list(+ return(as.character(tags$code("only NA", class = "text-blue")))
|
| 1030 | +672 | ! |
- labs = do.call("labs", all_ggplot2_args$labs),
+ } else if (bins == 1) {
|
| 1031 | +673 | ! |
- theme = do.call("theme", all_ggplot2_args$theme)
+ return(as.character(tags$code("one date-time", class = "text-blue")))
|
| 1032 | +674 |
- )+ } |
|
| 1033 | -+ | ||
| 675 | +! |
- } else {
+ counts <- as.vector(unname(base::table(cut(arr_num, breaks = bins))))+ |
+ |
| 676 | +! | +
+ max_value <- max(counts) |
|
| 1034 | +677 |
- # factor low number of levels OR numeric as factor OR Date+ |
|
| 1035 | +678 | ! |
- plot_main <- plot_main ++ start_bins <- as.integer(seq(1, length(arr_num), length.out = bins)) |
| 1036 | +679 | ! |
- theme_light() ++ labels_start <- as.character(format(as.POSIXct(arr_num[start_bins], origin = as.Date("1970-01-01")), "%Y-%m-%d"))
|
| 1037 | +680 | ! |
- list(+ labels <- paste("Start:", labels_start)
+ |
+
| 681 | ++ | + | |
| 1038 | +682 | ! |
- labs = do.call("labs", all_ggplot2_args$labs),
+ sparkline::spk_chr( |
| 1039 | +683 | ! |
- theme = do.call("theme", all_ggplot2_args$theme)
+ unname(counts), |
| 1040 | -+ | ||
| 684 | +! |
- )+ type = "bar", |
|
| 1041 | -+ | ||
| 685 | +! |
- }+ chartRangeMin = 0, |
|
| 1042 | +686 | ! |
- plot_main <- ggplotGrob(plot_main)+ chartRangeMax = max_value, |
| 1043 | -+ | ||
| 687 | +! |
- }+ width = width, |
|
| 1044 | -+ | ||
| 688 | +! |
-
+ barWidth = bar_width, |
|
| 1045 | +689 | ! |
- grid::grid.draw(plot_main)+ barSpacing = bar_spacing, |
| 1046 | +690 | ! |
- plot_main+ tooltipFormatter = custom_sparkline_formatter(labels, counts) |
| 1047 | +691 |
- }+ ) |
|
| 1048 | +692 |
-
+ } |
|
| 1049 | +693 |
- is_num_var_short <- function(.unique_records_for_factor, input, data_for_analysis) {
- |
- |
| 1050 | -! | -
- length(unique(data_for_analysis()$data)) < .unique_records_for_factor && !is.null(input$numeric_as_factor)+ |
|
| 1051 | +694 |
- }+ |
|
| 1052 | +695 |
-
+ #' Generates the HTML code for the \code{sparkline} widget
|
|
| 1053 | +696 |
- #' Validates the variable browser inputs+ #' |
|
| 1054 | +697 |
- #'+ #' Coerces a character vector to factor and delegates to the \code{create_sparklines.factor}
|
|
| 1055 | +698 |
- #' @param input (`session$input`) the shiny session input+ #' |
|
| 1056 | +699 |
- #' @param plot_var (`list`) list of a data frame and an array of variable names+ #' |
|
| 1057 | +700 |
- #' @param data (`tdata`) the datasets passed to the module+ #' @return \code{character} with HTML code for the \code{sparkline} widget
|
|
| 1058 | +701 |
#' |
|
| 1059 | +702 |
- #' @returns `logical` TRUE if validations pass; a Shiny validation error otherwise+ #' @export |
|
| 1060 | +703 |
#' @keywords internal |
|
| 1061 | +704 |
- validate_input <- function(input, plot_var, data) {
+ #' @rdname create_sparklines |
|
| 1062 | -! | +||
| 705 | +
- reactive({
+ create_sparklines.character <- function(arr, ...) {
|
||
| 1063 | +706 | ! |
- dataset_name <- req(input$tabset_panel)+ return(create_sparklines(as.factor(arr))) |
| 1064 | -! | +||
| 707 | +
- varname <- plot_var$variable[[dataset_name]]+ } |
||
| 1065 | +708 | ||
| 1066 | -! | -
- validate(need(dataset_name, "No data selected"))- |
- |
| 1067 | -! | -
- validate(need(varname, "No variable selected"))- |
- |
| 1068 | -! | -
- df <- data()[[dataset_name]]- |
- |
| 1069 | -! | +||
| 709 | +
- teal::validate_has_data(df, 1)+ |
||
| 1070 | -! | +||
| 710 | +
- teal::validate_has_variable(varname = varname, data = df, "Variable not available")+ #' Generates the HTML code for the \code{sparkline} widget
|
||
| 1071 | +711 |
-
+ #' |
|
| 1072 | -! | +||
| 712 | +
- TRUE+ #' Coerces logical vector to factor and delegates to the \code{create_sparklines.factor}
|
||
| 1073 | +713 |
- })+ #' |
|
| 1074 | +714 |
- }+ #' |
|
| 1075 | +715 |
-
+ #' @return \code{character} with HTML code for the \code{sparkline} widget
|
|
| 1076 | +716 |
- get_plotted_data <- function(input, plot_var, data) {
+ #' |
|
| 1077 | -! | +||
| 717 | +
- dataset_name <- input$tabset_panel+ #' @export |
||
| 1078 | -! | +||
| 718 | +
- varname <- plot_var$variable[[dataset_name]]+ #' @keywords internal |
||
| 1079 | -! | +||
| 719 | +
- df <- data()[[dataset_name]]+ #' @rdname create_sparklines |
||
| 1080 | +720 |
-
+ create_sparklines.logical <- function(arr, ...) {
|
|
| 1081 | +721 | ! |
- var_description <- var_labels(df)[[varname]]+ return(create_sparklines(as.factor(arr))) |
| 1082 | -! | +||
| 722 | +
- list(data = df[[varname]], var_description = var_description)+ } |
||
| 1083 | +723 |
- }+ |
|
| 1084 | +724 | ||
| 1085 | +725 |
- #' Renders the left-hand side `tabset` panel of the module+ #' Generates the \code{sparkline} HTML code
|
|
| 1086 | +726 |
#' |
|
| 1087 | +727 |
- #' @param datanames (`character`) the name of the dataset+ #' @param bar_spacing \code{numeric} spacing between the bars (in pixels)
|
|
| 1088 | +728 |
- #' @param parent_dataname (`character`) the name of a parent `dataname` to filter out variables from+ #' @param bar_width \code{numeric} width of the bars (in pixels)
|
|
| 1089 | +729 |
- #' @param data (`tdata`) the object containing all datasets+ #' |
|
| 1090 | +730 |
- #' @param input (`session$input`) the shiny session input+ #' @return \code{character} with HTML code for the \code{sparkline} widget
|
|
| 1091 | +731 |
- #' @param output (`session$output`) the shiny session output+ #' |
|
| 1092 | +732 |
- #' @param columns_names (`environment`) the environment containing bindings for each dataset+ #' @export |
|
| 1093 | +733 |
- #' @param plot_var (`list`) the list containing the currently selected dataset (tab) and its column names+ #' @keywords internal |
|
| 1094 | +734 |
- #' @keywords internal+ #' @rdname create_sparklines |
|
| 1095 | +735 |
- render_tabset_panel_content <- function(datanames, parent_dataname, output, data, input, columns_names, plot_var) {
+ create_sparklines.factor <- function(arr, width = 150, bar_spacing = 5, bar_width = 20, ...) {
|
|
| 1096 | +736 | ! |
- lapply(datanames, render_single_tab,+ decreasing_order <- TRUE |
| 1097 | -! | +||
| 737 | +
- input = input,+ |
||
| 1098 | +738 | ! |
- output = output,+ counts <- table(arr) |
| 1099 | +739 | ! |
- data = data,+ if (length(counts) >= 100) {
|
| 1100 | +740 | ! |
- parent_dataname = parent_dataname,+ return(as.character(tags$code("> 99 levels", class = "text-blue")))
|
| 1101 | +741 | ! |
- columns_names = columns_names,+ } else if (length(counts) == 0) {
|
| 1102 | +742 | ! |
- plot_var = plot_var- |
-
| 1103 | -- |
- )- |
- |
| 1104 | -- |
- }+ return(as.character(tags$code("no levels", class = "text-blue")))
|
|
| 1105 | -+ | ||
| 743 | +! |
-
+ } else if (length(counts) == 1) {
|
|
| 1106 | -+ | ||
| 744 | +! |
- #' Renders a single tab in the left-hand side tabset panel+ return(as.character(tags$code("one level", class = "text-blue")))
|
|
| 1107 | +745 |
- #'+ } |
|
| 1108 | +746 |
- #' @description+ |
|
| 1109 | +747 |
- #' Renders a single tab in the left-hand side tabset panel. The rendered tab contains+ # Summarize the occurences of different levels |
|
| 1110 | +748 |
- #' information about one dataset out of many presented in the module.+ # and get the maximum and minimum number of occurences |
|
| 1111 | +749 |
- #'+ # This is needed for the sparkline to correctly display the bar plots |
|
| 1112 | +750 |
- #' @param dataset_name (`character`) the name of the dataset contained in the rendered tab+ # Otherwise they are cropped |
|
| 1113 | -+ | ||
| 751 | +! |
- #' @param parent_dataname (`character`) the name of a parent `dataname` to filter out variables from+ counts <- sort(counts, decreasing = decreasing_order, method = "radix") |
|
| 1114 | -+ | ||
| 752 | +! |
- #' @inheritParams render_tabset_panel_content+ max_value <- if (decreasing_order) counts[1] else counts[length[counts]] |
|
| 1115 | -+ | ||
| 753 | +! |
- #' @keywords internal+ max_value <- unname(max_value) |
|
| 1116 | +754 |
- render_single_tab <- function(dataset_name, parent_dataname, output, data, input, columns_names, plot_var) {
+
|
|
| 1117 | +755 | ! |
- render_tab_header(dataset_name, output, data)- |
-
| 1118 | -- |
-
+ sparkline::spk_chr( |
|
| 1119 | +756 | ! |
- render_tab_table(+ unname(counts), |
| 1120 | +757 | ! |
- dataset_name = dataset_name,+ type = "bar", |
| 1121 | +758 | ! |
- parent_dataname = parent_dataname,+ chartRangeMin = 0, |
| 1122 | +759 | ! |
- output = output,+ chartRangeMax = max_value, |
| 1123 | +760 | ! |
- data = data,+ width = width, |
| 1124 | +761 | ! |
- input = input,+ barWidth = bar_width, |
| 1125 | +762 | ! |
- columns_names = columns_names,+ barSpacing = bar_spacing, |
| 1126 | +763 | ! |
- plot_var = plot_var+ tooltipFormatter = custom_sparkline_formatter(names(counts), as.vector(counts)) |
| 1127 | +764 |
) |
|
| 1128 | +765 |
} |
|
| 1129 | +766 | ||
| 1130 | +767 |
- #' Renders the text headlining a single tab in the left-hand side tabset panel+ #' Generates the \code{sparkline} HTML code
|
|
| 1131 | +768 |
#' |
|
| 1132 | +769 |
- #' @param dataset_name (`character`) the name of the dataset of the tab+ #' |
|
| 1133 | +770 |
- #' @inheritParams render_tabset_panel_content+ #' @return \code{character} with HTML code for the \code{sparkline} widget
|
|
| 1134 | +771 | ++ |
+ #'+ |
+
| 772 | ++ |
+ #' @export+ |
+ |
| 773 |
#' @keywords internal |
||
| 1135 | +774 |
- render_tab_header <- function(dataset_name, output, data) {
+ #' @rdname create_sparklines |
|
| 1136 | -! | +||
| 775 | +
- dataset_ui_id <- paste0("dataset_summary_", dataset_name)
+ create_sparklines.numeric <- function(arr, width = 150, ...) {
|
||
| 1137 | +776 | ! |
- output[[dataset_ui_id]] <- renderText({
+ if (any(is.infinite(arr))) {
|
| 1138 | +777 | ! |
- df <- data()[[dataset_name]]+ return(as.character(tags$code("infinite values", class = "text-blue")))
|
| 1139 | -! | +||
| 778 | +
- join_keys <- join_keys(data())+ } |
||
| 1140 | +779 | ! |
- if (!is.null(join_keys)) {
+ if (length(arr) > 100000) {
|
| 1141 | +780 | ! |
- key <- join_keys(data())[dataset_name, dataset_name]+ return(as.character(tags$code("Too many rows (>100000)", class = "text-blue")))
|
| 1142 | +781 |
- } else {
- |
- |
| 1143 | -! | -
- key <- NULL+ } |
|
| 1144 | +782 |
- }+ |
|
| 1145 | +783 | ! |
- sprintf(+ arr <- arr[!is.na(arr)] |
| 1146 | +784 | ! |
- "Dataset with %s unique key rows and %s variables",+ res <- sparkline::spk_chr(unname(arr), type = "box", width = width, ...) |
| 1147 | +785 | ! |
- nrow(unique(`if`(length(key) > 0, df[, key, drop = FALSE], df))),+ return(res) |
| 1148 | -! | +||
| 786 | +
- ncol(df)+ } |
||
| 1149 | +787 |
- )+ |
|
| 1150 | +788 |
- })+ #' Summarizes variable |
|
| 1151 | +789 |
- }+ #' |
|
| 1152 | +790 |
-
+ #' Creates html summary with statistics relevant to data type. For numeric values it returns central |
|
| 1153 | +791 |
- #' Renders the table for a single dataset in the left-hand side tabset panel+ #' tendency measures, for factor returns level counts, for Date date range, for other just |
|
| 1154 | +792 |
- #'+ #' number of levels. |
|
| 1155 | +793 |
- #' @description+ #' @param x vector of any type |
|
| 1156 | +794 |
- #' The table contains column names, column labels,+ #' @param numeric_as_factor \code{logical} should the numeric variable be treated as a factor
|
|
| 1157 | +795 |
- #' small summary about NA values and `sparkline` (if appropriate).+ #' @param dt_rows \code{numeric} current/latest `DT` page length
|
|
| 1158 | +796 |
- #'+ #' @param outlier_definition If 0 no outliers are removed, otherwise |
|
| 1159 | +797 |
- #' @param dataset_name (`character`) the name of the dataset+ #' outliers (those more than outlier_definition*IQR below/above Q1/Q3 be removed) |
|
| 1160 | +798 |
- #' @param parent_dataname (`character`) the name of a parent `dataname` to filter out variables from+ #' @return text with simple statistics. |
|
| 1161 | +799 |
- #' @inheritParams render_tabset_panel_content+ #' @keywords internal |
|
| 1162 | +800 |
- #' @keywords internal+ var_summary_table <- function(x, numeric_as_factor, dt_rows, outlier_definition) {
+ |
+ |
| 801 | +! | +
+ if (is.null(dt_rows)) {
+ |
+ |
| 802 | +! | +
+ dt_rows <- 10 |
|
| 1163 | +803 |
- render_tab_table <- function(dataset_name, parent_dataname, output, data, input, columns_names, plot_var) {
+ } |
|
| 1164 | +804 | ! |
- table_ui_id <- paste0("variable_browser_", dataset_name)
+ if (is.numeric(x) && !numeric_as_factor) {
+ |
+
| 805 | +! | +
+ req(!any(is.infinite(x))) |
|
| 1165 | +806 | ||
| 1166 | +807 | ! |
- output[[table_ui_id]] <- DT::renderDataTable({
+ x <- remove_outliers_from(x, outlier_definition)+ |
+
| 808 | ++ | + | |
| 1167 | +809 | ! |
- df <- data()[[dataset_name]]+ qvals <- round(stats::quantile(x, na.rm = TRUE, probs = c(0.25, 0.5, 0.75), type = 2), 2) |
| 1168 | +810 | ++ |
+ # classical central tendency measures+ |
+
| 811 | |||
| 1169 | +812 | ! |
- get_vars_df <- function(input, dataset_name, parent_name, data) {
+ summary <- |
| 1170 | +813 | ! |
- data_cols <- colnames(df)+ data.frame( |
| 1171 | +814 | ! |
- if (isTRUE(input$show_parent_vars)) {
+ Statistic = c("min", "Q1", "median", "mean", "Q3", "max", "sd", "n"),
|
| 1172 | +815 | ! |
- data_cols+ Value = c( |
| 1173 | +816 | ! |
- } else if (dataset_name != parent_name && parent_name %in% names(data)) {
+ round(min(x, na.rm = TRUE), 2), |
| 1174 | +817 | ! |
- setdiff(data_cols, colnames(data()[[parent_name]]))+ qvals[1], |
| 1175 | -+ | ||
| 818 | +! |
- } else {
+ qvals[2], |
|
| 1176 | +819 | ! |
- data_cols+ round(mean(x, na.rm = TRUE), 2),+ |
+
| 820 | +! | +
+ qvals[3],+ |
+ |
| 821 | +! | +
+ round(max(x, na.rm = TRUE), 2),+ |
+ |
| 822 | +! | +
+ round(stats::sd(x, na.rm = TRUE), 2),+ |
+ |
| 823 | +! | +
+ length(x[!is.na(x)]) |
|
| 1177 | +824 |
- }+ ) |
|
| 1178 | +825 |
- }+ ) |
|
| 1179 | +826 | ||
| 1180 | +827 | ! |
- if (length(parent_dataname) > 0) {
+ DT::datatable(summary, rownames = FALSE, options = list(dom = "<t>", pageLength = dt_rows)) |
| 1181 | +828 | ! |
- df_vars <- get_vars_df(input, dataset_name, parent_dataname, data)+ } else if (is.factor(x) || is.character(x) || (is.numeric(x) && numeric_as_factor) || is.logical(x)) {
+ |
+
| 829 | ++ |
+ # make sure factor is ordered numeric |
|
| 1182 | +830 | ! |
- df <- df[df_vars]+ if (is.numeric(x)) {
+ |
+
| 831 | +! | +
+ x <- factor(x, levels = sort(unique(x))) |
|
| 1183 | +832 |
} |
|
| 1184 | +833 | ||
| 1185 | -! | -
- if (is.null(df) || ncol(df) == 0) {
- |
- |
| 1186 | +834 | ! |
- columns_names[[dataset_name]] <- character(0)+ level_counts <- table(x) |
| 1187 | +835 | ! |
- df_output <- data.frame(+ max_levels_signif <- nchar(level_counts) |
| 1188 | -! | +||
| 836 | +
- Type = character(0),+ |
||
| 1189 | +837 | ! |
- Variable = character(0),+ if (!all(is.na(x))) {
|
| 1190 | +838 | ! |
- Label = character(0),+ levels <- names(level_counts) |
| 1191 | +839 | ! |
- Missings = character(0),+ counts <- sprintf( |
| 1192 | +840 | ! |
- Sparklines = character(0),+ "%s [%.2f%%]", |
| 1193 | +841 | ! |
- stringsAsFactors = FALSE+ format(level_counts, width = max_levels_signif), prop.table(level_counts) * 100 |
| 1194 | +842 |
) |
|
| 1195 | +843 |
} else {
|
|
| 1196 | -- |
- # extract data variable labels- |
- |
| 1197 | +844 | ! |
- labels <- teal.data::col_labels(df)- |
-
| 1198 | -- |
-
+ levels <- character(0) |
|
| 1199 | +845 | ! |
- columns_names[[dataset_name]] <- names(labels)+ counts <- numeric(0) |
| 1200 | +846 |
-
+ } |
|
| 1201 | +847 |
- # calculate number of missing values- |
- |
| 1202 | -! | -
- missings <- vapply(+ |
|
| 1203 | +848 | ! |
- df,+ summary <- data.frame( |
| 1204 | +849 | ! |
- var_missings_info,+ Level = levels, |
| 1205 | +850 | ! |
- FUN.VALUE = character(1),+ Count = counts, |
| 1206 | +851 | ! |
- USE.NAMES = FALSE+ stringsAsFactors = FALSE |
| 1207 | +852 |
- )+ ) |
|
| 1208 | +853 | ||
| 1209 | +854 |
- # get icons proper for the data types+ # sort the dataset in decreasing order of counts (needed as character variables default to alphabetical) |
|
| 1210 | +855 | ! |
- icons <- vapply(df, function(x) class(x)[1L], character(1L))+ summary <- summary[order(summary$Count, decreasing = TRUE), ] |
| 1211 | +856 | ||
| 1212 | +857 | ! |
- join_keys <- join_keys(data())+ dom_opts <- if (nrow(summary) <= 10) {
|
| 1213 | +858 | ! |
- if (!is.null(join_keys)) {
+ "<t>"+ |
+
| 859 | ++ |
+ } else {
|
|
| 1214 | +860 | ! |
- icons[intersect(join_keys[dataset_name, dataset_name], colnames(df))] <- "primary_key"+ "<lf<t>ip>" |
| 1215 | +861 |
- }+ } |
|
| 1216 | +862 | ! |
- icons <- variable_type_icons(icons)+ DT::datatable(summary, rownames = FALSE, options = list(dom = dom_opts, pageLength = dt_rows)) |
| 1217 | -+ | ||
| 863 | +! |
-
+ } else if (inherits(x, "Date") || inherits(x, "POSIXct") || inherits(x, "POSIXlt")) {
|
|
| 1218 | -+ | ||
| 864 | +! |
- # generate sparklines+ summary <- |
|
| 1219 | +865 | ! |
- sparklines_html <- vapply(+ data.frame( |
| 1220 | +866 | ! |
- df,+ Statistic = c("min", "median", "max"),
|
| 1221 | +867 | ! |
- create_sparklines,+ Value = c( |
| 1222 | +868 | ! |
- FUN.VALUE = character(1),+ min(x, na.rm = TRUE), |
| 1223 | +869 | ! |
- USE.NAMES = FALSE+ stats::median(x, na.rm = TRUE),+ |
+
| 870 | +! | +
+ max(x, na.rm = TRUE) |
|
| 1224 | +871 |
- )+ ) |
|
| 1225 | +872 |
-
+ ) |
|
| 1226 | +873 | ! |
- df_output <- data.frame(+ DT::datatable(summary, rownames = FALSE, options = list(dom = "<t>", pageLength = dt_rows)) |
| 1227 | -! | +||
| 874 | +
- Type = icons,+ } else {
|
||
| 1228 | +875 | ! |
- Variable = names(labels),+ NULL |
| 1229 | -! | +||
| 876 | +
- Label = labels,+ } |
||
| 1230 | -! | +||
| 877 | +
- Missings = missings,+ } |
||
| 1231 | -! | +||
| 878 | +
- Sparklines = sparklines_html,+ |
||
| 1232 | -! | +||
| 879 | +
- stringsAsFactors = FALSE+ |
||
| 1233 | +880 |
- )+ #' Plot variable |
|
| 1234 | +881 |
- }+ #' |
|
| 1235 | +882 |
-
+ #' Creates summary plot with statistics relevant to data type. |
|
| 1236 | +883 |
- # Select row 1 as default / fallback+ #' @inheritParams shared_params |
|
| 1237 | -! | +||
| 884 | +
- selected_ix <- 1+ #' @param var vector of any type to be plotted. For numeric variables it produces histogram with |
||
| 1238 | +885 |
- # Define starting page index (base-0 index of the first item on page+ #' density line, for factors it creates frequency plot |
|
| 1239 | +886 |
- # note: in many cases it's not the item itself+ #' @param var_lab text describing selected variable to be displayed on the plot |
|
| 1240 | -! | +||
| 887 | +
- selected_page_ix <- 0+ #' @param wrap_character (`numeric`) number of characters at which to wrap text values of `var` |
||
| 1241 | +888 |
-
+ #' @param numeric_as_factor (`logical`) should the numeric variable be treated as a factor |
|
| 1242 | +889 |
- # Retrieve current selected variable if any+ #' @param display_density (`logical`) should density estimation be displayed for numeric values |
|
| 1243 | -! | +||
| 890 | +
- isolated_variable <- shiny::isolate(plot_var$variable[[dataset_name]])+ #' @param remove_NA_hist (`logical`) should (`NA`) values be removed for histogram of factor like variables |
||
| 1244 | +891 |
-
+ #' @param outlier_definition if 0 no outliers are removed, otherwise |
|
| 1245 | -! | +||
| 892 | +
- if (!is.null(isolated_variable)) {
+ #' outliers (those more than outlier_definition*IQR below/above Q1/Q3 be removed) |
||
| 1246 | -! | +||
| 893 | +
- index <- which(columns_names[[dataset_name]] == isolated_variable)[1]+ #' @param records_for_factor (`numeric`) if the number of factor levels is >= than this value then |
||
| 1247 | -! | +||
| 894 | +
- if (!is.null(index) && !is.na(index) && length(index) > 0) selected_ix <- index+ #' a graph of the factors isn't shown, only a list of values |
||
| 1248 | +895 |
- }+ #' |
|
| 1249 | +896 |
-
+ #' @return plot |
|
| 1250 | +897 |
- # Retrieve the index of the first item of the current page+ #' @keywords internal |
|
| 1251 | +898 |
- # it works with varying number of entries on the page (10, 25, ...)+ plot_var_summary <- function(var, |
|
| 1252 | -! | +||
| 899 | +
- table_id_sel <- paste0("variable_browser_", dataset_name, "_state")
+ var_lab, |
||
| 1253 | -! | +||
| 900 | +
- dt_state <- shiny::isolate(input[[table_id_sel]])+ wrap_character = NULL, |
||
| 1254 | -! | +||
| 901 | +
- if (selected_ix != 1 && !is.null(dt_state)) {
+ numeric_as_factor, |
||
| 1255 | -! | +||
| 902 | +
- selected_page_ix <- floor(selected_ix / dt_state$length) * dt_state$length+ display_density = is.numeric(var), |
||
| 1256 | +903 |
- }+ remove_NA_hist = FALSE, # nolint: object_name. |
|
| 1257 | +904 |
-
+ outlier_definition, |
|
| 1258 | -! | +||
| 905 | +
- DT::datatable(+ records_for_factor, |
||
| 1259 | -! | +||
| 906 | +
- df_output,+ ggplot2_args) {
|
||
| 1260 | +907 | ! |
- escape = FALSE,+ checkmate::assert_character(var_lab) |
| 1261 | +908 | ! |
- rownames = FALSE,+ checkmate::assert_numeric(wrap_character, null.ok = TRUE) |
| 1262 | +909 | ! |
- selection = list(mode = "single", target = "row", selected = selected_ix),+ checkmate::assert_flag(numeric_as_factor) |
| 1263 | +910 | ! |
- options = list(+ checkmate::assert_flag(display_density) |
| 1264 | +911 | ! |
- fnDrawCallback = htmlwidgets::JS("function() { HTMLWidgets.staticRender(); }"),
+ checkmate::assert_logical(remove_NA_hist, null.ok = TRUE) |
| 1265 | +912 | ! |
- pageLength = input[[paste0(table_ui_id, "_rows")]],+ checkmate::assert_number(outlier_definition, lower = 0, finite = TRUE) |
| 1266 | +913 | ! |
- displayStart = selected_page_ix- |
-
| 1267 | -- |
- )- |
- |
| 1268 | -- |
- )- |
- |
| 1269 | -- |
- })+ checkmate::assert_integerish(records_for_factor, lower = 0, len = 1, any.missing = FALSE) |
|
| 1270 | -+ | ||
| 914 | +! |
- }+ checkmate::assert_class(ggplot2_args, "ggplot2_args") |
|
| 1271 | +915 | ||
| 1272 | -- |
- #' Creates observers updating the currently selected column- |
- |
| 1273 | -+ | ||
| 916 | +! |
- #'+ grid::grid.newpage() |
|
| 1274 | +917 |
- #' @description+ |
|
| 1275 | -+ | ||
| 918 | +! |
- #' The created observers update the column currently selected in the left-hand side+ plot_main <- if (is.factor(var) || is.character(var) || is.logical(var)) {
|
|
| 1276 | -+ | ||
| 919 | +! |
- #' tabset panel.+ groups <- unique(as.character(var)) |
|
| 1277 | -+ | ||
| 920 | +! |
- #'+ len_groups <- length(groups) |
|
| 1278 | -+ | ||
| 921 | +! |
- #' @note+ if (len_groups >= records_for_factor) {
|
|
| 1279 | -+ | ||
| 922 | +! |
- #' Creates an observer for each dataset (each tab in the tabset panel).+ grid::textGrob( |
|
| 1280 | -+ | ||
| 923 | +! |
- #'+ sprintf( |
|
| 1281 | -+ | ||
| 924 | +! |
- #' @inheritParams render_tabset_panel_content+ "%s unique values\n%s:\n %s\n ...\n %s", |
|
| 1282 | -+ | ||
| 925 | +! |
- #' @keywords internal+ len_groups, |
|
| 1283 | -+ | ||
| 926 | +! |
- establish_updating_selection <- function(datanames, input, plot_var, columns_names) {
+ var_lab, |
|
| 1284 | +927 | ! |
- lapply(datanames, function(dataset_name) {
+ paste(utils::head(groups), collapse = ",\n "), |
| 1285 | +928 | ! |
- table_ui_id <- paste0("variable_browser_", dataset_name)
+ paste(utils::tail(groups), collapse = ",\n ") |
| 1286 | -! | +||
| 929 | +
- table_id_sel <- paste0(table_ui_id, "_rows_selected")+ ), |
||
| 1287 | +930 | ! |
- observeEvent(input[[table_id_sel]], {
+ x = grid::unit(1, "line"), |
| 1288 | +931 | ! |
- plot_var$data <- dataset_name+ y = grid::unit(1, "npc") - grid::unit(1, "line"), |
| 1289 | +932 | ! |
- plot_var$variable[[dataset_name]] <- columns_names[[dataset_name]][input[[table_id_sel]]]+ just = c("left", "top")
|
| 1290 | +933 |
- })+ ) |
|
| 1291 | +934 |
- })+ } else {
|
|
| 1292 | -+ | ||
| 935 | +! |
- }+ if (!is.null(wrap_character)) {
|
|
| 1293 | -+ | ||
| 936 | +! |
-
+ var <- stringr::str_wrap(var, width = wrap_character) |
|
| 1294 | +937 |
- get_bin_width <- function(x_vec, scaling_factor = 2) {
- |
- |
| 1295 | -! | -
- x_vec <- x_vec[!is.na(x_vec)]+ } |
|
| 1296 | +938 | ! |
- qntls <- stats::quantile(x_vec, probs = c(0.1, 0.25, 0.75, 0.9), type = 2)+ var <- if (isTRUE(remove_NA_hist)) as.vector(stats::na.omit(var)) else var |
| 1297 | +939 | ! |
- iqr <- qntls[3] - qntls[2]+ ggplot(data.frame(var), aes(x = forcats::fct_infreq(as.factor(var)))) + |
| 1298 | +940 | ! |
- binwidth <- max(scaling_factor * iqr / length(x_vec) ^ (1 / 3), sqrt(qntls[4] - qntls[1])) # styler: off+ geom_bar(stat = "count", aes(fill = ifelse(is.na(var), "withcolor", "")), show.legend = FALSE) + |
| 1299 | +941 | ! |
- binwidth <- ifelse(binwidth == 0, 1, binwidth)+ scale_fill_manual(values = c("gray50", "tan"))
|
| 1300 | +942 |
- # to ensure at least two bins when variable span is very small+ } |
|
| 1301 | +943 | ! |
- x_span <- diff(range(x_vec))+ } else if (is.numeric(var)) {
|
| 1302 | +944 | ! |
- if (isTRUE(x_span / binwidth >= 2)) binwidth else x_span / 2+ validate(need(any(!is.na(var)), "No data left to visualize.")) |
| 1303 | +945 |
- }+ |
|
| 1304 | +946 | ++ |
+ # Filter out NA+ |
+
| 947 | +! | +
+ var <- var[which(!is.na(var))]+ |
+ |
| 948 | |||
| 949 | +! | +
+ validate(need(!any(is.infinite(var)), "Cannot display graph when data includes infinite values"))+ |
+ |
| 1305 | +950 |
- custom_sparkline_formatter <- function(labels, counts) {
+
|
|
| 1306 | +951 | ! |
- htmlwidgets::JS(+ if (numeric_as_factor) {
|
| 1307 | +952 | ! |
- sprintf(+ var <- factor(var) |
| 1308 | +953 | ! |
- "function(sparkline, options, field) {
+ ggplot(NULL, aes(x = var)) + |
| 1309 | +954 | ! |
- return 'ID: ' + %s[field[0].offset] + '<br>' + 'Count: ' + %s[field[0].offset];+ geom_histogram(stat = "count") |
| 1310 | +955 |
- }",+ } else {
+ |
+ |
| 956 | ++ |
+ # remove outliers |
|
| 1311 | +957 | ! |
- jsonlite::toJSON(labels),+ if (outlier_definition != 0) {
|
| 1312 | +958 | ! |
- jsonlite::toJSON(counts)+ number_records <- length(var) |
| 1313 | -+ | ||
| 959 | +! |
- )+ var <- remove_outliers_from(var, outlier_definition) |
|
| 1314 | -+ | ||
| 960 | +! |
- )+ number_outliers <- number_records - length(var) |
|
| 1315 | -+ | ||
| 961 | +! |
- }+ outlier_text <- paste0( |
|
| 1316 | -+ | ||
| 962 | +! |
-
+ number_outliers, " outliers (",
|
|
| 1317 | -+ | ||
| 963 | +! |
- #' Removes the outlier observation from an array+ round(number_outliers / number_records * 100, 2), |
|
| 1318 | -+ | ||
| 964 | +! |
- #'+ "% of non-missing records) not shown" |
|
| 1319 | +965 |
- #' @param var (`numeric`) a numeric vector+ ) |
|
| 1320 | -+ | ||
| 966 | +! |
- #' @param outlier_definition (`numeric`) if `0` then no outliers are removed, otherwise+ validate(need( |
|
| 1321 | -+ | ||
| 967 | +! |
- #' outliers (those more than `outlier_definition*IQR below/above Q1/Q3`) are removed+ length(var) > 1, |
|
| 1322 | -+ | ||
| 968 | +! |
- #' @returns (`numeric`) vector without the outlier values+ "At least two data points must remain after removing outliers for this graph to be displayed" |
|
| 1323 | +969 |
- #' @keywords internal+ )) |
|
| 1324 | +970 |
- remove_outliers_from <- function(var, outlier_definition) {
- |
- |
| 1325 | -3x | -
- if (outlier_definition == 0) {
- |
- |
| 1326 | -1x | -
- return(var)+ } |
|
| 1327 | +971 |
- }+ ## histogram |
|
| 1328 | -2x | +||
| 972 | +! |
- q1_q3 <- stats::quantile(var, probs = c(0.25, 0.75), type = 2, na.rm = TRUE)+ binwidth <- get_bin_width(var) |
|
| 1329 | -2x | +||
| 973 | +! |
- iqr <- q1_q3[2] - q1_q3[1]+ p <- ggplot(data = data.frame(var = var), aes(x = var, y = after_stat(count))) + |
|
| 1330 | -2x | +||
| 974 | +! |
- var[var >= q1_q3[1] - outlier_definition * iqr & var <= q1_q3[2] + outlier_definition * iqr]+ geom_histogram(binwidth = binwidth) + |
|
| 1331 | -+ | ||
| 975 | +! |
- }+ scale_y_continuous( |
| 1 | -+ | ||
| 976 | +! |
- #' Data Table Viewer Teal Module+ sec.axis = sec_axis( |
|
| 2 | -+ | ||
| 977 | +! |
- #'+ trans = ~ . / nrow(data.frame(var = var)), |
|
| 3 | -+ | ||
| 978 | +! |
- #' A data table viewer shows the data using a paginated table.+ labels = scales::percent, |
|
| 4 | -+ | ||
| 979 | +! |
- #' specifically designed for use with `data.frames`.+ name = "proportion (in %)" |
|
| 5 | +980 |
- #' @md+ ) |
|
| 6 | +981 |
- #'+ ) |
|
| 7 | +982 |
- #' @inheritParams teal::module+ |
|
| 8 | -+ | ||
| 983 | +! |
- #' @inheritParams shared_params+ if (display_density) {
|
|
| 9 | -+ | ||
| 984 | +! |
- #' @param variables_selected (`list`) A named list of character vectors of the variables (i.e. columns)+ p <- p + geom_density(aes(y = after_stat(count * binwidth))) |
|
| 10 | +985 |
- #' which should be initially shown for each dataset. Names of list elements should correspond to the names+ } |
|
| 11 | +986 |
- #' of the datasets available in the app. If no entry is specified for a dataset, the first six variables from that+ |
|
| 12 | -+ | ||
| 987 | +! |
- #' dataset will initially be shown.+ if (outlier_definition != 0) {
|
|
| 13 | -+ | ||
| 988 | +! |
- #' @param datasets_selected (`character`) A vector of datasets which should be+ p <- p + annotate( |
|
| 14 | -+ | ||
| 989 | +! |
- #' shown and in what order. Names in the vector have to correspond with datasets names.+ geom = "text", |
|
| 15 | -+ | ||
| 990 | +! |
- #' If vector of length zero (default) then all datasets are shown.+ label = outlier_text, |
|
| 16 | -+ | ||
| 991 | +! |
- #' Note: Only datasets of the `data.frame` class are compatible;+ x = Inf, y = Inf, |
|
| 17 | -+ | ||
| 992 | +! |
- #' using other types will cause an error.+ hjust = 1.02, vjust = 1.2, |
|
| 18 | -+ | ||
| 993 | +! |
- #' @param dt_args (named `list`) Additional arguments to be passed to `DT::datatable`+ color = "black", |
|
| 19 | +994 |
- #' (must not include `data` or `options`).+ # explicitly modify geom text size according |
|
| 20 | -+ | ||
| 995 | +! |
- #' @param dt_options (named `list`) The `options` argument to `DT::datatable`. By default+ size = ggplot2_args[["theme"]][["text"]][["size"]] / 3.5 |
|
| 21 | +996 |
- #' `list(searching = FALSE, pageLength = 30, lengthMenu = c(5, 15, 30, 100), scrollX = TRUE)`+ ) |
|
| 22 | +997 |
- #' @param server_rendering (`logical`) should the data table be rendered server side+ } |
|
| 23 | -+ | ||
| 998 | +! |
- #' (see `server` argument of `DT::renderDataTable()`)+ p |
|
| 24 | +999 |
- #' @details+ } |
|
| 25 | -+ | ||
| 1000 | +! |
- #' The `DT` package has an option `DT.TOJSON_ARGS` to show `Inf` and `NA` in data tables. If this is something+ } else if (inherits(var, "Date") || inherits(var, "POSIXct") || inherits(var, "POSIXlt")) {
|
|
| 26 | -+ | ||
| 1001 | +! |
- #' you require then set `options(DT.TOJSON_ARGS = list(na = "string"))` before running the module.+ var_num <- as.numeric(var) |
|
| 27 | -+ | ||
| 1002 | +! |
- #' Note though that sorting of numeric columns with `NA`/`Inf` will be lexicographic not numerical.+ binwidth <- get_bin_width(var_num, 1) |
|
| 28 | -+ | ||
| 1003 | +! |
- #'+ p <- ggplot(data = data.frame(var = var), aes(x = var, y = after_stat(count))) + |
|
| 29 | -+ | ||
| 1004 | +! |
- #' @examples+ geom_histogram(binwidth = binwidth) |
|
| 30 | +1005 |
- #' # general data example+ } else {
|
|
| 31 | -+ | ||
| 1006 | +! |
- #'+ grid::textGrob( |
|
| 32 | -+ | ||
| 1007 | +! |
- #' data <- teal_data()+ paste(strwrap( |
|
| 33 | -+ | ||
| 1008 | +! |
- #' data <- within(data, {
+ utils::capture.output(utils::str(var)), |
|
| 34 | -+ | ||
| 1009 | +! |
- #' library(nestcolor)+ width = .9 * grid::convertWidth(grid::unit(1, "npc"), "char", TRUE) |
|
| 35 | -+ | ||
| 1010 | +! |
- #' iris <- iris+ ), collapse = "\n"), |
|
| 36 | -+ | ||
| 1011 | +! |
- #' })+ x = grid::unit(1, "line"), y = grid::unit(1, "npc") - grid::unit(1, "line"), just = c("left", "top")
|
|
| 37 | +1012 |
- #' datanames(data) <- c("iris")
+ ) |
|
| 38 | +1013 |
- #'+ } |
|
| 39 | +1014 |
- #' app <- init(+ |
|
| 40 | -+ | ||
| 1015 | +! |
- #' data = data,+ dev_ggplot2_args <- teal.widgets::ggplot2_args( |
|
| 41 | -+ | ||
| 1016 | +! |
- #' modules = modules(+ labs = list(x = var_lab) |
|
| 42 | +1017 |
- #' tm_data_table(+ ) |
|
| 43 | +1018 |
- #' variables_selected = list(+ ### |
|
| 44 | -+ | ||
| 1019 | +! |
- #' iris = c("Sepal.Length", "Sepal.Width", "Petal.Length", "Petal.Width", "Species")
+ all_ggplot2_args <- teal.widgets::resolve_ggplot2_args( |
|
| 45 | -+ | ||
| 1020 | +! |
- #' ),+ ggplot2_args, |
|
| 46 | -+ | ||
| 1021 | +! |
- #' dt_args = list(caption = "ADSL Table Caption")+ module_plot = dev_ggplot2_args |
|
| 47 | +1022 |
- #' )+ ) |
|
| 48 | +1023 |
- #' )+ |
|
| 49 | -+ | ||
| 1024 | +! |
- #' )+ if (is.ggplot(plot_main)) {
|
|
| 50 | -+ | ||
| 1025 | +! |
- #' if (interactive()) {
+ if (is.numeric(var) && !numeric_as_factor) {
|
|
| 51 | +1026 |
- #' shinyApp(app$ui, app$server)+ # numeric not as factor |
|
| 52 | -+ | ||
| 1027 | +! |
- #' }+ plot_main <- plot_main + |
|
| 53 | -+ | ||
| 1028 | +! |
- #'+ theme_light() + |
|
| 54 | -+ | ||
| 1029 | +! |
- #' # CDISC data example+ list( |
|
| 55 | -+ | ||
| 1030 | +! |
- #' data <- teal_data()+ labs = do.call("labs", all_ggplot2_args$labs),
|
|
| 56 | -+ | ||
| 1031 | +! |
- #' data <- within(data, {
+ theme = do.call("theme", all_ggplot2_args$theme)
|
|
| 57 | +1032 |
- #' library(nestcolor)+ ) |
|
| 58 | +1033 |
- #' ADSL <- rADSL+ } else {
|
|
| 59 | +1034 |
- #' })+ # factor low number of levels OR numeric as factor OR Date |
|
| 60 | -+ | ||
| 1035 | +! |
- #' datanames(data) <- "ADSL"+ plot_main <- plot_main + |
|
| 61 | -+ | ||
| 1036 | +! |
- #' join_keys(data) <- default_cdisc_join_keys[datanames(data)]+ theme_light() + |
|
| 62 | -+ | ||
| 1037 | +! |
- #'+ list( |
|
| 63 | -+ | ||
| 1038 | +! |
- #' app <- init(+ labs = do.call("labs", all_ggplot2_args$labs),
|
|
| 64 | -+ | ||
| 1039 | +! |
- #' data = data,+ theme = do.call("theme", all_ggplot2_args$theme)
|
|
| 65 | +1040 |
- #' modules = modules(+ ) |
|
| 66 | +1041 |
- #' tm_data_table(+ } |
|
| 67 | -+ | ||
| 1042 | +! |
- #' variables_selected = list(ADSL = c("STUDYID", "USUBJID", "SUBJID", "SITEID", "AGE", "SEX")),
+ plot_main <- ggplotGrob(plot_main) |
|
| 68 | +1043 |
- #' dt_args = list(caption = "ADSL Table Caption")+ } |
|
| 69 | +1044 |
- #' )+ |
|
| 70 | -+ | ||
| 1045 | +! |
- #' )+ grid::grid.draw(plot_main) |
|
| 71 | -+ | ||
| 1046 | +! |
- #' )+ plot_main |
|
| 72 | +1047 |
- #' if (interactive()) {
+ } |
|
| 73 | +1048 |
- #' shinyApp(app$ui, app$server)+ |
|
| 74 | +1049 |
- #' }+ is_num_var_short <- function(.unique_records_for_factor, input, data_for_analysis) {
|
|
| 75 | -+ | ||
| 1050 | +! |
- #'+ length(unique(data_for_analysis()$data)) < .unique_records_for_factor && !is.null(input$numeric_as_factor) |
|
| 76 | +1051 |
- #' @export+ } |
|
| 77 | +1052 |
- #'+ |
|
| 78 | +1053 |
- tm_data_table <- function(label = "Data Table",+ #' Validates the variable browser inputs |
|
| 79 | +1054 |
- variables_selected = list(),+ #' |
|
| 80 | +1055 |
- datasets_selected = character(0),+ #' @param input (`session$input`) the shiny session input |
|
| 81 | +1056 |
- dt_args = list(),+ #' @param plot_var (`list`) list of a data frame and an array of variable names |
|
| 82 | +1057 |
- dt_options = list(+ #' @param data (`tdata`) the datasets passed to the module |
|
| 83 | +1058 |
- searching = FALSE,+ #' |
|
| 84 | +1059 |
- pageLength = 30,+ #' @returns `logical` TRUE if validations pass; a Shiny validation error otherwise |
|
| 85 | +1060 |
- lengthMenu = c(5, 15, 30, 100),+ #' @keywords internal |
|
| 86 | +1061 |
- scrollX = TRUE+ validate_input <- function(input, plot_var, data) {
|
|
| 87 | -+ | ||
| 1062 | +! |
- ),+ reactive({
|
|
| 88 | -+ | ||
| 1063 | +! |
- server_rendering = FALSE,+ dataset_name <- req(input$tabset_panel) |
|
| 89 | -+ | ||
| 1064 | +! |
- pre_output = NULL,+ varname <- plot_var$variable[[dataset_name]] |
|
| 90 | +1065 |
- post_output = NULL) {
+
|
|
| 91 | +1066 | ! |
- logger::log_info("Initializing tm_data_table")
+ validate(need(dataset_name, "No data selected")) |
| 92 | +1067 | ! |
- checkmate::assert_string(label)+ validate(need(varname, "No variable selected")) |
| 93 | +1068 | ! |
- checkmate::assert_list(variables_selected, min.len = 0, types = "character", names = "named")+ df <- data()[[dataset_name]] |
| 94 | +1069 | ! |
- if (length(variables_selected) > 0) {
+ teal::validate_has_data(df, 1) |
| 95 | +1070 | ! |
- lapply(seq_along(variables_selected), function(i) {
+ teal::validate_has_variable(varname = varname, data = df, "Variable not available") |
| 96 | -! | +||
| 1071 | +
- checkmate::assert_character(variables_selected[[i]], min.chars = 1, min.len = 1)+ |
||
| 97 | +1072 | ! |
- if (!is.null(names(variables_selected[[i]]))) {
+ TRUE |
| 98 | -! | +||
| 1073 | +
- checkmate::assert_names(names(variables_selected[[i]]))+ }) |
||
| 99 | +1074 |
- }+ } |
|
| 100 | +1075 |
- })+ |
|
| 101 | +1076 |
- }+ get_plotted_data <- function(input, plot_var, data) {
|
|
| 102 | +1077 | ! |
- checkmate::assert_character(datasets_selected, min.len = 0, min.chars = 1)+ dataset_name <- input$tabset_panel |
| 103 | +1078 | ! |
- checkmate::assert_list(dt_options, names = "named")+ varname <- plot_var$variable[[dataset_name]] |
| 104 | +1079 | ! |
- checkmate::assert(+ df <- data()[[dataset_name]]+ |
+
| 1080 | ++ | + | |
| 105 | +1081 | ! |
- checkmate::check_list(dt_args, len = 0),+ var_description <- var_labels(df)[[varname]] |
| 106 | +1082 | ! |
- checkmate::check_subset(names(dt_args), choices = names(formals(DT::datatable)))+ list(data = df[[varname]], var_description = var_description) |
| 107 | +1083 |
- )+ } |
|
| 108 | +1084 | ||
| 109 | -! | +||
| 1085 | +
- checkmate::assert_flag(server_rendering)+ #' Renders the left-hand side `tabset` panel of the module |
||
| 110 | +1086 |
-
+ #' |
|
| 111 | -! | +||
| 1087 | +
- module(+ #' @param datanames (`character`) the name of the dataset |
||
| 112 | -! | +||
| 1088 | +
- label,+ #' @param parent_dataname (`character`) the name of a parent `dataname` to filter out variables from |
||
| 113 | -! | +||
| 1089 | +
- server = srv_page_data_table,+ #' @param data (`tdata`) the object containing all datasets |
||
| 114 | -! | +||
| 1090 | +
- ui = ui_page_data_table,+ #' @param input (`session$input`) the shiny session input+ |
+ ||
| 1091 | ++ |
+ #' @param output (`session$output`) the shiny session output+ |
+ |
| 1092 | ++ |
+ #' @param columns_names (`environment`) the environment containing bindings for each dataset+ |
+ |
| 1093 | ++ |
+ #' @param plot_var (`list`) the list containing the currently selected dataset (tab) and its column names+ |
+ |
| 1094 | ++ |
+ #' @keywords internal+ |
+ |
| 1095 | ++ |
+ render_tabset_panel_content <- function(datanames, parent_dataname, output, data, input, columns_names, plot_var) {
|
|
| 115 | +1096 | ! |
- datanames = if (length(datasets_selected) == 0) "all" else datasets_selected,+ lapply(datanames, render_single_tab, |
| 116 | +1097 | ! |
- server_args = list(+ input = input, |
| 117 | +1098 | ! |
- variables_selected = variables_selected,+ output = output, |
| 118 | +1099 | ! |
- datasets_selected = datasets_selected,+ data = data, |
| 119 | +1100 | ! |
- dt_args = dt_args,+ parent_dataname = parent_dataname, |
| 120 | +1101 | ! |
- dt_options = dt_options,+ columns_names = columns_names, |
| 121 | +1102 | ! |
- server_rendering = server_rendering+ plot_var = plot_var |
| 122 | +1103 |
- ),+ ) |
|
| 123 | -! | +||
| 1104 | +
- ui_args = list(+ } |
||
| 124 | -! | +||
| 1105 | +
- pre_output = pre_output,+ |
||
| 125 | -! | +||
| 1106 | +
- post_output = post_output+ #' Renders a single tab in the left-hand side tabset panel |
||
| 126 | +1107 |
- )+ #' |
|
| 127 | +1108 |
- )+ #' @description |
|
| 128 | +1109 |
- }+ #' Renders a single tab in the left-hand side tabset panel. The rendered tab contains |
|
| 129 | +1110 |
-
+ #' information about one dataset out of many presented in the module. |
|
| 130 | +1111 |
-
+ #' |
|
| 131 | +1112 |
- # ui page module+ #' @param dataset_name (`character`) the name of the dataset contained in the rendered tab |
|
| 132 | +1113 |
- ui_page_data_table <- function(id,+ #' @param parent_dataname (`character`) the name of a parent `dataname` to filter out variables from |
|
| 133 | +1114 |
- pre_output = NULL,+ #' @inheritParams render_tabset_panel_content |
|
| 134 | +1115 |
- post_output = NULL) {
+ #' @keywords internal+ |
+ |
| 1116 | ++ |
+ render_single_tab <- function(dataset_name, parent_dataname, output, data, input, columns_names, plot_var) {
|
|
| 135 | +1117 | ! |
- ns <- NS(id)+ render_tab_header(dataset_name, output, data) |
| 136 | +1118 | ||
| 137 | +1119 | ! |
- shiny::tagList(+ render_tab_table( |
| 138 | +1120 | ! |
- include_css_files("custom"),
+ dataset_name = dataset_name, |
| 139 | +1121 | ! |
- teal.widgets::standard_layout(+ parent_dataname = parent_dataname, |
| 140 | +1122 | ! |
- output = teal.widgets::white_small_well(+ output = output, |
| 141 | +1123 | ! |
- fluidRow(+ data = data, |
| 142 | +1124 | ! |
- column(+ input = input, |
| 143 | +1125 | +! | +
+ columns_names = columns_names,+ |
+
| 1126 | ! |
- width = 12,+ plot_var = plot_var+ |
+ |
| 1127 | ++ |
+ )+ |
+ |
| 1128 | ++ |
+ } |
|
| 144 | -! | +||
| 1129 | +
- checkboxInput(+ |
||
| 145 | -! | +||
| 1130 | +
- ns("if_distinct"),
+ #' Renders the text headlining a single tab in the left-hand side tabset panel |
||
| 146 | -! | +||
| 1131 | +
- "Show only distinct rows:",+ #' |
||
| 147 | -! | +||
| 1132 | +
- value = FALSE+ #' @param dataset_name (`character`) the name of the dataset of the tab |
||
| 148 | +1133 |
- )+ #' @inheritParams render_tabset_panel_content |
|
| 149 | +1134 |
- )+ #' @keywords internal |
|
| 150 | +1135 |
- ),+ render_tab_header <- function(dataset_name, output, data) {
|
|
| 151 | +1136 | ! |
- fluidRow(+ dataset_ui_id <- paste0("dataset_summary_", dataset_name)
|
| 152 | +1137 | ! |
- class = "mb-8",+ output[[dataset_ui_id]] <- renderText({
|
| 153 | +1138 | ! |
- column(+ df <- data()[[dataset_name]] |
| 154 | +1139 | ! |
- width = 12,+ join_keys <- join_keys(data()) |
| 155 | +1140 | ! |
- uiOutput(ns("dataset_table"))
+ if (!is.null(join_keys)) {
|
| 156 | -+ | ||
| 1141 | +! |
- )+ key <- join_keys(data())[dataset_name, dataset_name] |
|
| 157 | +1142 |
- )+ } else {
+ |
+ |
| 1143 | +! | +
+ key <- NULL |
|
| 158 | +1144 |
- ),+ } |
|
| 159 | +1145 | ! |
- pre_output = pre_output,+ sprintf( |
| 160 | +1146 | ! |
- post_output = post_output+ "Dataset with %s unique key rows and %s variables",+ |
+
| 1147 | +! | +
+ nrow(unique(`if`(length(key) > 0, df[, key, drop = FALSE], df))),+ |
+ |
| 1148 | +! | +
+ ncol(df) |
|
| 161 | +1149 |
) |
|
| 162 | +1150 |
- )+ }) |
|
| 163 | +1151 |
} |
|
| 164 | +1152 | ||
| 165 | +1153 |
-
+ #' Renders the table for a single dataset in the left-hand side tabset panel |
|
| 166 | +1154 |
- # server page module+ #' |
|
| 167 | +1155 |
- srv_page_data_table <- function(id,+ #' @description |
|
| 168 | +1156 |
- data,+ #' The table contains column names, column labels, |
|
| 169 | +1157 |
- datasets_selected,+ #' small summary about NA values and `sparkline` (if appropriate). |
|
| 170 | +1158 |
- variables_selected,+ #' |
|
| 171 | +1159 |
- dt_args,+ #' @param dataset_name (`character`) the name of the dataset |
|
| 172 | +1160 |
- dt_options,+ #' @param parent_dataname (`character`) the name of a parent `dataname` to filter out variables from |
|
| 173 | +1161 |
- server_rendering) {
+ #' @inheritParams render_tabset_panel_content |
|
| 174 | -! | +||
| 1162 | +
- checkmate::assert_class(data, "reactive")+ #' @keywords internal |
||
| 175 | -! | +||
| 1163 | +
- checkmate::assert_class(isolate(data()), "teal_data")+ render_tab_table <- function(dataset_name, parent_dataname, output, data, input, columns_names, plot_var) {
|
||
| 176 | +1164 | ! |
- moduleServer(id, function(input, output, session) {
+ table_ui_id <- paste0("variable_browser_", dataset_name)
+ |
+
| 1165 | ++ | + | |
| 177 | +1166 | ! |
- if_filtered <- reactive(as.logical(input$if_filtered))+ output[[table_ui_id]] <- DT::renderDataTable({
|
| 178 | +1167 | ! |
- if_distinct <- reactive(as.logical(input$if_distinct))+ df <- data()[[dataset_name]] |
| 179 | +1168 | ||
| 180 | +1169 | ! |
- datanames <- isolate(teal.data::datanames(data()))+ get_vars_df <- function(input, dataset_name, parent_name, data) {
|
| 181 | +1170 | ! |
- datanames <- Filter(function(name) {
+ data_cols <- colnames(df) |
| 182 | +1171 | ! |
- is.data.frame(isolate(data())[[name]])+ if (isTRUE(input$show_parent_vars)) {
|
| 183 | +1172 | ! |
- }, datanames)+ data_cols |
| 184 | -+ | ||
| 1173 | +! |
-
+ } else if (dataset_name != parent_name && parent_name %in% names(data)) {
|
|
| 185 | +1174 | ! |
- if (!identical(datasets_selected, character(0))) {
+ setdiff(data_cols, colnames(data()[[parent_name]])) |
| 186 | -! | +||
| 1175 | +
- checkmate::assert_subset(datasets_selected, datanames)+ } else {
|
||
| 187 | +1176 | ! |
- datanames <- datasets_selected+ data_cols |
| 188 | +1177 |
- }+ } |
|
| 189 | +1178 |
-
+ } |
|
| 190 | -! | +||
| 1179 | +
- output$dataset_table <- renderUI({
+
|
||
| 191 | +1180 | ! |
- do.call(+ if (length(parent_dataname) > 0) {
|
| 192 | +1181 | ! |
- tabsetPanel,+ df_vars <- get_vars_df(input, dataset_name, parent_dataname, data) |
| 193 | +1182 | ! |
- lapply(+ df <- df[df_vars] |
| 194 | -! | +||
| 1183 | +
- datanames,+ } |
||
| 195 | -! | +||
| 1184 | +
- function(x) {
+
|
||
| 196 | +1185 | ! |
- dataset <- isolate(data()[[x]])+ if (is.null(df) || ncol(df) == 0) {
|
| 197 | +1186 | ! |
- choices <- names(dataset)+ columns_names[[dataset_name]] <- character(0) |
| 198 | +1187 | ! |
- labels <- vapply(+ df_output <- data.frame( |
| 199 | +1188 | ! |
- dataset,+ Type = character(0), |
| 200 | +1189 | ! |
- function(x) ifelse(is.null(attr(x, "label")), "", attr(x, "label")),+ Variable = character(0), |
| 201 | +1190 | ! |
- character(1)- |
-
| 202 | -- |
- )+ Label = character(0), |
|
| 203 | +1191 | ! |
- names(choices) <- ifelse(+ Missings = character(0), |
| 204 | +1192 | ! |
- is.na(labels) | labels == "",+ Sparklines = character(0), |
| 205 | +1193 | ! |
- choices,+ stringsAsFactors = FALSE |
| 206 | -! | +||
| 1194 | +
- paste(choices, labels, sep = ": ")+ ) |
||
| 207 | +1195 |
- )+ } else {
|
|
| 208 | -! | +||
| 1196 | +
- variables_selected <- if (!is.null(variables_selected[[x]])) {
+ # extract data variable labels |
||
| 209 | +1197 | ! |
- variables_selected[[x]]+ labels <- teal.data::col_labels(df) |
| 210 | +1198 |
- } else {
+
|
|
| 211 | +1199 | ! |
- utils::head(choices)+ columns_names[[dataset_name]] <- names(labels) |
| 212 | +1200 |
- }+ |
|
| 213 | -! | +||
| 1201 | +
- tabPanel(+ # calculate number of missing values |
||
| 214 | +1202 | ! |
- title = x,+ missings <- vapply( |
| 215 | +1203 | ! |
- column(+ df, |
| 216 | +1204 | ! |
- width = 12,+ var_missings_info, |
| 217 | +1205 | ! |
- div(+ FUN.VALUE = character(1), |
| 218 | +1206 | ! |
- class = "mt-4",+ USE.NAMES = FALSE |
| 219 | -! | +||
| 1207 | +
- ui_data_table(+ ) |
||
| 220 | -! | +||
| 1208 | +
- id = session$ns(x),+ |
||
| 221 | -! | +||
| 1209 | +
- choices = choices,+ # get icons proper for the data types |
||
| 222 | +1210 | ! |
- selected = variables_selected+ icons <- vapply(df, function(x) class(x)[1L], character(1L)) |
| 223 | +1211 |
- )+ |
|
| 224 | -+ | ||
| 1212 | +! |
- )+ join_keys <- join_keys(data()) |
|
| 225 | -+ | ||
| 1213 | +! |
- )+ if (!is.null(join_keys)) {
|
|
| 226 | -+ | ||
| 1214 | +! |
- )+ icons[intersect(join_keys[dataset_name, dataset_name], colnames(df))] <- "primary_key" |
|
| 227 | +1215 |
- }+ } |
|
| 228 | -+ | ||
| 1216 | +! |
- )+ icons <- variable_type_icons(icons) |
|
| 229 | +1217 |
- )+ |
|
| 230 | +1218 |
- })+ # generate sparklines |
|
| 231 | -+ | ||
| 1219 | +! |
-
+ sparklines_html <- vapply( |
|
| 232 | +1220 | ! |
- lapply(+ df, |
| 233 | +1221 | ! |
- datanames,+ create_sparklines, |
| 234 | +1222 | ! |
- function(x) {
+ FUN.VALUE = character(1), |
| 235 | +1223 | ! |
- srv_data_table(+ USE.NAMES = FALSE |
| 236 | -! | +||
| 1224 | +
- id = x,+ )+ |
+ ||
| 1225 | ++ | + | |
| 237 | +1226 | ! |
- data = data,+ df_output <- data.frame( |
| 238 | +1227 | ! |
- dataname = x,+ Type = icons, |
| 239 | +1228 | ! |
- if_filtered = if_filtered,+ Variable = names(labels), |
| 240 | +1229 | ! |
- if_distinct = if_distinct,+ Label = labels, |
| 241 | +1230 | ! |
- dt_args = dt_args,+ Missings = missings, |
| 242 | +1231 | ! |
- dt_options = dt_options,+ Sparklines = sparklines_html, |
| 243 | +1232 | ! |
- server_rendering = server_rendering+ stringsAsFactors = FALSE |
| 244 | +1233 |
- )+ ) |
|
| 245 | +1234 |
- }+ } |
|
| 246 | +1235 |
- )+ |
|
| 247 | +1236 |
- })+ # Select row 1 as default / fallback+ |
+ |
| 1237 | +! | +
+ selected_ix <- 1 |
|
| 248 | +1238 |
- }+ # Define starting page index (base-0 index of the first item on page |
|
| 249 | +1239 |
-
+ # note: in many cases it's not the item itself+ |
+ |
| 1240 | +! | +
+ selected_page_ix <- 0 |
|
| 250 | +1241 |
- ui_data_table <- function(id,+ |
|
| 251 | +1242 |
- choices,+ # Retrieve current selected variable if any+ |
+ |
| 1243 | +! | +
+ isolated_variable <- shiny::isolate(plot_var$variable[[dataset_name]]) |
|
| 252 | +1244 |
- selected) {
+
|
|
| 253 | +1245 | ! |
- ns <- NS(id)+ if (!is.null(isolated_variable)) {
+ |
+
| 1246 | +! | +
+ index <- which(columns_names[[dataset_name]] == isolated_variable)[1]+ |
+ |
| 1247 | +! | +
+ if (!is.null(index) && !is.na(index) && length(index) > 0) selected_ix <- index |
|
| 254 | +1248 | ++ |
+ }+ |
+
| 1249 | |||
| 1250 | ++ |
+ # Retrieve the index of the first item of the current page+ |
+ |
| 1251 | ++ |
+ # it works with varying number of entries on the page (10, 25, ...)+ |
+ |
| 255 | +1252 | ! |
- if (!is.null(selected)) {
+ table_id_sel <- paste0("variable_browser_", dataset_name, "_state")
|
| 256 | +1253 | ! |
- all_choices <- choices+ dt_state <- shiny::isolate(input[[table_id_sel]]) |
| 257 | +1254 | ! |
- choices <- c(selected, setdiff(choices, selected))+ if (selected_ix != 1 && !is.null(dt_state)) {
|
| 258 | +1255 | ! |
- names(choices) <- names(all_choices)[match(choices, all_choices)]+ selected_page_ix <- floor(selected_ix / dt_state$length) * dt_state$length |
| 259 | +1256 |
- }+ } |
|
| 260 | +1257 | ||
| 261 | +1258 | ! |
- tagList(+ DT::datatable( |
| 262 | +1259 | ! |
- teal.widgets::get_dt_rows(ns("data_table"), ns("dt_rows")),
+ df_output, |
| 263 | +1260 | ! |
- fluidRow(+ escape = FALSE, |
| 264 | +1261 | ! |
- teal.widgets::optionalSelectInput(+ rownames = FALSE, |
| 265 | +1262 | ! |
- ns("variables"),
+ selection = list(mode = "single", target = "row", selected = selected_ix), |
| 266 | +1263 | ! |
- "Select variables:",+ options = list( |
| 267 | +1264 | ! |
- choices = choices,+ fnDrawCallback = htmlwidgets::JS("function() { HTMLWidgets.staticRender(); }"),
|
| 268 | +1265 | ! |
- selected = selected,+ pageLength = input[[paste0(table_ui_id, "_rows")]], |
| 269 | +1266 | ! |
- multiple = TRUE,+ displayStart = selected_page_ix |
| 270 | -! | +||
| 1267 | +
- width = "100%"+ ) |
||
| 271 | +1268 |
- )+ ) |
|
| 272 | +1269 |
- ),+ }) |
|
| 273 | -! | +||
| 1270 | +
- fluidRow(+ } |
||
| 274 | -! | +||
| 1271 | +
- DT::dataTableOutput(ns("data_table"), width = "100%")
+
|
||
| 275 | +1272 |
- )+ #' Creates observers updating the currently selected column |
|
| 276 | +1273 |
- )+ #' |
|
| 277 | +1274 |
- }+ #' @description |
|
| 278 | +1275 |
-
+ #' The created observers update the column currently selected in the left-hand side |
|
| 279 | +1276 |
- srv_data_table <- function(id,+ #' tabset panel. |
|
| 280 | +1277 |
- data,+ #' |
|
| 281 | +1278 |
- dataname,+ #' @note |
|
| 282 | +1279 |
- if_filtered,+ #' Creates an observer for each dataset (each tab in the tabset panel). |
|
| 283 | +1280 |
- if_distinct,+ #' |
|
| 284 | +1281 |
- dt_args,+ #' @inheritParams render_tabset_panel_content |
|
| 285 | +1282 |
- dt_options,+ #' @keywords internal |
|
| 286 | +1283 |
- server_rendering) {
+ establish_updating_selection <- function(datanames, input, plot_var, columns_names) {
|
|
| 287 | +1284 | ! |
- moduleServer(id, function(input, output, session) {
+ lapply(datanames, function(dataset_name) {
|
| 288 | +1285 | ! |
- iv <- shinyvalidate::InputValidator$new()+ table_ui_id <- paste0("variable_browser_", dataset_name)
|
| 289 | +1286 | ! |
- iv$add_rule("variables", shinyvalidate::sv_required("Please select valid variable names"))
+ table_id_sel <- paste0(table_ui_id, "_rows_selected") |
| 290 | +1287 | ! |
- iv$add_rule("variables", shinyvalidate::sv_in_set(
+ observeEvent(input[[table_id_sel]], {
|
| 291 | +1288 | ! |
- set = names(data()[[dataname]]), message_fmt = "Not all selected variables exist in the data"+ plot_var$data <- dataset_name+ |
+
| 1289 | +! | +
+ plot_var$variable[[dataset_name]] <- columns_names[[dataset_name]][input[[table_id_sel]]] |
|
| 292 | +1290 |
- ))+ }) |
|
| 293 | -! | +||
| 1291 | +
- iv$enable()+ }) |
||
| 294 | +1292 | ++ |
+ }+ |
+
| 1293 | |||
| 1294 | ++ |
+ get_bin_width <- function(x_vec, scaling_factor = 2) {
+ |
+ |
| 295 | +1295 | ! |
- output$data_table <- DT::renderDataTable(server = server_rendering, {
+ x_vec <- x_vec[!is.na(x_vec)] |
| 296 | +1296 | ! |
- teal::validate_inputs(iv)+ qntls <- stats::quantile(x_vec, probs = c(0.1, 0.25, 0.75, 0.9), type = 2) |
| 297 | -+ | ||
| 1297 | +! |
-
+ iqr <- qntls[3] - qntls[2] |
|
| 298 | +1298 | ! |
- df <- data()[[dataname]]+ binwidth <- max(scaling_factor * iqr / length(x_vec) ^ (1 / 3), sqrt(qntls[4] - qntls[1])) # styler: off |
| 299 | +1299 | ! |
- variables <- input$variables+ binwidth <- ifelse(binwidth == 0, 1, binwidth) |
| 300 | +1300 |
-
+ # to ensure at least two bins when variable span is very small |
|
| 301 | +1301 | ! |
- teal::validate_has_data(df, min_nrow = 1L, msg = paste("data", dataname, "is empty"))
+ x_span <- diff(range(x_vec))+ |
+
| 1302 | +! | +
+ if (isTRUE(x_span / binwidth >= 2)) binwidth else x_span / 2 |
|
| 302 | +1303 | ++ |
+ }+ |
+
| 1304 | |||
| 1305 | ++ |
+ custom_sparkline_formatter <- function(labels, counts) {
+ |
+ |
| 303 | +1306 | ! |
- dataframe_selected <- if (if_distinct()) {
+ htmlwidgets::JS( |
| 304 | +1307 | ! |
- dplyr::count(df, dplyr::across(tidyselect::all_of(variables)))+ sprintf(+ |
+
| 1308 | +! | +
+ "function(sparkline, options, field) {
+ |
+ |
| 1309 | +! | +
+ return 'ID: ' + %s[field[0].offset] + '<br>' + 'Count: ' + %s[field[0].offset]; |
|
| 305 | +1310 |
- } else {
+ }", |
|
| 306 | +1311 | ! |
- df[variables]+ jsonlite::toJSON(labels),+ |
+
| 1312 | +! | +
+ jsonlite::toJSON(counts) |
|
| 307 | +1313 |
- }+ ) |
|
| 308 | +1314 | ++ |
+ )+ |
+
| 1315 | ++ |
+ }+ |
+ |
| 1316 | |||
| 309 | -! | +||
| 1317 | +
- dt_args$options <- dt_options+ #' Removes the outlier observation from an array |
||
| 310 | -! | +||
| 1318 | +
- if (!is.null(input$dt_rows)) {
+ #' |
||
| 311 | -! | +||
| 1319 | +
- dt_args$options$pageLength <- input$dt_rows+ #' @param var (`numeric`) a numeric vector |
||
| 312 | +1320 |
- }+ #' @param outlier_definition (`numeric`) if `0` then no outliers are removed, otherwise |
|
| 313 | -! | +||
| 1321 | +
- dt_args$data <- dataframe_selected+ #' outliers (those more than `outlier_definition*IQR below/above Q1/Q3`) are removed |
||
| 314 | +1322 |
-
+ #' @returns (`numeric`) vector without the outlier values |
|
| 315 | -! | +||
| 1323 | +
- do.call(DT::datatable, dt_args)+ #' @keywords internal |
||
| 316 | +1324 |
- })+ remove_outliers_from <- function(var, outlier_definition) {
+ |
+ |
| 1325 | +3x | +
+ if (outlier_definition == 0) {
+ |
+ |
| 1326 | +1x | +
+ return(var) |
|
| 317 | +1327 |
- })+ }+ |
+ |
| 1328 | +2x | +
+ q1_q3 <- stats::quantile(var, probs = c(0.25, 0.75), type = 2, na.rm = TRUE)+ |
+ |
| 1329 | +2x | +
+ iqr <- q1_q3[2] - q1_q3[1]+ |
+ |
| 1330 | +2x | +
+ var[var >= q1_q3[1] - outlier_definition * iqr & var <= q1_q3[2] + outlier_definition * iqr] |
|
| 318 | +1331 |
}@@ -79637,7487 +80393,6724 @@ teal.modules.general coverage - 2.26% |
|
| 883 | -- | - - | -|
| 884 | -- | - - | -|
| 885 | -! | -
- fitted <- reactive(output_q()[["fit"]])- |
- |
| 886 | -! | -
- plot_r <- reactive(output_q()[["g"]])- |
- |
| 887 | -- | - - | -|
| 888 | -- |
- # Insert the plot into a plot_with_settings module from teal.widgets- |
- |
| 889 | -! | -
- pws <- teal.widgets::plot_with_settings_srv(- |
- |
| 890 | -! | -
- id = "myplot",- |
- |
| 891 | -! | -
- plot_r = plot_r,- |
- |
| 892 | -! | -
- height = plot_height,- |
- |
| 893 | -! | -
- width = plot_width- |
- |
| 894 | -- |
- )- |
- |
| 895 | -- | - - | -|
| 896 | -! | -
- output$text <- renderText({
- |
- |
| 897 | -! | -
- req(iv_r()$is_valid())- |
- |
| 898 | -! | -
- req(iv_out$is_valid())- |
- |
| 899 | -! | -
- paste(utils::capture.output(summary(teal.code::dev_suppress(fitted())))[-1],- |
- |
| 900 | -! | -
- collapse = "\n"- |
- |
| 901 | -- |
- )- |
- |
| 902 | -- |
- })- |
- |
| 903 | -- | - - | -|
| 904 | -! | -
- teal.widgets::verbatim_popup_srv(- |
- |
| 905 | -! | -
- id = "warning",- |
- |
| 906 | -! | -
- verbatim_content = reactive(teal.code::get_warnings(output_q())),- |
- |
| 907 | -! | -
- title = "Warning",- |
- |
| 908 | -! | -
- disabled = reactive(is.null(teal.code::get_warnings(output_q())))- |
- |
| 909 | -- |
- )- |
- |
| 910 | -- | - - | -|
| 911 | -! | -
- teal.widgets::verbatim_popup_srv(- |
- |
| 912 | -! | -
- id = "rcode",- |
- |
| 913 | -! | -
- verbatim_content = reactive(teal.code::get_code(output_q())),- |
- |
| 914 | -! | -
- title = "R code for the regression plot",- |
- |
| 915 | -- |
- )- |
- |
| 916 | -- | - - | -|
| 917 | -- |
- ### REPORTER- |
- |
| 918 | -! | -
- if (with_reporter) {
- |
- |
| 919 | -! | -
- card_fun <- function(comment, label) {
- |
- |
| 920 | -! | -
- card <- teal::report_card_template(- |
- |
| 921 | -! | -
- title = "Linear Regression Plot",- |
- |
| 922 | -! | -
- label = label,- |
- |
| 923 | -! | -
- with_filter = with_filter,- |
- |
| 924 | -! | -
- filter_panel_api = filter_panel_api- |
- |
| 925 | -- |
- )- |
- |
| 926 | -! | -
- card$append_text("Plot", "header3")
- |
- |
| 927 | -! | -
- card$append_plot(plot_r(), dim = pws$dim())- |
- |
| 928 | -! | -
- if (!comment == "") {
- |
- |
| 929 | -! | -
- card$append_text("Comment", "header3")
- |
- |
| 930 | -! | -
- card$append_text(comment)- |
- |
| 931 | -- |
- }- |
- |
| 932 | -! | -
- card$append_src(teal.code::get_code(output_q()))- |
- |
| 933 | -! | -
- card- |
- |
| 934 | -- |
- }- |
- |
| 935 | -! | -
- teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
- |
- |
| 936 | -- |
- }- |
- |
| 937 | -- |
- ###- |
- |
| 938 | -- |
- })- |
- |
| 939 | -- |
- }- |
- |
| 940 | -- | - - | -|
| 941 | -- |
- regression_names <- paste0(- |
- |
| 942 | -- |
- '"Response vs Regressor", "Residuals vs Fitted", ',- |
- |
| 943 | -- |
- '"Scale-Location", "Cook\'s distance", "Residuals vs Leverage"", "Cook\'s dist vs Leverage"'- |
- |
| 944 | -- |
- )- |
-
| 1 | -- |
- #' Front page module- |
- |
| 2 | -- |
- #'- |
- |
| 3 | -- |
- #' @description This `teal` module creates a simple front page for `teal` applications- |
- |
| 4 | -- |
- #'- |
- |
| 5 | -- |
- #' @inheritParams teal::module- |
- |
| 6 | -- |
- #' @param header_text `character vector` text to be shown at the top of the module, for each- |
- |
| 7 | -- |
- #' element, if named the name is shown first in bold as a header followed by the value. The first- |
- |
| 8 | -- |
- #' element's header is displayed larger than the others- |
- |
| 9 | -- |
- #' @param tables `named list of dataframes` tables to be shown in the module- |
- |
| 10 | +883 |
- #' @param additional_tags `shiny.tag.list` or `html` additional shiny tags or `html` to be included after the table,+ |
|
| 11 | +884 |
- #' for example to include an image, `tagList(tags$img(src = "image.png"))` or to include further `html`,+ |
|
| 12 | -+ | ||
| 885 | +! |
- #' `HTML("html text here")`
+ fitted <- reactive(output_q()[["fit"]]) |
|
| 13 | -+ | ||
| 886 | +! |
- #' @param footnotes `character vector` text to be shown at the bottom of the module, for each+ plot_r <- reactive(output_q()[["g"]]) |
|
| 14 | +887 |
- #' element, if named the name is shown first in bold, followed by the value+ |
|
| 15 | +888 |
- #' @param show_metadata `logical` should the metadata of the datasets be available on the module?+ # Insert the plot into a plot_with_settings module from teal.widgets |
|
| 16 | -+ | ||
| 889 | +! |
- #' @return A `teal` module to be used in `teal` applications+ pws <- teal.widgets::plot_with_settings_srv( |
|
| 17 | -+ | ||
| 890 | +! |
- #' @export+ id = "myplot", |
|
| 18 | -+ | ||
| 891 | +! |
- #' @examples+ plot_r = plot_r, |
|
| 19 | -+ | ||
| 892 | +! |
- #'+ height = plot_height, |
|
| 20 | -+ | ||
| 893 | +! |
- #' data <- teal_data()+ width = plot_width |
|
| 21 | +894 |
- #' data <- within(data, {
+ ) |
|
| 22 | +895 |
- #' library(nestcolor)+ |
|
| 23 | -+ | ||
| 896 | +! |
- #' ADSL <- teal.modules.general::rADSL+ output$text <- renderText({
|
|
| 24 | -+ | ||
| 897 | +! |
- #' attr(ADSL, "metadata") <- list("Author" = "NEST team", "data_source" = "synthetic data")
+ req(iv_r()$is_valid()) |
|
| 25 | -+ | ||
| 898 | +! |
- #' })+ req(iv_out$is_valid()) |
|
| 26 | -+ | ||
| 899 | +! |
- #' datanames <- c("ADSL")
+ paste(utils::capture.output(summary(teal.code::dev_suppress(fitted())))[-1], |
|
| 27 | -+ | ||
| 900 | +! |
- #' datanames(data) <- datanames+ collapse = "\n" |
|
| 28 | +901 |
- #' join_keys(data) <- default_cdisc_join_keys[datanames]+ ) |
|
| 29 | +902 |
- #'+ }) |
|
| 30 | +903 |
- #' table_1 <- data.frame(Info = c("A", "B"), Text = c("A", "B"))
+
|
|
| 31 | -+ | ||
| 904 | +! |
- #' table_2 <- data.frame(`Column 1` = c("C", "D"), `Column 2` = c(5.5, 6.6), `Column 3` = c("A", "B"))
+ teal.widgets::verbatim_popup_srv( |
|
| 32 | -+ | ||
| 905 | +! |
- #' table_3 <- data.frame(Info = c("E", "F"), Text = c("G", "H"))
+ id = "warning", |
|
| 33 | -+ | ||
| 906 | +! |
- #'+ verbatim_content = reactive(teal.code::get_warnings(output_q())), |
|
| 34 | -+ | ||
| 907 | +! |
- #' table_input <- list(+ title = "Warning", |
|
| 35 | -+ | ||
| 908 | +! |
- #' "Table 1" = table_1,+ disabled = reactive(is.null(teal.code::get_warnings(output_q()))) |
|
| 36 | +909 |
- #' "Table 2" = table_2,+ ) |
|
| 37 | +910 |
- #' "Table 3" = table_3+ |
|
| 38 | -+ | ||
| 911 | +! |
- #' )+ teal.widgets::verbatim_popup_srv( |
|
| 39 | -+ | ||
| 912 | +! |
- #'+ id = "rcode", |
|
| 40 | -+ | ||
| 913 | +! |
- #' app <- teal::init(+ verbatim_content = reactive(teal.code::get_code(output_q())), |
|
| 41 | -+ | ||
| 914 | +! |
- #' data = data,+ title = "R code for the regression plot", |
|
| 42 | +915 |
- #' modules = teal::modules(+ ) |
|
| 43 | +916 |
- #' teal.modules.general::tm_front_page(+ |
|
| 44 | +917 |
- #' header_text = c(+ ### REPORTER |
|
| 45 | -+ | ||
| 918 | +! |
- #' "Important information" = "It can go here.",+ if (with_reporter) {
|
|
| 46 | -+ | ||
| 919 | +! |
- #' "Other information" = "Can go here."+ card_fun <- function(comment, label) {
|
|
| 47 | -+ | ||
| 920 | +! |
- #' ),+ card <- teal::report_card_template( |
|
| 48 | -+ | ||
| 921 | +! |
- #' tables = table_input,+ title = "Linear Regression Plot", |
|
| 49 | -+ | ||
| 922 | +! |
- #' additional_tags = HTML("Additional HTML or shiny tags go here <br>"),
+ label = label, |
|
| 50 | -+ | ||
| 923 | +! |
- #' footnotes = c("X" = "is the first footnote", "Y is the second footnote"),
+ with_filter = with_filter, |
|
| 51 | -+ | ||
| 924 | +! |
- #' show_metadata = TRUE+ filter_panel_api = filter_panel_api |
|
| 52 | +925 |
- #' )+ ) |
|
| 53 | -+ | ||
| 926 | +! |
- #' ),+ card$append_text("Plot", "header3")
|
|
| 54 | -+ | ||
| 927 | +! |
- #' header = tags$h1("Sample Application"),
+ card$append_plot(plot_r(), dim = pws$dim()) |
|
| 55 | -+ | ||
| 928 | +! |
- #' footer = tags$p("Application footer"),
+ if (!comment == "") {
|
|
| 56 | -+ | ||
| 929 | +! |
- #' )+ card$append_text("Comment", "header3")
|
|
| 57 | -+ | ||
| 930 | +! |
- #' if (interactive()) {
+ card$append_text(comment) |
|
| 58 | +931 |
- #' shinyApp(app$ui, app$server)+ } |
|
| 59 | -+ | ||
| 932 | +! |
- #' }+ card$append_src(teal.code::get_code(output_q())) |
|
| 60 | -+ | ||
| 933 | +! |
- tm_front_page <- function(label = "Front page",+ card |
|
| 61 | +934 |
- header_text = character(0),+ } |
|
| 62 | -+ | ||
| 935 | +! |
- tables = list(),+ teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
|
|
| 63 | +936 |
- additional_tags = tagList(),+ } |
|
| 64 | +937 |
- footnotes = character(0),+ ### |
|
| 65 | +938 |
- show_metadata = FALSE) {
+ }) |
|
| 66 | -! | +||
| 939 | +
- checkmate::assert_string(label)+ } |
||
| 67 | -! | +||
| 940 | +
- checkmate::assert_character(header_text, min.len = 0, any.missing = FALSE)+ |
||
| 68 | -! | +||
| 941 | +
- checkmate::assert_list(tables, types = "data.frame", names = "named", any.missing = FALSE)+ regression_names <- paste0( |
||
| 69 | -! | +||
| 942 | +
- checkmate::assert_multi_class(additional_tags, classes = c("shiny.tag.list", "html"))
+ '"Response vs Regressor", "Residuals vs Fitted", ', |
||
| 70 | -! | +||
| 943 | +
- checkmate::assert_character(footnotes, min.len = 0, any.missing = FALSE)+ '"Scale-Location", "Cook\'s distance", "Residuals vs Leverage"", "Cook\'s dist vs Leverage"' |
||
| 71 | -! | +||
| 944 | +
- checkmate::assert_flag(show_metadata)+ ) |
| 72 | +1 |
-
+ #' Shared Parameters |
|
| 73 | -! | +||
| 2 | +
- logger::log_info("Initializing tm_front_page")
+ #' |
||
| 74 | -! | +||
| 3 | +
- args <- as.list(environment())+ #' @description Contains arguments that are shared between multiple functions |
||
| 75 | +4 |
-
+ #' in the package to avoid repetition using `inheritParams`. |
|
| 76 | -! | +||
| 5 | +
- module(+ #' |
||
| 77 | -! | +||
| 6 | +
- label = label,+ #' @param plot_height optional, (`numeric`) A vector of length three with `c(value, min and max)` |
||
| 78 | -! | +||
| 7 | +
- server = srv_front_page,+ #' for a slider encoding the plot height. |
||
| 79 | -! | +||
| 8 | +
- ui = ui_front_page,+ #' @param plot_width optional, (`numeric`) A vector of length three with `c(value, min and max)` |
||
| 80 | -! | +||
| 9 | +
- ui_args = args,+ #' for a slider encoding the plot width. |
||
| 81 | -! | +||
| 10 | +
- server_args = list(tables = tables, show_metadata = show_metadata),+ #' @param rotate_xaxis_labels optional, (`logical`) Whether to rotate plot X axis labels. Does not |
||
| 82 | -! | +||
| 11 | +
- datanames = if (show_metadata) "all" else NULL+ #' rotate by default (`FALSE`). |
||
| 83 | +12 |
- )+ #' @param ggtheme optional, (`character`) `ggplot2` theme to be used by default. Defaults to `"gray"`. |
|
| 84 | +13 |
- }+ #' @param ggplot2_args (`ggplot2_args`) object created by [teal.widgets::ggplot2_args()] |
|
| 85 | +14 |
-
+ #' with settings for the module plot. |
|
| 86 | +15 |
- ui_front_page <- function(id, ...) {
+ #' The argument is merged with options variable `teal.ggplot2_args` and default module setup. |
|
| 87 | -! | +||
| 16 | +
- args <- list(...)+ #' |
||
| 88 | -! | +||
| 17 | +
- ns <- NS(id)+ #' For more details see the vignette: `vignette("custom-ggplot2-arguments", package = "teal.widgets")`
|
||
| 89 | +18 |
-
+ #' @param basic_table_args (`basic_table_args`) object created by [teal.widgets::basic_table_args()] |
|
| 90 | -! | +||
| 19 | +
- tagList(+ #' with settings for the module table. |
||
| 91 | -! | +||
| 20 | +
- include_css_files("custom"),
+ #' The argument is merged with options variable `teal.basic_table_args` and default module setup. |
||
| 92 | -! | +||
| 21 | +
- tags$div(+ #' |
||
| 93 | -! | +||
| 22 | +
- id = "front_page_content",+ #' For more details see the vignette: `vignette("custom-basic-table-arguments", package = "teal.widgets")`
|
||
| 94 | -! | +||
| 23 | +
- class = "ml-8",+ #' @param pre_output (`shiny.tag`, optional)\cr |
||
| 95 | -! | +||
| 24 | +
- tags$div(+ #' with text placed before the output to put the output into context. For example a title. |
||
| 96 | -! | +||
| 25 | +
- id = "front_page_headers",+ #' @param post_output (`shiny.tag`, optional) with text placed after the output to put the output |
||
| 97 | -! | +||
| 26 | +
- get_header_tags(args$header_text)+ #' into context. For example the [shiny::helpText()] elements are useful. |
||
| 98 | +27 |
- ),+ #' |
|
| 99 | -! | +||
| 28 | +
- tags$div(+ #' @name shared_params |
||
| 100 | -! | +||
| 29 | +
- id = "front_page_tables",+ #' @keywords internal |
||
| 101 | -! | +||
| 30 | +
- class = "ml-4",+ NULL |
||
| 102 | -! | +||
| 31 | +
- get_table_tags(args$tables, ns)+ |
||
| 103 | +32 |
- ),+ #' Add axis labels that show facetting variable |
|
| 104 | -! | +||
| 33 | +
- tags$div(+ #' |
||
| 105 | -! | +||
| 34 | +
- id = "front_page_custom_html",+ #' Add axis labels that show facetting variable |
||
| 106 | -! | +||
| 35 | +
- class = "my-4",+ #' |
||
| 107 | -! | +||
| 36 | +
- args$additional_tags+ #' @param p `ggplot2` object to add facet labels to |
||
| 108 | +37 |
- ),+ #' @param xfacet_label label of facet along x axis (nothing created if NULL), |
|
| 109 | -! | +||
| 38 | +
- if (args$show_metadata) {
+ #' if vector, will be concatenated with " & " |
||
| 110 | -! | +||
| 39 | +
- tags$div(+ #' @param yfacet_label label of facet along y axis (nothing created if NULL), |
||
| 111 | -! | +||
| 40 | +
- id = "front_page_metabutton",+ #' if vector, will be concatenated with " & " |
||
| 112 | -! | +||
| 41 | +
- class = "m-4",+ #' |
||
| 113 | -! | +||
| 42 | +
- actionButton(ns("metadata_button"), "Show metadata")
+ #' @return grid grob object (to be drawn with \code{grid.draw})
|
||
| 114 | +43 |
- )+ #' |
|
| 115 | +44 |
- },+ #' @export |
|
| 116 | -! | +||
| 45 | +
- tags$footer(+ #' |
||
| 117 | -! | +||
| 46 | +
- class = ".small",+ #' @examples |
||
| 118 | -! | +||
| 47 | +
- get_footer_tags(args$footnotes)+ #' # we put donttest to avoid strictr error with seq along.with argument |
||
| 119 | +48 |
- )+ #' \donttest{
|
|
| 120 | +49 |
- )+ #' library(ggplot2) |
|
| 121 | +50 |
- )+ #' library(grid) |
|
| 122 | +51 |
- }+ #' |
|
| 123 | +52 |
-
+ #' p <- ggplot(mtcars) + |
|
| 124 | +53 |
- get_header_tags <- function(header_text) {
+ #' aes(x = mpg, y = disp) + |
|
| 125 | -! | +||
| 54 | +
- if (length(header_text) == 0) {
+ #' geom_point() + |
||
| 126 | -! | +||
| 55 | +
- return(list())+ #' facet_grid(gear ~ cyl) |
||
| 127 | +56 |
- }+ #' p |
|
| 128 | +57 |
-
+ #' xfacet_label <- "cylinders" |
|
| 129 | -! | +||
| 58 | +
- get_single_header_tags <- function(header_text, p_text, header_tag = tags$h4) {
+ #' yfacet_label <- "gear" |
||
| 130 | -! | +||
| 59 | +
- tagList(+ #' res <- add_facet_labels(p, xfacet_label, yfacet_label) |
||
| 131 | -! | +||
| 60 | +
- tags$div(+ #' grid.newpage() |
||
| 132 | -! | +||
| 61 | +
- if (!is.null(header_text) && nchar(header_text) > 0) header_tag(header_text),+ #' grid.draw(res) |
||
| 133 | -! | +||
| 62 | +
- tags$p(p_text)+ #' |
||
| 134 | +63 |
- )+ #' grid.newpage() |
|
| 135 | +64 |
- )+ #' grid.draw(add_facet_labels(p, xfacet_label = NULL, yfacet_label)) |
|
| 136 | +65 |
- }+ #' grid.newpage() |
|
| 137 | +66 |
-
+ #' grid.draw(add_facet_labels(p, xfacet_label, yfacet_label = NULL)) |
|
| 138 | -! | +||
| 67 | +
- header_tags <- get_single_header_tags(names(header_text[1]), header_text[1], header_tag = tags$h3)+ #' grid.newpage() |
||
| 139 | -! | +||
| 68 | +
- c(header_tags, mapply(get_single_header_tags, utils::tail(names(header_text), -1), utils::tail(header_text, -1)))+ #' grid.draw(add_facet_labels(p, xfacet_label = NULL, yfacet_label = NULL)) |
||
| 140 | +69 |
- }+ #' } |
|
| 141 | +70 |
-
+ #' |
|
| 142 | +71 |
- get_table_tags <- function(tables, ns) {
+ add_facet_labels <- function(p, xfacet_label = NULL, yfacet_label = NULL) {
|
|
| 143 | +72 | ! |
- if (length(tables) == 0) {
+ checkmate::assert_class(p, classes = "ggplot") |
| 144 | +73 | ! |
- return(list())- |
-
| 145 | -- |
- }+ checkmate::assert_character(xfacet_label, null.ok = TRUE, min.len = 1) |
|
| 146 | +74 | ! |
- table_tags <- c(lapply(seq_along(tables), function(idx) {
+ checkmate::assert_character(yfacet_label, null.ok = TRUE, min.len = 1) |
| 147 | +75 | ! |
- list(+ if (is.null(xfacet_label) && is.null(yfacet_label)) {
|
| 148 | +76 | ! |
- tableOutput(ns(paste0("table_", idx)))
- |
-
| 149 | -- |
- )+ return(ggplotGrob(p)) |
|
| 150 | +77 |
- }))+ } |
|
| 151 | +78 | ! |
- return(table_tags)+ grid::grid.grabExpr({
|
| 152 | -+ | ||
| 79 | +! |
- }+ g <- ggplotGrob(p) |
|
| 153 | +80 | ||
| 154 | +81 |
- get_footer_tags <- function(footnotes) {
+ # we are going to replace these, so we make sure they have nothing in them |
|
| 155 | +82 | ! |
- if (length(footnotes) == 0) {
+ checkmate::assert_class(g$grobs[[grep("xlab-t", g$layout$name, fixed = TRUE)]], "zeroGrob")
|
| 156 | +83 | ! |
- return(list())+ checkmate::assert_class(g$grobs[[grep("ylab-r", g$layout$name, fixed = TRUE)]], "zeroGrob")
|
| 157 | +84 |
- }- |
- |
| 158 | -! | -
- bold_texts <- if (is.null(names(footnotes))) rep("", length(footnotes)) else names(footnotes)
- |
- |
| 159 | -! | -
- footnote_tags <- mapply(function(bold_text, value) {
+
|
|
| 160 | +85 | ! |
- list(+ xaxis_label_grob <- g$grobs[[grep("xlab-b", g$layout$name, fixed = TRUE)]]
|
| 161 | +86 | ! |
- tags$div(+ xaxis_label_grob$children[[1]]$label <- paste(xfacet_label, collapse = " & ") |
| 162 | +87 | ! |
- tags$b(bold_text),+ yaxis_label_grob <- g$grobs[[grep("ylab-l", g$layout$name, fixed = TRUE)]]
|
| 163 | +88 | ! |
- value,+ yaxis_label_grob$children[[1]]$label <- paste(yfacet_label, collapse = " & ") |
| 164 | +89 | ! |
- tags$br()- |
-
| 165 | -- |
- )+ yaxis_label_grob$children[[1]]$rot <- 270 |
|
| 166 | +90 |
- )+ |
|
| 167 | +91 | ! |
- }, bold_text = bold_texts, value = footnotes)+ top_height <- if (is.null(xfacet_label)) 0 else grid::unit(2, "line") |
| 168 | -+ | ||
| 92 | +! |
- }+ right_width <- if (is.null(yfacet_label)) 0 else grid::unit(2, "line") |
|
| 169 | +93 | ||
| 170 | -- |
- srv_front_page <- function(id, data, tables, show_metadata) {
- |
- |
| 171 | +94 | ! |
- checkmate::assert_class(data, "reactive")+ grid::grid.newpage() |
| 172 | +95 | ! |
- checkmate::assert_class(isolate(data()), "teal_data")+ grid::pushViewport(grid::plotViewport(margins = c(0, 0, top_height, right_width), name = "ggplot")) |
| 173 | +96 | ! |
- moduleServer(id, function(input, output, session) {
+ grid::grid.draw(g) |
| 174 | +97 | ! |
- ns <- session$ns+ grid::upViewport(1) |
| 175 | +98 | ||
| 176 | -! | +||
| 99 | +
- lapply(seq_along(tables), function(idx) {
+ # draw x facet |
||
| 177 | +100 | ! |
- output[[paste0("table_", idx)]] <- renderTable(
+ if (!is.null(xfacet_label)) {
|
| 178 | +101 | ! |
- tables[[idx]],+ grid::pushViewport(grid::viewport( |
| 179 | +102 | ! |
- bordered = TRUE,+ x = 0, y = grid::unit(1, "npc") - top_height, width = grid::unit(1, "npc"), |
| 180 | +103 | ! |
- caption = names(tables)[idx],+ height = top_height, just = c("left", "bottom"), name = "topxaxis"
+ |
+
| 104 | ++ |
+ )) |
|
| 181 | +105 | ! |
- caption.placement = "top"+ grid::grid.draw(xaxis_label_grob) |
| 182 | -+ | ||
| 106 | +! |
- )+ grid::upViewport(1) |
|
| 183 | +107 |
- })+ } |
|
| 184 | +108 | ||
| 185 | -! | +||
| 109 | +
- if (show_metadata) {
+ # draw y facet |
||
| 186 | +110 | ! |
- observeEvent(+ if (!is.null(yfacet_label)) {
|
| 187 | +111 | ! |
- input$metadata_button, showModal(+ grid::pushViewport(grid::viewport( |
| 188 | +112 | ! |
- modalDialog(+ x = grid::unit(1, "npc") - grid::unit(as.numeric(right_width) / 2, "line"), y = 0, width = right_width, |
| 189 | +113 | ! |
- title = "Metadata",+ height = grid::unit(1, "npc"), just = c("left", "bottom"), name = "rightyaxis"
|
| 190 | -! | +||
| 114 | +
- dataTableOutput(ns("metadata_table")),
+ )) |
||
| 191 | +115 | ! |
- size = "l",+ grid::grid.draw(yaxis_label_grob) |
| 192 | +116 | ! |
- easyClose = TRUE+ grid::upViewport(1) |
| 193 | +117 |
- )+ } |
|
| 194 | +118 |
- )+ }) |
|
| 195 | +119 |
- )+ } |
|
| 196 | +120 | ||
| 197 | -! | -
- metadata_data_frame <- reactive({
- |
- |
| 198 | -! | +||
| 121 | +
- datanames <- teal.data::datanames(data())+ #' Call a function with a character vector for the \code{...} argument
|
||
| 199 | -! | +||
| 122 | +
- convert_metadata_to_dataframe(+ #' |
||
| 200 | -! | +||
| 123 | +
- lapply(datanames, function(dataname) attr(data()[[dataname]], "metadata")),+ #' @param fun (\code{character}) Name of a function where the \code{...} argument
|
||
| 201 | -! | +||
| 124 | +
- datanames+ #' shall be replaced by values from \code{str_args}.
|
||
| 202 | +125 |
- )+ #' @param str_args (\code{character}) A character vector that the function shall
|
|
| 203 | +126 |
- })+ #' be executed with |
|
| 204 | +127 |
-
+ #' |
|
| 205 | -! | +||
| 128 | +
- output$metadata_table <- renderDataTable({
+ #' @return: call (i.e. expression) of the function provided by \code{fun}
|
||
| 206 | -! | +||
| 129 | +
- validate(need(nrow(metadata_data_frame()) > 0, "The data has no associated metadata"))+ #' with arguments provided by \code{str_args}.
|
||
| 207 | -! | +||
| 130 | +
- metadata_data_frame()+ #' @keywords internal |
||
| 208 | +131 |
- })+ #' |
|
| 209 | +132 |
- }+ #' @examples |
|
| 210 | +133 |
- })+ #' \dontrun{
|
|
| 211 | +134 |
- }+ #' a <- 1 |
|
| 212 | +135 |
-
+ #' b <- 2 |
|
| 213 | +136 |
- # take a list of metadata, one item per dataset (raw_metadata each element from datasets$get_metadata())+ #' call_fun_dots("sum", c("a", "b"))
|
|
| 214 | +137 |
- # and the corresponding datanames and output a data.frame with columns {Dataset, Name, Value}.
+ #' eval(call_fun_dots("sum", c("a", "b")))
|
|
| 215 | +138 |
- # which are, the Dataset the metadata came from, the metadata's name and value+ #' } |
|
| 216 | +139 |
- convert_metadata_to_dataframe <- function(raw_metadata, datanames) {
+ call_fun_dots <- function(fun, str_args) {
|
|
| 217 | -4x | +||
| 140 | +! |
- output <- mapply(function(metadata, dataname) {
+ do.call("call", c(list(fun), lapply(str_args, as.name)), quote = TRUE)
|
|
| 218 | -6x | +||
| 141 | +
- if (is.null(metadata)) {
+ } |
||
| 219 | -2x | +||
| 142 | +
- return(data.frame(Dataset = character(0), Name = character(0), Value = character(0)))+ |
||
| 220 | +143 |
- }+ #' Get variable name with label |
|
| 221 | -4x | +||
| 144 | +
- return(data.frame(+ #' |
||
| 222 | -4x | +||
| 145 | +
- Dataset = dataname,+ #' @param var_names (\code{character}) Name of variable to extract labels from.
|
||
| 223 | -4x | +||
| 146 | +
- Name = names(metadata),+ #' @param dataset (\code{dataset}) Name of analysis dataset.
|
||
| 224 | -4x | +||
| 147 | +
- Value = unname(unlist(lapply(metadata, as.character)))+ #' @param prefix (\code{character}) String to paste to the beginning of the
|
||
| 225 | +148 |
- ))+ #' variable name with label. |
|
| 226 | -4x | +||
| 149 | +
- }, raw_metadata, datanames, SIMPLIFY = FALSE)+ #' @param suffix (\code{character}) String to paste to the end of the variable
|
||
| 227 | -4x | +||
| 150 | +
- do.call(rbind, output)+ #' name with label. |
||
| 228 | +151 |
- }+ #' @param wrap_width (\code{numeric}) Number of characters to wrap original
|
| 1 | +152 |
- #' Shared Parameters+ #' label to. Defaults to 80. |
|
| 2 | +153 |
#' |
|
| 3 | +154 |
- #' @description Contains arguments that are shared between multiple functions+ #' @return (\code{character}) String with variable name and label.
|
|
| 4 | +155 |
- #' in the package to avoid repetition using `inheritParams`.+ #' @keywords internal |
|
| 5 | +156 |
#' |
|
| 6 | +157 |
- #' @param plot_height optional, (`numeric`) A vector of length three with `c(value, min and max)`+ #' @examples |
|
| 7 | +158 |
- #' for a slider encoding the plot height.+ #' \dontrun{
|
|
| 8 | +159 |
- #' @param plot_width optional, (`numeric`) A vector of length three with `c(value, min and max)`+ #' ADSL <- teal.modules.general::rADSL |
|
| 9 | +160 |
- #' for a slider encoding the plot width.+ #' |
|
| 10 | +161 |
- #' @param rotate_xaxis_labels optional, (`logical`) Whether to rotate plot X axis labels. Does not+ #' varname_w_label("AGE", ADSL)
|
|
| 11 | +162 |
- #' rotate by default (`FALSE`).+ #' } |
|
| 12 | +163 |
- #' @param ggtheme optional, (`character`) `ggplot2` theme to be used by default. Defaults to `"gray"`.+ varname_w_label <- function(var_names, |
|
| 13 | +164 |
- #' @param ggplot2_args (`ggplot2_args`) object created by [teal.widgets::ggplot2_args()]+ dataset, |
|
| 14 | +165 |
- #' with settings for the module plot.+ wrap_width = 80, |
|
| 15 | +166 |
- #' The argument is merged with options variable `teal.ggplot2_args` and default module setup.+ prefix = NULL, |
|
| 16 | +167 |
- #'+ suffix = NULL) {
|
|
| 17 | -+ | ||
| 168 | +! |
- #' For more details see the vignette: `vignette("custom-ggplot2-arguments", package = "teal.widgets")`
+ add_label <- function(var_names) {
|
|
| 18 | -+ | ||
| 169 | +! |
- #' @param basic_table_args (`basic_table_args`) object created by [teal.widgets::basic_table_args()]+ label <- vapply( |
|
| 19 | -+ | ||
| 170 | +! |
- #' with settings for the module table.+ dataset[var_names], function(x) {
|
|
| 20 | -+ | ||
| 171 | +! |
- #' The argument is merged with options variable `teal.basic_table_args` and default module setup.+ attr_label <- attr(x, "label") |
|
| 21 | -+ | ||
| 172 | +! |
- #'+ `if`(is.null(attr_label), "", attr_label) |
|
| 22 | +173 |
- #' For more details see the vignette: `vignette("custom-basic-table-arguments", package = "teal.widgets")`
+ }, |
|
| 23 | -+ | ||
| 174 | +! |
- #' @param pre_output (`shiny.tag`, optional)\cr+ character(1) |
|
| 24 | +175 |
- #' with text placed before the output to put the output into context. For example a title.+ ) |
|
| 25 | +176 |
- #' @param post_output (`shiny.tag`, optional) with text placed after the output to put the output+ |
|
| 26 | -+ | ||
| 177 | +! |
- #' into context. For example the [shiny::helpText()] elements are useful.+ if (length(label) == 1 && !is.na(label) && !identical(label, "")) {
|
|
| 27 | -+ | ||
| 178 | +! |
- #'+ paste0(prefix, label, " [", var_names, "]", suffix) |
|
| 28 | +179 |
- #' @name shared_params+ } else {
+ |
+ |
| 180 | +! | +
+ var_names |
|
| 29 | +181 |
- #' @keywords internal+ } |
|
| 30 | +182 |
- NULL+ } |
|
| 31 | +183 | ||
| 32 | -+ | ||
| 184 | +! |
- #' Add axis labels that show facetting variable+ if (length(var_names) < 1) {
|
|
| 33 | -+ | ||
| 185 | +! |
- #'+ NULL |
|
| 34 | -+ | ||
| 186 | +! | +
+ } else if (length(var_names) == 1) {
+ |
+ |
| 187 | +! | +
+ stringr::str_wrap(add_label(var_names), width = wrap_width)+ |
+ |
| 188 | +! | +
+ } else if (length(var_names) > 1) {
+ |
+ |
| 189 | +! |
- #' Add axis labels that show facetting variable+ stringr::str_wrap(vapply(var_names, add_label, character(1)), width = wrap_width) |
|
| 35 | +190 |
- #'+ } |
|
| 36 | +191 |
- #' @param p `ggplot2` object to add facet labels to+ } |
|
| 37 | +192 |
- #' @param xfacet_label label of facet along x axis (nothing created if NULL),+ |
|
| 38 | +193 |
- #' if vector, will be concatenated with " & "+ #' Extract html id for `data_extract_ui` |
|
| 39 | +194 |
- #' @param yfacet_label label of facet along y axis (nothing created if NULL),+ #' @description The `data_extract_ui` is located under extended html id. |
|
| 40 | +195 |
- #' if vector, will be concatenated with " & "+ #' We could not use \code{ns("original id")} for reference, as it is extended with specific suffixes.
|
|
| 41 | +196 |
- #'+ #' @param varname character original html id. |
|
| 42 | +197 |
- #' @return grid grob object (to be drawn with \code{grid.draw})
+ #' This will be mostly retrieved with \code{ns("original id")} in `ui` or
|
|
| 43 | +198 |
- #'+ #' \code{session$ns("original id")} in server function.
|
|
| 44 | +199 |
- #' @export+ #' @param dataname character \code{dataname} from data_extract input.
|
|
| 45 | +200 |
- #'+ #' This might be retrieved like \code{teal.transform::data_extract_spec(...)[[1]]$dataname}.
|
|
| 46 | +201 |
- #' @examples+ #' @param filter logical if the connected \code{extract_data_spec} is used with \code{filter} option.
|
|
| 47 | +202 |
- #' # we put donttest to avoid strictr error with seq along.with argument+ #' @keywords internal |
|
| 48 | +203 |
- #' \donttest{
+ extract_input <- function(varname, dataname, filter = FALSE) {
|
|
| 49 | -+ | ||
| 204 | +! |
- #' library(ggplot2)+ if (filter) {
|
|
| 50 | -+ | ||
| 205 | +! |
- #' library(grid)+ paste0(varname, "-dataset_", dataname, "_singleextract-filter1-vals") |
|
| 51 | +206 |
- #'+ } else {
|
|
| 52 | -+ | ||
| 207 | +! |
- #' p <- ggplot(mtcars) ++ paste0(varname, "-dataset_", dataname, "_singleextract-select") |
|
| 53 | +208 |
- #' aes(x = mpg, y = disp) ++ } |
|
| 54 | +209 |
- #' geom_point() ++ } |
|
| 55 | +210 |
- #' facet_grid(gear ~ cyl)+ |
|
| 56 | +211 |
- #' p+ # see vignette("ggplot2-specs", package="ggplot2")
|
|
| 57 | +212 |
- #' xfacet_label <- "cylinders"+ shape_names <- c( |
|
| 58 | +213 |
- #' yfacet_label <- "gear"+ "circle", paste("circle", c("open", "filled", "cross", "plus", "small")), "bullet",
|
|
| 59 | +214 |
- #' res <- add_facet_labels(p, xfacet_label, yfacet_label)+ "square", paste("square", c("open", "filled", "cross", "plus", "triangle")),
|
|
| 60 | +215 |
- #' grid.newpage()+ "diamond", paste("diamond", c("open", "filled", "plus")),
|
|
| 61 | +216 |
- #' grid.draw(res)+ "triangle", paste("triangle", c("open", "filled", "square")),
|
|
| 62 | +217 |
- #'+ paste("triangle down", c("open", "filled")),
|
|
| 63 | +218 |
- #' grid.newpage()+ "plus", "cross", "asterisk" |
|
| 64 | +219 |
- #' grid.draw(add_facet_labels(p, xfacet_label = NULL, yfacet_label))+ ) |
|
| 65 | +220 |
- #' grid.newpage()+ |
|
| 66 | +221 |
- #' grid.draw(add_facet_labels(p, xfacet_label, yfacet_label = NULL))+ #' Get icons to represent variable types in dataset |
|
| 67 | +222 |
- #' grid.newpage()+ #' |
|
| 68 | +223 |
- #' grid.draw(add_facet_labels(p, xfacet_label = NULL, yfacet_label = NULL))+ #' @param var_type (`character`)\cr |
|
| 69 | +224 |
- #' }+ #' of R internal types (classes). |
|
| 70 | +225 |
#' |
|
| 71 | +226 |
- add_facet_labels <- function(p, xfacet_label = NULL, yfacet_label = NULL) {
- |
- |
| 72 | -! | -
- checkmate::assert_class(p, classes = "ggplot")- |
- |
| 73 | -! | -
- checkmate::assert_character(xfacet_label, null.ok = TRUE, min.len = 1)+ #' @return (`character`)\cr |
|
| 74 | -! | +||
| 227 | +
- checkmate::assert_character(yfacet_label, null.ok = TRUE, min.len = 1)+ #' vector of HTML icons corresponding to data type in each column. |
||
| 75 | -! | +||
| 228 | +
- if (is.null(xfacet_label) && is.null(yfacet_label)) {
+ #' @keywords internal |
||
| 76 | -! | +||
| 229 | +
- return(ggplotGrob(p))+ #' |
||
| 77 | +230 |
- }+ #' @examples |
|
| 78 | -! | +||
| 231 | +
- grid::grid.grabExpr({
+ #' teal.modules.general:::variable_type_icons(c( |
||
| 79 | -! | +||
| 232 | +
- g <- ggplotGrob(p)+ #' "integer", "numeric", "logical", "Date", "POSIXct", "POSIXlt", |
||
| 80 | +233 |
-
+ #' "factor", "character", "unknown", "" |
|
| 81 | +234 |
- # we are going to replace these, so we make sure they have nothing in them+ #' )) |
|
| 82 | -! | +||
| 235 | +
- checkmate::assert_class(g$grobs[[grep("xlab-t", g$layout$name, fixed = TRUE)]], "zeroGrob")
+ variable_type_icons <- function(var_type) {
|
||
| 83 | +236 | ! |
- checkmate::assert_class(g$grobs[[grep("ylab-r", g$layout$name, fixed = TRUE)]], "zeroGrob")
+ checkmate::assert_character(var_type, any.missing = FALSE) |
| 84 | +237 | ||
| 85 | +238 | ! |
- xaxis_label_grob <- g$grobs[[grep("xlab-b", g$layout$name, fixed = TRUE)]]
+ class_to_icon <- list( |
| 86 | +239 | ! |
- xaxis_label_grob$children[[1]]$label <- paste(xfacet_label, collapse = " & ")+ numeric = "arrow-up-1-9", |
| 87 | +240 | ! |
- yaxis_label_grob <- g$grobs[[grep("ylab-l", g$layout$name, fixed = TRUE)]]
+ integer = "arrow-up-1-9", |
| 88 | +241 | ! |
- yaxis_label_grob$children[[1]]$label <- paste(yfacet_label, collapse = " & ")+ logical = "pause", |
| 89 | +242 | ! |
- yaxis_label_grob$children[[1]]$rot <- 270- |
-
| 90 | -- |
-
+ Date = "calendar", |
|
| 91 | +243 | ! |
- top_height <- if (is.null(xfacet_label)) 0 else grid::unit(2, "line")+ POSIXct = "calendar", |
| 92 | +244 | ! |
- right_width <- if (is.null(yfacet_label)) 0 else grid::unit(2, "line")- |
-
| 93 | -- |
-
+ POSIXlt = "calendar", |
|
| 94 | +245 | ! |
- grid::grid.newpage()+ factor = "chart-bar", |
| 95 | +246 | ! |
- grid::pushViewport(grid::plotViewport(margins = c(0, 0, top_height, right_width), name = "ggplot"))+ character = "keyboard", |
| 96 | +247 | ! |
- grid::grid.draw(g)+ primary_key = "key", |
| 97 | +248 | ! |
- grid::upViewport(1)- |
-
| 98 | -- |
-
+ unknown = "circle-question" |
|
| 99 | +249 |
- # draw x facet+ ) |
|
| 100 | +250 | ! |
- if (!is.null(xfacet_label)) {
+ class_to_icon <- lapply(class_to_icon, function(icon_name) toString(icon(icon_name, lib = "font-awesome"))) |
| 101 | -! | +||
| 251 | +
- grid::pushViewport(grid::viewport(+ |
||
| 102 | +252 | ! |
- x = 0, y = grid::unit(1, "npc") - top_height, width = grid::unit(1, "npc"),+ res <- unname(vapply( |
| 103 | +253 | ! |
- height = top_height, just = c("left", "bottom"), name = "topxaxis"
- |
-
| 104 | -- |
- ))+ var_type, |
|
| 105 | +254 | ! |
- grid::grid.draw(xaxis_label_grob)+ FUN.VALUE = character(1), |
| 106 | +255 | ! |
- grid::upViewport(1)- |
-
| 107 | -- |
- }- |
- |
| 108 | -- | - - | -|
| 109 | -- |
- # draw y facet+ FUN = function(class) {
|
|
| 110 | +256 | ! |
- if (!is.null(yfacet_label)) {
+ if (class == "") {
|
| 111 | +257 | ! |
- grid::pushViewport(grid::viewport(+ class |
| 112 | +258 | ! |
- x = grid::unit(1, "npc") - grid::unit(as.numeric(right_width) / 2, "line"), y = 0, width = right_width,+ } else if (is.null(class_to_icon[[class]])) {
|
| 113 | +259 | ! |
- height = grid::unit(1, "npc"), just = c("left", "bottom"), name = "rightyaxis"
+ class_to_icon[["unknown"]] |
| 114 | +260 |
- ))+ } else {
|
|
| 115 | +261 | ! |
- grid::grid.draw(yaxis_label_grob)+ class_to_icon[[class]] |
| 116 | -! | +||
| 262 | +
- grid::upViewport(1)+ } |
||
| 117 | +263 |
} |
|
| 118 | +264 |
- })+ )) |
|
| 119 | +265 |
- }+ + |
+ |
| 266 | +! | +
+ return(res) |
|
| 120 | +267 |
-
+ } |
|
| 121 | +268 |
- #' Call a function with a character vector for the \code{...} argument
+
|
|
| 122 | +269 |
- #'+ #' Include `CSS` files from `/inst/css/` package directory to application header |
|
| 123 | +270 |
- #' @param fun (\code{character}) Name of a function where the \code{...} argument
+ #' |
|
| 124 | +271 |
- #' shall be replaced by values from \code{str_args}.
+ #' `system.file` should not be used to access files in other packages, it does |
|
| 125 | +272 |
- #' @param str_args (\code{character}) A character vector that the function shall
+ #' not work with `devtools`. Therefore, we redefine this method in each package |
|
| 126 | +273 |
- #' be executed with+ #' as needed. Thus, we do not export this method |
|
| 127 | +274 |
#' |
|
| 128 | +275 |
- #' @return: call (i.e. expression) of the function provided by \code{fun}
+ #' @param pattern (`character`) pattern of files to be included |
|
| 129 | +276 |
- #' with arguments provided by \code{str_args}.
+ #' |
|
| 130 | +277 |
- #' @keywords internal+ #' @return HTML code that includes `CSS` files |
|
| 131 | +278 |
- #'+ #' @keywords internal |
|
| 132 | +279 |
- #' @examples+ include_css_files <- function(pattern = "*") {
|
|
| 133 | -+ | ||
| 280 | +! |
- #' \dontrun{
+ css_files <- list.files( |
|
| 134 | -+ | ||
| 281 | +! |
- #' a <- 1+ system.file("css", package = "teal.modules.general", mustWork = TRUE),
|
|
| 135 | -+ | ||
| 282 | +! |
- #' b <- 2+ pattern = pattern, full.names = TRUE |
|
| 136 | +283 |
- #' call_fun_dots("sum", c("a", "b"))
+ ) |
|
| 137 | -+ | ||
| 284 | +! |
- #' eval(call_fun_dots("sum", c("a", "b")))
+ if (length(css_files) == 0) {
|
|
| 138 | -+ | ||
| 285 | +! |
- #' }+ return(NULL) |
|
| 139 | +286 |
- call_fun_dots <- function(fun, str_args) {
+ } |
|
| 140 | +287 | ! |
- do.call("call", c(list(fun), lapply(str_args, as.name)), quote = TRUE)
+ return(shiny::singleton(shiny::tags$head(lapply(css_files, shiny::includeCSS)))) |
| 141 | +288 |
} |
|
| 142 | +289 | ||
| 143 | +290 |
- #' Get variable name with label+ |
|
| 144 | +291 |
- #'+ #' Get Label Attributes of Variables in a \code{data.frame}
|
|
| 145 | +292 |
- #' @param var_names (\code{character}) Name of variable to extract labels from.
+ #' |
|
| 146 | +293 |
- #' @param dataset (\code{dataset}) Name of analysis dataset.
+ #' Variable labels can be stored as a \code{label} attribute for each variable.
|
|
| 147 | +294 |
- #' @param prefix (\code{character}) String to paste to the beginning of the
+ #' This functions returns a named character vector with the variable labels |
|
| 148 | +295 |
- #' variable name with label.+ #' (empty sting if not specified) |
|
| 149 | +296 |
- #' @param suffix (\code{character}) String to paste to the end of the variable
+ #' |
|
| 150 | +297 |
- #' name with label.+ #' @param x a \code{data.frame} object
|
|
| 151 | +298 |
- #' @param wrap_width (\code{numeric}) Number of characters to wrap original
+ #' @param fill boolean in case the \code{label} attribute does not exist if
|
|
| 152 | +299 |
- #' label to. Defaults to 80.+ #' \code{TRUE} the variable names is returned, otherwise \code{NA}
|
|
| 153 | +300 |
#' |
|
| 154 | +301 |
- #' @return (\code{character}) String with variable name and label.
+ #' @return a named character vector with the variable labels, the names |
|
| 155 | +302 |
- #' @keywords internal+ #' correspond to the variable names |
|
| 156 | +303 |
#' |
|
| 157 | -- |
- #' @examples- |
- |
| 158 | -- |
- #' \dontrun{
- |
- |
| 159 | +304 |
- #' ADSL <- teal.modules.general::rADSL+ #' @note the `formatters` package is the source of the function. |
|
| 160 | +305 |
#' |
|
| 161 | +306 |
- #' varname_w_label("AGE", ADSL)
+ #' @keywords internal |
|
| 162 | +307 |
- #' }+ var_labels <- function(x, fill = FALSE) {
|
|
| 163 | -+ | ||
| 308 | +! |
- varname_w_label <- function(var_names,+ stopifnot(is.data.frame(x)) |
|
| 164 | -+ | ||
| 309 | +! |
- dataset,+ if (NCOL(x) == 0) {
|
|
| 165 | -+ | ||
| 310 | +! |
- wrap_width = 80,+ return(character()) |
|
| 166 | +311 |
- prefix = NULL,+ } |
|
| 167 | +312 |
- suffix = NULL) {
+
|
|
| 168 | +313 | ! |
- add_label <- function(var_names) {
+ y <- Map(function(col, colname) {
|
| 169 | +314 | ! |
- label <- vapply(+ label <- attr(col, "label")+ |
+
| 315 | ++ | + | |
| 170 | +316 | ! |
- dataset[var_names], function(x) {
+ if (is.null(label)) {
|
| 171 | +317 | ! |
- attr_label <- attr(x, "label")+ if (fill) {
|
| 172 | +318 | ! |
- `if`(is.null(attr_label), "", attr_label)+ colname |
| 173 | +319 |
- },+ } else {
|
|
| 174 | +320 | ! |
- character(1)+ NA_character_ |
| 175 | +321 |
- )+ } |
|
| 176 | +322 |
-
+ } else {
|
|
| 177 | +323 | ! |
- if (length(label) == 1 && !is.na(label) && !identical(label, "")) {
+ if (!is.character(label) && !(length(label) == 1)) {
|
| 178 | +324 | ! |
- paste0(prefix, label, " [", var_names, "]", suffix)+ stop("label for variable ", colname, "is not a character string")
|
| 179 | +325 |
- } else {
+ } |
|
| 180 | +326 | ! |
- var_names+ as.vector(label) |
| 181 | +327 |
} |
|
| 182 | -+ | ||
| 328 | +! |
- }+ }, x, colnames(x)) |
|
| 183 | +329 | ||
| 184 | -! | -
- if (length(var_names) < 1) {
- |
- |
| 185 | -! | -
- NULL- |
- |
| 186 | +330 | ! |
- } else if (length(var_names) == 1) {
+ labels <- unlist(y, recursive = FALSE, use.names = TRUE) |
| 187 | -! | +||
| 331 | +
- stringr::str_wrap(add_label(var_names), width = wrap_width)+ |
||
| 188 | +332 | ! |
- } else if (length(var_names) > 1) {
+ if (!is.character(labels)) {
|
| 189 | +333 | ! |
- stringr::str_wrap(vapply(var_names, add_label, character(1)), width = wrap_width)+ stop("label extraction failed")
|
| 190 | +334 |
} |
|
| 191 | -- |
- }- |
- |
| 192 | +335 | ||
| 193 | -- |
- #' Extract html id for `data_extract_ui`- |
- |
| 194 | -+ | ||
| 336 | +! |
- #' @description The `data_extract_ui` is located under extended html id.+ labels |
|
| 195 | +337 |
- #' We could not use \code{ns("original id")} for reference, as it is extended with specific suffixes.
+ } |
|
| 196 | +338 |
- #' @param varname character original html id.+ |
|
| 197 | +339 |
- #' This will be mostly retrieved with \code{ns("original id")} in `ui` or
+ #' Get a string with java-script code checking if the specific tab is clicked |
|
| 198 | +340 |
- #' \code{session$ns("original id")} in server function.
+ #' @description will be the input for `shiny::conditionalPanel()` |
|
| 199 | +341 |
- #' @param dataname character \code{dataname} from data_extract input.
+ #' @param id `character(1)` the id of the tab panel with tabs. |
|
| 200 | +342 |
- #' This might be retrieved like \code{teal.transform::data_extract_spec(...)[[1]]$dataname}.
+ #' @param name `character(1)` the name of the tab. |
|
| 201 | +343 |
- #' @param filter logical if the connected \code{extract_data_spec} is used with \code{filter} option.
+ #' @keywords internal |
|
| 202 | +344 |
- #' @keywords internal+ is_tab_active_js <- function(id, name) {
|
|
| 203 | +345 |
- extract_input <- function(varname, dataname, filter = FALSE) {
+ # supporting the bs3 and higher version at the same time |
|
| 204 | +346 | ! |
- if (filter) {
+ sprintf( |
| 205 | +347 | ! |
- paste0(varname, "-dataset_", dataname, "_singleextract-filter1-vals")- |
-
| 206 | -- |
- } else {
+ "$(\"#%1$s > li.active\").text().trim() == '%2$s' || $(\"#%1$s > li a.active\").text().trim() == '%2$s'", |
|
| 207 | +348 | ! |
- paste0(varname, "-dataset_", dataname, "_singleextract-select")+ id, name |
| 208 | +349 |
- }+ ) |
|
| 209 | +350 |
} |
| 210 | -- | - - | -||
| 211 | -- |
- # see vignette("ggplot2-specs", package="ggplot2")
- |
- ||
| 212 | -- |
- shape_names <- c(- |
- ||
| 213 | +1 |
- "circle", paste("circle", c("open", "filled", "cross", "plus", "small")), "bullet",
+ #' Data Table Viewer Teal Module |
||
| 214 | +2 |
- "square", paste("square", c("open", "filled", "cross", "plus", "triangle")),
+ #' |
||
| 215 | +3 |
- "diamond", paste("diamond", c("open", "filled", "plus")),
+ #' A data table viewer shows the data using a paginated table. |
||
| 216 | +4 |
- "triangle", paste("triangle", c("open", "filled", "square")),
+ #' specifically designed for use with `data.frames`. |
||
| 217 | +5 |
- paste("triangle down", c("open", "filled")),
+ #' @md |
||
| 218 | +6 |
- "plus", "cross", "asterisk"+ #' |
||
| 219 | +7 |
- )+ #' @inheritParams teal::module |
||
| 220 | +8 |
-
+ #' @inheritParams shared_params |
||
| 221 | +9 |
- #' Get icons to represent variable types in dataset+ #' @param variables_selected (`list`) A named list of character vectors of the variables (i.e. columns) |
||
| 222 | +10 |
- #'+ #' which should be initially shown for each dataset. Names of list elements should correspond to the names |
||
| 223 | +11 |
- #' @param var_type (`character`)\cr+ #' of the datasets available in the app. If no entry is specified for a dataset, the first six variables from that |
||
| 224 | +12 |
- #' of R internal types (classes).+ #' dataset will initially be shown. |
||
| 225 | +13 |
- #'+ #' @param datasets_selected (`character`) A vector of datasets which should be |
||
| 226 | +14 |
- #' @return (`character`)\cr+ #' shown and in what order. Names in the vector have to correspond with datasets names. |
||
| 227 | +15 |
- #' vector of HTML icons corresponding to data type in each column.+ #' If vector of length zero (default) then all datasets are shown. |
||
| 228 | +16 |
- #' @keywords internal+ #' Note: Only datasets of the `data.frame` class are compatible; |
||
| 229 | +17 |
- #'+ #' using other types will cause an error. |
||
| 230 | +18 |
- #' @examples+ #' @param dt_args (named `list`) Additional arguments to be passed to `DT::datatable` |
||
| 231 | +19 |
- #' teal.modules.general:::variable_type_icons(c(+ #' (must not include `data` or `options`). |
||
| 232 | +20 |
- #' "integer", "numeric", "logical", "Date", "POSIXct", "POSIXlt",+ #' @param dt_options (named `list`) The `options` argument to `DT::datatable`. By default |
||
| 233 | +21 |
- #' "factor", "character", "unknown", ""+ #' `list(searching = FALSE, pageLength = 30, lengthMenu = c(5, 15, 30, 100), scrollX = TRUE)` |
||
| 234 | +22 |
- #' ))+ #' @param server_rendering (`logical`) should the data table be rendered server side |
||
| 235 | +23 |
- variable_type_icons <- function(var_type) {
- |
- ||
| 236 | -! | -
- checkmate::assert_character(var_type, any.missing = FALSE)+ #' (see `server` argument of `DT::renderDataTable()`) |
||
| 237 | -- | - - | -||
| 238 | -! | -
- class_to_icon <- list(- |
- ||
| 239 | -! | -
- numeric = "arrow-up-1-9",- |
- ||
| 240 | -! | -
- integer = "arrow-up-1-9",- |
- ||
| 241 | -! | -
- logical = "pause",- |
- ||
| 242 | -! | -
- Date = "calendar",- |
- ||
| 243 | -! | -
- POSIXct = "calendar",- |
- ||
| 244 | -! | -
- POSIXlt = "calendar",- |
- ||
| 245 | -! | -
- factor = "chart-bar",- |
- ||
| 246 | -! | -
- character = "keyboard",- |
- ||
| 247 | -! | +24 | +
- primary_key = "key",+ #' @details |
|
| 248 | -! | +|||
| 25 | +
- unknown = "circle-question"+ #' The `DT` package has an option `DT.TOJSON_ARGS` to show `Inf` and `NA` in data tables. If this is something |
|||
| 249 | +26 |
- )+ #' you require then set `options(DT.TOJSON_ARGS = list(na = "string"))` before running the module. |
||
| 250 | -! | +|||
| 27 | +
- class_to_icon <- lapply(class_to_icon, function(icon_name) toString(icon(icon_name, lib = "font-awesome")))+ #' Note though that sorting of numeric columns with `NA`/`Inf` will be lexicographic not numerical. |
|||
| 251 | +28 |
-
+ #' |
||
| 252 | -! | +|||
| 29 | +
- res <- unname(vapply(+ #' @examples |
|||
| 253 | -! | +|||
| 30 | +
- var_type,+ #' # general data example |
|||
| 254 | -! | +|||
| 31 | +
- FUN.VALUE = character(1),+ #' |
|||
| 255 | -! | +|||
| 32 | +
- FUN = function(class) {
+ #' data <- teal_data() |
|||
| 256 | -! | +|||
| 33 | +
- if (class == "") {
+ #' data <- within(data, {
|
|||
| 257 | -! | +|||
| 34 | +
- class+ #' library(nestcolor) |
|||
| 258 | -! | +|||
| 35 | +
- } else if (is.null(class_to_icon[[class]])) {
+ #' iris <- iris |
|||
| 259 | -! | +|||
| 36 | +
- class_to_icon[["unknown"]]+ #' }) |
|||
| 260 | +37 |
- } else {
+ #' datanames(data) <- c("iris")
|
||
| 261 | -! | +|||
| 38 | +
- class_to_icon[[class]]+ #' |
|||
| 262 | +39 |
- }+ #' app <- init( |
||
| 263 | +40 |
- }+ #' data = data, |
||
| 264 | +41 |
- ))+ #' modules = modules( |
||
| 265 | +42 |
-
+ #' tm_data_table( |
||
| 266 | -! | +|||
| 43 | +
- return(res)+ #' variables_selected = list( |
|||
| 267 | +44 |
- }+ #' iris = c("Sepal.Length", "Sepal.Width", "Petal.Length", "Petal.Width", "Species")
|
||
| 268 | +45 |
-
+ #' ), |
||
| 269 | +46 |
- #' Include `CSS` files from `/inst/css/` package directory to application header+ #' dt_args = list(caption = "ADSL Table Caption") |
||
| 270 | +47 |
- #'+ #' ) |
||
| 271 | +48 |
- #' `system.file` should not be used to access files in other packages, it does+ #' ) |
||
| 272 | +49 |
- #' not work with `devtools`. Therefore, we redefine this method in each package+ #' ) |
||
| 273 | +50 |
- #' as needed. Thus, we do not export this method+ #' if (interactive()) {
|
||
| 274 | +51 |
- #'+ #' shinyApp(app$ui, app$server) |
||
| 275 | +52 |
- #' @param pattern (`character`) pattern of files to be included+ #' } |
||
| 276 | +53 |
#' |
||
| 277 | +54 |
- #' @return HTML code that includes `CSS` files+ #' # CDISC data example |
||
| 278 | +55 |
- #' @keywords internal+ #' data <- teal_data() |
||
| 279 | +56 |
- include_css_files <- function(pattern = "*") {
+ #' data <- within(data, {
|
||
| 280 | -! | +|||
| 57 | +
- css_files <- list.files(+ #' library(nestcolor) |
|||
| 281 | -! | +|||
| 58 | +
- system.file("css", package = "teal.modules.general", mustWork = TRUE),
+ #' ADSL <- rADSL |
|||
| 282 | -! | +|||
| 59 | +
- pattern = pattern, full.names = TRUE+ #' }) |
|||
| 283 | +60 |
- )+ #' datanames(data) <- "ADSL" |
||
| 284 | -! | +|||
| 61 | +
- if (length(css_files) == 0) {
+ #' join_keys(data) <- default_cdisc_join_keys[datanames(data)] |
|||
| 285 | -! | +|||
| 62 | +
- return(NULL)+ #' |
|||
| 286 | +63 |
- }+ #' app <- init( |
||
| 287 | -! | +|||
| 64 | +
- return(shiny::singleton(shiny::tags$head(lapply(css_files, shiny::includeCSS))))+ #' data = data, |
|||
| 288 | +65 |
- }+ #' modules = modules( |
||
| 289 | +66 |
-
+ #' tm_data_table( |
||
| 290 | +67 |
-
+ #' variables_selected = list(ADSL = c("STUDYID", "USUBJID", "SUBJID", "SITEID", "AGE", "SEX")),
|
||
| 291 | +68 |
- #' Get Label Attributes of Variables in a \code{data.frame}
+ #' dt_args = list(caption = "ADSL Table Caption") |
||
| 292 | +69 |
- #'+ #' ) |
||
| 293 | +70 |
- #' Variable labels can be stored as a \code{label} attribute for each variable.
+ #' ) |
||
| 294 | +71 |
- #' This functions returns a named character vector with the variable labels+ #' ) |
||
| 295 | +72 |
- #' (empty sting if not specified)+ #' if (interactive()) {
|
||
| 296 | +73 |
- #'+ #' shinyApp(app$ui, app$server) |
||
| 297 | +74 |
- #' @param x a \code{data.frame} object
+ #' } |
||
| 298 | +75 |
- #' @param fill boolean in case the \code{label} attribute does not exist if
+ #' |
||
| 299 | +76 |
- #' \code{TRUE} the variable names is returned, otherwise \code{NA}
+ #' @export |
||
| 300 | +77 |
#' |
||
| 301 | +78 |
- #' @return a named character vector with the variable labels, the names+ tm_data_table <- function(label = "Data Table", |
||
| 302 | +79 |
- #' correspond to the variable names+ variables_selected = list(), |
||
| 303 | +80 |
- #'+ datasets_selected = character(0), |
||
| 304 | +81 |
- #' @note the `formatters` package is the source of the function.+ dt_args = list(), |
||
| 305 | +82 |
- #'+ dt_options = list( |
||
| 306 | +83 |
- #' @keywords internal+ searching = FALSE, |
||
| 307 | +84 |
- var_labels <- function(x, fill = FALSE) {
+ pageLength = 30, |
||
| 308 | -! | +|||
| 85 | +
- stopifnot(is.data.frame(x))+ lengthMenu = c(5, 15, 30, 100), |
|||
| 309 | -! | +|||
| 86 | +
- if (NCOL(x) == 0) {
+ scrollX = TRUE |
|||
| 310 | -! | +|||
| 87 | +
- return(character())+ ), |
|||
| 311 | +88 |
- }+ server_rendering = FALSE, |
||
| 312 | +89 |
-
+ pre_output = NULL,+ |
+ ||
| 90 | ++ |
+ post_output = NULL) {
|
||
| 313 | +91 | ! |
- y <- Map(function(col, colname) {
+ logger::log_info("Initializing tm_data_table")
|
|
| 314 | +92 | ! |
- label <- attr(col, "label")+ checkmate::assert_string(label) |
|
| 315 | -+ | |||
| 93 | +! |
-
+ checkmate::assert_list(variables_selected, min.len = 0, types = "character", names = "named") |
||
| 316 | +94 | ! |
- if (is.null(label)) {
+ if (length(variables_selected) > 0) {
|
|
| 317 | +95 | ! |
- if (fill) {
+ lapply(seq_along(variables_selected), function(i) {
|
|
| 318 | +96 | ! |
- colname+ checkmate::assert_character(variables_selected[[i]], min.chars = 1, min.len = 1) |
|
| 319 | -+ | |||
| 97 | +! |
- } else {
+ if (!is.null(names(variables_selected[[i]]))) {
|
||
| 320 | +98 | ! |
- NA_character_+ checkmate::assert_names(names(variables_selected[[i]])) |
|
| 321 | +99 |
} |
||
| 322 | +100 |
- } else {
+ }) |
||
| 323 | -! | +|||
| 101 | +
- if (!is.character(label) && !(length(label) == 1)) {
+ } |
|||
| 324 | +102 | ! |
- stop("label for variable ", colname, "is not a character string")
+ checkmate::assert_character(datasets_selected, min.len = 0, min.chars = 1) |
|
| 325 | -+ | |||
| 103 | +! |
- }+ checkmate::assert_list(dt_options, names = "named") |
||
| 326 | +104 | ! |
- as.vector(label)+ checkmate::assert( |
|
| 327 | -+ | |||
| 105 | +! |
- }+ checkmate::check_list(dt_args, len = 0), |
||
| 328 | +106 | ! |
- }, x, colnames(x))+ checkmate::check_subset(names(dt_args), choices = names(formals(DT::datatable))) |
|
| 329 | +107 | ++ |
+ )+ |
+ |
| 108 | ||||
| 330 | +109 | ! |
- labels <- unlist(y, recursive = FALSE, use.names = TRUE)+ checkmate::assert_flag(server_rendering) |
|
| 331 | +110 | |||
| 332 | +111 | ! |
- if (!is.character(labels)) {
+ module( |
|
| 333 | +112 | ! |
- stop("label extraction failed")
- |
- |
| 334 | -- |
- }- |
- ||
| 335 | -- |
-
+ label, |
||
| 336 | +113 | ! |
- labels+ server = srv_page_data_table, |
|
| 337 | -+ | |||
| 114 | +! |
- }+ ui = ui_page_data_table, |
||
| 338 | -+ | |||
| 115 | +! |
-
+ datanames = if (length(datasets_selected) == 0) "all" else datasets_selected, |
||
| 339 | -+ | |||
| 116 | +! |
- #' Get a string with java-script code checking if the specific tab is clicked+ server_args = list( |
||
| 340 | -+ | |||
| 117 | +! |
- #' @description will be the input for `shiny::conditionalPanel()`+ variables_selected = variables_selected, |
||
| 341 | -+ | |||
| 118 | +! |
- #' @param id `character(1)` the id of the tab panel with tabs.+ datasets_selected = datasets_selected, |
||
| 342 | -+ | |||
| 119 | +! |
- #' @param name `character(1)` the name of the tab.+ dt_args = dt_args, |
||
| 343 | -+ | |||
| 120 | +! |
- #' @keywords internal+ dt_options = dt_options, |
||
| 344 | -+ | |||
| 121 | +! |
- is_tab_active_js <- function(id, name) {
+ server_rendering = server_rendering |
||
| 345 | +122 |
- # supporting the bs3 and higher version at the same time+ ), |
||
| 346 | +123 | ! |
- sprintf(+ ui_args = list( |
|
| 347 | +124 | ! |
- "$(\"#%1$s > li.active\").text().trim() == '%2$s' || $(\"#%1$s > li a.active\").text().trim() == '%2$s'",+ pre_output = pre_output, |
|
| 348 | +125 | ! |
- id, name+ post_output = post_output |
|
| 349 | +126 |
- )+ ) |
||
| 350 | +127 |
- }+ ) |
| 1 | +128 |
- #' Create a simple cross-table+ } |
|
| 2 | +129 |
- #' @md+ |
|
| 3 | +130 |
- #'+ |
|
| 4 | +131 |
- #' @inheritParams teal::module+ # ui page module |
|
| 5 | +132 |
- #' @inheritParams shared_params+ ui_page_data_table <- function(id, |
|
| 6 | +133 |
- #' @param x (`data_extract_spec` or `list` of multiple `data_extract_spec`)+ pre_output = NULL, |
|
| 7 | +134 |
- #' Object with all available choices with pre-selected option for variable X - row values. In case+ post_output = NULL) {
|
|
| 8 | -+ | ||
| 135 | +! |
- #' of `data_extract_spec` use `select_spec(..., ordered = TRUE)` if table elements should be+ ns <- NS(id) |
|
| 9 | +136 |
- #' rendered according to selection order.+ |
|
| 10 | -+ | ||
| 137 | +! |
- #' @param y (`data_extract_spec` or `list` of multiple `data_extract_spec`)+ shiny::tagList( |
|
| 11 | -+ | ||
| 138 | +! |
- #' Object with all available choices with pre-selected option for variable Y - column values+ include_css_files("custom"),
|
|
| 12 | -+ | ||
| 139 | +! |
- #' \code{data_extract_spec} must not allow multiple selection in this case.
+ teal.widgets::standard_layout( |
|
| 13 | -+ | ||
| 140 | +! |
- #'+ output = teal.widgets::white_small_well( |
|
| 14 | -+ | ||
| 141 | +! |
- #' @param show_percentage optional, (`logical`) Whether to show percentages+ fluidRow( |
|
| 15 | -+ | ||
| 142 | +! |
- #' (relevant only when `x` is a `factor`). Defaults to `TRUE`.+ column( |
|
| 16 | -+ | ||
| 143 | +! |
- #' @param show_total optional, (`logical`) Whether to show total column. Defaults to `TRUE`.+ width = 12, |
|
| 17 | -+ | ||
| 144 | +! |
- #'+ checkboxInput( |
|
| 18 | -+ | ||
| 145 | +! |
- #' @note For more examples, please see the vignette "Using cross table" via+ ns("if_distinct"),
|
|
| 19 | -+ | ||
| 146 | +! |
- #' `vignette("using-cross-table", package = "teal.modules.general")`.
+ "Show only distinct rows:", |
|
| 20 | -+ | ||
| 147 | +! |
- #'+ value = FALSE |
|
| 21 | +148 |
- #' @examples+ ) |
|
| 22 | +149 |
- #' # general data example+ ) |
|
| 23 | +150 |
- #' library(teal.widgets)+ ), |
|
| 24 | -+ | ||
| 151 | +! |
- #'+ fluidRow( |
|
| 25 | -+ | ||
| 152 | +! |
- #' data <- teal_data()+ class = "mb-8", |
|
| 26 | -+ | ||
| 153 | +! |
- #' data <- within(data, {
+ column( |
|
| 27 | -+ | ||
| 154 | +! |
- #' mtcars <- mtcars+ width = 12, |
|
| 28 | -+ | ||
| 155 | +! |
- #' for (v in c("cyl", "vs", "am", "gear")) {
+ uiOutput(ns("dataset_table"))
|
|
| 29 | +156 |
- #' mtcars[[v]] <- as.factor(mtcars[[v]])+ ) |
|
| 30 | +157 |
- #' }+ ) |
|
| 31 | +158 |
- #' mtcars[["primary_key"]] <- seq_len(nrow(mtcars))+ ), |
|
| 32 | -+ | ||
| 159 | +! |
- #' })+ pre_output = pre_output, |
|
| 33 | -+ | ||
| 160 | +! |
- #' datanames(data) <- "mtcars"+ post_output = post_output |
|
| 34 | +161 |
- #' join_keys(data) <- join_keys(join_key("mtcars", "mtcars", "primary_key"))
+ ) |
|
| 35 | +162 |
- #'+ ) |
|
| 36 | +163 |
- #' app <- init(+ } |
|
| 37 | +164 |
- #' data = data,+ |
|
| 38 | +165 |
- #' modules = modules(+ |
|
| 39 | +166 |
- #' tm_t_crosstable(+ # server page module |
|
| 40 | +167 |
- #' label = "Cross Table",+ srv_page_data_table <- function(id, |
|
| 41 | +168 |
- #' x = data_extract_spec(+ data, |
|
| 42 | +169 |
- #' dataname = "mtcars",+ datasets_selected, |
|
| 43 | +170 |
- #' select = select_spec(+ variables_selected, |
|
| 44 | +171 |
- #' label = "Select variable:",+ dt_args, |
|
| 45 | +172 |
- #' choices = variable_choices(data[["mtcars"]], c("cyl", "vs", "am", "gear")),
+ dt_options, |
|
| 46 | +173 |
- #' selected = c("cyl", "gear"),
+ server_rendering) {
|
|
| 47 | -+ | ||
| 174 | +! |
- #' multiple = TRUE,+ checkmate::assert_class(data, "reactive") |
|
| 48 | -+ | ||
| 175 | +! |
- #' ordered = TRUE,+ checkmate::assert_class(isolate(data()), "teal_data") |
|
| 49 | -+ | ||
| 176 | +! |
- #' fixed = FALSE+ moduleServer(id, function(input, output, session) {
|
|
| 50 | -+ | ||
| 177 | +! |
- #' )+ if_filtered <- reactive(as.logical(input$if_filtered)) |
|
| 51 | -+ | ||
| 178 | +! |
- #' ),+ if_distinct <- reactive(as.logical(input$if_distinct)) |
|
| 52 | +179 |
- #' y = data_extract_spec(+ |
|
| 53 | -+ | ||
| 180 | +! |
- #' dataname = "mtcars",+ datanames <- isolate(teal.data::datanames(data())) |
|
| 54 | -+ | ||
| 181 | +! |
- #' select = select_spec(+ datanames <- Filter(function(name) {
|
|
| 55 | -+ | ||
| 182 | +! |
- #' label = "Select variable:",+ is.data.frame(isolate(data())[[name]]) |
|
| 56 | -+ | ||
| 183 | +! |
- #' choices = variable_choices(data[["mtcars"]], c("cyl", "vs", "am", "gear")),
+ }, datanames) |
|
| 57 | +184 |
- #' selected = "vs",+ |
|
| 58 | -+ | ||
| 185 | +! |
- #' multiple = FALSE,+ if (!identical(datasets_selected, character(0))) {
|
|
| 59 | -+ | ||
| 186 | +! |
- #' fixed = FALSE+ checkmate::assert_subset(datasets_selected, datanames) |
|
| 60 | -+ | ||
| 187 | +! |
- #' )+ datanames <- datasets_selected |
|
| 61 | +188 |
- #' ),+ } |
|
| 62 | +189 |
- #' basic_table_args = basic_table_args(+ |
|
| 63 | -+ | ||
| 190 | +! |
- #' subtitles = "Table generated by Crosstable Module"+ output$dataset_table <- renderUI({
|
|
| 64 | -+ | ||
| 191 | +! |
- #' )+ do.call( |
|
| 65 | -+ | ||
| 192 | +! |
- #' )+ tabsetPanel, |
|
| 66 | -+ | ||
| 193 | +! |
- #' )+ lapply( |
|
| 67 | -+ | ||
| 194 | +! |
- #' )+ datanames, |
|
| 68 | -+ | ||
| 195 | +! |
- #' if (interactive()) {
+ function(x) {
|
|
| 69 | -+ | ||
| 196 | +! |
- #' shinyApp(app$ui, app$server)+ dataset <- isolate(data()[[x]]) |
|
| 70 | -+ | ||
| 197 | +! |
- #' }+ choices <- names(dataset) |
|
| 71 | -+ | ||
| 198 | +! |
- #'+ labels <- vapply( |
|
| 72 | -+ | ||
| 199 | +! |
- #' # CDISC data example+ dataset, |
|
| 73 | -+ | ||
| 200 | +! |
- #' library(teal.widgets)+ function(x) ifelse(is.null(attr(x, "label")), "", attr(x, "label")), |
|
| 74 | -+ | ||
| 201 | +! |
- #'+ character(1) |
|
| 75 | +202 |
- #' data <- teal_data()+ ) |
|
| 76 | -+ | ||
| 203 | +! |
- #' data <- within(data, {
+ names(choices) <- ifelse( |
|
| 77 | -+ | ||
| 204 | +! |
- #' ADSL <- rADSL+ is.na(labels) | labels == "", |
|
| 78 | -+ | ||
| 205 | +! |
- #' })+ choices, |
|
| 79 | -+ | ||
| 206 | +! |
- #' datanames(data) <- "ADSL"+ paste(choices, labels, sep = ": ") |
|
| 80 | +207 |
- #' join_keys(data) <- default_cdisc_join_keys[datanames(data)]+ ) |
|
| 81 | -+ | ||
| 208 | +! |
- #'+ variables_selected <- if (!is.null(variables_selected[[x]])) {
|
|
| 82 | -+ | ||
| 209 | +! |
- #' app <- init(+ variables_selected[[x]] |
|
| 83 | +210 |
- #' data = data,+ } else {
|
|
| 84 | -+ | ||
| 211 | +! |
- #' modules = modules(+ utils::head(choices) |
|
| 85 | +212 |
- #' tm_t_crosstable(+ } |
|
| 86 | -+ | ||
| 213 | +! |
- #' label = "Cross Table",+ tabPanel( |
|
| 87 | -+ | ||
| 214 | +! |
- #' x = data_extract_spec(+ title = x, |
|
| 88 | -+ | ||
| 215 | +! |
- #' dataname = "ADSL",+ column( |
|
| 89 | -+ | ||
| 216 | +! |
- #' select = select_spec(+ width = 12, |
|
| 90 | -+ | ||
| 217 | +! |
- #' label = "Select variable:",+ div( |
|
| 91 | -+ | ||
| 218 | +! |
- #' choices = variable_choices(data[["ADSL"]], subset = function(data) {
+ class = "mt-4", |
|
| 92 | -+ | ||
| 219 | +! |
- #' idx <- !vapply(data, inherits, logical(1), c("Date", "POSIXct", "POSIXlt"))
+ ui_data_table( |
|
| 93 | -+ | ||
| 220 | +! |
- #' return(names(data)[idx])+ id = session$ns(x), |
|
| 94 | -+ | ||
| 221 | +! |
- #' }),+ choices = choices, |
|
| 95 | -+ | ||
| 222 | +! |
- #' selected = "COUNTRY",+ selected = variables_selected |
|
| 96 | +223 |
- #' multiple = TRUE,+ ) |
|
| 97 | +224 |
- #' ordered = TRUE,+ ) |
|
| 98 | +225 |
- #' fixed = FALSE+ ) |
|
| 99 | +226 |
- #' )+ ) |
|
| 100 | +227 |
- #' ),+ } |
|
| 101 | +228 |
- #' y = data_extract_spec(+ ) |
|
| 102 | +229 |
- #' dataname = "ADSL",+ ) |
|
| 103 | +230 |
- #' select = select_spec(+ }) |
|
| 104 | +231 |
- #' label = "Select variable:",+ |
|
| 105 | -+ | ||
| 232 | +! |
- #' choices = variable_choices(data[["ADSL"]], subset = function(data) {
+ lapply( |
|
| 106 | -+ | ||
| 233 | +! |
- #' idx <- vapply(data, is.factor, logical(1))+ datanames, |
|
| 107 | -+ | ||
| 234 | +! |
- #' return(names(data)[idx])+ function(x) {
|
|
| 108 | -+ | ||
| 235 | +! |
- #' }),+ srv_data_table( |
|
| 109 | -+ | ||
| 236 | +! |
- #' selected = "SEX",+ id = x, |
|
| 110 | -+ | ||
| 237 | +! |
- #' multiple = FALSE,+ data = data, |
|
| 111 | -+ | ||
| 238 | +! |
- #' fixed = FALSE+ dataname = x, |
|
| 112 | -+ | ||
| 239 | +! |
- #' )+ if_filtered = if_filtered, |
|
| 113 | -+ | ||
| 240 | +! |
- #' ),+ if_distinct = if_distinct, |
|
| 114 | -+ | ||
| 241 | +! |
- #' basic_table_args = basic_table_args(+ dt_args = dt_args, |
|
| 115 | -+ | ||
| 242 | +! |
- #' subtitles = "Table generated by Crosstable Module"+ dt_options = dt_options, |
|
| 116 | -+ | ||
| 243 | +! |
- #' )+ server_rendering = server_rendering |
|
| 117 | +244 |
- #' )+ ) |
|
| 118 | +245 |
- #' )+ } |
|
| 119 | +246 |
- #' )+ ) |
|
| 120 | +247 |
- #' if (interactive()) {
+ }) |
|
| 121 | +248 |
- #' shinyApp(app$ui, app$server)+ } |
|
| 122 | +249 |
- #' }+ |
|
| 123 | +250 |
- #'+ ui_data_table <- function(id, |
|
| 124 | +251 |
- #' @export+ choices, |
|
| 125 | +252 |
- #'+ selected) {
|
|
| 126 | -+ | ||
| 253 | +! |
- tm_t_crosstable <- function(label = "Cross Table",+ ns <- NS(id) |
|
| 127 | +254 |
- x,+ |
|
| 128 | -+ | ||
| 255 | +! |
- y,+ if (!is.null(selected)) {
|
|
| 129 | -+ | ||
| 256 | +! |
- show_percentage = TRUE,+ all_choices <- choices |
|
| 130 | -+ | ||
| 257 | +! |
- show_total = TRUE,+ choices <- c(selected, setdiff(choices, selected)) |
|
| 131 | -+ | ||
| 258 | +! |
- pre_output = NULL,+ names(choices) <- names(all_choices)[match(choices, all_choices)] |
|
| 132 | +259 |
- post_output = NULL,+ } |
|
| 133 | +260 |
- basic_table_args = teal.widgets::basic_table_args()) {
+
|
|
| 134 | +261 | ! |
- logger::log_info("Initializing tm_t_crosstable")
+ tagList( |
| 135 | +262 | ! |
- if (!requireNamespace("rtables", quietly = TRUE)) {
+ teal.widgets::get_dt_rows(ns("data_table"), ns("dt_rows")),
|
| 136 | +263 | ! |
- stop("Cannot load rtables - please install the package or restart your session.")
- |
-
| 137 | -- |
- }+ fluidRow( |
|
| 138 | +264 | ! |
- if (inherits(x, "data_extract_spec")) x <- list(x)+ teal.widgets::optionalSelectInput( |
| 139 | +265 | ! |
- if (inherits(y, "data_extract_spec")) y <- list(y)- |
-
| 140 | -- |
-
+ ns("variables"),
|
|
| 141 | +266 | ! |
- checkmate::assert_string(label)+ "Select variables:", |
| 142 | +267 | ! |
- checkmate::assert_list(x, types = "data_extract_spec")+ choices = choices, |
| 143 | +268 | ! |
- checkmate::assert_list(y, types = "data_extract_spec")+ selected = selected, |
| 144 | +269 | ! |
- if (any(vapply(y, function(x) x$select$multiple, logical(1)))) {
+ multiple = TRUE, |
| 145 | +270 | ! |
- stop("'y' should not allow multiple selection")
+ width = "100%" |
| 146 | +271 |
- }+ ) |
|
| 147 | -! | +||
| 272 | +
- checkmate::assert_flag(show_percentage)+ ), |
||
| 148 | +273 | ! |
- checkmate::assert_flag(show_total)+ fluidRow( |
| 149 | +274 | ! |
- checkmate::assert_class(basic_table_args, classes = "basic_table_args")+ DT::dataTableOutput(ns("data_table"), width = "100%")
|
| 150 | +275 |
-
+ ) |
|
| 151 | -! | +||
| 276 | +
- ui_args <- as.list(environment())+ ) |
||
| 152 | +277 |
-
+ } |
|
| 153 | -! | +||
| 278 | +
- server_args <- list(+ |
||
| 154 | -! | +||
| 279 | +
- label = label,+ srv_data_table <- function(id, |
||
| 155 | -! | +||
| 280 | +
- x = x,+ data, |
||
| 156 | -! | +||
| 281 | +
- y = y,+ dataname, |
||
| 157 | -! | +||
| 282 | +
- basic_table_args = basic_table_args+ if_filtered, |
||
| 158 | +283 |
- )+ if_distinct, |
|
| 159 | +284 |
-
+ dt_args, |
|
| 160 | -! | +||
| 285 | +
- module(+ dt_options, |
||
| 161 | -! | +||
| 286 | +
- label = label,+ server_rendering) {
|
||
| 162 | +287 | ! |
- server = srv_t_crosstable,+ moduleServer(id, function(input, output, session) {
|
| 163 | +288 | ! |
- ui = ui_t_crosstable,+ iv <- shinyvalidate::InputValidator$new() |
| 164 | +289 | ! |
- ui_args = ui_args,+ iv$add_rule("variables", shinyvalidate::sv_required("Please select valid variable names"))
|
| 165 | +290 | ! |
- server_args = server_args,+ iv$add_rule("variables", shinyvalidate::sv_in_set(
|
| 166 | +291 | ! |
- datanames = teal.transform::get_extract_datanames(list(x = x, y = y))+ set = names(data()[[dataname]]), message_fmt = "Not all selected variables exist in the data" |
| 167 | +292 |
- )+ )) |
|
| 168 | -+ | ||
| 293 | +! |
- }+ iv$enable() |
|
| 169 | +294 | ||
| 170 | -- |
- ui_t_crosstable <- function(id, x, y, show_percentage, show_total, pre_output, post_output, ...) {
- |
- |
| 171 | +295 | ! |
- ns <- NS(id)+ output$data_table <- DT::renderDataTable(server = server_rendering, {
|
| 172 | +296 | ! |
- is_single_dataset <- teal.transform::is_single_dataset(x, y)+ teal::validate_inputs(iv) |
| 173 | +297 | ||
| 174 | -! | -
- join_default_options <- c(- |
- |
| 175 | +298 | ! |
- "Full Join" = "dplyr::full_join",+ df <- data()[[dataname]] |
| 176 | +299 | ! |
- "Inner Join" = "dplyr::inner_join",+ variables <- input$variables |
| 177 | -! | +||
| 300 | +
- "Left Join" = "dplyr::left_join",+ |
||
| 178 | +301 | ! |
- "Right Join" = "dplyr::right_join"- |
-
| 179 | -- |
- )+ teal::validate_has_data(df, min_nrow = 1L, msg = paste("data", dataname, "is empty"))
|
|
| 180 | +302 | ||
| 181 | +303 | ! |
- teal.widgets::standard_layout(+ dataframe_selected <- if (if_distinct()) {
|
| 182 | +304 | ! |
- output = teal.widgets::white_small_well(+ dplyr::count(df, dplyr::across(tidyselect::all_of(variables))) |
| 183 | -! | +||
| 305 | +
- textOutput(ns("title")),
+ } else {
|
||
| 184 | +306 | ! |
- teal.widgets::table_with_settings_ui(ns("table"))
+ df[variables] |
| 185 | +307 |
- ),+ }+ |
+ |
| 308 | ++ | + | |
| 186 | +309 | ! |
- encoding = div(+ dt_args$options <- dt_options |
| 187 | -+ | ||
| 310 | +! |
- ### Reporter+ if (!is.null(input$dt_rows)) {
|
|
| 188 | +311 | ! |
- teal.reporter::simple_reporter_ui(ns("simple_reporter")),
+ dt_args$options$pageLength <- input$dt_rows |
| 189 | +312 |
- ###+ } |
|
| 190 | +313 | ! |
- tags$label("Encodings", class = "text-primary"),
+ dt_args$data <- dataframe_selected |
| 191 | -! | +||
| 314 | +
- teal.transform::datanames_input(list(x, y)),+ |
||
| 192 | +315 | ! |
- teal.transform::data_extract_ui(ns("x"), label = "Row values", x, is_single_dataset = is_single_dataset),
+ do.call(DT::datatable, dt_args) |
| 193 | -! | +||
| 316 | +
- teal.transform::data_extract_ui(ns("y"), label = "Column values", y, is_single_dataset = is_single_dataset),
+ }) |
||
| 194 | -! | +||
| 317 | +
- teal.widgets::optionalSelectInput(+ }) |
||
| 195 | -! | +||
| 318 | +
- ns("join_fun"),
+ } |
||
| 196 | -! | +
| 1 | +
- label = "Row to Column type of join",+ #' Front page module |
||
| 197 | -! | +||
| 2 | +
- choices = join_default_options,+ #' |
||
| 198 | -! | +||
| 3 | +
- selected = join_default_options[1],+ #' @description This `teal` module creates a simple front page for `teal` applications |
||
| 199 | -! | +||
| 4 | +
- multiple = FALSE+ #' |
||
| 200 | +5 |
- ),+ #' @inheritParams teal::module |
|
| 201 | -! | +||
| 6 | +
- tags$hr(),+ #' @param header_text `character vector` text to be shown at the top of the module, for each |
||
| 202 | -! | +||
| 7 | +
- teal.widgets::panel_group(+ #' element, if named the name is shown first in bold as a header followed by the value. The first |
||
| 203 | -! | +||
| 8 | +
- teal.widgets::panel_item(+ #' element's header is displayed larger than the others |
||
| 204 | -! | +||
| 9 | +
- title = "Table settings",+ #' @param tables `named list of dataframes` tables to be shown in the module |
||
| 205 | -! | +||
| 10 | +
- checkboxInput(ns("show_percentage"), "Show column percentage", value = show_percentage),
+ #' @param additional_tags `shiny.tag.list` or `html` additional shiny tags or `html` to be included after the table, |
||
| 206 | -! | +||
| 11 | +
- checkboxInput(ns("show_total"), "Show total column", value = show_total)
+ #' for example to include an image, `tagList(tags$img(src = "image.png"))` or to include further `html`, |
||
| 207 | +12 |
- )+ #' `HTML("html text here")`
|
|
| 208 | +13 |
- )+ #' @param footnotes `character vector` text to be shown at the bottom of the module, for each |
|
| 209 | +14 |
- ),+ #' element, if named the name is shown first in bold, followed by the value |
|
| 210 | -! | +||
| 15 | +
- forms = tagList(+ #' @param show_metadata `logical` should the metadata of the datasets be available on the module? |
||
| 211 | -! | +||
| 16 | +
- teal.widgets::verbatim_popup_ui(ns("warning"), "Show Warnings"),
+ #' @return A `teal` module to be used in `teal` applications |
||
| 212 | -! | +||
| 17 | +
- teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code")
+ #' @export |
||
| 213 | +18 |
- ),+ #' @examples |
|
| 214 | -! | +||
| 19 | +
- pre_output = pre_output,+ #' |
||
| 215 | -! | +||
| 20 | +
- post_output = post_output+ #' data <- teal_data() |
||
| 216 | +21 |
- )+ #' data <- within(data, {
|
|
| 217 | +22 |
- }+ #' library(nestcolor) |
|
| 218 | +23 |
-
+ #' ADSL <- teal.modules.general::rADSL |
|
| 219 | +24 |
- srv_t_crosstable <- function(id, data, reporter, filter_panel_api, label, x, y, basic_table_args) {
+ #' attr(ADSL, "metadata") <- list("Author" = "NEST team", "data_source" = "synthetic data")
|
|
| 220 | -! | +||
| 25 | +
- with_reporter <- !missing(reporter) && inherits(reporter, "Reporter")+ #' }) |
||
| 221 | -! | +||
| 26 | +
- with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI")+ #' datanames <- c("ADSL")
|
||
| 222 | -! | +||
| 27 | +
- checkmate::assert_class(data, "reactive")+ #' datanames(data) <- datanames |
||
| 223 | -! | +||
| 28 | +
- checkmate::assert_class(isolate(data()), "teal_data")+ #' join_keys(data) <- default_cdisc_join_keys[datanames] |
||
| 224 | -! | +||
| 29 | +
- moduleServer(id, function(input, output, session) {
+ #' |
||
| 225 | -! | +||
| 30 | +
- selector_list <- teal.transform::data_extract_multiple_srv(+ #' table_1 <- data.frame(Info = c("A", "B"), Text = c("A", "B"))
|
||
| 226 | -! | +||
| 31 | +
- data_extract = list(x = x, y = y),+ #' table_2 <- data.frame(`Column 1` = c("C", "D"), `Column 2` = c(5.5, 6.6), `Column 3` = c("A", "B"))
|
||
| 227 | -! | +||
| 32 | +
- datasets = data,+ #' table_3 <- data.frame(Info = c("E", "F"), Text = c("G", "H"))
|
||
| 228 | -! | +||
| 33 | +
- select_validation_rule = list(+ #' |
||
| 229 | -! | +||
| 34 | +
- x = shinyvalidate::sv_required("Please define column for row variable."),
+ #' table_input <- list( |
||
| 230 | -! | +||
| 35 | +
- y = shinyvalidate::sv_required("Please define column for column variable.")
+ #' "Table 1" = table_1, |
||
| 231 | +36 |
- )+ #' "Table 2" = table_2, |
|
| 232 | +37 |
- )+ #' "Table 3" = table_3 |
|
| 233 | +38 |
-
+ #' ) |
|
| 234 | -! | +||
| 39 | +
- iv_r <- reactive({
+ #' |
||
| 235 | -! | +||
| 40 | +
- iv <- shinyvalidate::InputValidator$new()+ #' app <- teal::init( |
||
| 236 | -! | +||
| 41 | +
- iv$add_rule("join_fun", function(value) {
+ #' data = data, |
||
| 237 | -! | +||
| 42 | +
- if (!identical(selector_list()$x()$dataname, selector_list()$y()$dataname)) {
+ #' modules = teal::modules( |
||
| 238 | -! | +||
| 43 | +
- if (!shinyvalidate::input_provided(value)) {
+ #' teal.modules.general::tm_front_page( |
||
| 239 | -! | +||
| 44 | +
- "Please select a joining function."+ #' header_text = c( |
||
| 240 | +45 |
- }+ #' "Important information" = "It can go here.", |
|
| 241 | +46 |
- }+ #' "Other information" = "Can go here." |
|
| 242 | +47 |
- })+ #' ), |
|
| 243 | -! | +||
| 48 | +
- teal.transform::compose_and_enable_validators(iv, selector_list)+ #' tables = table_input, |
||
| 244 | +49 |
- })+ #' additional_tags = HTML("Additional HTML or shiny tags go here <br>"),
|
|
| 245 | +50 |
-
+ #' footnotes = c("X" = "is the first footnote", "Y is the second footnote"),
|
|
| 246 | -! | +||
| 51 | +
- observeEvent(+ #' show_metadata = TRUE |
||
| 247 | -! | +||
| 52 | +
- eventExpr = {
+ #' ) |
||
| 248 | -! | +||
| 53 | +
- req(!is.null(selector_list()$x()) && !is.null(selector_list()$y()))+ #' ), |
||
| 249 | -! | +||
| 54 | +
- list(selector_list()$x(), selector_list()$y())+ #' header = tags$h1("Sample Application"),
|
||
| 250 | +55 |
- },+ #' footer = tags$p("Application footer"),
|
|
| 251 | -! | +||
| 56 | +
- handlerExpr = {
+ #' ) |
||
| 252 | -! | +||
| 57 | +
- if (identical(selector_list()$x()$dataname, selector_list()$y()$dataname)) {
+ #' if (interactive()) {
|
||
| 253 | -! | +||
| 58 | +
- shinyjs::hide("join_fun")
+ #' shinyApp(app$ui, app$server) |
||
| 254 | +59 |
- } else {
+ #' } |
|
| 255 | -! | +||
| 60 | +
- shinyjs::show("join_fun")
+ tm_front_page <- function(label = "Front page", |
||
| 256 | +61 |
- }+ header_text = character(0), |
|
| 257 | +62 |
- }+ tables = list(), |
|
| 258 | +63 |
- )+ additional_tags = tagList(), |
|
| 259 | +64 |
-
+ footnotes = character(0), |
|
| 260 | -! | +||
| 65 | +
- merge_function <- reactive({
+ show_metadata = FALSE) {
|
||
| 261 | +66 | ! |
- if (is.null(input$join_fun)) {
+ checkmate::assert_string(label) |
| 262 | +67 | ! |
- "dplyr::full_join"+ checkmate::assert_character(header_text, min.len = 0, any.missing = FALSE) |
| 263 | -+ | ||
| 68 | +! |
- } else {
+ checkmate::assert_list(tables, types = "data.frame", names = "named", any.missing = FALSE) |
|
| 264 | +69 | ! |
- input$join_fun+ checkmate::assert_multi_class(additional_tags, classes = c("shiny.tag.list", "html"))
|
| 265 | -+ | ||
| 70 | +! |
- }+ checkmate::assert_character(footnotes, min.len = 0, any.missing = FALSE) |
|
| 266 | -+ | ||
| 71 | +! |
- })+ checkmate::assert_flag(show_metadata) |
|
| 267 | +72 | ||
| 268 | +73 | ! |
- anl_merged_input <- teal.transform::merge_expression_srv(+ logger::log_info("Initializing tm_front_page")
|
| 269 | +74 | ! |
- datasets = data,+ args <- as.list(environment()) |
| 270 | -! | +||
| 75 | +
- selector_list = selector_list,+ |
||
| 271 | +76 | ! |
- merge_function = merge_function+ module( |
| 272 | -+ | ||
| 77 | +! |
- )+ label = label, |
|
| 273 | -+ | ||
| 78 | +! |
-
+ server = srv_front_page, |
|
| 274 | +79 | ! |
- anl_merged_q <- reactive({
+ ui = ui_front_page, |
| 275 | +80 | ! |
- req(anl_merged_input())+ ui_args = args, |
| 276 | +81 | ! |
- data() %>%+ server_args = list(tables = tables, show_metadata = show_metadata), |
| 277 | +82 | ! |
- teal.code::eval_code(as.expression(anl_merged_input()$expr))+ datanames = if (show_metadata) "all" else NULL |
| 278 | +83 |
- })+ ) |
|
| 279 | +84 |
-
+ } |
|
| 280 | -! | +||
| 85 | +
- merged <- list(+ |
||
| 281 | -! | +||
| 86 | +
- anl_input_r = anl_merged_input,+ ui_front_page <- function(id, ...) {
|
||
| 282 | +87 | ! |
- anl_q_r = anl_merged_q+ args <- list(...) |
| 283 | -+ | ||
| 88 | +! |
- )+ ns <- NS(id) |
|
| 284 | +89 | ||
| 285 | +90 | ! |
- output_q <- reactive({
+ tagList( |
| 286 | +91 | ! |
- teal::validate_inputs(iv_r())+ include_css_files("custom"),
|
| 287 | +92 | ! |
- ANL <- merged$anl_q_r()[["ANL"]] # nolint: object_name.- |
-
| 288 | -- | - - | -|
| 289 | -- |
- # As this is a summary+ tags$div( |
|
| 290 | +93 | ! |
- x_name <- as.vector(merged$anl_input_r()$columns_source$x)+ id = "front_page_content", |
| 291 | +94 | ! |
- y_name <- as.vector(merged$anl_input_r()$columns_source$y)+ class = "ml-8", |
| 292 | -+ | ||
| 95 | +! |
-
+ tags$div( |
|
| 293 | +96 | ! |
- teal::validate_has_data(ANL, 3)+ id = "front_page_headers", |
| 294 | +97 | ! |
- teal::validate_has_data(ANL[, c(x_name, y_name)], 3, complete = TRUE, allow_inf = FALSE)+ get_header_tags(args$header_text) |
| 295 | +98 |
-
+ ), |
|
| 296 | +99 | ! |
- is_allowed_class <- function(x) is.numeric(x) || is.factor(x) || is.character(x) || is.logical(x)+ tags$div( |
| 297 | +100 | ! |
- validate(need(+ id = "front_page_tables", |
| 298 | +101 | ! |
- all(vapply(ANL[x_name], is_allowed_class, logical(1))),+ class = "ml-4", |
| 299 | +102 | ! |
- "Selected row variable has an unsupported data type."+ get_table_tags(args$tables, ns) |
| 300 | +103 |
- ))+ ), |
|
| 301 | +104 | ! |
- validate(need(+ tags$div( |
| 302 | +105 | ! |
- is_allowed_class(ANL[[y_name]]),+ id = "front_page_custom_html", |
| 303 | +106 | ! |
- "Selected column variable has an unsupported data type."+ class = "my-4", |
| 304 | -+ | ||
| 107 | +! |
- ))+ args$additional_tags |
|
| 305 | +108 |
-
+ ), |
|
| 306 | +109 | ! |
- show_percentage <- input$show_percentage+ if (args$show_metadata) {
|
| 307 | +110 | ! |
- show_total <- input$show_total+ tags$div( |
| 308 | -+ | ||
| 111 | +! |
-
+ id = "front_page_metabutton", |
|
| 309 | +112 | ! |
- plot_title <- paste(+ class = "m-4", |
| 310 | +113 | ! |
- "Cross-Table of",+ actionButton(ns("metadata_button"), "Show metadata")
|
| 311 | -! | +||
| 114 | +
- paste0(varname_w_label(x_name, ANL), collapse = ", "),+ )+ |
+ ||
| 115 | ++ |
+ }, |
|
| 312 | +116 | ! |
- "(rows)", "vs.",+ tags$footer( |
| 313 | +117 | ! |
- varname_w_label(y_name, ANL),+ class = ".small", |
| 314 | +118 | ! |
- "(columns)"+ get_footer_tags(args$footnotes) |
| 315 | +119 |
) |
|
| 316 | +120 |
-
+ ) |
|
| 317 | -! | +||
| 121 | +
- labels_vec <- vapply(+ ) |
||
| 318 | -! | +||
| 122 | +
- x_name,+ } |
||
| 319 | -! | +||
| 123 | +
- varname_w_label,+ + |
+ ||
| 124 | ++ |
+ get_header_tags <- function(header_text) {
|
|
| 320 | +125 | ! |
- character(1),+ if (length(header_text) == 0) {
|
| 321 | +126 | ! |
- ANL+ return(list()) |
| 322 | +127 |
- )+ } |
|
| 323 | +128 | ||
| 324 | +129 | ! |
- teal.code::eval_code(+ get_single_header_tags <- function(header_text, p_text, header_tag = tags$h4) {
|
| 325 | +130 | ! |
- merged$anl_q_r(),+ tagList( |
| 326 | +131 | ! |
- substitute(+ tags$div( |
| 327 | +132 | ! |
- expr = {
+ if (!is.null(header_text) && nchar(header_text) > 0) header_tag(header_text), |
| 328 | +133 | ! |
- title <- plot_title+ tags$p(p_text) |
| 329 | +134 |
- },+ ) |
|
| 330 | -! | +||
| 135 | +
- env = list(plot_title = plot_title)+ ) |
||
| 331 | +136 |
- )+ } |
|
| 332 | +137 |
- ) %>%+ |
|
| 333 | +138 | ! |
- teal.code::eval_code(+ header_tags <- get_single_header_tags(names(header_text[1]), header_text[1], header_tag = tags$h3) |
| 334 | +139 | ! |
- substitute(+ c(header_tags, mapply(get_single_header_tags, utils::tail(names(header_text), -1), utils::tail(header_text, -1)))+ |
+
| 140 | ++ |
+ }+ |
+ |
| 141 | ++ | + | |
| 335 | -! | +||
| 142 | +
- expr = {
+ get_table_tags <- function(tables, ns) {
|
||
| 336 | +143 | ! |
- lyt <- basic_tables %>%+ if (length(tables) == 0) {
|
| 337 | +144 | ! |
- split_call %>% # styler: off+ return(list()) |
| 338 | -! | +||
| 145 | +
- rtables::add_colcounts() %>%+ } |
||
| 339 | +146 | ! |
- tern::analyze_vars(+ table_tags <- c(lapply(seq_along(tables), function(idx) {
|
| 340 | +147 | ! |
- vars = x_name,+ list( |
| 341 | +148 | ! |
- var_labels = labels_vec,+ tableOutput(ns(paste0("table_", idx)))
|
| 342 | -! | +||
| 149 | +
- na.rm = FALSE,+ ) |
||
| 343 | -! | +||
| 150 | +
- denom = "N_col",+ })) |
||
| 344 | +151 | ! |
- .stats = c("mean_sd", "median", "range", count_value)
+ return(table_tags) |
| 345 | +152 |
- )+ } |
|
| 346 | +153 |
- },+ |
|
| 347 | -! | +||
| 154 | +
- env = list(+ get_footer_tags <- function(footnotes) {
|
||
| 348 | +155 | ! |
- basic_tables = teal.widgets::parse_basic_table_args(+ if (length(footnotes) == 0) {
|
| 349 | +156 | ! |
- basic_table_args = teal.widgets::resolve_basic_table_args(basic_table_args)+ return(list()) |
| 350 | +157 |
- ),+ } |
|
| 351 | +158 | ! |
- split_call = if (show_total) {
+ bold_texts <- if (is.null(names(footnotes))) rep("", length(footnotes)) else names(footnotes)
|
| 352 | +159 | ! |
- substitute(+ footnote_tags <- mapply(function(bold_text, value) {
|
| 353 | +160 | ! |
- expr = rtables::split_cols_by(+ list( |
| 354 | +161 | ! |
- y_name,+ tags$div( |
| 355 | +162 | ! |
- split_fun = rtables::add_overall_level(label = "Total", first = FALSE)+ tags$b(bold_text), |
| 356 | -+ | ||
| 163 | +! |
- ),+ value, |
|
| 357 | +164 | ! |
- env = list(y_name = y_name)+ tags$br() |
| 358 | +165 |
- )+ ) |
|
| 359 | +166 |
- } else {
+ ) |
|
| 360 | +167 | ! |
- substitute(rtables::split_cols_by(y_name), env = list(y_name = y_name))+ }, bold_text = bold_texts, value = footnotes) |
| 361 | +168 |
- },- |
- |
| 362 | -! | -
- x_name = x_name,- |
- |
| 363 | -! | -
- labels_vec = labels_vec,- |
- |
| 364 | -! | -
- count_value = ifelse(show_percentage, "count_fraction", "count")+ } |
|
| 365 | +169 |
- )+ |
|
| 366 | +170 |
- )+ srv_front_page <- function(id, data, tables, show_metadata) {
|
|
| 367 | -+ | ||
| 171 | +! |
- ) %>%+ checkmate::assert_class(data, "reactive") |
|
| 368 | +172 | ! |
- teal.code::eval_code(+ checkmate::assert_class(isolate(data()), "teal_data") |
| 369 | +173 | ! |
- substitute(+ moduleServer(id, function(input, output, session) {
|
| 370 | +174 | ! |
- expr = {
+ ns <- session$ns+ |
+
| 175 | ++ | + | |
| 371 | +176 | ! |
- ANL <- tern::df_explicit_na(ANL) # nolint: object_name.+ lapply(seq_along(tables), function(idx) {
|
| 372 | +177 | ! |
- tbl <- rtables::build_table(lyt = lyt, df = ANL[order(ANL[[y_name]]), ])+ output[[paste0("table_", idx)]] <- renderTable(
|
| 373 | +178 | ! |
- tbl+ tables[[idx]], |
| 374 | -+ | ||
| 179 | +! |
- },+ bordered = TRUE, |
|
| 375 | +180 | ! |
- env = list(y_name = y_name)+ caption = names(tables)[idx], |
| 376 | -+ | ||
| 181 | +! |
- )+ caption.placement = "top" |
|
| 377 | +182 |
- )+ ) |
|
| 378 | +183 |
}) |
|
| 379 | +184 | ||
| 380 | +185 | ! |
- output$title <- renderText(output_q()[["title"]])+ if (show_metadata) {
|
| 381 | -+ | ||
| 186 | +! |
-
+ observeEvent( |
|
| 382 | +187 | ! |
- table_r <- reactive({
+ input$metadata_button, showModal( |
| 383 | +188 | ! |
- shiny::req(iv_r()$is_valid())+ modalDialog( |
| 384 | +189 | ! |
- output_q()[["tbl"]]+ title = "Metadata", |
| 385 | -+ | ||
| 190 | +! |
- })+ dataTableOutput(ns("metadata_table")),
|
|
| 386 | -+ | ||
| 191 | +! |
-
+ size = "l", |
|
| 387 | +192 | ! |
- teal.widgets::table_with_settings_srv(+ easyClose = TRUE |
| 388 | -! | +||
| 193 | +
- id = "table",+ ) |
||
| 389 | -! | +||
| 194 | +
- table_r = table_r+ ) |
||
| 390 | +195 |
- )+ ) |
|
| 391 | +196 | ||
| 392 | +197 | ! |
- teal.widgets::verbatim_popup_srv(+ metadata_data_frame <- reactive({
|
| 393 | +198 | ! |
- id = "warning",+ datanames <- teal.data::datanames(data()) |
| 394 | +199 | ! |
- verbatim_content = reactive(teal.code::get_warnings(output_q())),+ convert_metadata_to_dataframe( |
| 395 | +200 | ! |
- title = "Warning",+ lapply(datanames, function(dataname) attr(data()[[dataname]], "metadata")), |
| 396 | +201 | ! |
- disabled = reactive(is.null(teal.code::get_warnings(output_q())))+ datanames |
| 397 | +202 |
- )+ ) |
|
| 398 | +203 |
-
+ }) |
|
| 399 | -! | +||
| 204 | +
- teal.widgets::verbatim_popup_srv(+ |
||
| 400 | +205 | ! |
- id = "rcode",+ output$metadata_table <- renderDataTable({
|
| 401 | +206 | ! |
- verbatim_content = reactive(teal.code::get_code(output_q())),+ validate(need(nrow(metadata_data_frame()) > 0, "The data has no associated metadata")) |
| 402 | +207 | ! |
- title = "Show R Code for Cross-Table"+ metadata_data_frame() |
| 403 | +208 |
- )+ }) |
|
| 404 | +209 |
-
+ } |
|
| 405 | +210 |
- ### REPORTER- |
- |
| 406 | -! | -
- if (with_reporter) {
- |
- |
| 407 | -! | -
- card_fun <- function(comment, label) {
- |
- |
| 408 | -! | -
- card <- teal::report_card_template(- |
- |
| 409 | -! | -
- title = "Cross Table",+ }) |
|
| 410 | -! | +||
| 211 | +
- label = label,+ } |
||
| 411 | -! | +||
| 212 | +
- with_filter = with_filter,+ |
||
| 412 | -! | +||
| 213 | +
- filter_panel_api = filter_panel_api+ # take a list of metadata, one item per dataset (raw_metadata each element from datasets$get_metadata()) |
||
| 413 | +214 |
- )+ # and the corresponding datanames and output a data.frame with columns {Dataset, Name, Value}.
|
|
| 414 | -! | +||
| 215 | +
- card$append_text("Table", "header3")
+ # which are, the Dataset the metadata came from, the metadata's name and value |
||
| 415 | -! | +||
| 216 | +
- card$append_table(table_r())+ convert_metadata_to_dataframe <- function(raw_metadata, datanames) {
|
||
| 416 | -! | +||
| 217 | +4x |
- if (!comment == "") {
+ output <- mapply(function(metadata, dataname) {
|
|
| 417 | -! | +||
| 218 | +6x |
- card$append_text("Comment", "header3")
+ if (is.null(metadata)) {
|
|
| 418 | -! | +||
| 219 | +2x |
- card$append_text(comment)+ return(data.frame(Dataset = character(0), Name = character(0), Value = character(0))) |
|
| 419 | +220 |
- }+ } |
|
| 420 | -! | +||
| 221 | +4x |
- card$append_src(teal.code::get_code(output_q()))+ return(data.frame( |
|
| 421 | -! | +||
| 222 | +4x |
- card+ Dataset = dataname, |
|
| 422 | -+ | ||
| 223 | +4x |
- }+ Name = names(metadata), |
|
| 423 | -! | +||
| 224 | +4x |
- teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
+ Value = unname(unlist(lapply(metadata, as.character))) |
|
| 424 | +225 |
- }+ )) |
|
| 425 | -+ | ||
| 226 | +4x |
- ###+ }, raw_metadata, datanames, SIMPLIFY = FALSE) |
|
| 426 | -+ | ||
| 227 | +4x |
- })+ do.call(rbind, output) |
|
| 427 | +228 |
} |