expr = ANL <- anl_name[, selected_vars, drop = FALSE], # nolint object_name_linter+
expr = ANL <- anl_name[, selected_vars, drop = FALSE], # nolint: object_name.
substitute(expr = ANL <- anl_name, env = list(anl_name = as.name(dataname))) # nolint object_name_linter+
substitute(expr = ANL <- anl_name, env = list(anl_name = as.name(dataname))) # nolint: object_name.
expr = ANL[[group_var]] <- anl_name[[group_var]], # nolint object_name_linter+
expr = ANL[[group_var]] <- anl_name[[group_var]], # nolint: object_name.
expr = ANL[[new_col_name]] <- ifelse(rowSums(is.na(ANL)) > 0, NA, FALSE), # nolint object_name_linter+
expr = ANL[[new_col_name]] <- ifelse(rowSums(is.na(ANL)) > 0, NA, FALSE), # nolint: object_name.
ANL <- merged$anl_q_r()[["ANL"]] # nolint object_name_linter+
ANL <- merged$anl_q_r()[["ANL"]] # nolint: object_name.
# optional: grid.newpage() # nolint commented_code_linter+
# optional: grid.newpage() # nolint: commented_code.
| 1 |
- #' Variable Browser Teal Module+ #' File Viewer Teal Module |
||
| 3 |
- #' The variable browser provides a table with variable names and labels and a+ #' The file viewer module provides a tool to view static files. |
||
| 4 |
- #' plot that visualizes the content of a particular variable.+ #' Supported formats include text formats, \code{PDF}, \code{PNG}, \code{APNG},
|
||
| 5 |
- #' specifically designed for use with `data.frames`.+ #' \code{JPEG}, \code{SVG}, \code{WEBP}, \code{GIF} and \code{BMP}.
|
||
| 7 |
- #' @details Numeric columns with fewer than 30 distinct values can be treated as either factors+ #' @inheritParams teal::module |
||
| 8 |
- #' or numbers with a checkbox allowing users to switch how they are treated (if < 6 unique values+ #' @inheritParams shared_params |
||
| 9 |
- #' then the default is categorical, otherwise it is numeric).+ #' @param input_path optional, (`list`) of the input paths to either: specific files of accepted formats, |
||
| 10 |
- #'+ #' a directory or a URL. The paths can be specified as absolute paths or relative to the running |
||
| 11 |
- #' @inheritParams teal::module+ #' directory of the application. Will default to current working directory if not supplied. |
||
| 12 |
- #' @inheritParams shared_params+ #' |
||
| 13 |
- #' @param parent_dataname (`character(1)`) If this `dataname` exists in `datasets_selected`+ #' @export |
||
| 14 |
- #' then an extra checkbox will be shown to allow users to not show variables in other datasets+ #' |
||
| 15 |
- #' which exist in this `dataname`.+ #' @examples |
||
| 16 |
- #' This is typically used to remove `ADSL` columns in `CDISC` data. In non `CDISC` data this+ #' data <- teal_data() |
||
| 17 |
- #' can be ignored. Defaults to `"ADSL"`.+ #' data <- within(data, {
|
||
| 18 |
- #' @param datasets_selected (`character`) A vector of datasets which should be+ #' data <- data.frame(1) |
||
| 19 |
- #' shown and in what order. Names in the vector have to correspond with datasets names.+ #' }) |
||
| 20 |
- #' If vector of length zero (default) then all datasets are shown.+ #' datanames(data) <- c("data")
|
||
| 21 |
- #' Note: Only datasets of the `data.frame` class are compatible; using other types will cause an error.+ #' |
||
| 22 |
- #'+ #' app <- teal::init( |
||
| 23 |
- #' @aliases+ #' data = data, |
||
| 24 |
- #' tm_variable_browser_ui,+ #' modules = teal::modules( |
||
| 25 |
- #' tm_variable_browser_srv,+ #' teal.modules.general::tm_file_viewer( |
||
| 26 |
- #' tm_variable_browser,+ #' input_path = list( |
||
| 27 |
- #' variable_browser_ui,+ #' folder = system.file("sample_files", package = "teal.modules.general"),
|
||
| 28 |
- #' variable_browser_srv,+ #' png = system.file("sample_files/sample_file.png", package = "teal.modules.general"),
|
||
| 29 |
- #' variable_browser+ #' txt = system.file("sample_files/sample_file.txt", package = "teal.modules.general"),
|
||
| 30 |
- #'+ #' url = |
||
| 31 |
- #'+ #' "https://www.fda.gov/files/drugs/published/Portable-Document-Format-Specifications.pdf" |
||
| 32 |
- #' @export+ #' ) |
||
| 33 |
- #'+ #' ) |
||
| 34 |
- #' @examples+ #' ) |
||
| 35 |
- #'+ #' ) |
||
| 36 |
- #' data <- teal_data()+ #' if (interactive()) {
|
||
| 37 |
- #' data <- within(data, {
+ #' shinyApp(app$ui, app$server) |
||
| 38 |
- #' ADSL <- teal.modules.general::rADSL+ #' } |
||
| 39 |
- #' ADTTE <- teal.modules.general::rADTTE+ #' |
||
| 40 |
- #' })+ tm_file_viewer <- function(label = "File Viewer Module", |
||
| 41 |
- #' datanames <- c("ADSL", "ADTTE")
+ input_path = list("Current Working Directory" = ".")) {
|
||
| 42 | -+ | ! |
- #' datanames(data) <- datanames+ logger::log_info("Initializing tm_file_viewer")
|
| 43 | -+ | ! |
- #' join_keys(data) <- default_cdisc_join_keys[datanames]+ if (length(label) == 0 || identical(label, "")) {
|
| 44 | -+ | ! |
- #'+ label <- " " |
| 45 |
- #' app <- teal::init(+ } |
||
| 46 | -+ | ! |
- #' data = data,+ if (length(input_path) == 0 || identical(input_path, "")) {
|
| 47 | -+ | ! |
- #' modules(+ input_path <- list() |
| 48 |
- #' teal.modules.general::tm_variable_browser(+ } |
||
| 49 |
- #' label = "Variable browser",+ |
||
| 50 | -+ | ! |
- #' ggplot2_args = teal.widgets::ggplot2_args(+ checkmate::assert_string(label) |
| 51 | -+ | ! |
- #' labs = list(subtitle = "Plot generated by Variable Browser Module")+ checkmate::assert( |
| 52 | -+ | ! |
- #' ),+ checkmate::check_list(input_path, types = "character", min.len = 0), |
| 53 | -+ | ! |
- #' )+ checkmate::check_character(input_path, min.len = 1) |
| 54 |
- #' )+ ) |
||
| 55 |
- #' )+ |
||
| 56 | -+ | ! |
- #' if (interactive()) {
+ if (length(input_path) > 0) {
|
| 57 | -+ | ! |
- #' shinyApp(app$ui, app$server)+ valid_url <- function(url_input, timeout = 2) {
|
| 58 | -+ | ! |
- #' }+ con <- try(url(url_input), silent = TRUE) |
| 59 | -+ | ! |
- tm_variable_browser <- function(label = "Variable Browser",+ check <- suppressWarnings(try(open.connection(con, open = "rt", timeout = timeout), silent = TRUE)[1]) |
| 60 | -+ | ! |
- datasets_selected = character(0),+ try(close.connection(con), silent = TRUE) |
| 61 | -+ | ! |
- parent_dataname = "ADSL",+ ifelse(is.null(check), TRUE, FALSE) |
| 62 |
- pre_output = NULL,+ } |
||
| 63 | -+ | ! |
- post_output = NULL,+ idx <- vapply(input_path, function(x) file.exists(x) || valid_url(x), logical(1)) |
| 64 |
- ggplot2_args = teal.widgets::ggplot2_args()) {
+
|
||
| 65 | ! |
- logger::log_info("Initializing tm_variable_browser")
+ if (!all(idx)) {
|
|
| 66 | ! |
- if (!requireNamespace("sparkline", quietly = TRUE)) {
+ warning( |
|
| 67 | ! |
- stop("Cannot load sparkline - please install the package or restart your session.")
+ paste0( |
|
| 68 | -+ | ! |
- }+ "Non-existent file or url path. Please provide valid paths for:\n", |
| 69 | ! |
- if (!requireNamespace("htmlwidgets", quietly = TRUE)) {
+ paste0(input_path[!idx], collapse = "\n") |
|
| 70 | -! | +
- stop("Cannot load htmlwidgets - please install the package or restart your session.")
+ ) |
|
| 71 |
- }+ ) |
||
| 72 | -! | +
- if (!requireNamespace("jsonlite", quietly = TRUE)) {
+ } |
|
| 73 | ! |
- stop("Cannot load jsonlite - please install the package or restart your session.")
+ input_path <- input_path[idx] |
|
| 74 |
- }+ } else {
|
||
| 75 | ! |
- checkmate::assert_string(label)+ warning( |
|
| 76 | ! |
- checkmate::assert_character(datasets_selected)+ "No file or url paths were provided." |
|
| 77 | -! | +
- checkmate::assert_character(parent_dataname, min.len = 0, max.len = 1)+ ) |
|
| 78 | -! | +
- checkmate::assert_class(ggplot2_args, "ggplot2_args")+ } |
|
| 79 | -! | +
- datasets_selected <- unique(datasets_selected)+ |
|
| 81 | ! |
- module(+ args <- as.list(environment()) |
|
| 82 | -! | +
- label,+ |
|
| 83 | ! |
- server = srv_variable_browser,+ module( |
|
| 84 | ! |
- ui = ui_variable_browser,+ label = label, |
|
| 85 | ! |
- datanames = "all",+ server = srv_viewer, |
|
| 86 | ! |
- server_args = list(+ server_args = list(input_path = input_path), |
|
| 87 | ! |
- datasets_selected = datasets_selected,+ ui = ui_viewer, |
|
| 88 | ! |
- parent_dataname = parent_dataname,+ ui_args = args, |
|
| 89 | ! |
- ggplot2_args = ggplot2_args+ datanames = NULL |
|
| 90 |
- ),+ ) |
||
| 91 | -! | +
- ui_args = list(+ } |
|
| 92 | -! | +
- pre_output = pre_output,+ |
|
| 93 | -! | +
- post_output = post_output+ ui_viewer <- function(id, ...) {
|
|
| 94 | -+ | ! |
- )+ args <- list(...) |
| 95 | -+ | ! |
- )+ ns <- NS(id) |
| 96 |
- }+ |
||
| 97 | -+ | ! |
-
+ shiny::tagList( |
| 98 | -+ | ! |
- # ui function+ include_css_files("custom"),
|
| 99 | -+ | ! |
- ui_variable_browser <- function(id,+ teal.widgets::standard_layout( |
| 100 | -+ | ! |
- pre_output = NULL,+ output = div( |
| 101 | -+ | ! |
- post_output = NULL) {
+ uiOutput(ns("output"))
|
| 102 | -! | +
- ns <- NS(id)+ ), |
|
| 103 | -+ | ! |
-
+ encoding = div( |
| 104 | ! |
- shiny::tagList(+ class = "file_viewer_encoding", |
|
| 105 | ! |
- include_css_files("custom"),
+ tags$label("Encodings", class = "text-primary"),
|
|
| 106 | ! |
- shinyjs::useShinyjs(),+ shinyTree::shinyTree( |
|
| 107 | ! |
- teal.widgets::standard_layout(+ ns("tree"),
|
|
| 108 | ! |
- output = fluidRow(+ dragAndDrop = FALSE, |
|
| 109 | ! |
- htmlwidgets::getDependency("sparkline"), # needed for sparklines to work
+ sort = FALSE, |
|
| 110 | ! |
- column(+ wholerow = TRUE, |
|
| 111 | ! |
- 6,+ theme = "proton", |
|
| 112 | -+ | ! |
- # variable browser+ multiple = FALSE |
| 113 | -! | +
- teal.widgets::white_small_well(+ ) |
|
| 114 | -! | +
- uiOutput(ns("ui_variable_browser")),
+ ) |
|
| 115 | -! | +
- shinyjs::hidden({
+ ) |
|
| 116 | -! | +
- checkboxInput(ns("show_parent_vars"), "Show parent dataset variables", value = FALSE)
+ ) |
|
| 117 |
- })+ } |
||
| 118 |
- )+ |
||
| 119 |
- ),+ srv_viewer <- function(id, input_path) {
|
||
| 120 | ! |
- column(+ moduleServer(id, function(input, output, session) {
|
|
| 121 | ! |
- 6,+ temp_dir <- tempfile() |
|
| 122 | ! |
- teal.widgets::white_small_well(+ if (!dir.exists(temp_dir)) {
|
|
| 123 | -+ | ! |
- ### Reporter+ dir.create(temp_dir, recursive = TRUE) |
| 124 | -! | +
- teal.reporter::simple_reporter_ui(ns("simple_reporter")),
+ } |
|
| 125 | -+ | ! |
- ###+ addResourcePath(basename(temp_dir), temp_dir) |
| 126 | -! | +
- div(+ |
|
| 127 | ! |
- class = "block",+ test_path_text <- function(selected_path, type) {
|
|
| 128 | ! |
- uiOutput(ns("ui_histogram_display"))
+ out <- tryCatch( |
|
| 129 | -+ | ! |
- ),+ expr = {
|
| 130 | ! |
- div(+ if (type != "url") {
|
|
| 131 | ! |
- class = "block",+ selected_path <- normalizePath(selected_path, winslash = "/") |
|
| 132 | -! | +
- uiOutput(ns("ui_numeric_display"))
+ } |
|
| 133 | -+ | ! |
- ),+ readLines(con = selected_path) |
| 134 | -! | +
- teal.widgets::plot_with_settings_ui(ns("variable_plot")),
+ }, |
|
| 135 | ! |
- br(),+ error = function(cond) FALSE, |
|
| 136 | -+ | ! |
- # input user-defined text size+ warning = function(cond) {
|
| 137 | ! |
- teal.widgets::panel_item(+ `if`(grepl("^incomplete final line found on", cond[[1]]), suppressWarnings(eval(cond[[2]])), FALSE)
|
|
| 138 | -! | +
- title = "Plot settings",+ } |
|
| 139 | -! | +
- collapsed = TRUE,+ ) |
|
| 140 | -! | +
- selectInput(+ } |
|
| 141 | -! | +
- inputId = ns("ggplot_theme"), label = "ggplot2 theme",
+
|
|
| 142 | ! |
- choices = ggplot_themes,+ handle_connection_type <- function(selected_path) {
|
|
| 143 | ! |
- selected = "grey"+ file_extension <- tools::file_ext(selected_path) |
|
| 144 | -+ | ! |
- ),+ file_class <- suppressWarnings(file(selected_path)) |
| 145 | ! |
- fluidRow(+ close(file_class) |
|
| 146 | -! | +
- column(6, sliderInput(+ |
|
| 147 | ! |
- inputId = ns("font_size"), label = "font size",
+ output_text <- test_path_text(selected_path, type = class(file_class)[1]) |
|
| 148 | -! | +
- min = 5L, max = 30L, value = 15L, step = 1L, ticks = FALSE+ |
|
| 149 | -+ | ! |
- )),+ if (class(file_class)[1] == "url") {
|
| 150 | ! |
- column(6, sliderInput(+ list(selected_path = selected_path, output_text = output_text) |
|
| 151 | -! | +
- inputId = ns("label_rotation"), label = "rotate x labels",
+ } else {
|
|
| 152 | ! |
- min = 0L, max = 90L, value = 45L, step = 1, ticks = FALSE+ file.copy(normalizePath(selected_path, winslash = "/"), temp_dir) |
|
| 153 | -+ | ! |
- ))+ selected_path <- file.path(basename(temp_dir), basename(selected_path)) |
| 154 | -+ | ! |
- )+ list(selected_path = selected_path, output_text = output_text) |
| 155 |
- ),+ } |
||
| 156 | -! | +
- br(),+ } |
|
| 157 | -! | +
- teal.widgets::get_dt_rows(ns("variable_summary_table"), ns("variable_summary_table_rows")),
+
|
|
| 158 | ! |
- DT::dataTableOutput(ns("variable_summary_table"))
+ display_file <- function(selected_path) {
|
|
| 159 | -+ | ! |
- )+ con_type <- handle_connection_type(selected_path) |
| 160 | -+ | ! |
- )+ file_extension <- tools::file_ext(selected_path) |
| 161 | -+ | ! |
- ),+ if (file_extension %in% c("png", "apng", "jpg", "jpeg", "svg", "gif", "webp", "bmp")) {
|
| 162 | ! |
- pre_output = pre_output,+ tags$img(src = con_type$selected_path, alt = "file does not exist") |
|
| 163 | ! |
- post_output = post_output+ } else if (file_extension == "pdf") {
|
|
| 164 | -+ | ! |
- )+ tags$embed( |
| 165 | -+ | ! |
- )+ class = "embed_pdf", |
| 166 | -+ | ! |
- }+ src = con_type$selected_path |
| 167 |
-
+ ) |
||
| 168 | -+ | ! |
- srv_variable_browser <- function(id,+ } else if (!isFALSE(con_type$output_text[1])) {
|
| 169 | -+ | ! |
- data,+ tags$pre(paste0(con_type$output_text, collapse = "\n")) |
| 170 |
- reporter,+ } else {
|
||
| 171 | -+ | ! |
- filter_panel_api,+ tags$p("Please select a supported format.")
|
| 172 |
- datasets_selected, parent_dataname, ggplot2_args) {
+ } |
||
| 173 | -! | +
- with_reporter <- !missing(reporter) && inherits(reporter, "Reporter")+ } |
|
| 174 | -! | +
- with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI")+ |
|
| 175 | ! |
- checkmate::assert_class(data, "reactive")+ tree_list <- function(file_or_dir) {
|
|
| 176 | ! |
- checkmate::assert_class(isolate(data()), "teal_data")+ nested_list <- lapply(file_or_dir, function(path) {
|
|
| 177 | ! |
- moduleServer(id, function(input, output, session) {
+ file_class <- suppressWarnings(file(path)) |
|
| 178 | -+ | ! |
- # if there are < this number of unique records then a numeric+ close(file_class) |
| 179 | -+ | ! |
- # variable can be treated as a factor and all factors with < this groups+ if (class(file_class)[[1]] != "url") {
|
| 180 | -+ | ! |
- # have their values plotted+ isdir <- file.info(path)$isdir |
| 181 | ! |
- .unique_records_for_factor <- 30+ if (!isdir) {
|
|
| 182 | -+ | ! |
- # if there are < this number of unique records then a numeric+ structure(path, ancestry = path, sticon = "file") |
| 183 |
- # variable is by default treated as a factor+ } else {
|
||
| 184 | ! |
- .unique_records_default_as_factor <- 6 # nolint object_length_linter+ files <- list.files(path, full.names = TRUE, include.dirs = TRUE) |
|
| 185 | -+ | ! |
-
+ out <- lapply(files, function(x) tree_list(x)) |
| 186 | ! |
- datanames <- isolate(teal.data::datanames(data()))+ out <- unlist(out, recursive = FALSE) |
|
| 187 | ! |
- datanames <- Filter(function(name) {
+ if (length(files) > 0) names(out) <- basename(files) |
|
| 188 | ! |
- is.data.frame(isolate(data())[[name]])+ out |
|
| 189 | -! | +
- }, datanames)+ } |
|
| 190 |
-
+ } else {
|
||
| 191 | ! |
- checkmate::assert_character(datasets_selected)+ structure(path, ancestry = path, sticon = "file") |
|
| 192 | -! | +
- checkmate::assert_subset(datasets_selected, datanames)+ } |
|
| 193 | -! | +
- if (!identical(datasets_selected, character(0))) {
+ }) |
|
| 194 | -! | +
- checkmate::assert_subset(datasets_selected, datanames)+ |
|
| 195 | ! |
- datanames <- datasets_selected+ 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 | -! | +
- output$ui_variable_browser <- renderUI({
+ } |
|
| 199 | -! | +
- ns <- session$ns+ |
|
| 200 | ! |
- do.call(+ output$tree <- shinyTree::renderTree({
|
|
| 201 | ! |
- tabsetPanel,+ if (length(input_path) > 0) {
|
|
| 202 | ! |
- c(+ tree_list(input_path) |
|
| 203 | -! | +
- id = ns("tabset_panel"),
+ } else {
|
|
| 204 | ! |
- do.call(+ list("Empty Path" = NULL)
|
|
| 205 | -! | +
- tagList,+ } |
|
| 206 | -! | +
- lapply(datanames, function(dataname) {
+ }) |
|
| 207 | -! | +
- tabPanel(+ |
|
| 208 | ! |
- dataname,+ output$output <- renderUI({
|
|
| 209 | ! |
- div(+ validate( |
|
| 210 | ! |
- class = "mt-4",+ need( |
|
| 211 | ! |
- textOutput(ns(paste0("dataset_summary_", dataname)))
+ length(shinyTree::get_selected(input$tree)) > 0, |
|
| 212 | -+ | ! |
- ),+ "Please select a file." |
| 213 | -! | +
- div(+ ) |
|
| 214 | -! | +
- class = "mt-4",+ ) |
|
| 215 | -! | +
- teal.widgets::get_dt_rows(+ |
|
| 216 | ! |
- ns(paste0("variable_browser_", dataname)),
+ obj <- shinyTree::get_selected(input$tree, format = "names")[[1]] |
|
| 217 | ! |
- ns(paste0("variable_browser_", dataname, "_rows"))
+ repo <- attr(obj, "ancestry") |
|
| 218 | -+ | ! |
- ),+ repo_collapsed <- if (length(repo) > 1) paste0(repo, collapse = "/") else repo |
| 219 | ! |
- DT::dataTableOutput(ns(paste0("variable_browser_", dataname)), width = "100%")
+ is_not_named <- file.exists(file.path(c(repo_collapsed, obj[1])))[1] |
|
| 220 |
- )+ |
||
| 221 | -+ | ! |
- )+ if (is_not_named) {
|
| 222 | -+ | ! |
- })+ selected_path <- do.call("file.path", as.list(c(repo, obj[1])))
|
| 223 |
- )+ } else {
|
||
| 224 | -+ | ! |
- )+ if (length(repo) == 0) {
|
| 225 | -+ | ! |
- )+ selected_path <- do.call("file.path", as.list(attr(input$tree[[obj[1]]], "ancestry")))
|
| 226 |
- })+ } else {
|
||
| 227 | -+ | ! |
-
+ selected_path <- do.call("file.path", as.list(attr(input$tree[[repo]][[obj[1]]], "ancestry")))
|
| 228 |
- # conditionally display checkbox+ } |
||
| 229 | -! | +
- shinyjs::toggle(+ } |
|
| 230 | -! | +
- id = "show_parent_vars",+ |
|
| 231 | ! |
- condition = length(parent_dataname) > 0 && parent_dataname %in% datanames+ validate( |
|
| 232 | -+ | ! |
- )+ need( |
| 233 | -+ | ! |
-
+ !isTRUE(file.info(selected_path)$isdir) && length(selected_path) > 0, |
| 234 | ! |
- columns_names <- new.env()+ "Please select a single file." |
|
| 235 |
-
+ ) |
||
| 236 |
- # plot_var$data holds the name of the currently selected dataset+ ) |
||
| 237 | -+ | ! |
- # plot_var$variable[[<dataset_name>]] holds the name of the currently selected+ display_file(selected_path) |
| 238 |
- # variable for dataset <dataset_name>+ }) |
||
| 239 | -! | +
- plot_var <- reactiveValues(data = NULL, variable = list())+ |
|
| 240 | -+ | ! |
-
+ onStop(function() {
|
| 241 | ! |
- establish_updating_selection(datanames, input, plot_var, columns_names)+ removeResourcePath(basename(temp_dir)) |
|
| 242 | -+ | ! |
-
+ unlink(temp_dir) |
| 243 |
- # validations+ }) |
||
| 244 | -! | +
- validation_checks <- validate_input(input, plot_var, data)+ }) |
|
| 245 |
-
+ } |
| 246 | +1 |
- # data_for_analysis is a list with two elements: a column from a dataset and the column label+ #' Variable Browser Teal Module |
|
| 247 | -! | +||
| 2 | +
- plotted_data <- reactive({
+ #' |
||
| 248 | -! | +||
| 3 | +
- validation_checks()+ #' The variable browser provides a table with variable names and labels and a |
||
| 249 | +4 |
-
+ #' plot that visualizes the content of a particular variable. |
|
| 250 | -! | +||
| 5 | +
- get_plotted_data(input, plot_var, data)+ #' specifically designed for use with `data.frames`. |
||
| 251 | +6 |
- })+ #' |
|
| 252 | +7 |
-
+ #' @details Numeric columns with fewer than 30 distinct values can be treated as either factors |
|
| 253 | -! | +||
| 8 | +
- treat_numeric_as_factor <- reactive({
+ #' or numbers with a checkbox allowing users to switch how they are treated (if < 6 unique values |
||
| 254 | -! | +||
| 9 | +
- if (is_num_var_short(.unique_records_for_factor, input, plotted_data)) {
+ #' then the default is categorical, otherwise it is numeric). |
||
| 255 | -! | +||
| 10 | +
- input$numeric_as_factor+ #' |
||
| 256 | +11 |
- } else {
+ #' @inheritParams teal::module |
|
| 257 | -! | +||
| 12 | +
- FALSE+ #' @inheritParams shared_params |
||
| 258 | +13 |
- }+ #' @param parent_dataname (`character(1)`) If this `dataname` exists in `datasets_selected` |
|
| 259 | +14 |
- })+ #' then an extra checkbox will be shown to allow users to not show variables in other datasets |
|
| 260 | +15 |
-
+ #' which exist in this `dataname`. |
|
| 261 | -! | +||
| 16 | +
- render_tabset_panel_content(+ #' This is typically used to remove `ADSL` columns in `CDISC` data. In non `CDISC` data this |
||
| 262 | -! | -
- input = input,- |
- |
| 263 | -! | -
- output = output,- |
- |
| 264 | -! | +||
| 17 | +
- data = data,+ #' can be ignored. Defaults to `"ADSL"`. |
||
| 265 | -! | +||
| 18 | +
- datanames = datanames,+ #' @param datasets_selected (`character`) A vector of datasets which should be |
||
| 266 | -! | +||
| 19 | +
- parent_dataname = parent_dataname,+ #' shown and in what order. Names in the vector have to correspond with datasets names. |
||
| 267 | -! | +||
| 20 | +
- columns_names = columns_names,+ #' If vector of length zero (default) then all datasets are shown. |
||
| 268 | -! | +||
| 21 | +
- plot_var = plot_var+ #' Note: Only datasets of the `data.frame` class are compatible; using other types will cause an error. |
||
| 269 | +22 |
- )+ #' |
|
| 270 | +23 |
- # add used-defined text size to ggplot arguments passed from caller frame+ #' @aliases |
|
| 271 | -! | +||
| 24 | +
- all_ggplot2_args <- reactive({
+ #' tm_variable_browser_ui, |
||
| 272 | -! | +||
| 25 | +
- user_text <- teal.widgets::ggplot2_args(+ #' tm_variable_browser_srv, |
||
| 273 | -! | +||
| 26 | +
- theme = list(+ #' tm_variable_browser, |
||
| 274 | -! | +||
| 27 | +
- "text" = ggplot2::element_text(size = input[["font_size"]]),+ #' variable_browser_ui, |
||
| 275 | -! | +||
| 28 | +
- "axis.text.x" = ggplot2::element_text(angle = input[["label_rotation"]], hjust = 1)+ #' variable_browser_srv, |
||
| 276 | +29 |
- )+ #' variable_browser |
|
| 277 | +30 |
- )+ #' |
|
| 278 | -! | +||
| 31 | +
- user_theme <- utils::getFromNamespace(sprintf("theme_%s", input[["ggplot_theme"]]), ns = "ggplot2")
+ #' |
||
| 279 | -! | +||
| 32 | +
- user_theme <- user_theme()+ #' @export |
||
| 280 | +33 |
- # temporary fix to circumvent assertion issue with resolve_ggplot2_args+ #' |
|
| 281 | +34 |
- # drop problematic elements+ #' @examples |
|
| 282 | -! | +||
| 35 | +
- user_theme <- user_theme[grep("strip.text.y.left", names(user_theme), fixed = TRUE, invert = TRUE)]
+ #' |
||
| 283 | +36 |
-
+ #' data <- teal_data() |
|
| 284 | -! | +||
| 37 | +
- teal.widgets::resolve_ggplot2_args(+ #' data <- within(data, {
|
||
| 285 | -! | +||
| 38 | +
- user_plot = user_text,+ #' ADSL <- teal.modules.general::rADSL |
||
| 286 | -! | +||
| 39 | +
- user_default = teal.widgets::ggplot2_args(theme = user_theme),+ #' ADTTE <- teal.modules.general::rADTTE |
||
| 287 | -! | +||
| 40 | +
- module_plot = ggplot2_args+ #' }) |
||
| 288 | +41 |
- )+ #' datanames <- c("ADSL", "ADTTE")
|
|
| 289 | +42 |
- })+ #' datanames(data) <- datanames |
|
| 290 | +43 |
-
+ #' join_keys(data) <- default_cdisc_join_keys[datanames] |
|
| 291 | -! | +||
| 44 | +
- output$ui_numeric_display <- renderUI({
+ #' |
||
| 292 | -! | +||
| 45 | +
- validation_checks()+ #' app <- teal::init( |
||
| 293 | -! | +||
| 46 | +
- dataname <- input$tabset_panel+ #' data = data, |
||
| 294 | -! | +||
| 47 | +
- varname <- plot_var$variable[[dataname]]+ #' modules( |
||
| 295 | -! | +||
| 48 | +
- df <- data()[[dataname]]+ #' teal.modules.general::tm_variable_browser( |
||
| 296 | +49 |
-
+ #' label = "Variable browser", |
|
| 297 | -! | +||
| 50 | +
- numeric_ui <- tagList(+ #' ggplot2_args = teal.widgets::ggplot2_args( |
||
| 298 | -! | +||
| 51 | +
- fluidRow(+ #' labs = list(subtitle = "Plot generated by Variable Browser Module") |
||
| 299 | -! | +||
| 52 | +
- div(+ #' ), |
||
| 300 | -! | +||
| 53 | +
- class = "col-md-4",+ #' ) |
||
| 301 | -! | +||
| 54 | +
- br(),+ #' ) |
||
| 302 | -! | +||
| 55 | +
- shinyWidgets::switchInput(+ #' ) |
||
| 303 | -! | +||
| 56 | +
- inputId = session$ns("display_density"),
+ #' if (interactive()) {
|
||
| 304 | -! | +||
| 57 | +
- label = "Show density",+ #' shinyApp(app$ui, app$server) |
||
| 305 | -! | +||
| 58 | +
- value = `if`(is.null(isolate(input$display_density)), TRUE, isolate(input$display_density)),+ #' } |
||
| 306 | -! | +||
| 59 | +
- width = "50%",+ tm_variable_browser <- function(label = "Variable Browser", |
||
| 307 | -! | +||
| 60 | +
- labelWidth = "100px",+ datasets_selected = character(0), |
||
| 308 | -! | +||
| 61 | +
- handleWidth = "50px"+ parent_dataname = "ADSL", |
||
| 309 | +62 |
- )+ pre_output = NULL, |
|
| 310 | +63 |
- ),+ post_output = NULL, |
|
| 311 | -! | +||
| 64 | +
- div(+ ggplot2_args = teal.widgets::ggplot2_args()) {
|
||
| 312 | +65 | ! |
- class = "col-md-4",+ logger::log_info("Initializing tm_variable_browser")
|
| 313 | +66 | ! |
- br(),+ if (!requireNamespace("sparkline", quietly = TRUE)) {
|
| 314 | +67 | ! |
- shinyWidgets::switchInput(+ stop("Cannot load sparkline - please install the package or restart your session.")
|
| 315 | -! | +||
| 68 | +
- inputId = session$ns("remove_outliers"),
+ } |
||
| 316 | +69 | ! |
- label = "Remove outliers",+ if (!requireNamespace("htmlwidgets", quietly = TRUE)) {
|
| 317 | +70 | ! |
- value = `if`(is.null(isolate(input$remove_outliers)), FALSE, isolate(input$remove_outliers)),+ stop("Cannot load htmlwidgets - please install the package or restart your session.")
|
| 318 | -! | +||
| 71 | +
- width = "50%",+ } |
||
| 319 | +72 | ! |
- labelWidth = "100px",+ if (!requireNamespace("jsonlite", quietly = TRUE)) {
|
| 320 | +73 | ! |
- handleWidth = "50px"+ stop("Cannot load jsonlite - please install the package or restart your session.")
|
| 321 | +74 |
- )+ } |
|
| 322 | -+ | ||
| 75 | +! |
- ),+ checkmate::assert_string(label) |
|
| 323 | +76 | ! |
- div(+ checkmate::assert_character(datasets_selected) |
| 324 | +77 | ! |
- class = "col-md-4",+ checkmate::assert_character(parent_dataname, min.len = 0, max.len = 1) |
| 325 | +78 | ! |
- uiOutput(session$ns("outlier_definition_slider_ui"))
+ checkmate::assert_class(ggplot2_args, "ggplot2_args") |
| 326 | -+ | ||
| 79 | +! |
- )+ datasets_selected <- unique(datasets_selected) |
|
| 327 | +80 |
- ),+ |
|
| 328 | +81 | ! |
- div(+ module( |
| 329 | +82 | ! |
- class = "ml-4",+ label, |
| 330 | +83 | ! |
- uiOutput(session$ns("ui_density_help")),
+ server = srv_variable_browser, |
| 331 | +84 | ! |
- uiOutput(session$ns("ui_outlier_help"))
- |
-
| 332 | -- |
- )- |
- |
| 333 | -- |
- )- |
- |
| 334 | -- |
-
+ ui = ui_variable_browser, |
|
| 335 | +85 | ! |
- if (is.numeric(df[[varname]])) {
+ datanames = "all", |
| 336 | +86 | ! |
- unique_entries <- length(unique(df[[varname]]))+ server_args = list( |
| 337 | +87 | ! |
- if (unique_entries < .unique_records_for_factor && unique_entries > 0) {
+ datasets_selected = datasets_selected, |
| 338 | +88 | ! |
- list(+ parent_dataname = parent_dataname, |
| 339 | +89 | ! |
- checkboxInput(+ ggplot2_args = ggplot2_args |
| 340 | -! | +||
| 90 | +
- session$ns("numeric_as_factor"),
+ ), |
||
| 341 | +91 | ! |
- "Treat variable as factor",+ ui_args = list( |
| 342 | +92 | ! |
- value = `if`(+ pre_output = pre_output, |
| 343 | +93 | ! |
- is.null(isolate(input$numeric_as_factor)),+ post_output = post_output |
| 344 | -! | +||
| 94 | +
- unique_entries < .unique_records_default_as_factor,- |
- ||
| 345 | -! | -
- isolate(input$numeric_as_factor)- |
- |
| 346 | -- |
- )+ ) |
|
| 347 | +95 |
- ),- |
- |
| 348 | -! | -
- conditionalPanel("!input.numeric_as_factor", ns = session$ns, numeric_ui)
+ ) |
|
| 349 | +96 |
- )- |
- |
| 350 | -! | -
- } else if (unique_entries > 0) {
- |
- |
| 351 | -! | -
- numeric_ui+ } |
|
| 352 | +97 |
- }+ |
|
| 353 | +98 |
- } else {
- |
- |
| 354 | -! | -
- NULL+ # ui function |
|
| 355 | +99 |
- }+ ui_variable_browser <- function(id, |
|
| 356 | +100 |
- })+ pre_output = NULL, |
|
| 357 | +101 |
-
+ post_output = NULL) {
|
|
| 358 | +102 | ! |
- output$ui_histogram_display <- renderUI({
+ ns <- NS(id) |
| 359 | -! | +||
| 103 | +
- validation_checks()+ |
||
| 360 | +104 | ! |
- dataname <- input$tabset_panel+ shiny::tagList( |
| 361 | +105 | ! |
- varname <- plot_var$variable[[dataname]]+ include_css_files("custom"),
|
| 362 | +106 | ! |
- df <- data()[[dataname]]- |
-
| 363 | -- |
-
+ shinyjs::useShinyjs(), |
|
| 364 | +107 | ! |
- numeric_ui <- tagList(fluidRow(+ teal.widgets::standard_layout( |
| 365 | +108 | ! |
- div(+ output = fluidRow( |
| 366 | +109 | ! |
- class = "col-md-4",+ htmlwidgets::getDependency("sparkline"), # needed for sparklines to work
|
| 367 | +110 | ! |
- shinyWidgets::switchInput(+ column( |
| 368 | +111 | ! |
- inputId = session$ns("remove_NA_hist"),
+ 6, |
| 369 | -! | +||
| 112 | +
- label = "Remove NA values",+ # variable browser |
||
| 370 | +113 | ! |
- value = FALSE,+ teal.widgets::white_small_well( |
| 371 | +114 | ! |
- width = "50%",+ uiOutput(ns("ui_variable_browser")),
|
| 372 | +115 | ! |
- labelWidth = "100px",+ shinyjs::hidden({
|
| 373 | +116 | ! |
- handleWidth = "50px"+ checkboxInput(ns("show_parent_vars"), "Show parent dataset variables", value = FALSE)
|
| 374 | +117 |
- )+ }) |
|
| 375 | +118 |
- )+ ) |
|
| 376 | +119 |
- ))+ ), |
|
| 377 | -+ | ||
| 120 | +! |
-
+ column( |
|
| 378 | +121 | ! |
- var <- df[[varname]]+ 6, |
| 379 | +122 | ! |
- if (anyNA(var) && (is.factor(var) || is.character(var) || is.logical(var))) {
+ teal.widgets::white_small_well(+ |
+
| 123 | ++ |
+ ### Reporter |
|
| 380 | +124 | ! |
- groups <- unique(as.character(var))+ teal.reporter::simple_reporter_ui(ns("simple_reporter")),
+ |
+
| 125 | ++ |
+ ### |
|
| 381 | +126 | ! |
- len_groups <- length(groups)+ div( |
| 382 | +127 | ! |
- if (len_groups >= .unique_records_for_factor) {
+ class = "block", |
| 383 | +128 | ! |
- NULL+ uiOutput(ns("ui_histogram_display"))
|
| 384 | +129 |
- } else {
+ ), |
|
| 385 | +130 | ! |
- numeric_ui+ div( |
| 386 | -+ | ||
| 131 | +! |
- }+ class = "block",+ |
+ |
| 132 | +! | +
+ uiOutput(ns("ui_numeric_display"))
|
|
| 387 | +133 |
- } else {
+ ), |
|
| 388 | +134 | ! |
- NULL+ teal.widgets::plot_with_settings_ui(ns("variable_plot")),
|
| 389 | -+ | ||
| 135 | +! |
- }+ br(), |
|
| 390 | +136 |
- })+ # input user-defined text size |
|
| 391 | -+ | ||
| 137 | +! |
-
+ teal.widgets::panel_item( |
|
| 392 | +138 | ! |
- output$outlier_definition_slider_ui <- renderUI({
+ title = "Plot settings", |
| 393 | +139 | ! |
- req(input$remove_outliers)+ collapsed = TRUE, |
| 394 | +140 | ! |
- sliderInput(+ selectInput( |
| 395 | +141 | ! |
- inputId = session$ns("outlier_definition_slider"),
+ inputId = ns("ggplot_theme"), label = "ggplot2 theme",
|
| 396 | +142 | ! |
- div(+ choices = ggplot_themes, |
| 397 | +143 | ! |
- class = "teal-tooltip",+ selected = "grey" |
| 398 | -! | +||
| 144 | +
- tagList(+ ), |
||
| 399 | +145 | ! |
- "Outlier definition:",+ fluidRow( |
| 400 | +146 | ! |
- icon("circle-info"),
+ column(6, sliderInput( |
| 401 | +147 | ! |
- span(+ inputId = ns("font_size"), label = "font size",
|
| 402 | +148 | ! |
- class = "tooltiptext",+ min = 5L, max = 30L, value = 15L, step = 1L, ticks = FALSE |
| 403 | -! | +||
| 149 | +
- paste(+ )), |
||
| 404 | +150 | ! |
- "Use the slider to choose the cut-off value to define outliers; the larger the value the",+ column(6, sliderInput( |
| 405 | +151 | ! |
- "further below Q1/above Q3 points have to be in order to be classed as outliers"+ inputId = ns("label_rotation"), label = "rotate x labels",
|
| 406 | -+ | ||
| 152 | +! |
- )+ min = 0L, max = 90L, value = 45L, step = 1, ticks = FALSE |
|
| 407 | +153 |
- )+ )) |
|
| 408 | +154 |
- )+ ) |
|
| 409 | +155 |
- ),- |
- |
| 410 | -! | -
- min = 1,+ ), |
|
| 411 | +156 | ! |
- max = 5,+ br(), |
| 412 | +157 | ! |
- value = 3,+ teal.widgets::get_dt_rows(ns("variable_summary_table"), ns("variable_summary_table_rows")),
|
| 413 | +158 | ! |
- step = 0.5+ DT::dataTableOutput(ns("variable_summary_table"))
|
| 414 | +159 |
- )+ ) |
|
| 415 | +160 |
- })+ ) |
|
| 416 | +161 | - - | -|
| 417 | -! | -
- output$ui_density_help <- renderUI({
- |
- |
| 418 | -! | -
- req(is.logical(input$display_density))+ ), |
|
| 419 | +162 | ! |
- if (input$display_density) {
+ pre_output = pre_output, |
| 420 | +163 | ! |
- tags$small(helpText(paste(+ post_output = post_output |
| 421 | -! | +||
| 164 | +
- "Kernel density estimation with gaussian kernel",+ ) |
||
| 422 | -! | +||
| 165 | +
- "and bandwidth function bw.nrd0 (R default)"+ ) |
||
| 423 | +166 |
- )))+ } |
|
| 424 | +167 |
- } else {
+
|
|
| 425 | -! | +||
| 168 | +
- NULL+ srv_variable_browser <- function(id, |
||
| 426 | +169 |
- }+ data, |
|
| 427 | +170 |
- })+ reporter, |
|
| 428 | +171 |
-
+ filter_panel_api, |
|
| 429 | -! | +||
| 172 | +
- output$ui_outlier_help <- renderUI({
+ datasets_selected, parent_dataname, ggplot2_args) {
|
||
| 430 | +173 | ! |
- req(is.logical(input$remove_outliers), input$outlier_definition_slider)+ with_reporter <- !missing(reporter) && inherits(reporter, "Reporter") |
| 431 | +174 | ! |
- if (input$remove_outliers) {
+ with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI") |
| 432 | +175 | ! |
- tags$small(+ checkmate::assert_class(data, "reactive") |
| 433 | +176 | ! |
- helpText(+ checkmate::assert_class(isolate(data()), "teal_data") |
| 434 | +177 | ! |
- withMathJax(paste0(+ moduleServer(id, function(input, output, session) {
|
| 435 | -! | +||
| 178 | +
- "Outlier data points (\\( X \\lt Q1 - ", input$outlier_definition_slider, "\\times IQR \\) or+ # if there are < this number of unique records then a numeric |
||
| 436 | -! | +||
| 179 | +
- \\(Q3 + ", input$outlier_definition_slider, "\\times IQR \\lt X\\))+ # variable can be treated as a factor and all factors with < this groups |
||
| 437 | -! | +||
| 180 | +
- have not been displayed on the graph and will not be used for any kernel density estimations, ",+ # have their values plotted |
||
| 438 | +181 | ! |
- "although their values remain in the statisics table below."+ .unique_records_for_factor <- 30 |
| 439 | +182 |
- ))+ # if there are < this number of unique records then a numeric |
|
| 440 | +183 |
- )+ # variable is by default treated as a factor |
|
| 441 | -+ | ||
| 184 | +! |
- )+ .unique_records_default_as_factor <- 6 # nolint: object_length. |
|
| 442 | +185 |
- } else {
+
|
|
| 443 | +186 | ! |
- NULL- |
-
| 444 | -- |
- }- |
- |
| 445 | -- |
- })- |
- |
| 446 | -- | - - | -|
| 447 | -- |
-
+ datanames <- isolate(teal.data::datanames(data())) |
|
| 448 | +187 | ! |
- variable_plot_r <- reactive({
+ datanames <- Filter(function(name) {
|
| 449 | +188 | ! |
- display_density <- `if`(is.null(input$display_density), FALSE, input$display_density)+ is.data.frame(isolate(data())[[name]]) |
| 450 | +189 | ! |
- remove_outliers <- `if`(is.null(input$remove_outliers), FALSE, input$remove_outliers)+ }, datanames) |
| 451 | +190 | ||
| 452 | +191 | ! |
- if (remove_outliers) {
+ checkmate::assert_character(datasets_selected) |
| 453 | +192 | ! |
- req(input$outlier_definition_slider)+ checkmate::assert_subset(datasets_selected, datanames) |
| 454 | +193 | ! |
- outlier_definition <- as.numeric(input$outlier_definition_slider)+ if (!identical(datasets_selected, character(0))) {
|
| 455 | -+ | ||
| 194 | +! |
- } else {
+ checkmate::assert_subset(datasets_selected, datanames) |
|
| 456 | +195 | ! |
- outlier_definition <- 0+ datanames <- datasets_selected |
| 457 | +196 |
- }+ } |
|
| 458 | +197 | ||
| 459 | +198 | ! |
- plot_var_summary(+ output$ui_variable_browser <- renderUI({
|
| 460 | +199 | ! |
- var = plotted_data()$data,+ ns <- session$ns |
| 461 | +200 | ! |
- var_lab = plotted_data()$var_description,+ do.call( |
| 462 | +201 | ! |
- wrap_character = 15,+ tabsetPanel, |
| 463 | +202 | ! |
- numeric_as_factor = treat_numeric_as_factor(),+ c( |
| 464 | +203 | ! |
- remove_NA_hist = input$remove_NA_hist,+ id = ns("tabset_panel"),
|
| 465 | +204 | ! |
- display_density = display_density,+ do.call( |
| 466 | +205 | ! |
- outlier_definition = outlier_definition,+ tagList, |
| 467 | +206 | ! |
- records_for_factor = .unique_records_for_factor,+ lapply(datanames, function(dataname) {
|
| 468 | +207 | ! |
- ggplot2_args = all_ggplot2_args()- |
-
| 469 | -- |
- )- |
- |
| 470 | -- |
- })- |
- |
| 471 | -- |
-
+ tabPanel( |
|
| 472 | +208 | ! |
- pws <- teal.widgets::plot_with_settings_srv(+ dataname, |
| 473 | +209 | ! |
- id = "variable_plot",+ div( |
| 474 | +210 | ! |
- plot_r = variable_plot_r,+ class = "mt-4", |
| 475 | +211 | ! |
- height = c(500, 200, 2000)+ textOutput(ns(paste0("dataset_summary_", dataname)))
|
| 476 | +212 |
- )+ ), |
|
| 477 | -+ | ||
| 213 | +! |
-
+ div( |
|
| 478 | +214 | ! |
- output$variable_summary_table <- DT::renderDataTable({
+ class = "mt-4", |
| 479 | +215 | ! |
- var_summary_table(+ teal.widgets::get_dt_rows( |
| 480 | +216 | ! |
- plotted_data()$data,+ ns(paste0("variable_browser_", dataname)),
|
| 481 | +217 | ! |
- treat_numeric_as_factor(),+ ns(paste0("variable_browser_", dataname, "_rows"))
|
| 482 | -! | +||
| 218 | +
- input$variable_summary_table_rows,+ ), |
||
| 483 | +219 | ! |
- if (!is.null(input$remove_outliers) && input$remove_outliers) {
+ DT::dataTableOutput(ns(paste0("variable_browser_", dataname)), width = "100%")
|
| 484 | -! | +||
| 220 | +
- req(input$outlier_definition_slider)+ ) |
||
| 485 | -! | +||
| 221 | +
- as.numeric(input$outlier_definition_slider)+ ) |
||
| 486 | +222 |
- } else {
+ }) |
|
| 487 | -! | +||
| 223 | +
- 0+ ) |
||
| 488 | +224 |
- }+ ) |
|
| 489 | +225 |
) |
|
| 490 | +226 |
}) |
|
| 491 | +227 | ||
| 492 | +228 |
- ### REPORTER- |
- |
| 493 | -! | -
- if (with_reporter) {
- |
- |
| 494 | -! | -
- card_fun <- function(comment) {
+ # conditionally display checkbox |
|
| 495 | +229 | ! |
- card <- teal::TealReportCard$new()+ shinyjs::toggle( |
| 496 | +230 | ! |
- card$set_name("Variable Browser Plot")
+ id = "show_parent_vars", |
| 497 | +231 | ! |
- card$append_text("Variable Browser Plot", "header2")
+ condition = length(parent_dataname) > 0 && parent_dataname %in% datanames |
| 498 | -! | +||
| 232 | +
- if (with_filter) card$append_fs(filter_panel_api$get_filter_state())+ ) |
||
| 499 | -! | +||
| 233 | +
- card$append_text("Plot", "header3")
+
|
||
| 500 | +234 | ! |
- card$append_plot(variable_plot_r(), dim = pws$dim())+ columns_names <- new.env() |
| 501 | -! | +||
| 235 | +
- if (!comment == "") {
+
|
||
| 502 | -! | +||
| 236 | +
- card$append_text("Comment", "header3")
+ # plot_var$data holds the name of the currently selected dataset |
||
| 503 | -! | +||
| 237 | +
- card$append_text(comment)+ # plot_var$variable[[<dataset_name>]] holds the name of the currently selected |
||
| 504 | +238 |
- }+ # variable for dataset <dataset_name> |
|
| 505 | +239 | ! |
- card+ plot_var <- reactiveValues(data = NULL, variable = list()) |
| 506 | +240 |
- }+ |
|
| 507 | +241 | ! |
- teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
+ establish_updating_selection(datanames, input, plot_var, columns_names) |
| 508 | +242 |
- }+ |
|
| 509 | +243 |
- ###+ # validations |
|
| 510 | -+ | ||
| 244 | +! |
- })+ validation_checks <- validate_input(input, plot_var, data) |
|
| 511 | +245 |
- }+ |
|
| 512 | +246 |
-
+ # data_for_analysis is a list with two elements: a column from a dataset and the column label |
|
| 513 | -+ | ||
| 247 | +! |
- #' Summarizes missings occurrence+ plotted_data <- reactive({
|
|
| 514 | -+ | ||
| 248 | +! |
- #'+ validation_checks() |
|
| 515 | +249 |
- #' Summarizes missings occurrence in vector+ |
|
| 516 | -+ | ||
| 250 | +! |
- #' @param x vector of any type and length+ get_plotted_data(input, plot_var, data) |
|
| 517 | +251 |
- #' @return text describing \code{NA} occurrence.
+ }) |
|
| 518 | +252 |
- #' @keywords internal+ |
|
| 519 | -+ | ||
| 253 | +! |
- var_missings_info <- function(x) {
+ treat_numeric_as_factor <- reactive({
|
|
| 520 | +254 | ! |
- return(sprintf("%s [%s%%]", sum(is.na(x)), round(mean(is.na(x) * 100), 2)))
+ if (is_num_var_short(.unique_records_for_factor, input, plotted_data)) {
|
| 521 | -+ | ||
| 255 | +! |
- }+ input$numeric_as_factor |
|
| 522 | +256 |
-
+ } else {
|
|
| 523 | -+ | ||
| 257 | +! |
- #' S3 generic for \code{sparkline} widget HTML
+ FALSE |
|
| 524 | +258 |
- #'+ } |
|
| 525 | +259 |
- #' Generates the \code{sparkline} HTML code corresponding to the input array.
+ }) |
|
| 526 | +260 |
- #' For numeric variables creates a box plot, for character and factors - bar plot.+ |
|
| 527 | -+ | ||
| 261 | +! |
- #' Produces an empty string for variables of other types.+ render_tabset_panel_content( |
|
| 528 | -+ | ||
| 262 | +! |
- #'+ input = input, |
|
| 529 | -+ | ||
| 263 | +! |
- #' @param arr vector of any type and length+ output = output, |
|
| 530 | -+ | ||
| 264 | +! |
- #' @param width \code{numeric} the width of the \code{sparkline} widget (pixels)
+ data = data, |
|
| 531 | -+ | ||
| 265 | +! |
- #' @param ... \code{list} additional options passed to bar plots of \code{jquery.sparkline}; see
+ datanames = datanames, |
|
| 532 | -+ | ||
| 266 | +! |
- #' \href{https://omnipotent.net/jquery.sparkline/#common}{\code{jquery.sparkline docs}}
+ parent_dataname = parent_dataname, |
|
| 533 | -+ | ||
| 267 | +! |
- #'+ columns_names = columns_names, |
|
| 534 | -+ | ||
| 268 | +! |
- #' @return character variable containing the HTML code of the \code{sparkline} HTML widget
+ plot_var = plot_var |
|
| 535 | +269 |
- #' @keywords internal+ ) |
|
| 536 | +270 |
- #'+ # add used-defined text size to ggplot arguments passed from caller frame |
|
| 537 | -+ | ||
| 271 | +! |
- create_sparklines <- function(arr, width = 150, ...) {
+ all_ggplot2_args <- reactive({
|
|
| 538 | +272 | ! |
- if (all(is.null(arr))) {
+ user_text <- teal.widgets::ggplot2_args( |
| 539 | +273 | ! |
- return("")
- |
-
| 540 | -- |
- }+ theme = list( |
|
| 541 | +274 | ! |
- UseMethod("create_sparklines")
+ "text" = ggplot2::element_text(size = input[["font_size"]]), |
| 542 | -+ | ||
| 275 | +! |
- }+ "axis.text.x" = ggplot2::element_text(angle = input[["label_rotation"]], hjust = 1) |
|
| 543 | +276 |
-
+ ) |
|
| 544 | +277 |
- #' Default method for \code{\link{create_sparklines}}
+ ) |
|
| 545 | -+ | ||
| 278 | +! |
- #'+ user_theme <- utils::getFromNamespace(sprintf("theme_%s", input[["ggplot_theme"]]), ns = "ggplot2")
|
|
| 546 | -+ | ||
| 279 | +! |
- #'+ user_theme <- user_theme() |
|
| 547 | +280 |
- #' @export+ # temporary fix to circumvent assertion issue with resolve_ggplot2_args |
|
| 548 | +281 |
- #' @keywords internal+ # drop problematic elements |
|
| 549 | -+ | ||
| 282 | +! |
- #' @rdname create_sparklines+ user_theme <- user_theme[grep("strip.text.y.left", names(user_theme), fixed = TRUE, invert = TRUE)]
|
|
| 550 | +283 |
- create_sparklines.default <- function(arr, width = 150, ...) {
+
|
|
| 551 | +284 | ! |
- return(as.character(tags$code("unsupported variable type", class = "text-blue")))
- |
-
| 552 | -- |
- }+ teal.widgets::resolve_ggplot2_args( |
|
| 553 | -+ | ||
| 285 | +! |
-
+ user_plot = user_text, |
|
| 554 | -+ | ||
| 286 | +! |
- #' Generates the HTML code for the \code{sparkline} widget
+ user_default = teal.widgets::ggplot2_args(theme = user_theme), |
|
| 555 | -+ | ||
| 287 | +! |
- #'+ module_plot = ggplot2_args |
|
| 556 | +288 |
- #' @param bar_spacing \code{numeric} the spacing between the bars (in pixels)
+ ) |
|
| 557 | +289 |
- #' @param bar_width \code{numeric} the width of the bars (in pixels)
+ }) |
|
| 558 | +290 |
- #'+ |
|
| 559 | -+ | ||
| 291 | +! |
- #' @return \code{character} with HTML code for the \code{sparkline} widget
+ output$ui_numeric_display <- renderUI({
|
|
| 560 | -+ | ||
| 292 | +! |
- #'+ validation_checks() |
|
| 561 | -+ | ||
| 293 | +! |
- #' @export+ dataname <- input$tabset_panel |
|
| 562 | -+ | ||
| 294 | +! |
- #' @keywords internal+ varname <- plot_var$variable[[dataname]] |
|
| 563 | -+ | ||
| 295 | +! |
- #' @rdname create_sparklines+ df <- data()[[dataname]] |
|
| 564 | +296 |
- create_sparklines.Date <- function(arr, width = 150, bar_spacing = 5, bar_width = 20, ...) {
+
|
|
| 565 | +297 | ! |
- arr_num <- as.numeric(arr)+ numeric_ui <- tagList( |
| 566 | +298 | ! |
- arr_num <- sort(arr_num, decreasing = FALSE, method = "radix")+ fluidRow( |
| 567 | +299 | ! |
- binwidth <- get_bin_width(arr_num, 1)+ div( |
| 568 | +300 | ! |
- bins <- floor(diff(range(arr_num)) / binwidth) + 1+ class = "col-md-4", |
| 569 | +301 | ! |
- if (all(is.na(bins))) {
+ br(), |
| 570 | +302 | ! |
- return(as.character(tags$code("only NA", class = "text-blue")))
+ shinyWidgets::switchInput( |
| 571 | +303 | ! |
- } else if (bins == 1) {
+ inputId = session$ns("display_density"),
|
| 572 | +304 | ! |
- return(as.character(tags$code("one date", class = "text-blue")))
- |
-
| 573 | -- |
- }+ label = "Show density", |
|
| 574 | +305 | ! |
- counts <- as.vector(unname(base::table(cut(arr_num, breaks = bins))))+ value = `if`(is.null(isolate(input$display_density)), TRUE, isolate(input$display_density)), |
| 575 | +306 | ! |
- max_value <- max(counts)- |
-
| 576 | -- |
-
+ width = "50%", |
|
| 577 | +307 | ! |
- start_bins <- as.integer(seq(1, length(arr_num), length.out = bins))+ labelWidth = "100px", |
| 578 | +308 | ! |
- labels_start <- as.character(as.Date(arr_num[start_bins], origin = as.Date("1970-01-01")))
+ handleWidth = "50px" |
| 579 | -! | +||
| 309 | +
- labels <- paste("Start:", labels_start)
+ ) |
||
| 580 | +310 |
-
+ ), |
|
| 581 | +311 | ! |
- sparkline::spk_chr(+ div( |
| 582 | +312 | ! |
- unname(counts),+ class = "col-md-4", |
| 583 | +313 | ! |
- type = "bar",+ br(), |
| 584 | +314 | ! |
- chartRangeMin = 0,+ shinyWidgets::switchInput( |
| 585 | +315 | ! |
- chartRangeMax = max_value,+ inputId = session$ns("remove_outliers"),
|
| 586 | +316 | ! |
- width = width,+ label = "Remove outliers", |
| 587 | +317 | ! |
- barWidth = bar_width,+ value = `if`(is.null(isolate(input$remove_outliers)), FALSE, isolate(input$remove_outliers)), |
| 588 | +318 | ! |
- barSpacing = bar_spacing,+ width = "50%", |
| 589 | +319 | ! |
- tooltipFormatter = custom_sparkline_formatter(labels, counts)+ labelWidth = "100px", |
| 590 | -+ | ||
| 320 | +! |
- )+ handleWidth = "50px" |
|
| 591 | +321 |
- }+ ) |
|
| 592 | +322 |
-
+ ), |
|
| 593 | -+ | ||
| 323 | +! |
- #' Generates the HTML code for the \code{sparkline} widget
+ div( |
|
| 594 | -+ | ||
| 324 | +! |
- #'+ class = "col-md-4", |
|
| 595 | -+ | ||
| 325 | +! |
- #'+ uiOutput(session$ns("outlier_definition_slider_ui"))
|
|
| 596 | +326 |
- #' @param bar_spacing \code{numeric} the spacing between the bars (in pixels)
+ ) |
|
| 597 | +327 |
- #' @param bar_width \code{numeric} the width of the bars (in pixels)
+ ), |
|
| 598 | -+ | ||
| 328 | +! |
- #'+ div( |
|
| 599 | -+ | ||
| 329 | +! |
- #' @return \code{character} with HTML code for the \code{sparkline} widget
+ class = "ml-4", |
|
| 600 | -+ | ||
| 330 | +! |
- #'+ uiOutput(session$ns("ui_density_help")),
|
|
| 601 | -+ | ||
| 331 | +! |
- #' @export+ uiOutput(session$ns("ui_outlier_help"))
|
|
| 602 | +332 |
- #' @keywords internal+ ) |
|
| 603 | +333 |
- #' @rdname create_sparklines+ ) |
|
| 604 | +334 |
- create_sparklines.POSIXct <- function(arr, width = 150, bar_spacing = 5, bar_width = 20, ...) {
+
|
|
| 605 | +335 | ! |
- arr_num <- as.numeric(arr)+ if (is.numeric(df[[varname]])) {
|
| 606 | +336 | ! |
- arr_num <- sort(arr_num, decreasing = FALSE, method = "radix")+ unique_entries <- length(unique(df[[varname]])) |
| 607 | +337 | ! |
- binwidth <- get_bin_width(arr_num, 1)+ if (unique_entries < .unique_records_for_factor && unique_entries > 0) {
|
| 608 | +338 | ! |
- bins <- floor(diff(range(arr_num)) / binwidth) + 1+ list( |
| 609 | +339 | ! |
- if (all(is.na(bins))) {
+ checkboxInput( |
| 610 | +340 | ! |
- return(as.character(tags$code("only NA", class = "text-blue")))
+ session$ns("numeric_as_factor"),
|
| 611 | +341 | ! |
- } else if (bins == 1) {
+ "Treat variable as factor", |
| 612 | +342 | ! |
- return(as.character(tags$code("one date-time", class = "text-blue")))
+ value = `if`( |
| 613 | -+ | ||
| 343 | +! |
- }+ is.null(isolate(input$numeric_as_factor)), |
|
| 614 | +344 | ! |
- counts <- as.vector(unname(base::table(cut(arr_num, breaks = bins))))+ unique_entries < .unique_records_default_as_factor, |
| 615 | +345 | ! |
- max_value <- max(counts)+ isolate(input$numeric_as_factor) |
| 616 | +346 |
-
+ )+ |
+ |
| 347 | ++ |
+ ), |
|
| 617 | +348 | ! |
- start_bins <- as.integer(seq(1, length(arr_num), length.out = bins))+ conditionalPanel("!input.numeric_as_factor", ns = session$ns, numeric_ui)
+ |
+
| 349 | ++ |
+ ) |
|
| 618 | +350 | ! |
- labels_start <- as.character(format(as.POSIXct(arr_num[start_bins], origin = as.Date("1970-01-01")), "%Y-%m-%d"))
+ } else if (unique_entries > 0) {
|
| 619 | +351 | ! |
- labels <- paste("Start:", labels_start)
+ numeric_ui |
| 620 | +352 |
-
+ } |
|
| 621 | -! | +||
| 353 | +
- sparkline::spk_chr(+ } else {
|
||
| 622 | +354 | ! |
- unname(counts),+ NULL |
| 623 | -! | +||
| 355 | +
- type = "bar",+ } |
||
| 624 | -! | +||
| 356 | +
- chartRangeMin = 0,+ })+ |
+ ||
| 357 | ++ | + | |
| 625 | +358 | ! |
- chartRangeMax = max_value,+ output$ui_histogram_display <- renderUI({
|
| 626 | +359 | ! |
- width = width,+ validation_checks() |
| 627 | +360 | ! |
- barWidth = bar_width,+ dataname <- input$tabset_panel |
| 628 | +361 | ! |
- barSpacing = bar_spacing,+ varname <- plot_var$variable[[dataname]] |
| 629 | +362 | ! |
- tooltipFormatter = custom_sparkline_formatter(labels, counts)+ df <- data()[[dataname]] |
| 630 | +363 |
- )+ |
|
| 631 | -+ | ||
| 364 | +! |
- }+ numeric_ui <- tagList(fluidRow( |
|
| 632 | -+ | ||
| 365 | +! |
-
+ div( |
|
| 633 | -+ | ||
| 366 | +! |
- #' Generates the HTML code for the \code{sparkline} widget
+ class = "col-md-4", |
|
| 634 | -+ | ||
| 367 | +! |
- #'+ shinyWidgets::switchInput( |
|
| 635 | -+ | ||
| 368 | +! |
- #'+ inputId = session$ns("remove_NA_hist"),
|
|
| 636 | -+ | ||
| 369 | +! |
- #' @param bar_spacing \code{numeric} the spacing between the bars (in pixels)
+ label = "Remove NA values", |
|
| 637 | -+ | ||
| 370 | +! |
- #' @param bar_width \code{numeric} the width of the bars (in pixels)
+ value = FALSE, |
|
| 638 | -+ | ||
| 371 | +! |
- #'+ width = "50%", |
|
| 639 | -+ | ||
| 372 | +! |
- #' @return \code{character} with HTML code for the \code{sparkline} widget
+ labelWidth = "100px", |
|
| 640 | -+ | ||
| 373 | +! |
- #'+ handleWidth = "50px" |
|
| 641 | +374 |
- #' @export+ ) |
|
| 642 | +375 |
- #' @keywords internal+ ) |
|
| 643 | +376 |
- #' @rdname create_sparklines+ )) |
|
| 644 | +377 |
- create_sparklines.POSIXlt <- function(arr, width = 150, bar_spacing = 5, bar_width = 20, ...) {
+
|
|
| 645 | +378 | ! |
- arr_num <- as.numeric(arr)+ var <- df[[varname]] |
| 646 | +379 | ! |
- arr_num <- sort(arr_num, decreasing = FALSE, method = "radix")+ if (anyNA(var) && (is.factor(var) || is.character(var) || is.logical(var))) {
|
| 647 | +380 | ! |
- binwidth <- get_bin_width(arr_num, 1)+ groups <- unique(as.character(var)) |
| 648 | +381 | ! |
- bins <- floor(diff(range(arr_num)) / binwidth) + 1+ len_groups <- length(groups) |
| 649 | +382 | ! |
- if (all(is.na(bins))) {
+ if (len_groups >= .unique_records_for_factor) {
|
| 650 | +383 | ! |
- return(as.character(tags$code("only NA", class = "text-blue")))
+ NULL |
| 651 | -! | +||
| 384 | +
- } else if (bins == 1) {
+ } else {
|
||
| 652 | +385 | ! |
- return(as.character(tags$code("one date-time", class = "text-blue")))
+ numeric_ui |
| 653 | +386 |
- }+ } |
|
| 654 | -! | +||
| 387 | +
- counts <- as.vector(unname(base::table(cut(arr_num, breaks = bins))))+ } else {
|
||
| 655 | +388 | ! |
- max_value <- max(counts)+ NULL |
| 656 | +389 | ++ |
+ }+ |
+
| 390 | ++ |
+ })+ |
+ |
| 391 | |||
| 657 | +392 | ! |
- start_bins <- as.integer(seq(1, length(arr_num), length.out = bins))+ output$outlier_definition_slider_ui <- renderUI({
|
| 658 | +393 | ! |
- labels_start <- as.character(format(as.POSIXct(arr_num[start_bins], origin = as.Date("1970-01-01")), "%Y-%m-%d"))
+ req(input$remove_outliers) |
| 659 | +394 | ! |
- labels <- paste("Start:", labels_start)
+ sliderInput( |
| 660 | -+ | ||
| 395 | +! |
-
+ inputId = session$ns("outlier_definition_slider"),
|
|
| 661 | +396 | ! |
- sparkline::spk_chr(+ div( |
| 662 | +397 | ! |
- unname(counts),+ class = "teal-tooltip", |
| 663 | +398 | ! |
- type = "bar",+ tagList( |
| 664 | +399 | ! |
- chartRangeMin = 0,+ "Outlier definition:", |
| 665 | +400 | ! |
- chartRangeMax = max_value,+ icon("circle-info"),
|
| 666 | +401 | ! |
- width = width,+ span( |
| 667 | +402 | ! |
- barWidth = bar_width,+ class = "tooltiptext", |
| 668 | +403 | ! |
- barSpacing = bar_spacing,+ paste( |
| 669 | +404 | ! |
- tooltipFormatter = custom_sparkline_formatter(labels, counts)+ "Use the slider to choose the cut-off value to define outliers; the larger the value the", |
| 670 | -+ | ||
| 405 | +! |
- )+ "further below Q1/above Q3 points have to be in order to be classed as outliers" |
|
| 671 | +406 |
- }+ ) |
|
| 672 | +407 |
-
+ ) |
|
| 673 | +408 |
-
+ ) |
|
| 674 | +409 |
- #' Generates the HTML code for the \code{sparkline} widget
+ ), |
|
| 675 | -+ | ||
| 410 | +! |
- #'+ min = 1, |
|
| 676 | -+ | ||
| 411 | +! |
- #' Coerces a character vector to factor and delegates to the \code{create_sparklines.factor}
+ max = 5, |
|
| 677 | -+ | ||
| 412 | +! |
- #'+ value = 3, |
|
| 678 | -+ | ||
| 413 | +! |
- #'+ step = 0.5 |
|
| 679 | +414 |
- #' @return \code{character} with HTML code for the \code{sparkline} widget
+ ) |
|
| 680 | +415 |
- #'+ }) |
|
| 681 | +416 |
- #' @export+ |
|
| 682 | -+ | ||
| 417 | +! |
- #' @keywords internal+ output$ui_density_help <- renderUI({
|
|
| 683 | -+ | ||
| 418 | +! |
- #' @rdname create_sparklines+ req(is.logical(input$display_density)) |
|
| 684 | -+ | ||
| 419 | +! |
- create_sparklines.character <- function(arr, ...) {
+ if (input$display_density) {
|
|
| 685 | +420 | ! |
- return(create_sparklines(as.factor(arr)))+ tags$small(helpText(paste( |
| 686 | -+ | ||
| 421 | +! |
- }+ "Kernel density estimation with gaussian kernel", |
|
| 687 | -+ | ||
| 422 | +! |
-
+ "and bandwidth function bw.nrd0 (R default)" |
|
| 688 | +423 |
-
+ ))) |
|
| 689 | +424 |
- #' Generates the HTML code for the \code{sparkline} widget
+ } else {
|
|
| 690 | -+ | ||
| 425 | +! |
- #'+ NULL |
|
| 691 | +426 |
- #' Coerces logical vector to factor and delegates to the \code{create_sparklines.factor}
+ } |
|
| 692 | +427 |
- #'+ }) |
|
| 693 | +428 |
- #'+ |
|
| 694 | -+ | ||
| 429 | +! |
- #' @return \code{character} with HTML code for the \code{sparkline} widget
+ output$ui_outlier_help <- renderUI({
|
|
| 695 | -+ | ||
| 430 | +! |
- #'+ req(is.logical(input$remove_outliers), input$outlier_definition_slider) |
|
| 696 | -+ | ||
| 431 | +! |
- #' @export+ if (input$remove_outliers) {
|
|
| 697 | -+ | ||
| 432 | +! |
- #' @keywords internal+ tags$small( |
|
| 698 | -+ | ||
| 433 | +! |
- #' @rdname create_sparklines+ helpText( |
|
| 699 | -+ | ||
| 434 | +! |
- create_sparklines.logical <- function(arr, ...) {
+ withMathJax(paste0( |
|
| 700 | +435 | ! |
- return(create_sparklines(as.factor(arr)))+ "Outlier data points (\\( X \\lt Q1 - ", input$outlier_definition_slider, "\\times IQR \\) or |
| 701 | -+ | ||
| 436 | +! |
- }+ \\(Q3 + ", input$outlier_definition_slider, "\\times IQR \\lt X\\)) |
|
| 702 | -+ | ||
| 437 | +! |
-
+ have not been displayed on the graph and will not be used for any kernel density estimations, ", |
|
| 703 | -+ | ||
| 438 | +! |
-
+ "although their values remain in the statisics table below." |
|
| 704 | +439 |
- #' Generates the \code{sparkline} HTML code
+ )) |
|
| 705 | +440 |
- #'+ ) |
|
| 706 | +441 |
- #' @param bar_spacing \code{numeric} spacing between the bars (in pixels)
+ ) |
|
| 707 | +442 |
- #' @param bar_width \code{numeric} width of the bars (in pixels)
+ } else {
|
|
| 708 | -+ | ||
| 443 | +! |
- #'+ NULL |
|
| 709 | +444 |
- #' @return \code{character} with HTML code for the \code{sparkline} widget
+ } |
|
| 710 | +445 |
- #'+ }) |
|
| 711 | +446 |
- #' @export+ |
|
| 712 | +447 |
- #' @keywords internal+ |
|
| 713 | -+ | ||
| 448 | +! |
- #' @rdname create_sparklines+ variable_plot_r <- reactive({
|
|
| 714 | -+ | ||
| 449 | +! |
- create_sparklines.factor <- function(arr, width = 150, bar_spacing = 5, bar_width = 20, ...) {
+ display_density <- `if`(is.null(input$display_density), FALSE, input$display_density) |
|
| 715 | +450 | ! |
- decreasing_order <- TRUE+ remove_outliers <- `if`(is.null(input$remove_outliers), FALSE, input$remove_outliers) |
| 716 | +451 | ||
| 717 | +452 | ! |
- counts <- table(arr)+ if (remove_outliers) {
|
| 718 | +453 | ! |
- if (length(counts) >= 100) {
+ req(input$outlier_definition_slider) |
| 719 | +454 | ! |
- return(as.character(tags$code("> 99 levels", class = "text-blue")))
+ outlier_definition <- as.numeric(input$outlier_definition_slider) |
| 720 | -! | +||
| 455 | +
- } else if (length(counts) == 0) {
+ } else {
|
||
| 721 | +456 | ! |
- return(as.character(tags$code("no levels", class = "text-blue")))
+ outlier_definition <- 0 |
| 722 | -! | +||
| 457 | +
- } else if (length(counts) == 1) {
+ }+ |
+ ||
| 458 | ++ | + | |
| 723 | +459 | ! |
- return(as.character(tags$code("one level", class = "text-blue")))
+ plot_var_summary( |
| 724 | -+ | ||
| 460 | +! |
- }+ var = plotted_data()$data, |
|
| 725 | -+ | ||
| 461 | +! |
-
+ var_lab = plotted_data()$var_description, |
|
| 726 | -+ | ||
| 462 | +! |
- # Summarize the occurences of different levels+ wrap_character = 15, |
|
| 727 | -+ | ||
| 463 | +! |
- # and get the maximum and minimum number of occurences+ numeric_as_factor = treat_numeric_as_factor(), |
|
| 728 | -+ | ||
| 464 | +! |
- # This is needed for the sparkline to correctly display the bar plots+ remove_NA_hist = input$remove_NA_hist, |
|
| 729 | -+ | ||
| 465 | +! |
- # Otherwise they are cropped+ display_density = display_density, |
|
| 730 | +466 | ! |
- counts <- sort(counts, decreasing = decreasing_order, method = "radix")+ outlier_definition = outlier_definition, |
| 731 | +467 | ! |
- max_value <- if (decreasing_order) counts[1] else counts[length[counts]]+ records_for_factor = .unique_records_for_factor, |
| 732 | +468 | ! |
- max_value <- unname(max_value)+ ggplot2_args = all_ggplot2_args() |
| 733 | +469 | ++ |
+ )+ |
+
| 470 | ++ |
+ })+ |
+ |
| 471 | |||
| 734 | +472 | ! |
- sparkline::spk_chr(+ pws <- teal.widgets::plot_with_settings_srv( |
| 735 | +473 | ! |
- unname(counts),+ id = "variable_plot", |
| 736 | +474 | ! |
- type = "bar",+ plot_r = variable_plot_r, |
| 737 | +475 | ! |
- chartRangeMin = 0,+ height = c(500, 200, 2000) |
| 738 | -! | +||
| 476 | +
- chartRangeMax = max_value,+ )+ |
+ ||
| 477 | ++ | + | |
| 739 | +478 | ! |
- width = width,+ output$variable_summary_table <- DT::renderDataTable({
|
| 740 | +479 | ! |
- barWidth = bar_width,+ var_summary_table( |
| 741 | +480 | ! |
- barSpacing = bar_spacing,+ plotted_data()$data, |
| 742 | +481 | ! |
- tooltipFormatter = custom_sparkline_formatter(names(counts), as.vector(counts))+ treat_numeric_as_factor(), |
| 743 | -+ | ||
| 482 | +! |
- )+ input$variable_summary_table_rows, |
|
| 744 | -+ | ||
| 483 | +! |
- }+ if (!is.null(input$remove_outliers) && input$remove_outliers) {
|
|
| 745 | -+ | ||
| 484 | +! |
-
+ req(input$outlier_definition_slider) |
|
| 746 | -+ | ||
| 485 | +! |
- #' Generates the \code{sparkline} HTML code
+ as.numeric(input$outlier_definition_slider) |
|
| 747 | +486 |
- #'+ } else {
|
|
| 748 | -+ | ||
| 487 | +! |
- #'+ 0 |
|
| 749 | +488 |
- #' @return \code{character} with HTML code for the \code{sparkline} widget
+ } |
|
| 750 | +489 |
- #'+ ) |
|
| 751 | +490 |
- #' @export+ }) |
|
| 752 | +491 |
- #' @keywords internal+ |
|
| 753 | +492 |
- #' @rdname create_sparklines+ ### REPORTER |
|
| 754 | -+ | ||
| 493 | +! |
- create_sparklines.numeric <- function(arr, width = 150, ...) {
+ if (with_reporter) {
|
|
| 755 | +494 | ! |
- if (any(is.infinite(arr))) {
+ card_fun <- function(comment) {
|
| 756 | +495 | ! |
- return(as.character(tags$code("infinite values", class = "text-blue")))
+ card <- teal::TealReportCard$new() |
| 757 | -+ | ||
| 496 | +! |
- }+ card$set_name("Variable Browser Plot")
|
|
| 758 | +497 | ! |
- if (length(arr) > 100000) {
+ card$append_text("Variable Browser Plot", "header2")
|
| 759 | +498 | ! |
- return(as.character(tags$code("Too many rows (>100000)", class = "text-blue")))
+ if (with_filter) card$append_fs(filter_panel_api$get_filter_state()) |
| 760 | -+ | ||
| 499 | +! |
- }+ card$append_text("Plot", "header3")
|
|
| 761 | -+ | ||
| 500 | +! |
-
+ card$append_plot(variable_plot_r(), dim = pws$dim()) |
|
| 762 | +501 | ! |
- arr <- arr[!is.na(arr)]+ if (!comment == "") {
|
| 763 | +502 | ! |
- res <- sparkline::spk_chr(unname(arr), type = "box", width = width, ...)+ card$append_text("Comment", "header3")
|
| 764 | +503 | ! |
- return(res)+ card$append_text(comment) |
| 765 | +504 |
- }+ } |
|
| 766 | -+ | ||
| 505 | +! |
-
+ card |
|
| 767 | +506 |
- #' Summarizes variable+ }+ |
+ |
| 507 | +! | +
+ teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
|
|
| 768 | +508 |
- #'+ } |
|
| 769 | +509 |
- #' Creates html summary with statistics relevant to data type. For numeric values it returns central+ ### |
|
| 770 | +510 |
- #' tendency measures, for factor returns level counts, for Date date range, for other just+ }) |
|
| 771 | +511 |
- #' number of levels.+ } |
|
| 772 | +512 |
- #' @param x vector of any type+ |
|
| 773 | +513 |
- #' @param numeric_as_factor \code{logical} should the numeric variable be treated as a factor
+ #' Summarizes missings occurrence |
|
| 774 | +514 |
- #' @param dt_rows \code{numeric} current/latest `DT` page length
+ #' |
|
| 775 | +515 |
- #' @param outlier_definition If 0 no outliers are removed, otherwise+ #' Summarizes missings occurrence in vector |
|
| 776 | +516 |
- #' outliers (those more than outlier_definition*IQR below/above Q1/Q3 be removed)+ #' @param x vector of any type and length |
|
| 777 | +517 |
- #' @return text with simple statistics.+ #' @return text describing \code{NA} occurrence.
|
|
| 778 | +518 |
#' @keywords internal |
|
| 779 | +519 |
- var_summary_table <- function(x, numeric_as_factor, dt_rows, outlier_definition) {
+ var_missings_info <- function(x) {
|
|
| 780 | +520 | ! |
- if (is.null(dt_rows)) {
+ return(sprintf("%s [%s%%]", sum(is.na(x)), round(mean(is.na(x) * 100), 2)))
|
| 781 | -! | +||
| 521 | +
- dt_rows <- 10+ } |
||
| 782 | +522 |
- }+ |
|
| 783 | -! | +||
| 523 | +
- if (is.numeric(x) && !numeric_as_factor) {
+ #' S3 generic for \code{sparkline} widget HTML
|
||
| 784 | -! | +||
| 524 | +
- req(!any(is.infinite(x)))+ #' |
||
| 785 | +525 |
-
+ #' Generates the \code{sparkline} HTML code corresponding to the input array.
|
|
| 786 | -! | +||
| 526 | +
- x <- remove_outliers_from(x, outlier_definition)+ #' For numeric variables creates a box plot, for character and factors - bar plot. |
||
| 787 | +527 |
-
+ #' Produces an empty string for variables of other types. |
|
| 788 | -! | +||
| 528 | +
- qvals <- round(stats::quantile(x, na.rm = TRUE, probs = c(0.25, 0.5, 0.75), type = 2), 2)+ #' |
||
| 789 | +529 |
- # classical central tendency measures+ #' @param arr vector of any type and length |
|
| 790 | +530 |
-
+ #' @param width \code{numeric} the width of the \code{sparkline} widget (pixels)
|
|
| 791 | -! | +||
| 531 | +
- summary <-+ #' @param ... \code{list} additional options passed to bar plots of \code{jquery.sparkline}; see
|
||
| 792 | -! | +||
| 532 | +
- data.frame(+ #' \href{https://omnipotent.net/jquery.sparkline/#common}{\code{jquery.sparkline docs}}
|
||
| 793 | -! | +||
| 533 | +
- Statistic = c("min", "Q1", "median", "mean", "Q3", "max", "sd", "n"),
+ #' |
||
| 794 | -! | +||
| 534 | +
- Value = c(+ #' @return character variable containing the HTML code of the \code{sparkline} HTML widget
|
||
| 795 | -! | +||
| 535 | +
- round(min(x, na.rm = TRUE), 2),+ #' @keywords internal |
||
| 796 | -! | +||
| 536 | +
- qvals[1],+ #' |
||
| 797 | -! | +||
| 537 | +
- qvals[2],+ create_sparklines <- function(arr, width = 150, ...) {
|
||
| 798 | +538 | ! |
- round(mean(x, na.rm = TRUE), 2),+ if (all(is.null(arr))) {
|
| 799 | +539 | ! |
- qvals[3],+ return("")
|
| 800 | -! | +||
| 540 | +
- round(max(x, na.rm = TRUE), 2),+ } |
||
| 801 | +541 | ! |
- round(stats::sd(x, na.rm = TRUE), 2),+ UseMethod("create_sparklines")
|
| 802 | -! | +||
| 542 | +
- length(x[!is.na(x)])+ } |
||
| 803 | +543 |
- )+ |
|
| 804 | +544 |
- )+ #' Default method for \code{\link{create_sparklines}}
|
|
| 805 | +545 |
-
+ #' |
|
| 806 | -! | +||
| 546 | +
- DT::datatable(summary, rownames = FALSE, options = list(dom = "<t>", pageLength = dt_rows))+ #' |
||
| 807 | -! | +||
| 547 | +
- } else if (is.factor(x) || is.character(x) || (is.numeric(x) && numeric_as_factor) || is.logical(x)) {
+ #' @export |
||
| 808 | +548 |
- # make sure factor is ordered numeric- |
- |
| 809 | -! | -
- if (is.numeric(x)) {
- |
- |
| 810 | -! | -
- x <- factor(x, levels = sort(unique(x)))+ #' @keywords internal |
|
| 811 | +549 |
- }+ #' @rdname create_sparklines |
|
| 812 | +550 |
-
+ create_sparklines.default <- function(arr, width = 150, ...) {
|
|
| 813 | +551 | ! |
- level_counts <- table(x)+ return(as.character(tags$code("unsupported variable type", class = "text-blue")))
|
| 814 | -! | +||
| 552 | +
- max_levels_signif <- nchar(level_counts)+ } |
||
| 815 | +553 | ||
| 816 | -! | +||
| 554 | +
- if (!all(is.na(x))) {
+ #' Generates the HTML code for the \code{sparkline} widget
|
||
| 817 | -! | +||
| 555 | +
- levels <- names(level_counts)+ #' |
||
| 818 | -! | +||
| 556 | +
- counts <- sprintf(+ #' @param bar_spacing \code{numeric} the spacing between the bars (in pixels)
|
||
| 819 | -! | +||
| 557 | +
- "%s [%.2f%%]",+ #' @param bar_width \code{numeric} the width of the bars (in pixels)
|
||
| 820 | -! | +||
| 558 | +
- format(level_counts, width = max_levels_signif), prop.table(level_counts) * 100+ #' |
||
| 821 | +559 |
- )+ #' @return \code{character} with HTML code for the \code{sparkline} widget
|
|
| 822 | +560 |
- } else {
+ #' |
|
| 823 | -! | +||
| 561 | +
- levels <- character(0)+ #' @export |
||
| 824 | -! | +||
| 562 | +
- counts <- numeric(0)+ #' @keywords internal |
||
| 825 | +563 |
- }+ #' @rdname create_sparklines |
|
| 826 | +564 |
-
+ create_sparklines.Date <- function(arr, width = 150, bar_spacing = 5, bar_width = 20, ...) {
|
|
| 827 | +565 | ! |
- summary <- data.frame(+ arr_num <- as.numeric(arr) |
| 828 | +566 | ! |
- Level = levels,+ arr_num <- sort(arr_num, decreasing = FALSE, method = "radix") |
| 829 | +567 | ! |
- Count = counts,+ binwidth <- get_bin_width(arr_num, 1) |
| 830 | +568 | ! |
- stringsAsFactors = FALSE+ bins <- floor(diff(range(arr_num)) / binwidth) + 1 |
| 831 | -+ | ||
| 569 | +! |
- )+ if (all(is.na(bins))) {
|
|
| 832 | -+ | ||
| 570 | +! |
-
+ return(as.character(tags$code("only NA", class = "text-blue")))
|
|
| 833 | -+ | ||
| 571 | +! |
- # sort the dataset in decreasing order of counts (needed as character variables default to alphabetical)+ } else if (bins == 1) {
|
|
| 834 | +572 | ! |
- summary <- summary[order(summary$Count, decreasing = TRUE), ]+ return(as.character(tags$code("one date", class = "text-blue")))
|
| 835 | +573 |
-
+ } |
|
| 836 | +574 | ! |
- dom_opts <- if (nrow(summary) <= 10) {
+ counts <- as.vector(unname(base::table(cut(arr_num, breaks = bins)))) |
| 837 | +575 | ! |
- "<t>"+ max_value <- max(counts) |
| 838 | +576 |
- } else {
+
|
|
| 839 | +577 | ! |
- "<lf<t>ip>"- |
-
| 840 | -- |
- }+ start_bins <- as.integer(seq(1, length(arr_num), length.out = bins)) |
|
| 841 | +578 | ! |
- DT::datatable(summary, rownames = FALSE, options = list(dom = dom_opts, pageLength = dt_rows))+ labels_start <- as.character(as.Date(arr_num[start_bins], origin = as.Date("1970-01-01")))
|
| 842 | +579 | ! |
- } else if (inherits(x, "Date") || inherits(x, "POSIXct") || inherits(x, "POSIXlt")) {
+ labels <- paste("Start:", labels_start)
|
| 843 | -! | +||
| 580 | +
- summary <-+ |
||
| 844 | +581 | ! |
- data.frame(+ sparkline::spk_chr( |
| 845 | +582 | ! |
- Statistic = c("min", "median", "max"),
+ unname(counts), |
| 846 | +583 | ! |
- Value = c(+ type = "bar", |
| 847 | +584 | ! |
- min(x, na.rm = TRUE),+ chartRangeMin = 0, |
| 848 | +585 | ! |
- stats::median(x, na.rm = TRUE),+ chartRangeMax = max_value, |
| 849 | +586 | ! |
- max(x, na.rm = TRUE)- |
-
| 850 | -- |
- )- |
- |
| 851 | -- |
- )+ width = width, |
|
| 852 | +587 | ! |
- DT::datatable(summary, rownames = FALSE, options = list(dom = "<t>", pageLength = dt_rows))+ barWidth = bar_width, |
| 853 | -+ | ||
| 588 | +! |
- } else {
+ barSpacing = bar_spacing, |
|
| 854 | +589 | ! |
- NULL+ tooltipFormatter = custom_sparkline_formatter(labels, counts) |
| 855 | +590 |
- }+ ) |
|
| 856 | +591 |
} |
|
| 857 | +592 | ||
| 858 | +593 |
-
+ #' Generates the HTML code for the \code{sparkline} widget
|
|
| 859 | +594 |
- #' Plot variable+ #' |
|
| 860 | +595 |
#' |
|
| 861 | +596 |
- #' Creates summary plot with statistics relevant to data type.+ #' @param bar_spacing \code{numeric} the spacing between the bars (in pixels)
|
|
| 862 | +597 |
- #' @inheritParams shared_params+ #' @param bar_width \code{numeric} the width of the bars (in pixels)
|
|
| 863 | +598 |
- #' @param var vector of any type to be plotted. For numeric variables it produces histogram with+ #' |
|
| 864 | +599 |
- #' density line, for factors it creates frequency plot+ #' @return \code{character} with HTML code for the \code{sparkline} widget
|
|
| 865 | +600 |
- #' @param var_lab text describing selected variable to be displayed on the plot+ #' |
|
| 866 | +601 |
- #' @param wrap_character (`numeric`) number of characters at which to wrap text values of `var`+ #' @export |
|
| 867 | +602 |
- #' @param numeric_as_factor (`logical`) should the numeric variable be treated as a factor+ #' @keywords internal |
|
| 868 | +603 |
- #' @param display_density (`logical`) should density estimation be displayed for numeric values+ #' @rdname create_sparklines |
|
| 869 | +604 |
- #' @param remove_NA_hist (`logical`) should (`NA`) values be removed for histogram of factor like variables+ create_sparklines.POSIXct <- function(arr, width = 150, bar_spacing = 5, bar_width = 20, ...) {
|
|
| 870 | -+ | ||
| 605 | +! |
- #' @param outlier_definition if 0 no outliers are removed, otherwise+ arr_num <- as.numeric(arr) |
|
| 871 | -+ | ||
| 606 | +! |
- #' outliers (those more than outlier_definition*IQR below/above Q1/Q3 be removed)+ arr_num <- sort(arr_num, decreasing = FALSE, method = "radix") |
|
| 872 | -+ | ||
| 607 | +! |
- #' @param records_for_factor (`numeric`) if the number of factor levels is >= than this value then+ binwidth <- get_bin_width(arr_num, 1) |
|
| 873 | -+ | ||
| 608 | +! |
- #' a graph of the factors isn't shown, only a list of values+ bins <- floor(diff(range(arr_num)) / binwidth) + 1 |
|
| 874 | -+ | ||
| 609 | +! |
- #'+ if (all(is.na(bins))) {
|
|
| 875 | -+ | ||
| 610 | +! |
- #' @return plot+ return(as.character(tags$code("only NA", class = "text-blue")))
|
|
| 876 | -+ | ||
| 611 | +! |
- #' @keywords internal+ } else if (bins == 1) {
|
|
| 877 | -+ | ||
| 612 | +! |
- plot_var_summary <- function(var,+ return(as.character(tags$code("one date-time", class = "text-blue")))
|
|
| 878 | +613 |
- var_lab,+ } |
|
| 879 | -+ | ||
| 614 | +! |
- wrap_character = NULL,+ counts <- as.vector(unname(base::table(cut(arr_num, breaks = bins)))) |
|
| 880 | -+ | ||
| 615 | +! |
- numeric_as_factor,+ max_value <- max(counts) |
|
| 881 | +616 |
- display_density = is.numeric(var),+ |
|
| 882 | -+ | ||
| 617 | +! |
- remove_NA_hist = FALSE, # nolint object_name_linter+ start_bins <- as.integer(seq(1, length(arr_num), length.out = bins)) |
|
| 883 | -+ | ||
| 618 | +! |
- outlier_definition,+ labels_start <- as.character(format(as.POSIXct(arr_num[start_bins], origin = as.Date("1970-01-01")), "%Y-%m-%d"))
|
|
| 884 | -+ | ||
| 619 | +! |
- records_for_factor,+ labels <- paste("Start:", labels_start)
|
|
| 885 | +620 |
- ggplot2_args) {
+
|
|
| 886 | +621 | ! |
- checkmate::assert_character(var_lab)+ sparkline::spk_chr( |
| 887 | +622 | ! |
- checkmate::assert_numeric(wrap_character, null.ok = TRUE)+ unname(counts), |
| 888 | +623 | ! |
- checkmate::assert_flag(numeric_as_factor)+ type = "bar", |
| 889 | +624 | ! |
- checkmate::assert_flag(display_density)+ chartRangeMin = 0, |
| 890 | +625 | ! |
- checkmate::assert_logical(remove_NA_hist, null.ok = TRUE)+ chartRangeMax = max_value, |
| 891 | +626 | ! |
- checkmate::assert_number(outlier_definition, lower = 0, finite = TRUE)+ width = width, |
| 892 | +627 | ! |
- checkmate::assert_integerish(records_for_factor, lower = 0, len = 1, any.missing = FALSE)+ barWidth = bar_width, |
| 893 | +628 | ! |
- checkmate::assert_class(ggplot2_args, "ggplot2_args")+ barSpacing = bar_spacing,+ |
+
| 629 | +! | +
+ tooltipFormatter = custom_sparkline_formatter(labels, counts) |
|
| 894 | +630 |
-
+ ) |
|
| 895 | -! | +||
| 631 | +
- grid::grid.newpage()+ } |
||
| 896 | +632 | ||
| 897 | -! | +||
| 633 | +
- plot_main <- if (is.factor(var) || is.character(var) || is.logical(var)) {
+ #' Generates the HTML code for the \code{sparkline} widget
|
||
| 898 | -! | +||
| 634 | +
- groups <- unique(as.character(var))+ #' |
||
| 899 | -! | +||
| 635 | +
- len_groups <- length(groups)+ #' |
||
| 900 | -! | +||
| 636 | +
- if (len_groups >= records_for_factor) {
+ #' @param bar_spacing \code{numeric} the spacing between the bars (in pixels)
|
||
| 901 | -! | +||
| 637 | +
- grid::textGrob(+ #' @param bar_width \code{numeric} the width of the bars (in pixels)
|
||
| 902 | -! | +||
| 638 | +
- sprintf(- |
- ||
| 903 | -! | -
- "%s unique values\n%s:\n %s\n ...\n %s",+ #' |
|
| 904 | -! | +||
| 639 | +
- len_groups,+ #' @return \code{character} with HTML code for the \code{sparkline} widget
|
||
| 905 | -! | +||
| 640 | +
- var_lab,+ #' |
||
| 906 | -! | +||
| 641 | +
- paste(utils::head(groups), collapse = ",\n "),+ #' @export |
||
| 907 | -! | +||
| 642 | +
- paste(utils::tail(groups), collapse = ",\n ")+ #' @keywords internal |
||
| 908 | +643 |
- ),+ #' @rdname create_sparklines |
|
| 909 | -! | +||
| 644 | +
- x = grid::unit(1, "line"),+ create_sparklines.POSIXlt <- function(arr, width = 150, bar_spacing = 5, bar_width = 20, ...) {
|
||
| 910 | +645 | ! |
- y = grid::unit(1, "npc") - grid::unit(1, "line"),+ arr_num <- as.numeric(arr) |
| 911 | +646 | ! |
- just = c("left", "top")
- |
-
| 912 | -- |
- )- |
- |
| 913 | -- |
- } else {
+ arr_num <- sort(arr_num, decreasing = FALSE, method = "radix") |
|
| 914 | +647 | ! |
- if (!is.null(wrap_character)) {
+ binwidth <- get_bin_width(arr_num, 1) |
| 915 | +648 | ! |
- var <- stringr::str_wrap(var, width = wrap_character)- |
-
| 916 | -- |
- }+ bins <- floor(diff(range(arr_num)) / binwidth) + 1 |
|
| 917 | +649 | ! |
- var <- if (isTRUE(remove_NA_hist)) as.vector(stats::na.omit(var)) else var+ if (all(is.na(bins))) {
|
| 918 | +650 | ! |
- ggplot(data.frame(var), aes(x = forcats::fct_infreq(as.factor(var)))) ++ return(as.character(tags$code("only NA", class = "text-blue")))
|
| 919 | +651 | ! |
- geom_bar(stat = "count", aes(fill = ifelse(is.na(var), "withcolor", "")), show.legend = FALSE) ++ } else if (bins == 1) {
|
| 920 | +652 | ! |
- scale_fill_manual(values = c("gray50", "tan"))
+ return(as.character(tags$code("one date-time", class = "text-blue")))
|
| 921 | +653 |
- }+ } |
|
| 922 | +654 | ! |
- } else if (is.numeric(var)) {
+ counts <- as.vector(unname(base::table(cut(arr_num, breaks = bins)))) |
| 923 | +655 | ! |
- validate(need(any(!is.na(var)), "No data left to visualize."))+ max_value <- max(counts) |
| 924 | +656 | ||
| 925 | -- |
- # Filter out NA- |
- |
| 926 | +657 | ! |
- var <- var[which(!is.na(var))]+ start_bins <- as.integer(seq(1, length(arr_num), length.out = bins)) |
| 927 | -+ | ||
| 658 | +! |
-
+ labels_start <- as.character(format(as.POSIXct(arr_num[start_bins], origin = as.Date("1970-01-01")), "%Y-%m-%d"))
|
|
| 928 | +659 | ! |
- validate(need(!any(is.infinite(var)), "Cannot display graph when data includes infinite values"))+ labels <- paste("Start:", labels_start)
|
| 929 | +660 | ||
| 930 | +661 | ! |
- if (numeric_as_factor) {
+ sparkline::spk_chr( |
| 931 | +662 | ! |
- var <- factor(var)+ unname(counts), |
| 932 | +663 | ! |
- ggplot(NULL, aes(x = var)) ++ type = "bar", |
| 933 | +664 | ! |
- geom_histogram(stat = "count")- |
-
| 934 | -- |
- } else {
+ chartRangeMin = 0, |
|
| 935 | -+ | ||
| 665 | +! |
- # remove outliers+ chartRangeMax = max_value, |
|
| 936 | +666 | ! |
- if (outlier_definition != 0) {
+ width = width, |
| 937 | +667 | ! |
- number_records <- length(var)+ barWidth = bar_width, |
| 938 | +668 | ! |
- var <- remove_outliers_from(var, outlier_definition)+ barSpacing = bar_spacing, |
| 939 | +669 | ! |
- number_outliers <- number_records - length(var)+ tooltipFormatter = custom_sparkline_formatter(labels, counts) |
| 940 | -! | +||
| 670 | +
- outlier_text <- paste0(+ ) |
||
| 941 | -! | +||
| 671 | +
- number_outliers, " outliers (",
+ } |
||
| 942 | -! | +||
| 672 | +
- round(number_outliers / number_records * 100, 2),+ |
||
| 943 | -! | +||
| 673 | +
- "% of non-missing records) not shown"+ |
||
| 944 | +674 |
- )+ #' Generates the HTML code for the \code{sparkline} widget
|
|
| 945 | -! | +||
| 675 | +
- validate(need(+ #' |
||
| 946 | -! | +||
| 676 | +
- length(var) > 1,+ #' Coerces a character vector to factor and delegates to the \code{create_sparklines.factor}
|
||
| 947 | -! | +||
| 677 | +
- "At least two data points must remain after removing outliers for this graph to be displayed"+ #' |
||
| 948 | +678 |
- ))+ #' |
|
| 949 | +679 |
- }+ #' @return \code{character} with HTML code for the \code{sparkline} widget
|
|
| 950 | +680 |
- ## histogram+ #' |
|
| 951 | -! | +||
| 681 | +
- binwidth <- get_bin_width(var)+ #' @export |
||
| 952 | -! | +||
| 682 | +
- p <- ggplot(data = data.frame(var = var), aes(x = var, y = after_stat(count))) ++ #' @keywords internal |
||
| 953 | -! | +||
| 683 | +
- geom_histogram(binwidth = binwidth) ++ #' @rdname create_sparklines |
||
| 954 | -! | +||
| 684 | +
- scale_y_continuous(+ create_sparklines.character <- function(arr, ...) {
|
||
| 955 | +685 | ! |
- sec.axis = sec_axis(+ return(create_sparklines(as.factor(arr))) |
| 956 | -! | +||
| 686 | +
- trans = ~ . / nrow(data.frame(var = var)),+ } |
||
| 957 | -! | +||
| 687 | +
- labels = scales::percent,+ |
||
| 958 | -! | +||
| 688 | +
- name = "proportion (in %)"+ |
||
| 959 | +689 |
- )+ #' Generates the HTML code for the \code{sparkline} widget
|
|
| 960 | +690 |
- )+ #' |
|
| 961 | +691 |
-
+ #' Coerces logical vector to factor and delegates to the \code{create_sparklines.factor}
|
|
| 962 | -! | +||
| 692 | +
- if (display_density) {
+ #' |
||
| 963 | -! | +||
| 693 | +
- p <- p + geom_density(aes(y = after_stat(count * binwidth)))+ #' |
||
| 964 | +694 |
- }+ #' @return \code{character} with HTML code for the \code{sparkline} widget
|
|
| 965 | +695 |
-
+ #' |
|
| 966 | -! | +||
| 696 | +
- if (outlier_definition != 0) {
+ #' @export |
||
| 967 | -! | +||
| 697 | +
- p <- p + annotate(+ #' @keywords internal |
||
| 968 | -! | +||
| 698 | +
- geom = "text",+ #' @rdname create_sparklines |
||
| 969 | -! | +||
| 699 | +
- label = outlier_text,+ create_sparklines.logical <- function(arr, ...) {
|
||
| 970 | +700 | ! |
- x = Inf, y = Inf,+ return(create_sparklines(as.factor(arr))) |
| 971 | -! | +||
| 701 | +
- hjust = 1.02, vjust = 1.2,+ } |
||
| 972 | -! | +||
| 702 | +
- color = "black",+ |
||
| 973 | +703 |
- # explicitly modify geom text size according+ |
|
| 974 | -! | +||
| 704 | +
- size = ggplot2_args[["theme"]][["text"]][["size"]] / 3.5+ #' Generates the \code{sparkline} HTML code
|
||
| 975 | +705 |
- )+ #' |
|
| 976 | +706 |
- }+ #' @param bar_spacing \code{numeric} spacing between the bars (in pixels)
|
|
| 977 | -! | +||
| 707 | +
- p+ #' @param bar_width \code{numeric} width of the bars (in pixels)
|
||
| 978 | +708 |
- }+ #' |
|
| 979 | -! | +||
| 709 | +
- } else if (inherits(var, "Date") || inherits(var, "POSIXct") || inherits(var, "POSIXlt")) {
+ #' @return \code{character} with HTML code for the \code{sparkline} widget
|
||
| 980 | -! | +||
| 710 | +
- var_num <- as.numeric(var)+ #' |
||
| 981 | -! | +||
| 711 | +
- binwidth <- get_bin_width(var_num, 1)+ #' @export |
||
| 982 | -! | +||
| 712 | +
- p <- ggplot(data = data.frame(var = var), aes(x = var, y = after_stat(count))) ++ #' @keywords internal |
||
| 983 | -! | +||
| 713 | +
- geom_histogram(binwidth = binwidth)+ #' @rdname create_sparklines |
||
| 984 | +714 |
- } else {
+ create_sparklines.factor <- function(arr, width = 150, bar_spacing = 5, bar_width = 20, ...) {
|
|
| 985 | +715 | ! |
- grid::textGrob(+ decreasing_order <- TRUE |
| 986 | -! | +||
| 716 | +
- paste(strwrap(+ |
||
| 987 | +717 | ! |
- utils::capture.output(utils::str(var)),+ counts <- table(arr) |
| 988 | +718 | ! |
- width = .9 * grid::convertWidth(grid::unit(1, "npc"), "char", TRUE)+ if (length(counts) >= 100) {
|
| 989 | +719 | ! |
- ), collapse = "\n"),+ return(as.character(tags$code("> 99 levels", class = "text-blue")))
|
| 990 | +720 | ! |
- x = grid::unit(1, "line"), y = grid::unit(1, "npc") - grid::unit(1, "line"), just = c("left", "top")
+ } else if (length(counts) == 0) {
|
| 991 | -+ | ||
| 721 | +! |
- )+ return(as.character(tags$code("no levels", class = "text-blue")))
+ |
+ |
| 722 | +! | +
+ } else if (length(counts) == 1) {
+ |
+ |
| 723 | +! | +
+ return(as.character(tags$code("one level", class = "text-blue")))
|
|
| 992 | +724 |
} |
|
| 993 | +725 | ||
| 994 | -! | +||
| 726 | +
- dev_ggplot2_args <- teal.widgets::ggplot2_args(+ # Summarize the occurences of different levels |
||
| 995 | -! | +||
| 727 | +
- labs = list(x = var_lab)+ # and get the maximum and minimum number of occurences |
||
| 996 | +728 |
- )+ # This is needed for the sparkline to correctly display the bar plots |
|
| 997 | +729 |
- ###+ # Otherwise they are cropped |
|
| 998 | +730 | ! |
- all_ggplot2_args <- teal.widgets::resolve_ggplot2_args(+ counts <- sort(counts, decreasing = decreasing_order, method = "radix") |
| 999 | +731 | ! |
- ggplot2_args,+ max_value <- if (decreasing_order) counts[1] else counts[length[counts]] |
| 1000 | +732 | ! |
- module_plot = dev_ggplot2_args+ max_value <- unname(max_value) |
| 1001 | +733 |
- )+ |
|
| 1002 | -+ | ||
| 734 | +! |
-
+ sparkline::spk_chr( |
|
| 1003 | +735 | ! |
- if (is.ggplot(plot_main)) {
+ unname(counts), |
| 1004 | +736 | ! |
- if (is.numeric(var) && !numeric_as_factor) {
+ type = "bar", |
| 1005 | -+ | ||
| 737 | +! |
- # numeric not as factor+ chartRangeMin = 0, |
|
| 1006 | +738 | ! |
- plot_main <- plot_main ++ chartRangeMax = max_value, |
| 1007 | +739 | ! |
- theme_light() ++ width = width, |
| 1008 | +740 | ! |
- list(+ barWidth = bar_width, |
| 1009 | +741 | ! |
- labs = do.call("labs", all_ggplot2_args$labs),
+ barSpacing = bar_spacing, |
| 1010 | +742 | ! |
- theme = do.call("theme", all_ggplot2_args$theme)
+ tooltipFormatter = custom_sparkline_formatter(names(counts), as.vector(counts)) |
| 1011 | +743 |
- )+ ) |
|
| 1012 | +744 |
- } else {
+ } |
|
| 1013 | +745 |
- # factor low number of levels OR numeric as factor OR Date+ |
|
| 1014 | -! | +||
| 746 | +
- plot_main <- plot_main ++ #' Generates the \code{sparkline} HTML code
|
||
| 1015 | -! | +||
| 747 | +
- theme_light() ++ #' |
||
| 1016 | -! | +||
| 748 | +
- list(+ #' |
||
| 1017 | -! | +||
| 749 | +
- labs = do.call("labs", all_ggplot2_args$labs),
+ #' @return \code{character} with HTML code for the \code{sparkline} widget
|
||
| 1018 | -! | +||
| 750 | +
- theme = do.call("theme", all_ggplot2_args$theme)
+ #' |
||
| 1019 | +751 |
- )+ #' @export |
|
| 1020 | +752 |
- }+ #' @keywords internal |
|
| 1021 | -! | +||
| 753 | +
- plot_main <- ggplotGrob(plot_main)+ #' @rdname create_sparklines |
||
| 1022 | +754 |
- }+ create_sparklines.numeric <- function(arr, width = 150, ...) {
+ |
+ |
| 755 | +! | +
+ if (any(is.infinite(arr))) {
+ |
+ |
| 756 | +! | +
+ return(as.character(tags$code("infinite values", class = "text-blue")))
|
|
| 1023 | +757 |
-
+ } |
|
| 1024 | +758 | ! |
- grid::grid.draw(plot_main)+ if (length(arr) > 100000) {
|
| 1025 | +759 | ! |
- plot_main+ return(as.character(tags$code("Too many rows (>100000)", class = "text-blue")))
|
| 1026 | +760 |
- }+ } |
|
| 1027 | +761 | ||
| 1028 | -+ | ||
| 762 | +! |
- is_num_var_short <- function(.unique_records_for_factor, input, data_for_analysis) {
+ arr <- arr[!is.na(arr)] |
|
| 1029 | +763 | ! |
- length(unique(data_for_analysis()$data)) < .unique_records_for_factor && !is.null(input$numeric_as_factor)+ res <- sparkline::spk_chr(unname(arr), type = "box", width = width, ...)+ |
+
| 764 | +! | +
+ return(res) |
|
| 1030 | +765 |
} |
|
| 1031 | +766 | ||
| 1032 | +767 |
- #' Validates the variable browser inputs+ #' Summarizes variable |
|
| 1033 | +768 |
#' |
|
| 1034 | +769 |
- #' @param input (`session$input`) the shiny session input+ #' Creates html summary with statistics relevant to data type. For numeric values it returns central |
|
| 1035 | +770 |
- #' @param plot_var (`list`) list of a data frame and an array of variable names+ #' tendency measures, for factor returns level counts, for Date date range, for other just |
|
| 1036 | +771 |
- #' @param data (`tdata`) the datasets passed to the module+ #' number of levels. |
|
| 1037 | +772 |
- #'+ #' @param x vector of any type |
|
| 1038 | +773 |
- #' @returns `logical` TRUE if validations pass; a Shiny validation error otherwise+ #' @param numeric_as_factor \code{logical} should the numeric variable be treated as a factor
|
|
| 1039 | +774 |
- #' @keywords internal+ #' @param dt_rows \code{numeric} current/latest `DT` page length
|
|
| 1040 | +775 |
- validate_input <- function(input, plot_var, data) {
+ #' @param outlier_definition If 0 no outliers are removed, otherwise |
|
| 1041 | -! | +||
| 776 | +
- reactive({
+ #' outliers (those more than outlier_definition*IQR below/above Q1/Q3 be removed) |
||
| 1042 | -! | +||
| 777 | +
- dataset_name <- req(input$tabset_panel)+ #' @return text with simple statistics. |
||
| 1043 | -! | +||
| 778 | +
- varname <- plot_var$variable[[dataset_name]]+ #' @keywords internal |
||
| 1044 | +779 |
-
+ var_summary_table <- function(x, numeric_as_factor, dt_rows, outlier_definition) {
|
|
| 1045 | +780 | ! |
- validate(need(dataset_name, "No data selected"))+ if (is.null(dt_rows)) {
|
| 1046 | +781 | ! |
- validate(need(varname, "No variable selected"))+ dt_rows <- 10 |
| 1047 | -! | +||
| 782 | +
- df <- data()[[dataset_name]]+ } |
||
| 1048 | +783 | ! |
- teal::validate_has_data(df, 1)+ if (is.numeric(x) && !numeric_as_factor) {
|
| 1049 | +784 | ! |
- teal::validate_has_variable(varname = varname, data = df, "Variable not available")+ req(!any(is.infinite(x))) |
| 1050 | +785 | ||
| 1051 | +786 | ! |
- TRUE+ x <- remove_outliers_from(x, outlier_definition) |
| 1052 | +787 |
- })+ + |
+ |
| 788 | +! | +
+ qvals <- round(stats::quantile(x, na.rm = TRUE, probs = c(0.25, 0.5, 0.75), type = 2), 2) |
|
| 1053 | +789 |
- }+ # classical central tendency measures |
|
| 1054 | +790 | ||
| 1055 | -+ | ||
| 791 | +! |
- get_plotted_data <- function(input, plot_var, data) {
+ summary <- |
|
| 1056 | +792 | ! |
- dataset_name <- input$tabset_panel+ data.frame( |
| 1057 | +793 | ! |
- varname <- plot_var$variable[[dataset_name]]+ Statistic = c("min", "Q1", "median", "mean", "Q3", "max", "sd", "n"),
|
| 1058 | +794 | ! |
- df <- data()[[dataset_name]]+ Value = c( |
| 1059 | -+ | ||
| 795 | +! |
-
+ round(min(x, na.rm = TRUE), 2), |
|
| 1060 | +796 | ! |
- var_description <- var_labels(df)[[varname]]+ qvals[1], |
| 1061 | +797 | ! |
- list(data = df[[varname]], var_description = var_description)+ qvals[2], |
| 1062 | -+ | ||
| 798 | +! |
- }+ round(mean(x, na.rm = TRUE), 2), |
|
| 1063 | -+ | ||
| 799 | +! |
-
+ qvals[3], |
|
| 1064 | -+ | ||
| 800 | +! |
- #' Renders the left-hand side `tabset` panel of the module+ round(max(x, na.rm = TRUE), 2), |
|
| 1065 | -+ | ||
| 801 | +! |
- #'+ round(stats::sd(x, na.rm = TRUE), 2), |
|
| 1066 | -+ | ||
| 802 | +! |
- #' @param datanames (`character`) the name of the dataset+ length(x[!is.na(x)]) |
|
| 1067 | +803 |
- #' @param parent_dataname (`character`) the name of a parent `dataname` to filter out variables from+ ) |
|
| 1068 | +804 |
- #' @param data (`tdata`) the object containing all datasets+ ) |
|
| 1069 | +805 |
- #' @param input (`session$input`) the shiny session input+ |
|
| 1070 | -+ | ||
| 806 | +! |
- #' @param output (`session$output`) the shiny session output+ DT::datatable(summary, rownames = FALSE, options = list(dom = "<t>", pageLength = dt_rows)) |
|
| 1071 | -+ | ||
| 807 | +! |
- #' @param columns_names (`environment`) the environment containing bindings for each dataset+ } else if (is.factor(x) || is.character(x) || (is.numeric(x) && numeric_as_factor) || is.logical(x)) {
|
|
| 1072 | +808 |
- #' @param plot_var (`list`) the list containing the currently selected dataset (tab) and its column names+ # make sure factor is ordered numeric+ |
+ |
| 809 | +! | +
+ if (is.numeric(x)) {
+ |
+ |
| 810 | +! | +
+ x <- factor(x, levels = sort(unique(x))) |
|
| 1073 | +811 |
- #' @keywords internal+ } |
|
| 1074 | +812 |
- render_tabset_panel_content <- function(datanames, parent_dataname, output, data, input, columns_names, plot_var) {
+
|
|
| 1075 | +813 | ! |
- lapply(datanames, render_single_tab,+ level_counts <- table(x) |
| 1076 | +814 | ! |
- input = input,+ max_levels_signif <- nchar(level_counts) |
| 1077 | -! | +||
| 815 | +
- output = output,+ |
||
| 1078 | +816 | ! |
- data = data,+ if (!all(is.na(x))) {
|
| 1079 | +817 | ! |
- parent_dataname = parent_dataname,+ levels <- names(level_counts) |
| 1080 | +818 | ! |
- columns_names = columns_names,+ counts <- sprintf( |
| 1081 | +819 | ! |
- plot_var = plot_var+ "%s [%.2f%%]", |
| 1082 | -+ | ||
| 820 | +! |
- )+ format(level_counts, width = max_levels_signif), prop.table(level_counts) * 100 |
|
| 1083 | +821 |
- }+ ) |
|
| 1084 | +822 |
-
+ } else {
|
|
| 1085 | -+ | ||
| 823 | +! |
- #' Renders a single tab in the left-hand side tabset panel+ levels <- character(0) |
|
| 1086 | -+ | ||
| 824 | +! |
- #'+ counts <- numeric(0) |
|
| 1087 | +825 |
- #' @description+ } |
|
| 1088 | +826 |
- #' Renders a single tab in the left-hand side tabset panel. The rendered tab contains+ |
|
| 1089 | -+ | ||
| 827 | +! |
- #' information about one dataset out of many presented in the module.+ summary <- data.frame( |
|
| 1090 | -+ | ||
| 828 | +! |
- #'+ Level = levels, |
|
| 1091 | -+ | ||
| 829 | +! |
- #' @param dataset_name (`character`) the name of the dataset contained in the rendered tab+ Count = counts, |
|
| 1092 | -+ | ||
| 830 | +! |
- #' @param parent_dataname (`character`) the name of a parent `dataname` to filter out variables from+ stringsAsFactors = FALSE |
|
| 1093 | +831 |
- #' @inheritParams render_tabset_panel_content+ ) |
|
| 1094 | +832 |
- #' @keywords internal+ |
|
| 1095 | +833 |
- render_single_tab <- function(dataset_name, parent_dataname, output, data, input, columns_names, plot_var) {
+ # sort the dataset in decreasing order of counts (needed as character variables default to alphabetical) |
|
| 1096 | +834 | ! |
- render_tab_header(dataset_name, output, data)+ summary <- summary[order(summary$Count, decreasing = TRUE), ] |
| 1097 | +835 | ||
| 1098 | +836 | ! |
- render_tab_table(+ dom_opts <- if (nrow(summary) <= 10) {
|
| 1099 | +837 | ! |
- dataset_name = dataset_name,+ "<t>" |
| 1100 | -! | +||
| 838 | +
- parent_dataname = parent_dataname,+ } else {
|
||
| 1101 | +839 | ! |
- output = output,+ "<lf<t>ip>"+ |
+
| 840 | ++ |
+ } |
|
| 1102 | +841 | ! |
- data = data,+ DT::datatable(summary, rownames = FALSE, options = list(dom = dom_opts, pageLength = dt_rows)) |
| 1103 | +842 | ! |
- input = input,+ } else if (inherits(x, "Date") || inherits(x, "POSIXct") || inherits(x, "POSIXlt")) {
|
| 1104 | +843 | ! |
- columns_names = columns_names,+ summary <- |
| 1105 | +844 | ! |
- plot_var = plot_var+ data.frame( |
| 1106 | -+ | ||
| 845 | +! |
- )+ Statistic = c("min", "median", "max"),
|
|
| 1107 | -+ | ||
| 846 | +! |
- }+ Value = c( |
|
| 1108 | -+ | ||
| 847 | +! |
-
+ min(x, na.rm = TRUE), |
|
| 1109 | -+ | ||
| 848 | +! |
- #' Renders the text headlining a single tab in the left-hand side tabset panel+ stats::median(x, na.rm = TRUE), |
|
| 1110 | -+ | ||
| 849 | +! |
- #'+ max(x, na.rm = TRUE) |
|
| 1111 | +850 |
- #' @param dataset_name (`character`) the name of the dataset of the tab+ ) |
|
| 1112 | +851 |
- #' @inheritParams render_tabset_panel_content+ ) |
|
| 1113 | -+ | ||
| 852 | +! |
- #' @keywords internal+ DT::datatable(summary, rownames = FALSE, options = list(dom = "<t>", pageLength = dt_rows)) |
|
| 1114 | +853 |
- render_tab_header <- function(dataset_name, output, data) {
- |
- |
| 1115 | -! | -
- dataset_ui_id <- paste0("dataset_summary_", dataset_name)
+ } else {
|
|
| 1116 | +854 | ! |
- output[[dataset_ui_id]] <- renderText({
+ NULL |
| 1117 | -! | +||
| 855 | +
- df <- data()[[dataset_name]]+ } |
||
| 1118 | -! | +||
| 856 | +
- join_keys <- join_keys(data())+ } |
||
| 1119 | -! | +||
| 857 | +
- if (!is.null(join_keys)) {
+
|
||
| 1120 | -! | +||
| 858 | +
- key <- join_keys(data())[dataset_name, dataset_name]+ |
||
| 1121 | +859 |
- } else {
+ #' Plot variable |
|
| 1122 | -! | +||
| 860 | +
- key <- NULL+ #' |
||
| 1123 | +861 |
- }+ #' Creates summary plot with statistics relevant to data type. |
|
| 1124 | -! | +||
| 862 | +
- sprintf(+ #' @inheritParams shared_params |
||
| 1125 | -! | +||
| 863 | +
- "Dataset with %s unique key rows and %s variables",+ #' @param var vector of any type to be plotted. For numeric variables it produces histogram with |
||
| 1126 | -! | +||
| 864 | +
- nrow(unique(`if`(length(key) > 0, df[, key, drop = FALSE], df))),+ #' density line, for factors it creates frequency plot |
||
| 1127 | -! | +||
| 865 | +
- ncol(df)+ #' @param var_lab text describing selected variable to be displayed on the plot |
||
| 1128 | +866 |
- )+ #' @param wrap_character (`numeric`) number of characters at which to wrap text values of `var` |
|
| 1129 | +867 |
- })+ #' @param numeric_as_factor (`logical`) should the numeric variable be treated as a factor |
|
| 1130 | +868 |
- }+ #' @param display_density (`logical`) should density estimation be displayed for numeric values |
|
| 1131 | +869 |
-
+ #' @param remove_NA_hist (`logical`) should (`NA`) values be removed for histogram of factor like variables |
|
| 1132 | +870 |
- #' Renders the table for a single dataset in the left-hand side tabset panel+ #' @param outlier_definition if 0 no outliers are removed, otherwise |
|
| 1133 | +871 |
- #'+ #' outliers (those more than outlier_definition*IQR below/above Q1/Q3 be removed) |
|
| 1134 | +872 |
- #' @description+ #' @param records_for_factor (`numeric`) if the number of factor levels is >= than this value then |
|
| 1135 | +873 |
- #' The table contains column names, column labels,+ #' a graph of the factors isn't shown, only a list of values |
|
| 1136 | +874 |
- #' small summary about NA values and `sparkline` (if appropriate).+ #' |
|
| 1137 | +875 |
- #'+ #' @return plot |
|
| 1138 | +876 |
- #' @param dataset_name (`character`) the name of the dataset+ #' @keywords internal |
|
| 1139 | +877 |
- #' @param parent_dataname (`character`) the name of a parent `dataname` to filter out variables from+ plot_var_summary <- function(var, |
|
| 1140 | +878 |
- #' @inheritParams render_tabset_panel_content+ var_lab, |
|
| 1141 | +879 |
- #' @keywords internal+ wrap_character = NULL, |
|
| 1142 | +880 |
- render_tab_table <- function(dataset_name, parent_dataname, output, data, input, columns_names, plot_var) {
+ numeric_as_factor, |
|
| 1143 | -! | +||
| 881 | +
- table_ui_id <- paste0("variable_browser_", dataset_name)
+ display_density = is.numeric(var), |
||
| 1144 | +882 |
-
+ remove_NA_hist = FALSE, # nolint: object_name. |
|
| 1145 | -! | +||
| 883 | +
- output[[table_ui_id]] <- DT::renderDataTable({
+ outlier_definition, |
||
| 1146 | -! | +||
| 884 | +
- df <- data()[[dataset_name]]+ records_for_factor, |
||
| 1147 | +885 |
-
+ ggplot2_args) {
|
|
| 1148 | +886 | ! |
- get_vars_df <- function(input, dataset_name, parent_name, data) {
+ checkmate::assert_character(var_lab) |
| 1149 | +887 | ! |
- data_cols <- colnames(df)+ checkmate::assert_numeric(wrap_character, null.ok = TRUE) |
| 1150 | +888 | ! |
- if (isTRUE(input$show_parent_vars)) {
+ checkmate::assert_flag(numeric_as_factor) |
| 1151 | +889 | ! |
- data_cols+ checkmate::assert_flag(display_density) |
| 1152 | +890 | ! |
- } else if (dataset_name != parent_name && parent_name %in% names(data)) {
+ checkmate::assert_logical(remove_NA_hist, null.ok = TRUE) |
| 1153 | +891 | ! |
- setdiff(data_cols, colnames(data()[[parent_name]]))+ checkmate::assert_number(outlier_definition, lower = 0, finite = TRUE) |
| 1154 | -+ | ||
| 892 | +! |
- } else {
+ checkmate::assert_integerish(records_for_factor, lower = 0, len = 1, any.missing = FALSE) |
|
| 1155 | +893 | ! |
- data_cols+ checkmate::assert_class(ggplot2_args, "ggplot2_args") |
| 1156 | +894 |
- }+ |
|
| 1157 | -+ | ||
| 895 | +! |
- }+ grid::grid.newpage() |
|
| 1158 | +896 | ||
| 1159 | +897 | ! |
- if (length(parent_dataname) > 0) {
+ plot_main <- if (is.factor(var) || is.character(var) || is.logical(var)) {
|
| 1160 | +898 | ! |
- df_vars <- get_vars_df(input, dataset_name, parent_dataname, data)+ groups <- unique(as.character(var)) |
| 1161 | +899 | ! |
- df <- df[df_vars]+ len_groups <- length(groups) |
| 1162 | -+ | ||
| 900 | +! |
- }+ if (len_groups >= records_for_factor) {
|
|
| 1163 | -+ | ||
| 901 | +! |
-
+ grid::textGrob( |
|
| 1164 | +902 | ! |
- if (is.null(df) || ncol(df) == 0) {
+ sprintf( |
| 1165 | +903 | ! |
- columns_names[[dataset_name]] <- character(0)+ "%s unique values\n%s:\n %s\n ...\n %s", |
| 1166 | +904 | ! |
- df_output <- data.frame(+ len_groups, |
| 1167 | +905 | ! |
- Type = character(0),+ var_lab, |
| 1168 | +906 | ! |
- Variable = character(0),+ paste(utils::head(groups), collapse = ",\n "), |
| 1169 | +907 | ! |
- Label = character(0),+ paste(utils::tail(groups), collapse = ",\n ")+ |
+
| 908 | ++ |
+ ), |
|
| 1170 | +909 | ! |
- Missings = character(0),+ x = grid::unit(1, "line"), |
| 1171 | +910 | ! |
- Sparklines = character(0),+ y = grid::unit(1, "npc") - grid::unit(1, "line"), |
| 1172 | +911 | ! |
- stringsAsFactors = FALSE+ just = c("left", "top")
|
| 1173 | +912 |
) |
|
| 1174 | +913 |
} else {
|
|
| 1175 | -+ | ||
| 914 | +! |
- # extract data variable labels+ if (!is.null(wrap_character)) {
|
|
| 1176 | +915 | ! |
- labels <- teal.data::col_labels(df)+ var <- stringr::str_wrap(var, width = wrap_character) |
| 1177 | +916 |
-
+ } |
|
| 1178 | +917 | ! |
- columns_names[[dataset_name]] <- names(labels)- |
-
| 1179 | -- |
-
+ var <- if (isTRUE(remove_NA_hist)) as.vector(stats::na.omit(var)) else var |
|
| 1180 | -+ | ||
| 918 | +! |
- # calculate number of missing values+ ggplot(data.frame(var), aes(x = forcats::fct_infreq(as.factor(var)))) + |
|
| 1181 | +919 | ! |
- missings <- vapply(+ geom_bar(stat = "count", aes(fill = ifelse(is.na(var), "withcolor", "")), show.legend = FALSE) + |
| 1182 | +920 | ! |
- df,+ scale_fill_manual(values = c("gray50", "tan"))
|
| 1183 | -! | +||
| 921 | +
- var_missings_info,+ } |
||
| 1184 | +922 | ! |
- FUN.VALUE = character(1),+ } else if (is.numeric(var)) {
|
| 1185 | +923 | ! |
- USE.NAMES = FALSE+ validate(need(any(!is.na(var)), "No data left to visualize.")) |
| 1186 | +924 |
- )+ |
|
| 1187 | +925 |
-
+ # Filter out NA+ |
+ |
| 926 | +! | +
+ var <- var[which(!is.na(var))] |
|
| 1188 | +927 |
- # get icons proper for the data types+ |
|
| 1189 | +928 | ! |
- icons <- vapply(df, function(x) class(x)[1L], character(1L))+ validate(need(!any(is.infinite(var)), "Cannot display graph when data includes infinite values")) |
| 1190 | +929 | ||
| 1191 | +930 | ! |
- join_keys <- join_keys(data())+ if (numeric_as_factor) {
|
| 1192 | +931 | ! |
- if (!is.null(join_keys)) {
+ var <- factor(var) |
| 1193 | +932 | ! |
- icons[intersect(join_keys[dataset_name, dataset_name], colnames(df))] <- "primary_key"- |
-
| 1194 | -- |
- }+ ggplot(NULL, aes(x = var)) + |
|
| 1195 | +933 | ! |
- icons <- variable_type_icons(icons)+ geom_histogram(stat = "count") |
| 1196 | +934 |
-
+ } else {
|
|
| 1197 | +935 |
- # generate sparklines+ # remove outliers |
|
| 1198 | +936 | ! |
- sparklines_html <- vapply(+ if (outlier_definition != 0) {
|
| 1199 | +937 | ! |
- df,+ number_records <- length(var) |
| 1200 | +938 | ! |
- create_sparklines,+ var <- remove_outliers_from(var, outlier_definition) |
| 1201 | +939 | ! |
- FUN.VALUE = character(1),+ number_outliers <- number_records - length(var) |
| 1202 | +940 | ! |
- USE.NAMES = FALSE- |
-
| 1203 | -- |
- )- |
- |
| 1204 | -- |
-
+ outlier_text <- paste0( |
|
| 1205 | +941 | ! |
- df_output <- data.frame(+ number_outliers, " outliers (",
|
| 1206 | +942 | ! |
- Type = icons,+ round(number_outliers / number_records * 100, 2), |
| 1207 | +943 | ! |
- Variable = names(labels),+ "% of non-missing records) not shown" |
| 1208 | -! | +||
| 944 | +
- Label = labels,+ ) |
||
| 1209 | +945 | ! |
- Missings = missings,+ validate(need( |
| 1210 | +946 | ! |
- Sparklines = sparklines_html,+ length(var) > 1, |
| 1211 | +947 | ! |
- stringsAsFactors = FALSE+ "At least two data points must remain after removing outliers for this graph to be displayed" |
| 1212 | +948 |
- )+ )) |
|
| 1213 | +949 |
- }+ } |
|
| 1214 | +950 |
-
+ ## histogram |
|
| 1215 | -+ | ||
| 951 | +! |
- # Select row 1 as default / fallback+ binwidth <- get_bin_width(var) |
|
| 1216 | +952 | ! |
- selected_ix <- 1+ p <- ggplot(data = data.frame(var = var), aes(x = var, y = after_stat(count))) + |
| 1217 | -+ | ||
| 953 | +! |
- # Define starting page index (base-0 index of the first item on page+ geom_histogram(binwidth = binwidth) + |
|
| 1218 | -+ | ||
| 954 | +! |
- # note: in many cases it's not the item itself+ scale_y_continuous( |
|
| 1219 | +955 | ! |
- selected_page_ix <- 0+ sec.axis = sec_axis( |
| 1220 | -+ | ||
| 956 | +! |
-
+ trans = ~ . / nrow(data.frame(var = var)), |
|
| 1221 | -+ | ||
| 957 | +! |
- # Retrieve current selected variable if any+ labels = scales::percent, |
|
| 1222 | +958 | ! |
- isolated_variable <- shiny::isolate(plot_var$variable[[dataset_name]])+ name = "proportion (in %)" |
| 1223 | +959 |
-
+ ) |
|
| 1224 | -! | +||
| 960 | +
- if (!is.null(isolated_variable)) {
+ )+ |
+ ||
| 961 | ++ | + | |
| 1225 | +962 | ! |
- index <- which(columns_names[[dataset_name]] == isolated_variable)[1]+ if (display_density) {
|
| 1226 | +963 | ! |
- if (!is.null(index) && !is.na(index) && length(index) > 0) selected_ix <- index+ p <- p + geom_density(aes(y = after_stat(count * binwidth))) |
| 1227 | +964 |
- }+ } |
|
| 1228 | +965 | ||
| 1229 | -+ | ||
| 966 | +! |
- # Retrieve the index of the first item of the current page+ if (outlier_definition != 0) {
|
|
| 1230 | -+ | ||
| 967 | +! |
- # it works with varying number of entries on the page (10, 25, ...)+ p <- p + annotate( |
|
| 1231 | +968 | ! |
- table_id_sel <- paste0("variable_browser_", dataset_name, "_state")
+ geom = "text", |
| 1232 | +969 | ! |
- dt_state <- shiny::isolate(input[[table_id_sel]])+ label = outlier_text, |
| 1233 | +970 | ! |
- if (selected_ix != 1 && !is.null(dt_state)) {
+ x = Inf, y = Inf, |
| 1234 | +971 | ! |
- selected_page_ix <- floor(selected_ix / dt_state$length) * dt_state$length+ hjust = 1.02, vjust = 1.2,+ |
+
| 972 | +! | +
+ color = "black", |
|
| 1235 | +973 |
- }+ # explicitly modify geom text size according+ |
+ |
| 974 | +! | +
+ size = ggplot2_args[["theme"]][["text"]][["size"]] / 3.5 |
|
| 1236 | +975 |
-
+ )+ |
+ |
| 976 | ++ |
+ } |
|
| 1237 | +977 | ! |
- DT::datatable(+ p+ |
+
| 978 | ++ |
+ } |
|
| 1238 | +979 | ! |
- df_output,+ } else if (inherits(var, "Date") || inherits(var, "POSIXct") || inherits(var, "POSIXlt")) {
|
| 1239 | +980 | ! |
- escape = FALSE,+ var_num <- as.numeric(var) |
| 1240 | +981 | ! |
- rownames = FALSE,+ binwidth <- get_bin_width(var_num, 1) |
| 1241 | +982 | ! |
- selection = list(mode = "single", target = "row", selected = selected_ix),+ p <- ggplot(data = data.frame(var = var), aes(x = var, y = after_stat(count))) + |
| 1242 | +983 | ! |
- options = list(+ geom_histogram(binwidth = binwidth)+ |
+
| 984 | ++ |
+ } else {
|
|
| 1243 | +985 | ! |
- fnDrawCallback = htmlwidgets::JS("function() { HTMLWidgets.staticRender(); }"),
+ grid::textGrob( |
| 1244 | +986 | ! |
- pageLength = input[[paste0(table_ui_id, "_rows")]],+ paste(strwrap( |
| 1245 | +987 | ! |
- displayStart = selected_page_ix+ utils::capture.output(utils::str(var)), |
| 1246 | -+ | ||
| 988 | +! |
- )+ width = .9 * grid::convertWidth(grid::unit(1, "npc"), "char", TRUE) |
|
| 1247 | -+ | ||
| 989 | +! |
- )+ ), collapse = "\n"),+ |
+ |
| 990 | +! | +
+ x = grid::unit(1, "line"), y = grid::unit(1, "npc") - grid::unit(1, "line"), just = c("left", "top")
|
|
| 1248 | +991 |
- })+ ) |
|
| 1249 | +992 |
- }+ } |
|
| 1250 | +993 | ||
| 1251 | -+ | ||
| 994 | +! |
- #' Creates observers updating the currently selected column+ dev_ggplot2_args <- teal.widgets::ggplot2_args( |
|
| 1252 | -+ | ||
| 995 | +! |
- #'+ labs = list(x = var_lab) |
|
| 1253 | +996 |
- #' @description+ ) |
|
| 1254 | +997 |
- #' The created observers update the column currently selected in the left-hand side+ ### |
|
| 1255 | -+ | ||
| 998 | +! |
- #' tabset panel.+ all_ggplot2_args <- teal.widgets::resolve_ggplot2_args( |
|
| 1256 | -+ | ||
| 999 | +! |
- #'+ ggplot2_args, |
|
| 1257 | -+ | ||
| 1000 | +! |
- #' @note+ module_plot = dev_ggplot2_args |
|
| 1258 | +1001 |
- #' Creates an observer for each dataset (each tab in the tabset panel).+ ) |
|
| 1259 | +1002 |
- #'+ |
|
| 1260 | -+ | ||
| 1003 | +! |
- #' @inheritParams render_tabset_panel_content+ if (is.ggplot(plot_main)) {
|
|
| 1261 | -+ | ||
| 1004 | +! |
- #' @keywords internal+ if (is.numeric(var) && !numeric_as_factor) {
|
|
| 1262 | +1005 |
- establish_updating_selection <- function(datanames, input, plot_var, columns_names) {
+ # numeric not as factor |
|
| 1263 | +1006 | ! |
- lapply(datanames, function(dataset_name) {
+ plot_main <- plot_main + |
| 1264 | +1007 | ! |
- table_ui_id <- paste0("variable_browser_", dataset_name)
+ theme_light() + |
| 1265 | +1008 | ! |
- table_id_sel <- paste0(table_ui_id, "_rows_selected")+ list( |
| 1266 | +1009 | ! |
- observeEvent(input[[table_id_sel]], {
+ labs = do.call("labs", all_ggplot2_args$labs),
|
| 1267 | +1010 | ! |
- plot_var$data <- dataset_name+ theme = do.call("theme", all_ggplot2_args$theme)
|
| 1268 | -! | +||
| 1011 | +
- plot_var$variable[[dataset_name]] <- columns_names[[dataset_name]][input[[table_id_sel]]]- |
- ||
| 1269 | -- |
- })- |
- |
| 1270 | -- |
- })- |
- |
| 1271 | -- |
- }+ ) |
|
| 1272 | +1012 |
-
+ } else {
|
|
| 1273 | +1013 |
- get_bin_width <- function(x_vec, scaling_factor = 2) {
+ # factor low number of levels OR numeric as factor OR Date |
|
| 1274 | +1014 | ! |
- x_vec <- x_vec[!is.na(x_vec)]+ plot_main <- plot_main + |
| 1275 | +1015 | ! |
- qntls <- stats::quantile(x_vec, probs = c(0.1, 0.25, 0.75, 0.9), type = 2)+ theme_light() + |
| 1276 | +1016 | ! |
- iqr <- qntls[3] - qntls[2]+ list( |
| 1277 | +1017 | ! |
- binwidth <- max(scaling_factor * iqr / length(x_vec) ^ (1 / 3), sqrt(qntls[4] - qntls[1])) # styler: off+ labs = do.call("labs", all_ggplot2_args$labs),
|
| 1278 | +1018 | ! |
- binwidth <- ifelse(binwidth == 0, 1, binwidth)+ theme = do.call("theme", all_ggplot2_args$theme)
|
| 1279 | +1019 |
- # to ensure at least two bins when variable span is very small+ ) |
|
| 1280 | -! | +||
| 1020 | +
- x_span <- diff(range(x_vec))+ } |
||
| 1281 | +1021 | ! |
- if (isTRUE(x_span / binwidth >= 2)) binwidth else x_span / 2+ plot_main <- ggplotGrob(plot_main) |
| 1282 | +1022 |
- }+ } |
|
| 1283 | +1023 | ||
| 1284 | -- |
- custom_sparkline_formatter <- function(labels, counts) {
- |
- |
| 1285 | -! | -
- htmlwidgets::JS(- |
- |
| 1286 | +1024 | ! |
- sprintf(+ grid::grid.draw(plot_main) |
| 1287 | +1025 | ! |
- "function(sparkline, options, field) {
+ plot_main |
| 1288 | -! | +||
| 1026 | +
- return 'ID: ' + %s[field[0].offset] + '<br>' + 'Count: ' + %s[field[0].offset];+ } |
||
| 1289 | +1027 |
- }",+ |
|
| 1290 | -! | +||
| 1028 | +
- jsonlite::toJSON(labels),+ is_num_var_short <- function(.unique_records_for_factor, input, data_for_analysis) {
|
||
| 1291 | +1029 | ! |
- jsonlite::toJSON(counts)+ length(unique(data_for_analysis()$data)) < .unique_records_for_factor && !is.null(input$numeric_as_factor) |
| 1292 | +1030 |
- )+ } |
|
| 1293 | +1031 |
- )+ |
|
| 1294 | +1032 |
- }+ #' Validates the variable browser inputs |
|
| 1295 | +1033 |
-
+ #' |
|
| 1296 | +1034 |
- #' Removes the outlier observation from an array+ #' @param input (`session$input`) the shiny session input |
|
| 1297 | +1035 |
- #'+ #' @param plot_var (`list`) list of a data frame and an array of variable names |
|
| 1298 | +1036 |
- #' @param var (`numeric`) a numeric vector+ #' @param data (`tdata`) the datasets passed to the module |
|
| 1299 | +1037 |
- #' @param outlier_definition (`numeric`) if `0` then no outliers are removed, otherwise+ #' |
|
| 1300 | +1038 |
- #' outliers (those more than `outlier_definition*IQR below/above Q1/Q3`) are removed+ #' @returns `logical` TRUE if validations pass; a Shiny validation error otherwise |
|
| 1301 | +1039 |
- #' @returns (`numeric`) vector without the outlier values+ #' @keywords internal |
|
| 1302 | +1040 |
- #' @keywords internal+ validate_input <- function(input, plot_var, data) {
|
|
| 1303 | -+ | ||
| 1041 | +! |
- remove_outliers_from <- function(var, outlier_definition) {
+ reactive({
|
|
| 1304 | -3x | +||
| 1042 | +! |
- if (outlier_definition == 0) {
+ dataset_name <- req(input$tabset_panel) |
|
| 1305 | -1x | +||
| 1043 | +! |
- return(var)+ varname <- plot_var$variable[[dataset_name]] |
|
| 1306 | +1044 |
- }+ |
|
| 1307 | -2x | +||
| 1045 | +! |
- q1_q3 <- stats::quantile(var, probs = c(0.25, 0.75), type = 2, na.rm = TRUE)+ validate(need(dataset_name, "No data selected")) |
|
| 1308 | -2x | +||
| 1046 | +! |
- iqr <- q1_q3[2] - q1_q3[1]+ validate(need(varname, "No variable selected")) |
|
| 1309 | -2x | +||
| 1047 | +! |
- var[var >= q1_q3[1] - outlier_definition * iqr & var <= q1_q3[2] + outlier_definition * iqr]+ df <- data()[[dataset_name]] |
|
| 1310 | -+ | ||
| 1048 | +! |
- }+ teal::validate_has_data(df, 1) |
| 1 | -+ | ||
| 1049 | +! |
- #' Create a simple cross-table+ teal::validate_has_variable(varname = varname, data = df, "Variable not available") |
|
| 2 | +1050 |
- #' @md+ |
|
| 3 | -+ | ||
| 1051 | +! |
- #'+ TRUE |
|
| 4 | +1052 |
- #' @inheritParams teal::module+ }) |
|
| 5 | +1053 |
- #' @inheritParams shared_params+ } |
|
| 6 | +1054 |
- #' @param x (`data_extract_spec` or `list` of multiple `data_extract_spec`)+ |
|
| 7 | +1055 |
- #' Object with all available choices with pre-selected option for variable X - row values. In case+ get_plotted_data <- function(input, plot_var, data) {
|
|
| 8 | -+ | ||
| 1056 | +! |
- #' of `data_extract_spec` use `select_spec(..., ordered = TRUE)` if table elements should be+ dataset_name <- input$tabset_panel |
|
| 9 | -+ | ||
| 1057 | +! |
- #' rendered according to selection order.+ varname <- plot_var$variable[[dataset_name]] |
|
| 10 | -+ | ||
| 1058 | +! |
- #' @param y (`data_extract_spec` or `list` of multiple `data_extract_spec`)+ df <- data()[[dataset_name]] |
|
| 11 | +1059 |
- #' Object with all available choices with pre-selected option for variable Y - column values+ |
|
| 12 | -+ | ||
| 1060 | +! |
- #' \code{data_extract_spec} must not allow multiple selection in this case.
+ var_description <- var_labels(df)[[varname]] |
|
| 13 | -+ | ||
| 1061 | +! |
- #'+ list(data = df[[varname]], var_description = var_description) |
|
| 14 | +1062 |
- #' @param show_percentage optional, (`logical`) Whether to show percentages+ } |
|
| 15 | +1063 |
- #' (relevant only when `x` is a `factor`). Defaults to `TRUE`.+ |
|
| 16 | +1064 |
- #' @param show_total optional, (`logical`) Whether to show total column. Defaults to `TRUE`.+ #' Renders the left-hand side `tabset` panel of the module |
|
| 17 | +1065 |
#' |
|
| 18 | +1066 |
- #' @note For more examples, please see the vignette "Using cross table" via+ #' @param datanames (`character`) the name of the dataset |
|
| 19 | +1067 |
- #' `vignette("using-cross-table", package = "teal.modules.general")`.
+ #' @param parent_dataname (`character`) the name of a parent `dataname` to filter out variables from |
|
| 20 | +1068 |
- #'+ #' @param data (`tdata`) the object containing all datasets |
|
| 21 | +1069 |
- #' @export+ #' @param input (`session$input`) the shiny session input |
|
| 22 | +1070 |
- #'+ #' @param output (`session$output`) the shiny session output |
|
| 23 | +1071 |
- #' @examples+ #' @param columns_names (`environment`) the environment containing bindings for each dataset |
|
| 24 | +1072 |
- #' # Percentage cross table of variables from ADSL dataset+ #' @param plot_var (`list`) the list containing the currently selected dataset (tab) and its column names |
|
| 25 | +1073 |
- #'+ #' @keywords internal |
|
| 26 | +1074 |
- #' data <- teal_data()+ render_tabset_panel_content <- function(datanames, parent_dataname, output, data, input, columns_names, plot_var) {
|
|
| 27 | -+ | ||
| 1075 | +! |
- #' data <- within(data, {
+ lapply(datanames, render_single_tab, |
|
| 28 | -+ | ||
| 1076 | +! |
- #' ADSL <- teal.modules.general::rADSL+ input = input, |
|
| 29 | -+ | ||
| 1077 | +! |
- #' })+ output = output, |
|
| 30 | -+ | ||
| 1078 | +! |
- #' datanames <- c("ADSL")
+ data = data, |
|
| 31 | -+ | ||
| 1079 | +! |
- #' datanames(data) <- datanames+ parent_dataname = parent_dataname, |
|
| 32 | -+ | ||
| 1080 | +! |
- #' join_keys(data) <- default_cdisc_join_keys[datanames]+ columns_names = columns_names, |
|
| 33 | -+ | ||
| 1081 | +! |
- #'+ plot_var = plot_var |
|
| 34 | +1082 |
- #' app <- teal::init(+ ) |
|
| 35 | +1083 |
- #' data = data,+ } |
|
| 36 | +1084 |
- #' modules = teal::modules(+ |
|
| 37 | +1085 |
- #' teal.modules.general::tm_t_crosstable(+ #' Renders a single tab in the left-hand side tabset panel |
|
| 38 | +1086 |
- #' label = "Cross Table",+ #' |
|
| 39 | +1087 |
- #' x = teal.transform::data_extract_spec(+ #' @description |
|
| 40 | +1088 |
- #' dataname = "ADSL",+ #' Renders a single tab in the left-hand side tabset panel. The rendered tab contains |
|
| 41 | +1089 |
- #' select = teal.transform::select_spec(+ #' information about one dataset out of many presented in the module. |
|
| 42 | +1090 |
- #' label = "Select variable:",+ #' |
|
| 43 | +1091 |
- #' choices = variable_choices(data[["ADSL"]], subset = function(data) {
+ #' @param dataset_name (`character`) the name of the dataset contained in the rendered tab |
|
| 44 | +1092 |
- #' idx <- !vapply(data, inherits, logical(1), c("Date", "POSIXct", "POSIXlt"))
+ #' @param parent_dataname (`character`) the name of a parent `dataname` to filter out variables from |
|
| 45 | +1093 |
- #' return(names(data)[idx])+ #' @inheritParams render_tabset_panel_content |
|
| 46 | +1094 |
- #' }),+ #' @keywords internal |
|
| 47 | +1095 |
- #' selected = "COUNTRY",+ render_single_tab <- function(dataset_name, parent_dataname, output, data, input, columns_names, plot_var) {
|
|
| 48 | -+ | ||
| 1096 | +! |
- #' multiple = TRUE,+ render_tab_header(dataset_name, output, data) |
|
| 49 | +1097 |
- #' ordered = TRUE,+ |
|
| 50 | -+ | ||
| 1098 | +! |
- #' fixed = FALSE+ render_tab_table( |
|
| 51 | -+ | ||
| 1099 | +! |
- #' )+ dataset_name = dataset_name, |
|
| 52 | -+ | ||
| 1100 | +! |
- #' ),+ parent_dataname = parent_dataname, |
|
| 53 | -- |
- #' y = teal.transform::data_extract_spec(+ | |
| 1101 | +! | +
+ output = output, |
|
| 54 | -+ | ||
| 1102 | +! |
- #' dataname = "ADSL",+ data = data, |
|
| 55 | -+ | ||
| 1103 | +! |
- #' select = teal.transform::select_spec(+ input = input, |
|
| 56 | -+ | ||
| 1104 | +! |
- #' label = "Select variable:",+ columns_names = columns_names, |
|
| 57 | -+ | ||
| 1105 | +! |
- #' choices = variable_choices(data[["ADSL"]], subset = function(data) {
+ plot_var = plot_var |
|
| 58 | +1106 |
- #' idx <- vapply(data, is.factor, logical(1))+ ) |
|
| 59 | +1107 |
- #' return(names(data)[idx])+ } |
|
| 60 | +1108 |
- #' }),+ |
|
| 61 | +1109 |
- #' selected = "SEX",+ #' Renders the text headlining a single tab in the left-hand side tabset panel |
|
| 62 | +1110 |
- #' multiple = FALSE,+ #' |
|
| 63 | +1111 |
- #' fixed = FALSE+ #' @param dataset_name (`character`) the name of the dataset of the tab |
|
| 64 | +1112 |
- #' )+ #' @inheritParams render_tabset_panel_content |
|
| 65 | +1113 |
- #' ),+ #' @keywords internal |
|
| 66 | +1114 |
- #' basic_table_args = teal.widgets::basic_table_args(+ render_tab_header <- function(dataset_name, output, data) {
|
|
| 67 | -+ | ||
| 1115 | +! |
- #' subtitles = "Table generated by Crosstable Module"+ dataset_ui_id <- paste0("dataset_summary_", dataset_name)
|
|
| 68 | -+ | ||
| 1116 | +! |
- #' )+ output[[dataset_ui_id]] <- renderText({
|
|
| 69 | -+ | ||
| 1117 | +! |
- #' )+ df <- data()[[dataset_name]] |
|
| 70 | -+ | ||
| 1118 | +! |
- #' )+ join_keys <- join_keys(data())+ |
+ |
| 1119 | +! | +
+ if (!is.null(join_keys)) {
+ |
+ |
| 1120 | +! | +
+ key <- join_keys(data())[dataset_name, dataset_name] |
|
| 71 | +1121 |
- #' )+ } else {
+ |
+ |
| 1122 | +! | +
+ key <- NULL |
|
| 72 | +1123 |
- #' if (interactive()) {
+ }+ |
+ |
| 1124 | +! | +
+ sprintf(+ |
+ |
| 1125 | +! | +
+ "Dataset with %s unique key rows and %s variables",+ |
+ |
| 1126 | +! | +
+ nrow(unique(`if`(length(key) > 0, df[, key, drop = FALSE], df))),+ |
+ |
| 1127 | +! | +
+ ncol(df) |
|
| 73 | +1128 |
- #' shinyApp(app$ui, app$server)+ ) |
|
| 74 | +1129 |
- #' }+ }) |
|
| 75 | +1130 |
- tm_t_crosstable <- function(label = "Cross Table",+ } |
|
| 76 | +1131 |
- x,+ |
|
| 77 | +1132 |
- y,+ #' Renders the table for a single dataset in the left-hand side tabset panel |
|
| 78 | +1133 |
- show_percentage = TRUE,+ #' |
|
| 79 | +1134 |
- show_total = TRUE,+ #' @description |
|
| 80 | +1135 |
- pre_output = NULL,+ #' The table contains column names, column labels, |
|
| 81 | +1136 |
- post_output = NULL,+ #' small summary about NA values and `sparkline` (if appropriate). |
|
| 82 | +1137 |
- basic_table_args = teal.widgets::basic_table_args()) {
+ #' |
|
| 83 | -! | +||
| 1138 | +
- logger::log_info("Initializing tm_t_crosstable")
+ #' @param dataset_name (`character`) the name of the dataset |
||
| 84 | -! | +||
| 1139 | +
- if (!requireNamespace("rtables", quietly = TRUE)) {
+ #' @param parent_dataname (`character`) the name of a parent `dataname` to filter out variables from |
||
| 85 | -! | +||
| 1140 | +
- stop("Cannot load rtables - please install the package or restart your session.")
+ #' @inheritParams render_tabset_panel_content |
||
| 86 | +1141 |
- }+ #' @keywords internal |
|
| 87 | -! | +||
| 1142 | +
- if (inherits(x, "data_extract_spec")) x <- list(x)+ render_tab_table <- function(dataset_name, parent_dataname, output, data, input, columns_names, plot_var) {
|
||
| 88 | +1143 | ! |
- if (inherits(y, "data_extract_spec")) y <- list(y)+ table_ui_id <- paste0("variable_browser_", dataset_name)
|
| 89 | +1144 | ||
| 90 | +1145 | ! |
- checkmate::assert_string(label)+ output[[table_ui_id]] <- DT::renderDataTable({
|
| 91 | +1146 | ! |
- checkmate::assert_list(x, types = "data_extract_spec")+ df <- data()[[dataset_name]] |
| 92 | -! | +||
| 1147 | +
- checkmate::assert_list(y, types = "data_extract_spec")+ |
||
| 93 | +1148 | ! |
- if (any(vapply(y, function(x) x$select$multiple, logical(1)))) {
+ get_vars_df <- function(input, dataset_name, parent_name, data) {
|
| 94 | +1149 | ! |
- stop("'y' should not allow multiple selection")
+ data_cols <- colnames(df) |
| 95 | -+ | ||
| 1150 | +! |
- }+ if (isTRUE(input$show_parent_vars)) {
|
|
| 96 | +1151 | ! |
- checkmate::assert_flag(show_percentage)+ data_cols |
| 97 | +1152 | ! |
- checkmate::assert_flag(show_total)+ } else if (dataset_name != parent_name && parent_name %in% names(data)) {
|
| 98 | +1153 | ! |
- checkmate::assert_class(basic_table_args, classes = "basic_table_args")+ setdiff(data_cols, colnames(data()[[parent_name]])) |
| 99 | +1154 |
-
+ } else {
|
|
| 100 | +1155 | ! |
- ui_args <- as.list(environment())+ data_cols |
| 101 | +1156 |
-
+ } |
|
| 102 | -! | +||
| 1157 | +
- server_args <- list(+ } |
||
| 103 | -! | +||
| 1158 | +
- label = label,+ |
||
| 104 | +1159 | ! |
- x = x,+ if (length(parent_dataname) > 0) {
|
| 105 | +1160 | ! |
- y = y,+ df_vars <- get_vars_df(input, dataset_name, parent_dataname, data) |
| 106 | +1161 | ! |
- basic_table_args = basic_table_args+ df <- df[df_vars] |
| 107 | +1162 |
- )+ } |
|
| 108 | +1163 | ||
| 109 | +1164 | ! |
- module(+ if (is.null(df) || ncol(df) == 0) {
|
| 110 | +1165 | ! |
- label = label,+ columns_names[[dataset_name]] <- character(0) |
| 111 | +1166 | ! |
- server = srv_t_crosstable,+ df_output <- data.frame( |
| 112 | +1167 | ! |
- ui = ui_t_crosstable,+ Type = character(0), |
| 113 | +1168 | ! |
- ui_args = ui_args,+ Variable = character(0), |
| 114 | +1169 | ! |
- server_args = server_args,+ Label = character(0), |
| 115 | +1170 | ! |
- datanames = teal.transform::get_extract_datanames(list(x = x, y = y))+ Missings = character(0), |
| 116 | -+ | ||
| 1171 | +! |
- )+ Sparklines = character(0),+ |
+ |
| 1172 | +! | +
+ stringsAsFactors = FALSE |
|
| 117 | +1173 |
- }+ ) |
|
| 118 | +1174 |
-
+ } else {
|
|
| 119 | +1175 |
- ui_t_crosstable <- function(id, x, y, show_percentage, show_total, pre_output, post_output, ...) {
+ # extract data variable labels |
|
| 120 | +1176 | ! |
- ns <- NS(id)+ labels <- teal.data::col_labels(df)+ |
+
| 1177 | ++ | + | |
| 121 | +1178 | ! |
- is_single_dataset <- teal.transform::is_single_dataset(x, y)+ columns_names[[dataset_name]] <- names(labels) |
| 122 | +1179 | ||
| 1180 | ++ |
+ # calculate number of missing values+ |
+ |
| 123 | +1181 | ! |
- join_default_options <- c(+ missings <- vapply( |
| 124 | +1182 | ! |
- "Full Join" = "dplyr::full_join",+ df, |
| 125 | +1183 | ! |
- "Inner Join" = "dplyr::inner_join",+ var_missings_info, |
| 126 | +1184 | ! |
- "Left Join" = "dplyr::left_join",+ FUN.VALUE = character(1), |
| 127 | +1185 | ! |
- "Right Join" = "dplyr::right_join"+ USE.NAMES = FALSE |
| 128 | +1186 |
- )+ ) |
|
| 129 | +1187 | ||
| 1188 | ++ |
+ # get icons proper for the data types+ |
+ |
| 130 | +1189 | ! |
- teal.widgets::standard_layout(+ icons <- vapply(df, function(x) class(x)[1L], character(1L))+ |
+
| 1190 | ++ | + | |
| 131 | +1191 | ! |
- output = teal.widgets::white_small_well(+ join_keys <- join_keys(data()) |
| 132 | +1192 | ! |
- textOutput(ns("title")),
+ if (!is.null(join_keys)) {
|
| 133 | +1193 | ! |
- teal.widgets::table_with_settings_ui(ns("table"))
+ icons[intersect(join_keys[dataset_name, dataset_name], colnames(df))] <- "primary_key" |
| 134 | +1194 |
- ),+ } |
|
| 135 | +1195 | ! |
- encoding = div(+ icons <- variable_type_icons(icons) |
| 136 | +1196 |
- ### Reporter- |
- |
| 137 | -! | -
- teal.reporter::simple_reporter_ui(ns("simple_reporter")),
+
|
|
| 138 | +1197 |
- ###+ # generate sparklines |
|
| 139 | +1198 | ! |
- tags$label("Encodings", class = "text-primary"),
+ sparklines_html <- vapply( |
| 140 | +1199 | ! |
- teal.transform::datanames_input(list(x, y)),+ df, |
| 141 | +1200 | ! |
- teal.transform::data_extract_ui(ns("x"), label = "Row values", x, is_single_dataset = is_single_dataset),
+ create_sparklines, |
| 142 | +1201 | ! |
- teal.transform::data_extract_ui(ns("y"), label = "Column values", y, is_single_dataset = is_single_dataset),
+ FUN.VALUE = character(1), |
| 143 | +1202 | ! |
- teal.widgets::optionalSelectInput(+ USE.NAMES = FALSE |
| 144 | -! | +||
| 1203 | +
- ns("join_fun"),
+ ) |
||
| 145 | -! | +||
| 1204 | +
- label = "Row to Column type of join",+ |
||
| 146 | +1205 | ! |
- choices = join_default_options,+ df_output <- data.frame( |
| 147 | +1206 | ! |
- selected = join_default_options[1],+ Type = icons, |
| 148 | +1207 | ! |
- multiple = FALSE+ Variable = names(labels), |
| 149 | -+ | ||
| 1208 | +! |
- ),+ Label = labels, |
|
| 150 | +1209 | ! |
- tags$hr(),+ Missings = missings, |
| 151 | +1210 | ! |
- teal.widgets::panel_group(+ Sparklines = sparklines_html, |
| 152 | +1211 | ! |
- teal.widgets::panel_item(+ stringsAsFactors = FALSE |
| 153 | -! | +||
| 1212 | +
- title = "Table settings",+ ) |
||
| 154 | -! | +||
| 1213 | +
- checkboxInput(ns("show_percentage"), "Show column percentage", value = show_percentage),
+ } |
||
| 155 | -! | +||
| 1214 | +
- checkboxInput(ns("show_total"), "Show total column", value = show_total)
+
|
||
| 156 | +1215 |
- )+ # Select row 1 as default / fallback+ |
+ |
| 1216 | +! | +
+ selected_ix <- 1 |
|
| 157 | +1217 |
- )+ # Define starting page index (base-0 index of the first item on page |
|
| 158 | +1218 |
- ),+ # note: in many cases it's not the item itself |
|
| 159 | +1219 | ! |
- forms = tagList(+ selected_page_ix <- 0 |
| 160 | -! | +||
| 1220 | +
- teal.widgets::verbatim_popup_ui(ns("warning"), "Show Warnings"),
+
+ |
+ ||
| 1221 | ++ |
+ # Retrieve current selected variable if any |
|
| 161 | +1222 | ! |
- teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code")
+ isolated_variable <- shiny::isolate(plot_var$variable[[dataset_name]]) |
| 162 | +1223 |
- ),+ |
|
| 163 | +1224 | ! |
- pre_output = pre_output,+ if (!is.null(isolated_variable)) {
|
| 164 | +1225 | ! |
- post_output = post_output+ index <- which(columns_names[[dataset_name]] == isolated_variable)[1]+ |
+
| 1226 | +! | +
+ if (!is.null(index) && !is.na(index) && length(index) > 0) selected_ix <- index |
|
| 165 | +1227 |
- )+ } |
|
| 166 | +1228 |
- }+ |
|
| 167 | +1229 |
-
+ # Retrieve the index of the first item of the current page |
|
| 168 | +1230 |
- srv_t_crosstable <- function(id, data, reporter, filter_panel_api, label, x, y, basic_table_args) {
+ # it works with varying number of entries on the page (10, 25, ...) |
|
| 169 | +1231 | ! |
- with_reporter <- !missing(reporter) && inherits(reporter, "Reporter")+ table_id_sel <- paste0("variable_browser_", dataset_name, "_state")
|
| 170 | +1232 | ! |
- with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI")+ dt_state <- shiny::isolate(input[[table_id_sel]]) |
| 171 | +1233 | ! |
- checkmate::assert_class(data, "reactive")+ if (selected_ix != 1 && !is.null(dt_state)) {
|
| 172 | +1234 | ! |
- checkmate::assert_class(isolate(data()), "teal_data")+ selected_page_ix <- floor(selected_ix / dt_state$length) * dt_state$length+ |
+
| 1235 | ++ |
+ }+ |
+ |
| 1236 | ++ | + | |
| 173 | +1237 | ! |
- moduleServer(id, function(input, output, session) {
+ DT::datatable( |
| 174 | +1238 | ! |
- selector_list <- teal.transform::data_extract_multiple_srv(+ df_output, |
| 175 | +1239 | ! |
- data_extract = list(x = x, y = y),+ escape = FALSE, |
| 176 | +1240 | ! |
- datasets = data,+ rownames = FALSE, |
| 177 | +1241 | ! |
- select_validation_rule = list(+ selection = list(mode = "single", target = "row", selected = selected_ix), |
| 178 | +1242 | ! |
- x = shinyvalidate::sv_required("Please define column for row variable."),
+ options = list( |
| 179 | +1243 | ! |
- y = shinyvalidate::sv_required("Please define column for column variable.")
+ fnDrawCallback = htmlwidgets::JS("function() { HTMLWidgets.staticRender(); }"),
+ |
+
| 1244 | +! | +
+ pageLength = input[[paste0(table_ui_id, "_rows")]],+ |
+ |
| 1245 | +! | +
+ displayStart = selected_page_ix |
|
| 180 | +1246 |
) |
|
| 181 | +1247 |
) |
|
| 182 | +1248 |
-
+ }) |
|
| 183 | -! | +||
| 1249 | +
- iv_r <- reactive({
+ } |
||
| 184 | -! | +||
| 1250 | +
- iv <- shinyvalidate::InputValidator$new()+ |
||
| 185 | -! | +||
| 1251 | +
- iv$add_rule("join_fun", function(value) {
+ #' Creates observers updating the currently selected column |
||
| 186 | -! | +||
| 1252 | +
- if (!identical(selector_list()$x()$dataname, selector_list()$y()$dataname)) {
+ #' |
||
| 187 | -! | +||
| 1253 | +
- if (!shinyvalidate::input_provided(value)) {
+ #' @description |
||
| 188 | -! | +||
| 1254 | +
- "Please select a joining function."+ #' The created observers update the column currently selected in the left-hand side |
||
| 189 | +1255 |
- }+ #' tabset panel. |
|
| 190 | +1256 |
- }+ #' |
|
| 191 | +1257 |
- })+ #' @note |
|
| 192 | -! | +||
| 1258 | +
- teal.transform::compose_and_enable_validators(iv, selector_list)+ #' Creates an observer for each dataset (each tab in the tabset panel). |
||
| 193 | +1259 |
- })+ #' |
|
| 194 | +1260 |
-
+ #' @inheritParams render_tabset_panel_content |
|
| 195 | -! | +||
| 1261 | +
- observeEvent(+ #' @keywords internal |
||
| 196 | -! | +||
| 1262 | +
- eventExpr = {
+ establish_updating_selection <- function(datanames, input, plot_var, columns_names) {
|
||
| 197 | +1263 | ! |
- req(!is.null(selector_list()$x()) && !is.null(selector_list()$y()))+ lapply(datanames, function(dataset_name) {
|
| 198 | +1264 | ! |
- list(selector_list()$x(), selector_list()$y())+ table_ui_id <- paste0("variable_browser_", dataset_name)
|
| 199 | -+ | ||
| 1265 | +! |
- },+ table_id_sel <- paste0(table_ui_id, "_rows_selected") |
|
| 200 | +1266 | ! |
- handlerExpr = {
+ observeEvent(input[[table_id_sel]], {
|
| 201 | +1267 | ! |
- if (identical(selector_list()$x()$dataname, selector_list()$y()$dataname)) {
+ plot_var$data <- dataset_name |
| 202 | +1268 | ! |
- shinyjs::hide("join_fun")
+ plot_var$variable[[dataset_name]] <- columns_names[[dataset_name]][input[[table_id_sel]]] |
| 203 | +1269 |
- } else {
+ }) |
|
| 204 | -! | +||
| 1270 | +
- shinyjs::show("join_fun")
+ }) |
||
| 205 | +1271 |
- }+ } |
|
| 206 | +1272 |
- }+ |
|
| 207 | +1273 |
- )+ get_bin_width <- function(x_vec, scaling_factor = 2) {
|
|
| 208 | -+ | ||
| 1274 | +! |
-
+ x_vec <- x_vec[!is.na(x_vec)] |
|
| 209 | +1275 | ! |
- merge_function <- reactive({
+ qntls <- stats::quantile(x_vec, probs = c(0.1, 0.25, 0.75, 0.9), type = 2) |
| 210 | +1276 | ! |
- if (is.null(input$join_fun)) {
+ iqr <- qntls[3] - qntls[2] |
| 211 | +1277 | ! |
- "dplyr::full_join"+ binwidth <- max(scaling_factor * iqr / length(x_vec) ^ (1 / 3), sqrt(qntls[4] - qntls[1])) # styler: off+ |
+
| 1278 | +! | +
+ binwidth <- ifelse(binwidth == 0, 1, binwidth) |
|
| 212 | +1279 |
- } else {
+ # to ensure at least two bins when variable span is very small |
|
| 213 | +1280 | ! |
- input$join_fun+ x_span <- diff(range(x_vec)) |
| 214 | -+ | ||
| 1281 | +! |
- }+ if (isTRUE(x_span / binwidth >= 2)) binwidth else x_span / 2 |
|
| 215 | +1282 |
- })+ } |
|
| 216 | +1283 | ||
| 217 | -! | +||
| 1284 | +
- anl_merged_input <- teal.transform::merge_expression_srv(+ custom_sparkline_formatter <- function(labels, counts) {
|
||
| 218 | +1285 | ! |
- datasets = data,+ htmlwidgets::JS( |
| 219 | +1286 | ! |
- selector_list = selector_list,+ sprintf( |
| 220 | +1287 | ! |
- merge_function = merge_function+ "function(sparkline, options, field) {
|
| 221 | -+ | ||
| 1288 | +! |
- )+ return 'ID: ' + %s[field[0].offset] + '<br>' + 'Count: ' + %s[field[0].offset]; |
|
| 222 | +1289 |
-
+ }", |
|
| 223 | +1290 | ! |
- anl_merged_q <- reactive({
+ jsonlite::toJSON(labels), |
| 224 | +1291 | ! |
- req(anl_merged_input())+ jsonlite::toJSON(counts) |
| 225 | -! | +||
| 1292 | +
- data() %>%+ ) |
||
| 226 | -! | +||
| 1293 | +
- teal.code::eval_code(as.expression(anl_merged_input()$expr))+ ) |
||
| 227 | +1294 |
- })+ } |
|
| 228 | +1295 | ||
| 229 | -! | +||
| 1296 | +
- merged <- list(+ #' Removes the outlier observation from an array |
||
| 230 | -! | +||
| 1297 | +
- anl_input_r = anl_merged_input,+ #' |
||
| 231 | -! | +||
| 1298 | +
- anl_q_r = anl_merged_q+ #' @param var (`numeric`) a numeric vector |
||
| 232 | +1299 |
- )+ #' @param outlier_definition (`numeric`) if `0` then no outliers are removed, otherwise |
|
| 233 | +1300 | - - | -|
| 234 | -! | -
- output_q <- reactive({
- |
- |
| 235 | -! | -
- teal::validate_inputs(iv_r())+ #' outliers (those more than `outlier_definition*IQR below/above Q1/Q3`) are removed |
|
| 236 | -! | +||
| 1301 | +
- ANL <- merged$anl_q_r()[["ANL"]] # nolint object_name_linter+ #' @returns (`numeric`) vector without the outlier values |
||
| 237 | +1302 |
-
+ #' @keywords internal |
|
| 238 | +1303 |
- # As this is a summary+ remove_outliers_from <- function(var, outlier_definition) {
|
|
| 239 | -! | +||
| 1304 | +3x |
- x_name <- as.vector(merged$anl_input_r()$columns_source$x)+ if (outlier_definition == 0) {
|
|
| 240 | -! | +||
| 1305 | +1x |
- y_name <- as.vector(merged$anl_input_r()$columns_source$y)+ return(var) |
|
| 241 | +1306 |
-
+ } |
|
| 242 | -! | +||
| 1307 | +2x |
- teal::validate_has_data(ANL, 3)+ q1_q3 <- stats::quantile(var, probs = c(0.25, 0.75), type = 2, na.rm = TRUE) |
|
| 243 | -! | +||
| 1308 | +2x |
- teal::validate_has_data(ANL[, c(x_name, y_name)], 3, complete = TRUE, allow_inf = FALSE)+ iqr <- q1_q3[2] - q1_q3[1] |
|
| 244 | -+ | ||
| 1309 | +2x |
-
+ var[var >= q1_q3[1] - outlier_definition * iqr & var <= q1_q3[2] + outlier_definition * iqr] |
|
| 245 | -! | +||
| 1310 | +
- is_allowed_class <- function(x) is.numeric(x) || is.factor(x) || is.character(x) || is.logical(x)+ } |
||
| 246 | -! | +
| 1 | +
- validate(need(+ #' Stack Plots of variables and show association with reference variable |
||
| 247 | -! | +||
| 2 | +
- all(vapply(ANL[x_name], is_allowed_class, logical(1))),+ #' @md |
||
| 248 | -! | +||
| 3 | +
- "Selected row variable has an unsupported data type."+ #' |
||
| 249 | +4 |
- ))+ #' @inheritParams teal::module |
|
| 250 | -! | +||
| 5 | +
- validate(need(+ #' @inheritParams shared_params |
||
| 251 | -! | +||
| 6 | +
- is_allowed_class(ANL[[y_name]]),+ #' @param ref (`data_extract_spec` or `list` of multiple `data_extract_spec`) |
||
| 252 | -! | +||
| 7 | +
- "Selected column variable has an unsupported data type."+ #' reference variable, must set `multiple = FALSE`. |
||
| 253 | +8 |
- ))+ #' @param vars (`data_extract_spec` or `list` of multiple `data_extract_spec`) |
|
| 254 | +9 |
-
+ #' associated variables. |
|
| 255 | -! | +||
| 10 | +
- show_percentage <- input$show_percentage+ #' @param show_association optional, (`logical`) Whether show association of `vars` |
||
| 256 | -! | +||
| 11 | +
- show_total <- input$show_total+ #' with reference variable. Defaults to `TRUE`. |
||
| 257 | +12 |
-
+ #' @param distribution_theme,association_theme optional, (`character`) `ggplot2` themes to be used by default. |
|
| 258 | -! | +||
| 13 | +
- plot_title <- paste(+ #' Default to `"gray"`. |
||
| 259 | -! | +||
| 14 | +
- "Cross-Table of",+ #' |
||
| 260 | -! | +||
| 15 | +
- paste0(varname_w_label(x_name, ANL), collapse = ", "),+ #' @templateVar ggnames "Bivariate1", "Bivariate2" |
||
| 261 | -! | +||
| 16 | +
- "(rows)", "vs.",+ #' @template ggplot2_args_multi |
||
| 262 | -! | +||
| 17 | +
- varname_w_label(y_name, ANL),+ #' |
||
| 263 | -! | +||
| 18 | +
- "(columns)"+ #' @note For more examples, please see the vignette "Using association plot" via |
||
| 264 | +19 |
- )+ #' \code{vignette("using-association-plot", package = "teal.modules.general")}.
|
|
| 265 | +20 |
-
+ #' @export |
|
| 266 | -! | +||
| 21 | +
- labels_vec <- vapply(+ #' @examples |
||
| 267 | -! | +||
| 22 | +
- x_name,+ #' # Association plot of selected reference variable (SEX) |
||
| 268 | -! | +||
| 23 | +
- varname_w_label,+ #' # against other selected variables (BMRKR1) |
||
| 269 | -! | +||
| 24 | +
- character(1),+ #' data <- teal_data() |
||
| 270 | -! | +||
| 25 | +
- ANL+ #' data <- within(data, {
|
||
| 271 | +26 |
- )+ #' library(nestcolor) |
|
| 272 | +27 |
-
+ #' ADSL <- teal.modules.general::rADSL |
|
| 273 | -! | +||
| 28 | +
- teal.code::eval_code(+ #' }) |
||
| 274 | -! | +||
| 29 | +
- merged$anl_q_r(),+ #' datanames <- c("ADSL")
|
||
| 275 | -! | +||
| 30 | +
- substitute(+ #' datanames(data) <- datanames |
||
| 276 | -! | +||
| 31 | +
- expr = {
+ #' join_keys(data) <- default_cdisc_join_keys[datanames] |
||
| 277 | -! | +||
| 32 | +
- title <- plot_title+ #' |
||
| 278 | +33 |
- },+ #' app <- teal::init( |
|
| 279 | -! | +||
| 34 | +
- env = list(plot_title = plot_title)+ #' data = data, |
||
| 280 | +35 |
- )+ #' modules = teal::modules( |
|
| 281 | +36 |
- ) %>%+ #' teal.modules.general::tm_g_association( |
|
| 282 | -! | +||
| 37 | +
- teal.code::eval_code(+ #' ref = teal.transform::data_extract_spec( |
||
| 283 | -! | +||
| 38 | +
- substitute(+ #' dataname = "ADSL", |
||
| 284 | -! | +||
| 39 | +
- expr = {
+ #' select = teal.transform::select_spec( |
||
| 285 | -! | +||
| 40 | +
- lyt <- basic_tables %>%+ #' label = "Select variable:", |
||
| 286 | -! | +||
| 41 | +
- split_call %>% # styler: off+ #' choices = teal.transform::variable_choices( |
||
| 287 | -! | +||
| 42 | +
- rtables::add_colcounts() %>%+ #' data[["ADSL"]], |
||
| 288 | -! | +||
| 43 | +
- tern::analyze_vars(+ #' c("SEX", "RACE", "COUNTRY", "ARM", "STRATA1", "STRATA2", "ITTFL", "BMRKR2")
|
||
| 289 | -! | +||
| 44 | +
- vars = x_name,+ #' ), |
||
| 290 | -! | +||
| 45 | +
- var_labels = labels_vec,+ #' selected = "RACE", |
||
| 291 | -! | +||
| 46 | +
- na.rm = FALSE,+ #' fixed = FALSE |
||
| 292 | -! | +||
| 47 | +
- denom = "N_col",+ #' ) |
||
| 293 | -! | +||
| 48 | +
- .stats = c("mean_sd", "median", "range", count_value)
+ #' ), |
||
| 294 | +49 |
- )+ #' vars = teal.transform::data_extract_spec( |
|
| 295 | +50 |
- },+ #' dataname = "ADSL", |
|
| 296 | -! | +||
| 51 | +
- env = list(+ #' select = teal.transform::select_spec( |
||
| 297 | -! | +||
| 52 | +
- basic_tables = teal.widgets::parse_basic_table_args(+ #' label = "Select variables:", |
||
| 298 | -! | +||
| 53 | +
- basic_table_args = teal.widgets::resolve_basic_table_args(basic_table_args)+ #' choices = teal.transform::variable_choices( |
||
| 299 | +54 |
- ),+ #' data[["ADSL"]], |
|
| 300 | -! | +||
| 55 | +
- split_call = if (show_total) {
+ #' c("SEX", "RACE", "COUNTRY", "ARM", "STRATA1", "STRATA2", "ITTFL", "BMRKR2")
|
||
| 301 | -! | +||
| 56 | +
- substitute(+ #' ), |
||
| 302 | -! | +||
| 57 | +
- expr = rtables::split_cols_by(+ #' selected = "BMRKR2", |
||
| 303 | -! | +||
| 58 | +
- y_name,+ #' multiple = TRUE, |
||
| 304 | -! | +||
| 59 | +
- split_fun = rtables::add_overall_level(label = "Total", first = FALSE)+ #' fixed = FALSE |
||
| 305 | +60 |
- ),- |
- |
| 306 | -! | -
- env = list(y_name = y_name)+ #' ) |
|
| 307 | +61 |
- )+ #' ), |
|
| 308 | +62 |
- } else {
- |
- |
| 309 | -! | -
- substitute(rtables::split_cols_by(y_name), env = list(y_name = y_name))+ #' ggplot2_args = teal.widgets::ggplot2_args( |
|
| 310 | +63 |
- },+ #' labs = list(subtitle = "Plot generated by Association Module") |
|
| 311 | -! | +||
| 64 | +
- x_name = x_name,+ #' ) |
||
| 312 | -! | +||
| 65 | +
- labels_vec = labels_vec,+ #' ) |
||
| 313 | -! | +||
| 66 | +
- count_value = ifelse(show_percentage, "count_fraction", "count")+ #' ) |
||
| 314 | +67 |
- )+ #' ) |
|
| 315 | +68 |
- )+ #' if (interactive()) {
|
|
| 316 | +69 |
- ) %>%+ #' shinyApp(app$ui, app$server) |
|
| 317 | -! | +||
| 70 | +
- teal.code::eval_code(+ #' } |
||
| 318 | -! | +||
| 71 | +
- substitute(+ tm_g_association <- function(label = "Association", |
||
| 319 | -! | +||
| 72 | +
- expr = {
+ ref, |
||
| 320 | -! | +||
| 73 | +
- ANL <- tern::df_explicit_na(ANL) # nolint object_name_linter+ vars, |
||
| 321 | -! | +||
| 74 | +
- tbl <- rtables::build_table(lyt = lyt, df = ANL[order(ANL[[y_name]]), ])+ show_association = TRUE, |
||
| 322 | -! | +||
| 75 | +
- tbl+ plot_height = c(600, 400, 5000), |
||
| 323 | +76 |
- },+ plot_width = NULL, |
|
| 324 | -! | +||
| 77 | +
- env = list(y_name = y_name)+ distribution_theme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void"), # nolint: line_length.
|
||
| 325 | +78 |
- )+ association_theme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void"), # nolint: line_length.
|
|
| 326 | +79 |
- )+ pre_output = NULL, |
|
| 327 | +80 |
- })+ post_output = NULL, |
|
| 328 | +81 |
-
+ ggplot2_args = teal.widgets::ggplot2_args()) {
|
|
| 329 | +82 | ! |
- output$title <- renderText(output_q()[["title"]])- |
-
| 330 | -- |
-
+ logger::log_info("Initializing tm_g_association")
|
|
| 331 | +83 | ! |
- table_r <- reactive({
+ if (inherits(ref, "data_extract_spec")) ref <- list(ref) |
| 332 | +84 | ! |
- shiny::req(iv_r()$is_valid())+ if (inherits(vars, "data_extract_spec")) vars <- list(vars) |
| 333 | +85 | ! |
- output_q()[["tbl"]]+ if (inherits(ggplot2_args, "ggplot2_args")) ggplot2_args <- list(default = ggplot2_args) |
| 334 | +86 |
- })+ |
|
| 335 | -+ | ||
| 87 | +! |
-
+ checkmate::assert_string(label) |
|
| 336 | +88 | ! |
- teal.widgets::table_with_settings_srv(+ checkmate::assert_list(ref, types = "data_extract_spec") |
| 337 | +89 | ! |
- id = "table",+ if (!all(vapply(ref, function(x) !x$select$multiple, logical(1)))) {
|
| 338 | +90 | ! |
- table_r = table_r+ stop("'ref' should not allow multiple selection")
|
| 339 | +91 |
- )+ } |
|
| 340 | -+ | ||
| 92 | +! |
-
+ checkmate::assert_list(vars, types = "data_extract_spec") |
|
| 341 | +93 | ! |
- teal.widgets::verbatim_popup_srv(+ checkmate::assert_flag(show_association) |
| 342 | +94 | ! |
- id = "warning",+ checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE) |
| 343 | +95 | ! |
- verbatim_content = reactive(teal.code::get_warnings(output_q())),+ checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height") |
| 344 | +96 | ! |
- title = "Warning",+ checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE) |
| 345 | +97 | ! |
- disabled = reactive(is.null(teal.code::get_warnings(output_q())))+ checkmate::assert_numeric( |
| 346 | -+ | ||
| 98 | +! |
- )+ plot_width[1],+ |
+ |
| 99 | +! | +
+ lower = plot_width[2], upper = plot_width[3], null.ok = TRUE, .var.name = "plot_width" |
|
| 347 | +100 |
-
+ ) |
|
| 348 | +101 | ! |
- teal.widgets::verbatim_popup_srv(+ distribution_theme <- match.arg(distribution_theme) |
| 349 | +102 | ! |
- id = "rcode",+ association_theme <- match.arg(association_theme) |
| 350 | +103 | ! |
- verbatim_content = reactive(teal.code::get_code(output_q())),+ plot_choices <- c("Bivariate1", "Bivariate2")
|
| 351 | +104 | ! |
- title = "Show R Code for Cross-Table"+ checkmate::assert_list(ggplot2_args, types = "ggplot2_args") |
| 352 | -+ | ||
| 105 | +! |
- )+ checkmate::assert_subset(names(ggplot2_args), c("default", plot_choices))
|
|
| 353 | +106 | ||
| 354 | -- |
- ### REPORTER- |
- |
| 355 | -! | -
- if (with_reporter) {
- |
- |
| 356 | +107 | ! |
- card_fun <- function(comment, label) {
+ args <- as.list(environment()) |
| 357 | -! | +||
| 108 | +
- card <- teal::report_card_template(+ |
||
| 358 | +109 | ! |
- title = "Cross Table",+ data_extract_list <- list( |
| 359 | +110 | ! |
- label = label,+ ref = ref, |
| 360 | +111 | ! |
- with_filter = with_filter,+ vars = vars |
| 361 | -! | +||
| 112 | +
- filter_panel_api = filter_panel_api+ ) |
||
| 362 | +113 |
- )+ |
|
| 363 | +114 | ! |
- card$append_text("Table", "header3")
+ module( |
| 364 | +115 | ! |
- card$append_table(table_r())+ label = label, |
| 365 | +116 | ! |
- if (!comment == "") {
+ server = srv_tm_g_association, |
| 366 | +117 | ! |
- card$append_text("Comment", "header3")
+ ui = ui_tm_g_association, |
| 367 | +118 | ! |
- card$append_text(comment)+ ui_args = args, |
| 368 | -+ | ||
| 119 | +! |
- }+ server_args = c( |
|
| 369 | +120 | ! |
- card$append_src(teal.code::get_code(output_q()))+ data_extract_list, |
| 370 | +121 | ! |
- card+ list(plot_height = plot_height, plot_width = plot_width, ggplot2_args = ggplot2_args) |
| 371 | +122 |
- }+ ), |
|
| 372 | +123 | ! |
- teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
+ datanames = teal.transform::get_extract_datanames(data_extract_list) |
| 373 | +124 |
- }+ ) |
|
| 374 | +125 |
- ###+ } |
|
| 375 | +126 |
- })+ |
|
| 376 | +127 |
- }+ ui_tm_g_association <- function(id, ...) {
|
| 1 | -+ | ||
| 128 | +! |
- #' File Viewer Teal Module+ ns <- NS(id) |
|
| 2 | -+ | ||
| 129 | +! |
- #'+ args <- list(...) |
|
| 3 | -+ | ||
| 130 | +! |
- #' The file viewer module provides a tool to view static files.+ is_single_dataset_value <- teal.transform::is_single_dataset(args$ref, args$vars) |
|
| 4 | +131 |
- #' Supported formats include text formats, \code{PDF}, \code{PNG}, \code{APNG},
+
|
|
| 5 | -+ | ||
| 132 | +! |
- #' \code{JPEG}, \code{SVG}, \code{WEBP}, \code{GIF} and \code{BMP}.
+ teal.widgets::standard_layout( |
|
| 6 | -+ | ||
| 133 | +! |
- #'+ output = teal.widgets::white_small_well( |
|
| 7 | -+ | ||
| 134 | +! |
- #' @inheritParams teal::module+ textOutput(ns("title")),
|
|
| 8 | -+ | ||
| 135 | +! |
- #' @inheritParams shared_params+ tags$br(), |
|
| 9 | -+ | ||
| 136 | +! |
- #' @param input_path optional, (`list`) of the input paths to either: specific files of accepted formats,+ teal.widgets::plot_with_settings_ui(id = ns("myplot"))
|
|
| 10 | +137 |
- #' a directory or a URL. The paths can be specified as absolute paths or relative to the running+ ), |
|
| 11 | -+ | ||
| 138 | +! |
- #' directory of the application. Will default to current working directory if not supplied.+ encoding = div( |
|
| 12 | +139 |
- #'+ ### Reporter |
|
| 13 | -+ | ||
| 140 | +! |
- #' @export+ teal.reporter::simple_reporter_ui(ns("simple_reporter")),
|
|
| 14 | +141 |
- #'+ ### |
|
| 15 | -+ | ||
| 142 | +! |
- #' @examples+ tags$label("Encodings", class = "text-primary"),
|
|
| 16 | -+ | ||
| 143 | +! |
- #' data <- teal_data()+ teal.transform::datanames_input(args[c("ref", "vars")]),
|
|
| 17 | -+ | ||
| 144 | +! |
- #' data <- within(data, {
+ teal.transform::data_extract_ui( |
|
| 18 | -+ | ||
| 145 | +! |
- #' data <- data.frame(1)+ id = ns("ref"),
|
|
| 19 | -+ | ||
| 146 | +! |
- #' })+ label = "Reference variable", |
|
| 20 | -- |
- #' datanames(data) <- c("data")
- |
- |
| 21 | -- |
- #'- |
- |
| 22 | -+ | ||
| 147 | +! |
- #' app <- teal::init(+ data_extract_spec = args$ref, |
|
| 23 | -+ | ||
| 148 | +! |
- #' data = data,+ is_single_dataset = is_single_dataset_value |
|
| 24 | +149 |
- #' modules = teal::modules(+ ), |
|
| 25 | -+ | ||
| 150 | +! |
- #' teal.modules.general::tm_file_viewer(+ teal.transform::data_extract_ui( |
|
| 26 | -+ | ||
| 151 | +! |
- #' input_path = list(+ id = ns("vars"),
|
|
| 27 | -+ | ||
| 152 | +! |
- #' folder = system.file("sample_files", package = "teal.modules.general"),
+ label = "Associated variables", |
|
| 28 | -+ | ||
| 153 | +! |
- #' png = system.file("sample_files/sample_file.png", package = "teal.modules.general"),
+ data_extract_spec = args$vars, |
|
| 29 | -+ | ||
| 154 | +! |
- #' txt = system.file("sample_files/sample_file.txt", package = "teal.modules.general"),
+ is_single_dataset = is_single_dataset_value |
|
| 30 | +155 |
- #' url =+ ), |
|
| 31 | -+ | ||
| 156 | +! |
- #' "https://www.fda.gov/files/drugs/published/Portable-Document-Format-Specifications.pdf"+ checkboxInput( |
|
| 32 | -+ | ||
| 157 | +! |
- #' )+ ns("association"),
|
|
| 33 | -+ | ||
| 158 | +! |
- #' )+ "Association with reference variable", |
|
| 34 | -+ | ||
| 159 | +! |
- #' )+ value = args$show_association |
|
| 35 | +160 |
- #' )+ ), |
|
| 36 | -+ | ||
| 161 | +! |
- #' if (interactive()) {
+ checkboxInput( |
|
| 37 | -+ | ||
| 162 | +! |
- #' shinyApp(app$ui, app$server)+ ns("show_dist"),
|
|
| 38 | -+ | ||
| 163 | +! |
- #' }+ "Scaled frequencies", |
|
| 39 | -+ | ||
| 164 | +! |
- #'+ value = FALSE |
|
| 40 | +165 |
- tm_file_viewer <- function(label = "File Viewer Module",+ ), |
|
| 41 | -+ | ||
| 166 | +! |
- input_path = list("Current Working Directory" = ".")) {
+ checkboxInput( |
|
| 42 | +167 | ! |
- logger::log_info("Initializing tm_file_viewer")
+ ns("log_transformation"),
|
| 43 | +168 | ! |
- if (length(label) == 0 || identical(label, "")) {
+ "Log transformed", |
| 44 | +169 | ! |
- label <- " "+ value = FALSE |
| 45 | +170 |
- }+ ), |
|
| 46 | +171 | ! |
- if (length(input_path) == 0 || identical(input_path, "")) {
+ teal.widgets::panel_group( |
| 47 | +172 | ! |
- input_path <- list()- |
-
| 48 | -- |
- }- |
- |
| 49 | -- |
-
+ teal.widgets::panel_item( |
|
| 50 | +173 | ! |
- checkmate::assert_string(label)+ title = "Plot settings", |
| 51 | +174 | ! |
- checkmate::assert(+ teal.widgets::optionalSliderInputValMinMax(ns("alpha"), "Scatterplot opacity:", c(0.5, 0, 1), ticks = FALSE),
|
| 52 | +175 | ! |
- checkmate::check_list(input_path, types = "character", min.len = 0),+ teal.widgets::optionalSliderInputValMinMax(ns("size"), "Scatterplot points size:", c(2, 1, 8), ticks = FALSE),
|
| 53 | +176 | ! |
- checkmate::check_character(input_path, min.len = 1)- |
-
| 54 | -- |
- )+ checkboxInput(ns("swap_axes"), "Swap axes", value = FALSE),
|
|
| 55 | -+ | ||
| 177 | +! |
-
+ checkboxInput(ns("rotate_xaxis_labels"), "Rotate X axis labels", value = FALSE),
|
|
| 56 | +178 | ! |
- if (length(input_path) > 0) {
+ selectInput( |
| 57 | +179 | ! |
- valid_url <- function(url_input, timeout = 2) {
+ inputId = ns("distribution_theme"),
|
| 58 | +180 | ! |
- con <- try(url(url_input), silent = TRUE)+ label = "Distribution theme (by ggplot):", |
| 59 | +181 | ! |
- check <- suppressWarnings(try(open.connection(con, open = "rt", timeout = timeout), silent = TRUE)[1])+ choices = ggplot_themes, |
| 60 | +182 | ! |
- try(close.connection(con), silent = TRUE)+ selected = args$distribution_theme, |
| 61 | +183 | ! |
- ifelse(is.null(check), TRUE, FALSE)+ multiple = FALSE |
| 62 | +184 |
- }+ ), |
|
| 63 | +185 | ! |
- idx <- vapply(input_path, function(x) file.exists(x) || valid_url(x), logical(1))+ selectInput( |
| 64 | -+ | ||
| 186 | +! |
-
+ inputId = ns("association_theme"),
|
|
| 65 | +187 | ! |
- if (!all(idx)) {
+ label = "Association theme (by ggplot):", |
| 66 | +188 | ! |
- warning(+ choices = ggplot_themes, |
| 67 | +189 | ! |
- paste0(+ selected = args$association_theme, |
| 68 | +190 | ! |
- "Non-existent file or url path. Please provide valid paths for:\n",+ multiple = FALSE |
| 69 | -! | +||
| 191 | +
- paste0(input_path[!idx], collapse = "\n")+ ) |
||
| 70 | +192 |
) |
|
| 71 | +193 |
) |
|
| 72 | +194 |
- }+ ), |
|
| 73 | +195 | ! |
- input_path <- input_path[idx]- |
-
| 74 | -- |
- } else {
+ forms = tagList( |
|
| 75 | +196 | ! |
- warning(+ teal.widgets::verbatim_popup_ui(ns("warning"), "Show Warnings"),
|
| 76 | +197 | ! |
- "No file or url paths were provided."+ teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code")
|
| 77 | +198 |
- )+ ), |
|
| 78 | -+ | ||
| 199 | +! |
- }+ pre_output = args$pre_output, |
|
| 79 | -+ | ||
| 200 | +! |
-
+ post_output = args$post_output |
|
| 80 | +201 |
-
+ ) |
|
| 81 | -! | +||
| 202 | +
- args <- as.list(environment())+ } |
||
| 82 | +203 | ||
| 83 | -! | +||
| 204 | +
- module(+ srv_tm_g_association <- function(id, |
||
| 84 | -! | +||
| 205 | +
- label = label,+ data, |
||
| 85 | -! | +||
| 206 | +
- server = srv_viewer,+ reporter, |
||
| 86 | -! | +||
| 207 | +
- server_args = list(input_path = input_path),+ filter_panel_api, |
||
| 87 | -! | +||
| 208 | +
- ui = ui_viewer,+ ref, |
||
| 88 | -! | +||
| 209 | +
- ui_args = args,+ vars, |
||
| 89 | -! | +||
| 210 | +
- datanames = NULL+ plot_height, |
||
| 90 | +211 |
- )+ plot_width, |
|
| 91 | +212 |
- }+ ggplot2_args) {
|
|
| 92 | -+ | ||
| 213 | +! |
-
+ with_reporter <- !missing(reporter) && inherits(reporter, "Reporter") |
|
| 93 | -+ | ||
| 214 | +! |
- ui_viewer <- function(id, ...) {
+ with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI") |
|
| 94 | +215 | ! |
- args <- list(...)+ checkmate::assert_class(data, "reactive") |
| 95 | +216 | ! |
- ns <- NS(id)+ checkmate::assert_class(isolate(data()), "teal_data") |
| 96 | +217 | ||
| 97 | +218 | ! |
- shiny::tagList(+ moduleServer(id, function(input, output, session) {
|
| 98 | +219 | ! |
- include_css_files("custom"),
+ selector_list <- teal.transform::data_extract_multiple_srv( |
| 99 | +220 | ! |
- teal.widgets::standard_layout(+ data_extract = list(ref = ref, vars = vars), |
| 100 | +221 | ! |
- output = div(+ datasets = data, |
| 101 | +222 | ! |
- uiOutput(ns("output"))
+ select_validation_rule = list( |
| 102 | -+ | ||
| 223 | +! |
- ),+ ref = shinyvalidate::compose_rules( |
|
| 103 | +224 | ! |
- encoding = div(+ shinyvalidate::sv_required("A reference variable needs to be selected."),
|
| 104 | +225 | ! |
- class = "file_viewer_encoding",+ ~ if ((.) %in% selector_list()$vars()$select) {
|
| 105 | +226 | ! |
- tags$label("Encodings", class = "text-primary"),
+ "Associated variables and reference variable cannot overlap" |
| 106 | -! | +||
| 227 | +
- shinyTree::shinyTree(+ } |
||
| 107 | -! | +||
| 228 | +
- ns("tree"),
+ ), |
||
| 108 | +229 | ! |
- dragAndDrop = FALSE,+ vars = shinyvalidate::compose_rules( |
| 109 | +230 | ! |
- sort = FALSE,+ shinyvalidate::sv_required("An associated variable needs to be selected."),
|
| 110 | +231 | ! |
- wholerow = TRUE,+ ~ if (length(selector_list()$ref()$select) != 0 && selector_list()$ref()$select %in% (.)) {
|
| 111 | +232 | ! |
- theme = "proton",+ "Associated variables and reference variable cannot overlap" |
| 112 | -! | +||
| 233 | +
- multiple = FALSE+ } |
||
| 113 | +234 |
) |
|
| 114 | +235 |
) |
|
| 115 | +236 |
) |
|
| 116 | -- |
- )- |
- |
| 117 | -- |
- }- |
- |
| 118 | +237 | ||
| 119 | -- |
- srv_viewer <- function(id, input_path) {
- |
- |
| 120 | -! | -
- moduleServer(id, function(input, output, session) {
- |
- |
| 121 | +238 | ! |
- temp_dir <- tempfile()+ iv_r <- reactive({
|
| 122 | +239 | ! |
- if (!dir.exists(temp_dir)) {
+ iv <- shinyvalidate::InputValidator$new() |
| 123 | +240 | ! |
- dir.create(temp_dir, recursive = TRUE)+ teal.transform::compose_and_enable_validators(iv, selector_list) |
| 124 | +241 |
- }- |
- |
| 125 | -! | -
- addResourcePath(basename(temp_dir), temp_dir)+ }) |
|
| 126 | +242 | ||
| 127 | -! | -
- test_path_text <- function(selected_path, type) {
- |
- |
| 128 | -! | -
- out <- tryCatch(- |
- |
| 129 | +243 | ! |
- expr = {
+ anl_merged_input <- teal.transform::merge_expression_srv( |
| 130 | +244 | ! |
- if (type != "url") {
+ datasets = data, |
| 131 | +245 | ! |
- selected_path <- normalizePath(selected_path, winslash = "/")+ selector_list = selector_list |
| 132 | +246 |
- }- |
- |
| 133 | -! | -
- readLines(con = selected_path)+ ) |
|
| 134 | +247 |
- },+ |
|
| 135 | +248 | ! |
- error = function(cond) FALSE,+ anl_merged_q <- reactive({
|
| 136 | +249 | ! |
- warning = function(cond) {
+ req(anl_merged_input()) |
| 137 | +250 | ! |
- `if`(grepl("^incomplete final line found on", cond[[1]]), suppressWarnings(eval(cond[[2]])), FALSE)
- |
-
| 138 | -- |
- }- |
- |
| 139 | -- |
- )+ data() %>% teal.code::eval_code(as.expression(anl_merged_input()$expr)) |
|
| 140 | +251 |
- }+ }) |
|
| 141 | +252 | ||
| 142 | -! | -
- handle_connection_type <- function(selected_path) {
- |
- |
| 143 | +253 | ! |
- file_extension <- tools::file_ext(selected_path)+ merged <- list( |
| 144 | +254 | ! |
- file_class <- suppressWarnings(file(selected_path))+ anl_input_r = anl_merged_input, |
| 145 | +255 | ! |
- close(file_class)+ anl_q_r = anl_merged_q |
| 146 | +256 | - - | -|
| 147 | -! | -
- output_text <- test_path_text(selected_path, type = class(file_class)[1])+ ) |
|
| 148 | +257 | ||
| 149 | +258 | ! |
- if (class(file_class)[1] == "url") {
+ output_q <- reactive({
|
| 150 | +259 | ! |
- list(selected_path = selected_path, output_text = output_text)+ teal::validate_inputs(iv_r()) |
| 151 | +260 |
- } else {
- |
- |
| 152 | -! | -
- file.copy(normalizePath(selected_path, winslash = "/"), temp_dir)+ |
|
| 153 | +261 | ! |
- selected_path <- file.path(basename(temp_dir), basename(selected_path))+ ANL <- merged$anl_q_r()[["ANL"]] # nolint: object_name. |
| 154 | +262 | ! |
- list(selected_path = selected_path, output_text = output_text)+ teal::validate_has_data(ANL, 3) |
| 155 | +263 |
- }+ |
|
| 156 | -+ | ||
| 264 | +! |
- }+ vars_names <- merged$anl_input_r()$columns_source$vars |
|
| 157 | +265 | ||
| 158 | -! | -
- display_file <- function(selected_path) {
- |
- |
| 159 | +266 | ! |
- con_type <- handle_connection_type(selected_path)+ ref_name <- as.vector(merged$anl_input_r()$columns_source$ref) |
| 160 | +267 | ! |
- file_extension <- tools::file_ext(selected_path)+ association <- input$association |
| 161 | +268 | ! |
- if (file_extension %in% c("png", "apng", "jpg", "jpeg", "svg", "gif", "webp", "bmp")) {
+ show_dist <- input$show_dist |
| 162 | +269 | ! |
- tags$img(src = con_type$selected_path, alt = "file does not exist")+ log_transformation <- input$log_transformation |
| 163 | +270 | ! |
- } else if (file_extension == "pdf") {
+ rotate_xaxis_labels <- input$rotate_xaxis_labels |
| 164 | +271 | ! |
- tags$embed(+ swap_axes <- input$swap_axes |
| 165 | +272 | ! |
- class = "embed_pdf",+ distribution_theme <- input$distribution_theme |
| 166 | +273 | ! |
- src = con_type$selected_path+ association_theme <- input$association_theme |
| 167 | +274 |
- )+ |
|
| 168 | +275 | ! |
- } else if (!isFALSE(con_type$output_text[1])) {
+ is_scatterplot <- is.numeric(ANL[[ref_name]]) && any(vapply(ANL[vars_names], is.numeric, logical(1))) |
| 169 | +276 | ! |
- tags$pre(paste0(con_type$output_text, collapse = "\n"))+ if (is_scatterplot) {
|
| 170 | -+ | ||
| 277 | +! |
- } else {
+ shinyjs::show("alpha")
|
|
| 171 | +278 | ! |
- tags$p("Please select a supported format.")
+ shinyjs::show("size")
|
| 172 | -+ | ||
| 279 | +! |
- }+ alpha <- input$alpha |
|
| 173 | -+ | ||
| 280 | +! |
- }+ size <- input$size |
|
| 174 | +281 |
-
+ } else {
|
|
| 175 | +282 | ! |
- tree_list <- function(file_or_dir) {
+ shinyjs::hide("alpha")
|
| 176 | +283 | ! |
- nested_list <- lapply(file_or_dir, function(path) {
+ shinyjs::hide("size")
|
| 177 | +284 | ! |
- file_class <- suppressWarnings(file(path))+ alpha <- 0.5 |
| 178 | +285 | ! |
- close(file_class)+ size <- 2 |
| 179 | -! | +||
| 286 | +
- if (class(file_class)[[1]] != "url") {
+ } |
||
| 180 | -! | +||
| 287 | +
- isdir <- file.info(path)$isdir+ |
||
| 181 | +288 | ! |
- if (!isdir) {
+ teal::validate_has_data(ANL[, c(ref_name, vars_names)], 3, complete = TRUE, allow_inf = FALSE) |
| 182 | -! | +||
| 289 | +
- structure(path, ancestry = path, sticon = "file")+ |
||
| 183 | +290 |
- } else {
+ # reference |
|
| 184 | +291 | ! |
- files <- list.files(path, full.names = TRUE, include.dirs = TRUE)+ ref_class <- class(ANL[[ref_name]]) |
| 185 | +292 | ! |
- out <- lapply(files, function(x) tree_list(x))+ if (is.numeric(ANL[[ref_name]]) && log_transformation) {
|
| 186 | -! | +||
| 293 | +
- out <- unlist(out, recursive = FALSE)+ # works for both integers and doubles |
||
| 187 | +294 | ! |
- if (length(files) > 0) names(out) <- basename(files)+ ref_cl_name <- call("log", as.name(ref_name))
|
| 188 | +295 | ! |
- out+ ref_cl_lbl <- varname_w_label(ref_name, ANL, prefix = "Log of ") |
| 189 | +296 |
- }+ } else {
|
|
| 190 | +297 |
- } else {
+ # silently ignore when non-numeric even if `log` is selected because some+ |
+ |
| 298 | ++ |
+ # variables may be numeric and others not |
|
| 191 | +299 | ! |
- structure(path, ancestry = path, sticon = "file")+ ref_cl_name <- as.name(ref_name) |
| 192 | -+ | ||
| 300 | +! |
- }+ ref_cl_lbl <- varname_w_label(ref_name, ANL) |
|
| 193 | +301 |
- })+ } |
|
| 194 | +302 | ||
| 195 | +303 | ! |
- missing_labels <- if (is.null(names(nested_list))) seq_along(nested_list) else which(names(nested_list) == "")+ user_ggplot2_args <- teal.widgets::resolve_ggplot2_args( |
| 196 | +304 | ! |
- names(nested_list)[missing_labels] <- file_or_dir[missing_labels]+ user_plot = ggplot2_args[["Bivariate1"]], |
| 197 | +305 | ! |
- nested_list+ user_default = ggplot2_args$default |
| 198 | +306 |
- }+ ) |
|
| 199 | +307 | ||
| 200 | +308 | ! |
- output$tree <- shinyTree::renderTree({
+ ref_call <- bivariate_plot_call( |
| 201 | +309 | ! |
- if (length(input_path) > 0) {
+ data_name = "ANL", |
| 202 | +310 | ! |
- tree_list(input_path)- |
-
| 203 | -- |
- } else {
+ x = ref_cl_name, |
|
| 204 | +311 | ! |
- list("Empty Path" = NULL)
+ x_class = ref_class, |
| 205 | -+ | ||
| 312 | +! |
- }+ x_label = ref_cl_lbl, |
|
| 206 | -+ | ||
| 313 | +! |
- })+ freq = !show_dist, |
|
| 207 | -+ | ||
| 314 | +! |
-
+ theme = distribution_theme, |
|
| 208 | +315 | ! |
- output$output <- renderUI({
+ rotate_xaxis_labels = rotate_xaxis_labels, |
| 209 | +316 | ! |
- validate(+ swap_axes = FALSE, |
| 210 | +317 | ! |
- need(+ size = size, |
| 211 | +318 | ! |
- length(shinyTree::get_selected(input$tree)) > 0,+ alpha = alpha, |
| 212 | +319 | ! |
- "Please select a file."+ ggplot2_args = user_ggplot2_args |
| 213 | +320 |
- )+ ) |
|
| 214 | +321 |
- )+ |
|
| 215 | +322 |
-
+ # association |
|
| 216 | +323 | ! |
- obj <- shinyTree::get_selected(input$tree, format = "names")[[1]]+ ref_class_cov <- ifelse(association, ref_class, "NULL") |
| 217 | -! | +||
| 324 | +
- repo <- attr(obj, "ancestry")+ |
||
| 218 | -! | -
- repo_collapsed <- if (length(repo) > 1) paste0(repo, collapse = "/") else repo- |
- |
| 219 | +325 | ! |
- is_not_named <- file.exists(file.path(c(repo_collapsed, obj[1])))[1]+ print_call <- quote(print(p)) |
| 220 | +326 | ||
| 221 | +327 | ! |
- if (is_not_named) {
+ var_calls <- lapply(vars_names, function(var_i) {
|
| 222 | +328 | ! |
- selected_path <- do.call("file.path", as.list(c(repo, obj[1])))
+ var_class <- class(ANL[[var_i]])+ |
+
| 329 | +! | +
+ if (is.numeric(ANL[[var_i]]) && log_transformation) {
|
|
| 223 | +330 |
- } else {
+ # works for both integers and doubles |
|
| 224 | +331 | ! |
- if (length(repo) == 0) {
+ var_cl_name <- call("log", as.name(var_i))
|
| 225 | +332 | ! |
- selected_path <- do.call("file.path", as.list(attr(input$tree[[obj[1]]], "ancestry")))
+ var_cl_lbl <- varname_w_label(var_i, ANL, prefix = "Log of ") |
| 226 | +333 |
} else {
|
|
| 227 | -! | +||
| 334 | +
- selected_path <- do.call("file.path", as.list(attr(input$tree[[repo]][[obj[1]]], "ancestry")))
+ # silently ignore when non-numeric even if `log` is selected because some |
||
| 228 | +335 |
- }+ # variables may be numeric and others not |
|
| 229 | -+ | ||
| 336 | +! |
- }+ var_cl_name <- as.name(var_i)+ |
+ |
| 337 | +! | +
+ var_cl_lbl <- varname_w_label(var_i, ANL) |
|
| 230 | +338 |
-
+ } |
|
| 231 | -! | +||
| 339 | +
- validate(+ |
||
| 232 | +340 | ! |
- need(+ user_ggplot2_args <- teal.widgets::resolve_ggplot2_args( |
| 233 | +341 | ! |
- !isTRUE(file.info(selected_path)$isdir) && length(selected_path) > 0,+ user_plot = ggplot2_args[["Bivariate2"]], |
| 234 | +342 | ! |
- "Please select a single file."+ user_default = ggplot2_args$default |
| 235 | +343 |
) |
|
| 236 | +344 |
- )+ |
|
| 237 | +345 | ! |
- display_file(selected_path)+ bivariate_plot_call( |
| 238 | -+ | ||
| 346 | +! |
- })+ data_name = "ANL", |
|
| 239 | -+ | ||
| 347 | +! |
-
+ x = ref_cl_name, |
|
| 240 | +348 | ! |
- onStop(function() {
+ y = var_cl_name, |
| 241 | +349 | ! |
- removeResourcePath(basename(temp_dir))+ x_class = ref_class_cov, |
| 242 | +350 | ! |
- unlink(temp_dir)+ y_class = var_class, |
| 243 | -+ | ||
| 351 | +! |
- })+ x_label = ref_cl_lbl, |
|
| 244 | -+ | ||
| 352 | +! |
- })+ y_label = var_cl_lbl, |
|
| 245 | -+ | ||
| 353 | +! |
- }+ theme = association_theme, |
| 1 | -+ | ||
| 354 | +! |
- #' Stack Plots of variables and show association with reference variable+ freq = !show_dist, |
|
| 2 | -+ | ||
| 355 | +! |
- #' @md+ rotate_xaxis_labels = rotate_xaxis_labels, |
|
| 3 | -+ | ||
| 356 | +! |
- #'+ swap_axes = swap_axes, |
|
| 4 | -+ | ||
| 357 | +! |
- #' @inheritParams teal::module+ alpha = alpha, |
|
| 5 | -+ | ||
| 358 | +! |
- #' @inheritParams shared_params+ size = size, |
|
| 6 | -+ | ||
| 359 | +! |
- #' @param ref (`data_extract_spec` or `list` of multiple `data_extract_spec`)+ ggplot2_args = user_ggplot2_args |
|
| 7 | +360 |
- #' reference variable, must set `multiple = FALSE`.+ ) |
|
| 8 | +361 |
- #' @param vars (`data_extract_spec` or `list` of multiple `data_extract_spec`)+ }) |
|
| 9 | +362 |
- #' associated variables.+ |
|
| 10 | +363 |
- #' @param show_association optional, (`logical`) Whether show association of `vars`+ # helper function to format variable name |
|
| 11 | -+ | ||
| 364 | +! |
- #' with reference variable. Defaults to `TRUE`.+ format_varnames <- function(x) {
|
|
| 12 | -+ | ||
| 365 | +! |
- #' @param distribution_theme,association_theme optional, (`character`) `ggplot2` themes to be used by default.+ if (is.numeric(ANL[[x]]) && log_transformation) {
|
|
| 13 | -+ | ||
| 366 | +! |
- #' Default to `"gray"`.+ varname_w_label(x, ANL, prefix = "Log of ") |
|
| 14 | +367 |
- #'+ } else {
|
|
| 15 | -+ | ||
| 368 | +! |
- #' @templateVar ggnames "Bivariate1", "Bivariate2"+ varname_w_label(x, ANL) |
|
| 16 | +369 |
- #' @template ggplot2_args_multi+ } |
|
| 17 | +370 |
- #'+ } |
|
| 18 | -+ | ||
| 371 | +! |
- #' @note For more examples, please see the vignette "Using association plot" via+ new_title <- |
|
| 19 | -+ | ||
| 372 | +! |
- #' \code{vignette("using-association-plot", package = "teal.modules.general")}.
+ if (association) {
|
|
| 20 | -+ | ||
| 373 | +! |
- #' @export+ switch(as.character(length(vars_names)), |
|
| 21 | -+ | ||
| 374 | +! |
- #' @examples+ "0" = sprintf("Value distribution for %s", ref_cl_lbl),
|
|
| 22 | -+ | ||
| 375 | +! |
- #' # Association plot of selected reference variable (SEX)+ "1" = sprintf( |
|
| 23 | -+ | ||
| 376 | +! |
- #' # against other selected variables (BMRKR1)+ "Association between %s and %s", |
|
| 24 | -+ | ||
| 377 | +! |
- #' data <- teal_data()+ ref_cl_lbl, |
|
| 25 | -+ | ||
| 378 | +! |
- #' data <- within(data, {
+ format_varnames(vars_names) |
|
| 26 | +379 |
- #' library(nestcolor)+ ), |
|
| 27 | -+ | ||
| 380 | +! |
- #' ADSL <- teal.modules.general::rADSL+ sprintf( |
|
| 28 | -+ | ||
| 381 | +! |
- #' })+ "Associations between %s and: %s", |
|
| 29 | -+ | ||
| 382 | +! |
- #' datanames <- c("ADSL")
+ ref_cl_lbl, |
|
| 30 | -+ | ||
| 383 | +! |
- #' datanames(data) <- datanames+ paste(lapply(vars_names, format_varnames), collapse = ", ") |
|
| 31 | +384 |
- #' join_keys(data) <- default_cdisc_join_keys[datanames]+ ) |
|
| 32 | +385 |
- #'+ ) |
|
| 33 | +386 |
- #' app <- teal::init(+ } else {
|
|
| 34 | -+ | ||
| 387 | +! |
- #' data = data,+ switch(as.character(length(vars_names)), |
|
| 35 | -+ | ||
| 388 | +! |
- #' modules = teal::modules(+ "0" = sprintf("Value distribution for %s", ref_cl_lbl),
|
|
| 36 | -+ | ||
| 389 | +! |
- #' teal.modules.general::tm_g_association(+ sprintf( |
|
| 37 | -+ | ||
| 390 | +! |
- #' ref = teal.transform::data_extract_spec(+ "Value distributions for %s and %s", |
|
| 38 | -+ | ||
| 391 | +! |
- #' dataname = "ADSL",+ ref_cl_lbl, |
|
| 39 | -+ | ||
| 392 | +! |
- #' select = teal.transform::select_spec(+ paste(lapply(vars_names, format_varnames), collapse = ", ") |
|
| 40 | +393 |
- #' label = "Select variable:",+ ) |
|
| 41 | +394 |
- #' choices = teal.transform::variable_choices(+ ) |
|
| 42 | +395 |
- #' data[["ADSL"]],+ } |
|
| 43 | +396 |
- #' c("SEX", "RACE", "COUNTRY", "ARM", "STRATA1", "STRATA2", "ITTFL", "BMRKR2")
+
|
|
| 44 | -+ | ||
| 397 | +! |
- #' ),+ teal.code::eval_code( |
|
| 45 | -+ | ||
| 398 | +! |
- #' selected = "RACE",+ merged$anl_q_r(), |
|
| 46 | -+ | ||
| 399 | +! |
- #' fixed = FALSE+ substitute( |
|
| 47 | -+ | ||
| 400 | +! |
- #' )+ expr = title <- new_title, |
|
| 48 | -+ | ||
| 401 | +! |
- #' ),+ env = list(new_title = new_title) |
|
| 49 | +402 |
- #' vars = teal.transform::data_extract_spec(+ ) |
|
| 50 | +403 |
- #' dataname = "ADSL",+ ) %>% |
|
| 51 | -+ | ||
| 404 | +! |
- #' select = teal.transform::select_spec(+ teal.code::eval_code( |
|
| 52 | -+ | ||
| 405 | +! |
- #' label = "Select variables:",+ substitute( |
|
| 53 | -- |
- #' choices = teal.transform::variable_choices(+ | |
| 406 | +! | +
+ expr = {
|
|
| 54 | -+ | ||
| 407 | +! |
- #' data[["ADSL"]],+ plots <- plot_calls |
|
| 55 | -+ | ||
| 408 | +! |
- #' c("SEX", "RACE", "COUNTRY", "ARM", "STRATA1", "STRATA2", "ITTFL", "BMRKR2")
+ p <- tern::stack_grobs(grobs = lapply(plots, ggplotGrob)) |
|
| 56 | -+ | ||
| 409 | +! |
- #' ),+ grid::grid.newpage() |
|
| 57 | -+ | ||
| 410 | +! |
- #' selected = "BMRKR2",+ grid::grid.draw(p) |
|
| 58 | +411 |
- #' multiple = TRUE,+ }, |
|
| 59 | -+ | ||
| 412 | +! |
- #' fixed = FALSE+ env = list( |
|
| 60 | -+ | ||
| 413 | +! |
- #' )+ plot_calls = do.call( |
|
| 61 | -+ | ||
| 414 | +! |
- #' ),+ "call", |
|
| 62 | -+ | ||
| 415 | +! |
- #' ggplot2_args = teal.widgets::ggplot2_args(+ c(list("list", ref_call), var_calls),
|
|
| 63 | -+ | ||
| 416 | +! |
- #' labs = list(subtitle = "Plot generated by Association Module")+ quote = TRUE |
|
| 64 | +417 |
- #' )+ ) |
|
| 65 | +418 |
- #' )+ ) |
|
| 66 | +419 |
- #' )+ ) |
|
| 67 | +420 |
- #' )+ ) |
|
| 68 | +421 |
- #' if (interactive()) {
+ }) |
|
| 69 | +422 |
- #' shinyApp(app$ui, app$server)+ |
|
| 70 | -+ | ||
| 423 | +! |
- #' }+ plot_r <- shiny::reactive({
|
|
| 71 | -+ | ||
| 424 | +! |
- tm_g_association <- function(label = "Association",+ shiny::req(iv_r()$is_valid()) |
|
| 72 | -+ | ||
| 425 | +! |
- ref,+ output_q()[["p"]] |
|
| 73 | +426 |
- vars,+ }) |
|
| 74 | +427 |
- show_association = TRUE,+ |
|
| 75 | -+ | ||
| 428 | +! |
- plot_height = c(600, 400, 5000),+ pws <- teal.widgets::plot_with_settings_srv( |
|
| 76 | -+ | ||
| 429 | +! |
- plot_width = NULL,+ id = "myplot", |
|
| 77 | -+ | ||
| 430 | +! |
- distribution_theme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void"), # nolint line_length_linter
+ plot_r = plot_r, |
|
| 78 | -+ | ||
| 431 | +! |
- association_theme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void"), # nolint line_length_linter
+ height = plot_height, |
|
| 79 | -+ | ||
| 432 | +! |
- pre_output = NULL,+ width = plot_width |
|
| 80 | +433 |
- post_output = NULL,+ ) |
|
| 81 | +434 |
- ggplot2_args = teal.widgets::ggplot2_args()) {
- |
- |
| 82 | -! | -
- logger::log_info("Initializing tm_g_association")
+
|
|
| 83 | +435 | ! |
- if (inherits(ref, "data_extract_spec")) ref <- list(ref)+ output$title <- renderText({
|
| 84 | +436 | ! |
- if (inherits(vars, "data_extract_spec")) vars <- list(vars)+ teal.code::dev_suppress(output_q()[["title"]]) |
| 85 | -! | +||
| 437 | +
- if (inherits(ggplot2_args, "ggplot2_args")) ggplot2_args <- list(default = ggplot2_args)+ }) |
||
| 86 | +438 | ||
| 87 | +439 | ! |
- checkmate::assert_string(label)+ teal.widgets::verbatim_popup_srv( |
| 88 | +440 | ! |
- checkmate::assert_list(ref, types = "data_extract_spec")+ id = "warning", |
| 89 | +441 | ! |
- if (!all(vapply(ref, function(x) !x$select$multiple, logical(1)))) {
+ verbatim_content = reactive(teal.code::get_warnings(output_q())), |
| 90 | +442 | ! |
- stop("'ref' should not allow multiple selection")
+ title = "Warning", |
| 91 | -+ | ||
| 443 | +! |
- }+ disabled = reactive(is.null(teal.code::get_warnings(output_q()))) |
|
| 92 | -! | +||
| 444 | +
- checkmate::assert_list(vars, types = "data_extract_spec")+ ) |
||
| 93 | -! | +||
| 445 | +
- checkmate::assert_flag(show_association)+ |
||
| 94 | +446 | ! |
- checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE)+ teal.widgets::verbatim_popup_srv( |
| 95 | +447 | ! |
- checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height")+ id = "rcode", |
| 96 | +448 | ! |
- checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE)+ verbatim_content = reactive(teal.code::get_code(output_q())), |
| 97 | +449 | ! |
- checkmate::assert_numeric(+ title = "Association Plot" |
| 98 | -! | +||
| 450 | +
- plot_width[1],+ ) |
||
| 99 | -! | +||
| 451 | +
- lower = plot_width[2], upper = plot_width[3], null.ok = TRUE, .var.name = "plot_width"+ |
||
| 100 | +452 |
- )+ ### REPORTER |
|
| 101 | +453 | ! |
- distribution_theme <- match.arg(distribution_theme)+ if (with_reporter) {
|
| 102 | +454 | ! |
- association_theme <- match.arg(association_theme)+ card_fun <- function(comment, label) {
|
| 103 | +455 | ! |
- plot_choices <- c("Bivariate1", "Bivariate2")
+ card <- teal::report_card_template( |
| 104 | +456 | ! |
- checkmate::assert_list(ggplot2_args, types = "ggplot2_args")+ title = "Association Plot", |
| 105 | +457 | ! |
- checkmate::assert_subset(names(ggplot2_args), c("default", plot_choices))
+ label = label, |
| 106 | -+ | ||
| 458 | +! |
-
+ with_filter = with_filter, |
|
| 107 | +459 | ! |
- args <- as.list(environment())+ filter_panel_api = filter_panel_api |
| 108 | +460 |
-
+ ) |
|
| 109 | +461 | ! |
- data_extract_list <- list(+ card$append_text("Plot", "header3")
|
| 110 | +462 | ! |
- ref = ref,+ card$append_plot(plot_r(), dim = pws$dim()) |
| 111 | +463 | ! |
- vars = vars+ if (!comment == "") {
|
| 112 | -+ | ||
| 464 | +! |
- )+ card$append_text("Comment", "header3")
+ |
+ |
| 465 | +! | +
+ card$append_text(comment) |
|
| 113 | +466 |
-
+ } |
|
| 114 | +467 | ! |
- module(+ card$append_src(teal.code::get_code(output_q())) |
| 115 | +468 | ! |
- label = label,+ card |
| 116 | -! | +||
| 469 | +
- server = srv_tm_g_association,+ } |
||
| 117 | +470 | ! |
- ui = ui_tm_g_association,+ teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
|
| 118 | -! | +||
| 471 | +
- ui_args = args,+ } |
||
| 119 | -! | +||
| 472 | +
- server_args = c(+ ### |
||
| 120 | -! | +||
| 473 | +
- data_extract_list,+ }) |
||
| 121 | -! | +||
| 474 | +
- list(plot_height = plot_height, plot_width = plot_width, ggplot2_args = ggplot2_args)+ } |
| 122 | +1 |
- ),+ #' Distribution Module |
|
| 123 | -! | +||
| 2 | +
- datanames = teal.transform::get_extract_datanames(data_extract_list)+ #' @md |
||
| 124 | +3 |
- )+ #' |
|
| 125 | +4 |
- }+ #' @details |
|
| 126 | +5 |
-
+ #' Module to analyze and explore univariate variable distribution |
|
| 127 | +6 |
- ui_tm_g_association <- function(id, ...) {
+ #' |
|
| 128 | -! | +||
| 7 | +
- ns <- NS(id)+ #' @inheritParams teal::module |
||
| 129 | -! | +||
| 8 | +
- args <- list(...)+ #' @inheritParams teal.widgets::standard_layout |
||
| 130 | -! | +||
| 9 | +
- is_single_dataset_value <- teal.transform::is_single_dataset(args$ref, args$vars)+ #' @inheritParams shared_params |
||
| 131 | +10 |
-
+ #' |
|
| 132 | -! | +||
| 11 | +
- teal.widgets::standard_layout(+ #' @param dist_var (`data_extract_spec` or `list` of multiple `data_extract_spec`) |
||
| 133 | -! | +||
| 12 | +
- output = teal.widgets::white_small_well(+ #' Variable to consider for the distribution analysis. |
||
| 134 | -! | +||
| 13 | +
- textOutput(ns("title")),
+ #' @param strata_var (`data_extract_spec` or `list` of multiple `data_extract_spec`) |
||
| 135 | -! | +||
| 14 | +
- tags$br(),+ #' Categorical variable to split the selected distribution variable on. |
||
| 136 | -! | +||
| 15 | +
- teal.widgets::plot_with_settings_ui(id = ns("myplot"))
+ #' @param group_var optional, (`data_extract_spec` or `list` of multiple `data_extract_spec`) |
||
| 137 | +16 |
- ),+ #' Which data columns to use for faceting rows. |
|
| 138 | -! | +||
| 17 | +
- encoding = div(+ #' @param freq optional, (`logical`) Whether to display frequency (`TRUE`) or density (`FALSE`). |
||
| 139 | +18 |
- ### Reporter+ #' Defaults to density (`FALSE`). |
|
| 140 | -! | +||
| 19 | +
- teal.reporter::simple_reporter_ui(ns("simple_reporter")),
+ #' @param bins optional, (`integer(1)` or `integer(3)`) If scalar then the histogram bins will have a fixed size. |
||
| 141 | +20 |
- ###+ #' If a slider should be presented to adjust the number of histogram bins dynamically then it can be a |
|
| 142 | -! | +||
| 21 | +
- tags$label("Encodings", class = "text-primary"),
+ #' vector of length three with `c(value, min, max)`. |
||
| 143 | -! | +||
| 22 | +
- teal.transform::datanames_input(args[c("ref", "vars")]),
+ #' Defaults to `c(30L, 1L, 100L)`. |
||
| 144 | -! | +||
| 23 | +
- teal.transform::data_extract_ui(+ #' |
||
| 145 | -! | +||
| 24 | +
- id = ns("ref"),
+ #' @templateVar ggnames "Histogram", "QQplot" |
||
| 146 | -! | +||
| 25 | +
- label = "Reference variable",+ #' @template ggplot2_args_multi |
||
| 147 | -! | +||
| 26 | +
- data_extract_spec = args$ref,+ #' |
||
| 148 | -! | +||
| 27 | +
- is_single_dataset = is_single_dataset_value+ #' |
||
| 149 | +28 |
- ),+ #' @export |
|
| 150 | -! | +||
| 29 | +
- teal.transform::data_extract_ui(+ #' |
||
| 151 | -! | +||
| 30 | +
- id = ns("vars"),
+ #' @examples |
||
| 152 | -! | +||
| 31 | +
- label = "Associated variables",+ #' # Example with non-clinical data |
||
| 153 | -! | +||
| 32 | +
- data_extract_spec = args$vars,+ #' |
||
| 154 | -! | +||
| 33 | +
- is_single_dataset = is_single_dataset_value+ #' data <- teal_data() |
||
| 155 | +34 |
- ),+ #' data <- within(data, {
|
|
| 156 | -! | +||
| 35 | +
- checkboxInput(+ #' iris <- iris |
||
| 157 | -! | +||
| 36 | +
- ns("association"),
+ #' }) |
||
| 158 | -! | +||
| 37 | +
- "Association with reference variable",+ #' datanames(data) <- c("iris")
|
||
| 159 | -! | +||
| 38 | +
- value = args$show_association+ #' |
||
| 160 | +39 |
- ),+ #' app <- teal::init( |
|
| 161 | -! | +||
| 40 | +
- checkboxInput(+ #' data = data, |
||
| 162 | -! | +||
| 41 | +
- ns("show_dist"),
+ #' modules = list( |
||
| 163 | -! | +||
| 42 | +
- "Scaled frequencies",+ #' teal.modules.general::tm_g_distribution( |
||
| 164 | -! | +||
| 43 | +
- value = FALSE+ #' dist_var = teal.transform::data_extract_spec( |
||
| 165 | +44 |
- ),+ #' dataname = "iris", |
|
| 166 | -! | +||
| 45 | +
- checkboxInput(+ #' select = teal.transform::select_spec(variable_choices("iris"), "Petal.Length")
|
||
| 167 | -! | +||
| 46 | +
- ns("log_transformation"),
+ #' ), |
||
| 168 | -! | +||
| 47 | +
- "Log transformed",+ #' ggplot2_args = teal.widgets::ggplot2_args( |
||
| 169 | -! | +||
| 48 | +
- value = FALSE+ #' labs = list(subtitle = "Plot generated by Distribution Module") |
||
| 170 | +49 |
- ),+ #' ) |
|
| 171 | -! | +||
| 50 | +
- teal.widgets::panel_group(+ #' ) |
||
| 172 | -! | +||
| 51 | +
- teal.widgets::panel_item(+ #' ) |
||
| 173 | -! | +||
| 52 | +
- title = "Plot settings",+ #' ) |
||
| 174 | -! | +||
| 53 | +
- teal.widgets::optionalSliderInputValMinMax(ns("alpha"), "Scatterplot opacity:", c(0.5, 0, 1), ticks = FALSE),
+ #' if (interactive()) {
|
||
| 175 | -! | +||
| 54 | +
- teal.widgets::optionalSliderInputValMinMax(ns("size"), "Scatterplot points size:", c(2, 1, 8), ticks = FALSE),
+ #' shinyApp(app$ui, app$server) |
||
| 176 | -! | +||
| 55 | +
- checkboxInput(ns("swap_axes"), "Swap axes", value = FALSE),
+ #' } |
||
| 177 | -! | +||
| 56 | +
- checkboxInput(ns("rotate_xaxis_labels"), "Rotate X axis labels", value = FALSE),
+ #' |
||
| 178 | -! | +||
| 57 | +
- selectInput(+ #' # Example with clinical data |
||
| 179 | -! | +||
| 58 | +
- inputId = ns("distribution_theme"),
+ #' data <- teal_data() |
||
| 180 | -! | +||
| 59 | +
- label = "Distribution theme (by ggplot):",+ #' data <- within(data, {
|
||
| 181 | -! | +||
| 60 | +
- choices = ggplot_themes,+ #' ADSL <- teal.modules.general::rADSL |
||
| 182 | -! | +||
| 61 | +
- selected = args$distribution_theme,+ #' }) |
||
| 183 | -! | +||
| 62 | +
- multiple = FALSE+ #' datanames <- c("ADSL")
|
||
| 184 | +63 |
- ),+ #' datanames(data) <- datanames |
|
| 185 | -! | +||
| 64 | +
- selectInput(+ #' join_keys(data) <- default_cdisc_join_keys[datanames] |
||
| 186 | -! | +||
| 65 | +
- inputId = ns("association_theme"),
+ #' |
||
| 187 | -! | +||
| 66 | +
- label = "Association theme (by ggplot):",+ #' vars1 <- choices_selected( |
||
| 188 | -! | +||
| 67 | +
- choices = ggplot_themes,+ #' variable_choices(data[["ADSL"]], c("ARM", "COUNTRY", "SEX")),
|
||
| 189 | -! | +||
| 68 | +
- selected = args$association_theme,+ #' selected = NULL |
||
| 190 | -! | +||
| 69 | +
- multiple = FALSE+ #' ) |
||
| 191 | +70 |
- )+ #' |
|
| 192 | +71 |
- )+ #' app <- teal::init( |
|
| 193 | +72 |
- )+ #' data = data, |
|
| 194 | +73 |
- ),+ #' modules = teal::modules( |
|
| 195 | -! | +||
| 74 | +
- forms = tagList(+ #' teal.modules.general::tm_g_distribution( |
||
| 196 | -! | +||
| 75 | +
- teal.widgets::verbatim_popup_ui(ns("warning"), "Show Warnings"),
+ #' dist_var = teal.transform::data_extract_spec( |
||
| 197 | -! | +||
| 76 | +
- teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code")
+ #' dataname = "ADSL", |
||
| 198 | +77 |
- ),+ #' select = teal.transform::select_spec( |
|
| 199 | -! | +||
| 78 | +
- pre_output = args$pre_output,+ #' choices = teal.transform::variable_choices(data[["ADSL"]], c("AGE", "BMRKR1")),
|
||
| 200 | -! | +||
| 79 | +
- post_output = args$post_output+ #' selected = "BMRKR1", |
||
| 201 | +80 |
- )+ #' multiple = FALSE, |
|
| 202 | +81 |
- }+ #' fixed = FALSE |
|
| 203 | +82 |
-
+ #' ) |
|
| 204 | +83 |
- srv_tm_g_association <- function(id,+ #' ), |
|
| 205 | +84 |
- data,+ #' strata_var = teal.transform::data_extract_spec( |
|
| 206 | +85 |
- reporter,+ #' dataname = "ADSL", |
|
| 207 | +86 |
- filter_panel_api,+ #' filter = teal.transform::filter_spec( |
|
| 208 | +87 |
- ref,+ #' vars = vars1, |
|
| 209 | +88 |
- vars,+ #' multiple = TRUE |
|
| 210 | +89 |
- plot_height,+ #' ) |
|
| 211 | +90 |
- plot_width,+ #' ), |
|
| 212 | +91 |
- ggplot2_args) {
+ #' group_var = teal.transform::data_extract_spec( |
|
| 213 | -! | +||
| 92 | +
- with_reporter <- !missing(reporter) && inherits(reporter, "Reporter")+ #' dataname = "ADSL", |
||
| 214 | -! | +||
| 93 | +
- with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI")+ #' filter = teal.transform::filter_spec( |
||
| 215 | -! | +||
| 94 | +
- checkmate::assert_class(data, "reactive")+ #' vars = vars1, |
||
| 216 | -! | +||
| 95 | +
- checkmate::assert_class(isolate(data()), "teal_data")+ #' multiple = TRUE |
||
| 217 | +96 |
-
+ #' ) |
|
| 218 | -! | +||
| 97 | +
- moduleServer(id, function(input, output, session) {
+ #' ), |
||
| 219 | -! | +||
| 98 | +
- selector_list <- teal.transform::data_extract_multiple_srv(+ #' ggplot2_args = teal.widgets::ggplot2_args( |
||
| 220 | -! | +||
| 99 | +
- data_extract = list(ref = ref, vars = vars),+ #' labs = list(subtitle = "Plot generated by Distribution Module") |
||
| 221 | -! | +||
| 100 | +
- datasets = data,+ #' ) |
||
| 222 | -! | +||
| 101 | +
- select_validation_rule = list(+ #' ) |
||
| 223 | -! | +||
| 102 | +
- ref = shinyvalidate::compose_rules(+ #' ) |
||
| 224 | -! | +||
| 103 | +
- shinyvalidate::sv_required("A reference variable needs to be selected."),
+ #' ) |
||
| 225 | -! | +||
| 104 | +
- ~ if ((.) %in% selector_list()$vars()$select) {
+ #' if (interactive()) {
|
||
| 226 | -! | +||
| 105 | +
- "Associated variables and reference variable cannot overlap"+ #' shinyApp(app$ui, app$server) |
||
| 227 | +106 |
- }+ #' } |
|
| 228 | +107 |
- ),+ tm_g_distribution <- function(label = "Distribution Module", |
|
| 229 | -! | +||
| 108 | +
- vars = shinyvalidate::compose_rules(+ dist_var, |
||
| 230 | -! | +||
| 109 | +
- shinyvalidate::sv_required("An associated variable needs to be selected."),
+ strata_var = NULL, |
||
| 231 | -! | +||
| 110 | +
- ~ if (length(selector_list()$ref()$select) != 0 && selector_list()$ref()$select %in% (.)) {
+ group_var = NULL, |
||
| 232 | -! | +||
| 111 | +
- "Associated variables and reference variable cannot overlap"+ freq = FALSE, |
||
| 233 | +112 |
- }+ ggtheme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void"),
|
|
| 234 | +113 |
- )+ ggplot2_args = teal.widgets::ggplot2_args(), |
|
| 235 | +114 |
- )+ bins = c(30L, 1L, 100L), |
|
| 236 | +115 |
- )+ plot_height = c(600, 200, 2000), |
|
| 237 | +116 |
-
+ plot_width = NULL, |
|
| 238 | -! | +||
| 117 | +
- iv_r <- reactive({
+ pre_output = NULL, |
||
| 239 | -! | +||
| 118 | +
- iv <- shinyvalidate::InputValidator$new()+ post_output = NULL) {
|
||
| 240 | +119 | ! |
- teal.transform::compose_and_enable_validators(iv, selector_list)- |
-
| 241 | -- |
- })+ logger::log_info("Initializing tm_g_distribution")
|
|
| 242 | +120 | ||
| 243 | +121 | ! |
- anl_merged_input <- teal.transform::merge_expression_srv(+ extra_packages <- c("ggpmisc", "ggpp", "goftest", "MASS", "broom")
|
| 244 | +122 | ! |
- datasets = data,+ missing_packages <- Filter(function(x) !requireNamespace(x, quietly = TRUE), extra_packages) |
| 245 | +123 | ! |
- selector_list = selector_list- |
-
| 246 | -- |
- )+ if (length(missing_packages) > 0L) {
|
|
| 247 | -+ | ||
| 124 | +! |
-
+ stop(sprintf( |
|
| 248 | +125 | ! |
- anl_merged_q <- reactive({
+ "Cannot load package(s): %s.\nInstall or restart your session.", |
| 249 | +126 | ! |
- req(anl_merged_input())+ toString(missing_packages) |
| 250 | -! | +||
| 127 | +
- data() %>% teal.code::eval_code(as.expression(anl_merged_input()$expr))+ )) |
||
| 251 | +128 |
- })+ } |
|
| 252 | +129 | ||
| 253 | +130 | ! |
- merged <- list(+ if (inherits(dist_var, "data_extract_spec")) dist_var <- list(dist_var) |
| 254 | +131 | ! |
- anl_input_r = anl_merged_input,+ if (inherits(strata_var, "data_extract_spec")) strata_var <- list(strata_var) |
| 255 | +132 | ! |
- anl_q_r = anl_merged_q+ if (inherits(group_var, "data_extract_spec")) group_var <- list(group_var) |
| 256 | -+ | ||
| 133 | +! |
- )+ if (inherits(ggplot2_args, "ggplot2_args")) ggplot2_args <- list(default = ggplot2_args) |
|
| 257 | +134 | ||
| 258 | +135 | ! |
- output_q <- reactive({
+ ggtheme <- match.arg(ggtheme) |
| 259 | +136 | ! |
- teal::validate_inputs(iv_r())+ if (length(bins) == 1) {
+ |
+
| 137 | +! | +
+ checkmate::assert_numeric(bins, any.missing = FALSE, lower = 1) |
|
| 260 | +138 |
-
+ } else {
|
|
| 261 | +139 | ! |
- ANL <- merged$anl_q_r()[["ANL"]] # nolint object_name_linter+ checkmate::assert_numeric(bins, len = 3, any.missing = FALSE, lower = 1) |
| 262 | +140 | ! |
- teal::validate_has_data(ANL, 3)+ checkmate::assert_numeric(bins[1], lower = bins[2], upper = bins[3], .var.name = "bins") |
| 263 | +141 |
-
+ } |
|
| 264 | +142 | ! |
- vars_names <- merged$anl_input_r()$columns_source$vars- |
-
| 265 | -- |
-
+ checkmate::assert_string(label) |
|
| 266 | +143 | ! |
- ref_name <- as.vector(merged$anl_input_r()$columns_source$ref)+ checkmate::assert_list(dist_var, "data_extract_spec") |
| 267 | +144 | ! |
- association <- input$association+ checkmate::assert_false(dist_var[[1]]$select$multiple) |
| 268 | +145 | ! |
- show_dist <- input$show_dist+ checkmate::assert_list(strata_var, types = "data_extract_spec", null.ok = TRUE) |
| 269 | +146 | ! |
- log_transformation <- input$log_transformation+ checkmate::assert_list(group_var, types = "data_extract_spec", null.ok = TRUE) |
| 270 | +147 | ! |
- rotate_xaxis_labels <- input$rotate_xaxis_labels+ checkmate::assert_flag(freq) |
| 271 | +148 | ! |
- swap_axes <- input$swap_axes+ plot_choices <- c("Histogram", "QQplot")
|
| 272 | +149 | ! |
- distribution_theme <- input$distribution_theme+ checkmate::assert_list(ggplot2_args, types = "ggplot2_args") |
| 273 | +150 | ! |
- association_theme <- input$association_theme+ checkmate::assert_subset(names(ggplot2_args), c("default", plot_choices))
|
| 274 | +151 | ||
| 275 | +152 | ! |
- is_scatterplot <- is.numeric(ANL[[ref_name]]) && any(vapply(ANL[vars_names], is.numeric, logical(1)))+ args <- as.list(environment()) |
| 276 | -! | +||
| 153 | +
- if (is_scatterplot) {
+
|
||
| 277 | +154 | ! |
- shinyjs::show("alpha")
+ data_extract_list <- list( |
| 278 | +155 | ! |
- shinyjs::show("size")
+ dist_var = dist_var, |
| 279 | +156 | ! |
- alpha <- input$alpha+ strata_var = strata_var, |
| 280 | +157 | ! |
- size <- input$size+ group_var = group_var |
| 281 | +158 |
- } else {
+ ) |
|
| 282 | -! | +||
| 159 | +
- shinyjs::hide("alpha")
+
|
||
| 283 | +160 | ! |
- shinyjs::hide("size")
+ module( |
| 284 | +161 | ! |
- alpha <- 0.5+ label = label, |
| 285 | +162 | ! |
- size <- 2- |
-
| 286 | -- |
- }+ server = srv_distribution, |
|
| 287 | -+ | ||
| 163 | +! |
-
+ server_args = c( |
|
| 288 | +164 | ! |
- teal::validate_has_data(ANL[, c(ref_name, vars_names)], 3, complete = TRUE, allow_inf = FALSE)+ data_extract_list, |
| 289 | -+ | ||
| 165 | +! |
-
+ list(plot_height = plot_height, plot_width = plot_width, ggplot2_args = ggplot2_args) |
|
| 290 | +166 |
- # reference+ ), |
|
| 291 | +167 | ! |
- ref_class <- class(ANL[[ref_name]])+ ui = ui_distribution, |
| 292 | +168 | ! |
- if (is.numeric(ANL[[ref_name]]) && log_transformation) {
- |
-
| 293 | -- |
- # works for both integers and doubles+ ui_args = args, |
|
| 294 | +169 | ! |
- ref_cl_name <- call("log", as.name(ref_name))
+ datanames = teal.transform::get_extract_datanames(data_extract_list) |
| 295 | -! | +||
| 170 | +
- ref_cl_lbl <- varname_w_label(ref_name, ANL, prefix = "Log of ")+ ) |
||
| 296 | +171 |
- } else {
+ } |
|
| 297 | +172 |
- # silently ignore when non-numeric even if `log` is selected because some+ |
|
| 298 | +173 |
- # variables may be numeric and others not+ ui_distribution <- function(id, ...) {
|
|
| 299 | +174 | ! |
- ref_cl_name <- as.name(ref_name)+ args <- list(...) |
| 300 | +175 | ! |
- ref_cl_lbl <- varname_w_label(ref_name, ANL)+ ns <- NS(id) |
| 301 | -+ | ||
| 176 | +! |
- }+ is_single_dataset_value <- teal.transform::is_single_dataset(args$dist_var, args$strata_var, args$group_var) |
|
| 302 | +177 | ||
| 303 | +178 | ! |
- user_ggplot2_args <- teal.widgets::resolve_ggplot2_args(+ teal.widgets::standard_layout( |
| 304 | +179 | ! |
- user_plot = ggplot2_args[["Bivariate1"]],+ output = teal.widgets::white_small_well( |
| 305 | +180 | ! |
- user_default = ggplot2_args$default+ tabsetPanel( |
| 306 | -+ | ||
| 181 | +! |
- )+ id = ns("tabs"),
|
|
| 307 | -+ | ||
| 182 | +! |
-
+ tabPanel("Histogram", teal.widgets::plot_with_settings_ui(id = ns("hist_plot"))),
|
|
| 308 | +183 | ! |
- ref_call <- bivariate_plot_call(+ tabPanel("QQplot", teal.widgets::plot_with_settings_ui(id = ns("qq_plot")))
|
| 309 | -! | +||
| 184 | +
- data_name = "ANL",+ ), |
||
| 310 | +185 | ! |
- x = ref_cl_name,+ h3("Statistics Table"),
|
| 311 | +186 | ! |
- x_class = ref_class,+ DT::dataTableOutput(ns("summary_table")),
|
| 312 | +187 | ! |
- x_label = ref_cl_lbl,+ h3("Tests"),
|
| 313 | +188 | ! |
- freq = !show_dist,+ DT::dataTableOutput(ns("t_stats"))
|
| 314 | -! | +||
| 189 | +
- theme = distribution_theme,+ ), |
||
| 315 | +190 | ! |
- rotate_xaxis_labels = rotate_xaxis_labels,+ encoding = div(+ |
+
| 191 | ++ |
+ ### Reporter |
|
| 316 | +192 | ! |
- swap_axes = FALSE,+ teal.reporter::simple_reporter_ui(ns("simple_reporter")),
+ |
+
| 193 | ++ |
+ ### |
|
| 317 | +194 | ! |
- size = size,+ tags$label("Encodings", class = "text-primary"),
|
| 318 | +195 | ! |
- alpha = alpha,+ teal.transform::datanames_input(args[c("dist_var", "strata_var")]),
|
| 319 | +196 | ! |
- ggplot2_args = user_ggplot2_args+ teal.transform::data_extract_ui( |
| 320 | -+ | ||
| 197 | +! |
- )+ id = ns("dist_i"),
|
|
| 321 | -+ | ||
| 198 | +! |
-
+ label = "Variable", |
|
| 322 | -+ | ||
| 199 | +! |
- # association+ data_extract_spec = args$dist_var, |
|
| 323 | +200 | ! |
- ref_class_cov <- ifelse(association, ref_class, "NULL")+ is_single_dataset = is_single_dataset_value |
| 324 | +201 |
-
+ ), |
|
| 325 | +202 | ! |
- print_call <- quote(print(p))- |
-
| 326 | -- |
-
+ if (!is.null(args$group_var)) {
|
|
| 327 | +203 | ! |
- var_calls <- lapply(vars_names, function(var_i) {
+ tagList( |
| 328 | +204 | ! |
- var_class <- class(ANL[[var_i]])+ teal.transform::data_extract_ui( |
| 329 | +205 | ! |
- if (is.numeric(ANL[[var_i]]) && log_transformation) {
+ id = ns("group_i"),
|
| 330 | -+ | ||
| 206 | +! |
- # works for both integers and doubles+ label = "Group by", |
|
| 331 | +207 | ! |
- var_cl_name <- call("log", as.name(var_i))
+ data_extract_spec = args$group_var, |
| 332 | +208 | ! |
- var_cl_lbl <- varname_w_label(var_i, ANL, prefix = "Log of ")+ is_single_dataset = is_single_dataset_value |
| 333 | +209 |
- } else {
+ ),+ |
+ |
| 210 | +! | +
+ uiOutput(ns("scales_types_ui"))
|
|
| 334 | +211 |
- # silently ignore when non-numeric even if `log` is selected because some+ ) |
|
| 335 | +212 |
- # variables may be numeric and others not+ }, |
|
| 336 | +213 | ! |
- var_cl_name <- as.name(var_i)+ if (!is.null(args$strata_var)) {
|
| 337 | +214 | ! |
- var_cl_lbl <- varname_w_label(var_i, ANL)- |
-
| 338 | -- |
- }+ teal.transform::data_extract_ui( |
|
| 339 | -+ | ||
| 215 | +! |
-
+ id = ns("strata_i"),
|
|
| 340 | +216 | ! |
- user_ggplot2_args <- teal.widgets::resolve_ggplot2_args(+ label = "Stratify by", |
| 341 | +217 | ! |
- user_plot = ggplot2_args[["Bivariate2"]],+ data_extract_spec = args$strata_var, |
| 342 | +218 | ! |
- user_default = ggplot2_args$default+ is_single_dataset = is_single_dataset_value |
| 343 | +219 |
) |
|
| 344 | +220 |
-
+ }, |
|
| 345 | +221 | ! |
- bivariate_plot_call(+ teal.widgets::panel_group( |
| 346 | +222 | ! |
- data_name = "ANL",+ conditionalPanel( |
| 347 | +223 | ! |
- x = ref_cl_name,+ condition = paste0("input['", ns("tabs"), "'] == 'Histogram'"),
|
| 348 | +224 | ! |
- y = var_cl_name,+ teal.widgets::panel_item( |
| 349 | +225 | ! |
- x_class = ref_class_cov,+ "Histogram", |
| 350 | +226 | ! |
- y_class = var_class,+ teal.widgets::optionalSliderInputValMinMax(ns("bins"), "Bins", args$bins, ticks = FALSE, step = 1),
|
| 351 | +227 | ! |
- x_label = ref_cl_lbl,+ shinyWidgets::prettyRadioButtons( |
| 352 | +228 | ! |
- y_label = var_cl_lbl,+ ns("main_type"),
|
| 353 | +229 | ! |
- theme = association_theme,+ label = "Plot Type:", |
| 354 | +230 | ! |
- freq = !show_dist,+ choices = c("Density", "Frequency"),
|
| 355 | +231 | ! |
- rotate_xaxis_labels = rotate_xaxis_labels,+ selected = if (!args$freq) "Density" else "Frequency", |
| 356 | +232 | ! |
- swap_axes = swap_axes,+ bigger = FALSE, |
| 357 | +233 | ! |
- alpha = alpha,+ inline = TRUE |
| 358 | -! | +||
| 234 | +
- size = size,+ ), |
||
| 359 | +235 | ! |
- ggplot2_args = user_ggplot2_args+ checkboxInput(ns("add_dens"), label = "Overlay Density", value = TRUE),
|
| 360 | -+ | ||
| 236 | +! |
- )+ collapsed = FALSE |
|
| 361 | +237 |
- })+ ) |
|
| 362 | +238 |
-
+ ), |
|
| 363 | -+ | ||
| 239 | +! |
- # helper function to format variable name+ conditionalPanel( |
|
| 364 | +240 | ! |
- format_varnames <- function(x) {
+ condition = paste0("input['", ns("tabs"), "'] == 'QQplot'"),
|
| 365 | +241 | ! |
- if (is.numeric(ANL[[x]]) && log_transformation) {
+ teal.widgets::panel_item( |
| 366 | +242 | ! |
- varname_w_label(x, ANL, prefix = "Log of ")+ "QQ Plot", |
| 367 | -+ | ||
| 243 | +! |
- } else {
+ checkboxInput(ns("qq_line"), label = "Add diagonal line(s)", TRUE),
|
|
| 368 | +244 | ! |
- varname_w_label(x, ANL)+ collapsed = FALSE |
| 369 | +245 |
- }+ ) |
|
| 370 | +246 |
- }+ ), |
|
| 371 | +247 | ! |
- new_title <-+ conditionalPanel( |
| 372 | +248 | ! |
- if (association) {
+ condition = paste0("input['", ns("main_type"), "'] == 'Density'"),
|
| 373 | +249 | ! |
- switch(as.character(length(vars_names)),+ teal.widgets::panel_item( |
| 374 | +250 | ! |
- "0" = sprintf("Value distribution for %s", ref_cl_lbl),
+ "Theoretical Distribution", |
| 375 | +251 | ! |
- "1" = sprintf(+ teal.widgets::optionalSelectInput( |
| 376 | +252 | ! |
- "Association between %s and %s",+ ns("t_dist"),
|
| 377 | +253 | ! |
- ref_cl_lbl,+ div( |
| 378 | +254 | ! |
- format_varnames(vars_names)+ class = "teal-tooltip", |
| 379 | -+ | ||
| 255 | +! |
- ),+ tagList( |
|
| 380 | +256 | ! |
- sprintf(+ "Distribution:", |
| 381 | +257 | ! |
- "Associations between %s and: %s",+ icon("circle-info"),
|
| 382 | +258 | ! |
- ref_cl_lbl,+ span( |
| 383 | +259 | ! |
- paste(lapply(vars_names, format_varnames), collapse = ", ")+ class = "tooltiptext",+ |
+
| 260 | +! | +
+ "Default parameters are optimized with MASS::fitdistr function." |
|
| 384 | +261 |
- )+ ) |
|
| 385 | +262 |
- )+ ) |
|
| 386 | +263 |
- } else {
+ ), |
|
| 387 | +264 | ! |
- switch(as.character(length(vars_names)),+ choices = c("normal", "lognormal", "gamma", "unif"),
+ |
+
| 265 | +! | +
+ selected = NULL,+ |
+ |
| 266 | +! | +
+ multiple = FALSE |
|
| 388 | -! | +||
| 267 | +
- "0" = sprintf("Value distribution for %s", ref_cl_lbl),
+ ), |
||
| 389 | +268 | ! |
- sprintf(+ numericInput(ns("dist_param1"), label = "param1", value = NULL),
|
| 390 | +269 | ! |
- "Value distributions for %s and %s",+ numericInput(ns("dist_param2"), label = "param2", value = NULL),
|
| 391 | +270 | ! |
- ref_cl_lbl,+ span(actionButton(ns("params_reset"), "Reset params")),
|
| 392 | +271 | ! |
- paste(lapply(vars_names, format_varnames), collapse = ", ")+ collapsed = FALSE |
| 393 | +272 |
- )+ ) |
|
| 394 | +273 |
- )+ ) |
|
| 395 | +274 |
- }+ ), |
|
| 396 | -+ | ||
| 275 | +! |
-
+ teal.widgets::panel_item( |
|
| 397 | +276 | ! |
- teal.code::eval_code(+ "Tests", |
| 398 | +277 | ! |
- merged$anl_q_r(),+ teal.widgets::optionalSelectInput( |
| 399 | +278 | ! |
- substitute(+ ns("dist_tests"),
|
| 400 | +279 | ! |
- expr = title <- new_title,+ "Tests:", |
| 401 | +280 | ! |
- env = list(new_title = new_title)+ choices = c( |
| 402 | -+ | ||
| 281 | +! |
- )+ "Shapiro-Wilk", |
|
| 403 | -+ | ||
| 282 | +! |
- ) %>%+ if (!is.null(args$strata_var)) "t-test (two-samples, not paired)", |
|
| 404 | +283 | ! |
- teal.code::eval_code(+ if (!is.null(args$strata_var)) "one-way ANOVA", |
| 405 | +284 | ! |
- substitute(+ if (!is.null(args$strata_var)) "Fligner-Killeen", |
| 406 | +285 | ! |
- expr = {
+ if (!is.null(args$strata_var)) "F-test", |
| 407 | +286 | ! |
- plots <- plot_calls+ "Kolmogorov-Smirnov (one-sample)", |
| 408 | +287 | ! |
- p <- tern::stack_grobs(grobs = lapply(plots, ggplotGrob))+ "Anderson-Darling (one-sample)", |
| 409 | +288 | ! |
- grid::grid.newpage()+ "Cramer-von Mises (one-sample)", |
| 410 | +289 | ! |
- grid::grid.draw(p)+ if (!is.null(args$strata_var)) "Kolmogorov-Smirnov (two-samples)" |
| 411 | +290 |
- },+ ), |
|
| 412 | +291 | ! |
- env = list(+ selected = NULL |
| 413 | -! | +||
| 292 | +
- plot_calls = do.call(+ )+ |
+ ||
| 293 | ++ |
+ ), |
|
| 414 | +294 | ! |
- "call",+ teal.widgets::panel_item( |
| 415 | +295 | ! |
- c(list("list", ref_call), var_calls),
+ "Statistics Table", |
| 416 | +296 | ! |
- quote = TRUE+ sliderInput(ns("roundn"), "Round to n digits", min = 0, max = 10, value = 2)
|
| 417 | +297 |
- )+ ), |
|
| 418 | -+ | ||
| 298 | +! |
- )+ teal.widgets::panel_item( |
|
| 419 | -+ | ||
| 299 | +! |
- )+ title = "Plot settings", |
|
| 420 | -+ | ||
| 300 | +! |
- )+ selectInput( |
|
| 421 | -+ | ||
| 301 | +! |
- })+ inputId = ns("ggtheme"),
|
|
| 422 | -+ | ||
| 302 | +! |
-
+ label = "Theme (by ggplot):", |
|
| 423 | +303 | ! |
- plot_r <- shiny::reactive({
+ choices = ggplot_themes, |
| 424 | +304 | ! |
- shiny::req(iv_r()$is_valid())+ selected = args$ggtheme, |
| 425 | +305 | ! |
- output_q()[["p"]]+ multiple = FALSE |
| 426 | +306 |
- })+ ) |
|
| 427 | +307 |
-
+ )+ |
+ |
| 308 | ++ |
+ ), |
|
| 428 | +309 | ! |
- pws <- teal.widgets::plot_with_settings_srv(+ forms = tagList( |
| 429 | +310 | ! |
- id = "myplot",+ teal.widgets::verbatim_popup_ui(ns("warning"), "Show Warnings"),
|
| 430 | +311 | ! |
- plot_r = plot_r,+ teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code")
+ |
+
| 312 | ++ |
+ ), |
|
| 431 | +313 | ! |
- height = plot_height,+ pre_output = args$pre_output, |
| 432 | +314 | ! |
- width = plot_width+ post_output = args$post_output |
| 433 | +315 |
- )+ ) |
|
| 434 | +316 |
-
+ } |
|
| 435 | -! | +||
| 317 | +
- output$title <- renderText({
+
|
||
| 436 | -! | +||
| 318 | +
- teal.code::dev_suppress(output_q()[["title"]])+ srv_distribution <- function(id, |
||
| 437 | +319 |
- })+ data, |
|
| 438 | +320 |
-
+ reporter, |
|
| 439 | -! | +||
| 321 | +
- teal.widgets::verbatim_popup_srv(+ filter_panel_api, |
||
| 440 | -! | +||
| 322 | +
- id = "warning",+ dist_var, |
||
| 441 | -! | +||
| 323 | +
- verbatim_content = reactive(teal.code::get_warnings(output_q())),+ strata_var, |
||
| 442 | -! | +||
| 324 | +
- title = "Warning",+ group_var, |
||
| 443 | -! | +||
| 325 | +
- disabled = reactive(is.null(teal.code::get_warnings(output_q())))+ plot_height, |
||
| 444 | +326 |
- )+ plot_width, |
|
| 445 | +327 |
-
+ ggplot2_args) {
|
|
| 446 | +328 | ! |
- teal.widgets::verbatim_popup_srv(+ with_reporter <- !missing(reporter) && inherits(reporter, "Reporter") |
| 447 | +329 | ! |
- id = "rcode",+ with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI") |
| 448 | +330 | ! |
- verbatim_content = reactive(teal.code::get_code(output_q())),+ checkmate::assert_class(data, "reactive") |
| 449 | +331 | ! |
- title = "Association Plot"- |
-
| 450 | -- |
- )- |
- |
| 451 | -- |
-
+ checkmate::assert_class(isolate(data()), "teal_data") |
|
| 452 | -+ | ||
| 332 | +! |
- ### REPORTER+ moduleServer(id, function(input, output, session) {
|
|
| 453 | +333 | ! |
- if (with_reporter) {
+ rule_req <- function(value) {
|
| 454 | +334 | ! |
- card_fun <- function(comment, label) {
+ if (isTRUE(input$dist_tests %in% c( |
| 455 | +335 | ! |
- card <- teal::report_card_template(+ "Fligner-Killeen", |
| 456 | +336 | ! |
- title = "Association Plot",+ "t-test (two-samples, not paired)", |
| 457 | +337 | ! |
- label = label,+ "F-test", |
| 458 | +338 | ! |
- with_filter = with_filter,+ "Kolmogorov-Smirnov (two-samples)", |
| 459 | +339 | ! |
- filter_panel_api = filter_panel_api+ "one-way ANOVA" |
| 460 | +340 |
- )+ ))) {
|
|
| 461 | +341 | ! |
- card$append_text("Plot", "header3")
+ if (!shinyvalidate::input_provided(value)) {
|
| 462 | +342 | ! |
- card$append_plot(plot_r(), dim = pws$dim())+ "Please select stratify variable." |
| 463 | -! | +||
| 343 | +
- if (!comment == "") {
+ } |
||
| 464 | -! | +||
| 344 | +
- card$append_text("Comment", "header3")
+ }+ |
+ ||
| 345 | ++ |
+ } |
|
| 465 | +346 | ! |
- card$append_text(comment)+ rule_dupl <- function(...) {
|
| 466 | -+ | ||
| 347 | +! |
- }+ if (identical(input$dist_tests, "Fligner-Killeen")) {
|
|
| 467 | +348 | ! |
- card$append_src(teal.code::get_code(output_q()))+ strata <- selector_list()$strata_i()$select |
| 468 | +349 | ! |
- card+ group <- selector_list()$group_i()$select |
| 469 | -+ | ||
| 350 | +! |
- }+ if (isTRUE(strata == group)) {
|
|
| 470 | +351 | ! |
- teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
+ "Please select different variables for strata and group." |
| 471 | +352 |
- }+ } |
|
| 472 | +353 |
- ###+ } |
|
| 473 | +354 |
- })+ } |
|
| 474 | +355 |
- }+ |
| 1 | -+ | ||
| 356 | +! |
- #' Distribution Module+ selector_list <- teal.transform::data_extract_multiple_srv( |
|
| 2 | -+ | ||
| 357 | +! |
- #' @md+ data_extract = list( |
|
| 3 | -+ | ||
| 358 | +! |
- #'+ dist_i = dist_var, |
|
| 4 | -+ | ||
| 359 | +! |
- #' @details+ strata_i = strata_var, |
|
| 5 | -+ | ||
| 360 | +! |
- #' Module to analyze and explore univariate variable distribution+ group_i = group_var |
|
| 6 | +361 |
- #'+ ), |
|
| 7 | -+ | ||
| 362 | +! |
- #' @inheritParams teal::module+ data, |
|
| 8 | -+ | ||
| 363 | +! |
- #' @inheritParams teal.widgets::standard_layout+ select_validation_rule = list( |
|
| 9 | -+ | ||
| 364 | +! |
- #' @inheritParams shared_params+ dist_i = shinyvalidate::sv_required("Please select a variable")
|
|
| 10 | +365 |
- #'+ ), |
|
| 11 | -+ | ||
| 366 | +! |
- #' @param dist_var (`data_extract_spec` or `list` of multiple `data_extract_spec`)+ filter_validation_rule = list( |
|
| 12 | -+ | ||
| 367 | +! |
- #' Variable to consider for the distribution analysis.+ strata_i = shinyvalidate::compose_rules( |
|
| 13 | -+ | ||
| 368 | +! |
- #' @param strata_var (`data_extract_spec` or `list` of multiple `data_extract_spec`)+ rule_req, |
|
| 14 | -+ | ||
| 369 | +! |
- #' Categorical variable to split the selected distribution variable on.+ rule_dupl |
|
| 15 | +370 |
- #' @param group_var optional, (`data_extract_spec` or `list` of multiple `data_extract_spec`)+ ), |
|
| 16 | -+ | ||
| 371 | +! |
- #' Which data columns to use for faceting rows.+ group_i = rule_dupl |
|
| 17 | +372 |
- #' @param freq optional, (`logical`) Whether to display frequency (`TRUE`) or density (`FALSE`).+ ) |
|
| 18 | +373 |
- #' Defaults to density (`FALSE`).+ ) |
|
| 19 | +374 |
- #' @param bins optional, (`integer(1)` or `integer(3)`) If scalar then the histogram bins will have a fixed size.+ |
|
| 20 | -+ | ||
| 375 | +! |
- #' If a slider should be presented to adjust the number of histogram bins dynamically then it can be a+ iv_r <- reactive({
|
|
| 21 | -+ | ||
| 376 | +! |
- #' vector of length three with `c(value, min, max)`.+ iv <- shinyvalidate::InputValidator$new() |
|
| 22 | -+ | ||
| 377 | +! |
- #' Defaults to `c(30L, 1L, 100L)`.+ teal.transform::compose_and_enable_validators(iv, selector_list, validator_names = "dist_i") |
|
| 23 | +378 |
- #'+ }) |
|
| 24 | +379 |
- #' @templateVar ggnames "Histogram", "QQplot"+ |
|
| 25 | -+ | ||
| 380 | +! |
- #' @template ggplot2_args_multi+ iv_r_dist <- reactive({
|
|
| 26 | -+ | ||
| 381 | +! |
- #'+ iv <- shinyvalidate::InputValidator$new() |
|
| 27 | -+ | ||
| 382 | +! |
- #'+ teal.transform::compose_and_enable_validators( |
|
| 28 | -+ | ||
| 383 | +! |
- #' @export+ iv, selector_list, |
|
| 29 | -+ | ||
| 384 | +! |
- #'+ validator_names = c("strata_i", "group_i")
|
|
| 30 | +385 |
- #' @examples+ ) |
|
| 31 | +386 |
- #' # Example with non-clinical data+ }) |
|
| 32 | -+ | ||
| 387 | +! |
- #'+ rule_dist_1 <- function(value) {
|
|
| 33 | -+ | ||
| 388 | +! |
- #' data <- teal_data()+ if (!is.null(input$t_dist)) {
|
|
| 34 | -+ | ||
| 389 | +! |
- #' data <- within(data, {
+ switch(input$t_dist, |
|
| 35 | -+ | ||
| 390 | +! |
- #' iris <- iris+ "normal" = if (!shinyvalidate::input_provided(value)) "mean is required", |
|
| 36 | -+ | ||
| 391 | +! |
- #' })+ "lognormal" = if (!shinyvalidate::input_provided(value)) "meanlog is required", |
|
| 37 | -+ | ||
| 392 | +! |
- #' datanames(data) <- c("iris")
+ "gamma" = {
|
|
| 38 | -+ | ||
| 393 | +! |
- #'+ if (!shinyvalidate::input_provided(value)) "shape is required" else if (value <= 0) "shape must be positive" |
|
| 39 | +394 |
- #' app <- teal::init(+ }, |
|
| 40 | -+ | ||
| 395 | +! |
- #' data = data,+ "unif" = NULL |
|
| 41 | +396 |
- #' modules = list(+ ) |
|
| 42 | +397 |
- #' teal.modules.general::tm_g_distribution(+ } |
|
| 43 | +398 |
- #' dist_var = teal.transform::data_extract_spec(+ } |
|
| 44 | -+ | ||
| 399 | +! |
- #' dataname = "iris",+ rule_dist_2 <- function(value) {
|
|
| 45 | -+ | ||
| 400 | +! |
- #' select = teal.transform::select_spec(variable_choices("iris"), "Petal.Length")
+ if (!is.null(input$t_dist)) {
|
|
| 46 | -+ | ||
| 401 | +! |
- #' ),+ switch(input$t_dist, |
|
| 47 | -+ | ||
| 402 | +! |
- #' ggplot2_args = teal.widgets::ggplot2_args(+ "normal" = {
|
|
| 48 | -+ | ||
| 403 | +! |
- #' labs = list(subtitle = "Plot generated by Distribution Module")+ if (!shinyvalidate::input_provided(value)) {
|
|
| 49 | -+ | ||
| 404 | +! |
- #' )+ "sd is required" |
|
| 50 | -+ | ||
| 405 | +! |
- #' )+ } else if (value < 0) {
|
|
| 51 | -+ | ||
| 406 | +! |
- #' )+ "sd must be non-negative" |
|
| 52 | +407 |
- #' )+ } |
|
| 53 | +408 |
- #' if (interactive()) {
+ }, |
|
| 54 | -+ | ||
| 409 | +! |
- #' shinyApp(app$ui, app$server)+ "lognormal" = {
|
|
| 55 | -+ | ||
| 410 | +! |
- #' }+ if (!shinyvalidate::input_provided(value)) {
|
|
| 56 | -+ | ||
| 411 | +! |
- #'+ "sdlog is required" |
|
| 57 | -+ | ||
| 412 | +! |
- #' # Example with clinical data+ } else if (value < 0) {
|
|
| 58 | -+ | ||
| 413 | +! |
- #' data <- teal_data()+ "sdlog must be non-negative" |
|
| 59 | +414 |
- #' data <- within(data, {
+ } |
|
| 60 | +415 |
- #' ADSL <- teal.modules.general::rADSL+ }, |
|
| 61 | -+ | ||
| 416 | +! |
- #' })+ "gamma" = {
|
|
| 62 | -+ | ||
| 417 | +! |
- #' datanames <- c("ADSL")
+ if (!shinyvalidate::input_provided(value)) {
|
|
| 63 | -+ | ||
| 418 | +! |
- #' datanames(data) <- datanames+ "rate is required" |
|
| 64 | -+ | ||
| 419 | +! |
- #' join_keys(data) <- default_cdisc_join_keys[datanames]+ } else if (value <= 0) {
|
|
| 65 | -+ | ||
| 420 | +! |
- #'+ "rate must be positive" |
|
| 66 | +421 |
- #' vars1 <- choices_selected(+ } |
|
| 67 | +422 |
- #' variable_choices(data[["ADSL"]], c("ARM", "COUNTRY", "SEX")),
+ }, |
|
| 68 | -+ | ||
| 423 | +! |
- #' selected = NULL+ "unif" = NULL |
|
| 69 | +424 |
- #' )+ ) |
|
| 70 | +425 |
- #'+ } |
|
| 71 | +426 |
- #' app <- teal::init(+ } |
|
| 72 | -+ | ||
| 427 | +! |
- #' data = data,+ rule_dist <- function(value) {
|
|
| 73 | -+ | ||
| 428 | +! |
- #' modules = teal::modules(+ if (isTRUE(input$tabs == "QQplot" || |
|
| 74 | -+ | ||
| 429 | +! |
- #' teal.modules.general::tm_g_distribution(+ input$dist_tests %in% c( |
|
| 75 | -+ | ||
| 430 | +! |
- #' dist_var = teal.transform::data_extract_spec(+ "Kolmogorov-Smirnov (one-sample)", |
|
| 76 | -+ | ||
| 431 | +! |
- #' dataname = "ADSL",+ "Anderson-Darling (one-sample)", |
|
| 77 | -+ | ||
| 432 | +! |
- #' select = teal.transform::select_spec(+ "Cramer-von Mises (one-sample)" |
|
| 78 | +433 |
- #' choices = teal.transform::variable_choices(data[["ADSL"]], c("AGE", "BMRKR1")),
+ ))) {
|
|
| 79 | -+ | ||
| 434 | +! |
- #' selected = "BMRKR1",+ if (!shinyvalidate::input_provided(value)) {
|
|
| 80 | -+ | ||
| 435 | +! |
- #' multiple = FALSE,+ "Please select the theoretical distribution." |
|
| 81 | +436 |
- #' fixed = FALSE+ } |
|
| 82 | +437 |
- #' )+ } |
|
| 83 | +438 |
- #' ),+ } |
|
| 84 | -+ | ||
| 439 | +! |
- #' strata_var = teal.transform::data_extract_spec(+ iv_dist <- shinyvalidate::InputValidator$new() |
|
| 85 | -+ | ||
| 440 | +! |
- #' dataname = "ADSL",+ iv_dist$add_rule("t_dist", rule_dist)
|
|
| 86 | -+ | ||
| 441 | +! |
- #' filter = teal.transform::filter_spec(+ iv_dist$add_rule("dist_param1", rule_dist_1)
|
|
| 87 | -+ | ||
| 442 | +! |
- #' vars = vars1,+ iv_dist$add_rule("dist_param2", rule_dist_2)
|
|
| 88 | -+ | ||
| 443 | +! |
- #' multiple = TRUE+ iv_dist$enable() |
|
| 89 | +444 |
- #' )+ |
|
| 90 | -+ | ||
| 445 | +! |
- #' ),+ anl_merged_input <- teal.transform::merge_expression_srv( |
|
| 91 | -+ | ||
| 446 | +! |
- #' group_var = teal.transform::data_extract_spec(+ selector_list = selector_list, |
|
| 92 | -+ | ||
| 447 | +! |
- #' dataname = "ADSL",+ datasets = data |
|
| 93 | +448 |
- #' filter = teal.transform::filter_spec(+ ) |
|
| 94 | +449 |
- #' vars = vars1,+ |
|
| 95 | -+ | ||
| 450 | +! |
- #' multiple = TRUE+ anl_merged_q <- reactive({
|
|
| 96 | -+ | ||
| 451 | +! |
- #' )+ req(anl_merged_input()) |
|
| 97 | -+ | ||
| 452 | +! |
- #' ),+ data() %>% |
|
| 98 | -+ | ||
| 453 | +! |
- #' ggplot2_args = teal.widgets::ggplot2_args(+ teal.code::eval_code(as.expression(anl_merged_input()$expr)) |
|
| 99 | +454 |
- #' labs = list(subtitle = "Plot generated by Distribution Module")+ }) |
|
| 100 | +455 |
- #' )+ |
|
| 101 | -+ | ||
| 456 | +! |
- #' )+ merged <- list( |
|
| 102 | -+ | ||
| 457 | +! |
- #' )+ anl_input_r = anl_merged_input, |
|
| 103 | -+ | ||
| 458 | +! |
- #' )+ anl_q_r = anl_merged_q |
|
| 104 | +459 |
- #' if (interactive()) {
+ ) |
|
| 105 | +460 |
- #' shinyApp(app$ui, app$server)+ |
|
| 106 | -+ | ||
| 461 | +! |
- #' }+ output$scales_types_ui <- renderUI({
|
|
| 107 | -+ | ||
| 462 | +! |
- tm_g_distribution <- function(label = "Distribution Module",+ if ("group_i" %in% names(selector_list()) && length(selector_list()$group_i()$filters[[1]]$selected) > 0) {
|
|
| 108 | -+ | ||
| 463 | +! |
- dist_var,+ shinyWidgets::prettyRadioButtons( |
|
| 109 | -+ | ||
| 464 | +! |
- strata_var = NULL,+ session$ns("scales_type"),
|
|
| 110 | -+ | ||
| 465 | +! |
- group_var = NULL,+ label = "Scales:", |
|
| 111 | -+ | ||
| 466 | +! |
- freq = FALSE,+ choices = c("Fixed", "Free"),
|
|
| 112 | -+ | ||
| 467 | +! |
- ggtheme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void"),
+ selected = "Fixed", |
|
| 113 | -+ | ||
| 468 | +! |
- ggplot2_args = teal.widgets::ggplot2_args(),+ bigger = FALSE, |
|
| 114 | -+ | ||
| 469 | +! |
- bins = c(30L, 1L, 100L),+ inline = TRUE |
|
| 115 | +470 |
- plot_height = c(600, 200, 2000),+ ) |
|
| 116 | +471 |
- plot_width = NULL,+ } |
|
| 117 | +472 |
- pre_output = NULL,+ }) |
|
| 118 | +473 |
- post_output = NULL) {
+
|
|
| 119 | +474 | ! |
- logger::log_info("Initializing tm_g_distribution")
+ observeEvent( |
| 120 | -+ | ||
| 475 | +! |
-
+ eventExpr = list( |
|
| 121 | +476 | ! |
- extra_packages <- c("ggpmisc", "ggpp", "goftest", "MASS", "broom")
+ input$t_dist, |
| 122 | +477 | ! |
- missing_packages <- Filter(function(x) !requireNamespace(x, quietly = TRUE), extra_packages)+ input$params_reset, |
| 123 | +478 | ! |
- if (length(missing_packages) > 0L) {
+ selector_list()$dist_i()$select |
| 124 | -! | +||
| 479 | +
- stop(sprintf(+ ), |
||
| 125 | +480 | ! |
- "Cannot load package(s): %s.\nInstall or restart your session.",+ handlerExpr = {
|
| 126 | +481 | ! |
- toString(missing_packages)+ if (length(input$t_dist) != 0) {
|
| 127 | -+ | ||
| 482 | +! |
- ))+ dist_var2 <- as.vector(merged$anl_input_r()$columns_source$dist_i) |
|
| 128 | +483 |
- }+ |
|
| 129 | -+ | ||
| 484 | +! |
-
+ get_dist_params <- function(x, dist) {
|
|
| 130 | +485 | ! |
- if (inherits(dist_var, "data_extract_spec")) dist_var <- list(dist_var)+ if (dist == "unif") {
|
| 131 | +486 | ! |
- if (inherits(strata_var, "data_extract_spec")) strata_var <- list(strata_var)+ res <- as.list(range(x)) |
| 132 | +487 | ! |
- if (inherits(group_var, "data_extract_spec")) group_var <- list(group_var)+ names(res) <- c("min", "max")
|
| 133 | +488 | ! |
- if (inherits(ggplot2_args, "ggplot2_args")) ggplot2_args <- list(default = ggplot2_args)+ return(res) |
| 134 | +489 |
-
+ } |
|
| 135 | +490 | ! |
- ggtheme <- match.arg(ggtheme)+ tryCatch( |
| 136 | +491 | ! |
- if (length(bins) == 1) {
+ as.list(MASS::fitdistr(x, densfun = dist)$estimate), |
| 137 | +492 | ! |
- checkmate::assert_numeric(bins, any.missing = FALSE, lower = 1)+ error = function(e) list(param1 = NA, param2 = NA) |
| 138 | +493 |
- } else {
- |
- |
| 139 | -! | -
- checkmate::assert_numeric(bins, len = 3, any.missing = FALSE, lower = 1)+ ) |
|
| 140 | -! | +||
| 494 | +
- checkmate::assert_numeric(bins[1], lower = bins[2], upper = bins[3], .var.name = "bins")+ } |
||
| 141 | +495 |
- }+ |
|
| 142 | +496 | ! |
- checkmate::assert_string(label)+ ANL <- merged$anl_q_r()[[as.character(dist_var[[1]]$dataname)]] # nolint: object_name. |
| 143 | +497 | ! |
- checkmate::assert_list(dist_var, "data_extract_spec")+ params <- get_dist_params(as.numeric(stats::na.omit(ANL[[dist_var2]])), input$t_dist) |
| 144 | +498 | ! |
- checkmate::assert_false(dist_var[[1]]$select$multiple)+ params_vec <- round(unname(unlist(params)), 2) |
| 145 | +499 | ! |
- checkmate::assert_list(strata_var, types = "data_extract_spec", null.ok = TRUE)+ params_names <- names(params) |
| 146 | -! | +||
| 500 | +
- checkmate::assert_list(group_var, types = "data_extract_spec", null.ok = TRUE)+ |
||
| 147 | +501 | ! |
- checkmate::assert_flag(freq)+ updateNumericInput(session, "dist_param1", label = params_names[1], value = params_vec[1]) |
| 148 | +502 | ! |
- plot_choices <- c("Histogram", "QQplot")
+ updateNumericInput(session, "dist_param2", label = params_names[2], value = params_vec[2])+ |
+
| 503 | ++ |
+ } else {
|
|
| 149 | +504 | ! |
- checkmate::assert_list(ggplot2_args, types = "ggplot2_args")+ updateNumericInput(session, "dist_param1", label = "param1", value = NA) |
| 150 | +505 | ! |
- checkmate::assert_subset(names(ggplot2_args), c("default", plot_choices))
+ updateNumericInput(session, "dist_param2", label = "param2", value = NA) |
| 151 | +506 |
-
+ }+ |
+ |
| 507 | ++ |
+ }, |
|
| 152 | +508 | ! |
- args <- as.list(environment())+ ignoreInit = TRUE |
| 153 | +509 | ++ |
+ )+ |
+
| 510 | |||
| 154 | +511 | ! |
- data_extract_list <- list(+ merge_vars <- reactive({
|
| 155 | +512 | ! |
- dist_var = dist_var,+ teal::validate_inputs(iv_r())+ |
+
| 513 | ++ | + | |
| 156 | +514 | ! |
- strata_var = strata_var,+ dist_var <- as.vector(merged$anl_input_r()$columns_source$dist_i) |
| 157 | +515 | ! |
- group_var = group_var+ s_var <- as.vector(merged$anl_input_r()$columns_source$strata_i) |
| 158 | -+ | ||
| 516 | +! |
- )+ g_var <- as.vector(merged$anl_input_r()$columns_source$group_i) |
|
| 159 | +517 | ||
| 160 | +518 | ! |
- module(+ dist_var_name <- if (length(dist_var)) as.name(dist_var) else NULL |
| 161 | +519 | ! |
- label = label,+ s_var_name <- if (length(s_var)) as.name(s_var) else NULL |
| 162 | +520 | ! |
- server = srv_distribution,+ g_var_name <- if (length(g_var)) as.name(g_var) else NULL+ |
+
| 521 | ++ | + | |
| 163 | +522 | ! |
- server_args = c(+ list( |
| 164 | +523 | ! |
- data_extract_list,+ dist_var = dist_var, |
| 165 | +524 | ! |
- list(plot_height = plot_height, plot_width = plot_width, ggplot2_args = ggplot2_args)+ s_var = s_var, |
| 166 | -+ | ||
| 525 | +! |
- ),+ g_var = g_var, |
|
| 167 | +526 | ! |
- ui = ui_distribution,+ dist_var_name = dist_var_name, |
| 168 | +527 | ! |
- ui_args = args,+ s_var_name = s_var_name, |
| 169 | +528 | ! |
- datanames = teal.transform::get_extract_datanames(data_extract_list)+ g_var_name = g_var_name |
| 170 | +529 |
- )+ ) |
|
| 171 | +530 |
- }+ }) |
|
| 172 | +531 | ||
| 173 | +532 |
- ui_distribution <- function(id, ...) {
- |
- |
| 174 | -! | -
- args <- list(...)+ # common qenv |
|
| 175 | +533 | ! |
- ns <- NS(id)+ common_q <- reactive({
|
| 176 | -! | +||
| 534 | +
- is_single_dataset_value <- teal.transform::is_single_dataset(args$dist_var, args$strata_var, args$group_var)+ # Create a private stack for this function only. |
||
| 177 | +535 | ||
| 178 | +536 | ! |
- teal.widgets::standard_layout(+ ANL <- merged$anl_q_r()[["ANL"]] # nolint: object_name. |
| 179 | +537 | ! |
- output = teal.widgets::white_small_well(+ dist_var <- merge_vars()$dist_var |
| 180 | +538 | ! |
- tabsetPanel(+ s_var <- merge_vars()$s_var |
| 181 | +539 | ! |
- id = ns("tabs"),
+ g_var <- merge_vars()$g_var |
| 182 | -! | +||
| 540 | +
- tabPanel("Histogram", teal.widgets::plot_with_settings_ui(id = ns("hist_plot"))),
+
|
||
| 183 | +541 | ! |
- tabPanel("QQplot", teal.widgets::plot_with_settings_ui(id = ns("qq_plot")))
- |
-
| 184 | -- |
- ),+ dist_var_name <- merge_vars()$dist_var_name |
|
| 185 | +542 | ! |
- h3("Statistics Table"),
+ s_var_name <- merge_vars()$s_var_name |
| 186 | +543 | ! |
- DT::dataTableOutput(ns("summary_table")),
+ g_var_name <- merge_vars()$g_var_name |
| 187 | -! | +||
| 544 | +
- h3("Tests"),
+
|
||
| 188 | +545 | ! |
- DT::dataTableOutput(ns("t_stats"))
+ roundn <- input$roundn |
| 189 | -+ | ||
| 546 | +! |
- ),+ dist_param1 <- input$dist_param1 |
|
| 190 | +547 | ! |
- encoding = div(+ dist_param2 <- input$dist_param2 |
| 191 | +548 |
- ### Reporter+ # isolated as dist_param1/dist_param2 already triggered the reactivity |
|
| 192 | +549 | ! |
- teal.reporter::simple_reporter_ui(ns("simple_reporter")),
+ t_dist <- isolate(input$t_dist) |
| 193 | +550 |
- ###+ |
|
| 194 | +551 | ! |
- tags$label("Encodings", class = "text-primary"),
+ qenv <- merged$anl_q_r() |
| 195 | -! | +||
| 552 | +
- teal.transform::datanames_input(args[c("dist_var", "strata_var")]),
+
|
||
| 196 | +553 | ! |
- teal.transform::data_extract_ui(+ if (length(g_var) > 0) {
|
| 197 | +554 | ! |
- id = ns("dist_i"),
+ validate( |
| 198 | +555 | ! |
- label = "Variable",+ need( |
| 199 | +556 | ! |
- data_extract_spec = args$dist_var,+ inherits(ANL[[g_var]], c("integer", "factor", "character")),
|
| 200 | +557 | ! |
- is_single_dataset = is_single_dataset_value+ "Group by variable must be `factor`, `character`, or `integer`" |
| 201 | +558 |
- ),- |
- |
| 202 | -! | -
- if (!is.null(args$group_var)) {
+ ) |
|
| 203 | -! | +||
| 559 | +
- tagList(+ ) |
||
| 204 | +560 | ! |
- teal.transform::data_extract_ui(+ qenv <- teal.code::eval_code( |
| 205 | +561 | ! |
- id = ns("group_i"),
+ qenv, |
| 206 | +562 | ! |
- label = "Group by",+ substitute( |
| 207 | +563 | ! |
- data_extract_spec = args$group_var,+ expr = ANL[[g_var]] <- forcats::fct_na_value_to_level(as.factor(ANL[[g_var]]), "NA"), # nolint: object_name. |
| 208 | +564 | ! |
- is_single_dataset = is_single_dataset_value+ env = list(g_var = g_var) |
| 209 | +565 |
- ),- |
- |
| 210 | -! | -
- uiOutput(ns("scales_types_ui"))
+ ) |
|
| 211 | +566 |
) |
|
| 212 | +567 |
- },+ } |
|
| 213 | -! | +||
| 568 | +
- if (!is.null(args$strata_var)) {
+
|
||
| 214 | +569 | ! |
- teal.transform::data_extract_ui(+ if (length(s_var) > 0) {
|
| 215 | +570 | ! |
- id = ns("strata_i"),
+ validate( |
| 216 | +571 | ! |
- label = "Stratify by",+ need( |
| 217 | +572 | ! |
- data_extract_spec = args$strata_var,+ inherits(ANL[[s_var]], c("integer", "factor", "character")),
|
| 218 | +573 | ! |
- is_single_dataset = is_single_dataset_value+ "Stratify by variable must be `factor`, `character`, or `integer`" |
| 219 | +574 |
- )+ ) |
|
| 220 | +575 |
- },+ ) |
|
| 221 | +576 | ! |
- teal.widgets::panel_group(+ qenv <- teal.code::eval_code( |
| 222 | +577 | ! |
- conditionalPanel(+ qenv, |
| 223 | +578 | ! |
- condition = paste0("input['", ns("tabs"), "'] == 'Histogram'"),
+ substitute( |
| 224 | +579 | ! |
- teal.widgets::panel_item(+ expr = ANL[[s_var]] <- forcats::fct_na_value_to_level(as.factor(ANL[[s_var]]), "NA"), # nolint: object_name. |
| 225 | +580 | ! |
- "Histogram",+ env = list(s_var = s_var) |
| 226 | -! | +||
| 581 | +
- teal.widgets::optionalSliderInputValMinMax(ns("bins"), "Bins", args$bins, ticks = FALSE, step = 1),
+ ) |
||
| 227 | -! | +||
| 582 | +
- shinyWidgets::prettyRadioButtons(+ ) |
||
| 228 | -! | +||
| 583 | +
- ns("main_type"),
+ }+ |
+ ||
| 584 | ++ | + | |
| 229 | +585 | ! |
- label = "Plot Type:",+ validate(need(is.numeric(ANL[[dist_var]]), "Please select a numeric variable.")) |
| 230 | +586 | ! |
- choices = c("Density", "Frequency"),
+ teal::validate_has_data(ANL, 1, complete = TRUE)+ |
+
| 587 | ++ | + | |
| 231 | +588 | ! |
- selected = if (!args$freq) "Density" else "Frequency",+ if (length(t_dist) != 0) {
|
| 232 | +589 | ! |
- bigger = FALSE,+ map_distr_nams <- list( |
| 233 | +590 | ! |
- inline = TRUE+ normal = c("mean", "sd"),
|
| 234 | -+ | ||
| 591 | +! |
- ),+ lognormal = c("meanlog", "sdlog"),
|
|
| 235 | +592 | ! |
- checkboxInput(ns("add_dens"), label = "Overlay Density", value = TRUE),
+ gamma = c("shape", "rate"),
|
| 236 | +593 | ! |
- collapsed = FALSE+ unif = c("min", "max")
|
| 237 | +594 |
- )+ )+ |
+ |
| 595 | +! | +
+ params_names_raw <- map_distr_nams[[t_dist]] |
|
| 238 | +596 |
- ),+ |
|
| 239 | +597 | ! |
- conditionalPanel(+ qenv <- teal.code::eval_code( |
| 240 | +598 | ! |
- condition = paste0("input['", ns("tabs"), "'] == 'QQplot'"),
+ qenv, |
| 241 | +599 | ! |
- teal.widgets::panel_item(+ substitute( |
| 242 | +600 | ! |
- "QQ Plot",+ expr = {
|
| 243 | +601 | ! |
- checkboxInput(ns("qq_line"), label = "Add diagonal line(s)", TRUE),
+ params <- as.list(c(dist_param1, dist_param2)) |
| 244 | +602 | ! |
- collapsed = FALSE+ names(params) <- params_names_raw |
| 245 | +603 |
- )+ }, |
|
| 246 | -+ | ||
| 604 | +! |
- ),+ env = list( |
|
| 247 | +605 | ! |
- conditionalPanel(+ dist_param1 = dist_param1, |
| 248 | +606 | ! |
- condition = paste0("input['", ns("main_type"), "'] == 'Density'"),
+ dist_param2 = dist_param2, |
| 249 | +607 | ! |
- teal.widgets::panel_item(+ params_names_raw = params_names_raw |
| 250 | -! | +||
| 608 | +
- "Theoretical Distribution",+ ) |
||
| 251 | -! | +||
| 609 | +
- teal.widgets::optionalSelectInput(+ ) |
||
| 252 | -! | +||
| 610 | +
- ns("t_dist"),
+ ) |
||
| 253 | -! | +||
| 611 | +
- div(+ }+ |
+ ||
| 612 | ++ | + | |
| 254 | +613 | ! |
- class = "teal-tooltip",+ if (length(s_var) == 0 && length(g_var) == 0) {
|
| 255 | +614 | ! |
- tagList(+ qenv <- teal.code::eval_code( |
| 256 | +615 | ! |
- "Distribution:",+ qenv, |
| 257 | +616 | ! |
- icon("circle-info"),
+ substitute( |
| 258 | +617 | ! |
- span(+ expr = {
|
| 259 | +618 | ! |
- class = "tooltiptext",+ summary_table <- ANL %>% |
| 260 | +619 | ! |
- "Default parameters are optimized with MASS::fitdistr function."+ dplyr::summarise( |
| 261 | -+ | ||
| 620 | +! |
- )+ min = round(min(dist_var_name, na.rm = TRUE), roundn), |
|
| 262 | -+ | ||
| 621 | +! |
- )+ median = round(stats::median(dist_var_name, na.rm = TRUE), roundn), |
|
| 263 | -+ | ||
| 622 | +! |
- ),+ mean = round(mean(dist_var_name, na.rm = TRUE), roundn), |
|
| 264 | +623 | ! |
- choices = c("normal", "lognormal", "gamma", "unif"),
+ max = round(max(dist_var_name, na.rm = TRUE), roundn), |
| 265 | +624 | ! |
- selected = NULL,+ sd = round(stats::sd(dist_var_name, na.rm = TRUE), roundn), |
| 266 | +625 | ! |
- multiple = FALSE+ count = dplyr::n() |
| 267 | +626 |
- ),+ )+ |
+ |
| 627 | ++ |
+ }, |
|
| 268 | +628 | ! |
- numericInput(ns("dist_param1"), label = "param1", value = NULL),
+ env = list( |
| 269 | +629 | ! |
- numericInput(ns("dist_param2"), label = "param2", value = NULL),
+ dist_var_name = as.name(dist_var), |
| 270 | +630 | ! |
- span(actionButton(ns("params_reset"), "Reset params")),
+ roundn = roundn |
| 271 | -! | +||
| 631 | +
- collapsed = FALSE+ ) |
||
| 272 | +632 |
) |
|
| 273 | +633 |
) |
|
| 274 | +634 |
- ),+ } else {
|
|
| 275 | +635 | ! |
- teal.widgets::panel_item(+ qenv <- teal.code::eval_code( |
| 276 | +636 | ! |
- "Tests",+ qenv, |
| 277 | +637 | ! |
- teal.widgets::optionalSelectInput(+ substitute( |
| 278 | +638 | ! |
- ns("dist_tests"),
+ expr = {
|
| 279 | +639 | ! |
- "Tests:",+ strata_vars <- strata_vars_raw |
| 280 | +640 | ! |
- choices = c(+ summary_table <- ANL %>% |
| 281 | +641 | ! |
- "Shapiro-Wilk",+ dplyr::group_by_at(dplyr::vars(dplyr::any_of(strata_vars))) %>% |
| 282 | +642 | ! |
- if (!is.null(args$strata_var)) "t-test (two-samples, not paired)",+ dplyr::summarise( |
| 283 | +643 | ! |
- if (!is.null(args$strata_var)) "one-way ANOVA",+ min = round(min(dist_var_name, na.rm = TRUE), roundn), |
| 284 | +644 | ! |
- if (!is.null(args$strata_var)) "Fligner-Killeen",+ median = round(stats::median(dist_var_name, na.rm = TRUE), roundn), |
| 285 | +645 | ! |
- if (!is.null(args$strata_var)) "F-test",+ mean = round(mean(dist_var_name, na.rm = TRUE), roundn), |
| 286 | +646 | ! |
- "Kolmogorov-Smirnov (one-sample)",+ max = round(max(dist_var_name, na.rm = TRUE), roundn), |
| 287 | +647 | ! |
- "Anderson-Darling (one-sample)",+ sd = round(stats::sd(dist_var_name, na.rm = TRUE), roundn), |
| 288 | +648 | ! |
- "Cramer-von Mises (one-sample)",+ count = dplyr::n()+ |
+
| 649 | ++ |
+ ) |
|
| 289 | +650 | ! |
- if (!is.null(args$strata_var)) "Kolmogorov-Smirnov (two-samples)"+ summary_table # used to display table when running show-r-code code |
| 290 | +651 |
- ),+ }, |
|
| 291 | +652 | ! |
- selected = NULL+ env = list(+ |
+
| 653 | +! | +
+ dist_var_name = dist_var_name,+ |
+ |
| 654 | +! | +
+ strata_vars_raw = c(g_var, s_var),+ |
+ |
| 655 | +! | +
+ roundn = roundn |
|
| 292 | +656 |
- )+ ) |
|
| 293 | +657 |
- ),+ ) |
|
| 294 | -! | +||
| 658 | +
- teal.widgets::panel_item(+ ) |
||
| 295 | -! | +||
| 659 | +
- "Statistics Table",+ } |
||
| 296 | -! | +||
| 660 | +
- sliderInput(ns("roundn"), "Round to n digits", min = 0, max = 10, value = 2)
+ }) |
||
| 297 | +661 |
- ),+ + |
+ |
| 662 | ++ |
+ # distplot qenv ---- |
|
| 298 | +663 | ! |
- teal.widgets::panel_item(+ dist_q <- eventReactive( |
| 299 | +664 | ! |
- title = "Plot settings",+ eventExpr = {
|
| 300 | +665 | ! |
- selectInput(+ common_q() |
| 301 | +666 | ! |
- inputId = ns("ggtheme"),
+ input$scales_type |
| 302 | +667 | ! |
- label = "Theme (by ggplot):",+ input$main_type |
| 303 | +668 | ! |
- choices = ggplot_themes,+ input$bins |
| 304 | +669 | ! |
- selected = args$ggtheme,+ input$add_dens |
| 305 | +670 | ! |
- multiple = FALSE+ is.null(input$ggtheme) |
| 306 | +671 |
- )+ }, |
|
| 307 | -+ | ||
| 672 | +! |
- )+ valueExpr = {
|
|
| 308 | -+ | ||
| 673 | +! |
- ),+ dist_var <- merge_vars()$dist_var |
|
| 309 | +674 | ! |
- forms = tagList(+ s_var <- merge_vars()$s_var |
| 310 | +675 | ! |
- teal.widgets::verbatim_popup_ui(ns("warning"), "Show Warnings"),
+ g_var <- merge_vars()$g_var |
| 311 | +676 | ! |
- teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code")
+ dist_var_name <- merge_vars()$dist_var_name |
| 312 | -+ | ||
| 677 | +! |
- ),+ s_var_name <- merge_vars()$s_var_name |
|
| 313 | +678 | ! |
- pre_output = args$pre_output,+ g_var_name <- merge_vars()$g_var_name |
| 314 | +679 | ! |
- post_output = args$post_output+ t_dist <- input$t_dist |
| 315 | -+ | ||
| 680 | +! |
- )+ dist_param1 <- input$dist_param1 |
|
| 316 | -+ | ||
| 681 | +! |
- }+ dist_param2 <- input$dist_param2 |
|
| 317 | +682 | ||
| 318 | -+ | ||
| 683 | +! |
- srv_distribution <- function(id,+ scales_type <- input$scales_type |
|
| 319 | +684 |
- data,+ |
|
| 320 | -+ | ||
| 685 | +! |
- reporter,+ ndensity <- 512 |
|
| 321 | -+ | ||
| 686 | +! |
- filter_panel_api,+ main_type_var <- input$main_type |
|
| 322 | -+ | ||
| 687 | +! |
- dist_var,+ bins_var <- input$bins |
|
| 323 | -+ | ||
| 688 | +! |
- strata_var,+ add_dens_var <- input$add_dens |
|
| 324 | -+ | ||
| 689 | +! |
- group_var,+ ggtheme <- input$ggtheme |
|
| 325 | +690 |
- plot_height,+ |
|
| 326 | -+ | ||
| 691 | +! |
- plot_width,+ teal::validate_inputs(iv_dist) |
|
| 327 | +692 |
- ggplot2_args) {
+
|
|
| 328 | +693 | ! |
- with_reporter <- !missing(reporter) && inherits(reporter, "Reporter")+ qenv <- common_q() |
| 329 | -! | +||
| 694 | +
- with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI")+ |
||
| 330 | +695 | ! |
- checkmate::assert_class(data, "reactive")+ m_type <- if (main_type_var == "Density") "density" else "count" |
| 331 | -! | +||
| 696 | +
- checkmate::assert_class(isolate(data()), "teal_data")+ |
||
| 332 | +697 | ! |
- moduleServer(id, function(input, output, session) {
+ plot_call <- if (length(s_var) == 0 && length(g_var) == 0) {
|
| 333 | +698 | ! |
- rule_req <- function(value) {
+ substitute( |
| 334 | +699 | ! |
- if (isTRUE(input$dist_tests %in% c(+ expr = ggplot(ANL, aes(dist_var_name)) + |
| 335 | +700 | ! |
- "Fligner-Killeen",+ geom_histogram( |
| 336 | +701 | ! |
- "t-test (two-samples, not paired)",+ position = "identity", aes(y = after_stat(m_type)), bins = bins_var, alpha = 0.3 |
| 337 | -! | +||
| 702 | +
- "F-test",+ ), |
||
| 338 | +703 | ! |
- "Kolmogorov-Smirnov (two-samples)",+ env = list( |
| 339 | +704 | ! |
- "one-way ANOVA"+ m_type = as.name(m_type), bins_var = bins_var, dist_var_name = as.name(dist_var) |
| 340 | +705 |
- ))) {
+ )+ |
+ |
| 706 | ++ |
+ ) |
|
| 341 | +707 | ! |
- if (!shinyvalidate::input_provided(value)) {
+ } else if (length(s_var) != 0 && length(g_var) == 0) {
|
| 342 | +708 | ! |
- "Please select stratify variable."+ substitute( |
| 343 | -+ | ||
| 709 | +! |
- }+ expr = ggplot(ANL, aes(dist_var_name, col = s_var_name)) + |
|
| 344 | -+ | ||
| 710 | +! |
- }+ geom_histogram(+ |
+ |
| 711 | +! | +
+ position = "identity", aes(y = after_stat(m_type), fill = s_var), bins = bins_var, alpha = 0.3 |
|
| 345 | +712 |
- }+ ), |
|
| 346 | +713 | ! |
- rule_dupl <- function(...) {
+ env = list( |
| 347 | +714 | ! |
- if (identical(input$dist_tests, "Fligner-Killeen")) {
+ m_type = as.name(m_type), |
| 348 | +715 | ! |
- strata <- selector_list()$strata_i()$select+ bins_var = bins_var, |
| 349 | +716 | ! |
- group <- selector_list()$group_i()$select+ dist_var_name = dist_var_name, |
| 350 | +717 | ! |
- if (isTRUE(strata == group)) {
+ s_var = as.name(s_var), |
| 351 | +718 | ! |
- "Please select different variables for strata and group."- |
-
| 352 | -- |
- }+ s_var_name = s_var_name |
|
| 353 | +719 |
- }+ ) |
|
| 354 | +720 |
- }+ ) |
|
| 355 | -+ | ||
| 721 | +! |
-
+ } else if (length(s_var) == 0 && length(g_var) != 0) {
|
|
| 356 | +722 | ! |
- selector_list <- teal.transform::data_extract_multiple_srv(+ req(scales_type) |
| 357 | +723 | ! |
- data_extract = list(+ substitute( |
| 358 | +724 | ! |
- dist_i = dist_var,+ expr = ggplot(ANL[ANL[[g_var]] != "NA", ], aes(dist_var_name)) + |
| 359 | +725 | ! |
- strata_i = strata_var,+ geom_histogram( |
| 360 | +726 | ! |
- group_i = group_var+ position = "identity", aes(y = after_stat(m_type)), bins = bins_var, alpha = 0.3 |
| 361 | +727 |
- ),- |
- |
| 362 | -! | -
- data,+ ) + |
|
| 363 | +728 | ! |
- select_validation_rule = list(+ facet_wrap(~g_var_name, ncol = 1, scales = scales_raw), |
| 364 | +729 | ! |
- dist_i = shinyvalidate::sv_required("Please select a variable")
- |
-
| 365 | -- |
- ),+ env = list( |
|
| 366 | +730 | ! |
- filter_validation_rule = list(+ m_type = as.name(m_type), |
| 367 | +731 | ! |
- strata_i = shinyvalidate::compose_rules(+ bins_var = bins_var, |
| 368 | +732 | ! |
- rule_req,+ dist_var_name = dist_var_name, |
| 369 | +733 | ! |
- rule_dupl+ g_var = g_var, |
| 370 | -+ | ||
| 734 | +! |
- ),+ g_var_name = g_var_name, |
|
| 371 | +735 | ! |
- group_i = rule_dupl+ scales_raw = tolower(scales_type) |
| 372 | +736 |
- )+ ) |
|
| 373 | +737 |
- )+ ) |
|
| 374 | +738 |
-
+ } else {
|
|
| 375 | +739 | ! |
- iv_r <- reactive({
+ req(scales_type) |
| 376 | +740 | ! |
- iv <- shinyvalidate::InputValidator$new()+ substitute( |
| 377 | +741 | ! |
- teal.transform::compose_and_enable_validators(iv, selector_list, validator_names = "dist_i")- |
-
| 378 | -- |
- })- |
- |
| 379 | -- |
-
+ expr = ggplot(ANL[ANL[[g_var]] != "NA", ], aes(dist_var_name, col = s_var_name)) + |
|
| 380 | +742 | ! |
- iv_r_dist <- reactive({
+ geom_histogram( |
| 381 | +743 | ! |
- iv <- shinyvalidate::InputValidator$new()+ position = "identity", |
| 382 | +744 | ! |
- teal.transform::compose_and_enable_validators(+ aes(y = after_stat(m_type), fill = s_var), bins = bins_var, alpha = 0.3 |
| 383 | -! | +||
| 745 | +
- iv, selector_list,+ ) + |
||
| 384 | +746 | ! |
- validator_names = c("strata_i", "group_i")
+ facet_wrap(~g_var_name, ncol = 1, scales = scales_raw), |
| 385 | -+ | ||
| 747 | +! |
- )+ env = list( |
|
| 386 | -+ | ||
| 748 | +! |
- })+ m_type = as.name(m_type), |
|
| 387 | +749 | ! |
- rule_dist_1 <- function(value) {
+ bins_var = bins_var, |
| 388 | +750 | ! |
- if (!is.null(input$t_dist)) {
+ dist_var_name = dist_var_name, |
| 389 | +751 | ! |
- switch(input$t_dist,+ g_var = g_var, |
| 390 | +752 | ! |
- "normal" = if (!shinyvalidate::input_provided(value)) "mean is required",+ s_var = as.name(s_var), |
| 391 | +753 | ! |
- "lognormal" = if (!shinyvalidate::input_provided(value)) "meanlog is required",+ g_var_name = g_var_name, |
| 392 | +754 | ! |
- "gamma" = {
+ s_var_name = s_var_name, |
| 393 | +755 | ! |
- if (!shinyvalidate::input_provided(value)) "shape is required" else if (value <= 0) "shape must be positive"+ scales_raw = tolower(scales_type) |
| 394 | +756 |
- },- |
- |
| 395 | -! | -
- "unif" = NULL+ ) |
|
| 396 | +757 |
- )+ ) |
|
| 397 | +758 |
- }+ } |
|
| 398 | +759 |
- }+ |
|
| 399 | +760 | ! |
- rule_dist_2 <- function(value) {
+ if (add_dens_var) {
|
| 400 | +761 | ! |
- if (!is.null(input$t_dist)) {
+ plot_call <- substitute( |
| 401 | +762 | ! |
- switch(input$t_dist,+ expr = plot_call + |
| 402 | +763 | ! |
- "normal" = {
+ stat_density( |
| 403 | +764 | ! |
- if (!shinyvalidate::input_provided(value)) {
+ aes(y = after_stat(const * m_type2)), |
| 404 | +765 | ! |
- "sd is required"+ geom = "line", |
| 405 | +766 | ! |
- } else if (value < 0) {
+ position = "identity", |
| 406 | +767 | ! |
- "sd must be non-negative"- |
-
| 407 | -- |
- }+ alpha = 0.5, |
|
| 408 | -+ | ||
| 768 | +! |
- },+ size = 2, |
|
| 409 | +769 | ! |
- "lognormal" = {
+ n = ndensity |
| 410 | -! | +||
| 770 | +
- if (!shinyvalidate::input_provided(value)) {
+ ), |
||
| 411 | +771 | ! |
- "sdlog is required"+ env = list( |
| 412 | +772 | ! |
- } else if (value < 0) {
+ plot_call = plot_call, |
| 413 | +773 | ! |
- "sdlog must be non-negative"+ const = if (main_type_var == "Density") {
|
| 414 | -+ | ||
| 774 | +! |
- }+ 1 |
|
| 415 | +775 |
- },- |
- |
| 416 | -! | -
- "gamma" = {
+ } else {
|
|
| 417 | +776 | ! |
- if (!shinyvalidate::input_provided(value)) {
+ diff(range(qenv[["ANL"]][[dist_var]], na.rm = TRUE)) / bins_var |
| 418 | -! | +||
| 777 | +
- "rate is required"+ }, |
||
| 419 | +778 | ! |
- } else if (value <= 0) {
+ m_type2 = if (main_type_var == "Density") as.name("density") else as.name("count"),
|
| 420 | +779 | ! |
- "rate must be positive"- |
-
| 421 | -- |
- }+ ndensity = ndensity |
|
| 422 | +780 |
- },- |
- |
| 423 | -! | -
- "unif" = NULL+ ) |
|
| 424 | +781 |
- )+ ) |
|
| 425 | +782 |
- }+ } |
|
| 426 | +783 |
- }+ |
|
| 427 | +784 | ! |
- rule_dist <- function(value) {
+ if (length(t_dist) != 0 && main_type_var == "Density" && length(g_var) == 0 && length(s_var) == 0) {
|
| 428 | +785 | ! |
- if (isTRUE(input$tabs == "QQplot" ||+ qenv <- teal.code::eval_code( |
| 429 | +786 | ! |
- input$dist_tests %in% c(+ qenv, |
| 430 | +787 | ! |
- "Kolmogorov-Smirnov (one-sample)",+ substitute( |
| 431 | +788 | ! |
- "Anderson-Darling (one-sample)",+ df_params <- as.data.frame(append(params, list(name = t_dist))), |
| 432 | +789 | ! |
- "Cramer-von Mises (one-sample)"+ env = list(t_dist = t_dist) |
| 433 | +790 |
- ))) {
+ ) |
|
| 434 | -! | +||
| 791 | +
- if (!shinyvalidate::input_provided(value)) {
+ ) |
||
| 435 | +792 | ! |
- "Please select the theoretical distribution."- |
-
| 436 | -- |
- }+ datas <- quote(data.frame(x = 0.7, y = 1, tb = I(list(df_params = df_params)))) |
|
| 437 | -+ | ||
| 793 | +! |
- }+ label <- quote(tb) |
|
| 438 | +794 |
- }+ |
|
| 439 | +795 | ! |
- iv_dist <- shinyvalidate::InputValidator$new()+ plot_call <- substitute( |
| 440 | +796 | ! |
- iv_dist$add_rule("t_dist", rule_dist)
+ expr = plot_call + ggpp::geom_table_npc( |
| 441 | +797 | ! |
- iv_dist$add_rule("dist_param1", rule_dist_1)
+ data = data, |
| 442 | +798 | ! |
- iv_dist$add_rule("dist_param2", rule_dist_2)
+ aes(npcx = x, npcy = y, label = label), |
| 443 | +799 | ! |
- iv_dist$enable()+ hjust = 0, vjust = 1, size = 4 |
| 444 | +800 | - - | -|
| 445 | -! | -
- anl_merged_input <- teal.transform::merge_expression_srv(+ ), |
|
| 446 | +801 | ! |
- selector_list = selector_list,+ env = list(plot_call = plot_call, data = datas, label = label) |
| 447 | -! | +||
| 802 | +
- datasets = data+ ) |
||
| 448 | +803 |
- )+ } |
|
| 449 | +804 | ||
| 450 | +805 | ! |
- anl_merged_q <- reactive({
+ if (length(s_var) == 0 && length(g_var) == 0 && main_type_var == "Density" && |
| 451 | +806 | ! |
- req(anl_merged_input())+ length(t_dist) != 0 && main_type_var == "Density") {
|
| 452 | +807 | ! |
- data() %>%+ map_dist <- stats::setNames( |
| 453 | +808 | ! |
- teal.code::eval_code(as.expression(anl_merged_input()$expr))+ c("dnorm", "dlnorm", "dgamma", "dunif"),
|
| 454 | -+ | ||
| 809 | +! |
- })+ c("normal", "lognormal", "gamma", "unif")
|
|
| 455 | +810 |
-
+ ) |
|
| 456 | +811 | ! |
- merged <- list(+ plot_call <- substitute( |
| 457 | +812 | ! |
- anl_input_r = anl_merged_input,+ expr = plot_call + stat_function( |
| 458 | +813 | ! |
- anl_q_r = anl_merged_q+ data = data.frame(x = range(ANL[[dist_var]]), color = mapped_dist), |
| 459 | -+ | ||
| 814 | +! |
- )+ aes(x, color = color), |
|
| 460 | -+ | ||
| 815 | +! |
-
+ fun = mapped_dist_name, |
|
| 461 | +816 | ! |
- output$scales_types_ui <- renderUI({
+ n = ndensity, |
| 462 | +817 | ! |
- if ("group_i" %in% names(selector_list()) && length(selector_list()$group_i()$filters[[1]]$selected) > 0) {
+ size = 2, |
| 463 | +818 | ! |
- shinyWidgets::prettyRadioButtons(+ args = params+ |
+
| 819 | ++ |
+ ) + |
|
| 464 | +820 | ! |
- session$ns("scales_type"),
+ scale_color_manual(values = stats::setNames("blue", mapped_dist), aesthetics = "color"),
|
| 465 | +821 | ! |
- label = "Scales:",+ env = list( |
| 466 | +822 | +! | +
+ plot_call = plot_call,+ |
+
| 823 | ! |
- choices = c("Fixed", "Free"),
+ dist_var = dist_var, |
|
| 467 | +824 | ! |
- selected = "Fixed",+ ndensity = ndensity, |
| 468 | +825 | ! |
- bigger = FALSE,+ mapped_dist = unname(map_dist[t_dist]), |
| 469 | +826 | ! |
- inline = TRUE+ mapped_dist_name = as.name(unname(map_dist[t_dist])) |
| 470 | +827 |
- )+ ) |
|
| 471 | +828 |
- }+ ) |
|
| 472 | +829 |
- })+ } |
|
| 473 | +830 | ||
| 474 | -! | -
- observeEvent(- |
- |
| 475 | +831 | ! |
- eventExpr = list(+ all_ggplot2_args <- teal.widgets::resolve_ggplot2_args( |
| 476 | +832 | ! |
- input$t_dist,+ user_plot = ggplot2_args[["Histogram"]], |
| 477 | +833 | ! |
- input$params_reset,+ user_default = ggplot2_args$default |
| 478 | -! | +||
| 834 | +
- selector_list()$dist_i()$select+ ) |
||
| 479 | +835 |
- ),+ |
|
| 480 | +836 | ! |
- handlerExpr = {
+ parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args( |
| 481 | +837 | ! |
- if (length(input$t_dist) != 0) {
+ all_ggplot2_args, |
| 482 | +838 | ! |
- dist_var2 <- as.vector(merged$anl_input_r()$columns_source$dist_i)+ ggtheme = ggtheme |
| 483 | +839 | ++ |
+ )+ |
+
| 840 | |||
| 484 | +841 | ! |
- get_dist_params <- function(x, dist) {
+ teal.code::eval_code( |
| 485 | +842 | ! |
- if (dist == "unif") {
+ qenv, |
| 486 | +843 | ! |
- res <- as.list(range(x))+ substitute( |
| 487 | +844 | ! |
- names(res) <- c("min", "max")
+ expr = {
|
| 488 | +845 | ! |
- return(res)+ g <- plot_call+ |
+
| 846 | +! | +
+ print(g) |
|
| 489 | +847 |
- }+ }, |
|
| 490 | +848 | ! |
- tryCatch(+ env = list(plot_call = Reduce(function(x, y) call("+", x, y), c(plot_call, parsed_ggplot2_args)))
|
| 491 | -! | +||
| 849 | +
- as.list(MASS::fitdistr(x, densfun = dist)$estimate),+ ) |
||
| 492 | -! | +||
| 850 | +
- error = function(e) list(param1 = NA, param2 = NA)+ ) |
||
| 493 | +851 |
- )+ } |
|
| 494 | +852 |
- }+ ) |
|
| 495 | +853 | ||
| 496 | -! | +||
| 854 | +
- ANL <- merged$anl_q_r()[[as.character(dist_var[[1]]$dataname)]] # nolint object_name_linter+ # qqplot qenv ---- |
||
| 497 | +855 | ! |
- params <- get_dist_params(as.numeric(stats::na.omit(ANL[[dist_var2]])), input$t_dist)+ qq_q <- eventReactive( |
| 498 | +856 | ! |
- params_vec <- round(unname(unlist(params)), 2)+ eventExpr = {
|
| 499 | +857 | ! |
- params_names <- names(params)+ common_q() |
| 500 | -+ | ||
| 858 | +! |
-
+ input$scales_type |
|
| 501 | +859 | ! |
- updateNumericInput(session, "dist_param1", label = params_names[1], value = params_vec[1])+ input$qq_line |
| 502 | +860 | ! |
- updateNumericInput(session, "dist_param2", label = params_names[2], value = params_vec[2])+ is.null(input$ggtheme) |
| 503 | +861 |
- } else {
+ }, |
|
| 504 | +862 | ! |
- updateNumericInput(session, "dist_param1", label = "param1", value = NA)+ valueExpr = {
|
| 505 | +863 | ! |
- updateNumericInput(session, "dist_param2", label = "param2", value = NA)- |
-
| 506 | -- |
- }- |
- |
| 507 | -- |
- },+ dist_var <- merge_vars()$dist_var |
|
| 508 | +864 | ! |
- ignoreInit = TRUE- |
-
| 509 | -- |
- )+ s_var <- merge_vars()$s_var |
|
| 510 | -+ | ||
| 865 | +! |
-
+ g_var <- merge_vars()$g_var |
|
| 511 | +866 | ! |
- merge_vars <- reactive({
+ dist_var_name <- merge_vars()$dist_var_name |
| 512 | +867 | ! |
- teal::validate_inputs(iv_r())+ s_var_name <- merge_vars()$s_var_name |
| 513 | -+ | ||
| 868 | +! |
-
+ g_var_name <- merge_vars()$g_var_name |
|
| 514 | +869 | ! |
- dist_var <- as.vector(merged$anl_input_r()$columns_source$dist_i)+ t_dist <- input$t_dist |
| 515 | +870 | ! |
- s_var <- as.vector(merged$anl_input_r()$columns_source$strata_i)+ dist_param1 <- input$dist_param1 |
| 516 | +871 | ! |
- g_var <- as.vector(merged$anl_input_r()$columns_source$group_i)+ dist_param2 <- input$dist_param2 |
| 517 | +872 | ||
| 518 | -! | -
- dist_var_name <- if (length(dist_var)) as.name(dist_var) else NULL- |
- |
| 519 | +873 | ! |
- s_var_name <- if (length(s_var)) as.name(s_var) else NULL+ scales_type <- input$scales_type |
| 520 | +874 | ! |
- g_var_name <- if (length(g_var)) as.name(g_var) else NULL+ ggtheme <- input$ggtheme |
| 521 | +875 | ||
| 522 | +876 | ! |
- list(+ teal::validate_inputs(iv_r_dist(), iv_dist) |
| 523 | -! | +||
| 877 | +
- dist_var = dist_var,+ |
||
| 524 | +878 | ! |
- s_var = s_var,+ qenv <- common_q() |
| 525 | -! | +||
| 879 | +
- g_var = g_var,+ |
||
| 526 | +880 | ! |
- dist_var_name = dist_var_name,+ plot_call <- if (length(s_var) == 0 && length(g_var) == 0) {
|
| 527 | +881 | ! |
- s_var_name = s_var_name,+ substitute( |
| 528 | +882 | ! |
- g_var_name = g_var_name+ expr = ggplot(ANL, aes_string(sample = dist_var)), |
| 529 | -+ | ||
| 883 | +! |
- )+ env = list(dist_var = dist_var) |
|
| 530 | +884 |
- })+ ) |
|
| 531 | -+ | ||
| 885 | +! |
-
+ } else if (length(s_var) != 0 && length(g_var) == 0) {
|
|
| 532 | -+ | ||
| 886 | +! |
- # common qenv+ substitute( |
|
| 533 | +887 | ! |
- common_q <- reactive({
+ expr = ggplot(ANL, aes_string(sample = dist_var, color = s_var)), |
| 534 | -+ | ||
| 888 | +! |
- # Create a private stack for this function only.+ env = list(dist_var = dist_var, s_var = s_var) |
|
| 535 | +889 |
-
+ ) |
|
| 536 | +890 | ! |
- ANL <- merged$anl_q_r()[["ANL"]] # nolint object_name_linter+ } else if (length(s_var) == 0 && length(g_var) != 0) {
|
| 537 | +891 | ! |
- dist_var <- merge_vars()$dist_var+ substitute( |
| 538 | +892 | ! |
- s_var <- merge_vars()$s_var+ expr = ggplot(ANL[ANL[[g_var]] != "NA", ], aes_string(sample = dist_var)) + |
| 539 | +893 | ! |
- g_var <- merge_vars()$g_var- |
-
| 540 | -- |
-
+ facet_wrap(~g_var_name, ncol = 1, scales = scales_raw), |
|
| 541 | +894 | ! |
- dist_var_name <- merge_vars()$dist_var_name+ env = list( |
| 542 | +895 | ! |
- s_var_name <- merge_vars()$s_var_name+ dist_var = dist_var, |
| 543 | +896 | ! |
- g_var_name <- merge_vars()$g_var_name+ g_var = g_var, |
| 544 | -+ | ||
| 897 | +! |
-
+ g_var_name = g_var_name, |
|
| 545 | +898 | ! |
- roundn <- input$roundn+ scales_raw = tolower(scales_type) |
| 546 | -! | +||
| 899 | +
- dist_param1 <- input$dist_param1+ ) |
||
| 547 | -! | +||
| 900 | +
- dist_param2 <- input$dist_param2+ ) |
||
| 548 | +901 |
- # isolated as dist_param1/dist_param2 already triggered the reactivity+ } else {
|
|
| 549 | +902 | ! |
- t_dist <- isolate(input$t_dist)+ substitute( |
| 550 | -+ | ||
| 903 | +! |
-
+ expr = ggplot(ANL[ANL[[g_var]] != "NA", ], aes_string(sample = dist_var, color = s_var)) + |
|
| 551 | +904 | ! |
- qenv <- merged$anl_q_r()+ facet_wrap(~g_var_name, ncol = 1, scales = scales_raw), |
| 552 | -+ | ||
| 905 | +! |
-
+ env = list( |
|
| 553 | +906 | ! |
- if (length(g_var) > 0) {
+ dist_var = dist_var, |
| 554 | +907 | ! |
- validate(+ g_var = g_var, |
| 555 | +908 | ! |
- need(+ s_var = s_var, |
| 556 | +909 | ! |
- inherits(ANL[[g_var]], c("integer", "factor", "character")),
+ g_var_name = g_var_name, |
| 557 | +910 | ! |
- "Group by variable must be `factor`, `character`, or `integer`"+ scales_raw = tolower(scales_type) |
| 558 | +911 |
- )+ ) |
|
| 559 | +912 |
- )+ ) |
|
| 560 | -! | +||
| 913 | +
- qenv <- teal.code::eval_code(+ } |
||
| 561 | -! | +||
| 914 | +
- qenv,+ |
||
| 562 | +915 | ! |
- substitute(+ map_dist <- stats::setNames( |
| 563 | +916 | ! |
- expr = ANL[[g_var]] <- forcats::fct_na_value_to_level(as.factor(ANL[[g_var]]), "NA"), # nolint object_name_linter+ c("qnorm", "qlnorm", "qgamma", "qunif"),
|
| 564 | +917 | ! |
- env = list(g_var = g_var)- |
-
| 565 | -- |
- )+ c("normal", "lognormal", "gamma", "unif")
|
|
| 566 | +918 |
) |
|
| 567 | -- |
- }- |
- |
| 568 | +919 | ||
| 569 | -! | -
- if (length(s_var) > 0) {
- |
- |
| 570 | +920 | ! |
- validate(+ plot_call <- substitute( |
| 571 | +921 | ! |
- need(+ expr = plot_call + |
| 572 | +922 | ! |
- inherits(ANL[[s_var]], c("integer", "factor", "character")),
+ stat_qq(distribution = mapped_dist, dparams = params), |
| 573 | +923 | ! |
- "Stratify by variable must be `factor`, `character`, or `integer`"+ env = list(plot_call = plot_call, mapped_dist = as.name(unname(map_dist[t_dist]))) |
| 574 | +924 |
- )+ ) |
|
| 575 | +925 |
- )+ |
|
| 576 | +926 | ! |
- qenv <- teal.code::eval_code(+ if (length(t_dist) != 0 && length(g_var) == 0 && length(s_var) == 0) {
|
| 577 | +927 | ! |
- qenv,+ qenv <- teal.code::eval_code( |
| 578 | +928 | ! |
- substitute(+ qenv, |
| 579 | +929 | ! |
- expr = ANL[[s_var]] <- forcats::fct_na_value_to_level(as.factor(ANL[[s_var]]), "NA"), # nolint object_name_linter+ substitute( |
| 580 | +930 | ! |
- env = list(s_var = s_var)- |
-
| 581 | -- |
- )+ df_params <- as.data.frame(append(params, list(name = t_dist))), |
|
| 582 | -+ | ||
| 931 | +! |
- )+ env = list(t_dist = t_dist) |
|
| 583 | +932 |
- }+ ) |
|
| 584 | +933 |
-
+ ) |
|
| 585 | +934 | ! |
- validate(need(is.numeric(ANL[[dist_var]]), "Please select a numeric variable."))+ datas <- quote(data.frame(x = 0.7, y = 1, tb = I(list(df_params = df_params)))) |
| 586 | +935 | ! |
- teal::validate_has_data(ANL, 1, complete = TRUE)+ label <- quote(tb) |
| 587 | +936 | ||
| 588 | +937 | ! |
- if (length(t_dist) != 0) {
+ plot_call <- substitute( |
| 589 | +938 | ! |
- map_distr_nams <- list(+ expr = plot_call + |
| 590 | +939 | ! |
- normal = c("mean", "sd"),
+ ggpp::geom_table_npc( |
| 591 | +940 | ! |
- lognormal = c("meanlog", "sdlog"),
+ data = data, |
| 592 | +941 | ! |
- gamma = c("shape", "rate"),
+ aes(npcx = x, npcy = y, label = label), |
| 593 | +942 | ! |
- unif = c("min", "max")
+ hjust = 0, |
| 594 | -+ | ||
| 943 | +! |
- )+ vjust = 1, |
|
| 595 | +944 | ! |
- params_names_raw <- map_distr_nams[[t_dist]]+ size = 4 |
| 596 | +945 |
-
+ ), |
|
| 597 | +946 | ! |
- qenv <- teal.code::eval_code(+ env = list( |
| 598 | +947 | ! |
- qenv,+ plot_call = plot_call, |
| 599 | +948 | ! |
- substitute(+ data = datas, |
| 600 | +949 | ! |
- expr = {
+ label = label |
| 601 | -! | +||
| 950 | +
- params <- as.list(c(dist_param1, dist_param2))+ ) |
||
| 602 | -! | +||
| 951 | +
- names(params) <- params_names_raw+ ) |
||
| 603 | +952 |
- },+ } |
|
| 604 | -! | +||
| 953 | +
- env = list(+ |
||
| 605 | +954 | ! |
- dist_param1 = dist_param1,+ if (isTRUE(input$qq_line)) {
|
| 606 | +955 | ! |
- dist_param2 = dist_param2,+ plot_call <- substitute( |
| 607 | +956 | ! |
- params_names_raw = params_names_raw+ expr = plot_call + |
| 608 | -+ | ||
| 957 | +! |
- )+ stat_qq_line(distribution = mapped_dist, dparams = params), |
|
| 609 | -+ | ||
| 958 | +! |
- )+ env = list(plot_call = plot_call, mapped_dist = as.name(unname(map_dist[t_dist]))) |
|
| 610 | +959 |
- )+ ) |
|
| 611 | +960 |
- }+ } |
|
| 612 | +961 | ||
| 613 | +962 | ! |
- if (length(s_var) == 0 && length(g_var) == 0) {
+ all_ggplot2_args <- teal.widgets::resolve_ggplot2_args( |
| 614 | +963 | ! |
- qenv <- teal.code::eval_code(+ user_plot = ggplot2_args[["QQplot"]], |
| 615 | +964 | ! |
- qenv,+ user_default = ggplot2_args$default, |
| 616 | +965 | ! |
- substitute(+ module_plot = teal.widgets::ggplot2_args(labs = list(x = "theoretical", y = "sample")) |
| 617 | -! | +||
| 966 | +
- expr = {
+ )+ |
+ ||
| 967 | ++ | + | |
| 618 | +968 | ! |
- summary_table <- ANL %>%+ parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args( |
| 619 | +969 | ! |
- dplyr::summarise(+ all_ggplot2_args, |
| 620 | +970 | ! |
- min = round(min(dist_var_name, na.rm = TRUE), roundn),+ ggtheme = ggtheme+ |
+
| 971 | ++ |
+ )+ |
+ |
| 972 | ++ | + | |
| 621 | +973 | ! |
- median = round(stats::median(dist_var_name, na.rm = TRUE), roundn),+ teal.code::eval_code( |
| 622 | +974 | ! |
- mean = round(mean(dist_var_name, na.rm = TRUE), roundn),+ qenv, |
| 623 | +975 | ! |
- max = round(max(dist_var_name, na.rm = TRUE), roundn),+ substitute( |
| 624 | +976 | ! |
- sd = round(stats::sd(dist_var_name, na.rm = TRUE), roundn),+ expr = {
|
| 625 | +977 | ! |
- count = dplyr::n()+ g <- plot_call |
| 626 | -+ | ||
| 978 | +! |
- )+ print(g) |
|
| 627 | +979 |
}, |
|
| 628 | +980 | ! |
- env = list(+ env = list(plot_call = Reduce(function(x, y) call("+", x, y), c(plot_call, parsed_ggplot2_args)))
|
| 629 | -! | +||
| 981 | +
- dist_var_name = as.name(dist_var),+ ) |
||
| 630 | -! | +||
| 982 | +
- roundn = roundn+ ) |
||
| 631 | +983 |
- )+ } |
|
| 632 | +984 |
- )+ ) |
|
| 633 | +985 |
- )+ |
|
| 634 | +986 |
- } else {
+ # test qenv ---- |
|
| 635 | +987 | ! |
- qenv <- teal.code::eval_code(+ test_q <- eventReactive( |
| 636 | +988 | ! |
- qenv,+ ignoreNULL = FALSE, |
| 637 | +989 | ! |
- substitute(+ eventExpr = {
|
| 638 | +990 | ! |
- expr = {
+ common_q() |
| 639 | +991 | ! |
- strata_vars <- strata_vars_raw+ input$dist_param1 |
| 640 | +992 | ! |
- summary_table <- ANL %>%+ input$dist_param2 |
| 641 | +993 | ! |
- dplyr::group_by_at(dplyr::vars(dplyr::any_of(strata_vars))) %>%+ input$dist_tests |
| 642 | -! | +||
| 994 | +
- dplyr::summarise(+ }, |
||
| 643 | +995 | ! |
- min = round(min(dist_var_name, na.rm = TRUE), roundn),+ valueExpr = {
|
| 644 | -! | +||
| 996 | +
- median = round(stats::median(dist_var_name, na.rm = TRUE), roundn),+ # Create a private stack for this function only. |
||
| 645 | +997 | ! |
- mean = round(mean(dist_var_name, na.rm = TRUE), roundn),+ ANL <- common_q()[["ANL"]] # nolint: object_name.+ |
+
| 998 | ++ | + | |
| 646 | +999 | ! |
- max = round(max(dist_var_name, na.rm = TRUE), roundn),+ dist_var <- merge_vars()$dist_var |
| 647 | +1000 | ! |
- sd = round(stats::sd(dist_var_name, na.rm = TRUE), roundn),+ s_var <- merge_vars()$s_var |
| 648 | +1001 | ! |
- count = dplyr::n()+ g_var <- merge_vars()$g_var |
| 649 | +1002 |
- )+ |
|
| 650 | +1003 | ! |
- summary_table # used to display table when running show-r-code code+ dist_var_name <- merge_vars()$dist_var_name+ |
+
| 1004 | +! | +
+ s_var_name <- merge_vars()$s_var_name+ |
+ |
| 1005 | +! | +
+ g_var_name <- merge_vars()$g_var_name |
|
| 651 | +1006 |
- },+ |
|
| 652 | +1007 | ! |
- env = list(+ dist_param1 <- input$dist_param1 |
| 653 | +1008 | ! |
- dist_var_name = dist_var_name,+ dist_param2 <- input$dist_param2 |
| 654 | +1009 | ! |
- strata_vars_raw = c(g_var, s_var),+ dist_tests <- input$dist_tests |
| 655 | +1010 | ! |
- roundn = roundn+ t_dist <- input$t_dist |
| 656 | +1011 |
- )+ |
|
| 657 | -+ | ||
| 1012 | +! |
- )+ validate(need(dist_tests, "Please select a test")) |
|
| 658 | +1013 |
- )+ |
|
| 659 | -+ | ||
| 1014 | +! |
- }+ teal::validate_inputs(iv_dist) |
|
| 660 | +1015 |
- })+ |
|
| 661 | -+ | ||
| 1016 | +! |
-
+ if (length(s_var) > 0 || length(g_var) > 0) {
|
|
| 662 | -+ | ||
| 1017 | +! |
- # distplot qenv ----+ counts <- ANL %>% |
|
| 663 | +1018 | ! |
- dist_q <- eventReactive(+ dplyr::group_by_at(dplyr::vars(dplyr::any_of(c(s_var, g_var)))) %>% |
| 664 | +1019 | ! |
- eventExpr = {
+ dplyr::summarise(n = dplyr::n())+ |
+
| 1020 | ++ | + | |
| 665 | +1021 | ! |
- common_q()+ validate(need(all(counts$n > 5), "Please select strata*group with at least 5 observation each."))+ |
+
| 1022 | ++ |
+ }+ |
+ |
| 1023 | ++ | + | |
| 666 | -! | +||
| 1024 | +
- input$scales_type+ |
||
| 667 | +1025 | ! |
- input$main_type+ if (dist_tests %in% c( |
| 668 | +1026 | ! |
- input$bins+ "t-test (two-samples, not paired)", |
| 669 | +1027 | ! |
- input$add_dens+ "F-test", |
| 670 | +1028 | ! |
- is.null(input$ggtheme)+ "Kolmogorov-Smirnov (two-samples)" |
| 671 | +1029 |
- },+ )) {
|
|
| 672 | +1030 | ! |
- valueExpr = {
+ if (length(g_var) == 0 && length(s_var) > 0) {
|
| 673 | +1031 | ! |
- dist_var <- merge_vars()$dist_var+ validate(need( |
| 674 | +1032 | ! |
- s_var <- merge_vars()$s_var+ length(unique(ANL[[s_var]])) == 2, |
| 675 | +1033 | ! |
- g_var <- merge_vars()$g_var+ "Please select stratify variable with 2 levels." |
| 676 | -! | +||
| 1034 | +
- dist_var_name <- merge_vars()$dist_var_name+ )) |
||
| 677 | -! | +||
| 1035 | +
- s_var_name <- merge_vars()$s_var_name+ } |
||
| 678 | +1036 | ! |
- g_var_name <- merge_vars()$g_var_name+ if (length(g_var) > 0 && length(s_var) > 0) {
|
| 679 | +1037 | ! |
- t_dist <- input$t_dist+ validate(need( |
| 680 | +1038 | ! |
- dist_param1 <- input$dist_param1+ all(stats::na.omit(as.vector( |
| 681 | +1039 | ! |
- dist_param2 <- input$dist_param2+ tapply(ANL[[s_var]], list(ANL[[g_var]]), function(x) length(unique(x))) == 2 |
| 682 | +1040 |
-
+ ))), |
|
| 683 | +1041 | ! |
- scales_type <- input$scales_type+ "Please select stratify variable with 2 levels, per each group." |
| 684 | +1042 |
-
+ )) |
|
| 685 | -! | +||
| 1043 | +
- ndensity <- 512+ } |
||
| 686 | -! | +||
| 1044 | +
- main_type_var <- input$main_type+ }+ |
+ ||
| 1045 | ++ | + | |
| 687 | +1046 | ! |
- bins_var <- input$bins+ map_dist <- stats::setNames( |
| 688 | +1047 | ! |
- add_dens_var <- input$add_dens+ c("pnorm", "plnorm", "pgamma", "punif"),
|
| 689 | +1048 | ! |
- ggtheme <- input$ggtheme+ c("normal", "lognormal", "gamma", "unif")
|
| 690 | +1049 |
-
+ ) |
|
| 691 | +1050 | ! |
- teal::validate_inputs(iv_dist)- |
-
| 692 | -- |
-
+ sks_args <- list( |
|
| 693 | +1051 | ! |
- qenv <- common_q()+ test = quote(stats::ks.test), |
| 694 | -+ | ||
| 1052 | +! |
-
+ args = bquote(append(list(.[[.(dist_var)]], .(map_dist[t_dist])), params)), |
|
| 695 | +1053 | ! |
- m_type <- if (main_type_var == "Density") "density" else "count"+ groups = c(g_var, s_var) |
| 696 | +1054 | - - | -|
| 697 | -! | -
- plot_call <- if (length(s_var) == 0 && length(g_var) == 0) {
+ ) |
|
| 698 | +1055 | ! |
- substitute(+ ssw_args <- list( |
| 699 | +1056 | ! |
- expr = ggplot(ANL, aes(dist_var_name)) ++ test = quote(stats::shapiro.test), |
| 700 | +1057 | ! |
- geom_histogram(+ args = bquote(list(.[[.(dist_var)]])), |
| 701 | +1058 | ! |
- position = "identity", aes(y = after_stat(m_type)), bins = bins_var, alpha = 0.3+ groups = c(g_var, s_var) |
| 702 | +1059 |
- ),+ ) |
|
| 703 | +1060 | ! |
- env = list(+ mfil_args <- list( |
| 704 | +1061 | ! |
- m_type = as.name(m_type), bins_var = bins_var, dist_var_name = as.name(dist_var)+ test = quote(stats::fligner.test), |
| 705 | -+ | ||
| 1062 | +! |
- )+ args = bquote(list(.[[.(dist_var)]], .[[.(s_var)]])), |
|
| 706 | -+ | ||
| 1063 | +! |
- )+ groups = c(g_var) |
|
| 707 | -! | +||
| 1064 | +
- } else if (length(s_var) != 0 && length(g_var) == 0) {
+ ) |
||
| 708 | +1065 | ! |
- substitute(+ sad_args <- list( |
| 709 | +1066 | ! |
- expr = ggplot(ANL, aes(dist_var_name, col = s_var_name)) ++ test = quote(goftest::ad.test), |
| 710 | +1067 | ! |
- geom_histogram(+ args = bquote(append(list(.[[.(dist_var)]], .(map_dist[t_dist])), params)), |
| 711 | +1068 | ! |
- position = "identity", aes(y = after_stat(m_type), fill = s_var), bins = bins_var, alpha = 0.3+ groups = c(g_var, s_var) |
| 712 | +1069 |
- ),+ ) |
|
| 713 | +1070 | ! |
- env = list(+ scvm_args <- list( |
| 714 | +1071 | ! |
- m_type = as.name(m_type),+ test = quote(goftest::cvm.test), |
| 715 | +1072 | ! |
- bins_var = bins_var,+ args = bquote(append(list(.[[.(dist_var)]], .(map_dist[t_dist])), params)), |
| 716 | +1073 | ! |
- dist_var_name = dist_var_name,+ groups = c(g_var, s_var) |
| 717 | -! | +||
| 1074 | +
- s_var = as.name(s_var),+ ) |
||
| 718 | +1075 | ! |
- s_var_name = s_var_name+ manov_args <- list( |
| 719 | -+ | ||
| 1076 | +! |
- )+ test = quote(stats::aov), |
|
| 720 | -+ | ||
| 1077 | +! |
- )+ args = bquote(list(stats::formula(.(dist_var_name) ~ .(s_var_name)), .)), |
|
| 721 | +1078 | ! |
- } else if (length(s_var) == 0 && length(g_var) != 0) {
+ groups = c(g_var) |
| 722 | -! | +||
| 1079 | +
- req(scales_type)+ ) |
||
| 723 | +1080 | ! |
- substitute(+ mt_args <- list( |
| 724 | +1081 | ! |
- expr = ggplot(ANL[ANL[[g_var]] != "NA", ], aes(dist_var_name)) ++ test = quote(stats::t.test), |
| 725 | +1082 | ! |
- geom_histogram(+ args = bquote(unname(split(.[[.(dist_var)]], .[[.(s_var)]], drop = TRUE))), |
| 726 | +1083 | ! |
- position = "identity", aes(y = after_stat(m_type)), bins = bins_var, alpha = 0.3+ groups = c(g_var) |
| 727 | +1084 |
- ) ++ ) |
|
| 728 | +1085 | ! |
- facet_wrap(~g_var_name, ncol = 1, scales = scales_raw),+ mv_args <- list( |
| 729 | +1086 | ! |
- env = list(+ test = quote(stats::var.test), |
| 730 | +1087 | ! |
- m_type = as.name(m_type),+ args = bquote(unname(split(.[[.(dist_var)]], .[[.(s_var)]], drop = TRUE))), |
| 731 | +1088 | ! |
- bins_var = bins_var,+ groups = c(g_var) |
| 732 | -! | +||
| 1089 | +
- dist_var_name = dist_var_name,+ ) |
||
| 733 | +1090 | ! |
- g_var = g_var,+ mks_args <- list( |
| 734 | +1091 | ! |
- g_var_name = g_var_name,+ test = quote(stats::ks.test), |
| 735 | +1092 | ! |
- scales_raw = tolower(scales_type)+ args = bquote(unname(split(.[[.(dist_var)]], .[[.(s_var)]], drop = TRUE))), |
| 736 | -+ | ||
| 1093 | +! |
- )+ groups = c(g_var) |
|
| 737 | +1094 |
- )+ ) |
|
| 738 | +1095 |
- } else {
+
|
|
| 739 | +1096 | ! |
- req(scales_type)+ tests_base <- switch(dist_tests, |
| 740 | +1097 | ! |
- substitute(+ "Kolmogorov-Smirnov (one-sample)" = sks_args, |
| 741 | +1098 | ! |
- expr = ggplot(ANL[ANL[[g_var]] != "NA", ], aes(dist_var_name, col = s_var_name)) ++ "Shapiro-Wilk" = ssw_args, |
| 742 | +1099 | ! |
- geom_histogram(+ "Fligner-Killeen" = mfil_args, |
| 743 | +1100 | ! |
- position = "identity",+ "one-way ANOVA" = manov_args, |
| 744 | +1101 | ! |
- aes(y = after_stat(m_type), fill = s_var), bins = bins_var, alpha = 0.3- |
-
| 745 | -- |
- ) ++ "t-test (two-samples, not paired)" = mt_args, |
|
| 746 | +1102 | ! |
- facet_wrap(~g_var_name, ncol = 1, scales = scales_raw),+ "F-test" = mv_args, |
| 747 | +1103 | ! |
- env = list(+ "Kolmogorov-Smirnov (two-samples)" = mks_args, |
| 748 | +1104 | ! |
- m_type = as.name(m_type),+ "Anderson-Darling (one-sample)" = sad_args, |
| 749 | +1105 | ! |
- bins_var = bins_var,+ "Cramer-von Mises (one-sample)" = scvm_args |
| 750 | -! | +||
| 1106 | +
- dist_var_name = dist_var_name,+ ) |
||
| 751 | -! | +||
| 1107 | +
- g_var = g_var,+ |
||
| 752 | +1108 | ! |
- s_var = as.name(s_var),+ env <- list( |
| 753 | +1109 | ! |
- g_var_name = g_var_name,+ t_test = t_dist, |
| 754 | +1110 | ! |
- s_var_name = s_var_name,+ dist_var = dist_var, |
| 755 | +1111 | ! |
- scales_raw = tolower(scales_type)- |
-
| 756 | -- |
- )+ g_var = g_var, |
|
| 757 | -+ | ||
| 1112 | +! |
- )+ s_var = s_var, |
|
| 758 | -+ | ||
| 1113 | +! |
- }+ args = tests_base$args, |
|
| 759 | -+ | ||
| 1114 | +! |
-
+ groups = tests_base$groups, |
|
| 760 | +1115 | ! |
- if (add_dens_var) {
+ test = tests_base$test, |
| 761 | +1116 | ! |
- plot_call <- substitute(+ dist_var_name = dist_var_name, |
| 762 | +1117 | ! |
- expr = plot_call ++ g_var_name = g_var_name, |
| 763 | +1118 | ! |
- stat_density(+ s_var_name = s_var_name |
| 764 | -! | +||
| 1119 | +
- aes(y = after_stat(const * m_type2)),+ ) |
||
| 765 | -! | +||
| 1120 | +
- geom = "line",+ |
||
| 766 | +1121 | ! |
- position = "identity",+ qenv <- common_q() |
| 767 | -! | +||
| 1122 | +
- alpha = 0.5,+ |
||
| 768 | +1123 | ! |
- size = 2,+ if (length(s_var) == 0 && length(g_var) == 0) {
|
| 769 | +1124 | ! |
- n = ndensity+ qenv <- teal.code::eval_code( |
| 770 | -+ | ||
| 1125 | +! |
- ),+ qenv, |
|
| 771 | +1126 | ! |
- env = list(+ substitute( |
| 772 | +1127 | ! |
- plot_call = plot_call,+ expr = {
|
| 773 | +1128 | ! |
- const = if (main_type_var == "Density") {
+ test_stats <- ANL %>% |
| 774 | +1129 | ! |
- 1+ dplyr::select(dist_var) %>% |
| 775 | -+ | ||
| 1130 | +! |
- } else {
+ with(., broom::glance(do.call(test, args))) %>% |
|
| 776 | +1131 | ! |
- diff(range(qenv[["ANL"]][[dist_var]], na.rm = TRUE)) / bins_var+ dplyr::mutate_if(is.numeric, round, 3) |
| 777 | +1132 |
}, |
|
| 778 | -! | -
- m_type2 = if (main_type_var == "Density") as.name("density") else as.name("count"),
- |
- |
| 779 | +1133 | ! |
- ndensity = ndensity+ env = env |
| 780 | +1134 |
) |
|
| 781 | +1135 |
) |
|
| 782 | -- |
- }- |
- |
| 783 | +1136 |
-
+ } else {
|
|
| 784 | +1137 | ! |
- if (length(t_dist) != 0 && main_type_var == "Density" && length(g_var) == 0 && length(s_var) == 0) {
+ qenv <- teal.code::eval_code( |
| 785 | +1138 | ! |
- qenv <- teal.code::eval_code(+ qenv, |
| 786 | +1139 | ! |
- qenv,+ substitute( |
| 787 | +1140 | ! |
- substitute(+ expr = {
|
| 788 | +1141 | ! |
- df_params <- as.data.frame(append(params, list(name = t_dist))),+ test_stats <- ANL %>% |
| 789 | +1142 | ! |
- env = list(t_dist = t_dist)+ dplyr::select(dist_var, s_var, g_var) %>% |
| 790 | -+ | ||
| 1143 | +! |
- )+ dplyr::group_by_at(dplyr::vars(dplyr::any_of(groups))) %>% |
|
| 791 | -+ | ||
| 1144 | +! |
- )+ dplyr::do(tests = broom::glance(do.call(test, args))) %>% |
|
| 792 | +1145 | ! |
- datas <- quote(data.frame(x = 0.7, y = 1, tb = I(list(df_params = df_params))))+ tidyr::unnest(tests) %>% |
| 793 | +1146 | ! |
- label <- quote(tb)+ dplyr::mutate_if(is.numeric, round, 3) |
| 794 | +1147 |
-
+ }, |
|
| 795 | +1148 | ! |
- plot_call <- substitute(+ env = env |
| 796 | -! | +||
| 1149 | +
- expr = plot_call + ggpp::geom_table_npc(+ ) |
||
| 797 | -! | +||
| 1150 | +
- data = data,+ ) |
||
| 798 | -! | +||
| 1151 | +
- aes(npcx = x, npcy = y, label = label),+ } |
||
| 799 | +1152 | ! |
- hjust = 0, vjust = 1, size = 4+ qenv %>% |
| 800 | +1153 |
- ),+ # used to display table when running show-r-code code |
|
| 801 | +1154 | ! |
- env = list(plot_call = plot_call, data = datas, label = label)+ teal.code::eval_code(quote(test_stats)) |
| 802 | +1155 |
- )+ } |
|
| 803 | +1156 |
- }+ ) |
|
| 804 | +1157 | ||
| 805 | -! | +||
| 1158 | +
- if (length(s_var) == 0 && length(g_var) == 0 && main_type_var == "Density" &&+ # outputs ---- |
||
| 806 | -! | +||
| 1159 | +
- length(t_dist) != 0 && main_type_var == "Density") {
+ ## building main qenv |
||
| 807 | +1160 | ! |
- map_dist <- stats::setNames(+ output_q <- reactive({
|
| 808 | +1161 | ! |
- c("dnorm", "dlnorm", "dgamma", "dunif"),
+ tab <- input$tabs |
| 809 | +1162 | ! |
- c("normal", "lognormal", "gamma", "unif")
+ req(tab) # tab is NULL upon app launch, hence will crash without this statement |
| 810 | +1163 |
- )+ |
|
| 811 | +1164 | ! |
- plot_call <- substitute(+ qenv_final <- common_q() |
| 812 | -! | +||
| 1165 | +
- expr = plot_call + stat_function(+ # wrapped in if since could lead into validate error - we do want to continue |
||
| 813 | +1166 | ! |
- data = data.frame(x = range(ANL[[dist_var]]), color = mapped_dist),+ test_r_qenv_out <- try(test_q(), silent = TRUE) |
| 814 | +1167 | ! |
- aes(x, color = color),+ if (!inherits(test_r_qenv_out, c("try-error", "error"))) {
|
| 815 | +1168 | ! |
- fun = mapped_dist_name,+ qenv_final <- teal.code::join(qenv_final, test_q()) |
| 816 | -! | +||
| 1169 | +
- n = ndensity,+ } |
||
| 817 | -! | +||
| 1170 | +
- size = 2,+ |
||
| 818 | +1171 | ! |
- args = params- |
-
| 819 | -- |
- ) ++ qenv_final <- if (tab == "Histogram") {
|
|
| 820 | +1172 | ! |
- scale_color_manual(values = stats::setNames("blue", mapped_dist), aesthetics = "color"),
+ req(dist_q()) |
| 821 | +1173 | ! |
- env = list(+ teal.code::join(qenv_final, dist_q()) |
| 822 | +1174 | ! |
- plot_call = plot_call,+ } else if (tab == "QQplot") {
|
| 823 | +1175 | ! |
- dist_var = dist_var,+ req(qq_q()) |
| 824 | +1176 | ! |
- ndensity = ndensity,+ teal.code::join(qenv_final, qq_q()) |
| 825 | -! | +||
| 1177 | +
- mapped_dist = unname(map_dist[t_dist]),+ } |
||
| 826 | +1178 | ! |
- mapped_dist_name = as.name(unname(map_dist[t_dist]))+ qenv_final |
| 827 | +1179 |
- )+ }) |
|
| 828 | +1180 |
- )+ |
|
| 829 | -+ | ||
| 1181 | +! |
- }+ dist_r <- reactive(dist_q()[["g"]]) |
|
| 830 | +1182 | ||
| 831 | +1183 | ! |
- all_ggplot2_args <- teal.widgets::resolve_ggplot2_args(+ qq_r <- reactive(qq_q()[["g"]]) |
| 832 | -! | +||
| 1184 | +
- user_plot = ggplot2_args[["Histogram"]],+ |
||
| 833 | +1185 | ! |
- user_default = ggplot2_args$default+ output$summary_table <- DT::renderDataTable( |
| 834 | -+ | ||
| 1186 | +! |
- )+ expr = if (iv_r()$is_valid()) common_q()[["summary_table"]] else NULL, |
|
| 835 | -+ | ||
| 1187 | +! |
-
+ options = list( |
|
| 836 | +1188 | ! |
- parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(+ autoWidth = TRUE, |
| 837 | +1189 | ! |
- all_ggplot2_args,+ columnDefs = list(list(width = "200px", targets = "_all"))+ |
+
| 1190 | ++ |
+ ), |
|
| 838 | +1191 | ! |
- ggtheme = ggtheme+ rownames = FALSE |
| 839 | +1192 |
- )+ ) |
|
| 840 | +1193 | ||
| 841 | +1194 | ! |
- teal.code::eval_code(+ tests_r <- reactive({
|
| 842 | +1195 | ! |
- qenv,+ req(iv_r()$is_valid()) |
| 843 | +1196 | ! |
- substitute(+ teal::validate_inputs(iv_r_dist()) |
| 844 | +1197 | ! |
- expr = {
+ test_q()[["test_stats"]] |
| 845 | -! | +||
| 1198 | +
- g <- plot_call+ })+ |
+ ||
| 1199 | ++ | + | |
| 846 | +1200 | ! |
- print(g)+ pws1 <- teal.widgets::plot_with_settings_srv( |
| 847 | -+ | ||
| 1201 | +! |
- },+ id = "hist_plot", |
|
| 848 | +1202 | ! |
- env = list(plot_call = Reduce(function(x, y) call("+", x, y), c(plot_call, parsed_ggplot2_args)))
+ plot_r = dist_r, |
| 849 | -+ | ||
| 1203 | +! |
- )+ height = plot_height, |
|
| 850 | -+ | ||
| 1204 | +! |
- )+ width = plot_width, |
|
| 851 | -+ | ||
| 1205 | +! |
- }+ brushing = FALSE |
|
| 852 | +1206 |
) |
|
| 853 | +1207 | ||
| 854 | -+ | ||
| 1208 | +! |
- # qqplot qenv ----+ pws2 <- teal.widgets::plot_with_settings_srv( |
|
| 855 | +1209 | ! |
- qq_q <- eventReactive(+ id = "qq_plot", |
| 856 | +1210 | ! |
- eventExpr = {
+ plot_r = qq_r, |
| 857 | +1211 | ! |
- common_q()+ height = plot_height, |
| 858 | +1212 | ! |
- input$scales_type+ width = plot_width, |
| 859 | +1213 | ! |
- input$qq_line+ brushing = FALSE |
| 860 | -! | +||
| 1214 | +
- is.null(input$ggtheme)+ ) |
||
| 861 | +1215 |
- },+ |
|
| 862 | +1216 | ! |
- valueExpr = {
+ output$t_stats <- DT::renderDataTable( |
| 863 | +1217 | ! |
- dist_var <- merge_vars()$dist_var+ expr = tests_r(),+ |
+
| 1218 | +! | +
+ options = list(scrollX = TRUE),+ |
+ |
| 1219 | +! | +
+ rownames = FALSE |
|
| 864 | -! | +||
| 1220 | +
- s_var <- merge_vars()$s_var+ ) |
||
| 865 | -! | +||
| 1221 | +
- g_var <- merge_vars()$g_var+ |
||
| 866 | +1222 | ! |
- dist_var_name <- merge_vars()$dist_var_name+ teal.widgets::verbatim_popup_srv( |
| 867 | +1223 | ! |
- s_var_name <- merge_vars()$s_var_name+ id = "warning", |
| 868 | +1224 | ! |
- g_var_name <- merge_vars()$g_var_name+ verbatim_content = reactive(teal.code::get_warnings(output_q())), |
| 869 | +1225 | ! |
- t_dist <- input$t_dist+ title = "Warning", |
| 870 | +1226 | ! |
- dist_param1 <- input$dist_param1+ disabled = reactive(is.null(teal.code::get_warnings(output_q()))) |
| 871 | -! | +||
| 1227 | +
- dist_param2 <- input$dist_param2+ ) |
||
| 872 | +1228 | ||
| 873 | +1229 | ! |
- scales_type <- input$scales_type+ teal.widgets::verbatim_popup_srv( |
| 874 | +1230 | ! |
- ggtheme <- input$ggtheme+ id = "rcode", |
| 875 | -+ | ||
| 1231 | +! |
-
+ verbatim_content = reactive(teal.code::get_code(output_q())), |
|
| 876 | +1232 | ! |
- teal::validate_inputs(iv_r_dist(), iv_dist)+ title = "R Code for distribution" |
| 877 | +1233 |
-
+ ) |
|
| 878 | -! | +||
| 1234 | +
- qenv <- common_q()+ |
||
| 879 | +1235 |
-
+ ### REPORTER |
|
| 880 | +1236 | ! |
- plot_call <- if (length(s_var) == 0 && length(g_var) == 0) {
+ if (with_reporter) {
|
| 881 | +1237 | ! |
- substitute(+ card_fun <- function(comment, label) {
|
| 882 | +1238 | ! |
- expr = ggplot(ANL, aes_string(sample = dist_var)),+ card <- teal::report_card_template( |
| 883 | +1239 | ! |
- env = list(dist_var = dist_var)+ title = "Distribution Plot", |
| 884 | -+ | ||
| 1240 | +! |
- )+ label = label, |
|
| 885 | +1241 | ! |
- } else if (length(s_var) != 0 && length(g_var) == 0) {
+ with_filter = with_filter, |
| 886 | +1242 | ! |
- substitute(+ filter_panel_api = filter_panel_api |
| 887 | -! | +||
| 1243 | +
- expr = ggplot(ANL, aes_string(sample = dist_var, color = s_var)),+ ) |
||
| 888 | +1244 | ! |
- env = list(dist_var = dist_var, s_var = s_var)+ card$append_text("Plot", "header3")
|
| 889 | -+ | ||
| 1245 | +! |
- )+ if (input$tabs == "Histogram") {
|
|
| 890 | +1246 | ! |
- } else if (length(s_var) == 0 && length(g_var) != 0) {
+ card$append_plot(dist_r(), dim = pws1$dim()) |
| 891 | +1247 | ! |
- substitute(+ } else if (input$tabs == "QQplot") {
|
| 892 | +1248 | ! |
- expr = ggplot(ANL[ANL[[g_var]] != "NA", ], aes_string(sample = dist_var)) ++ card$append_plot(qq_r(), dim = pws2$dim()) |
| 893 | -! | +||
| 1249 | +
- facet_wrap(~g_var_name, ncol = 1, scales = scales_raw),+ } |
||
| 894 | +1250 | ! |
- env = list(+ card$append_text("Statistics table", "header3")
+ |
+
| 1251 | ++ | + | |
| 895 | +1252 | ! |
- dist_var = dist_var,+ card$append_table(common_q()[["summary_table"]]) |
| 896 | +1253 | ! |
- g_var = g_var,+ tests_error <- tryCatch(expr = tests_r(), error = function(e) "error") |
| 897 | +1254 | ! |
- g_var_name = g_var_name,+ if (inherits(tests_error, "data.frame")) {
|
| 898 | +1255 | ! |
- scales_raw = tolower(scales_type)+ card$append_text("Tests table", "header3")
|
| 899 | -+ | ||
| 1256 | +! |
- )+ card$append_table(tests_r()) |
|
| 900 | +1257 |
- )+ } |
|
| 901 | +1258 |
- } else {
+
|
|
| 902 | +1259 | ! |
- substitute(+ if (!comment == "") {
|
| 903 | +1260 | ! |
- expr = ggplot(ANL[ANL[[g_var]] != "NA", ], aes_string(sample = dist_var, color = s_var)) ++ card$append_text("Comment", "header3")
|
| 904 | +1261 | ! |
- facet_wrap(~g_var_name, ncol = 1, scales = scales_raw),+ card$append_text(comment) |
| 905 | -! | +||
| 1262 | +
- env = list(+ } |
||
| 906 | +1263 | ! |
- dist_var = dist_var,+ card$append_src(teal.code::get_code(output_q())) |
| 907 | +1264 | ! |
- g_var = g_var,+ card |
| 908 | -! | +||
| 1265 | +
- s_var = s_var,+ } |
||
| 909 | +1266 | ! |
- g_var_name = g_var_name,+ teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
|
| 910 | -! | +||
| 1267 | +
- scales_raw = tolower(scales_type)+ } |
||
| 911 | +1268 |
- )+ ### |
|
| 912 | +1269 |
- )+ }) |
|
| 913 | +1270 |
- }+ } |
| 914 | +1 |
-
+ #' Outliers Module |
|
| 915 | -! | +||
| 2 | +
- map_dist <- stats::setNames(+ #' |
||
| 916 | -! | +||
| 3 | +
- c("qnorm", "qlnorm", "qgamma", "qunif"),
+ #' Module to analyze and identify outliers using different methods |
||
| 917 | -! | +||
| 4 | +
- c("normal", "lognormal", "gamma", "unif")
+ #' |
||
| 918 | +5 |
- )+ #' @inheritParams teal::module |
|
| 919 | +6 |
-
+ #' @inheritParams shared_params |
|
| 920 | -! | +||
| 7 | +
- plot_call <- substitute(+ #' |
||
| 921 | -! | +||
| 8 | +
- expr = plot_call ++ #' @param outlier_var (`data_extract_spec` or `list` of multiple `data_extract_spec`) |
||
| 922 | -! | +||
| 9 | +
- stat_qq(distribution = mapped_dist, dparams = params),+ #' variable to consider for the outliers analysis. |
||
| 923 | -! | +||
| 10 | +
- env = list(plot_call = plot_call, mapped_dist = as.name(unname(map_dist[t_dist])))+ #' @param categorical_var (`data_extract_spec` or `list` of multiple `data_extract_spec`) |
||
| 924 | +11 |
- )+ #' categorical factor to split the selected outlier variables on. |
|
| 925 | +12 |
-
+ #' |
|
| 926 | -! | +||
| 13 | +
- if (length(t_dist) != 0 && length(g_var) == 0 && length(s_var) == 0) {
+ #' @templateVar ggnames "Boxplot","Density Plot","Cumulative Distribution Plot" |
||
| 927 | -! | +||
| 14 | +
- qenv <- teal.code::eval_code(+ #' @template ggplot2_args_multi |
||
| 928 | -! | +||
| 15 | +
- qenv,+ #' |
||
| 929 | -! | +||
| 16 | +
- substitute(+ #' @export |
||
| 930 | -! | +||
| 17 | +
- df_params <- as.data.frame(append(params, list(name = t_dist))),+ #' |
||
| 931 | -! | +||
| 18 | +
- env = list(t_dist = t_dist)+ #' @examples |
||
| 932 | +19 |
- )+ #' |
|
| 933 | +20 |
- )+ #' data <- teal_data() |
|
| 934 | -! | +||
| 21 | +
- datas <- quote(data.frame(x = 0.7, y = 1, tb = I(list(df_params = df_params))))+ #' data <- within(data, {
|
||
| 935 | -! | +||
| 22 | +
- label <- quote(tb)+ #' ADSL <- teal.modules.general::rADSL |
||
| 936 | +23 |
-
+ #' }) |
|
| 937 | -! | +||
| 24 | +
- plot_call <- substitute(+ #' datanames <- c("ADSL")
|
||
| 938 | -! | +||
| 25 | +
- expr = plot_call ++ #' datanames(data) <- datanames |
||
| 939 | -! | +||
| 26 | +
- ggpp::geom_table_npc(+ #' join_keys(data) <- default_cdisc_join_keys[datanames] |
||
| 940 | -! | +||
| 27 | +
- data = data,+ #' |
||
| 941 | -! | +||
| 28 | +
- aes(npcx = x, npcy = y, label = label),+ #' fact_vars_adsl <- names(Filter(isTRUE, sapply(data[["ADSL"]], is.factor))) |
||
| 942 | -! | +||
| 29 | +
- hjust = 0,+ #' vars <- choices_selected(variable_choices(data[["ADSL"]], fact_vars_adsl)) |
||
| 943 | -! | +||
| 30 | +
- vjust = 1,+ #' |
||
| 944 | -! | +||
| 31 | +
- size = 4+ #' app <- teal::init( |
||
| 945 | +32 |
- ),+ #' data = data,+ |
+ |
| 33 | ++ |
+ #' modules = teal::modules(+ |
+ |
| 34 | ++ |
+ #' teal.modules.general::tm_outliers(+ |
+ |
| 35 | ++ |
+ #' outlier_var = list(+ |
+ |
| 36 | ++ |
+ #' teal.transform::data_extract_spec( |
|
| 946 | -! | +||
| 37 | +
- env = list(+ #' dataname = "ADSL", |
||
| 947 | -! | +||
| 38 | +
- plot_call = plot_call,+ #' select = select_spec( |
||
| 948 | -! | +||
| 39 | +
- data = datas,+ #' label = "Select variable:", |
||
| 949 | -! | +||
| 40 | +
- label = label+ #' choices = variable_choices(data[["ADSL"]], c("AGE", "BMRKR1")),
|
||
| 950 | +41 |
- )+ #' selected = "AGE", |
|
| 951 | +42 |
- )+ #' multiple = FALSE, |
|
| 952 | +43 |
- }+ #' fixed = FALSE |
|
| 953 | +44 |
-
+ #' ) |
|
| 954 | -! | +||
| 45 | +
- if (isTRUE(input$qq_line)) {
+ #' ) |
||
| 955 | -! | +||
| 46 | +
- plot_call <- substitute(+ #' ), |
||
| 956 | -! | +||
| 47 | +
- expr = plot_call ++ #' categorical_var = list( |
||
| 957 | -! | +||
| 48 | +
- stat_qq_line(distribution = mapped_dist, dparams = params),+ #' teal.transform::data_extract_spec( |
||
| 958 | -! | +||
| 49 | +
- env = list(plot_call = plot_call, mapped_dist = as.name(unname(map_dist[t_dist])))+ #' dataname = "ADSL", |
||
| 959 | +50 |
- )+ #' filter = teal.transform::filter_spec( |
|
| 960 | +51 |
- }+ #' vars = vars, |
|
| 961 | +52 |
-
+ #' choices = value_choices(data[["ADSL"]], vars$selected), |
|
| 962 | -! | +||
| 53 | +
- all_ggplot2_args <- teal.widgets::resolve_ggplot2_args(+ #' selected = value_choices(data[["ADSL"]], vars$selected), |
||
| 963 | -! | +||
| 54 | +
- user_plot = ggplot2_args[["QQplot"]],+ #' multiple = TRUE |
||
| 964 | -! | +||
| 55 | +
- user_default = ggplot2_args$default,+ #' ) |
||
| 965 | -! | +||
| 56 | +
- module_plot = teal.widgets::ggplot2_args(labs = list(x = "theoretical", y = "sample"))+ #' ) |
||
| 966 | +57 |
- )+ #' ), |
|
| 967 | +58 |
-
+ #' ggplot2_args = list( |
|
| 968 | -! | +||
| 59 | +
- parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(+ #' teal.widgets::ggplot2_args( |
||
| 969 | -! | +||
| 60 | +
- all_ggplot2_args,+ #' labs = list(subtitle = "Plot generated by Outliers Module") |
||
| 970 | -! | +||
| 61 | +
- ggtheme = ggtheme+ #' ) |
||
| 971 | +62 |
- )+ #' ) |
|
| 972 | +63 |
-
+ #' ) |
|
| 973 | -! | +||
| 64 | +
- teal.code::eval_code(+ #' ) |
||
| 974 | -! | +||
| 65 | +
- qenv,+ #' ) |
||
| 975 | -! | +||
| 66 | +
- substitute(+ #' if (interactive()) {
|
||
| 976 | -! | +||
| 67 | +
- expr = {
+ #' shinyApp(app$ui, app$server) |
||
| 977 | -! | +||
| 68 | +
- g <- plot_call+ #' } |
||
| 978 | -! | +||
| 69 | +
- print(g)+ tm_outliers <- function(label = "Outliers Module", |
||
| 979 | +70 |
- },+ outlier_var, |
|
| 980 | -! | +||
| 71 | +
- env = list(plot_call = Reduce(function(x, y) call("+", x, y), c(plot_call, parsed_ggplot2_args)))
+ categorical_var = NULL, |
||
| 981 | +72 |
- )+ ggtheme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void"),
|
|
| 982 | +73 |
- )+ ggplot2_args = teal.widgets::ggplot2_args(), |
|
| 983 | +74 |
- }+ plot_height = c(600, 200, 2000), |
|
| 984 | +75 |
- )+ plot_width = NULL, |
|
| 985 | +76 |
-
+ pre_output = NULL, |
|
| 986 | +77 |
- # test qenv ----+ post_output = NULL) {
|
|
| 987 | +78 | ! |
- test_q <- eventReactive(+ logger::log_info("Initializing tm_outliers")
|
| 988 | +79 | ! |
- ignoreNULL = FALSE,+ if (inherits(outlier_var, "data_extract_spec")) outlier_var <- list(outlier_var) |
| 989 | +80 | ! |
- eventExpr = {
+ if (inherits(categorical_var, "data_extract_spec")) categorical_var <- list(categorical_var) |
| 990 | +81 | ! |
- common_q()+ if (inherits(ggplot2_args, "ggplot2_args")) ggplot2_args <- list(default = ggplot2_args) |
| 991 | -! | +||
| 82 | +
- input$dist_param1+ |
||
| 992 | +83 | ! |
- input$dist_param2+ ggtheme <- match.arg(ggtheme) |
| 993 | +84 | ! |
- input$dist_tests+ checkmate::assert_string(label) |
| 994 | -+ | ||
| 85 | +! |
- },+ checkmate::assert_list(outlier_var, types = "data_extract_spec") |
|
| 995 | +86 | ! |
- valueExpr = {
+ checkmate::assert_list(categorical_var, types = "data_extract_spec", null.ok = TRUE) |
| 996 | -+ | ||
| 87 | +! |
- # Create a private stack for this function only.+ if (is.list(categorical_var)) {
|
|
| 997 | +88 | ! |
- ANL <- common_q()[["ANL"]] # nolint object_name_linter+ lapply(categorical_var, function(x) {
|
| 998 | -+ | ||
| 89 | +! |
-
+ if (length(x$filter) > 1L) {
|
|
| 999 | +90 | ! |
- dist_var <- merge_vars()$dist_var+ stop("tm_outliers: categorical_var data_extract_specs may only specify one filter_spec", call. = FALSE)
|
| 1000 | -! | +||
| 91 | +
- s_var <- merge_vars()$s_var+ } |
||
| 1001 | -! | +||
| 92 | +
- g_var <- merge_vars()$g_var+ }) |
||
| 1002 | +93 |
-
+ } |
|
| 1003 | +94 | ! |
- dist_var_name <- merge_vars()$dist_var_name+ plot_choices <- c("Boxplot", "Density Plot", "Cumulative Distribution Plot")
|
| 1004 | +95 | ! |
- s_var_name <- merge_vars()$s_var_name+ checkmate::assert_list(ggplot2_args, types = "ggplot2_args") |
| 1005 | +96 | ! |
- g_var_name <- merge_vars()$g_var_name+ checkmate::assert_subset(names(ggplot2_args), c("default", plot_choices))
|
| 1006 | +97 | ||
| 1007 | +98 | ! |
- dist_param1 <- input$dist_param1+ args <- as.list(environment())+ |
+
| 99 | ++ | + | |
| 1008 | +100 | ! |
- dist_param2 <- input$dist_param2+ data_extract_list <- list( |
| 1009 | +101 | ! |
- dist_tests <- input$dist_tests+ outlier_var = outlier_var, |
| 1010 | +102 | ! |
- t_dist <- input$t_dist+ categorical_var = categorical_var |
| 1011 | +103 | - - | -|
| 1012 | -! | -
- validate(need(dist_tests, "Please select a test"))+ ) |
|
| 1013 | +104 | ||
| 1014 | +105 | ! |
- teal::validate_inputs(iv_dist)+ module( |
| 1015 | -+ | ||
| 106 | +! |
-
+ label = label, |
|
| 1016 | +107 | ! |
- if (length(s_var) > 0 || length(g_var) > 0) {
+ server = srv_outliers, |
| 1017 | +108 | ! |
- counts <- ANL %>%+ server_args = c( |
| 1018 | +109 | ! |
- dplyr::group_by_at(dplyr::vars(dplyr::any_of(c(s_var, g_var)))) %>%+ data_extract_list, |
| 1019 | +110 | ! |
- dplyr::summarise(n = dplyr::n())+ list(plot_height = plot_height, plot_width = plot_width, ggplot2_args = ggplot2_args) |
| 1020 | +111 |
-
+ ), |
|
| 1021 | +112 | ! |
- validate(need(all(counts$n > 5), "Please select strata*group with at least 5 observation each."))+ ui = ui_outliers,+ |
+
| 113 | +! | +
+ ui_args = args,+ |
+ |
| 114 | +! | +
+ datanames = teal.transform::get_extract_datanames(data_extract_list) |
|
| 1022 | +115 |
- }+ ) |
|
| 1023 | +116 |
-
+ } |
|
| 1024 | +117 | ||
| 1025 | -! | +||
| 118 | +
- if (dist_tests %in% c(+ ui_outliers <- function(id, ...) {
|
||
| 1026 | +119 | ! |
- "t-test (two-samples, not paired)",+ args <- list(...) |
| 1027 | +120 | ! |
- "F-test",+ ns <- NS(id) |
| 1028 | +121 | ! |
- "Kolmogorov-Smirnov (two-samples)"+ is_single_dataset_value <- teal.transform::is_single_dataset(args$outlier_var, args$categorical_var) |
| 1029 | +122 |
- )) {
+
|
|
| 1030 | +123 | ! |
- if (length(g_var) == 0 && length(s_var) > 0) {
+ teal.widgets::standard_layout( |
| 1031 | +124 | ! |
- validate(need(+ output = teal.widgets::white_small_well( |
| 1032 | +125 | ! |
- length(unique(ANL[[s_var]])) == 2,+ uiOutput(ns("total_outliers")),
|
| 1033 | +126 | ! |
- "Please select stratify variable with 2 levels."+ DT::dataTableOutput(ns("summary_table")),
|
| 1034 | -+ | ||
| 127 | +! |
- ))+ uiOutput(ns("total_missing")),
|
|
| 1035 | -+ | ||
| 128 | +! | +
+ br(), hr(),+ |
+ |
| 129 | +! |
- }+ tabsetPanel( |
|
| 1036 | +130 | ! |
- if (length(g_var) > 0 && length(s_var) > 0) {
+ id = ns("tabs"),
|
| 1037 | +131 | ! |
- validate(need(+ tabPanel( |
| 1038 | +132 | ! |
- all(stats::na.omit(as.vector(+ "Boxplot", |
| 1039 | +133 | ! |
- tapply(ANL[[s_var]], list(ANL[[g_var]]), function(x) length(unique(x))) == 2+ teal.widgets::plot_with_settings_ui(id = ns("box_plot"))
|
| 1040 | +134 |
- ))),+ ), |
|
| 1041 | +135 | ! |
- "Please select stratify variable with 2 levels, per each group."- |
-
| 1042 | -- |
- ))+ tabPanel( |
|
| 1043 | -+ | ||
| 136 | +! |
- }+ "Density Plot", |
|
| 1044 | -+ | ||
| 137 | +! |
- }+ teal.widgets::plot_with_settings_ui(id = ns("density_plot"))
|
|
| 1045 | +138 |
-
+ ), |
|
| 1046 | +139 | ! |
- map_dist <- stats::setNames(+ tabPanel( |
| 1047 | +140 | ! |
- c("pnorm", "plnorm", "pgamma", "punif"),
+ "Cumulative Distribution Plot", |
| 1048 | +141 | ! |
- c("normal", "lognormal", "gamma", "unif")
+ teal.widgets::plot_with_settings_ui(id = ns("cum_density_plot"))
|
| 1049 | +142 |
) |
|
| 1050 | -! | +||
| 143 | +
- sks_args <- list(+ ), |
||
| 1051 | +144 | ! |
- test = quote(stats::ks.test),+ br(), hr(), |
| 1052 | +145 | ! |
- args = bquote(append(list(.[[.(dist_var)]], .(map_dist[t_dist])), params)),+ uiOutput(ns("table_ui_wrap"))
+ |
+
| 146 | ++ |
+ ), |
|
| 1053 | +147 | ! |
- groups = c(g_var, s_var)+ encoding = div( |
| 1054 | +148 |
- )+ ### Reporter |
|
| 1055 | +149 | ! |
- ssw_args <- list(+ teal.reporter::simple_reporter_ui(ns("simple_reporter")),
|
| 1056 | -! | +||
| 150 | +
- test = quote(stats::shapiro.test),+ ### |
||
| 1057 | +151 | ! |
- args = bquote(list(.[[.(dist_var)]])),+ tags$label("Encodings", class = "text-primary"),
|
| 1058 | +152 | ! |
- groups = c(g_var, s_var)+ teal.transform::datanames_input(args[c("outlier_var", "categorical_var")]),
|
| 1059 | -+ | ||
| 153 | +! |
- )+ teal.transform::data_extract_ui( |
|
| 1060 | +154 | ! |
- mfil_args <- list(+ id = ns("outlier_var"),
|
| 1061 | +155 | ! |
- test = quote(stats::fligner.test),+ label = "Variable", |
| 1062 | +156 | ! |
- args = bquote(list(.[[.(dist_var)]], .[[.(s_var)]])),+ data_extract_spec = args$outlier_var, |
| 1063 | +157 | ! |
- groups = c(g_var)+ is_single_dataset = is_single_dataset_value |
| 1064 | +158 |
- )+ ), |
|
| 1065 | +159 | ! |
- sad_args <- list(+ if (!is.null(args$categorical_var)) {
|
| 1066 | +160 | ! |
- test = quote(goftest::ad.test),+ teal.transform::data_extract_ui( |
| 1067 | +161 | ! |
- args = bquote(append(list(.[[.(dist_var)]], .(map_dist[t_dist])), params)),+ id = ns("categorical_var"),
|
| 1068 | +162 | ! |
- groups = c(g_var, s_var)+ label = "Categorical factor",+ |
+
| 163 | +! | +
+ data_extract_spec = args$categorical_var,+ |
+ |
| 164 | +! | +
+ is_single_dataset = is_single_dataset_value |
|
| 1069 | +165 |
) |
|
| 1070 | -! | +||
| 166 | +
- scvm_args <- list(+ }, |
||
| 1071 | +167 | ! |
- test = quote(goftest::cvm.test),+ conditionalPanel( |
| 1072 | +168 | ! |
- args = bquote(append(list(.[[.(dist_var)]], .(map_dist[t_dist])), params)),+ condition = paste0("input['", ns("tabs"), "'] == 'Boxplot'"),
|
| 1073 | +169 | ! |
- groups = c(g_var, s_var)+ teal.widgets::optionalSelectInput( |
| 1074 | -+ | ||
| 170 | +! |
- )+ inputId = ns("boxplot_alts"),
|
|
| 1075 | +171 | ! |
- manov_args <- list(+ label = "Plot type", |
| 1076 | +172 | ! |
- test = quote(stats::aov),+ choices = c("Box plot", "Violin plot"),
|
| 1077 | +173 | ! |
- args = bquote(list(stats::formula(.(dist_var_name) ~ .(s_var_name)), .)),+ selected = "Box plot", |
| 1078 | +174 | ! |
- groups = c(g_var)+ multiple = FALSE |
| 1079 | +175 |
) |
|
| 1080 | -! | +||
| 176 | +
- mt_args <- list(+ ), |
||
| 1081 | +177 | ! |
- test = quote(stats::t.test),+ shinyjs::hidden(checkboxInput(ns("split_outliers"), "Define outliers based on group splitting", value = FALSE)),
|
| 1082 | +178 | ! |
- args = bquote(unname(split(.[[.(dist_var)]], .[[.(s_var)]], drop = TRUE))),+ shinyjs::hidden(checkboxInput(ns("order_by_outlier"), "Re-order categories by outliers [by %]", value = FALSE)),
|
| 1083 | +179 | ! |
- groups = c(g_var)- |
-
| 1084 | -- |
- )+ teal.widgets::panel_group( |
|
| 1085 | +180 | ! |
- mv_args <- list(+ teal.widgets::panel_item( |
| 1086 | +181 | ! |
- test = quote(stats::var.test),+ title = "Method parameters", |
| 1087 | +182 | ! |
- args = bquote(unname(split(.[[.(dist_var)]], .[[.(s_var)]], drop = TRUE))),+ collapsed = FALSE, |
| 1088 | +183 | ! |
- groups = c(g_var)- |
-
| 1089 | -- |
- )+ teal.widgets::optionalSelectInput( |
|
| 1090 | +184 | ! |
- mks_args <- list(+ inputId = ns("method"),
|
| 1091 | +185 | ! |
- test = quote(stats::ks.test),+ label = "Method", |
| 1092 | +186 | ! |
- args = bquote(unname(split(.[[.(dist_var)]], .[[.(s_var)]], drop = TRUE))),+ choices = c("IQR", "Z-score", "Percentile"),
|
| 1093 | +187 | ! |
- groups = c(g_var)+ selected = "IQR", |
| 1094 | -+ | ||
| 188 | +! |
- )+ multiple = FALSE |
|
| 1095 | +189 |
-
+ ), |
|
| 1096 | +190 | ! |
- tests_base <- switch(dist_tests,+ conditionalPanel( |
| 1097 | +191 | ! |
- "Kolmogorov-Smirnov (one-sample)" = sks_args,+ condition = |
| 1098 | +192 | ! |
- "Shapiro-Wilk" = ssw_args,+ paste0("input['", ns("method"), "'] == 'IQR'"),
|
| 1099 | +193 | ! |
- "Fligner-Killeen" = mfil_args,+ sliderInput( |
| 1100 | +194 | ! |
- "one-way ANOVA" = manov_args,+ ns("iqr_slider"),
|
| 1101 | +195 | ! |
- "t-test (two-samples, not paired)" = mt_args,+ "Outlier range:", |
| 1102 | +196 | ! |
- "F-test" = mv_args,+ min = 1, |
| 1103 | +197 | ! |
- "Kolmogorov-Smirnov (two-samples)" = mks_args,+ max = 5, |
| 1104 | +198 | ! |
- "Anderson-Darling (one-sample)" = sad_args,+ value = 3, |
| 1105 | +199 | ! |
- "Cramer-von Mises (one-sample)" = scvm_args+ step = 0.5 |
| 1106 | +200 |
- )+ ) |
|
| 1107 | +201 | - - | -|
| 1108 | -! | -
- env <- list(+ ), |
|
| 1109 | +202 | ! |
- t_test = t_dist,+ conditionalPanel( |
| 1110 | +203 | ! |
- dist_var = dist_var,+ condition = |
| 1111 | +204 | ! |
- g_var = g_var,+ paste0("input['", ns("method"), "'] == 'Z-score'"),
|
| 1112 | +205 | ! |
- s_var = s_var,+ sliderInput( |
| 1113 | +206 | ! |
- args = tests_base$args,+ ns("zscore_slider"),
|
| 1114 | +207 | ! |
- groups = tests_base$groups,+ "Outlier range:", |
| 1115 | +208 | ! |
- test = tests_base$test,+ min = 1, |
| 1116 | +209 | ! |
- dist_var_name = dist_var_name,+ max = 5, |
| 1117 | +210 | ! |
- g_var_name = g_var_name,+ value = 3, |
| 1118 | +211 | ! |
- s_var_name = s_var_name+ step = 0.5 |
| 1119 | +212 |
- )+ ) |
|
| 1120 | +213 |
-
+ ), |
|
| 1121 | +214 | ! |
- qenv <- common_q()- |
-
| 1122 | -- |
-
+ conditionalPanel( |
|
| 1123 | +215 | ! |
- if (length(s_var) == 0 && length(g_var) == 0) {
+ condition = |
| 1124 | +216 | ! |
- qenv <- teal.code::eval_code(+ paste0("input['", ns("method"), "'] == 'Percentile'"),
|
| 1125 | +217 | ! |
- qenv,+ sliderInput( |
| 1126 | +218 | ! |
- substitute(+ ns("percentile_slider"),
|
| 1127 | +219 | ! |
- expr = {
+ "Outlier range:", |
| 1128 | +220 | ! |
- test_stats <- ANL %>%+ min = 0.001, |
| 1129 | +221 | ! |
- dplyr::select(dist_var) %>%+ max = 0.5, |
| 1130 | +222 | ! |
- with(., broom::glance(do.call(test, args))) %>%+ value = 0.01, |
| 1131 | +223 | ! |
- dplyr::mutate_if(is.numeric, round, 3)+ step = 0.001 |
| 1132 | +224 |
- },- |
- |
| 1133 | -! | -
- env = env+ ) |
|
| 1134 | +225 |
- )+ ), |
|
| 1135 | -+ | ||
| 226 | +! |
- )+ uiOutput(ns("ui_outlier_help"))
|
|
| 1136 | +227 |
- } else {
- |
- |
| 1137 | -! | -
- qenv <- teal.code::eval_code(+ ) |
|
| 1138 | -! | +||
| 228 | +
- qenv,+ ), |
||
| 1139 | +229 | ! |
- substitute(+ teal.widgets::panel_item( |
| 1140 | +230 | ! |
- expr = {
+ title = "Plot settings", |
| 1141 | +231 | ! |
- test_stats <- ANL %>%+ selectInput( |
| 1142 | +232 | ! |
- dplyr::select(dist_var, s_var, g_var) %>%+ inputId = ns("ggtheme"),
|
| 1143 | +233 | ! |
- dplyr::group_by_at(dplyr::vars(dplyr::any_of(groups))) %>%+ label = "Theme (by ggplot):", |
| 1144 | +234 | ! |
- dplyr::do(tests = broom::glance(do.call(test, args))) %>%+ choices = ggplot_themes, |
| 1145 | +235 | ! |
- tidyr::unnest(tests) %>%+ selected = args$ggtheme, |
| 1146 | +236 | ! |
- dplyr::mutate_if(is.numeric, round, 3)+ multiple = FALSE |
| 1147 | +237 |
- },+ ) |
|
| 1148 | -! | +||
| 238 | +
- env = env+ ) |
||
| 1149 | +239 |
- )+ ), |
|
| 1150 | -+ | ||
| 240 | +! |
- )+ forms = tagList( |
|
| 1151 | -+ | ||
| 241 | +! |
- }+ teal.widgets::verbatim_popup_ui(ns("warning"), "Show Warnings"),
|
|
| 1152 | +242 | ! |
- qenv %>%+ teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code")
|
| 1153 | +243 |
- # used to display table when running show-r-code code+ ), |
|
| 1154 | +244 | ! |
- teal.code::eval_code(quote(test_stats))+ pre_output = args$pre_output, |
| 1155 | -+ | ||
| 245 | +! |
- }+ post_output = args$post_output |
|
| 1156 | +246 |
- )+ ) |
|
| 1157 | +247 |
-
+ } |
|
| 1158 | +248 |
- # outputs ----+ |
|
| 1159 | +249 |
- ## building main qenv+ srv_outliers <- function(id, data, reporter, filter_panel_api, outlier_var, |
|
| 1160 | -! | +||
| 250 | +
- output_q <- reactive({
+ categorical_var, plot_height, plot_width, ggplot2_args) {
|
||
| 1161 | +251 | ! |
- tab <- input$tabs+ with_reporter <- !missing(reporter) && inherits(reporter, "Reporter") |
| 1162 | +252 | ! |
- req(tab) # tab is NULL upon app launch, hence will crash without this statement- |
-
| 1163 | -- |
-
+ with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI") |
|
| 1164 | +253 | ! |
- qenv_final <- common_q()- |
-
| 1165 | -- |
- # wrapped in if since could lead into validate error - we do want to continue+ checkmate::assert_class(data, "reactive") |
|
| 1166 | +254 | ! |
- test_r_qenv_out <- try(test_q(), silent = TRUE)+ checkmate::assert_class(isolate(data()), "teal_data") |
| 1167 | +255 | ! |
- if (!inherits(test_r_qenv_out, c("try-error", "error"))) {
+ moduleServer(id, function(input, output, session) {
|
| 1168 | +256 | ! |
- qenv_final <- teal.code::join(qenv_final, test_q())- |
-
| 1169 | -- |
- }+ vars <- list(outlier_var = outlier_var, categorical_var = categorical_var) |
|
| 1170 | +257 | ||
| 1171 | +258 | ! |
- qenv_final <- if (tab == "Histogram") {
+ rule_diff <- function(other) {
|
| 1172 | +259 | ! |
- req(dist_q())+ function(value) {
|
| 1173 | +260 | ! |
- teal.code::join(qenv_final, dist_q())+ othervalue <- tryCatch(selector_list()[[other]]()[["select"]], error = function(e) NULL) |
| 1174 | +261 | ! |
- } else if (tab == "QQplot") {
+ if (!is.null(othervalue) && identical(othervalue, value)) {
|
| 1175 | +262 | ! |
- req(qq_q())+ "`Variable` and `Categorical factor` cannot be the same" |
| 1176 | -! | +||
| 263 | +
- teal.code::join(qenv_final, qq_q())+ } |
||
| 1177 | +264 |
} |
|
| 1178 | -! | -
- qenv_final- |
- |
| 1179 | +265 |
- })+ } |
|
| 1180 | +266 | ||
| 1181 | +267 | ! |
- dist_r <- reactive(dist_q()[["g"]])- |
-
| 1182 | -- |
-
+ selector_list <- teal.transform::data_extract_multiple_srv( |
|
| 1183 | +268 | ! |
- qq_r <- reactive(qq_q()[["g"]])- |
-
| 1184 | -- |
-
+ data_extract = vars, |
|
| 1185 | +269 | ! |
- output$summary_table <- DT::renderDataTable(+ datasets = data, |
| 1186 | +270 | ! |
- expr = if (iv_r()$is_valid()) common_q()[["summary_table"]] else NULL,+ select_validation_rule = list( |
| 1187 | +271 | ! |
- options = list(+ outlier_var = shinyvalidate::compose_rules( |
| 1188 | +272 | ! |
- autoWidth = TRUE,+ shinyvalidate::sv_required("Please select a variable"),
|
| 1189 | +273 | ! |
- columnDefs = list(list(width = "200px", targets = "_all"))+ rule_diff("categorical_var")
|
| 1190 | +274 |
- ),+ ), |
|
| 1191 | +275 | ! |
- rownames = FALSE+ categorical_var = rule_diff("outlier_var")
|
| 1192 | +276 | ++ |
+ )+ |
+
| 277 |
) |
||
| 1193 | +278 | ||
| 1194 | +279 | ! |
- tests_r <- reactive({
+ iv_r <- reactive({
|
| 1195 | +280 | ! |
- req(iv_r()$is_valid())+ iv <- shinyvalidate::InputValidator$new() |
| 1196 | +281 | ! |
- teal::validate_inputs(iv_r_dist())+ iv$add_rule("method", shinyvalidate::sv_required("Please select a method"))
|
| 1197 | +282 | ! |
- test_q()[["test_stats"]]+ iv$add_rule("boxplot_alts", shinyvalidate::sv_required("Please select Plot Type"))
+ |
+
| 283 | +! | +
+ teal.transform::compose_and_enable_validators(iv, selector_list) |
|
| 1198 | +284 |
}) |
|
| 1199 | +285 | ||
| 1200 | +286 | ! |
- pws1 <- teal.widgets::plot_with_settings_srv(+ reactive_select_input <- reactive({
|
| 1201 | +287 | ! |
- id = "hist_plot",+ if (is.null(selector_list()$categorical_var) || length(selector_list()$categorical_var()$select) == 0) {
|
| 1202 | +288 | ! |
- plot_r = dist_r,+ selector_list()[names(selector_list()) != "categorical_var"] |
| 1203 | -! | +||
| 289 | +
- height = plot_height,+ } else {
|
||
| 1204 | +290 | ! |
- width = plot_width,+ selector_list() |
| 1205 | -! | +||
| 291 | +
- brushing = FALSE+ } |
||
| 1206 | +292 |
- )+ }) |
|
| 1207 | +293 | ||
| 1208 | -! | -
- pws2 <- teal.widgets::plot_with_settings_srv(- |
- |
| 1209 | -! | -
- id = "qq_plot",- |
- |
| 1210 | +294 | ! |
- plot_r = qq_r,+ anl_merged_input <- teal.transform::merge_expression_srv( |
| 1211 | +295 | ! |
- height = plot_height,+ selector_list = reactive_select_input, |
| 1212 | +296 | ! |
- width = plot_width,+ datasets = data, |
| 1213 | +297 | ! |
- brushing = FALSE+ merge_function = "dplyr::inner_join" |
| 1214 | +298 |
) |
|
| 1215 | +299 | ||
| 1216 | +300 | ! |
- output$t_stats <- DT::renderDataTable(+ anl_merged_q <- reactive({
|
| 1217 | +301 | ! |
- expr = tests_r(),+ req(anl_merged_input()) |
| 1218 | +302 | ! |
- options = list(scrollX = TRUE),+ data() %>% |
| 1219 | +303 | ! |
- rownames = FALSE+ teal.code::eval_code(as.expression(anl_merged_input()$expr)) |
| 1220 | +304 |
- )+ }) |
|
| 1221 | +305 | ||
| 1222 | -! | -
- teal.widgets::verbatim_popup_srv(- |
- |
| 1223 | -! | -
- id = "warning",- |
- |
| 1224 | +306 | ! |
- verbatim_content = reactive(teal.code::get_warnings(output_q())),+ merged <- list( |
| 1225 | +307 | ! |
- title = "Warning",+ anl_input_r = anl_merged_input, |
| 1226 | +308 | ! |
- disabled = reactive(is.null(teal.code::get_warnings(output_q())))+ anl_q_r = anl_merged_q |
| 1227 | +309 |
) |
|
| 1228 | +310 | ||
| 1229 | +311 | ! |
- teal.widgets::verbatim_popup_srv(+ n_outlier_missing <- reactive({
|
| 1230 | +312 | ! |
- id = "rcode",+ shiny::req(iv_r()$is_valid()) |
| 1231 | +313 | ! |
- verbatim_content = reactive(teal.code::get_code(output_q())),+ outlier_var <- as.vector(merged$anl_input_r()$columns_source$outlier_var) |
| 1232 | +314 | ! |
- title = "R Code for distribution"+ ANL <- merged$anl_q_r()[["ANL"]] # nolint: object_name.+ |
+
| 315 | +! | +
+ sum(is.na(ANL[[outlier_var]])) |
|
| 1233 | +316 |
- )+ }) |
|
| 1234 | +317 | ||
| 1235 | +318 |
- ### REPORTER+ # Used to create outlier table and the dropdown with additional columns |
|
| 1236 | +319 | ! |
- if (with_reporter) {
+ dataname_first <- isolate(teal.data::datanames(data())[[1]]) |
| 1237 | -! | +||
| 320 | +
- card_fun <- function(comment, label) {
+
|
||
| 1238 | +321 | ! |
- card <- teal::report_card_template(+ common_code_q <- reactive({
|
| 1239 | +322 | ! |
- title = "Distribution Plot",+ shiny::req(iv_r()$is_valid()) |
| 1240 | -! | +||
| 323 | +
- label = label,+ |
||
| 1241 | +324 | ! |
- with_filter = with_filter,+ ANL <- merged$anl_q_r()[["ANL"]] # nolint: object_name. |
| 1242 | +325 | ! |
- filter_panel_api = filter_panel_api+ qenv <- merged$anl_q_r() |
| 1243 | +326 |
- )+ |
|
| 1244 | +327 | ! |
- card$append_text("Plot", "header3")
+ outlier_var <- as.vector(merged$anl_input_r()$columns_source$outlier_var) |
| 1245 | +328 | ! |
- if (input$tabs == "Histogram") {
+ categorical_var <- as.vector(merged$anl_input_r()$columns_source$categorical_var) |
| 1246 | +329 | ! |
- card$append_plot(dist_r(), dim = pws1$dim())+ order_by_outlier <- input$order_by_outlier |
| 1247 | +330 | ! |
- } else if (input$tabs == "QQplot") {
+ method <- input$method |
| 1248 | +331 | ! |
- card$append_plot(qq_r(), dim = pws2$dim())+ split_outliers <- input$split_outliers+ |
+
| 332 | +! | +
+ teal::validate_has_data( |
|
| 1249 | +333 |
- }+ # missing values in the categorical variable may be used to form a category of its own+ |
+ |
| 334 | +! | +
+ `if`(+ |
+ |
| 335 | +! | +
+ length(categorical_var) == 0,+ |
+ |
| 336 | +! | +
+ ANL, |
|
| 1250 | +337 | ! |
- card$append_text("Statistics table", "header3")
+ ANL[, names(ANL) != categorical_var, drop = FALSE] |
| 1251 | +338 |
-
+ ), |
|
| 1252 | +339 | ! |
- card$append_table(common_q()[["summary_table"]])+ min_nrow = 10, |
| 1253 | +340 | ! |
- tests_error <- tryCatch(expr = tests_r(), error = function(e) "error")+ complete = TRUE, |
| 1254 | +341 | ! |
- if (inherits(tests_error, "data.frame")) {
+ allow_inf = FALSE+ |
+
| 342 | ++ |
+ ) |
|
| 1255 | +343 | ! |
- card$append_text("Tests table", "header3")
+ validate(need(is.numeric(ANL[[outlier_var]]), "`Variable` is not numeric")) |
| 1256 | +344 | ! |
- card$append_table(tests_r())+ validate(need(length(unique(ANL[[outlier_var]])) > 1, "Variable has no variation, i.e. only one unique value")) |
| 1257 | +345 |
- }+ |
|
| 1258 | +346 |
-
+ # show/hide split_outliers |
|
| 1259 | +347 | ! |
- if (!comment == "") {
+ if (length(categorical_var) == 0) {
|
| 1260 | +348 | ! |
- card$append_text("Comment", "header3")
+ shinyjs::hide("split_outliers")
|
| 1261 | +349 | ! |
- card$append_text(comment)+ if (n_outlier_missing() > 0) {
|
| 1262 | -+ | ||
| 350 | +! |
- }+ qenv <- teal.code::eval_code( |
|
| 1263 | +351 | ! |
- card$append_src(teal.code::get_code(output_q()))+ qenv, |
| 1264 | +352 | ! |
- card+ substitute( |
| 1265 | -+ | ||
| 353 | +! |
- }+ expr = ANL <- ANL %>% dplyr::filter(!is.na(outlier_var_name)), # nolint: object_name. |
|
| 1266 | +354 | ! |
- teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
+ env = list(outlier_var_name = as.name(outlier_var)) |
| 1267 | +355 |
- }+ ) |
|
| 1268 | +356 |
- ###+ ) |
|
| 1269 | +357 |
- })+ } |
|
| 1270 | +358 |
- }+ } else {
|
| 1 | -+ | ||
| 359 | +! |
- #' Outliers Module+ validate(need( |
|
| 2 | -+ | ||
| 360 | +! |
- #'+ is.factor(ANL[[categorical_var]]) || |
|
| 3 | -+ | ||
| 361 | +! |
- #' Module to analyze and identify outliers using different methods+ is.character(ANL[[categorical_var]]) || |
|
| 4 | -+ | ||
| 362 | +! |
- #'+ is.integer(ANL[[categorical_var]]), |
|
| 5 | -+ | ||
| 363 | +! |
- #' @inheritParams teal::module+ "`Categorical factor` must be `factor`, `character`, or `integer`" |
|
| 6 | +364 |
- #' @inheritParams shared_params+ )) |
|
| 7 | +365 |
- #'+ |
|
| 8 | -+ | ||
| 366 | +! |
- #' @param outlier_var (`data_extract_spec` or `list` of multiple `data_extract_spec`)+ if (n_outlier_missing() > 0) {
|
|
| 9 | -+ | ||
| 367 | +! |
- #' variable to consider for the outliers analysis.+ qenv <- teal.code::eval_code( |
|
| 10 | -+ | ||
| 368 | +! |
- #' @param categorical_var (`data_extract_spec` or `list` of multiple `data_extract_spec`)+ qenv, |
|
| 11 | -+ | ||
| 369 | +! |
- #' categorical factor to split the selected outlier variables on.+ substitute( |
|
| 12 | -+ | ||
| 370 | +! |
- #'+ expr = ANL <- ANL %>% dplyr::filter(!is.na(outlier_var_name)), # nolint: object_name. |
|
| 13 | -+ | ||
| 371 | +! |
- #' @templateVar ggnames "Boxplot","Density Plot","Cumulative Distribution Plot"+ env = list(outlier_var_name = as.name(outlier_var)) |
|
| 14 | +372 |
- #' @template ggplot2_args_multi+ ) |
|
| 15 | +373 |
- #'+ ) |
|
| 16 | +374 |
- #' @export+ } |
|
| 17 | -+ | ||
| 375 | +! |
- #'+ shinyjs::show("split_outliers")
|
|
| 18 | +376 |
- #' @examples+ } |
|
| 19 | +377 |
- #'+ |
|
| 20 | +378 |
- #' data <- teal_data()+ # slider |
|
| 21 | -+ | ||
| 379 | +! |
- #' data <- within(data, {
+ outlier_definition_param <- if (method == "IQR") {
|
|
| 22 | -+ | ||
| 380 | +! |
- #' ADSL <- teal.modules.general::rADSL+ input$iqr_slider |
|
| 23 | -+ | ||
| 381 | +! |
- #' })+ } else if (method == "Z-score") {
|
|
| 24 | -+ | ||
| 382 | +! |
- #' datanames <- c("ADSL")
+ input$zscore_slider |
|
| 25 | -+ | ||
| 383 | +! |
- #' datanames(data) <- datanames+ } else if (method == "Percentile") {
|
|
| 26 | -+ | ||
| 384 | +! |
- #' join_keys(data) <- default_cdisc_join_keys[datanames]+ input$percentile_slider |
|
| 27 | +385 |
- #'+ } |
|
| 28 | +386 |
- #' fact_vars_adsl <- names(Filter(isTRUE, sapply(data[["ADSL"]], is.factor)))+ |
|
| 29 | +387 |
- #' vars <- choices_selected(variable_choices(data[["ADSL"]], fact_vars_adsl))+ # this is utils function that converts a %>% NULL %>% b into a %>% b |
|
| 30 | -+ | ||
| 388 | +! |
- #'+ remove_pipe_null <- function(x) {
|
|
| 31 | -+ | ||
| 389 | +! |
- #' app <- teal::init(+ if (length(x) == 1) {
|
|
| 32 | -+ | ||
| 390 | +! |
- #' data = data,+ return(x) |
|
| 33 | +391 |
- #' modules = teal::modules(+ } |
|
| 34 | -+ | ||
| 392 | +! |
- #' teal.modules.general::tm_outliers(+ if (identical(x[[1]], as.name("%>%")) && is.null(x[[3]])) {
|
|
| 35 | -+ | ||
| 393 | +! |
- #' outlier_var = list(+ return(remove_pipe_null(x[[2]])) |
|
| 36 | +394 |
- #' teal.transform::data_extract_spec(+ } |
|
| 37 | -+ | ||
| 395 | +! |
- #' dataname = "ADSL",+ return(as.call(c(x[[1]], lapply(x[-1], remove_pipe_null)))) |
|
| 38 | +396 |
- #' select = select_spec(+ } |
|
| 39 | +397 |
- #' label = "Select variable:",+ |
|
| 40 | -+ | ||
| 398 | +! |
- #' choices = variable_choices(data[["ADSL"]], c("AGE", "BMRKR1")),
+ qenv <- teal.code::eval_code( |
|
| 41 | -+ | ||
| 399 | +! |
- #' selected = "AGE",+ qenv, |
|
| 42 | -+ | ||
| 400 | +! |
- #' multiple = FALSE,+ substitute( |
|
| 43 | -+ | ||
| 401 | +! |
- #' fixed = FALSE+ expr = {
|
|
| 44 | -+ | ||
| 402 | +! |
- #' )+ ANL_OUTLIER <- ANL %>% # nolint: object_name. |
|
| 45 | -+ | ||
| 403 | +! |
- #' )+ group_expr %>% # styler: off |
|
| 46 | -+ | ||
| 404 | +! |
- #' ),+ dplyr::mutate(is_outlier = {
|
|
| 47 | -+ | ||
| 405 | +! |
- #' categorical_var = list(+ q1_q3 <- stats::quantile(outlier_var_name, probs = c(0.25, 0.75)) |
|
| 48 | -+ | ||
| 406 | +! |
- #' teal.transform::data_extract_spec(+ iqr <- q1_q3[2] - q1_q3[1] |
|
| 49 | -+ | ||
| 407 | +! |
- #' dataname = "ADSL",+ !(outlier_var_name >= q1_q3[1] - 1.5 * iqr & outlier_var_name <= q1_q3[2] + 1.5 * iqr) |
|
| 50 | +408 |
- #' filter = teal.transform::filter_spec(+ }) %>% |
|
| 51 | -+ | ||
| 409 | +! |
- #' vars = vars,+ calculate_outliers %>% # styler: off |
|
| 52 | -+ | ||
| 410 | +! |
- #' choices = value_choices(data[["ADSL"]], vars$selected),+ ungroup_expr %>% # styler: off |
|
| 53 | -+ | ||
| 411 | +! |
- #' selected = value_choices(data[["ADSL"]], vars$selected),+ dplyr::filter(is_outlier | is_outlier_selected) %>% |
|
| 54 | -+ | ||
| 412 | +! |
- #' multiple = TRUE+ dplyr::select(-is_outlier) |
|
| 55 | +413 |
- #' )+ }, |
|
| 56 | -+ | ||
| 414 | +! | +
+ env = list(+ |
+ |
| 415 | +! | +
+ calculate_outliers = if (method == "IQR") {
+ |
+ |
| 416 | +! | +
+ substitute(+ |
+ |
| 417 | +! | +
+ expr = dplyr::mutate(is_outlier_selected = {
+ |
+ |
| 418 | +! |
- #' )+ q1_q3 <- stats::quantile(outlier_var_name, probs = c(0.25, 0.75)) |
|
| 57 | -+ | ||
| 419 | +! |
- #' ),+ iqr <- q1_q3[2] - q1_q3[1] |
|
| 58 | -+ | ||
| 420 | +! |
- #' ggplot2_args = list(+ !(outlier_var_name >= q1_q3[1] - outlier_definition_param * iqr & |
|
| 59 | -+ | ||
| 421 | +! |
- #' teal.widgets::ggplot2_args(+ outlier_var_name <= q1_q3[2] + outlier_definition_param * iqr) |
|
| 60 | +422 |
- #' labs = list(subtitle = "Plot generated by Outliers Module")+ }), |
|
| 61 | -+ | ||
| 423 | +! |
- #' )+ env = list( |
|
| 62 | -+ | ||
| 424 | +! |
- #' )+ outlier_var_name = as.name(outlier_var), |
|
| 63 | -+ | ||
| 425 | +! |
- #' )+ outlier_definition_param = outlier_definition_param |
|
| 64 | +426 |
- #' )+ ) |
|
| 65 | +427 |
- #' )+ ) |
|
| 66 | -+ | ||
| 428 | +! |
- #' if (interactive()) {
+ } else if (method == "Z-score") {
|
|
| 67 | -+ | ||
| 429 | +! |
- #' shinyApp(app$ui, app$server)+ substitute( |
|
| 68 | -+ | ||
| 430 | +! |
- #' }+ expr = dplyr::mutate( |
|
| 69 | -+ | ||
| 431 | +! |
- tm_outliers <- function(label = "Outliers Module",+ is_outlier_selected = abs(outlier_var_name - mean(outlier_var_name)) / |
|
| 70 | -+ | ||
| 432 | +! |
- outlier_var,+ stats::sd(outlier_var_name) > outlier_definition_param |
|
| 71 | +433 |
- categorical_var = NULL,+ ), |
|
| 72 | -+ | ||
| 434 | +! |
- ggtheme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void"),
+ env = list( |
|
| 73 | -+ | ||
| 435 | +! |
- ggplot2_args = teal.widgets::ggplot2_args(),+ outlier_var_name = as.name(outlier_var), |
|
| 74 | -+ | ||
| 436 | +! |
- plot_height = c(600, 200, 2000),+ outlier_definition_param = outlier_definition_param |
|
| 75 | +437 |
- plot_width = NULL,+ ) |
|
| 76 | +438 |
- pre_output = NULL,+ ) |
|
| 77 | -+ | ||
| 439 | +! |
- post_output = NULL) {
+ } else if (method == "Percentile") {
|
|
| 78 | +440 | ! |
- logger::log_info("Initializing tm_outliers")
+ substitute( |
| 79 | +441 | ! |
- if (inherits(outlier_var, "data_extract_spec")) outlier_var <- list(outlier_var)+ expr = dplyr::mutate( |
| 80 | +442 | ! |
- if (inherits(categorical_var, "data_extract_spec")) categorical_var <- list(categorical_var)+ is_outlier_selected = outlier_var_name < stats::quantile(outlier_var_name, outlier_definition_param) | |
| 81 | +443 | ! |
- if (inherits(ggplot2_args, "ggplot2_args")) ggplot2_args <- list(default = ggplot2_args)+ outlier_var_name > stats::quantile(outlier_var_name, 1 - outlier_definition_param) |
| 82 | +444 |
-
+ ), |
|
| 83 | +445 | ! |
- ggtheme <- match.arg(ggtheme)+ env = list( |
| 84 | +446 | ! |
- checkmate::assert_string(label)+ outlier_var_name = as.name(outlier_var), |
| 85 | +447 | ! |
- checkmate::assert_list(outlier_var, types = "data_extract_spec")+ outlier_definition_param = outlier_definition_param+ |
+
| 448 | ++ |
+ )+ |
+ |
| 449 | ++ |
+ )+ |
+ |
| 450 | ++ |
+ }, |
|
| 86 | +451 | ! |
- checkmate::assert_list(categorical_var, types = "data_extract_spec", null.ok = TRUE)+ outlier_var_name = as.name(outlier_var), |
| 87 | +452 | ! |
- if (is.list(categorical_var)) {
+ group_expr = if (isTRUE(split_outliers) && length(categorical_var) != 0) {
|
| 88 | +453 | ! |
- lapply(categorical_var, function(x) {
+ substitute(dplyr::group_by(x), list(x = as.name(categorical_var)))+ |
+
| 454 | ++ |
+ }, |
|
| 89 | +455 | ! |
- if (length(x$filter) > 1L) {
+ ungroup_expr = if (isTRUE(split_outliers) && length(categorical_var) != 0) {
|
| 90 | +456 | ! |
- stop("tm_outliers: categorical_var data_extract_specs may only specify one filter_spec", call. = FALSE)
+ substitute(dplyr::ungroup()) |
| 91 | +457 |
- }+ } |
|
| 92 | +458 |
- })+ ) |
|
| 93 | +459 |
- }- |
- |
| 94 | -! | -
- plot_choices <- c("Boxplot", "Density Plot", "Cumulative Distribution Plot")
+ ) %>% |
|
| 95 | +460 | ! |
- checkmate::assert_list(ggplot2_args, types = "ggplot2_args")+ remove_pipe_null() |
| 96 | -! | +||
| 461 | +
- checkmate::assert_subset(names(ggplot2_args), c("default", plot_choices))
+ ) |
||
| 97 | +462 | ||
| 98 | -! | -
- args <- as.list(environment())- |
- |
| 99 | +463 |
-
+ # ANL_OUTLIER_EXTENDED is the base table |
|
| 100 | +464 | ! |
- data_extract_list <- list(+ qenv <- teal.code::eval_code( |
| 101 | +465 | ! |
- outlier_var = outlier_var,+ qenv, |
| 102 | +466 | ! |
- categorical_var = categorical_var+ substitute( |
| 103 | -+ | ||
| 467 | +! |
- )+ expr = {
|
|
| 104 | -+ | ||
| 468 | +! |
-
+ ANL_OUTLIER_EXTENDED <- dplyr::left_join( # nolint: object_name. |
|
| 105 | +469 | ! |
- module(+ ANL_OUTLIER, |
| 106 | +470 | ! |
- label = label,+ dplyr::select( |
| 107 | +471 | ! |
- server = srv_outliers,+ dataname, |
| 108 | +472 | ! |
- server_args = c(+ dplyr::setdiff(names(dataname), dplyr::setdiff(names(ANL_OUTLIER), join_keys)) |
| 109 | -! | +||
| 473 | +
- data_extract_list,+ ), |
||
| 110 | +474 | ! |
- list(plot_height = plot_height, plot_width = plot_width, ggplot2_args = ggplot2_args)+ by = join_keys |
| 111 | +475 |
- ),+ )+ |
+ |
| 476 | ++ |
+ }, |
|
| 112 | +477 | ! |
- ui = ui_outliers,+ env = list( |
| 113 | +478 | ! |
- ui_args = args,+ dataname = as.name(dataname_first), |
| 114 | +479 | ! |
- datanames = teal.transform::get_extract_datanames(data_extract_list)+ join_keys = as.character(teal.data::join_keys(data())[dataname_first, dataname_first]) |
| 115 | +480 |
- )+ ) |
|
| 116 | +481 |
- }+ ) |
|
| 117 | +482 |
-
+ ) |
|
| 118 | +483 |
- ui_outliers <- function(id, ...) {
+
|
|
| 119 | +484 | ! |
- args <- list(...)+ if (length(categorical_var) > 0) {
|
| 120 | +485 | ! |
- ns <- NS(id)+ qenv <- teal.code::eval_code( |
| 121 | +486 | ! |
- is_single_dataset_value <- teal.transform::is_single_dataset(args$outlier_var, args$categorical_var)+ qenv, |
| 122 | -+ | ||
| 487 | +! |
-
+ substitute( |
|
| 123 | +488 | ! |
- teal.widgets::standard_layout(+ expr = summary_table_pre <- ANL_OUTLIER %>% |
| 124 | +489 | ! |
- output = teal.widgets::white_small_well(+ dplyr::filter(is_outlier_selected) %>% |
| 125 | +490 | ! |
- uiOutput(ns("total_outliers")),
+ dplyr::select(outlier_var_name, categorical_var_name) %>% |
| 126 | +491 | ! |
- DT::dataTableOutput(ns("summary_table")),
+ dplyr::group_by(categorical_var_name) %>% |
| 127 | +492 | ! |
- uiOutput(ns("total_missing")),
+ dplyr::summarise(n_outliers = dplyr::n()) %>% |
| 128 | +493 | ! |
- br(), hr(),+ dplyr::right_join( |
| 129 | +494 | ! |
- tabsetPanel(+ ANL %>% |
| 130 | +495 | ! |
- id = ns("tabs"),
+ dplyr::select(outlier_var_name, categorical_var_name) %>% |
| 131 | +496 | ! |
- tabPanel(+ dplyr::group_by(categorical_var_name) %>% |
| 132 | +497 | ! |
- "Boxplot",+ dplyr::summarise( |
| 133 | +498 | ! |
- teal.widgets::plot_with_settings_ui(id = ns("box_plot"))
+ total_in_cat = dplyr::n(),+ |
+
| 499 | +! | +
+ n_na = sum(is.na(outlier_var_name) | is.na(categorical_var_name)) |
|
| 134 | +500 |
- ),+ ), |
|
| 135 | +501 | ! |
- tabPanel(+ by = categorical_var+ |
+
| 502 | ++ |
+ ) %>%+ |
+ |
| 503 | ++ |
+ # This is important as there may be categorical variables with natural orderings, e.g. AGE.+ |
+ |
| 504 | ++ |
+ # The plots should be displayed by default in increasing order in these situations.+ |
+ |
| 505 | ++ |
+ # dplyr::arrange will sort integer, factor, and character data types in the expected way. |
|
| 136 | +506 | ! |
- "Density Plot",+ dplyr::arrange(categorical_var_name) %>% |
| 137 | +507 | ! |
- teal.widgets::plot_with_settings_ui(id = ns("density_plot"))
+ dplyr::mutate( |
| 138 | -+ | ||
| 508 | +! |
- ),+ n_outliers = dplyr::if_else(is.na(n_outliers), 0, as.numeric(n_outliers)), |
|
| 139 | +509 | ! |
- tabPanel(+ display_str = dplyr::if_else( |
| 140 | +510 | ! |
- "Cumulative Distribution Plot",+ n_outliers > 0, |
| 141 | +511 | ! |
- teal.widgets::plot_with_settings_ui(id = ns("cum_density_plot"))
+ sprintf("%d [%.02f%%]", n_outliers, 100 * n_outliers / total_in_cat),
|
| 142 | -+ | ||
| 512 | +! |
- )+ "0" |
|
| 143 | +513 |
- ),+ ), |
|
| 144 | +514 | ! |
- br(), hr(),+ display_str_na = dplyr::if_else( |
| 145 | +515 | ! |
- uiOutput(ns("table_ui_wrap"))
+ n_na > 0, |
| 146 | -+ | ||
| 516 | +! |
- ),+ sprintf("%d [%.02f%%]", n_na, 100 * n_na / total_in_cat),
|
|
| 147 | +517 | ! |
- encoding = div(+ "0" |
| 148 | +518 |
- ### Reporter+ ), |
|
| 149 | +519 | ! |
- teal.reporter::simple_reporter_ui(ns("simple_reporter")),
+ order = seq_along(n_outliers) |
| 150 | +520 |
- ###+ ), |
|
| 151 | +521 | ! |
- tags$label("Encodings", class = "text-primary"),
+ env = list( |
| 152 | +522 | ! |
- teal.transform::datanames_input(args[c("outlier_var", "categorical_var")]),
+ categorical_var = categorical_var, |
| 153 | +523 | ! |
- teal.transform::data_extract_ui(+ categorical_var_name = as.name(categorical_var), |
| 154 | +524 | ! |
- id = ns("outlier_var"),
+ outlier_var_name = as.name(outlier_var) |
| 155 | -! | +||
| 525 | +
- label = "Variable",+ ) |
||
| 156 | -! | +||
| 526 | +
- data_extract_spec = args$outlier_var,+ ) |
||
| 157 | -! | +||
| 527 | +
- is_single_dataset = is_single_dataset_value+ ) |
||
| 158 | +528 |
- ),+ # now to handle when user chooses to order based on amount of outliers |
|
| 159 | +529 | ! |
- if (!is.null(args$categorical_var)) {
+ if (order_by_outlier) {
|
| 160 | +530 | ! |
- teal.transform::data_extract_ui(+ qenv <- teal.code::eval_code( |
| 161 | +531 | ! |
- id = ns("categorical_var"),
+ qenv, |
| 162 | +532 | ! |
- label = "Categorical factor",+ quote( |
| 163 | +533 | ! |
- data_extract_spec = args$categorical_var,+ summary_table_pre <- summary_table_pre %>% |
| 164 | +534 | ! |
- is_single_dataset = is_single_dataset_value+ dplyr::arrange(desc(n_outliers / total_in_cat)) %>% |
| 165 | -+ | ||
| 535 | +! |
- )+ dplyr::mutate(order = seq_len(nrow(summary_table_pre))) |
|
| 166 | +536 |
- },+ ) |
|
| 167 | -! | +||
| 537 | +
- conditionalPanel(+ ) |
||
| 168 | -! | +||
| 538 | +
- condition = paste0("input['", ns("tabs"), "'] == 'Boxplot'"),
+ } |
||
| 169 | -! | +||
| 539 | +
- teal.widgets::optionalSelectInput(+ |
||
| 170 | +540 | ! |
- inputId = ns("boxplot_alts"),
+ qenv <- teal.code::eval_code( |
| 171 | +541 | ! |
- label = "Plot type",+ qenv, |
| 172 | +542 | ! |
- choices = c("Box plot", "Violin plot"),
+ substitute( |
| 173 | +543 | ! |
- selected = "Box plot",+ expr = {
|
| 174 | -! | +||
| 544 | +
- multiple = FALSE+ # In order for geom_rug to work properly when reordering takes place inside facet_grid, |
||
| 175 | +545 |
- )+ # all tables must have the column used for reording. |
|
| 176 | +546 |
- ),+ # In this case, the column used for reordering is `order`. |
|
| 177 | +547 | ! |
- shinyjs::hidden(checkboxInput(ns("split_outliers"), "Define outliers based on group splitting", value = FALSE)),
+ ANL_OUTLIER <- dplyr::left_join( # nolint: object_name. |
| 178 | +548 | ! |
- shinyjs::hidden(checkboxInput(ns("order_by_outlier"), "Re-order categories by outliers [by %]", value = FALSE)),
+ ANL_OUTLIER, |
| 179 | +549 | ! |
- teal.widgets::panel_group(+ summary_table_pre[, c("order", categorical_var)],
|
| 180 | +550 | ! |
- teal.widgets::panel_item(+ by = categorical_var |
| 181 | -! | +||
| 551 | +
- title = "Method parameters",+ ) |
||
| 182 | -! | +||
| 552 | +
- collapsed = FALSE,+ # so that x axis of plot aligns with columns of summary table, from most outliers to least by percentage |
||
| 183 | +553 | ! |
- teal.widgets::optionalSelectInput(+ ANL <- ANL %>% # nolint: object_name. |
| 184 | +554 | ! |
- inputId = ns("method"),
+ dplyr::left_join( |
| 185 | +555 | ! |
- label = "Method",+ dplyr::select(summary_table_pre, categorical_var_name, order), |
| 186 | +556 | ! |
- choices = c("IQR", "Z-score", "Percentile"),
+ by = categorical_var+ |
+
| 557 | ++ |
+ ) %>% |
|
| 187 | +558 | ! |
- selected = "IQR",+ dplyr::arrange(order) |
| 188 | +559 | ! |
- multiple = FALSE+ summary_table <- summary_table_pre %>% |
| 189 | -+ | ||
| 560 | +! |
- ),+ dplyr::select( |
|
| 190 | +561 | ! |
- conditionalPanel(+ categorical_var_name, |
| 191 | +562 | ! |
- condition =+ Outliers = display_str, Missings = display_str_na, Total = total_in_cat+ |
+
| 563 | ++ |
+ ) %>% |
|
| 192 | +564 | ! |
- paste0("input['", ns("method"), "'] == 'IQR'"),
+ dplyr::mutate_all(as.character) %>% |
| 193 | +565 | ! |
- sliderInput(+ tidyr::pivot_longer(-categorical_var_name) %>% |
| 194 | +566 | ! |
- ns("iqr_slider"),
+ tidyr::pivot_wider(names_from = categorical_var, values_from = value) %>% |
| 195 | +567 | ! |
- "Outlier range:",+ tibble::column_to_rownames("name")
|
| 196 | +568 | ! |
- min = 1,+ summary_table+ |
+
| 569 | ++ |
+ }, |
|
| 197 | +570 | ! |
- max = 5,+ env = list( |
| 198 | +571 | ! |
- value = 3,+ categorical_var = categorical_var, |
| 199 | +572 | ! |
- step = 0.5+ categorical_var_name = as.name(categorical_var) |
| 200 | +573 |
) |
|
| 201 | +574 |
- ),+ ) |
|
| 202 | -! | +||
| 575 | +
- conditionalPanel(+ ) |
||
| 203 | -! | +||
| 576 | +
- condition =+ } |
||
| 204 | -! | +||
| 577 | +
- paste0("input['", ns("method"), "'] == 'Z-score'"),
+
|
||
| 205 | +578 | ! |
- sliderInput(+ if (length(categorical_var) > 0 && nrow(qenv[["ANL_OUTLIER"]]) > 0) {
|
| 206 | +579 | ! |
- ns("zscore_slider"),
+ shinyjs::show("order_by_outlier")
|
| 207 | -! | +||
| 580 | +
- "Outlier range:",+ } else {
|
||
| 208 | +581 | ! |
- min = 1,+ shinyjs::hide("order_by_outlier")
|
| 209 | -! | +||
| 582 | +
- max = 5,+ } |
||
| 210 | -! | +||
| 583 | +
- value = 3,+ |
||
| 211 | +584 | ! |
- step = 0.5+ qenv |
| 212 | +585 |
- )+ }) |
|
| 213 | +586 |
- ),+ |
|
| 214 | +587 | ! |
- conditionalPanel(+ output$summary_table <- DT::renderDataTable( |
| 215 | +588 | ! |
- condition =+ expr = {
|
| 216 | +589 | ! |
- paste0("input['", ns("method"), "'] == 'Percentile'"),
+ if (iv_r()$is_valid()) {
|
| 217 | +590 | ! |
- sliderInput(+ categorical_var <- as.vector(merged$anl_input_r()$columns_source$categorical_var) |
| 218 | +591 | ! |
- ns("percentile_slider"),
+ if (!is.null(categorical_var)) {
|
| 219 | +592 | ! |
- "Outlier range:",+ DT::datatable( |
| 220 | +593 | ! |
- min = 0.001,+ common_code_q()[["summary_table"]], |
| 221 | +594 | ! |
- max = 0.5,+ options = list( |
| 222 | +595 | ! |
- value = 0.01,+ dom = "t", |
| 223 | +596 | ! |
- step = 0.001+ autoWidth = TRUE,+ |
+
| 597 | +! | +
+ columnDefs = list(list(width = "200px", targets = "_all")) |
|
| 224 | +598 | ++ |
+ )+ |
+
| 599 |
) |
||
| 225 | +600 |
- ),+ } |
|
| 226 | -! | +||
| 601 | +
- uiOutput(ns("ui_outlier_help"))
+ } |
||
| 227 | +602 |
- )+ } |
|
| 228 | +603 |
- ),+ ) |
|
| 229 | -! | +||
| 604 | +
- teal.widgets::panel_item(+ |
||
| 230 | -! | +||
| 605 | +
- title = "Plot settings",+ # boxplot/violinplot # nolint commented_code |
||
| 231 | +606 | ! |
- selectInput(+ boxplot_q <- reactive({
|
| 232 | +607 | ! |
- inputId = ns("ggtheme"),
+ req(common_code_q()) |
| 233 | +608 | ! |
- label = "Theme (by ggplot):",+ ANL <- common_code_q()[["ANL"]] # nolint: object_name. |
| 234 | +609 | ! |
- choices = ggplot_themes,+ ANL_OUTLIER <- common_code_q()[["ANL_OUTLIER"]] # nolint: object_name.+ |
+
| 610 | ++ | + | |
| 235 | +611 | ! |
- selected = args$ggtheme,+ outlier_var <- as.vector(merged$anl_input_r()$columns_source$outlier_var) |
| 236 | +612 | ! |
- multiple = FALSE+ categorical_var <- as.vector(merged$anl_input_r()$columns_source$categorical_var) |
| 237 | +613 |
- )+ |
|
| 238 | +614 |
- )+ # validation+ |
+ |
| 615 | +! | +
+ teal::validate_has_data(ANL, 1) |
|
| 239 | +616 | ++ | + + | +
| 617 |
- ),+ # boxplot |
||
| 240 | +618 | ! |
- forms = tagList(+ plot_call <- quote(ANL %>% ggplot()) |
| 241 | -! | +||
| 619 | +
- teal.widgets::verbatim_popup_ui(ns("warning"), "Show Warnings"),
+
|
||
| 242 | +620 | ! |
- teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code")
- |
-
| 243 | -- |
- ),+ plot_call <- if (input$boxplot_alts == "Box plot") {
|
|
| 244 | +621 | ! |
- pre_output = args$pre_output,+ substitute(expr = plot_call + geom_boxplot(outlier.shape = NA), env = list(plot_call = plot_call)) |
| 245 | +622 | ! |
- post_output = args$post_output+ } else if (input$boxplot_alts == "Violin plot") {
|
| 246 | -+ | ||
| 623 | +! |
- )+ substitute(expr = plot_call + geom_violin(), env = list(plot_call = plot_call)) |
|
| 247 | +624 |
- }+ } else {
|
|
| 248 | -+ | ||
| 625 | +! |
-
+ NULL |
|
| 249 | +626 |
- srv_outliers <- function(id, data, reporter, filter_panel_api, outlier_var,+ } |
|
| 250 | +627 |
- categorical_var, plot_height, plot_width, ggplot2_args) {
+
|
|
| 251 | +628 | ! |
- with_reporter <- !missing(reporter) && inherits(reporter, "Reporter")+ plot_call <- if (identical(categorical_var, character(0)) || is.null(categorical_var)) {
|
| 252 | +629 | ! |
- with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI")+ inner_call <- substitute( |
| 253 | +630 | ! |
- checkmate::assert_class(data, "reactive")+ expr = plot_call + |
| 254 | +631 | ! |
- checkmate::assert_class(isolate(data()), "teal_data")+ aes(x = "Entire dataset", y = outlier_var_name) + |
| 255 | +632 | ! |
- moduleServer(id, function(input, output, session) {
+ scale_x_discrete(), |
| 256 | +633 | ! |
- vars <- list(outlier_var = outlier_var, categorical_var = categorical_var)+ env = list(plot_call = plot_call, outlier_var_name = as.name(outlier_var)) |
| 257 | +634 |
-
+ ) |
|
| 258 | +635 | ! |
- rule_diff <- function(other) {
+ if (nrow(ANL_OUTLIER) > 0) {
|
| 259 | +636 | ! |
- function(value) {
+ substitute( |
| 260 | +637 | ! |
- othervalue <- tryCatch(selector_list()[[other]]()[["select"]], error = function(e) NULL)+ expr = inner_call + geom_point( |
| 261 | +638 | ! |
- if (!is.null(othervalue) && identical(othervalue, value)) {
+ data = ANL_OUTLIER, |
| 262 | +639 | ! |
- "`Variable` and `Categorical factor` cannot be the same"+ aes(x = "Entire dataset", y = outlier_var_name, color = is_outlier_selected) |
| 263 | +640 |
- }+ ), |
|
| 264 | -+ | ||
| 641 | +! |
- }+ env = list(inner_call = inner_call, outlier_var_name = as.name(outlier_var)) |
|
| 265 | +642 |
- }+ ) |
|
| 266 | +643 |
-
+ } else {
|
|
| 267 | +644 | ! |
- selector_list <- teal.transform::data_extract_multiple_srv(+ inner_call |
| 268 | -! | +||
| 645 | +
- data_extract = vars,+ } |
||
| 269 | -! | +||
| 646 | +
- datasets = data,+ } else {
|
||
| 270 | +647 | ! |
- select_validation_rule = list(+ substitute( |
| 271 | +648 | ! |
- outlier_var = shinyvalidate::compose_rules(+ expr = plot_call + |
| 272 | +649 | ! |
- shinyvalidate::sv_required("Please select a variable"),
+ aes(y = outlier_var_name, x = reorder(categorical_var_name, order)) + |
| 273 | +650 | ! |
- rule_diff("categorical_var")
+ xlab(categorical_var) + |
| 274 | -+ | ||
| 651 | +! |
- ),+ scale_x_discrete() + |
|
| 275 | +652 | ! |
- categorical_var = rule_diff("outlier_var")
+ geom_point( |
| 276 | -+ | ||
| 653 | +! |
- )+ data = ANL_OUTLIER, |
|
| 277 | -+ | ||
| 654 | +! |
- )+ aes(x = as.factor(categorical_var_name), y = outlier_var_name, color = is_outlier_selected) |
|
| 278 | +655 |
-
+ ), |
|
| 279 | +656 | ! |
- iv_r <- reactive({
+ env = list( |
| 280 | +657 | ! |
- iv <- shinyvalidate::InputValidator$new()+ plot_call = plot_call, |
| 281 | +658 | ! |
- iv$add_rule("method", shinyvalidate::sv_required("Please select a method"))
+ outlier_var_name = as.name(outlier_var), |
| 282 | +659 | ! |
- iv$add_rule("boxplot_alts", shinyvalidate::sv_required("Please select Plot Type"))
+ categorical_var_name = as.name(categorical_var), |
| 283 | +660 | ! |
- teal.transform::compose_and_enable_validators(iv, selector_list)+ categorical_var = categorical_var |
| 284 | +661 |
- })+ ) |
|
| 285 | +662 |
-
+ ) |
|
| 286 | -! | +||
| 663 | +
- reactive_select_input <- reactive({
+ } |
||
| 287 | -! | +||
| 664 | +
- if (is.null(selector_list()$categorical_var) || length(selector_list()$categorical_var()$select) == 0) {
+
|
||
| 288 | +665 | ! |
- selector_list()[names(selector_list()) != "categorical_var"]- |
-
| 289 | -- |
- } else {
+ dev_ggplot2_args <- teal.widgets::ggplot2_args( |
|
| 290 | +666 | ! |
- selector_list()+ labs = list(color = "Is outlier?"), |
| 291 | -+ | ||
| 667 | +! |
- }+ theme = list(legend.position = "top") |
|
| 292 | +668 |
- })+ ) |
|
| 293 | +669 | ||
| 294 | +670 | ! |
- anl_merged_input <- teal.transform::merge_expression_srv(+ all_ggplot2_args <- teal.widgets::resolve_ggplot2_args( |
| 295 | +671 | ! |
- selector_list = reactive_select_input,+ user_plot = ggplot2_args[["Boxplot"]], |
| 296 | +672 | ! |
- datasets = data,+ user_default = ggplot2_args$default, |
| 297 | +673 | ! |
- merge_function = "dplyr::inner_join"+ module_plot = dev_ggplot2_args |
| 298 | +674 |
- )+ ) |
|
| 299 | +675 | ||
| 300 | -! | -
- anl_merged_q <- reactive({
- |
- |
| 301 | +676 | ! |
- req(anl_merged_input())+ parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args( |
| 302 | +677 | ! |
- data() %>%+ all_ggplot2_args, |
| 303 | +678 | ! |
- teal.code::eval_code(as.expression(anl_merged_input()$expr))+ ggtheme = input$ggtheme |
| 304 | +679 |
- })+ ) |
|
| 305 | +680 | ||
| 306 | +681 | ! |
- merged <- list(+ teal.code::eval_code( |
| 307 | +682 | ! |
- anl_input_r = anl_merged_input,+ common_code_q(), |
| 308 | +683 | ! |
- anl_q_r = anl_merged_q+ substitute( |
| 309 | -+ | ||
| 684 | +! |
- )+ expr = g <- plot_call + |
|
| 310 | -+ | ||
| 685 | +! |
-
+ scale_color_manual(values = c("TRUE" = "red", "FALSE" = "black")) +
|
|
| 311 | +686 | ! |
- n_outlier_missing <- reactive({
+ labs + ggthemes + themes, |
| 312 | +687 | ! |
- shiny::req(iv_r()$is_valid())+ env = list( |
| 313 | +688 | ! |
- outlier_var <- as.vector(merged$anl_input_r()$columns_source$outlier_var)+ plot_call = plot_call, |
| 314 | +689 | ! |
- ANL <- merged$anl_q_r()[["ANL"]] # nolint object_name_linter+ labs = parsed_ggplot2_args$labs, |
| 315 | +690 | ! |
- sum(is.na(ANL[[outlier_var]]))+ ggthemes = parsed_ggplot2_args$ggtheme,+ |
+
| 691 | +! | +
+ themes = parsed_ggplot2_args$theme |
|
| 316 | +692 |
- })+ ) |
|
| 317 | +693 |
-
+ ) |
|
| 318 | +694 |
- # Used to create outlier table and the dropdown with additional columns+ ) %>% |
|
| 319 | +695 | ! |
- dataname_first <- isolate(teal.data::datanames(data())[[1]])+ teal.code::eval_code(quote(print(g))) |
| 320 | +696 | ++ |
+ })+ |
+
| 697 | |||
| 698 | ++ |
+ # density plot+ |
+ |
| 321 | +699 | ! |
- common_code_q <- reactive({
+ density_plot_q <- reactive({
|
| 322 | +700 | ! |
- shiny::req(iv_r()$is_valid())+ ANL <- common_code_q()[["ANL"]] # nolint: object_name.+ |
+
| 701 | +! | +
+ ANL_OUTLIER <- common_code_q()[["ANL_OUTLIER"]] # nolint: object_name. |
|
| 323 | +702 | ||
| 324 | +703 | ! |
- ANL <- merged$anl_q_r()[["ANL"]] # nolint object_name_linter+ outlier_var <- as.vector(merged$anl_input_r()$columns_source$outlier_var) |
| 325 | +704 | ! |
- qenv <- merged$anl_q_r()+ categorical_var <- as.vector(merged$anl_input_r()$columns_source$categorical_var) |
| 326 | +705 | ||
| 327 | -! | +||
| 706 | +
- outlier_var <- as.vector(merged$anl_input_r()$columns_source$outlier_var)+ # validation |
||
| 328 | +707 | ! |
- categorical_var <- as.vector(merged$anl_input_r()$columns_source$categorical_var)+ teal::validate_has_data(ANL, 1) |
| 329 | -! | +||
| 708 | +
- order_by_outlier <- input$order_by_outlier+ # plot |
||
| 330 | +709 | ! |
- method <- input$method+ plot_call <- substitute( |
| 331 | +710 | ! |
- split_outliers <- input$split_outliers+ expr = ANL %>% |
| 332 | +711 | ! |
- teal::validate_has_data(- |
-
| 333 | -- |
- # missing values in the categorical variable may be used to form a category of its own+ ggplot(aes(x = outlier_var_name)) + |
|
| 334 | +712 | ! |
- `if`(+ geom_density() + |
| 335 | +713 | ! |
- length(categorical_var) == 0,+ geom_rug(data = ANL_OUTLIER, aes(x = outlier_var_name, color = is_outlier_selected)) + |
| 336 | +714 | ! |
- ANL,+ scale_color_manual(values = c("TRUE" = "red", "FALSE" = "black")),
|
| 337 | +715 | ! |
- ANL[, names(ANL) != categorical_var, drop = FALSE]+ env = list(outlier_var_name = as.name(outlier_var)) |
| 338 | +716 |
- ),+ ) |
|
| 339 | -! | +||
| 717 | +
- min_nrow = 10,+ |
||
| 340 | +718 | ! |
- complete = TRUE,+ plot_call <- if (identical(categorical_var, character(0)) || is.null(categorical_var)) {
|
| 341 | +719 | ! |
- allow_inf = FALSE+ substitute(expr = plot_call, env = list(plot_call = plot_call)) |
| 342 | +720 |
- )+ } else {
+ |
+ |
| 721 | +! | +
+ substitute( |
|
| 343 | +722 | ! |
- validate(need(is.numeric(ANL[[outlier_var]]), "`Variable` is not numeric"))+ expr = plot_call + facet_grid(~ reorder(categorical_var_name, order)), |
| 344 | +723 | ! |
- validate(need(length(unique(ANL[[outlier_var]])) > 1, "Variable has no variation, i.e. only one unique value"))+ env = list(plot_call = plot_call, categorical_var_name = as.name(categorical_var)) |
| 345 | +724 |
-
+ ) |
|
| 346 | +725 |
- # show/hide split_outliers+ } |
|
| 347 | -! | +||
| 726 | +
- if (length(categorical_var) == 0) {
+
|
||
| 348 | +727 | ! |
- shinyjs::hide("split_outliers")
+ dev_ggplot2_args <- teal.widgets::ggplot2_args( |
| 349 | +728 | ! |
- if (n_outlier_missing() > 0) {
+ labs = list(color = "Is outlier?"), |
| 350 | +729 | ! |
- qenv <- teal.code::eval_code(+ theme = list(legend.position = "top") |
| 351 | -! | +||
| 730 | +
- qenv,+ ) |
||
| 352 | -! | +||
| 731 | +
- substitute(+ |
||
| 353 | +732 | ! |
- expr = ANL <- ANL %>% dplyr::filter(!is.na(outlier_var_name)), # nolint object_name_linter+ all_ggplot2_args <- teal.widgets::resolve_ggplot2_args( |
| 354 | +733 | ! |
- env = list(outlier_var_name = as.name(outlier_var))+ user_plot = ggplot2_args[["Density Plot"]], |
| 355 | -+ | ||
| 734 | +! |
- )+ user_default = ggplot2_args$default, |
|
| 356 | -+ | ||
| 735 | +! |
- )+ module_plot = dev_ggplot2_args |
|
| 357 | +736 |
- }+ ) |
|
| 358 | +737 |
- } else {
+
|
|
| 359 | +738 | ! |
- validate(need(+ parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args( |
| 360 | +739 | ! |
- is.factor(ANL[[categorical_var]]) ||+ all_ggplot2_args, |
| 361 | +740 | ! |
- is.character(ANL[[categorical_var]]) ||+ ggtheme = input$ggtheme |
| 362 | -! | +||
| 741 | +
- is.integer(ANL[[categorical_var]]),+ )+ |
+ ||
| 742 | ++ | + | |
| 363 | +743 | ! |
- "`Categorical factor` must be `factor`, `character`, or `integer`"+ teal.code::eval_code( |
| 364 | -+ | ||
| 744 | +! |
- ))+ common_code_q(), |
|
| 365 | -+ | ||
| 745 | +! |
-
+ substitute( |
|
| 366 | +746 | ! |
- if (n_outlier_missing() > 0) {
+ expr = g <- plot_call + labs + ggthemes + themes, |
| 367 | +747 | ! |
- qenv <- teal.code::eval_code(+ env = list( |
| 368 | +748 | ! |
- qenv,+ plot_call = plot_call, |
| 369 | +749 | ! |
- substitute(+ labs = parsed_ggplot2_args$labs, |
| 370 | +750 | ! |
- expr = ANL <- ANL %>% dplyr::filter(!is.na(outlier_var_name)), # nolint object_name_linter+ themes = parsed_ggplot2_args$theme, |
| 371 | +751 | ! |
- env = list(outlier_var_name = as.name(outlier_var))+ ggthemes = parsed_ggplot2_args$ggtheme |
| 372 | +752 |
- )+ ) |
|
| 373 | +753 |
- )+ ) |
|
| 374 | +754 |
- }+ ) %>% |
|
| 375 | +755 | ! |
- shinyjs::show("split_outliers")
+ teal.code::eval_code(quote(print(g))) |
| 376 | +756 |
- }+ }) |
|
| 377 | +757 | ||
| 378 | +758 |
- # slider+ # Cumulative distribution plot |
|
| 379 | +759 | ! |
- outlier_definition_param <- if (method == "IQR") {
+ cumulative_plot_q <- reactive({
|
| 380 | +760 | ! |
- input$iqr_slider+ ANL <- common_code_q()[["ANL"]] # nolint: object_name. |
| 381 | +761 | ! |
- } else if (method == "Z-score") {
+ ANL_OUTLIER <- common_code_q()[["ANL_OUTLIER"]] # nolint: object_name. |
| 382 | -! | +||
| 762 | +
- input$zscore_slider+ |
||
| 383 | +763 | ! |
- } else if (method == "Percentile") {
+ qenv <- common_code_q()+ |
+
| 764 | ++ | + | |
| 384 | +765 | ! |
- input$percentile_slider+ outlier_var <- as.vector(merged$anl_input_r()$columns_source$outlier_var) |
| 385 | -+ | ||
| 766 | +! |
- }+ categorical_var <- as.vector(merged$anl_input_r()$columns_source$categorical_var) |
|
| 386 | +767 | ||
| 387 | +768 |
- # this is utils function that converts a %>% NULL %>% b into a %>% b+ # validation |
|
| 388 | +769 | ! |
- remove_pipe_null <- function(x) {
+ teal::validate_has_data(ANL, 1) |
| 389 | -! | +||
| 770 | +
- if (length(x) == 1) {
+
+ |
+ ||
| 771 | ++ |
+ # plot |
|
| 390 | +772 | ! |
- return(x)+ plot_call <- substitute( |
| 391 | -+ | ||
| 773 | +! |
- }+ expr = ANL %>% ggplot(aes(x = outlier_var_name)) + |
|
| 392 | +774 | ! |
- if (identical(x[[1]], as.name("%>%")) && is.null(x[[3]])) {
+ stat_ecdf(), |
| 393 | +775 | ! |
- return(remove_pipe_null(x[[2]]))+ env = list(outlier_var_name = as.name(outlier_var)) |
| 394 | +776 |
- }+ ) |
|
| 395 | +777 | ! |
- return(as.call(c(x[[1]], lapply(x[-1], remove_pipe_null))))+ if (length(categorical_var) == 0) {
|
| 396 | -+ | ||
| 778 | +! |
- }+ qenv <- teal.code::eval_code( |
|
| 397 | -+ | ||
| 779 | +! |
-
+ qenv, |
|
| 398 | +780 | ! |
- qenv <- teal.code::eval_code(+ substitute( |
| 399 | +781 | ! |
- qenv,+ expr = {
|
| 400 | +782 | ! |
- substitute(+ ecdf_df <- ANL %>% |
| 401 | +783 | ! |
- expr = {
+ dplyr::mutate( |
| 402 | +784 | ! |
- ANL_OUTLIER <- ANL %>% # nolint object_name_linter+ y = stats::ecdf(ANL[[outlier_var]])(ANL[[outlier_var]]) |
| 403 | -! | +||
| 785 | +
- group_expr %>% # styler: off+ )+ |
+ ||
| 786 | ++ | + | |
| 404 | +787 | ! |
- dplyr::mutate(is_outlier = {
+ outlier_points <- dplyr::left_join( |
| 405 | +788 | ! |
- q1_q3 <- stats::quantile(outlier_var_name, probs = c(0.25, 0.75))+ ecdf_df, |
| 406 | +789 | ! |
- iqr <- q1_q3[2] - q1_q3[1]+ ANL_OUTLIER, |
| 407 | +790 | ! |
- !(outlier_var_name >= q1_q3[1] - 1.5 * iqr & outlier_var_name <= q1_q3[2] + 1.5 * iqr)+ by = dplyr::setdiff(names(ecdf_df), "y") |
| 408 | +791 |
- }) %>%+ ) %>% |
|
| 409 | +792 | ! |
- calculate_outliers %>% # styler: off+ dplyr::filter(!is.na(is_outlier_selected)) |
| 410 | -! | +||
| 793 | +
- ungroup_expr %>% # styler: off+ }, |
||
| 411 | +794 | ! |
- dplyr::filter(is_outlier | is_outlier_selected) %>%+ env = list(outlier_var = outlier_var) |
| 412 | -! | +||
| 795 | +
- dplyr::select(-is_outlier)+ ) |
||
| 413 | +796 |
- },+ ) |
|
| 414 | -! | +||
| 797 | +
- env = list(+ } else {
|
||
| 415 | +798 | ! |
- calculate_outliers = if (method == "IQR") {
+ qenv <- teal.code::eval_code( |
| 416 | +799 | ! |
- substitute(+ qenv, |
| 417 | +800 | ! |
- expr = dplyr::mutate(is_outlier_selected = {
+ substitute( |
| 418 | +801 | ! |
- q1_q3 <- stats::quantile(outlier_var_name, probs = c(0.25, 0.75))+ expr = {
|
| 419 | +802 | ! |
- iqr <- q1_q3[2] - q1_q3[1]+ all_categories <- lapply( |
| 420 | +803 | ! |
- !(outlier_var_name >= q1_q3[1] - outlier_definition_param * iqr &+ unique(ANL[[categorical_var]]), |
| 421 | +804 | ! |
- outlier_var_name <= q1_q3[2] + outlier_definition_param * iqr)- |
-
| 422 | -- |
- }),+ function(x) {
|
|
| 423 | +805 | ! |
- env = list(+ ANL <- ANL %>% dplyr::filter(get(categorical_var) == x) # nolint: object_name. |
| 424 | +806 | ! |
- outlier_var_name = as.name(outlier_var),+ anl_outlier2 <- ANL_OUTLIER %>% dplyr::filter(get(categorical_var) == x) |
| 425 | +807 | ! |
- outlier_definition_param = outlier_definition_param+ ecdf_df <- ANL %>% |
| 426 | -+ | ||
| 808 | +! |
- )+ dplyr::mutate(y = stats::ecdf(ANL[[outlier_var]])(ANL[[outlier_var]])) |
|
| 427 | +809 |
- )- |
- |
| 428 | -! | -
- } else if (method == "Z-score") {
+
|
|
| 429 | +810 | ! |
- substitute(+ dplyr::left_join( |
| 430 | +811 | ! |
- expr = dplyr::mutate(+ ecdf_df, |
| 431 | +812 | ! |
- is_outlier_selected = abs(outlier_var_name - mean(outlier_var_name)) /+ anl_outlier2, |
| 432 | +813 | ! |
- stats::sd(outlier_var_name) > outlier_definition_param+ by = dplyr::setdiff(names(ecdf_df), "y") |
| 433 | +814 |
- ),- |
- |
| 434 | -! | -
- env = list(- |
- |
| 435 | -! | -
- outlier_var_name = as.name(outlier_var),+ ) %>% |
|
| 436 | +815 | ! |
- outlier_definition_param = outlier_definition_param+ dplyr::filter(!is.na(is_outlier_selected)) |
| 437 | +816 |
- )+ } |
|
| 438 | +817 |
) |
|
| 439 | -! | -
- } else if (method == "Percentile") {
- |
- |
| 440 | +818 | ! |
- substitute(+ outlier_points <- do.call(rbind, all_categories) |
| 441 | -! | +||
| 819 | +
- expr = dplyr::mutate(+ }, |
||
| 442 | +820 | ! |
- is_outlier_selected = outlier_var_name < stats::quantile(outlier_var_name, outlier_definition_param) |+ env = list(categorical_var = categorical_var, outlier_var = outlier_var) |
| 443 | -! | +||
| 821 | +
- outlier_var_name > stats::quantile(outlier_var_name, 1 - outlier_definition_param)+ ) |
||
| 444 | +822 |
- ),+ ) |
|
| 445 | +823 | ! |
- env = list(+ plot_call <- substitute( |
| 446 | +824 | ! |
- outlier_var_name = as.name(outlier_var),+ expr = plot_call + facet_grid(~ reorder(categorical_var_name, order)), |
| 447 | +825 | ! |
- outlier_definition_param = outlier_definition_param+ env = list(plot_call = plot_call, categorical_var_name = as.name(categorical_var)) |
| 448 | +826 |
- )+ ) |
|
| 449 | +827 |
- )+ } |
|
| 450 | +828 |
- },+ |
|
| 451 | +829 | ! |
- outlier_var_name = as.name(outlier_var),+ dev_ggplot2_args <- teal.widgets::ggplot2_args( |
| 452 | +830 | ! |
- group_expr = if (isTRUE(split_outliers) && length(categorical_var) != 0) {
+ labs = list(color = "Is outlier?"), |
| 453 | +831 | ! |
- substitute(dplyr::group_by(x), list(x = as.name(categorical_var)))+ theme = list(legend.position = "top") |
| 454 | +832 |
- },+ )+ |
+ |
| 833 | ++ | + | |
| 455 | +834 | ! |
- ungroup_expr = if (isTRUE(split_outliers) && length(categorical_var) != 0) {
+ all_ggplot2_args <- teal.widgets::resolve_ggplot2_args( |
| 456 | +835 | ! |
- substitute(dplyr::ungroup())+ user_plot = ggplot2_args[["Cumulative Distribution Plot"]], |
| 457 | -+ | ||
| 836 | +! |
- }+ user_default = ggplot2_args$default,+ |
+ |
| 837 | +! | +
+ module_plot = dev_ggplot2_args |
|
| 458 | +838 |
- )+ ) |
|
| 459 | +839 |
- ) %>%+ |
|
| 460 | +840 | ! |
- remove_pipe_null()+ parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args( |
| 461 | -+ | ||
| 841 | +! |
- )+ all_ggplot2_args,+ |
+ |
| 842 | +! | +
+ ggtheme = input$ggtheme |
|
| 462 | +843 |
-
+ ) |
|
| 463 | +844 |
- # ANL_OUTLIER_EXTENDED is the base table+ |
|
| 464 | +845 | ! |
- qenv <- teal.code::eval_code(+ teal.code::eval_code( |
| 465 | +846 | ! |
qenv, |
| 466 | +847 | ! |
substitute( |
| 467 | +848 | ! |
- expr = {
+ expr = g <- plot_call + |
| 468 | +849 | ! |
- ANL_OUTLIER_EXTENDED <- dplyr::left_join( # nolint object_name_linter+ geom_point(data = outlier_points, aes(x = outlier_var_name, y = y, color = is_outlier_selected)) + |
| 469 | +850 | ! |
- ANL_OUTLIER,+ scale_color_manual(values = c("TRUE" = "red", "FALSE" = "black")) +
|
| 470 | +851 | ! |
- dplyr::select(+ labs + ggthemes + themes, |
| 471 | +852 | ! |
- dataname,+ env = list( |
| 472 | +853 | ! |
- dplyr::setdiff(names(dataname), dplyr::setdiff(names(ANL_OUTLIER), join_keys))- |
-
| 473 | -- |
- ),+ plot_call = plot_call, |
|
| 474 | +854 | ! |
- by = join_keys- |
-
| 475 | -- |
- )- |
- |
| 476 | -- |
- },+ outlier_var_name = as.name(outlier_var), |
|
| 477 | +855 | ! |
- env = list(+ labs = parsed_ggplot2_args$labs, |
| 478 | +856 | ! |
- dataname = as.name(dataname_first),+ themes = parsed_ggplot2_args$theme, |
| 479 | +857 | ! |
- join_keys = as.character(teal.data::join_keys(data())[dataname_first, dataname_first])+ ggthemes = parsed_ggplot2_args$ggtheme |
| 480 | +858 |
) |
|
| 481 | +859 |
) |
|
| 482 | +860 |
- )+ ) %>%+ |
+ |
| 861 | +! | +
+ teal.code::eval_code(quote(print(g))) |
|
| 483 | +862 | ++ |
+ })+ |
+
| 863 | |||
| 484 | +864 | ! |
- if (length(categorical_var) > 0) {
+ final_q <- reactive({
|
| 485 | +865 | ! |
- qenv <- teal.code::eval_code(+ req(input$tabs) |
| 486 | +866 | ! |
- qenv,+ tab_type <- input$tabs |
| 487 | +867 | ! |
- substitute(+ result_q <- if (tab_type == "Boxplot") {
|
| 488 | +868 | ! |
- expr = summary_table_pre <- ANL_OUTLIER %>%+ boxplot_q() |
| 489 | +869 | ! |
- dplyr::filter(is_outlier_selected) %>%+ } else if (tab_type == "Density Plot") {
|
| 490 | +870 | ! |
- dplyr::select(outlier_var_name, categorical_var_name) %>%+ density_plot_q() |
| 491 | +871 | ! |
- dplyr::group_by(categorical_var_name) %>%+ } else if (tab_type == "Cumulative Distribution Plot") {
|
| 492 | +872 | ! |
- dplyr::summarise(n_outliers = dplyr::n()) %>%+ cumulative_plot_q()+ |
+
| 873 | ++ |
+ }+ |
+ |
| 874 | ++ |
+ # used to display table when running show-r-code code+ |
+ |
| 875 | ++ |
+ # added after the plots so that a change in selected columns doesn't affect+ |
+ |
| 876 | ++ |
+ # brush selection. |
|
| 493 | +877 | ! |
- dplyr::right_join(+ teal.code::eval_code( |
| 494 | +878 | ! |
- ANL %>%+ result_q, |
| 495 | +879 | ! |
- dplyr::select(outlier_var_name, categorical_var_name) %>%+ substitute( |
| 496 | +880 | ! |
- dplyr::group_by(categorical_var_name) %>%+ expr = {
|
| 497 | +881 | ! |
- dplyr::summarise(+ columns_index <- union( |
| 498 | +882 | ! |
- total_in_cat = dplyr::n(),+ setdiff(names(ANL_OUTLIER), "is_outlier_selected"), |
| 499 | +883 | ! |
- n_na = sum(is.na(outlier_var_name) | is.na(categorical_var_name))+ table_columns |
| 500 | +884 |
- ),+ ) |
|
| 501 | +885 | ! |
- by = categorical_var+ ANL_OUTLIER_EXTENDED[ANL_OUTLIER_EXTENDED$is_outlier_selected, columns_index] |
| 502 | +886 |
- ) %>%+ },+ |
+ |
| 887 | +! | +
+ env = list(+ |
+ |
| 888 | +! | +
+ table_columns = input$table_ui_columns |
|
| 503 | +889 |
- # This is important as there may be categorical variables with natural orderings, e.g. AGE.+ ) |
|
| 504 | +890 |
- # The plots should be displayed by default in increasing order in these situations.+ ) |
|
| 505 | +891 |
- # dplyr::arrange will sort integer, factor, and character data types in the expected way.+ ) |
|
| 506 | -! | +||
| 892 | +
- dplyr::arrange(categorical_var_name) %>%+ }) |
||
| 507 | -! | +||
| 893 | +
- dplyr::mutate(+ |
||
| 508 | -! | +||
| 894 | +
- n_outliers = dplyr::if_else(is.na(n_outliers), 0, as.numeric(n_outliers)),+ # slider text |
||
| 509 | +895 | ! |
- display_str = dplyr::if_else(+ output$ui_outlier_help <- renderUI({
|
| 510 | +896 | ! |
- n_outliers > 0,+ req(input$method) |
| 511 | +897 | ! |
- sprintf("%d [%.02f%%]", n_outliers, 100 * n_outliers / total_in_cat),
+ if (input$method == "IQR") {
|
| 512 | +898 | ! |
- "0"- |
-
| 513 | -- |
- ),+ req(input$iqr_slider) |
|
| 514 | +899 | ! |
- display_str_na = dplyr::if_else(+ tags$small( |
| 515 | +900 | ! |
- n_na > 0,+ withMathJax( |
| 516 | +901 | ! |
- sprintf("%d [%.02f%%]", n_na, 100 * n_na / total_in_cat),
+ helpText( |
| 517 | +902 | ! |
- "0"- |
-
| 518 | -- |
- ),+ "Outlier data points (\\(x \\lt Q1 - ", input$iqr_slider, "\\times IQR\\) or \\( |
|
| 519 | +903 | ! |
- order = seq_along(n_outliers)- |
-
| 520 | -- |
- ),+ Q3 + ", input$iqr_slider, "\\times IQR \\lt x\\)) |
|
| 521 | +904 | ! |
- env = list(+ are displayed in red on the plot and can be visualized in the table below." |
| 522 | -! | +||
| 905 | +
- categorical_var = categorical_var,+ ), |
||
| 523 | +906 | ! |
- categorical_var_name = as.name(categorical_var),+ if (input$split_outliers) {
|
| 524 | +907 | ! |
- outlier_var_name = as.name(outlier_var)+ withMathJax(helpText("Note: Quantiles are calculated per group."))
|
| 525 | +908 |
- )+ } |
|
| 526 | +909 |
) |
|
| 527 | +910 |
) |
|
| 528 | -+ | ||
| 911 | +! |
- # now to handle when user chooses to order based on amount of outliers+ } else if (input$method == "Z-score") {
|
|
| 529 | +912 | ! |
- if (order_by_outlier) {
+ req(input$zscore_slider) |
| 530 | +913 | ! |
- qenv <- teal.code::eval_code(+ tags$small( |
| 531 | +914 | ! |
- qenv,+ withMathJax( |
| 532 | +915 | ! |
- quote(+ helpText( |
| 533 | +916 | ! |
- summary_table_pre <- summary_table_pre %>%+ "Outlier data points (\\(Zscore(x) < -", input$zscore_slider, |
| 534 | +917 | ! |
- dplyr::arrange(desc(n_outliers / total_in_cat)) %>%+ "\\) or \\(", input$zscore_slider, "< Zscore(x) \\))
|
| 535 | +918 | ! |
- dplyr::mutate(order = seq_len(nrow(summary_table_pre)))+ are displayed in red on the plot and can be visualized in the table below." |
| 536 | +919 |
- )+ ),+ |
+ |
| 920 | +! | +
+ if (input$split_outliers) {
+ |
+ |
| 921 | +! | +
+ withMathJax(helpText(" Note: Z-scores are calculated per group."))
|
|
| 537 | +922 | ++ |
+ }+ |
+
| 923 |
) |
||
| 538 | +924 |
- }+ ) |
|
| 539 | -+ | ||
| 925 | +! |
-
+ } else if (input$method == "Percentile") {
|
|
| 540 | +926 | ! |
- qenv <- teal.code::eval_code(+ req(input$percentile_slider) |
| 541 | +927 | ! |
- qenv,+ tags$small( |
| 542 | +928 | ! |
- substitute(+ withMathJax( |
| 543 | +929 | ! |
- expr = {
+ helpText( |
| 544 | -+ | ||
| 930 | +! |
- # In order for geom_rug to work properly when reordering takes place inside facet_grid,+ "Outlier/extreme data points (\\( Percentile(x) <", input$percentile_slider, |
|
| 545 | -+ | ||
| 931 | +! |
- # all tables must have the column used for reording.+ "\\) or \\(", 1 - input$percentile_slider, " < Percentile(x) \\))
+ |
+ |
| 932 | +! | +
+ are displayed in red on the plot and can be visualized in the table below." |
|
| 546 | +933 |
- # In this case, the column used for reordering is `order`.+ ), |
|
| 547 | +934 | ! |
- ANL_OUTLIER <- dplyr::left_join( # nolint object_name_linter+ if (input$split_outliers) {
|
| 548 | +935 | ! |
- ANL_OUTLIER,+ withMathJax(helpText("Note: Percentiles are calculated per group."))
|
| 549 | -! | +||
| 936 | +
- summary_table_pre[, c("order", categorical_var)],
+ } |
||
| 550 | -! | +||
| 937 | +
- by = categorical_var+ ) |
||
| 551 | +938 |
- )+ ) |
|
| 552 | +939 |
- # so that x axis of plot aligns with columns of summary table, from most outliers to least by percentage+ } |
|
| 553 | -! | +||
| 940 | +
- ANL <- ANL %>% # nolint object_name_linter+ }) |
||
| 554 | -! | +||
| 941 | +
- dplyr::left_join(+ |
||
| 555 | +942 | ! |
- dplyr::select(summary_table_pre, categorical_var_name, order),+ boxplot_r <- reactive({
|
| 556 | +943 | ! |
- by = categorical_var- |
-
| 557 | -- |
- ) %>%+ teal::validate_inputs(iv_r()) |
|
| 558 | +944 | ! |
- dplyr::arrange(order)+ boxplot_q()[["g"]] |
| 559 | -! | +||
| 945 | +
- summary_table <- summary_table_pre %>%+ }) |
||
| 560 | +946 | ! |
- dplyr::select(+ density_plot_r <- reactive({
|
| 561 | +947 | ! |
- categorical_var_name,+ teal::validate_inputs(iv_r()) |
| 562 | +948 | ! |
- Outliers = display_str, Missings = display_str_na, Total = total_in_cat+ density_plot_q()[["g"]] |
| 563 | +949 |
- ) %>%- |
- |
| 564 | -! | -
- dplyr::mutate_all(as.character) %>%+ }) |
|
| 565 | +950 | ! |
- tidyr::pivot_longer(-categorical_var_name) %>%+ cumulative_plot_r <- reactive({
|
| 566 | +951 | ! |
- tidyr::pivot_wider(names_from = categorical_var, values_from = value) %>%+ teal::validate_inputs(iv_r()) |
| 567 | +952 | ! |
- tibble::column_to_rownames("name")
+ cumulative_plot_q()[["g"]] |
| 568 | -! | +||
| 953 | +
- summary_table+ }) |
||
| 569 | +954 |
- },+ |
|
| 570 | +955 | ! |
- env = list(+ box_pws <- teal.widgets::plot_with_settings_srv( |
| 571 | +956 | ! |
- categorical_var = categorical_var,+ id = "box_plot", |
| 572 | +957 | ! |
- categorical_var_name = as.name(categorical_var)+ plot_r = boxplot_r, |
| 573 | -+ | ||
| 958 | +! |
- )+ height = plot_height, |
|
| 574 | -+ | ||
| 959 | +! |
- )+ width = plot_width, |
|
| 575 | -+ | ||
| 960 | +! |
- )+ brushing = TRUE |
|
| 576 | +961 |
- }+ ) |
|
| 577 | +962 | ||
| 578 | +963 | ! |
- if (length(categorical_var) > 0 && nrow(qenv[["ANL_OUTLIER"]]) > 0) {
+ density_pws <- teal.widgets::plot_with_settings_srv( |
| 579 | +964 | ! |
- shinyjs::show("order_by_outlier")
- |
-
| 580 | -- |
- } else {
+ id = "density_plot", |
|
| 581 | +965 | ! |
- shinyjs::hide("order_by_outlier")
+ plot_r = density_plot_r, |
| 582 | -+ | ||
| 966 | +! |
- }+ height = plot_height, |
|
| 583 | -+ | ||
| 967 | +! |
-
+ width = plot_width, |
|
| 584 | +968 | ! |
- qenv+ brushing = TRUE |
| 585 | +969 |
- })+ ) |
|
| 586 | +970 | ||
| 587 | +971 | ! |
- output$summary_table <- DT::renderDataTable(+ cum_density_pws <- teal.widgets::plot_with_settings_srv( |
| 588 | +972 | ! |
- expr = {
+ id = "cum_density_plot", |
| 589 | +973 | ! |
- if (iv_r()$is_valid()) {
+ plot_r = cumulative_plot_r, |
| 590 | +974 | ! |
- categorical_var <- as.vector(merged$anl_input_r()$columns_source$categorical_var)+ height = plot_height, |
| 591 | +975 | ! |
- if (!is.null(categorical_var)) {
+ width = plot_width, |
| 592 | +976 | ! |
- DT::datatable(+ brushing = TRUE+ |
+
| 977 | ++ |
+ )+ |
+ |
| 978 | ++ | + | |
| 593 | +979 | ! |
- common_code_q()[["summary_table"]],+ choices <- teal.transform::variable_choices(data()[[dataname_first]])+ |
+
| 980 | ++ | + | |
| 594 | +981 | ! |
- options = list(+ observeEvent(common_code_q(), {
|
| 595 | +982 | ! |
- dom = "t",+ ANL_OUTLIER <- common_code_q()[["ANL_OUTLIER"]] # nolint: object_name. |
| 596 | +983 | ! |
- autoWidth = TRUE,+ teal.widgets::updateOptionalSelectInput( |
| 597 | +984 | ! |
- columnDefs = list(list(width = "200px", targets = "_all"))+ session, |
| 598 | -+ | ||
| 985 | +! |
- )+ inputId = "table_ui_columns", |
|
| 599 | -+ | ||
| 986 | +! |
- )+ choices = dplyr::setdiff(choices, names(ANL_OUTLIER)), |
|
| 600 | -+ | ||
| 987 | +! |
- }+ selected = isolate(input$table_ui_columns) |
|
| 601 | +988 |
- }+ ) |
|
| 602 | +989 |
- }+ }) |
|
| 603 | +990 |
- )+ |
|
| 604 | -+ | ||
| 991 | +! |
-
+ output$table_ui <- DT::renderDataTable( |
|
| 605 | -+ | ||
| 992 | +! |
- # boxplot/violinplot # nolint commented_code_linter+ expr = {
|
|
| 606 | +993 | ! |
- boxplot_q <- reactive({
+ tab <- input$tabs |
| 607 | +994 | ! |
- req(common_code_q())+ req(tab) # tab is NULL upon app launch, hence will crash without this statement |
| 608 | +995 | ! |
- ANL <- common_code_q()[["ANL"]] # nolint object_name_linter+ outlier_var <- as.vector(merged$anl_input_r()$columns_source$outlier_var) |
| 609 | +996 | ! |
- ANL_OUTLIER <- common_code_q()[["ANL_OUTLIER"]] # nolint object_name_linter+ categorical_var <- as.vector(merged$anl_input_r()$columns_source$categorical_var) |
| 610 | +997 | ||
| 611 | +998 | ! |
- outlier_var <- as.vector(merged$anl_input_r()$columns_source$outlier_var)+ ANL_OUTLIER <- common_code_q()[["ANL_OUTLIER"]] # nolint: object_name. |
| 612 | +999 | ! |
- categorical_var <- as.vector(merged$anl_input_r()$columns_source$categorical_var)- |
-
| 613 | -- |
-
+ ANL_OUTLIER_EXTENDED <- common_code_q()[["ANL_OUTLIER_EXTENDED"]] # nolint: object_name. |
|
| 614 | -+ | ||
| 1000 | +! |
- # validation+ ANL <- common_code_q()[["ANL"]] # nolint: object_name. |
|
| 615 | +1001 | ! |
- teal::validate_has_data(ANL, 1)+ plot_brush <- if (tab == "Boxplot") {
|
| 616 | -+ | ||
| 1002 | +! |
-
+ boxplot_r() |
|
| 617 | -+ | ||
| 1003 | +! |
- # boxplot+ box_pws$brush() |
|
| 618 | +1004 | ! |
- plot_call <- quote(ANL %>% ggplot())+ } else if (tab == "Density Plot") {
|
| 619 | -+ | ||
| 1005 | +! |
-
+ density_plot_r() |
|
| 620 | +1006 | ! |
- plot_call <- if (input$boxplot_alts == "Box plot") {
+ density_pws$brush() |
| 621 | +1007 | ! |
- substitute(expr = plot_call + geom_boxplot(outlier.shape = NA), env = list(plot_call = plot_call))+ } else if (tab == "Cumulative Distribution Plot") {
|
| 622 | +1008 | ! |
- } else if (input$boxplot_alts == "Violin plot") {
+ cumulative_plot_r() |
| 623 | +1009 | ! |
- substitute(expr = plot_call + geom_violin(), env = list(plot_call = plot_call))+ cum_density_pws$brush() |
| 624 | +1010 |
- } else {
+ } |
|
| 625 | -! | +||
| 1011 | +
- NULL+ |
||
| 626 | +1012 |
- }+ # removing unused column ASAP+ |
+ |
| 1013 | +! | +
+ ANL_OUTLIER$order <- ANL$order <- NULL # nolint: object_name. |
|
| 627 | +1014 | ||
| 628 | +1015 | ! |
- plot_call <- if (identical(categorical_var, character(0)) || is.null(categorical_var)) {
+ display_table <- if (!is.null(plot_brush)) {
|
| 629 | +1016 | ! |
- inner_call <- substitute(+ if (length(categorical_var) > 0) {
|
| 630 | -! | +||
| 1017 | +
- expr = plot_call ++ # due to reordering, the x-axis label may be changed to something like "reorder(categorical_var, order)" |
||
| 631 | +1018 | ! |
- aes(x = "Entire dataset", y = outlier_var_name) ++ if (tab == "Boxplot") {
|
| 632 | +1019 | ! |
- scale_x_discrete(),+ plot_brush$mapping$x <- categorical_var+ |
+
| 1020 | ++ |
+ } else {
|
|
| 633 | -! | +||
| 1021 | +
- env = list(plot_call = plot_call, outlier_var_name = as.name(outlier_var))+ # the other plots use facetting |
||
| 634 | +1022 |
- )+ # so it is panelvar1 that gets relabelled to "reorder(categorical_var, order)" |
|
| 635 | +1023 | ! |
- if (nrow(ANL_OUTLIER) > 0) {
+ plot_brush$mapping$panelvar1 <- categorical_var |
| 636 | -! | +||
| 1024 | +
- substitute(+ } |
||
| 637 | -! | +||
| 1025 | +
- expr = inner_call + geom_point(+ } else {
|
||
| 638 | +1026 | ! |
- data = ANL_OUTLIER,+ if (tab == "Boxplot") {
|
| 639 | -! | +||
| 1027 | +
- aes(x = "Entire dataset", y = outlier_var_name, color = is_outlier_selected)+ # in boxplot with no categorical variable, there is no column in ANL that would correspond to x-axis |
||
| 640 | +1028 |
- ),+ # so a column needs to be inserted with the value "Entire dataset" because that's the label used in plot |
|
| 641 | +1029 | ! |
- env = list(inner_call = inner_call, outlier_var_name = as.name(outlier_var))+ ANL[[plot_brush$mapping$x]] <- "Entire dataset" # nolint: object_name. |
| 642 | +1030 |
- )+ } |
|
| 643 | +1031 |
- } else {
+ } |
|
| 644 | -! | +||
| 1032 | +
- inner_call+ |
||
| 645 | +1033 |
- }+ # in density and cumulative plots, ANL does not have a column corresponding to y-axis. |
|
| 646 | +1034 |
- } else {
+ # so they need to be computed and attached to ANL |
|
| 647 | +1035 | ! |
- substitute(+ if (tab == "Density Plot") {
|
| 648 | +1036 | ! |
- expr = plot_call ++ plot_brush$mapping$y <- "density" |
| 649 | +1037 | ! |
- aes(y = outlier_var_name, x = reorder(categorical_var_name, order)) ++ ANL$density <- plot_brush$ymin # nolint: object_name.+ |
+
| 1038 | ++ |
+ # either ymin or ymax will work |
|
| 650 | +1039 | ! |
- xlab(categorical_var) ++ } else if (tab == "Cumulative Distribution Plot") {
|
| 651 | +1040 | ! |
- scale_x_discrete() ++ plot_brush$mapping$y <- "cdf" |
| 652 | +1041 | ! |
- geom_point(+ if (length(categorical_var) > 0) {
|
| 653 | +1042 | ! |
- data = ANL_OUTLIER,+ ANL <- ANL %>% # nolint: object_name. |
| 654 | +1043 | ! |
- aes(x = as.factor(categorical_var_name), y = outlier_var_name, color = is_outlier_selected)+ dplyr::group_by(!!as.name(plot_brush$mapping$panelvar1)) %>%+ |
+
| 1044 | +! | +
+ dplyr::mutate(cdf = stats::ecdf(!!as.name(outlier_var))(!!as.name(outlier_var))) |
|
| 655 | +1045 |
- ),+ } else {
|
|
| 656 | +1046 | ! |
- env = list(+ ANL$cdf <- stats::ecdf(ANL[[outlier_var]])(ANL[[outlier_var]]) # nolint: object_name. |
| 657 | -! | +||
| 1047 | +
- plot_call = plot_call,+ } |
||
| 658 | -! | +||
| 1048 | +
- outlier_var_name = as.name(outlier_var),+ }+ |
+ ||
| 1049 | ++ | + | |
| 659 | +1050 | ! |
- categorical_var_name = as.name(categorical_var),+ brushed_rows <- brushedPoints(ANL, plot_brush) |
| 660 | +1051 | ! |
- categorical_var = categorical_var+ if (nrow(brushed_rows) > 0) {
|
| 661 | +1052 |
- )+ # now we need to remove extra column from ANL so that it will have the same columns as ANL_OUTLIER |
|
| 662 | +1053 |
- )+ # so that dplyr::intersect will work |
|
| 663 | -+ | ||
| 1054 | +! |
- }+ if (tab == "Density Plot") {
|
|
| 664 | -+ | ||
| 1055 | +! |
-
+ brushed_rows$density <- NULL |
|
| 665 | +1056 | ! |
- dev_ggplot2_args <- teal.widgets::ggplot2_args(+ } else if (tab == "Cumulative Distribution Plot") {
|
| 666 | +1057 | ! |
- labs = list(color = "Is outlier?"),+ brushed_rows$cdf <- NULL |
| 667 | +1058 | ! |
- theme = list(legend.position = "top")+ } else if (tab == "Boxplot" && length(categorical_var) == 0) {
+ |
+
| 1059 | +! | +
+ brushed_rows[[plot_brush$mapping$x]] <- NULL |
|
| 668 | +1060 |
- )+ } |
|
| 669 | +1061 |
-
+ # is_outlier_selected is part of ANL_OUTLIER so needed here |
|
| 670 | +1062 | ! |
- all_ggplot2_args <- teal.widgets::resolve_ggplot2_args(+ brushed_rows$is_outlier_selected <- TRUE |
| 671 | +1063 | ! |
- user_plot = ggplot2_args[["Boxplot"]],+ dplyr::intersect(ANL_OUTLIER, brushed_rows) |
| 672 | -! | +||
| 1064 | +
- user_default = ggplot2_args$default,+ } else {
|
||
| 673 | +1065 | ! |
- module_plot = dev_ggplot2_args+ ANL_OUTLIER[0, ] |
| 674 | +1066 |
- )+ } |
|
| 675 | +1067 |
-
+ } else {
|
|
| 676 | +1068 | ! |
- parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(+ ANL_OUTLIER[ANL_OUTLIER$is_outlier_selected, ] |
| 677 | -! | +||
| 1069 | +
- all_ggplot2_args,+ }+ |
+ ||
| 1070 | ++ | + | |
| 678 | +1071 | ! |
- ggtheme = input$ggtheme+ display_table$is_outlier_selected <- NULL |
| 679 | +1072 |
- )+ |
|
| 680 | +1073 |
-
+ # Extend the brushed ANL_OUTLIER with additional columns |
|
| 681 | +1074 | ! |
- teal.code::eval_code(+ dplyr::left_join( |
| 682 | +1075 | ! |
- common_code_q(),+ display_table, |
| 683 | +1076 | ! |
- substitute(+ dplyr::select(ANL_OUTLIER_EXTENDED, -"is_outlier_selected"), |
| 684 | +1077 | ! |
- expr = g <- plot_call ++ by = names(display_table) |
| 685 | -! | +||
| 1078 | +
- scale_color_manual(values = c("TRUE" = "red", "FALSE" = "black")) +
+ ) %>% |
||
| 686 | +1079 | ! |
- labs + ggthemes + themes,+ dplyr::select(union(names(display_table), input$table_ui_columns)) |
| 687 | -! | +||
| 1080 | +
- env = list(+ }, |
||
| 688 | +1081 | ! |
- plot_call = plot_call,+ options = list( |
| 689 | +1082 | ! |
- labs = parsed_ggplot2_args$labs,+ searching = FALSE, language = list( |
| 690 | +1083 | ! |
- ggthemes = parsed_ggplot2_args$ggtheme,+ zeroRecords = "The brushed area does not contain outlier observations for the currently defined threshold"+ |
+
| 1084 | ++ |
+ ), |
|
| 691 | +1085 | ! |
- themes = parsed_ggplot2_args$theme+ pageLength = input$table_ui_rows |
| 692 | +1086 |
- )+ ) |
|
| 693 | +1087 |
- )+ ) |
|
| 694 | +1088 |
- ) %>%+ |
|
| 695 | +1089 | ! |
- teal.code::eval_code(quote(print(g)))+ output$total_outliers <- renderUI({
|
| 696 | -+ | ||
| 1090 | +! |
- })+ shiny::req(iv_r()$is_valid()) |
|
| 697 | -+ | ||
| 1091 | +! |
-
+ ANL <- merged$anl_q_r()[["ANL"]] # nolint: object_name. |
|
| 698 | -+ | ||
| 1092 | +! |
- # density plot+ ANL_OUTLIER <- common_code_q()[["ANL_OUTLIER"]] # nolint: object_name. |
|
| 699 | +1093 | ! |
- density_plot_q <- reactive({
+ teal::validate_has_data(ANL, 1) |
| 700 | +1094 | ! |
- ANL <- common_code_q()[["ANL"]] # nolint object_name_linter+ ANL_OUTLIER_SELECTED <- ANL_OUTLIER[ANL_OUTLIER$is_outlier_selected, ] # nolint: object_name. |
| 701 | +1095 | ! |
- ANL_OUTLIER <- common_code_q()[["ANL_OUTLIER"]] # nolint object_name_linter+ h5( |
| 702 | -+ | ||
| 1096 | +! |
-
+ sprintf( |
|
| 703 | +1097 | ! |
- outlier_var <- as.vector(merged$anl_input_r()$columns_source$outlier_var)+ "%s %d / %d [%.02f%%]", |
| 704 | +1098 | ! |
- categorical_var <- as.vector(merged$anl_input_r()$columns_source$categorical_var)+ "Total number of outlier(s):", |
| 705 | -+ | ||
| 1099 | +! |
-
+ nrow(ANL_OUTLIER_SELECTED), |
|
| 706 | -+ | ||
| 1100 | +! |
- # validation+ nrow(ANL), |
|
| 707 | +1101 | ! |
- teal::validate_has_data(ANL, 1)+ 100 * nrow(ANL_OUTLIER_SELECTED) / nrow(ANL) |
| 708 | +1102 |
- # plot+ ) |
|
| 709 | -! | +||
| 1103 | +
- plot_call <- substitute(+ ) |
||
| 710 | -! | +||
| 1104 | +
- expr = ANL %>%+ }) |
||
| 711 | -! | +||
| 1105 | +
- ggplot(aes(x = outlier_var_name)) ++ |
||
| 712 | +1106 | ! |
- geom_density() ++ output$total_missing <- renderUI({
|
| 713 | +1107 | ! |
- geom_rug(data = ANL_OUTLIER, aes(x = outlier_var_name, color = is_outlier_selected)) ++ if (n_outlier_missing() > 0) {
|
| 714 | +1108 | ! |
- scale_color_manual(values = c("TRUE" = "red", "FALSE" = "black")),
+ ANL <- merged$anl_q_r()[["ANL"]] # nolint: object_name. |
| 715 | +1109 | ! |
- env = list(outlier_var_name = as.name(outlier_var))- |
-
| 716 | -- |
- )+ helpText( |
|
| 717 | -+ | ||
| 1110 | +! |
-
+ sprintf( |
|
| 718 | +1111 | ! |
- plot_call <- if (identical(categorical_var, character(0)) || is.null(categorical_var)) {
+ "%s %d / %d [%.02f%%]", |
| 719 | +1112 | ! |
- substitute(expr = plot_call, env = list(plot_call = plot_call))+ "Total number of row(s) with missing values:", |
| 720 | -+ | ||
| 1113 | +! |
- } else {
+ n_outlier_missing(), |
|
| 721 | +1114 | ! |
- substitute(+ nrow(ANL), |
| 722 | +1115 | ! |
- expr = plot_call + facet_grid(~ reorder(categorical_var_name, order)),+ 100 * (n_outlier_missing()) / nrow(ANL) |
| 723 | -! | +||
| 1116 | +
- env = list(plot_call = plot_call, categorical_var_name = as.name(categorical_var))+ ) |
||
| 724 | +1117 |
) |
|
| 725 | +1118 |
} |
|
| 726 | +1119 | ++ |
+ })+ |
+
| 1120 | |||
| 727 | +1121 | ! |
- dev_ggplot2_args <- teal.widgets::ggplot2_args(+ output$table_ui_wrap <- renderUI({
|
| 728 | +1122 | ! |
- labs = list(color = "Is outlier?"),+ shiny::req(iv_r()$is_valid()) |
| 729 | +1123 | ! |
- theme = list(legend.position = "top")- |
-
| 730 | -- |
- )+ tagList( |
|
| 731 | -+ | ||
| 1124 | +! |
-
+ teal.widgets::optionalSelectInput( |
|
| 732 | +1125 | ! |
- all_ggplot2_args <- teal.widgets::resolve_ggplot2_args(+ inputId = session$ns("table_ui_columns"),
|
| 733 | +1126 | ! |
- user_plot = ggplot2_args[["Density Plot"]],+ label = "Choose additional columns", |
| 734 | +1127 | ! |
- user_default = ggplot2_args$default,+ choices = NULL, |
| 735 | +1128 | ! |
- module_plot = dev_ggplot2_args+ selected = NULL, |
| 736 | -+ | ||
| 1129 | +! |
- )+ multiple = TRUE |
|
| 737 | +1130 |
-
+ ), |
|
| 738 | +1131 | ! |
- parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(+ h4("Outlier Table"),
|
| 739 | +1132 | ! |
- all_ggplot2_args,+ teal.widgets::get_dt_rows(session$ns("table_ui"), session$ns("table_ui_rows")),
|
| 740 | +1133 | ! |
- ggtheme = input$ggtheme+ DT::dataTableOutput(session$ns("table_ui"))
|
| 741 | +1134 |
) |
|
| 742 | +1135 |
-
+ }) |
|
| 743 | -! | +||
| 1136 | +
- teal.code::eval_code(+ |
||
| 744 | +1137 | ! |
- common_code_q(),+ teal.widgets::verbatim_popup_srv( |
| 745 | +1138 | ! |
- substitute(+ id = "warning", |
| 746 | +1139 | ! |
- expr = g <- plot_call + labs + ggthemes + themes,+ verbatim_content = reactive(teal.code::get_warnings(final_q())), |
| 747 | +1140 | ! |
- env = list(+ title = "Warning", |
| 748 | +1141 | ! |
- plot_call = plot_call,+ disabled = reactive(is.null(teal.code::get_warnings(final_q()))) |
| 749 | -! | +||
| 1142 | +
- labs = parsed_ggplot2_args$labs,+ ) |
||
| 750 | -! | +||
| 1143 | +
- themes = parsed_ggplot2_args$theme,+ |
||
| 751 | +1144 | ! |
- ggthemes = parsed_ggplot2_args$ggtheme- |
-
| 752 | -- |
- )+ teal.widgets::verbatim_popup_srv( |
|
| 753 | -+ | ||
| 1145 | +! |
- )+ id = "rcode", |
|
| 754 | -+ | ||
| 1146 | +! |
- ) %>%+ verbatim_content = reactive(teal.code::get_code(final_q())), |
|
| 755 | +1147 | ! |
- teal.code::eval_code(quote(print(g)))+ title = "Show R Code for Outlier" |
| 756 | +1148 |
- })+ ) |
|
| 757 | +1149 | ||
| 758 | +1150 |
- # Cumulative distribution plot+ ### REPORTER |
|
| 759 | +1151 | ! |
- cumulative_plot_q <- reactive({
+ if (with_reporter) {
|
| 760 | +1152 | ! |
- ANL <- common_code_q()[["ANL"]] # nolint object_name_linter+ card_fun <- function(comment, label) {
|
| 761 | +1153 | ! |
- ANL_OUTLIER <- common_code_q()[["ANL_OUTLIER"]] # nolint object_name_linter- |
-
| 762 | -- |
-
+ tab_type <- input$tabs |
|
| 763 | +1154 | ! |
- qenv <- common_code_q()- |
-
| 764 | -- |
-
+ card <- teal::report_card_template( |
|
| 765 | +1155 | ! |
- outlier_var <- as.vector(merged$anl_input_r()$columns_source$outlier_var)+ title = paste0("Outliers - ", tab_type),
|
| 766 | +1156 | ! |
- categorical_var <- as.vector(merged$anl_input_r()$columns_source$categorical_var)- |
-
| 767 | -- |
-
+ label = label, |
|
| 768 | -+ | ||
| 1157 | +! |
- # validation+ with_filter = with_filter, |
|
| 769 | +1158 | ! |
- teal::validate_has_data(ANL, 1)+ filter_panel_api = filter_panel_api |
| 770 | +1159 |
-
+ ) |
|
| 771 | -+ | ||
| 1160 | +! |
- # plot+ categorical_var <- as.vector(merged$anl_input_r()$columns_source$categorical_var) |
|
| 772 | +1161 | ! |
- plot_call <- substitute(+ if (length(categorical_var) > 0) {
|
| 773 | +1162 | ! |
- expr = ANL %>% ggplot(aes(x = outlier_var_name)) ++ summary_table <- common_code_q()[["summary_table"]] |
| 774 | +1163 | ! |
- stat_ecdf(),+ card$append_text("Summary Table", "header3")
|
| 775 | +1164 | ! |
- env = list(outlier_var_name = as.name(outlier_var))+ card$append_table(summary_table) |
| 776 | +1165 |
- )- |
- |
| 777 | -! | -
- if (length(categorical_var) == 0) {
+ } |
|
| 778 | +1166 | ! |
- qenv <- teal.code::eval_code(+ card$append_text("Plot", "header3")
|
| 779 | +1167 | ! |
- qenv,+ if (tab_type == "Boxplot") {
|
| 780 | +1168 | ! |
- substitute(+ card$append_plot(boxplot_r(), dim = box_pws$dim()) |
| 781 | +1169 | ! |
- expr = {
+ } else if (tab_type == "Density Plot") {
|
| 782 | +1170 | ! |
- ecdf_df <- ANL %>%+ card$append_plot(density_plot_r(), dim = density_pws$dim()) |
| 783 | +1171 | ! |
- dplyr::mutate(+ } else if (tab_type == "Cumulative Distribution Plot") {
|
| 784 | +1172 | ! |
- y = stats::ecdf(ANL[[outlier_var]])(ANL[[outlier_var]])- |
-
| 785 | -- |
- )+ card$append_plot(cumulative_plot_r(), dim = cum_density_pws$dim()) |
|
| 786 | +1173 |
-
+ } |
|
| 787 | +1174 | ! |
- outlier_points <- dplyr::left_join(+ if (!comment == "") {
|
| 788 | +1175 | ! |
- ecdf_df,+ card$append_text("Comment", "header3")
|
| 789 | +1176 | ! |
- ANL_OUTLIER,+ card$append_text(comment) |
| 790 | -! | +||
| 1177 | +
- by = dplyr::setdiff(names(ecdf_df), "y")+ } |
||
| 791 | -+ | ||
| 1178 | +! |
- ) %>%+ card$append_src(teal.code::get_code(final_q())) |
|
| 792 | +1179 | ! |
- dplyr::filter(!is.na(is_outlier_selected))+ card |
| 793 | +1180 |
- },+ } |
|
| 794 | +1181 | ! |
- env = list(outlier_var = outlier_var)+ teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
|
| 795 | +1182 |
- )+ } |
|
| 796 | +1183 |
- )+ ### |
|
| 797 | +1184 |
- } else {
- |
- |
| 798 | -! | -
- qenv <- teal.code::eval_code(+ }) |
|
| 799 | -! | +||
| 1185 | +
- qenv,+ } |
||
| 800 | -! | +
| 1 | +
- substitute(+ #' Scatterplot and Regression Model |
||
| 801 | -! | +||
| 2 | +
- expr = {
+ #' @md |
||
| 802 | -! | +||
| 3 | +
- all_categories <- lapply(+ #' |
||
| 803 | -! | +||
| 4 | +
- unique(ANL[[categorical_var]]),+ #' @inheritParams teal::module |
||
| 804 | -! | +||
| 5 | +
- function(x) {
+ #' @inheritParams shared_params |
||
| 805 | -! | +||
| 6 | +
- ANL <- ANL %>% dplyr::filter(get(categorical_var) == x) # nolint object_name_linter+ #' @param regressor (`data_extract_spec` or `list` of multiple `data_extract_spec`) |
||
| 806 | -! | +||
| 7 | +
- anl_outlier2 <- ANL_OUTLIER %>% dplyr::filter(get(categorical_var) == x)+ #' Regressor variables from an incoming dataset with filtering and selecting. |
||
| 807 | -! | +||
| 8 | +
- ecdf_df <- ANL %>%+ #' @param response (`data_extract_spec` or `list` of multiple `data_extract_spec`) |
||
| 808 | -! | +||
| 9 | +
- dplyr::mutate(y = stats::ecdf(ANL[[outlier_var]])(ANL[[outlier_var]]))+ #' Response variables from an incoming dataset with filtering and selecting. |
||
| 809 | +10 |
-
+ #' @param alpha optional, (`numeric`) If scalar then the plot points will have a fixed opacity. If a |
|
| 810 | -! | +||
| 11 | +
- dplyr::left_join(+ #' slider should be presented to adjust the plot point opacity dynamically then it can be a vector of |
||
| 811 | -! | +||
| 12 | +
- ecdf_df,+ #' length three with `c(value, min, max)`. |
||
| 812 | -! | +||
| 13 | +
- anl_outlier2,+ #' @param size optional, (`numeric`) If scalar then the plot point sizes will have a fixed size |
||
| 813 | -! | +||
| 14 | +
- by = dplyr::setdiff(names(ecdf_df), "y")+ #' If a slider should be presented to adjust the plot point sizes dynamically then it can be a |
||
| 814 | +15 |
- ) %>%+ #' vector of length three with `c(value, min, max)`. |
|
| 815 | -! | +||
| 16 | +
- dplyr::filter(!is.na(is_outlier_selected))+ #' @param default_outlier_label optional, (`character`) The default column selected to label outliers. |
||
| 816 | +17 |
- }+ #' @param default_plot_type optional, (`numeric`) Defaults to Response vs Regressor. |
|
| 817 | +18 |
- )+ #' 1. Response vs Regressor |
|
| 818 | -! | +||
| 19 | +
- outlier_points <- do.call(rbind, all_categories)+ #' 2. Residuals vs Fitted |
||
| 819 | +20 |
- },+ #' 3. Normal Q-Q |
|
| 820 | -! | +||
| 21 | +
- env = list(categorical_var = categorical_var, outlier_var = outlier_var)+ #' 4. Scale-Location |
||
| 821 | +22 |
- )+ #' 5. Cook's distance |
|
| 822 | +23 |
- )+ #' 6. Residuals vs Leverage |
|
| 823 | -! | +||
| 24 | +
- plot_call <- substitute(+ #' 7. Cook's dist vs Leverage |
||
| 824 | -! | +||
| 25 | +
- expr = plot_call + facet_grid(~ reorder(categorical_var_name, order)),+ #' |
||
| 825 | -! | +||
| 26 | +
- env = list(plot_call = plot_call, categorical_var_name = as.name(categorical_var))+ #' @templateVar ggnames `r regression_names` |
||
| 826 | +27 |
- )+ #' @template ggplot2_args_multi |
|
| 827 | +28 |
- }+ #' |
|
| 828 | +29 |
-
+ #' @note For more examples, please see the vignette "Using regression plots" via |
|
| 829 | -! | +||
| 30 | +
- dev_ggplot2_args <- teal.widgets::ggplot2_args(+ #' `vignette("using-regression-plots", package = "teal.modules.general")`.
|
||
| 830 | -! | +||
| 31 | +
- labs = list(color = "Is outlier?"),+ #' @export |
||
| 831 | -! | +||
| 32 | +
- theme = list(legend.position = "top")+ #' |
||
| 832 | +33 |
- )+ #' @examples |
|
| 833 | +34 |
-
+ #' # Regression graphs from selected response variable (BMRKR1) and |
|
| 834 | -! | +||
| 35 | +
- all_ggplot2_args <- teal.widgets::resolve_ggplot2_args(+ #' # selected regressors (AGE) |
||
| 835 | -! | +||
| 36 | +
- user_plot = ggplot2_args[["Cumulative Distribution Plot"]],+ #' |
||
| 836 | -! | +||
| 37 | +
- user_default = ggplot2_args$default,+ #' data <- teal_data() |
||
| 837 | -! | +||
| 38 | +
- module_plot = dev_ggplot2_args+ #' data <- within(data, {
|
||
| 838 | +39 |
- )+ #' library(nestcolor) |
|
| 839 | +40 |
-
+ #' ADSL <- teal.modules.general::rADSL |
|
| 840 | -! | +||
| 41 | +
- parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(+ #' }) |
||
| 841 | -! | +||
| 42 | +
- all_ggplot2_args,+ #' datanames <- c("ADSL")
|
||
| 842 | -! | +||
| 43 | +
- ggtheme = input$ggtheme+ #' datanames(data) <- datanames |
||
| 843 | +44 |
- )+ #' join_keys(data) <- default_cdisc_join_keys[datanames] |
|
| 844 | +45 |
-
+ #' |
|
| 845 | -! | +||
| 46 | +
- teal.code::eval_code(+ #' app <- teal::init( |
||
| 846 | -! | +||
| 47 | +
- qenv,+ #' data = data, |
||
| 847 | -! | +||
| 48 | +
- substitute(+ #' modules = teal::modules( |
||
| 848 | -! | +||
| 49 | +
- expr = g <- plot_call ++ #' teal.modules.general::tm_a_regression( |
||
| 849 | -! | +||
| 50 | +
- geom_point(data = outlier_points, aes(x = outlier_var_name, y = y, color = is_outlier_selected)) ++ #' label = "Regression", |
||
| 850 | -! | +||
| 51 | +
- scale_color_manual(values = c("TRUE" = "red", "FALSE" = "black")) +
+ #' response = teal.transform::data_extract_spec( |
||
| 851 | -! | +||
| 52 | +
- labs + ggthemes + themes,+ #' dataname = "ADSL", |
||
| 852 | -! | +||
| 53 | +
- env = list(+ #' select = teal.transform::select_spec( |
||
| 853 | -! | +||
| 54 | +
- plot_call = plot_call,+ #' label = "Select variable:", |
||
| 854 | -! | +||
| 55 | +
- outlier_var_name = as.name(outlier_var),+ #' choices = "BMRKR1", |
||
| 855 | -! | +||
| 56 | +
- labs = parsed_ggplot2_args$labs,+ #' selected = "BMRKR1", |
||
| 856 | -! | +||
| 57 | +
- themes = parsed_ggplot2_args$theme,+ #' multiple = FALSE, |
||
| 857 | -! | +||
| 58 | +
- ggthemes = parsed_ggplot2_args$ggtheme+ #' fixed = TRUE |
||
| 858 | +59 |
- )+ #' ) |
|
| 859 | +60 |
- )+ #' ), |
|
| 860 | +61 |
- ) %>%+ #' regressor = teal.transform::data_extract_spec( |
|
| 861 | -! | +||
| 62 | +
- teal.code::eval_code(quote(print(g)))+ #' dataname = "ADSL", |
||
| 862 | +63 |
- })+ #' select = teal.transform::select_spec( |
|
| 863 | +64 |
-
+ #' label = "Select variables:", |
|
| 864 | -! | +||
| 65 | +
- final_q <- reactive({
+ #' choices = teal.transform::variable_choices(data[["ADSL"]], c("AGE", "SEX", "RACE")),
|
||
| 865 | -! | +||
| 66 | +
- req(input$tabs)+ #' selected = "AGE", |
||
| 866 | -! | +||
| 67 | +
- tab_type <- input$tabs+ #' multiple = TRUE, |
||
| 867 | -! | +||
| 68 | +
- result_q <- if (tab_type == "Boxplot") {
+ #' fixed = FALSE |
||
| 868 | -! | +||
| 69 | +
- boxplot_q()+ #' ) |
||
| 869 | -! | +||
| 70 | +
- } else if (tab_type == "Density Plot") {
+ #' ), |
||
| 870 | -! | +||
| 71 | +
- density_plot_q()+ #' ggplot2_args = teal.widgets::ggplot2_args( |
||
| 871 | -! | +||
| 72 | +
- } else if (tab_type == "Cumulative Distribution Plot") {
+ #' labs = list(subtitle = "Plot generated by Regression Module") |
||
| 872 | -! | +||
| 73 | +
- cumulative_plot_q()+ #' ) |
||
| 873 | +74 |
- }+ #' ) |
|
| 874 | +75 |
- # used to display table when running show-r-code code+ #' ) |
|
| 875 | +76 |
- # added after the plots so that a change in selected columns doesn't affect+ #' ) |
|
| 876 | +77 |
- # brush selection.+ #' if (interactive()) {
|
|
| 877 | -! | +||
| 78 | +
- teal.code::eval_code(+ #' shinyApp(app$ui, app$server) |
||
| 878 | -! | +||
| 79 | +
- result_q,+ #' } |
||
| 879 | -! | +||
| 80 | +
- substitute(+ tm_a_regression <- function(label = "Regression Analysis", |
||
| 880 | -! | +||
| 81 | +
- expr = {
+ regressor, |
||
| 881 | -! | +||
| 82 | +
- columns_index <- union(+ response, |
||
| 882 | -! | +||
| 83 | +
- setdiff(names(ANL_OUTLIER), "is_outlier_selected"),+ plot_height = c(600, 200, 2000), |
||
| 883 | -! | +||
| 84 | +
- table_columns+ plot_width = NULL, |
||
| 884 | +85 |
- )+ alpha = c(1, 0, 1), |
|
| 885 | -! | +||
| 86 | +
- ANL_OUTLIER_EXTENDED[ANL_OUTLIER_EXTENDED$is_outlier_selected, columns_index]+ size = c(2, 1, 8), |
||
| 886 | +87 |
- },+ ggtheme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void"),
|
|
| 887 | -! | +||
| 88 | +
- env = list(+ ggplot2_args = teal.widgets::ggplot2_args(), |
||
| 888 | -! | +||
| 89 | +
- table_columns = input$table_ui_columns+ pre_output = NULL, |
||
| 889 | +90 |
- )+ post_output = NULL, |
|
| 890 | +91 |
- )+ default_plot_type = 1, |
|
| 891 | +92 |
- )+ default_outlier_label = "USUBJID") {
|
|
| 892 | -+ | ||
| 93 | +! |
- })+ logger::log_info("Initializing tm_a_regression")
|
|
| 893 | -+ | ||
| 94 | +! |
-
+ if (inherits(regressor, "data_extract_spec")) regressor <- list(regressor)+ |
+ |
| 95 | +! | +
+ if (inherits(response, "data_extract_spec")) response <- list(response)+ |
+ |
| 96 | +! | +
+ if (inherits(ggplot2_args, "ggplot2_args")) ggplot2_args <- list(default = ggplot2_args) |
|
| 894 | +97 |
- # slider text+ |
|
| 895 | +98 | ! |
- output$ui_outlier_help <- renderUI({
+ checkmate::assert_string(label) |
| 896 | +99 | ! |
- req(input$method)+ checkmate::assert_list(response, types = "data_extract_spec") |
| 897 | +100 | ! |
- if (input$method == "IQR") {
+ if (!all(vapply(response, function(x) !(x$select$multiple), logical(1)))) {
|
| 898 | +101 | ! |
- req(input$iqr_slider)+ stop("'response' should not allow multiple selection")
+ |
+
| 102 | ++ |
+ } |
|
| 899 | +103 | ! |
- tags$small(+ checkmate::assert_list(regressor, types = "data_extract_spec") |
| 900 | +104 | ! |
- withMathJax(+ ggtheme <- match.arg(ggtheme) |
| 901 | +105 | ! |
- helpText(+ checkmate::assert_string(default_outlier_label) |
| 902 | +106 | ! |
- "Outlier data points (\\(x \\lt Q1 - ", input$iqr_slider, "\\times IQR\\) or \\(+ plot_choices <- c( |
| 903 | +107 | ! |
- Q3 + ", input$iqr_slider, "\\times IQR \\lt x\\))+ "Response vs Regressor", "Residuals vs Fitted", "Normal Q-Q", "Scale-Location", |
| 904 | +108 | ! |
- are displayed in red on the plot and can be visualized in the table below."+ "Cook's distance", "Residuals vs Leverage", "Cook's dist vs Leverage" |
| 905 | +109 |
- ),+ ) |
|
| 906 | +110 | ! |
- if (input$split_outliers) {
+ checkmate::assert_list(ggplot2_args, types = "ggplot2_args") |
| 907 | +111 | ! |
- withMathJax(helpText("Note: Quantiles are calculated per group."))
+ checkmate::assert_subset(names(ggplot2_args), c("default", plot_choices))
|
| 908 | -+ | ||
| 112 | +! |
- }+ checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE) |
|
| 909 | -+ | ||
| 113 | +! |
- )+ checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height") |
|
| 910 | -+ | ||
| 114 | +! |
- )+ checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE) |
|
| 911 | +115 | ! |
- } else if (input$method == "Z-score") {
+ checkmate::assert_numeric( |
| 912 | +116 | ! |
- req(input$zscore_slider)+ plot_width[1], |
| 913 | +117 | ! |
- tags$small(+ lower = plot_width[2], upper = plot_width[3], null.ok = TRUE, .var.name = "plot_width" |
| 914 | -! | +||
| 118 | +
- withMathJax(+ ) |
||
| 915 | -! | +||
| 119 | +
- helpText(+ |
||
| 916 | -! | +||
| 120 | +
- "Outlier data points (\\(Zscore(x) < -", input$zscore_slider,+ # Send ui args |
||
| 917 | +121 | ! |
- "\\) or \\(", input$zscore_slider, "< Zscore(x) \\))
+ args <- as.list(environment()) |
| 918 | +122 | ! |
- are displayed in red on the plot and can be visualized in the table below."+ args[["plot_choices"]] <- plot_choices |
| 919 | -+ | ||
| 123 | +! |
- ),+ data_extract_list <- list( |
|
| 920 | +124 | ! |
- if (input$split_outliers) {
+ regressor = regressor, |
| 921 | +125 | ! |
- withMathJax(helpText(" Note: Z-scores are calculated per group."))
+ response = response |
| 922 | +126 |
- }+ ) |
|
| 923 | +127 |
- )+ |
|
| 924 | -+ | ||
| 128 | +! |
- )+ module( |
|
| 925 | +129 | ! |
- } else if (input$method == "Percentile") {
+ label = label, |
| 926 | +130 | ! |
- req(input$percentile_slider)+ server = srv_a_regression, |
| 927 | +131 | ! |
- tags$small(+ ui = ui_a_regression, |
| 928 | +132 | ! |
- withMathJax(+ ui_args = args, |
| 929 | +133 | ! |
- helpText(+ server_args = c( |
| 930 | +134 | ! |
- "Outlier/extreme data points (\\( Percentile(x) <", input$percentile_slider,+ data_extract_list, |
| 931 | +135 | ! |
- "\\) or \\(", 1 - input$percentile_slider, " < Percentile(x) \\))
+ list( |
| 932 | +136 | ! |
- are displayed in red on the plot and can be visualized in the table below."+ plot_height = plot_height, |
| 933 | -+ | ||
| 137 | +! |
- ),+ plot_width = plot_width, |
|
| 934 | +138 | ! |
- if (input$split_outliers) {
+ default_outlier_label = default_outlier_label, |
| 935 | +139 | ! |
- withMathJax(helpText("Note: Percentiles are calculated per group."))
+ ggplot2_args = ggplot2_args |
| 936 | +140 |
- }+ ) |
|
| 937 | +141 |
- )+ ),+ |
+ |
| 142 | +! | +
+ datanames = teal.transform::get_extract_datanames(data_extract_list) |
|
| 938 | +143 |
- )+ ) |
|
| 939 | +144 |
- }+ } |
|
| 940 | +145 |
- })+ |
|
| 941 | +146 |
-
+ ui_a_regression <- function(id, ...) {
|
|
| 942 | +147 | ! |
- boxplot_r <- reactive({
+ ns <- NS(id) |
| 943 | +148 | ! |
- teal::validate_inputs(iv_r())+ args <- list(...) |
| 944 | +149 | ! |
- boxplot_q()[["g"]]+ is_single_dataset_value <- teal.transform::is_single_dataset(args$regressor, args$response) |
| 945 | +150 |
- })+ |
|
| 946 | +151 | ! |
- density_plot_r <- reactive({
+ teal.widgets::standard_layout( |
| 947 | +152 | ! |
- teal::validate_inputs(iv_r())+ output = teal.widgets::white_small_well(tags$div( |
| 948 | +153 | ! |
- density_plot_q()[["g"]]+ teal.widgets::plot_with_settings_ui(id = ns("myplot")),
+ |
+
| 154 | +! | +
+ tags$div(verbatimTextOutput(ns("text")))
|
|
| 949 | +155 |
- })+ )), |
|
| 950 | +156 | ! |
- cumulative_plot_r <- reactive({
+ encoding = div( |
| 951 | -! | +||
| 157 | +
- teal::validate_inputs(iv_r())+ ### Reporter |
||
| 952 | +158 | ! |
- cumulative_plot_q()[["g"]]+ teal.reporter::simple_reporter_ui(ns("simple_reporter")),
|
| 953 | +159 |
- })+ ### |
|
| 954 | -+ | ||
| 160 | +! |
-
+ tags$label("Encodings", class = "text-primary"),
|
|
| 955 | +161 | ! |
- box_pws <- teal.widgets::plot_with_settings_srv(+ teal.transform::datanames_input(args[c("response", "regressor")]),
|
| 956 | +162 | ! |
- id = "box_plot",+ teal.transform::data_extract_ui( |
| 957 | +163 | ! |
- plot_r = boxplot_r,+ id = ns("response"),
|
| 958 | +164 | ! |
- height = plot_height,+ label = "Response variable", |
| 959 | +165 | ! |
- width = plot_width,+ data_extract_spec = args$response, |
| 960 | +166 | ! |
- brushing = TRUE+ is_single_dataset = is_single_dataset_value |
| 961 | +167 |
- )+ ), |
|
| 962 | -+ | ||
| 168 | +! |
-
+ teal.transform::data_extract_ui( |
|
| 963 | +169 | ! |
- density_pws <- teal.widgets::plot_with_settings_srv(+ id = ns("regressor"),
|
| 964 | +170 | ! |
- id = "density_plot",+ label = "Regressor variables", |
| 965 | +171 | ! |
- plot_r = density_plot_r,+ data_extract_spec = args$regressor, |
| 966 | +172 | ! |
- height = plot_height,+ is_single_dataset = is_single_dataset_value+ |
+
| 173 | ++ |
+ ), |
|
| 967 | +174 | ! |
- width = plot_width,+ radioButtons( |
| 968 | +175 | ! |
- brushing = TRUE+ ns("plot_type"),
|
| 969 | -+ | ||
| 176 | +! |
- )+ label = "Plot type:",+ |
+ |
| 177 | +! | +
+ choices = args$plot_choices,+ |
+ |
| 178 | +! | +
+ selected = args$plot_choices[args$default_plot_type] |
|
| 970 | +179 |
-
+ ), |
|
| 971 | +180 | ! |
- cum_density_pws <- teal.widgets::plot_with_settings_srv(+ checkboxInput(ns("show_outlier"), label = "Display outlier labels", value = TRUE),
|
| 972 | +181 | ! |
- id = "cum_density_plot",+ conditionalPanel( |
| 973 | +182 | ! |
- plot_r = cumulative_plot_r,+ condition = "input['show_outlier']", |
| 974 | +183 | ! |
- height = plot_height,+ ns = ns, |
| 975 | +184 | ! |
- width = plot_width,+ teal.widgets::optionalSliderInput( |
| 976 | +185 | ! |
- brushing = TRUE+ ns("outlier"),
|
| 977 | -+ | ||
| 186 | +! |
- )+ div( |
|
| 978 | -+ | ||
| 187 | +! |
-
+ class = "teal-tooltip", |
|
| 979 | +188 | ! |
- choices <- teal.transform::variable_choices(data()[[dataname_first]])+ tagList( |
| 980 | -+ | ||
| 189 | +! |
-
+ "Outlier definition:", |
|
| 981 | +190 | ! |
- observeEvent(common_code_q(), {
+ icon("circle-info"),
|
| 982 | +191 | ! |
- ANL_OUTLIER <- common_code_q()[["ANL_OUTLIER"]] # nolint object_name_linter+ span( |
| 983 | +192 | ! |
- teal.widgets::updateOptionalSelectInput(+ class = "tooltiptext", |
| 984 | +193 | ! |
- session,+ paste( |
| 985 | +194 | ! |
- inputId = "table_ui_columns",+ "Use the slider to choose the cut-off value to define outliers.", |
| 986 | +195 | ! |
- choices = dplyr::setdiff(choices, names(ANL_OUTLIER)),+ "Points with a Cook's distance greater than", |
| 987 | +196 | ! |
- selected = isolate(input$table_ui_columns)+ "the value on the slider times the mean of the Cook's distance of the dataset will have labels." |
| 988 | +197 |
- )+ ) |
|
| 989 | +198 |
- })+ ) |
|
| 990 | +199 |
-
+ ) |
|
| 991 | -! | +||
| 200 | +
- output$table_ui <- DT::renderDataTable(+ ), |
||
| 992 | +201 | ! |
- expr = {
+ min = 1, max = 10, value = 9, ticks = FALSE, step = .1+ |
+
| 202 | ++ |
+ ), |
|
| 993 | +203 | ! |
- tab <- input$tabs+ teal.widgets::optionalSelectInput( |
| 994 | +204 | ! |
- req(tab) # tab is NULL upon app launch, hence will crash without this statement+ ns("label_var"),
|
| 995 | +205 | ! |
- outlier_var <- as.vector(merged$anl_input_r()$columns_source$outlier_var)+ multiple = FALSE, |
| 996 | +206 | ! |
- categorical_var <- as.vector(merged$anl_input_r()$columns_source$categorical_var)+ label = "Outlier label" |
| 997 | +207 |
-
+ ) |
|
| 998 | -! | +||
| 208 | +
- ANL_OUTLIER <- common_code_q()[["ANL_OUTLIER"]] # nolint object_name_linter+ ), |
||
| 999 | +209 | ! |
- ANL_OUTLIER_EXTENDED <- common_code_q()[["ANL_OUTLIER_EXTENDED"]] # nolint object_name_linter+ teal.widgets::panel_group( |
| 1000 | +210 | ! |
- ANL <- common_code_q()[["ANL"]] # nolint object_name_linter+ teal.widgets::panel_item( |
| 1001 | +211 | ! |
- plot_brush <- if (tab == "Boxplot") {
+ title = "Plot settings", |
| 1002 | +212 | ! |
- boxplot_r()+ teal.widgets::optionalSliderInputValMinMax(ns("alpha"), "Opacity:", args$alpha, ticks = FALSE),
|
| 1003 | +213 | ! |
- box_pws$brush()+ teal.widgets::optionalSliderInputValMinMax(ns("size"), "Points size:", args$size, ticks = FALSE),
|
| 1004 | +214 | ! |
- } else if (tab == "Density Plot") {
+ selectInput( |
| 1005 | +215 | ! |
- density_plot_r()+ inputId = ns("ggtheme"),
|
| 1006 | +216 | ! |
- density_pws$brush()+ label = "Theme (by ggplot):", |
| 1007 | +217 | ! |
- } else if (tab == "Cumulative Distribution Plot") {
+ choices = ggplot_themes, |
| 1008 | +218 | ! |
- cumulative_plot_r()+ selected = args$ggtheme, |
| 1009 | +219 | ! |
- cum_density_pws$brush()+ multiple = FALSE |
| 1010 | +220 |
- }+ ) |
|
| 1011 | +221 |
-
+ ) |
|
| 1012 | +222 |
- # removing unused column ASAP+ ) |
|
| 1013 | -! | +||
| 223 | +
- ANL_OUTLIER$order <- ANL$order <- NULL # nolint object_name_linter+ ), |
||
| 1014 | -+ | ||
| 224 | +! |
-
+ forms = tagList( |
|
| 1015 | +225 | ! |
- display_table <- if (!is.null(plot_brush)) {
+ teal.widgets::verbatim_popup_ui(ns("warning"), "Show Warnings"),
|
| 1016 | +226 | ! |
- if (length(categorical_var) > 0) {
+ teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code")
|
| 1017 | +227 |
- # due to reordering, the x-axis label may be changed to something like "reorder(categorical_var, order)"+ ), |
|
| 1018 | +228 | ! |
- if (tab == "Boxplot") {
+ pre_output = args$pre_output, |
| 1019 | +229 | ! |
- plot_brush$mapping$x <- categorical_var+ post_output = args$post_output |
| 1020 | +230 |
- } else {
+ ) |
|
| 1021 | +231 |
- # the other plots use facetting+ } |
|
| 1022 | +232 |
- # so it is panelvar1 that gets relabelled to "reorder(categorical_var, order)"- |
- |
| 1023 | -! | -
- plot_brush$mapping$panelvar1 <- categorical_var+ |
|
| 1024 | +233 |
- }+ |
|
| 1025 | +234 |
- } else {
- |
- |
| 1026 | -! | -
- if (tab == "Boxplot") {
+ srv_a_regression <- function(id, |
|
| 1027 | +235 |
- # in boxplot with no categorical variable, there is no column in ANL that would correspond to x-axis+ data, |
|
| 1028 | +236 |
- # so a column needs to be inserted with the value "Entire dataset" because that's the label used in plot+ reporter, |
|
| 1029 | -! | +||
| 237 | +
- ANL[[plot_brush$mapping$x]] <- "Entire dataset" # nolint object_name_linter+ filter_panel_api, |
||
| 1030 | +238 |
- }+ response, |
|
| 1031 | +239 |
- }+ regressor, |
|
| 1032 | +240 |
-
+ plot_height, |
|
| 1033 | +241 |
- # in density and cumulative plots, ANL does not have a column corresponding to y-axis.+ plot_width, |
|
| 1034 | +242 |
- # so they need to be computed and attached to ANL+ ggplot2_args, |
|
| 1035 | -! | +||
| 243 | +
- if (tab == "Density Plot") {
+ default_outlier_label) {
|
||
| 1036 | +244 | ! |
- plot_brush$mapping$y <- "density"+ with_reporter <- !missing(reporter) && inherits(reporter, "Reporter") |
| 1037 | +245 | ! |
- ANL$density <- plot_brush$ymin # nolint #either ymin or ymax will work+ with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI") |
| 1038 | +246 | ! |
- } else if (tab == "Cumulative Distribution Plot") {
+ checkmate::assert_class(data, "reactive") |
| 1039 | +247 | ! |
- plot_brush$mapping$y <- "cdf"+ checkmate::assert_class(isolate(data()), "teal_data") |
| 1040 | +248 | ! |
- if (length(categorical_var) > 0) {
+ moduleServer(id, function(input, output, session) {
|
| 1041 | +249 | ! |
- ANL <- ANL %>% # nolint object_name_linter+ rule_rvr1 <- function(value) {
|
| 1042 | +250 | ! |
- dplyr::group_by(!!as.name(plot_brush$mapping$panelvar1)) %>%+ if (isTRUE(input$plot_type == "Response vs Regressor")) {
|
| 1043 | +251 | ! |
- dplyr::mutate(cdf = stats::ecdf(!!as.name(outlier_var))(!!as.name(outlier_var)))- |
-
| 1044 | -- |
- } else {
+ if (length(value) > 1L) {
|
|
| 1045 | +252 | ! |
- ANL$cdf <- stats::ecdf(ANL[[outlier_var]])(ANL[[outlier_var]]) # nolint object_name_linter- |
-
| 1046 | -- |
- }- |
- |
| 1047 | -- |
- }+ "This plot can only have one regressor." |
|
| 1048 | +253 | - - | -|
| 1049 | -! | -
- brushed_rows <- brushedPoints(ANL, plot_brush)- |
- |
| 1050 | -! | -
- if (nrow(brushed_rows) > 0) {
+ } |
|
| 1051 | +254 |
- # now we need to remove extra column from ANL so that it will have the same columns as ANL_OUTLIER+ } |
|
| 1052 | +255 |
- # so that dplyr::intersect will work+ } |
|
| 1053 | +256 | ! |
- if (tab == "Density Plot") {
+ rule_rvr2 <- function(other) {
|
| 1054 | +257 | ! |
- brushed_rows$density <- NULL+ function(value) {
|
| 1055 | +258 | ! |
- } else if (tab == "Cumulative Distribution Plot") {
+ if (isTRUE(input$plot_type == "Response vs Regressor")) {
|
| 1056 | +259 | ! |
- brushed_rows$cdf <- NULL+ otherval <- selector_list()[[other]]()$select |
| 1057 | +260 | ! |
- } else if (tab == "Boxplot" && length(categorical_var) == 0) {
+ if (isTRUE(value == otherval)) {
|
| 1058 | +261 | ! |
- brushed_rows[[plot_brush$mapping$x]] <- NULL+ "Response and Regressor must be different." |
| 1059 | +262 |
- }+ } |
|
| 1060 | +263 |
- # is_outlier_selected is part of ANL_OUTLIER so needed here- |
- |
| 1061 | -! | -
- brushed_rows$is_outlier_selected <- TRUE- |
- |
| 1062 | -! | -
- dplyr::intersect(ANL_OUTLIER, brushed_rows)+ } |
|
| 1063 | +264 |
- } else {
- |
- |
| 1064 | -! | -
- ANL_OUTLIER[0, ]+ } |
|
| 1065 | +265 |
- }+ } |
|
| 1066 | +266 |
- } else {
+
|
|
| 1067 | +267 | ! |
- ANL_OUTLIER[ANL_OUTLIER$is_outlier_selected, ]- |
-
| 1068 | -- |
- }- |
- |
| 1069 | -- |
-
+ selector_list <- teal.transform::data_extract_multiple_srv( |
|
| 1070 | +268 | ! |
- display_table$is_outlier_selected <- NULL- |
-
| 1071 | -- | - - | -|
| 1072 | -- |
- # Extend the brushed ANL_OUTLIER with additional columns+ data_extract = list(response = response, regressor = regressor), |
|
| 1073 | +269 | ! |
- dplyr::left_join(+ datasets = data, |
| 1074 | +270 | ! |
- display_table,+ select_validation_rule = list( |
| 1075 | +271 | ! |
- dplyr::select(ANL_OUTLIER_EXTENDED, -"is_outlier_selected"),+ regressor = shinyvalidate::compose_rules( |
| 1076 | +272 | ! |
- by = names(display_table)+ shinyvalidate::sv_required("At least one regressor should be selected."),
|
| 1077 | -+ | ||
| 273 | +! |
- ) %>%+ rule_rvr1, |
|
| 1078 | +274 | ! |
- dplyr::select(union(names(display_table), input$table_ui_columns))+ rule_rvr2("response")
|
| 1079 | +275 |
- },+ ), |
|
| 1080 | +276 | ! |
- options = list(+ response = shinyvalidate::compose_rules( |
| 1081 | +277 | ! |
- searching = FALSE, language = list(+ shinyvalidate::sv_required("At least one response should be selected."),
|
| 1082 | +278 | ! |
- zeroRecords = "The brushed area does not contain outlier observations for the currently defined threshold"+ rule_rvr2("regressor")
|
| 1083 | +279 |
- ),- |
- |
| 1084 | -! | -
- pageLength = input$table_ui_rows+ ) |
|
| 1085 | +280 |
) |
|
| 1086 | +281 |
) |
|
| 1087 | +282 | ||
| 1088 | -! | -
- output$total_outliers <- renderUI({
- |
- |
| 1089 | -! | -
- shiny::req(iv_r()$is_valid())- |
- |
| 1090 | -! | -
- ANL <- merged$anl_q_r()[["ANL"]] # nolint object_name_linter- |
- |
| 1091 | -! | -
- ANL_OUTLIER <- common_code_q()[["ANL_OUTLIER"]] # nolint object_name_linter- |
- |
| 1092 | +283 | ! |
- teal::validate_has_data(ANL, 1)+ iv_r <- reactive({
|
| 1093 | +284 | ! |
- ANL_OUTLIER_SELECTED <- ANL_OUTLIER[ANL_OUTLIER$is_outlier_selected, ] # nolint object_name_linter+ iv <- shinyvalidate::InputValidator$new() |
| 1094 | +285 | ! |
- h5(+ teal.transform::compose_and_enable_validators(iv, selector_list) |
| 1095 | -! | +||
| 286 | +
- sprintf(+ }) |
||
| 1096 | -! | +||
| 287 | +
- "%s %d / %d [%.02f%%]",+ |
||
| 1097 | +288 | ! |
- "Total number of outlier(s):",+ iv_out <- shinyvalidate::InputValidator$new() |
| 1098 | +289 | ! |
- nrow(ANL_OUTLIER_SELECTED),+ iv_out$condition(~ isTRUE(input$show_outlier)) |
| 1099 | +290 | ! |
- nrow(ANL),+ iv_out$add_rule("label_var", shinyvalidate::sv_required("Please provide an `Outlier label` variable"))
|
| 1100 | +291 | ! |
- 100 * nrow(ANL_OUTLIER_SELECTED) / nrow(ANL)- |
-
| 1101 | -- |
- )- |
- |
| 1102 | -- |
- )- |
- |
| 1103 | -- |
- })+ iv_out$enable() |
|
| 1104 | +292 | ||
| 1105 | +293 | ! |
- output$total_missing <- renderUI({
+ anl_merged_input <- teal.transform::merge_expression_srv( |
| 1106 | +294 | ! |
- if (n_outlier_missing() > 0) {
+ selector_list = selector_list, |
| 1107 | +295 | ! |
- ANL <- merged$anl_q_r()[["ANL"]] # nolint object_name_linter+ datasets = data |
| 1108 | -! | +||
| 296 | +
- helpText(+ ) |
||
| 1109 | -! | +||
| 297 | +
- sprintf(+ |
||
| 1110 | +298 | ! |
- "%s %d / %d [%.02f%%]",+ regression_var <- reactive({
|
| 1111 | +299 | ! |
- "Total number of row(s) with missing values:",+ teal::validate_inputs(iv_r()) |
| 1112 | -! | +||
| 300 | +
- n_outlier_missing(),+ |
||
| 1113 | +301 | ! |
- nrow(ANL),+ list( |
| 1114 | +302 | ! |
- 100 * (n_outlier_missing()) / nrow(ANL)- |
-
| 1115 | -- |
- )+ response = as.vector(anl_merged_input()$columns_source$response), |
|
| 1116 | -+ | ||
| 303 | +! |
- )+ regressor = as.vector(anl_merged_input()$columns_source$regressor) |
|
| 1117 | +304 |
- }+ ) |
|
| 1118 | +305 |
}) |
|
| 1119 | +306 | ||
| 1120 | +307 | ! |
- output$table_ui_wrap <- renderUI({
+ anl_merged_q <- reactive({
|
| 1121 | +308 | ! |
- shiny::req(iv_r()$is_valid())+ req(anl_merged_input()) |
| 1122 | +309 | ! |
- tagList(+ data() %>% |
| 1123 | +310 | ! |
- teal.widgets::optionalSelectInput(+ teal.code::eval_code(as.expression(anl_merged_input()$expr)) |
| 1124 | -! | +||
| 311 | +
- inputId = session$ns("table_ui_columns"),
+ })+ |
+ ||
| 312 | ++ | + + | +|
| 313 | ++ |
+ # sets qenv object and populates it with data merge call and fit expression |
|
| 1125 | +314 | ! |
- label = "Choose additional columns",+ fit_r <- reactive({
|
| 1126 | +315 | ! |
- choices = NULL,+ ANL <- anl_merged_q()[["ANL"]] # nolint: object_name. |
| 1127 | +316 | ! |
- selected = NULL,+ teal::validate_has_data(ANL, 10)+ |
+
| 317 | ++ | + | |
| 1128 | +318 | ! |
- multiple = TRUE+ validate(need(is.numeric(ANL[regression_var()$response][[1]]), "Response variable should be numeric.")) |
| 1129 | +319 |
- ),+ |
|
| 1130 | +320 | ! |
- h4("Outlier Table"),
+ teal::validate_has_data( |
| 1131 | +321 | ! |
- teal.widgets::get_dt_rows(session$ns("table_ui"), session$ns("table_ui_rows")),
+ ANL[, c(regression_var()$response, regression_var()$regressor)], 10, |
| 1132 | +322 | ! |
- DT::dataTableOutput(session$ns("table_ui"))
+ complete = TRUE, allow_inf = FALSE |
| 1133 | +323 |
) |
|
| 1134 | +324 |
- })+ |
|
| 1135 | -+ | ||
| 325 | +! |
-
+ form <- stats::as.formula( |
|
| 1136 | +326 | ! |
- teal.widgets::verbatim_popup_srv(+ paste( |
| 1137 | +327 | ! |
- id = "warning",+ regression_var()$response, |
| 1138 | +328 | ! |
- verbatim_content = reactive(teal.code::get_warnings(final_q())),+ paste( |
| 1139 | +329 | ! |
- title = "Warning",+ regression_var()$regressor, |
| 1140 | +330 | ! |
- disabled = reactive(is.null(teal.code::get_warnings(final_q())))+ collapse = " + " |
| 1141 | +331 |
- )+ ),+ |
+ |
| 332 | +! | +
+ sep = " ~ " |
|
| 1142 | +333 | ++ |
+ )+ |
+
| 334 | ++ |
+ )+ |
+ |
| 335 | |||
| 1143 | +336 | ! |
- teal.widgets::verbatim_popup_srv(+ if (input$show_outlier) {
|
| 1144 | +337 | ! |
- id = "rcode",+ opts <- teal.transform::variable_choices(ANL) |
| 1145 | +338 | ! |
- verbatim_content = reactive(teal.code::get_code(final_q())),+ selected <- if (!is.null(isolate(input$label_var)) && isolate(input$label_var) %in% as.character(opts)) {
|
| 1146 | +339 | ! |
- title = "Show R Code for Outlier"+ isolate(input$label_var) |
| 1147 | +340 |
- )+ } else {
|
|
| 1148 | -+ | ||
| 341 | +! |
-
+ if (length(opts[as.character(opts) == default_outlier_label]) == 0) {
+ |
+ |
| 342 | +! | +
+ opts[[1]] |
|
| 1149 | +343 |
- ### REPORTER+ } else {
|
|
| 1150 | +344 | ! |
- if (with_reporter) {
+ opts[as.character(opts) == default_outlier_label] |
| 1151 | -! | +||
| 345 | +
- card_fun <- function(comment, label) {
+ } |
||
| 1152 | -! | +||
| 346 | +
- tab_type <- input$tabs+ } |
||
| 1153 | +347 | ! |
- card <- teal::report_card_template(+ teal.widgets::updateOptionalSelectInput( |
| 1154 | +348 | ! |
- title = paste0("Outliers - ", tab_type),
+ session = session, |
| 1155 | +349 | ! |
- label = label,+ inputId = "label_var", |
| 1156 | +350 | ! |
- with_filter = with_filter,+ choices = opts, |
| 1157 | +351 | ! |
- filter_panel_api = filter_panel_api+ selected = selected |
| 1158 | +352 |
) |
|
| 1159 | -! | +||
| 353 | +
- categorical_var <- as.vector(merged$anl_input_r()$columns_source$categorical_var)+ |
||
| 1160 | +354 | ! |
- if (length(categorical_var) > 0) {
+ data <- fortify(stats::lm(form, data = ANL)) |
| 1161 | +355 | ! |
- summary_table <- common_code_q()[["summary_table"]]+ cooksd <- data$.cooksd[!is.nan(data$.cooksd)] |
| 1162 | +356 | ! |
- card$append_text("Summary Table", "header3")
+ max_outlier <- max(ceiling(max(cooksd) / mean(cooksd)), 2) |
| 1163 | +357 | ! |
- card$append_table(summary_table)- |
-
| 1164 | -- |
- }+ cur_outlier <- isolate(input$outlier) |
|
| 1165 | +358 | ! |
- card$append_text("Plot", "header3")
+ updateSliderInput( |
| 1166 | +359 | ! |
- if (tab_type == "Boxplot") {
+ session = session, |
| 1167 | +360 | ! |
- card$append_plot(boxplot_r(), dim = box_pws$dim())+ inputId = "outlier", |
| 1168 | +361 | ! |
- } else if (tab_type == "Density Plot") {
+ min = 1, |
| 1169 | +362 | ! |
- card$append_plot(density_plot_r(), dim = density_pws$dim())+ max = max_outlier, |
| 1170 | +363 | ! |
- } else if (tab_type == "Cumulative Distribution Plot") {
+ value = if (cur_outlier < max_outlier) cur_outlier else max_outlier * .9 |
| 1171 | -! | +||
| 364 | +
- card$append_plot(cumulative_plot_r(), dim = cum_density_pws$dim())+ ) |
||
| 1172 | +365 |
- }+ } |
|
| 1173 | -! | +||
| 366 | +
- if (!comment == "") {
+
|
||
| 1174 | +367 | ! |
- card$append_text("Comment", "header3")
+ anl_merged_q() %>% |
| 1175 | +368 | ! |
- card$append_text(comment)+ teal.code::eval_code(substitute(fit <- stats::lm(form, data = ANL), env = list(form = form))) %>% |
| 1176 | -+ | ||
| 369 | +! |
- }+ teal.code::eval_code(quote({
|
|
| 1177 | +370 | ! |
- card$append_src(teal.code::get_code(final_q()))+ for (regressor in names(fit$contrasts)) {
|
| 1178 | +371 | ! |
- card+ alts <- paste0(levels(ANL[[regressor]]), collapse = "|") |
| 1179 | -+ | ||
| 372 | +! |
- }+ names(fit$coefficients) <- gsub( |
|
| 1180 | +373 | ! |
- teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
+ paste0("^(", regressor, ")(", alts, ")$"), paste0("\\1", ": ", "\\2"), names(fit$coefficients)
|
| 1181 | +374 |
- }+ ) |
|
| 1182 | +375 |
- ###+ } |
|
| 1183 | +376 |
- })+ })) %>% |
|
| 1184 | -+ | ||
| 377 | +! |
- }+ teal.code::eval_code(quote(summary(fit))) |
| 1 | +378 |
- #' Scatterplot and Regression Model+ }) |
||
| 2 | +379 |
- #' @md+ |
||
| 3 | -+ | |||
| 380 | +! |
- #'+ label_col <- reactive({
|
||
| 4 | -+ | |||
| 381 | +! |
- #' @inheritParams teal::module+ teal::validate_inputs(iv_out) |
||
| 5 | +382 |
- #' @inheritParams shared_params+ |
||
| 6 | -+ | |||
| 383 | +! |
- #' @param regressor (`data_extract_spec` or `list` of multiple `data_extract_spec`)+ substitute( |
||
| 7 | -+ | |||
| 384 | +! |
- #' Regressor variables from an incoming dataset with filtering and selecting.+ expr = dplyr::if_else( |
||
| 8 | -+ | |||
| 385 | +! |
- #' @param response (`data_extract_spec` or `list` of multiple `data_extract_spec`)+ data$.cooksd > outliers * mean(data$.cooksd, na.rm = TRUE), |
||
| 9 | -+ | |||
| 386 | +! |
- #' Response variables from an incoming dataset with filtering and selecting.+ as.character(stats::na.omit(ANL)[[label_var]]), |
||
| 10 | +387 |
- #' @param alpha optional, (`numeric`) If scalar then the plot points will have a fixed opacity. If a+ "" |
||
| 11 | +388 |
- #' slider should be presented to adjust the plot point opacity dynamically then it can be a vector of+ ) %>%+ |
+ ||
| 389 | +! | +
+ dplyr::if_else(is.na(.), "cooksd == NaN", .),+ |
+ ||
| 390 | +! | +
+ env = list(outliers = input$outlier, label_var = input$label_var) |
||
| 12 | +391 |
- #' length three with `c(value, min, max)`.+ ) |
||
| 13 | +392 |
- #' @param size optional, (`numeric`) If scalar then the plot point sizes will have a fixed size+ }) |
||
| 14 | +393 |
- #' If a slider should be presented to adjust the plot point sizes dynamically then it can be a+ |
||
| 15 | -+ | |||
| 394 | +! |
- #' vector of length three with `c(value, min, max)`.+ outlier_label <- reactive({
|
||
| 16 | -+ | |||
| 395 | +! |
- #' @param default_outlier_label optional, (`character`) The default column selected to label outliers.+ substitute( |
||
| 17 | -+ | |||
| 396 | +! |
- #' @param default_plot_type optional, (`numeric`) Defaults to Response vs Regressor.+ expr = geom_text(label = label_col, hjust = 0, vjust = 1, color = "red"), |
||
| 18 | -+ | |||
| 397 | +! |
- #' 1. Response vs Regressor+ env = list(label_col = label_col()) |
||
| 19 | +398 |
- #' 2. Residuals vs Fitted+ ) |
||
| 20 | +399 |
- #' 3. Normal Q-Q+ }) |
||
| 21 | +400 |
- #' 4. Scale-Location+ |
||
| 22 | -+ | |||
| 401 | +! |
- #' 5. Cook's distance+ output_q <- reactive({
|
||
| 23 | -+ | |||
| 402 | +! |
- #' 6. Residuals vs Leverage+ alpha <- input$alpha |
||
| 24 | -+ | |||
| 403 | +! |
- #' 7. Cook's dist vs Leverage+ size <- input$size |
||
| 25 | -+ | |||
| 404 | +! |
- #'+ ggtheme <- input$ggtheme |
||
| 26 | -+ | |||
| 405 | +! |
- #' @templateVar ggnames `r regression_names`+ input_type <- input$plot_type |
||
| 27 | -+ | |||
| 406 | +! |
- #' @template ggplot2_args_multi+ show_outlier <- input$show_outlier |
||
| 28 | +407 |
- #'+ |
||
| 29 | -+ | |||
| 408 | +! |
- #' @note For more examples, please see the vignette "Using regression plots" via+ teal::validate_inputs(iv_r()) |
||
| 30 | +409 |
- #' `vignette("using-regression-plots", package = "teal.modules.general")`.
+
|
||
| 31 | -+ | |||
| 410 | +! |
- #' @export+ plot_type_0 <- function() {
|
||
| 32 | -+ | |||
| 411 | +! |
- #'+ fit <- fit_r()[["fit"]] |
||
| 33 | -+ | |||
| 412 | +! |
- #' @examples+ ANL <- anl_merged_q()[["ANL"]] # nolint: object_name. |
||
| 34 | +413 |
- #' # Regression graphs from selected response variable (BMRKR1) and+ |
||
| 35 | -+ | |||
| 414 | +! |
- #' # selected regressors (AGE)+ stopifnot(ncol(fit$model) == 2) |
||
| 36 | +415 |
- #'+ |
||
| 37 | -+ | |||
| 416 | +! |
- #' data <- teal_data()+ if (!is.factor(ANL[[regression_var()$regressor]])) {
|
||
| 38 | -+ | |||
| 417 | +! |
- #' data <- within(data, {
+ shinyjs::show("size")
|
||
| 39 | -+ | |||
| 418 | +! |
- #' library(nestcolor)+ shinyjs::show("alpha")
|
||
| 40 | -+ | |||
| 419 | +! |
- #' ADSL <- teal.modules.general::rADSL+ plot <- substitute( |
||
| 41 | -+ | |||
| 420 | +! |
- #' })+ env = list( |
||
| 42 | -+ | |||
| 421 | +! |
- #' datanames <- c("ADSL")
+ regressor = regression_var()$regressor, |
||
| 43 | -+ | |||
| 422 | +! |
- #' datanames(data) <- datanames+ response = regression_var()$response, |
||
| 44 | -+ | |||
| 423 | +! |
- #' join_keys(data) <- default_cdisc_join_keys[datanames]+ size = size, |
||
| 45 | -+ | |||
| 424 | +! |
- #'+ alpha = alpha |
||
| 46 | +425 |
- #' app <- teal::init(+ ), |
||
| 47 | -+ | |||
| 426 | +! |
- #' data = data,+ expr = ggplot( |
||
| 48 | -+ | |||
| 427 | +! |
- #' modules = teal::modules(+ fit$model[, 2:1], |
||
| 49 | -+ | |||
| 428 | +! |
- #' teal.modules.general::tm_a_regression(+ aes_string(regressor, response) |
||
| 50 | +429 |
- #' label = "Regression",+ ) + |
||
| 51 | -+ | |||
| 430 | +! |
- #' response = teal.transform::data_extract_spec(+ geom_point(size = size, alpha = alpha) + |
||
| 52 | -+ | |||
| 431 | +! |
- #' dataname = "ADSL",+ stat_smooth( |
||
| 53 | -+ | |||
| 432 | +! |
- #' select = teal.transform::select_spec(+ method = "lm", |
||
| 54 | -+ | |||
| 433 | +! |
- #' label = "Select variable:",+ formula = y ~ x, |
||
| 55 | -+ | |||
| 434 | +! |
- #' choices = "BMRKR1",+ se = FALSE |
||
| 56 | +435 |
- #' selected = "BMRKR1",+ ) |
||
| 57 | +436 |
- #' multiple = FALSE,+ ) |
||
| 58 | -+ | |||
| 437 | +! |
- #' fixed = TRUE+ if (show_outlier) {
|
||
| 59 | -+ | |||
| 438 | +! |
- #' )+ plot <- substitute( |
||
| 60 | -+ | |||
| 439 | +! |
- #' ),+ expr = plot + outlier_label, |
||
| 61 | -+ | |||
| 440 | +! |
- #' regressor = teal.transform::data_extract_spec(+ env = list(plot = plot, outlier_label = outlier_label()) |
||
| 62 | +441 |
- #' dataname = "ADSL",+ ) |
||
| 63 | +442 |
- #' select = teal.transform::select_spec(+ } |
||
| 64 | +443 |
- #' label = "Select variables:",+ } else {
|
||
| 65 | -+ | |||
| 444 | +! |
- #' choices = teal.transform::variable_choices(data[["ADSL"]], c("AGE", "SEX", "RACE")),
+ shinyjs::hide("size")
|
||
| 66 | -+ | |||
| 445 | +! |
- #' selected = "AGE",+ shinyjs::hide("alpha")
|
||
| 67 | -+ | |||
| 446 | +! |
- #' multiple = TRUE,+ plot <- substitute( |
||
| 68 | -+ | |||
| 447 | +! |
- #' fixed = FALSE+ expr = ggplot(fit$model[, 2:1], aes_string(regressor, response)) + |
||
| 69 | -+ | |||
| 448 | +! |
- #' )+ geom_boxplot(), |
||
| 70 | -+ | |||
| 449 | +! |
- #' ),+ env = list(regressor = regression_var()$regressor, response = regression_var()$response) |
||
| 71 | +450 |
- #' ggplot2_args = teal.widgets::ggplot2_args(+ ) |
||
| 72 | -+ | |||
| 451 | +! |
- #' labs = list(subtitle = "Plot generated by Regression Module")+ if (show_outlier) {
|
||
| 73 | -+ | |||
| 452 | +! |
- #' )+ plot <- substitute(expr = plot + outlier_label, env = list(plot = plot, outlier_label = outlier_label())) |
||
| 74 | +453 |
- #' )+ } |
||
| 75 | +454 |
- #' )+ } |
||
| 76 | +455 |
- #' )+ |
||
| 77 | -+ | |||
| 456 | +! |
- #' if (interactive()) {
+ parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args( |
||
| 78 | -+ | |||
| 457 | +! |
- #' shinyApp(app$ui, app$server)+ teal.widgets::resolve_ggplot2_args( |
||
| 79 | -+ | |||
| 458 | +! |
- #' }+ user_plot = ggplot2_args[["Response vs Regressor"]], |
||
| 80 | -+ | |||
| 459 | +! |
- tm_a_regression <- function(label = "Regression Analysis",+ user_default = ggplot2_args$default, |
||
| 81 | -+ | |||
| 460 | +! |
- regressor,+ module_plot = teal.widgets::ggplot2_args( |
||
| 82 | -+ | |||
| 461 | +! |
- response,+ labs = list( |
||
| 83 | -+ | |||
| 462 | +! |
- plot_height = c(600, 200, 2000),+ title = "Response vs Regressor", |
||
| 84 | -+ | |||
| 463 | +! |
- plot_width = NULL,+ x = varname_w_label(regression_var()$regressor, ANL), |
||
| 85 | -+ | |||
| 464 | +! |
- alpha = c(1, 0, 1),+ y = varname_w_label(regression_var()$response, ANL) |
||
| 86 | +465 |
- size = c(2, 1, 8),+ ), |
||
| 87 | -+ | |||
| 466 | +! |
- ggtheme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void"),
+ theme = list() |
||
| 88 | +467 |
- ggplot2_args = teal.widgets::ggplot2_args(),+ ) |
||
| 89 | +468 |
- pre_output = NULL,+ ), |
||
| 90 | -+ | |||
| 469 | +! |
- post_output = NULL,+ ggtheme = ggtheme |
||
| 91 | +470 |
- default_plot_type = 1,+ ) |
||
| 92 | +471 |
- default_outlier_label = "USUBJID") {
+
|
||
| 93 | +472 | ! |
- logger::log_info("Initializing tm_a_regression")
+ teal.code::eval_code( |
|
| 94 | +473 | ! |
- if (inherits(regressor, "data_extract_spec")) regressor <- list(regressor)+ fit_r(), |
|
| 95 | +474 | ! |
- if (inherits(response, "data_extract_spec")) response <- list(response)+ substitute( |
|
| 96 | +475 | ! |
- if (inherits(ggplot2_args, "ggplot2_args")) ggplot2_args <- list(default = ggplot2_args)- |
- |
| 97 | -- |
-
+ expr = {
|
||
| 98 | +476 | ! |
- checkmate::assert_string(label)+ class(fit$residuals) <- NULL |
|
| 99 | +477 | ! |
- checkmate::assert_list(response, types = "data_extract_spec")+ data <- fortify(fit) |
|
| 100 | +478 | ! |
- if (!all(vapply(response, function(x) !(x$select$multiple), logical(1)))) {
+ g <- plot |
|
| 101 | +479 | ! |
- stop("'response' should not allow multiple selection")
+ print(g) |
|
| 102 | +480 |
- }+ }, |
||
| 103 | +481 | ! |
- checkmate::assert_list(regressor, types = "data_extract_spec")+ env = list( |
|
| 104 | +482 | ! |
- ggtheme <- match.arg(ggtheme)+ plot = Reduce(function(x, y) call("+", x, y), c(plot, parsed_ggplot2_args))
|
|
| 105 | -! | +|||
| 483 | +
- checkmate::assert_string(default_outlier_label)+ ) |
|||
| 106 | -! | +|||
| 484 | +
- plot_choices <- c(+ ) |
|||
| 107 | -! | +|||
| 485 | +
- "Response vs Regressor", "Residuals vs Fitted", "Normal Q-Q", "Scale-Location",+ ) |
|||
| 108 | -! | +|||
| 486 | +
- "Cook's distance", "Residuals vs Leverage", "Cook's dist vs Leverage"+ } |
|||
| 109 | +487 |
- )+ |
||
| 110 | +488 | ! |
- checkmate::assert_list(ggplot2_args, types = "ggplot2_args")+ plot_base <- function() {
|
|
| 111 | +489 | ! |
- checkmate::assert_subset(names(ggplot2_args), c("default", plot_choices))
+ base_fit <- fit_r() |
|
| 112 | +490 | ! |
- checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE)+ teal.code::eval_code( |
|
| 113 | +491 | ! |
- checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height")+ base_fit, |
|
| 114 | +492 | ! |
- checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE)+ quote({
|
|
| 115 | +493 | ! |
- checkmate::assert_numeric(+ class(fit$residuals) <- NULL |
|
| 116 | -! | +|||
| 494 | +
- plot_width[1],+ |
|||
| 117 | +495 | ! |
- lower = plot_width[2], upper = plot_width[3], null.ok = TRUE, .var.name = "plot_width"- |
- |
| 118 | -- |
- )+ data <- ggplot2::fortify(fit) |
||
| 119 | +496 | |||
| 120 | -- |
- # Send ui args- |
- ||
| 121 | +497 | ! |
- args <- as.list(environment())+ smooth <- function(x, y) {
|
|
| 122 | +498 | ! |
- args[["plot_choices"]] <- plot_choices+ as.data.frame(stats::lowess(x, y, f = 2 / 3, iter = 3)) |
|
| 123 | -! | +|||
| 499 | +
- data_extract_list <- list(+ } |
|||
| 124 | -! | +|||
| 500 | +
- regressor = regressor,+ |
|||
| 125 | +501 | ! |
- response = response+ smoothy_aes <- ggplot2::aes_string(x = "x", y = "y") |
|
| 126 | +502 |
- )+ + |
+ ||
| 503 | +! | +
+ reg_form <- deparse(fit$call[[2]]) |
||
| 127 | +504 |
-
+ }) |
||
| 128 | -! | +|||
| 505 | +
- module(+ ) |
|||
| 129 | -! | +|||
| 506 | +
- label = label,+ } |
|||
| 130 | -! | +|||
| 507 | +
- server = srv_a_regression,+ |
|||
| 131 | +508 | ! |
- ui = ui_a_regression,+ plot_type_1 <- function(plot_base) {
|
|
| 132 | +509 | ! |
- ui_args = args,+ shinyjs::show("size")
|
|
| 133 | +510 | ! |
- server_args = c(+ shinyjs::show("alpha")
|
|
| 134 | +511 | ! |
- data_extract_list,+ plot <- substitute( |
|
| 135 | +512 | ! |
- list(+ expr = ggplot(data = data, aes(.fitted, .resid)) + |
|
| 136 | +513 | ! |
- plot_height = plot_height,+ geom_point(size = size, alpha = alpha) + |
|
| 137 | +514 | ! |
- plot_width = plot_width,+ geom_hline(yintercept = 0, linetype = "dashed", size = 1) + |
|
| 138 | +515 | ! |
- default_outlier_label = default_outlier_label,+ geom_line(data = smoothy, mapping = smoothy_aes), |
|
| 139 | +516 | ! |
- ggplot2_args = ggplot2_args- |
- |
| 140 | -- |
- )+ env = list(size = size, alpha = alpha) |
||
| 141 | +517 |
- ),+ ) |
||
| 142 | +518 | ! |
- datanames = teal.transform::get_extract_datanames(data_extract_list)+ if (show_outlier) {
|
|
| 143 | -+ | |||
| 519 | +! |
- )+ plot <- substitute(expr = plot + outlier_label, env = list(plot = plot, outlier_label = outlier_label())) |
||
| 144 | +520 |
- }+ } |
||
| 145 | +521 | |||
| 146 | -+ | |||
| 522 | +! |
- ui_a_regression <- function(id, ...) {
+ parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args( |
||
| 147 | +523 | ! |
- ns <- NS(id)+ teal.widgets::resolve_ggplot2_args( |
|
| 148 | +524 | ! |
- args <- list(...)+ user_plot = ggplot2_args[["Residuals vs Fitted"]], |
|
| 149 | +525 | ! |
- is_single_dataset_value <- teal.transform::is_single_dataset(args$regressor, args$response)+ user_default = ggplot2_args$default, |
|
| 150 | -+ | |||
| 526 | +! |
-
+ module_plot = teal.widgets::ggplot2_args( |
||
| 151 | +527 | ! |
- teal.widgets::standard_layout(+ labs = list( |
|
| 152 | +528 | ! |
- output = teal.widgets::white_small_well(tags$div(+ x = quote(paste0("Fitted values\nlm(", reg_form, ")")),
|
|
| 153 | +529 | ! |
- teal.widgets::plot_with_settings_ui(id = ns("myplot")),
+ y = "Residuals", |
|
| 154 | +530 | ! |
- tags$div(verbatimTextOutput(ns("text")))
+ title = "Residuals vs Fitted" |
|
| 155 | +531 |
- )),+ ) |
||
| 156 | -! | +|||
| 532 | +
- encoding = div(+ ) |
|||
| 157 | +533 |
- ### Reporter+ ), |
||
| 158 | +534 | ! |
- teal.reporter::simple_reporter_ui(ns("simple_reporter")),
+ ggtheme = ggtheme |
|
| 159 | +535 |
- ###+ )+ |
+ ||
| 536 | ++ | + | ||
| 160 | +537 | ! |
- tags$label("Encodings", class = "text-primary"),
+ teal.code::eval_code( |
|
| 161 | +538 | ! |
- teal.transform::datanames_input(args[c("response", "regressor")]),
+ plot_base, |
|
| 162 | +539 | ! |
- teal.transform::data_extract_ui(+ substitute( |
|
| 163 | +540 | ! |
- id = ns("response"),
+ expr = {
|
|
| 164 | +541 | ! |
- label = "Response variable",+ smoothy <- smooth(data$.fitted, data$.resid) |
|
| 165 | +542 | ! |
- data_extract_spec = args$response,+ g <- plot |
|
| 166 | +543 | ! |
- is_single_dataset = is_single_dataset_value+ print(g) |
|
| 167 | +544 |
- ),+ }, |
||
| 168 | +545 | ! |
- teal.transform::data_extract_ui(+ env = list( |
|
| 169 | +546 | ! |
- id = ns("regressor"),
+ plot = Reduce(function(x, y) call("+", x, y), c(plot, parsed_ggplot2_args))
|
|
| 170 | -! | +|||
| 547 | +
- label = "Regressor variables",+ ) |
|||
| 171 | -! | +|||
| 548 | +
- data_extract_spec = args$regressor,+ ) |
|||
| 172 | -! | +|||
| 549 | +
- is_single_dataset = is_single_dataset_value+ ) |
|||
| 173 | +550 |
- ),+ } |
||
| 174 | -! | +|||
| 551 | +
- radioButtons(+ |
|||
| 175 | +552 | ! |
- ns("plot_type"),
+ plot_type_2 <- function(plot_base) {
|
|
| 176 | +553 | ! |
- label = "Plot type:",+ shinyjs::show("size")
|
|
| 177 | +554 | ! |
- choices = args$plot_choices,+ shinyjs::show("alpha")
|
|
| 178 | +555 | ! |
- selected = args$plot_choices[args$default_plot_type]+ plot <- substitute( |
|
| 179 | -+ | |||
| 556 | +! |
- ),+ expr = ggplot(data = data, aes(sample = .stdresid)) + |
||
| 180 | +557 | ! |
- checkboxInput(ns("show_outlier"), label = "Display outlier labels", value = TRUE),
+ stat_qq(size = size, alpha = alpha) + |
|
| 181 | +558 | ! |
- conditionalPanel(+ geom_abline(linetype = "dashed"), |
|
| 182 | +559 | ! |
- condition = "input['show_outlier']",+ env = list(size = size, alpha = alpha)+ |
+ |
| 560 | ++ |
+ ) |
||
| 183 | +561 | ! |
- ns = ns,+ if (show_outlier) {
|
|
| 184 | +562 | ! |
- teal.widgets::optionalSliderInput(+ plot <- substitute( |
|
| 185 | +563 | ! |
- ns("outlier"),
+ expr = plot + |
|
| 186 | +564 | ! |
- div(+ stat_qq( |
|
| 187 | +565 | ! |
- class = "teal-tooltip",+ geom = "text", |
|
| 188 | +566 | ! |
- tagList(+ label = label_col %>% |
|
| 189 | +567 | ! |
- "Outlier definition:",+ data.frame(label = .) %>% |
|
| 190 | +568 | ! |
- icon("circle-info"),
+ dplyr::filter(label != "cooksd == NaN") %>% |
|
| 191 | +569 | ! |
- span(+ unlist(), |
|
| 192 | +570 | ! |
- class = "tooltiptext",+ hjust = 0, |
|
| 193 | +571 | ! |
- paste(+ vjust = 1, |
|
| 194 | +572 | ! |
- "Use the slider to choose the cut-off value to define outliers.",+ color = "red" |
|
| 195 | -! | +|||
| 573 | +
- "Points with a Cook's distance greater than",+ ), |
|||
| 196 | +574 | ! |
- "the value on the slider times the mean of the Cook's distance of the dataset will have labels."+ env = list(plot = plot, label_col = label_col()) |
|
| 197 | +575 |
- )+ ) |
||
| 198 | +576 |
- )+ } |
||
| 199 | +577 |
- )+ |
||
| 200 | -+ | |||
| 578 | +! |
- ),+ parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args( |
||
| 201 | +579 | ! |
- min = 1, max = 10, value = 9, ticks = FALSE, step = .1+ teal.widgets::resolve_ggplot2_args( |
|
| 202 | -+ | |||
| 580 | +! |
- ),+ user_plot = ggplot2_args[["Normal Q-Q"]], |
||
| 203 | +581 | ! |
- teal.widgets::optionalSelectInput(+ user_default = ggplot2_args$default, |
|
| 204 | +582 | ! |
- ns("label_var"),
+ module_plot = teal.widgets::ggplot2_args( |
|
| 205 | +583 | ! |
- multiple = FALSE,+ labs = list( |
|
| 206 | +584 | ! |
- label = "Outlier label"+ x = quote(paste0("Theoretical Quantiles\nlm(", reg_form, ")")),
+ |
+ |
| 585 | +! | +
+ y = "Standardized residuals",+ |
+ ||
| 586 | +! | +
+ title = "Normal Q-Q" |
||
| 207 | +587 |
- )+ ) |
||
| 208 | +588 |
- ),+ ) |
||
| 209 | -! | +|||
| 589 | +
- teal.widgets::panel_group(+ ), |
|||
| 210 | +590 | ! |
- teal.widgets::panel_item(+ ggtheme = ggtheme |
|
| 211 | -! | +|||
| 591 | +
- title = "Plot settings",+ )+ |
+ |||
| 592 | ++ | + | ||
| 212 | +593 | ! |
- teal.widgets::optionalSliderInputValMinMax(ns("alpha"), "Opacity:", args$alpha, ticks = FALSE),
+ teal.code::eval_code( |
|
| 213 | +594 | ! |
- teal.widgets::optionalSliderInputValMinMax(ns("size"), "Points size:", args$size, ticks = FALSE),
+ plot_base, |
|
| 214 | +595 | ! |
- selectInput(+ substitute( |
|
| 215 | +596 | ! |
- inputId = ns("ggtheme"),
+ expr = {
|
|
| 216 | +597 | ! |
- label = "Theme (by ggplot):",+ g <- plot |
|
| 217 | +598 | ! |
- choices = ggplot_themes,+ print(g)+ |
+ |
| 599 | ++ |
+ }, |
||
| 218 | +600 | ! |
- selected = args$ggtheme,+ env = list( |
|
| 219 | +601 | ! |
- multiple = FALSE+ plot = Reduce(function(x, y) call("+", x, y), c(plot, parsed_ggplot2_args))
|
|
| 220 | +602 | ++ |
+ )+ |
+ |
| 603 |
) |
|||
| 221 | +604 |
) |
||
| 222 | +605 |
- )+ } |
||
| 223 | +606 |
- ),+ |
||
| 224 | +607 | ! |
- forms = tagList(+ plot_type_3 <- function(plot_base) {
|
|
| 225 | +608 | ! |
- teal.widgets::verbatim_popup_ui(ns("warning"), "Show Warnings"),
+ shinyjs::show("size")
|
|
| 226 | +609 | ! |
- teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code")
- |
- |
| 227 | -- |
- ),+ shinyjs::show("alpha")
|
||
| 228 | +610 | ! |
- pre_output = args$pre_output,+ plot <- substitute( |
|
| 229 | +611 | ! |
- post_output = args$post_output- |
- |
| 230 | -- |
- )- |
- ||
| 231 | -- |
- }+ expr = ggplot(data = data, aes(.fitted, sqrt(abs(.stdresid)))) + |
||
| 232 | -+ | |||
| 612 | +! |
-
+ geom_point(size = size, alpha = alpha) + |
||
| 233 | -+ | |||
| 613 | +! |
-
+ geom_line(data = smoothy, mapping = smoothy_aes), |
||
| 234 | -+ | |||
| 614 | +! |
- srv_a_regression <- function(id,+ env = list(size = size, alpha = alpha) |
||
| 235 | +615 |
- data,+ ) |
||
| 236 | -+ | |||
| 616 | +! |
- reporter,+ if (show_outlier) {
|
||
| 237 | -+ | |||
| 617 | +! |
- filter_panel_api,+ plot <- substitute(expr = plot + outlier_label, env = list(plot = plot, outlier_label = outlier_label())) |
||
| 238 | +618 |
- response,+ } |
||
| 239 | +619 |
- regressor,+ |
||
| 240 | -+ | |||
| 620 | +! |
- plot_height,+ parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args( |
||
| 241 | -+ | |||
| 621 | +! |
- plot_width,+ teal.widgets::resolve_ggplot2_args( |
||
| 242 | -+ | |||
| 622 | +! |
- ggplot2_args,+ user_plot = ggplot2_args[["Scale-Location"]], |
||
| 243 | -+ | |||
| 623 | +! |
- default_outlier_label) {
+ user_default = ggplot2_args$default, |
||
| 244 | +624 | ! |
- with_reporter <- !missing(reporter) && inherits(reporter, "Reporter")+ module_plot = teal.widgets::ggplot2_args( |
|
| 245 | +625 | ! |
- with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI")+ labs = list( |
|
| 246 | +626 | ! |
- checkmate::assert_class(data, "reactive")+ x = quote(paste0("Fitted values\nlm(", reg_form, ")")),
|
|
| 247 | +627 | ! |
- checkmate::assert_class(isolate(data()), "teal_data")+ y = quote(expression(sqrt(abs(`Standardized residuals`)))), |
|
| 248 | +628 | ! |
- moduleServer(id, function(input, output, session) {
+ title = "Scale-Location" |
|
| 249 | -! | +|||
| 629 | +
- rule_rvr1 <- function(value) {
+ ) |
|||
| 250 | -! | +|||
| 630 | +
- if (isTRUE(input$plot_type == "Response vs Regressor")) {
+ ) |
|||
| 251 | -! | +|||
| 631 | +
- if (length(value) > 1L) {
+ ), |
|||
| 252 | +632 | ! |
- "This plot can only have one regressor."+ ggtheme = ggtheme |
|
| 253 | +633 |
- }+ ) |
||
| 254 | +634 |
- }+ |
||
| 255 | -+ | |||
| 635 | +! |
- }+ teal.code::eval_code( |
||
| 256 | +636 | ! |
- rule_rvr2 <- function(other) {
+ plot_base, |
|
| 257 | +637 | ! |
- function(value) {
+ substitute( |
|
| 258 | +638 | ! |
- if (isTRUE(input$plot_type == "Response vs Regressor")) {
+ expr = {
|
|
| 259 | +639 | ! |
- otherval <- selector_list()[[other]]()$select+ smoothy <- smooth(data$.fitted, sqrt(abs(data$.stdresid))) |
|
| 260 | +640 | ! |
- if (isTRUE(value == otherval)) {
+ g <- plot |
|
| 261 | +641 | ! |
- "Response and Regressor must be different."+ print(g) |
|
| 262 | +642 |
- }+ },+ |
+ ||
| 643 | +! | +
+ env = list(+ |
+ ||
| 644 | +! | +
+ plot = Reduce(function(x, y) call("+", x, y), c(plot, parsed_ggplot2_args))
|
||
| 263 | +645 |
- }+ ) |
||
| 264 | +646 |
- }+ ) |
||
| 265 | +647 |
- }+ ) |
||
| 266 | +648 |
-
+ } |
||
| 267 | -! | +|||
| 649 | +
- selector_list <- teal.transform::data_extract_multiple_srv(+ |
|||
| 268 | +650 | ! |
- data_extract = list(response = response, regressor = regressor),+ plot_type_4 <- function(plot_base) {
|
|
| 269 | +651 | ! |
- datasets = data,+ shinyjs::hide("size")
|
|
| 270 | +652 | ! |
- select_validation_rule = list(+ shinyjs::show("alpha")
|
|
| 271 | +653 | ! |
- regressor = shinyvalidate::compose_rules(+ plot <- substitute( |
|
| 272 | +654 | ! |
- shinyvalidate::sv_required("At least one regressor should be selected."),
+ expr = ggplot(data = data, aes(seq_along(.cooksd), .cooksd)) + |
|
| 273 | +655 | ! |
- rule_rvr1,+ geom_col(alpha = alpha), |
|
| 274 | +656 | ! |
- rule_rvr2("response")
+ env = list(alpha = alpha) |
|
| 275 | +657 |
- ),+ ) |
||
| 276 | +658 | ! |
- response = shinyvalidate::compose_rules(+ if (show_outlier) {
|
|
| 277 | +659 | ! |
- shinyvalidate::sv_required("At least one response should be selected."),
+ plot <- substitute( |
|
| 278 | +660 | ! |
- rule_rvr2("regressor")
- |
- |
| 279 | -- |
- )- |
- ||
| 280 | -- |
- )+ expr = plot + |
||
| 281 | -+ | |||
| 661 | +! |
- )+ geom_hline( |
||
| 282 | -+ | |||
| 662 | +! |
-
+ yintercept = c( |
||
| 283 | +663 | ! |
- iv_r <- reactive({
+ outlier * mean(data$.cooksd, na.rm = TRUE), |
|
| 284 | +664 | ! |
- iv <- shinyvalidate::InputValidator$new()+ mean(data$.cooksd, na.rm = TRUE)+ |
+ |
| 665 | ++ |
+ ), |
||
| 285 | +666 | ! |
- teal.transform::compose_and_enable_validators(iv, selector_list)+ color = "red", |
|
| 286 | -+ | |||
| 667 | +! |
- })+ linetype = "dashed" |
||
| 287 | +668 |
-
+ ) + |
||
| 288 | +669 | ! |
- iv_out <- shinyvalidate::InputValidator$new()+ geom_text( |
|
| 289 | +670 | ! |
- iv_out$condition(~ isTRUE(input$show_outlier))+ aes( |
|
| 290 | +671 | ! |
- iv_out$add_rule("label_var", shinyvalidate::sv_required("Please provide an `Outlier label` variable"))
+ x = 0, |
|
| 291 | +672 | ! |
- iv_out$enable()+ y = mean(data$.cooksd, na.rm = TRUE), |
|
| 292 | -+ | |||
| 673 | +! |
-
+ label = paste("mu", "=", round(mean(data$.cooksd, na.rm = TRUE), 4)),
|
||
| 293 | +674 | ! |
- anl_merged_input <- teal.transform::merge_expression_srv(+ vjust = -1, |
|
| 294 | +675 | ! |
- selector_list = selector_list,+ hjust = 0, |
|
| 295 | +676 | ! |
- datasets = data+ color = "red", |
|
| 296 | -+ | |||
| 677 | +! |
- )+ angle = 90 |
||
| 297 | +678 |
-
+ ), |
||
| 298 | +679 | ! |
- regression_var <- reactive({
+ parse = TRUE, |
|
| 299 | +680 | ! |
- teal::validate_inputs(iv_r())+ show.legend = FALSE |
|
| 300 | +681 | - - | -||
| 301 | -! | -
- list(+ ) + |
||
| 302 | +682 | ! |
- response = as.vector(anl_merged_input()$columns_source$response),+ outlier_label, |
|
| 303 | +683 | ! |
- regressor = as.vector(anl_merged_input()$columns_source$regressor)+ env = list(plot = plot, outlier = input$outlier, outlier_label = outlier_label()) |
|
| 304 | +684 |
- )+ ) |
||
| 305 | +685 |
- })+ } |
||
| 306 | +686 | |||
| 307 | +687 | ! |
- anl_merged_q <- reactive({
+ parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args( |
|
| 308 | +688 | ! |
- req(anl_merged_input())+ teal.widgets::resolve_ggplot2_args( |
|
| 309 | +689 | ! |
- data() %>%+ user_plot = ggplot2_args[["Cook's distance"]], |
|
| 310 | +690 | ! |
- teal.code::eval_code(as.expression(anl_merged_input()$expr))- |
- |
| 311 | -- |
- })- |
- ||
| 312 | -- | - - | -||
| 313 | -- |
- # sets qenv object and populates it with data merge call and fit expression+ user_default = ggplot2_args$default, |
||
| 314 | +691 | ! |
- fit_r <- reactive({
+ module_plot = teal.widgets::ggplot2_args( |
|
| 315 | +692 | ! |
- ANL <- anl_merged_q()[["ANL"]] # nolint object_name_linter+ labs = list( |
|
| 316 | +693 | ! |
- teal::validate_has_data(ANL, 10)+ x = quote(paste0("Obs. number\nlm(", reg_form, ")")),
|
|
| 317 | -+ | |||
| 694 | +! |
-
+ y = "Cook's distance", |
||
| 318 | +695 | ! |
- validate(need(is.numeric(ANL[regression_var()$response][[1]]), "Response variable should be numeric."))+ title = "Cook's distance" |
|
| 319 | +696 |
-
+ ) |
||
| 320 | -! | +|||
| 697 | +
- teal::validate_has_data(+ ) |
|||
| 321 | -! | +|||
| 698 | +
- ANL[, c(regression_var()$response, regression_var()$regressor)], 10,+ ), |
|||
| 322 | +699 | ! |
- complete = TRUE, allow_inf = FALSE+ ggtheme = ggtheme |
|
| 323 | +700 |
- )+ ) |
||
| 324 | +701 | |||
| 325 | +702 | ! |
- form <- stats::as.formula(+ teal.code::eval_code( |
|
| 326 | +703 | ! |
- paste(+ plot_base, |
|
| 327 | +704 | ! |
- regression_var()$response,+ substitute( |
|
| 328 | +705 | ! |
- paste(+ expr = {
|
|
| 329 | +706 | ! |
- regression_var()$regressor,+ g <- plot |
|
| 330 | +707 | ! |
- collapse = " + "+ print(g) |
|
| 331 | +708 |
- ),+ }, |
||
| 332 | +709 | ! |
- sep = " ~ "+ env = list( |
|
| 333 | -+ | |||
| 710 | +! |
- )+ plot = Reduce(function(x, y) call("+", x, y), c(plot, parsed_ggplot2_args))
|
||
| 334 | +711 |
- )+ ) |
||
| 335 | +712 | - - | -||
| 336 | -! | -
- if (input$show_outlier) {
+ ) |
||
| 337 | -! | +|||
| 713 | +
- opts <- teal.transform::variable_choices(ANL)+ ) |
|||
| 338 | -! | +|||
| 714 | +
- selected <- if (!is.null(isolate(input$label_var)) && isolate(input$label_var) %in% as.character(opts)) {
+ } |
|||
| 339 | -! | +|||
| 715 | +
- isolate(input$label_var)+ |
|||
| 340 | +716 |
- } else {
+
|
||
| 341 | +717 | ! |
- if (length(opts[as.character(opts) == default_outlier_label]) == 0) {
+ plot_type_5 <- function(plot_base) {
|
|
| 342 | +718 | ! |
- opts[[1]]- |
- |
| 343 | -- |
- } else {
+ shinyjs::show("size")
|
||
| 344 | +719 | ! |
- opts[as.character(opts) == default_outlier_label]+ shinyjs::show("alpha")
|
|
| 345 | -+ | |||
| 720 | +! |
- }+ plot <- substitute( |
||
| 346 | -+ | |||
| 721 | +! |
- }+ expr = ggplot(data = data, aes(.hat, .stdresid)) + |
||
| 347 | +722 | ! |
- teal.widgets::updateOptionalSelectInput(+ geom_vline( |
|
| 348 | +723 | ! |
- session = session,+ size = 1, |
|
| 349 | +724 | ! |
- inputId = "label_var",+ colour = "black", |
|
| 350 | +725 | ! |
- choices = opts,+ linetype = "dashed", |
|
| 351 | +726 | ! |
- selected = selected+ xintercept = 0 |
|
| 352 | +727 |
- )+ ) + |
||
| 353 | -+ | |||
| 728 | +! |
-
+ geom_hline( |
||
| 354 | +729 | ! |
- data <- fortify(stats::lm(form, data = ANL))+ size = 1, |
|
| 355 | +730 | ! |
- cooksd <- data$.cooksd[!is.nan(data$.cooksd)]+ colour = "black", |
|
| 356 | +731 | ! |
- max_outlier <- max(ceiling(max(cooksd) / mean(cooksd)), 2)+ linetype = "dashed", |
|
| 357 | +732 | ! |
- cur_outlier <- isolate(input$outlier)+ yintercept = 0 |
|
| 358 | -! | +|||
| 733 | +
- updateSliderInput(+ ) + |
|||
| 359 | +734 | ! |
- session = session,+ geom_point(size = size, alpha = alpha) + |
|
| 360 | +735 | ! |
- inputId = "outlier",+ geom_line(data = smoothy, mapping = smoothy_aes), |
|
| 361 | +736 | ! |
- min = 1,+ env = list(size = size, alpha = alpha)+ |
+ |
| 737 | ++ |
+ ) |
||
| 362 | +738 | ! |
- max = max_outlier,+ if (show_outlier) {
|
|
| 363 | +739 | ! |
- value = if (cur_outlier < max_outlier) cur_outlier else max_outlier * .9+ plot <- substitute(expr = plot + outlier_label, env = list(plot = plot, outlier_label = outlier_label())) |
|
| 364 | +740 |
- )+ } |
||
| 365 | +741 |
- }+ |
||
| 366 | -+ | |||
| 742 | +! |
-
+ parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args( |
||
| 367 | +743 | ! |
- anl_merged_q() %>%+ teal.widgets::resolve_ggplot2_args( |
|
| 368 | +744 | ! |
- teal.code::eval_code(substitute(fit <- stats::lm(form, data = ANL), env = list(form = form))) %>%+ user_plot = ggplot2_args[["Residuals vs Leverage"]], |
|
| 369 | +745 | ! |
- teal.code::eval_code(quote({
+ user_default = ggplot2_args$default, |
|
| 370 | +746 | ! |
- for (regressor in names(fit$contrasts)) {
+ module_plot = teal.widgets::ggplot2_args( |
|
| 371 | +747 | ! |
- alts <- paste0(levels(ANL[[regressor]]), collapse = "|")+ labs = list( |
|
| 372 | +748 | ! |
- names(fit$coefficients) <- gsub(+ x = quote(paste0("Standardized residuals\nlm(", reg_form, ")")),
|
|
| 373 | +749 | ! |
- paste0("^(", regressor, ")(", alts, ")$"), paste0("\\1", ": ", "\\2"), names(fit$coefficients)
+ y = "Leverage",+ |
+ |
| 750 | +! | +
+ title = "Residuals vs Leverage" |
||
| 374 | +751 |
- )+ ) |
||
| 375 | +752 |
- }+ ) |
||
| 376 | +753 |
- })) %>%+ ), |
||
| 377 | +754 | ! |
- teal.code::eval_code(quote(summary(fit)))+ ggtheme = ggtheme |
|
| 378 | +755 |
- })+ ) |
||
| 379 | +756 | |||
| 380 | +757 | ! |
- label_col <- reactive({
+ teal.code::eval_code( |
|
| 381 | -! | -
- teal::validate_inputs(iv_out)- |
- ||
| 382 | -+ | 758 | +! |
-
+ plot_base, |
| 383 | +759 | ! |
- substitute(+ substitute( |
|
| 384 | +760 | ! |
- expr = dplyr::if_else(+ expr = {
|
|
| 385 | +761 | ! |
- data$.cooksd > outliers * mean(data$.cooksd, na.rm = TRUE),+ smoothy <- smooth(data$.hat, data$.stdresid) |
|
| 386 | +762 | ! |
- as.character(stats::na.omit(ANL)[[label_var]]),+ g <- plot |
|
| 387 | -+ | |||
| 763 | +! |
- ""+ print(g) |
||
| 388 | +764 |
- ) %>%+ }, |
||
| 389 | +765 | ! |
- dplyr::if_else(is.na(.), "cooksd == NaN", .),+ env = list( |
|
| 390 | +766 | ! |
- env = list(outliers = input$outlier, label_var = input$label_var)+ plot = Reduce(function(x, y) call("+", x, y), c(plot, parsed_ggplot2_args))
|
|
| 391 | +767 |
- )+ ) |
||
| 392 | +768 |
- })+ ) |
||
| 393 | +769 | ++ |
+ )+ |
+ |
| 770 | ++ |
+ }+ |
+ ||
| 771 | ||||
| 394 | +772 | ! |
- outlier_label <- reactive({
+ plot_type_6 <- function(plot_base) {
|
|
| 395 | +773 | ! |
- substitute(+ shinyjs::show("size")
|
|
| 396 | +774 | ! |
- expr = geom_text(label = label_col, hjust = 0, vjust = 1, color = "red"),+ shinyjs::show("alpha")
|
|
| 397 | +775 | ! |
- env = list(label_col = label_col())+ plot <- substitute( |
|
| 398 | -+ | |||
| 776 | +! |
- )+ expr = ggplot(data = data, aes(.hat, .cooksd)) + |
||
| 399 | -+ | |||
| 777 | +! |
- })+ geom_vline(xintercept = 0, colour = NA) + |
||
| 400 | -+ | |||
| 778 | +! |
-
+ geom_abline( |
||
| 401 | +779 | ! |
- output_q <- reactive({
+ slope = seq(0, 3, by = 0.5), |
|
| 402 | +780 | ! |
- alpha <- input$alpha+ colour = "black", |
|
| 403 | +781 | ! |
- size <- input$size+ linetype = "dashed", |
|
| 404 | +782 | ! |
- ggtheme <- input$ggtheme+ size = 1 |
|
| 405 | -! | +|||
| 783 | +
- input_type <- input$plot_type+ ) + |
|||
| 406 | +784 | ! |
- show_outlier <- input$show_outlier+ geom_line(data = smoothy, mapping = smoothy_aes) + |
|
| 407 | -+ | |||
| 785 | +! |
-
+ geom_point(size = size, alpha = alpha), |
||
| 408 | +786 | ! |
- teal::validate_inputs(iv_r())+ env = list(size = size, alpha = alpha) |
|
| 409 | +787 |
-
+ ) |
||
| 410 | +788 | ! |
- plot_type_0 <- function() {
+ if (show_outlier) {
|
|
| 411 | +789 | ! |
- fit <- fit_r()[["fit"]]+ plot <- substitute(expr = plot + outlier_label, env = list(plot = plot, outlier_label = outlier_label())) |
|
| 412 | -! | +|||
| 790 | +
- ANL <- anl_merged_q()[["ANL"]] # nolint object_name_linter+ } |
|||
| 413 | +791 | |||
| 414 | +792 | ! |
- stopifnot(ncol(fit$model) == 2)+ parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args( |
|
| 415 | -+ | |||
| 793 | +! |
-
+ teal.widgets::resolve_ggplot2_args( |
||
| 416 | +794 | ! |
- if (!is.factor(ANL[[regression_var()$regressor]])) {
+ user_plot = ggplot2_args[["Cook's dist vs Leverage"]], |
|
| 417 | +795 | ! |
- shinyjs::show("size")
+ user_default = ggplot2_args$default, |
|
| 418 | +796 | ! |
- shinyjs::show("alpha")
+ module_plot = teal.widgets::ggplot2_args( |
|
| 419 | +797 | ! |
- plot <- substitute(+ labs = list( |
|
| 420 | +798 | ! |
- env = list(+ x = quote(paste0("Leverage\nlm(", reg_form, ")")),
|
|
| 421 | +799 | ! |
- regressor = regression_var()$regressor,+ y = "Cooks's distance", |
|
| 422 | +800 | ! |
- response = regression_var()$response,+ title = "Cook's dist vs Leverage" |
|
| 423 | -! | +|||
| 801 | +
- size = size,+ )+ |
+ |||
| 802 | ++ |
+ )+ |
+ ||
| 803 | ++ |
+ ), |
||
| 424 | +804 | ! |
- alpha = alpha+ ggtheme = ggtheme |
|
| 425 | +805 |
- ),+ )+ |
+ ||
| 806 | ++ | + | ||
| 426 | +807 | ! |
- expr = ggplot(+ teal.code::eval_code( |
|
| 427 | +808 | ! |
- fit$model[, 2:1],+ plot_base, |
|
| 428 | +809 | ! |
- aes_string(regressor, response)+ substitute( |
|
| 429 | -+ | |||
| 810 | +! |
- ) ++ expr = {
|
||
| 430 | +811 | ! |
- geom_point(size = size, alpha = alpha) ++ smoothy <- smooth(data$.hat, data$.cooksd) |
|
| 431 | +812 | ! |
- stat_smooth(+ g <- plot |
|
| 432 | +813 | ! |
- method = "lm",+ print(g)+ |
+ |
| 814 | ++ |
+ }, |
||
| 433 | +815 | ! |
- formula = y ~ x,+ env = list( |
|
| 434 | +816 | ! |
- se = FALSE+ plot = Reduce(function(x, y) call("+", x, y), c(plot, parsed_ggplot2_args))
|
|
| 435 | +817 |
- )+ ) |
||
| 436 | +818 |
) |
||
| 437 | -! | +|||
| 819 | +
- if (show_outlier) {
+ ) |
|||
| 438 | -! | +|||
| 820 | +
- plot <- substitute(+ }+ |
+ |||
| 821 | ++ | + | ||
| 439 | +822 | ! |
- expr = plot + outlier_label,+ qenv <- if (input_type == "Response vs Regressor") {
|
|
| 440 | +823 | ! |
- env = list(plot = plot, outlier_label = outlier_label())+ plot_type_0() |
|
| 441 | +824 |
- )+ } else {
|
||
| 442 | -+ | |||
| 825 | +! |
- }+ plot_base_q <- plot_base() |
||
| 443 | -+ | |||
| 826 | +! |
- } else {
+ switch(input_type, |
||
| 444 | +827 | ! |
- shinyjs::hide("size")
+ "Residuals vs Fitted" = plot_base_q %>% plot_type_1(), |
|
| 445 | +828 | ! |
- shinyjs::hide("alpha")
+ "Normal Q-Q" = plot_base_q %>% plot_type_2(), |
|
| 446 | +829 | ! |
- plot <- substitute(+ "Scale-Location" = plot_base_q %>% plot_type_3(), |
|
| 447 | +830 | ! |
- expr = ggplot(fit$model[, 2:1], aes_string(regressor, response)) ++ "Cook's distance" = plot_base_q %>% plot_type_4(), |
|
| 448 | +831 | ! |
- geom_boxplot(),+ "Residuals vs Leverage" = plot_base_q %>% plot_type_5(), |
|
| 449 | +832 | ! |
- env = list(regressor = regression_var()$regressor, response = regression_var()$response)+ "Cook's dist vs Leverage" = plot_base_q %>% plot_type_6() |
|
| 450 | +833 |
- )+ ) |
||
| 451 | -! | +|||
| 834 | +
- if (show_outlier) {
+ } |
|||
| 452 | +835 | ! |
- plot <- substitute(expr = plot + outlier_label, env = list(plot = plot, outlier_label = outlier_label()))+ qenv |
|
| 453 | +836 |
- }+ }) |
||
| 454 | +837 |
- }+ |
||
| 455 | +838 | |||
| 456 | +839 | ! |
- parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(+ fitted <- reactive(output_q()[["fit"]]) |
|
| 457 | +840 | ! |
- teal.widgets::resolve_ggplot2_args(+ plot_r <- reactive(output_q()[["g"]]) |
|
| 458 | -! | +|||
| 841 | +
- user_plot = ggplot2_args[["Response vs Regressor"]],+ |
|||
| 459 | -! | +|||
| 842 | +
- user_default = ggplot2_args$default,+ # Insert the plot into a plot_with_settings module from teal.widgets |
|||
| 460 | +843 | ! |
- module_plot = teal.widgets::ggplot2_args(+ pws <- teal.widgets::plot_with_settings_srv( |
|
| 461 | +844 | ! |
- labs = list(+ id = "myplot", |
|
| 462 | +845 | ! |
- title = "Response vs Regressor",+ plot_r = plot_r, |
|
| 463 | +846 | ! |
- x = varname_w_label(regression_var()$regressor, ANL),+ height = plot_height, |
|
| 464 | +847 | ! |
- y = varname_w_label(regression_var()$response, ANL)+ width = plot_width |
|
| 465 | +848 |
- ),+ )+ |
+ ||
| 849 | ++ | + | ||
| 466 | +850 | ! |
- theme = list()+ output$text <- renderText({
|
|
| 467 | -+ | |||
| 851 | +! |
- )+ req(iv_r()$is_valid()) |
||
| 468 | -+ | |||
| 852 | +! |
- ),+ req(iv_out$is_valid()) |
||
| 469 | +853 | ! |
- ggtheme = ggtheme+ paste(utils::capture.output(summary(teal.code::dev_suppress(fitted())))[-1], |
|
| 470 | -+ | |||
| 854 | +! |
- )+ collapse = "\n" |
||
| 471 | +855 |
-
+ ) |
||
| 472 | -! | +|||
| 856 | +
- teal.code::eval_code(+ }) |
|||
| 473 | -! | +|||
| 857 | +
- fit_r(),+ |
|||
| 474 | +858 | ! |
- substitute(+ teal.widgets::verbatim_popup_srv( |
|
| 475 | +859 | ! |
- expr = {
+ id = "warning", |
|
| 476 | +860 | ! |
- class(fit$residuals) <- NULL+ verbatim_content = reactive(teal.code::get_warnings(output_q())), |
|
| 477 | +861 | ! |
- data <- fortify(fit)+ title = "Warning", |
|
| 478 | +862 | ! |
- g <- plot+ disabled = reactive(is.null(teal.code::get_warnings(output_q()))) |
|
| 479 | -! | +|||
| 863 | +
- print(g)+ ) |
|||
| 480 | +864 |
- },+ |
||
| 481 | +865 | ! |
- env = list(+ teal.widgets::verbatim_popup_srv( |
|
| 482 | +866 | ! |
- plot = Reduce(function(x, y) call("+", x, y), c(plot, parsed_ggplot2_args))
+ id = "rcode", |
|
| 483 | -+ | |||
| 867 | +! |
- )+ verbatim_content = reactive(teal.code::get_code(output_q())), |
||
| 484 | -+ | |||
| 868 | +! |
- )+ title = "R code for the regression plot", |
||
| 485 | +869 |
- )+ ) |
||
| 486 | +870 |
- }+ |
||
| 487 | +871 |
-
+ ### REPORTER |
||
| 488 | +872 | ! |
- plot_base <- function() {
+ if (with_reporter) {
|
|
| 489 | +873 | ! |
- base_fit <- fit_r()+ card_fun <- function(comment, label) {
|
|
| 490 | +874 | ! |
- teal.code::eval_code(+ card <- teal::report_card_template( |
|
| 491 | +875 | ! |
- base_fit,+ title = "Linear Regression Plot", |
|
| 492 | +876 | ! |
- quote({
+ label = label, |
|
| 493 | +877 | ! |
- class(fit$residuals) <- NULL+ with_filter = with_filter,+ |
+ |
| 878 | +! | +
+ filter_panel_api = filter_panel_api |
||
| 494 | +879 |
-
+ ) |
||
| 495 | +880 | ! |
- data <- ggplot2::fortify(fit)+ card$append_text("Plot", "header3")
|
|
| 496 | -+ | |||
| 881 | +! |
-
+ card$append_plot(plot_r(), dim = pws$dim()) |
||
| 497 | +882 | ! |
- smooth <- function(x, y) {
+ if (!comment == "") {
|
|
| 498 | +883 | ! |
- as.data.frame(stats::lowess(x, y, f = 2 / 3, iter = 3))+ card$append_text("Comment", "header3")
|
|
| 499 | -+ | |||
| 884 | +! |
- }+ card$append_text(comment) |
||
| 500 | +885 |
-
+ } |
||
| 501 | +886 | ! |
- smoothy_aes <- ggplot2::aes_string(x = "x", y = "y")+ card$append_src(teal.code::get_code(output_q()))+ |
+ |
| 887 | +! | +
+ card |
||
| 502 | +888 |
-
+ } |
||
| 503 | +889 | ! |
- reg_form <- deparse(fit$call[[2]])+ teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
|
|
| 504 | +890 |
- })+ } |
||
| 505 | +891 |
- )+ ### |
||
| 506 | +892 |
- }+ }) |
||
| 507 | +893 | - - | -||
| 508 | -! | -
- plot_type_1 <- function(plot_base) {
- |
- ||
| 509 | -! | -
- shinyjs::show("size")
+ } |
||
| 510 | -! | +|||
| 894 | +
- shinyjs::show("alpha")
+
|
|||
| 511 | -! | +|||
| 895 | +
- plot <- substitute(+ regression_names <- paste0( |
|||
| 512 | -! | +|||
| 896 | +
- expr = ggplot(data = data, aes(.fitted, .resid)) ++ '"Response vs Regressor", "Residuals vs Fitted", ', |
|||
| 513 | -! | +|||
| 897 | +
- geom_point(size = size, alpha = alpha) ++ '"Scale-Location", "Cook\'s distance", "Residuals vs Leverage"", "Cook\'s dist vs Leverage"' |
|||
| 514 | -! | +|||
| 898 | +
- geom_hline(yintercept = 0, linetype = "dashed", size = 1) ++ ) |
|||
| 515 | -! | +
| 1 | +
- geom_line(data = smoothy, mapping = smoothy_aes),+ #' Create a simple scatterplot |
||
| 516 | -! | +||
| 2 | +
- env = list(size = size, alpha = alpha)+ #' |
||
| 517 | +3 |
- )+ #' Create a plot with the \code{\link{ggplot2}[geom_point]} function
|
|
| 518 | -! | +||
| 4 | +
- if (show_outlier) {
+ #' @md |
||
| 519 | -! | +||
| 5 | +
- plot <- substitute(expr = plot + outlier_label, env = list(plot = plot, outlier_label = outlier_label()))+ #' |
||
| 520 | +6 |
- }+ #' @inheritParams teal::module |
|
| 521 | +7 |
-
+ #' @inheritParams shared_params |
|
| 522 | -! | +||
| 8 | +
- parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(+ #' @param x (`data_extract_spec` or `list` of multiple `data_extract_spec`) Variable |
||
| 523 | -! | +||
| 9 | +
- teal.widgets::resolve_ggplot2_args(+ #' names selected to plot along the x-axis by default. |
||
| 524 | -! | +||
| 10 | +
- user_plot = ggplot2_args[["Residuals vs Fitted"]],+ #' @param y (`data_extract_spec` or `list` of multiple `data_extract_spec`) Variable |
||
| 525 | -! | +||
| 11 | +
- user_default = ggplot2_args$default,+ #' names selected to plot along the y-axis by default. |
||
| 526 | -! | +||
| 12 | +
- module_plot = teal.widgets::ggplot2_args(+ #' @param color_by optional (`data_extract_spec` or `list` of multiple `data_extract_spec`) |
||
| 527 | -! | +||
| 13 | +
- labs = list(+ #' Defines the color encoding. If `NULL` then no color encoding option will be displayed. |
||
| 528 | -! | +||
| 14 | +
- x = quote(paste0("Fitted values\nlm(", reg_form, ")")),
+ #' @param size_by optional (`data_extract_spec` or `list` of multiple `data_extract_spec`) |
||
| 529 | -! | +||
| 15 | +
- y = "Residuals",+ #' Defines the point size encoding. If `NULL` then no size encoding option will be displayed. |
||
| 530 | -! | +||
| 16 | +
- title = "Residuals vs Fitted"+ #' @param row_facet optional, (`data_extract_spec` or `list` of multiple `data_extract_spec`) |
||
| 531 | +17 |
- )+ #' Which data columns to use for faceting rows. |
|
| 532 | +18 |
- )+ #' @param col_facet optional, (`data_extract_spec` or `list` of multiple `data_extract_spec`) |
|
| 533 | +19 |
- ),+ #' Which data to use for faceting columns. |
|
| 534 | -! | +||
| 20 | +
- ggtheme = ggtheme+ #' @param alpha optional, (`numeric`) If scalar then the plot points will have a fixed opacity. If a |
||
| 535 | +21 |
- )+ #' slider should be presented to adjust the plot point opacity dynamically then it can be a vector of |
|
| 536 | +22 |
-
+ #' length three with `c(value, min, max)`. |
|
| 537 | -! | +||
| 23 | +
- teal.code::eval_code(+ #' @param size optional, (`numeric`) If scalar then the plot point sizes will have a fixed size |
||
| 538 | -! | +||
| 24 | +
- plot_base,+ #' If a slider should be presented to adjust the plot point sizes dynamically then it can be a |
||
| 539 | -! | +||
| 25 | +
- substitute(+ #' vector of length three with `c(value, min, max)`. |
||
| 540 | -! | +||
| 26 | +
- expr = {
+ #' @param shape optional, (`character`) A character vector with the English names of the |
||
| 541 | -! | +||
| 27 | +
- smoothy <- smooth(data$.fitted, data$.resid)+ #' shape, e.g. `c("triangle", "square", "circle")`. It defaults to `shape_names`. This is a complete list from
|
||
| 542 | -! | +||
| 28 | +
- g <- plot+ #' `vignette("ggplot2-specs", package="ggplot2")`.
|
||
| 543 | -! | +||
| 29 | +
- print(g)+ #' @param max_deg optional, (`integer`) The maximum degree for the polynomial trend line. Must not be less than 1. |
||
| 544 | +30 |
- },+ #' @param table_dec optional, (`integer`) Number of decimal places used to round numeric values in the table. |
|
| 545 | -! | +||
| 31 | +
- env = list(+ #' |
||
| 546 | -! | +||
| 32 | +
- plot = Reduce(function(x, y) call("+", x, y), c(plot, parsed_ggplot2_args))
+ #' |
||
| 547 | +33 |
- )+ #' @note For more examples, please see the vignette "Using scatterplot" via |
|
| 548 | +34 |
- )+ #' `vignette("using-scatterplot", package = "teal.modules.general")`.
|
|
| 549 | +35 |
- )+ #' |
|
| 550 | +36 |
- }+ #' @export |
|
| 551 | +37 |
-
+ #' @examples |
|
| 552 | -! | +||
| 38 | +
- plot_type_2 <- function(plot_base) {
+ #' # Scatterplot of variables from ADSL dataset |
||
| 553 | -! | +||
| 39 | +
- shinyjs::show("size")
+ #' |
||
| 554 | -! | +||
| 40 | +
- shinyjs::show("alpha")
+ #' data <- teal_data() |
||
| 555 | -! | +||
| 41 | +
- plot <- substitute(+ #' data <- within(data, {
|
||
| 556 | -! | +||
| 42 | +
- expr = ggplot(data = data, aes(sample = .stdresid)) ++ #' library(nestcolor) |
||
| 557 | -! | +||
| 43 | +
- stat_qq(size = size, alpha = alpha) ++ #' ADSL <- teal.modules.general::rADSL |
||
| 558 | -! | +||
| 44 | +
- geom_abline(linetype = "dashed"),+ #' }) |
||
| 559 | -! | +||
| 45 | +
- env = list(size = size, alpha = alpha)+ #' datanames <- c("ADSL")
|
||
| 560 | +46 |
- )+ #' datanames(data) <- datanames |
|
| 561 | -! | +||
| 47 | +
- if (show_outlier) {
+ #' join_keys(data) <- default_cdisc_join_keys[datanames] |
||
| 562 | -! | +||
| 48 | +
- plot <- substitute(+ #' |
||
| 563 | -! | +||
| 49 | +
- expr = plot ++ #' app <- teal::init( |
||
| 564 | -! | +||
| 50 | +
- stat_qq(+ #' data = data, |
||
| 565 | -! | +||
| 51 | +
- geom = "text",+ #' modules = teal::modules( |
||
| 566 | -! | +||
| 52 | +
- label = label_col %>%+ #' teal.modules.general::tm_g_scatterplot( |
||
| 567 | -! | +||
| 53 | +
- data.frame(label = .) %>%+ #' label = "Scatterplot Choices", |
||
| 568 | -! | +||
| 54 | +
- dplyr::filter(label != "cooksd == NaN") %>%+ #' x = teal.transform::data_extract_spec( |
||
| 569 | -! | +||
| 55 | +
- unlist(),+ #' dataname = "ADSL", |
||
| 570 | -! | +||
| 56 | +
- hjust = 0,+ #' select = teal.transform::select_spec( |
||
| 571 | -! | +||
| 57 | +
- vjust = 1,+ #' label = "Select variable:", |
||
| 572 | -! | +||
| 58 | +
- color = "red"+ #' choices = teal.transform::variable_choices( |
||
| 573 | +59 |
- ),+ #' data[["ADSL"]], |
|
| 574 | -! | +||
| 60 | +
- env = list(plot = plot, label_col = label_col())+ #' c("AGE", "BMRKR1", "BMRKR2")
|
||
| 575 | +61 |
- )+ #' ), |
|
| 576 | +62 |
- }+ #' selected = "AGE", |
|
| 577 | +63 |
-
+ #' multiple = FALSE, |
|
| 578 | -! | +||
| 64 | +
- parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(+ #' fixed = FALSE |
||
| 579 | -! | +||
| 65 | +
- teal.widgets::resolve_ggplot2_args(+ #' ) |
||
| 580 | -! | +||
| 66 | +
- user_plot = ggplot2_args[["Normal Q-Q"]],+ #' ), |
||
| 581 | -! | +||
| 67 | +
- user_default = ggplot2_args$default,+ #' y = teal.transform::data_extract_spec( |
||
| 582 | -! | +||
| 68 | +
- module_plot = teal.widgets::ggplot2_args(+ #' dataname = "ADSL", |
||
| 583 | -! | +||
| 69 | +
- labs = list(+ #' select = teal.transform::select_spec( |
||
| 584 | -! | +||
| 70 | +
- x = quote(paste0("Theoretical Quantiles\nlm(", reg_form, ")")),
+ #' label = "Select variable:", |
||
| 585 | -! | +||
| 71 | +
- y = "Standardized residuals",+ #' choices = teal.transform::variable_choices( |
||
| 586 | -! | +||
| 72 | +
- title = "Normal Q-Q"+ #' data[["ADSL"]], |
||
| 587 | +73 |
- )+ #' c("AGE", "BMRKR1", "BMRKR2")
|
|
| 588 | +74 |
- )+ #' ), |
|
| 589 | +75 |
- ),+ #' selected = "BMRKR1", |
|
| 590 | -! | +||
| 76 | +
- ggtheme = ggtheme+ #' multiple = FALSE, |
||
| 591 | +77 |
- )+ #' fixed = FALSE |
|
| 592 | +78 |
-
+ #' ) |
|
| 593 | -! | +||
| 79 | +
- teal.code::eval_code(+ #' ), |
||
| 594 | -! | +||
| 80 | +
- plot_base,+ #' color_by = teal.transform::data_extract_spec( |
||
| 595 | -! | +||
| 81 | +
- substitute(+ #' dataname = "ADSL", |
||
| 596 | -! | +||
| 82 | +
- expr = {
+ #' select = teal.transform::select_spec( |
||
| 597 | -! | +||
| 83 | +
- g <- plot+ #' label = "Select variable:", |
||
| 598 | -! | +||
| 84 | +
- print(g)+ #' choices = teal.transform::variable_choices( |
||
| 599 | +85 |
- },+ #' data[["ADSL"]], |
|
| 600 | -! | +||
| 86 | +
- env = list(+ #' c("AGE", "BMRKR1", "BMRKR2", "RACE", "REGION1")
|
||
| 601 | -! | +||
| 87 | +
- plot = Reduce(function(x, y) call("+", x, y), c(plot, parsed_ggplot2_args))
+ #' ), |
||
| 602 | +88 |
- )+ #' selected = NULL, |
|
| 603 | +89 |
- )+ #' multiple = FALSE, |
|
| 604 | +90 |
- )+ #' fixed = FALSE |
|
| 605 | +91 |
- }+ #' ) |
|
| 606 | +92 |
-
+ #' ), |
|
| 607 | -! | +||
| 93 | +
- plot_type_3 <- function(plot_base) {
+ #' size_by = teal.transform::data_extract_spec( |
||
| 608 | -! | +||
| 94 | +
- shinyjs::show("size")
+ #' dataname = "ADSL", |
||
| 609 | -! | +||
| 95 | +
- shinyjs::show("alpha")
+ #' select = teal.transform::select_spec( |
||
| 610 | -! | +||
| 96 | +
- plot <- substitute(+ #' label = "Select variable:", |
||
| 611 | -! | +||
| 97 | +
- expr = ggplot(data = data, aes(.fitted, sqrt(abs(.stdresid)))) ++ #' choices = teal.transform::variable_choices( |
||
| 612 | -! | +||
| 98 | +
- geom_point(size = size, alpha = alpha) ++ #' data[["ADSL"]], |
||
| 613 | -! | +||
| 99 | +
- geom_line(data = smoothy, mapping = smoothy_aes),+ #' c("AGE", "BMRKR1", "BMRKR2", "RACE", "REGION1")
|
||
| 614 | -! | +||
| 100 | +
- env = list(size = size, alpha = alpha)+ #' ), |
||
| 615 | +101 |
- )+ #' selected = "AGE", |
|
| 616 | -! | +||
| 102 | +
- if (show_outlier) {
+ #' multiple = FALSE, |
||
| 617 | -! | +||
| 103 | +
- plot <- substitute(expr = plot + outlier_label, env = list(plot = plot, outlier_label = outlier_label()))+ #' fixed = FALSE |
||
| 618 | +104 |
- }+ #' ) |
|
| 619 | +105 |
-
+ #' ), |
|
| 620 | -! | +||
| 106 | +
- parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(+ #' row_facet = teal.transform::data_extract_spec( |
||
| 621 | -! | +||
| 107 | +
- teal.widgets::resolve_ggplot2_args(+ #' dataname = "ADSL", |
||
| 622 | -! | +||
| 108 | +
- user_plot = ggplot2_args[["Scale-Location"]],+ #' select = teal.transform::select_spec( |
||
| 623 | -! | +||
| 109 | +
- user_default = ggplot2_args$default,+ #' label = "Select variable:", |
||
| 624 | -! | +||
| 110 | +
- module_plot = teal.widgets::ggplot2_args(+ #' choices = teal.transform::variable_choices( |
||
| 625 | -! | +||
| 111 | +
- labs = list(+ #' data[["ADSL"]], |
||
| 626 | -! | +||
| 112 | +
- x = quote(paste0("Fitted values\nlm(", reg_form, ")")),
+ #' c("BMRKR2", "RACE", "REGION1")
|
||
| 627 | -! | +||
| 113 | +
- y = quote(expression(sqrt(abs(`Standardized residuals`)))),+ #' ), |
||
| 628 | -! | +||
| 114 | +
- title = "Scale-Location"+ #' selected = NULL, |
||
| 629 | +115 |
- )+ #' multiple = FALSE, |
|
| 630 | +116 |
- )+ #' fixed = FALSE |
|
| 631 | +117 |
- ),+ #' ) |
|
| 632 | -! | +||
| 118 | +
- ggtheme = ggtheme+ #' ), |
||
| 633 | +119 |
- )+ #' col_facet = teal.transform::data_extract_spec( |
|
| 634 | +120 |
-
+ #' dataname = "ADSL", |
|
| 635 | -! | +||
| 121 | +
- teal.code::eval_code(+ #' select = teal.transform::select_spec( |
||
| 636 | -! | +||
| 122 | +
- plot_base,+ #' label = "Select variable:", |
||
| 637 | -! | +||
| 123 | +
- substitute(+ #' choices = teal.transform::variable_choices( |
||
| 638 | -! | +||
| 124 | +
- expr = {
+ #' data[["ADSL"]], |
||
| 639 | -! | +||
| 125 | +
- smoothy <- smooth(data$.fitted, sqrt(abs(data$.stdresid)))+ #' c("BMRKR2", "RACE", "REGION1")
|
||
| 640 | -! | +||
| 126 | +
- g <- plot+ #' ), |
||
| 641 | -! | +||
| 127 | +
- print(g)+ #' selected = NULL, |
||
| 642 | +128 |
- },+ #' multiple = FALSE, |
|
| 643 | -! | +||
| 129 | +
- env = list(+ #' fixed = FALSE |
||
| 644 | -! | +||
| 130 | +
- plot = Reduce(function(x, y) call("+", x, y), c(plot, parsed_ggplot2_args))
+ #' ) |
||
| 645 | +131 |
- )+ #' ), |
|
| 646 | +132 |
- )+ #' ggplot2_args = teal.widgets::ggplot2_args( |
|
| 647 | +133 |
- )+ #' labs = list(subtitle = "Plot generated by Scatterplot Module") |
|
| 648 | +134 |
- }+ #' ) |
|
| 649 | +135 |
-
+ #' ) |
|
| 650 | -! | +||
| 136 | +
- plot_type_4 <- function(plot_base) {
+ #' ) |
||
| 651 | -! | +||
| 137 | +
- shinyjs::hide("size")
+ #' ) |
||
| 652 | -! | +||
| 138 | +
- shinyjs::show("alpha")
+ #' if (interactive()) {
|
||
| 653 | -! | +||
| 139 | +
- plot <- substitute(+ #' shinyApp(app$ui, app$server) |
||
| 654 | -! | +||
| 140 | +
- expr = ggplot(data = data, aes(seq_along(.cooksd), .cooksd)) ++ #' } |
||
| 655 | -! | +||
| 141 | +
- geom_col(alpha = alpha),+ tm_g_scatterplot <- function(label = "Scatterplot", |
||
| 656 | -! | +||
| 142 | +
- env = list(alpha = alpha)+ x, |
||
| 657 | +143 |
- )+ y, |
|
| 658 | -! | +||
| 144 | +
- if (show_outlier) {
+ color_by = NULL, |
||
| 659 | -! | +||
| 145 | +
- plot <- substitute(+ size_by = NULL, |
||
| 660 | -! | +||
| 146 | +
- expr = plot ++ row_facet = NULL, |
||
| 661 | -! | +||
| 147 | +
- geom_hline(+ col_facet = NULL, |
||
| 662 | -! | +||
| 148 | +
- yintercept = c(+ plot_height = c(600, 200, 2000), |
||
| 663 | -! | +||
| 149 | +
- outlier * mean(data$.cooksd, na.rm = TRUE),+ plot_width = NULL, |
||
| 664 | -! | +||
| 150 | +
- mean(data$.cooksd, na.rm = TRUE)+ alpha = c(1, 0, 1), |
||
| 665 | +151 |
- ),+ shape = shape_names, |
|
| 666 | -! | +||
| 152 | +
- color = "red",+ size = c(5, 1, 15), |
||
| 667 | -! | +||
| 153 | +
- linetype = "dashed"+ max_deg = 5L, |
||
| 668 | +154 |
- ) ++ rotate_xaxis_labels = FALSE, |
|
| 669 | -! | +||
| 155 | +
- geom_text(+ ggtheme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void"),
|
||
| 670 | -! | +||
| 156 | +
- aes(+ pre_output = NULL, |
||
| 671 | -! | +||
| 157 | +
- x = 0,+ post_output = NULL, |
||
| 672 | -! | +||
| 158 | +
- y = mean(data$.cooksd, na.rm = TRUE),+ table_dec = 4, |
||
| 673 | -! | +||
| 159 | +
- label = paste("mu", "=", round(mean(data$.cooksd, na.rm = TRUE), 4)),
+ ggplot2_args = teal.widgets::ggplot2_args()) {
|
||
| 674 | +160 | ! |
- vjust = -1,+ logger::log_info("Initializing tm_g_scatterplot")
|
| 675 | -! | +||
| 161 | +
- hjust = 0,+ |
||
| 676 | +162 | ! |
- color = "red",+ extra_packages <- c("ggpmisc", "ggExtra", "colourpicker")
|
| 677 | +163 | ! |
- angle = 90- |
-
| 678 | -- |
- ),+ missing_packages <- Filter(function(x) !requireNamespace(x, quietly = TRUE), extra_packages) |
|
| 679 | +164 | ! |
- parse = TRUE,+ if (length(missing_packages) > 0L) {
|
| 680 | +165 | ! |
- show.legend = FALSE- |
-
| 681 | -- |
- ) ++ stop(sprintf( |
|
| 682 | +166 | ! |
- outlier_label,+ "Cannot load package(s): %s.\nInstall or restart your session.", |
| 683 | +167 | ! |
- env = list(plot = plot, outlier = input$outlier, outlier_label = outlier_label())+ toString(missing_packages) |
| 684 | +168 |
- )+ )) |
|
| 685 | +169 |
- }+ } |
|
| 686 | +170 | ||
| 687 | -! | -
- parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(- |
- |
| 688 | -! | -
- teal.widgets::resolve_ggplot2_args(- |
- |
| 689 | +171 | ! |
- user_plot = ggplot2_args[["Cook's distance"]],+ if (inherits(x, "data_extract_spec")) x <- list(x) |
| 690 | +172 | ! |
- user_default = ggplot2_args$default,+ if (inherits(y, "data_extract_spec")) y <- list(y) |
| 691 | +173 | ! |
- module_plot = teal.widgets::ggplot2_args(+ if (inherits(color_by, "data_extract_spec")) color_by <- list(color_by) |
| 692 | +174 | ! |
- labs = list(+ if (inherits(size_by, "data_extract_spec")) size_by <- list(size_by) |
| 693 | +175 | ! |
- x = quote(paste0("Obs. number\nlm(", reg_form, ")")),
+ if (inherits(row_facet, "data_extract_spec")) row_facet <- list(row_facet) |
| 694 | +176 | ! |
- y = "Cook's distance",+ if (inherits(col_facet, "data_extract_spec")) col_facet <- list(col_facet) |
| 695 | +177 | ! |
- title = "Cook's distance"- |
-
| 696 | -- |
- )- |
- |
| 697 | -- |
- )+ if (is.double(max_deg)) max_deg <- as.integer(max_deg) |
|
| 698 | +178 |
- ),+ |
|
| 699 | +179 | ! |
- ggtheme = ggtheme- |
-
| 700 | -- |
- )+ ggtheme <- match.arg(ggtheme) |
|
| 701 | -+ | ||
| 180 | +! |
-
+ checkmate::assert_string(label) |
|
| 702 | +181 | ! |
- teal.code::eval_code(+ checkmate::assert_list(x, types = "data_extract_spec") |
| 703 | +182 | ! |
- plot_base,+ checkmate::assert_list(y, types = "data_extract_spec") |
| 704 | +183 | ! |
- substitute(+ checkmate::assert_list(color_by, types = "data_extract_spec", null.ok = TRUE) |
| 705 | +184 | ! |
- expr = {
+ checkmate::assert_list(size_by, types = "data_extract_spec", null.ok = TRUE) |
| 706 | +185 | ! |
- g <- plot+ checkmate::assert_list(row_facet, types = "data_extract_spec", null.ok = TRUE) |
| 707 | +186 | ! |
- print(g)+ checkmate::assert_list(col_facet, types = "data_extract_spec", null.ok = TRUE) |
| 708 | -+ | ||
| 187 | +! |
- },+ checkmate::assert_list(row_facet, types = "data_extract_spec", null.ok = TRUE) |
|
| 709 | +188 | ! |
- env = list(+ if (!all(vapply(row_facet, function(x) !x$select$multiple, logical(1)))) {
|
| 710 | +189 | ! |
- plot = Reduce(function(x, y) call("+", x, y), c(plot, parsed_ggplot2_args))
+ stop("'row_facet' should not allow multiple selection")
|
| 711 | +190 |
- )+ } |
|
| 712 | -+ | ||
| 191 | +! |
- )+ if (!all(vapply(col_facet, function(x) !x$select$multiple, logical(1)))) {
|
|
| 713 | -+ | ||
| 192 | +! |
- )+ stop("'col_facet' should not allow multiple selection")
|
|
| 714 | +193 |
- }+ } |
|
| 715 | -+ | ||
| 194 | +! |
-
+ checkmate::assert_character(shape) |
|
| 716 | +195 | ||
| 717 | -! | -
- plot_type_5 <- function(plot_base) {
- |
- |
| 718 | +196 | ! |
- shinyjs::show("size")
+ checkmate::assert_int(max_deg, lower = 1L) |
| 719 | +197 | ! |
- shinyjs::show("alpha")
+ checkmate::assert_scalar(table_dec) |
| 720 | +198 | ! |
- plot <- substitute(+ checkmate::assert_flag(rotate_xaxis_labels) |
| 721 | +199 | ! |
- expr = ggplot(data = data, aes(.hat, .stdresid)) ++ if (length(alpha) == 1) {
|
| 722 | +200 | ! |
- geom_vline(+ checkmate::assert_numeric(alpha, any.missing = FALSE, finite = TRUE) |
| 723 | -! | +||
| 201 | +
- size = 1,+ } else {
|
||
| 724 | +202 | ! |
- colour = "black",+ checkmate::assert_numeric(alpha, len = 3, any.missing = FALSE, finite = TRUE) |
| 725 | +203 | ! |
- linetype = "dashed",+ checkmate::assert_numeric(alpha[1], lower = alpha[2], upper = alpha[3], .var.name = "alpha") |
| 726 | -! | +||
| 204 | +
- xintercept = 0+ } |
||
| 727 | +205 |
- ) ++ |
|
| 728 | +206 | ! |
- geom_hline(+ if (length(size) == 1) {
|
| 729 | +207 | ! |
- size = 1,+ checkmate::assert_numeric(size, any.missing = FALSE, finite = TRUE) |
| 730 | -! | +||
| 208 | +
- colour = "black",+ } else {
|
||
| 731 | +209 | ! |
- linetype = "dashed",+ checkmate::assert_numeric(size, len = 3, any.missing = FALSE, finite = TRUE) |
| 732 | +210 | ! |
- yintercept = 0+ checkmate::assert_numeric(size[1], lower = size[2], upper = size[3], .var.name = "size") |
| 733 | +211 |
- ) ++ }+ |
+ |
| 212 | ++ | + | |
| 734 | +213 | ! |
- geom_point(size = size, alpha = alpha) ++ checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE) |
| 735 | +214 | ! |
- geom_line(data = smoothy, mapping = smoothy_aes),+ checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height") |
| 736 | +215 | ! |
- env = list(size = size, alpha = alpha)+ checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE) |
| 737 | -+ | ||
| 216 | +! |
- )+ checkmate::assert_numeric( |
|
| 738 | +217 | ! |
- if (show_outlier) {
+ plot_width[1], |
| 739 | +218 | ! |
- plot <- substitute(expr = plot + outlier_label, env = list(plot = plot, outlier_label = outlier_label()))+ lower = plot_width[2], upper = plot_width[3], null.ok = TRUE, .var.name = "plot_width" |
| 740 | +219 |
- }+ ) |
|
| 741 | +220 | ||
| 742 | +221 | ! |
- parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(+ checkmate::assert_class(ggplot2_args, "ggplot2_args") |
| 743 | -! | +||
| 222 | +
- teal.widgets::resolve_ggplot2_args(+ |
||
| 744 | +223 | ! |
- user_plot = ggplot2_args[["Residuals vs Leverage"]],+ args <- as.list(environment()) |
| 745 | -! | +||
| 224 | +
- user_default = ggplot2_args$default,+ |
||
| 746 | +225 | ! |
- module_plot = teal.widgets::ggplot2_args(+ data_extract_list <- list( |
| 747 | +226 | ! |
- labs = list(+ x = x, |
| 748 | +227 | ! |
- x = quote(paste0("Standardized residuals\nlm(", reg_form, ")")),
+ y = y, |
| 749 | +228 | ! |
- y = "Leverage",+ color_by = color_by, |
| 750 | +229 | ! |
- title = "Residuals vs Leverage"- |
-
| 751 | -- |
- )- |
- |
| 752 | -- |
- )+ size_by = size_by, |
|
| 753 | -+ | ||
| 230 | +! |
- ),+ row_facet = row_facet, |
|
| 754 | +231 | ! |
- ggtheme = ggtheme+ col_facet = col_facet |
| 755 | +232 |
- )+ ) |
|
| 756 | +233 | ||
| 757 | +234 | ! |
- teal.code::eval_code(+ module( |
| 758 | +235 | ! |
- plot_base,+ label = label, |
| 759 | +236 | ! |
- substitute(+ server = srv_g_scatterplot, |
| 760 | +237 | ! |
- expr = {
+ ui = ui_g_scatterplot, |
| 761 | +238 | ! |
- smoothy <- smooth(data$.hat, data$.stdresid)+ ui_args = args, |
| 762 | +239 | ! |
- g <- plot+ server_args = c( |
| 763 | +240 | ! |
- print(g)- |
-
| 764 | -- |
- },+ data_extract_list, |
|
| 765 | +241 | ! |
- env = list(+ list(plot_height = plot_height, plot_width = plot_width, table_dec = table_dec, ggplot2_args = ggplot2_args) |
| 766 | -! | +||
| 242 | +
- plot = Reduce(function(x, y) call("+", x, y), c(plot, parsed_ggplot2_args))
+ ), |
||
| 767 | -+ | ||
| 243 | +! |
- )+ datanames = teal.transform::get_extract_datanames(data_extract_list) |
|
| 768 | +244 |
- )+ ) |
|
| 769 | +245 |
- )+ } |
|
| 770 | +246 |
- }+ |
|
| 771 | +247 |
-
+ ui_g_scatterplot <- function(id, ...) {
|
|
| 772 | +248 | ! |
- plot_type_6 <- function(plot_base) {
+ args <- list(...) |
| 773 | +249 | ! |
- shinyjs::show("size")
+ ns <- NS(id) |
| 774 | +250 | ! |
- shinyjs::show("alpha")
+ is_single_dataset_value <- teal.transform::is_single_dataset( |
| 775 | +251 | ! |
- plot <- substitute(+ args$x, args$y, args$color_by, args$size_by, args$row_facet, args$col_facet |
| 776 | -! | +||
| 252 | +
- expr = ggplot(data = data, aes(.hat, .cooksd)) ++ ) |
||
| 777 | -! | +||
| 253 | +
- geom_vline(xintercept = 0, colour = NA) ++ |
||
| 778 | +254 | ! |
- geom_abline(+ shiny::tagList( |
| 779 | +255 | ! |
- slope = seq(0, 3, by = 0.5),+ include_css_files("custom"),
|
| 780 | +256 | ! |
- colour = "black",+ teal.widgets::standard_layout( |
| 781 | +257 | ! |
- linetype = "dashed",+ output = teal.widgets::white_small_well( |
| 782 | +258 | ! |
- size = 1- |
-
| 783 | -- |
- ) ++ teal.widgets::plot_with_settings_ui(id = ns("scatter_plot")),
|
|
| 784 | +259 | ! |
- geom_line(data = smoothy, mapping = smoothy_aes) ++ tags$h1(tags$strong("Selected points:"), class = "text-center font-150p"),
|
| 785 | +260 | ! |
- geom_point(size = size, alpha = alpha),+ teal.widgets::get_dt_rows(ns("data_table"), ns("data_table_rows")),
|
| 786 | +261 | ! |
- env = list(size = size, alpha = alpha)+ DT::dataTableOutput(ns("data_table"), width = "100%")
|
| 787 | +262 |
- )- |
- |
| 788 | -! | -
- if (show_outlier) {
+ ), |
|
| 789 | +263 | ! |
- plot <- substitute(expr = plot + outlier_label, env = list(plot = plot, outlier_label = outlier_label()))- |
-
| 790 | -- |
- }+ encoding = div( |
|
| 791 | +264 |
-
+ ### Reporter |
|
| 792 | +265 | ! |
- parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(+ teal.reporter::simple_reporter_ui(ns("simple_reporter")),
|
| 793 | -! | +||
| 266 | +
- teal.widgets::resolve_ggplot2_args(+ ### |
||
| 794 | +267 | ! |
- user_plot = ggplot2_args[["Cook's dist vs Leverage"]],+ tags$label("Encodings", class = "text-primary"),
|
| 795 | +268 | ! |
- user_default = ggplot2_args$default,+ teal.transform::datanames_input(args[c("x", "y", "color_by", "size_by", "row_facet", "col_facet")]),
|
| 796 | +269 | ! |
- module_plot = teal.widgets::ggplot2_args(+ teal.transform::data_extract_ui( |
| 797 | +270 | ! |
- labs = list(+ id = ns("x"),
|
| 798 | +271 | ! |
- x = quote(paste0("Leverage\nlm(", reg_form, ")")),
+ label = "X variable", |
| 799 | +272 | ! |
- y = "Cooks's distance",+ data_extract_spec = args$x, |
| 800 | +273 | ! |
- title = "Cook's dist vs Leverage"- |
-
| 801 | -- |
- )+ is_single_dataset = is_single_dataset_value |
|
| 802 | +274 |
- )+ ), |
|
| 803 | -+ | ||
| 275 | +! |
- ),+ checkboxInput(ns("log_x"), "Use log transformation", value = FALSE),
|
|
| 804 | +276 | ! |
- ggtheme = ggtheme+ conditionalPanel( |
| 805 | -+ | ||
| 277 | +! |
- )+ condition = paste0("input['", ns("log_x"), "'] == true"),
|
|
| 806 | -+ | ||
| 278 | +! |
-
+ radioButtons( |
|
| 807 | +279 | ! |
- teal.code::eval_code(+ ns("log_x_base"),
|
| 808 | +280 | ! |
- plot_base,+ label = NULL, |
| 809 | +281 | ! |
- substitute(+ inline = TRUE, |
| 810 | +282 | ! |
- expr = {
+ choices = c("Natural" = "log", "Base 10" = "log10", "Base 2" = "log2")
|
| 811 | -! | +||
| 283 | +
- smoothy <- smooth(data$.hat, data$.cooksd)+ ) |
||
| 812 | -! | +||
| 284 | +
- g <- plot+ ), |
||
| 813 | +285 | ! |
- print(g)+ teal.transform::data_extract_ui( |
| 814 | -+ | ||
| 286 | +! |
- },+ id = ns("y"),
|
|
| 815 | +287 | ! |
- env = list(+ label = "Y variable", |
| 816 | +288 | ! |
- plot = Reduce(function(x, y) call("+", x, y), c(plot, parsed_ggplot2_args))
+ data_extract_spec = args$y, |
| 817 | -+ | ||
| 289 | +! |
- )+ is_single_dataset = is_single_dataset_value |
|
| 818 | +290 |
- )+ ), |
|
| 819 | -+ | ||
| 291 | +! |
- )+ checkboxInput(ns("log_y"), "Use log transformation", value = FALSE),
|
|
| 820 | -+ | ||
| 292 | +! |
- }+ conditionalPanel( |
|
| 821 | -+ | ||
| 293 | +! |
-
+ condition = paste0("input['", ns("log_y"), "'] == true"),
|
|
| 822 | +294 | ! |
- qenv <- if (input_type == "Response vs Regressor") {
+ radioButtons( |
| 823 | +295 | ! |
- plot_type_0()+ ns("log_y_base"),
|
| 824 | -+ | ||
| 296 | +! |
- } else {
+ label = NULL, |
|
| 825 | +297 | ! |
- plot_base_q <- plot_base()+ inline = TRUE, |
| 826 | +298 | ! |
- switch(input_type,+ choices = c("Natural" = "log", "Base 10" = "log10", "Base 2" = "log2")
+ |
+
| 299 | ++ |
+ )+ |
+ |
| 300 | ++ |
+ ), |
|
| 827 | +301 | ! |
- "Residuals vs Fitted" = plot_base_q %>% plot_type_1(),+ if (!is.null(args$color_by)) {
|
| 828 | +302 | ! |
- "Normal Q-Q" = plot_base_q %>% plot_type_2(),+ teal.transform::data_extract_ui( |
| 829 | +303 | ! |
- "Scale-Location" = plot_base_q %>% plot_type_3(),+ id = ns("color_by"),
|
| 830 | +304 | ! |
- "Cook's distance" = plot_base_q %>% plot_type_4(),+ label = "Color by variable", |
| 831 | +305 | ! |
- "Residuals vs Leverage" = plot_base_q %>% plot_type_5(),+ data_extract_spec = args$color_by, |
| 832 | +306 | ! |
- "Cook's dist vs Leverage" = plot_base_q %>% plot_type_6()+ is_single_dataset = is_single_dataset_value |
| 833 | +307 |
- )+ ) |
|
| 834 | +308 |
- }+ }, |
|
| 835 | +309 | ! |
- qenv+ if (!is.null(args$size_by)) {
|
| 836 | -+ | ||
| 310 | +! |
- })+ teal.transform::data_extract_ui( |
|
| 837 | -+ | ||
| 311 | +! |
-
+ id = ns("size_by"),
|
|
| 838 | -+ | ||
| 312 | +! |
-
+ label = "Size by variable", |
|
| 839 | +313 | ! |
- fitted <- reactive(output_q()[["fit"]])+ data_extract_spec = args$size_by, |
| 840 | +314 | ! |
- plot_r <- reactive(output_q()[["g"]])+ is_single_dataset = is_single_dataset_value |
| 841 | +315 |
-
+ ) |
|
| 842 | +316 |
- # Insert the plot into a plot_with_settings module from teal.widgets+ }, |
|
| 843 | +317 | ! |
- pws <- teal.widgets::plot_with_settings_srv(+ if (!is.null(args$row_facet)) {
|
| 844 | +318 | ! |
- id = "myplot",+ teal.transform::data_extract_ui( |
| 845 | +319 | ! |
- plot_r = plot_r,+ id = ns("row_facet"),
|
| 846 | +320 | ! |
- height = plot_height,+ label = "Row facetting", |
| 847 | +321 | ! |
- width = plot_width+ data_extract_spec = args$row_facet,+ |
+
| 322 | +! | +
+ is_single_dataset = is_single_dataset_value |
|
| 848 | +323 |
- )+ ) |
|
| 849 | +324 |
-
+ }, |
|
| 850 | +325 | ! |
- output$text <- renderText({
+ if (!is.null(args$col_facet)) {
|
| 851 | +326 | ! |
- req(iv_r()$is_valid())+ teal.transform::data_extract_ui( |
| 852 | +327 | ! |
- req(iv_out$is_valid())+ id = ns("col_facet"),
|
| 853 | +328 | ! |
- paste(utils::capture.output(summary(teal.code::dev_suppress(fitted())))[-1],+ label = "Column facetting", |
| 854 | +329 | ! |
- collapse = "\n"+ data_extract_spec = args$col_facet, |
| 855 | -+ | ||
| 330 | +! |
- )+ is_single_dataset = is_single_dataset_value |
|
| 856 | +331 |
- })+ ) |
|
| 857 | +332 |
-
+ }, |
|
| 858 | +333 | ! |
- teal.widgets::verbatim_popup_srv(+ teal.widgets::panel_group( |
| 859 | +334 | ! |
- id = "warning",+ teal.widgets::panel_item( |
| 860 | +335 | ! |
- verbatim_content = reactive(teal.code::get_warnings(output_q())),+ title = "Plot settings", |
| 861 | +336 | ! |
- title = "Warning",+ teal.widgets::optionalSliderInputValMinMax(ns("alpha"), "Opacity:", args$alpha, ticks = FALSE),
|
| 862 | +337 | ! |
- disabled = reactive(is.null(teal.code::get_warnings(output_q())))+ teal.widgets::optionalSelectInput( |
| 863 | -+ | ||
| 338 | +! |
- )+ inputId = ns("shape"),
|
|
| 864 | -+ | ||
| 339 | +! |
-
+ label = "Points shape:", |
|
| 865 | +340 | ! |
- teal.widgets::verbatim_popup_srv(+ choices = args$shape, |
| 866 | +341 | ! |
- id = "rcode",+ selected = args$shape[1], |
| 867 | +342 | ! |
- verbatim_content = reactive(teal.code::get_code(output_q())),+ multiple = FALSE+ |
+
| 343 | ++ |
+ ), |
|
| 868 | +344 | ! |
- title = "R code for the regression plot",+ colourpicker::colourInput(ns("color"), "Points color:", "black"),
|
| 869 | -+ | ||
| 345 | +! |
- )+ teal.widgets::optionalSliderInputValMinMax(ns("size"), "Points size:", args$size, ticks = FALSE, step = .1),
|
|
| 870 | -+ | ||
| 346 | +! |
-
+ checkboxInput(ns("rotate_xaxis_labels"), "Rotate X axis labels", value = args$rotate_xaxis_labels),
|
|
| 871 | -+ | ||
| 347 | +! |
- ### REPORTER+ checkboxInput(ns("add_density"), "Add marginal density", value = FALSE),
|
|
| 872 | +348 | ! |
- if (with_reporter) {
+ checkboxInput(ns("rug_plot"), "Include rug plot", value = FALSE),
|
| 873 | +349 | ! |
- card_fun <- function(comment, label) {
+ checkboxInput(ns("show_count"), "Show N (number of observations)", value = FALSE),
|
| 874 | +350 | ! |
- card <- teal::report_card_template(+ shinyjs::hidden(helpText(id = ns("line_msg"), "Trendline needs numeric X and Y variables")),
|
| 875 | +351 | ! |
- title = "Linear Regression Plot",+ teal.widgets::optionalSelectInput(ns("smoothing_degree"), "Smoothing degree", seq_len(args$max_deg)),
|
| 876 | +352 | ! |
- label = label,+ shinyjs::hidden(teal.widgets::optionalSelectInput(ns("color_sub"), label = "", multiple = TRUE)),
|
| 877 | +353 | ! |
- with_filter = with_filter,+ teal.widgets::optionalSliderInputValMinMax(ns("ci"), "Confidence", c(.95, .8, .99), ticks = FALSE),
|
| 878 | +354 | ! |
- filter_panel_api = filter_panel_api+ shinyjs::hidden(checkboxInput(ns("show_form"), "Show formula", value = TRUE)),
|
| 879 | -+ | ||
| 355 | +! |
- )+ shinyjs::hidden(checkboxInput(ns("show_r2"), "Show adj-R Squared", value = TRUE)),
|
|
| 880 | +356 | ! |
- card$append_text("Plot", "header3")
+ uiOutput(ns("num_na_removed")),
|
| 881 | +357 | ! |
- card$append_plot(plot_r(), dim = pws$dim())+ div( |
| 882 | +358 | ! |
- if (!comment == "") {
+ id = ns("label_pos"),
|
| 883 | +359 | ! |
- card$append_text("Comment", "header3")
+ div(strong("Stats position")),
|
| 884 | +360 | ! |
- card$append_text(comment)+ div(class = "inline-block w-10", helpText("Left")),
|
| 885 | -+ | ||
| 361 | +! |
- }+ div( |
|
| 886 | +362 | ! |
- card$append_src(teal.code::get_code(output_q()))+ class = "inline-block w-70", |
| 887 | +363 | ! |
- card+ teal.widgets::optionalSliderInput( |
| 888 | -+ | ||
| 364 | +! |
- }+ ns("pos"),
|
|
| 889 | +365 | ! |
- teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
+ label = NULL, |
| 890 | -+ | ||
| 366 | +! |
- }+ min = 0, max = 1, value = .99, ticks = FALSE, step = .01 |
|
| 891 | +367 |
- ###+ ) |
|
| 892 | +368 |
- })+ ), |
|
| 893 | -+ | ||
| 369 | +! |
- }+ div(class = "inline-block w-10", helpText("Right"))
|
|
| 894 | +370 |
-
+ ), |
|
| 895 | -+ | ||
| 371 | +! |
- regression_names <- paste0(+ teal.widgets::optionalSliderInput( |
|
| 896 | -+ | ||
| 372 | +! |
- '"Response vs Regressor", "Residuals vs Fitted", ',+ ns("label_size"), "Stats font size",
|
|
| 897 | -+ | ||
| 373 | +! |
- '"Scale-Location", "Cook\'s distance", "Residuals vs Leverage"", "Cook\'s dist vs Leverage"'+ min = 3, max = 10, value = 5, ticks = FALSE, step = .1 |
|
| 898 | +374 |
- )+ ), |
| 1 | -+ | |||
| 375 | +! |
- #' Create a simple scatterplot+ if (!is.null(args$row_facet) || !is.null(args$col_facet)) {
|
||
| 2 | -+ | |||
| 376 | +! |
- #'+ checkboxInput(ns("free_scales"), "Free scales", value = FALSE)
|
||
| 3 | +377 |
- #' Create a plot with the \code{\link{ggplot2}[geom_point]} function
+ }, |
||
| 4 | -+ | |||
| 378 | +! |
- #' @md+ selectInput( |
||
| 5 | -+ | |||
| 379 | +! |
- #'+ inputId = ns("ggtheme"),
|
||
| 6 | -+ | |||
| 380 | +! |
- #' @inheritParams teal::module+ label = "Theme (by ggplot):", |
||
| 7 | -+ | |||
| 381 | +! |
- #' @inheritParams shared_params+ choices = ggplot_themes, |
||
| 8 | -+ | |||
| 382 | +! |
- #' @param x (`data_extract_spec` or `list` of multiple `data_extract_spec`) Variable+ selected = args$ggtheme,+ |
+ ||
| 383 | +! | +
+ multiple = FALSE |
||
| 9 | +384 |
- #' names selected to plot along the x-axis by default.+ ) |
||
| 10 | +385 |
- #' @param y (`data_extract_spec` or `list` of multiple `data_extract_spec`) Variable+ ) |
||
| 11 | +386 |
- #' names selected to plot along the y-axis by default.+ ) |
||
| 12 | +387 |
- #' @param color_by optional (`data_extract_spec` or `list` of multiple `data_extract_spec`)+ ),+ |
+ ||
| 388 | +! | +
+ forms = tagList(+ |
+ ||
| 389 | +! | +
+ teal.widgets::verbatim_popup_ui(ns("warning"), button_label = "Show Warnings"),
|
||
| 13 | -+ | |||
| 390 | +! |
- #' Defines the color encoding. If `NULL` then no color encoding option will be displayed.+ teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code")
|
||
| 14 | +391 |
- #' @param size_by optional (`data_extract_spec` or `list` of multiple `data_extract_spec`)+ ), |
||
| 15 | -+ | |||
| 392 | +! |
- #' Defines the point size encoding. If `NULL` then no size encoding option will be displayed.+ pre_output = args$pre_output, |
||
| 16 | -+ | |||
| 393 | +! |
- #' @param row_facet optional, (`data_extract_spec` or `list` of multiple `data_extract_spec`)+ post_output = args$post_output |
||
| 17 | +394 |
- #' Which data columns to use for faceting rows.+ ) |
||
| 18 | +395 |
- #' @param col_facet optional, (`data_extract_spec` or `list` of multiple `data_extract_spec`)+ ) |
||
| 19 | +396 |
- #' Which data to use for faceting columns.+ } |
||
| 20 | +397 |
- #' @param alpha optional, (`numeric`) If scalar then the plot points will have a fixed opacity. If a+ |
||
| 21 | +398 |
- #' slider should be presented to adjust the plot point opacity dynamically then it can be a vector of+ srv_g_scatterplot <- function(id, |
||
| 22 | +399 |
- #' length three with `c(value, min, max)`.+ data, |
||
| 23 | +400 |
- #' @param size optional, (`numeric`) If scalar then the plot point sizes will have a fixed size+ reporter, |
||
| 24 | +401 |
- #' If a slider should be presented to adjust the plot point sizes dynamically then it can be a+ filter_panel_api, |
||
| 25 | +402 |
- #' vector of length three with `c(value, min, max)`.+ x, |
||
| 26 | +403 |
- #' @param shape optional, (`character`) A character vector with the English names of the+ y, |
||
| 27 | +404 |
- #' shape, e.g. `c("triangle", "square", "circle")`. It defaults to `shape_names`. This is a complete list from
+ color_by, |
||
| 28 | +405 |
- #' `vignette("ggplot2-specs", package="ggplot2")`.
+ size_by, |
||
| 29 | +406 |
- #' @param max_deg optional, (`integer`) The maximum degree for the polynomial trend line. Must not be less than 1.+ row_facet, |
||
| 30 | +407 |
- #' @param table_dec optional, (`integer`) Number of decimal places used to round numeric values in the table.+ col_facet, |
||
| 31 | +408 |
- #'+ plot_height, |
||
| 32 | +409 |
- #'+ plot_width, |
||
| 33 | +410 |
- #' @note For more examples, please see the vignette "Using scatterplot" via+ table_dec, |
||
| 34 | +411 |
- #' `vignette("using-scatterplot", package = "teal.modules.general")`.
+ ggplot2_args) {
|
||
| 35 | -+ | |||
| 412 | +! |
- #'+ with_reporter <- !missing(reporter) && inherits(reporter, "Reporter") |
||
| 36 | -+ | |||
| 413 | +! |
- #' @export+ with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI") |
||
| 37 | -+ | |||
| 414 | +! |
- #' @examples+ checkmate::assert_class(data, "reactive") |
||
| 38 | -+ | |||
| 415 | +! |
- #' # Scatterplot of variables from ADSL dataset+ checkmate::assert_class(isolate(data()), "teal_data") |
||
| 39 | -+ | |||
| 416 | +! |
- #'+ moduleServer(id, function(input, output, session) {
|
||
| 40 | -+ | |||
| 417 | +! |
- #' data <- teal_data()+ data_extract <- list( |
||
| 41 | -+ | |||
| 418 | +! |
- #' data <- within(data, {
+ x = x, |
||
| 42 | -+ | |||
| 419 | +! |
- #' library(nestcolor)+ y = y, |
||
| 43 | -+ | |||
| 420 | +! |
- #' ADSL <- teal.modules.general::rADSL+ color_by = color_by, |
||
| 44 | -+ | |||
| 421 | +! |
- #' })+ size_by = size_by, |
||
| 45 | -+ | |||
| 422 | +! |
- #' datanames <- c("ADSL")
+ row_facet = row_facet, |
||
| 46 | -+ | |||
| 423 | +! |
- #' datanames(data) <- datanames+ col_facet = col_facet |
||
| 47 | +424 |
- #' join_keys(data) <- default_cdisc_join_keys[datanames]+ ) |
||
| 48 | +425 |
- #'+ |
||
| 49 | -+ | |||
| 426 | +! |
- #' app <- teal::init(+ rule_diff <- function(other) {
|
||
| 50 | -+ | |||
| 427 | +! |
- #' data = data,+ function(value) {
|
||
| 51 | -+ | |||
| 428 | +! |
- #' modules = teal::modules(+ othervalue <- selector_list()[[other]]()[["select"]] |
||
| 52 | -+ | |||
| 429 | +! |
- #' teal.modules.general::tm_g_scatterplot(+ if (!is.null(othervalue)) {
|
||
| 53 | -+ | |||
| 430 | +! |
- #' label = "Scatterplot Choices",+ if (identical(value, othervalue)) {
|
||
| 54 | -+ | |||
| 431 | +! |
- #' x = teal.transform::data_extract_spec(+ "Row and column facetting variables must be different." |
||
| 55 | +432 |
- #' dataname = "ADSL",+ } |
||
| 56 | +433 |
- #' select = teal.transform::select_spec(+ } |
||
| 57 | +434 |
- #' label = "Select variable:",+ } |
||
| 58 | +435 |
- #' choices = teal.transform::variable_choices(+ } |
||
| 59 | +436 |
- #' data[["ADSL"]],+ |
||
| 60 | -+ | |||
| 437 | +! |
- #' c("AGE", "BMRKR1", "BMRKR2")
+ selector_list <- teal.transform::data_extract_multiple_srv( |
||
| 61 | -+ | |||
| 438 | +! |
- #' ),+ data_extract = data_extract, |
||
| 62 | -+ | |||
| 439 | +! |
- #' selected = "AGE",+ datasets = data, |
||
| 63 | -+ | |||
| 440 | +! |
- #' multiple = FALSE,+ select_validation_rule = list( |
||
| 64 | -+ | |||
| 441 | +! |
- #' fixed = FALSE+ x = ~ if (length(.) != 1) "Please select exactly one x var.", |
||
| 65 | -+ | |||
| 442 | +! |
- #' )+ y = ~ if (length(.) != 1) "Please select exactly one y var.", |
||
| 66 | -+ | |||
| 443 | +! |
- #' ),+ color_by = ~ if (length(.) > 1) "There cannot be more than 1 color variable.", |
||
| 67 | -+ | |||
| 444 | +! |
- #' y = teal.transform::data_extract_spec(+ size_by = ~ if (length(.) > 1) "There cannot be more than 1 size variable.", |
||
| 68 | -+ | |||
| 445 | +! |
- #' dataname = "ADSL",+ row_facet = shinyvalidate::compose_rules( |
||
| 69 | -+ | |||
| 446 | +! |
- #' select = teal.transform::select_spec(+ shinyvalidate::sv_optional(), |
||
| 70 | -+ | |||
| 447 | +! |
- #' label = "Select variable:",+ rule_diff("col_facet")
|
||
| 71 | +448 |
- #' choices = teal.transform::variable_choices(+ ), |
||
| 72 | -+ | |||
| 449 | +! |
- #' data[["ADSL"]],+ col_facet = shinyvalidate::compose_rules( |
||
| 73 | -+ | |||
| 450 | +! |
- #' c("AGE", "BMRKR1", "BMRKR2")
+ shinyvalidate::sv_optional(), |
||
| 74 | -+ | |||
| 451 | +! |
- #' ),+ rule_diff("row_facet")
|
||
| 75 | +452 |
- #' selected = "BMRKR1",+ ) |
||
| 76 | +453 |
- #' multiple = FALSE,+ ) |
||
| 77 | +454 |
- #' fixed = FALSE+ ) |
||
| 78 | +455 |
- #' )+ |
||
| 79 | -+ | |||
| 456 | +! |
- #' ),+ iv_r <- reactive({
|
||
| 80 | -+ | |||
| 457 | +! |
- #' color_by = teal.transform::data_extract_spec(+ iv_facet <- shinyvalidate::InputValidator$new() |
||
| 81 | -+ | |||
| 458 | +! |
- #' dataname = "ADSL",+ iv <- shinyvalidate::InputValidator$new() |
||
| 82 | -+ | |||
| 459 | +! |
- #' select = teal.transform::select_spec(+ teal.transform::compose_and_enable_validators(iv, selector_list) |
||
| 83 | +460 |
- #' label = "Select variable:",+ }) |
||
| 84 | -+ | |||
| 461 | +! |
- #' choices = teal.transform::variable_choices(+ iv_facet <- shinyvalidate::InputValidator$new() |
||
| 85 | -+ | |||
| 462 | +! |
- #' data[["ADSL"]],+ iv_facet$add_rule("add_density", ~ if (isTRUE(.) &&
|
||
| 86 | -+ | |||
| 463 | +! |
- #' c("AGE", "BMRKR1", "BMRKR2", "RACE", "REGION1")
+ (length(selector_list()$row_facet()$select) > 0L || |
||
| 87 | -+ | |||
| 464 | +! |
- #' ),+ length(selector_list()$col_facet()$select) > 0L)) {
|
||
| 88 | -+ | |||
| 465 | +! |
- #' selected = NULL,+ "Cannot add marginal density when Row or Column facetting has been selected" |
||
| 89 | +466 |
- #' multiple = FALSE,+ }) |
||
| 90 | -+ | |||
| 467 | +! |
- #' fixed = FALSE+ iv_facet$enable() |
||
| 91 | +468 |
- #' )+ |
||
| 92 | -+ | |||
| 469 | +! |
- #' ),+ anl_merged_input <- teal.transform::merge_expression_srv( |
||
| 93 | -+ | |||
| 470 | +! |
- #' size_by = teal.transform::data_extract_spec(+ selector_list = selector_list, |
||
| 94 | -+ | |||
| 471 | +! |
- #' dataname = "ADSL",+ datasets = data, |
||
| 95 | -+ | |||
| 472 | +! |
- #' select = teal.transform::select_spec(+ merge_function = "dplyr::inner_join" |
||
| 96 | +473 |
- #' label = "Select variable:",+ ) |
||
| 97 | +474 |
- #' choices = teal.transform::variable_choices(+ |
||
| 98 | -+ | |||
| 475 | +! |
- #' data[["ADSL"]],+ anl_merged_q <- reactive({
|
||
| 99 | -+ | |||
| 476 | +! |
- #' c("AGE", "BMRKR1", "BMRKR2", "RACE", "REGION1")
+ req(anl_merged_input()) |
||
| 100 | -+ | |||
| 477 | +! |
- #' ),+ data() %>% |
||
| 101 | -+ | |||
| 478 | +! |
- #' selected = "AGE",+ teal.code::eval_code(as.expression(anl_merged_input()$expr)) %>% |
||
| 102 | -+ | |||
| 479 | +! |
- #' multiple = FALSE,+ teal.code::eval_code(quote(ANL)) # used to display table when running show-r-code code |
||
| 103 | +480 |
- #' fixed = FALSE+ }) |
||
| 104 | +481 |
- #' )+ |
||
| 105 | -+ | |||
| 482 | +! |
- #' ),+ merged <- list( |
||
| 106 | -+ | |||
| 483 | +! |
- #' row_facet = teal.transform::data_extract_spec(+ anl_input_r = anl_merged_input, |
||
| 107 | -+ | |||
| 484 | +! |
- #' dataname = "ADSL",+ anl_q_r = anl_merged_q |
||
| 108 | +485 |
- #' select = teal.transform::select_spec(+ ) |
||
| 109 | +486 |
- #' label = "Select variable:",+ |
||
| 110 | -+ | |||
| 487 | +! |
- #' choices = teal.transform::variable_choices(+ trend_line_is_applicable <- reactive({
|
||
| 111 | -+ | |||
| 488 | +! |
- #' data[["ADSL"]],+ ANL <- merged$anl_q_r()[["ANL"]] # nolint: object_name. |
||
| 112 | -+ | |||
| 489 | +! |
- #' c("BMRKR2", "RACE", "REGION1")
+ x_var <- as.vector(merged$anl_input_r()$columns_source$x) |
||
| 113 | -+ | |||
| 490 | +! |
- #' ),+ y_var <- as.vector(merged$anl_input_r()$columns_source$y) |
||
| 114 | -+ | |||
| 491 | +! |
- #' selected = NULL,+ length(x_var) > 0 && length(y_var) > 0 && is.numeric(ANL[[x_var]]) && is.numeric(ANL[[y_var]]) |
||
| 115 | +492 |
- #' multiple = FALSE,+ }) |
||
| 116 | +493 |
- #' fixed = FALSE+ |
||
| 117 | -+ | |||
| 494 | +! |
- #' )+ add_trend_line <- reactive({
|
||
| 118 | -+ | |||
| 495 | +! |
- #' ),+ smoothing_degree <- as.integer(input$smoothing_degree) |
||
| 119 | -+ | |||
| 496 | +! |
- #' col_facet = teal.transform::data_extract_spec(+ trend_line_is_applicable() && length(smoothing_degree) > 0 |
||
| 120 | +497 |
- #' dataname = "ADSL",+ }) |
||
| 121 | +498 |
- #' select = teal.transform::select_spec(+ |
||
| 122 | -+ | |||
| 499 | +! |
- #' label = "Select variable:",+ if (!is.null(color_by)) {
|
||
| 123 | -+ | |||
| 500 | +! |
- #' choices = teal.transform::variable_choices(+ observeEvent( |
||
| 124 | -+ | |||
| 501 | +! |
- #' data[["ADSL"]],+ eventExpr = merged$anl_input_r()$columns_source$color_by, |
||
| 125 | -+ | |||
| 502 | +! |
- #' c("BMRKR2", "RACE", "REGION1")
+ handlerExpr = {
|
||
| 126 | -+ | |||
| 503 | +! |
- #' ),+ color_by_var <- as.vector(merged$anl_input_r()$columns_source$color_by) |
||
| 127 | -+ | |||
| 504 | +! |
- #' selected = NULL,+ if (length(color_by_var) > 0) {
|
||
| 128 | -+ | |||
| 505 | +! |
- #' multiple = FALSE,+ shinyjs::hide("color")
|
||
| 129 | +506 |
- #' fixed = FALSE+ } else {
|
||
| 130 | -+ | |||
| 507 | +! |
- #' )+ shinyjs::show("color")
|
||
| 131 | +508 |
- #' ),+ } |
||
| 132 | +509 |
- #' ggplot2_args = teal.widgets::ggplot2_args(+ } |
||
| 133 | +510 |
- #' labs = list(subtitle = "Plot generated by Scatterplot Module")+ ) |
||
| 134 | +511 |
- #' )+ } |
||
| 135 | +512 |
- #' )+ |
||
| 136 | -+ | |||
| 513 | +! |
- #' )+ output$num_na_removed <- renderUI({
|
||
| 137 | -+ | |||
| 514 | +! |
- #' )+ if (add_trend_line()) {
|
||
| 138 | -+ | |||
| 515 | +! |
- #' if (interactive()) {
+ ANL <- merged$anl_q_r()[["ANL"]] # nolint: object_name. |
||
| 139 | -+ | |||
| 516 | +! |
- #' shinyApp(app$ui, app$server)+ x_var <- as.vector(merged$anl_input_r()$columns_source$x) |
||
| 140 | -+ | |||
| 517 | +! |
- #' }+ y_var <- as.vector(merged$anl_input_r()$columns_source$y) |
||
| 141 | -+ | |||
| 518 | +! |
- tm_g_scatterplot <- function(label = "Scatterplot",+ if ((num_total_na <- nrow(ANL) - nrow(stats::na.omit(ANL[, c(x_var, y_var)]))) > 0) {
|
||
| 142 | -+ | |||
| 519 | +! |
- x,+ shiny::tags$div(paste(num_total_na, "row(s) with missing values were removed"), shiny::tags$hr()) |
||
| 143 | +520 |
- y,+ } |
||
| 144 | +521 |
- color_by = NULL,+ } |
||
| 145 | +522 |
- size_by = NULL,+ }) |
||
| 146 | +523 |
- row_facet = NULL,+ |
||
| 147 | -+ | |||
| 524 | +! |
- col_facet = NULL,+ observeEvent( |
||
| 148 | -+ | |||
| 525 | +! |
- plot_height = c(600, 200, 2000),+ eventExpr = merged$anl_input_r()$columns_source[c("col_facet", "row_facet")],
|
||
| 149 | -+ | |||
| 526 | +! |
- plot_width = NULL,+ handlerExpr = {
|
||
| 150 | -+ | |||
| 527 | +! |
- alpha = c(1, 0, 1),+ if (length(merged$anl_input_r()$columns_source$col_facet) == 0 && |
||
| 151 | -+ | |||
| 528 | +! |
- shape = shape_names,+ length(merged$anl_input_r()$columns_source$row_facet) == 0) {
|
||
| 152 | -+ | |||
| 529 | +! |
- size = c(5, 1, 15),+ shinyjs::hide("free_scales")
|
||
| 153 | +530 |
- max_deg = 5L,+ } else {
|
||
| 154 | -+ | |||
| 531 | +! |
- rotate_xaxis_labels = FALSE,+ shinyjs::show("free_scales")
|
||
| 155 | +532 |
- ggtheme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void"),
+ } |
||
| 156 | +533 |
- pre_output = NULL,+ } |
||
| 157 | +534 |
- post_output = NULL,+ ) |
||
| 158 | +535 |
- table_dec = 4,+ |
||
| 159 | -+ | |||
| 536 | +! |
- ggplot2_args = teal.widgets::ggplot2_args()) {
+ output_q <- reactive({
|
||
| 160 | +537 | ! |
- logger::log_info("Initializing tm_g_scatterplot")
+ teal::validate_inputs(iv_r(), iv_facet) |
|
| 161 | +538 | |||
| 162 | +539 | ! |
- extra_packages <- c("ggpmisc", "ggExtra", "colourpicker")
+ ANL <- merged$anl_q_r()[["ANL"]] # nolint: object_name. |
|
| 163 | -! | +|||
| 540 | +
- missing_packages <- Filter(function(x) !requireNamespace(x, quietly = TRUE), extra_packages)+ |
|||
| 164 | +541 | ! |
- if (length(missing_packages) > 0L) {
+ x_var <- as.vector(merged$anl_input_r()$columns_source$x) |
|
| 165 | +542 | ! |
- stop(sprintf(+ y_var <- as.vector(merged$anl_input_r()$columns_source$y) |
|
| 166 | +543 | ! |
- "Cannot load package(s): %s.\nInstall or restart your session.",+ color_by_var <- as.vector(merged$anl_input_r()$columns_source$color_by) |
|
| 167 | +544 | ! |
- toString(missing_packages)- |
- |
| 168 | -- |
- ))- |
- ||
| 169 | -- |
- }- |
- ||
| 170 | -- |
-
+ size_by_var <- as.vector(merged$anl_input_r()$columns_source$size_by) |
||
| 171 | +545 | ! |
- if (inherits(x, "data_extract_spec")) x <- list(x)+ row_facet_name <- if (length(merged$anl_input_r()$columns_source$row_facet) == 0) {
|
|
| 172 | +546 | ! |
- if (inherits(y, "data_extract_spec")) y <- list(y)+ character(0) |
|
| 173 | -! | +|||
| 547 | +
- if (inherits(color_by, "data_extract_spec")) color_by <- list(color_by)+ } else {
|
|||
| 174 | +548 | ! |
- if (inherits(size_by, "data_extract_spec")) size_by <- list(size_by)+ as.vector(merged$anl_input_r()$columns_source$row_facet) |
|
| 175 | -! | +|||
| 549 | +
- if (inherits(row_facet, "data_extract_spec")) row_facet <- list(row_facet)+ } |
|||
| 176 | +550 | ! |
- if (inherits(col_facet, "data_extract_spec")) col_facet <- list(col_facet)+ col_facet_name <- if (length(merged$anl_input_r()$columns_source$col_facet) == 0) {
|
|
| 177 | +551 | ! |
- if (is.double(max_deg)) max_deg <- as.integer(max_deg)+ character(0) |
|
| 178 | +552 |
-
+ } else {
|
||
| 179 | +553 | ! |
- ggtheme <- match.arg(ggtheme)+ as.vector(merged$anl_input_r()$columns_source$col_facet)+ |
+ |
| 554 | ++ |
+ } |
||
| 180 | +555 | ! |
- checkmate::assert_string(label)+ alpha <- input$alpha |
|
| 181 | +556 | ! |
- checkmate::assert_list(x, types = "data_extract_spec")+ size <- input$size |
|
| 182 | +557 | ! |
- checkmate::assert_list(y, types = "data_extract_spec")+ rotate_xaxis_labels <- input$rotate_xaxis_labels |
|
| 183 | +558 | ! |
- checkmate::assert_list(color_by, types = "data_extract_spec", null.ok = TRUE)+ add_density <- input$add_density |
|
| 184 | +559 | ! |
- checkmate::assert_list(size_by, types = "data_extract_spec", null.ok = TRUE)+ ggtheme <- input$ggtheme |
|
| 185 | +560 | ! |
- checkmate::assert_list(row_facet, types = "data_extract_spec", null.ok = TRUE)+ rug_plot <- input$rug_plot |
|
| 186 | +561 | ! |
- checkmate::assert_list(col_facet, types = "data_extract_spec", null.ok = TRUE)+ color <- input$color |
|
| 187 | +562 | ! |
- checkmate::assert_list(row_facet, types = "data_extract_spec", null.ok = TRUE)+ shape <- `if`(is.null(input$shape) || identical(input$shape, ""), "circle", input$shape) |
|
| 188 | +563 | ! |
- if (!all(vapply(row_facet, function(x) !x$select$multiple, logical(1)))) {
+ smoothing_degree <- as.integer(input$smoothing_degree) |
|
| 189 | +564 | ! |
- stop("'row_facet' should not allow multiple selection")
+ ci <- input$ci |
|
| 190 | +565 |
- }- |
- ||
| 191 | -! | -
- if (!all(vapply(col_facet, function(x) !x$select$multiple, logical(1)))) {
+
|
||
| 192 | +566 | ! |
- stop("'col_facet' should not allow multiple selection")
- |
- |
| 193 | -- |
- }+ log_x <- input$log_x |
||
| 194 | +567 | ! |
- checkmate::assert_character(shape)+ log_y <- input$log_y |
|
| 195 | +568 | |||
| 196 | +569 | ! |
- checkmate::assert_int(max_deg, lower = 1L)+ validate(need( |
|
| 197 | +570 | ! |
- checkmate::assert_scalar(table_dec)+ length(row_facet_name) == 0 || inherits(ANL[[row_facet_name]], c("character", "factor", "Date", "integer")),
|
|
| 198 | +571 | ! |
- checkmate::assert_flag(rotate_xaxis_labels)+ "`Row facetting` variable must be of class `character`, `factor`, `Date`, or `integer`" |
|
| 199 | -! | +|||
| 572 | +
- if (length(alpha) == 1) {
+ )) |
|||
| 200 | +573 | ! |
- checkmate::assert_numeric(alpha, any.missing = FALSE, finite = TRUE)- |
- |
| 201 | -- |
- } else {
+ validate(need( |
||
| 202 | +574 | ! |
- checkmate::assert_numeric(alpha, len = 3, any.missing = FALSE, finite = TRUE)+ length(col_facet_name) == 0 || inherits(ANL[[col_facet_name]], c("character", "factor", "Date", "integer")),
|
|
| 203 | +575 | ! |
- checkmate::assert_numeric(alpha[1], lower = alpha[2], upper = alpha[3], .var.name = "alpha")+ "`Column facetting` variable must be of class `character`, `factor`, `Date`, or `integer`" |
|
| 204 | +576 |
- }+ )) |
||
| 205 | +577 | |||
| 206 | +578 | ! |
- if (length(size) == 1) {
+ if (add_density && length(color_by_var) > 0) {
|
|
| 207 | +579 | ! |
- checkmate::assert_numeric(size, any.missing = FALSE, finite = TRUE)- |
- |
| 208 | -- |
- } else {
+ validate(need( |
||
| 209 | +580 | ! |
- checkmate::assert_numeric(size, len = 3, any.missing = FALSE, finite = TRUE)+ !is.numeric(ANL[[color_by_var]]), |
|
| 210 | +581 | ! |
- checkmate::assert_numeric(size[1], lower = size[2], upper = size[3], .var.name = "size")+ "Marginal plots cannot be produced when the points are colored by numeric variables. |
|
| 211 | -+ | |||
| 582 | +! |
- }+ \n Uncheck the 'Add marginal density' checkbox to display the plot." |
||
| 212 | +583 |
-
+ )) |
||
| 213 | +584 | ! |
- checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE)+ validate(need( |
|
| 214 | +585 | ! |
- checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height")+ !(inherits(ANL[[color_by_var]], "Date") || |
|
| 215 | +586 | ! |
- checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE)+ inherits(ANL[[color_by_var]], "POSIXct") || |
|
| 216 | +587 | ! |
- checkmate::assert_numeric(+ inherits(ANL[[color_by_var]], "POSIXlt")), |
|
| 217 | +588 | ! |
- plot_width[1],+ "Marginal plots cannot be produced when the points are colored by Date or POSIX variables. |
|
| 218 | +589 | ! |
- lower = plot_width[2], upper = plot_width[3], null.ok = TRUE, .var.name = "plot_width"+ \n Uncheck the 'Add marginal density' checkbox to display the plot." |
|
| 219 | +590 |
- )+ )) |
||
| 220 | +591 | - - | -||
| 221 | -! | -
- checkmate::assert_class(ggplot2_args, "ggplot2_args")+ } |
||
| 222 | +592 | |||
| 223 | +593 | ! |
- args <- as.list(environment())+ teal::validate_has_data(ANL[, c(x_var, y_var)], 10, complete = TRUE, allow_inf = FALSE) |
|
| 224 | +594 | |||
| 225 | +595 | ! |
- data_extract_list <- list(+ if (log_x) {
|
|
| 226 | +596 | ! |
- x = x,+ validate( |
|
| 227 | +597 | ! |
- y = y,+ need( |
|
| 228 | +598 | ! |
- color_by = color_by,+ is.numeric(ANL[[x_var]]) && all( |
|
| 229 | +599 | ! |
- size_by = size_by,+ ANL[[x_var]] > 0 | is.na(ANL[[x_var]]) |
|
| 230 | -! | +|||
| 600 | +
- row_facet = row_facet,+ ), |
|||
| 231 | +601 | ! |
- col_facet = col_facet+ "X variable can only be log transformed if variable is numeric and all values are positive." |
|
| 232 | +602 |
- )+ ) |
||
| 233 | +603 |
-
+ ) |
||
| 234 | -! | +|||
| 604 | +
- module(+ } |
|||
| 235 | +605 | ! |
- label = label,+ if (log_y) {
|
|
| 236 | +606 | ! |
- server = srv_g_scatterplot,+ validate( |
|
| 237 | +607 | ! |
- ui = ui_g_scatterplot,+ need( |
|
| 238 | +608 | ! |
- ui_args = args,+ is.numeric(ANL[[y_var]]) && all( |
|
| 239 | +609 | ! |
- server_args = c(+ ANL[[y_var]] > 0 | is.na(ANL[[y_var]]) |
|
| 240 | -! | +|||
| 610 | +
- data_extract_list,+ ), |
|||
| 241 | +611 | ! |
- list(plot_height = plot_height, plot_width = plot_width, table_dec = table_dec, ggplot2_args = ggplot2_args)+ "Y variable can only be log transformed if variable is numeric and all values are positive." |
|
| 242 | +612 |
- ),- |
- ||
| 243 | -! | -
- datanames = teal.transform::get_extract_datanames(data_extract_list)+ ) |
||
| 244 | +613 |
- )+ ) |
||
| 245 | +614 |
- }+ } |
||
| 246 | +615 | |||
| 247 | -+ | |||
| 616 | +! |
- ui_g_scatterplot <- function(id, ...) {
+ facet_cl <- facet_ggplot_call( |
||
| 248 | +617 | ! |
- args <- list(...)+ row_facet_name, |
|
| 249 | +618 | ! |
- ns <- NS(id)+ col_facet_name, |
|
| 250 | +619 | ! |
- is_single_dataset_value <- teal.transform::is_single_dataset(+ free_x_scales = isTRUE(input$free_scales), |
|
| 251 | +620 | ! |
- args$x, args$y, args$color_by, args$size_by, args$row_facet, args$col_facet+ free_y_scales = isTRUE(input$free_scales) |
|
| 252 | +621 |
- )+ ) |
||
| 253 | +622 | |||
| 254 | -! | -
- shiny::tagList(- |
- ||
| 255 | -! | -
- include_css_files("custom"),
- |
- ||
| 256 | -! | -
- teal.widgets::standard_layout(- |
- ||
| 257 | +623 | ! |
- output = teal.widgets::white_small_well(+ point_sizes <- if (length(size_by_var) > 0) {
|
|
| 258 | +624 | ! |
- teal.widgets::plot_with_settings_ui(id = ns("scatter_plot")),
+ validate(need(is.numeric(ANL[[size_by_var]]), "Variable to size by must be numeric")) |
|
| 259 | +625 | ! |
- tags$h1(tags$strong("Selected points:"), class = "text-center font-150p"),
+ substitute( |
|
| 260 | +626 | ! |
- teal.widgets::get_dt_rows(ns("data_table"), ns("data_table_rows")),
+ expr = size * ANL[[size_by_var]] / max(ANL[[size_by_var]], na.rm = TRUE), |
|
| 261 | +627 | ! |
- DT::dataTableOutput(ns("data_table"), width = "100%")
+ env = list(size = size, size_by_var = size_by_var) |
|
| 262 | +628 |
- ),- |
- ||
| 263 | -! | -
- encoding = div(+ ) |
||
| 264 | +629 |
- ### Reporter+ } else {
|
||
| 265 | +630 | ! |
- teal.reporter::simple_reporter_ui(ns("simple_reporter")),
+ size |
|
| 266 | +631 |
- ###+ } |
||
| 267 | -! | +|||
| 632 | +
- tags$label("Encodings", class = "text-primary"),
+
|
|||
| 268 | +633 | ! |
- teal.transform::datanames_input(args[c("x", "y", "color_by", "size_by", "row_facet", "col_facet")]),
+ plot_q <- merged$anl_q_r() |
|
| 269 | -! | +|||
| 634 | +
- teal.transform::data_extract_ui(+ |
|||
| 270 | +635 | ! |
- id = ns("x"),
+ if (log_x) {
|
|
| 271 | +636 | ! |
- label = "X variable",+ log_x_fn <- input$log_x_base |
|
| 272 | +637 | ! |
- data_extract_spec = args$x,+ plot_q <- teal.code::eval_code( |
|
| 273 | +638 | ! |
- is_single_dataset = is_single_dataset_value- |
- |
| 274 | -- |
- ),+ object = plot_q, |
||
| 275 | +639 | ! |
- checkboxInput(ns("log_x"), "Use log transformation", value = FALSE),
+ code = substitute( |
|
| 276 | +640 | ! |
- conditionalPanel(+ expr = ANL[, log_x_var] <- log_x_fn(ANL[, x_var]), # nolint: object_name. |
|
| 277 | +641 | ! |
- condition = paste0("input['", ns("log_x"), "'] == true"),
+ env = list( |
|
| 278 | +642 | ! |
- radioButtons(+ x_var = x_var, |
|
| 279 | +643 | ! |
- ns("log_x_base"),
+ log_x_fn = as.name(log_x_fn), |
|
| 280 | +644 | ! |
- label = NULL,+ log_x_var = paste0(log_x_fn, "_", x_var) |
|
| 281 | -! | +|||
| 645 | +
- inline = TRUE,+ ) |
|||
| 282 | -! | +|||
| 646 | +
- choices = c("Natural" = "log", "Base 10" = "log10", "Base 2" = "log2")
+ ) |
|||
| 283 | +647 |
- )+ ) |
||
| 284 | +648 |
- ),+ } |
||
| 285 | -! | +|||
| 649 | +
- teal.transform::data_extract_ui(+ |
|||
| 286 | +650 | ! |
- id = ns("y"),
+ if (log_y) {
|
|
| 287 | +651 | ! |
- label = "Y variable",+ log_y_fn <- input$log_y_base |
|
| 288 | +652 | ! |
- data_extract_spec = args$y,+ plot_q <- teal.code::eval_code( |
|
| 289 | +653 | ! |
- is_single_dataset = is_single_dataset_value+ object = plot_q, |
|
| 290 | -+ | |||
| 654 | +! |
- ),+ code = substitute( |
||
| 291 | +655 | ! |
- checkboxInput(ns("log_y"), "Use log transformation", value = FALSE),
+ expr = ANL[, log_y_var] <- log_y_fn(ANL[, y_var]), # nolint: object_name. |
|
| 292 | +656 | ! |
- conditionalPanel(+ env = list( |
|
| 293 | +657 | ! |
- condition = paste0("input['", ns("log_y"), "'] == true"),
+ y_var = y_var, |
|
| 294 | +658 | ! |
- radioButtons(+ log_y_fn = as.name(log_y_fn), |
|
| 295 | +659 | ! |
- ns("log_y_base"),
+ log_y_var = paste0(log_y_fn, "_", y_var) |
|
| 296 | -! | +|||
| 660 | +
- label = NULL,+ ) |
|||
| 297 | -! | +|||
| 661 | +
- inline = TRUE,+ ) |
|||
| 298 | -! | +|||
| 662 | +
- choices = c("Natural" = "log", "Base 10" = "log10", "Base 2" = "log2")
+ ) |
|||
| 299 | +663 |
- )+ } |
||
| 300 | +664 |
- ),+ |
||
| 301 | +665 | ! |
- if (!is.null(args$color_by)) {
+ pre_pro_anl <- if (input$show_count) {
|
|
| 302 | +666 | ! |
- teal.transform::data_extract_ui(+ paste0( |
|
| 303 | +667 | ! |
- id = ns("color_by"),
+ "ANL %>% dplyr::group_by(",
|
|
| 304 | +668 | ! |
- label = "Color by variable",+ paste( |
|
| 305 | +669 | ! |
- data_extract_spec = args$color_by,+ c( |
|
| 306 | +670 | ! |
- is_single_dataset = is_single_dataset_value+ if (length(color_by_var) > 0 && inherits(ANL[[color_by_var]], c("factor", "character"))) color_by_var,
|
|
| 307 | -+ | |||
| 671 | +! |
- )+ row_facet_name,+ |
+ ||
| 672 | +! | +
+ col_facet_name |
||
| 308 | +673 |
- },+ ), |
||
| 309 | +674 | ! |
- if (!is.null(args$size_by)) {
+ collapse = ", " |
|
| 310 | -! | +|||
| 675 | +
- teal.transform::data_extract_ui(+ ), |
|||
| 311 | +676 | ! |
- id = ns("size_by"),
+ ") %>% dplyr::mutate(n = dplyr::n()) %>% dplyr::ungroup()" |
|
| 312 | -! | +|||
| 677 | +
- label = "Size by variable",+ ) |
|||
| 313 | -! | +|||
| 678 | +
- data_extract_spec = args$size_by,+ } else {
|
|||
| 314 | +679 | ! |
- is_single_dataset = is_single_dataset_value+ "ANL" |
|
| 315 | +680 |
- )+ } |
||
| 316 | +681 |
- },+ |
||
| 317 | +682 | ! |
- if (!is.null(args$row_facet)) {
+ plot_call <- substitute(expr = pre_pro_anl %>% ggplot(), env = list(pre_pro_anl = str2lang(pre_pro_anl)))+ |
+ |
| 683 | ++ | + | ||
| 318 | +684 | ! |
- teal.transform::data_extract_ui(+ plot_call <- if (length(color_by_var) == 0) {
|
|
| 319 | +685 | ! |
- id = ns("row_facet"),
+ substitute( |
|
| 320 | +686 | ! |
- label = "Row facetting",+ expr = plot_call + |
|
| 321 | +687 | ! |
- data_extract_spec = args$row_facet,+ ggplot2::aes(x = x_name, y = y_name) + |
|
| 322 | +688 | ! |
- is_single_dataset = is_single_dataset_value+ ggplot2::geom_point(alpha = alpha_value, size = point_sizes, shape = shape_value, color = color_value), |
|
| 323 | -+ | |||
| 689 | +! |
- )+ env = list( |
||
| 324 | -+ | |||
| 690 | +! |
- },+ plot_call = plot_call, |
||
| 325 | +691 | ! |
- if (!is.null(args$col_facet)) {
+ x_name = if (log_x) as.name(paste0(log_x_fn, "_", x_var)) else as.name(x_var), |
|
| 326 | +692 | ! |
- teal.transform::data_extract_ui(+ y_name = if (log_y) as.name(paste0(log_y_fn, "_", y_var)) else as.name(y_var), |
|
| 327 | +693 | ! |
- id = ns("col_facet"),
+ alpha_value = alpha, |
|
| 328 | +694 | ! |
- label = "Column facetting",+ point_sizes = point_sizes, |
|
| 329 | +695 | ! |
- data_extract_spec = args$col_facet,+ shape_value = shape, |
|
| 330 | +696 | ! |
- is_single_dataset = is_single_dataset_value+ color_value = color |
|
| 331 | +697 |
) |
||
| 332 | +698 |
- },- |
- ||
| 333 | -! | -
- teal.widgets::panel_group(+ ) |
||
| 334 | -! | +|||
| 699 | +
- teal.widgets::panel_item(+ } else {
|
|||
| 335 | +700 | ! |
- title = "Plot settings",+ substitute( |
|
| 336 | +701 | ! |
- teal.widgets::optionalSliderInputValMinMax(ns("alpha"), "Opacity:", args$alpha, ticks = FALSE),
+ expr = plot_call + |
|
| 337 | +702 | ! |
- teal.widgets::optionalSelectInput(+ ggplot2::aes(x = x_name, y = y_name, color = color_by_var_name) + |
|
| 338 | +703 | ! |
- inputId = ns("shape"),
+ ggplot2::geom_point(alpha = alpha_value, size = point_sizes, shape = shape_value), |
|
| 339 | +704 | ! |
- label = "Points shape:",+ env = list( |
|
| 340 | +705 | ! |
- choices = args$shape,+ plot_call = plot_call, |
|
| 341 | +706 | ! |
- selected = args$shape[1],+ x_name = if (log_x) as.name(paste0(log_x_fn, "_", x_var)) else as.name(x_var), |
|
| 342 | +707 | ! |
- multiple = FALSE- |
- |
| 343 | -- |
- ),+ y_name = if (log_y) as.name(paste0(log_y_fn, "_", y_var)) else as.name(y_var), |
||
| 344 | +708 | ! |
- colourpicker::colourInput(ns("color"), "Points color:", "black"),
+ color_by_var_name = as.name(color_by_var), |
|
| 345 | +709 | ! |
- teal.widgets::optionalSliderInputValMinMax(ns("size"), "Points size:", args$size, ticks = FALSE, step = .1),
+ alpha_value = alpha, |
|
| 346 | +710 | ! |
- checkboxInput(ns("rotate_xaxis_labels"), "Rotate X axis labels", value = args$rotate_xaxis_labels),
+ point_sizes = point_sizes, |
|
| 347 | +711 | ! |
- checkboxInput(ns("add_density"), "Add marginal density", value = FALSE),
+ shape_value = shape |
|
| 348 | -! | +|||
| 712 | +
- checkboxInput(ns("rug_plot"), "Include rug plot", value = FALSE),
+ ) |
|||
| 349 | -! | +|||
| 713 | +
- checkboxInput(ns("show_count"), "Show N (number of observations)", value = FALSE),
+ ) |
|||
| 350 | -! | +|||
| 714 | +
- shinyjs::hidden(helpText(id = ns("line_msg"), "Trendline needs numeric X and Y variables")),
+ } |
|||
| 351 | -! | +|||
| 715 | +
- teal.widgets::optionalSelectInput(ns("smoothing_degree"), "Smoothing degree", seq_len(args$max_deg)),
+
|
|||
| 352 | +716 | ! |
- shinyjs::hidden(teal.widgets::optionalSelectInput(ns("color_sub"), label = "", multiple = TRUE)),
+ if (rug_plot) plot_call <- substitute(expr = plot_call + geom_rug(), env = list(plot_call = plot_call)) |
|
| 353 | -! | +|||
| 717 | +
- teal.widgets::optionalSliderInputValMinMax(ns("ci"), "Confidence", c(.95, .8, .99), ticks = FALSE),
+
|
|||
| 354 | +718 | ! |
- shinyjs::hidden(checkboxInput(ns("show_form"), "Show formula", value = TRUE)),
+ plot_label_generator <- function(rhs_formula = quote(y ~ 1), |
|
| 355 | +719 | ! |
- shinyjs::hidden(checkboxInput(ns("show_r2"), "Show adj-R Squared", value = TRUE)),
+ show_form = input$show_form, |
|
| 356 | +720 | ! |
- uiOutput(ns("num_na_removed")),
+ show_r2 = input$show_r2, |
|
| 357 | +721 | ! |
- div(+ show_count = input$show_count, |
|
| 358 | +722 | ! |
- id = ns("label_pos"),
+ pos = input$pos, |
|
| 359 | +723 | ! |
- div(strong("Stats position")),
+ label_size = input$label_size) {
|
|
| 360 | +724 | ! |
- div(class = "inline-block w-10", helpText("Left")),
+ stopifnot(sum(show_form, show_r2, show_count) >= 1) |
|
| 361 | +725 | ! |
- div(+ aes_label <- paste0( |
|
| 362 | +726 | ! |
- class = "inline-block w-70",+ "aes(",
|
|
| 363 | +727 | ! |
- teal.widgets::optionalSliderInput(+ if (show_count) "n = n, ", |
|
| 364 | +728 | ! |
- ns("pos"),
+ "label = ", |
|
| 365 | +729 | ! |
- label = NULL,+ if (sum(show_form, show_r2, show_count) > 1) "paste(",
|
|
| 366 | +730 | ! |
- min = 0, max = 1, value = .99, ticks = FALSE, step = .01- |
- |
| 367 | -- |
- )- |
- ||
| 368 | -- |
- ),+ paste( |
||
| 369 | +731 | ! |
- div(class = "inline-block w-10", helpText("Right"))
- |
- |
| 370 | -- |
- ),+ c( |
||
| 371 | +732 | ! |
- teal.widgets::optionalSliderInput(+ if (show_form) "stat(eq.label)", |
|
| 372 | +733 | ! |
- ns("label_size"), "Stats font size",
+ if (show_r2) "stat(adj.rr.label)", |
|
| 373 | +734 | ! |
- min = 3, max = 10, value = 5, ticks = FALSE, step = .1+ if (show_count) "paste('N ~`=`~', n)"
|
|
| 374 | +735 |
), |
||
| 375 | -! | -
- if (!is.null(args$row_facet) || !is.null(args$col_facet)) {
- |
- ||
| 376 | +736 | ! |
- checkboxInput(ns("free_scales"), "Free scales", value = FALSE)
+ collapse = ", " |
|
| 377 | +737 |
- },+ ), |
||
| 378 | +738 | ! |
- selectInput(+ if (sum(show_form, show_r2, show_count) > 1) ", sep = '*\", \"*'))" else ")" |
|
| 379 | -! | +|||
| 739 | +
- inputId = ns("ggtheme"),
+ ) |
|||
| 380 | +740 | ! |
- label = "Theme (by ggplot):",+ label_geom <- substitute( |
|
| 381 | +741 | ! |
- choices = ggplot_themes,+ expr = ggpmisc::stat_poly_eq( |
|
| 382 | +742 | ! |
- selected = args$ggtheme,+ mapping = aes_label, |
|
| 383 | -! | -
- multiple = FALSE- |
- ||
| 384 | -- |
- )- |
- ||
| 385 | -- |
- )- |
- ||
| 386 | -- |
- )- |
- ||
| 387 | -+ | 743 | +! |
- ),+ formula = rhs_formula, |
| 388 | +744 | ! |
- forms = tagList(+ parse = TRUE, |
|
| 389 | +745 | ! |
- teal.widgets::verbatim_popup_ui(ns("warning"), button_label = "Show Warnings"),
+ label.x = pos, |
|
| 390 | +746 | ! |
- teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code")
+ size = label_size |
|
| 391 | +747 |
- ),+ ), |
||
| 392 | +748 | ! |
- pre_output = args$pre_output,+ env = list( |
|
| 393 | +749 | ! |
- post_output = args$post_output- |
- |
| 394 | -- |
- )+ rhs_formula = rhs_formula, |
||
| 395 | -+ | |||
| 750 | +! |
- )+ pos = pos, |
||
| 396 | -+ | |||
| 751 | +! |
- }+ aes_label = str2lang(aes_label), |
||
| 397 | -+ | |||
| 752 | +! |
-
+ label_size = label_size |
||
| 398 | +753 |
- srv_g_scatterplot <- function(id,+ ) |
||
| 399 | +754 |
- data,+ ) |
||
| 400 | -+ | |||
| 755 | +! |
- reporter,+ substitute( |
||
| 401 | -+ | |||
| 756 | +! |
- filter_panel_api,+ expr = plot_call + label_geom, |
||
| 402 | -+ | |||
| 757 | +! |
- x,+ env = list( |
||
| 403 | -+ | |||
| 758 | +! |
- y,+ plot_call = plot_call, |
||
| 404 | -+ | |||
| 759 | +! |
- color_by,+ label_geom = label_geom |
||
| 405 | +760 |
- size_by,+ ) |
||
| 406 | +761 |
- row_facet,+ ) |
||
| 407 | +762 |
- col_facet,+ } |
||
| 408 | +763 |
- plot_height,+ |
||
| 409 | -+ | |||
| 764 | +! |
- plot_width,+ if (trend_line_is_applicable()) {
|
||
| 410 | -+ | |||
| 765 | +! |
- table_dec,+ shinyjs::hide("line_msg")
|
||
| 411 | -+ | |||
| 766 | +! |
- ggplot2_args) {
+ shinyjs::show("smoothing_degree")
|
||
| 412 | +767 | ! |
- with_reporter <- !missing(reporter) && inherits(reporter, "Reporter")+ if (!add_trend_line()) {
|
|
| 413 | +768 | ! |
- with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI")+ shinyjs::hide("ci")
|
|
| 414 | +769 | ! |
- checkmate::assert_class(data, "reactive")+ shinyjs::hide("color_sub")
|
|
| 415 | +770 | ! |
- checkmate::assert_class(isolate(data()), "teal_data")+ shinyjs::hide("show_form")
|
|
| 416 | +771 | ! |
- moduleServer(id, function(input, output, session) {
+ shinyjs::hide("show_r2")
|
|
| 417 | +772 | ! |
- data_extract <- list(+ if (input$show_count) {
|
|
| 418 | +773 | ! |
- x = x,+ plot_call <- plot_label_generator(show_form = FALSE, show_r2 = FALSE) |
|
| 419 | +774 | ! |
- y = y,+ shinyjs::show("label_pos")
|
|
| 420 | +775 | ! |
- color_by = color_by,+ shinyjs::show("label_size")
|
|
| 421 | -! | +|||
| 776 | +
- size_by = size_by,+ } else {
|
|||
| 422 | +777 | ! |
- row_facet = row_facet,+ shinyjs::hide("label_pos")
|
|
| 423 | +778 | ! |
- col_facet = col_facet+ shinyjs::hide("label_size")
|
|
| 424 | +779 |
- )+ } |
||
| 425 | +780 |
-
+ } else {
|
||
| 426 | +781 | ! |
- rule_diff <- function(other) {
+ shinyjs::show("ci")
|
|
| 427 | +782 | ! |
- function(value) {
+ shinyjs::show("show_form")
|
|
| 428 | +783 | ! |
- othervalue <- selector_list()[[other]]()[["select"]]+ shinyjs::show("show_r2")
|
|
| 429 | +784 | ! |
- if (!is.null(othervalue)) {
+ if (nrow(ANL) - nrow(stats::na.omit(ANL[, c(x_var, y_var)])) > 0) {
|
|
| 430 | +785 | ! |
- if (identical(value, othervalue)) {
+ plot_q <- teal.code::eval_code( |
|
| 431 | +786 | ! |
- "Row and column facetting variables must be different."+ plot_q, |
|
| 432 | -+ | |||
| 787 | +! |
- }+ substitute( |
||
| 433 | -+ | |||
| 788 | +! |
- }+ expr = ANL <- dplyr::filter(ANL, !is.na(x_var) & !is.na(y_var)), # nolint: object_name.+ |
+ ||
| 789 | +! | +
+ env = list(x_var = as.name(x_var), y_var = as.name(y_var)) |
||
| 434 | +790 |
- }+ ) |
||
| 435 | +791 |
- }+ ) |
||
| 436 | +792 |
-
+ } |
||
| 437 | +793 | ! |
- selector_list <- teal.transform::data_extract_multiple_srv(+ rhs_formula <- substitute( |
|
| 438 | +794 | ! |
- data_extract = data_extract,+ expr = y ~ poly(x, smoothing_degree, raw = TRUE), |
|
| 439 | +795 | ! |
- datasets = data,+ env = list(smoothing_degree = smoothing_degree) |
|
| 440 | -! | +|||
| 796 | +
- select_validation_rule = list(+ ) |
|||
| 441 | +797 | ! |
- x = ~ if (length(.) != 1) "Please select exactly one x var.",+ if (input$show_form || input$show_r2 || input$show_count) {
|
|
| 442 | +798 | ! |
- y = ~ if (length(.) != 1) "Please select exactly one y var.",+ plot_call <- plot_label_generator(rhs_formula = rhs_formula) |
|
| 443 | +799 | ! |
- color_by = ~ if (length(.) > 1) "There cannot be more than 1 color variable.",+ shinyjs::show("label_pos")
|
|
| 444 | +800 | ! |
- size_by = ~ if (length(.) > 1) "There cannot be more than 1 size variable.",+ shinyjs::show("label_size")
|
|
| 445 | -! | +|||
| 801 | +
- row_facet = shinyvalidate::compose_rules(+ } else {
|
|||
| 446 | +802 | ! |
- shinyvalidate::sv_optional(),+ shinyjs::hide("label_pos")
|
|
| 447 | +803 | ! |
- rule_diff("col_facet")
+ shinyjs::hide("label_size")
|
|
| 448 | +804 |
- ),+ } |
||
| 449 | +805 | ! |
- col_facet = shinyvalidate::compose_rules(+ plot_call <- substitute( |
|
| 450 | +806 | ! |
- shinyvalidate::sv_optional(),+ expr = plot_call + ggplot2::geom_smooth(formula = rhs_formula, se = TRUE, level = ci, method = "lm"), |
|
| 451 | +807 | ! |
- rule_diff("row_facet")
+ env = list(plot_call = plot_call, rhs_formula = rhs_formula, ci = ci) |
|
| 452 | +808 |
- )+ ) |
||
| 453 | +809 |
- )+ } |
||
| 454 | +810 |
- )+ } else {
|
||
| 455 | -+ | |||
| 811 | +! |
-
+ shinyjs::hide("smoothing_degree")
|
||
| 456 | +812 | ! |
- iv_r <- reactive({
+ shinyjs::hide("ci")
|
|
| 457 | +813 | ! |
- iv_facet <- shinyvalidate::InputValidator$new()+ shinyjs::hide("color_sub")
|
|
| 458 | +814 | ! |
- iv <- shinyvalidate::InputValidator$new()+ shinyjs::hide("show_form")
|
|
| 459 | +815 | ! |
- teal.transform::compose_and_enable_validators(iv, selector_list)+ shinyjs::hide("show_r2")
|
|
| 460 | -+ | |||
| 816 | +! |
- })+ if (input$show_count) {
|
||
| 461 | +817 | ! |
- iv_facet <- shinyvalidate::InputValidator$new()+ plot_call <- plot_label_generator(show_form = FALSE, show_r2 = FALSE) |
|
| 462 | +818 | ! |
- iv_facet$add_rule("add_density", ~ if (isTRUE(.) &&
+ shinyjs::show("label_pos")
|
|
| 463 | +819 | ! |
- (length(selector_list()$row_facet()$select) > 0L ||+ shinyjs::show("label_size")
+ |
+ |
| 820 | ++ |
+ } else {
|
||
| 464 | +821 | ! |
- length(selector_list()$col_facet()$select) > 0L)) {
+ shinyjs::hide("label_pos")
|
|
| 465 | +822 | ! |
- "Cannot add marginal density when Row or Column facetting has been selected"+ shinyjs::hide("label_size")
|
|
| 466 | +823 |
- })+ } |
||
| 467 | +824 | ! |
- iv_facet$enable()+ shinyjs::show("line_msg")
|
|
| 468 | +825 | ++ |
+ }+ |
+ |
| 826 | ||||
| 469 | +827 | ! |
- anl_merged_input <- teal.transform::merge_expression_srv(+ if (!is.null(facet_cl)) {
|
|
| 470 | +828 | ! |
- selector_list = selector_list,+ plot_call <- substitute(expr = plot_call + facet_cl, env = list(plot_call = plot_call, facet_cl = facet_cl))+ |
+ |
| 829 | ++ |
+ }+ |
+ ||
| 830 | ++ | + | ||
| 471 | +831 | ! |
- datasets = data,+ y_label <- varname_w_label( |
|
| 472 | +832 | ! |
- merge_function = "dplyr::inner_join"+ y_var, |
|
| 473 | -+ | |||
| 833 | +! |
- )+ ANL,+ |
+ ||
| 834 | +! | +
+ prefix = if (log_y) paste(log_y_fn, "(") else NULL,
+ |
+ ||
| 835 | +! | +
+ suffix = if (log_y) ")" else NULL |
||
| 474 | +836 |
-
+ ) |
||
| 475 | +837 | ! |
- anl_merged_q <- reactive({
+ x_label <- varname_w_label( |
|
| 476 | +838 | +! | +
+ x_var,+ |
+ |
| 839 | +! | +
+ ANL,+ |
+ ||
| 840 | ! |
- req(anl_merged_input())+ prefix = if (log_x) paste(log_x_fn, "(") else NULL,
+ |
+ ||
| 841 | +! | +
+ suffix = if (log_x) ")" else NULL+ |
+ ||
| 842 | ++ |
+ )+ |
+ ||
| 843 | ++ | + | ||
| 477 | +844 | ! |
- data() %>%+ dev_ggplot2_args <- teal.widgets::ggplot2_args( |
|
| 478 | +845 | ! |
- teal.code::eval_code(as.expression(anl_merged_input()$expr)) %>%+ labs = list(y = y_label, x = x_label), |
|
| 479 | +846 | ! |
- teal.code::eval_code(quote(ANL)) # used to display table when running show-r-code code+ theme = list(legend.position = "bottom") |
|
| 480 | +847 |
- })+ ) |
||
| 481 | +848 | |||
| 482 | -! | -
- merged <- list(- |
- ||
| 483 | +849 | ! |
- anl_input_r = anl_merged_input,+ if (rotate_xaxis_labels) {
|
|
| 484 | +850 | ! |
- anl_q_r = anl_merged_q+ dev_ggplot2_args$theme[["axis.text.x"]] <- quote(element_text(angle = 45, hjust = 1)) |
|
| 485 | +851 |
- )+ } |
||
| 486 | +852 | |||
| 487 | +853 | ! |
- trend_line_is_applicable <- reactive({
+ all_ggplot2_args <- teal.widgets::resolve_ggplot2_args( |
|
| 488 | +854 | ! |
- ANL <- merged$anl_q_r()[["ANL"]] # nolint object_name_linter+ user_plot = ggplot2_args, |
|
| 489 | +855 | ! |
- x_var <- as.vector(merged$anl_input_r()$columns_source$x)+ module_plot = dev_ggplot2_args |
|
| 490 | -! | +|||
| 856 | +
- y_var <- as.vector(merged$anl_input_r()$columns_source$y)+ )+ |
+ |||
| 857 | ++ | + | ||
| 491 | +858 | ! |
- length(x_var) > 0 && length(y_var) > 0 && is.numeric(ANL[[x_var]]) && is.numeric(ANL[[y_var]])+ parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(all_ggplot2_args, ggtheme = ggtheme) |
|
| 492 | +859 |
- })+ |
||
| 493 | +860 | |||
| 494 | +861 | ! |
- add_trend_line <- reactive({
+ if (add_density) {
|
|
| 495 | +862 | ! |
- smoothing_degree <- as.integer(input$smoothing_degree)+ plot_call <- substitute( |
|
| 496 | +863 | ! |
- trend_line_is_applicable() && length(smoothing_degree) > 0- |
- |
| 497 | -- |
- })+ expr = ggExtra::ggMarginal( |
||
| 498 | -+ | |||
| 864 | +! |
-
+ plot_call + labs + ggthemes + themes, |
||
| 499 | +865 | ! |
- if (!is.null(color_by)) {
+ type = "density", |
|
| 500 | +866 | ! |
- observeEvent(+ groupColour = group_colour |
|
| 501 | -! | +|||
| 867 | +
- eventExpr = merged$anl_input_r()$columns_source$color_by,+ ), |
|||
| 502 | +868 | ! |
- handlerExpr = {
+ env = list( |
|
| 503 | +869 | ! |
- color_by_var <- as.vector(merged$anl_input_r()$columns_source$color_by)+ plot_call = plot_call, |
|
| 504 | +870 | ! |
- if (length(color_by_var) > 0) {
+ group_colour = if (length(color_by_var) > 0) TRUE else FALSE, |
|
| 505 | +871 | ! |
- shinyjs::hide("color")
+ labs = parsed_ggplot2_args$labs, |
|
| 506 | -+ | |||
| 872 | +! |
- } else {
+ ggthemes = parsed_ggplot2_args$ggtheme, |
||
| 507 | +873 | ! |
- shinyjs::show("color")
+ themes = parsed_ggplot2_args$theme |
|
| 508 | +874 |
- }+ ) |
||
| 509 | +875 |
- }+ ) |
||
| 510 | +876 |
- )+ } else {
|
||
| 511 | -+ | |||
| 877 | +! |
- }+ plot_call <- substitute( |
||
| 512 | -+ | |||
| 878 | +! |
-
+ expr = plot_call + |
||
| 513 | +879 | ! |
- output$num_na_removed <- renderUI({
+ labs + |
|
| 514 | +880 | ! |
- if (add_trend_line()) {
+ ggthemes + |
|
| 515 | +881 | +! | +
+ themes,+ |
+ |
| 882 | ! |
- ANL <- merged$anl_q_r()[["ANL"]] # nolint object_name_linter+ env = list( |
||
| 516 | +883 | ! |
- x_var <- as.vector(merged$anl_input_r()$columns_source$x)+ plot_call = plot_call, |
|
| 517 | +884 | ! |
- y_var <- as.vector(merged$anl_input_r()$columns_source$y)+ labs = parsed_ggplot2_args$labs, |
|
| 518 | +885 | ! |
- if ((num_total_na <- nrow(ANL) - nrow(stats::na.omit(ANL[, c(x_var, y_var)]))) > 0) {
+ ggthemes = parsed_ggplot2_args$ggtheme, |
|
| 519 | +886 | ! |
- shiny::tags$div(paste(num_total_na, "row(s) with missing values were removed"), shiny::tags$hr())+ themes = parsed_ggplot2_args$theme |
|
| 520 | +887 |
- }+ ) |
||
| 521 | +888 |
- }+ ) |
||
| 522 | +889 |
- })+ } |
||
| 523 | +890 | |||
| 524 | -! | -
- observeEvent(- |
- ||
| 525 | +891 | ! |
- eventExpr = merged$anl_input_r()$columns_source[c("col_facet", "row_facet")],
+ plot_call <- substitute(expr = p <- plot_call, env = list(plot_call = plot_call)) |
|
| 526 | -! | +|||
| 892 | +
- handlerExpr = {
+
|
|||
| 527 | +893 | ! |
- if (length(merged$anl_input_r()$columns_source$col_facet) == 0 &&+ teal.code::eval_code(plot_q, plot_call) %>% |
|
| 528 | +894 | ! |
- length(merged$anl_input_r()$columns_source$row_facet) == 0) {
+ teal.code::eval_code(quote(print(p))) |
|
| 529 | -! | +|||
| 895 | +
- shinyjs::hide("free_scales")
+ }) |
|||
| 530 | +896 |
- } else {
+
|
||
| 531 | +897 | ! |
- shinyjs::show("free_scales")
+ plot_r <- reactive(output_q()[["p"]]) |
|
| 532 | +898 |
- }+ |
||
| 533 | +899 |
- }+ # Insert the plot into a plot_with_settings module from teal.widgets |
||
| 534 | -+ | |||
| 900 | +! |
- )+ pws <- teal.widgets::plot_with_settings_srv( |
||
| 535 | -+ | |||
| 901 | +! |
-
+ id = "scatter_plot", |
||
| 536 | +902 | ! |
- output_q <- reactive({
+ plot_r = plot_r, |
|
| 537 | +903 | ! |
- teal::validate_inputs(iv_r(), iv_facet)+ height = plot_height, |
|
| 538 | -+ | |||
| 904 | +! |
-
+ width = plot_width, |
||
| 539 | +905 | ! |
- ANL <- merged$anl_q_r()[["ANL"]] # nolint object_name_linter+ brushing = TRUE |
|
| 540 | +906 | ++ |
+ )+ |
+ |
| 907 | ||||
| 541 | +908 | ! |
- x_var <- as.vector(merged$anl_input_r()$columns_source$x)+ output$data_table <- DT::renderDataTable({
|
|
| 542 | +909 | ! |
- y_var <- as.vector(merged$anl_input_r()$columns_source$y)+ plot_brush <- pws$brush() |
|
| 543 | -! | +|||
| 910 | +
- color_by_var <- as.vector(merged$anl_input_r()$columns_source$color_by)+ |
|||
| 544 | +911 | ! |
- size_by_var <- as.vector(merged$anl_input_r()$columns_source$size_by)+ if (!is.null(plot_brush)) {
|
|
| 545 | +912 | ! |
- row_facet_name <- if (length(merged$anl_input_r()$columns_source$row_facet) == 0) {
+ validate(need(!input$add_density, "Brushing feature is currently not supported when plot has marginal density")) |
|
| 546 | -! | +|||
| 913 | +
- character(0)+ } |
|||
| 547 | +914 |
- } else {
+
|
||
| 548 | +915 | ! |
- as.vector(merged$anl_input_r()$columns_source$row_facet)+ merged_data <- isolate(teal.code::dev_suppress(output_q()[["ANL"]])) |
|
| 549 | +916 |
- }+ |
||
| 550 | +917 | ! |
- col_facet_name <- if (length(merged$anl_input_r()$columns_source$col_facet) == 0) {
+ brushed_df <- teal.widgets::clean_brushedPoints(merged_data, plot_brush) |
|
| 551 | +918 | ! |
- character(0)+ numeric_cols <- names(brushed_df)[ |
|
| 552 | -+ | |||
| 919 | +! |
- } else {
+ vapply(brushed_df, function(x) is.numeric(x) && !is.integer(x), FUN.VALUE = logical(1)) |
||
| 553 | -! | +|||
| 920 | +
- as.vector(merged$anl_input_r()$columns_source$col_facet)+ ] |
|||
| 554 | +921 |
- }+ |
||
| 555 | +922 | ! |
- alpha <- input$alpha+ if (length(numeric_cols) > 0) {
|
|
| 556 | +923 | ! |
- size <- input$size+ DT::formatRound( |
|
| 557 | +924 | ! |
- rotate_xaxis_labels <- input$rotate_xaxis_labels+ DT::datatable(brushed_df, |
|
| 558 | +925 | ! |
- add_density <- input$add_density+ rownames = FALSE, |
|
| 559 | +926 | ! |
- ggtheme <- input$ggtheme+ options = list(scrollX = TRUE, pageLength = input$data_table_rows) |
|
| 560 | -! | +|||
| 927 | +
- rug_plot <- input$rug_plot+ ), |
|||
| 561 | +928 | ! |
- color <- input$color+ numeric_cols, |
|
| 562 | +929 | ! |
- shape <- `if`(is.null(input$shape) || identical(input$shape, ""), "circle", input$shape)+ table_dec |
|
| 563 | -! | +|||
| 930 | +
- smoothing_degree <- as.integer(input$smoothing_degree)+ )+ |
+ |||
| 931 | ++ |
+ } else {
|
||
| 564 | +932 | ! |
- ci <- input$ci+ DT::datatable(brushed_df, rownames = FALSE, options = list(scrollX = TRUE, pageLength = input$data_table_rows)) |
|
| 565 | +933 | ++ |
+ }+ |
+ |
| 934 | ++ |
+ })+ |
+ ||
| 935 | ||||
| 566 | +936 | ! |
- log_x <- input$log_x+ teal.widgets::verbatim_popup_srv( |
|
| 567 | +937 | ! |
- log_y <- input$log_y+ id = "warning", |
|
| 568 | -+ | |||
| 938 | +! |
-
+ verbatim_content = reactive(teal.code::get_warnings(output_q())), |
||
| 569 | +939 | ! |
- validate(need(+ title = "Warning", |
|
| 570 | +940 | ! |
- length(row_facet_name) == 0 || inherits(ANL[[row_facet_name]], c("character", "factor", "Date", "integer")),
+ disabled = reactive(is.null(teal.code::get_warnings(output_q()))) |
|
| 571 | -! | +|||
| 941 | +
- "`Row facetting` variable must be of class `character`, `factor`, `Date`, or `integer`"+ ) |
|||
| 572 | +942 |
- ))+ |
||
| 573 | +943 | +! | +
+ teal.widgets::verbatim_popup_srv(+ |
+ |
| 944 | ! |
- validate(need(+ id = "rcode", |
||
| 574 | +945 | ! |
- length(col_facet_name) == 0 || inherits(ANL[[col_facet_name]], c("character", "factor", "Date", "integer")),
+ verbatim_content = reactive(teal.code::get_code(output_q())), |
|
| 575 | +946 | ! |
- "`Column facetting` variable must be of class `character`, `factor`, `Date`, or `integer`"+ title = "R Code for scatterplot" |
|
| 576 | +947 |
- ))+ ) |
||
| 577 | +948 | |||
| 578 | -! | +|||
| 949 | +
- if (add_density && length(color_by_var) > 0) {
+ ### REPORTER |
|||
| 579 | +950 | ! |
- validate(need(+ if (with_reporter) {
|
|
| 580 | +951 | ! |
- !is.numeric(ANL[[color_by_var]]),+ card_fun <- function(comment, label) {
|
|
| 581 | +952 | ! |
- "Marginal plots cannot be produced when the points are colored by numeric variables.+ card <- teal::report_card_template( |
|
| 582 | +953 | ! |
- \n Uncheck the 'Add marginal density' checkbox to display the plot."+ title = "Scatter Plot", |
|
| 583 | -+ | |||
| 954 | +! |
- ))+ label = label, |
||
| 584 | +955 | ! |
- validate(need(+ with_filter = with_filter, |
|
| 585 | +956 | ! |
- !(inherits(ANL[[color_by_var]], "Date") ||+ filter_panel_api = filter_panel_api |
|
| 586 | -! | +|||
| 957 | +
- inherits(ANL[[color_by_var]], "POSIXct") ||+ ) |
|||
| 587 | +958 | ! |
- inherits(ANL[[color_by_var]], "POSIXlt")),+ card$append_text("Plot", "header3")
|
|
| 588 | +959 | ! |
- "Marginal plots cannot be produced when the points are colored by Date or POSIX variables.+ card$append_plot(plot_r(), dim = pws$dim()) |
|
| 589 | +960 | ! |
- \n Uncheck the 'Add marginal density' checkbox to display the plot."+ if (!comment == "") {
|
|
| 590 | -+ | |||
| 961 | +! |
- ))+ card$append_text("Comment", "header3")
|
||
| 591 | -+ | |||
| 962 | +! |
- }+ card$append_text(comment) |
||
| 592 | +963 |
-
+ } |
||
| 593 | +964 | ! |
- teal::validate_has_data(ANL[, c(x_var, y_var)], 10, complete = TRUE, allow_inf = FALSE)- |
- |
| 594 | -- |
-
+ card$append_src(teal.code::get_code(output_q())) |
||
| 595 | +965 | ! |
- if (log_x) {
+ card |
|
| 596 | -! | +|||
| 966 | +
- validate(+ } |
|||
| 597 | +967 | ! |
- need(+ teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
|
|
| 598 | -! | +|||
| 968 | +
- is.numeric(ANL[[x_var]]) && all(+ } |
|||
| 599 | -! | +|||
| 969 | +
- ANL[[x_var]] > 0 | is.na(ANL[[x_var]])+ ### |
|||
| 600 | +970 |
- ),+ }) |
||
| 601 | -! | +|||
| 971 | +
- "X variable can only be log transformed if variable is numeric and all values are positive."+ } |
| 602 | +1 |
- )+ #' Create a simple cross-table |
||||
| 603 | +2 |
- )+ #' @md |
||||
| 604 | +3 |
- }+ #' |
||||
| 605 | -! | +|||||
| 4 | +
- if (log_y) {
+ #' @inheritParams teal::module |
|||||
| 606 | -! | +|||||
| 5 | +
- validate(+ #' @inheritParams shared_params |
|||||
| 607 | -! | +|||||
| 6 | +
- need(+ #' @param x (`data_extract_spec` or `list` of multiple `data_extract_spec`) |
|||||
| 608 | -! | +|||||
| 7 | +
- is.numeric(ANL[[y_var]]) && all(+ #' Object with all available choices with pre-selected option for variable X - row values. In case |
|||||
| 609 | -! | +|||||
| 8 | +
- ANL[[y_var]] > 0 | is.na(ANL[[y_var]])+ #' of `data_extract_spec` use `select_spec(..., ordered = TRUE)` if table elements should be |
|||||
| 610 | +9 |
- ),+ #' rendered according to selection order. |
||||
| 611 | -! | +|||||
| 10 | +
- "Y variable can only be log transformed if variable is numeric and all values are positive."+ #' @param y (`data_extract_spec` or `list` of multiple `data_extract_spec`) |
|||||
| 612 | +11 |
- )+ #' Object with all available choices with pre-selected option for variable Y - column values |
||||
| 613 | +12 |
- )+ #' \code{data_extract_spec} must not allow multiple selection in this case.
|
||||
| 614 | +13 |
- }+ #' |
||||
| 615 | +14 |
-
+ #' @param show_percentage optional, (`logical`) Whether to show percentages |
||||
| 616 | -! | +|||||
| 15 | +
- facet_cl <- facet_ggplot_call(+ #' (relevant only when `x` is a `factor`). Defaults to `TRUE`. |
|||||
| 617 | -! | +|||||
| 16 | +
- row_facet_name,+ #' @param show_total optional, (`logical`) Whether to show total column. Defaults to `TRUE`. |
|||||
| 618 | -! | +|||||
| 17 | +
- col_facet_name,+ #' |
|||||
| 619 | -! | +|||||
| 18 | +
- free_x_scales = isTRUE(input$free_scales),+ #' @note For more examples, please see the vignette "Using cross table" via |
|||||
| 620 | -! | +|||||
| 19 | +
- free_y_scales = isTRUE(input$free_scales)+ #' `vignette("using-cross-table", package = "teal.modules.general")`.
|
|||||
| 621 | +20 |
- )+ #' |
||||
| 622 | +21 |
-
+ #' @export |
||||
| 623 | -! | +|||||
| 22 | +
- point_sizes <- if (length(size_by_var) > 0) {
+ #' |
|||||
| 624 | -! | +|||||
| 23 | +
- validate(need(is.numeric(ANL[[size_by_var]]), "Variable to size by must be numeric"))+ #' @examples |
|||||
| 625 | -! | +|||||
| 24 | +
- substitute(+ #' # Percentage cross table of variables from ADSL dataset |
|||||
| 626 | -! | +|||||
| 25 | +
- expr = size * ANL[[size_by_var]] / max(ANL[[size_by_var]], na.rm = TRUE),+ #' |
|||||
| 627 | -! | +|||||
| 26 | +
- env = list(size = size, size_by_var = size_by_var)+ #' data <- teal_data() |
|||||
| 628 | +27 |
- )+ #' data <- within(data, {
|
||||
| 629 | +28 |
- } else {
+ #' ADSL <- teal.modules.general::rADSL |
||||
| 630 | -! | +|||||
| 29 | +
- size+ #' }) |
|||||
| 631 | +30 |
- }+ #' datanames <- c("ADSL")
|
||||
| 632 | +31 |
-
+ #' datanames(data) <- datanames |
||||
| 633 | -! | +|||||
| 32 | +
- plot_q <- merged$anl_q_r()+ #' join_keys(data) <- default_cdisc_join_keys[datanames] |
|||||
| 634 | +33 |
-
+ #' |
||||
| 635 | -! | +|||||
| 34 | +
- if (log_x) {
+ #' app <- teal::init( |
|||||
| 636 | -! | +|||||
| 35 | +
- log_x_fn <- input$log_x_base+ #' data = data, |
|||||
| 637 | -! | +|||||
| 36 | +
- plot_q <- teal.code::eval_code(+ #' modules = teal::modules( |
|||||
| 638 | -! | +|||||
| 37 | +
- object = plot_q,+ #' teal.modules.general::tm_t_crosstable( |
|||||
| 639 | -! | +|||||
| 38 | +
- code = substitute(+ #' label = "Cross Table", |
|||||
| 640 | -! | +|||||
| 39 | +
- expr = ANL[, log_x_var] <- log_x_fn(ANL[, x_var]), # nolint object_name_linter+ #' x = teal.transform::data_extract_spec( |
|||||
| 641 | -! | +|||||
| 40 | +
- env = list(+ #' dataname = "ADSL", |
|||||
| 642 | -! | +|||||
| 41 | +
- x_var = x_var,+ #' select = teal.transform::select_spec( |
|||||
| 643 | -! | +|||||
| 42 | +
- log_x_fn = as.name(log_x_fn),+ #' label = "Select variable:", |
|||||
| 644 | -! | +|||||
| 43 | +
- log_x_var = paste0(log_x_fn, "_", x_var)+ #' choices = variable_choices(data[["ADSL"]], subset = function(data) {
|
|||||
| 645 | +44 |
- )+ #' idx <- !vapply(data, inherits, logical(1), c("Date", "POSIXct", "POSIXlt"))
|
||||
| 646 | +45 |
- )+ #' return(names(data)[idx]) |
||||
| 647 | +46 |
- )+ #' }), |
||||
| 648 | +47 |
- }+ #' selected = "COUNTRY", |
||||
| 649 | +48 |
-
+ #' multiple = TRUE, |
||||
| 650 | -! | +|||||
| 49 | +
- if (log_y) {
+ #' ordered = TRUE, |
|||||
| 651 | -! | +|||||
| 50 | +
- log_y_fn <- input$log_y_base+ #' fixed = FALSE |
|||||
| 652 | -! | +|||||
| 51 | +
- plot_q <- teal.code::eval_code(+ #' ) |
|||||
| 653 | -! | +|||||
| 52 | +
- object = plot_q,+ #' ), |
|||||
| 654 | -! | +|||||
| 53 | +
- code = substitute(+ #' y = teal.transform::data_extract_spec( |
|||||
| 655 | -! | +|||||
| 54 | +
- expr = ANL[, log_y_var] <- log_y_fn(ANL[, y_var]), # nolint object_name_linter+ #' dataname = "ADSL", |
|||||
| 656 | -! | +|||||
| 55 | +
- env = list(+ #' select = teal.transform::select_spec( |
|||||
| 657 | -! | +|||||
| 56 | +
- y_var = y_var,+ #' label = "Select variable:", |
|||||
| 658 | -! | +|||||
| 57 | +
- log_y_fn = as.name(log_y_fn),+ #' choices = variable_choices(data[["ADSL"]], subset = function(data) {
|
|||||
| 659 | -! | +|||||
| 58 | +
- log_y_var = paste0(log_y_fn, "_", y_var)+ #' idx <- vapply(data, is.factor, logical(1)) |
|||||
| 660 | +59 |
- )+ #' return(names(data)[idx]) |
||||
| 661 | +60 |
- )+ #' }), |
||||
| 662 | +61 |
- )+ #' selected = "SEX", |
||||
| 663 | +62 |
- }+ #' multiple = FALSE, |
||||
| 664 | +63 |
-
+ #' fixed = FALSE |
||||
| 665 | -! | +|||||
| 64 | +
- pre_pro_anl <- if (input$show_count) {
+ #' ) |
|||||
| 666 | -! | +|||||
| 65 | +
- paste0(+ #' ), |
|||||
| 667 | -! | +|||||
| 66 | +
- "ANL %>% dplyr::group_by(",
+ #' basic_table_args = teal.widgets::basic_table_args( |
|||||
| 668 | -! | +|||||
| 67 | +
- paste(+ #' subtitles = "Table generated by Crosstable Module" |
|||||
| 669 | -! | +|||||
| 68 | +
- c(+ #' ) |
|||||
| 670 | -! | +|||||
| 69 | +
- if (length(color_by_var) > 0 && inherits(ANL[[color_by_var]], c("factor", "character"))) color_by_var,
+ #' ) |
|||||
| 671 | -! | +|||||
| 70 | +
- row_facet_name,+ #' ) |
|||||
| 672 | -! | +|||||
| 71 | +
- col_facet_name+ #' ) |
|||||
| 673 | +72 |
- ),+ #' if (interactive()) {
|
||||
| 674 | -! | +|||||
| 73 | +
- collapse = ", "+ #' shinyApp(app$ui, app$server) |
|||||
| 675 | +74 |
- ),+ #' } |
||||
| 676 | -! | +|||||
| 75 | +
- ") %>% dplyr::mutate(n = dplyr::n()) %>% dplyr::ungroup()"+ tm_t_crosstable <- function(label = "Cross Table", |
|||||
| 677 | +76 |
- )+ x, |
||||
| 678 | +77 |
- } else {
+ y, |
||||
| 679 | -! | +|||||
| 78 | +
- "ANL"+ show_percentage = TRUE, |
|||||
| 680 | +79 |
- }+ show_total = TRUE, |
||||
| 681 | +80 |
-
+ pre_output = NULL, |
||||
| 682 | -! | +|||||
| 81 | +
- plot_call <- substitute(expr = pre_pro_anl %>% ggplot(), env = list(pre_pro_anl = str2lang(pre_pro_anl)))+ post_output = NULL, |
|||||
| 683 | +82 |
-
+ basic_table_args = teal.widgets::basic_table_args()) {
|
||||
| 684 | +83 | ! |
- plot_call <- if (length(color_by_var) == 0) {
+ logger::log_info("Initializing tm_t_crosstable")
|
|||
| 685 | +84 | ! |
- substitute(+ if (!requireNamespace("rtables", quietly = TRUE)) {
|
|||
| 686 | +85 | ! |
- expr = plot_call ++ stop("Cannot load rtables - please install the package or restart your session.")
+ |
+ |||
| 86 | ++ |
+ } |
||||
| 687 | +87 | ! |
- ggplot2::aes(x = x_name, y = y_name) ++ if (inherits(x, "data_extract_spec")) x <- list(x) |
|||
| 688 | +88 | ! |
- ggplot2::geom_point(alpha = alpha_value, size = point_sizes, shape = shape_value, color = color_value),+ if (inherits(y, "data_extract_spec")) y <- list(y)+ |
+ |||
| 89 | ++ | + | ||||
| 689 | +90 | ! |
- env = list(+ checkmate::assert_string(label) |
|||
| 690 | +91 | ! |
- plot_call = plot_call,+ checkmate::assert_list(x, types = "data_extract_spec") |
|||
| 691 | +92 | ! |
- x_name = if (log_x) as.name(paste0(log_x_fn, "_", x_var)) else as.name(x_var),+ checkmate::assert_list(y, types = "data_extract_spec") |
|||
| 692 | +93 | ! |
- y_name = if (log_y) as.name(paste0(log_y_fn, "_", y_var)) else as.name(y_var),+ if (any(vapply(y, function(x) x$select$multiple, logical(1)))) {
|
|||
| 693 | +94 | ! |
- alpha_value = alpha,+ stop("'y' should not allow multiple selection")
+ |
+ |||
| 95 | ++ |
+ } |
||||
| 694 | +96 | ! |
- point_sizes = point_sizes,+ checkmate::assert_flag(show_percentage) |
|||
| 695 | +97 | ! |
- shape_value = shape,+ checkmate::assert_flag(show_total) |
|||
| 696 | +98 | ! |
- color_value = color+ checkmate::assert_class(basic_table_args, classes = "basic_table_args") |
|||
| 697 | +99 |
- )+ |
||||
| 698 | -+ | |||||
| 100 | +! |
- )+ ui_args <- as.list(environment()) |
||||
| 699 | +101 |
- } else {
+
|
||||
| 700 | +102 | ! |
- substitute(+ server_args <- list( |
|||
| 701 | +103 | ! |
- expr = plot_call ++ label = label, |
|||
| 702 | +104 | ! |
- ggplot2::aes(x = x_name, y = y_name, color = color_by_var_name) ++ x = x, |
|||
| 703 | +105 | ! |
- ggplot2::geom_point(alpha = alpha_value, size = point_sizes, shape = shape_value),+ y = y, |
|||
| 704 | +106 | ! |
- env = list(+ basic_table_args = basic_table_args+ |
+ |||
| 107 | ++ |
+ )+ |
+ ||||
| 108 | ++ | + | ||||
| 705 | +109 | ! |
- plot_call = plot_call,+ module( |
|||
| 706 | +110 | ! |
- x_name = if (log_x) as.name(paste0(log_x_fn, "_", x_var)) else as.name(x_var),+ label = label, |
|||
| 707 | +111 | ! |
- y_name = if (log_y) as.name(paste0(log_y_fn, "_", y_var)) else as.name(y_var),+ server = srv_t_crosstable, |
|||
| 708 | +112 | ! |
- color_by_var_name = as.name(color_by_var),+ ui = ui_t_crosstable, |
|||
| 709 | +113 | ! |
- alpha_value = alpha,+ ui_args = ui_args, |
|||
| 710 | +114 | ! |
- point_sizes = point_sizes,+ server_args = server_args, |
|||
| 711 | +115 | ! |
- shape_value = shape+ datanames = teal.transform::get_extract_datanames(list(x = x, y = y)) |
|||
| 712 | +116 |
- )+ ) |
||||
| 713 | +117 |
- )+ } |
||||
| 714 | +118 |
- }+ |
||||
| 715 | +119 |
-
+ ui_t_crosstable <- function(id, x, y, show_percentage, show_total, pre_output, post_output, ...) {
|
||||
| 716 | +120 | ! |
- if (rug_plot) plot_call <- substitute(expr = plot_call + geom_rug(), env = list(plot_call = plot_call))- |
- |||
| 717 | -- |
-
+ ns <- NS(id) |
||||
| 718 | +121 | ! |
- plot_label_generator <- function(rhs_formula = quote(y ~ 1),+ is_single_dataset <- teal.transform::is_single_dataset(x, y) |
|||
| 719 | -! | +|||||
| 122 | +
- show_form = input$show_form,+ |
|||||
| 720 | +123 | ! |
- show_r2 = input$show_r2,+ join_default_options <- c( |
|||
| 721 | +124 | ! |
- show_count = input$show_count,+ "Full Join" = "dplyr::full_join", |
|||
| 722 | +125 | ! |
- pos = input$pos,+ "Inner Join" = "dplyr::inner_join", |
|||
| 723 | +126 | ! |
- label_size = input$label_size) {
+ "Left Join" = "dplyr::left_join", |
|||
| 724 | +127 | ! |
- stopifnot(sum(show_form, show_r2, show_count) >= 1)+ "Right Join" = "dplyr::right_join" |
|||
| 725 | -! | +|||||
| 128 | +
- aes_label <- paste0(+ ) |
|||||
| 726 | -! | +|||||
| 129 | +
- "aes(",
+
|
|||||
| 727 | +130 | ! |
- if (show_count) "n = n, ",+ teal.widgets::standard_layout( |
|||
| 728 | +131 | ! |
- "label = ",+ output = teal.widgets::white_small_well( |
|||
| 729 | +132 | ! |
- if (sum(show_form, show_r2, show_count) > 1) "paste(",
+ textOutput(ns("title")),
|
|||
| 730 | +133 | ! |
- paste(+ teal.widgets::table_with_settings_ui(ns("table"))
|
|||
| 731 | -! | +|||||
| 134 | +
- c(+ ), |
|||||
| 732 | +135 | ! |
- if (show_form) "stat(eq.label)",+ encoding = div( |
|||
| 733 | -! | +|||||
| 136 | +
- if (show_r2) "stat(adj.rr.label)",+ ### Reporter |
|||||
| 734 | +137 | ! |
- if (show_count) "paste('N ~`=`~', n)"
+ teal.reporter::simple_reporter_ui(ns("simple_reporter")),
|
|||
| 735 | +138 |
- ),+ ### |
||||
| 736 | +139 | ! |
- collapse = ", "+ tags$label("Encodings", class = "text-primary"),
|
|||
| 737 | -+ | |||||
| 140 | +! |
- ),+ teal.transform::datanames_input(list(x, y)), |
||||
| 738 | +141 | ! |
- if (sum(show_form, show_r2, show_count) > 1) ", sep = '*\", \"*'))" else ")"+ teal.transform::data_extract_ui(ns("x"), label = "Row values", x, is_single_dataset = is_single_dataset),
|
|||
| 739 | -+ | |||||
| 142 | +! |
- )+ teal.transform::data_extract_ui(ns("y"), label = "Column values", y, is_single_dataset = is_single_dataset),
|
||||
| 740 | +143 | ! |
- label_geom <- substitute(+ teal.widgets::optionalSelectInput( |
|||
| 741 | +144 | ! |
- expr = ggpmisc::stat_poly_eq(+ ns("join_fun"),
|
|||
| 742 | +145 | ! |
- mapping = aes_label,+ label = "Row to Column type of join", |
|||
| 743 | +146 | ! |
- formula = rhs_formula,+ choices = join_default_options, |
|||
| 744 | +147 | ! |
- parse = TRUE,+ selected = join_default_options[1], |
|||
| 745 | +148 | ! |
- label.x = pos,+ multiple = FALSE+ |
+ |||
| 149 | ++ |
+ ), |
||||
| 746 | +150 | ! |
- size = label_size+ tags$hr(), |
|||
| 747 | -+ | |||||
| 151 | +! |
- ),+ teal.widgets::panel_group( |
||||
| 748 | +152 | ! |
- env = list(+ teal.widgets::panel_item( |
|||
| 749 | +153 | ! |
- rhs_formula = rhs_formula,+ title = "Table settings", |
|||
| 750 | +154 | ! |
- pos = pos,+ checkboxInput(ns("show_percentage"), "Show column percentage", value = show_percentage),
|
|||
| 751 | +155 | ! |
- aes_label = str2lang(aes_label),+ checkboxInput(ns("show_total"), "Show total column", value = show_total)
|
|||
| 752 | -! | +|||||
| 156 | +
- label_size = label_size+ ) |
|||||
| 753 | +157 |
- )+ ) |
||||
| 754 | +158 |
- )+ ), |
||||
| 755 | +159 | ! |
- substitute(+ forms = tagList( |
|||
| 756 | +160 | ! |
- expr = plot_call + label_geom,+ teal.widgets::verbatim_popup_ui(ns("warning"), "Show Warnings"),
|
|||
| 757 | +161 | ! |
- env = list(+ teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code")
|
|||
| 758 | -! | +|||||
| 162 | +
- plot_call = plot_call,+ ), |
|||||
| 759 | +163 | ! |
- label_geom = label_geom+ pre_output = pre_output, |
|||
| 760 | -+ | |||||
| 164 | +! |
- )+ post_output = post_output |
||||
| 761 | +165 |
- )+ ) |
||||
| 762 | +166 |
- }+ } |
||||
| 763 | +167 | |||||
| 764 | -! | +|||||
| 168 | +
- if (trend_line_is_applicable()) {
+ srv_t_crosstable <- function(id, data, reporter, filter_panel_api, label, x, y, basic_table_args) {
|
|||||
| 765 | +169 | ! |
- shinyjs::hide("line_msg")
+ with_reporter <- !missing(reporter) && inherits(reporter, "Reporter") |
|||
| 766 | +170 | ! |
- shinyjs::show("smoothing_degree")
+ with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI") |
|||
| 767 | +171 | ! |
- if (!add_trend_line()) {
+ checkmate::assert_class(data, "reactive") |
|||
| 768 | +172 | ! |
- shinyjs::hide("ci")
+ checkmate::assert_class(isolate(data()), "teal_data") |
|||
| 769 | +173 | ! |
- shinyjs::hide("color_sub")
+ moduleServer(id, function(input, output, session) {
|
|||
| 770 | +174 | ! |
- shinyjs::hide("show_form")
+ selector_list <- teal.transform::data_extract_multiple_srv( |
|||
| 771 | +175 | ! |
- shinyjs::hide("show_r2")
+ data_extract = list(x = x, y = y), |
|||
| 772 | +176 | ! |
- if (input$show_count) {
+ datasets = data, |
|||
| 773 | +177 | ! |
- plot_call <- plot_label_generator(show_form = FALSE, show_r2 = FALSE)+ select_validation_rule = list( |
|||
| 774 | +178 | ! |
- shinyjs::show("label_pos")
+ x = shinyvalidate::sv_required("Please define column for row variable."),
|
|||
| 775 | +179 | ! |
- shinyjs::show("label_size")
+ y = shinyvalidate::sv_required("Please define column for column variable.")
|
|||
| 776 | +180 |
- } else {
- |
- ||||
| 777 | -! | -
- shinyjs::hide("label_pos")
- |
- ||||
| 778 | -! | -
- shinyjs::hide("label_size")
+ ) |
||||
| 779 | +181 |
- }+ ) |
||||
| 780 | +182 |
- } else {
+
|
||||
| 781 | +183 | ! |
- shinyjs::show("ci")
+ iv_r <- reactive({
|
|||
| 782 | +184 | ! |
- shinyjs::show("show_form")
+ iv <- shinyvalidate::InputValidator$new() |
|||
| 783 | +185 | ! |
- shinyjs::show("show_r2")
+ iv$add_rule("join_fun", function(value) {
|
|||
| 784 | +186 | ! |
- if (nrow(ANL) - nrow(stats::na.omit(ANL[, c(x_var, y_var)])) > 0) {
+ if (!identical(selector_list()$x()$dataname, selector_list()$y()$dataname)) {
|
|||
| 785 | +187 | ! |
- plot_q <- teal.code::eval_code(+ if (!shinyvalidate::input_provided(value)) {
|
|||
| 786 | +188 | ! |
- plot_q,+ "Please select a joining function." |
|||
| 787 | -! | +|||||
| 189 | +
- substitute(+ } |
|||||
| 788 | -! | +|||||
| 190 | ++ |
+ }+ |
+ ||||
| 191 | +
- expr = ANL <- dplyr::filter(ANL, !is.na(x_var) & !is.na(y_var)), # nolint object_name_linter+ }) |
|||||
| 789 | +192 | ! |
- env = list(x_var = as.name(x_var), y_var = as.name(y_var))+ teal.transform::compose_and_enable_validators(iv, selector_list) |
|||
| 790 | +193 |
- )+ }) |
||||
| 791 | +194 |
- )+ |
||||
| 792 | -+ | |||||
| 195 | +! |
- }+ observeEvent( |
||||
| 793 | +196 | ! |
- rhs_formula <- substitute(+ eventExpr = {
|
|||
| 794 | +197 | ! |
- expr = y ~ poly(x, smoothing_degree, raw = TRUE),+ req(!is.null(selector_list()$x()) && !is.null(selector_list()$y())) |
|||
| 795 | +198 | ! |
- env = list(smoothing_degree = smoothing_degree)+ list(selector_list()$x(), selector_list()$y()) |
|||
| 796 | +199 |
- )+ }, |
||||
| 797 | +200 | ! |
- if (input$show_form || input$show_r2 || input$show_count) {
+ handlerExpr = {
|
|||
| 798 | +201 | ! |
- plot_call <- plot_label_generator(rhs_formula = rhs_formula)+ if (identical(selector_list()$x()$dataname, selector_list()$y()$dataname)) {
|
|||
| 799 | +202 | ! |
- shinyjs::show("label_pos")
+ shinyjs::hide("join_fun")
+ |
+ |||
| 203 | ++ |
+ } else {
|
||||
| 800 | +204 | ! |
- shinyjs::show("label_size")
+ shinyjs::show("join_fun")
|
|||
| 801 | +205 |
- } else {
+ } |
||||
| 802 | -! | +|||||
| 206 | +
- shinyjs::hide("label_pos")
+ } |
|||||
| 803 | -! | +|||||
| 207 | +
- shinyjs::hide("label_size")
+ ) |
|||||
| 804 | +208 |
- }+ |
||||
| 805 | +209 | ! |
- plot_call <- substitute(+ merge_function <- reactive({
|
|||
| 806 | +210 | ! |
- expr = plot_call + ggplot2::geom_smooth(formula = rhs_formula, se = TRUE, level = ci, method = "lm"),+ if (is.null(input$join_fun)) {
|
|||
| 807 | +211 | ! |
- env = list(plot_call = plot_call, rhs_formula = rhs_formula, ci = ci)+ "dplyr::full_join" |
|||
| 808 | +212 |
- )+ } else {
+ |
+ ||||
| 213 | +! | +
+ input$join_fun |
||||
| 809 | +214 |
- }+ } |
||||
| 810 | +215 |
- } else {
+ }) |
||||
| 811 | -! | +|||||
| 216 | +
- shinyjs::hide("smoothing_degree")
+
|
|||||
| 812 | +217 | ! |
- shinyjs::hide("ci")
+ anl_merged_input <- teal.transform::merge_expression_srv( |
|||
| 813 | +218 | ! |
- shinyjs::hide("color_sub")
+ datasets = data, |
|||
| 814 | +219 | ! |
- shinyjs::hide("show_form")
+ selector_list = selector_list, |
|||
| 815 | +220 | ! |
- shinyjs::hide("show_r2")
+ merge_function = merge_function+ |
+ |||
| 221 | ++ |
+ )+ |
+ ||||
| 222 | ++ | + | ||||
| 816 | +223 | ! |
- if (input$show_count) {
+ anl_merged_q <- reactive({
|
|||
| 817 | +224 | ! |
- plot_call <- plot_label_generator(show_form = FALSE, show_r2 = FALSE)+ req(anl_merged_input()) |
|||
| 818 | +225 | ! |
- shinyjs::show("label_pos")
+ data() %>% |
|||
| 819 | +226 | ! |
- shinyjs::show("label_size")
+ teal.code::eval_code(as.expression(anl_merged_input()$expr)) |
|||
| 820 | +227 |
- } else {
+ }) |
||||
| 821 | -! | +|||||
| 228 | +
- shinyjs::hide("label_pos")
+
|
|||||
| 822 | +229 | ! |
- shinyjs::hide("label_size")
+ merged <- list( |
|||
| 823 | -+ | |||||
| 230 | +! |
- }+ anl_input_r = anl_merged_input, |
||||
| 824 | +231 | ! |
- shinyjs::show("line_msg")
+ anl_q_r = anl_merged_q |
|||
| 825 | +232 |
- }+ ) |
||||
| 826 | +233 | |||||
| 827 | +234 | ! |
- if (!is.null(facet_cl)) {
+ output_q <- reactive({
|
|||
| 828 | +235 | ! |
- plot_call <- substitute(expr = plot_call + facet_cl, env = list(plot_call = plot_call, facet_cl = facet_cl))+ teal::validate_inputs(iv_r())+ |
+ |||
| 236 | +! | +
+ ANL <- merged$anl_q_r()[["ANL"]] # nolint: object_name. |
||||
| 829 | +237 |
- }+ |
||||
| 830 | +238 |
-
+ # As this is a summary |
||||
| 831 | +239 | ! |
- y_label <- varname_w_label(+ x_name <- as.vector(merged$anl_input_r()$columns_source$x) |
|||
| 832 | +240 | ! |
- y_var,+ y_name <- as.vector(merged$anl_input_r()$columns_source$y) |
|||
| 833 | -! | +|||||
| 241 | +
- ANL,+ |
|||||
| 834 | +242 | ! |
- prefix = if (log_y) paste(log_y_fn, "(") else NULL,
+ teal::validate_has_data(ANL, 3) |
|||
| 835 | +243 | ! |
- suffix = if (log_y) ")" else NULL+ teal::validate_has_data(ANL[, c(x_name, y_name)], 3, complete = TRUE, allow_inf = FALSE) |
|||
| 836 | +244 |
- )- |
- ||||
| 837 | -! | -
- x_label <- varname_w_label(+ |
||||
| 838 | +245 | ! |
- x_var,+ is_allowed_class <- function(x) is.numeric(x) || is.factor(x) || is.character(x) || is.logical(x) |
|||
| 839 | +246 | ! |
- ANL,+ validate(need( |
|||
| 840 | +247 | ! |
- prefix = if (log_x) paste(log_x_fn, "(") else NULL,
+ all(vapply(ANL[x_name], is_allowed_class, logical(1))), |
|||
| 841 | +248 | ! |
- suffix = if (log_x) ")" else NULL- |
- |||
| 842 | -- |
- )+ "Selected row variable has an unsupported data type." |
||||
| 843 | +249 |
-
+ )) |
||||
| 844 | +250 | ! |
- dev_ggplot2_args <- teal.widgets::ggplot2_args(+ validate(need( |
|||
| 845 | +251 | ! |
- labs = list(y = y_label, x = x_label),+ is_allowed_class(ANL[[y_name]]), |
|||
| 846 | +252 | ! |
- theme = list(legend.position = "bottom")+ "Selected column variable has an unsupported data type." |
|||
| 847 | +253 |
- )+ )) |
||||
| 848 | +254 | |||||
| 849 | -! | -
- if (rotate_xaxis_labels) {
- |
- ||||
| 850 | +255 | ! |
- dev_ggplot2_args$theme[["axis.text.x"]] <- quote(element_text(angle = 45, hjust = 1))+ show_percentage <- input$show_percentage |
|||
| 851 | -+ | |||||
| 256 | +! |
- }+ show_total <- input$show_total |
||||
| 852 | +257 | |||||
| 853 | +258 | ! |
- all_ggplot2_args <- teal.widgets::resolve_ggplot2_args(+ plot_title <- paste( |
|||
| 854 | +259 | ! |
- user_plot = ggplot2_args,+ "Cross-Table of", |
|||
| 855 | +260 | ! |
- module_plot = dev_ggplot2_args+ paste0(varname_w_label(x_name, ANL), collapse = ", "), |
|||
| 856 | -+ | |||||
| 261 | +! |
- )+ "(rows)", "vs.", |
||||
| 857 | -+ | |||||
| 262 | +! |
-
+ varname_w_label(y_name, ANL), |
||||
| 858 | +263 | ! |
- parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(all_ggplot2_args, ggtheme = ggtheme)+ "(columns)" |
|||
| 859 | +264 |
-
+ ) |
||||
| 860 | +265 | |||||
| 861 | +266 | ! |
- if (add_density) {
+ labels_vec <- vapply( |
|||
| 862 | +267 | ! |
- plot_call <- substitute(+ x_name, |
|||
| 863 | +268 | ! |
- expr = ggExtra::ggMarginal(+ varname_w_label, |
|||
| 864 | +269 | ! |
- plot_call + labs + ggthemes + themes,+ character(1), |
|||
| 865 | +270 | ! |
- type = "density",+ ANL |
|||
| 866 | -! | +|||||
| 271 | +
- groupColour = group_colour+ ) |
|||||
| 867 | +272 |
- ),+ |
||||
| 868 | +273 | ! |
- env = list(+ teal.code::eval_code( |
|||
| 869 | +274 | ! |
- plot_call = plot_call,+ merged$anl_q_r(), |
|||
| 870 | +275 | ! |
- group_colour = if (length(color_by_var) > 0) TRUE else FALSE,+ substitute( |
|||
| 871 | +276 | ! |
- labs = parsed_ggplot2_args$labs,+ expr = {
|
|||
| 872 | +277 | ! |
- ggthemes = parsed_ggplot2_args$ggtheme,+ title <- plot_title+ |
+ |||
| 278 | ++ |
+ }, |
||||
| 873 | +279 | ! |
- themes = parsed_ggplot2_args$theme+ env = list(plot_title = plot_title) |
|||
| 874 | +280 |
- )+ ) |
||||
| 875 | +281 |
- )+ ) %>% |
||||
| 876 | -+ | |||||
| 282 | +! |
- } else {
+ teal.code::eval_code( |
||||
| 877 | +283 | ! |
- plot_call <- substitute(+ substitute( |
|||
| 878 | +284 | ! |
- expr = plot_call ++ expr = {
|
|||
| 879 | +285 | ! |
- labs ++ lyt <- basic_tables %>% |
|||
| 880 | +286 | ! |
- ggthemes ++ split_call %>% # styler: off |
|||
| 881 | +287 | ! |
- themes,+ rtables::add_colcounts() %>% |
|||
| 882 | +288 | ! |
- env = list(+ tern::analyze_vars( |
|||
| 883 | +289 | ! |
- plot_call = plot_call,+ vars = x_name, |
|||
| 884 | +290 | ! |
- labs = parsed_ggplot2_args$labs,+ var_labels = labels_vec, |
|||
| 885 | +291 | ! |
- ggthemes = parsed_ggplot2_args$ggtheme,+ na.rm = FALSE, |
|||
| 886 | +292 | ! |
- themes = parsed_ggplot2_args$theme+ denom = "N_col", |
|||
| 887 | -+ | |||||
| 293 | +! |
- )+ .stats = c("mean_sd", "median", "range", count_value)
|
||||
| 888 | +294 |
- )+ ) |
||||
| 889 | +295 |
- }+ }, |
||||
| 890 | -+ | |||||
| 296 | +! |
-
+ env = list( |
||||
| 891 | +297 | ! |
- plot_call <- substitute(expr = p <- plot_call, env = list(plot_call = plot_call))+ basic_tables = teal.widgets::parse_basic_table_args(+ |
+ |||
| 298 | +! | +
+ basic_table_args = teal.widgets::resolve_basic_table_args(basic_table_args) |
||||
| 892 | +299 |
-
+ ), |
||||
| 893 | +300 | ! |
- teal.code::eval_code(plot_q, plot_call) %>%+ split_call = if (show_total) {
|
|||
| 894 | +301 | ! |
- teal.code::eval_code(quote(print(p)))+ substitute( |
|||
| 895 | -+ | |||||
| 302 | +! |
- })+ expr = rtables::split_cols_by(+ |
+ ||||
| 303 | +! | +
+ y_name,+ |
+ ||||
| 304 | +! | +
+ split_fun = rtables::add_overall_level(label = "Total", first = FALSE) |
||||
| 896 | +305 |
-
+ ), |
||||
| 897 | +306 | ! |
- plot_r <- reactive(output_q()[["p"]])+ env = list(y_name = y_name) |
|||
| 898 | +307 |
-
+ ) |
||||
| 899 | +308 |
- # Insert the plot into a plot_with_settings module from teal.widgets+ } else {
|
||||
| 900 | +309 | ! |
- pws <- teal.widgets::plot_with_settings_srv(+ substitute(rtables::split_cols_by(y_name), env = list(y_name = y_name)) |
|||
| 901 | -! | +|||||
| 310 | +
- id = "scatter_plot",+ }, |
|||||
| 902 | +311 | ! |
- plot_r = plot_r,+ x_name = x_name, |
|||
| 903 | +312 | ! |
- height = plot_height,+ labels_vec = labels_vec, |
|||
| 904 | +313 | ! |
- width = plot_width,+ count_value = ifelse(show_percentage, "count_fraction", "count") |
|||
| 905 | -! | +|||||
| 314 | +
- brushing = TRUE+ ) |
|||||
| 906 | +315 |
- )+ ) |
||||
| 907 | +316 |
-
+ ) %>% |
||||
| 908 | +317 | ! |
- output$data_table <- DT::renderDataTable({
+ teal.code::eval_code( |
|||
| 909 | +318 | ! |
- plot_brush <- pws$brush()- |
- |||
| 910 | -- |
-
+ substitute( |
||||
| 911 | +319 | ! |
- if (!is.null(plot_brush)) {
+ expr = {
|
|||
| 912 | +320 | ! |
- validate(need(!input$add_density, "Brushing feature is currently not supported when plot has marginal density"))- |
- |||
| 913 | -- |
- }+ ANL <- tern::df_explicit_na(ANL) # nolint: object_name. |
||||
| 914 | -+ | |||||
| 321 | +! |
-
+ tbl <- rtables::build_table(lyt = lyt, df = ANL[order(ANL[[y_name]]), ]) |
||||
| 915 | +322 | ! |
- merged_data <- isolate(teal.code::dev_suppress(output_q()[["ANL"]]))+ tbl |
|||
| 916 | +323 |
-
+ }, |
||||
| 917 | +324 | ! |
- brushed_df <- teal.widgets::clean_brushedPoints(merged_data, plot_brush)+ env = list(y_name = y_name) |
|||
| 918 | -! | +|||||
| 325 | +
- numeric_cols <- names(brushed_df)[+ ) |
|||||
| 919 | -! | +|||||
| 326 | +
- vapply(brushed_df, function(x) is.numeric(x) && !is.integer(x), FUN.VALUE = logical(1))+ ) |
|||||
| 920 | +327 |
- ]+ }) |
||||
| 921 | +328 | |||||
| 922 | +329 | ! |
- if (length(numeric_cols) > 0) {
+ output$title <- renderText(output_q()[["title"]]) |
|||
| 923 | -! | +|||||
| 330 | +
- DT::formatRound(+ |
|||||
| 924 | +331 | ! |
- DT::datatable(brushed_df,+ table_r <- reactive({
|
|||
| 925 | +332 | ! |
- rownames = FALSE,+ shiny::req(iv_r()$is_valid()) |
|||
| 926 | +333 | ! |
- options = list(scrollX = TRUE, pageLength = input$data_table_rows)+ output_q()[["tbl"]] |
|||
| 927 | +334 |
- ),- |
- ||||
| 928 | -! | -
- numeric_cols,- |
- ||||
| 929 | -! | -
- table_dec+ }) |
||||
| 930 | +335 |
- )+ |
||||
| 931 | -+ | |||||
| 336 | +! |
- } else {
+ teal.widgets::table_with_settings_srv( |
||||
| 932 | +337 | ! |
- DT::datatable(brushed_df, rownames = FALSE, options = list(scrollX = TRUE, pageLength = input$data_table_rows))+ id = "table", |
|||
| 933 | -+ | |||||
| 338 | +! |
- }+ table_r = table_r |
||||
| 934 | +339 |
- })+ ) |
||||
| 935 | +340 | |||||
| 936 | +341 | ! |
teal.widgets::verbatim_popup_srv( |
|||
| 937 | +342 | ! |
id = "warning", |
|||
| 938 | +343 | ! |
verbatim_content = reactive(teal.code::get_warnings(output_q())), |
|||
| 939 | +344 | ! |
title = "Warning", |
|||
| 940 | +345 | ! |
disabled = reactive(is.null(teal.code::get_warnings(output_q()))) |
|||
| 941 | +346 |
) |
||||
| 942 | +347 | |||||
| 943 | +348 | ! |
teal.widgets::verbatim_popup_srv( |
|||
| 944 | +349 | ! |
id = "rcode", |
|||
| 945 | +350 | ! |
verbatim_content = reactive(teal.code::get_code(output_q())), |
|||
| 946 | +351 | ! |
- title = "R Code for scatterplot"+ title = "Show R Code for Cross-Table" |
|||
| 947 | +352 |
) |
||||
| 948 | +353 | |||||
| 949 | +354 |
### REPORTER |
||||
| 950 | +355 | ! |
if (with_reporter) {
|
|||
| 951 | +356 | ! |
card_fun <- function(comment, label) {
|
|||
| 952 | +357 | ! |
card <- teal::report_card_template( |
|||
| 953 | +358 | ! |
- title = "Scatter Plot",+ title = "Cross Table", |
|||
| 954 | +359 | ! |
label = label, |
|||
| 955 | +360 | ! |
with_filter = with_filter, |
|||
| 956 | +361 | ! |
filter_panel_api = filter_panel_api |
|||
| 957 | +362 |
) |
||||
| 958 | +363 | ! |
- card$append_text("Plot", "header3")
+ card$append_text("Table", "header3")
|
|||
| 959 | +364 | ! |
- card$append_plot(plot_r(), dim = pws$dim())+ card$append_table(table_r()) |
|||
| 960 | +365 | ! |
if (!comment == "") {
|
|||
| 961 | +366 | ! |
card$append_text("Comment", "header3")
|
|||
| 962 | +367 | ! |
card$append_text(comment) |
|||
| 963 | +368 |
} |
||||
| 964 | +369 | ! |
card$append_src(teal.code::get_code(output_q())) |
|||
| 965 | +370 | ! |
card |
|||
| 966 | +371 |
} |
||||
| 967 | +372 | ! |
teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
|
|||
| 968 | +373 |
} |
||||
| 969 | +374 |
### |
||||
| 970 | +375 |
}) |
||||
| 971 | +376 |
}@@ -67069,7 +67076,7 @@ teal.modules.general coverage - 2.26% | 348 | ! |
- ANL <- merged$anl_q_r()[["ANL"]] # nolint object_name_linter+ ANL <- merged$anl_q_r()[["ANL"]] # nolint: object_name. |
|
| 379 | ! |
- ANL <- merged$anl_q_r()[["ANL"]] # nolint object_name_linter+ ANL <- merged$anl_q_r()[["ANL"]] # nolint: object_name. |
||||
| 392 | ! |
- quote(ANL <- tidyr::drop_na(ANL, keep_columns)) # nolint object_name_linter+ quote(ANL <- tidyr::drop_na(ANL, keep_columns)) # nolint: object_name. |
||||
| 614 | ! |
- ANL <- qenv[["ANL"]] # nolint object_name_linter+ ANL <- qenv[["ANL"]] # nolint: object_name. |
||||
| 710 | ! |
- if (is.character(response) || is.factor(response) || (is.numeric(response) && length(unique(response)) <= 6)) { # nolint line_length_linter
+ if (is.character(response) || is.factor(response) || (is.numeric(response) && length(unique(response)) <= 6)) { # nolint: line_length.
|
||||
| 298 | ! |
- ANL <- qenv[["ANL"]] # nolint object_name_linter+ ANL <- qenv[["ANL"]] # nolint: object_name. |
||||
| 335 | ! |
- expr = ANL[[x]] <- with(ANL, forcats::fct_rev(x_cl)), # nolint object_name_linter+ expr = ANL[[x]] <- with(ANL, forcats::fct_rev(x_cl)), # nolint: object_name. |
||||
| 344 | ! |
- expr = ANL[[resp_var]] <- factor(ANL[[resp_var]]), # nolint object_name_linter+ expr = ANL[[resp_var]] <- factor(ANL[[resp_var]]), # nolint: object_name. |
||||
| 1 |
- #' Create a scatterplot matrix+ #' Shared Parameters |
||
| 3 |
- #' The available datasets to choose from for each dataset selector is the same and+ #' @description Contains arguments that are shared between multiple functions |
||
| 4 |
- #' determined by the argument `variables`.+ #' in the package to avoid repetition using `inheritParams`. |
||
| 5 |
- #' @md+ #' |
||
| 6 |
- #'+ #' @param plot_height optional, (`numeric`) A vector of length three with `c(value, min and max)` |
||
| 7 |
- #' @inheritParams teal::module+ #' for a slider encoding the plot height. |
||
| 8 |
- #' @inheritParams tm_g_scatterplot+ #' @param plot_width optional, (`numeric`) A vector of length three with `c(value, min and max)` |
||
| 9 |
- #' @inheritParams shared_params+ #' for a slider encoding the plot width. |
||
| 10 |
- #'+ #' @param rotate_xaxis_labels optional, (`logical`) Whether to rotate plot X axis labels. Does not |
||
| 11 |
- #' @param variables (`data_extract_spec` or `list` of multiple `data_extract_spec`)+ #' rotate by default (`FALSE`). |
||
| 12 |
- #' Plotting variables from an incoming dataset with filtering and selecting. In case of+ #' @param ggtheme optional, (`character`) `ggplot2` theme to be used by default. Defaults to `"gray"`. |
||
| 13 |
- #' `data_extract_spec` use `select_spec(..., ordered = TRUE)` if plot elements should be+ #' @param ggplot2_args (`ggplot2_args`) object created by [teal.widgets::ggplot2_args()] |
||
| 14 |
- #' rendered according to selection order.+ #' with settings for the module plot. |
||
| 15 |
- #'+ #' The argument is merged with options variable `teal.ggplot2_args` and default module setup. |
||
| 16 |
- #' @note For more examples, please see the vignette "Using scatterplot matrix" via+ #' |
||
| 17 |
- #' \code{vignette("using-scatterplot-matrix", package = "teal.modules.general")}.
+ #' For more details see the vignette: `vignette("custom-ggplot2-arguments", package = "teal.widgets")`
|
||
| 18 |
- #' @export+ #' @param basic_table_args (`basic_table_args`) object created by [teal.widgets::basic_table_args()] |
||
| 19 |
- #'+ #' with settings for the module table. |
||
| 20 |
- #' @examples+ #' The argument is merged with options variable `teal.basic_table_args` and default module setup. |
||
| 21 |
- #' # Scatterplot matrix of variables from ADSL dataset+ #' |
||
| 22 |
- #'+ #' For more details see the vignette: `vignette("custom-basic-table-arguments", package = "teal.widgets")`
|
||
| 23 |
- #' data <- teal_data()+ #' @param pre_output (`shiny.tag`, optional)\cr |
||
| 24 |
- #' data <- within(data, {
+ #' with text placed before the output to put the output into context. For example a title. |
||
| 25 |
- #' ADSL <- teal.modules.general::rADSL+ #' @param post_output (`shiny.tag`, optional) with text placed after the output to put the output |
||
| 26 |
- #' ADRS <- teal.modules.general::rADRS+ #' into context. For example the [shiny::helpText()] elements are useful. |
||
| 27 |
- #' })+ #' |
||
| 28 |
- #' datanames <- c("ADSL", "ADRS")
+ #' @name shared_params |
||
| 29 |
- #' datanames(data) <- datanames+ #' @keywords internal |
||
| 30 |
- #' join_keys(data) <- default_cdisc_join_keys[datanames]+ NULL |
||
| 31 |
- #'+ |
||
| 32 |
- #' app <- teal::init(+ #' Add axis labels that show facetting variable |
||
| 33 |
- #' data = data,+ #' |
||
| 34 |
- #' modules = teal::modules(+ #' Add axis labels that show facetting variable |
||
| 35 |
- #' teal.modules.general::tm_g_scatterplotmatrix(+ #' |
||
| 36 |
- #' label = "Scatterplot matrix",+ #' @param p `ggplot2` object to add facet labels to |
||
| 37 |
- #' variables = list(+ #' @param xfacet_label label of facet along x axis (nothing created if NULL), |
||
| 38 |
- #' teal.transform::data_extract_spec(+ #' if vector, will be concatenated with " & " |
||
| 39 |
- #' dataname = "ADSL",+ #' @param yfacet_label label of facet along y axis (nothing created if NULL), |
||
| 40 |
- #' select = select_spec(+ #' if vector, will be concatenated with " & " |
||
| 41 |
- #' label = "Select variables:",+ #' |
||
| 42 |
- #' choices = variable_choices(data[["ADSL"]]),+ #' @return grid grob object (to be drawn with \code{grid.draw})
|
||
| 43 |
- #' selected = c("AGE", "RACE", "SEX"),
+ #' |
||
| 44 |
- #' multiple = TRUE,+ #' @export |
||
| 45 |
- #' ordered = TRUE,+ #' |
||
| 46 |
- #' fixed = FALSE+ #' @examples |
||
| 47 |
- #' )+ #' # we put donttest to avoid strictr error with seq along.with argument |
||
| 48 |
- #' ),+ #' \donttest{
|
||
| 49 |
- #' teal.transform::data_extract_spec(+ #' library(ggplot2) |
||
| 50 |
- #' dataname = "ADRS",+ #' library(grid) |
||
| 51 |
- #' filter = teal.transform::filter_spec(+ #' |
||
| 52 |
- #' label = "Select endpoints:",+ #' p <- ggplot(mtcars) + |
||
| 53 |
- #' vars = c("PARAMCD", "AVISIT"),
+ #' aes(x = mpg, y = disp) + |
||
| 54 |
- #' choices = value_choices(data[["ADRS"]], c("PARAMCD", "AVISIT"), c("PARAM", "AVISIT")),
+ #' geom_point() + |
||
| 55 |
- #' selected = "INVET - END OF INDUCTION",+ #' facet_grid(gear ~ cyl) |
||
| 56 |
- #' multiple = TRUE+ #' p |
||
| 57 |
- #' ),+ #' xfacet_label <- "cylinders" |
||
| 58 |
- #' select = select_spec(+ #' yfacet_label <- "gear" |
||
| 59 |
- #' label = "Select variables:",+ #' res <- add_facet_labels(p, xfacet_label, yfacet_label) |
||
| 60 |
- #' choices = variable_choices(data[["ADRS"]]),+ #' grid.newpage() |
||
| 61 |
- #' selected = c("AGE", "AVAL", "ADY"),
+ #' grid.draw(res) |
||
| 62 |
- #' multiple = TRUE,+ #' |
||
| 63 |
- #' ordered = TRUE,+ #' grid.newpage() |
||
| 64 |
- #' fixed = FALSE+ #' grid.draw(add_facet_labels(p, xfacet_label = NULL, yfacet_label)) |
||
| 65 |
- #' )+ #' grid.newpage() |
||
| 66 |
- #' )+ #' grid.draw(add_facet_labels(p, xfacet_label, yfacet_label = NULL)) |
||
| 67 |
- #' )+ #' grid.newpage() |
||
| 68 |
- #' )+ #' grid.draw(add_facet_labels(p, xfacet_label = NULL, yfacet_label = NULL)) |
||
| 69 |
- #' )+ #' } |
||
| 70 |
- #' )+ #' |
||
| 71 |
- #' if (interactive()) {
+ add_facet_labels <- function(p, xfacet_label = NULL, yfacet_label = NULL) {
|
||
| 72 | -+ | ! |
- #' shinyApp(app$ui, app$server)+ checkmate::assert_class(p, classes = "ggplot") |
| 73 | -+ | ! |
- #' }+ checkmate::assert_character(xfacet_label, null.ok = TRUE, min.len = 1) |
| 74 | -+ | ! |
- tm_g_scatterplotmatrix <- function(label = "Scatterplot Matrix",+ checkmate::assert_character(yfacet_label, null.ok = TRUE, min.len = 1) |
| 75 | -+ | ! |
- variables,+ if (is.null(xfacet_label) && is.null(yfacet_label)) {
|
| 76 | -+ | ! |
- plot_height = c(600, 200, 2000),+ return(ggplotGrob(p)) |
| 77 |
- plot_width = NULL,+ } |
||
| 78 | -+ | ! |
- pre_output = NULL,+ grid::grid.grabExpr({
|
| 79 | -+ | ! |
- post_output = NULL) {
+ g <- ggplotGrob(p) |
| 80 | -! | +
- logger::log_info("Initializing tm_g_scatterplotmatrix")
+
|
|
| 81 | -! | +
- if (!requireNamespace("lattice", quietly = TRUE)) {
+ # we are going to replace these, so we make sure they have nothing in them |
|
| 82 | ! |
- stop("Cannot load lattice - please install the package or restart your session.")
+ checkmate::assert_class(g$grobs[[grep("xlab-t", g$layout$name, fixed = TRUE)]], "zeroGrob")
|
|
| 83 | -+ | ! |
- }+ checkmate::assert_class(g$grobs[[grep("ylab-r", g$layout$name, fixed = TRUE)]], "zeroGrob")
|
| 84 | -! | +
- if (inherits(variables, "data_extract_spec")) variables <- list(variables)+ |
|
| 85 | -+ | ! |
-
+ xaxis_label_grob <- g$grobs[[grep("xlab-b", g$layout$name, fixed = TRUE)]]
|
| 86 | ! |
- checkmate::assert_string(label)+ xaxis_label_grob$children[[1]]$label <- paste(xfacet_label, collapse = " & ") |
|
| 87 | ! |
- checkmate::assert_list(variables, types = "data_extract_spec")+ yaxis_label_grob <- g$grobs[[grep("ylab-l", g$layout$name, fixed = TRUE)]]
|
|
| 88 | ! |
- checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE)+ yaxis_label_grob$children[[1]]$label <- paste(yfacet_label, collapse = " & ") |
|
| 89 | ! |
- checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height")+ yaxis_label_grob$children[[1]]$rot <- 270 |
|
| 90 | -! | +
- checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE)+ |
|
| 91 | ! |
- checkmate::assert_numeric(+ top_height <- if (is.null(xfacet_label)) 0 else grid::unit(2, "line") |
|
| 92 | ! |
- plot_width[1],+ right_width <- if (is.null(yfacet_label)) 0 else grid::unit(2, "line") |
|
| 93 | -! | +
- lower = plot_width[2], upper = plot_width[3], null.ok = TRUE, .var.name = "plot_width"+ |
|
| 94 | -+ | ! |
- )+ grid::grid.newpage() |
| 95 | -+ | ! |
-
+ grid::pushViewport(grid::plotViewport(margins = c(0, 0, top_height, right_width), name = "ggplot")) |
| 96 | ! |
- args <- as.list(environment())+ grid::grid.draw(g) |
|
| 97 | ! |
- module(+ grid::upViewport(1) |
|
| 98 | -! | +
- label = label,+ |
|
| 99 | -! | +
- server = srv_g_scatterplotmatrix,+ # draw x facet |
|
| 100 | ! |
- ui = ui_g_scatterplotmatrix,+ if (!is.null(xfacet_label)) {
|
|
| 101 | ! |
- ui_args = args,+ grid::pushViewport(grid::viewport( |
|
| 102 | ! |
- server_args = list(variables = variables, plot_height = plot_height, plot_width = plot_width),+ x = 0, y = grid::unit(1, "npc") - top_height, width = grid::unit(1, "npc"), |
|
| 103 | ! |
- datanames = teal.transform::get_extract_datanames(variables)+ height = top_height, just = c("left", "bottom"), name = "topxaxis"
|
|
| 104 |
- )+ )) |
||
| 105 | -+ | ! |
- }+ grid::grid.draw(xaxis_label_grob) |
| 106 | -+ | ! |
-
+ grid::upViewport(1) |
| 107 |
- ui_g_scatterplotmatrix <- function(id, ...) {
+ } |
||
| 108 | -! | +
- args <- list(...)+ |
|
| 109 | -! | +
- is_single_dataset_value <- teal.transform::is_single_dataset(args$variables)+ # draw y facet |
|
| 110 | ! |
- ns <- NS(id)+ if (!is.null(yfacet_label)) {
|
|
| 111 | ! |
- teal.widgets::standard_layout(+ grid::pushViewport(grid::viewport( |
|
| 112 | ! |
- output = teal.widgets::white_small_well(+ x = grid::unit(1, "npc") - grid::unit(as.numeric(right_width) / 2, "line"), y = 0, width = right_width, |
|
| 113 | ! |
- textOutput(ns("message")),
+ height = grid::unit(1, "npc"), just = c("left", "bottom"), name = "rightyaxis"
|
|
| 114 | -! | +
- br(),+ )) |
|
| 115 | ! |
- teal.widgets::plot_with_settings_ui(id = ns("myplot"))
+ grid::grid.draw(yaxis_label_grob) |
|
| 116 | -+ | ! |
- ),+ grid::upViewport(1) |
| 117 | -! | +
- encoding = div(+ } |
|
| 118 |
- ### Reporter+ }) |
||
| 119 | -! | +
- teal.reporter::simple_reporter_ui(ns("simple_reporter")),
+ } |
|
| 120 |
- ###+ |
||
| 121 | -! | +
- tags$label("Encodings", class = "text-primary"),
+ #' Call a function with a character vector for the \code{...} argument
|
|
| 122 | -! | +
- teal.transform::datanames_input(args$variables),+ #' |
|
| 123 | -! | +
- teal.transform::data_extract_ui(+ #' @param fun (\code{character}) Name of a function where the \code{...} argument
|
|
| 124 | -! | +
- id = ns("variables"),
+ #' shall be replaced by values from \code{str_args}.
|
|
| 125 | -! | +
- label = "Variables",+ #' @param str_args (\code{character}) A character vector that the function shall
|
|
| 126 | -! | +
- data_extract_spec = args$variables,+ #' be executed with |
|
| 127 | -! | +
- is_single_dataset = is_single_dataset_value+ #' |
|
| 128 |
- ),+ #' @return: call (i.e. expression) of the function provided by \code{fun}
|
||
| 129 | -! | +
- hr(),+ #' with arguments provided by \code{str_args}.
|
|
| 130 | -! | +
- teal.widgets::panel_group(+ #' @keywords internal |
|
| 131 | -! | +
- teal.widgets::panel_item(+ #' |
|
| 132 | -! | +
- title = "Plot settings",+ #' @examples |
|
| 133 | -! | +
- sliderInput(+ #' \dontrun{
|
|
| 134 | -! | +
- ns("alpha"), "Opacity:",
+ #' a <- 1 |
|
| 135 | -! | +
- min = 0, max = 1,+ #' b <- 2 |
|
| 136 | -! | +
- step = .05, value = .5, ticks = FALSE+ #' call_fun_dots("sum", c("a", "b"))
|
|
| 137 |
- ),+ #' eval(call_fun_dots("sum", c("a", "b")))
|
||
| 138 | -! | +
- sliderInput(+ #' } |
|
| 139 | -! | +
- ns("cex"), "Points size:",
+ call_fun_dots <- function(fun, str_args) {
|
|
| 140 | ! |
- min = 0.2, max = 3,+ do.call("call", c(list(fun), lapply(str_args, as.name)), quote = TRUE)
|
|
| 141 | -! | +
- step = .05, value = .65, ticks = FALSE+ } |
|
| 142 |
- ),+ |
||
| 143 | -! | +
- checkboxInput(ns("cor"), "Add Correlation", value = FALSE),
+ #' Get variable name with label |
|
| 144 | -! | +
- radioButtons(+ #' |
|
| 145 | -! | +
- ns("cor_method"), "Select Correlation Method",
+ #' @param var_names (\code{character}) Name of variable to extract labels from.
|
|
| 146 | -! | +
- choiceNames = c("Pearson", "Kendall", "Spearman"),
+ #' @param dataset (\code{dataset}) Name of analysis dataset.
|
|
| 147 | -! | +
- choiceValues = c("pearson", "kendall", "spearman"),
+ #' @param prefix (\code{character}) String to paste to the beginning of the
|
|
| 148 | -! | +
- inline = TRUE+ #' variable name with label. |
|
| 149 |
- ),+ #' @param suffix (\code{character}) String to paste to the end of the variable
|
||
| 150 | -! | +
- checkboxInput(ns("cor_na_omit"), "Omit Missing Values", value = TRUE)
+ #' name with label. |
|
| 151 |
- )+ #' @param wrap_width (\code{numeric}) Number of characters to wrap original
|
||
| 152 |
- )+ #' label to. Defaults to 80. |
||
| 153 |
- ),+ #' |
||
| 154 | -! | +
- forms = tagList(+ #' @return (\code{character}) String with variable name and label.
|
|
| 155 | -! | +
- teal.widgets::verbatim_popup_ui(ns("warning"), "Show Warnings"),
+ #' @keywords internal |
|
| 156 | -! | +
- teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code")
+ #' |
|
| 157 |
- ),+ #' @examples |
||
| 158 | -! | +
- pre_output = args$pre_output,+ #' \dontrun{
|
|
| 159 | -! | +
- post_output = args$post_output+ #' ADSL <- teal.modules.general::rADSL |
|
| 160 |
- )+ #' |
||
| 161 |
- }+ #' varname_w_label("AGE", ADSL)
|
||
| 162 |
-
+ #' } |
||
| 163 |
- srv_g_scatterplotmatrix <- function(id, data, reporter, filter_panel_api, variables, plot_height, plot_width) {
+ varname_w_label <- function(var_names, |
||
| 164 | -! | +
- with_reporter <- !missing(reporter) && inherits(reporter, "Reporter")+ dataset, |
|
| 165 | -! | +
- with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI")+ wrap_width = 80, |
|
| 166 | -! | +
- checkmate::assert_class(data, "reactive")+ prefix = NULL, |
|
| 167 | -! | +
- checkmate::assert_class(isolate(data()), "teal_data")+ suffix = NULL) {
|
|
| 168 | ! |
- moduleServer(id, function(input, output, session) {
+ add_label <- function(var_names) {
|
|
| 169 | ! |
- selector_list <- teal.transform::data_extract_multiple_srv(+ label <- vapply( |
|
| 170 | ! |
- data_extract = list(variables = variables),+ dataset[var_names], function(x) {
|
|
| 171 | ! |
- datasets = data,+ attr_label <- attr(x, "label") |
|
| 172 | ! |
- select_validation_rule = list(+ `if`(is.null(attr_label), "", attr_label) |
|
| 173 | -! | +
- variables = ~ if (length(.) <= 1) "Please select at least 2 columns."+ }, |
|
| 174 | -+ | ! |
- )+ character(1) |
| 177 | ! |
- iv_r <- reactive({
+ if (length(label) == 1 && !is.na(label) && !identical(label, "")) {
|
|
| 178 | ! |
- iv <- shinyvalidate::InputValidator$new()+ paste0(prefix, label, " [", var_names, "]", suffix) |
|
| 179 | -! | +
- teal.transform::compose_and_enable_validators(iv, selector_list)+ } else {
|
|
| 180 | -+ | ! |
- })+ var_names |
| 181 |
-
+ } |
||
| 182 | -! | +
- anl_merged_input <- teal.transform::merge_expression_srv(+ } |
|
| 183 | -! | +
- datasets = data,+ |
|
| 184 | ! |
- selector_list = selector_list+ if (length(var_names) < 1) {
|
|
| 185 | -+ | ! |
- )+ NULL |
| 186 | -+ | ! |
-
+ } else if (length(var_names) == 1) {
|
| 187 | ! |
- anl_merged_q <- reactive({
+ stringr::str_wrap(add_label(var_names), width = wrap_width) |
|
| 188 | ! |
- req(anl_merged_input())+ } else if (length(var_names) > 1) {
|
|
| 189 | ! |
- data() %>%+ stringr::str_wrap(vapply(var_names, add_label, character(1)), width = wrap_width) |
|
| 190 | -! | +
- teal.code::eval_code(as.expression(anl_merged_input()$expr))+ } |
|
| 191 |
- })+ } |
||
| 193 | -! | +
- merged <- list(+ #' Extract html id for `data_extract_ui` |
|
| 194 | -! | +
- anl_input_r = anl_merged_input,+ #' @description The `data_extract_ui` is located under extended html id. |
|
| 195 | -! | +
- anl_q_r = anl_merged_q+ #' We could not use \code{ns("original id")} for reference, as it is extended with specific suffixes.
|
|
| 196 |
- )+ #' @param varname character original html id. |
||
| 197 |
-
+ #' This will be mostly retrieved with \code{ns("original id")} in `ui` or
|
||
| 198 |
- # plot+ #' \code{session$ns("original id")} in server function.
|
||
| 199 | -! | +
- output_q <- reactive({
+ #' @param dataname character \code{dataname} from data_extract input.
|
|
| 200 | -! | +
- teal::validate_inputs(iv_r())+ #' This might be retrieved like \code{teal.transform::data_extract_spec(...)[[1]]$dataname}.
|
|
| 201 |
-
+ #' @param filter logical if the connected \code{extract_data_spec} is used with \code{filter} option.
|
||
| 202 | -! | +
- qenv <- merged$anl_q_r()+ #' @keywords internal |
|
| 203 | -! | +
- ANL <- qenv[["ANL"]] # nolint object_name_linter+ extract_input <- function(varname, dataname, filter = FALSE) {
|
|
| 204 | -+ | ! |
-
+ if (filter) {
|
| 205 | ! |
- cols_names <- merged$anl_input_r()$columns_source$variables+ paste0(varname, "-dataset_", dataname, "_singleextract-filter1-vals") |
|
| 206 | -! | +
- alpha <- input$alpha+ } else {
|
|
| 207 | ! |
- cex <- input$cex+ paste0(varname, "-dataset_", dataname, "_singleextract-select") |
|
| 208 | -! | +
- add_cor <- input$cor+ } |
|
| 209 | -! | +
- cor_method <- input$cor_method+ } |
|
| 210 | -! | +
- cor_na_omit <- input$cor_na_omit+ |
|
| 211 |
-
+ # see vignette("ggplot2-specs", package="ggplot2")
|
||
| 212 | -! | +
- cor_na_action <- if (isTruthy(cor_na_omit)) {
+ shape_names <- c( |
|
| 213 | -! | +
- "na.omit"+ "circle", paste("circle", c("open", "filled", "cross", "plus", "small")), "bullet",
|
|
| 214 |
- } else {
+ "square", paste("square", c("open", "filled", "cross", "plus", "triangle")),
|
||
| 215 | -! | +
- "na.fail"+ "diamond", paste("diamond", c("open", "filled", "plus")),
|
|
| 216 |
- }+ "triangle", paste("triangle", c("open", "filled", "square")),
|
||
| 217 |
-
+ paste("triangle down", c("open", "filled")),
|
||
| 218 | -! | +
- teal::validate_has_data(ANL, 10)+ "plus", "cross", "asterisk" |
|
| 219 | -! | +
- teal::validate_has_data(ANL[, cols_names, drop = FALSE], 10, complete = TRUE, allow_inf = FALSE)+ ) |
|
| 221 |
- # get labels and proper variable names+ #' Get icons to represent variable types in dataset |
||
| 222 | -! | +
- varnames <- varname_w_label(cols_names, ANL, wrap_width = 20)+ #' |
|
| 223 |
-
+ #' @param var_type (`character`)\cr |
||
| 224 |
- # check character columns. If any, then those are converted to factors+ #' of R internal types (classes). |
||
| 225 | -! | +
- check_char <- vapply(ANL[, cols_names], is.character, logical(1))+ #' |
|
| 226 | -! | +
- if (any(check_char)) {
+ #' @return (`character`)\cr |
|
| 227 | -! | +
- qenv <- teal.code::eval_code(+ #' vector of HTML icons corresponding to data type in each column. |
|
| 228 | -! | +
- qenv,+ #' @keywords internal |
|
| 229 | -! | +
- substitute(+ #' |
|
| 230 | -! | +
- expr = ANL <- ANL[, cols_names] %>% # nolint object_name_linter+ #' @examples |
|
| 231 | -! | +
- dplyr::mutate_if(is.character, as.factor) %>%+ #' teal.modules.general:::variable_type_icons(c( |
|
| 232 | -! | +
- droplevels(),+ #' "integer", "numeric", "logical", "Date", "POSIXct", "POSIXlt", |
|
| 233 | -! | +
- env = list(cols_names = cols_names)+ #' "factor", "character", "unknown", "" |
|
| 234 |
- )+ #' )) |
||
| 235 |
- )+ variable_type_icons <- function(var_type) {
|
||
| 236 | -+ | ! |
- } else {
+ checkmate::assert_character(var_type, any.missing = FALSE) |
| 237 | -! | +
- qenv <- teal.code::eval_code(+ |
|
| 238 | ! |
- qenv,+ class_to_icon <- list( |
|
| 239 | ! |
- substitute(+ numeric = "arrow-up-1-9", |
|
| 240 | ! |
- expr = ANL <- ANL[, cols_names] %>% # nolint object_name_linter+ integer = "arrow-up-1-9", |
|
| 241 | ! |
- droplevels(),+ logical = "pause", |
|
| 242 | ! |
- env = list(cols_names = cols_names)+ Date = "calendar", |
|
| 243 | -+ | ! |
- )+ POSIXct = "calendar", |
| 244 | -+ | ! |
- )+ POSIXlt = "calendar", |
| 245 | -+ | ! |
- }+ factor = "chart-bar", |
| 246 | -+ | ! |
-
+ character = "keyboard", |
| 247 | -+ | ! |
-
+ primary_key = "key", |
| 248 | -+ | ! |
- # create plot+ unknown = "circle-question" |
| 249 | -! | +
- if (add_cor) {
+ ) |
|
| 250 | ! |
- shinyjs::show("cor_method")
+ class_to_icon <- lapply(class_to_icon, function(icon_name) toString(icon(icon_name, lib = "font-awesome"))) |
|
| 251 | -! | +
- shinyjs::show("cor_use")
+
|
|
| 252 | ! |
- shinyjs::show("cor_na_omit")
+ res <- unname(vapply( |
|
| 253 | -+ | ! |
-
+ var_type, |
| 254 | ! |
- qenv <- teal.code::eval_code(+ FUN.VALUE = character(1), |
|
| 255 | ! |
- qenv,+ FUN = function(class) {
|
|
| 256 | ! |
- substitute(+ if (class == "") {
|
|
| 257 | ! |
- expr = {
+ class |
|
| 258 | ! |
- g <- lattice::splom(+ } else if (is.null(class_to_icon[[class]])) {
|
|
| 259 | ! |
- ANL,+ class_to_icon[["unknown"]] |
|
| 260 | -! | +
- varnames = varnames_value,+ } else {
|
|
| 261 | ! |
- panel = function(x, y, ...) {
+ class_to_icon[[class]] |
|
| 262 | -! | +
- lattice::panel.splom(x = x, y = y, ...)+ } |
|
| 263 | -! | +
- cpl <- lattice::current.panel.limits()+ } |
|
| 264 | -! | +
- lattice::panel.text(+ )) |
|
| 265 | -! | +
- mean(cpl$xlim),+ |
|
| 266 | ! |
- mean(cpl$ylim),+ return(res) |
|
| 267 | -! | +
- get_scatterplotmatrix_stats(+ } |
|
| 268 | -! | +
- x,+ |
|
| 269 | -! | +
- y,+ #' Include `CSS` files from `/inst/css/` package directory to application header |
|
| 270 | -! | +
- .f = stats::cor.test,+ #' |
|
| 271 | -! | +
- .f_args = list(method = cor_method, na.action = cor_na_action)+ #' `system.file` should not be used to access files in other packages, it does |
|
| 272 |
- ),+ #' not work with `devtools`. Therefore, we redefine this method in each package |
||
| 273 | -! | +
- alpha = 0.6,+ #' as needed. Thus, we do not export this method |
|
| 274 | -! | +
- fontsize = 18,+ #' |
|
| 275 | -! | +
- fontface = "bold"+ #' @param pattern (`character`) pattern of files to be included |
|
| 276 |
- )+ #' |
||
| 277 |
- },+ #' @return HTML code that includes `CSS` files |
||
| 278 | -! | +
- pch = 16,+ #' @keywords internal |
|
| 279 | -! | +
- alpha = alpha_value,+ include_css_files <- function(pattern = "*") {
|
|
| 280 | ! |
- cex = cex_value+ css_files <- list.files( |
|
| 281 | -+ | ! |
- )+ system.file("css", package = "teal.modules.general", mustWork = TRUE),
|
| 282 | ! |
- print(g)+ pattern = pattern, full.names = TRUE |
|
| 283 |
- },+ ) |
||
| 284 | ! |
- env = list(+ if (length(css_files) == 0) {
|
|
| 285 | ! |
- varnames_value = varnames,+ return(NULL) |
|
| 286 | -! | +
- cor_method = cor_method,+ } |
|
| 287 | ! |
- cor_na_action = cor_na_action,+ return(shiny::singleton(shiny::tags$head(lapply(css_files, shiny::includeCSS)))) |
|
| 288 | -! | +
- alpha_value = alpha,+ } |
|
| 289 | -! | +
- cex_value = cex+ |
|
| 290 |
- )+ |
||
| 291 |
- )+ #' Get Label Attributes of Variables in a \code{data.frame}
|
||
| 292 |
- )+ #' |
||
| 293 |
- } else {
+ #' Variable labels can be stored as a \code{label} attribute for each variable.
|
||
| 294 | -! | +
- shinyjs::hide("cor_method")
+ #' This functions returns a named character vector with the variable labels |
|
| 295 | -! | +
- shinyjs::hide("cor_use")
+ #' (empty sting if not specified) |
|
| 296 | -! | +
- shinyjs::hide("cor_na_omit")
+ #' |
|
| 297 | -! | +
- qenv <- teal.code::eval_code(+ #' @param x a \code{data.frame} object
|
|
| 298 | -! | +
- qenv,+ #' @param fill boolean in case the \code{label} attribute does not exist if
|
|
| 299 | -! | +
- substitute(+ #' \code{TRUE} the variable names is returned, otherwise \code{NA}
|
|
| 300 | -! | +
- expr = {
+ #' |
|
| 301 | -! | +
- g <- lattice::splom(ANL, varnames = varnames_value, pch = 16, alpha = alpha_value, cex = cex_value)+ #' @return a named character vector with the variable labels, the names |
|
| 302 | -! | +
- g+ #' correspond to the variable names |
|
| 303 |
- },+ #' |
||
| 304 | -! | +
- env = list(varnames_value = varnames, alpha_value = alpha, cex_value = cex)+ #' @note the `formatters` package is the source of the function. |
|
| 305 |
- )+ #' |
||
| 306 |
- )+ #' @keywords internal |
||
| 307 |
- }+ var_labels <- function(x, fill = FALSE) {
|
||
| 308 | ! |
- qenv+ stopifnot(is.data.frame(x)) |
|
| 309 | -+ | ! |
- })+ if (NCOL(x) == 0) {
|
| 310 | -+ | ! |
-
+ return(character()) |
| 311 | -! | +
- plot_r <- reactive(output_q()[["g"]])+ } |
|
| 313 | -+ | ! |
- # Insert the plot into a plot_with_settings module+ y <- Map(function(col, colname) {
|
| 314 | ! |
- pws <- teal.widgets::plot_with_settings_srv(+ label <- attr(col, "label") |
|
| 315 | -! | +
- id = "myplot",+ |
|
| 316 | ! |
- plot_r = plot_r,+ if (is.null(label)) {
|
|
| 317 | ! |
- height = plot_height,+ if (fill) {
|
|
| 318 | ! |
- width = plot_width+ colname |
|
| 319 |
- )+ } else {
|
||
| 320 | -+ | ! |
-
+ NA_character_ |
| 321 |
- # show a message if conversion to factors took place+ } |
||
| 322 | -! | +
- output$message <- renderText({
+ } else {
|
|
| 323 | ! |
- shiny::req(iv_r()$is_valid())+ if (!is.character(label) && !(length(label) == 1)) {
|
|
| 324 | ! |
- req(selector_list()$variables())+ stop("label for variable ", colname, "is not a character string")
|
|
| 325 | -! | +
- ANL <- merged$anl_q_r()[["ANL"]] # nolint object_name_linter+ } |
|
| 326 | ! |
- cols_names <- unique(unname(do.call(c, merged$anl_input_r()$columns_source)))+ as.vector(label) |
|
| 327 | -! | +
- check_char <- vapply(ANL[, cols_names], is.character, logical(1))+ } |
|
| 328 | ! |
- if (any(check_char)) {
+ }, x, colnames(x)) |
|
| 329 | -! | +
- is_single <- sum(check_char) == 1+ |
|
| 330 | ! |
- paste(+ labels <- unlist(y, recursive = FALSE, use.names = TRUE) |
|
| 331 | -! | +
- "Character",+ |
|
| 332 | ! |
- ifelse(is_single, "variable", "variables"),+ if (!is.character(labels)) {
|
|
| 333 | ! |
- paste0("(", paste(cols_names[check_char], collapse = ", "), ")"),
+ stop("label extraction failed")
|
|
| 334 | -! | +
- ifelse(is_single, "was", "were"),+ } |
|
| 335 | -! | +
- "converted to",+ |
|
| 336 | ! |
- ifelse(is_single, "factor.", "factors.")+ labels |
|
| 337 |
- )+ } |
||
| 338 |
- } else {
+
|
||
| 339 |
- ""+ #' Get a string with java-script code checking if the specific tab is clicked |
||
| 340 |
- }+ #' @description will be the input for `shiny::conditionalPanel()` |
||
| 341 |
- })+ #' @param id `character(1)` the id of the tab panel with tabs. |
||
| 342 |
-
+ #' @param name `character(1)` the name of the tab. |
||
| 343 | -! | +
- teal.widgets::verbatim_popup_srv(+ #' @keywords internal |
|
| 344 | -! | +
- id = "warning",+ is_tab_active_js <- function(id, name) {
|
|
| 345 | -! | +
- verbatim_content = reactive(teal.code::get_warnings(output_q())),+ # supporting the bs3 and higher version at the same time |
|
| 346 | ! |
- title = "Warning",+ sprintf( |
|
| 347 | ! |
- disabled = reactive(is.null(teal.code::get_warnings(output_q())))+ "$(\"#%1$s > li.active\").text().trim() == '%2$s' || $(\"#%1$s > li a.active\").text().trim() == '%2$s'", |
|
| 348 | -+ | ! |
- )+ id, name |
| 349 |
-
+ ) |
||
| 350 | -! | +
- teal.widgets::verbatim_popup_srv(+ } |
|
| 351 | -! | +
| 1 | +
- id = "rcode",+ #' Create a scatterplot matrix |
||
| 352 | -! | +||
| 2 | +
- verbatim_content = reactive(teal.code::get_code(output_q())),+ #' |
||
| 353 | -! | +||
| 3 | +
- title = "Show R Code for Scatterplotmatrix"+ #' The available datasets to choose from for each dataset selector is the same and |
||
| 354 | +4 |
- )+ #' determined by the argument `variables`. |
|
| 355 | +5 |
-
+ #' @md |
|
| 356 | +6 |
- ### REPORTER+ #' |
|
| 357 | -! | +||
| 7 | +
- if (with_reporter) {
+ #' @inheritParams teal::module |
||
| 358 | -! | +||
| 8 | +
- card_fun <- function(comment, label) {
+ #' @inheritParams tm_g_scatterplot |
||
| 359 | -! | +||
| 9 | +
- card <- teal::report_card_template(+ #' @inheritParams shared_params |
||
| 360 | -! | +||
| 10 | +
- title = "Scatter Plot Matrix",+ #' |
||
| 361 | -! | +||
| 11 | +
- label = label,+ #' @param variables (`data_extract_spec` or `list` of multiple `data_extract_spec`) |
||
| 362 | -! | +||
| 12 | +
- with_filter = with_filter,+ #' Plotting variables from an incoming dataset with filtering and selecting. In case of |
||
| 363 | -! | +||
| 13 | +
- filter_panel_api = filter_panel_api+ #' `data_extract_spec` use `select_spec(..., ordered = TRUE)` if plot elements should be |
||
| 364 | +14 |
- )+ #' rendered according to selection order. |
|
| 365 | -! | +||
| 15 | +
- card$append_text("Plot", "header3")
+ #' |
||
| 366 | -! | +||
| 16 | +
- card$append_plot(plot_r(), dim = pws$dim())+ #' @note For more examples, please see the vignette "Using scatterplot matrix" via |
||
| 367 | -! | +||
| 17 | +
- if (!comment == "") {
+ #' \code{vignette("using-scatterplot-matrix", package = "teal.modules.general")}.
|
||
| 368 | -! | +||
| 18 | +
- card$append_text("Comment", "header3")
+ #' @export |
||
| 369 | -! | +||
| 19 | +
- card$append_text(comment)+ #' |
||
| 370 | +20 |
- }+ #' @examples |
|
| 371 | -! | +||
| 21 | +
- card$append_src(teal.code::get_code(output_q()))+ #' # Scatterplot matrix of variables from ADSL dataset |
||
| 372 | -! | +||
| 22 | +
- card+ #' |
||
| 373 | +23 |
- }+ #' data <- teal_data() |
|
| 374 | -! | +||
| 24 | +
- teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
+ #' data <- within(data, {
+ |
+ ||
| 25 | ++ |
+ #' ADSL <- teal.modules.general::rADSL |
|
| 375 | +26 |
- }+ #' ADRS <- teal.modules.general::rADRS |
|
| 376 | +27 |
- ###+ #' }) |
|
| 377 | +28 |
- })+ #' datanames <- c("ADSL", "ADRS")
|
|
| 378 | +29 |
- }+ #' datanames(data) <- datanames |
|
| 379 | +30 |
-
+ #' join_keys(data) <- default_cdisc_join_keys[datanames] |
|
| 380 | +31 |
- #' Get stats for x-y pairs in scatterplot matrix+ #' |
|
| 381 | +32 |
- #' @description uses stats::cor.test per default for all numerical input variables and converts results+ #' app <- teal::init( |
|
| 382 | +33 |
- #' to character vector. Could be extended if different stats for different variable+ #' data = data, |
|
| 383 | +34 |
- #' types are needed. Meant to be called from \code{lattice::panel.text}.
+ #' modules = teal::modules( |
|
| 384 | +35 |
- #' @param x \code{numeric}
+ #' teal.modules.general::tm_g_scatterplotmatrix( |
|
| 385 | +36 |
- #' @param y \code{numeric}
+ #' label = "Scatterplot matrix", |
|
| 386 | +37 |
- #' @param .f \code{function}, function that accepts x and y as formula input \code{~ x + y}.
+ #' variables = list( |
|
| 387 | +38 |
- #' Default \code{stats::cor.test}
+ #' teal.transform::data_extract_spec( |
|
| 388 | +39 |
- #' @param .f_args \code{list} of arguments to be passed to \code{.f}
+ #' dataname = "ADSL", |
|
| 389 | +40 |
- #' @param round_stat \code{integer}
+ #' select = select_spec( |
|
| 390 | +41 |
- #' @param round_pval \code{integer}
+ #' label = "Select variables:", |
|
| 391 | +42 |
- #' @details presently we need to use a formula input for \code{stats::cor.test} because
+ #' choices = variable_choices(data[["ADSL"]]), |
|
| 392 | +43 |
- #' \code{na.fail} only gets evaluated when a formula is passed (see below).
+ #' selected = c("AGE", "RACE", "SEX"),
|
|
| 393 | +44 |
- #' \preformatted{
+ #' multiple = TRUE, |
|
| 394 | +45 |
- #' x = c(1,3,5,7,NA)+ #' ordered = TRUE, |
|
| 395 | +46 |
- #' y = c(3,6,7,8,1)+ #' fixed = FALSE |
|
| 396 | +47 |
- #' stats::cor.test(x, y, na.action = "na.fail")+ #' ) |
|
| 397 | +48 |
- #' stats::cor.test(~ x + y, na.action = "na.fail")+ #' ), |
|
| 398 | +49 |
- #' }+ #' teal.transform::data_extract_spec( |
|
| 399 | +50 |
- #' @return \code{character} with stats. For \code{stats::cor.test} correlation coefficient and p-value.
+ #' dataname = "ADRS", |
|
| 400 | +51 |
- #' @export+ #' filter = teal.transform::filter_spec( |
|
| 401 | +52 |
- #' @examples+ #' label = "Select endpoints:", |
|
| 402 | +53 |
- #' set.seed(1)+ #' vars = c("PARAMCD", "AVISIT"),
|
|
| 403 | +54 |
- #' x <- runif(25, 0, 1)+ #' choices = value_choices(data[["ADRS"]], c("PARAMCD", "AVISIT"), c("PARAM", "AVISIT")),
|
|
| 404 | +55 |
- #' y <- runif(25, 0, 1)+ #' selected = "INVET - END OF INDUCTION", |
|
| 405 | +56 |
- #' x[c(3, 10, 18)] <- NA+ #' multiple = TRUE |
|
| 406 | +57 |
- #'+ #' ), |
|
| 407 | +58 |
- #' get_scatterplotmatrix_stats(x, y, .f = stats::cor.test, .f_args = list(method = "pearson"))+ #' select = select_spec( |
|
| 408 | +59 |
- #' get_scatterplotmatrix_stats(x, y, .f = stats::cor.test, .f_args = list(+ #' label = "Select variables:", |
|
| 409 | +60 |
- #' method = "pearson",+ #' choices = variable_choices(data[["ADRS"]]), |
|
| 410 | +61 |
- #' na.action = na.fail+ #' selected = c("AGE", "AVAL", "ADY"),
|
|
| 411 | +62 |
- #' ))+ #' multiple = TRUE, |
|
| 412 | +63 |
- get_scatterplotmatrix_stats <- function(x, y,+ #' ordered = TRUE, |
|
| 413 | +64 |
- .f = stats::cor.test,+ #' fixed = FALSE |
|
| 414 | +65 |
- .f_args = list(),+ #' ) |
|
| 415 | +66 |
- round_stat = 2,+ #' ) |
|
| 416 | +67 |
- round_pval = 4) {
+ #' ) |
|
| 417 | -6x | +||
| 68 | +
- if (is.numeric(x) && is.numeric(y)) {
+ #' ) |
||
| 418 | -3x | +||
| 69 | +
- stat <- tryCatch(do.call(.f, c(list(~ x + y), .f_args)), error = function(e) NA)+ #' ) |
||
| 419 | +70 |
-
+ #' ) |
|
| 420 | -3x | +||
| 71 | +
- if (anyNA(stat)) {
+ #' if (interactive()) {
|
||
| 421 | -1x | +||
| 72 | +
- return("NA")
+ #' shinyApp(app$ui, app$server) |
||
| 422 | -2x | +||
| 73 | +
- } else if (all(c("estimate", "p.value") %in% names(stat))) {
+ #' } |
||
| 423 | -2x | +||
| 74 | +
- return(paste(+ tm_g_scatterplotmatrix <- function(label = "Scatterplot Matrix", |
||
| 424 | -2x | +||
| 75 | +
- c(+ variables, |
||
| 425 | -2x | +||
| 76 | +
- paste0(names(stat$estimate), ":", round(stat$estimate, round_stat)),+ plot_height = c(600, 200, 2000), |
||
| 426 | -2x | +||
| 77 | +
- paste0("P:", round(stat$p.value, round_pval))
+ plot_width = NULL, |
||
| 427 | +78 |
- ),+ pre_output = NULL, |
|
| 428 | -2x | +||
| 79 | +
- collapse = "\n"+ post_output = NULL) {
|
||
| 429 | -+ | ||
| 80 | +! |
- ))+ logger::log_info("Initializing tm_g_scatterplotmatrix")
|
|
| 430 | -+ | ||
| 81 | +! |
- } else {
+ if (!requireNamespace("lattice", quietly = TRUE)) {
|
|
| 431 | +82 | ! |
- stop("function not supported")
+ stop("Cannot load lattice - please install the package or restart your session.")
|
| 432 | +83 |
- }+ } |
|
| 433 | -+ | ||
| 84 | +! |
- } else {
+ if (inherits(variables, "data_extract_spec")) variables <- list(variables) |
|
| 434 | -3x | +||
| 85 | +
- if ("method" %in% names(.f_args)) {
+
|
||
| 435 | -3x | +||
| 86 | +! |
- if (.f_args$method == "pearson") {
+ checkmate::assert_string(label) |
|
| 436 | -1x | +||
| 87 | +! |
- return("cor:-")
+ checkmate::assert_list(variables, types = "data_extract_spec") |
|
| 437 | -+ | ||
| 88 | +! |
- }+ checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE) |
|
| 438 | -2x | +||
| 89 | +! |
- if (.f_args$method == "kendall") {
+ checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height") |
|
| 439 | -1x | +||
| 90 | +! |
- return("tau:-")
+ checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE) |
|
| 440 | -+ | ||
| 91 | +! |
- }+ checkmate::assert_numeric( |
|
| 441 | -1x | +||
| 92 | +! |
- if (.f_args$method == "spearman") {
+ plot_width[1], |
|
| 442 | -1x | +||
| 93 | +! |
- return("rho:-")
+ lower = plot_width[2], upper = plot_width[3], null.ok = TRUE, .var.name = "plot_width" |
|
| 443 | +94 |
- }+ ) |
|
| 444 | +95 |
- }+ |
|
| 445 | +96 | ! |
- return("-")
+ args <- as.list(environment()) |
| 446 | -+ | ||
| 97 | +! |
- }+ module( |
|
| 447 | -+ | ||
| 98 | +! |
- }+ label = label, |
| 1 | -+ | ||
| 99 | +! |
- #' Data Table Viewer Teal Module+ server = srv_g_scatterplotmatrix, |
|
| 2 | -+ | ||
| 100 | +! |
- #'+ ui = ui_g_scatterplotmatrix, |
|
| 3 | -+ | ||
| 101 | +! |
- #' A data table viewer shows the data using a paginated table.+ ui_args = args, |
|
| 4 | -+ | ||
| 102 | +! |
- #' specifically designed for use with `data.frames`.+ server_args = list(variables = variables, plot_height = plot_height, plot_width = plot_width), |
|
| 5 | -+ | ||
| 103 | +! |
- #' @md+ datanames = teal.transform::get_extract_datanames(variables) |
|
| 6 | +104 |
- #'+ ) |
|
| 7 | +105 |
- #' @inheritParams teal::module+ } |
|
| 8 | +106 |
- #' @inheritParams shared_params+ |
|
| 9 | +107 |
- #' @param variables_selected (`list`) A named list of character vectors of the variables (i.e. columns)+ ui_g_scatterplotmatrix <- function(id, ...) {
|
|
| 10 | -+ | ||
| 108 | +! |
- #' which should be initially shown for each dataset. Names of list elements should correspond to the names+ args <- list(...) |
|
| 11 | -+ | ||
| 109 | +! |
- #' of the datasets available in the app. If no entry is specified for a dataset, the first six variables from that+ is_single_dataset_value <- teal.transform::is_single_dataset(args$variables) |
|
| 12 | -+ | ||
| 110 | +! |
- #' dataset will initially be shown.+ ns <- NS(id) |
|
| 13 | -+ | ||
| 111 | +! |
- #' @param datasets_selected (`character`) A vector of datasets which should be+ teal.widgets::standard_layout( |
|
| 14 | -+ | ||
| 112 | +! |
- #' shown and in what order. Names in the vector have to correspond with datasets names.+ output = teal.widgets::white_small_well( |
|
| 15 | -+ | ||
| 113 | +! |
- #' If vector of length zero (default) then all datasets are shown.+ textOutput(ns("message")),
+ |
+ |
| 114 | +! | +
+ br(),+ |
+ |
| 115 | +! | +
+ teal.widgets::plot_with_settings_ui(id = ns("myplot"))
|
|
| 16 | +116 |
- #' Note: Only datasets of the `data.frame` class are compatible;+ ), |
|
| 17 | -+ | ||
| 117 | +! |
- #' using other types will cause an error.+ encoding = div( |
|
| 18 | +118 |
- #' @param dt_args (named `list`) Additional arguments to be passed to `DT::datatable`+ ### Reporter |
|
| 19 | -+ | ||
| 119 | +! |
- #' (must not include `data` or `options`).+ teal.reporter::simple_reporter_ui(ns("simple_reporter")),
|
|
| 20 | +120 |
- #' @param dt_options (named `list`) The `options` argument to `DT::datatable`. By default+ ### |
|
| 21 | -+ | ||
| 121 | +! |
- #' `list(searching = FALSE, pageLength = 30, lengthMenu = c(5, 15, 30, 100), scrollX = TRUE)`+ tags$label("Encodings", class = "text-primary"),
|
|
| 22 | -+ | ||
| 122 | +! |
- #' @param server_rendering (`logical`) should the data table be rendered server side+ teal.transform::datanames_input(args$variables), |
|
| 23 | -+ | ||
| 123 | +! |
- #' (see `server` argument of `DT::renderDataTable()`)+ teal.transform::data_extract_ui( |
|
| 24 | -+ | ||
| 124 | +! |
- #' @details+ id = ns("variables"),
|
|
| 25 | -+ | ||
| 125 | +! |
- #' The `DT` package has an option `DT.TOJSON_ARGS` to show `Inf` and `NA` in data tables. If this is something+ label = "Variables", |
|
| 26 | -+ | ||
| 126 | +! |
- #' you require then set `options(DT.TOJSON_ARGS = list(na = "string"))` before running the module.+ data_extract_spec = args$variables, |
|
| 27 | -+ | ||
| 127 | +! |
- #' Note though that sorting of numeric columns with `NA`/`Inf` will be lexicographic not numerical.+ is_single_dataset = is_single_dataset_value |
|
| 28 | +128 |
- #' @export+ ), |
|
| 29 | -+ | ||
| 129 | +! |
- #' @examples+ hr(), |
|
| 30 | -+ | ||
| 130 | +! |
- #'+ teal.widgets::panel_group( |
|
| 31 | -+ | ||
| 131 | +! |
- #' data <- teal_data()+ teal.widgets::panel_item( |
|
| 32 | -+ | ||
| 132 | +! |
- #' data <- within(data, {
+ title = "Plot settings", |
|
| 33 | -+ | ||
| 133 | +! |
- #' library(nestcolor)+ sliderInput( |
|
| 34 | -+ | ||
| 134 | +! |
- #' ADSL <- teal.modules.general::rADSL+ ns("alpha"), "Opacity:",
|
|
| 35 | -+ | ||
| 135 | +! |
- #' })+ min = 0, max = 1, |
|
| 36 | -+ | ||
| 136 | +! |
- #' datanames <- c("ADSL")
+ step = .05, value = .5, ticks = FALSE |
|
| 37 | +137 |
- #' datanames(data) <- datanames+ ), |
|
| 38 | -+ | ||
| 138 | +! |
- #' join_keys(data) <- default_cdisc_join_keys[datanames]+ sliderInput( |
|
| 39 | -+ | ||
| 139 | +! |
- #'+ ns("cex"), "Points size:",
|
|
| 40 | -+ | ||
| 140 | +! |
- #' app <- teal::init(+ min = 0.2, max = 3, |
|
| 41 | -+ | ||
| 141 | +! |
- #' data = data,+ step = .05, value = .65, ticks = FALSE |
|
| 42 | +142 |
- #' modules = teal::modules(+ ), |
|
| 43 | -+ | ||
| 143 | +! |
- #' teal.modules.general::tm_data_table(+ checkboxInput(ns("cor"), "Add Correlation", value = FALSE),
|
|
| 44 | -+ | ||
| 144 | +! |
- #' variables_selected = list(ADSL = c("STUDYID", "USUBJID", "SUBJID", "SITEID", "AGE", "SEX")),
+ radioButtons( |
|
| 45 | -+ | ||
| 145 | +! |
- #' dt_args = list(caption = "ADSL Table Caption")+ ns("cor_method"), "Select Correlation Method",
|
|
| 46 | -+ | ||
| 146 | +! |
- #' )+ choiceNames = c("Pearson", "Kendall", "Spearman"),
|
|
| 47 | -+ | ||
| 147 | +! |
- #' )+ choiceValues = c("pearson", "kendall", "spearman"),
|
|
| 48 | -+ | ||
| 148 | +! |
- #' )+ inline = TRUE |
|
| 49 | +149 |
- #' if (interactive()) {
+ ), |
|
| 50 | -+ | ||
| 150 | +! |
- #' shinyApp(app$ui, app$server)+ checkboxInput(ns("cor_na_omit"), "Omit Missing Values", value = TRUE)
|
|
| 51 | +151 |
- #' }+ ) |
|
| 52 | +152 |
- tm_data_table <- function(label = "Data Table",+ ) |
|
| 53 | +153 |
- variables_selected = list(),+ ), |
|
| 54 | -+ | ||
| 154 | +! |
- datasets_selected = character(0),+ forms = tagList( |
|
| 55 | -+ | ||
| 155 | +! |
- dt_args = list(),+ teal.widgets::verbatim_popup_ui(ns("warning"), "Show Warnings"),
|
|
| 56 | -+ | ||
| 156 | +! |
- dt_options = list(+ teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code")
|
|
| 57 | +157 |
- searching = FALSE,+ ), |
|
| 58 | -+ | ||
| 158 | +! |
- pageLength = 30,+ pre_output = args$pre_output, |
|
| 59 | -+ | ||
| 159 | +! |
- lengthMenu = c(5, 15, 30, 100),+ post_output = args$post_output |
|
| 60 | +160 |
- scrollX = TRUE+ ) |
|
| 61 | +161 |
- ),+ } |
|
| 62 | +162 |
- server_rendering = FALSE,+ |
|
| 63 | +163 |
- pre_output = NULL,+ srv_g_scatterplotmatrix <- function(id, data, reporter, filter_panel_api, variables, plot_height, plot_width) {
|
|
| 64 | -+ | ||
| 164 | +! |
- post_output = NULL) {
+ with_reporter <- !missing(reporter) && inherits(reporter, "Reporter") |
|
| 65 | +165 | ! |
- logger::log_info("Initializing tm_data_table")
+ with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI") |
| 66 | +166 | ! |
- checkmate::assert_string(label)+ checkmate::assert_class(data, "reactive") |
| 67 | +167 | ! |
- checkmate::assert_list(variables_selected, min.len = 0, types = "character", names = "named")+ checkmate::assert_class(isolate(data()), "teal_data") |
| 68 | +168 | ! |
- if (length(variables_selected) > 0) {
+ moduleServer(id, function(input, output, session) {
|
| 69 | +169 | ! |
- lapply(seq_along(variables_selected), function(i) {
+ selector_list <- teal.transform::data_extract_multiple_srv( |
| 70 | +170 | ! |
- checkmate::assert_character(variables_selected[[i]], min.chars = 1, min.len = 1)+ data_extract = list(variables = variables), |
| 71 | +171 | ! |
- if (!is.null(names(variables_selected[[i]]))) {
+ datasets = data, |
| 72 | +172 | ! |
- checkmate::assert_names(names(variables_selected[[i]]))+ select_validation_rule = list( |
| 73 | -+ | ||
| 173 | +! |
- }+ variables = ~ if (length(.) <= 1) "Please select at least 2 columns." |
|
| 74 | +174 |
- })+ ) |
|
| 75 | +175 |
- }- |
- |
| 76 | -! | -
- checkmate::assert_character(datasets_selected, min.len = 0, min.chars = 1)+ ) |
|
| 77 | -! | +||
| 176 | +
- checkmate::assert_list(dt_options, names = "named")+ |
||
| 78 | +177 | ! |
- checkmate::assert(+ iv_r <- reactive({
|
| 79 | +178 | ! |
- checkmate::check_list(dt_args, len = 0),+ iv <- shinyvalidate::InputValidator$new() |
| 80 | +179 | ! |
- checkmate::check_subset(names(dt_args), choices = names(formals(DT::datatable)))- |
-
| 81 | -- |
- )+ teal.transform::compose_and_enable_validators(iv, selector_list) |
|
| 82 | +180 | - - | -|
| 83 | -! | -
- checkmate::assert_flag(server_rendering)+ }) |
|
| 84 | +181 | ||
| 85 | -! | -
- module(- |
- |
| 86 | -! | -
- label,- |
- |
| 87 | +182 | ! |
- server = srv_page_data_table,+ anl_merged_input <- teal.transform::merge_expression_srv( |
| 88 | +183 | ! |
- ui = ui_page_data_table,+ datasets = data, |
| 89 | +184 | ! |
- datanames = if (length(datasets_selected) == 0) "all" else datasets_selected,+ selector_list = selector_list |
| 90 | -! | +||
| 185 | +
- server_args = list(+ ) |
||
| 91 | -! | +||
| 186 | +
- variables_selected = variables_selected,+ |
||
| 92 | +187 | ! |
- datasets_selected = datasets_selected,+ anl_merged_q <- reactive({
|
| 93 | +188 | ! |
- dt_args = dt_args,+ req(anl_merged_input()) |
| 94 | +189 | ! |
- dt_options = dt_options,+ data() %>% |
| 95 | +190 | ! |
- server_rendering = server_rendering+ teal.code::eval_code(as.expression(anl_merged_input()$expr)) |
| 96 | +191 |
- ),+ }) |
|
| 97 | -! | +||
| 192 | +
- ui_args = list(+ |
||
| 98 | +193 | ! |
- pre_output = pre_output,+ merged <- list( |
| 99 | +194 | ! |
- post_output = post_output- |
-
| 100 | -- |
- )+ anl_input_r = anl_merged_input, |
|
| 101 | -+ | ||
| 195 | +! |
- )+ anl_q_r = anl_merged_q |
|
| 102 | +196 |
- }+ ) |
|
| 103 | +197 | ||
| 104 | +198 |
-
+ # plot |
|
| 105 | -+ | ||
| 199 | +! |
- # ui page module+ output_q <- reactive({
|
|
| 106 | -+ | ||
| 200 | +! |
- ui_page_data_table <- function(id,+ teal::validate_inputs(iv_r()) |
|
| 107 | +201 |
- pre_output = NULL,+ |
|
| 108 | -+ | ||
| 202 | +! |
- post_output = NULL) {
+ qenv <- merged$anl_q_r() |
|
| 109 | +203 | ! |
- ns <- NS(id)+ ANL <- qenv[["ANL"]] # nolint: object_name. |
| 110 | +204 | ||
| 111 | +205 | ! |
- shiny::tagList(+ cols_names <- merged$anl_input_r()$columns_source$variables |
| 112 | +206 | ! |
- include_css_files("custom"),
+ alpha <- input$alpha |
| 113 | +207 | ! |
- teal.widgets::standard_layout(+ cex <- input$cex |
| 114 | +208 | ! |
- output = teal.widgets::white_small_well(+ add_cor <- input$cor |
| 115 | +209 | ! |
- fluidRow(+ cor_method <- input$cor_method |
| 116 | +210 | ! |
- column(+ cor_na_omit <- input$cor_na_omit |
| 117 | -! | +||
| 211 | +
- width = 12,+ |
||
| 118 | +212 | ! |
- checkboxInput(+ cor_na_action <- if (isTruthy(cor_na_omit)) {
|
| 119 | +213 | ! |
- ns("if_distinct"),
+ "na.omit" |
| 120 | -! | +||
| 214 | +
- "Show only distinct rows:",+ } else {
|
||
| 121 | +215 | ! |
- value = FALSE- |
-
| 122 | -- |
- )+ "na.fail" |
|
| 123 | +216 |
- )+ } |
|
| 124 | +217 |
- ),+ |
|
| 125 | +218 | ! |
- fluidRow(+ teal::validate_has_data(ANL, 10) |
| 126 | +219 | ! |
- class = "mb-8",+ teal::validate_has_data(ANL[, cols_names, drop = FALSE], 10, complete = TRUE, allow_inf = FALSE) |
| 127 | -! | +||
| 220 | +
- column(+ |
||
| 128 | -! | +||
| 221 | +
- width = 12,+ # get labels and proper variable names |
||
| 129 | +222 | ! |
- uiOutput(ns("dataset_table"))
- |
-
| 130 | -- |
- )+ varnames <- varname_w_label(cols_names, ANL, wrap_width = 20) |
|
| 131 | +223 |
- )+ |
|
| 132 | +224 |
- ),+ # check character columns. If any, then those are converted to factors |
|
| 133 | +225 | ! |
- pre_output = pre_output,+ check_char <- vapply(ANL[, cols_names], is.character, logical(1)) |
| 134 | +226 | ! |
- post_output = post_output- |
-
| 135 | -- |
- )- |
- |
| 136 | -- |
- )+ if (any(check_char)) {
|
|
| 137 | -+ | ||
| 227 | +! |
- }+ qenv <- teal.code::eval_code( |
|
| 138 | -+ | ||
| 228 | +! |
-
+ qenv, |
|
| 139 | -+ | ||
| 229 | +! |
-
+ substitute( |
|
| 140 | -+ | ||
| 230 | +! |
- # server page module+ expr = ANL <- ANL[, cols_names] %>% # nolint: object_name. |
|
| 141 | -+ | ||
| 231 | +! |
- srv_page_data_table <- function(id,+ dplyr::mutate_if(is.character, as.factor) %>% |
|
| 142 | -+ | ||
| 232 | +! |
- data,+ droplevels(), |
|
| 143 | -+ | ||
| 233 | +! |
- datasets_selected,+ env = list(cols_names = cols_names) |
|
| 144 | +234 |
- variables_selected,+ ) |
|
| 145 | +235 |
- dt_args,+ ) |
|
| 146 | +236 |
- dt_options,+ } else {
|
|
| 147 | -+ | ||
| 237 | +! |
- server_rendering) {
+ qenv <- teal.code::eval_code( |
|
| 148 | +238 | ! |
- checkmate::assert_class(data, "reactive")+ qenv, |
| 149 | +239 | ! |
- checkmate::assert_class(isolate(data()), "teal_data")+ substitute( |
| 150 | +240 | ! |
- moduleServer(id, function(input, output, session) {
+ expr = ANL <- ANL[, cols_names] %>% # nolint: object_name. |
| 151 | +241 | ! |
- if_filtered <- reactive(as.logical(input$if_filtered))+ droplevels(), |
| 152 | +242 | ! |
- if_distinct <- reactive(as.logical(input$if_distinct))+ env = list(cols_names = cols_names) |
| 153 | +243 |
-
+ ) |
|
| 154 | -! | +||
| 244 | +
- datanames <- isolate(teal.data::datanames(data()))+ ) |
||
| 155 | -! | +||
| 245 | +
- datanames <- Filter(function(name) {
+ } |
||
| 156 | -! | +||
| 246 | +
- is.data.frame(isolate(data())[[name]])+ |
||
| 157 | -! | +||
| 247 | +
- }, datanames)+ |
||
| 158 | +248 |
-
+ # create plot |
|
| 159 | +249 | ! |
- if (!identical(datasets_selected, character(0))) {
+ if (add_cor) {
|
| 160 | +250 | ! |
- checkmate::assert_subset(datasets_selected, datanames)+ shinyjs::show("cor_method")
|
| 161 | +251 | ! |
- datanames <- datasets_selected+ shinyjs::show("cor_use")
|
| 162 | -+ | ||
| 252 | +! |
- }+ shinyjs::show("cor_na_omit")
|
|
| 163 | +253 | ||
| 164 | +254 | ! |
- output$dataset_table <- renderUI({
+ qenv <- teal.code::eval_code( |
| 165 | +255 | ! |
- do.call(+ qenv, |
| 166 | +256 | ! |
- tabsetPanel,+ substitute( |
| 167 | +257 | ! |
- lapply(+ expr = {
|
| 168 | +258 | ! |
- datanames,+ g <- lattice::splom( |
| 169 | +259 | ! |
- function(x) {
+ ANL, |
| 170 | +260 | ! |
- dataset <- isolate(data()[[x]])+ varnames = varnames_value, |
| 171 | +261 | ! |
- choices <- names(dataset)+ panel = function(x, y, ...) {
|
| 172 | +262 | ! |
- labels <- vapply(+ lattice::panel.splom(x = x, y = y, ...) |
| 173 | +263 | ! |
- dataset,+ cpl <- lattice::current.panel.limits() |
| 174 | +264 | ! |
- function(x) ifelse(is.null(attr(x, "label")), "", attr(x, "label")),+ lattice::panel.text( |
| 175 | +265 | ! |
- character(1)+ mean(cpl$xlim), |
| 176 | -+ | ||
| 266 | +! |
- )+ mean(cpl$ylim), |
|
| 177 | +267 | ! |
- names(choices) <- ifelse(+ get_scatterplotmatrix_stats( |
| 178 | +268 | ! |
- is.na(labels) | labels == "",+ x, |
| 179 | +269 | ! |
- choices,+ y, |
| 180 | +270 | ! |
- paste(choices, labels, sep = ": ")+ .f = stats::cor.test,+ |
+
| 271 | +! | +
+ .f_args = list(method = cor_method, na.action = cor_na_action) |
|
| 181 | +272 |
- )+ ), |
|
| 182 | +273 | ! |
- variables_selected <- if (!is.null(variables_selected[[x]])) {
+ alpha = 0.6, |
| 183 | +274 | ! |
- variables_selected[[x]]- |
-
| 184 | -- |
- } else {
+ fontsize = 18, |
|
| 185 | +275 | ! |
- utils::head(choices)+ fontface = "bold" |
| 186 | +276 |
- }+ ) |
|
| 187 | -! | +||
| 277 | +
- tabPanel(+ }, |
||
| 188 | +278 | ! |
- title = x,+ pch = 16, |
| 189 | +279 | ! |
- column(+ alpha = alpha_value, |
| 190 | +280 | ! |
- width = 12,+ cex = cex_value |
| 191 | -! | +||
| 281 | +
- div(+ ) |
||
| 192 | +282 | ! |
- class = "mt-4",+ print(g) |
| 193 | -! | +||
| 283 | +
- ui_data_table(+ }, |
||
| 194 | +284 | ! |
- id = session$ns(x),+ env = list( |
| 195 | +285 | ! |
- choices = choices,+ varnames_value = varnames, |
| 196 | +286 | ! |
- selected = variables_selected- |
-
| 197 | -- |
- )- |
- |
| 198 | -- |
- )+ cor_method = cor_method, |
|
| 199 | -+ | ||
| 287 | +! |
- )+ cor_na_action = cor_na_action, |
|
| 200 | -+ | ||
| 288 | +! |
- )+ alpha_value = alpha, |
|
| 201 | -+ | ||
| 289 | +! |
- }+ cex_value = cex |
|
| 202 | +290 |
- )+ ) |
|
| 203 | +291 |
- )+ ) |
|
| 204 | +292 |
- })+ ) |
|
| 205 | +293 | - - | -|
| 206 | -! | -
- lapply(+ } else {
|
|
| 207 | +294 | ! |
- datanames,+ shinyjs::hide("cor_method")
|
| 208 | +295 | ! |
- function(x) {
+ shinyjs::hide("cor_use")
|
| 209 | +296 | ! |
- srv_data_table(+ shinyjs::hide("cor_na_omit")
|
| 210 | +297 | ! |
- id = x,+ qenv <- teal.code::eval_code( |
| 211 | +298 | ! |
- data = data,+ qenv, |
| 212 | +299 | ! |
- dataname = x,+ substitute( |
| 213 | +300 | ! |
- if_filtered = if_filtered,+ expr = {
|
| 214 | +301 | ! |
- if_distinct = if_distinct,+ g <- lattice::splom(ANL, varnames = varnames_value, pch = 16, alpha = alpha_value, cex = cex_value) |
| 215 | +302 | ! |
- dt_args = dt_args,+ g |
| 216 | -! | +||
| 303 | +
- dt_options = dt_options,+ }, |
||
| 217 | +304 | ! |
- server_rendering = server_rendering+ env = list(varnames_value = varnames, alpha_value = alpha, cex_value = cex) |
| 218 | +305 |
- )+ ) |
|
| 219 | +306 |
- }+ ) |
|
| 220 | +307 |
- )+ } |
|
| 221 | -+ | ||
| 308 | +! |
- })+ qenv |
|
| 222 | +309 |
- }+ }) |
|
| 223 | +310 | ||
| 224 | -+ | ||
| 311 | +! |
- ui_data_table <- function(id,+ plot_r <- reactive(output_q()[["g"]]) |
|
| 225 | +312 |
- choices,+ |
|
| 226 | +313 |
- selected) {
+ # Insert the plot into a plot_with_settings module |
|
| 227 | +314 | ! |
- ns <- NS(id)- |
-
| 228 | -- |
-
+ pws <- teal.widgets::plot_with_settings_srv( |
|
| 229 | +315 | ! |
- if (!is.null(selected)) {
+ id = "myplot", |
| 230 | +316 | ! |
- all_choices <- choices+ plot_r = plot_r, |
| 231 | +317 | ! |
- choices <- c(selected, setdiff(choices, selected))+ height = plot_height, |
| 232 | +318 | ! |
- names(choices) <- names(all_choices)[match(choices, all_choices)]+ width = plot_width |
| 233 | +319 |
- }+ ) |
|
| 234 | +320 | ||
| 321 | ++ |
+ # show a message if conversion to factors took place+ |
+ |
| 235 | +322 | ! |
- tagList(+ output$message <- renderText({
|
| 236 | +323 | ! |
- teal.widgets::get_dt_rows(ns("data_table"), ns("dt_rows")),
+ shiny::req(iv_r()$is_valid()) |
| 237 | +324 | ! |
- fluidRow(+ req(selector_list()$variables()) |
| 238 | +325 | ! |
- teal.widgets::optionalSelectInput(+ ANL <- merged$anl_q_r()[["ANL"]] # nolint: object_name. |
| 239 | +326 | ! |
- ns("variables"),
+ cols_names <- unique(unname(do.call(c, merged$anl_input_r()$columns_source))) |
| 240 | +327 | ! |
- "Select variables:",+ check_char <- vapply(ANL[, cols_names], is.character, logical(1)) |
| 241 | +328 | ! |
- choices = choices,+ if (any(check_char)) {
|
| 242 | +329 | ! |
- selected = selected,+ is_single <- sum(check_char) == 1 |
| 243 | +330 | ! |
- multiple = TRUE,+ paste( |
| 244 | +331 | ! |
- width = "100%"+ "Character", |
| 245 | -+ | ||
| 332 | +! |
- )+ ifelse(is_single, "variable", "variables"), |
|
| 246 | -+ | ||
| 333 | +! |
- ),+ paste0("(", paste(cols_names[check_char], collapse = ", "), ")"),
|
|
| 247 | +334 | ! |
- fluidRow(+ ifelse(is_single, "was", "were"), |
| 248 | +335 | ! |
- DT::dataTableOutput(ns("data_table"), width = "100%")
+ "converted to", |
| 249 | -+ | ||
| 336 | +! |
- )+ ifelse(is_single, "factor.", "factors.") |
|
| 250 | +337 |
- )+ ) |
|
| 251 | +338 |
- }+ } else {
|
|
| 252 | +339 |
-
+ "" |
|
| 253 | +340 |
- srv_data_table <- function(id,+ } |
|
| 254 | +341 |
- data,+ }) |
|
| 255 | +342 |
- dataname,+ |
|
| 256 | -+ | ||
| 343 | +! |
- if_filtered,+ teal.widgets::verbatim_popup_srv( |
|
| 257 | -+ | ||
| 344 | +! |
- if_distinct,+ id = "warning", |
|
| 258 | -+ | ||
| 345 | +! |
- dt_args,+ verbatim_content = reactive(teal.code::get_warnings(output_q())), |
|
| 259 | -+ | ||
| 346 | +! |
- dt_options,+ title = "Warning",+ |
+ |
| 347 | +! | +
+ disabled = reactive(is.null(teal.code::get_warnings(output_q()))) |
|
| 260 | +348 |
- server_rendering) {
+ ) |
|
| 261 | -! | +||
| 349 | +
- moduleServer(id, function(input, output, session) {
+
|
||
| 262 | +350 | ! |
- iv <- shinyvalidate::InputValidator$new()+ teal.widgets::verbatim_popup_srv( |
| 263 | +351 | ! |
- iv$add_rule("variables", shinyvalidate::sv_required("Please select valid variable names"))
+ id = "rcode", |
| 264 | +352 | ! |
- iv$add_rule("variables", shinyvalidate::sv_in_set(
+ verbatim_content = reactive(teal.code::get_code(output_q())), |
| 265 | +353 | ! |
- set = names(data()[[dataname]]), message_fmt = "Not all selected variables exist in the data"+ title = "Show R Code for Scatterplotmatrix" |
| 266 | +354 |
- ))+ ) |
|
| 267 | -! | +||
| 355 | +
- iv$enable()+ |
||
| 268 | +356 |
-
+ ### REPORTER |
|
| 269 | +357 | ! |
- output$data_table <- DT::renderDataTable(server = server_rendering, {
+ if (with_reporter) {
|
| 270 | +358 | ! |
- teal::validate_inputs(iv)+ card_fun <- function(comment, label) {
|
| 271 | -+ | ||
| 359 | +! |
-
+ card <- teal::report_card_template( |
|
| 272 | +360 | ! |
- df <- data()[[dataname]]+ title = "Scatter Plot Matrix", |
| 273 | +361 | ! |
- variables <- input$variables+ label = label, |
| 274 | -+ | ||
| 362 | +! |
-
+ with_filter = with_filter, |
|
| 275 | +363 | ! |
- teal::validate_has_data(df, min_nrow = 1L, msg = paste("data", dataname, "is empty"))
+ filter_panel_api = filter_panel_api |
| 276 | +364 |
-
+ ) |
|
| 277 | +365 | ! |
- dataframe_selected <- if (if_distinct()) {
+ card$append_text("Plot", "header3")
|
| 278 | +366 | ! |
- dplyr::count(df, dplyr::across(tidyselect::all_of(variables)))+ card$append_plot(plot_r(), dim = pws$dim()) |
| 279 | -+ | ||
| 367 | +! |
- } else {
+ if (!comment == "") {
|
|
| 280 | +368 | ! |
- df[variables]+ card$append_text("Comment", "header3")
|
| 281 | -+ | ||
| 369 | +! |
- }+ card$append_text(comment) |
|
| 282 | +370 | - - | -|
| 283 | -! | -
- dt_args$options <- dt_options+ } |
|
| 284 | +371 | ! |
- if (!is.null(input$dt_rows)) {
+ card$append_src(teal.code::get_code(output_q())) |
| 285 | +372 | ! |
- dt_args$options$pageLength <- input$dt_rows+ card |
| 286 | +373 |
} |
|
| 287 | +374 | ! |
- dt_args$data <- dataframe_selected+ teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
|
| 288 | +375 |
-
+ } |
|
| 289 | -! | +||
| 376 | +
- do.call(DT::datatable, dt_args)+ ### |
||
| 290 | +377 |
- })+ }) |
|
| 291 | +378 |
- })+ } |
|
| 292 | +379 |
- }+ |
| 1 | +380 |
- #' Shared Parameters+ #' Get stats for x-y pairs in scatterplot matrix |
|
| 2 | +381 |
- #'+ #' @description uses stats::cor.test per default for all numerical input variables and converts results |
|
| 3 | +382 |
- #' @description Contains arguments that are shared between multiple functions+ #' to character vector. Could be extended if different stats for different variable |
|
| 4 | +383 |
- #' in the package to avoid repetition using `inheritParams`.+ #' types are needed. Meant to be called from \code{lattice::panel.text}.
|
|
| 5 | +384 |
- #'+ #' @param x \code{numeric}
|
|
| 6 | +385 |
- #' @param plot_height optional, (`numeric`) A vector of length three with `c(value, min and max)`+ #' @param y \code{numeric}
|
|
| 7 | +386 |
- #' for a slider encoding the plot height.+ #' @param .f \code{function}, function that accepts x and y as formula input \code{~ x + y}.
|
|
| 8 | +387 |
- #' @param plot_width optional, (`numeric`) A vector of length three with `c(value, min and max)`+ #' Default \code{stats::cor.test}
|
|
| 9 | +388 |
- #' for a slider encoding the plot width.+ #' @param .f_args \code{list} of arguments to be passed to \code{.f}
|
|
| 10 | +389 |
- #' @param rotate_xaxis_labels optional, (`logical`) Whether to rotate plot X axis labels. Does not+ #' @param round_stat \code{integer}
|
|
| 11 | +390 |
- #' rotate by default (`FALSE`).+ #' @param round_pval \code{integer}
|
|
| 12 | +391 |
- #' @param ggtheme optional, (`character`) `ggplot2` theme to be used by default. Defaults to `"gray"`.+ #' @details presently we need to use a formula input for \code{stats::cor.test} because
|
|
| 13 | +392 |
- #' @param ggplot2_args (`ggplot2_args`) object created by [teal.widgets::ggplot2_args()]+ #' \code{na.fail} only gets evaluated when a formula is passed (see below).
|
|
| 14 | +393 |
- #' with settings for the module plot.+ #' \preformatted{
|
|
| 15 | +394 |
- #' The argument is merged with options variable `teal.ggplot2_args` and default module setup.+ #' x = c(1,3,5,7,NA) |
|
| 16 | +395 |
- #'+ #' y = c(3,6,7,8,1) |
|
| 17 | +396 |
- #' For more details see the vignette: `vignette("custom-ggplot2-arguments", package = "teal.widgets")`
+ #' stats::cor.test(x, y, na.action = "na.fail") |
|
| 18 | +397 |
- #' @param basic_table_args (`basic_table_args`) object created by [teal.widgets::basic_table_args()]+ #' stats::cor.test(~ x + y, na.action = "na.fail") |
|
| 19 | +398 |
- #' with settings for the module table.+ #' } |
|
| 20 | +399 |
- #' The argument is merged with options variable `teal.basic_table_args` and default module setup.+ #' @return \code{character} with stats. For \code{stats::cor.test} correlation coefficient and p-value.
|
|
| 21 | +400 |
- #'+ #' @export |
|
| 22 | +401 |
- #' For more details see the vignette: `vignette("custom-basic-table-arguments", package = "teal.widgets")`
+ #' @examples |
|
| 23 | +402 |
- #' @param pre_output (`shiny.tag`, optional)\cr+ #' set.seed(1) |
|
| 24 | +403 |
- #' with text placed before the output to put the output into context. For example a title.+ #' x <- runif(25, 0, 1) |
|
| 25 | +404 |
- #' @param post_output (`shiny.tag`, optional) with text placed after the output to put the output+ #' y <- runif(25, 0, 1) |
|
| 26 | +405 |
- #' into context. For example the [shiny::helpText()] elements are useful.+ #' x[c(3, 10, 18)] <- NA |
|
| 27 | +406 |
#' |
|
| 28 | +407 |
- #' @name shared_params+ #' get_scatterplotmatrix_stats(x, y, .f = stats::cor.test, .f_args = list(method = "pearson")) |
|
| 29 | +408 |
- #' @keywords internal+ #' get_scatterplotmatrix_stats(x, y, .f = stats::cor.test, .f_args = list( |
|
| 30 | +409 |
- NULL+ #' method = "pearson", |
|
| 31 | +410 |
-
+ #' na.action = na.fail |
|
| 32 | +411 |
- #' Add axis labels that show facetting variable+ #' )) |
|
| 33 | +412 |
- #'+ get_scatterplotmatrix_stats <- function(x, y, |
|
| 34 | +413 |
- #' Add axis labels that show facetting variable+ .f = stats::cor.test, |
|
| 35 | +414 |
- #'+ .f_args = list(), |
|
| 36 | +415 |
- #' @param p `ggplot2` object to add facet labels to+ round_stat = 2, |
|
| 37 | +416 |
- #' @param xfacet_label label of facet along x axis (nothing created if NULL),+ round_pval = 4) {
|
|
| 38 | -+ | ||
| 417 | +6x |
- #' if vector, will be concatenated with " & "+ if (is.numeric(x) && is.numeric(y)) {
|
|
| 39 | -+ | ||
| 418 | +3x |
- #' @param yfacet_label label of facet along y axis (nothing created if NULL),+ stat <- tryCatch(do.call(.f, c(list(~ x + y), .f_args)), error = function(e) NA) |
|
| 40 | +419 |
- #' if vector, will be concatenated with " & "+ |
|
| 41 | -+ | ||
| 420 | +3x |
- #'+ if (anyNA(stat)) {
|
|
| 42 | -+ | ||
| 421 | +1x |
- #' @return grid grob object (to be drawn with \code{grid.draw})
+ return("NA")
|
|
| 43 | -+ | ||
| 422 | +2x |
- #'+ } else if (all(c("estimate", "p.value") %in% names(stat))) {
|
|
| 44 | -+ | ||
| 423 | +2x |
- #' @export+ return(paste( |
|
| 45 | -+ | ||
| 424 | +2x |
- #'+ c( |
|
| 46 | -+ | ||
| 425 | +2x |
- #' @examples+ paste0(names(stat$estimate), ":", round(stat$estimate, round_stat)), |
|
| 47 | -+ | ||
| 426 | +2x |
- #' # we put donttest to avoid strictr error with seq along.with argument+ paste0("P:", round(stat$p.value, round_pval))
|
|
| 48 | +427 |
- #' \donttest{
+ ), |
|
| 49 | -+ | ||
| 428 | +2x |
- #' library(ggplot2)+ collapse = "\n" |
|
| 50 | +429 |
- #' library(grid)+ )) |
|
| 51 | +430 |
- #'+ } else {
|
|
| 52 | -+ | ||
| 431 | +! |
- #' p <- ggplot(mtcars) ++ stop("function not supported")
|
|
| 53 | +432 |
- #' aes(x = mpg, y = disp) ++ } |
|
| 54 | +433 |
- #' geom_point() ++ } else {
|
|
| 55 | -+ | ||
| 434 | +3x |
- #' facet_grid(gear ~ cyl)+ if ("method" %in% names(.f_args)) {
|
|
| 56 | -+ | ||
| 435 | +3x |
- #' p+ if (.f_args$method == "pearson") {
|
|
| 57 | -+ | ||
| 436 | +1x |
- #' xfacet_label <- "cylinders"+ return("cor:-")
|
|
| 58 | +437 |
- #' yfacet_label <- "gear"+ } |
|
| 59 | -+ | ||
| 438 | +2x |
- #' res <- add_facet_labels(p, xfacet_label, yfacet_label)+ if (.f_args$method == "kendall") {
|
|
| 60 | -+ | ||
| 439 | +1x |
- #' grid.newpage()+ return("tau:-")
|
|
| 61 | +440 |
- #' grid.draw(res)+ } |
|
| 62 | -+ | ||
| 441 | +1x |
- #'+ if (.f_args$method == "spearman") {
|
|
| 63 | -+ | ||
| 442 | +1x |
- #' grid.newpage()+ return("rho:-")
|
|
| 64 | +443 |
- #' grid.draw(add_facet_labels(p, xfacet_label = NULL, yfacet_label))+ } |
|
| 65 | +444 |
- #' grid.newpage()+ } |
|
| 66 | -+ | ||
| 445 | +! |
- #' grid.draw(add_facet_labels(p, xfacet_label, yfacet_label = NULL))+ return("-")
|
|
| 67 | +446 |
- #' grid.newpage()+ } |
|
| 68 | +447 |
- #' grid.draw(add_facet_labels(p, xfacet_label = NULL, yfacet_label = NULL))+ } |
| 69 | +1 |
- #' }+ #' Data Table Viewer Teal Module |
|
| 70 | +2 |
#' |
|
| 71 | +3 |
- add_facet_labels <- function(p, xfacet_label = NULL, yfacet_label = NULL) {
+ #' A data table viewer shows the data using a paginated table. |
|
| 72 | -! | +||
| 4 | +
- checkmate::assert_class(p, classes = "ggplot")+ #' specifically designed for use with `data.frames`. |
||
| 73 | -! | +||
| 5 | +
- checkmate::assert_character(xfacet_label, null.ok = TRUE, min.len = 1)+ #' @md |
||
| 74 | -! | +||
| 6 | +
- checkmate::assert_character(yfacet_label, null.ok = TRUE, min.len = 1)+ #' |
||
| 75 | -! | +||
| 7 | +
- if (is.null(xfacet_label) && is.null(yfacet_label)) {
+ #' @inheritParams teal::module |
||
| 76 | -! | +||
| 8 | +
- return(ggplotGrob(p))+ #' @inheritParams shared_params |
||
| 77 | +9 |
- }+ #' @param variables_selected (`list`) A named list of character vectors of the variables (i.e. columns) |
|
| 78 | -! | +||
| 10 | +
- grid::grid.grabExpr({
+ #' which should be initially shown for each dataset. Names of list elements should correspond to the names |
||
| 79 | -! | +||
| 11 | +
- g <- ggplotGrob(p)+ #' of the datasets available in the app. If no entry is specified for a dataset, the first six variables from that |
||
| 80 | +12 |
-
+ #' dataset will initially be shown. |
|
| 81 | +13 |
- # we are going to replace these, so we make sure they have nothing in them+ #' @param datasets_selected (`character`) A vector of datasets which should be |
|
| 82 | -! | +||
| 14 | +
- checkmate::assert_class(g$grobs[[grep("xlab-t", g$layout$name, fixed = TRUE)]], "zeroGrob")
+ #' shown and in what order. Names in the vector have to correspond with datasets names. |
||
| 83 | -! | +||
| 15 | +
- checkmate::assert_class(g$grobs[[grep("ylab-r", g$layout$name, fixed = TRUE)]], "zeroGrob")
+ #' If vector of length zero (default) then all datasets are shown. |
||
| 84 | +16 |
-
+ #' Note: Only datasets of the `data.frame` class are compatible; |
|
| 85 | -! | +||
| 17 | +
- xaxis_label_grob <- g$grobs[[grep("xlab-b", g$layout$name, fixed = TRUE)]]
+ #' using other types will cause an error. |
||
| 86 | -! | +||
| 18 | +
- xaxis_label_grob$children[[1]]$label <- paste(xfacet_label, collapse = " & ")+ #' @param dt_args (named `list`) Additional arguments to be passed to `DT::datatable` |
||
| 87 | -! | +||
| 19 | +
- yaxis_label_grob <- g$grobs[[grep("ylab-l", g$layout$name, fixed = TRUE)]]
+ #' (must not include `data` or `options`). |
||
| 88 | -! | +||
| 20 | +
- yaxis_label_grob$children[[1]]$label <- paste(yfacet_label, collapse = " & ")+ #' @param dt_options (named `list`) The `options` argument to `DT::datatable`. By default |
||
| 89 | -! | +||
| 21 | +
- yaxis_label_grob$children[[1]]$rot <- 270+ #' `list(searching = FALSE, pageLength = 30, lengthMenu = c(5, 15, 30, 100), scrollX = TRUE)` |
||
| 90 | +22 |
-
+ #' @param server_rendering (`logical`) should the data table be rendered server side |
|
| 91 | -! | +||
| 23 | +
- top_height <- if (is.null(xfacet_label)) 0 else grid::unit(2, "line")+ #' (see `server` argument of `DT::renderDataTable()`) |
||
| 92 | -! | +||
| 24 | +
- right_width <- if (is.null(yfacet_label)) 0 else grid::unit(2, "line")+ #' @details |
||
| 93 | +25 |
-
+ #' The `DT` package has an option `DT.TOJSON_ARGS` to show `Inf` and `NA` in data tables. If this is something |
|
| 94 | -! | +||
| 26 | +
- grid::grid.newpage()+ #' you require then set `options(DT.TOJSON_ARGS = list(na = "string"))` before running the module. |
||
| 95 | -! | +||
| 27 | +
- grid::pushViewport(grid::plotViewport(margins = c(0, 0, top_height, right_width), name = "ggplot"))+ #' Note though that sorting of numeric columns with `NA`/`Inf` will be lexicographic not numerical. |
||
| 96 | -! | +||
| 28 | +
- grid::grid.draw(g)+ #' @export |
||
| 97 | -! | +||
| 29 | +
- grid::upViewport(1)+ #' @examples |
||
| 98 | +30 |
-
+ #' |
|
| 99 | +31 |
- # draw x facet+ #' data <- teal_data() |
|
| 100 | -! | +||
| 32 | +
- if (!is.null(xfacet_label)) {
+ #' data <- within(data, {
|
||
| 101 | -! | +||
| 33 | +
- grid::pushViewport(grid::viewport(+ #' library(nestcolor) |
||
| 102 | -! | +||
| 34 | +
- x = 0, y = grid::unit(1, "npc") - top_height, width = grid::unit(1, "npc"),+ #' ADSL <- teal.modules.general::rADSL |
||
| 103 | -! | +||
| 35 | +
- height = top_height, just = c("left", "bottom"), name = "topxaxis"
+ #' }) |
||
| 104 | +36 |
- ))+ #' datanames <- c("ADSL")
|
|
| 105 | -! | +||
| 37 | +
- grid::grid.draw(xaxis_label_grob)+ #' datanames(data) <- datanames |
||
| 106 | -! | +||
| 38 | +
- grid::upViewport(1)+ #' join_keys(data) <- default_cdisc_join_keys[datanames] |
||
| 107 | +39 |
- }+ #' |
|
| 108 | +40 |
-
+ #' app <- teal::init( |
|
| 109 | +41 |
- # draw y facet+ #' data = data, |
|
| 110 | -! | +||
| 42 | +
- if (!is.null(yfacet_label)) {
+ #' modules = teal::modules( |
||
| 111 | -! | +||
| 43 | +
- grid::pushViewport(grid::viewport(+ #' teal.modules.general::tm_data_table( |
||
| 112 | -! | +||
| 44 | +
- x = grid::unit(1, "npc") - grid::unit(as.numeric(right_width) / 2, "line"), y = 0, width = right_width,+ #' variables_selected = list(ADSL = c("STUDYID", "USUBJID", "SUBJID", "SITEID", "AGE", "SEX")),
|
||
| 113 | -! | +||
| 45 | +
- height = grid::unit(1, "npc"), just = c("left", "bottom"), name = "rightyaxis"
+ #' dt_args = list(caption = "ADSL Table Caption") |
||
| 114 | +46 |
- ))+ #' ) |
|
| 115 | -! | +||
| 47 | +
- grid::grid.draw(yaxis_label_grob)+ #' ) |
||
| 116 | -! | +||
| 48 | +
- grid::upViewport(1)+ #' ) |
||
| 117 | +49 |
- }+ #' if (interactive()) {
|
|
| 118 | +50 |
- })+ #' shinyApp(app$ui, app$server) |
|
| 119 | +51 |
- }+ #' } |
|
| 120 | +52 |
-
+ tm_data_table <- function(label = "Data Table", |
|
| 121 | +53 |
- #' Call a function with a character vector for the \code{...} argument
+ variables_selected = list(), |
|
| 122 | +54 |
- #'+ datasets_selected = character(0), |
|
| 123 | +55 |
- #' @param fun (\code{character}) Name of a function where the \code{...} argument
+ dt_args = list(), |
|
| 124 | +56 |
- #' shall be replaced by values from \code{str_args}.
+ dt_options = list( |
|
| 125 | +57 |
- #' @param str_args (\code{character}) A character vector that the function shall
+ searching = FALSE, |
|
| 126 | +58 |
- #' be executed with+ pageLength = 30, |
|
| 127 | +59 |
- #'+ lengthMenu = c(5, 15, 30, 100), |
|
| 128 | +60 |
- #' @return: call (i.e. expression) of the function provided by \code{fun}
+ scrollX = TRUE |
|
| 129 | +61 |
- #' with arguments provided by \code{str_args}.
+ ), |
|
| 130 | +62 |
- #' @keywords internal+ server_rendering = FALSE, |
|
| 131 | +63 |
- #'+ pre_output = NULL, |
|
| 132 | +64 |
- #' @examples+ post_output = NULL) {
|
|
| 133 | -+ | ||
| 65 | +! |
- #' \dontrun{
+ logger::log_info("Initializing tm_data_table")
|
|
| 134 | -+ | ||
| 66 | +! |
- #' a <- 1+ checkmate::assert_string(label) |
|
| 135 | -+ | ||
| 67 | +! |
- #' b <- 2+ checkmate::assert_list(variables_selected, min.len = 0, types = "character", names = "named") |
|
| 136 | -+ | ||
| 68 | +! |
- #' call_fun_dots("sum", c("a", "b"))
+ if (length(variables_selected) > 0) {
+ |
+ |
| 69 | +! | +
+ lapply(seq_along(variables_selected), function(i) {
+ |
+ |
| 70 | +! | +
+ checkmate::assert_character(variables_selected[[i]], min.chars = 1, min.len = 1)+ |
+ |
| 71 | +! | +
+ if (!is.null(names(variables_selected[[i]]))) {
+ |
+ |
| 72 | +! | +
+ checkmate::assert_names(names(variables_selected[[i]])) |
|
| 137 | +73 |
- #' eval(call_fun_dots("sum", c("a", "b")))
+ } |
|
| 138 | +74 |
- #' }+ }) |
|
| 139 | +75 |
- call_fun_dots <- function(fun, str_args) {
+ } |
|
| 140 | +76 | ! |
- do.call("call", c(list(fun), lapply(str_args, as.name)), quote = TRUE)
+ checkmate::assert_character(datasets_selected, min.len = 0, min.chars = 1)+ |
+
| 77 | +! | +
+ checkmate::assert_list(dt_options, names = "named")+ |
+ |
| 78 | +! | +
+ checkmate::assert(+ |
+ |
| 79 | +! | +
+ checkmate::check_list(dt_args, len = 0),+ |
+ |
| 80 | +! | +
+ checkmate::check_subset(names(dt_args), choices = names(formals(DT::datatable))) |
|
| 141 | +81 |
- }+ ) |
|
| 142 | +82 | ||
| 143 | -+ | ||
| 83 | +! |
- #' Get variable name with label+ checkmate::assert_flag(server_rendering) |
|
| 144 | +84 |
- #'+ |
|
| 145 | -+ | ||
| 85 | +! |
- #' @param var_names (\code{character}) Name of variable to extract labels from.
+ module( |
|
| 146 | -+ | ||
| 86 | +! |
- #' @param dataset (\code{dataset}) Name of analysis dataset.
+ label, |
|
| 147 | -+ | ||
| 87 | +! |
- #' @param prefix (\code{character}) String to paste to the beginning of the
+ server = srv_page_data_table, |
|
| 148 | -+ | ||
| 88 | +! |
- #' variable name with label.+ ui = ui_page_data_table, |
|
| 149 | -+ | ||
| 89 | +! |
- #' @param suffix (\code{character}) String to paste to the end of the variable
+ datanames = if (length(datasets_selected) == 0) "all" else datasets_selected, |
|
| 150 | -+ | ||
| 90 | +! |
- #' name with label.+ server_args = list( |
|
| 151 | -+ | ||
| 91 | +! |
- #' @param wrap_width (\code{numeric}) Number of characters to wrap original
+ variables_selected = variables_selected, |
|
| 152 | -+ | ||
| 92 | +! |
- #' label to. Defaults to 80.+ datasets_selected = datasets_selected, |
|
| 153 | -+ | ||
| 93 | +! |
- #'+ dt_args = dt_args, |
|
| 154 | -+ | ||
| 94 | +! |
- #' @return (\code{character}) String with variable name and label.
+ dt_options = dt_options, |
|
| 155 | -+ | ||
| 95 | +! |
- #' @keywords internal+ server_rendering = server_rendering |
|
| 156 | +96 |
- #'+ ), |
|
| 157 | -+ | ||
| 97 | +! |
- #' @examples+ ui_args = list(+ |
+ |
| 98 | +! | +
+ pre_output = pre_output,+ |
+ |
| 99 | +! | +
+ post_output = post_output |
|
| 158 | +100 |
- #' \dontrun{
+ ) |
|
| 159 | +101 |
- #' ADSL <- teal.modules.general::rADSL+ ) |
|
| 160 | +102 |
- #'+ } |
|
| 161 | +103 |
- #' varname_w_label("AGE", ADSL)
+
|
|
| 162 | +104 |
- #' }+ |
|
| 163 | +105 |
- varname_w_label <- function(var_names,+ # ui page module |
|
| 164 | +106 |
- dataset,+ ui_page_data_table <- function(id, |
|
| 165 | +107 |
- wrap_width = 80,+ pre_output = NULL, |
|
| 166 | +108 |
- prefix = NULL,+ post_output = NULL) {
+ |
+ |
| 109 | +! | +
+ ns <- NS(id) |
|
| 167 | +110 |
- suffix = NULL) {
+
+ |
+ |
| 111 | +! | +
+ shiny::tagList(+ |
+ |
| 112 | +! | +
+ include_css_files("custom"),
+ |
+ |
| 113 | +! | +
+ teal.widgets::standard_layout(+ |
+ |
| 114 | +! | +
+ output = teal.widgets::white_small_well(+ |
+ |
| 115 | +! | +
+ fluidRow(+ |
+ |
| 116 | +! | +
+ column( |
|
| 168 | +117 | ! |
- add_label <- function(var_names) {
+ width = 12, |
| 169 | +118 | ! |
- label <- vapply(+ checkboxInput( |
| 170 | +119 | ! |
- dataset[var_names], function(x) {
+ ns("if_distinct"),
|
| 171 | +120 | ! |
- attr_label <- attr(x, "label")+ "Show only distinct rows:", |
| 172 | +121 | ! |
- `if`(is.null(attr_label), "", attr_label)+ value = FALSE |
| 173 | +122 |
- },- |
- |
| 174 | -! | -
- character(1)+ ) |
|
| 175 | +123 |
- )+ ) |
|
| 176 | +124 |
-
+ ), |
|
| 177 | +125 | ! |
- if (length(label) == 1 && !is.na(label) && !identical(label, "")) {
+ fluidRow( |
| 178 | +126 | ! |
- paste0(prefix, label, " [", var_names, "]", suffix)+ class = "mb-8", |
| 179 | -+ | ||
| 127 | +! |
- } else {
+ column( |
|
| 180 | +128 | ! |
- var_names+ width = 12, |
| 181 | -+ | ||
| 129 | +! |
- }+ uiOutput(ns("dataset_table"))
|
|
| 182 | +130 |
- }+ ) |
|
| 183 | +131 | - - | -|
| 184 | -! | -
- if (length(var_names) < 1) {
- |
- |
| 185 | -! | -
- NULL+ ) |
|
| 186 | -! | +||
| 132 | +
- } else if (length(var_names) == 1) {
+ ), |
||
| 187 | +133 | ! |
- stringr::str_wrap(add_label(var_names), width = wrap_width)+ pre_output = pre_output, |
| 188 | +134 | ! |
- } else if (length(var_names) > 1) {
+ post_output = post_output |
| 189 | -! | +||
| 135 | +
- stringr::str_wrap(vapply(var_names, add_label, character(1)), width = wrap_width)+ ) |
||
| 190 | +136 |
- }+ ) |
|
| 191 | +137 |
} |
|
| 192 | +138 | ||
| 193 | +139 |
- #' Extract html id for `data_extract_ui`+ |
|
| 194 | +140 |
- #' @description The `data_extract_ui` is located under extended html id.+ # server page module |
|
| 195 | +141 |
- #' We could not use \code{ns("original id")} for reference, as it is extended with specific suffixes.
+ srv_page_data_table <- function(id, |
|
| 196 | +142 |
- #' @param varname character original html id.+ data, |
|
| 197 | +143 |
- #' This will be mostly retrieved with \code{ns("original id")} in `ui` or
+ datasets_selected, |
|
| 198 | +144 |
- #' \code{session$ns("original id")} in server function.
+ variables_selected, |
|
| 199 | +145 |
- #' @param dataname character \code{dataname} from data_extract input.
+ dt_args, |
|
| 200 | +146 |
- #' This might be retrieved like \code{teal.transform::data_extract_spec(...)[[1]]$dataname}.
+ dt_options, |
|
| 201 | +147 |
- #' @param filter logical if the connected \code{extract_data_spec} is used with \code{filter} option.
+ server_rendering) {
|
|
| 202 | -+ | ||
| 148 | +! |
- #' @keywords internal+ checkmate::assert_class(data, "reactive") |
|
| 203 | -+ | ||
| 149 | +! |
- extract_input <- function(varname, dataname, filter = FALSE) {
+ checkmate::assert_class(isolate(data()), "teal_data") |
|
| 204 | +150 | ! |
- if (filter) {
+ moduleServer(id, function(input, output, session) {
|
| 205 | +151 | ! |
- paste0(varname, "-dataset_", dataname, "_singleextract-filter1-vals")+ if_filtered <- reactive(as.logical(input$if_filtered))+ |
+
| 152 | +! | +
+ if_distinct <- reactive(as.logical(input$if_distinct)) |
|
| 206 | +153 |
- } else {
+
|
|
| 207 | +154 | ! |
- paste0(varname, "-dataset_", dataname, "_singleextract-select")+ datanames <- isolate(teal.data::datanames(data())) |
| 208 | -+ | ||
| 155 | +! |
- }+ datanames <- Filter(function(name) {
|
|
| 209 | -+ | ||
| 156 | +! |
- }+ is.data.frame(isolate(data())[[name]])+ |
+ |
| 157 | +! | +
+ }, datanames) |
|
| 210 | +158 | ||
| 211 | -+ | ||
| 159 | +! |
- # see vignette("ggplot2-specs", package="ggplot2")
+ if (!identical(datasets_selected, character(0))) {
|
|
| 212 | -+ | ||
| 160 | +! |
- shape_names <- c(+ checkmate::assert_subset(datasets_selected, datanames) |
|
| 213 | -+ | ||
| 161 | +! |
- "circle", paste("circle", c("open", "filled", "cross", "plus", "small")), "bullet",
+ datanames <- datasets_selected |
|
| 214 | +162 |
- "square", paste("square", c("open", "filled", "cross", "plus", "triangle")),
+ } |
|
| 215 | +163 |
- "diamond", paste("diamond", c("open", "filled", "plus")),
+
|
|
| 216 | -+ | ||
| 164 | +! |
- "triangle", paste("triangle", c("open", "filled", "square")),
+ output$dataset_table <- renderUI({
|
|
| 217 | -+ | ||
| 165 | +! |
- paste("triangle down", c("open", "filled")),
+ do.call( |
|
| 218 | -+ | ||
| 166 | +! |
- "plus", "cross", "asterisk"+ tabsetPanel, |
|
| 219 | -+ | ||
| 167 | +! |
- )+ lapply( |
|
| 220 | -+ | ||
| 168 | +! |
-
+ datanames, |
|
| 221 | -+ | ||
| 169 | +! |
- #' Get icons to represent variable types in dataset+ function(x) {
|
|
| 222 | -+ | ||
| 170 | +! |
- #'+ dataset <- isolate(data()[[x]]) |
|
| 223 | -+ | ||
| 171 | +! |
- #' @param var_type (`character`)\cr+ choices <- names(dataset) |
|
| 224 | -+ | ||
| 172 | +! |
- #' of R internal types (classes).+ labels <- vapply( |
|
| 225 | -+ | ||
| 173 | +! |
- #'+ dataset, |
|
| 226 | -+ | ||
| 174 | +! |
- #' @return (`character`)\cr+ function(x) ifelse(is.null(attr(x, "label")), "", attr(x, "label")), |
|
| 227 | -+ | ||
| 175 | +! |
- #' vector of HTML icons corresponding to data type in each column.+ character(1) |
|
| 228 | +176 |
- #' @keywords internal+ ) |
|
| 229 | -+ | ||
| 177 | +! |
- #'+ names(choices) <- ifelse( |
|
| 230 | -+ | ||
| 178 | +! |
- #' @examples+ is.na(labels) | labels == "", |
|
| 231 | -+ | ||
| 179 | +! |
- #' teal.modules.general:::variable_type_icons(c(+ choices, |
|
| 232 | -+ | ||
| 180 | +! |
- #' "integer", "numeric", "logical", "Date", "POSIXct", "POSIXlt",+ paste(choices, labels, sep = ": ") |
|
| 233 | +181 |
- #' "factor", "character", "unknown", ""+ ) |
|
| 234 | -+ | ||
| 182 | +! |
- #' ))+ variables_selected <- if (!is.null(variables_selected[[x]])) {
+ |
+ |
| 183 | +! | +
+ variables_selected[[x]] |
|
| 235 | +184 |
- variable_type_icons <- function(var_type) {
+ } else {
|
|
| 236 | +185 | ! |
- checkmate::assert_character(var_type, any.missing = FALSE)+ utils::head(choices) |
| 237 | +186 |
-
+ } |
|
| 238 | +187 | ! |
- class_to_icon <- list(+ tabPanel( |
| 239 | +188 | ! |
- numeric = "arrow-up-1-9",+ title = x, |
| 240 | +189 | ! |
- integer = "arrow-up-1-9",+ column( |
| 241 | +190 | ! |
- logical = "pause",+ width = 12, |
| 242 | +191 | ! |
- Date = "calendar",+ div( |
| 243 | +192 | ! |
- POSIXct = "calendar",+ class = "mt-4", |
| 244 | +193 | ! |
- POSIXlt = "calendar",+ ui_data_table( |
| 245 | +194 | ! |
- factor = "chart-bar",+ id = session$ns(x), |
| 246 | +195 | ! |
- character = "keyboard",+ choices = choices, |
| 247 | +196 | ! |
- primary_key = "key",+ selected = variables_selected |
| 248 | -! | +||
| 197 | ++ |
+ )+ |
+ |
| 198 | ++ |
+ )+ |
+ |
| 199 | ++ |
+ )+ |
+ |
| 200 | ++ |
+ )+ |
+ |
| 201 | ++ |
+ }+ |
+ |
| 202 | ++ |
+ )+ |
+ |
| 203 | ++ |
+ )+ |
+ |
| 204 | +
- unknown = "circle-question"+ }) |
||
| 249 | +205 |
- )+ |
|
| 250 | +206 | ! |
- class_to_icon <- lapply(class_to_icon, function(icon_name) toString(icon(icon_name, lib = "font-awesome")))+ lapply( |
| 251 | -+ | ||
| 207 | +! |
-
+ datanames, |
|
| 252 | +208 | ! |
- res <- unname(vapply(+ function(x) {
|
| 253 | +209 | ! |
- var_type,+ srv_data_table( |
| 254 | +210 | ! |
- FUN.VALUE = character(1),+ id = x, |
| 255 | +211 | ! |
- FUN = function(class) {
+ data = data, |
| 256 | +212 | ! |
- if (class == "") {
+ dataname = x, |
| 257 | +213 | ! |
- class+ if_filtered = if_filtered, |
| 258 | +214 | ! |
- } else if (is.null(class_to_icon[[class]])) {
+ if_distinct = if_distinct, |
| 259 | +215 | ! |
- class_to_icon[["unknown"]]+ dt_args = dt_args, |
| 260 | -+ | ||
| 216 | +! |
- } else {
+ dt_options = dt_options, |
|
| 261 | +217 | ! |
- class_to_icon[[class]]+ server_rendering = server_rendering |
| 262 | +218 |
- }+ ) |
|
| 263 | +219 |
- }+ } |
|
| 264 | +220 |
- ))+ ) |
|
| 265 | +221 | - - | -|
| 266 | -! | -
- return(res)+ }) |
|
| 267 | +222 |
} |
|
| 268 | +223 | ||
| 269 | +224 |
- #' Include `CSS` files from `/inst/css/` package directory to application header+ ui_data_table <- function(id, |
|
| 270 | +225 |
- #'+ choices, |
|
| 271 | +226 |
- #' `system.file` should not be used to access files in other packages, it does+ selected) {
|
|
| 272 | -+ | ||
| 227 | +! |
- #' not work with `devtools`. Therefore, we redefine this method in each package+ ns <- NS(id) |
|
| 273 | +228 |
- #' as needed. Thus, we do not export this method+ |
|
| 274 | -+ | ||
| 229 | +! |
- #'+ if (!is.null(selected)) {
|
|
| 275 | -+ | ||
| 230 | +! |
- #' @param pattern (`character`) pattern of files to be included+ all_choices <- choices |
|
| 276 | -+ | ||
| 231 | +! |
- #'+ choices <- c(selected, setdiff(choices, selected)) |
|
| 277 | -+ | ||
| 232 | +! |
- #' @return HTML code that includes `CSS` files+ names(choices) <- names(all_choices)[match(choices, all_choices)] |
|
| 278 | +233 |
- #' @keywords internal+ } |
|
| 279 | +234 |
- include_css_files <- function(pattern = "*") {
+
|
|
| 280 | +235 | ! |
- css_files <- list.files(+ tagList( |
| 281 | +236 | ! |
- system.file("css", package = "teal.modules.general", mustWork = TRUE),
+ teal.widgets::get_dt_rows(ns("data_table"), ns("dt_rows")),
|
| 282 | +237 | ! |
- pattern = pattern, full.names = TRUE- |
-
| 283 | -- |
- )+ fluidRow( |
|
| 284 | +238 | ! |
- if (length(css_files) == 0) {
+ teal.widgets::optionalSelectInput( |
| 285 | +239 | ! |
- return(NULL)- |
-
| 286 | -- |
- }+ ns("variables"),
|
|
| 287 | +240 | ! |
- return(shiny::singleton(shiny::tags$head(lapply(css_files, shiny::includeCSS))))- |
-
| 288 | -- |
- }- |
- |
| 289 | -- |
-
+ "Select variables:", |
|
| 290 | -+ | ||
| 241 | +! |
-
+ choices = choices, |
|
| 291 | -+ | ||
| 242 | +! |
- #' Get Label Attributes of Variables in a \code{data.frame}
+ selected = selected, |
|
| 292 | -+ | ||
| 243 | +! |
- #'+ multiple = TRUE, |
|
| 293 | -+ | ||
| 244 | +! |
- #' Variable labels can be stored as a \code{label} attribute for each variable.
+ width = "100%" |
|
| 294 | +245 |
- #' This functions returns a named character vector with the variable labels+ ) |
|
| 295 | +246 |
- #' (empty sting if not specified)+ ), |
|
| 296 | -+ | ||
| 247 | +! |
- #'+ fluidRow( |
|
| 297 | -+ | ||
| 248 | +! |
- #' @param x a \code{data.frame} object
+ DT::dataTableOutput(ns("data_table"), width = "100%")
|
|
| 298 | +249 |
- #' @param fill boolean in case the \code{label} attribute does not exist if
+ ) |
|
| 299 | +250 |
- #' \code{TRUE} the variable names is returned, otherwise \code{NA}
+ ) |
|
| 300 | +251 |
- #'+ } |
|
| 301 | +252 |
- #' @return a named character vector with the variable labels, the names+ |
|
| 302 | +253 |
- #' correspond to the variable names+ srv_data_table <- function(id, |
|
| 303 | +254 |
- #'+ data, |
|
| 304 | +255 |
- #' @note the `formatters` package is the source of the function.+ dataname, |
|
| 305 | +256 |
- #'+ if_filtered, |
|
| 306 | +257 |
- #' @keywords internal+ if_distinct, |
|
| 307 | +258 |
- var_labels <- function(x, fill = FALSE) {
- |
- |
| 308 | -! | -
- stopifnot(is.data.frame(x))- |
- |
| 309 | -! | -
- if (NCOL(x) == 0) {
- |
- |
| 310 | -! | -
- return(character())+ dt_args, |
|
| 311 | +259 |
- }+ dt_options, |
|
| 312 | +260 |
-
+ server_rendering) {
|
|
| 313 | +261 | ! |
- y <- Map(function(col, colname) {
+ moduleServer(id, function(input, output, session) {
|
| 314 | +262 | ! |
- label <- attr(col, "label")- |
-
| 315 | -- |
-
+ iv <- shinyvalidate::InputValidator$new() |
|
| 316 | +263 | ! |
- if (is.null(label)) {
+ iv$add_rule("variables", shinyvalidate::sv_required("Please select valid variable names"))
|
| 317 | +264 | ! |
- if (fill) {
+ iv$add_rule("variables", shinyvalidate::sv_in_set(
|
| 318 | +265 | ! |
- colname+ set = names(data()[[dataname]]), message_fmt = "Not all selected variables exist in the data" |
| 319 | +266 |
- } else {
+ )) |
|
| 320 | +267 | ! |
- NA_character_- |
-
| 321 | -- |
- }+ iv$enable() |
|
| 322 | +268 |
- } else {
+
|
|
| 323 | +269 | ! |
- if (!is.character(label) && !(length(label) == 1)) {
+ output$data_table <- DT::renderDataTable(server = server_rendering, {
|
| 324 | +270 | ! |
- stop("label for variable ", colname, "is not a character string")
+ teal::validate_inputs(iv) |
| 325 | +271 |
- }+ |
|
| 326 | +272 | ! |
- as.vector(label)- |
-
| 327 | -- |
- }+ df <- data()[[dataname]] |
|
| 328 | +273 | ! |
- }, x, colnames(x))+ variables <- input$variables |
| 329 | +274 | ||
| 330 | +275 | ! |
- labels <- unlist(y, recursive = FALSE, use.names = TRUE)+ teal::validate_has_data(df, min_nrow = 1L, msg = paste("data", dataname, "is empty"))
|
| 331 | +276 | ||
| 332 | +277 | ! |
- if (!is.character(labels)) {
+ dataframe_selected <- if (if_distinct()) {
|
| 333 | +278 | ! |
- stop("label extraction failed")
- |
-
| 334 | -- |
- }+ dplyr::count(df, dplyr::across(tidyselect::all_of(variables))) |
|
| 335 | +279 |
-
+ } else {
|
|
| 336 | +280 | ! |
- labels+ df[variables] |
| 337 | +281 |
- }+ } |
|
| 338 | +282 | ||
| 339 | -- |
- #' Get a string with java-script code checking if the specific tab is clicked- |
- |
| 340 | -+ | ||
| 283 | +! |
- #' @description will be the input for `shiny::conditionalPanel()`+ dt_args$options <- dt_options |
|
| 341 | -+ | ||
| 284 | +! |
- #' @param id `character(1)` the id of the tab panel with tabs.+ if (!is.null(input$dt_rows)) {
|
|
| 342 | -+ | ||
| 285 | +! |
- #' @param name `character(1)` the name of the tab.+ dt_args$options$pageLength <- input$dt_rows |
|
| 343 | +286 |
- #' @keywords internal+ } |
|
| 344 | -+ | ||
| 287 | +! |
- is_tab_active_js <- function(id, name) {
+ dt_args$data <- dataframe_selected |
|
| 345 | +288 |
- # supporting the bs3 and higher version at the same time- |
- |
| 346 | -! | -
- sprintf(+ |
|
| 347 | +289 | ! |
- "$(\"#%1$s > li.active\").text().trim() == '%2$s' || $(\"#%1$s > li a.active\").text().trim() == '%2$s'",+ do.call(DT::datatable, dt_args) |
| 348 | -! | +||
| 290 | +
- id, name+ }) |
||
| 349 | +291 |
- )+ }) |
|
| 350 | +292 |
} |